-
Notifications
You must be signed in to change notification settings - Fork 528
/
Storable.xs
7864 lines (6816 loc) · 230 KB
/
Storable.xs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/* -*- c-basic-offset: 4 -*-
*
* Fast store and retrieve mechanism.
*
* Copyright (c) 1995-2000, Raphael Manfredi
* Copyright (c) 2016, 2017 cPanel Inc
* Copyright (c) 2017 Reini Urban
*
* You may redistribute only under the same terms as Perl 5, as specified
* in the README file that comes with the distribution.
*
*/
#define PERL_NO_GET_CONTEXT /* we want efficiency */
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#define NEED_PL_parser
#define NEED_sv_2pv_flags
#define NEED_load_module
#define NEED_vload_module
#define NEED_newCONSTSUB
#define NEED_newSVpvn_flags
#define NEED_newRV_noinc
#include "ppport.h" /* handle old perls */
#ifdef DEBUGGING
#define DEBUGME /* Debug mode, turns assertions on as well */
#define DASSERT /* Assertion mode */
#endif
/*
* Earlier versions of perl might be used, we can't assume they have the latest!
*/
/* perl <= 5.8.2 needs this */
#ifndef SvIsCOW
# define SvIsCOW(sv) 0
#endif
#ifndef HvRITER_set
# define HvRITER_set(hv,r) (HvRITER(hv) = r)
#endif
#ifndef HvEITER_set
# define HvEITER_set(hv,r) (HvEITER(hv) = r)
#endif
#ifndef HvRITER_get
# define HvRITER_get HvRITER
#endif
#ifndef HvEITER_get
# define HvEITER_get HvEITER
#endif
#ifndef HvPLACEHOLDERS_get
# define HvPLACEHOLDERS_get HvPLACEHOLDERS
#endif
#ifndef HvTOTALKEYS
# define HvTOTALKEYS(hv) HvKEYS(hv)
#endif
/* 5.6 */
#ifndef HvUSEDKEYS
# define HvUSEDKEYS(hv) HvKEYS(hv)
#endif
#ifdef SVf_IsCOW
# define SvTRULYREADONLY(sv) SvREADONLY(sv)
#else
# define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv))
#endif
#ifndef strEQc
# define strEQc(s,c) memEQ(s, ("" c ""), sizeof(c))
#endif
#if defined(HAS_FLOCK) || defined(FCNTL_CAN_LOCK) && defined(HAS_LOCKF)
#define CAN_FLOCK &PL_sv_yes
#else
#define CAN_FLOCK &PL_sv_no
#endif
#ifdef DEBUGME
#ifndef DASSERT
#define DASSERT
#endif
/*
* TRACEME() will only output things when the $Storable::DEBUGME is true,
* using the value traceme cached in the context.
*
*
* TRACEMED() directly looks at the variable, for use before traceme has been
* updated.
*/
#define TRACEME(x) \
STMT_START { \
if (cxt->traceme) \
{ PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
} STMT_END
#define TRACEMED(x) \
STMT_START { \
if (SvTRUE(get_sv("Storable::DEBUGME", GV_ADD))) \
{ PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \
} STMT_END
#define INIT_TRACEME \
STMT_START { \
cxt->traceme = SvTRUE(get_sv("Storable::DEBUGME", GV_ADD)); \
} STMT_END
#else
#define TRACEME(x)
#define TRACEMED(x)
#define INIT_TRACEME
#endif /* DEBUGME */
#ifdef DASSERT
#define ASSERT(x,y) \
STMT_START { \
if (!(x)) { \
PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \
__FILE__, (int)__LINE__); \
PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \
} \
} STMT_END
#else
#define ASSERT(x,y)
#endif
/*
* Type markers.
*/
#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */
#define SX_OBJECT C(0) /* Already stored object */
#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */
#define SX_ARRAY C(2) /* Array forthcoming (size, item list) */
#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */
#define SX_REF C(4) /* Reference to object forthcoming */
#define SX_UNDEF C(5) /* Undefined scalar */
#define SX_INTEGER C(6) /* Integer forthcoming */
#define SX_DOUBLE C(7) /* Double forthcoming */
#define SX_BYTE C(8) /* (signed) byte forthcoming */
#define SX_NETINT C(9) /* Integer in network order forthcoming */
#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */
#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */
#define SX_TIED_HASH C(12) /* Tied hash forthcoming */
#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */
#define SX_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */
#define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */
#define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */
#define SX_BLESS C(17) /* Object is blessed */
#define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */
#define SX_HOOK C(19) /* Stored via hook, user-defined */
#define SX_OVERLOAD C(20) /* Overloaded reference */
#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */
#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */
#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */
#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */
#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */
#define SX_CODE C(26) /* Code references as perl source code */
#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */
#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */
#define SX_VSTRING C(29) /* vstring forthcoming (small) */
#define SX_LVSTRING C(30) /* vstring forthcoming (large) */
#define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */
#define SX_REGEXP C(32) /* Regexp */
#define SX_LOBJECT C(33) /* Large object: string, array or hash (size >2G) */
#define SX_BOOLEAN_TRUE C(34) /* Boolean true */
#define SX_BOOLEAN_FALSE C(35) /* Boolean false */
#define SX_LAST C(36) /* invalid. marker only */
/*
* Those are only used to retrieve "old" pre-0.6 binary images.
*/
#define SX_ITEM 'i' /* An array item introducer */
#define SX_IT_UNDEF 'I' /* Undefined array item */
#define SX_KEY 'k' /* A hash key introducer */
#define SX_VALUE 'v' /* A hash value introducer */
#define SX_VL_UNDEF 'V' /* Undefined hash value */
/*
* Those are only used to retrieve "old" pre-0.7 binary images
*/
#define SX_CLASS 'b' /* Object is blessed, class name length <255 */
#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */
#define SX_STORED 'X' /* End of object */
/*
* Limits between short/long length representation.
*/
#define LG_SCALAR 255 /* Large scalar length limit */
#define LG_BLESS 127 /* Large classname bless limit */
/*
* Operation types
*/
#define ST_STORE 0x1 /* Store operation */
#define ST_RETRIEVE 0x2 /* Retrieval operation */
#define ST_CLONE 0x4 /* Deep cloning operation */
/*
* The following structure is used for hash table key retrieval. Since, when
* retrieving objects, we'll be facing blessed hash references, it's best
* to pre-allocate that buffer once and resize it as the need arises, never
* freeing it (keys will be saved away someplace else anyway, so even large
* keys are not enough a motivation to reclaim that space).
*
* This structure is also used for memory store/retrieve operations which
* happen in a fixed place before being malloc'ed elsewhere if persistence
* is required. Hence the aptr pointer.
*/
struct extendable {
char *arena; /* Will hold hash key strings, resized as needed */
STRLEN asiz; /* Size of aforementioned buffer */
char *aptr; /* Arena pointer, for in-place read/write ops */
char *aend; /* First invalid address */
};
/*
* At store time:
* A hash table records the objects which have already been stored.
* Those are referred to as SX_OBJECT in the file, and their "tag" (i.e.
* an arbitrary sequence number) is used to identify them.
*
* At retrieve time:
* An array table records the objects which have already been retrieved,
* as seen by the tag determined by counting the objects themselves. The
* reference to that retrieved object is kept in the table, and is returned
* when an SX_OBJECT is found bearing that same tag.
*
* The same processing is used to record "classname" for blessed objects:
* indexing by a hash at store time, and via an array at retrieve time.
*/
typedef unsigned long stag_t; /* Used by pre-0.6 binary format */
/*
* Make the tag type 64-bit on 64-bit platforms.
*
* If the tag number is low enough it's stored as a 32-bit value, but
* with very large arrays and hashes it's possible to go over 2**32
* scalars.
*/
typedef STRLEN ntag_t;
/* used for where_is_undef - marks an unset value */
#define UNSET_NTAG_T (~(ntag_t)0)
/*
* The following "thread-safe" related defines were contributed by
* Murray Nesbitt <murray@activestate.com> and integrated by RAM, who
* only renamed things a little bit to ensure consistency with surrounding
* code. -- RAM, 14/09/1999
*
* The original patch suffered from the fact that the stcxt_t structure
* was global. Murray tried to minimize the impact on the code as much as
* possible.
*
* Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks
* on objects. Therefore, the notion of context needs to be generalized,
* threading or not.
*/
#define MY_VERSION "Storable(" XS_VERSION ")"
/*
* Conditional UTF8 support.
*
*/
#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR)
#define HAS_UTF8_SCALARS
#ifdef HeKUTF8
#define HAS_UTF8_HASHES
#define HAS_UTF8_ALL
#else
/* 5.6 perl has utf8 scalars but not hashes */
#endif
#ifndef HAS_UTF8_ALL
#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl"))
#endif
#ifndef SvWEAKREF
#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl"))
#endif
#ifndef SvVOK
#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl"))
#endif
#ifdef HvPLACEHOLDERS
#define HAS_RESTRICTED_HASHES
#else
#define HVhek_PLACEHOLD 0x200
#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash"))
#endif
#ifdef HvHASKFLAGS
#define HAS_HASH_KEY_FLAGS
#endif
#ifdef ptr_table_new
#define USE_PTR_TABLE
#endif
/* do we need/want to clear padding on NVs? */
#if defined(LONG_DOUBLEKIND) && defined(USE_LONG_DOUBLE)
# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
# define NV_PADDING (NVSIZE - 10)
# else
# define NV_PADDING 0
# endif
#else
/* This is kind of a guess - it means we'll get an unneeded clear on 128-bit NV
but an upgraded perl will fix that
*/
# if NVSIZE > 8
# define NV_CLEAR
# endif
# define NV_PADDING 0
#endif
typedef union {
NV nv;
U8 bytes[sizeof(NV)];
} NV_bytes;
/* Needed for 32bit with lengths > 2G - 4G, and 64bit */
#if PTRSIZE > 4
#define HAS_U64
#endif
/*
* Fields s_tainted and s_dirty are prefixed with s_ because Perl's include
* files remap tainted and dirty when threading is enabled. That's bad for
* perl to remap such common words. -- RAM, 29/09/00
*/
struct stcxt;
typedef struct stcxt {
int entry; /* flags recursion */
int optype; /* type of traversal operation */
/* which objects have been seen, store time.
tags are numbers, which are cast to (SV *) and stored directly */
#ifdef USE_PTR_TABLE
/* use pseen if we have ptr_tables. We have to store tag+1, because
tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table
without it being confused for a fetch lookup failure. */
struct ptr_tbl *pseen;
/* Still need hseen for the 0.6 file format code. */
#endif
HV *hseen;
AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */
AV *aseen; /* which objects have been seen, retrieve time */
ntag_t where_is_undef; /* index in aseen of PL_sv_undef */
HV *hclass; /* which classnames have been seen, store time */
AV *aclass; /* which classnames have been seen, retrieve time */
HV *hook; /* cache for hook methods per class name */
IV tagnum; /* incremented at store time for each seen object */
IV classnum; /* incremented at store time for each seen classname */
int netorder; /* true if network order used */
int s_tainted; /* true if input source is tainted, at retrieve time */
int forgive_me; /* whether to be forgiving... */
int deparse; /* whether to deparse code refs */
SV *eval; /* whether to eval source code */
int canonical; /* whether to store hashes sorted by key */
#ifndef HAS_RESTRICTED_HASHES
int derestrict; /* whether to downgrade restricted hashes */
#endif
#ifndef HAS_UTF8_ALL
int use_bytes; /* whether to bytes-ify utf8 */
#endif
int accept_future_minor; /* croak immediately on future minor versions? */
int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */
int membuf_ro; /* true means membuf is read-only and msaved is rw */
struct extendable keybuf; /* for hash key retrieval */
struct extendable membuf; /* for memory store/retrieve operations */
struct extendable msaved; /* where potentially valid mbuf is saved */
PerlIO *fio; /* where I/O are performed, NULL for memory */
int ver_major; /* major of version for retrieved object */
int ver_minor; /* minor of version for retrieved object */
SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */
SV *prev; /* contexts chained backwards in real recursion */
SV *my_sv; /* the blessed scalar who's SvPVX() I am */
/* recur_sv:
A hashref of hashrefs or arrayref of arrayrefs is actually a
chain of four SVs, eg for an array ref containing an array ref:
RV -> AV (element) -> RV -> AV
To make this depth appear natural from a perl level we only
want to count this as two levels, so store_ref() stores it's RV
into recur_sv and store_array()/store_hash() will only count
that level if the AV/HV *isn't* recur_sv.
We can't just have store_hash()/store_array() not count that
level, since it's possible for XS code to store an AV or HV
directly as an element (though perl code trying to access such
an object will generally croak.)
*/
SV *recur_sv; /* check only one recursive SV */
int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */
int flags; /* controls whether to bless or tie objects */
IV recur_depth; /* avoid stack overflows RT #97526 */
IV max_recur_depth; /* limit for recur_depth */
IV max_recur_depth_hash; /* limit for recur_depth for hashes */
#ifdef DEBUGME
int traceme; /* TRACEME() produces output */
#endif
} stcxt_t;
#define RECURSION_TOO_DEEP() \
(cxt->max_recur_depth != -1 && ++cxt->recur_depth > cxt->max_recur_depth)
/* There's cases where we need to check whether the hash recursion
limit has been reached without bumping the recursion levels, so the
hash check doesn't bump the depth.
*/
#define RECURSION_TOO_DEEP_HASH() \
(cxt->max_recur_depth_hash != -1 && cxt->recur_depth > cxt->max_recur_depth_hash)
#define MAX_DEPTH_ERROR "Max. recursion depth with nested structures exceeded"
static int storable_free(pTHX_ SV *sv, MAGIC* mg);
static MGVTBL vtbl_storable = {
NULL, /* get */
NULL, /* set */
NULL, /* len */
NULL, /* clear */
storable_free,
#ifdef MGf_COPY
NULL, /* copy */
#endif
#ifdef MGf_DUP
NULL, /* dup */
#endif
#ifdef MGf_LOCAL
NULL /* local */
#endif
};
/* From Digest::MD5. */
#ifndef sv_magicext
# define sv_magicext(sv, obj, type, vtbl, name, namlen) \
THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen)
static MAGIC *THX_sv_magicext(pTHX_
SV *sv, SV *obj, int type,
MGVTBL const *vtbl, char const *name, I32 namlen)
{
MAGIC *mg;
if (obj || namlen)
/* exceeded intended usage of this reserve implementation */
return NULL;
Newxz(mg, 1, MAGIC);
mg->mg_virtual = (MGVTBL*)vtbl;
mg->mg_type = type;
mg->mg_ptr = (char *)name;
mg->mg_len = -1;
(void) SvUPGRADE(sv, SVt_PVMG);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC_set(sv, mg);
SvMAGICAL_off(sv);
mg_magical(sv);
return mg;
}
#endif
#define NEW_STORABLE_CXT_OBJ(cxt) \
STMT_START { \
SV *self = newSV(sizeof(stcxt_t) - 1); \
SV *my_sv = newRV_noinc(self); \
sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \
cxt = (stcxt_t *)SvPVX(self); \
Zero(cxt, 1, stcxt_t); \
cxt->my_sv = my_sv; \
} STMT_END
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI)
#define dSTCXT_SV \
SV *perinterp_sv = *hv_fetch(PL_modglobal, \
MY_VERSION, sizeof(MY_VERSION)-1, TRUE)
#define dSTCXT_PTR(T,name) \
T name = ((perinterp_sv \
&& SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \
? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0))
#define dSTCXT \
dSTCXT_SV; \
dSTCXT_PTR(stcxt_t *, cxt)
#define INIT_STCXT \
dSTCXT; \
NEW_STORABLE_CXT_OBJ(cxt); \
assert(perinterp_sv); \
sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv))
#define SET_STCXT(x) \
STMT_START { \
dSTCXT_SV; \
sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \
} STMT_END
#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */
static stcxt_t *Context_ptr = NULL;
#define dSTCXT stcxt_t *cxt = Context_ptr
#define SET_STCXT(x) Context_ptr = x
#define INIT_STCXT \
dSTCXT; \
NEW_STORABLE_CXT_OBJ(cxt); \
SET_STCXT(cxt)
#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */
/*
* KNOWN BUG:
* Croaking implies a memory leak, since we don't use setjmp/longjmp
* to catch the exit and free memory used during store or retrieve
* operations. This is not too difficult to fix, but I need to understand
* how Perl does it, and croaking is exceptional anyway, so I lack the
* motivation to do it.
*
* The current workaround is to mark the context as dirty when croaking,
* so that data structures can be freed whenever we renter Storable code
* (but only *then*: it's a workaround, not a fix).
*
* This is also imperfect, because we don't really know how far they trapped
* the croak(), and when we were recursing, we won't be able to clean anything
* but the topmost context stacked.
*/
#define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END
/*
* End of "thread-safe" related definitions.
*/
/*
* LOW_32BITS
*
* Keep only the low 32 bits of a pointer (used for tags, which are not
* really pointers).
*/
#if PTRSIZE <= 4
#define LOW_32BITS(x) ((I32) (x))
#else
#define LOW_32BITS(x) ((I32) ((STRLEN) (x) & 0xffffffffUL))
#endif
/*
* PTR2TAG(x)
*
* Convert a pointer into an ntag_t.
*/
#define PTR2TAG(x) ((ntag_t)(x))
#define TAG2PTR(x, type) ((y)(x))
/*
* oI, oS, oC
*
* Hack for Crays, where sizeof(I32) == 8, and which are big-endians.
* Used in the WLEN and RLEN macros.
*/
#if INTSIZE > 4
#define oI(x) ((I32 *) ((char *) (x) + 4))
#define oS(x) ((x) - 4)
#define oL(x) (x)
#define oC(x) (x = 0)
#define CRAY_HACK
#else
#define oI(x) (x)
#define oS(x) (x)
#define oL(x) (x)
#define oC(x)
#endif
/*
* key buffer handling
*/
#define kbuf (cxt->keybuf).arena
#define ksiz (cxt->keybuf).asiz
#define KBUFINIT() \
STMT_START { \
if (!kbuf) { \
TRACEME(("** allocating kbuf of 128 bytes")); \
New(10003, kbuf, 128, char); \
ksiz = 128; \
} \
} STMT_END
#define KBUFCHK(x) \
STMT_START { \
if (x >= ksiz) { \
if (x >= I32_MAX) \
CROAK(("Too large size > I32_MAX")); \
TRACEME(("** extending kbuf to %d bytes (had %d)", \
(int)(x+1), (int)ksiz)); \
Renew(kbuf, x+1, char); \
ksiz = x+1; \
} \
} STMT_END
/*
* memory buffer handling
*/
#define mbase (cxt->membuf).arena
#define msiz (cxt->membuf).asiz
#define mptr (cxt->membuf).aptr
#define mend (cxt->membuf).aend
#define MGROW (1 << 13)
#define MMASK (MGROW - 1)
#define round_mgrow(x) \
((STRLEN) (((STRLEN) (x) + MMASK) & ~MMASK))
#define trunc_int(x) \
((STRLEN) ((STRLEN) (x) & ~(sizeof(int)-1)))
#define int_aligned(x) \
((STRLEN)(x) == trunc_int(x))
#define MBUF_INIT(x) \
STMT_START { \
if (!mbase) { \
TRACEME(("** allocating mbase of %d bytes", MGROW)); \
New(10003, mbase, (int)MGROW, char); \
msiz = (STRLEN)MGROW; \
} \
mptr = mbase; \
if (x) \
mend = mbase + x; \
else \
mend = mbase + msiz; \
} STMT_END
#define MBUF_TRUNC(x) mptr = mbase + x
#define MBUF_SIZE() (mptr - mbase)
/*
* MBUF_SAVE_AND_LOAD
* MBUF_RESTORE
*
* Those macros are used in do_retrieve() to save the current memory
* buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve
* data from a string.
*/
#define MBUF_SAVE_AND_LOAD(in) \
STMT_START { \
ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \
cxt->membuf_ro = 1; \
TRACEME(("saving mbuf")); \
StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \
MBUF_LOAD(in); \
} STMT_END
#define MBUF_RESTORE() \
STMT_START { \
ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
cxt->membuf_ro = 0; \
TRACEME(("restoring mbuf")); \
StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \
} STMT_END
/*
* Use SvPOKp(), because SvPOK() fails on tainted scalars.
* See store_scalar() for other usage of this workaround.
*/
#define MBUF_LOAD(v) \
STMT_START { \
ASSERT(cxt->membuf_ro, ("mbase is read-only")); \
if (!SvPOKp(v)) \
CROAK(("Not a scalar string")); \
mptr = mbase = SvPV(v, msiz); \
mend = mbase + msiz; \
} STMT_END
#define MBUF_XTEND(x) \
STMT_START { \
STRLEN nsz = (STRLEN) round_mgrow((x)+msiz); \
STRLEN offset = mptr - mbase; \
ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \
TRACEME(("** extending mbase from %lu to %lu bytes (wants %lu new)", \
(unsigned long)msiz, (unsigned long)nsz, (unsigned long)(x))); \
Renew(mbase, nsz, char); \
msiz = nsz; \
mptr = mbase + offset; \
mend = mbase + nsz; \
} STMT_END
#define MBUF_CHK(x) \
STMT_START { \
if ((mptr + (x)) > mend) \
MBUF_XTEND(x); \
} STMT_END
#define MBUF_GETC(x) \
STMT_START { \
if (mptr < mend) \
x = (int) (unsigned char) *mptr++; \
else \
return (SV *) 0; \
} STMT_END
#ifdef CRAY_HACK
#define MBUF_GETINT(x) \
STMT_START { \
oC(x); \
if ((mptr + 4) <= mend) { \
memcpy(oI(&x), mptr, 4); \
mptr += 4; \
} else \
return (SV *) 0; \
} STMT_END
#else
#define MBUF_GETINT(x) \
STMT_START { \
if ((mptr + sizeof(int)) <= mend) { \
if (int_aligned(mptr)) \
x = *(int *) mptr; \
else \
memcpy(&x, mptr, sizeof(int)); \
mptr += sizeof(int); \
} else \
return (SV *) 0; \
} STMT_END
#endif
#define MBUF_READ(x,s) \
STMT_START { \
if ((mptr + (s)) <= mend) { \
memcpy(x, mptr, s); \
mptr += s; \
} else \
return (SV *) 0; \
} STMT_END
#define MBUF_SAFEREAD(x,s,z) \
STMT_START { \
if ((mptr + (s)) <= mend) { \
memcpy(x, mptr, s); \
mptr += s; \
} else { \
sv_free(z); \
return (SV *) 0; \
} \
} STMT_END
#define MBUF_SAFEPVREAD(x,s,z) \
STMT_START { \
if ((mptr + (s)) <= mend) { \
memcpy(x, mptr, s); \
mptr += s; \
} else { \
Safefree(z); \
return (SV *) 0; \
} \
} STMT_END
#define MBUF_PUTC(c) \
STMT_START { \
if (mptr < mend) \
*mptr++ = (char) c; \
else { \
MBUF_XTEND(1); \
*mptr++ = (char) c; \
} \
} STMT_END
#ifdef CRAY_HACK
#define MBUF_PUTINT(i) \
STMT_START { \
MBUF_CHK(4); \
memcpy(mptr, oI(&i), 4); \
mptr += 4; \
} STMT_END
#else
#define MBUF_PUTINT(i) \
STMT_START { \
MBUF_CHK(sizeof(int)); \
if (int_aligned(mptr)) \
*(int *) mptr = i; \
else \
memcpy(mptr, &i, sizeof(int)); \
mptr += sizeof(int); \
} STMT_END
#endif
#define MBUF_PUTLONG(l) \
STMT_START { \
MBUF_CHK(8); \
memcpy(mptr, &l, 8); \
mptr += 8; \
} STMT_END
#define MBUF_WRITE(x,s) \
STMT_START { \
MBUF_CHK(s); \
memcpy(mptr, x, s); \
mptr += s; \
} STMT_END
/*
* Possible return values for sv_type().
*/
#define svis_REF 0
#define svis_SCALAR 1
#define svis_ARRAY 2
#define svis_HASH 3
#define svis_TIED 4
#define svis_TIED_ITEM 5
#define svis_CODE 6
#define svis_REGEXP 7
#define svis_OTHER 8
/*
* Flags for SX_HOOK.
*/
#define SHF_TYPE_MASK 0x03
#define SHF_LARGE_CLASSLEN 0x04
#define SHF_LARGE_STRLEN 0x08
#define SHF_LARGE_LISTLEN 0x10
#define SHF_IDX_CLASSNAME 0x20
#define SHF_NEED_RECURSE 0x40
#define SHF_HAS_LIST 0x80
/*
* Types for SX_HOOK (last 2 bits in flags).
*/
#define SHT_SCALAR 0
#define SHT_ARRAY 1
#define SHT_HASH 2
#define SHT_EXTRA 3 /* Read extra byte for type */
/*
* The following are held in the "extra byte"...
*/
#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */
#define SHT_TARRAY 5 /* 4 + 1 -- tied array */
#define SHT_THASH 6 /* 4 + 2 -- tied hash */
/*
* per hash flags for flagged hashes
*/
#define SHV_RESTRICTED 0x01
/*
* per key flags for flagged hashes
*/
#define SHV_K_UTF8 0x01
#define SHV_K_WASUTF8 0x02
#define SHV_K_LOCKED 0x04
#define SHV_K_ISSV 0x08
#define SHV_K_PLACEHOLDER 0x10
/*
* flags to allow blessing and/or tieing data the data we load
*/
#define FLAG_BLESS_OK 2
#define FLAG_TIE_OK 4
/*
* Flags for SX_REGEXP.
*/
#define SHR_U32_RE_LEN 0x01
/*
* Before 0.6, the magic string was "perl-store" (binary version number 0).
*
* Since 0.6 introduced many binary incompatibilities, the magic string has
* been changed to "pst0" to allow an old image to be properly retrieved by
* a newer Storable, but ensure a newer image cannot be retrieved with an
* older version.
*
* At 0.7, objects are given the ability to serialize themselves, and the
* set of markers is extended, backward compatibility is not jeopardized,
* so the binary version number could have remained unchanged. To correctly
* spot errors if a file making use of 0.7-specific extensions is given to
* 0.6 for retrieval, the binary version was moved to "2". And I'm introducing
* a "minor" version, to better track this kind of evolution from now on.
*
*/
static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */
static const char magicstr[] = "pst0"; /* Used as a magic number */
#define MAGICSTR_BYTES 'p','s','t','0'
#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e'
/* 5.6.x introduced the ability to have IVs as long long.
However, Configure still defined BYTEORDER based on the size of a long.
Storable uses the BYTEORDER value as part of the header, but doesn't
explicitly store sizeof(IV) anywhere in the header. Hence on 5.6.x built
with IV as long long on a platform that uses Configure (ie most things
except VMS and Windows) headers are identical for the different IV sizes,
despite the files containing some fields based on sizeof(IV)
Erk. Broken-ness.
5.8 is consistent - the following redefinition kludge is only needed on
5.6.x, but the interwork is needed on 5.8 while data survives in files
with the 5.6 header.
*/
#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4)
#ifndef NO_56_INTERWORK_KLUDGE
#define USE_56_INTERWORK_KLUDGE
#endif
#if BYTEORDER == 0x1234
#undef BYTEORDER
#define BYTEORDER 0x12345678
#else
#if BYTEORDER == 0x4321
#undef BYTEORDER
#define BYTEORDER 0x87654321
#endif
#endif
#endif
#if BYTEORDER == 0x1234
#define BYTEORDER_BYTES '1','2','3','4'
#else
#if BYTEORDER == 0x12345678
#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8'
#ifdef USE_56_INTERWORK_KLUDGE
#define BYTEORDER_BYTES_56 '1','2','3','4'
#endif
#else
#if BYTEORDER == 0x87654321
#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1'
#ifdef USE_56_INTERWORK_KLUDGE
#define BYTEORDER_BYTES_56 '4','3','2','1'
#endif
#else
#if BYTEORDER == 0x4321
#define BYTEORDER_BYTES '4','3','2','1'
#else
#error Unknown byteorder. Please append your byteorder to Storable.xs
#endif
#endif
#endif
#endif
#ifndef INT32_MAX
# define INT32_MAX 2147483647
#endif
#if IVSIZE > 4 && !defined(INT64_MAX)
# define INT64_MAX 9223372036854775807LL
#endif
static const char byteorderstr[] = {BYTEORDER_BYTES, 0};
#ifdef USE_56_INTERWORK_KLUDGE
static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0};
#endif
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */
#define STORABLE_BIN_MINOR 12 /* Binary minor "version" */
#if !defined (SvVOK)
/*
* Perl 5.6.0-5.8.0 can do weak references, but not vstring magic.
*/
#define STORABLE_BIN_WRITE_MINOR 8
#elif PERL_VERSION_GE(5,19,0)
/* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */
/* With 3.x we added LOBJECT */
#define STORABLE_BIN_WRITE_MINOR 11
#else
#define STORABLE_BIN_WRITE_MINOR 9
#endif
#if PERL_VERSION_LT(5,8,1)
#define PL_sv_placeholder PL_sv_undef
#endif
/*
* Useful store shortcuts...
*/
/*
* Note that if you put more than one mark for storing a particular