File Coverage

srl_encoder.c
Criterion Covered Total %
statement 631 670 94.1
branch 934 2162 43.2
condition n/a
subroutine n/a
pod n/a
total 1565 2832 55.2


line stmt bran cond sub pod time code
1             /* Must be defined before including Perl header files or we slow down by 2x! */
2             #define PERL_NO_GET_CONTEXT
3              
4             #ifdef __cplusplus
5             extern "C" {
6             #endif
7             #include "EXTERN.h"
8             #include "perl.h"
9             #include "XSUB.h"
10             #include "ppport.h"
11             #ifdef __cplusplus
12             }
13             #endif
14              
15             #include
16              
17             #ifndef PERL_VERSION
18             # include
19             # if !(defined(PERL_VERSION) || (PERL_SUBVERSION > 0 && defined(PATCHLEVEL)))
20             # include
21             # endif
22             # define PERL_REVISION 5
23             # define PERL_VERSION PATCHLEVEL
24             # define PERL_SUBVERSION PERL_SUBVERSION
25             #endif
26             #if PERL_VERSION < 8
27             # define PERL_MAGIC_qr 'r' /* precompiled qr// regex */
28             # define BFD_Svs_SMG_OR_RMG SVs_RMG
29             #elif ((PERL_VERSION==8) && (PERL_SUBVERSION >= 1) || (PERL_VERSION>8))
30             # define BFD_Svs_SMG_OR_RMG SVs_SMG
31             # define MY_PLACEHOLDER PL_sv_placeholder
32             #else
33             # define BFD_Svs_SMG_OR_RMG SVs_RMG
34             # define MY_PLACEHOLDER PL_sv_undef
35             #endif
36             #if (((PERL_VERSION == 9) && (PERL_SUBVERSION >= 4)) || (PERL_VERSION > 9))
37             # define NEW_REGEX_ENGINE 1
38             #endif
39             #if (((PERL_VERSION == 8) && (PERL_SUBVERSION >= 1)) || (PERL_VERSION > 8))
40             #define MY_CAN_FIND_PLACEHOLDERS
41             #define HAS_SV2OBJ
42             #endif
43              
44             /* hv_backreferences_p is not marked as exported in embed.fnc in any perl */
45             #if (PERL_VERSION >= 10)
46             #define HAS_HV_BACKREFS
47             #endif
48              
49             #include "srl_protocol.h"
50             #include "srl_encoder.h"
51             #include "srl_common.h"
52             #include "ptable.h"
53             #include "srl_buffer.h"
54             #include "srl_compress.h"
55             #include "qsort.h"
56              
57             /* The ENABLE_DANGEROUS_HACKS (passed through from ENV via Makefile.PL) enables
58             * optimizations that may make the code so cozy with a particular version of the
59             * Perl core that the code is no longer portable and/or compatible.
60             * It would be great to determine where these hacks are safe and enable them
61             * where possible. Gut feeling as for portability is that most things will be
62             * ok on Unixes, but fail on the stricter Win32. As for compatibility with old
63             * versions of perl, all bets are off.
64             */
65             #ifdef ENABLE_DANGEROUS_HACKS
66             /* It's unclear why DO_SHARED_HASH_ENTRY_REFCOUNT_CHECK doesn't
67             * help much. It basically means breaking perl's encapsulation to
68             * check whether a HE (hash entry) that is shared has a refcount > 1
69             * and only bothers inserting key into our ptr table if that's the
70             * case. Benchmarks don't show much of a difference and it's a high
71             * price to pay to break encapsulation for something that's not
72             * measureable.
73             */
74             /* DO_SHARED_HASH_ENTRY_REFCOUNT_CHECK only works on 5.10 and better */
75             # define DO_SHARED_HASH_ENTRY_REFCOUNT_CHECK 1
76             #else
77             # define DO_SHARED_HASH_ENTRY_REFCOUNT_CHECK 0
78             #endif
79              
80             #define DEFAULT_MAX_RECUR_DEPTH 10000
81              
82             #define DEBUGHACK 0
83              
84             /* some static function declarations */
85             SRL_STATIC_INLINE void srl_clear_seen_hashes(pTHX_ srl_encoder_t *enc);
86             static void srl_dump_sv(pTHX_ srl_encoder_t *enc, SV *src);
87             SRL_STATIC_INLINE void srl_dump_svpv(pTHX_ srl_encoder_t *enc, SV *src);
88             SRL_STATIC_INLINE void srl_dump_pv(pTHX_ srl_encoder_t *enc, const char* src, STRLEN src_len, int is_utf8);
89             SRL_STATIC_INLINE void srl_fixup_weakrefs(pTHX_ srl_encoder_t *enc);
90             SRL_STATIC_INLINE void srl_dump_av(pTHX_ srl_encoder_t *enc, AV *src, U32 refcnt);
91             SRL_STATIC_INLINE void srl_dump_hv(pTHX_ srl_encoder_t *enc, HV *src, U32 refcnt);
92             SRL_STATIC_INLINE void srl_dump_hk(pTHX_ srl_encoder_t *enc, HE *src, const int share_keys);
93             SRL_STATIC_INLINE void srl_dump_nv(pTHX_ srl_encoder_t *enc, SV *src);
94             SRL_STATIC_INLINE void srl_dump_ivuv(pTHX_ srl_encoder_t *enc, SV *src);
95             SRL_STATIC_INLINE int srl_dump_classname(pTHX_ srl_encoder_t *enc, SV *referent, SV *replacement);
96             SRL_STATIC_INLINE SV *srl_get_frozen_object(pTHX_ srl_encoder_t *enc, SV *src, SV *referent);
97             SRL_STATIC_INLINE PTABLE_t *srl_init_string_hash(srl_encoder_t *enc);
98             SRL_STATIC_INLINE PTABLE_t *srl_init_ref_hash(srl_encoder_t *enc);
99             SRL_STATIC_INLINE PTABLE_t *srl_init_freezeobj_svhash(srl_encoder_t *enc);
100             SRL_STATIC_INLINE PTABLE_t *srl_init_weak_hash(srl_encoder_t *enc);
101             SRL_STATIC_INLINE HV *srl_init_string_deduper_hv(pTHX_ srl_encoder_t *enc);
102              
103             /* Note: This returns an encoder struct pointer because it will
104             * clone the current encoder struct if it's dirty. That in
105             * turn means in order to access the output buffer, you need
106             * to inspect the returned encoder struct. If necessary, it
107             * will be cleaned up automatically by Perl, so don't bother
108             * freeing it. */
109             SRL_STATIC_INLINE srl_encoder_t *srl_dump_data_structure(pTHX_ srl_encoder_t *enc, SV *src, SV *user_header_src);
110              
111             #define SRL_GET_STR_DEDUPER_HV(enc) ( (enc)->string_deduper_hv == NULL \
112             ? srl_init_string_deduper_hv(aTHX_ enc) \
113             : (enc)->string_deduper_hv )
114              
115             #define SRL_GET_STR_PTR_SEENHASH(enc) ( (enc)->str_seenhash == NULL \
116             ? srl_init_string_hash(enc) \
117             : (enc)->str_seenhash )
118              
119             #define SRL_GET_REF_SEENHASH(enc) ( (enc)->ref_seenhash == NULL \
120             ? srl_init_ref_hash(enc) \
121             : (enc)->ref_seenhash )
122              
123             #define SRL_GET_WEAK_SEENHASH(enc) ( (enc)->weak_seenhash == NULL \
124             ? srl_init_weak_hash(enc) \
125             : (enc)->weak_seenhash )
126              
127             #define SRL_GET_WEAK_SEENHASH_OR_NULL(enc) ((enc)->weak_seenhash)
128              
129             #define SRL_GET_FREEZEOBJ_SVHASH(enc) ( (enc)->freezeobj_svhash == NULL \
130             ? srl_init_freezeobj_svhash(enc) \
131             : (enc)->freezeobj_svhash )
132              
133             #define SRL_ENC_UPDATE_BODY_POS(enc) SRL_UPDATE_BODY_POS(&(enc)->buf, (enc)->protocol_version)
134              
135             #ifndef MAX_CHARSET_NAME_LENGTH
136             # define MAX_CHARSET_NAME_LENGTH 2
137             #endif
138              
139             #if PERL_VERSION == 10
140             /*
141             Apparently regexes in 5.10 are "modern" but with 5.8 internals
142             */
143             #ifndef RXf_PMf_STD_PMMOD_SHIFT
144             # define RXf_PMf_STD_PMMOD_SHIFT 12
145             #endif
146             #ifndef RE_EXTFLAGS
147             # define RX_EXTFLAGS(re) ((re)->extflags)
148             #endif
149             #ifndef RX_PRECOMP
150             # define RX_PRECOMP(re) ((re)->precomp)
151             #endif
152             #ifndef RX_PRELEN
153             # define RX_PRELEN(re) ((re)->prelen)
154             #endif
155              
156             /* Maybe this is only on OS X, where SvUTF8(sv) exists but looks at flags that don't exist */
157             #ifndef RX_UTF8
158             # define RX_UTF8(re) (RX_EXTFLAGS(re) & RXf_UTF8)
159             #endif
160              
161             #elif defined(SvRX)
162             # define MODERN_REGEXP
163             # if ( PERL_VERSION > 27 || (PERL_VERSION == 27 && PERL_SUBVERSION >= 3) )
164             /* Commit df6b4bd56551f2d39f7c0019c23f27181d8c39c4
165             * changed the behavior mentioned below, so that the POK flag is on again. Sigh.
166             * So this branch is a deliberate NO-OP, it just makes the conditions easier to read.*/
167             # elif ( PERL_VERSION > 17 || (PERL_VERSION == 17 && PERL_SUBVERSION >= 6) )
168             /* With commit 8d919b0a35f2b57a6bed2f8355b25b19ac5ad0c5 (perl.git) and
169             * release 5.17.6, regular expression are no longer SvPOK (IOW are no longer
170             * considered to be containing a string).
171             * This breaks some of the REGEXP detection logic in srl_dump_sv, so
172             * we need yet another CPP define. */
173             # define REGEXP_NO_LONGER_POK
174             # endif
175             #else
176             # define INT_PAT_MODS "msix"
177             # define RXf_PMf_STD_PMMOD_SHIFT 12
178             # define RX_PRECOMP(re) ((re)->precomp)
179             # define RX_PRELEN(re) ((re)->prelen)
180             # define RX_UTF8(re) ((re)->reganch & ROPT_UTF8)
181             # define RX_EXTFLAGS(re) ((re)->reganch)
182             # define RXf_PMf_COMPILETIME PMf_COMPILETIME
183             #endif
184              
185             #if defined(MODERN_REGEXP) && !defined(REGEXP_NO_LONGER_POK)
186             #define DO_POK_REGEXP(enc, src, svt) \
187             /* Only need to enter here if we have rather modern regexps,*/ \
188             /* but they're still POK (pre 5.17.6). */ \
189             if (expect_false( svt == SVt_REGEXP ) ) { \
190             srl_dump_regexp(aTHX_ enc, src); \
191             } \
192             else
193             #else
194             #define DO_POK_REGEXP(enc, src, svt) /*no-op*/
195             #endif
196              
197              
198              
199             #ifdef SvIsBOOL
200             #define _SRL_CHECK_BOOL(enc, src, svt) \
201             if (enc->protocol_version >=5 && SvIsBOOL(src)) { \
202             if (PV == PL_No) { \
203             srl_buf_cat_char(&enc->buf, SRL_HDR_NO); \
204             } else { \
205             assert(PV == Pl_Yes); \
206             srl_buf_cat_char(&enc->buf, SRL_HDR_YES); \
207             } \
208             } \
209             else
210             #else
211             #define _SRL_CHECK_BOOL(enc, src, svt)
212             #endif
213              
214             #define _SRL_IF_SIMPLE_DIRECT_DUMP_SV(enc, src, svt) \
215             if (SvPOK(src)) { \
216             STRLEN L; \
217             char *PV= SvPV(src, L); \
218             if ( SvIOK(src) ) { \
219             _SRL_CHECK_BOOL(enc, src, svt) \
220             if ( SvIV(src) == 0 ) { \
221             if ( L == 1 && PV[0] == '0' ) { \
222             /* its a true 0 */ \
223             srl_buf_cat_char(&enc->buf, SRL_HDR_POS + 0); \
224             } \
225             else { \
226             /* must be a string */ \
227             srl_dump_svpv(aTHX_ enc, src); \
228             } \
229             } \
230             else \
231             if ( \
232             !L || \
233             !isDIGIT(PV[L-1]) || \
234             ( \
235             SvIV(src) > 0 \
236             ? ( PV[0] == '0' || !isDIGIT(PV[0]) ) \
237             : ( L < 2 || PV[0] != '-' || PV[1] == '0' || !isDIGIT(PV[1]) ) \
238             ) \
239             ) { \
240             srl_dump_svpv(aTHX_ enc, src); \
241             } \
242             else { \
243             if ( SvNOK(src) ) { \
244             /* fallback to checking if the canonical stringified*/ \
245             /* int is the same as the buffer */ \
246             sv_setiv(enc->scratch_sv,SvIV(src)); \
247             if ( sv_cmp(enc->scratch_sv,src) ) { \
248             srl_dump_svpv(aTHX_ enc, src); \
249             } else { \
250             srl_dump_ivuv(aTHX_ enc, src); \
251             } \
252             } else { \
253             srl_dump_ivuv(aTHX_ enc, src); \
254             } \
255             } \
256             } \
257             else \
258             if ( SvNOK(src) ) { \
259             if ( L <= 8 || \
260             !isDIGIT(PV[0]) || \
261             !isDIGIT(PV[L-1]) || \
262             PV[L-1] == '0' || \
263             ( \
264             SvNV(src) > 0.0 \
265             ? ( PV[0] == '.' || (PV[0] == '0' && PV[1] != '.') ) \
266             : ( PV[0] != '-' || PV[1] == '.' || (PV[1] == '0' && PV[2] != '.')) \
267             ) \
268             ) { \
269             srl_dump_svpv(aTHX_ enc, src); \
270             } \
271             else { \
272             srl_dump_nv(aTHX_ enc, src); \
273             } \
274             } \
275             else { \
276             DO_POK_REGEXP(enc,src,svt) \
277             srl_dump_svpv(aTHX_ enc, src); \
278             } \
279             } \
280             else \
281             if ( SvIOK(src) ) { \
282             srl_dump_ivuv(aTHX_ enc, src); \
283             } \
284             else \
285             /* if its a float then its a float */ \
286             if (SvNOK(src)) { \
287             srl_dump_nv(aTHX_ enc, src); \
288             } \
289             else \
290             /* The POKp, IOKp, NOKp checks below deal with PVLV */ \
291             /* if its POK or POKp, then we treat it as a string */ \
292             if (SvPOKp(src)) { \
293             DO_POK_REGEXP(enc,src,svt) \
294             srl_dump_svpv(aTHX_ enc, src); \
295             } \
296             else \
297             /* if its IOKp then we treat it as an int */ \
298             if (SvIOKp(src)) { \
299             srl_dump_ivuv(aTHX_ enc, src); \
300             } \
301             else \
302             /* if its NOKp then we treat it as an nv */ \
303             if (SvNOKp(src)) { \
304             srl_dump_nv(aTHX_ enc, src); \
305             } \
306              
307             #define CALL_SRL_DUMP_SV(enc, src) STMT_START { \
308             if (!(src)) { \
309             srl_buf_cat_char(&(enc)->buf, SRL_HDR_CANONICAL_UNDEF); /* is this right? */\
310             } \
311             else \
312             { \
313             svtype svt; \
314             SvGETMAGIC(src); \
315             svt= SvTYPE((src)); \
316             if (svt < SVt_PVMG && \
317             SvREFCNT((src)) == 1 && \
318             !SvROK((src)) \
319             ) { \
320             _SRL_IF_SIMPLE_DIRECT_DUMP_SV(enc, src, svt) \
321             else { \
322             srl_dump_sv(aTHX_ (enc), (src)); \
323             } \
324             } else { \
325             srl_dump_sv(aTHX_ (enc), (src)); \
326             } \
327             } \
328             } STMT_END
329              
330             #define CALL_SRL_DUMP_SVP(enc, srcp) STMT_START { \
331             if (!(srcp)) { \
332             srl_buf_cat_char(&(enc)->buf, SRL_HDR_CANONICAL_UNDEF); /* is this right? */\
333             } else { \
334             SV *src= *srcp; \
335             CALL_SRL_DUMP_SV(enc,src); \
336             } \
337             } STMT_END
338              
339             /* This is fired when we exit the Perl pseudo-block.
340             * It frees our encoder and all. Put encoder-level cleanup
341             * logic here so that we can simply use croak/longjmp for
342             * exception handling. Makes life vastly easier!
343             */
344             void
345 1189144           srl_destructor_hook(pTHX_ void *p)
346             {
347 1189144           srl_encoder_t *enc = (srl_encoder_t *)p;
348             /* Do not auto-destroy encoder if set to be re-used */
349 1189144 100         if (!SRL_ENC_HAVE_OPTION(enc, SRL_F_REUSE_ENCODER)) {
350             /* Exception cleanup. Under normal operation, we should have
351             * assigned NULL to buf_start after we're done. */
352 244250           srl_destroy_encoder(aTHX_ enc);
353             }
354             else {
355 944894           srl_clear_encoder(aTHX_ enc);
356             }
357 1189144           }
358              
359             SRL_STATIC_INLINE void
360 1399673           srl_clear_seen_hashes(pTHX_ srl_encoder_t *enc)
361             {
362 1399673 100         if (enc->ref_seenhash != NULL)
363 1279067           PTABLE_clear(enc->ref_seenhash);
364 1399673 100         if (enc->freezeobj_svhash != NULL)
365 4           PTABLE_clear_dec(aTHX_ enc->freezeobj_svhash);
366 1399673 100         if (enc->str_seenhash != NULL)
367 1279060           PTABLE_clear(enc->str_seenhash);
368 1399673 100         if (enc->weak_seenhash != NULL)
369 18           PTABLE_clear(enc->weak_seenhash);
370 1399673 100         if (enc->string_deduper_hv != NULL)
371 94661           hv_clear(enc->string_deduper_hv);
372 1399673           }
373              
374             void
375 944894           srl_clear_encoder(pTHX_ srl_encoder_t *enc)
376             {
377             /* TODO I think this could just be made an assert. */
378 944894 50         if (!SRL_ENC_HAVE_OPER_FLAG(enc, SRL_OF_ENCODER_DIRTY)) {
379 0           warn("Sereal Encoder being cleared but in virgin state. That is unexpected.");
380             }
381              
382 944894           enc->recursion_depth = 0;
383 944894           srl_clear_seen_hashes(aTHX_ enc);
384              
385 944894           enc->buf.pos = enc->buf.start;
386             /* tmp_buf.start may be NULL for an unused tmp_buf, but so what? */
387 944894           enc->tmp_buf.pos = enc->tmp_buf.start;
388              
389 944894           SRL_SET_BODY_POS(&enc->buf, enc->buf.start);
390              
391 944894           SRL_ENC_RESET_OPER_FLAG(enc, SRL_OF_ENCODER_DIRTY);
392 944894           }
393              
394             void
395 244588           srl_destroy_encoder(pTHX_ srl_encoder_t *enc)
396             {
397 244588           srl_buf_free_buffer(aTHX_ &enc->buf);
398              
399             /* Free tmp buffer only if it was allocated at all. */
400 244588 100         if (enc->tmp_buf.start != NULL)
401 59           srl_buf_free_buffer(aTHX_ &enc->tmp_buf);
402              
403 244588           srl_destroy_snappy_workmem(aTHX_ enc->snappy_workmem);
404              
405 244588 100         if (enc->ref_seenhash != NULL)
406 116439           PTABLE_free(enc->ref_seenhash);
407 244588 100         if (enc->freezeobj_svhash != NULL)
408 3           PTABLE_free(enc->freezeobj_svhash);
409 244588 100         if (enc->str_seenhash != NULL)
410 43214           PTABLE_free(enc->str_seenhash);
411 244588 100         if (enc->weak_seenhash != NULL)
412 18           PTABLE_free(enc->weak_seenhash);
413 244588 100         if (enc->string_deduper_hv != NULL)
414 6067           SvREFCNT_dec(enc->string_deduper_hv);
415              
416 244588           SvREFCNT_dec(enc->sereal_string_sv);
417 244588           SvREFCNT_dec(enc->scratch_sv);
418              
419 244588           Safefree(enc);
420 244588           }
421              
422             /* allocate an empty encoder struct - flags still to be set up */
423             SRL_STATIC_INLINE srl_encoder_t *
424 244588           srl_empty_encoder_struct(pTHX)
425             {
426             srl_encoder_t *enc;
427 244588           Newxz(enc, 1, srl_encoder_t);
428 244588 50         if (enc == NULL)
429 0           croak("Out of memory");
430              
431             /* Init buffer struct */
432 244588 50         if (expect_false( srl_buf_init_buffer(aTHX_ &(enc->buf), INITIALIZATION_SIZE) != 0 )) {
433 0           Safefree(enc);
434 0           croak("Out of memory");
435             }
436              
437 244588           enc->protocol_version = SRL_PROTOCOL_VERSION;
438 244588           enc->max_recursion_depth = DEFAULT_MAX_RECUR_DEPTH;
439              
440 244588           return enc;
441             }
442              
443             #define my_hv_fetchs(he,val,opt,idx) STMT_START { \
444             he = hv_fetch_ent(opt, options[idx].sv, 0, options[idx].hash); \
445             if (he) \
446             val= HeVAL(he); \
447             else \
448             val= NULL; \
449             } STMT_END
450              
451             /* Builds the C-level configuration and state struct. */
452             srl_encoder_t *
453 244586           srl_build_encoder_struct(pTHX_ HV *opt, sv_with_hash *options)
454             {
455             srl_encoder_t *enc;
456             SV *val;
457             HE *he;
458              
459 244586           enc = srl_empty_encoder_struct(aTHX);
460 244586           enc->flags = 0;
461 244586           enc->scratch_sv= newSViv(0);
462              
463             /* load options */
464 244586 100         if (opt != NULL) {
465 244025           int undef_unknown = 0;
466 244025           int compression_format = 0;
467             /* SRL_F_SHARED_HASHKEYS on by default */
468 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_NO_SHARED_HASHKEYS);
469 244025 100         if ( !val || !SvTRUE(val) )
    50          
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
470 243982           SRL_ENC_SET_OPTION(enc, SRL_F_SHARED_HASHKEYS);
471              
472             /* Needs to be before the snappy options */
473             /* enc->protocol_version defaults to SRL_PROTOCOL_VERSION. */
474 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_PROTOCOL_VERSION);
475 244025 100         if (val && SvOK(val)) {
    50          
    0          
    0          
476 243784 50         enc->protocol_version = SvUV(val);
477 487568 50         if (enc->protocol_version < 1
478 243784 50         || enc->protocol_version > SRL_PROTOCOL_VERSION)
479             {
480 0           croak("Specified Sereal protocol version (%"UVuf") is invalid",
481 0           (UV)enc->protocol_version);
482             }
483             }
484             else {
485             /* Compatibility with the old way to specify older protocol version */
486 241 50         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_USE_PROTOCOL_V1);
487 241 50         if ( val && SvTRUE(val) )
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
488 0           enc->protocol_version = 1;
489             }
490              
491 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_CROAK_ON_BLESS);
492 244025 100         if ( val && SvTRUE(val) )
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
493 1           SRL_ENC_SET_OPTION(enc, SRL_F_CROAK_ON_BLESS);
494              
495 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_NO_BLESS_OBJECTS);
496 244025 100         if ( val && SvTRUE(val) )
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
497 1           SRL_ENC_SET_OPTION(enc, SRL_F_NO_BLESS_OBJECTS);
498              
499 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_FREEZE_CALLBACKS);
500 244025 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
501 16255 50         if (SRL_ENC_HAVE_OPTION(enc, SRL_F_NO_BLESS_OBJECTS))
502 0           croak("The no_bless_objects and freeze_callback_support "
503             "options are mutually exclusive");
504 16255           SRL_ENC_SET_OPTION(enc, SRL_F_ENABLE_FREEZE_SUPPORT);
505 16255           enc->sereal_string_sv = newSVpvs("Sereal");
506             }
507              
508 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_COMPRESS);
509 244025 100         if (val) {
510 40630 50         compression_format = SvIV(val);
511              
512             /* See also Encoder.pm's constants */
513 40630           switch (compression_format) {
514             case 0: /* uncompressed */
515 0           break;
516             case 1:
517 0           SRL_ENC_SET_OPTION(enc, SRL_F_COMPRESS_SNAPPY_INCREMENTAL);
518 0           break;
519             case 2:
520 24378           SRL_ENC_SET_OPTION(enc, SRL_F_COMPRESS_ZLIB);
521 24378 50         if (enc->protocol_version < 3)
522 0           croak("Zlib compression was introduced in protocol version 3 and you are asking for only version %i", (int)enc->protocol_version);
523              
524 24378           enc->compress_level = MZ_DEFAULT_COMPRESSION;
525 24378 50         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_COMPRESS_LEVEL);
526 24378 50         if ( val && SvTRUE(val) ) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
527 0 0         IV lvl = SvIV(val);
528 0 0         if (expect_false( lvl < 1 || lvl > 10 )) /* Sekrit: compression lvl 10 is a miniz thing that doesn't exist in normal zlib */
    0          
    0          
529 0           croak("'compress_level' needs to be between 1 and 9");
530 0           enc->compress_level = lvl;
531             }
532 24378           break;
533             case 3:
534 16252           SRL_ENC_SET_OPTION(enc, SRL_F_COMPRESS_ZSTD);
535 16252 50         if (enc->protocol_version < 3)
536 0           croak("zstd compression was introduced in protocol version 3 and you are asking for only version %i", (int)enc->protocol_version);
537              
538 16252           enc->compress_level = 3; /* default compression level */
539 16252 50         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_COMPRESS_LEVEL);
540 16252 50         if ( val && SvTRUE(val) ) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
541 0 0         IV lvl = SvIV(val);
542 0 0         if (expect_false( lvl < 1 || lvl > 22 )) /* TODO: ZSTD_maxCLevel() */
    0          
    0          
543 0           croak("'compress_level' needs to be between 1 and 22");
544 0           enc->compress_level = lvl;
545             }
546 16252           break;
547             default:
548 40630           croak("Invalid Sereal compression format");
549             }
550             }
551             else {
552             /* Only bother with old compression options if necessary */
553              
554 203395 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_SNAPPY_INCR);
555 203395 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
556 32504           SRL_ENC_SET_OPTION(enc, SRL_F_COMPRESS_SNAPPY_INCREMENTAL);
557 32504           compression_format = 1;
558             }
559             else {
560             /* snappy_incr >> snappy */
561 170891 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_SNAPPY);
562 170891 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
563             /* incremental is the new black in V2 */
564 40630 100         if (expect_true( enc->protocol_version > 1 ))
565 32504           SRL_ENC_SET_OPTION(enc, SRL_F_COMPRESS_SNAPPY_INCREMENTAL);
566             else
567 8126           SRL_ENC_SET_OPTION(enc, SRL_F_COMPRESS_SNAPPY);
568 40630           compression_format = 1;
569             }
570             }
571             }
572              
573 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_UNDEF_UNKNOWN);
574 244025 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
575 1           undef_unknown = 1;
576 1           SRL_ENC_SET_OPTION(enc, SRL_F_UNDEF_UNKNOWN);
577             }
578              
579 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_SORT_KEYS);
580 244025 100         if ( !val )
581 203389 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_CANONICAL);
582 244025 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
583 97524           SRL_ENC_SET_OPTION(enc, SRL_F_SORT_KEYS);
584 97524 50         if (SvIV(val) > 1) {
    100          
585 24378           SRL_ENC_SET_OPTION(enc, SRL_F_SORT_KEYS_PERL);
586 24378 50         if (SvIV(val) > 2) {
    100          
587 12189           SRL_ENC_SET_OPTION(enc, SRL_F_SORT_KEYS_PERL_REV);
588             }
589             }
590             }
591              
592 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_CANONICAL_REFS);
593 244025 100         if ( !val )
594 244023 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_CANONICAL);
595 244025 100         if ( val && SvTRUE(val) )
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
596 56890           SRL_ENC_SET_OPTION(enc, SRL_F_CANONICAL_REFS);
597              
598 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_ALIASED_DEDUPE_STRINGS);
599 244025 100         if ( val && SvTRUE(val) )
    50          
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
600 43           SRL_ENC_SET_OPTION(enc, SRL_F_ALIASED_DEDUPE_STRINGS | SRL_F_DEDUPE_STRINGS);
601             else {
602 243982 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_DEDUPE_STRINGS);
603 243982 100         if ( val && SvTRUE(val) )
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
604 16294           SRL_ENC_SET_OPTION(enc, SRL_F_DEDUPE_STRINGS);
605             }
606              
607 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_STRINGIFY_UNKNOWN);
608 244025 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
609 8 50         if (expect_false( undef_unknown ))
610 0           croak("'undef_unknown' and 'stringify_unknown' "
611             "options are mutually exclusive");
612 8           SRL_ENC_SET_OPTION(enc, SRL_F_STRINGIFY_UNKNOWN);
613             }
614              
615 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_WARN_UNKNOWN);
616 244025 100         if ( val && SvTRUE(val) ) {
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
617 3           SRL_ENC_SET_OPTION(enc, SRL_F_WARN_UNKNOWN);
618 3 50         if (SvIV(val) < 0)
    100          
619 1           SRL_ENC_SET_OPTION(enc, SRL_F_NOWARN_UNKNOWN_OVERLOAD);
620             }
621              
622 244025 100         if (compression_format) {
623 113764           enc->compress_threshold = 1024;
624 113764 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_COMPRESS_THRESHOLD);
625 113764 100         if ( val && SvOK(val) )
    50          
    0          
    0          
626 20315 50         enc->compress_threshold = SvIV(val);
627 93449 100         else if (compression_format == 1) {
628             /* compression_format==1 is some sort of Snappy */
629 73134 50         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_SNAPPY_THRESHOLD);
630 73134 50         if ( val && SvOK(val) )
    0          
    0          
    0          
631 0 0         enc->compress_threshold = SvIV(val);
632             }
633             }
634              
635 244025 100         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_MAX_RECURSION_DEPTH);
636 244025 100         if ( val && SvTRUE(val) )
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
637 2 50         enc->max_recursion_depth = SvUV(val);
638              
639 244025 50         my_hv_fetchs(he, val, opt, SRL_ENC_OPT_IDX_USE_STANDARD_DOUBLE);
640 244025 50         if ( val && SvTRUE(val) )
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
641 244025           SRL_ENC_SET_OPTION(enc, SRL_F_USE_STANDARD_DOUBLE);
642             }
643             else {
644             /* SRL_F_SHARED_HASHKEYS on by default */
645 561           SRL_ENC_SET_OPTION(enc, SRL_F_SHARED_HASHKEYS);
646             }
647              
648             DEBUG_ASSERT_BUF_SANE(&enc->buf);
649 244586           return enc;
650             }
651              
652             /* clone an encoder without current state */
653             srl_encoder_t *
654 2           srl_build_encoder_struct_alike(pTHX_ srl_encoder_t *proto)
655             {
656             srl_encoder_t *enc;
657 2           enc = srl_empty_encoder_struct(aTHX);
658              
659             /* Copy the configuration-type, non-ephemeral attributes */
660 2           enc->flags = proto->flags;
661 2           enc->max_recursion_depth = proto->max_recursion_depth;
662 2           enc->compress_threshold = proto->compress_threshold;
663 2 100         if (expect_false(SRL_ENC_HAVE_OPTION(enc, SRL_F_ENABLE_FREEZE_SUPPORT))) {
664 1           enc->sereal_string_sv = newSVpvs("Sereal");
665             }
666 2           enc->protocol_version = proto->protocol_version;
667 2           enc->scratch_sv= newSViv(0);
668             DEBUG_ASSERT_BUF_SANE(&enc->buf);
669 2           return enc;
670             }
671              
672             SRL_STATIC_INLINE PTABLE_t *
673 43214           srl_init_string_hash(srl_encoder_t *enc)
674             {
675 43214           enc->str_seenhash = PTABLE_new_size(4);
676 43214           return enc->str_seenhash;
677             }
678              
679             SRL_STATIC_INLINE PTABLE_t *
680 116439           srl_init_ref_hash(srl_encoder_t *enc)
681             {
682 116439           enc->ref_seenhash = PTABLE_new_size(4);
683 116439           return enc->ref_seenhash;
684             }
685              
686             SRL_STATIC_INLINE PTABLE_t *
687 18           srl_init_weak_hash(srl_encoder_t *enc)
688             {
689 18           enc->weak_seenhash = PTABLE_new_size(3);
690 18           return enc->weak_seenhash;
691             }
692              
693             SRL_STATIC_INLINE PTABLE_t *
694 3           srl_init_freezeobj_svhash(srl_encoder_t *enc)
695             {
696 3           enc->freezeobj_svhash = PTABLE_new_size(3);
697 3           return enc->freezeobj_svhash;
698             }
699              
700             SRL_STATIC_INLINE HV *
701 6067           srl_init_string_deduper_hv(pTHX_ srl_encoder_t *enc)
702             {
703 6067           enc->string_deduper_hv = newHV();
704 6067           return enc->string_deduper_hv;
705             }
706              
707              
708             void
709 1189144           srl_write_header(pTHX_ srl_encoder_t *enc, SV *user_header_src, const U32 compress_flags)
710             {
711             /* 4th to 8th bit are flags. Using 4th for snappy flag. FIXME needs to go in spec. */
712              
713 1189144           U8 flags= srl_get_compression_header_flag(compress_flags);
714 1189144           const U8 version_and_flags = (U8)enc->protocol_version | flags;
715              
716             /* 4 byte magic string + proto version
717             * + potentially uncompressed size varint
718             * + 1 byte varint that indicates zero-length header */
719 1189144 50         BUF_SIZE_ASSERT(&enc->buf, sizeof(SRL_MAGIC_STRING) + 1 + 1);
720 1189144 100         if (expect_true( enc->protocol_version > 2 ))
721 937300           srl_buf_cat_str_s_nocheck(&enc->buf, SRL_MAGIC_STRING_HIGHBIT);
722             else
723 251844           srl_buf_cat_str_s_nocheck(&enc->buf, SRL_MAGIC_STRING);
724 1189144           srl_buf_cat_char_nocheck(&enc->buf, version_and_flags);
725 1189144 100         if (user_header_src == NULL) {
726 734365           srl_buf_cat_char_nocheck(&enc->buf, '\0'); /* variable header length (0 right now) */
727             }
728             else {
729             STRLEN user_data_len;
730              
731 454779 50         if (expect_false( enc->protocol_version < 2 ))
732 0           croak("Cannot serialize user header data in Sereal protocol V1 mode!");
733              
734             /* Allocate tmp buffer for swapping if necessary,
735             * will be cleaned up automatically */
736 454779 100         if (enc->tmp_buf.start == NULL)
737 59           srl_buf_init_buffer(aTHX_ &enc->tmp_buf, INITIALIZATION_SIZE);
738              
739             /* Write document body (for header) into separate buffer */
740 454779           srl_buf_swap_buffer(aTHX_ &enc->tmp_buf, &enc->buf);
741 454779 50         SRL_ENC_UPDATE_BODY_POS(enc);
742 454779           srl_dump_sv(aTHX_ enc, user_header_src);
743 454779           srl_fixup_weakrefs(aTHX_ enc); /* more bodies to follow */
744 454779           srl_clear_seen_hashes(aTHX_ enc); /* more bodies to follow */
745              
746             /* Swap main buffer back in, encode header length&bitfield, copy user header data */
747 454779           user_data_len = BUF_POS_OFS(&enc->buf);
748 454779           srl_buf_swap_buffer(aTHX_ &enc->buf, &enc->tmp_buf);
749              
750 454779 50         BUF_SIZE_ASSERT(&enc->buf, user_data_len + 1 + SRL_MAX_VARINT_LENGTH); /* +1 for bit field, +X for header len */
751              
752             /* Encode header length */
753 454779           srl_buf_cat_varint_nocheck(aTHX_ &enc->buf, 0, (UV)(user_data_len + 1)); /* +1 for bit field */
754             /* Encode bitfield */
755 454779           srl_buf_cat_char_nocheck(&enc->buf, '\1');
756             /* Copy user header data */
757 454779           Copy(enc->tmp_buf.start, enc->buf.pos, user_data_len, char);
758 454779           enc->buf.pos += user_data_len;
759              
760 454779           enc->tmp_buf.pos = enc->tmp_buf.start; /* reset tmp buffer just to be clean */
761             }
762 1189144           }
763              
764             /* The following is to handle the fact that under normal build options
765             * VC6 will compare all floating point at 80 bits of precision, regardless
766             * regardless of the type.
767             * By setting the vars to "volatile" we avoid this behavior.
768             * Hopefully this fixes various remaining Win32 test failures we see.
769             *
770             * Note this patch could not have been written without Bulk88's help.
771             * Thanks a lot man!
772             *
773             * Comment from Bulk88:
774             * -O1 and -O2 tested and both of those 2 "failed"
775             * -Op - Improve Float Consistency does not have the bug
776             * Problem not seen in VC 2003
777             * I (Bulk88) don't have a VC 2002 to test v13 officially
778             *
779             */
780             #if defined(_MSC_VER)
781             # if _MSC_VER < 1300
782             # define MS_VC6_WORKAROUND_VOLATILE volatile
783             # else
784             # define MS_VC6_WORKAROUND_VOLATILE
785             # endif
786             #else
787             # define MS_VC6_WORKAROUND_VOLATILE
788             #endif
789              
790              
791             /* Code for serializing floats */
792             SRL_STATIC_INLINE void
793 225307           srl_dump_nv(pTHX_ srl_encoder_t *enc, SV *src)
794             {
795 225307 50         NV nv= SvNV(src);
796 225307           MS_VC6_WORKAROUND_VOLATILE float f= (float)nv;
797 225307           MS_VC6_WORKAROUND_VOLATILE double d= (double)nv;
798             #ifdef HAS_QUADMATH
799             #define LONG_FLOAT_MIN_VER 5
800             #else
801             #define LONG_FLOAT_MIN_VER 4
802             #endif
803             /* TODO: this logic could be reworked to not duplicate so much code, which will help on win32 */
804 225307 100         if ( f == nv || nv != nv ) {
    50          
805 14892 50         BUF_SIZE_ASSERT(&enc->buf, 1 + sizeof(f)); /* tag + payload */
806 14892           srl_buf_cat_char_nocheck(&enc->buf, SRL_HDR_FLOAT);
807 14892           Copy((char *)&f, enc->buf.pos, sizeof(f), char);
808 14892           enc->buf.pos += sizeof(f);
809             } else if (
810             !HAS_LONG_FLOAT ||
811             d == nv ||
812             SRL_ENC_HAVE_OPTION(enc,SRL_F_USE_STANDARD_DOUBLE) ||
813             (enc->protocol_version < LONG_FLOAT_MIN_VER)
814             ) {
815 210415 50         BUF_SIZE_ASSERT(&enc->buf, 1 + sizeof(d)); /* tag + payload */
816 210415           srl_buf_cat_char_nocheck(&enc->buf, SRL_HDR_DOUBLE);
817 210415           Copy((char *)&d, enc->buf.pos, sizeof(d), char);
818 210415           enc->buf.pos += sizeof(d);
819             } else {
820             assert(HAS_LONG_FLOAT);
821             BUF_SIZE_ASSERT(&enc->buf, 1 + sizeof(nv)); /* tag + payload */
822             srl_buf_cat_char_nocheck(&enc->buf,
823             #ifdef HAS_QUADMATH
824             SRL_HDR_FLOAT_128
825             #else
826             SRL_HDR_LONG_DOUBLE
827             #endif
828             );
829             Copy((char *)&nv, enc->buf.pos, sizeof(nv), char);
830             #if SRL_EXTENDED_PRECISION_LONG_DOUBLE
831             /* x86 uses an 80 bit extended precision. on 64 bit machines
832             * this is 16 bytes long, and on 32 bits its is 12 bytes long.
833             * the unused 2/6 bytes are not necessarily zeroed, potentially
834             * allowing internal memory to be exposed. We therefore zero
835             * the unused bytes here. */
836             memset(enc->buf.pos+10, 0, sizeof(nv) - 10);
837             #endif
838             enc->buf.pos += sizeof(nv);
839             }
840 225307           }
841              
842              
843             /* Code for serializing any SINGLE integer type */
844             SRL_STATIC_INLINE void
845 1324564           srl_dump_ivuv(pTHX_ srl_encoder_t *enc, SV *src)
846             {
847             char hdr;
848             /* TODO for the time being, we just won't ever use NUMLIST types because that's
849             * a fair amount of extra implementation work. The decoders won't care and
850             * we're just wasting some space. */
851             /* TODO optimize! */
852              
853             /* FIXME find a way to express the condition without repeated SvIV/SvUV */
854 1324564 100         if (expect_true( SvIOK_UV(src) || SvIV(src) >= 0 )) {
    50          
    100          
    0          
    100          
855 1100245 100         const UV num = SvUV(src); /* FIXME is SvUV_nomg good enough because of the GET magic in dump_sv? SvUVX after having checked the flags? */
856 1100245 100         if (num <= 15) {
857             /* encodable as POS */
858 195509           hdr = SRL_HDR_POS_LOW | (unsigned char)num;
859 195509           srl_buf_cat_char(&enc->buf, hdr);
860             }
861             else {
862 1100245           srl_buf_cat_varint(aTHX_ &enc->buf, SRL_HDR_VARINT, num);
863             }
864             }
865             else {
866 224319 50         const IV num = SvIV(src);
867 224319 100         if (num >= -16) {
868             /* encodable as NEG */
869 29813           hdr = SRL_HDR_NEG_LOW | ((unsigned char)num + 32);
870 29813           srl_buf_cat_char(&enc->buf, hdr);
871             }
872             else {
873             /* Needs ZIGZAG */
874 194506           srl_buf_cat_zigzag(aTHX_ &enc->buf, SRL_HDR_ZIGZAG, num);
875             }
876             }
877 1324564           }
878              
879             /* Dumps the tag and class name of an object doing all necessary callbacks or
880             * exception-throwing.
881             * The provided SV must already have been identified as a Perl object
882             * using sv_isobject().
883             * If the return value is not NULL, then it's the actual object content that
884             * needs to be serialized by the caller. */
885             SRL_STATIC_INLINE SV *
886 64906           srl_get_frozen_object(pTHX_ srl_encoder_t *enc, SV *src, SV *referent)
887             {
888             assert(sv_isobject(src)); /* duplicate asserts are "free" */
889              
890             /* Check for FREEZE support */
891 64906 100         if (expect_false( SRL_ENC_HAVE_OPTION(enc, SRL_F_ENABLE_FREEZE_SUPPORT) )) {
892 4448           HV *stash = SvSTASH(referent);
893 4448           GV *method = NULL;
894             assert(stash != NULL);
895 4448           method = gv_fetchmethod_autoload(stash, "FREEZE", 0);
896              
897 4448 100         if (expect_false( method != NULL )) {
898 8           SV *replacement= NULL;
899 8 100         PTABLE_t *freezeobj_svhash = SRL_GET_FREEZEOBJ_SVHASH(enc);
900 8 100         if (SvREFCNT(referent)>1) {
901 5           replacement= (SV *) PTABLE_fetch(freezeobj_svhash, referent);
902             }
903 8 100         if (!replacement) {
904             int count;
905 7           dSP;
906 7           ENTER;
907 7           SAVETMPS;
908 7 50         PUSHMARK(SP);
909              
910 7 50         EXTEND(SP, 2);
911 7           PUSHs(src);
912 7           PUSHs(enc->sereal_string_sv); /* not NULL if SRL_F_ENABLE_FREEZE_SUPPORT is set */
913 7           replacement= (SV*)newAV();
914 7           PTABLE_store(freezeobj_svhash, referent, replacement);
915              
916 7           PUTBACK;
917 7           count = call_sv((SV *)GvCV(method), G_ARRAY);
918             /* TODO explore method lookup caching */
919 7           SPAGAIN;
920              
921 18 100         while ( count-- > 0) {
922 11           SV *tmp = POPs;
923 11           SvREFCNT_inc(tmp);
924 11 50         if (!av_store((AV*)replacement,count,tmp))
925 0           croak("Failed to push value into array");
926             }
927              
928 7           PUTBACK;
929 7 50         FREETMPS;
930 7           LEAVE;
931             }
932 8           return replacement;
933             }
934             }
935 64898           return NULL;
936              
937             }
938              
939             /* Outputs a bless header and the class name (as some form of string or COPY).
940             * Caller then has to output the actual reference payload.
941             * If it returns 1 it means the classname was written out and should NOT
942             * be overwritten by the ref rewrite logic (which handles REFP).
943             * If it returns 0 it means no classname was output. */
944             SRL_STATIC_INLINE int
945 64906           srl_dump_classname(pTHX_ srl_encoder_t *enc, SV *referent, SV *replacement)
946             {
947             /* Check that we actually want to support objects */
948 64906 100         if (expect_false( SRL_ENC_HAVE_OPTION(enc, SRL_F_CROAK_ON_BLESS)) ) {
949 1           croak("Attempted to serialize blessed reference. Serializing objects "
950             "using Sereal::Encoder was explicitly disabled using the "
951             "'croak_on_bless' option.");
952 64905 100         } else if (expect_false( SRL_ENC_HAVE_OPTION(enc, SRL_F_NO_BLESS_OBJECTS) )) {
953 1           return 0;
954             } else {
955 64904           const HV *stash = SvSTASH(referent);
956 64904 100         PTABLE_t *string_seenhash = SRL_GET_STR_PTR_SEENHASH(enc);
957 64904           svtype svt= SvTYPE(referent);
958 64904 100         int is_av_or_hv= (svt == SVt_PVAV || svt== SVt_PVHV);
    100          
959 64904           ptrdiff_t oldoffset= is_av_or_hv
960             ? 0
961 64904 100         : (ptrdiff_t)PTABLE_fetch(string_seenhash, referent);
962              
963 64904 100         if (oldoffset) {
964 28912           return 0;
965             } else {
966 35992 100         svt= replacement ? SvTYPE(replacement) : SvTYPE(referent);
967 35992 50         if (SRL_UNSUPPORTED_SvTYPE(svt)) {
    100          
    50          
    50          
968 13           return 0;
969             }
970 35979           oldoffset= (ptrdiff_t)PTABLE_fetch(string_seenhash, (SV *)stash);
971             }
972              
973 35979 100         if (oldoffset != 0) {
974             /* Issue COPY instead of literal class name string */
975 900 100         srl_buf_cat_varint(aTHX_ &enc->buf,
976 900           expect_false(replacement) ? SRL_HDR_OBJECTV_FREEZE : SRL_HDR_OBJECTV,
977             (UV)oldoffset);
978             }
979             else {
980 35079 50         const char *class_name = HvNAME_get(stash);
    50          
    50          
    0          
    50          
    50          
981 35079 50         const size_t len = HvNAMELEN_get(stash);
    50          
    50          
    0          
    50          
    50          
982              
983             /* First save this new string (well, the HV * that it is represented by) into the string
984             * dedupe table.
985             * By saving the ptr to the HV, we only dedupe class names with class names, though
986             * this seems a small price to pay for not having to keep a full string table.
987             * At least, we can safely use the same PTABLE to store the ptrs to hashkeys since
988             * the set of pointers will never collide.
989             * /me bows to Yves for the delightfully evil hack. */
990 35079 100         srl_buf_cat_char(&enc->buf, expect_false(replacement) ? SRL_HDR_OBJECT_FREEZE : SRL_HDR_OBJECT);
991              
992             /* remember current offset before advancing it */
993 35079           PTABLE_store(string_seenhash, (void *)stash, INT2PTR(void *, BODY_POS_OFS(&enc->buf)));
994              
995             /* HvNAMEUTF8 not in older perls and it would be 0 for those anyway */
996             #if PERL_VERSION >= 16
997 35079 50         srl_dump_pv(aTHX_ enc, class_name, len, HvNAMEUTF8(stash));
    50          
    50          
    0          
    50          
    50          
    50          
998             #else
999             srl_dump_pv(aTHX_ enc, class_name, len, 0);
1000             #endif
1001             }
1002 35979 100         if (is_av_or_hv) {
1003 47           return 0;
1004             } else {
1005             /* use the string_seenhash to track which items we have seen before */
1006 35932           PTABLE_store(string_seenhash, (void *)referent, INT2PTR(void *, BODY_POS_OFS(&enc->buf)));
1007 35932           return 1;
1008             }
1009             }
1010             return 0;
1011             }
1012              
1013              
1014             /* Prepare encoder for encoding: Clone if already in use since
1015             * encoders aren't "reentrant". Set as in use and register cleanup
1016             * routine with Perl. */
1017             SRL_STATIC_INLINE srl_encoder_t *
1018 1189144           srl_prepare_encoder(pTHX_ srl_encoder_t *enc)
1019             {
1020             /* Check whether encoder is in use and create a new one on the
1021             * fly if necessary. Should only happen in edge cases such as
1022             * FREEZE hooks that serialize things using the same encoder
1023             * object. */
1024 1189144 100         if (SRL_ENC_HAVE_OPER_FLAG(enc, SRL_OF_ENCODER_DIRTY)) {
1025 2           srl_encoder_t * const proto = enc;
1026 2           enc = srl_build_encoder_struct_alike(aTHX_ proto);
1027 2           SRL_ENC_RESET_OPTION(enc, SRL_F_REUSE_ENCODER);
1028             }
1029             /* Set to being in use */;
1030 1189144           SRL_ENC_SET_OPER_FLAG(enc, SRL_OF_ENCODER_DIRTY);
1031              
1032             /* Register our structure for destruction on scope exit */
1033 1189144           SAVEDESTRUCTOR_X(&srl_destructor_hook, (void *)enc);
1034              
1035 1189144           return enc;
1036             }
1037              
1038             SRL_STATIC_INLINE srl_encoder_t *
1039 1189144           srl_dump_data_structure(pTHX_ srl_encoder_t *enc, SV *src, SV *user_header_src)
1040             {
1041             U32 compress_flags;
1042              
1043 1189144           enc = srl_prepare_encoder(aTHX_ enc);
1044 1189144           compress_flags= SRL_ENC_HAVE_OPTION(enc, SRL_F_COMPRESS_FLAGS_MASK);
1045              
1046 1189144 100         if (expect_false(compress_flags))
1047             { /* Have some sort of compression */
1048             ptrdiff_t sereal_header_len;
1049             STRLEN uncompressed_body_length;
1050 552432           const STRLEN max_len = (1L << 32) - 1;
1051              
1052             /* Alas, have to write entire packet first since the header length
1053             * will determine offsets. */
1054 552432           srl_write_header(aTHX_ enc, user_header_src, compress_flags);
1055 552432           sereal_header_len = BUF_POS_OFS(&enc->buf);
1056 552432 100         SRL_ENC_UPDATE_BODY_POS(enc);
1057 552432           srl_dump_sv(aTHX_ enc, src);
1058 552432           srl_fixup_weakrefs(aTHX_ enc);
1059             assert(BUF_POS_OFS(&enc->buf) > sereal_header_len);
1060 552432           uncompressed_body_length = BUF_POS_OFS(&enc->buf) - sereal_header_len;
1061              
1062 552432 100         if ((uncompressed_body_length < (STRLEN)enc->compress_threshold) || uncompressed_body_length > max_len) {
    50          
1063 353682 50         if (uncompressed_body_length > max_len) {
1064             /* we dont support SNAPPY on super long buffers, it has a 2**32 limit
1065             * and we currently don't support splitting things up. See Issue #88 */
1066 0           warn("disabling SNAPPY compression as buffer is too large!");
1067             }
1068             /* Don't bother with compression at all if we have less than $threshold bytes of payload */
1069 353682           srl_reset_compression_header_flag(&enc->buf);
1070             }
1071             else { /* Do Snappy or zlib compression of body */
1072 198750           srl_compress_body(aTHX_ &enc->buf, sereal_header_len,
1073 198750           compress_flags, enc->compress_level,
1074             &enc->snappy_workmem);
1075              
1076 552432 100         SRL_ENC_UPDATE_BODY_POS(enc);
1077             DEBUG_ASSERT_BUF_SANE(&enc->buf);
1078             }
1079             } /* End of "want compression?" */
1080             else
1081             {
1082 636712           srl_write_header(aTHX_ enc, user_header_src, compress_flags);
1083 636712 100         SRL_ENC_UPDATE_BODY_POS(enc);
1084 636712           srl_dump_sv(aTHX_ enc, src);
1085 636708           srl_fixup_weakrefs(aTHX_ enc);
1086             }
1087              
1088             /* NOT doing a
1089             * SRL_ENC_RESET_OPER_FLAG(enc, SRL_OF_ENCODER_DIRTY);
1090             * here because we're relying on the SAVEDESTRUCTOR_X call. */
1091 1189140           return enc;
1092             }
1093              
1094             SV *
1095 1189144           srl_dump_data_structure_mortal_sv(pTHX_ srl_encoder_t *enc, SV *src, SV *user_header_src, const U32 flags)
1096             {
1097             assert(enc);
1098 1189144           enc = srl_dump_data_structure(aTHX_ enc, src, user_header_src);
1099             assert(enc->buf.start && enc->buf.pos && enc->buf.pos > enc->buf.start);
1100              
1101 1189140 100         if ( flags && /* for now simpler and equivalent to: flags == SRL_ENC_SV_REUSE_MAYBE */
    100          
1102 118374 100         (BUF_POS_OFS(&enc->buf) > 20 && BUF_SPACE(&enc->buf) < BUF_POS_OFS(&enc->buf) )
1103             ){
1104             /* If not wasting more than 2x memory - FIXME fungible */
1105 59887           SV *sv = sv_2mortal(newSV_type(SVt_PV));
1106 59887           SvPV_set(sv, (char *) enc->buf.start);
1107 59887           SvLEN_set(sv, BUF_SIZE(&enc->buf));
1108 59887           SvCUR_set(sv, BUF_POS_OFS(&enc->buf));
1109 59887           SvPOK_on(sv);
1110 59887           enc->buf.start = enc->buf.pos = NULL; /* no need to free these guys now */
1111 59887           return sv;
1112             }
1113              
1114 1129253           return sv_2mortal(newSVpvn((char *)enc->buf.start, (STRLEN)BUF_POS_OFS(&enc->buf)));
1115             }
1116              
1117             SRL_STATIC_INLINE void
1118 1643919           srl_fixup_weakrefs(pTHX_ srl_encoder_t *enc)
1119             {
1120 1643919           PTABLE_t *weak_seenhash = SRL_GET_WEAK_SEENHASH_OR_NULL(enc);
1121 1643919 100         if (!weak_seenhash)
1122 1643901           return;
1123              
1124             {
1125 18           PTABLE_ITER_t *it = PTABLE_iter_new(weak_seenhash);
1126             PTABLE_ENTRY_t *ent;
1127              
1128             /* we now walk the weak_seenhash and set any tags it points
1129             * at to the PAD opcode, this basically turns the first weakref
1130             * we encountered into a normal ref when there is only a weakref
1131             * pointing at the structure. */
1132 40 100         while ( NULL != (ent = PTABLE_iter_next(it)) ) {
1133 22           const ptrdiff_t offset = (ptrdiff_t)ent->value;
1134 22 100         if ( offset ) {
1135 4           srl_buffer_char *pos = enc->buf.body_pos + offset;
1136             assert(*pos == SRL_HDR_WEAKEN);
1137             if (DEBUGHACK) warn("setting byte at offset %"UVuf" to PAD", (UV)offset);
1138 4           *pos = SRL_HDR_PAD;
1139             }
1140             }
1141              
1142 18           PTABLE_iter_free(it);
1143             }
1144             }
1145              
1146              
1147              
1148             static inline void
1149 23668           srl_dump_regexp(pTHX_ srl_encoder_t *enc, SV *sv)
1150             {
1151 23668           STRLEN left = 0;
1152             const char *fptr;
1153             char ch;
1154             U16 match_flags;
1155             #ifdef MODERN_REGEXP
1156 23668           REGEXP *re= SvRX(sv);
1157             #else
1158             regexp *re = (regexp *)(((MAGIC*)sv)->mg_obj);
1159             #endif
1160              
1161             char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH];
1162              
1163             /*
1164             we are in list context so stringify
1165             the modifiers that apply. We ignore "negative
1166             modifiers" in this scenario, and the default character set
1167             */
1168              
1169             #ifdef REGEXP_DEPENDS_CHARSET
1170             if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) {
1171             STRLEN len;
1172             const char* const name = get_regex_charset_name(RX_EXTFLAGS(re),
1173             &len);
1174             Copy(name, reflags + left, len, char);
1175             left += len;
1176             }
1177             #endif
1178 23668           fptr = INT_PAT_MODS;
1179 23668           match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME)
1180             >> RXf_PMf_STD_PMMOD_SHIFT);
1181              
1182 189344 100         while((ch = *fptr++)) {
1183 165676 100         if(match_flags & 1) {
1184 7896           reflags[left++] = ch;
1185             }
1186 165676           match_flags >>= 1;
1187             }
1188              
1189 23668           srl_buf_cat_char(&enc->buf, SRL_HDR_REGEXP);
1190 23668           srl_dump_pv(aTHX_ enc, RX_PRECOMP(re),RX_PRELEN(re), (RX_UTF8(re) ? SVf_UTF8 : 0));
1191 23668           srl_dump_pv(aTHX_ enc, reflags, left, 0);
1192 23668           return;
1193             }
1194              
1195             #define ASSUME_BYTES_PER_TAG 4
1196             #define BUF_SIZE_ASSERT_AV(b,n) \
1197             BUF_SIZE_ASSERT((b), 2 + SRL_MAX_VARINT_LENGTH + (1 * ASSUME_BYTES_PER_TAG * (n) ) )
1198             /* heuristic: 6 * n = liberal estimate of min size of n hashkeys */
1199             #define BUF_SIZE_ASSERT_HV(b, n) \
1200             BUF_SIZE_ASSERT((b), 2 + SRL_MAX_VARINT_LENGTH + (2 * ASSUME_BYTES_PER_TAG * (n) ) )
1201              
1202             SRL_STATIC_INLINE void
1203 1076667           srl_dump_av(pTHX_ srl_encoder_t *enc, AV *src, U32 refcount)
1204             {
1205             UV n;
1206             SV **svp;
1207              
1208 1076667           n = av_len(src)+1;
1209              
1210             /* heuristic: n is virtually the min. size of any element */
1211 1076667 100         BUF_SIZE_ASSERT_AV(&enc->buf, n);
1212              
1213 1076667 100         if (n < 16 && refcount == 1 && !SRL_ENC_HAVE_OPTION(enc,SRL_F_CANONICAL_REFS)) {
    100          
    100          
1214 646570           enc->buf.pos--; /* backup over previous REFN */
1215 646570           srl_buf_cat_char_nocheck(&enc->buf, SRL_HDR_ARRAYREF + n);
1216             } else {
1217             /* header and num. elements */
1218 430097           srl_buf_cat_varint_nocheck(aTHX_ &enc->buf, SRL_HDR_ARRAY, n);
1219             }
1220 1076667 100         if (!n)
1221 31567           return;
1222             /* I can't decide if this should make me feel dirty */
1223 1045100 100         if (SvMAGICAL(src)) {
1224             UV i;
1225 6 100         for (i = 0; i < n; ++i) {
1226 5           svp = av_fetch(src, i, 0);
1227 5 50         CALL_SRL_DUMP_SVP(enc, svp);
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1228             }
1229             } else {
1230             SV **end;
1231 1045099           svp= AvARRAY(src);
1232 1045099           end= svp + n;
1233 3591654 100         for ( ; svp < end ; svp++) {
1234             /* we cannot have a null *svp so we do not use CALL_SRL_DUMP_SVP() here */
1235 2547554 100         CALL_SRL_DUMP_SV(enc, *svp);
    50          
    0          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    0          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
1236             }
1237             }
1238             }
1239              
1240             SRL_STATIC_INLINE void
1241 176709           srl_dump_hv_unsorted_nomg(pTHX_ srl_encoder_t *enc, HV *src, UV n)
1242             {
1243             HE *he;
1244 176709           const int do_share_keys = HvSHAREKEYS((SV *)src);
1245 176709           HE **he_ptr= HvARRAY(src);
1246 176709           HE **he_end= he_ptr + HvMAX(src) + 1;
1247              
1248             do {
1249 1466436 100         for (he= *he_ptr++; he; he= HeNEXT(he) ) {
1250 528803           SV *v= HeVAL(he);
1251 528803 50         if (v != &PL_sv_placeholder) {
1252 528803           srl_dump_hk(aTHX_ enc, he, do_share_keys);
1253 528803 50         CALL_SRL_DUMP_SV(enc, v);
    50          
    0          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    0          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
1254 528803 100         if (--n == 0) {
1255 176709           he_ptr= he_end;
1256 176709           break;
1257             }
1258             }
1259             }
1260 1114342 100         } while ( he_ptr < he_end );
1261 176709           }
1262              
1263             SRL_STATIC_INLINE void
1264 1           srl_dump_hv_unsorted_mg(pTHX_ srl_encoder_t *enc, HV *src, const UV n)
1265             {
1266             HE *he;
1267 1           UV i= 0;
1268 1           const int do_share_keys = HvSHAREKEYS((SV *)src);
1269              
1270 1           (void)hv_iterinit(src); /* return value not reliable according to API docs */
1271 5 100         while ((he = hv_iternext(src))) {
1272             SV *v;
1273 4 50         if (expect_false( i == n ))
1274 0           croak("Panic: cannot serialize a tied hash which changes its size!");
1275 4           v= hv_iterval(src, he);
1276 4           srl_dump_hk(aTHX_ enc, he, do_share_keys);
1277 4 50         CALL_SRL_DUMP_SV(enc, v);
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1278 4           ++i;
1279             }
1280 1 50         if (expect_false( i != n ))
1281 0           croak("Panic: cannot serialize a tied hash which changes its size!");
1282 1           }
1283              
1284             /* sorting hashes - nothing in perl is easy. ever.
1285             *
1286             * Some things to keep in mind about perl hashes as you read this code:
1287             *
1288             * Hashes may be shared or not. Usually shared. This means they share their
1289             * key data via PL_strtab.
1290             *
1291             * Hashes may be tied or not. Usually not. When tied the keys from the hash
1292             * are available only as SV *'s, and when untied, the keys from the hash are
1293             * accessed via HE *'s.
1294             *
1295             * Some HE's actually contains SV's but most contain a ptr/len combo with
1296             * an utf8 flag. To make things even more interesting utf8 keys are
1297             * normalized to latin1 by perl where possible before being stored in the HE,
1298             * with the utf8 flag indicating "was utf8" instead of "is utf8" or "not utf8".
1299             *
1300             * The complexity about accessing the key for a hash can be managed away by
1301             * perl via API's like hv_iterkeysv(), but using that means constructing mortal
1302             * SV's for each key as we go.
1303             *
1304             * We could in theory use the HePV() interface, but one annoying result of the
1305             * "was utf8" logic is that we can't use a sort comparator which looks
1306             * at the raw binary of the keys when the keys might contain utf8. A utf8 key
1307             * like "\xDF" will be downgraded to ascii in the HE form, but will be upgraded
1308             * to the utf8 representation in the SV form. So if we want to do "fast" sorting
1309             * we have to restrict it to non-utf8/non-sv keys, and force the use of the SV
1310             * based API (which we have to use for tie's anyway) when we see a UTF8 key.
1311             *
1312             * Which is what we do below. In order to sort a hash we need to construct an
1313             * array of its contents, in srl_dump_sorted_nomg() we walk the hash, checking
1314             * each key, and copying each HE over into a scratch buffer which it then sorts.
1315             * If during the transcription process it sees any utf8 or SV keys it exits
1316             * immediately, and falls through to srl_dump_sort_mg(), which uses hv_iterkeysv()
1317             * to construct an array of HE_SV instead, which we then sort.
1318             */
1319              
1320              
1321              
1322             SRL_STATIC_INLINE int
1323             he_islt(const HE *a, const HE *b)
1324             {
1325             /* no need for a dTHX here, we don't use anything that needs it */
1326             const STRLEN la = HeKLEN(a);
1327             const STRLEN lb = HeKLEN(b);
1328             const int cmp = memcmp(HeKEY(a), HeKEY(b), la < lb ? la : lb);
1329             if (cmp) {
1330             return cmp < 0;
1331             } else {
1332             return la < lb;
1333             }
1334             }
1335              
1336             SRL_STATIC_INLINE int
1337 521291           he_sv_islt_fast(const HE_SV *a, const HE_SV *b)
1338             {
1339             /* no need for a dTHX here, we don't use anything that needs it */
1340             char *a_ptr;
1341             char *b_ptr;
1342             int a_isutf8;
1343             int b_isutf8;
1344 521291 100         const STRLEN a_len= a->key.sv ? SvCUR(a->key.sv) : HeKLEN(a->val.he);
1345 521291 100         const STRLEN b_len= b->key.sv ? SvCUR(b->key.sv) : HeKLEN(b->val.he);
1346 521291 100         if (a_len != b_len) {
1347 228214           return a_len < b_len;
1348             }
1349 293077 100         a_isutf8= (a->key.sv ? SvUTF8(a->key.sv) : HeKUTF8(a->val.he)) ? 0 : 1;
    100          
1350 293077 100         b_isutf8= (b->key.sv ? SvUTF8(b->key.sv) : HeKUTF8(b->val.he)) ? 0 : 1;
    100          
1351 293077 100         if (a_isutf8 != b_isutf8) {
1352 11           return a_isutf8 < b_isutf8;
1353             }
1354 293066 100         a_ptr= a->key.sv ? SvPVX(a->key.sv) : HeKEY(a->val.he);
1355 293066 100         b_ptr= b->key.sv ? SvPVX(b->key.sv) : HeKEY(b->val.he);
1356 293066           return memcmp(a_ptr, b_ptr, a_len < b_len ? a_len : b_len ) < 0;
1357             }
1358              
1359             #define ISLT_HE_SV(a,b) he_sv_islt_fast( a, b )
1360             #define ISLT_SV_CMP(a,b) sv_cmp(a->key.sv, b->key.sv) == sort_dir
1361              
1362              
1363             SRL_STATIC_INLINE void
1364 109278           srl_qsort(pTHX_ srl_encoder_t *enc, const UV n, HE_SV *array)
1365             {
1366 109278 100         if ( SRL_ENC_HAVE_OPTION(enc, SRL_F_SORT_KEYS_PERL) ) {
1367 28260 100         int sort_dir= SRL_ENC_HAVE_OPTION(enc, SRL_F_SORT_KEYS_PERL_REV) ? 1 : -1;
1368             /* hack to forcefully disable "use bytes" */
1369 28260           COP cop= *PL_curcop;
1370 28260           cop.op_private= 0;
1371              
1372 28260           ENTER;
1373 28260           SAVETMPS;
1374              
1375 28260           SAVEVPTR (PL_curcop);
1376 28260           PL_curcop= &cop;
1377            
1378             /* now sort */
1379 208685 100         QSORT(HE_SV, array, n, ISLT_SV_CMP);
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1380              
1381 28260 50         FREETMPS;
1382 28260           LEAVE;
1383             } else {
1384             /* now sort */
1385 584593 100         QSORT(HE_SV, array, n, ISLT_HE_SV);
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1386             }
1387 109278           }
1388              
1389              
1390             SRL_STATIC_INLINE void
1391 28261           srl_dump_hv_sorted_sv_slow(pTHX_ srl_encoder_t *enc, HV *src, const UV n, HE_SV *array)
1392             {
1393             HE *he;
1394 28261           UV i= 0;
1395 28261           const int do_share_keys = HvSHAREKEYS((SV *)src);
1396 28261           const int is_tie= !array;
1397              
1398             /* This sub is used for ties, and for hashes with SV keys in them,
1399             * and when the user requests SORT_KEYS_PERL, it is the slowest way
1400             * and most memory hungry way to serialize a hash. We will use the
1401             * full perl api for extracting the contents of the hash, which fortifies
1402             * us against ties, and we will convert all keys into mortal
1403             * sv's where necessary. This means we can use sv_cmp on the keys
1404             * if we wish.
1405             */
1406              
1407 28261           (void)hv_iterinit(src); /* return value not reliable according to API docs */
1408             {
1409             HE_SV *array_end;
1410 28261 50         if (!array) {
1411 28261 50         Newx(array, n, HE_SV);
1412 28261           SAVEFREEPV(array);
1413             }
1414 28261           array_end= array + n;
1415 106758 100         while ((he = hv_iternext(src))) {
1416 78497 50         if (expect_false( i == n ))
1417 0 0         croak("Panic: cannot serialize a %s hash which changes its size!",is_tie ? "tied" : "untied");
1418 78497           array[i].key.sv= hv_iterkeysv(he);
1419 78497           array[i].val.sv= hv_iterval(src,he);
1420 78497           i++;
1421             }
1422 28261 50         if (expect_false( i != n ))
1423 0 0         croak("Panic: can not serialize a %s hash which changes it size!", is_tie ? "tied" : "untied");
1424              
1425 28261           srl_qsort(aTHX_ enc, n, array);
1426              
1427 106758 100         while ( array < array_end ) {
1428 78497 50         CALL_SRL_DUMP_SV(enc, array->key.sv);
    50          
    0          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1429 78497 50         CALL_SRL_DUMP_SV(enc, array->val.sv);
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    0          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
1430 78497           array++;
1431             }
1432             }
1433 28261           }
1434              
1435              
1436             SRL_STATIC_INLINE void
1437 81017           srl_dump_hv_sorted_nomg(pTHX_ srl_encoder_t *enc, HV *src, const UV n)
1438             {
1439             HE *he;
1440 81017           const int do_share_keys = HvSHAREKEYS((SV *)src);
1441              
1442             /* This sub is used only for untied hashes and when the user wants
1443             * sorted keys, but not necessarily the order that perl would use.
1444             */
1445              
1446 81017           (void)hv_iterinit(src); /* return value not reliable according to API docs */
1447             {
1448             HE_SV *array;
1449             HE_SV *array_ptr;
1450             HE_SV *array_end;
1451 81017 50         Newx(array, n, HE_SV);
1452 81017           SAVEFREEPV(array);
1453 81017           array_ptr = array;
1454 306070 100         while ((he = hv_iternext(src))) {
1455 225053 100         if ( HeKWASUTF8(he) ) {
1456 1           array_ptr->key.sv= hv_iterkeysv(he);
1457             } else {
1458 225052 50         array_ptr->key.sv = HeSVKEY(he);
    50          
1459             }
1460 225053           array_ptr->val.he = he;
1461 225053           array_ptr++;
1462             }
1463            
1464 81017           srl_qsort(aTHX_ enc, n, array);
1465              
1466 81017           array_end = array + n;
1467 306070 100         for ( array_end= array + n; array < array_end; array++ ) {
1468             SV *v;
1469 225053           he = array->val.he;
1470 225053           v = hv_iterval(src, he);
1471 225053           srl_dump_hk(aTHX_ enc, he, do_share_keys);
1472 225053 50         CALL_SRL_DUMP_SV(enc, v);
    50          
    0          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    0          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
1473             }
1474             }
1475 81017           }
1476              
1477             SRL_STATIC_INLINE void
1478 311654           srl_dump_hv(pTHX_ srl_encoder_t *enc, HV *src, U32 refcount)
1479             {
1480             HE *he;
1481             UV n;
1482 311654 100         if ( SvMAGICAL(src) ) {
1483             /* for tied hashes, we have to iterate to find the number of entries. Alas... */
1484 2           n= 0;
1485 2           (void)hv_iterinit(src); /* return value not reliable according to API docs */
1486 23 100         while ((he = hv_iternext(src))) { ++n; }
1487             }
1488             else {
1489 311652 50         n= HvUSEDKEYS(src);
1490             }
1491              
1492 311654 100         BUF_SIZE_ASSERT_HV(&enc->buf, n);
1493 311654 100         if (n < 16 && refcount == 1 && !SRL_ENC_HAVE_OPTION(enc,SRL_F_CANONICAL_REFS)) {
    100          
    100          
1494 184760           enc->buf.pos--; /* backup over the previous REFN */
1495 184760           srl_buf_cat_char_nocheck(&enc->buf, SRL_HDR_HASHREF + n);
1496             } else {
1497 126894           srl_buf_cat_varint_nocheck(aTHX_ &enc->buf, SRL_HDR_HASH, n);
1498             }
1499              
1500 311654 100         if ( n ) {
1501 285988 100         if ( SvMAGICAL(src) || SRL_ENC_HAVE_OPTION(enc, SRL_F_SORT_KEYS_PERL) ) {
    100          
1502             /* SORT_KEYS_PERL implies SORT_KEYS, but we check for either just to be
1503             * careful - yves*/
1504 56524 100         if ( SRL_ENC_HAVE_OPTION(enc, SRL_F_SORT_KEYS|SRL_F_SORT_KEYS_PERL) ) {
1505 28261           srl_dump_hv_sorted_sv_slow(aTHX_ enc, src, n, NULL);
1506             }
1507             else {
1508 1           srl_dump_hv_unsorted_mg(aTHX_ enc, src, n);
1509             }
1510             }
1511             else {
1512 257726 100         if ( SRL_ENC_HAVE_OPTION(enc, SRL_F_SORT_KEYS) ) {
1513 81017           srl_dump_hv_sorted_nomg(aTHX_ enc, src, n);
1514             }
1515             else {
1516 176709           srl_dump_hv_unsorted_nomg(aTHX_ enc, src, n);
1517             }
1518             }
1519             }
1520 311654           }
1521              
1522              
1523              
1524             SRL_STATIC_INLINE void
1525 753860           srl_dump_hk(pTHX_ srl_encoder_t *enc, HE *src, const int share_keys)
1526             {
1527             char *str;
1528             STRLEN len;
1529             char mode;
1530              
1531 753860 100         if (HeKLEN(src) == HEf_SVKEY) {
1532 4 50         SV *sv = HeSVKEY(src);
    50          
1533              
1534 4 50         SvGETMAGIC(sv);
    0          
1535 4 50         str = SvPV(sv, len);
1536 4           mode= SvUTF8(sv) ? 1 : 0;
1537              
1538             }
1539             else {
1540 753856           str = HeKEY(src);
1541             /* This logic is an optimization for output space: We keep track of
1542             * all seen hash key strings that are in perl's shared string storage.
1543             * If we see one again, we just emit a COPY instruction.
1544             * This means that we only need to keep a ptr table since the strings
1545             * don't move in the shared key storage -- otherwise, we'd have to
1546             * compare strings / keep a full string hash table. */
1547 753856 50         if ( share_keys && SRL_ENC_HAVE_OPTION(enc, SRL_F_SHARED_HASHKEYS) /* only enter branch if shared hk's enabled */
1548             #if PERL_VERSION >= 10
1549 753856 100         && (!DO_SHARED_HASH_ENTRY_REFCOUNT_CHECK
1550             || src->he_valu.hent_refcount > 1)
1551             #endif
1552             )
1553             {
1554 753848 100         PTABLE_t *string_seenhash = SRL_GET_STR_PTR_SEENHASH(enc);
1555 753848           const ptrdiff_t oldoffset = (ptrdiff_t)PTABLE_fetch(string_seenhash, str);
1556 753848 100         if (oldoffset != 0) {
1557             /* Issue COPY instead of literal hash key string */
1558 16845           srl_buf_cat_varint(aTHX_ &enc->buf, SRL_HDR_COPY, (UV)oldoffset);
1559 16845           return;
1560             }
1561             else {
1562             /* remember current offset before advancing it */
1563 737003           const ptrdiff_t newoffset = BODY_POS_OFS(&enc->buf);
1564 737003           PTABLE_store(string_seenhash, (void *)str, INT2PTR(void *, newoffset));
1565             }
1566             }
1567 737011           len= HeKLEN(src);
1568 737011 100         mode= HeKWASUTF8(src) ? 2 : HeKUTF8(src) ? 1 : 0;
1569             }
1570 737015 100         if (mode == 2) { /* must convert back to utf8 */
1571 5           char* utf8= (char *)Perl_bytes_to_utf8(aTHX_ (U8 *)str, &len);
1572 5           srl_dump_pv(aTHX_ enc, utf8, len, 1);
1573 5           Safefree(utf8);
1574             } else {
1575 737015           srl_dump_pv(aTHX_ enc, str, len, mode);
1576             }
1577             }
1578              
1579             SRL_STATIC_INLINE void
1580 1603298           srl_dump_svpv(pTHX_ srl_encoder_t *enc, SV *src)
1581             {
1582             STRLEN len;
1583 1603298 50         const char * const str= SvPV(src, len);
1584 1603298 100         if ( SRL_ENC_HAVE_OPTION(enc, SRL_F_DEDUPE_STRINGS) && len > 3 ) {
    100          
1585 57438 100         HV *string_deduper_hv= SRL_GET_STR_DEDUPER_HV(enc);
1586 57438           HE *dupe_offset_he= hv_fetch_ent(string_deduper_hv, src, 1, 0);
1587 57438 50         if (!dupe_offset_he) {
1588 0           croak("out of memory (hv_fetch_ent returned NULL)");
1589             } else {
1590 57438 100         const char out_tag= SRL_ENC_HAVE_OPTION(enc, SRL_F_ALIASED_DEDUPE_STRINGS)
1591             ? SRL_HDR_ALIAS
1592             : SRL_HDR_COPY;
1593 57438           SV *ofs_sv= HeVAL(dupe_offset_he);
1594 57438 100         if (SvIOK(ofs_sv)) {
1595             /* emit copy or alias */
1596 26408 100         if (out_tag == SRL_HDR_ALIAS)
1597 5 50         SRL_SET_TRACK_FLAG(*(enc->buf.body_pos + SvUV(ofs_sv)));
1598 26408 50         srl_buf_cat_varint(aTHX_ &enc->buf, out_tag, SvIV(ofs_sv));
1599 26408           return;
1600 31030 50         } else if (SvUOK(ofs_sv)) {
1601 0 0         srl_buf_cat_varint(aTHX_ &enc->buf, out_tag, SvUV(ofs_sv));
1602 0           return;
1603             } else {
1604             /* start tracking this string */
1605 31030           sv_setuv(ofs_sv, (UV)BODY_POS_OFS(&enc->buf));
1606             }
1607             }
1608             }
1609 1576890           srl_dump_pv(aTHX_ enc, str, len, SvUTF8(src));
1610             }
1611              
1612             SRL_STATIC_INLINE void
1613 2396338           srl_dump_pv(pTHX_ srl_encoder_t *enc, const char* src, STRLEN src_len, int is_utf8)
1614             {
1615 2396338 100         BUF_SIZE_ASSERT(&enc->buf, 1 + SRL_MAX_VARINT_LENGTH + src_len); /* overallocate a bit sometimes */
1616 2396338 100         if (is_utf8) {
1617 138468           srl_buf_cat_varint_nocheck(aTHX_ &enc->buf, SRL_HDR_STR_UTF8, src_len);
1618 2257870 100         } else if (src_len <= SRL_MASK_SHORT_BINARY_LEN) {
1619 1678159           srl_buf_cat_char_nocheck(&enc->buf, SRL_HDR_SHORT_BINARY_LOW | (char)src_len);
1620             } else {
1621 579711           srl_buf_cat_varint_nocheck(aTHX_ &enc->buf, SRL_HDR_BINARY, src_len);
1622             }
1623 2396338           Copy(src, enc->buf.pos, src_len, char);
1624 2396338           enc->buf.pos += src_len;
1625 2396338           }
1626              
1627             #ifdef HAS_HV_BACKREFS
1628             AV *
1629 123235           srl_hv_backreferences_p_safe(pTHX_ HV *hv) {
1630 123235 50         if (SvOOK(hv)) {
1631 123235           struct xpvhv_aux * const iter = HvAUX(hv);
1632 123235           return iter->xhv_backreferences;
1633             } else {
1634 0           return NULL;
1635             }
1636             }
1637             #endif
1638              
1639             /* Dumps generic SVs and delegates
1640             * to more specialized functions for RVs, etc. */
1641             /* TODO decide when to use the IV, when to use the PV, and when
1642             * to use the NV slots of the SV.
1643             * Safest simple solution seems "prefer string" (fuck dualvars).
1644             * Potentially better but slower: If we would choose the string,
1645             * then try int-to-string (respective float-to-string) conversion
1646             * and strcmp. If same, then use int or float.
1647             */
1648             static void
1649 3058114           srl_dump_sv(pTHX_ srl_encoder_t *enc, SV *src)
1650             {
1651             UV refcount;
1652             svtype svt;
1653             MAGIC *mg;
1654             AV *backrefs;
1655 3058114           SV* refsv= NULL;
1656 3058114           SV* replacement= NULL;
1657 3058114           UV weakref_ofs= 0; /* preserved between loops */
1658 3058114           SSize_t ref_rewrite_pos= 0; /* preserved between loops - note SSize_t is a perl define */
1659             assert(src);
1660              
1661 3058114 100         if (expect_false( ++enc->recursion_depth == enc->max_recursion_depth )) {
1662 1           croak("Hit maximum recursion depth (%"UVuf"), aborting serialization",
1663 1           (UV)enc->max_recursion_depth);
1664             }
1665              
1666             redo_dump:
1667 5489880           mg= NULL;
1668 5489880           backrefs= NULL;
1669 5489880           svt = SvTYPE(src);
1670 5489880           refcount = SvREFCNT(src);
1671             DEBUG_ASSERT_BUF_SANE(&enc->buf);
1672 5489880 100         if ( SvMAGICAL(src) ) {
1673 66 100         SvGETMAGIC(src);
    50          
1674             #ifdef HAS_HV_BACKREFS
1675 66 100         if (svt != SVt_PVHV)
1676             #endif
1677 64           mg = mg_find(src, PERL_MAGIC_backref);
1678             }
1679             #ifdef HAS_HV_BACKREFS
1680 5489880 100         if (expect_false( svt == SVt_PVHV && SvOOK(src) )) {
    100          
    100          
1681 123235           backrefs= srl_hv_backreferences_p_safe(aTHX_ (HV *)src);
1682             if (DEBUGHACK) warn("backreferences %p", src);
1683             }
1684             #endif
1685 5489880 100         if (expect_false( mg || backrefs )) {
    100          
    100          
1686 43 100         PTABLE_t *weak_seenhash= SRL_GET_WEAK_SEENHASH(enc);
1687 43           PTABLE_ENTRY_t *pe= PTABLE_find(weak_seenhash, src);
1688 43 100         if (!pe) {
1689             /* not seen it before */
1690             if (DEBUGHACK) warn("scalar %p - is weak referent, storing %"UVuf, src, weakref_ofs);
1691             /* if weakref_ofs is false we got here some way that holds a refcount on this item */
1692 22           PTABLE_store(weak_seenhash, src, INT2PTR(void *, weakref_ofs));
1693             } else {
1694             if (DEBUGHACK) warn("scalar %p - is weak referent, seen before value:%"UVuf" weakref_ofs:%"UVuf,
1695             src, (UV)pe->value, (UV)weakref_ofs);
1696 21 100         if (pe->value)
1697 6           pe->value= INT2PTR(void *, weakref_ofs);
1698             }
1699 43           refcount++;
1700 43           weakref_ofs= 0;
1701             }
1702              
1703             /* check if we have seen this scalar before, and track it so
1704             * if we see it again we recognize it */
1705 5489880 100         if ( expect_false( refcount > 1 ) ) {
1706 1253255 100         if (src == &PL_sv_undef && enc->protocol_version >=3 ) {
    100          
1707 36570           srl_buf_cat_char(&enc->buf, SRL_HDR_CANONICAL_UNDEF);
1708 36570           --enc->recursion_depth;
1709 36570           return;
1710             }
1711             else
1712 1216685 100         if (src == &PL_sv_yes) {
1713 8           srl_buf_cat_char(&enc->buf, SRL_HDR_TRUE);
1714 8           --enc->recursion_depth;
1715 8           return;
1716             }
1717             else
1718 1216677 100         if (src == &PL_sv_no) {
1719 8           srl_buf_cat_char(&enc->buf, SRL_HDR_FALSE);
1720 8           --enc->recursion_depth;
1721 8           return;
1722             }
1723             else {
1724 1216669 100         PTABLE_t *ref_seenhash= SRL_GET_REF_SEENHASH(enc);
1725 1216669           const ptrdiff_t oldoffset = (ptrdiff_t)PTABLE_fetch(ref_seenhash, src);
1726 1216669 100         if (expect_false(oldoffset)) {
1727             /* we have seen it before, so we do not need to bless it again */
1728 432469 100         if (ref_rewrite_pos) {
1729             if (DEBUGHACK) warn("ref to %p as %"UVuf, src, (UV)oldoffset);
1730 299309           enc->buf.pos= enc->buf.body_pos + ref_rewrite_pos;
1731 299309           srl_buf_cat_varint(aTHX_ &enc->buf, SRL_HDR_REFP, (UV)oldoffset);
1732             } else {
1733             if (DEBUGHACK) warn("alias to %p as %"UVuf, src, (UV)oldoffset);
1734 133160           srl_buf_cat_varint(aTHX_ &enc->buf, SRL_HDR_ALIAS, (UV)oldoffset);
1735             }
1736 432469           SRL_SET_TRACK_FLAG(*(enc->buf.body_pos + oldoffset));
1737 432469           --enc->recursion_depth;
1738 432469           return;
1739             }
1740             if (DEBUGHACK) warn("storing %p as %"UVuf, src, (UV)BODY_POS_OFS(&enc->buf));
1741 784200           PTABLE_store(ref_seenhash, src, INT2PTR(void *, BODY_POS_OFS(&enc->buf)));
1742             }
1743             }
1744              
1745 5020825 50         if (expect_false( weakref_ofs != 0 )) {
1746 0           sv_dump(src);
1747 0           croak("Corrupted weakref? weakref_ofs should be 0, but got %"UVuf" (this should not happen)", weakref_ofs);
1748             }
1749              
1750 5020825 100         if (replacement) {
1751 7 50         if (SvROK(replacement)) {
1752 0           src= SvRV(replacement);
1753             } else {
1754 7           src= replacement;
1755             }
1756 7           replacement= NULL;
1757 7           svt = SvTYPE(src);
1758             /* plus one ensures that later on we get REFN/ARRAY and not ARRAYREF - This is horrible tho. needs to be revisited another day */
1759 7           refcount= SvREFCNT(src) + 1;
1760             /* We could, but do not do the following:*/
1761             /* goto redo_dump; */
1762             /* Probably a "proper" solution would, but there are nits there that I dont want to chase right now. */
1763             }
1764              
1765             /* --------------------------------- */
1766 5020825 100         _SRL_IF_SIMPLE_DIRECT_DUMP_SV(enc, src, svt)
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
    100          
    50          
    50          
    50          
1767             else
1768             #if defined(MODERN_REGEXP) && defined(REGEXP_NO_LONGER_POK)
1769             /* Only need to enter here if we have rather modern regexps AND they're
1770             * NO LONGER POK (5.17.6 and up). */
1771 3911868 100         if ( expect_false( svt == SVt_REGEXP ) ) {
1772 23668           srl_dump_regexp(aTHX_ enc, src);
1773             }
1774             else
1775             #endif
1776 3888200 100         if (SvROK(src)) {
1777             /* dump references */
1778 2431768           SV *referent= SvRV(src);
1779             /* assert()-like hack to be compiled out by default */
1780             #ifndef NDEBUG
1781             if (!referent) {
1782             sv_dump(src);
1783             assert(referent);
1784             }
1785             #endif
1786 2431768 100         if (expect_false( SvWEAKREF(src) )) {
1787             if (DEBUGHACK) warn("Is weakref %p", src);
1788 24           weakref_ofs= BODY_POS_OFS(&enc->buf);
1789 24           srl_buf_cat_char(&enc->buf, SRL_HDR_WEAKEN);
1790             }
1791              
1792 2431768           ref_rewrite_pos= BODY_POS_OFS(&enc->buf);
1793              
1794 2431768 100         if ( expect_false( sv_isobject(src) ) ) {
1795             /* Write bless operator with class name */
1796 64906           replacement= srl_get_frozen_object(aTHX_ enc, src, referent);
1797 64906 100         if (srl_dump_classname(aTHX_ enc, referent, replacement)) {
1798             /* 1 means we should not rewrite away the classname */
1799 35932           ref_rewrite_pos= BODY_POS_OFS(&enc->buf);
1800             }
1801             }
1802              
1803 2431767           srl_buf_cat_char(&enc->buf, SRL_HDR_REFN);
1804 2431767           refsv= src;
1805 2431767           src= referent;
1806              
1807             if (DEBUGHACK) warn("Going to redo %p", src);
1808 2431767           goto redo_dump;
1809             }
1810             else
1811             #ifndef MODERN_REGEXP
1812             if (
1813             svt == SVt_PVMG &&
1814             ((SvFLAGS(src) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|BFD_Svs_SMG_OR_RMG)) &&
1815             (mg = mg_find(src, PERL_MAGIC_qr))
1816             ) {
1817             /* Houston, we have a regex! */
1818             srl_dump_regexp(aTHX_ enc, (SV*)mg); /* yes the SV* cast makes me feel dirty too */
1819             }
1820             else
1821             #endif
1822 1456432 100         if (svt == SVt_PVHV) {
1823 311654           srl_dump_hv(aTHX_ enc, (HV *)src, refcount);
1824             }
1825             else
1826 1144778 100         if (svt == SVt_PVAV) {
1827 1076667           srl_dump_av(aTHX_ enc, (AV *)src, refcount);
1828             }
1829             else
1830 68111 50         if ( ! SvOK(src) ) { /* undef and weird shit */
    50          
    50          
1831 136220 50         if ( SRL_UNSUPPORTED_SvTYPE(svt) ) {
    100          
    50          
    50          
1832             /* we exclude magic, because magic sv's can be undef too */
1833             /* called when we find an unsupported type/reference. May either throw exception
1834             * or write ONE (nested or single) item to the buffer. */
1835             #define SRL_HANDLE_UNSUPPORTED_SvTYPE(enc, src, svt, refsv, ref_rewrite_pos) \
1836             STMT_START { \
1837             if ( SRL_ENC_HAVE_OPTION((enc), SRL_F_UNDEF_UNKNOWN) ) { \
1838             if (SRL_ENC_HAVE_OPTION((enc), SRL_F_WARN_UNKNOWN)) \
1839             warn("Found type %u %s(0x%p), but it is not representable " \
1840             "by the Sereal encoding format; will encode as an " \
1841             "undefined value", (svt), sv_reftype((src),0),(src)); \
1842             if (ref_rewrite_pos) { \
1843             /* make sure we don't keep a reference to the thing that we do not \
1844             * want to serialize around for REFP and ALIAS output */ \
1845             PTABLE_t *ref_seenhash= SRL_GET_REF_SEENHASH(enc); \
1846             PTABLE_delete(ref_seenhash, src); \
1847             enc->buf.pos= enc->buf.body_pos + ref_rewrite_pos; \
1848             } \
1849             srl_buf_cat_char(&(enc)->buf, SRL_HDR_UNDEF); \
1850             } \
1851             else if ( SRL_ENC_HAVE_OPTION((enc), SRL_F_STRINGIFY_UNKNOWN) ) { \
1852             STRLEN len; \
1853             char *str; \
1854             if (SRL_ENC_HAVE_OPTION((enc), SRL_F_WARN_UNKNOWN)) { \
1855             /* In theory, we need to warn about stringifying this unsupported \
1856             * item. However, if the SRL_F_NOWARN_UNKNOWN_OVERLOAD option is set, \
1857             * then we DO NOT warn about stringifying this unsupported item if \
1858             * it is an object with string overloading (assuming it's done on \
1859             * purpose to stringify in cases like these). \
1860             */ \
1861             if (!SRL_ENC_HAVE_OPTION((enc), SRL_F_NOWARN_UNKNOWN_OVERLOAD) \
1862             || !SvOBJECT(src) \
1863             || !Gv_AMG(SvSTASH(src))) \
1864             { \
1865             warn("Found type %u %s(0x%p), but it is not representable " \
1866             "by the Sereal encoding format; will encode as a " \
1867             "stringified form", (svt), sv_reftype((src),0),(src)); \
1868             } \
1869             } \
1870             if (ref_rewrite_pos) { \
1871             /* make sure we don't keep a reference to the thing that we do not \
1872             * want to serialize around for REFP and ALIAS output */ \
1873             PTABLE_t *ref_seenhash= SRL_GET_REF_SEENHASH(enc); \
1874             PTABLE_delete(ref_seenhash, src); \
1875             enc->buf.pos= enc->buf.body_pos + ref_rewrite_pos; \
1876             str = SvPV((refsv), len); \
1877             } else \
1878             str = SvPV((src), len); \
1879             srl_dump_pv(aTHX_ (enc), (str), len, SvUTF8(src)); \
1880             } \
1881             else { \
1882             croak("Found type %u %s(0x%p), but it is not representable " \
1883             "by the Sereal encoding format", (svt), sv_reftype((src),0),(src)); \
1884             } \
1885             } STMT_END
1886 21 100         SRL_HANDLE_UNSUPPORTED_SvTYPE(enc, src, svt, refsv, ref_rewrite_pos);
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    0          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    0          
1887             }
1888 68090 100         else if (src == &PL_sv_undef && enc->protocol_version >= 3 ) {
    50          
1889 0           srl_buf_cat_char(&enc->buf, SRL_HDR_CANONICAL_UNDEF);
1890             } else {
1891 68090           srl_buf_cat_char(&enc->buf, SRL_HDR_UNDEF);
1892             }
1893             }
1894             else {
1895 0 0         SRL_HANDLE_UNSUPPORTED_SvTYPE(enc, src, svt, refsv, ref_rewrite_pos);
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1896             #undef SRL_HANDLE_UNSUPPORTED_SvTYPE
1897             }
1898 2588056           --enc->recursion_depth;
1899             }