From: Vincent Pit Date: Sun, 3 May 2009 13:00:36 +0000 (+0200) Subject: Introduce the 'hook' unimport option X-Git-Tag: v0.12~3 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=36e1f9a23b073751223769b71f1e84643913e592;p=perl%2Fmodules%2Findirect.git Introduce the 'hook' unimport option --- diff --git a/lib/indirect.pm b/lib/indirect.pm index 4484dae..6354a13 100644 --- a/lib/indirect.pm +++ b/lib/indirect.pm @@ -39,37 +39,70 @@ It currently does not warn when the object is enclosed between braces (like C a source filter. +=cut + +BEGIN { + require XSLoader; + XSLoader::load(__PACKAGE__, $VERSION); +} + =head1 METHODS -=head2 C +=head2 C<< unimport [ hook => $hook | ':fatal' ] >> -Magically called when C is encountered. Turns the module on. If C<@opts> contains C<':fatal'>, the module will croak on the first indirect syntax met. +Magically called when C is encountered. +Turns the module on. +The policy to apply depends on what is first found in C<@opts> : -=head2 C +=over 4 -Magically called at each C. Turns the module off. +=item * -=cut +If it's the string C<':fatal'>, the compilation will croak on the first indirect syntax met. -BEGIN { - require XSLoader; - XSLoader::load(__PACKAGE__, $VERSION); -} +=item * -sub import { - $^H{+(__PACKAGE__)} = undef; - (); -} +If the key/value pair C<< hook => $hook >> comes first, C<$hook> will be called for each error with the object name as C<$_[0]> and the method name as C<$_[1]>. + +=item * + +Otherwise, a warning will be emitted for each indirect construct. + +=back + +=cut my $msg = sub { "Indirect call of method \"$_[1]\" on object \"$_[0]\"" }; sub unimport { - (undef, my $type) = @_; + shift; + + my $hook; + while (@_) { + my $arg = shift; + if ($arg eq 'hook') { + $hook = shift; + } elsif ($arg eq ':fatal') { + $hook = sub { die $msg->(@_) }; + } + last if $hook; + } + $hook = sub { warn $msg->(@_) } unless defined $hook; + $^H |= 0x00020000; - my $cb = (defined $type and $type eq ':fatal') - ? sub { die $msg->(@_) } - : sub { warn $msg->(@_) }; - $^H{+(__PACKAGE__)} = _tag($cb); + $^H{+(__PACKAGE__)} = _tag($hook); + + (); +} + +=head2 C + +Magically called at each C. Turns the module off. + +=cut + +sub import { + $^H{+(__PACKAGE__)} = undef; (); } diff --git a/t/10-args.t b/t/10-args.t index 6b7b61c..4db490c 100644 --- a/t/10-args.t +++ b/t/10-args.t @@ -1,17 +1,50 @@ -#!perl +#!perl -T use strict; use warnings; -use Test::More tests => 1; +use Test::More tests => 4 + 1 + 1; + +sub expect { + my ($pkg) = @_; + return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"/; +} + +{ + my @warns; + local $SIG{__WARN__} = sub { push @warns, "@_" }; + eval <<'HERE'; + die qq{ok\n}; + no indirect; + my $x = new Warn1; + $x = new Warn2; +HERE + my $w1 = shift @warns; + my $w2 = shift @warns; + is $@, "ok\n", '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'; +} + +{ + local $SIG{__WARN__} = sub { die "warn:@_" }; + eval <<'HERE'; + die qq{shouldn't even compile\n}; + no indirect ':fatal', hook => sub { die 'should not be called' }; + my $x = new Fatal; + $x = new NotReached; +HERE + like $@, expect('Fatal'), 'croaks when :fatal is specified'; +} { - local $SIG{__WARN__} = sub { die 'warn:' . join(' ', @_) }; - eval < sub { die 'hook:' . join(':', @_) . "\n" }, ':fatal'; + my $x = new Hooked; + $x = new AlsoNotReached; HERE - like($@, qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"Hlagh"/, 'croak when :fatal is specified'); + is $@, "hook:Hooked:new\n", 'calls the specified hook'; }