This enables the module globally.
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
t/lib/indirect/TestRequired5/c0.pm
t/lib/indirect/TestRequired5/d0.pm
t/lib/indirect/TestRequired6.pm
+t/lib/indirect/TestRequiredGlobal.pm
tTHX owner;
#endif
ptable *map;
+ SV *global_code;
} my_cxt_t;
START_MY_CXT
AV *stashes = NULL;
SV *dupsv;
+ if (!sv)
+ return NULL;
+
if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
stashes = newAV();
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);
}
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);
STATIC SV *indirect_hint(pTHX) {
#define indirect_hint() indirect_hint(aTHX)
- SV *hint;
+ SV *hint = NULL;
if (IN_PERL_RUNTIME)
return NULL;
#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 ............................................... */
{
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];
PROTOTYPE: DISABLE
PREINIT:
ptable *t;
+ SV *global_code_dup;
PPCODE:
{
my_cxt_t ud;
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);
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);
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
=head1 METHODS
-=head2 C<< unimport [ hook => $hook | ':fatal', 'FATAL', ... ] >>
+=head2 C<< unimport [ 'global', hook => $hook | 'fatal' ] >>
Magically called when C<no indirect @opts> is encountered.
Turns the module on.
=item *
-Otherwise, a warning will be emitted for each indirect construct.
+If none of C<fatal> and C<hook> are specified, a warning will be emitted for each indirect construct.
+
+=item *
+
+If C<@opts> contains a string that matches C</^:?global$/i>, the pragma will be globally enabled for B<all> code compiled after the current C<no indirect> statement, except for code that is in the lexical scope of C<use indirect>.
+This option may come indifferently before or after the C<fatal> or C<hook> options, in the case they are also passed to L</unimport>.
+
+The global policy applied is the one resulting of the C<fatal> or C<hook> options, thus defaults to a warning when none of those are specified :
+
+ no indirect 'global'; # warn for any indirect call
+ no indirect qw<global fatal>; # die on any indirect call
+ no indirect 'global', hook => \&hook # custom global action
+
+Note that if another policy is installed by a C<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
+ }
=back
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);
+ }
();
}
Magically called at each C<use indirect>. Turns the module off.
+As explained in L</unimport>'s description, an C<use indirect> statement will lexically override a global policy previously installed by C<no indirect 'global', ...> (if there's one).
+
=cut
sub import {
- $^H{+(__PACKAGE__)} = undef;
+ $^H{+(__PACKAGE__)} = _tag(undef);
();
}
--- /dev/null
+#!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 $/; <DATA> };
+ 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<global fatal> }; 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 };
+}
--- /dev/null
+package indirect::TestRequiredGlobal;
+
+sub hurp { new ABC }
+
+BEGIN { eval 'new DEF' }
+
+eval 'new GHI';
+
+1;
projects / perl / modules / indirect.git / commitdiff