Changes to perlfaq8 "How do I find out if I'm running interactively

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

diff --git a/sv.c b/sv.c
index 8e90234..df5a556 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1738,7 +1738,11 @@ S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
           can tail call us and return true.  */
        return (char *) 1;
     } else {
-       return SvPV(buffer, *len);
+       assert(SvPOK(buffer));
+       if (len) {
+           *len = SvCUR(buffer);
+       }
+       return SvPVX(buffer);
     }
 }
 
@@ -3305,8 +3309,9 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
                        }
                    }
                if (!intro)
-                   cv_ckproto(cv, (GV*)dstr,
-                              SvPOK(sref) ? SvPVX_const(sref) : NULL);
+                   cv_ckproto_len(cv, (GV*)dstr,
+                                  SvPOK(sref) ? SvPVX_const(sref) : NULL,
+                                  SvPOK(sref) ? SvCUR(sref) : 0);
            }
            GvCVGEN(dstr) = 0; /* Switch off cacheness. */
            GvASSUMECV_on(dstr);
@@ -3881,21 +3886,27 @@ Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
 }
 
 /*
-=for apidoc sv_usepvn
-
-Tells an SV to use C<ptr> to find its string value.  Normally the string is
-stored inside the SV but sv_usepvn allows the SV to use an outside string.
-The C<ptr> should point to memory that was allocated by C<malloc>.  The
-string length, C<len>, must be supplied.  This function will realloc the
-memory pointed to by C<ptr>, so that pointer should not be freed or used by
-the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
-See C<sv_usepvn_mg>.
+=for apidoc sv_usepvn_flags
+
+Tells an SV to use C<ptr> to find its string value.  Normally the
+string is stored inside the SV but sv_usepvn allows the SV to use an
+outside string.  The C<ptr> should point to memory that was allocated
+by C<malloc>.  The string length, C<len>, must be supplied.  By default
+this function will realloc (i.e. move) the memory pointed to by C<ptr>,
+so that pointer should not be freed or used by the programmer after
+giving it to sv_usepvn, and neither should any pointers from "behind"
+that pointer (e.g. ptr + 1) be used.
+
+If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
+SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
+C<len>, and already meets the requirements for storing in C<SvPVX>)
 
 =cut
 */
 
 void
-Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
+Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags)
 {
     dVAR;
     STRLEN allocate;
@@ -3903,34 +3914,43 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
     SvUPGRADE(sv, SVt_PV);
     if (!ptr) {
        (void)SvOK_off(sv);
+       if (flags & SV_SMAGIC)
+           SvSETMAGIC(sv);
        return;
     }
     if (SvPVX_const(sv))
        SvPV_free(sv);
 
-    allocate = PERL_STRLEN_ROUNDUP(len + 1);
-    ptr = saferealloc (ptr, allocate);
+    if (flags & SV_HAS_TRAILING_NUL)
+       assert(ptr[len] == '\0');
+
+    allocate = (flags & SV_HAS_TRAILING_NUL)
+       ? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
+    if (flags & SV_HAS_TRAILING_NUL) {
+       /* It's long enough - do nothing.
+          Specfically Perl_newCONSTSUB is relying on this.  */
+    } else {
+#ifdef DEBUGGING
+       /* Force a move to shake out bugs in callers.  */
+       char *new_ptr = safemalloc(allocate);
+       Copy(ptr, new_ptr, len, char);
+       PoisonFree(ptr,len,char);
+       Safefree(ptr);
+       ptr = new_ptr;
+#else
+       ptr = saferealloc (ptr, allocate);
+#endif
+    }
     SvPV_set(sv, ptr);
     SvCUR_set(sv, len);
     SvLEN_set(sv, allocate);
-    *SvEND(sv) = '\0';
+    if (!(flags & SV_HAS_TRAILING_NUL)) {
+       *SvEND(sv) = '\0';
+    }
     (void)SvPOK_only_UTF8(sv);         /* validate pointer */
     SvTAINT(sv);
-}
-
-/*
-=for apidoc sv_usepvn_mg
-
-Like C<sv_usepvn>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
-{
-    sv_usepvn(sv,ptr,len);
-    SvSETMAGIC(sv);
+    if (flags & SV_SMAGIC)
+       SvSETMAGIC(sv);
 }
 
 #ifdef PERL_OLD_COPY_ON_WRITE
@@ -10675,21 +10695,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 #endif
                break;
            }
-       case SAVEt_COP_WARNINGS:
-           {
-               void *optr = POPPTR(ss,ix);
-               TOPPTR(nss,ix) = ptr = any_dup(optr, proto_perl);
-               if (ptr != optr) {
-                   /* We duped something in the interpreter structure.  */
-                   ptr = POPPTR(ss,ix);
-                   TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
-               } else {
-                   /* I don't think that this happens, but it would mean that
-                      we (didn't) dup something shared.  */
-                   ptr = POPPTR(ss,ix);
-                   TOPPTR(nss,ix) = ptr;
-               }
-           }
+       case SAVEt_COMPILE_WARNINGS:
+           ptr = POPPTR(ss,ix);
+           TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
            break;
        default:
            Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i);