From: Vincent Pit Date: Sat, 22 Oct 2011 23:59:29 +0000 (+0200) Subject: Add 'global' option to 'no indirect' X-Git-Tag: v0.26~11 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=d34f50c40cce04c745a116755c566e4c4e3a516d;hp=838f008dcda56897a619afdd99f450fb62672a15 Add 'global' option to 'no indirect' This enables the module globally. --- diff --git a/MANIFEST b/MANIFEST index dab2fb4..ac3d160 100644 --- a/MANIFEST +++ b/MANIFEST @@ -19,6 +19,7 @@ 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/45-memory.t @@ -45,3 +46,4 @@ 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 diff --git a/indirect.xs b/indirect.xs index beec19f..1bd3ffa 100644 --- a/indirect.xs +++ b/indirect.xs @@ -212,6 +212,7 @@ typedef struct { tTHX owner; #endif ptable *map; + SV *global_code; } my_cxt_t; START_MY_CXT @@ -224,6 +225,9 @@ STATIC SV *indirect_clone(pTHX_ SV *sv, tTHX owner) { AV *stashes = NULL; SV *dupsv; + if (!sv) + return NULL; + if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv)) stashes = newAV(); @@ -272,6 +276,7 @@ STATIC void indirect_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { 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); } @@ -363,21 +368,18 @@ STATIC SV *indirect_tag(pTHX_ SV *value) { STATIC SV *indirect_detag(pTHX_ const SV *hint) { #define indirect_detag(H) indirect_detag(aTHX_ (H)) indirect_hint_t *h; - - if (!(hint && SvIOK(hint))) - return NULL; +#if I_THREADSAFE || I_WORKAROUND_REQUIRE_PROPAGATION + dMY_CXT; +#endif h = INT2PTR(indirect_hint_t *, SvIVX(hint)); #if I_THREADSAFE - { - dMY_CXT; - h = ptable_fetch(MY_CXT.tbl, h); - } + h = ptable_fetch(MY_CXT.tbl, h); #endif /* I_THREADSAFE */ #if I_WORKAROUND_REQUIRE_PROPAGATION if (indirect_require_tag() != h->require_tag) - return NULL; + return MY_CXT.global_code; #endif /* I_WORKAROUND_REQUIRE_PROPAGATION */ return I_HINT_CODE(h); @@ -387,7 +389,7 @@ STATIC U32 indirect_hash = 0; STATIC SV *indirect_hint(pTHX) { #define indirect_hint() indirect_hint(aTHX) - SV *hint; + SV *hint = NULL; if (IN_PERL_RUNTIME) return NULL; @@ -404,13 +406,17 @@ STATIC SV *indirect_hint(pTHX) { #else { SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); - if (!val) - return 0; - hint = *val; + if (val) + hint = *val; } #endif - return indirect_detag(hint); + if (hint && SvIOK(hint)) + return indirect_detag(hint); + else { + dMY_CXT; + return MY_CXT.global_code; + } } /* ... op -> source position ............................................... */ @@ -851,10 +857,11 @@ STATIC void indirect_setup(pTHX) { { MY_CXT_INIT; #if I_THREADSAFE - MY_CXT.tbl = ptable_new(); - MY_CXT.owner = aTHX; + MY_CXT.tbl = ptable_new(); + MY_CXT.owner = aTHX; #endif - MY_CXT.map = ptable_new(); + MY_CXT.map = ptable_new(); + MY_CXT.global_code = NULL; } indirect_old_ck_const = PL_check[OP_CONST]; @@ -914,6 +921,7 @@ CLONE(...) PROTOTYPE: DISABLE PREINIT: ptable *t; + SV *global_code_dup; PPCODE: { my_cxt_t ud; @@ -921,12 +929,14 @@ PPCODE: 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.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); @@ -940,3 +950,18 @@ 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); diff --git a/lib/indirect.pm b/lib/indirect.pm index 1eac9b9..c285468 100644 --- a/lib/indirect.pm +++ b/lib/indirect.pm @@ -38,11 +38,11 @@ BEGIN { no indirect ':fatal'; # or 'FATAL', or ':Fatal' ... if (defied $foo) { ... } # croaks, note the typo - # From the command-line - perl -M-indirect -e 'my $x = new Banana;' # warns + # Globally enabled from the command-line + perl -M-indirect=global -e 'my $x = new Banana;' # warns - # Or each time perl is ran - export PERL5OPT="-M-indirect" + # Or globally enabled each time perl is executed + export PERL5OPT="-M-indirect=global" perl -e 'my $y = new Coconut;' # warns =head1 DESCRIPTION @@ -72,7 +72,7 @@ BEGIN { =head1 METHODS -=head2 C<< unimport [ hook => $hook | ':fatal', 'FATAL', ... ] >> +=head2 C<< unimport [ 'global', hook => $hook | 'fatal' ] >> Magically called when C is encountered. Turns the module on. @@ -91,7 +91,28 @@ If and only if the object is actually a block, C<$_[0]> is assured to start by C =item * -Otherwise, a warning will be emitted for each indirect construct. +If none of C and C are specified, a warning will be emitted for each indirect construct. + +=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 @@ -101,19 +122,28 @@ sub unimport { shift; my $hook; + my $global; while (@_) { my $arg = shift; if ($arg eq 'hook') { + last if $hook; $hook = shift; } elsif ($arg =~ /^:?fatal$/i) { + last if $hook; $hook = sub { die msg(@_) }; + } elsif ($arg =~ /^:?global$/i) { + $global = 1; } - last if $hook; } $hook = sub { warn msg(@_) } unless defined $hook; $^H |= 0x00020000; - $^H{+(__PACKAGE__)} = _tag($hook); + if ($global) { + delete $^H{+(__PACKAGE__)}; + _global($hook); + } else { + $^H{+(__PACKAGE__)} = _tag($hook); + } (); } @@ -122,10 +152,12 @@ sub unimport { 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{+(__PACKAGE__)} = undef; + $^H{+(__PACKAGE__)} = _tag(undef); (); } diff --git a/t/32-global.t b/t/32-global.t new file mode 100644 index 0000000..80f9e41 --- /dev/null +++ b/t/32-global.t @@ -0,0 +1,139 @@ +#!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 }; +} diff --git a/t/lib/indirect/TestRequiredGlobal.pm b/t/lib/indirect/TestRequiredGlobal.pm new file mode 100644 index 0000000..3020efb --- /dev/null +++ b/t/lib/indirect/TestRequiredGlobal.pm @@ -0,0 +1,9 @@ +package indirect::TestRequiredGlobal; + +sub hurp { new ABC } + +BEGIN { eval 'new DEF' } + +eval 'new GHI'; + +1;