From: Vincent Pit <vince@profvince.com>
Date: Mon, 19 Jan 2009 23:53:19 +0000 (+0100)
Subject: A better fix for handling exceptions at compile time.
X-Git-Tag: v0.28~20
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=6e42ee234deb79fad1c91703e5a7ec3bd8bc47f3

A better fix for handling exceptions at compile time.

Also remove useless returns check for call_sv. It's called in scalar context, so it has to return exactly one scalar.
---

diff --git a/Magic.xs b/Magic.xs
index f2981d6..0ecf693 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -117,6 +117,16 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
 #endif
 
+#if VMG_HAS_PERL(5, 10, 0) || defined(PL_parser)
+# ifndef PL_error_count
+#  define PL_error_count PL_parser->error_count
+# endif
+#else
+# ifndef PL_error_count
+#  define PL_error_count PL_Ierror_count
+# endif
+#endif
+
 /* uvar magic and Hash::Util::FieldHash were commited with 28419 */
 #if VMG_HAS_PERL_MAINT(5, 9, 4, 28419) || VMG_HAS_PERL(5, 10, 0)
 # define VMG_UVAR 1
@@ -241,10 +251,8 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
 #define vmg_data_new(C, S, A) vmg_data_new(aTHX_ (C), (S), (A))
  SV *nsv;
  I32 i, alen = (args == NULL) ? 0 : av_len(args);
- I32 flags = G_SCALAR;
 
  dSP;
- int count;
 
  ENTER;
  SAVETMPS;
@@ -256,14 +264,10 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
   PUSHs(*av_fetch(args, i, 0));
  PUTBACK;
 
- if (IN_PERL_COMPILETIME)
-  flags |= G_EVAL | G_KEEPERR;
-
- count = call_sv(ctor, flags);
+ call_sv(ctor, G_SCALAR);
 
  SPAGAIN;
 
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
  nsv = POPs;
 #if VMG_HAS_PERL(5, 8, 3)
  SvREFCNT_inc(nsv);    /* Or it will be destroyed in FREETMPS */
@@ -466,15 +470,18 @@ STATIC UV vmg_dispell(pTHX_ SV *sv, U16 sig) {
 
 /* ... svt callbacks ....................................................... */
 
-STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
+#define VMG_CB_CALL_ARGS_MASK 15
+#define VMG_CB_CALL_EVAL      16
+
+STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int flags, ...){
  va_list ap;
  SV *svr;
  int ret;
  unsigned int i;
- I32 flags = G_SCALAR;
+ unsigned int args = flags & VMG_CB_CALL_ARGS_MASK;
+ unsigned int eval = flags & VMG_CB_CALL_EVAL ? G_EVAL : 0;
 
  dSP;
- int count;
 
  ENTER;
  SAVETMPS;
@@ -483,7 +490,7 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
  EXTEND(SP, args + 2);
  PUSHs(sv_2mortal(newRV_inc(sv)));
  PUSHs(data ? data : &PL_sv_undef);
- va_start(ap, args);
+ va_start(ap, flags);
  for (i = 0; i < args; ++i) {
   SV *sva = va_arg(ap, SV *);
   PUSHs(sva ? sva : &PL_sv_undef);
@@ -491,26 +498,24 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
  va_end(ap);
  PUTBACK;
 
- if (IN_PERL_COMPILETIME)
-  flags |= G_EVAL | G_KEEPERR;
-
- count = call_sv(cb, flags);
+ call_sv(cb, G_SCALAR | eval);
 
  SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
+ if (eval && IN_PERL_COMPILETIME && SvTRUE(ERRSV))
+  ++PL_error_count;
  svr = POPs;
  ret = SvOK(svr) ? SvIV(svr) : 0;
-
  PUTBACK;
 
  FREETMPS;
  LEAVE;
 
+
  return ret;
 }
 
 #define vmg_cb_call1(I, S, D)         vmg_cb_call(aTHX_ (I), (S), (D), 0)
+#define vmg_cb_call1e(I, S, D)        vmg_cb_call(aTHX_ (I), (S), (D), VMG_CB_CALL_EVAL)
 #define vmg_cb_call2(I, S, D, S2)     vmg_cb_call(aTHX_ (I), (S), (D), 1, (S2))
 #define vmg_cb_call3(I, S, D, S2, S3) vmg_cb_call(aTHX_ (I), (S), (D), 2, (S2), (S3))
 
@@ -526,7 +531,6 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  SV *svr;
  I32 len, has_array;
  U32 ret;
- I32 flags = G_SCALAR;
 
  dSP;
  int count;
@@ -549,17 +553,11 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  }
  PUTBACK;
 
- if (IN_PERL_COMPILETIME)
-  flags |= G_EVAL | G_KEEPERR;
-
- count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, flags);
+ count = call_sv(SV2MGWIZ(mg->mg_ptr)->cb_len, G_SCALAR);
 
  SPAGAIN;
-
- if (count != 1) { croak("Callback needs to return 1 scalar\n"); }
  svr = POPs;
  ret = SvOK(svr) ? SvUV(svr) : len;
-
  PUTBACK;
 
  FREETMPS;
@@ -583,7 +581,7 @@ STATIC int vmg_svt_free(pTHX_ SV *sv, MAGIC *mg) {
 #endif
  /* Perl_mg_free will get rid of the magic and decrement mg->mg_obj and
   * mg->mg_ptr reference count */
- return vmg_cb_call1(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
+ return vmg_cb_call1e(SV2MGWIZ(mg->mg_ptr)->cb_free, sv, mg->mg_obj);
 }
 
 #if MGf_COPY
diff --git a/t/14-callbacks.t b/t/14-callbacks.t
index 3cc6d93..e14d570 100644
--- a/t/14-callbacks.t
+++ b/t/14-callbacks.t
@@ -54,7 +54,7 @@ is_deeply(\@callers, [
  @callers = ();
  my $u = $b;
  is_deeply(\@callers, [
-  [ 'main', $0, __LINE__-2 ]
+  [ 'main', $0, __LINE__-2 ],
  ], 'caller into callback into block returns the right thing');
 }
 
@@ -62,6 +62,5 @@ is_deeply(\@callers, [
 eval { my $u = $b };
 is($@, '', 'caller into callback doesn\'t croak');
 is_deeply(\@callers, [
- [ 'main', $0, __LINE__-3 ],
- [ 'main', $0, __LINE__-4 ],
+ ([ 'main', $0, __LINE__-3 ]) x 2,
 ], 'caller into callback into eval returns the right thing');
diff --git a/t/17-ctl.t b/t/17-ctl.t
index e694a16..ded9d63 100644
--- a/t/17-ctl.t
+++ b/t/17-ctl.t
@@ -3,20 +3,74 @@
 use strict;
 use warnings;
 
-use Test::More tests => 1;
+use Test::More tests => 7;
 
-use Variable::Magic qw/wizard cast getdata/;
+use Variable::Magic qw/wizard cast/;
+
+my $wiz;
+
+eval {
+ $wiz = wizard data => sub { $_[1]->() };
+ my $x;
+ cast $x, $wiz, sub { die "carrot" };
+};
+
+like $@, qr/carrot/, 'die in data callback';
+
+eval {
+ $wiz = wizard data => sub { $_[1] },
+               set  => sub { $_[1]->(); () };
+ my $x;
+ cast $x, $wiz, sub { die "lettuce" };
+ $x = 5;
+};
+
+like $@, qr/lettuce/, 'die in set callback';
+
+my $res = eval {
+ $wiz = wizard data => sub { $_[1] },
+               len  => sub { $_[1]->(); () };
+ my @a = (1 .. 3);
+ cast @a, $wiz, sub { die "potato" };
+ @a;
+};
+
+like $@, qr/potato/, 'die in len callback';
+
+eval {
+ $wiz = wizard data => sub { $_[1] },
+               free => sub { $_[1]->(); () };
+ my $x;
+ cast $x, $wiz, sub { die "spinach" };
+};
+
+like $@, qr/spinach/, 'die in free callback';
 
 # Inspired by B::Hooks::EndOfScope
-# This test is better be left at the beginning of the file, since problems
-# happen at UNITCHECK time
 
-my $wiz;
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1]->() };
+ my $x;
+ cast $x, $wiz, sub { die "pumpkin" };
+}};
 
-BEGIN {
- $wiz = wizard data => sub { $_[1] }, free => sub { $_[1]->(); () };
+like $@, qr/pumpkin/, 'die in data callback in BEGIN';
+
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1] },
+               free => sub { $_[1]->(); () };
  $^H |= 0x020000;
- cast %^H, $wiz, sub { die "harmless" };
-}
+ cast %^H, $wiz, sub { die "macaroni" };
+}};
+
+like $@, qr/macaroni/, 'die in free callback in BEGIN';
+
+eval q{BEGIN {
+ $wiz = wizard data => sub { $_[1] },
+               len  => sub { $_[1]->(); $_[2] },
+               free => sub { my $x = @{$_[0]}; () };
+ my @a = (1 .. 5);
+ cast @a, $wiz, sub { die "pepperoni" };
+}};
 
-pass 'die in free callback in BEGIN didn\'t segfault';
+like $@, qr/pepperoni/, 'die in len callback in BEGIN';