Upgrade to CGI.pm-3.31. Includes version bump to CGI::Carp due to a Pod fix.

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

diff --git a/sv.c b/sv.c
index bf2e8c8..718e305 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -544,7 +544,8 @@ Perl_sv_clean_all(pTHX)
   memory in the last arena-set (1/2 on average).  In trade, we get
   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
   smaller types).  The recovery of the wasted space allows use of
-  small arenas for large, rare body types,
+  small arenas for large, rare body types, by changing array* fields
+  in body_details_by_type[] below.
 */
 struct arena_desc {
     char       *arena;         /* the raw storage, allocated aligned */
@@ -555,7 +556,7 @@ struct arena_desc {
 struct arena_set;
 
 /* Get the maximum number of elements in set[] such that struct arena_set
-   will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and
+   will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
    therefore likely to be 1 aligned memory page.  */
 
 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
@@ -2501,6 +2502,29 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     return SvNVX(sv);
 }
 
+/*
+=for apidoc sv_2num
+
+Return an SV with the numeric value of the source SV, doing any necessary
+reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
+access this function.
+
+=cut
+*/
+
+SV *
+Perl_sv_2num(pTHX_ register SV *sv)
+{
+    if (!SvROK(sv))
+       return sv;
+    if (SvAMAGIC(sv)) {
+       SV * const tmpsv = AMG_CALLun(sv,numer);
+       if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
+           return sv_2num(tmpsv);
+    }
+    return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
+}
+
 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
  * UV as a string towards the end of buf, and return pointers to start and
  * end of it.
@@ -5075,7 +5099,9 @@ Perl_sv_clear(pTHX_ register SV *sv)
     }
 
     if (SvOBJECT(sv)) {
-       if (PL_defstash) {              /* Still have a symbol table? */
+       if (PL_defstash &&      /* Still have a symbol table? */
+           SvDESTROYABLE(sv))
+       {
            dSP;
            HV* stash;
            do {        
@@ -7953,6 +7979,8 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash)
         Perl_croak(aTHX_ "Can't bless non-reference value");
     tmpRef = SvRV(sv);
     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
+       if (SvIsCOW(tmpRef))
+           sv_force_normal_flags(tmpRef, 0);
        if (SvREADONLY(tmpRef))
            Perl_croak(aTHX_ PL_no_modify);
        if (SvOBJECT(tmpRef)) {
@@ -8603,10 +8631,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                %p              include pointer address (standard)      
                %-p     (SVf)   include an SV (previously %_)
                %-<num>p        include an SV with precision <num>      
-               %1p     (VDf)   include a v-string (as %vd)
                %<num>p         reserved for future extensions
 
        Robin Barker 2005-07-14
+
+               %1p     (VDf)   removed.  RMB 2007-10-19
 */
            char* r = q; 
            bool sv = FALSE;    
@@ -8626,13 +8655,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                        is_utf8 = TRUE;
                    goto string;
                }
-#if vdNUMBER
-               else if (n == vdNUMBER) {       /* VDf */
-                   vectorize = TRUE;
-                   VECTORIZE_ARGS
-                   goto format_vd;
-               }
-#endif
                else if (n) {
                    if (ckWARN_d(WARN_INTERNAL))
                        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
@@ -9998,10 +10020,10 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
         /** We are joining here so we don't want do clone
            something that is bad **/
        if (SvTYPE(sstr) == SVt_PVHV) {
-           const char * const hvname = HvNAME_get(sstr);
+           const HEK * const hvname = HvNAME_HEK(sstr);
            if (hvname)
                /** don't clone stashes if they already exist **/
-               return (SV*)gv_stashpv(hvname,0);
+               return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
         }
     }
 
@@ -10031,8 +10053,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
 
     /* don't clone objects whose class has asked us not to */
     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
-       SvFLAGS(dstr) &= ~SVTYPEMASK;
-       SvOBJECT_off(dstr);
+       SvFLAGS(dstr) = 0;
        return dstr;
     }
 
@@ -11349,6 +11370,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_lockhook                = proto_perl->Ilockhook;
     PL_unlockhook      = proto_perl->Iunlockhook;
     PL_threadhook      = proto_perl->Ithreadhook;
+    PL_destroyhook     = proto_perl->Idestroyhook;
 
 #ifdef THREADS_HAVE_PIDS
     PL_ppid            = proto_perl->Ippid;
@@ -12072,10 +12094,18 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
 
     case OP_RV2SV:
     case OP_CUSTOM:
-    case OP_ENTERSUB:
        match = 1; /* XS or custom code could trigger random warnings */
        goto do_op;
 
+    case OP_ENTERSUB:
+    case OP_GOTO:
+       /* XXX tmp hack: these two may call an XS sub, and currently
+         XS subs don't have a SUB entry on the context stack, so CV and
+         pad determination goes wrong, and BAD things happen. So, just
+         don't try to determine the value under those circumstances.
+         Need a better fix at dome point. DAPM 11/2007 */
+       break;
+
     case OP_POS:
        /* def-ness of rval pos() is independent of the def-ness of its arg */
        if ( !(obase->op_flags & OPf_MOD))