indirect-0.31/0000750000175000017500000000000012212131272012214 5ustar vincevinceindirect-0.31/lib/0000750000175000017500000000000012212131272012762 5ustar vincevinceindirect-0.31/lib/indirect.pm0000644000175000017500000002227112212131007015126 0ustar vincevincepackage indirect; use 5.008_001; use strict; use warnings; =head1 NAME indirect - Lexically warn about using the indirect method call syntax. =head1 VERSION Version 0.31 =cut our $VERSION; BEGIN { $VERSION = '0.31'; } =head1 SYNOPSIS In a script : no indirect; # lexically enables the pragma my $x = new Apple 1, 2, 3; # warns { use indirect; # lexically disables the pragma my $y = new Pear; # legit, does not warn { # lexically specify an hook called for each indirect construct no indirect hook => sub { die "You really wanted $_[0]\->$_[1] at $_[2]:$_[3]" }; my $z = new Pineapple 'fresh'; # croaks 'You really wanted...' } } try { ... }; # warns if try() hasn't been declared in this package no indirect 'fatal'; # or ':fatal', 'FATAL', ':Fatal' ... if (defied $foo) { ... } # croaks, note the typo Global uses : # Globally enable the pragma from the command-line perl -M-indirect=global -e 'my $x = new Banana;' # warns # Globally enforce the pragma each time perl is executed export PERL5OPT="-M-indirect=global,fatal" perl -e 'my $y = new Coconut;' # croaks =head1 DESCRIPTION When enabled, this pragma warns about indirect method calls that are present in your code. The indirect syntax is now considered harmful, since its parsing has many quirks and its use is error prone : when the subroutine C has not been declared in the current package, C actually compiles to C<< $x->foo >>, and C<< foo { key => 1 } >> to C<< 'key'->foo(1) >>. In L, Matt S. Trout gives an example of an undesirable indirect method call on a block that can cause a particularly bewildering error. This pragma currently does not warn for core functions (C, C, C or C). This may change in the future, or may be added as optional features that would be enabled by passing options to C. This module is B a source filter. =cut BEGIN { if ($ENV{PERL_INDIRECT_PM_DISABLE}) { *_tag = sub ($) { 1 }; *I_THREADSAFE = sub () { 1 }; *I_FORKSAFE = sub () { 1 }; } else { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); } } =head1 METHODS =head2 C no indirect; no indirect 'fatal'; no indirect hook => sub { my ($obj, $name, $file, $line) = @_; ... }; no indirect 'global'; no indirect 'global, 'fatal'; no indirect 'global', hook => sub { ... }; Magically called when C is encountered. Turns the module on. The policy to apply depends on what is first found in C<@opts> : =over 4 =item * If it is a string that matches C, the compilation will croak when the first indirect method call is found. This option is mutually exclusive with the C<'hook'> option. =item * If the key/value pair C<< hook => $hook >> comes first, C<$hook> will be called for each error with a string representation of the object as C<$_[0]>, the method name as C<$_[1]>, the current file as C<$_[2]> and the line number as C<$_[3]>. If and only if the object is actually a block, C<$_[0]> is assured to start by C<'{'>. This option is mutually exclusive with the C<'fatal'> option. =item * If none of C and C are specified, a warning will be emitted for each indirect method call. =item * If C<@opts> contains a string that matches C, the pragma will be globally enabled for B code compiled after the current C statement, except for code that is in the lexical scope of C. This option may come indifferently before or after the C or C options, in the case they are also passed to L. The global policy applied is the one resulting of the C or C options, thus defaults to a warning when none of those are specified : no indirect 'global'; # warn for any indirect call no indirect qw; # die on any indirect call no indirect 'global', hook => \&hook # custom global action Note that if another policy is installed by a C statement further in the code, it will overrule the global policy : no indirect 'global'; # warn globally { no indirect 'fatal'; # throw exceptions for this lexical scope ... require Some::Module; # the global policy will apply for the # compilation phase of this module } =back =cut sub _no_hook_and_fatal { require Carp; Carp::croak("The 'fatal' and 'hook' options are mutually exclusive"); } sub unimport { shift; my ($global, $fatal, $hook); while (@_) { my $arg = shift; if ($arg eq 'hook') { _no_hook_and_fatal() if $fatal; $hook = shift; } elsif ($arg =~ /^:?fatal$/i) { _no_hook_and_fatal() if defined $hook; $fatal = 1; } elsif ($arg =~ /^:?global$/i) { $global = 1; } } unless (defined $hook) { $hook = $fatal ? sub { die msg(@_) } : sub { warn msg(@_) }; } $^H |= 0x00020000; if ($global) { delete $^H{+(__PACKAGE__)}; _global($hook); } else { $^H{+(__PACKAGE__)} = _tag($hook); } return; } =head2 C use indirect; Magically called at each C. Turns the module off. As explained in L's description, an C statement will lexically override a global policy previously installed by C (if there's one). =cut sub import { $^H |= 0x00020000; $^H{+(__PACKAGE__)} = _tag(undef); return; } =head1 FUNCTIONS =head2 C my $msg = msg($object, $method, $file, $line); Returns the default error message that C generates when an indirect method call is reported. =cut sub msg { my $obj = $_[0]; join ' ', "Indirect call of method \"$_[1]\" on", ($obj =~ /^\s*\{/ ? "a block" : "object \"$obj\""), "at $_[2] line $_[3].\n"; }; =head1 CONSTANTS =head2 C True iff the module could have been built with thread-safety features enabled. =head2 C True iff this module could have been built with fork-safety features enabled. This will always be true except on Windows where it's false for perl 5.10.0 and below . =head1 DIAGNOSTICS =head2 C The default warning/exception message thrown when an indirect method call on an object is found. =head2 C The default warning/exception message thrown when an indirect method call on a block is found. =head1 ENVIRONMENT =head2 C If this environment variable is set to true when the pragma is used for the first time, the XS code won't be loaded and, although the C<'indirect'> lexical hint will be set to true in the scope of use, the pragma itself won't do anything. In this case, the pragma will always be considered to be thread-safe, and as such L will be true. This is useful for disabling C in production environments. Note that clearing this variable after C was loaded has no effect. If you want to re-enable the pragma later, you also need to reload it by deleting the C<'indirect.pm'> entry from C<%INC>. =head1 CAVEATS The implementation was tweaked to work around several limitations of vanilla C pragmas : it's thread safe, and does not suffer from a C bug that causes all pragmas to propagate into Cd scopes. Before C 5.12, C (no semicolon) at the end of a file is not seen as an indirect method call, although it is as soon as there is another token before the end (as in C or C). If you use C 5.12 or greater, those constructs are correctly reported. With 5.8 perls, the pragma does not propagate into C. This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. The search for indirect method calls happens before constant folding. Hence C will be caught. =head1 DEPENDENCIES L 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 (standard since perl 5), L (since perl 5.6.0). =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc indirect Tests code coverage report is available at L. =head1 ACKNOWLEDGEMENTS Bram, for motivation and advices. Andrew Main and Florian Ragwitz, for testing on real-life code and reporting issues. =head1 COPYRIGHT & LICENSE Copyright 2008,2009,2010,2011,2012,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. =cut 1; # End of indirect indirect-0.31/t/0000750000175000017500000000000012212131272012457 5ustar vincevinceindirect-0.31/t/12-env.t0000644000175000017500000000072011610665342013673 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 3; { local $ENV{PERL_INDIRECT_PM_DISABLE} = 1; my $err = 0; my $res = eval <<' TEST_ENV_VARIABLE'; return 1; no indirect hook => sub { ++$err }; my $x = new Flurbz; TEST_ENV_VARIABLE is $@, '', 'PERL_INDIRECT_PM_DISABLE test doesn\'t croak'; is $res, 1, 'PERL_INDIRECT_PM_DISABLE test returns the correct value'; is $err, 0, 'PERL_INDIRECT_PM_DISABLE test didn\'t generate any error'; } indirect-0.31/t/41-threads-teardown.t0000644000175000017500000000171512207502502016354 0ustar vincevince#!perl use strict; use warnings; use lib 't/lib'; use indirect::TestThreads; use Test::Leaner tests => 1; sub run_perl { my $code = shift; my ($SystemRoot, $PATH) = @ENV{qw}; local %ENV; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code; } SKIP: { skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002; my $status = run_perl <<' RUN'; my ($code, @expected); BEGIN { $code = 2; @expected = qw; } sub cb { --$code if $_[0] eq shift(@expected) || q{DUMMY} } use threads; $code = threads->create(sub { eval q{return; no indirect hook => \&cb; new X;}; return $code; })->join; eval q{new Y;}; eval q{return; no indirect hook => \&cb; new Z;}; exit $code; RUN is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault'; } indirect-0.31/t/32-global.t0000644000175000017500000000625111650654236014356 0ustar vincevince#!perl use strict; use warnings; my $tests; BEGIN { $tests = 9 } use Test::More tests => (1 + $tests + 1) + 3 + 5 + 2 + 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } use lib 't/lib'; my %wrong = map { $_ => 1 } 2, 3, 5, 6, 7, 9; sub expect { my ($pkg, $file, $prefix) = @_; $file = defined $file ? quotemeta $file : '\(eval \d+\)'; $prefix = defined $prefix ? quotemeta $prefix : 'warn:'; qr/^${prefix}Indirect call of method "new" on object "$pkg" at $file line \d+/; } { my $code = do { local $/; }; my (%res, $num, @left); { local $SIG{__WARN__} = sub { ++$num; my $w = join '', 'warn:', @_; if ($w =~ /"P(\d+)"/ and not exists $res{$1}) { $res{$1} = $w; } else { push @left, "[$num] $w"; } }; eval "return; $code"; } is $@, '', 'DATA compiled fine'; for (1 .. $tests) { my $w = $res{$_}; if ($wrong{$_}) { like $w, expect("P$_"), "$_ should warn"; } else { is $w, undef, "$_ shouldn't warn"; } } is @left, 0, 'nothing left'; diag "Extraneous warnings:\n", @left if @left; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect "global" }; BEGIN { eval q[return; new XYZ] }'; } is $@, '', 'eval test did not croak prematurely'; is @w, 1, 'eval test threw one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('XYZ'), 'eval test threw the correct warning'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect "global" }; use indirect::TestRequiredGlobal'; } is $@, '', 'require test did not croak prematurely'; is @w, 3, 'require test threw three warnings'; diag join "\n", 'All warnings:', @w if @w > 3; like $w[0], expect('ABC', 't/lib/indirect/TestRequiredGlobal.pm'), 'require test first warning is correct'; like $w[1], expect('DEF'), 'require test second warning is correct'; like $w[2], expect('GHI'), 'require test third warning is correct'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect qw }; new MNO'; } like $@, expect('MNO', undef, ''), 'fatal test throw the correct exception'; is @w, 0, 'fatal test did not throw any warning'; diag join "\n", 'All warnings:', @w if @w; } { my @w; my @h; my $hook = sub { push @h, join '', 'hook:', indirect::msg(@_) }; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; { no indirect hook => $hook, "global" }; new PQR'; } is $@, '', 'hook test did not croak prematurely'; is @w, 0, 'hook test did not throw any warning'; diag join "\n", 'All warnings:', @w if @w; is @h, 1, 'hook test hooked up three violations'; diag join "\n", 'All captured violations:', @h if @h > 1; like $h[0], expect('PQR', undef, 'hook:'), 'hook test captured the correct error'; } __DATA__ my $a = new P1; { no indirect 'global'; my $b = new P2; { my $c = new P3; } { use indirect; my $d = new P4; } my $e = new P5; } my $f = new P6; no indirect; my $g = new P7; use indirect; my $h = new P8; { no indirect; eval { my $i = new P9 }; } indirect-0.31/t/40-threads.t0000644000175000017500000000310011657265606014543 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use indirect::TestThreads; use Test::Leaner; sub expect { my ($pkg) = @_; qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/; } { no indirect; sub try { my $tid = threads->tid(); for (1 .. 2) { { my $class = "Coconut$tid"; my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval 'die "the code compiled but it shouldn\'t have\n"; no indirect ":fatal"; my $x = new ' . $class . ' 1, 2;'; } like $@ || '', expect($class), "\"no indirect\" in eval in thread $tid died as expected"; is_deeply \@warns, [ ], "\"no indirect\" in eval in thread $tid didn't warn"; } SKIP: { skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3 unless "$]" >= 5.010; my $class = "Pineapple$tid"; my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval 'return; my $y = new ' . $class . ' 1, 2;'; } is $@, '', "\"no indirect\" propagated into eval in thread $tid didn't croak"; my $first = shift @warns; like $first || '', expect($class), "\"no indirect\" propagated into eval in thread $tid warned once"; is_deeply \@warns, [ ], "\"no indirect\" propagated into eval in thread $tid warned just once"; } } } } my @threads = map spawn(\&try), 1 .. 10; $_->join for @threads; pass 'done'; done_testing(scalar(@threads) * 2 * (2 + 3) + 1); indirect-0.31/t/lib/0000750000175000017500000000000012212131272013225 5ustar vincevinceindirect-0.31/t/lib/indirect/0000750000175000017500000000000012212131272015026 5ustar vincevinceindirect-0.31/t/lib/indirect/Test3.pm0000644000175000017500000000011712144733277016413 0ustar vincevinceno indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[new $x]} }; } 1; indirect-0.31/t/lib/indirect/TestRequired6.pm0000644000175000017500000000026311610665342020113 0ustar vincevincepackage indirect::TestRequired6; sub new { bless {} } sub bar { my $foo = new indirect::TestRequired6; } sub baz { eval q{my $foo = new indirect::TestRequired6}; } 1; indirect-0.31/t/lib/indirect/TestRequiredGlobal.pm0000644000175000017500000000015311650652055021145 0ustar vincevincepackage indirect::TestRequiredGlobal; sub hurp { new ABC } BEGIN { eval 'new DEF' } eval 'new GHI'; 1; indirect-0.31/t/lib/indirect/TestRequired1.pm0000644000175000017500000000015011610665342020101 0ustar vincevincepackage indirect::TestRequired1; BEGIN { require strict; } import strict; eval 'import strict;'; 1; indirect-0.31/t/lib/indirect/TestThreads.pm0000644000175000017500000000211412207502502017623 0ustar vincevincepackage indirect::TestThreads; use strict; use warnings; use Config qw<%Config>; use VPIT::TestHelpers; sub import { shift; require indirect; skip_all 'This indirect isn\'t thread safe' unless indirect::I_THREADSAFE(); my $force = $ENV{PERL_INDIRECT_TEST_THREADS} ? 1 : !1; 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.013_004; load_or_skip_all('threads', $force ? '0' : '1.67', [ ]); my %exports = ( spawn => \&spawn, ); my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } sub spawn { local $@; my @diag; my $thread = eval { local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; threads->create(@_); }; push @diag, "Thread creation error: $@" if $@; if (@diag) { require Test::Leaner; Test::Leaner::diag($_) for @diag; } return $thread ? $thread : (); } 1; indirect-0.31/t/lib/indirect/Test2.pm0000644000175000017500000000012012144733277016404 0ustar vincevinceno indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[$x->new]} }; } 1; indirect-0.31/t/lib/indirect/Test4.pm0000644000175000017500000000013112144733277016410 0ustar vincevinceno indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[$x ->new]} }; } 1; indirect-0.31/t/lib/indirect/Test1/0000750000175000017500000000000012212131272016026 5ustar vincevinceindirect-0.31/t/lib/indirect/Test1/il1.pm0000644000175000017500000000003211610665342017064 0ustar vincevinceno indirect ":fatal"; 1; indirect-0.31/t/lib/indirect/Test1/il2.pm0000644000175000017500000000007611610665342017075 0ustar vincevincepackage indirect::Test1::il2; import indirect::Test1::il2; 1; indirect-0.31/t/lib/indirect/Test5.pm0000644000175000017500000000013612144733277016416 0ustar vincevinceno indirect ":fatal"; my $x; if ($x) { my $y = qq{abcdef @{[sort $x ->new]} }; } 1; indirect-0.31/t/lib/indirect/TestRequired2.pm0000644000175000017500000000031611610665342020106 0ustar vincevincepackage indirect::TestRequired2; no indirect; BEGIN { delete $INC{'indirect/TestRequired1.pm'} } use lib 't/lib'; use indirect::TestRequired1; eval { my $y = new Baz; }; eval 'my $z = new Blech'; 1; indirect-0.31/t/lib/indirect/TestRequired5/0000750000175000017500000000000012212131272017533 5ustar vincevinceindirect-0.31/t/lib/indirect/TestRequired5/d0.pm0000644000175000017500000000005711610665342020416 0ustar vincevincepackage indirect::TestRequired5::d0; new X; 1; indirect-0.31/t/lib/indirect/TestRequired5/a0.pm0000644000175000017500000000024711610665342020414 0ustar vincevincepackage indirect::TestRequired5::a0; no indirect ":fatal"; use indirect::TestRequired5::b0; sub error { local $@; indirect::TestRequired5::b0->get; return $@; } 1; indirect-0.31/t/lib/indirect/TestRequired5/b0.pm0000644000175000017500000000014111610665342020406 0ustar vincevincepackage indirect::TestRequired5::b0; sub get { eval 'require indirect::TestRequired5::c0'; } 1; indirect-0.31/t/lib/indirect/TestRequired5/c0.pm0000644000175000017500000000011511610665342020410 0ustar vincevincepackage indirect::TestRequired5::c0; require indirect::TestRequired5::d0; 1; indirect-0.31/t/lib/indirect/TestRequired3X.pm0000644000175000017500000000021511610665342020235 0ustar vincevincepackage indirect::TestRequired3X; sub new { push @main::new, __PACKAGE__ } no indirect hook => \&main::cb3; new indirect::TestRequired3X; indirect-0.31/t/lib/indirect/Test0/0000750000175000017500000000000012212131272016025 5ustar vincevinceindirect-0.31/t/lib/indirect/Test0/Fffff/0000750000175000017500000000000012212131272017042 5ustar vincevinceindirect-0.31/t/lib/indirect/Test0/Fffff/Vvvvvvv.pm0000644000175000017500000000025711610665342021135 0ustar vincevincepackage indirect::Test0::Fffff::Vvvvvvv; use warnings; use strict; my $f; sub import { my($class, %args) = @_; $f = bless({ x => $args{x}, y => $args{y} }, $class); } 1; indirect-0.31/t/lib/indirect/Test0/Oooooo/0000750000175000017500000000000012212131272017276 5ustar vincevinceindirect-0.31/t/lib/indirect/Test0/Oooooo/Pppppppp.pm0000644000175000017500000000040611624504243021470 0ustar vincevincepackage indirect::Test0::Oooooo::Pppppppp; use strict; no indirect ":fatal"; use indirect::Test0::Fffff::Vvvvvvv z => 0, x => sub { }, y => sub { }; use indirect::Test0::Fffff::Vvvvvvv t => [ xxxx => qw ], x => sub { $_[0]->method }; 1; indirect-0.31/t/lib/indirect/TestRequired3Y.pm0000644000175000017500000000015311610665342020237 0ustar vincevincepackage indirect::TestRequired3Y; sub new { push @main::new, __PACKAGE__ } new indirect::TestRequired3Y; indirect-0.31/t/lib/indirect/TestRequired4/0000750000175000017500000000000012212131272017532 5ustar vincevinceindirect-0.31/t/lib/indirect/TestRequired4/a0.pm0000644000175000017500000000024711610665342020413 0ustar vincevincepackage indirect::TestRequired4::a0; no indirect ":fatal"; use indirect::TestRequired4::b0; sub error { local $@; indirect::TestRequired4::b0->get; return $@; } 1; indirect-0.31/t/lib/indirect/TestRequired4/b0.pm0000644000175000017500000000014111610665342020405 0ustar vincevincepackage indirect::TestRequired4::b0; sub get { eval 'require indirect::TestRequired4::c0'; } 1; indirect-0.31/t/lib/indirect/TestRequired4/c0.pm0000644000175000017500000000005711610665342020414 0ustar vincevincepackage indirect::TestRequired4::c0; new X; 1; indirect-0.31/t/lib/VPIT/0000750000175000017500000000000012212131272014007 5ustar vincevinceindirect-0.31/t/lib/VPIT/TestHelpers.pm0000644000175000017500000000376712144733277016652 0ustar vincevincepackage VPIT::TestHelpers; use strict; use warnings; my %exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); sub import { my $pkg = caller; while (my ($name, $code) = each %exports) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } } my $test_sub = sub { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return $glob ? *$glob{CODE} : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } 1; indirect-0.31/t/lib/Test/0000750000175000017500000000000012212131272014144 5ustar vincevinceindirect-0.31/t/lib/Test/Leaner.pm0000644000175000017500000004537412207502502015734 0ustar vincevincepackage Test::Leaner; use 5.006; use strict; use warnings; =head1 NAME Test::Leaner - A slimmer Test::More for when you favor performance over completeness. =head1 VERSION Version 0.05 =cut our $VERSION = '0.05'; =head1 SYNOPSIS use Test::Leaner tests => 10_000; for (1 .. 10_000) { ... is $one, 1, "checking situation $_"; } =head1 DESCRIPTION When profiling some L-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L itself, even though every single test actually involved a costly C. This module aims to be a partial replacement to L in those situations where you want to run a large number of simple tests. Its functions behave the same as their L counterparts, except for the following differences : =over 4 =item * Stringification isn't forced on the test operands. However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. =item * L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. =item * C (the sub C in package C) is not aliased to L. =item * L and L don't special case regular expressions that are passed as C<'/.../'> strings. A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). =item * L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. =item * L doesn't guard for memory cycles. If the two first arguments present parallel memory cycles, the test may result in an infinite loop. =item * The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. Moreover, this allows a much faster variant of L. =item * C, C, C, C, C, C, C, C blocks and C are not implemented. =back =cut use Exporter (); my $main_process; BEGIN { $main_process = $$; if ("$]" >= 5.008 and $INC{'threads.pm'}) { my $use_ithreads = do { require Config; no warnings 'once'; $Config::Config{useithreads}; }; if ($use_ithreads) { require threads::shared; *THREADSAFE = sub () { 1 }; } } unless (defined &Test::Leaner::THREADSAFE) { *THREADSAFE = sub () { 0 } } } my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); our @EXPORT = qw< plan skip done_testing pass fail ok is isnt like unlike cmp_ok is_deeply diag note BAIL_OUT >; =head1 ENVIRONMENT =head2 C If this environment variable is set, L will replace its functions by those from L. Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. This may be useful if your L-based test script fails and you want extra diagnostics. =cut sub _handle_import_args { my @imports; my $i = 0; while ($i <= $#_) { my $item = $_[$i]; my $splice; if (defined $item) { if ($item eq 'import') { push @imports, @{ $_[$i+1] }; $splice = 2; } elsif ($item eq 'no_diag') { lock $plan if THREADSAFE; $no_diag = 1; $splice = 1; } } if ($splice) { splice @_, $i, $splice; } else { ++$i; } } return @imports; } if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { require Test::More; my $leaner_stash = \%Test::Leaner::; my $more_stash = \%Test::More::; my %stubbed; for (@EXPORT) { my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} : undef; unless (defined $replacement) { $stubbed{$_}++; $replacement = sub { @_ = ("$_ is not implemented in this version of Test::More"); goto &croak; }; } no warnings 'redefine'; $leaner_stash->{$_} = $replacement; } my $import = sub { my $class = shift; my @imports = &_handle_import_args; if (@imports == grep /^!/, @imports) { # All imports are negated, or @imports is empty my %negated; /^!(.*)/ and ++$negated{$1} for @imports; push @imports, grep !$negated{$_}, @EXPORT; } my @test_more_imports; for (@imports) { if ($stubbed{$_}) { my $pkg = caller; no strict 'refs'; *{$pkg."::$_"} = $leaner_stash->{$_}; } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) { push @test_more_imports, $_; } else { # Croak for symbols in Test::More but not in Test::Leaner Exporter::import($class, $_); } } my $test_more_import = 'Test::More'->can('import'); return unless $test_more_import; @_ = ( 'Test::More', @_, import => \@test_more_imports, ); { lock $plan if THREADSAFE; push @_, 'no_diag' if $no_diag; } goto $test_more_import; }; no warnings 'redefine'; *import = $import; return 1; } sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } BEGIN { if (THREADSAFE) { threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing; } lock $plan if THREADSAFE; $plan = undef; $test = 0; $failed = 0; } sub carp { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } sub _sanitize_comment { $_[0] =~ s/\n+\z//; $_[0] =~ s/#/\\#/g; $_[0] =~ s/\n/\n# /g; } =head1 FUNCTIONS The following functions from L are implemented and exported by default. =head2 C plan tests => $count; plan 'no_plan'; plan skip_all => $reason; See L. =cut sub plan { my ($key, $value) = @_; return unless $key; lock $plan if THREADSAFE; croak("You tried to plan twice") if defined $plan; my $plan_str; if ($key eq 'no_plan') { croak("no_plan takes no arguments") if $value; $plan = NO_PLAN; } elsif ($key eq 'tests') { croak("Got an undefined number of tests") unless defined $value; croak("You said to run 0 tests") unless $value; croak("Number of tests must be a positive integer. You gave it '$value'") unless $value =~ /^\+?[0-9]+$/; $plan = $value; $plan_str = "1..$value"; } elsif ($key eq 'skip_all') { $plan = SKIP_ALL; $plan_str = '1..0 # SKIP'; if (defined $value) { _sanitize_comment($value); $plan_str .= " $value" if length $value; } } else { my @args = grep defined, $key, $value; croak("plan() doesn't understand @args"); } if (defined $plan_str) { local $\; print $TAP_STREAM "$plan_str\n"; } exit 0 if $plan == SKIP_ALL; return 1; } sub import { my $class = shift; my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; &plan; } @_ = ($class, @imports); goto &Exporter::import; } =head2 C skip $reason => $count; See L. =cut sub skip { my ($reason, $count) = @_; lock $plan if THREADSAFE; if (not defined $count) { carp("skip() needs to know \$how_many tests are in the block") unless defined $plan and $plan == NO_PLAN; $count = 1; } elsif ($count =~ /[^0-9]/) { carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); $count = 1; } for (1 .. $count) { ++$test; my $skip_str = "ok $test # skip"; if (defined $reason) { _sanitize_comment($reason); $skip_str .= " $reason" if length $reason; } local $\; print $TAP_STREAM "$skip_str\n"; } no warnings 'exiting'; last SKIP; } =head2 C done_testing; done_testing $count; See L. =cut sub done_testing { my ($count) = @_; lock $plan if THREADSAFE; $count = $test unless defined $count; croak("Number of tests must be a positive integer. You gave it '$count'") unless $count =~ /^\+?[0-9]+$/; if (not defined $plan or $plan == NO_PLAN) { $plan = $count; # $plan can't be NO_PLAN anymore $done_testing = 1; local $\; print $TAP_STREAM "1..$plan\n"; } else { if ($done_testing) { @_ = ('done_testing() was already called'); goto &fail; } elsif ($plan != $count) { @_ = ("planned to run $plan tests but done_testing() expects $count"); goto &fail; } } return 1; } =head2 C ok $ok; ok $ok, $desc; See L. =cut sub ok ($;$) { my ($ok, $desc) = @_; lock $plan if THREADSAFE; ++$test; my $test_str = "ok $test"; $ok or do { $test_str = "not $test_str"; ++$failed; }; if (defined $desc) { _sanitize_comment($desc); $test_str .= " - $desc" if length $desc; } local $\; print $TAP_STREAM "$test_str\n"; return $ok; } =head2 C pass; pass $desc; See L. =cut sub pass (;$) { unshift @_, 1; goto &ok; } =head2 C fail; fail $desc; See L. =cut sub fail (;$) { unshift @_, 0; goto &ok; } =head2 C is $got, $expected; is $got, $expected, $desc; See L. =cut sub is ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( (not(defined $got xor defined $expected) and $got eq $expected), $desc, ); goto &ok; } =head2 C isnt $got, $expected; isnt $got, $expected, $desc; See L. =cut sub isnt ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( ((defined $got xor defined $expected) or $got ne $expected), $desc, ); goto &ok; } my %binops = ( 'or' => 'or', 'xor' => 'xor', 'and' => 'and', '||' => 'hor', ('//' => 'dor') x ("$]" >= 5.010), '&&' => 'hand', '|' => 'bor', '^' => 'bxor', '&' => 'band', 'lt' => 'lt', 'le' => 'le', 'gt' => 'gt', 'ge' => 'ge', 'eq' => 'eq', 'ne' => 'ne', 'cmp' => 'cmp', '<' => 'nlt', '<=' => 'nle', '>' => 'ngt', '>=' => 'nge', '==' => 'neq', '!=' => 'nne', '<=>' => 'ncmp', '=~' => 'like', '!~' => 'unlike', ('~~' => 'smartmatch') x ("$]" >= 5.010), '+' => 'add', '-' => 'substract', '*' => 'multiply', '/' => 'divide', '%' => 'modulo', '<<' => 'lshift', '>>' => 'rshift', '.' => 'concat', '..' => 'flipflop', '...' => 'altflipflop', ',' => 'comma', '=>' => 'fatcomma', ); my %binop_handlers; sub _create_binop_handler { my ($op) = @_; my $name = $binops{$op}; croak("Operator $op not supported") unless defined $name; { local $@; eval <<"IS_BINOP"; sub is_$name (\$\$;\$) { my (\$got, \$expected, \$desc) = \@_; \@_ = (scalar(\$got $op \$expected), \$desc); goto &ok; } IS_BINOP die $@ if $@; } $binop_handlers{$op} = do { no strict 'refs'; \&{__PACKAGE__."::is_$name"}; } } =head2 C like $got, $regexp_expected; like $got, $regexp_expected, $desc; See L. =head2 C unlike $got, $regexp_expected; unlike $got, $regexp_expected, $desc; See L. =cut { no warnings 'once'; *like = _create_binop_handler('=~'); *unlike = _create_binop_handler('!~'); } =head2 C cmp_ok $got, $op, $expected; cmp_ok $got, $op, $expected, $desc; See L. =cut sub cmp_ok ($$$;$) { my ($got, $op, $expected, $desc) = @_; my $handler = $binop_handlers{$op}; unless ($handler) { local $Test::More::Level = ($Test::More::Level || 0) + 1; $handler = _create_binop_handler($op); } @_ = ($got, $expected, $desc); goto $handler; } =head2 C is_deeply $got, $expected; is_deeply $got, $expected, $desc; See L. =cut BEGIN { local $@; if (eval { require Scalar::Util; 1 }) { *_reftype = \&Scalar::Util::reftype; } else { # Stolen from Scalar::Util::PP require B; my %tmap = qw< B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP >; *_reftype = sub ($) { my $r = shift; return undef unless length ref $r; my $t = ref B::svref_2object($r); return exists $tmap{$t} ? $tmap{$t} : length ref $$r ? 'REF' : 'SCALAR' } } } sub _deep_ref_check { my ($x, $y, $ry) = @_; no warnings qw; if ($ry eq 'ARRAY') { return 0 unless $#$x == $#$y; my ($ex, $ey); for (0 .. $#$y) { $ex = $x->[$_]; $ey = $y->[$_]; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'HASH') { return 0 unless keys(%$x) == keys(%$y); my ($ex, $ey); for (keys %$y) { return 0 unless exists $x->{$_}; $ex = $x->{$_}; $ey = $y->{$_}; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { return _deep_check($$x, $$y); } return 0; } sub _deep_check { my ($x, $y) = @_; no warnings qw; return 0 if defined $x xor defined $y; # Try object identity/eq overloading first. It also covers the case where # $x and $y are both undefined. # If either $x or $y is overloaded but none has eq overloading, the test will # break at that point. return 1 if not(ref $x xor ref $y) and $x eq $y; # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. my $ry = _reftype($y); return 0 if _reftype($x) ne $ry; # Shortcut if $x and $y are both not references and failed the previous # $x eq $y test. return 0 unless $ry; # We know that $x and $y are both references of type $ry, without overloading. _deep_ref_check($x, $y, $ry); } sub is_deeply { @_ = ( &_deep_check, $_[2], ); goto &ok; } sub _diag_fh { my $fh = shift; return unless @_; lock $plan if THREADSAFE; return if $no_diag; my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; _sanitize_comment($msg); return unless length $msg; local $\; print $fh "# $msg\n"; return 0; }; =head2 C diag @lines; See L. =cut sub diag { unshift @_, $DIAG_STREAM; goto &_diag_fh; } =head2 C note @lines; See L. =cut sub note { unshift @_, $TAP_STREAM; goto &_diag_fh; } =head2 C BAIL_OUT; BAIL_OUT $desc; See L. =cut sub BAIL_OUT { my ($desc) = @_; lock $plan if THREADSAFE; my $bail_out_str = 'Bail out!'; if (defined $desc) { _sanitize_comment($desc); $bail_out_str .= " $desc" if length $desc; # Two spaces } local $\; print $TAP_STREAM "$bail_out_str\n"; exit 255; } END { if ($main_process == $$ and not $?) { lock $plan if THREADSAFE; if (defined $plan) { if ($failed) { $? = $failed <= 254 ? $failed : 254; } elsif ($plan >= 0) { $? = $test == $plan ? 0 : 255; } if ($plan == NO_PLAN) { local $\; print $TAP_STREAM "1..$test\n"; } } } } =pod L also provides some functions of its own, which are never exported. =head2 C 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>. Note that it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub tap_stream (;*) { if (@_) { $TAP_STREAM = $_[0]; my $fh = select $TAP_STREAM; $|++; select $fh; } return $TAP_STREAM; } tap_stream *STDOUT; =head2 C 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>. Just like L, it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub diag_stream (;*) { if (@_) { $DIAG_STREAM = $_[0]; my $fh = select $DIAG_STREAM; $|++; select $fh; } return $DIAG_STREAM; } diag_stream *STDERR; =head2 C This constant evaluates to true if and only if L is thread-safe, i.e. when this version of C is at least 5.8, has been compiled with C defined, and L has been loaded B L. In that case, it also needs a working L. =head1 DEPENDENCIES L 5.6. L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Leaner =head1 COPYRIGHT & LICENSE 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. Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L and is Copyright 1997-2007 Graham Barr, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Leaner indirect-0.31/t/20-good.t0000644000175000017500000001757112212066110014031 0ustar vincevince#!perl -T package NotEmpty; sub new; package main; use strict; use warnings; use Test::More tests => 119 * 8 + 10; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } my ($obj, $pkg, $cb, $x, @a); our ($y, $meth); sub meh; sub zap (&); my @warns; sub try { my ($code) = @_; @warns = (); { local $SIG{__WARN__} = sub { push @warns, @_ }; eval $code; } } { local $/ = "####"; while () { chomp; s/\s*$//; s/(.*?)$//m; my ($skip, $prefix) = split /#+/, $1; $skip = 0 unless defined $skip; $prefix = '' unless defined $prefix; s/\s*//; 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'; try "return; $prefix; no indirect; $_"; is $@, '', "no indirect: $_"; is @warns, 0, 'no reports'; } { local $_ = $_; s/Pkg/NotEmpty/g; try "return; $prefix; use indirect; $_"; is $@, '', "use indirect, defined: $_"; is @warns, 0, 'no reports'; try "return; $prefix; no indirect; $_"; is $@, '', "no indirect, defined: $_"; is @warns, 0, 'no reports'; } } } } # These tests must be run outside of eval to be meaningful. { sub Zlott::Owww::new { } my (@warns, $hook, $desc, $id); BEGIN { $hook = sub { push @warns, indirect::msg(@_) }; $desc = "test sort and line endings %d: no indirect construct"; $id = 1; } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; }; BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } BEGIN { @warns = () } { no indirect hook => $hook; my @stuff = sort Zlott::Owww ->new; } BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ } } __DATA__ $obj = Pkg->new; #### $obj = Pkg->new(); #### $obj = Pkg->new(1); #### $obj = Pkg->new(q{foo}, bar => $obj); #### $obj = Pkg -> new ; #### $obj = Pkg -> new ( ) ; #### $obj = Pkg -> new ( 1 ) ; #### $obj = Pkg -> new ( 'foo' , bar => $obj ); #### $obj = Pkg -> new ; #### $obj = Pkg -> new ( ) ; #### $obj = Pkg -> new ( 1 ) ; #### $obj = Pkg -> new ( "foo" , bar => $obj ); #### $obj = new->new; #### $obj = new->new; # new new #### $obj = new->newnew; #### $obj = newnew->new; #### $obj = Pkg->$cb; #### $obj = Pkg->$cb(); #### $obj = Pkg->$cb($pkg); #### $obj = Pkg->$cb(sub { 'foo' }, bar => $obj); #### $obj = Pkg->$meth; #### $obj = Pkg -> $meth ( 1, 2 ); #### $obj = $pkg->new ; #### $obj = $pkg -> new ( ); #### $obj = $pkg -> new ( $pkg ); #### $obj = $pkg -> new ( qr/foo/, foo => qr/bar/ ); #### $obj = $pkg -> $cb ; #### $obj = $pkg -> ($cb) (); #### $obj = $pkg->$cb( $obj ); #### $obj = $pkg->$cb(qw); #### $obj = $pkg->$meth; #### $obj = $pkg -> $meth ( 1 .. 10 ); #### $obj = $y->$cb; #### $obj = $y -> $cb ( 'foo', 1, 2, 'bar' ); #### $obj = $y->$meth; #### $obj = $y-> $meth ( qr(hello), ); #### meh; #### meh $_; #### meh $x; #### meh $x, 1, 2; #### meh $y; #### meh $y, 1, 2; #### "$]" < 5.010 # use feature 'state'; state $z meh $z; #### "$]" < 5.010 # use feature 'state'; state $z meh $z, 1, 2; #### print; #### print $_; #### print $x; #### print $x "oh hai\n"; #### print $y; #### print $y "hello thar\n"; #### "$]" < 5.010 # use feature 'state'; state $z print $z; #### "$]" < 5.010 # use feature 'state'; state $z print $z "lolno\n"; #### print STDOUT "bananananananana\n"; #### $x->foo($pkg->$cb) #### $obj = "apple ${\($x->new)} pear" #### $obj = "apple @{[$x->new]} pear" #### $obj = "apple ${\($y->new)} pear" #### $obj = "apple @{[$y->new]} pear" #### $obj = "apple ${\($x->$cb)} pear" #### $obj = "apple @{[$x->$cb]} pear" #### $obj = "apple ${\($y->$cb)} pear" #### $obj = "apple @{[$y->$cb]} pear" #### $obj = "apple ${\($x->$meth)} pear" #### $obj = "apple @{[$x->$meth]} pear" #### $obj = "apple ${\($y->$meth)} pear" #### $obj = "apple @{[$y->$meth]} pear" #### # local $_ = "foo"; s/foo/return; Pkg->new/e; #### # local $_ = "bar"; s/foo/return; Pkg->new/e; #### # local $_ = "foo"; s/foo/return; Pkg->$cb/e; #### # local $_ = "bar"; s/foo/return; Pkg->$cb/e; #### # local $_ = "foo"; s/foo/return; Pkg->$meth/e; #### # local $_ = "bar"; s/foo/return; Pkg->$meth/e; #### # local $_ = "foo"; s/foo/return; $x->new/e; #### # local $_ = "bar"; s/foo/return; $x->new/e; #### # local $_ = "foo"; s/foo/return; $x->$cb/e; #### # local $_ = "bar"; s/foo/return; $x->$cb/e; #### # local $_ = "foo"; s/foo/return; $x->$meth/e; #### # local $_ = "bar"; s/foo/return; $x->$meth/e; #### # local $_ = "foo"; s/foo/return; $y->new/e; #### # local $_ = "bar"; s/foo/return; $y->new/e; #### # local $_ = "foo"; s/foo/return; $y->$cb/e; #### # local $_ = "bar"; s/foo/return; $y->$cb/e; #### # local $_ = "foo"; s/foo/return; $y->$meth/e; #### # local $_ = "bar"; s/foo/return; $y->$meth/e; #### "foo" =~ /(?{Pkg->new})/; #### "foo" =~ /(?{Pkg->$cb})/; #### "foo" =~ /(?{Pkg->$meth})/; #### "foo" =~ /(?{$x->new})/; #### "foo" =~ /(?{$x->$cb})/; #### "foo" =~ /(?{$x->$meth})/; #### "foo" =~ /(?{$y->new})/; #### "foo" =~ /(?{$y->$cb})/; #### "foo" =~ /(?{$y->$meth})/; #### exec $x $x, @a; #### exec { $a[0] } @a; #### system $x $x, @a; #### system { $a[0] } @a; #### zap { }; #### zap { 1; }; #### zap { 1; 1; }; #### zap { zap { }; 1; }; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### my @stuff = sort Pkg ->new; #### 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__ indirect-0.31/t/21-bad.t0000644000175000017500000002132712212071031013620 0ustar vincevince#!perl -T package NotEmpty; sub new; package main; use strict; use warnings; my ($tests, $reports); BEGIN { $tests = 88; $reports = 100; } use Test::More tests => 3 * (4 * $tests + $reports) + 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } my ($obj, $x); our ($y, $bloop); sub expect { my ($expected) = @_; die unless $expected; map { my ($meth, $obj, $file, $line) = @$_; $meth = quotemeta $meth; $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\""; $file = '\((?:re_)?eval \d+\)' unless defined $file; $line = '\d+' unless defined $line; qr/^Indirect call of method "$meth" on $obj at $file line $line/ } eval $expected; } my @warns; sub try { my ($code) = @_; @warns = (); { local $SIG{__WARN__} = sub { push @warns, @_ }; eval $code; } } { local $/ = "####"; while () { chomp; s/\s*$//; s/(.*?)$//m; my ($skip, $prefix) = split /#+/, $1; $skip = 0 unless defined $skip; $prefix = '' unless defined $prefix; s/\s*//; 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'; try "return; $prefix; no indirect; $code"; is $@, '', "no indirect: $code"; is @warns, @expected, 'correct number of reports'; for my $i (0 .. $#expected) { like $warns[$i], $expected[$i], "report $i is correct"; } } { local $_ = $_; s/Pkg/NotEmpty/g; my ($code, $expected) = split /^-{4,}$/m, $_, 2; my @expected = expect($expected); try "return; $prefix; use indirect; $code"; is $@, '', "use indirect, defined: $code"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $code"; is $@, '', "no indirect, defined: $code"; is @warns, @expected, 'correct number of reports'; for my $i (0 .. $#expected) { like $warns[$i], $expected[$i], "report $i is correct"; } } 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; $code =~ s/\$/\$ \n\t /g; try "return; $prefix; use indirect; $code"; is $@, '', "use indirect, spaces: $code"; is @warns, 0, 'correct number of reports'; try "return; $prefix; no indirect; $code"; is $@, '', "no indirect, spaces: $code"; is @warns, @expected, 'correct number of reports'; for my $i (0 .. $#expected) { like $warns[$i], $expected[$i], "report $i is correct"; } } } } } eval { my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval "return; no indirect 'whatever'; \$obj = new Pkg1;"; } 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 "Pkg1"/, 'no indirect "whatever" enables the pragma'; is_deeply \@warns, [ ], 'nothing more'; } __DATA__ $obj = new Pkg; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg if 0; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg(); ---- [ 'new', 'Pkg' ] #### $obj = new Pkg(1); ---- [ 'new', 'Pkg' ] #### $obj = new Pkg(1, 2); ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 , 2 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new Pkg ( 1 , 2 ) ; ---- [ 'new', 'Pkg' ] #### $obj = new $x; ---- [ 'new', '$x' ] #### $obj = new $x(); ---- [ 'new', '$x' ] #### $obj = new $x('foo'); ---- [ 'new', '$x' ] #### $obj = new $x qq{foo}, 1; ---- [ 'new', '$x' ] #### $obj = new $x qr{foo\s+bar}, 1 .. 1; ---- [ 'new', '$x' ] #### $obj = new $x(qw); ---- [ 'new', '$x' ] #### $obj = new $_; ---- [ 'new', '$_' ] #### $obj = new $_ ( ); ---- [ 'new', '$_' ] #### $obj = new $_ qr/foo/ ; ---- [ 'new', '$_' ] #### $obj = new $_ qq(bar baz); ---- [ 'new', '$_' ] #### meh $_; ---- [ 'meh', '$_' ] #### meh $_ 1, 2; ---- [ 'meh', '$_' ] #### meh $$; ---- [ 'meh', '$$' ] #### meh $$ 1, 2; ---- [ 'meh', '$$' ] #### meh $x; ---- [ 'meh', '$x' ] #### meh $x 1, 2; ---- [ 'meh', '$x' ] #### meh $x, 1, 2; ---- [ 'meh', '$x' ] #### meh $y; ---- [ 'meh', '$y' ] #### meh $y 1, 2; ---- [ 'meh', '$y' ] #### meh $y, 1, 2; ---- [ 'meh', '$y' ] #### "$]" < 5.010 # use feature 'state'; state $z meh $z; ---- [ 'meh', '$z' ] #### "$]" < 5.010 # use feature 'state'; state $z meh $z 1, 2; ---- [ 'meh', '$z' ] #### "$]" < 5.010 # use feature 'state'; state $z meh $z, 1, 2; ---- [ 'meh', '$z' ] #### package sploosh; our $sploosh; meh $sploosh::sploosh; ---- [ 'meh', '$sploosh::sploosh' ] #### package sploosh; our $sploosh; meh $sploosh; ---- [ 'meh', '$sploosh' ] #### package sploosh; meh $main::bloop; ---- [ 'meh', '$main::bloop' ] #### package sploosh; meh $bloop; ---- [ 'meh', '$bloop' ] #### package ma; meh $bloop; ---- [ 'meh', '$bloop' ] #### package sploosh; our $sploosh; package main; meh $sploosh::sploosh; ---- [ 'meh', '$sploosh::sploosh' ] #### new Pkg->wut; ---- [ 'new', 'Pkg' ] #### new Pkg->wut(); ---- [ 'new', 'Pkg' ] #### new Pkg->wut, "Wut"; ---- [ 'new', 'Pkg' ] #### $obj = PkgPkg Pkg; ---- [ 'PkgPkg', 'Pkg' ] #### $obj = PkgPkg Pkg; # PkgPkg Pkg ---- [ 'PkgPkg', 'Pkg' ] #### $obj = new newnew; ---- [ 'new', 'newnew' ] #### $obj = new newnew; # new newnew ---- [ 'new', 'newnew' ] #### $obj = feh feh; ---- [ 'feh', 'feh' ] #### $obj = feh feh; # feh feh ---- [ 'feh', 'feh' ] #### new Pkg (meh $x) ---- [ 'meh', '$x' ], [ 'new', 'Pkg' ] #### Pkg->new(meh $x) ---- [ 'meh', '$x' ] #### $obj = "apple ${\(new Pkg)} pear" ---- [ 'new', 'Pkg' ] #### $obj = "apple @{[new Pkg]} pear" ---- [ 'new', 'Pkg' ] #### $obj = "apple ${\(new $x)} pear" ---- [ 'new', '$x' ] #### $obj = "apple @{[new $x]} pear" ---- [ 'new', '$x' ] #### $obj = "apple ${\(new $y)} pear" ---- [ 'new', '$y' ] #### $obj = "apple @{[new $y]} pear" ---- [ 'new', '$y' ] #### $obj = "apple ${\(new $x qq|${\(stuff $y)}|)} pear" ---- [ 'stuff', '$y' ], [ 'new', '$x' ] #### $obj = "apple @{[new $x qq|@{[stuff $y]}|]} pear" ---- [ 'stuff', '$y' ], [ 'new', '$x' ] #### # local $_ = "foo"; s/foo/return; new Pkg/e; ---- [ 'new', 'Pkg' ] #### # local $_ = "bar"; s/foo/return; new Pkg/e; ---- [ 'new', 'Pkg' ] #### # local $_ = "foo"; s/foo/return; new $x/e; ---- [ 'new', '$x' ] #### # local $_ = "bar"; s/foo/return; new $x/e; ---- [ 'new', '$x' ] #### # local $_ = "foo"; s/foo/return; new $y/e; ---- [ 'new', '$y' ] #### # local $_ = "bar"; s/foo/return; new $y/e; ---- [ 'new', '$y' ] #### "foo" =~ /(?{new Pkg})/; ---- [ 'new', 'Pkg' ] #### "foo" =~ /(?{new $x})/; ---- [ 'new', '$x' ] #### "foo" =~ /(?{new $y})/; ---- [ 'new', '$y' ] #### "foo" =~ /(??{new Pkg})/; ---- [ 'new', 'Pkg' ] #### "foo" =~ /(??{new $x})/; ---- [ 'new', '$x' ] #### "foo" =~ /(??{new $y})/; ---- [ 'new', '$y' ] #### meh { }; ---- [ 'meh', '{' ] #### meh { 1; }; ---- [ 'meh', '{' ] #### meh { 1; 1; }; ---- [ 'meh', '{' ] #### meh { new Pkg; 1; }; ---- [ 'new', 'Pkg' ], [ 'meh', '{' ] #### meh { feh $x; 1; }; ---- [ 'feh', '$x' ], [ 'meh', '{' ] #### meh { feh $x; use indirect; new Pkg; 1; }; ---- [ 'feh', '$x' ], [ 'meh', '{' ] #### meh { feh $y; 1; }; ---- [ 'feh', '$y' ], [ 'meh', '{' ] #### meh { feh $x; 1; } new Pkg, feh $y; ---- [ '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', '{' ] indirect-0.31/t/23-bad-notaint.t0000644000175000017500000000042711610665342015311 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 1; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } { my @warns; { no indirect hook => sub { push @warns, \@_ }; eval { meh { } }; } is_deeply \@warns, [ [ '{', 'meh', $0, __LINE__-2 ] ], 'covering OP_CONST'; } indirect-0.31/t/00-load.t0000644000175000017500000000024012207502502014003 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'indirect' ); } diag( "Testing indirect $indirect::VERSION, Perl $], $^X" ); indirect-0.31/t/51-dd-newlines.t0000644000175000017500000000103012144733503015310 0ustar vincevince#!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; indirect-0.31/t/45-memory.t0000644000175000017500000000032611610665342014423 0ustar vincevince#!perl -T use lib 't/lib'; use Test::More tests => 1; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } eval "require indirect::Test0::Oooooo::Pppppppp"; is($@, '', 'memory reallocation to an uncatched optype'); indirect-0.31/t/22-bad-mixed.t0000644000175000017500000000263412212067160014735 0ustar vincevince#!perl -T package NotEmpty; sub new; package main; use strict; use warnings; use Test::More tests => 3 * 9; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub meh; my @warns; sub try { my ($code) = @_; @warns = (); { local $SIG{__WARN__} = sub { push @warns, @_ }; eval $code; } } { local $/ = "####"; while () { chomp; s/\s*$//; s/(.*?)$//m; my ($skip, $prefix) = split /#+/, $1; $skip = 0 unless defined $skip; $prefix = '' unless defined $prefix; s/\s*//; 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'; try "return; $prefix; no indirect; $_"; is $@, '', "no indirect: $_"; is @warns, 0, 'correct number of reports'; } { local $_ = $_; s/Pkg/NotEmpty/g; try "return; $prefix; use indirect; $_"; is $@, '', "use indirect, defined: $_"; is @warns, 0, 'correct number of reports'; 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 "NotEmpty" at \(eval \d+\) line \d+/, 'report 0 is correct'; } } } } __DATA__ meh Pkg->new; #### meh Pkg->new(); #### meh Pkg->new, "Wut"; indirect-0.31/t/47-stress-use.t0000644000175000017500000000135111650764524015237 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 3 * (2 * 1); my $n = 1_000; sub linear { my ($n, $force_use) = @_; my @lines; my $use = $force_use; for (1 .. $n) { my $stmt = $use ? 'use indirect;' : 'no indirect;'; $use = !$use unless defined $force_use; push @lines, "{ $stmt }"; } return '{ no indirect; ', @lines, '}'; } for my $test ([ 1, 'always use' ], [ 0, 'always no' ], [ undef, 'mixed' ]) { my ($force_use, $desc) = @$test; my $code = join "\n", linear $n, $force_use; my ($err, @warns); { local $SIG{__WARN__} = sub { push @warns, "@_" }; local $@; eval $code; $err = $@; } is $err, '', "linear ($desc): no errror"; is @warns, 0, "linear ($desc): no warnings"; diag $_ for @warns; } indirect-0.31/t/11-line.t0000644000175000017500000000174711610665342014043 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 3 * 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub expect { my ($pkg, $line) = @_; return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+\(eval\s+\d+\)\s+line\s+$line/; } { local $/ = "####"; while () { chomp; s/^\s+//; my ($code, $lines) = split /#+/, $_, 2; $lines = eval "[ sort ($lines) ]"; if ($@) { diag "Couldn't parse line numbers: $@"; next; } my (@warns, @lines); { local $SIG{__WARN__} = sub { push @warns, "@_" }; eval "return; no indirect hook => sub { push \@lines, \$_[3] }; $code"; } is $@, '', 'did\'t croak'; is_deeply \@warns, [ ], 'didn\'t warn'; is_deeply [ sort @lines ], $lines, 'correct line numbers'; } } __DATA__ my $x = new X; # 1 #### my $x = new X; # 1 #### my $x = new X; $x = new X; # 1, 1 #### my $x = new X new X; # 1, 2 indirect-0.31/t/31-hints.t0000644000175000017500000000104411651071706014231 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 1; SKIP: { skip 'This fails on perl 5.11.x even without using indirect' => 1 if "$]" >= 5.011 and "$]" < 5.012; local %^H = (a => 1); require indirect; # Force %^H repopulation with an Unicode match my $x = "foo"; utf8::upgrade($x); $x =~ /foo/i; my $hints = join ',', map { $_, defined $^H{$_} ? $^H{$_} : '(undef)' } sort keys(%^H); is $hints, 'a,1', 'indirect does not vivify entries in %^H'; } indirect-0.31/t/42-threads-global.t0000644000175000017500000000152711650770107016004 0ustar vincevince#!perl -T use strict; use warnings; use lib 't/lib'; use indirect::TestThreads; use Test::Leaner; sub expect { my ($pkg) = @_; qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/; } my $error; no indirect 'global', 'hook' => sub { $error = indirect::msg(@_) }; sub try { my $tid = threads->tid(); for my $run (1 .. 2) { my $desc = "global indirect hook (thread $tid, run $run)"; my $class = "Mango$tid"; my @warns; { local $SIG{__WARN__} = sub { push @warns, @_ }; eval "return; my \$x = new $class 1, 2;" } is $@, '', "$desc: did not croak"; is_deeply \@warns, [ ], "$desc: no warnings"; like $error, expect($class), "$desc: correct error"; } } my @threads = map spawn(\&try), 1 .. 10; $_->join for @threads; done_testing(scalar(@threads) * 3 * 2); indirect-0.31/t/30-scope.t0000644000175000017500000001520212207502502014204 0ustar vincevince#!perl use strict; use warnings; my $tests; BEGIN { $tests = 18 } use Test::More tests => (1 + $tests + 1) + 2 + 3 + 3 + 3 + 5 + 4 + 5 + 4; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } use lib 't/lib'; my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18; sub expect { my ($obj, $file, $prefix) = @_; $obj = quotemeta $obj; $file = $file ? quotemeta $file : '\(eval \d+\)'; $prefix = defined $prefix ? quotemeta $prefix : 'warn:'; qr/^${prefix}Indirect call of method "new" on object "$obj" at $file line \d+/; } { my $code = do { local $/; }; my (%res, $num, @left); { local $SIG{__WARN__} = sub { ++$num; my $w = join '', 'warn:', @_; if ($w =~ /"P(\d+)"/ and not exists $res{$1}) { $res{$1} = $w; } else { push @left, "[$num] $w"; } }; eval "return; $code"; } is $@, '', 'DATA compiled fine'; for (1 .. $tests) { my $w = $res{$_}; if ($wrong{$_}) { like $w, expect("P$_"), "$_ should warn"; } else { is $w, undef, "$_ shouldn't warn"; } } is @left, 0, 'nothing left'; diag "Extraneous warnings:\n", @left if @left; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; no indirect; my $x = new Foo'; } is $@, '', "eval 'no indirect; my \$x = new Foo'"; is @w, 1, 'got one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('Foo'), 'correct warning'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; { no indirect; eval 'return; my $x = new Bar'; } } is $@, '', "no indirect; eval 'my \$x = new Bar'"; if ("$]" < 5.009_005) { is @w, 0, 'no warnings caught'; pass 'placeholder'; } else { is @w, 1, 'got one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('Bar'), 'correct warning'; } } SKIP: { skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 2 if "$]" < 5.009_005; my @w; my $test = sub { eval 'return; new XYZ' }; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval 'return; no indirect; BEGIN { $test->() }'; } is $@, '', 'eval test doesn\'t croak prematurely'; is @w, 0, 'eval did not throw a warning'; diag join "\n", 'All warnings:', @w if @w; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;"; } is $@, '', 'first require test doesn\'t croak prematurely'; is @w, 1, 'first require threw only one warning'; diag join "\n", 'All warnings:', @w if @w > 1; like $w[0], expect('Foo'), 'first require test catch errors in current scope'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; 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.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.009_005; $w = shift @w; like $w, expect('Blech'), 'second require test caught error for Blech'; } $w = shift @w; like $w, expect('Bar'), 'second require test caught error for Bar'; is_deeply \@w, [ ], 'second require test doesn\'t have more errors'; } { local @main::new; my (@err, @w); sub cb3 { push @err, $_[0] }; local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; eval <<' TESTREQUIRED3'; { package indirect::TestRequired3Z; sub new { push @main::new, __PACKAGE__ } no indirect hook => \&main::cb3; use indirect::TestRequired3X; use indirect::TestRequired3Y; new indirect::TestRequired3Z; } TESTREQUIRED3 @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, [ ], "pragma leak when reusing callback test doesn't warn"; is_deeply \@err, [ map "indirect::TestRequired3$_", qw ], "pragma leak when reusing callback test caught the right errors"; is_deeply \@main::new, [ map "indirect::TestRequired3$_", qw ], "pragma leak when reusing callback test ran the three constructors"; } { eval <<' SNIP'; return; no indirect ':fatal'; use indirect::Test1::il1 (); use indirect::Test1::il2 (); SNIP is $@, '', 'RT #47902'; } # This test may not fail for the old version when ran in taint mode { my $err = eval <<' SNIP'; use indirect::TestRequired4::a0; indirect::TestRequired4::a0::error(); SNIP like $err, qr/^Can't locate object method "new" via package "X"/, 'RT #50570'; } # This test must be in the topmost scope BEGIN { eval 'use indirect::TestRequired5::a0' } my $err = indirect::TestRequired5::a0::error(); like $err, qr/^Can't locate object method "new" via package "X"/, 'identifying requires by their eval context pointer is not enough'; { my @w; no indirect hook => sub { push @w, indirect::msg(@_) }; use indirect::TestRequired6; indirect::TestRequired6::bar(); is_deeply \@w, [ ], 'indirect syntax in sub'; @w = (); indirect::TestRequired6::baz(); is_deeply \@w, [ ], 'indirect syntax in eval in sub'; } { local $@; eval { require indirect::Test2 }; is $@, '', 'direct call in string is not fooled by newlines'; } { local $@; eval { require indirect::Test3 }; like $@, expect('$x', 't/lib/indirect/Test3.pm', ''), 'indirect call in string is not fooled by newlines'; } { local $@; eval { require indirect::Test4 }; is $@, '', 'direct call in string is not fooled by more newlines'; } { local $@; eval { require indirect::Test5 }; is $@, '', 'direct call in sort in string is not fooled by newlines'; } __DATA__ my $a = new P1; { no indirect; my $b = new P2; { my $c = new P3; } { use indirect; my $d = new P4; } my $e = new P5; } my $f = new P6; no indirect; my $g = new P7; use indirect; my $h = new P8; { no indirect; eval { my $i = new P9 }; } eval { no indirect; my $j = new P10 }; { use indirect; new P11 do { use indirect; new P12 }; } { use indirect; new P13 do { no indirect; new P14 }; } { no indirect; new P15 do { use indirect; new P16 }; } { no indirect; new P17 do { no indirect; new P18 }; } indirect-0.31/t/10-args.t0000644000175000017500000000372311650761422014043 0ustar vincevince#!perl -T use strict; use warnings; use Test::More tests => 4 + 3 + 1 + 2; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub expect { my ($pkg) = @_; qr/^Indirect call of method "new" on object "$pkg" at \(eval \d+\) line \d+/; } { my @warns; { local $SIG{__WARN__} = sub { push @warns, "@_" }; eval <<' HERE'; return; no indirect; my $x = new Warn1; $x = new Warn2; HERE } my $w1 = shift @warns; my $w2 = shift @warns; is $@, '', 'didn\'t croak without arguments'; like $w1, expect('Warn1'), 'first warning caught without arguments'; like $w2, expect('Warn2'), 'second warning caught without arguments'; is_deeply \@warns, [ ], 'no more warnings without arguments'; } for my $fatal (':fatal', 'FATAL', ':Fatal') { { local $SIG{__WARN__} = sub { die "warn:@_" }; eval <<" HERE"; die qq{shouldn't even compile\n}; no indirect '$fatal'; my \$x = new Croaked; \$x = new NotReached; HERE } like $@, expect('Croaked'), "croaks when $fatal is specified"; } { { local $SIG{__WARN__} = sub { "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; no indirect 'whatever', hook => sub { die 'hook:' . join(':', @_) . "\n" }; my $x = new Hooked; $x = new AlsoNotReached; HERE } like $@, qr/^hook:Hooked:new:\(eval\s+\d+\):\d+$/, 'calls the specified hook'; } { my $no_hook_and_fatal = qr/^The 'fatal' and 'hook' options are mutually exclusive at \(eval \d+\) line \d+/; { local $SIG{__WARN__} = sub { die "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; no indirect 'fatal', hook => sub { }; new NotReached; HERE } like $@, $no_hook_and_fatal, '"no indirect qw" croaks'; { local $SIG{__WARN__} = sub { die "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; no indirect hook => sub { }, 'fatal'; new NotReached; HERE } like $@, $no_hook_and_fatal, '"no indirect qw" croaks'; } indirect-0.31/t/46-stress.t0000644000175000017500000000100011650764553014435 0ustar vincevince#!perl -T use strict; use warnings; my $count; BEGIN { $count = 1_000 } use lib 't/lib'; use Test::Leaner tests => 2 * $count; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } for (1 .. $count) { my @errs; { local $SIG{__WARN__} = sub { die @_ }; eval q( return; no indirect hook => sub { push @errs, [ @_[0, 1, 3] ] }; my $x = new Wut; ); } is $@, '', "didn't croak at run $_"; is_deeply \@errs, [ [ 'Wut', 'new', 4 ] ], "got the right data at run $_"; } indirect-0.31/t/50-external.t0000644000175000017500000000173412144733277014743 0ustar vincevince#!perl use strict; use warnings; use Test::More tests => 3; use lib 't/lib'; use VPIT::TestHelpers; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } sub run_perl { my $code = shift; my ($SystemRoot, $PATH) = @ENV{qw}; local %ENV; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; system { $^X } $^X, '-T', map("-I$_", @INC), '-e', $code; } { my $status = run_perl 'no indirect; qq{a\x{100}b} =~ /\A[\x00-\x7f]*\z/;'; is $status, 0, 'RT #47866'; } SKIP: { skip 'Fixed in core only since 5.12' => 1 unless "$]" >= 5.012; my $status = run_perl 'no indirect hook => sub { exit 2 }; new X'; is $status, 2 << 8, 'no semicolon at the end of -e'; } SKIP: { load_or_skip('Devel::CallParser', undef, undef, 1); my $status = run_perl "use Devel::CallParser (); no indirect; sub ok { } ok 1"; is $status, 0, 'indirect is not getting upset by Devel::CallParser'; } indirect-0.31/META.json0000640000175000017500000000267512212131272013650 0ustar vincevince{ "abstract" : "Lexically warn about using the indirect method call syntax.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.74, CPAN::Meta::Converter version 2.132140", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "indirect", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Carp" : "0", "Config" : "0", "ExtUtils::MakeMaker" : "0", "Test::More" : "0", "XSLoader" : "0" } }, "configure" : { "requires" : { "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "XSLoader" : "0", "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Name=indirect" }, "homepage" : "http://search.cpan.org/dist/indirect/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2Findirect.git" } }, "version" : "0.31" } indirect-0.31/README0000644000175000017500000002033212212131272013101 0ustar vincevinceNAME indirect - Lexically warn about using the indirect method call syntax. VERSION Version 0.31 SYNOPSIS In a script : no indirect; # lexically enables the pragma my $x = new Apple 1, 2, 3; # warns { use indirect; # lexically disables the pragma my $y = new Pear; # legit, does not warn { # lexically specify an hook called for each indirect construct no indirect hook => sub { die "You really wanted $_[0]\->$_[1] at $_[2]:$_[3]" }; my $z = new Pineapple 'fresh'; # croaks 'You really wanted...' } } try { ... }; # warns if try() hasn't been declared in this package no indirect 'fatal'; # or ':fatal', 'FATAL', ':Fatal' ... if (defied $foo) { ... } # croaks, note the typo Global uses : # Globally enable the pragma from the command-line perl -M-indirect=global -e 'my $x = new Banana;' # warns # Globally enforce the pragma each time perl is executed export PERL5OPT="-M-indirect=global,fatal" perl -e 'my $y = new Coconut;' # croaks DESCRIPTION When enabled, this pragma warns about indirect method calls that are present in your code. The indirect syntax is now considered harmful, since its parsing has many quirks and its use is error prone : when the subroutine "foo" has not been declared in the current package, "foo $x" actually compiles to "$x->foo", and "foo { key => 1 }" to "'key'->foo(1)". In , Matt S. Trout gives an example of an undesirable indirect method call on a block that can cause a particularly bewildering error. This pragma currently does not warn for core functions ("print", "say", "exec" or "system"). This may change in the future, or may be added as optional features that would be enabled by passing options to "unimport". This module is not a source filter. METHODS "unimport" no indirect; no indirect 'fatal'; no indirect hook => sub { my ($obj, $name, $file, $line) = @_; ... }; no indirect 'global'; no indirect 'global, 'fatal'; no indirect 'global', hook => sub { ... }; Magically called when "no indirect @opts" is encountered. Turns the module on. The policy to apply depends on what is first found in @opts : * If it is a string that matches "/^:?fatal$/i", the compilation will croak when the first indirect method call is found. This option is mutually exclusive with the 'hook' option. * If the key/value pair "hook => $hook" comes first, $hook will be called for each error with a string representation of the object as $_[0], the method name as $_[1], the current file as $_[2] and the line number as $_[3]. If and only if the object is actually a block, $_[0] is assured to start by '{'. This option is mutually exclusive with the 'fatal' option. * If none of "fatal" and "hook" are specified, a warning will be emitted for each indirect method call. * If @opts contains a string that matches "/^:?global$/i", the pragma will be globally enabled for all code compiled after the current "no indirect" statement, except for code that is in the lexical scope of "use indirect". This option may come indifferently before or after the "fatal" or "hook" options, in the case they are also passed to "unimport". The global policy applied is the one resulting of the "fatal" or "hook" options, thus defaults to a warning when none of those are specified : no indirect 'global'; # warn for any indirect call no indirect qw; # die on any indirect call no indirect 'global', hook => \&hook # custom global action Note that if another policy is installed by a "no indirect" statement further in the code, it will overrule the global policy : no indirect 'global'; # warn globally { no indirect 'fatal'; # throw exceptions for this lexical scope ... require Some::Module; # the global policy will apply for the # compilation phase of this module } "import" use indirect; Magically called at each "use indirect". Turns the module off. As explained in "unimport"'s description, an "use indirect" statement will lexically override a global policy previously installed by "no indirect 'global', ..." (if there's one). FUNCTIONS "msg" my $msg = msg($object, $method, $file, $line); Returns the default error message that "indirect" generates when an indirect method call is reported. CONSTANTS "I_THREADSAFE" True iff the module could have been built with thread-safety features enabled. "I_FORKSAFE" True iff this module could have been built with fork-safety features enabled. This will always be true except on Windows where it's false for perl 5.10.0 and below . DIAGNOSTICS "Indirect call of method "%s" on object "%s" at %s line %d." The default warning/exception message thrown when an indirect method call on an object is found. "Indirect call of method "%s" on a block at %s line %d." The default warning/exception message thrown when an indirect method call on a block is found. ENVIRONMENT "PERL_INDIRECT_PM_DISABLE" If this environment variable is set to true when the pragma is used for the first time, the XS code won't be loaded and, although the 'indirect' lexical hint will be set to true in the scope of use, the pragma itself won't do anything. In this case, the pragma will always be considered to be thread-safe, and as such "I_THREADSAFE" will be true. This is useful for disabling "indirect" in production environments. Note that clearing this variable after "indirect" was loaded has no effect. If you want to re-enable the pragma later, you also need to reload it by deleting the 'indirect.pm' entry from %INC. CAVEATS The implementation was tweaked to work around several limitations of vanilla "perl" pragmas : it's thread safe, and does not suffer from a "perl 5.8.x-5.10.0" bug that causes all pragmas to propagate into "require"d scopes. Before "perl" 5.12, "meth $obj" (no semicolon) at the end of a file is not seen as an indirect method call, although it is as soon as there is another token before the end (as in "meth $obj;" or "meth $obj 1"). If you use "perl" 5.12 or greater, those constructs are correctly reported. With 5.8 perls, the pragma does not propagate into "eval STRING". This is due to a shortcoming in the way perl handles the hints hash, which is addressed in perl 5.10. The search for indirect method calls happens before constant folding. Hence "my $x = new Class if 0" will be caught. DEPENDENCIES 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. Carp (standard since perl 5), XSLoader (since perl 5.6.0). AUTHOR Vincent Pit, "", . You can contact me by mail or on "irc.perl.org" (vincent). BUGS Please report any bugs or feature requests to "bug-indirect at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc indirect Tests code coverage report is available at . ACKNOWLEDGEMENTS Bram, for motivation and advices. Andrew Main and Florian Ragwitz, for testing on real-life code and reporting issues. COPYRIGHT & LICENSE Copyright 2008,2009,2010,2011,2012,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. indirect-0.31/indirect.xs0000644000175000017500000005722512212064223014412 0ustar vincevince/* This file is part of the indirect Perl module. * See http://search.cpan.org/dist/indirect/ */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define __PACKAGE__ "indirect" #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) /* --- Compatibility wrappers ---------------------------------------------- */ #ifndef NOOP # define NOOP #endif #ifndef dNOOP # define dNOOP #endif #ifndef Newx # define Newx(v, n, c) New(0, v, n, c) #endif #ifndef SvPV_const # define SvPV_const SvPV #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const SvPV_nolen #endif #ifndef SvPVX_const # define SvPVX_const SvPVX #endif #ifndef SvREFCNT_inc_simple_void_NN # ifdef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_void_NN SvREFCNT_inc_simple_NN # else # define SvREFCNT_inc_simple_void_NN SvREFCNT_inc # endif #endif #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef mPUSHp # define mPUSHp(P, L) PUSHs(sv_2mortal(newSVpvn((P), (L)))) #endif #ifndef mPUSHu # define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U))) #endif #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) # ifndef PL_linestr # define PL_linestr PL_parser->linestr # endif # ifndef PL_bufptr # define PL_bufptr PL_parser->bufptr # endif # ifndef PL_oldbufptr # define PL_oldbufptr PL_parser->oldbufptr # endif # ifndef PL_lex_inwhat # define PL_lex_inwhat PL_parser->lex_inwhat # endif #else # ifndef PL_linestr # define PL_linestr PL_Ilinestr # endif # ifndef PL_bufptr # define PL_bufptr PL_Ibufptr # endif # ifndef PL_oldbufptr # define PL_oldbufptr PL_Ioldbufptr # endif # ifndef PL_lex_inwhat # define PL_lex_inwhat PL_Ilex_inwhat # endif #endif #ifndef I_WORKAROUND_REQUIRE_PROPAGATION # define I_WORKAROUND_REQUIRE_PROPAGATION !I_HAS_PERL(5, 10, 1) #endif /* ... Thread safety and multiplicity ...................................... */ /* Safe unless stated otherwise in Makefile.PL */ #ifndef I_FORKSAFE # define I_FORKSAFE 1 #endif #ifndef I_MULTIPLICITY # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT) # define I_MULTIPLICITY 1 # else # define I_MULTIPLICITY 0 # endif #endif #if I_MULTIPLICITY && !defined(tTHX) # define tTHX PerlInterpreter* #endif #if I_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV)) # define I_THREADSAFE 1 # ifndef MY_CXT_CLONE # define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # endif #else # define I_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT indirect_globaldata # undef START_MY_CXT # define START_MY_CXT STATIC my_cxt_t MY_CXT; # undef MY_CXT_INIT # define MY_CXT_INIT NOOP # undef MY_CXT_CLONE # define MY_CXT_CLONE NOOP #endif #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) # define I_CHECK_MUTEX_LOCK OP_CHECK_MUTEX_LOCK # define I_CHECK_MUTEX_UNLOCK OP_CHECK_MUTEX_UNLOCK #else # define I_CHECK_MUTEX_LOCK OP_REFCNT_LOCK # define I_CHECK_MUTEX_UNLOCK OP_REFCNT_UNLOCK #endif typedef OP *(*indirect_ck_t)(pTHX_ OP *); #ifdef wrap_op_checker # define indirect_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) #else STATIC void indirect_ck_replace(pTHX_ OPCODE type, indirect_ck_t new_ck, indirect_ck_t *old_ck_p) { #define indirect_ck_replace(T, NC, OCP) indirect_ck_replace(aTHX_ (T), (NC), (OCP)) I_CHECK_MUTEX_LOCK; if (!*old_ck_p) { *old_ck_p = PL_check[type]; PL_check[type] = new_ck; } I_CHECK_MUTEX_UNLOCK; } #endif STATIC void indirect_ck_restore(pTHX_ OPCODE type, indirect_ck_t *old_ck_p) { #define indirect_ck_restore(T, OCP) indirect_ck_restore(aTHX_ (T), (OCP)) I_CHECK_MUTEX_LOCK; if (*old_ck_p) { PL_check[type] = *old_ck_p; *old_ck_p = 0; } I_CHECK_MUTEX_UNLOCK; } /* --- Helpers ------------------------------------------------------------- */ /* ... Thread-safe hints ................................................... */ #if I_WORKAROUND_REQUIRE_PROPAGATION typedef struct { SV *code; IV require_tag; } indirect_hint_t; #define I_HINT_STRUCT 1 #define I_HINT_CODE(H) ((H)->code) #define I_HINT_FREE(H) { \ indirect_hint_t *h = (H); \ SvREFCNT_dec(h->code); \ PerlMemShared_free(h); \ } #else /* I_WORKAROUND_REQUIRE_PROPAGATION */ typedef SV indirect_hint_t; #define I_HINT_STRUCT 0 #define I_HINT_CODE(H) (H) #define I_HINT_FREE(H) SvREFCNT_dec(H); #endif /* !I_WORKAROUND_REQUIRE_PROPAGATION */ #if I_THREADSAFE #define PTABLE_NAME ptable_hints #define PTABLE_VAL_FREE(V) I_HINT_FREE(V) #define pPTBL pTHX #define pPTBL_ pTHX_ #define aPTBL aTHX #define aPTBL_ aTHX_ #include "ptable.h" #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V)) #define ptable_hints_free(T) ptable_hints_free(aTHX_ (T)) #endif /* I_THREADSAFE */ /* Define the op->str ptable here because we need to be able to clean it during * thread cleanup. */ typedef struct { char *buf; STRLEN pos; STRLEN size; STRLEN len; line_t line; } indirect_op_info_t; #define PTABLE_NAME ptable #define PTABLE_VAL_FREE(V) if (V) { Safefree(((indirect_op_info_t *) (V))->buf); Safefree(V); } #define pPTBL pTHX #define pPTBL_ pTHX_ #define aPTBL aTHX #define aPTBL_ aTHX_ #include "ptable.h" #define ptable_store(T, K, V) ptable_store(aTHX_ (T), (K), (V)) #define ptable_delete(T, K) ptable_delete(aTHX_ (T), (K)) #define ptable_clear(T) ptable_clear(aTHX_ (T)) #define ptable_free(T) ptable_free(aTHX_ (T)) #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { #if I_THREADSAFE ptable *tbl; /* It really is a ptable_hints */ tTHX owner; #endif ptable *map; SV *global_code; } my_cxt_t; START_MY_CXT #if I_THREADSAFE STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { #define indirect_clone(S, O) indirect_clone(aTHX_ (S), (O)) CLONE_PARAMS param; AV *stashes = NULL; SV *dupsv; if (!sv) return NULL; if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) stashes = newAV(); param.stashes = stashes; param.flags = 0; param.proto_perl = owner; dupsv = sv_dup(sv, ¶m); if (stashes) { av_undef(stashes); SvREFCNT_dec(stashes); } return SvREFCNT_inc(dupsv); } STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { my_cxt_t *ud = ud_; indirect_hint_t *h1 = ent->val; indirect_hint_t *h2; if (ud->owner == aTHX) return; #if I_HINT_STRUCT h2 = PerlMemShared_malloc(sizeof *h2); h2->code = indirect_clone(h1->code, ud->owner); #if I_WORKAROUND_REQUIRE_PROPAGATION h2->require_tag = PTR2IV(indirect_clone(INT2PTR(SV *, h1->require_tag), ud->owner)); #endif #else /* I_HINT_STRUCT */ h2 = indirect_clone(h1, ud->owner); #endif /* !I_HINT_STRUCT */ ptable_hints_store(ud->tbl, ent->key, h2); } #include "reap.h" STATIC void indirect_thread_cleanup(pTHX_ void *ud) { dMY_CXT; SvREFCNT_dec(MY_CXT.global_code); ptable_free(MY_CXT.map); ptable_hints_free(MY_CXT.tbl); } #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION STATIC IV indirect_require_tag(pTHX) { #define indirect_require_tag() indirect_require_tag(aTHX) const CV *cv, *outside; cv = PL_compcv; if (!cv) { /* If for some reason the pragma is operational at run-time, try to discover * the current cv in use. */ const PERL_SI *si; for (si = PL_curstackinfo; si; si = si->si_prev) { I32 cxix; for (cxix = si->si_cxix; cxix >= 0; --cxix) { const PERL_CONTEXT *cx = si->si_cxstack + cxix; switch (CxTYPE(cx)) { case CXt_SUB: case CXt_FORMAT: /* The propagation workaround is only needed up to 5.10.0 and at that * time format and sub contexts were still identical. And even later the * cv members offsets should have been kept the same. */ cv = cx->blk_sub.cv; goto get_enclosing_cv; case CXt_EVAL: cv = cx->blk_eval.cv; goto get_enclosing_cv; default: break; } } } cv = PL_main_cv; } get_enclosing_cv: for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) cv = outside; return PTR2IV(cv); } #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ STATIC SV *indirect_tag(pTHX_ SV *value) { #define indirect_tag(V) indirect_tag(aTHX_ (V)) indirect_hint_t *h; SV *code = NULL; if (SvROK(value)) { value = SvRV(value); if (SvTYPE(value) >= SVt_PVCV) { code = value; SvREFCNT_inc_simple_void_NN(code); } } #if I_HINT_STRUCT h = PerlMemShared_malloc(sizeof *h); h->code = code; # if I_WORKAROUND_REQUIRE_PROPAGATION h->require_tag = indirect_require_tag(); # endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ #else /* I_HINT_STRUCT */ h = code; #endif /* !I_HINT_STRUCT */ #if I_THREADSAFE { dMY_CXT; /* We only need for the key to be an unique tag for looking up the value later * Allocated memory provides convenient unique identifiers, so that's why we * use the hint as the key itself. */ ptable_hints_store(MY_CXT.tbl, h, h); } #endif /* I_THREADSAFE */ return newSViv(PTR2IV(h)); } STATIC SV *indirect_detag(pTHX_ const SV *hint) { #define indirect_detag(H) indirect_detag(aTHX_ (H)) indirect_hint_t *h; #if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION dMY_CXT; #endif h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE h = ptable_fetch(MY_CXT.tbl, h); #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION if (indirect_require_tag() != h->require_tag) return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); } STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) SV *hint = NULL; if (IN_PERL_RUNTIME) return NULL; #if I_HAS_PERL(5, 10, 0) || defined(PL_parser) if (!PL_parser) return NULL; #endif #ifdef cop_hints_fetch_pvn hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, indirect_hash, 0); #elif I_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, __PACKAGE__, __PACKAGE_LEN__, 0, indirect_hash); #else { SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); if (val) hint = *val; } #endif if (hint && SvIOK(hint)) return indirect_detag(hint); else { dMY_CXT; return MY_CXT.global_code; } } /* ... op -> source position ............................................... */ STATIC void indirect_map_store(pTHX_ const OP *o, STRLEN pos, SV *sv, line_t line) { #define indirect_map_store(O, P, N, L) indirect_map_store(aTHX_ (O), (P), (N), (L)) indirect_op_info_t *oi; const char *s; STRLEN len; dMY_CXT; if (!(oi = ptable_fetch(MY_CXT.map, o))) { Newx(oi, 1, indirect_op_info_t); ptable_store(MY_CXT.map, o, oi); oi->buf = NULL; oi->size = 0; } if (sv) { s = SvPV_const(sv, len); } else { s = "{"; len = 1; } if (len > oi->size) { Safefree(oi->buf); Newx(oi->buf, len, char); oi->size = len; } Copy(s, oi->buf, len, char); oi->len = len; oi->pos = pos; oi->line = line; } STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) { #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O)) dMY_CXT; return ptable_fetch(MY_CXT.map, o); } STATIC void indirect_map_delete(pTHX_ const OP *o) { #define indirect_map_delete(O) indirect_map_delete(aTHX_ (O)) dMY_CXT; ptable_delete(MY_CXT.map, o); } /* --- Check functions ----------------------------------------------------- */ 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; line = SvPV_const(PL_linestr, line_len); line_end = line + line_len; name = SvPV_const(name_sv, name_len); if (name_len >= 1 && *name == '$') { ++name; --name_len; while (line_bufptr < line_end && *line_bufptr != '$') ++line_bufptr; if (line_bufptr >= line_end) return 0; } name_end = name + name_len; p = line_bufptr; while (1) { p = ninstr(p, line_end, name, name_end); if (!p) return 0; if (!isALNUM(p[name_len])) break; /* p points to a word that has name as prefix, skip the rest of the word */ p += name_len + 1; while (isALNUM(*p)) ++p; } *name_pos = p - line; return 1; } /* ... ck_const ............................................................ */ STATIC OP *(*indirect_old_ck_const)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_const(pTHX_ OP *o) { o = indirect_old_ck_const(aTHX_ o); if (indirect_hint()) { SV *sv = cSVOPo_sv; if (SvPOK(sv) && (SvTYPE(sv) >= SVt_PV)) { 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; } } } indirect_map_delete(o); return o; } /* ... ck_rv2sv ............................................................ */ STATIC OP *(*indirect_old_ck_rv2sv)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_rv2sv(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; SV *sv; const char *name = NULL; STRLEN pos, len; OPCODE type = (OPCODE) op->op_type; switch (type) { case OP_GV: case OP_GVSV: { GV *gv = cGVOPx_gv(op); name = GvNAME(gv); len = GvNAMELEN(gv); break; } default: if ((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP) { SV *nsv = cSVOPx_sv(op); if (SvPOK(nsv) && (SvTYPE(nsv) >= SVt_PV)) name = SvPV_const(nsv, len); } } if (!name) goto done; sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, name, len); if (!indirect_find(sv, PL_oldbufptr, &pos)) { /* If it failed, retry without the current stash */ const char *stash = HvNAME_get(PL_curstash); STRLEN stashlen = HvNAMELEN_get(PL_curstash); if ((len < stashlen + 2) || strnNE(name, stash, stashlen) || name[stashlen] != ':' || name[stashlen+1] != ':') { /* Failed again ? Try to remove main */ stash = "main"; stashlen = 4; if ((len < stashlen + 2) || strnNE(name, stash, stashlen) || name[stashlen] != ':' || name[stashlen+1] != ':') goto done; } sv_setpvn(sv, "$", 1); stashlen += 2; sv_catpvn_nomg(sv, name + stashlen, len - stashlen); if (!indirect_find(sv, PL_oldbufptr, &pos)) goto done; } o = indirect_old_ck_rv2sv(aTHX_ o); indirect_map_store(o, pos, sv, CopLINE(&PL_compiling)); return o; } done: o = indirect_old_ck_rv2sv(aTHX_ o); indirect_map_delete(o); return o; } /* ... ck_padany ........................................................... */ STATIC OP *(*indirect_old_ck_padany)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_padany(pTHX_ OP *o) { o = indirect_old_ck_padany(aTHX_ o); if (indirect_hint()) { SV *sv; const char *s = PL_oldbufptr, *t = PL_bufptr - 1; while (s < t && isSPACE(*s)) ++s; if (*s == '$' && ++s <= t) { while (s < t && isSPACE(*s)) ++s; while (s < t && isSPACE(*t)) --t; sv = sv_2mortal(newSVpvn("$", 1)); sv_catpvn_nomg(sv, s, t - s + 1); indirect_map_store(o, s - SvPVX_const(PL_linestr), sv, CopLINE(&PL_compiling)); return o; } } indirect_map_delete(o); return o; } /* ... ck_scope ............................................................ */ STATIC OP *(*indirect_old_ck_scope) (pTHX_ OP *) = 0; STATIC OP *(*indirect_old_ck_lineseq)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_scope(pTHX_ OP *o) { OP *(*old_ck)(pTHX_ OP *) = 0; switch (o->op_type) { case OP_SCOPE: old_ck = indirect_old_ck_scope; break; case OP_LINESEQ: old_ck = indirect_old_ck_lineseq; break; } o = old_ck(aTHX_ o); if (indirect_hint()) { indirect_map_store(o, PL_oldbufptr - SvPVX_const(PL_linestr), NULL, CopLINE(&PL_compiling)); return o; } indirect_map_delete(o); return o; } /* We don't need to clean the map entries for leave ops because they can only * be created by mutating from a lineseq. */ /* ... ck_method ........................................................... */ STATIC OP *(*indirect_old_ck_method)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_method(pTHX_ OP *o) { if (indirect_hint()) { OP *op = cUNOPo->op_first; /* Indirect method call is only possible when the method is a bareword, so * don't trip up on $obj->$meth. */ if (op && op->op_type == OP_CONST) { const indirect_op_info_t *oi = indirect_map_fetch(op); STRLEN pos; line_t line; SV *sv; if (!oi) goto done; sv = sv_2mortal(newSVpvn(oi->buf, oi->len)); pos = oi->pos; /* Keep the old line so that we really point to the first line of the * expression. */ line = oi->line; o = indirect_old_ck_method(aTHX_ o); /* o may now be a method_named */ indirect_map_store(o, pos, sv, line); return o; } } done: o = indirect_old_ck_method(aTHX_ o); indirect_map_delete(o); return o; } /* ... ck_method_named ..................................................... */ /* "use foo/no foo" compiles its call to import/unimport directly to a * method_named op. */ STATIC OP *(*indirect_old_ck_method_named)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_method_named(pTHX_ OP *o) { if (indirect_hint()) { STRLEN pos; line_t line; SV *sv; sv = cSVOPo_sv; if (!SvPOK(sv) || (SvTYPE(sv) < SVt_PV)) goto done; sv = sv_mortalcopy(sv); if (!indirect_find(sv, PL_oldbufptr, &pos)) goto done; line = CopLINE(&PL_compiling); o = indirect_old_ck_method_named(aTHX_ o); indirect_map_store(o, pos, sv, line); return o; } done: o = indirect_old_ck_method_named(aTHX_ o); indirect_map_delete(o); return o; } /* ... ck_entersub ......................................................... */ STATIC OP *(*indirect_old_ck_entersub)(pTHX_ OP *) = 0; STATIC OP *indirect_ck_entersub(pTHX_ OP *o) { SV *code = indirect_hint(); o = indirect_old_ck_entersub(aTHX_ o); if (code) { const indirect_op_info_t *moi, *ooi; OP *mop, *oop; LISTOP *lop; oop = o; do { lop = (LISTOP *) oop; if (!(lop->op_flags & OPf_KIDS)) goto done; oop = lop->op_first; } while (oop->op_type != OP_PUSHMARK); oop = oop->op_sibling; mop = lop->op_last; if (!oop) goto done; switch (oop->op_type) { case OP_CONST: case OP_RV2SV: case OP_PADSV: case OP_SCOPE: case OP_LEAVE: break; default: goto done; } if (mop->op_type == OP_METHOD) mop = cUNOPx(mop)->op_first; else if (mop->op_type != OP_METHOD_NAMED) goto done; moi = indirect_map_fetch(mop); if (!moi) goto done; ooi = indirect_map_fetch(oop); if (!ooi) goto done; /* When positions are identical, the method and the object must have the * same name. But it also means that it is an indirect call, as "foo->foo" * results in different positions. */ if ( moi->line < ooi->line || (moi->line == ooi->line && moi->pos <= ooi->pos)) { SV *file; dSP; ENTER; SAVETMPS; #ifdef USE_ITHREADS file = sv_2mortal(newSVpv(CopFILE(&PL_compiling), 0)); #else file = sv_mortalcopy(CopFILESV(&PL_compiling)); #endif PUSHMARK(SP); EXTEND(SP, 4); mPUSHp(ooi->buf, ooi->len); mPUSHp(moi->buf, moi->len); PUSHs(file); mPUSHu(moi->line); PUTBACK; call_sv(code, G_VOID); PUTBACK; FREETMPS; LEAVE; } } done: return o; } STATIC U32 indirect_initialized = 0; STATIC void indirect_teardown(pTHX_ void *root) { if (!indirect_initialized) return; #if I_MULTIPLICITY if (aTHX != root) return; #endif { dMY_CXT; ptable_free(MY_CXT.map); #if I_THREADSAFE ptable_hints_free(MY_CXT.tbl); #endif } indirect_ck_restore(OP_CONST, &indirect_old_ck_const); indirect_ck_restore(OP_RV2SV, &indirect_old_ck_rv2sv); indirect_ck_restore(OP_PADANY, &indirect_old_ck_padany); indirect_ck_restore(OP_SCOPE, &indirect_old_ck_scope); indirect_ck_restore(OP_LINESEQ, &indirect_old_ck_lineseq); indirect_ck_restore(OP_METHOD, &indirect_old_ck_method); indirect_ck_restore(OP_METHOD_NAMED, &indirect_old_ck_method_named); indirect_ck_restore(OP_ENTERSUB, &indirect_old_ck_entersub); indirect_initialized = 0; } STATIC void indirect_setup(pTHX) { #define indirect_setup() indirect_setup(aTHX) if (indirect_initialized) return; { MY_CXT_INIT; #if I_THREADSAFE MY_CXT.tbl = ptable_new(); MY_CXT.owner = aTHX; #endif MY_CXT.map = ptable_new(); MY_CXT.global_code = NULL; } indirect_ck_replace(OP_CONST, indirect_ck_const, &indirect_old_ck_const); indirect_ck_replace(OP_RV2SV, indirect_ck_rv2sv, &indirect_old_ck_rv2sv); indirect_ck_replace(OP_PADANY, indirect_ck_padany, &indirect_old_ck_padany); indirect_ck_replace(OP_SCOPE, indirect_ck_scope, &indirect_old_ck_scope); indirect_ck_replace(OP_LINESEQ, indirect_ck_scope, &indirect_old_ck_lineseq); indirect_ck_replace(OP_METHOD, indirect_ck_method, &indirect_old_ck_method); indirect_ck_replace(OP_METHOD_NAMED, indirect_ck_method_named, &indirect_old_ck_method_named); indirect_ck_replace(OP_ENTERSUB, indirect_ck_entersub, &indirect_old_ck_entersub); #if I_MULTIPLICITY call_atexit(indirect_teardown, aTHX); #else call_atexit(indirect_teardown, NULL); #endif indirect_initialized = 1; } STATIC U32 indirect_booted = 0; /* --- XS ------------------------------------------------------------------ */ MODULE = indirect PACKAGE = indirect PROTOTYPES: ENABLE BOOT: { if (!indirect_booted++) { HV *stash; PERL_HASH(indirect_hash, __PACKAGE__, __PACKAGE_LEN__); stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1); newCONSTSUB(stash, "I_THREADSAFE", newSVuv(I_THREADSAFE)); newCONSTSUB(stash, "I_FORKSAFE", newSVuv(I_FORKSAFE)); } indirect_setup(); } #if I_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; SV *global_code_dup; PPCODE: { my_cxt_t ud; dMY_CXT; ud.tbl = t = ptable_new(); ud.owner = MY_CXT.owner; ptable_walk(MY_CXT.tbl, indirect_ptable_clone, &ud); global_code_dup = indirect_clone(MY_CXT.global_code, MY_CXT.owner); } { MY_CXT_CLONE; MY_CXT.map = ptable_new(); MY_CXT.tbl = t; MY_CXT.owner = aTHX; MY_CXT.global_code = global_code_dup; } reap(3, indirect_thread_cleanup, NULL); XSRETURN(0); #endif SV * _tag(SV *value) PROTOTYPE: $ CODE: RETVAL = indirect_tag(value); OUTPUT: RETVAL void _global(SV *code) PROTOTYPE: $ PPCODE: if (!SvOK(code)) code = NULL; else if (SvROK(code)) code = SvRV(code); { dMY_CXT; SvREFCNT_dec(MY_CXT.global_code); MY_CXT.global_code = SvREFCNT_inc(code); } XSRETURN(0); indirect-0.31/Changes0000644000175000017500000003064312212131210013512 0ustar vincevinceRevision 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 "@{[ $x->new ]}" will no longer be reported as indirect. This was a regression in 0.28. Thanks Andrew Main for reporting. + Fix : Broken linkage on Windows with gcc 3.4, which appears in particular when using ActivePerl's default compiler suite. For those setups, the indirect shared library will now be linked against the perl dll directly (instead of the import library). 0.28 2013-02-26 17:05 UTC + Fix : [RT #83450] : newlines confuse indirect Perl sometimes resets the line buffer between the object and the method name (e.g. for "sort Class\n->method" outside of eval), and this could cause direct method calls to be reported as indirect. Thanks Gianni Ceccarelli for reporting. + Fix : Check functions are now replaced and restored in a thread-safe manner, either by using the wrap_op_checker() function from perl when it is available (starting from perl 5.16) or by taking the OP_REFCNT mutex on older perls. 0.27 2013-01-30 19:00 UTC + Fix : [RT #82562] : indirect/Devel::CallParser interaction indirect has been taught to play nicely with Devel::CallParser. Thanks Andrew Main for the patch. + Tst : Author tests overhaul. 0.26 2011-10-23 14:25 UTC + Add : "no indirect 'global'" enables the pragma for the whole program, except for lexical scopes that "use indirect" explicitely. + Chg : Passing both the 'fatal' and 'hook' options to unimport() is now considered an error, and will result in an exception. unimport() used to consider only the first passed option of those two, and silently ignored the other. + Tst : Test failures of t/41-threads-teardown.t and t/50-external.t on Cygwin should have been addressed. + Tst : Threads tests will not fail anymore if resources constraints prevent the system from creating all the required threads. 0.25 2011-08-24 15:40 UTC + Fix : RT #69291 is now also fixed for perl 5.8. The pragma will no longer vivify the "indirect" entry in the hints hash %^H on perl 5.8. + Tst : Attempt to make t/50-external.t pass on Cygwin. 0.24 2011-07-17 23:15 UTC + Fix : [RT #64521] : "no indirect" leaking into eval. This is currently only fixed for perl 5.10 (perl 5.12 and higher were never affected). It was caused by a very stupid mistake of mine that was introduced in indirect version 0.23. Thanks Michael G Schwern for reporting. + Fix : [RT #69291] : indirect.pm breaks %^H. This was caused by the same mistake as for the previous bug, and as such it is also only fixed for perl 5.10 (and never affected perl 5.12). Thanks Andrew Main for reporting. + Doc : C++ compilers are officially NOT supported. 0.23 2010-10-03 00:15 UTC + Fix : Some indirect constructs could be incorrectly reported when several modules were used in the same scope. This caused t/30-scope.t to fail randomly. + Tst : Threads tests are now only run on perl 5.13.4 and higher. They could segfault randomly because of what seems to be an internal bug of Perl, which has been addressed in 5.13.4. There is also an environment variable that allows you to forcefully run those tests, but it should be set only for author testing and not for end users. 0.22 2010-08-16 16:00 UTC + Add : Indirect constructs are now reported for code interpolated in quote-like environments, like "${\( ... )}", "@{[ ... ]}", s/pattern/ ... /e, qr/(?{ ... })/ or qr/(??{ ... })/. + Add : You can now make the pragma lethal by passing anything matching /^:?fatal$/i to import(), including "FATAL" and ":Fatal". + Fix : [RT #60378] : segmentation fault on indirect_ck_method. This caused constructs like "@{[ $obj->$meth ]}" to segfault when $meth was a lexical. Thanks Tokuhiro Matsuno for reporting. 0.21 2010-05-31 23:10 UTC + Chg : perl 5.8.1 is now required (instead of 5.8.0). + Fix : [RT #57699] : indirect fail with 64-bit int on 5.13.1. It was actually a problem with thread destructors segfaulting because they weren't called at the right time anymore. Thanks Andrew Main for reporting. + Tst : A few more regression tests about the scope leak bug. 0.20 2010-04-18 21:25 UTC + Fix : [RT #50570] : "indirect" leaking into LWP. Thanks Andrew Main for reporting. More generally, the require propagation workaround on 5.8-5.10.0 has been overhauled, and other scope leaks should be fixed. + Fix : Test failures with 5.12 on Windows where Strawberry Perl crashes because the SystemRoot environment variable is missing. + Fix : Work around Kwalitee test misfailures. 0.19 2009-08-28 18:40 UTC + Add : The new constant I_FORKSAFE can be tested to know whether the module will behave nicely when fork()ing. It's currently always true except on Windows where you need perl 5.10.1 for it to be true. + Fix : I_THREADSAFE and I_FORKSAFE ought to be true when PERL_INDIRECT_PM_DISABLE is set. + Fix : The pragma could still leak if you passed to the "hook" option a reference to the same (named) subroutine from two different require scopes. The fix also provides a better solution for RT #47902. + Fix : Segfaults when indirect is loaded for the first time from inside a thread. + Fix : Leaks of memory associated with the root interpreter. + Opt : Less memory will be used for non-threaded perls version 5.10.0 and below, and for threaded perls from version 5.10.1. 0.18 2009-08-23 16:15 UTC + Add : When set, the PERL_INDIRECT_PM_DISABLE environment variable disables the pragma globally. 0.17 2009-07-16 12:10 UTC + Fix : [RT #47902] : "no indirect" leaking again. This actually turned out to be a bug in how the hook coderefs were stored in the hints hash. Thanks Andrew Main for reporting once again. + Fix : t/80-regressions.t failing on Windows. + Tst : Yet more cleanups. 0.16 2009-07-14 16:50 UTC + Add : Indirect calls on blocks are now reported. For those, '{' is passed to the hook as the object description. + Add : The new indirect::msg() function publicizes the default warning/exception message. + Fix : [RT #47866] : Segfault with UTF-8 regexps. Thanks Andrew Main for reporting. + Tst : Cleanups. 0.15 2009-07-08 22:55 UTC + Fix : Invalid constructs with the same method and package name were not reported. + Fix : The error line number used to point to the end of the expression instead of its beginning. 0.14 2009-06-04 21:55 UTC + Fix : Prevent bogus invalid syntaxes caused by reallocated memory chunks. Thanks Andrew Main for reporting with a reproducible test case. 0.13 2009-05-24 18:50 UTC + Add : The hook now receives the file name and the line where the error happened in respectively $_[2] and $_[3]. + Fix : Pass mortalized copies of the method name and object to the hook. This seems to fix some rare crashes. + Fix : Work around a bug in perl 5.10.0 and lower. Thanks Andrew Main for teaching me about this issue. + Fix : Report the correct file in error messages (a regression from the previous version). 0.12 2009-05-03 14:30 UTC + Add : You can specify the action to execute for each indirect construct encountered with the new "hook => $coderef" unimport() option. + Chg : A ptable is now used internally for the op => position mapping. + Fix : The pragma is now built with thread safety features enabled whenever possible (a notable exception is perl 5.8.x on Win32, as something seems wrong with its context handling). The new indirect::I_THREADSAFE() constant reflects this. + Fix : A negation precedence nit in indirect_ck_entersub(). + Tst : "use/no indirect" while parsing an indirect construct. + Tst : Thread safety. 0.11 2009-02-08 18:35 UTC + Fix : Potential collisions by hashing pointers with a wrong format. + Upd : Resources in META.yml. 0.10 2009-01-17 12:40 UTC Re-release 0.09_01 as stable. 0.09_01 2008-12-08 17:55 UTC + Fix : Invalid memory read with "${\(new Foo)}" constructs. The corresponding test is turned back on. + Tst : Refinements in t/30-scope.t 0.09 2008-12-05 20:35 UTC + Add : Support for perl 5.8. + Tst : Skip a test in t/10-good.t that randomly segfaults for (I guess) systems stricter than linux in the way they manage their memory. 0.08 2008-10-22 14:45 UTC + Fix : A rare edge case for package whose names are prefix of 'main'. + Tst : Test $$ as variable and state variables. 0.07_03 2008-10-17 20:10 UTC + Add : Support and tests for variables with spaces after the sigil. + Upd : META.yml spec updated to 1.4. 0.07_02 2008-10-15 21:10 UTC + Add : Support and tests for package variables. + Tst : Coverage improved by removing dead code. 0.07_01 2008-10-15 16:00 UTC + Fix : [RT #40055] : Not handling RV2SV => GV(SV) correctly, which could cause 'no indirect; print' segfaults. Thanks Goro Fuji for reporting. 0.06 2008-10-11 16:45 UTC + Doc : Nits. + Tst : Test "no indirect 'anything'", "foo Class->bar", and indirect uses of exec() and system(). 0.05 2008-10-02 14:40 UTC + Chg : Now the old check function is always called before storing an op into the map. + Fix : Misc code and docs refinements. 0.04 2008-08-30 19:00 UTC + Fix : Clean up the op->src hash when we're done with an entersub. + Tst : No longer fork for testing. IPC::Cmd isn't required anymore. 0.03 2008-08-12 15:25 UTC This release is kindly supported by Copenhagen Hotel Centrum WiFi. + Fix : Tests used not to pass PERL5OPTS to their kids. This lead to failures under CPAN. I think. + Tst : Refinements. 0.02 2008-08-11 15:55 UTC + Fix : Some building failures with old gcc versions that didn't seem to like the ((hint == 2) ? croak : warn)(msg) construct. I think. + Rem : Unused cruft from a previous implementation. + Tst : Fail more gracefully when we can't capture buffers or when the child returned an error. 0.01 2008-08-10 20:40 UTC First version, released on an unsuspecting world. indirect-0.31/reap.h0000644000175000017500000000346311650762333013344 0ustar vincevince/* This file is part of the indirect Perl module. * See http://search.cpan.org/dist/indirect/ */ /* This header provides a specialized version of Scope::Upper::reap that can be * called directly from XS. * See http://search.cpan.org/dist/Scope-Upper/ for details. */ #ifndef REAP_H #define REAP_H 1 #define REAP_DESTRUCTOR_SIZE 3 typedef struct { I32 depth; I32 *origin; void (*cb)(pTHX_ void *); void *ud; char *dummy; } reap_ud; STATIC void reap_pop(pTHX_ void *); STATIC void reap_pop(pTHX_ void *ud_) { reap_ud *ud = ud_; I32 depth, *origin, mark, base; depth = ud->depth; origin = ud->origin; mark = origin[depth]; base = origin[depth - 1]; if (base < mark) { PL_savestack_ix = mark; leave_scope(base); } PL_savestack_ix = base; if ((ud->depth = --depth) > 0) { SAVEDESTRUCTOR_X(reap_pop, ud); } else { void (*cb)(pTHX_ void *) = ud->cb; void *cb_ud = ud->ud; PerlMemShared_free(ud->origin); PerlMemShared_free(ud); SAVEDESTRUCTOR_X(cb, cb_ud); } } STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) { #define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD)) reap_ud *ud; I32 i; if (depth > PL_scopestack_ix) depth = PL_scopestack_ix; ud = PerlMemShared_malloc(sizeof *ud); ud->depth = depth; ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin); ud->cb = cb; ud->ud = cb_ud; ud->dummy = NULL; for (i = depth; i >= 1; --i) { I32 j = PL_scopestack_ix - i; ud->origin[depth - i] = PL_scopestack[j]; PL_scopestack[j] += REAP_DESTRUCTOR_SIZE; } ud->origin[depth] = PL_savestack_ix; while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE <= PL_scopestack[PL_scopestack_ix - 1]) { save_pptr(&ud->dummy); } SAVEDESTRUCTOR_X(reap_pop, ud); } #endif /* REAP_H */ indirect-0.31/ptable.h0000644000175000017500000001311711650762333013661 0ustar vincevince/* This file is part of the indirect Perl module. * See http://search.cpan.org/dist/indirect/ */ /* This is a pointer table implementation essentially copied from the ptr_table * implementation in perl's sv.c, except that it has been modified to use memory * shared across threads. * Copyright goes to the original authors, bug reports to me. */ /* This header is designed to be included several times with different * definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */ #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #endif #undef pPTBLMS #undef pPTBLMS_ #undef aPTBLMS #undef aPTBLMS_ /* Context for PerlMemShared_* functions */ #ifdef PERL_IMPLICIT_SYS # define pPTBLMS pTHX # define pPTBLMS_ pTHX_ # define aPTBLMS aTHX # define aPTBLMS_ aTHX_ #else # define pPTBLMS void # define pPTBLMS_ # define aPTBLMS # define aPTBLMS_ #endif #ifndef pPTBL # define pPTBL pPTBLMS #endif #ifndef pPTBL_ # define pPTBL_ pPTBLMS_ #endif #ifndef aPTBL # define aPTBL aPTBLMS #endif #ifndef aPTBL_ # define aPTBL_ aPTBLMS_ #endif #ifndef PTABLE_NAME # define PTABLE_NAME ptable #endif #ifndef PTABLE_VAL_FREE # define PTABLE_VAL_FREE(V) #endif #ifndef PTABLE_JOIN # define PTABLE_PASTE(A, B) A ## B # define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) #endif #ifndef PTABLE_PREFIX # define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) #endif #ifndef ptable_ent typedef struct ptable_ent { struct ptable_ent *next; const void * key; void * val; } ptable_ent; #define ptable_ent ptable_ent #endif /* !ptable_ent */ #ifndef ptable typedef struct ptable { ptable_ent **ary; size_t max; size_t items; } ptable; #define ptable ptable #endif /* !ptable */ #ifndef ptable_new STATIC ptable *ptable_new(pPTBLMS) { #define ptable_new() ptable_new(aPTBLMS) ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t)); t->max = 15; t->items = 0; t->ary = VOID2(ptable_ent **, PerlMemShared_calloc(t->max + 1, sizeof *t->ary)); return t; } #endif /* !ptable_new */ #ifndef PTABLE_HASH # define PTABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) #endif #ifndef ptable_find STATIC ptable_ent *ptable_find(const ptable * const t, const void * const key) { #define ptable_find ptable_find ptable_ent *ent; const UV hash = PTABLE_HASH(key); ent = t->ary[hash & t->max]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } return NULL; } #endif /* !ptable_find */ #ifndef ptable_fetch STATIC void *ptable_fetch(const ptable * const t, const void * const key) { #define ptable_fetch ptable_fetch const ptable_ent *const ent = ptable_find(t, key); return ent ? ent->val : NULL; } #endif /* !ptable_fetch */ #ifndef ptable_split STATIC void ptable_split(pPTBLMS_ ptable * const t) { #define ptable_split(T) ptable_split(aPTBLMS_ (T)) ptable_ent **ary = t->ary; const size_t oldsize = t->max + 1; size_t newsize = oldsize * 2; size_t i; ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary))); Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary)); t->max = --newsize; t->ary = ary; for (i = 0; i < oldsize; i++, ary++) { ptable_ent **curentp, **entp, *ent; if (!*ary) continue; curentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { if ((newsize & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; continue; } else entp = &ent->next; } } } #endif /* !ptable_split */ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { ptable_ent *ent = ptable_find(t, key); if (ent) { void *oldval = ent->val; PTABLE_VAL_FREE(oldval); ent->val = val; } else if (val) { const size_t i = PTABLE_HASH(key) & t->max; ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent)); ent->key = key; ent->val = val; ent->next = t->ary[i]; t->ary[i] = ent; t->items++; if (ent->next && t->items > t->max) ptable_split(t); } } STATIC void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) { ptable_ent *prev, *ent; const size_t i = PTABLE_HASH(key) & t->max; prev = NULL; ent = t->ary[i]; for (; ent; prev = ent, ent = ent->next) { if (ent->key == key) break; } if (ent) { if (prev) prev->next = ent->next; else t->ary[i] = ent->next; PTABLE_VAL_FREE(ent->val); PerlMemShared_free(ent); } } #ifndef ptable_walk STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { #define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry; for (entry = array[i]; entry; entry = entry->next) if (entry->val) cb(aTHX_ entry, userdata); } while (i--); } } #endif /* !ptable_walk */ STATIC void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry = array[i]; while (entry) { ptable_ent * const oentry = entry; void *val = oentry->val; entry = entry->next; PTABLE_VAL_FREE(val); PerlMemShared_free(oentry); } array[i] = NULL; } while (i--); t->items = 0; } } STATIC void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); PerlMemShared_free(t->ary); PerlMemShared_free(t); } #undef pPTBL #undef pPTBL_ #undef aPTBL #undef aPTBL_ #undef PTABLE_NAME #undef PTABLE_VAL_FREE indirect-0.31/MANIFEST0000644000175000017500000000220612207502502013354 0ustar vincevinceChanges MANIFEST META.json META.yml Makefile.PL README indirect.xs lib/indirect.pm ptable.h reap.h samples/indirect.pl t/00-load.t t/10-args.t t/11-line.t t/12-env.t t/20-good.t t/21-bad.t t/22-bad-mixed.t t/23-bad-notaint.t t/30-scope.t t/31-hints.t t/32-global.t t/40-threads.t t/41-threads-teardown.t t/42-threads-global.t t/45-memory.t t/46-stress.t t/47-stress-use.t t/50-external.t t/51-dd-newlines.t t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm t/lib/indirect/Test0/Fffff/Vvvvvvv.pm t/lib/indirect/Test0/Oooooo/Pppppppp.pm t/lib/indirect/Test1/il1.pm t/lib/indirect/Test1/il2.pm t/lib/indirect/Test2.pm t/lib/indirect/Test3.pm t/lib/indirect/Test4.pm t/lib/indirect/Test5.pm t/lib/indirect/TestRequired1.pm t/lib/indirect/TestRequired2.pm t/lib/indirect/TestRequired3X.pm t/lib/indirect/TestRequired3Y.pm t/lib/indirect/TestRequired4/a0.pm t/lib/indirect/TestRequired4/b0.pm t/lib/indirect/TestRequired4/c0.pm t/lib/indirect/TestRequired5/a0.pm t/lib/indirect/TestRequired5/b0.pm t/lib/indirect/TestRequired5/c0.pm t/lib/indirect/TestRequired5/d0.pm t/lib/indirect/TestRequired6.pm t/lib/indirect/TestRequiredGlobal.pm t/lib/indirect/TestThreads.pm indirect-0.31/META.yml0000640000175000017500000000151312212131272013466 0ustar vincevince--- abstract: 'Lexically warn about using the indirect method call syntax.' author: - 'Vincent Pit ' build_requires: Carp: 0 Config: 0 ExtUtils::MakeMaker: 0 Test::More: 0 XSLoader: 0 configure_requires: Config: 0 ExtUtils::MakeMaker: 0 dynamic_config: 1 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 version: 1.4 name: indirect no_index: directory: - t - inc requires: Carp: 0 XSLoader: 0 perl: 5.008001 resources: 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.31 indirect-0.31/Makefile.PL0000644000175000017500000000510112207502502014172 0ustar vincevinceuse 5.008_001; use strict; use warnings; use ExtUtils::MakeMaker; use Config; my @DEFINES; my %macro; my $is_gcc_34 = 0; print "Checking if this is gcc 3.4 on Windows trying to link against an import library... "; if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) { my ($libperl, $gccversion) = map $_ || '', @Config{qw}; if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) { $is_gcc_34 = 1; my ($lddlflags, $ldflags) = @Config{qw}; $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags; $libperl = "-l$libperl"; my $libdirs = join ' ', map { s/(?}; $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl"; $macro{LDFLAGS} = "$ldflags $libdirs $libperl"; $macro{PERL_ARCHIVE} = '', } } print $is_gcc_34 ? "yes\n" : "no\n"; # Threads, Windows and 5.8.x don't seem to be best friends if ($^O eq 'MSWin32' and "$]" < 5.009) { push @DEFINES, '-DI_MULTIPLICITY=0'; } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' and "$]" < 5.010_001) { push @DEFINES, '-DI_FORKSAFE=0'; } @DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES; %macro = (macro => { %macro }) if %macro; # Beware of the circle my $dist = 'indirect'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'Carp' => 0, 'XSLoader' => 0, ); my %BUILD_REQUIRES =( 'Config' => 0, 'ExtUtils::MakeMaker' => 0, 'Test::More' => 0, %PREREQ_PM, ); my %META = ( configure_requires => { 'Config' => 0, 'ExtUtils::MakeMaker' => 0, }, build_requires => { %BUILD_REQUIRES, }, dynamic_config => 1, resources => { 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", }, ); WriteMakefile( NAME => $name, AUTHOR => 'Vincent Pit ', LICENSE => 'perl', VERSION_FROM => $file, ABSTRACT_FROM => $file, PL_FILES => {}, @DEFINES, BUILD_REQUIRES => \%BUILD_REQUIRES, PREREQ_PM => \%PREREQ_PM, MIN_PERL_VERSION => '5.008001', META_MERGE => \%META, dist => { PREOP => "pod2text -u $file > \$(DISTVNAME)/README", COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, clean => { FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*" }, %macro, ); indirect-0.31/samples/0000750000175000017500000000000012212131272013660 5ustar vincevinceindirect-0.31/samples/indirect.pl0000755000175000017500000000226011624504243016036 0ustar vincevince#!/usr/bin/env perl #use strict; #use warnings; use lib qw; sub Hlagh::new { my $class = shift; bless { }, ref($class) || $class ; } sub foo { shift; print "foo $_[0]\n" } sub bar { print "wut\n"; } my $bar = bless { }, 'main'; my %h; my $x = 1; no indirect; $x = new Hlagh 1, 2, 3; my $y = slap $x "what", 5; $h{foo} = 12; use indirect; foo 4, 5; no indirect; my $pkg = 'Hlagh'; my $cb = 'new'; foo(6, 7, 8); my $y = new $_ qr/bar/; my $y = Hlagh->new; $y = new Hlagh; my $z = foo meh, 1, 2; $y = meh $x, 7; $y = foo(3, 4); $y = Hlagh->new(); $y = Hlagh->new(1, 2, 3); $y = Hlagh->$cb; $y = new Hlagh; $y = new Hlagh 1, 2, 3; $y = new Hlagh 1 , 2, 3; $y = new $pkg; $y = new $pkg 'what'; $y = $pkg->new; $y = $pkg->new(1, 2, 3); $y = $pkg->$cb; $y = new(Hlagh); $y = new { Hlagh }; $y = new { $y }; $y = Hlagh -> new ( 1 , 2, 3); $y = Hlagh -> $ cb ( 1 , 2, 3); $y = new Hlagh $,; $y = new Hlagh ','; print { $^H{dongs} } 'bleh'; print STDERR 1; print STDERR 'what'; print STDERR q{wat}; my $fh; print $fh 'dongs';