X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FScope-Upper.git;a=blobdiff_plain;f=Upper.xs;h=0c762de1dcb947d420bd265d01231d8cec433d7e;hp=6f28120f08e05e210af8678940ed49fc756e8386;hb=HEAD;hpb=3c2c6ae79844c468194a77f080e5fb2002335544

diff --git a/Upper.xs b/Upper.xs
index 6f28120..7be4f69 100644
--- a/Upper.xs
+++ b/Upper.xs
@@ -808,25 +808,31 @@ typedef struct {
 
 static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *elem) {
 #define su_ud_localize_init(UD, S, V, E) su_ud_localize_init(aTHX_ (UD), (S), (V), (E))
- UV deref = 0;
- svtype t = SVt_NULL;
- I32 size;
+ int take_ref = 0;
+ svtype     t = SVt_NULL;
+ I32     size;
 
  SvREFCNT_inc_simple_void(sv);
 
  if (SvTYPE(sv) >= SVt_PVGV) {
+  if (SvFAKE(sv)) {
+   sv_force_normal(sv);
+   goto string_spec;
+  }
+
   if (!val || !SvROK(val)) { /* local *x; or local *x = $val; */
    t = SVt_PVGV;
   } else {                   /* local *x = \$val; */
    t = SvTYPE(SvRV(val));
-   deref = 1;
   }
  } else if (SvROK(sv)) {
   croak("Invalid %s reference as the localization target",
                  sv_reftype(SvRV(sv), 0));
  } else {
   STRLEN len, l;
-  const char *p = SvPV_const(sv, len), *s;
+  const char *p, *s;
+string_spec:
+  p = SvPV_const(sv, len);
   for (s = p, l = len; l > 0 && isSPACE(*s); ++s, --l) { }
   if (!l) {
    l = len;
@@ -842,14 +848,17 @@ static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *el
   if (t != SVt_NULL) {
    ++s;
    --l;
+   if (t == SVt_PV)
+    take_ref = 1;
   } else if (val) { /* t == SVt_NULL, type can't be inferred from the sigil */
    if (SvROK(val) && !sv_isobject(val)) {
     t = SvTYPE(SvRV(val));
-    deref = 1;
    } else {
     t = SvTYPE(val);
+    take_ref = 1;
    }
   }
+
   SvREFCNT_dec(sv);
   sv = newSVpvn(s, l);
  }
@@ -858,31 +867,31 @@ static I32 su_ud_localize_init(pTHX_ su_ud_localize *ud, SV *sv, SV *val, SV *el
   case SVt_PVAV:
    size  = elem ? SU_SAVE_AELEM_OR_ADELETE_SIZE
                 : SU_SAVE_ARY_SIZE;
-   deref = 0;
    break;
   case SVt_PVHV:
    size  = elem ? SU_SAVE_HELEM_OR_HDELETE_SIZE
                 : SU_SAVE_HASH_SIZE;
-   deref = 0;
    break;
   case SVt_PVGV:
    size  = SU_SAVE_GP_SIZE;
-   deref = 0;
    break;
   case SVt_PVCV:
    size  = SU_SAVE_GVCV_SIZE;
-   deref = 0;
    break;
   default:
    size = SU_SAVE_SCALAR_SIZE;
    break;
  }
- /* When deref is set, val isn't NULL */
 
  SU_UD_PRIVATE(ud) = t;
 
  ud->sv   = sv;
- ud->val  = val ? newSVsv(deref ? SvRV(val) : val) : NULL;
+ if (val) {
+  val     = newSVsv(val);
+  ud->val = take_ref ? newRV_noinc(val) : val;
+ } else {
+  ud->val = NULL;
+ }
  ud->elem = SvREFCNT_inc(elem);
 
  return size;
@@ -957,7 +966,7 @@ static void su_localize(pTHX_ void *ud_) {
    su_save_gvcv(gv);
    break;
   default:
-   gv = (GV *) save_scalar(gv);
+   save_scalar(gv);
    break;
  }
 
@@ -2013,16 +2022,23 @@ static int su_uplevel_runops_hook_entersub(pTHX) {
   */
  assert(sud);
  if (sud->argarray) {
+  I32 fill;
   AV *av = newAV();
   AvREAL_off(av);
   AvREIFY_on(av);
-  av_extend(av, AvMAX(sud->argarray));
-  AvFILLp(av) = AvFILLp(sud->argarray);
-  Copy(AvARRAY(sud->argarray), AvARRAY(av), AvFILLp(av) + 1, SV *);
 
+  fill = AvFILLp(sud->argarray);
+  if (fill >= 0) {
+   av_extend(av, fill);
+   Copy(AvARRAY(sud->argarray), AvARRAY(av), fill + 1, SV *);
+   AvFILLp(av) = fill;
+  }
+
+#if !XSH_HAS_PERL(5, 37, 10)
   /* should be referenced by PL_curpad[0] and *_ */
   assert(SvREFCNT(PL_curpad[0]) > 1);
   SvREFCNT_dec(PL_curpad[0]);
+#endif
 
   PL_curpad[0] = (SV *) av;
  }
@@ -3122,7 +3138,9 @@ PPCODE:
  /* warnings (9) */
  {
   SV *mask = NULL;
-#if XSH_HAS_PERL(5, 9, 4)
+#if XSH_HAS_PERL(5, 37, 6)
+  char *old_warnings = cop->cop_warnings;
+#elif XSH_HAS_PERL(5, 9, 4)
   STRLEN *old_warnings = cop->cop_warnings;
 #else
   SV *old_warnings = cop->cop_warnings;
@@ -3155,7 +3173,9 @@ context_info_warnings_on:
    if (!mask)
     mask = su_newmortal_pvn(WARN_ALLstring, WARNsize);
   } else {
-#if XSH_HAS_PERL(5, 9, 4)
+#if XSH_HAS_PERL(5, 37, 6)
+   mask = su_newmortal_pvn((char *) old_warnings, RCPV_LEN(old_warnings));
+#elif XSH_HAS_PERL(5, 9, 4)
    mask = su_newmortal_pvn((char *) (old_warnings + 1), old_warnings[0]);
 #else
    mask = sv_mortalcopy(old_warnings);