SCALAR/FIRSTKEY for tied hashes in scalar context

[p5sagit/p5-mst-13.2.git] / mg.c

diff --git a/mg.c b/mg.c
index df75970..2529ff7 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -623,8 +623,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                  SetLastError(dwErr);
             }
 #else
-            sv_setnv(sv, (NV)errno);
-            sv_setpv(sv, errno ? Strerror(errno) : "");
+            {
+                int saveerrno = errno;
+                sv_setnv(sv, (NV)errno);
+                sv_setpv(sv, errno ? Strerror(errno) : "");
+                errno = saveerrno;
+            }
 #endif
 #endif
 #endif
@@ -1534,6 +1538,12 @@ Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
     call_method("CLEAR", G_SCALAR|G_DISCARD);
     POPSTACK;
     LEAVE;
+
+    if (SvTYPE(sv) == SVt_PVHV)
+        /* must reset iterator otherwise Perl_magic_scalarpack
+         * wont report a false value on a cleared hash */
+        HvEITER((HV*)sv) = NULL;
+    
     return 0;
 }
 
@@ -1568,6 +1578,41 @@ Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
     return magic_methpack(sv,mg,"EXISTS");
 }
 
+SV *
+Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
+{
+    dSP;
+    SV *retval = &PL_sv_undef;
+    SV *tied = SvTIED_obj((SV*)hv, mg);
+    HV *pkg = SvSTASH((SV*)SvRV(tied));
+   
+    if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
+        SV *key;
+        if (HvEITER(hv))
+            /* we are in an iteration so the hash cannot be empty */
+            return &PL_sv_yes;
+        /* no xhv_eiter so now use FIRSTKEY */
+        key = sv_newmortal();
+        magic_nextpack((SV*)hv, mg, key);
+        HvEITER(hv) = NULL;     /* need to reset iterator */
+        return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
+    }
+   
+    /* there is a SCALAR method that we can call */
+    ENTER;
+    PUSHSTACKi(PERLSI_MAGIC);
+    PUSHMARK(SP);
+    EXTEND(SP, 1);
+    PUSHs(tied);
+    PUTBACK;
+
+    if (call_method("SCALAR", G_SCALAR))
+        retval = *PL_stack_sp--; 
+    POPSTACK;
+    LEAVE;
+    return retval;
+}
+
 int
 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -2068,7 +2113,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        break;
     case '\020':       /* ^P */
        PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
-       if (PL_perldb && !PL_DBsingle)
+       if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
+               && !PL_DBsingle)
            init_debugger();
        break;
     case '\024':       /* ^T */
@@ -2240,9 +2286,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_SETRESUID
       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
 #else
-       if (PL_uid == PL_euid)          /* special case $< = $> */
+       if (PL_uid == PL_euid) {                /* special case $< = $> */
+#ifdef PERL_DARWIN
+           /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
+           if (PL_uid != 0 && PerlProc_getuid() == 0)
+               (void)PerlProc_setuid(0);
+#endif
            (void)PerlProc_setuid(PL_uid);
-       else {
+       } else {
            PL_uid = PerlProc_getuid();
            Perl_croak(aTHX_ "setruid() not implemented");
        }
@@ -2395,10 +2446,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 #endif
        /* PL_origalen is set in perl_parse(). */
        s = SvPV_force(sv,len);
-       if (len >= (STRLEN)PL_origalen) {
-           /* Longer than original, will be truncated. */
-           Copy(s, PL_origargv[0], PL_origalen, char);
-           PL_origargv[0][PL_origalen - 1] = 0;
+       if (len >= (STRLEN)PL_origalen-1) {
+           /* Longer than original, will be truncated. We assume that
+             * PL_origalen bytes are available. */
+           Copy(s, PL_origargv[0], PL_origalen-1, char);
        }
        else {
            /* Shorter than original, will be padded. */
@@ -2411,9 +2462,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                    * --jhi */
                   (int)' ',
                   PL_origalen - len - 1);
-           for (i = 1; i < PL_origargc; i++)
-                PL_origargv[i] = 0;
        }
+       PL_origargv[0][PL_origalen-1] = 0;
+       for (i = 1; i < PL_origargc; i++)
+           PL_origargv[i] = 0;
        UNLOCK_DOLLARZERO_MUTEX;
        break;
 #endif
@@ -2573,6 +2625,13 @@ restore_magic(pTHX_ void *p)
 
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
     {
+#ifdef PERL_COPY_ON_WRITE
+       /* While magic was saved (and off) sv_setsv may well have seen
+          this SV as a prime candidate for COW.  */
+       if (SvIsCOW(sv))
+           sv_force_normal(sv);
+#endif
+
        if (mgs->mgs_flags)
            SvFLAGS(sv) |= mgs->mgs_flags;
        else