This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
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 03201dd..ae831e4 100644 (file)
--- a/util.c
+++ b/util.c
@@ -30,6 +30,11 @@
 #endif
 #endif
 
+#ifdef __Lynx__
+/* Missing protos on LynxOS */
+int putenv(char *);
+#endif
+
 #ifdef I_SYS_WAIT
 #  include <sys/wait.h>
 #endif
@@ -256,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)
@@ -265,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; /**/ ) {
@@ -286,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;
 
@@ -296,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; /**/ ) {
@@ -316,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;
 
@@ -325,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; /**/ ) {
@@ -361,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;
@@ -374,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);
-    (void)SvUPGRADE(sv, SVt_PVBM);
+    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;
@@ -402,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;
@@ -438,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;
 
@@ -486,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--;
@@ -569,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;
@@ -589,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;
 
@@ -616,7 +618,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 
 /* start_shift, end_shift are positive quantities which give offsets
    of ends of some substring of bigstr.
-   If `last' we want the last occurrence.
+   If "last" we want the last occurrence.
    old_posp is the way of communication between consequent calls if
    the next call needs to find the .
    The initial *old_posp should be -1.
@@ -632,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;
@@ -681,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;
@@ -759,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 */
@@ -842,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;
@@ -870,6 +867,7 @@ S_mess_alloc(pTHX)
     Newz(905, any, 1, XPVMG);
     SvFLAGS(sv) = SVt_PVMG;
     SvANY(sv) = (void*)any;
+    SvPV_set(sv, 0);
     SvREFCNT(sv) = 1 << 30; /* practically infinite */
     PL_mess_sv = sv;
     return sv;
@@ -1008,7 +1006,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args)
            OutCopFILE(cop), (IV)CopLINE(cop));
        if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
            const bool line_mode = (RsSIMPLE(PL_rs) &&
-                             SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
+                             SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n');
            Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
                           PL_last_in_gv == PL_argvgv ?
                           "" : GvNAME(PL_last_in_gv),
@@ -1069,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;
@@ -1143,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)
 {
@@ -1361,10 +1357,10 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     dVAR;
     if (ckDEAD(err)) {
-       SV *msv = vmess(pat, args);
+       SV * const msv = vmess(pat, args);
        STRLEN msglen;
        const char *message = SvPV(msv, msglen);
-       I32 utf8 = SvUTF8(msv);
+       const I32 utf8 = SvUTF8(msv);
 
        if (PL_diehook) {
            assert(message);
@@ -2033,7 +2029,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     UNLOCK_FDPID_MUTEX;
-    (void)SvUPGRADE(sv,SVt_IV);
+    SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     /* If we managed to get status pipe check for exec fail */
@@ -2184,7 +2180,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
     LOCK_FDPID_MUTEX;
     sv = *av_fetch(PL_fdpid,p[This],TRUE);
     UNLOCK_FDPID_MUTEX;
-    (void)SvUPGRADE(sv,SVt_IV);
+    SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, pid);
     PL_forkprocess = pid;
     if (did_pipes && pid > 0) {
@@ -2516,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
@@ -2536,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
@@ -2560,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));
@@ -2650,7 +2640,7 @@ Perl_pidgone(pTHX_ Pid_t pid, int status)
 
     sprintf(spid, "%"IVdf, (IV)pid);
     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
-    (void)SvUPGRADE(sv,SVt_IV);
+    SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, status);
     return;
 }
@@ -2729,16 +2719,16 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     if (strNE(a,b))
        return FALSE;
     if (fa == a)
-       sv_setpv(tmpsv, ".");
+       sv_setpvn(tmpsv, ".", 1);
     else
        sv_setpvn(tmpsv, a, fa - a);
-    if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
+    if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
        return FALSE;
     if (fb == b)
-       sv_setpv(tmpsv, ".");
+       sv_setpvn(tmpsv, ".", 1);
     else
        sv_setpvn(tmpsv, b, fb - b);
-    if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
+    if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
        return FALSE;
     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
           tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
@@ -3012,6 +3002,8 @@ Perl_set_context(void *t)
     if (pthread_setspecific(PL_thr_key, t))
        Perl_croak_nocontext("panic: pthread_setspecific");
 #  endif
+#else
+    (void)t;
 #endif
 }
 
@@ -3698,7 +3690,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
     int pathlen=0;
     Direntry_t *dp;
 
-    (void)SvUPGRADE(sv, SVt_PV);
+    SvUPGRADE(sv, SVt_PV);
 
     if (PerlLIO_lstat(".", &statbuf) < 0) {
        SV_CWD_RETURN_UNDEF;
@@ -3765,7 +3757,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 
        if (pathlen) {
            /* shift down */
-           Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
+           Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
        }
 
        /* prepend current directory to the front */
@@ -3787,7 +3779,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
        *SvEND(sv) = '\0';
        SvPOK_only(sv);
 
-       if (PerlDir_chdir(SvPVX(sv)) < 0) {
+       if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
            SV_CWD_RETURN_UNDEF;
        }
     }
@@ -3969,7 +3961,7 @@ Perl_new_version(pTHX_ SV *ver)
        AvREAL_on((AV*)sv);
        for ( key = 0; key <= av_len(av); key++ )
        {
-           I32 rev = SvIV(*av_fetch(av, key, FALSE));
+           const I32 rev = SvIV(*av_fetch(av, key, FALSE));
            av_push((AV *)sv, newSViv(rev));
        }
        return rv;
@@ -4057,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));
@@ -4074,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;
 }
@@ -4110,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));
@@ -4126,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;
@@ -4784,5 +4776,5 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
  * indent-tabs-mode: t
  * End:
  *
- * vim: ts=8 sts=4 sw=4 noet:
-*/
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
Unnamed repository; edit this file 'description' to name the repository.