t/op/delete.t See if delete works
t/op/die_except.t See if die/eval avoids $@ clobberage
t/op/die_exit.t See if die and exit status interaction works
+t/op/die_keeperr.t See if G_KEEPERR works for destructors
t/op/die.t See if die works
t/op/dor.t See if defined-or (//) works
t/op/do.t See if subroutines work
hash actions codes defined in hv.h */
#define G_EVAL 8 /* Assume eval {} around subroutine call. */
#define G_NOARGS 16 /* Don't construct a @_ array. */
-#define G_KEEPERR 32 /* Append errors to $@, don't overwrite it */
+#define G_KEEPERR 32 /* Warn for errors, don't overwrite $@ */
#define G_NODEBUG 64 /* Disable debugging at toplevel. */
#define G_METHOD 128 /* Calling method. */
#define G_FAKINGEVAL 256 /* Faking an eval context for call_sv or
use strict;
# Test::More doesn't have fresh_perl_is() yet
-# use Test::More tests => 240;
+# use Test::More tests => 342;
BEGIN {
require '../../t/test.pl';
- plan(240);
+ plan(342);
use_ok('XS::APItest')
};
}
sub d {
- no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
die "its_dead_jim\n";
}
}
sub Foo::d {
- no warnings 'misc'; # keep G_KEEPERR from emitting this as a warning
die "its_dead_jim\n";
}
? [0] : [ undef, 1 ];
for my $keep (0, G_KEEPERR) {
my $desc = $description . ($keep ? ' G_KEEPERR' : '');
- my $exp_err = $keep ? "before\n\t(in cleanup) its_dead_jim\n"
+ my $exp_warn = $keep ? "\t(in cleanup) its_dead_jim\n" : "";
+ my $exp_err = $keep ? "before\n"
: "its_dead_jim\n";
+ my $warn;
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
$@ = "before\n";
+ $warn = "";
ok(eq_array( [ call_sv('d', $flags|G_EVAL|$keep, @$args) ],
$returnval),
"$desc G_EVAL call_sv('d')");
is($@, $exp_err, "$desc G_EVAL call_sv('d') - \$@");
+ is($warn, $exp_warn, "$desc G_EVAL call_sv('d') - warning");
$@ = "before\n";
+ $warn = "";
ok(eq_array( [ call_pv('d', $flags|G_EVAL|$keep, @$args) ],
$returnval),
"$desc G_EVAL call_pv('d')");
is($@, $exp_err, "$desc G_EVAL call_pv('d') - \$@");
+ is($warn, $exp_warn, "$desc G_EVAL call_pv('d') - warning");
$@ = "before\n";
+ $warn = "";
ok(eq_array( [ eval_sv('d()', $flags|$keep) ],
$returnval),
"$desc eval_sv('d()')");
is($@, $exp_err, "$desc eval_sv('d()') - \$@");
+ is($warn, $exp_warn, "$desc G_EVAL eval_sv('d') - warning");
$@ = "before\n";
+ $warn = "";
ok(eq_array( [ call_method('d', $flags|G_EVAL|$keep, $obj, @$args) ],
$returnval),
"$desc G_EVAL call_method('d')");
is($@, $exp_err, "$desc G_EVAL call_method('d') - \$@");
+ is($warn, $exp_warn, "$desc G_EVAL call_method('d') - warning");
}
ok(eq_array( [ sub { call_sv('f', $flags|G_NOARGS, "bad") }->(@$args) ],
};
+foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
+ foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
+ my $warn;
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ $@ = $outx;
+ $warn = "";
+ call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL);
+ ok ref($@) eq ref($inx) && $@ eq $inx;
+ $warn =~ s/ at [^\n]*\n\z//;
+ is $warn, "";
+ $@ = $outx;
+ $warn = "";
+ call_sv(sub { die $inx if $inx }, G_VOID|G_EVAL|G_KEEPERR);
+ ok ref($@) eq ref($outx) && $@ eq $outx;
+ $warn =~ s/ at [^\n]*\n\z//;
+ is $warn, $inx ? "\t(in cleanup) $inx" : "";
+ }
+}
+
+{
+ no warnings "misc";
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ call_sv(sub { die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
+ is $warn, "";
+}
+
+{
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ call_sv(sub { no warnings "misc"; die "aa\n" }, G_VOID|G_EVAL|G_KEEPERR);
+ is $warn, "\t(in cleanup) aa\n";
+}
+
is(eval_pv('f()', 0), 'y', "eval_pv('f()', 0)");
is(eval_pv('f(qw(a b c))', 0), 'y', "eval_pv('f(qw(a b c))', 0)");
is(eval_pv('d()', 0), undef, "eval_pv('d()', 0)");
=head2 G_KEEPERR
-You may have noticed that using the G_EVAL flag described above will
-B<always> clear the C<$@> variable and set it to a string describing
-the error iff there was an error in the called code. This unqualified
-resetting of C<$@> can be problematic in the reliable identification of
-errors using the C<eval {}> mechanism, because the possibility exists
-that perl will call other code (end of block processing code, for
-example) between the time the error causes C<$@> to be set within
-C<eval {}>, and the subsequent statement which checks for the value of
-C<$@> gets executed in the user's script.
-
-This scenario will mostly be applicable to code that is meant to be
-called from within destructors, asynchronous callbacks, signal
-handlers, C<__DIE__> or C<__WARN__> hooks, and C<tie> functions. In
-such situations, you will not want to clear C<$@> at all, but simply to
-append any new errors to any existing value of C<$@>.
+Using the G_EVAL flag described above will always set C<$@>: clearing
+it if there was no error, and setting it to describe the error if there
+was an error in the called code. This is what you want if your intention
+is to handle possible errors, but sometimes you just want to trap errors
+and stop them interfering with the rest of the program.
+
+This scenario will mostly be applicable to code that is meant to be called
+from within destructors, asynchronous callbacks, and signal handlers.
+In such situations, where the code being called has little relation to the
+surrounding dynamic context, the main program needs to be insulated from
+errors in the called code, even if they can't be handled intelligently.
+It may also be useful to do this with code for C<__DIE__> or C<__WARN__>
+hooks, and C<tie> functions.
The G_KEEPERR flag is meant to be used in conjunction with G_EVAL in
I<call_*> functions that are used to implement such code. This flag
has no effect when G_EVAL is not used.
-When G_KEEPERR is used, any errors in the called code will be prefixed
-with the string "\t(in cleanup)", and appended to the current value
-of C<$@>. an error will not be appended if that same error string is
-already at the end of C<$@>.
-
-In addition, a warning is generated using the appended string. This can be
-disabled using C<no warnings 'misc'>.
+When G_KEEPERR is used, any error in the called code will terminate the
+call as usual, and the error will not propagate beyond the call (as usual
+for G_EVAL), but it will not go into C<$@>. Instead the error will be
+converted into a warning, prefixed with the string "\t(in cleanup)".
+This can be disabled using C<no warnings 'misc'>. If there is no error,
+C<$@> will not be cleared.
The G_KEEPERR flag was introduced in Perl version 5.002.
sub foo { die "foo dies"; }
package main;
- eval { Foo->new->foo };
+ {
+ my $foo = Foo->new;
+ eval { $foo->foo };
+ }
print "Saw: $@" if $@; # should be, but isn't
This example will fail to recognize that an error occurred inside the
C<eval {}>. Here's why: the call_Subtract code got executed while perl
-was cleaning up temporaries when exiting the eval block, and because
+was cleaning up temporaries when exiting the outer braced block, and because
call_Subtract is implemented with I<call_pv> using the G_EVAL
flag, it promptly reset C<$@>. This results in the failure of the
outermost test for C<$@>, and thereby the failure of the error trap.
*msg ? msg : "Unknown error\n");
}
if (in_eval & EVAL_KEEPERR) {
- static const char prefix[] = "\t(in cleanup) ";
- SV * const err = ERRSV;
- const char *e = NULL;
- if (!SvPOK(err))
- sv_setpvs(err,"");
- else if (SvCUR(err) >= sizeof(prefix)+SvCUR(exceptsv)-1) {
- STRLEN len;
- STRLEN msglen;
- const char* message = SvPV_const(exceptsv, msglen);
- e = SvPV_const(err, len);
- e += len - msglen;
- if (*e != *message || strNE(e,message))
- e = NULL;
- }
- if (!e) {
- STRLEN start;
- SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(exceptsv));
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catsv(err, exceptsv);
- start = SvCUR(err)-SvCUR(exceptsv)-sizeof(prefix)+1;
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
- SvPVX_const(err)+start);
- }
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
+ SvPV_nolen_const(exceptsv));
}
else {
sv_setsv(ERRSV, exceptsv);
{ bless ['B'], 'Foo' for 1..10 }
EXPECT
(in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) A foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
+ (in cleanup) B foo bar at - line 4.
(in cleanup) B foo bar at - line 4.
########
# pp_ctl.c
--- /dev/null
+#!perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ require 'test.pl';
+ plan(20);
+}
+
+sub End::DESTROY { $_[0]->() }
+
+sub end(&) {
+ my($c) = @_;
+ return bless(sub { $c->() }, "End");
+}
+
+foreach my $inx ("", "aabbcc\n", [qw(aa bb cc)]) {
+ foreach my $outx ("", "xxyyzz\n", [qw(xx yy zz)]) {
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ {
+ $@ = $outx;
+ my $e = end { die $inx if $inx };
+ }
+ ok ref($@) eq ref($outx) && $@ eq $outx;
+ $warn =~ s/ at [^\n]*\n\z//;
+ is $warn, $inx ? "\t(in cleanup) $inx" : "";
+ }
+}
+
+{
+ no warnings "misc";
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ { my $e = end { die "aa\n"; }; }
+ is $warn, "";
+}
+
+{
+ my $warn = "";
+ local $SIG{__WARN__} = sub { $warn .= $_[0] };
+ { my $e = end { no warnings "misc"; die "aa\n"; }; }
+ is $warn, "\t(in cleanup) aa\n";
+}
+
+1;
projects / p5sagit/p5-mst-13.2.git / commitdiff