Don't test the core XS code yet with PERL_DEBUG_COW > 1

[perl5.git] / util.c

diff --git a/util.c b/util.c
index cb3774e..ae831e4 100644 (file)
--- a/util.c
+++ b/util.c
@@ -261,7 +261,6 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons
 char *
 Perl_instr(pTHX_ register const char *big, register const char *little)
 {
-    register const char *s, *x;
     register I32 first;
 
     if (!little)
@@ -270,6 +269,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
     if (!first)
        return (char*)big;
     while (*big) {
+       register const char *s, *x;
        if (*big++ != first)
            continue;
        for (x=big,s=little; *s; /**/ ) {
@@ -291,7 +291,6 @@ Perl_instr(pTHX_ register const char *big, register const char *little)
 char *
 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 {
-    register const char *s, *x;
     register const I32 first = *little;
     register const char *littleend = lend;
 
@@ -301,6 +300,7 @@ Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const c
        return Nullch;
     bigend -= littleend - little++;
     while (big <= bigend) {
+       register const char *s, *x;
        if (*big++ != first)
            continue;
        for (x=big,s=little; s < littleend; /**/ ) {
@@ -321,7 +321,6 @@ char *
 Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
 {
     register const char *bigbeg;
-    register const char *s, *x;
     register const I32 first = *little;
     register const char *littleend = lend;
 
@@ -330,6 +329,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
     bigbeg = big;
     big = bigend - (littleend - little++);
     while (big >= bigbeg) {
+       register const char *s, *x;
        if (*big-- != first)
            continue;
        for (x=big+2,s=little; s < littleend; /**/ ) {
@@ -366,7 +366,7 @@ Analyses the string in order to make fast searches on it using fbm_instr()
 void
 Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
 {
-    register U8 *s;
+    const register U8 *s;
     register U8 *table;
     register U32 i;
     STRLEN len;
@@ -379,20 +379,16 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
        if (mg && mg->mg_len >= 0)
            mg->mg_len++;
     }
-    s = (U8*)SvPV_force(sv, len);
+    s = (U8*)SvPV_force_mutable(sv, len);
     SvUPGRADE(sv, SVt_PVBM);
     if (len == 0)              /* TAIL might be on a zero-length string. */
        return;
     if (len > 2) {
-       U8 mlen;
-       unsigned char *sb;
+       const unsigned char *sb;
+       const U8 mlen = (len>255) ? 255 : (U8)len;
 
-       if (len > 255)
-           mlen = 255;
-       else
-           mlen = (U8)len;
        Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
-       table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
+       table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
        s = table - 1 - FBM_TABLE_OFFSET;       /* last char */
        memset((void*)table, mlen, 256);
        table[-1] = (U8)flags;
@@ -407,7 +403,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
     sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0);    /* deep magic */
     SvVALID_on(sv);
 
-    s = (unsigned char*)(SvPVX(sv));           /* deeper magic */
+    s = (const unsigned char*)(SvPVX_const(sv));       /* deeper magic */
     for (i = 0; i < len; i++) {
        if (PL_freq[s[i]] < frequency) {
            rarest = i;
@@ -443,7 +439,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 {
     register unsigned char *s;
     STRLEN l;
-    register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
+    register const unsigned char *little
+       = (const unsigned char *)SvPV_const(littlestr,l);
     register STRLEN littlelen = l;
     register const I32 multiline = flags & FBMrf_MULTILINE;
 
@@ -491,8 +488,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            /* This should be better than FBM if c1 == c2, and almost
               as good otherwise: maybe better since we do less indirection.
               And we save a lot of memory by caching no table. */
-           register unsigned char c1 = little[0];
-           register unsigned char c2 = little[1];
+           const unsigned char c1 = little[0];
+           const unsigned char c2 = little[1];
 
            s = big + 1;
            bigend--;
@@ -574,7 +571,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 
     {  /* Do actual FBM.  */
        register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
-       register unsigned char *oldlittle;
+       const register unsigned char *oldlittle;
 
        if (littlelen > (STRLEN)(bigend - big))
            return Nullch;
@@ -594,7 +591,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
                goto check_end;
            }
            else {              /* less expensive than calling strncmp() */
-               register unsigned char *olds = s;
+               register unsigned char * const olds = s;
 
                tmp = littlelen;
 
@@ -637,7 +634,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 char *
 Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
 {
-    register unsigned char *s, *x;
     register unsigned char *big;
     register I32 pos;
     register I32 previous;
@@ -686,6 +682,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     }
     big -= previous;
     do {
+       register unsigned char *s, *x;
        if (pos >= stop_pos) break;
        if (big[pos] != first)
            continue;
@@ -764,20 +761,15 @@ be freed with the C<Safefree()> function.
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
-    register char *newaddr;
-#ifdef PERL_MALLOC_WRAP
-    STRLEN pvlen;
-#endif
     if (!pv)
        return Nullch;
+    else {
+       char *newaddr;
+       const STRLEN pvlen = strlen(pv)+1;
+       New(902,newaddr,pvlen,char);
+       return strcpy(newaddr,pv);
+    }
 
-#ifdef PERL_MALLOC_WRAP
-    pvlen = strlen(pv)+1;
-    New(902,newaddr,pvlen,char);
-#else
-    New(902,newaddr,strlen(pv)+1,char);
-#endif
-    return strcpy(newaddr,pv);
 }
 
 /* same thing but with a known length */
@@ -847,7 +839,7 @@ char *
 Perl_savesvpv(pTHX_ SV *sv)
 {
     STRLEN len;
-    const char *pv = SvPV(sv, len);
+    const char *pv = SvPV_const(sv, len);
     register char *newaddr;
 
     ++len;
@@ -1075,40 +1067,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
 
 /* Common code used by vcroak, vdie and vwarner  */
 
-void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8);
-
-STATIC char *
-S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
-                   I32* utf8)
-{
-    dVAR;
-    char *message;
-
-    if (pat) {
-       SV *msv = vmess(pat, args);
-       if (PL_errors && SvCUR(PL_errors)) {
-           sv_catsv(PL_errors, msv);
-           message = SvPV(PL_errors, *msglen);
-           SvCUR_set(PL_errors, 0);
-       }
-       else
-           message = SvPV(msv,*msglen);
-       *utf8 = SvUTF8(msv);
-    }
-    else {
-       message = Nullch;
-    }
-
-    DEBUG_S(PerlIO_printf(Perl_debug_log,
-                         "%p: die/croak: message = %s\ndiehook = %p\n",
-                         thr, message, PL_diehook));
-    if (PL_diehook) {
-       S_vdie_common(aTHX_ message, *msglen, *utf8);
-    }
-    return message;
-}
-
-void
+STATIC void
 S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
 {
     HV *stash;
@@ -1149,6 +1108,37 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8)
     }
 }
 
+STATIC char *
+S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen,
+                   I32* utf8)
+{
+    dVAR;
+    char *message;
+
+    if (pat) {
+       SV *msv = vmess(pat, args);
+       if (PL_errors && SvCUR(PL_errors)) {
+           sv_catsv(PL_errors, msv);
+           message = SvPV(PL_errors, *msglen);
+           SvCUR_set(PL_errors, 0);
+       }
+       else
+           message = SvPV(msv,*msglen);
+       *utf8 = SvUTF8(msv);
+    }
+    else {
+       message = Nullch;
+    }
+
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
+                         "%p: die/croak: message = %s\ndiehook = %p\n",
+                         thr, message, PL_diehook));
+    if (PL_diehook) {
+       S_vdie_common(aTHX_ message, *msglen, *utf8);
+    }
+    return message;
+}
+
 OP *
 Perl_vdie(pTHX_ const char* pat, va_list *args)
 {
@@ -2522,9 +2512,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     Pid_t pid2;
     bool close_failed;
     int saved_errno = 0;
-#ifdef VMS
-    int saved_vaxc_errno;
-#endif
 #ifdef WIN32
     int saved_win32_errno;
 #endif
@@ -2542,9 +2529,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 #endif
     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
        saved_errno = errno;
-#ifdef VMS
-       saved_vaxc_errno = vaxc$errno;
-#endif
 #ifdef WIN32
        saved_win32_errno = GetLastError();
 #endif
@@ -2566,7 +2550,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     rsignal_restore(SIGQUIT, &qstat);
 #endif
     if (close_failed) {
-       SETERRNO(saved_errno, saved_vaxc_errno);
+       SETERRNO(saved_errno, 0);
        return -1;
     }
     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
@@ -4065,7 +4049,7 @@ Perl_vnumify(pTHX_ SV *vs)
     len = av_len((AV *)vs);
     if ( len == -1 )
     {
-       Perl_sv_catpv(aTHX_ sv,"0");
+       sv_catpvn(sv,"0",1);
        return sv;
     }
     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
@@ -4082,14 +4066,14 @@ Perl_vnumify(pTHX_ SV *vs)
        if ( (int)PERL_ABS(digit) != 0 || len == 1 )
        {
            if ( digit < 0 ) /* alpha version */
-               Perl_sv_catpv(aTHX_ sv,"_");
+               sv_catpvn(sv,"_",1);
            /* Don't display additional trailing zeros */
            Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit));
        }
     }
     else /* len == 0 */
     {
-        Perl_sv_catpv(aTHX_ sv,"000");
+        sv_catpvn(sv,"000",3);
     }
     return sv;
 }
@@ -4118,7 +4102,7 @@ Perl_vnormal(pTHX_ SV *vs)
     len = av_len((AV *)vs);
     if ( len == -1 )
     {
-       Perl_sv_catpv(aTHX_ sv,"");
+       sv_catpvn(sv,"",0);
        return sv;
     }
     digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
@@ -4134,7 +4118,7 @@ Perl_vnormal(pTHX_ SV *vs)
     
     if ( len <= 2 ) { /* short version, must be at least three */
        for ( len = 2 - len; len != 0; len-- )
-           Perl_sv_catpv(aTHX_ sv,".0");
+           sv_catpvn(sv,".0",2);
     }
 
     return sv;