A better fix for handling exceptions at compile time.

[perl/modules/Variable-Magic.git] / Magic.xs

diff --git a/Magic.xs b/Magic.xs
index 1b63117385baadf79db86a09695025d9616a717f..0ecf6933caf6975cf3b3388152a4b25b3b63cf4a 100644 (file)
--- a/Magic.xs
+++ b/Magic.xs
@@ -113,6 +113,20 @@ STATIC SV *vmg_clone(pTHX_ SV *sv, tTHX owner) {
 # define MGf_LOCAL 0
 #endif
 
+#ifndef IN_PERL_COMPILETIME
+# 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
@@ -239,7 +253,6 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
  I32 i, alen = (args == NULL) ? 0 : av_len(args);
 
  dSP;
- int count;
 
  ENTER;
  SAVETMPS;
@@ -251,11 +264,10 @@ STATIC SV *vmg_data_new(pTHX_ SV *ctor, SV *sv, AV *args) {
   PUSHs(*av_fetch(args, i, 0));
  PUTBACK;
 
- count = call_sv(ctor, G_SCALAR);
+ 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 */
@@ -458,14 +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;
+ 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;
@@ -474,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);
@@ -482,23 +498,24 @@ STATIC int vmg_cb_call(pTHX_ SV *cb, SV *sv, SV *data, unsigned int args, ...) {
  va_end(ap);
  PUTBACK;
 
- count = call_sv(cb, G_SCALAR);
+ 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))
 
@@ -512,12 +529,14 @@ STATIC int vmg_svt_set(pTHX_ SV *sv, MAGIC *mg) {
 
 STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  SV *svr;
- I32 len;
+ I32 len, has_array;
  U32 ret;
 
  dSP;
  int count;
 
+ has_array = SvTYPE(sv) == SVt_PVAV;
+
  ENTER;
  SAVETMPS;
 
@@ -525,11 +544,11 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  EXTEND(SP, 3);
  PUSHs(sv_2mortal(newRV_inc(sv)));
  PUSHs(mg->mg_obj ? mg->mg_obj : &PL_sv_undef);
- if (SvTYPE(sv) == SVt_PVAV) {
+ if (has_array) {
   len = av_len((AV *) sv) + 1;
   mPUSHi(len);
  } else {
-  len = 1;
+  len = 0;
   PUSHs(&PL_sv_undef);
  }
  PUTBACK;
@@ -537,17 +556,14 @@ STATIC U32 vmg_svt_len(pTHX_ SV *sv, MAGIC *mg) {
  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;
  LEAVE;
 
- return ret - 1;
+ return has_array ? ret - 1 : ret;
 }
 
 STATIC int vmg_svt_clear(pTHX_ SV *sv, MAGIC *mg) {
@@ -565,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
@@ -721,7 +737,6 @@ STATIC MGVTBL vmg_wizard_vtbl = {
 };
 
 STATIC const char vmg_invalid_wiz[]    = "Invalid wizard object";
-STATIC const char vmg_invalid_sv[]     = "Invalid variable";
 STATIC const char vmg_invalid_sig[]    = "Invalid numeric signature";
 STATIC const char vmg_wrongargnum[]    = "Wrong number of arguments";
 STATIC const char vmg_toomanysigs[]    = "Too many magic signatures used";