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
integrate cfgperl and vmsperl contents into mainline
[perl5.git] / sv.c
diff --git a/sv.c b/sv.c
index 405f47d..f6f49d2 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1938,11 +1938,9 @@ Perl_sv_2pv_nolen(pTHX_ register SV *sv)
 static char *
 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
 {
-    STRLEN len;
     char *ptr = buf + TYPE_CHARS(UV);
     char *ebuf = ptr;
     int sign;
-    char *p;
 
     if (is_uv)
        sign = 0;
@@ -2033,7 +2031,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
                            int right = 4;
                            U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
 
-                           while(ch = *fptr++) {
+                           while((ch = *fptr++)) {
                                if(reganch & 1) {
                                    reflags[left++] = ch;
                                }
@@ -2097,32 +2095,11 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            return "";
        }
     }
-    if (SvIOKp(sv)) {
-       I32 isIOK = SvIOK(sv);
-       I32 isUIOK = SvIsUV(sv);
-       char buf[TYPE_CHARS(UV)];
-       char *ebuf, *ptr;
-
-       if (SvTYPE(sv) < SVt_PVIV)
-           sv_upgrade(sv, SVt_PVIV);
-       if (isUIOK)
-           ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
-       else
-           ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
-       SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
-       Move(ptr,SvPVX(sv),ebuf - ptr,char);
-       SvCUR_set(sv, ebuf - ptr);
-       s = SvEND(sv);
-       *s = '\0';
-       if (isIOK)
-           SvIOK_on(sv);
-       else
-           SvIOKp_on(sv);
-       if (isUIOK)
-           SvIsUV_on(sv);
-       SvPOK_on(sv);
-    }
-    else if (SvNOKp(sv)) {                     /* See note in sv_2uv() */
+    if (SvNOKp(sv)) {                  /* See note in sv_2uv() */
+       /* XXXX 64-bit?  IV may have better precision... */
+       /* I tried changing this for to be 64-bit-aware and
+        * the t/op/numconvert.t became very, very, angry.
+        * --jhi Sep 1999 */
        if (SvTYPE(sv) < SVt_PVNV)
            sv_upgrade(sv, SVt_PVNV);
        SvGROW(sv, 28);
@@ -2147,6 +2124,31 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
            *--s = '\0';
 #endif
     }
+    else if (SvIOKp(sv)) {
+       U32 isIOK = SvIOK(sv);
+       U32 isUIOK = SvIsUV(sv);
+       char buf[TYPE_CHARS(UV)];
+       char *ebuf, *ptr;
+
+       if (SvTYPE(sv) < SVt_PVIV)
+           sv_upgrade(sv, SVt_PVIV);
+       if (isUIOK)
+           ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
+       else
+           ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+       SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
+       Move(ptr,SvPVX(sv),ebuf - ptr,char);
+       SvCUR_set(sv, ebuf - ptr);
+       s = SvEND(sv);
+       *s = '\0';
+       if (isIOK)
+           SvIOK_on(sv);
+       else
+           SvIOKp_on(sv);
+       if (isUIOK)
+           SvIsUV_on(sv);
+       SvPOK_on(sv);
+    }
     else {
        dTHR;
        if (ckWARN(WARN_UNINITIALIZED)
@@ -2609,7 +2611,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                    else
                        dref = (SV*)GvAV(dstr);
                    GvAV(dstr) = (AV*)sref;
-                   if (GvIMPORTED_AV_off(dstr)
+                   if (!GvIMPORTED_AV(dstr)
                        && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
                    {
                        GvIMPORTED_AV_on(dstr);
@@ -2621,7 +2623,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                    else
                        dref = (SV*)GvHV(dstr);
                    GvHV(dstr) = (HV*)sref;
-                   if (GvIMPORTED_HV_off(dstr)
+                   if (!GvIMPORTED_HV(dstr)
                        && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
                    {
                        GvIMPORTED_HV_on(dstr);
@@ -2672,7 +2674,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                        GvASSUMECV_on(dstr);
                        PL_sub_generation++;
                    }
-                   if (GvIMPORTED_CV_off(dstr)
+                   if (!GvIMPORTED_CV(dstr)
                        && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
                    {
                        GvIMPORTED_CV_on(dstr);
@@ -2691,7 +2693,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
                    else
                        dref = (SV*)GvSV(dstr);
                    GvSV(dstr) = sref;
-                   if (GvIMPORTED_SV_off(dstr)
+                   if (!GvIMPORTED_SV(dstr)
                        && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
                    {
                        GvIMPORTED_SV_on(dstr);
@@ -3087,7 +3089,7 @@ Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
     STRLEN len;
     if (!sstr)
        return;
-    if (s = SvPV(sstr, len)) {
+    if ((s = SvPV(sstr, len))) {
        if (SvUTF8(sstr))
            sv_utf8_upgrade(dstr);
        sv_catpvn(dstr,s,len);
@@ -3498,7 +3500,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN
        SvCUR_set(bigstr, mid - big);
     }
     /*SUPPRESS 560*/
-    else if (i = mid - big) {  /* faster from front */
+    else if ((i = mid - big)) {        /* faster from front */
        midend -= littlelen;
        mid = midend;
        sv_chop(bigstr,midend-i);
@@ -3945,7 +3947,6 @@ Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
     STRLEN cur1, cur2;
     char *pv1, *pv2;
     I32 retval;
-    bool utf1;
 
     if (str1) {
         pv1 = SvPV(str1, cur1);
@@ -4742,6 +4743,25 @@ Perl_newSViv(pTHX_ IV i)
 }
 
 /*
+=for apidoc newSVuv
+
+Creates a new SV and copies an unsigned integer into it.
+The reference count for the SV is set to 1.
+
+=cut
+*/
+
+SV *
+Perl_newSVuv(pTHX_ UV u)
+{
+    register SV *sv;
+
+    new_SV(sv);
+    sv_setuv(sv,u);
+    return sv;
+}
+
+/*
 =for apidoc newRV_noinc
 
 Creates an RV wrapper for an SV.  The reference count for the original
@@ -5167,6 +5187,7 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob)
        case SVt_PVCV:          return "CODE";
        case SVt_PVGV:          return "GLOB";
        case SVt_PVFM:          return "FORMAT";
+       case SVt_PVIO:          return "IO";
        default:                return "UNKNOWN";
        }
     }
@@ -5467,7 +5488,7 @@ Perl_sv_tainted(pTHX_ SV *sv)
 {
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
        MAGIC *mg = mg_find(sv, 't');
-       if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
+       if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
            return TRUE;
     }
     return FALSE;
@@ -5808,6 +5829,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    vecsv = va_arg(*args, SV*);
                else if (svix < svmax)
                    vecsv = svargs[svix++];
+               else
+                   continue;
                dotstr = SvPVx(vecsv,dotstrlen);
                if (DO_UTF8(vecsv))
                    is_utf = TRUE;
@@ -5820,6 +5843,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                    vecsv = va_arg(*args, SV*);
                else if (svix < svmax)
                    vecsv = svargs[svix++];
+               else {
+                   vecstr = (U8*)"";
+                   veclen = 0;
+                   continue;
+               }
                vecstr = (U8*)SvPVx(vecsv,veclen);
                utf = DO_UTF8(vecsv);
                continue;
@@ -6074,7 +6102,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            goto uns_integer;
 
        case 'X':
-           /* FALL THROUGH */
        case 'x':
            base = 16;
 
@@ -6204,7 +6231,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            need = 0;
            if (c != 'e' && c != 'E') {
                i = PERL_INT_MIN;
-               (void)frexp(nv, &i);
+               (void)Perl_frexp(nv, &i);
                if (i == PERL_INT_MIN)
                    Perl_die(aTHX_ "panic: frexp");
                if (i > 0)
@@ -6227,8 +6254,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            *--eptr = c;
 #ifdef USE_LONG_DOUBLE
            {
-               char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
-               while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
+               static char const my_prifldbl[] = PERL_PRIfldbl;
+               char const *p = my_prifldbl + sizeof my_prifldbl - 3;
+               while (p >= my_prifldbl) { *--eptr = *p--; }
            }
 #endif
            if (has_precis) {
@@ -6374,10 +6402,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
 #endif
 
-#ifndef OpREFCNT_inc
-#  define OpREFCNT_inc(o)      ((o) ? (++(o)->op_targ, (o)) : Nullop)
-#endif
-
 #ifndef GpREFCNT_inc
 #  define GpREFCNT_inc(gp)     ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
 #endif
@@ -6606,9 +6630,6 @@ char *PL_watch_pvx;
 SV *
 Perl_sv_dup(pTHX_ SV *sstr)
 {
-    U32 sflags;
-    int dtype;
-    int stype;
     SV *dstr;
 
     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
@@ -6843,7 +6864,6 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
        HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
        if (HvARRAY((HV*)sstr)) {
-           HE *entry;
            STRLEN i = 0;
            XPVHV *dxhv = (XPVHV*)SvANY(dstr);
            XPVHV *sxhv = (XPVHV*)SvANY(sstr);
@@ -7330,15 +7350,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
      * their pointers copied. */
 
     IV i;
-    SV *sv;
-    SV **svp;
 #  ifdef PERL_OBJECT
     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
                                        ipD, ipS, ipP);
-    PERL_SET_INTERP(pPerl);
+    PERL_SET_THX(pPerl);
 #  else                /* !PERL_OBJECT */
     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+    PERL_SET_THX(my_perl);
 
 #    ifdef DEBUGGING
     memset(my_perl, 0xab, sizeof(PerlInterpreter));
@@ -7363,10 +7381,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #  endif       /* PERL_OBJECT */
 #else          /* !PERL_IMPLICIT_SYS */
     IV i;
-    SV *sv;
-    SV **svp;
     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+    PERL_SET_THX(my_perl);
 
 #    ifdef DEBUGGING
     memset(my_perl, 0xab, sizeof(PerlInterpreter));
@@ -8007,10 +8023,10 @@ do_clean_named_objs(pTHXo_ SV *sv)
 {
     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
        if ( SvOBJECT(GvSV(sv)) ||
-            GvAV(sv) && SvOBJECT(GvAV(sv)) ||
-            GvHV(sv) && SvOBJECT(GvHV(sv)) ||
-            GvIO(sv) && SvOBJECT(GvIO(sv)) ||
-            GvCV(sv) && SvOBJECT(GvCV(sv)) )
+            (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
+            (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
+            (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
+            (GvCV(sv) && SvOBJECT(GvCV(sv))) )
        {
            DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
            SvREFCNT_dec(sv);
Unnamed repository; edit this file 'description' to name the repository.