This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable.xs: Add comments to store_scalar concerning utf8
[perl5.git] / dist / Storable / Storable.xs
index 876a323..65428ad 100644 (file)
@@ -17,7 +17,7 @@
 #include <patchlevel.h>                /* Perl's one, needed since 5.6 */
 #endif
 
-#if !defined(PERL_VERSION) || PERL_VERSION < 8 || (PERL_VERSION == 8 && PERL_SUBVERSION < 9) || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
+#if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1)
 #define NEED_load_module
 #define NEED_vload_module
 #define NEED_newCONSTSUB
 #  define HvPLACEHOLDERS_get HvPLACEHOLDERS
 #endif
 
+#ifndef HvTOTALKEYS
+#  define HvTOTALKEYS(hv)      HvKEYS(hv)
+#endif
+
 #ifdef DEBUGME
 
 #ifndef DASSERT
@@ -982,7 +986,7 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
   } STMT_END
 
 /*
- * Bless `s' in `p', via a temporary reference, required by sv_bless().
+ * Bless 's' in 'p', via a temporary reference, required by sv_bless().
  * "A" magic is added before the sv_bless for overloaded classes, this avoids
  * an expensive call to S_reset_amagic in sv_bless.
  */
@@ -1036,6 +1040,12 @@ static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
 static int store(pTHX_ stcxt_t *cxt, SV *sv);
 static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname);
 
+#define UNSEE()                             \
+  STMT_START {                              \
+    av_pop(cxt->aseen);                     \
+    cxt->tagnum--;                          \
+  } STMT_END
+
 /*
  * Dynamic dispatching table for SV store.
  */
@@ -1231,7 +1241,7 @@ static void init_store_context(
        cxt->entry = 1;                                 /* No recursion yet */
 
        /*
-        * The `hseen' table is used to keep track of each SV stored and their
+        * The 'hseen' table is used to keep track of each SV stored and their
         * associated tag numbers is special. It is "abused" because the
         * values stored are not real SV, just integers cast to (SV *),
         * which explains the freeing below.
@@ -1273,7 +1283,7 @@ static void init_store_context(
 #endif
 
        /*
-        * The `hclass' hash uses the same settings as `hseen' above, but it is
+        * The 'hclass' hash uses the same settings as 'hseen' above, but it is
         * used to assign sequential tags (numbers) to class names for blessed
         * objects.
         *
@@ -1287,7 +1297,7 @@ static void init_store_context(
 #endif
 
        /*
-        * The `hook' hash table is used to keep track of the references on
+        * The 'hook' hash table is used to keep track of the references on
         * the STORABLE_freeze hook routines, when found in some class name.
         *
         * It is assumed that the inheritance tree will not be changed during
@@ -1298,7 +1308,7 @@ static void init_store_context(
        cxt->hook = newHV();                    /* Table where hooks are cached */
 
        /*
-        * The `hook_seen' array keeps track of all the SVs returned by
+        * The 'hook_seen' array keeps track of all the SVs returned by
         * STORABLE_freeze hooks for us to serialize, so that they are not
         * reclaimed until the end of the serialization process.  Each SV is
         * only stored once, the first time it is seen.
@@ -1718,7 +1728,7 @@ static SV *pkg_can(
         * Look into the cache to see whether we already have determined
         * where the routine was, if any.
         *
-        * NOTA BENE: we don't use `method' at all in our lookup, since we know
+        * NOTA BENE: we don't use 'method' at all in our lookup, since we know
         * that only one hook (i.e. always the same) is cached in a given cache.
         */
 
@@ -1843,8 +1853,8 @@ static AV *array_call(
 /*
  * known_class
  *
- * Lookup the class name in the `hclass' table and either assign it a new ID
- * or return the existing one, by filling in `classnum'.
+ * Lookup the class name in the 'hclass' table and either assign it a new ID
+ * or return the existing one, by filling in 'classnum'.
  *
  * Return true if the class was known, false if the ID was just generated.
  */
@@ -1928,6 +1938,7 @@ static int store_ref(pTHX_ stcxt_t *cxt, SV *sv)
  * Store a scalar.
  *
  * Layout is SX_LSCALAR <length> <data>, SX_SCALAR <length> <data> or SX_UNDEF.
+ * SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings.
  * The <data> section is omitted if <length> is 0.
  *
  * If integer or double, the layout is SX_INTEGER <data> or SX_DOUBLE <data>.
@@ -2222,12 +2233,7 @@ sortcmp(const void *a, const void *b)
 static int store_hash(pTHX_ stcxt_t *cxt, HV *hv)
 {
        dVAR;
-       I32 len = 
-#ifdef HAS_RESTRICTED_HASHES
-            HvTOTALKEYS(hv);
-#else
-            HvKEYS(hv); /* Not HvUSEDKEYS, as 5.6 lacketh it */
-#endif
+       I32 len = HvTOTALKEYS(hv);
        I32 i;
        int ret = 0;
        I32 riter;
@@ -2855,6 +2861,7 @@ static int store_hook(
         */
 
        switch (type) {
+        case svis_REF:
        case svis_SCALAR:
                obj_type = SHT_SCALAR;
                break;
@@ -2876,7 +2883,7 @@ static int store_hook(
                 * Signal the tie-ing magic by setting the object type as SHT_EXTRA
                 * (since we have only 2 bits in <flags> to store the type), and an
                 * <extra> byte flag will be emitted after the FIRST <flags> in the
-                * stream, carrying what we put in `eflags'.
+                * stream, carrying what we put in 'eflags'.
                 */
                obj_type = SHT_EXTRA;
                switch (SvTYPE(sv)) {
@@ -2908,7 +2915,7 @@ static int store_hook(
         *    $object->STORABLE_freeze($cloning);
         *
         * but we don't have the $object here.  For instance, if $object is
-        * a blessed array, what we have in `sv' is the array, and we can't
+        * a blessed array, what we have in 'sv' is the array, and we can't
         * call a method on those.
         *
         * Therefore, we need to create a temporary reference to the object and
@@ -2917,9 +2924,8 @@ static int store_hook(
 
        TRACEME(("about to call STORABLE_freeze on class %s", classname));
 
-       ref = newRV_noinc(sv);                          /* Temporary reference */
+       ref = newRV_inc(sv);                            /* Temporary reference */
        av = array_call(aTHX_ ref, hook, clone);        /* @a = $object->STORABLE_freeze($c) */
-       SvRV_set(ref, NULL);
        SvREFCNT_dec(ref);                                      /* Reclaim temporary reference */
 
        count = AvFILLp(av) + 1;
@@ -3049,7 +3055,7 @@ static int store_hook(
                        CROAK(("Could not serialize item #%d from hook in %s", i, classname));
 #endif
                /*
-                * It was the first time we serialized `xsv'.
+                * It was the first time we serialized 'xsv'.
                 *
                 * Keep this SV alive until the end of the serialization: if we
                 * disposed of it right now by decrementing its refcount, and it was
@@ -3065,7 +3071,7 @@ static int store_hook(
 
        sv_seen:
                /*
-                * Dispose of the REF they returned.  If we saved the `xsv' away
+                * Dispose of the REF they returned.  If we saved the 'xsv' away
                 * in the array of returned SVs, that will not cause the underlying
                 * referenced SV to be reclaimed.
                 */
@@ -3333,7 +3339,7 @@ static int store_blessed(
  * We don't know how to store the item we reached, so return an error condition.
  * (it's probably a GLOB, some CODE reference, etc...)
  *
- * If they defined the `forgive_me' variable at the Perl level to some
+ * If they defined the 'forgive_me' variable at the Perl level to some
  * true value, then don't croak, just warn, and store a placeholder string
  * instead.
  */
@@ -3552,7 +3558,7 @@ static int store(pTHX_ stcxt_t *cxt, SV *sv)
 #endif
 
        /*
-        * Store `sv' and everything beneath it, using appropriate routine.
+        * Store 'sv' and everything beneath it, using appropriate routine.
         * Abort immediately if we get a non-zero status back.
         */
 
@@ -3677,9 +3683,9 @@ static int magic_write(pTHX_ stcxt_t *cxt)
  * Common code for store operations.
  *
  * When memory store is requested (f = NULL) and a non null SV* is given in
- * `res', it is filled with a new SV created out of the memory buffer.
+ * 'res', it is filled with a new SV created out of the memory buffer.
  *
- * It is required to provide a non-null `res' when the operation type is not
+ * It is required to provide a non-null 'res' when the operation type is not
  * dclone() and store() is performed to memory.
  */
 static int do_store(
@@ -3862,7 +3868,7 @@ static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname)
                RLEN(idx);
 
        /*
-        * Fetch classname in `aclass'
+        * Fetch classname in 'aclass'
         */
 
        sva = av_fetch(cxt->aclass, idx, FALSE);
@@ -4063,7 +4069,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
                I32 idx;
 
                /*
-                * Fetch index from `aclass'
+                * Fetch index from 'aclass'
                 */
 
                if (flags & SHF_LARGE_CLASSLEN)
@@ -4217,8 +4223,12 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
            attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
            if (attached &&
                SvROK(attached) && 
-               sv_derived_from(attached, classname))
+               sv_derived_from(attached, classname)
+        ) {
+               UNSEE();
+               SEEN(SvRV(attached), 0, 0);
                return SvRV(attached);
+        }
            CROAK(("STORABLE_attach did not return a %s object", classname));
        }
 
@@ -4251,7 +4261,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
        }
 
        /*
-        * If we don't have an `av' yet, prepare one.
+        * If we don't have an 'av' yet, prepare one.
         * Then insert the frozen string as item [0].
         */
 
@@ -5098,7 +5108,7 @@ static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
        SEEN(hv, cname, 0);             /* Will return if table not allocated properly */
        if (len == 0)
                return (SV *) hv;       /* No data follow if table empty */
-       hv_ksplit(hv, len);             /* pre-extend hash to save multiple splits */
+       hv_ksplit(hv, len + 1);         /* pre-extend hash to save multiple splits */
 
        /*
         * Now get each key/value pair in turn...
@@ -5185,7 +5195,7 @@ static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname)
     SEEN(hv, cname, 0);                /* Will return if table not allocated properly */
     if (len == 0)
         return (SV *) hv;      /* No data follow if table empty */
-    hv_ksplit(hv, len);                /* pre-extend hash to save multiple splits */
+    hv_ksplit(hv, len + 1);            /* pre-extend hash to save multiple splits */
 
     /*
      * Now get each key/value pair in turn...
@@ -5504,7 +5514,7 @@ static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname)
        SEEN(hv, 0, 0);                 /* Will return if table not allocated properly */
        if (len == 0)
                return (SV *) hv;       /* No data follow if table empty */
-       hv_ksplit(hv, len);             /* pre-extend hash to save multiple splits */
+       hv_ksplit(hv, len + 1);         /* pre-extend hash to save multiple splits */
 
        /*
         * Now get each key/value pair in turn...
@@ -5975,7 +5985,7 @@ static SV *do_retrieve(
        /*
         * Prepare context.
         *
-        * Data is loaded into the memory buffer when f is NULL, unless `in' is
+        * Data is loaded into the memory buffer when f is NULL, unless 'in' is
         * also NULL, in which case we're expecting the data to already lie
         * in the buffer (dclone case).
         */
@@ -6044,7 +6054,7 @@ static SV *do_retrieve(
         * Check whether input source is tainted, so that we don't wrongly
         * taint perfectly good values...
         *
-        * We assume file input is always tainted.  If both `f' and `in' are
+        * We assume file input is always tainted.  If both 'f' and 'in' are
         * NULL, then we come from dclone, and tainted is already filled in
         * the context.  That's a kludge, but the whole dclone() thing is
         * already quite a kludge anyway! -- RAM, 15/09/2000.
@@ -6234,7 +6244,7 @@ static SV *dclone(pTHX_ SV *sv)
        cxt = real_context;                                     /* And we need this temporary... */
 
        /*
-        * Now, `cxt' may refer to a new context.
+        * Now, 'cxt' may refer to a new context.
         */
 
        ASSERT(!cxt->s_dirty, ("clean context"));