Keep track of if collation locale is UTF-8 or not

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 42baa29..e2288b5 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -125,6 +125,9 @@
 #   define ASSERT_UTF8_CACHE(cache) NOOP
 #endif
 
+static const char S_destroy[] = "DESTROY";
+#define S_destroy_len (sizeof(S_destroy)-1)
+
 /* ============================================================================
 
 =head1 Allocation and deallocation of SVs.
@@ -1570,7 +1573,9 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
      * Only increment if the allocation isn't MEM_SIZE_MAX,
      * otherwise it will wrap to 0.
      */
-    if (newlen & 0xff && newlen != MEM_SIZE_MAX)
+    if (   (newlen < 0x1000 || (newlen & (newlen - 1)))
+        && newlen != MEM_SIZE_MAX
+    )
         newlen++;
 #endif
 
@@ -3118,10 +3123,7 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
                     DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
                     STORE_LC_NUMERIC_SET_TO_NEEDED();
 
-                    local_radix =
-                        PL_numeric_local &&
-                        PL_numeric_radix_sv &&
-                        SvUTF8(PL_numeric_radix_sv);
+                    local_radix = PL_numeric_local && PL_numeric_radix_sv;
                     if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
                         size += SvLEN(PL_numeric_radix_sv) - 1;
                         s = SvGROW_mutable(sv, size);
@@ -3131,8 +3133,10 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
 
                     /* If the radix character is UTF-8, and actually is in the
                      * output, turn on the UTF-8 flag for the scalar */
-                    if (local_radix &&
-                        instr(s, SvPVX_const(PL_numeric_radix_sv))) {
+                    if (   local_radix
+                        && SvUTF8(PL_numeric_radix_sv)
+                        && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+                    {
                         SvUTF8_on(sv);
                     }
 
@@ -6776,6 +6780,7 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
          if (HvNAME(stash)) {
            CV* destructor = NULL;
             struct mro_meta *meta;
+
            assert (SvOOK(stash));
 
             DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n",
@@ -6790,13 +6795,33 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
                              (void *)destructor, HvNAME(stash)) );
             }
             else {
-               GV * const gv =
-                   gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
-               if (gv) destructor = GvCV(gv);
-                meta->destroy_gen = PL_sub_generation;
-                meta->destroy = destructor;
-                DEBUG_o( Perl_deb(aTHX_ "Set cached DESTROY method %p for %s\n",
-                             (void *)destructor, HvNAME(stash)) );
+                bool autoload = FALSE;
+               GV *gv =
+                    gv_fetchmeth_pvn(stash, S_destroy, S_destroy_len, -1, 0);
+               if (gv)
+                    destructor = GvCV(gv);
+                if (!destructor) {
+                    gv = gv_autoload_pvn(stash, S_destroy, S_destroy_len,
+                                         GV_AUTOLOAD_ISMETHOD);
+                    if (gv)
+                        destructor = GvCV(gv);
+                    if (destructor)
+                        autoload = TRUE;
+                }
+                /* we don't cache AUTOLOAD for DESTROY, since this code
+                   would then need to set $__PACKAGE__::AUTOLOAD, or the
+                   equivalent for XS AUTOLOADs */
+                if (!autoload) {
+                    meta->destroy_gen = PL_sub_generation;
+                    meta->destroy = destructor;
+
+                    DEBUG_o( Perl_deb(aTHX_ "Set cached DESTROY method %p for %s\n",
+                                      (void *)destructor, HvNAME(stash)) );
+                }
+                else {
+                    DEBUG_o( Perl_deb(aTHX_ "Not caching AUTOLOAD for DESTROY method for %s\n",
+                                      HvNAME(stash)) );
+                }
            }
            assert(!destructor || SvTYPE(destructor) == SVt_PVCV);
            if (destructor
@@ -8114,13 +8139,18 @@ Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
     PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
 
     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
+
+    /* If we don't have collation magic on 'sv', or the locale has changed
+     * since the last time we calculated it, get it and save it now */
     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
        const char *s;
        char *xf;
        STRLEN len, xlen;
 
+        /* Free the old space */
        if (mg)
            Safefree(mg->mg_ptr);
+
        s = SvPV_flags_const(sv, len, flags);
        if ((xf = mem_collxfrm(s, len, &xlen))) {
            if (! mg) {
@@ -8138,6 +8168,7 @@ Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
            }
        }
     }
+
     if (mg && mg->mg_ptr) {
        *nxp = mg->mg_len;
        return mg->mg_ptr + sizeof(PL_collation_ix);
@@ -9681,6 +9712,8 @@ Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
                if (!todo[(U8)*HeKEY(entry)])
                    continue;
                gv = MUTABLE_GV(HeVAL(entry));
+               if (!isGV(gv))
+                   continue;
                sv = GvSV(gv);
                if (sv && !SvREADONLY(sv)) {
                    SV_CHECK_THINKFIRST_COW_DROP(sv);
@@ -10492,6 +10525,9 @@ Perl_sv_tainted(pTHX_ SV *const sv)
     return FALSE;
 }
 
+#ifndef NO_MATHOMS  /* Can't move these to mathoms.c because call uiv_2buf(),
+                       private to this file */
+
 /*
 =for apidoc sv_setpviv
 
@@ -10530,6 +10566,8 @@ Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
     SvSETMAGIC(sv);
 }
 
+#endif  /* NO_MATHOMS */
+
 #if defined(PERL_IMPLICIT_CONTEXT)
 
 /* pTHX_ magic can't cope with varargs, so this is a no-context
@@ -10719,7 +10757,7 @@ Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
 =for apidoc sv_vcatpvf
 
 Processes its arguments like C<sv_catpvfn> called with a non-null C-style
-variable argument list, and appends the formatted
+variable argument list, and appends the formatted output
 to an SV.  Does not handle 'set' magic.  See C<L</sv_vcatpvf_mg>>.
 
 Usually used via its frontend C<sv_catpvf>.
@@ -13085,7 +13123,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param)
     pos = PerlDir_tell(dp);
     if ((dirent = PerlDir_read(dp))) {
        len = d_namlen(dirent);
-        if (len > sizeof(dirent->d_name)) {
+        if (len > sizeof(dirent->d_name) && sizeof(dirent->d_name) > PTRSIZE) {
             /* If the len is somehow magically longer than the
              * maximum length of the directory entry, even though
              * we could fit it in a buffer, we could not copy it
@@ -14159,7 +14197,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 {
     dVAR;
     ANY * const ss     = proto_perl->Isavestack;
-    const I32 max      = proto_perl->Isavestack_max;
+    const I32 max      = proto_perl->Isavestack_max + SS_MAXPUSH;
     I32 ix             = proto_perl->Isavestack_ix;
     ANY *nss;
     const SV *sv;
@@ -14751,6 +14789,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     /* Did the locale setup indicate UTF-8? */
     PL_utf8locale      = proto_perl->Iutf8locale;
     PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
+    PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
     /* Unicode features (see perlrun/-C) */
     PL_unicode         = proto_perl->Iunicode;