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
Re: [perl #41215] % on scalars sometimes throws away fractions
[perl5.git] / sv.c
diff --git a/sv.c b/sv.c
index a98c70b..33cdb52 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -704,7 +704,7 @@ Perl_get_arena(pTHX_ int arena_size)
     Newxz(adesc->arena, arena_size, char);
     adesc->size = arena_size;
     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n", 
-                         curr, adesc->arena, arena_size));
+                         curr, (void*)adesc->arena, arena_size));
 
     return adesc->arena;
 }
@@ -1069,7 +1069,7 @@ S_more_bodies (pTHX_ svtype sv_type)
     /* computed count doesnt reflect the 1st slot reservation */
     DEBUG_m(PerlIO_printf(Perl_debug_log,
                          "arena %p end %p arena-size %d type %d size %d ct %d\n",
-                         start, end,
+                         (void*)start, (void*)end,
                          (int)bdp->arena_size, sv_type, (int)body_size,
                          (int)bdp->arena_size / (int)body_size));
 
@@ -3339,14 +3339,14 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 
     if (SvIS_FREED(dstr)) {
        Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
-                  " to a freed scalar %p", sstr, dstr);
+                  " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
     }
     SV_CHECK_THINKFIRST_COW_DROP(dstr);
     if (!sstr)
        sstr = &PL_sv_undef;
     if (SvIS_FREED(sstr)) {
-       Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr,
-                  dstr);
+       Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
+                  (void*)sstr, (void*)dstr);
     }
     stype = SvTYPE(sstr);
     dtype = SvTYPE(dstr);
@@ -3489,7 +3489,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     dtype = SvTYPE(dstr);
     sflags = SvFLAGS(sstr);
 
-    if (dtype == SVt_PVCV) {
+    if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
        /* Assigning to a subroutine sets the prototype.  */
        if (SvOK(sstr)) {
            STRLEN len;
@@ -3499,9 +3499,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
             Copy(ptr, SvPVX(dstr), len + 1, char);
             SvCUR_set(dstr, len);
            SvPOK_only(dstr);
+           SvFLAGS(dstr) |= sflags & SVf_UTF8;
        } else {
            SvOK_off(dstr);
        }
+    } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
+       const char * const type = sv_reftype(dstr,0);
+       if (PL_op)
+           Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
+       else
+           Perl_croak(aTHX_ "Cannot copy to %s", type);
     } else if (sflags & SVf_ROK) {
        if (isGV_with_GP(dstr) && dtype == SVt_PVGV
            && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
@@ -3771,7 +3778,7 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
 
     if (DEBUG_C_TEST) {
        PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
-                     sstr, dstr);
+                     (void*)sstr, (void*)dstr);
        sv_dump(sstr);
        if (dstr)
                    sv_dump(dstr);
@@ -4508,9 +4515,6 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_regdata:
        vtable = &PL_vtbl_regdata;
        break;
-    case PERL_MAGIC_regdata_names:
-       vtable = &PL_vtbl_regdata_names;
-       break;
     case PERL_MAGIC_regdatum:
        vtable = &PL_vtbl_regdatum;
        break;
@@ -5113,7 +5117,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
     }
     if (type >= SVt_PVMG) {
        if (type == SVt_PVMG && SvPAD_OUR(sv)) {
-           SvREFCNT_dec(OURSTASH(sv));
+           SvREFCNT_dec(SvOURSTASH(sv));
        } else if (SvMAGIC(sv))
            mg_free(sv);
        if (type == SVt_PVMG && SvPAD_TYPED(sv))
@@ -5382,7 +5386,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv)
                        PL_utf8cache = 0;
                        Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
                                   " real %"UVuf" for %"SVf,
-                                  (UV) ulen, (UV) real, (void*)sv);
+                                  (UV) ulen, (UV) real, SVfARG(sv));
                    }
                }
            }
@@ -5540,7 +5544,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
                PL_utf8cache = 0;
                Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
                           " real %"UVuf" for %"SVf,
-                          (UV) boffset, (UV) real_boffset, (void*)sv);
+                          (UV) boffset, (UV) real_boffset, SVfARG(sv));
            }
        }
        boffset = real_boffset;
@@ -5662,7 +5666,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
            SAVEI8(PL_utf8cache);
            PL_utf8cache = 0;
            Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
-                      " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv);
+                      " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
        }
     }
 
@@ -5885,7 +5889,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
                PL_utf8cache = 0;
                Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
                           " real %"UVuf" for %"SVf,
-                          (UV) len, (UV) real_len, (void*)sv);
+                          (UV) len, (UV) real_len, SVfARG(sv));
            }
        }
        len = real_len;
@@ -7379,7 +7383,7 @@ Perl_sv_2io(pTHX_ SV *sv)
        else
            io = 0;
        if (!io)
-           Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv);
+           Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
        break;
     }
     return io;
@@ -7471,7 +7475,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
            LEAVE;
            if (!GvCVu(gv))
                Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
-                          (void*)sv);
+                          SVfARG(sv));
        }
        return GvCVu(gv);
     }
@@ -8407,7 +8411,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     }
     if (args && patlen == 3 && pat[0] == '%' &&
                pat[1] == '-' && pat[2] == 'p') {
-       argsv = va_arg(*args, SV*);
+       argsv = (SV*)va_arg(*args, void*);
        sv_catsv(sv, argsv);
        return;
     }
@@ -8563,7 +8567,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                        precis = n;
                        has_precis = TRUE;
                    }
-                   argsv = va_arg(*args, SV*);
+                   argsv = (SV*)va_arg(*args, void*);
                    eptr = SvPVx_const(argsv, elen);
                    if (DO_UTF8(argsv))
                        is_utf8 = TRUE;
@@ -9340,7 +9344,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                                       (UV)c & 0xFF);
                } else
                    sv_catpvs(msg, "end of string");
-               Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */
+               Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
            }
 
            /* output mangled stuff ... */
@@ -9491,7 +9495,14 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
     if (!proto)
        return NULL;
 
+    /* look for it in the table first */
+    parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
+    if (parser)
+       return parser;
+
+    /* create anew and remember what it is */
     Newxz(parser, 1, yy_parser);
+    ptr_table_store(PL_ptr_table, proto, parser);
 
     parser->yyerrstatus = 0;
     parser->yychar = YYEMPTY;          /* Cause a token to be read.  */
@@ -9682,6 +9693,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
     return mgret;
 }
 
+#endif /* USE_ITHREADS */
+
 /* create a new pointer-mapping table */
 
 PTR_TBL_t *
@@ -9825,6 +9838,7 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
     Safefree(tbl);
 }
 
+#if defined(USE_ITHREADS)
 
 void
 Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param)
@@ -9920,7 +9934,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
 #ifdef DEBUGGING
     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
        PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
-                     PL_watch_pvx, SvPVX_const(sstr));
+                     (void*)PL_watch_pvx, SvPVX_const(sstr));
 #endif
 
     /* don't clone objects whose class has asked us not to */
@@ -10007,7 +10021,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param)
               FIXME - instrument and check that assumption  */
            if (sv_type >= SVt_PVMG) {
                if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
-                   OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param));
+                   SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
                } else if (SvMAGIC(dstr))
                    SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
                if (SvSTASH(dstr))
@@ -10660,6 +10674,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
            ptr = POPPTR(ss,ix);
            TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
            break;
+       case SAVEt_PARSER:
+           ptr = POPPTR(ss,ix);
+           TOPPTR(nss,ix) = parser_dup(ptr, param);
+           break;
        default:
            Perl_croak(aTHX_
                       "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
Unnamed repository; edit this file 'description' to name the repository.