From: Vincent Pit Date: Sun, 23 Oct 2011 09:49:47 +0000 (+0200) Subject: Forbid passing 'hook' and 'fatal' at the same time X-Git-Tag: v0.26~6 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=75a60b70d39a18521fcf5c2fbc7266100da27110;p=perl%2Fmodules%2Findirect.git Forbid passing 'hook' and 'fatal' at the same time Carp is required. --- diff --git a/Makefile.PL b/Makefile.PL index e00e6f1..c421a46 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -26,6 +26,7 @@ my $dist = 'indirect'; $file = "lib/$file.pm"; my %PREREQ_PM = ( + 'Carp' => 0, 'XSLoader' => 0, ); diff --git a/lib/indirect.pm b/lib/indirect.pm index 1c4d065..1e08274 100644 --- a/lib/indirect.pm +++ b/lib/indirect.pm @@ -90,11 +90,15 @@ The policy to apply depends on what is first found in C<@opts> : 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. @@ -124,24 +128,32 @@ Note that if another policy is installed by a C statement further i =cut +sub _no_hook_and_fatal { + require Carp; + Carp::croak("The 'fatal' and 'hook' options are mutually exclusive"); +} + sub unimport { shift; - my $hook; - my $global; + my ($global, $fatal, $hook); + while (@_) { my $arg = shift; if ($arg eq 'hook') { - last if $hook; + _no_hook_and_fatal() if $fatal; $hook = shift; } elsif ($arg =~ /^:?fatal$/i) { - last if $hook; - $hook = sub { die msg(@_) }; + _no_hook_and_fatal() if defined $hook; + $fatal = 1; } elsif ($arg =~ /^:?global$/i) { $global = 1; } } - $hook = sub { warn msg(@_) } unless defined $hook; + + unless (defined $hook) { + $hook = $fatal ? sub { die msg(@_) } : sub { warn msg(@_) }; + } $^H |= 0x00020000; if ($global) { @@ -237,7 +249,7 @@ 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.006). +L (standard since perl 5), L (since perl 5.006). =head1 AUTHOR diff --git a/t/10-args.t b/t/10-args.t index bacf850..444c730 100644 --- a/t/10-args.t +++ b/t/10-args.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 4 + 3 + 1; +use Test::More tests => 4 + 3 + 1 + 2; BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } @@ -36,7 +36,7 @@ for my $fatal (':fatal', 'FATAL', ':Fatal') { 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' }; + no indirect '$fatal'; my \$x = new Croaked; \$x = new NotReached; HERE @@ -49,10 +49,34 @@ for my $fatal (':fatal', 'FATAL', ':Fatal') { local $SIG{__WARN__} = sub { "warn:@_" }; eval <<' HERE'; die qq{shouldn't even compile\n}; - no indirect 'whatever', hook => sub { die 'hook:' . join(':', @_) . "\n" }, ':fatal'; + 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'; +}