line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* |
2
|
|
|
|
|
|
* Store and retrieve mechanism. |
3
|
|
|
|
|
|
* |
4
|
|
|
|
|
|
* Copyright (c) 1995-2000, Raphael Manfredi |
5
|
|
|
|
|
|
* |
6
|
|
|
|
|
|
* You may redistribute only under the same terms as Perl 5, as specified |
7
|
|
|
|
|
|
* in the README file that comes with the distribution. |
8
|
|
|
|
|
|
* |
9
|
|
|
|
|
|
*/ |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
#define PERL_NO_GET_CONTEXT /* we want efficiency */ |
12
|
|
|
|
|
|
#include |
13
|
|
|
|
|
|
#include |
14
|
|
|
|
|
|
#include |
15
|
|
|
|
|
|
|
16
|
|
|
|
|
|
#ifndef PATCHLEVEL |
17
|
|
|
|
|
|
#include /* Perl's one, needed since 5.6 */ |
18
|
|
|
|
|
|
#endif |
19
|
|
|
|
|
|
|
20
|
|
|
|
|
|
#if !defined(PERL_VERSION) || PERL_VERSION < 10 || (PERL_VERSION == 10 && PERL_SUBVERSION < 1) |
21
|
|
|
|
|
|
#define NEED_load_module |
22
|
|
|
|
|
|
#define NEED_vload_module |
23
|
|
|
|
|
|
#define NEED_newCONSTSUB |
24
|
|
|
|
|
|
#define NEED_newSVpvn_flags |
25
|
|
|
|
|
|
#define NEED_newRV_noinc |
26
|
|
|
|
|
|
#include "ppport.h" /* handle old perls */ |
27
|
|
|
|
|
|
#endif |
28
|
|
|
|
|
|
|
29
|
|
|
|
|
|
#if 0 |
30
|
|
|
|
|
|
#define DEBUGME /* Debug mode, turns assertions on as well */ |
31
|
|
|
|
|
|
#define DASSERT /* Assertion mode */ |
32
|
|
|
|
|
|
#endif |
33
|
|
|
|
|
|
|
34
|
|
|
|
|
|
/* |
35
|
|
|
|
|
|
* Pre PerlIO time when none of USE_PERLIO and PERLIO_IS_STDIO is defined |
36
|
|
|
|
|
|
* Provide them with the necessary defines so they can build with pre-5.004. |
37
|
|
|
|
|
|
*/ |
38
|
|
|
|
|
|
#ifndef USE_PERLIO |
39
|
|
|
|
|
|
#ifndef PERLIO_IS_STDIO |
40
|
|
|
|
|
|
#define PerlIO FILE |
41
|
|
|
|
|
|
#define PerlIO_getc(x) getc(x) |
42
|
|
|
|
|
|
#define PerlIO_putc(f,x) putc(x,f) |
43
|
|
|
|
|
|
#define PerlIO_read(x,y,z) fread(y,1,z,x) |
44
|
|
|
|
|
|
#define PerlIO_write(x,y,z) fwrite(y,1,z,x) |
45
|
|
|
|
|
|
#define PerlIO_stdoutf printf |
46
|
|
|
|
|
|
#endif /* PERLIO_IS_STDIO */ |
47
|
|
|
|
|
|
#endif /* USE_PERLIO */ |
48
|
|
|
|
|
|
|
49
|
|
|
|
|
|
/* |
50
|
|
|
|
|
|
* Earlier versions of perl might be used, we can't assume they have the latest! |
51
|
|
|
|
|
|
*/ |
52
|
|
|
|
|
|
|
53
|
|
|
|
|
|
#ifndef HvSHAREKEYS_off |
54
|
|
|
|
|
|
#define HvSHAREKEYS_off(hv) /* Ignore */ |
55
|
|
|
|
|
|
#endif |
56
|
|
|
|
|
|
|
57
|
|
|
|
|
|
/* perl <= 5.8.2 needs this */ |
58
|
|
|
|
|
|
#ifndef SvIsCOW |
59
|
|
|
|
|
|
# define SvIsCOW(sv) 0 |
60
|
|
|
|
|
|
#endif |
61
|
|
|
|
|
|
|
62
|
|
|
|
|
|
#ifndef HvRITER_set |
63
|
|
|
|
|
|
# define HvRITER_set(hv,r) (HvRITER(hv) = r) |
64
|
|
|
|
|
|
#endif |
65
|
|
|
|
|
|
#ifndef HvEITER_set |
66
|
|
|
|
|
|
# define HvEITER_set(hv,r) (HvEITER(hv) = r) |
67
|
|
|
|
|
|
#endif |
68
|
|
|
|
|
|
|
69
|
|
|
|
|
|
#ifndef HvRITER_get |
70
|
|
|
|
|
|
# define HvRITER_get HvRITER |
71
|
|
|
|
|
|
#endif |
72
|
|
|
|
|
|
#ifndef HvEITER_get |
73
|
|
|
|
|
|
# define HvEITER_get HvEITER |
74
|
|
|
|
|
|
#endif |
75
|
|
|
|
|
|
|
76
|
|
|
|
|
|
#ifndef HvPLACEHOLDERS_get |
77
|
|
|
|
|
|
# define HvPLACEHOLDERS_get HvPLACEHOLDERS |
78
|
|
|
|
|
|
#endif |
79
|
|
|
|
|
|
|
80
|
|
|
|
|
|
#ifndef HvTOTALKEYS |
81
|
|
|
|
|
|
# define HvTOTALKEYS(hv) HvKEYS(hv) |
82
|
|
|
|
|
|
#endif |
83
|
|
|
|
|
|
|
84
|
|
|
|
|
|
#ifdef SVf_IsCOW |
85
|
|
|
|
|
|
# define SvTRULYREADONLY(sv) SvREADONLY(sv) |
86
|
|
|
|
|
|
#else |
87
|
|
|
|
|
|
# define SvTRULYREADONLY(sv) (SvREADONLY(sv) && !SvIsCOW(sv)) |
88
|
|
|
|
|
|
#endif |
89
|
|
|
|
|
|
|
90
|
|
|
|
|
|
#ifdef DEBUGME |
91
|
|
|
|
|
|
|
92
|
|
|
|
|
|
#ifndef DASSERT |
93
|
|
|
|
|
|
#define DASSERT |
94
|
|
|
|
|
|
#endif |
95
|
|
|
|
|
|
|
96
|
|
|
|
|
|
/* |
97
|
|
|
|
|
|
* TRACEME() will only output things when the $Storable::DEBUGME is true. |
98
|
|
|
|
|
|
*/ |
99
|
|
|
|
|
|
|
100
|
|
|
|
|
|
#define TRACEME(x) \ |
101
|
|
|
|
|
|
STMT_START { \ |
102
|
|
|
|
|
|
if (SvTRUE(perl_get_sv("Storable::DEBUGME", GV_ADD))) \ |
103
|
|
|
|
|
|
{ PerlIO_stdoutf x; PerlIO_stdoutf("\n"); } \ |
104
|
|
|
|
|
|
} STMT_END |
105
|
|
|
|
|
|
#else |
106
|
|
|
|
|
|
#define TRACEME(x) |
107
|
|
|
|
|
|
#endif /* DEBUGME */ |
108
|
|
|
|
|
|
|
109
|
|
|
|
|
|
#ifdef DASSERT |
110
|
|
|
|
|
|
#define ASSERT(x,y) \ |
111
|
|
|
|
|
|
STMT_START { \ |
112
|
|
|
|
|
|
if (!(x)) { \ |
113
|
|
|
|
|
|
PerlIO_stdoutf("ASSERT FAILED (\"%s\", line %d): ", \ |
114
|
|
|
|
|
|
__FILE__, __LINE__); \ |
115
|
|
|
|
|
|
PerlIO_stdoutf y; PerlIO_stdoutf("\n"); \ |
116
|
|
|
|
|
|
} \ |
117
|
|
|
|
|
|
} STMT_END |
118
|
|
|
|
|
|
#else |
119
|
|
|
|
|
|
#define ASSERT(x,y) |
120
|
|
|
|
|
|
#endif |
121
|
|
|
|
|
|
|
122
|
|
|
|
|
|
/* |
123
|
|
|
|
|
|
* Type markers. |
124
|
|
|
|
|
|
*/ |
125
|
|
|
|
|
|
|
126
|
|
|
|
|
|
#define C(x) ((char) (x)) /* For markers with dynamic retrieval handling */ |
127
|
|
|
|
|
|
|
128
|
|
|
|
|
|
#define SX_OBJECT C(0) /* Already stored object */ |
129
|
|
|
|
|
|
#define SX_LSCALAR C(1) /* Scalar (large binary) follows (length, data) */ |
130
|
|
|
|
|
|
#define SX_ARRAY C(2) /* Array forthcoming (size, item list) */ |
131
|
|
|
|
|
|
#define SX_HASH C(3) /* Hash forthcoming (size, key/value pair list) */ |
132
|
|
|
|
|
|
#define SX_REF C(4) /* Reference to object forthcoming */ |
133
|
|
|
|
|
|
#define SX_UNDEF C(5) /* Undefined scalar */ |
134
|
|
|
|
|
|
#define SX_INTEGER C(6) /* Integer forthcoming */ |
135
|
|
|
|
|
|
#define SX_DOUBLE C(7) /* Double forthcoming */ |
136
|
|
|
|
|
|
#define SX_BYTE C(8) /* (signed) byte forthcoming */ |
137
|
|
|
|
|
|
#define SX_NETINT C(9) /* Integer in network order forthcoming */ |
138
|
|
|
|
|
|
#define SX_SCALAR C(10) /* Scalar (binary, small) follows (length, data) */ |
139
|
|
|
|
|
|
#define SX_TIED_ARRAY C(11) /* Tied array forthcoming */ |
140
|
|
|
|
|
|
#define SX_TIED_HASH C(12) /* Tied hash forthcoming */ |
141
|
|
|
|
|
|
#define SX_TIED_SCALAR C(13) /* Tied scalar forthcoming */ |
142
|
|
|
|
|
|
#define SX_SV_UNDEF C(14) /* Perl's immortal PL_sv_undef */ |
143
|
|
|
|
|
|
#define SX_SV_YES C(15) /* Perl's immortal PL_sv_yes */ |
144
|
|
|
|
|
|
#define SX_SV_NO C(16) /* Perl's immortal PL_sv_no */ |
145
|
|
|
|
|
|
#define SX_BLESS C(17) /* Object is blessed */ |
146
|
|
|
|
|
|
#define SX_IX_BLESS C(18) /* Object is blessed, classname given by index */ |
147
|
|
|
|
|
|
#define SX_HOOK C(19) /* Stored via hook, user-defined */ |
148
|
|
|
|
|
|
#define SX_OVERLOAD C(20) /* Overloaded reference */ |
149
|
|
|
|
|
|
#define SX_TIED_KEY C(21) /* Tied magic key forthcoming */ |
150
|
|
|
|
|
|
#define SX_TIED_IDX C(22) /* Tied magic index forthcoming */ |
151
|
|
|
|
|
|
#define SX_UTF8STR C(23) /* UTF-8 string forthcoming (small) */ |
152
|
|
|
|
|
|
#define SX_LUTF8STR C(24) /* UTF-8 string forthcoming (large) */ |
153
|
|
|
|
|
|
#define SX_FLAG_HASH C(25) /* Hash with flags forthcoming (size, flags, key/flags/value triplet list) */ |
154
|
|
|
|
|
|
#define SX_CODE C(26) /* Code references as perl source code */ |
155
|
|
|
|
|
|
#define SX_WEAKREF C(27) /* Weak reference to object forthcoming */ |
156
|
|
|
|
|
|
#define SX_WEAKOVERLOAD C(28) /* Overloaded weak reference */ |
157
|
|
|
|
|
|
#define SX_VSTRING C(29) /* vstring forthcoming (small) */ |
158
|
|
|
|
|
|
#define SX_LVSTRING C(30) /* vstring forthcoming (large) */ |
159
|
|
|
|
|
|
#define SX_SVUNDEF_ELEM C(31) /* array element set to &PL_sv_undef */ |
160
|
|
|
|
|
|
#define SX_ERROR C(32) /* Error */ |
161
|
|
|
|
|
|
|
162
|
|
|
|
|
|
/* |
163
|
|
|
|
|
|
* Those are only used to retrieve "old" pre-0.6 binary images. |
164
|
|
|
|
|
|
*/ |
165
|
|
|
|
|
|
#define SX_ITEM 'i' /* An array item introducer */ |
166
|
|
|
|
|
|
#define SX_IT_UNDEF 'I' /* Undefined array item */ |
167
|
|
|
|
|
|
#define SX_KEY 'k' /* A hash key introducer */ |
168
|
|
|
|
|
|
#define SX_VALUE 'v' /* A hash value introducer */ |
169
|
|
|
|
|
|
#define SX_VL_UNDEF 'V' /* Undefined hash value */ |
170
|
|
|
|
|
|
|
171
|
|
|
|
|
|
/* |
172
|
|
|
|
|
|
* Those are only used to retrieve "old" pre-0.7 binary images |
173
|
|
|
|
|
|
*/ |
174
|
|
|
|
|
|
|
175
|
|
|
|
|
|
#define SX_CLASS 'b' /* Object is blessed, class name length <255 */ |
176
|
|
|
|
|
|
#define SX_LG_CLASS 'B' /* Object is blessed, class name length >255 */ |
177
|
|
|
|
|
|
#define SX_STORED 'X' /* End of object */ |
178
|
|
|
|
|
|
|
179
|
|
|
|
|
|
/* |
180
|
|
|
|
|
|
* Limits between short/long length representation. |
181
|
|
|
|
|
|
*/ |
182
|
|
|
|
|
|
|
183
|
|
|
|
|
|
#define LG_SCALAR 255 /* Large scalar length limit */ |
184
|
|
|
|
|
|
#define LG_BLESS 127 /* Large classname bless limit */ |
185
|
|
|
|
|
|
|
186
|
|
|
|
|
|
/* |
187
|
|
|
|
|
|
* Operation types |
188
|
|
|
|
|
|
*/ |
189
|
|
|
|
|
|
|
190
|
|
|
|
|
|
#define ST_STORE 0x1 /* Store operation */ |
191
|
|
|
|
|
|
#define ST_RETRIEVE 0x2 /* Retrieval operation */ |
192
|
|
|
|
|
|
#define ST_CLONE 0x4 /* Deep cloning operation */ |
193
|
|
|
|
|
|
|
194
|
|
|
|
|
|
/* |
195
|
|
|
|
|
|
* The following structure is used for hash table key retrieval. Since, when |
196
|
|
|
|
|
|
* retrieving objects, we'll be facing blessed hash references, it's best |
197
|
|
|
|
|
|
* to pre-allocate that buffer once and resize it as the need arises, never |
198
|
|
|
|
|
|
* freeing it (keys will be saved away someplace else anyway, so even large |
199
|
|
|
|
|
|
* keys are not enough a motivation to reclaim that space). |
200
|
|
|
|
|
|
* |
201
|
|
|
|
|
|
* This structure is also used for memory store/retrieve operations which |
202
|
|
|
|
|
|
* happen in a fixed place before being malloc'ed elsewhere if persistence |
203
|
|
|
|
|
|
* is required. Hence the aptr pointer. |
204
|
|
|
|
|
|
*/ |
205
|
|
|
|
|
|
struct extendable { |
206
|
|
|
|
|
|
char *arena; /* Will hold hash key strings, resized as needed */ |
207
|
|
|
|
|
|
STRLEN asiz; /* Size of aforementioned buffer */ |
208
|
|
|
|
|
|
char *aptr; /* Arena pointer, for in-place read/write ops */ |
209
|
|
|
|
|
|
char *aend; /* First invalid address */ |
210
|
|
|
|
|
|
}; |
211
|
|
|
|
|
|
|
212
|
|
|
|
|
|
/* |
213
|
|
|
|
|
|
* At store time: |
214
|
|
|
|
|
|
* A hash table records the objects which have already been stored. |
215
|
|
|
|
|
|
* Those are referred to as SX_OBJECT in the file, and their "tag" (i.e. |
216
|
|
|
|
|
|
* an arbitrary sequence number) is used to identify them. |
217
|
|
|
|
|
|
* |
218
|
|
|
|
|
|
* At retrieve time: |
219
|
|
|
|
|
|
* An array table records the objects which have already been retrieved, |
220
|
|
|
|
|
|
* as seen by the tag determined by counting the objects themselves. The |
221
|
|
|
|
|
|
* reference to that retrieved object is kept in the table, and is returned |
222
|
|
|
|
|
|
* when an SX_OBJECT is found bearing that same tag. |
223
|
|
|
|
|
|
* |
224
|
|
|
|
|
|
* The same processing is used to record "classname" for blessed objects: |
225
|
|
|
|
|
|
* indexing by a hash at store time, and via an array at retrieve time. |
226
|
|
|
|
|
|
*/ |
227
|
|
|
|
|
|
|
228
|
|
|
|
|
|
typedef unsigned long stag_t; /* Used by pre-0.6 binary format */ |
229
|
|
|
|
|
|
|
230
|
|
|
|
|
|
/* |
231
|
|
|
|
|
|
* The following "thread-safe" related defines were contributed by |
232
|
|
|
|
|
|
* Murray Nesbitt and integrated by RAM, who |
233
|
|
|
|
|
|
* only renamed things a little bit to ensure consistency with surrounding |
234
|
|
|
|
|
|
* code. -- RAM, 14/09/1999 |
235
|
|
|
|
|
|
* |
236
|
|
|
|
|
|
* The original patch suffered from the fact that the stcxt_t structure |
237
|
|
|
|
|
|
* was global. Murray tried to minimize the impact on the code as much as |
238
|
|
|
|
|
|
* possible. |
239
|
|
|
|
|
|
* |
240
|
|
|
|
|
|
* Starting with 0.7, Storable can be re-entrant, via the STORABLE_xxx hooks |
241
|
|
|
|
|
|
* on objects. Therefore, the notion of context needs to be generalized, |
242
|
|
|
|
|
|
* threading or not. |
243
|
|
|
|
|
|
*/ |
244
|
|
|
|
|
|
|
245
|
|
|
|
|
|
#define MY_VERSION "Storable(" XS_VERSION ")" |
246
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
248
|
|
|
|
|
|
/* |
249
|
|
|
|
|
|
* Conditional UTF8 support. |
250
|
|
|
|
|
|
* |
251
|
|
|
|
|
|
*/ |
252
|
|
|
|
|
|
#ifdef SvUTF8_on |
253
|
|
|
|
|
|
#define STORE_UTF8STR(pv, len) STORE_PV_LEN(pv, len, SX_UTF8STR, SX_LUTF8STR) |
254
|
|
|
|
|
|
#define HAS_UTF8_SCALARS |
255
|
|
|
|
|
|
#ifdef HeKUTF8 |
256
|
|
|
|
|
|
#define HAS_UTF8_HASHES |
257
|
|
|
|
|
|
#define HAS_UTF8_ALL |
258
|
|
|
|
|
|
#else |
259
|
|
|
|
|
|
/* 5.6 perl has utf8 scalars but not hashes */ |
260
|
|
|
|
|
|
#endif |
261
|
|
|
|
|
|
#else |
262
|
|
|
|
|
|
#define SvUTF8(sv) 0 |
263
|
|
|
|
|
|
#define STORE_UTF8STR(pv, len) CROAK(("panic: storing UTF8 in non-UTF8 perl")) |
264
|
|
|
|
|
|
#endif |
265
|
|
|
|
|
|
#ifndef HAS_UTF8_ALL |
266
|
|
|
|
|
|
#define UTF8_CROAK() CROAK(("Cannot retrieve UTF8 data in non-UTF8 perl")) |
267
|
|
|
|
|
|
#endif |
268
|
|
|
|
|
|
#ifndef SvWEAKREF |
269
|
|
|
|
|
|
#define WEAKREF_CROAK() CROAK(("Cannot retrieve weak references in this perl")) |
270
|
|
|
|
|
|
#endif |
271
|
|
|
|
|
|
#ifndef SvVOK |
272
|
|
|
|
|
|
#define VSTRING_CROAK() CROAK(("Cannot retrieve vstring in this perl")) |
273
|
|
|
|
|
|
#endif |
274
|
|
|
|
|
|
|
275
|
|
|
|
|
|
#ifdef HvPLACEHOLDERS |
276
|
|
|
|
|
|
#define HAS_RESTRICTED_HASHES |
277
|
|
|
|
|
|
#else |
278
|
|
|
|
|
|
#define HVhek_PLACEHOLD 0x200 |
279
|
|
|
|
|
|
#define RESTRICTED_HASH_CROAK() CROAK(("Cannot retrieve restricted hash")) |
280
|
|
|
|
|
|
#endif |
281
|
|
|
|
|
|
|
282
|
|
|
|
|
|
#ifdef HvHASKFLAGS |
283
|
|
|
|
|
|
#define HAS_HASH_KEY_FLAGS |
284
|
|
|
|
|
|
#endif |
285
|
|
|
|
|
|
|
286
|
|
|
|
|
|
#ifdef ptr_table_new |
287
|
|
|
|
|
|
#define USE_PTR_TABLE |
288
|
|
|
|
|
|
#endif |
289
|
|
|
|
|
|
|
290
|
|
|
|
|
|
/* |
291
|
|
|
|
|
|
* Fields s_tainted and s_dirty are prefixed with s_ because Perl's include |
292
|
|
|
|
|
|
* files remap tainted and dirty when threading is enabled. That's bad for |
293
|
|
|
|
|
|
* perl to remap such common words. -- RAM, 29/09/00 |
294
|
|
|
|
|
|
*/ |
295
|
|
|
|
|
|
|
296
|
|
|
|
|
|
struct stcxt; |
297
|
|
|
|
|
|
typedef struct stcxt { |
298
|
|
|
|
|
|
int entry; /* flags recursion */ |
299
|
|
|
|
|
|
int optype; /* type of traversal operation */ |
300
|
|
|
|
|
|
/* which objects have been seen, store time. |
301
|
|
|
|
|
|
tags are numbers, which are cast to (SV *) and stored directly */ |
302
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
303
|
|
|
|
|
|
/* use pseen if we have ptr_tables. We have to store tag+1, because |
304
|
|
|
|
|
|
tag numbers start at 0, and we can't store (SV *) 0 in a ptr_table |
305
|
|
|
|
|
|
without it being confused for a fetch lookup failure. */ |
306
|
|
|
|
|
|
struct ptr_tbl *pseen; |
307
|
|
|
|
|
|
/* Still need hseen for the 0.6 file format code. */ |
308
|
|
|
|
|
|
#endif |
309
|
|
|
|
|
|
HV *hseen; |
310
|
|
|
|
|
|
AV *hook_seen; /* which SVs were returned by STORABLE_freeze() */ |
311
|
|
|
|
|
|
AV *aseen; /* which objects have been seen, retrieve time */ |
312
|
|
|
|
|
|
IV where_is_undef; /* index in aseen of PL_sv_undef */ |
313
|
|
|
|
|
|
HV *hclass; /* which classnames have been seen, store time */ |
314
|
|
|
|
|
|
AV *aclass; /* which classnames have been seen, retrieve time */ |
315
|
|
|
|
|
|
HV *hook; /* cache for hook methods per class name */ |
316
|
|
|
|
|
|
IV tagnum; /* incremented at store time for each seen object */ |
317
|
|
|
|
|
|
IV classnum; /* incremented at store time for each seen classname */ |
318
|
|
|
|
|
|
int netorder; /* true if network order used */ |
319
|
|
|
|
|
|
int s_tainted; /* true if input source is tainted, at retrieve time */ |
320
|
|
|
|
|
|
int forgive_me; /* whether to be forgiving... */ |
321
|
|
|
|
|
|
int deparse; /* whether to deparse code refs */ |
322
|
|
|
|
|
|
SV *eval; /* whether to eval source code */ |
323
|
|
|
|
|
|
int canonical; /* whether to store hashes sorted by key */ |
324
|
|
|
|
|
|
#ifndef HAS_RESTRICTED_HASHES |
325
|
|
|
|
|
|
int derestrict; /* whether to downgrade restricted hashes */ |
326
|
|
|
|
|
|
#endif |
327
|
|
|
|
|
|
#ifndef HAS_UTF8_ALL |
328
|
|
|
|
|
|
int use_bytes; /* whether to bytes-ify utf8 */ |
329
|
|
|
|
|
|
#endif |
330
|
|
|
|
|
|
int accept_future_minor; /* croak immediately on future minor versions? */ |
331
|
|
|
|
|
|
int s_dirty; /* context is dirty due to CROAK() -- can be cleaned */ |
332
|
|
|
|
|
|
int membuf_ro; /* true means membuf is read-only and msaved is rw */ |
333
|
|
|
|
|
|
struct extendable keybuf; /* for hash key retrieval */ |
334
|
|
|
|
|
|
struct extendable membuf; /* for memory store/retrieve operations */ |
335
|
|
|
|
|
|
struct extendable msaved; /* where potentially valid mbuf is saved */ |
336
|
|
|
|
|
|
PerlIO *fio; /* where I/O are performed, NULL for memory */ |
337
|
|
|
|
|
|
int ver_major; /* major of version for retrieved object */ |
338
|
|
|
|
|
|
int ver_minor; /* minor of version for retrieved object */ |
339
|
|
|
|
|
|
SV *(**retrieve_vtbl)(pTHX_ struct stcxt *, const char *); /* retrieve dispatch table */ |
340
|
|
|
|
|
|
SV *prev; /* contexts chained backwards in real recursion */ |
341
|
|
|
|
|
|
SV *my_sv; /* the blessed scalar who's SvPVX() I am */ |
342
|
|
|
|
|
|
int in_retrieve_overloaded; /* performance hack for retrieving overloaded objects */ |
343
|
|
|
|
|
|
} stcxt_t; |
344
|
|
|
|
|
|
|
345
|
|
|
|
|
|
static int storable_free(pTHX_ SV *sv, MAGIC* mg); |
346
|
|
|
|
|
|
|
347
|
|
|
|
|
|
static MGVTBL vtbl_storable = { |
348
|
|
|
|
|
|
NULL, /* get */ |
349
|
|
|
|
|
|
NULL, /* set */ |
350
|
|
|
|
|
|
NULL, /* len */ |
351
|
|
|
|
|
|
NULL, /* clear */ |
352
|
|
|
|
|
|
storable_free, |
353
|
|
|
|
|
|
#ifdef MGf_COPY |
354
|
|
|
|
|
|
NULL, /* copy */ |
355
|
|
|
|
|
|
#endif |
356
|
|
|
|
|
|
#ifdef MGf_DUP |
357
|
|
|
|
|
|
NULL, /* dup */ |
358
|
|
|
|
|
|
#endif |
359
|
|
|
|
|
|
#ifdef MGf_LOCAL |
360
|
|
|
|
|
|
NULL /* local */ |
361
|
|
|
|
|
|
#endif |
362
|
|
|
|
|
|
}; |
363
|
|
|
|
|
|
|
364
|
|
|
|
|
|
/* From Digest::MD5. */ |
365
|
|
|
|
|
|
#ifndef sv_magicext |
366
|
|
|
|
|
|
# define sv_magicext(sv, obj, type, vtbl, name, namlen) \ |
367
|
|
|
|
|
|
THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen) |
368
|
|
|
|
|
|
static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, |
369
|
|
|
|
|
|
MGVTBL const *vtbl, char const *name, I32 namlen) |
370
|
|
|
|
|
|
{ |
371
|
|
|
|
|
|
MAGIC *mg; |
372
|
|
|
|
|
|
if (obj || namlen) |
373
|
|
|
|
|
|
/* exceeded intended usage of this reserve implementation */ |
374
|
|
|
|
|
|
return NULL; |
375
|
|
|
|
|
|
Newxz(mg, 1, MAGIC); |
376
|
|
|
|
|
|
mg->mg_virtual = (MGVTBL*)vtbl; |
377
|
|
|
|
|
|
mg->mg_type = type; |
378
|
|
|
|
|
|
mg->mg_ptr = (char *)name; |
379
|
|
|
|
|
|
mg->mg_len = -1; |
380
|
|
|
|
|
|
(void) SvUPGRADE(sv, SVt_PVMG); |
381
|
|
|
|
|
|
mg->mg_moremagic = SvMAGIC(sv); |
382
|
|
|
|
|
|
SvMAGIC_set(sv, mg); |
383
|
|
|
|
|
|
SvMAGICAL_off(sv); |
384
|
|
|
|
|
|
mg_magical(sv); |
385
|
|
|
|
|
|
return mg; |
386
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
#endif |
388
|
|
|
|
|
|
|
389
|
|
|
|
|
|
#define NEW_STORABLE_CXT_OBJ(cxt) \ |
390
|
|
|
|
|
|
STMT_START { \ |
391
|
|
|
|
|
|
SV *self = newSV(sizeof(stcxt_t) - 1); \ |
392
|
|
|
|
|
|
SV *my_sv = newRV_noinc(self); \ |
393
|
|
|
|
|
|
sv_magicext(self, NULL, PERL_MAGIC_ext, &vtbl_storable, NULL, 0); \ |
394
|
|
|
|
|
|
cxt = (stcxt_t *)SvPVX(self); \ |
395
|
|
|
|
|
|
Zero(cxt, 1, stcxt_t); \ |
396
|
|
|
|
|
|
cxt->my_sv = my_sv; \ |
397
|
|
|
|
|
|
} STMT_END |
398
|
|
|
|
|
|
|
399
|
|
|
|
|
|
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || defined(PERL_CAPI) |
400
|
|
|
|
|
|
|
401
|
|
|
|
|
|
#if (PATCHLEVEL <= 4) && (SUBVERSION < 68) |
402
|
|
|
|
|
|
#define dSTCXT_SV \ |
403
|
|
|
|
|
|
SV *perinterp_sv = perl_get_sv(MY_VERSION, 0) |
404
|
|
|
|
|
|
#else /* >= perl5.004_68 */ |
405
|
|
|
|
|
|
#define dSTCXT_SV \ |
406
|
|
|
|
|
|
SV *perinterp_sv = *hv_fetch(PL_modglobal, \ |
407
|
|
|
|
|
|
MY_VERSION, sizeof(MY_VERSION)-1, TRUE) |
408
|
|
|
|
|
|
#endif /* < perl5.004_68 */ |
409
|
|
|
|
|
|
|
410
|
|
|
|
|
|
#define dSTCXT_PTR(T,name) \ |
411
|
|
|
|
|
|
T name = ((perinterp_sv && SvIOK(perinterp_sv) && SvIVX(perinterp_sv) \ |
412
|
|
|
|
|
|
? (T)SvPVX(SvRV(INT2PTR(SV*,SvIVX(perinterp_sv)))) : (T) 0)) |
413
|
|
|
|
|
|
#define dSTCXT \ |
414
|
|
|
|
|
|
dSTCXT_SV; \ |
415
|
|
|
|
|
|
dSTCXT_PTR(stcxt_t *, cxt) |
416
|
|
|
|
|
|
|
417
|
|
|
|
|
|
#define INIT_STCXT \ |
418
|
|
|
|
|
|
dSTCXT; \ |
419
|
|
|
|
|
|
NEW_STORABLE_CXT_OBJ(cxt); \ |
420
|
|
|
|
|
|
sv_setiv(perinterp_sv, PTR2IV(cxt->my_sv)) |
421
|
|
|
|
|
|
|
422
|
|
|
|
|
|
#define SET_STCXT(x) \ |
423
|
|
|
|
|
|
STMT_START { \ |
424
|
|
|
|
|
|
dSTCXT_SV; \ |
425
|
|
|
|
|
|
sv_setiv(perinterp_sv, PTR2IV(x->my_sv)); \ |
426
|
|
|
|
|
|
} STMT_END |
427
|
|
|
|
|
|
|
428
|
|
|
|
|
|
#else /* !MULTIPLICITY && !PERL_OBJECT && !PERL_CAPI */ |
429
|
|
|
|
|
|
|
430
|
|
|
|
|
|
static stcxt_t *Context_ptr = NULL; |
431
|
|
|
|
|
|
#define dSTCXT stcxt_t *cxt = Context_ptr |
432
|
|
|
|
|
|
#define SET_STCXT(x) Context_ptr = x |
433
|
|
|
|
|
|
#define INIT_STCXT \ |
434
|
|
|
|
|
|
dSTCXT; \ |
435
|
|
|
|
|
|
NEW_STORABLE_CXT_OBJ(cxt); \ |
436
|
|
|
|
|
|
SET_STCXT(cxt) |
437
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
439
|
|
|
|
|
|
#endif /* MULTIPLICITY || PERL_OBJECT || PERL_CAPI */ |
440
|
|
|
|
|
|
|
441
|
|
|
|
|
|
/* |
442
|
|
|
|
|
|
* KNOWN BUG: |
443
|
|
|
|
|
|
* Croaking implies a memory leak, since we don't use setjmp/longjmp |
444
|
|
|
|
|
|
* to catch the exit and free memory used during store or retrieve |
445
|
|
|
|
|
|
* operations. This is not too difficult to fix, but I need to understand |
446
|
|
|
|
|
|
* how Perl does it, and croaking is exceptional anyway, so I lack the |
447
|
|
|
|
|
|
* motivation to do it. |
448
|
|
|
|
|
|
* |
449
|
|
|
|
|
|
* The current workaround is to mark the context as dirty when croaking, |
450
|
|
|
|
|
|
* so that data structures can be freed whenever we renter Storable code |
451
|
|
|
|
|
|
* (but only *then*: it's a workaround, not a fix). |
452
|
|
|
|
|
|
* |
453
|
|
|
|
|
|
* This is also imperfect, because we don't really know how far they trapped |
454
|
|
|
|
|
|
* the croak(), and when we were recursing, we won't be able to clean anything |
455
|
|
|
|
|
|
* but the topmost context stacked. |
456
|
|
|
|
|
|
*/ |
457
|
|
|
|
|
|
|
458
|
|
|
|
|
|
#define CROAK(x) STMT_START { cxt->s_dirty = 1; croak x; } STMT_END |
459
|
|
|
|
|
|
|
460
|
|
|
|
|
|
/* |
461
|
|
|
|
|
|
* End of "thread-safe" related definitions. |
462
|
|
|
|
|
|
*/ |
463
|
|
|
|
|
|
|
464
|
|
|
|
|
|
/* |
465
|
|
|
|
|
|
* LOW_32BITS |
466
|
|
|
|
|
|
* |
467
|
|
|
|
|
|
* Keep only the low 32 bits of a pointer (used for tags, which are not |
468
|
|
|
|
|
|
* really pointers). |
469
|
|
|
|
|
|
*/ |
470
|
|
|
|
|
|
|
471
|
|
|
|
|
|
#if PTRSIZE <= 4 |
472
|
|
|
|
|
|
#define LOW_32BITS(x) ((I32) (x)) |
473
|
|
|
|
|
|
#else |
474
|
|
|
|
|
|
#define LOW_32BITS(x) ((I32) ((unsigned long) (x) & 0xffffffffUL)) |
475
|
|
|
|
|
|
#endif |
476
|
|
|
|
|
|
|
477
|
|
|
|
|
|
/* |
478
|
|
|
|
|
|
* oI, oS, oC |
479
|
|
|
|
|
|
* |
480
|
|
|
|
|
|
* Hack for Crays, where sizeof(I32) == 8, and which are big-endians. |
481
|
|
|
|
|
|
* Used in the WLEN and RLEN macros. |
482
|
|
|
|
|
|
*/ |
483
|
|
|
|
|
|
|
484
|
|
|
|
|
|
#if INTSIZE > 4 |
485
|
|
|
|
|
|
#define oI(x) ((I32 *) ((char *) (x) + 4)) |
486
|
|
|
|
|
|
#define oS(x) ((x) - 4) |
487
|
|
|
|
|
|
#define oC(x) (x = 0) |
488
|
|
|
|
|
|
#define CRAY_HACK |
489
|
|
|
|
|
|
#else |
490
|
|
|
|
|
|
#define oI(x) (x) |
491
|
|
|
|
|
|
#define oS(x) (x) |
492
|
|
|
|
|
|
#define oC(x) |
493
|
|
|
|
|
|
#endif |
494
|
|
|
|
|
|
|
495
|
|
|
|
|
|
/* |
496
|
|
|
|
|
|
* key buffer handling |
497
|
|
|
|
|
|
*/ |
498
|
|
|
|
|
|
#define kbuf (cxt->keybuf).arena |
499
|
|
|
|
|
|
#define ksiz (cxt->keybuf).asiz |
500
|
|
|
|
|
|
#define KBUFINIT() \ |
501
|
|
|
|
|
|
STMT_START { \ |
502
|
|
|
|
|
|
if (!kbuf) { \ |
503
|
|
|
|
|
|
TRACEME(("** allocating kbuf of 128 bytes")); \ |
504
|
|
|
|
|
|
New(10003, kbuf, 128, char); \ |
505
|
|
|
|
|
|
ksiz = 128; \ |
506
|
|
|
|
|
|
} \ |
507
|
|
|
|
|
|
} STMT_END |
508
|
|
|
|
|
|
#define KBUFCHK(x) \ |
509
|
|
|
|
|
|
STMT_START { \ |
510
|
|
|
|
|
|
if (x >= ksiz) { \ |
511
|
|
|
|
|
|
TRACEME(("** extending kbuf to %d bytes (had %d)", x+1, ksiz)); \ |
512
|
|
|
|
|
|
Renew(kbuf, x+1, char); \ |
513
|
|
|
|
|
|
ksiz = x+1; \ |
514
|
|
|
|
|
|
} \ |
515
|
|
|
|
|
|
} STMT_END |
516
|
|
|
|
|
|
|
517
|
|
|
|
|
|
/* |
518
|
|
|
|
|
|
* memory buffer handling |
519
|
|
|
|
|
|
*/ |
520
|
|
|
|
|
|
#define mbase (cxt->membuf).arena |
521
|
|
|
|
|
|
#define msiz (cxt->membuf).asiz |
522
|
|
|
|
|
|
#define mptr (cxt->membuf).aptr |
523
|
|
|
|
|
|
#define mend (cxt->membuf).aend |
524
|
|
|
|
|
|
|
525
|
|
|
|
|
|
#define MGROW (1 << 13) |
526
|
|
|
|
|
|
#define MMASK (MGROW - 1) |
527
|
|
|
|
|
|
|
528
|
|
|
|
|
|
#define round_mgrow(x) \ |
529
|
|
|
|
|
|
((unsigned long) (((unsigned long) (x) + MMASK) & ~MMASK)) |
530
|
|
|
|
|
|
#define trunc_int(x) \ |
531
|
|
|
|
|
|
((unsigned long) ((unsigned long) (x) & ~(sizeof(int)-1))) |
532
|
|
|
|
|
|
#define int_aligned(x) \ |
533
|
|
|
|
|
|
((unsigned long) (x) == trunc_int(x)) |
534
|
|
|
|
|
|
|
535
|
|
|
|
|
|
#define MBUF_INIT(x) \ |
536
|
|
|
|
|
|
STMT_START { \ |
537
|
|
|
|
|
|
if (!mbase) { \ |
538
|
|
|
|
|
|
TRACEME(("** allocating mbase of %d bytes", MGROW)); \ |
539
|
|
|
|
|
|
New(10003, mbase, MGROW, char); \ |
540
|
|
|
|
|
|
msiz = (STRLEN)MGROW; \ |
541
|
|
|
|
|
|
} \ |
542
|
|
|
|
|
|
mptr = mbase; \ |
543
|
|
|
|
|
|
if (x) \ |
544
|
|
|
|
|
|
mend = mbase + x; \ |
545
|
|
|
|
|
|
else \ |
546
|
|
|
|
|
|
mend = mbase + msiz; \ |
547
|
|
|
|
|
|
} STMT_END |
548
|
|
|
|
|
|
|
549
|
|
|
|
|
|
#define MBUF_TRUNC(x) mptr = mbase + x |
550
|
|
|
|
|
|
#define MBUF_SIZE() (mptr - mbase) |
551
|
|
|
|
|
|
|
552
|
|
|
|
|
|
/* |
553
|
|
|
|
|
|
* MBUF_SAVE_AND_LOAD |
554
|
|
|
|
|
|
* MBUF_RESTORE |
555
|
|
|
|
|
|
* |
556
|
|
|
|
|
|
* Those macros are used in do_retrieve() to save the current memory |
557
|
|
|
|
|
|
* buffer into cxt->msaved, before MBUF_LOAD() can be used to retrieve |
558
|
|
|
|
|
|
* data from a string. |
559
|
|
|
|
|
|
*/ |
560
|
|
|
|
|
|
#define MBUF_SAVE_AND_LOAD(in) \ |
561
|
|
|
|
|
|
STMT_START { \ |
562
|
|
|
|
|
|
ASSERT(!cxt->membuf_ro, ("mbase not already saved")); \ |
563
|
|
|
|
|
|
cxt->membuf_ro = 1; \ |
564
|
|
|
|
|
|
TRACEME(("saving mbuf")); \ |
565
|
|
|
|
|
|
StructCopy(&cxt->membuf, &cxt->msaved, struct extendable); \ |
566
|
|
|
|
|
|
MBUF_LOAD(in); \ |
567
|
|
|
|
|
|
} STMT_END |
568
|
|
|
|
|
|
|
569
|
|
|
|
|
|
#define MBUF_RESTORE() \ |
570
|
|
|
|
|
|
STMT_START { \ |
571
|
|
|
|
|
|
ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ |
572
|
|
|
|
|
|
cxt->membuf_ro = 0; \ |
573
|
|
|
|
|
|
TRACEME(("restoring mbuf")); \ |
574
|
|
|
|
|
|
StructCopy(&cxt->msaved, &cxt->membuf, struct extendable); \ |
575
|
|
|
|
|
|
} STMT_END |
576
|
|
|
|
|
|
|
577
|
|
|
|
|
|
/* |
578
|
|
|
|
|
|
* Use SvPOKp(), because SvPOK() fails on tainted scalars. |
579
|
|
|
|
|
|
* See store_scalar() for other usage of this workaround. |
580
|
|
|
|
|
|
*/ |
581
|
|
|
|
|
|
#define MBUF_LOAD(v) \ |
582
|
|
|
|
|
|
STMT_START { \ |
583
|
|
|
|
|
|
ASSERT(cxt->membuf_ro, ("mbase is read-only")); \ |
584
|
|
|
|
|
|
if (!SvPOKp(v)) \ |
585
|
|
|
|
|
|
CROAK(("Not a scalar string")); \ |
586
|
|
|
|
|
|
mptr = mbase = SvPV(v, msiz); \ |
587
|
|
|
|
|
|
mend = mbase + msiz; \ |
588
|
|
|
|
|
|
} STMT_END |
589
|
|
|
|
|
|
|
590
|
|
|
|
|
|
#define MBUF_XTEND(x) \ |
591
|
|
|
|
|
|
STMT_START { \ |
592
|
|
|
|
|
|
int nsz = (int) round_mgrow((x)+msiz); \ |
593
|
|
|
|
|
|
int offset = mptr - mbase; \ |
594
|
|
|
|
|
|
ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); \ |
595
|
|
|
|
|
|
TRACEME(("** extending mbase from %d to %d bytes (wants %d new)", \ |
596
|
|
|
|
|
|
msiz, nsz, (x))); \ |
597
|
|
|
|
|
|
Renew(mbase, nsz, char); \ |
598
|
|
|
|
|
|
msiz = nsz; \ |
599
|
|
|
|
|
|
mptr = mbase + offset; \ |
600
|
|
|
|
|
|
mend = mbase + nsz; \ |
601
|
|
|
|
|
|
} STMT_END |
602
|
|
|
|
|
|
|
603
|
|
|
|
|
|
#define MBUF_CHK(x) \ |
604
|
|
|
|
|
|
STMT_START { \ |
605
|
|
|
|
|
|
if ((mptr + (x)) > mend) \ |
606
|
|
|
|
|
|
MBUF_XTEND(x); \ |
607
|
|
|
|
|
|
} STMT_END |
608
|
|
|
|
|
|
|
609
|
|
|
|
|
|
#define MBUF_GETC(x) \ |
610
|
|
|
|
|
|
STMT_START { \ |
611
|
|
|
|
|
|
if (mptr < mend) \ |
612
|
|
|
|
|
|
x = (int) (unsigned char) *mptr++; \ |
613
|
|
|
|
|
|
else \ |
614
|
|
|
|
|
|
return (SV *) 0; \ |
615
|
|
|
|
|
|
} STMT_END |
616
|
|
|
|
|
|
|
617
|
|
|
|
|
|
#ifdef CRAY_HACK |
618
|
|
|
|
|
|
#define MBUF_GETINT(x) \ |
619
|
|
|
|
|
|
STMT_START { \ |
620
|
|
|
|
|
|
oC(x); \ |
621
|
|
|
|
|
|
if ((mptr + 4) <= mend) { \ |
622
|
|
|
|
|
|
memcpy(oI(&x), mptr, 4); \ |
623
|
|
|
|
|
|
mptr += 4; \ |
624
|
|
|
|
|
|
} else \ |
625
|
|
|
|
|
|
return (SV *) 0; \ |
626
|
|
|
|
|
|
} STMT_END |
627
|
|
|
|
|
|
#else |
628
|
|
|
|
|
|
#define MBUF_GETINT(x) \ |
629
|
|
|
|
|
|
STMT_START { \ |
630
|
|
|
|
|
|
if ((mptr + sizeof(int)) <= mend) { \ |
631
|
|
|
|
|
|
if (int_aligned(mptr)) \ |
632
|
|
|
|
|
|
x = *(int *) mptr; \ |
633
|
|
|
|
|
|
else \ |
634
|
|
|
|
|
|
memcpy(&x, mptr, sizeof(int)); \ |
635
|
|
|
|
|
|
mptr += sizeof(int); \ |
636
|
|
|
|
|
|
} else \ |
637
|
|
|
|
|
|
return (SV *) 0; \ |
638
|
|
|
|
|
|
} STMT_END |
639
|
|
|
|
|
|
#endif |
640
|
|
|
|
|
|
|
641
|
|
|
|
|
|
#define MBUF_READ(x,s) \ |
642
|
|
|
|
|
|
STMT_START { \ |
643
|
|
|
|
|
|
if ((mptr + (s)) <= mend) { \ |
644
|
|
|
|
|
|
memcpy(x, mptr, s); \ |
645
|
|
|
|
|
|
mptr += s; \ |
646
|
|
|
|
|
|
} else \ |
647
|
|
|
|
|
|
return (SV *) 0; \ |
648
|
|
|
|
|
|
} STMT_END |
649
|
|
|
|
|
|
|
650
|
|
|
|
|
|
#define MBUF_SAFEREAD(x,s,z) \ |
651
|
|
|
|
|
|
STMT_START { \ |
652
|
|
|
|
|
|
if ((mptr + (s)) <= mend) { \ |
653
|
|
|
|
|
|
memcpy(x, mptr, s); \ |
654
|
|
|
|
|
|
mptr += s; \ |
655
|
|
|
|
|
|
} else { \ |
656
|
|
|
|
|
|
sv_free(z); \ |
657
|
|
|
|
|
|
return (SV *) 0; \ |
658
|
|
|
|
|
|
} \ |
659
|
|
|
|
|
|
} STMT_END |
660
|
|
|
|
|
|
|
661
|
|
|
|
|
|
#define MBUF_SAFEPVREAD(x,s,z) \ |
662
|
|
|
|
|
|
STMT_START { \ |
663
|
|
|
|
|
|
if ((mptr + (s)) <= mend) { \ |
664
|
|
|
|
|
|
memcpy(x, mptr, s); \ |
665
|
|
|
|
|
|
mptr += s; \ |
666
|
|
|
|
|
|
} else { \ |
667
|
|
|
|
|
|
Safefree(z); \ |
668
|
|
|
|
|
|
return (SV *) 0; \ |
669
|
|
|
|
|
|
} \ |
670
|
|
|
|
|
|
} STMT_END |
671
|
|
|
|
|
|
|
672
|
|
|
|
|
|
#define MBUF_PUTC(c) \ |
673
|
|
|
|
|
|
STMT_START { \ |
674
|
|
|
|
|
|
if (mptr < mend) \ |
675
|
|
|
|
|
|
*mptr++ = (char) c; \ |
676
|
|
|
|
|
|
else { \ |
677
|
|
|
|
|
|
MBUF_XTEND(1); \ |
678
|
|
|
|
|
|
*mptr++ = (char) c; \ |
679
|
|
|
|
|
|
} \ |
680
|
|
|
|
|
|
} STMT_END |
681
|
|
|
|
|
|
|
682
|
|
|
|
|
|
#ifdef CRAY_HACK |
683
|
|
|
|
|
|
#define MBUF_PUTINT(i) \ |
684
|
|
|
|
|
|
STMT_START { \ |
685
|
|
|
|
|
|
MBUF_CHK(4); \ |
686
|
|
|
|
|
|
memcpy(mptr, oI(&i), 4); \ |
687
|
|
|
|
|
|
mptr += 4; \ |
688
|
|
|
|
|
|
} STMT_END |
689
|
|
|
|
|
|
#else |
690
|
|
|
|
|
|
#define MBUF_PUTINT(i) \ |
691
|
|
|
|
|
|
STMT_START { \ |
692
|
|
|
|
|
|
MBUF_CHK(sizeof(int)); \ |
693
|
|
|
|
|
|
if (int_aligned(mptr)) \ |
694
|
|
|
|
|
|
*(int *) mptr = i; \ |
695
|
|
|
|
|
|
else \ |
696
|
|
|
|
|
|
memcpy(mptr, &i, sizeof(int)); \ |
697
|
|
|
|
|
|
mptr += sizeof(int); \ |
698
|
|
|
|
|
|
} STMT_END |
699
|
|
|
|
|
|
#endif |
700
|
|
|
|
|
|
|
701
|
|
|
|
|
|
#define MBUF_WRITE(x,s) \ |
702
|
|
|
|
|
|
STMT_START { \ |
703
|
|
|
|
|
|
MBUF_CHK(s); \ |
704
|
|
|
|
|
|
memcpy(mptr, x, s); \ |
705
|
|
|
|
|
|
mptr += s; \ |
706
|
|
|
|
|
|
} STMT_END |
707
|
|
|
|
|
|
|
708
|
|
|
|
|
|
/* |
709
|
|
|
|
|
|
* Possible return values for sv_type(). |
710
|
|
|
|
|
|
*/ |
711
|
|
|
|
|
|
|
712
|
|
|
|
|
|
#define svis_REF 0 |
713
|
|
|
|
|
|
#define svis_SCALAR 1 |
714
|
|
|
|
|
|
#define svis_ARRAY 2 |
715
|
|
|
|
|
|
#define svis_HASH 3 |
716
|
|
|
|
|
|
#define svis_TIED 4 |
717
|
|
|
|
|
|
#define svis_TIED_ITEM 5 |
718
|
|
|
|
|
|
#define svis_CODE 6 |
719
|
|
|
|
|
|
#define svis_OTHER 7 |
720
|
|
|
|
|
|
|
721
|
|
|
|
|
|
/* |
722
|
|
|
|
|
|
* Flags for SX_HOOK. |
723
|
|
|
|
|
|
*/ |
724
|
|
|
|
|
|
|
725
|
|
|
|
|
|
#define SHF_TYPE_MASK 0x03 |
726
|
|
|
|
|
|
#define SHF_LARGE_CLASSLEN 0x04 |
727
|
|
|
|
|
|
#define SHF_LARGE_STRLEN 0x08 |
728
|
|
|
|
|
|
#define SHF_LARGE_LISTLEN 0x10 |
729
|
|
|
|
|
|
#define SHF_IDX_CLASSNAME 0x20 |
730
|
|
|
|
|
|
#define SHF_NEED_RECURSE 0x40 |
731
|
|
|
|
|
|
#define SHF_HAS_LIST 0x80 |
732
|
|
|
|
|
|
|
733
|
|
|
|
|
|
/* |
734
|
|
|
|
|
|
* Types for SX_HOOK (last 2 bits in flags). |
735
|
|
|
|
|
|
*/ |
736
|
|
|
|
|
|
|
737
|
|
|
|
|
|
#define SHT_SCALAR 0 |
738
|
|
|
|
|
|
#define SHT_ARRAY 1 |
739
|
|
|
|
|
|
#define SHT_HASH 2 |
740
|
|
|
|
|
|
#define SHT_EXTRA 3 /* Read extra byte for type */ |
741
|
|
|
|
|
|
|
742
|
|
|
|
|
|
/* |
743
|
|
|
|
|
|
* The following are held in the "extra byte"... |
744
|
|
|
|
|
|
*/ |
745
|
|
|
|
|
|
|
746
|
|
|
|
|
|
#define SHT_TSCALAR 4 /* 4 + 0 -- tied scalar */ |
747
|
|
|
|
|
|
#define SHT_TARRAY 5 /* 4 + 1 -- tied array */ |
748
|
|
|
|
|
|
#define SHT_THASH 6 /* 4 + 2 -- tied hash */ |
749
|
|
|
|
|
|
|
750
|
|
|
|
|
|
/* |
751
|
|
|
|
|
|
* per hash flags for flagged hashes |
752
|
|
|
|
|
|
*/ |
753
|
|
|
|
|
|
|
754
|
|
|
|
|
|
#define SHV_RESTRICTED 0x01 |
755
|
|
|
|
|
|
|
756
|
|
|
|
|
|
/* |
757
|
|
|
|
|
|
* per key flags for flagged hashes |
758
|
|
|
|
|
|
*/ |
759
|
|
|
|
|
|
|
760
|
|
|
|
|
|
#define SHV_K_UTF8 0x01 |
761
|
|
|
|
|
|
#define SHV_K_WASUTF8 0x02 |
762
|
|
|
|
|
|
#define SHV_K_LOCKED 0x04 |
763
|
|
|
|
|
|
#define SHV_K_ISSV 0x08 |
764
|
|
|
|
|
|
#define SHV_K_PLACEHOLDER 0x10 |
765
|
|
|
|
|
|
|
766
|
|
|
|
|
|
/* |
767
|
|
|
|
|
|
* Before 0.6, the magic string was "perl-store" (binary version number 0). |
768
|
|
|
|
|
|
* |
769
|
|
|
|
|
|
* Since 0.6 introduced many binary incompatibilities, the magic string has |
770
|
|
|
|
|
|
* been changed to "pst0" to allow an old image to be properly retrieved by |
771
|
|
|
|
|
|
* a newer Storable, but ensure a newer image cannot be retrieved with an |
772
|
|
|
|
|
|
* older version. |
773
|
|
|
|
|
|
* |
774
|
|
|
|
|
|
* At 0.7, objects are given the ability to serialize themselves, and the |
775
|
|
|
|
|
|
* set of markers is extended, backward compatibility is not jeopardized, |
776
|
|
|
|
|
|
* so the binary version number could have remained unchanged. To correctly |
777
|
|
|
|
|
|
* spot errors if a file making use of 0.7-specific extensions is given to |
778
|
|
|
|
|
|
* 0.6 for retrieval, the binary version was moved to "2". And I'm introducing |
779
|
|
|
|
|
|
* a "minor" version, to better track this kind of evolution from now on. |
780
|
|
|
|
|
|
* |
781
|
|
|
|
|
|
*/ |
782
|
|
|
|
|
|
static const char old_magicstr[] = "perl-store"; /* Magic number before 0.6 */ |
783
|
|
|
|
|
|
static const char magicstr[] = "pst0"; /* Used as a magic number */ |
784
|
|
|
|
|
|
|
785
|
|
|
|
|
|
#define MAGICSTR_BYTES 'p','s','t','0' |
786
|
|
|
|
|
|
#define OLDMAGICSTR_BYTES 'p','e','r','l','-','s','t','o','r','e' |
787
|
|
|
|
|
|
|
788
|
|
|
|
|
|
/* 5.6.x introduced the ability to have IVs as long long. |
789
|
|
|
|
|
|
However, Configure still defined BYTEORDER based on the size of a long. |
790
|
|
|
|
|
|
Storable uses the BYTEORDER value as part of the header, but doesn't |
791
|
|
|
|
|
|
explicitly store sizeof(IV) anywhere in the header. Hence on 5.6.x built |
792
|
|
|
|
|
|
with IV as long long on a platform that uses Configure (ie most things |
793
|
|
|
|
|
|
except VMS and Windows) headers are identical for the different IV sizes, |
794
|
|
|
|
|
|
despite the files containing some fields based on sizeof(IV) |
795
|
|
|
|
|
|
Erk. Broken-ness. |
796
|
|
|
|
|
|
5.8 is consistent - the following redefinition kludge is only needed on |
797
|
|
|
|
|
|
5.6.x, but the interwork is needed on 5.8 while data survives in files |
798
|
|
|
|
|
|
with the 5.6 header. |
799
|
|
|
|
|
|
|
800
|
|
|
|
|
|
*/ |
801
|
|
|
|
|
|
|
802
|
|
|
|
|
|
#if defined (IVSIZE) && (IVSIZE == 8) && (LONGSIZE == 4) |
803
|
|
|
|
|
|
#ifndef NO_56_INTERWORK_KLUDGE |
804
|
|
|
|
|
|
#define USE_56_INTERWORK_KLUDGE |
805
|
|
|
|
|
|
#endif |
806
|
|
|
|
|
|
#if BYTEORDER == 0x1234 |
807
|
|
|
|
|
|
#undef BYTEORDER |
808
|
|
|
|
|
|
#define BYTEORDER 0x12345678 |
809
|
|
|
|
|
|
#else |
810
|
|
|
|
|
|
#if BYTEORDER == 0x4321 |
811
|
|
|
|
|
|
#undef BYTEORDER |
812
|
|
|
|
|
|
#define BYTEORDER 0x87654321 |
813
|
|
|
|
|
|
#endif |
814
|
|
|
|
|
|
#endif |
815
|
|
|
|
|
|
#endif |
816
|
|
|
|
|
|
|
817
|
|
|
|
|
|
#if BYTEORDER == 0x1234 |
818
|
|
|
|
|
|
#define BYTEORDER_BYTES '1','2','3','4' |
819
|
|
|
|
|
|
#else |
820
|
|
|
|
|
|
#if BYTEORDER == 0x12345678 |
821
|
|
|
|
|
|
#define BYTEORDER_BYTES '1','2','3','4','5','6','7','8' |
822
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
823
|
|
|
|
|
|
#define BYTEORDER_BYTES_56 '1','2','3','4' |
824
|
|
|
|
|
|
#endif |
825
|
|
|
|
|
|
#else |
826
|
|
|
|
|
|
#if BYTEORDER == 0x87654321 |
827
|
|
|
|
|
|
#define BYTEORDER_BYTES '8','7','6','5','4','3','2','1' |
828
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
829
|
|
|
|
|
|
#define BYTEORDER_BYTES_56 '4','3','2','1' |
830
|
|
|
|
|
|
#endif |
831
|
|
|
|
|
|
#else |
832
|
|
|
|
|
|
#if BYTEORDER == 0x4321 |
833
|
|
|
|
|
|
#define BYTEORDER_BYTES '4','3','2','1' |
834
|
|
|
|
|
|
#else |
835
|
|
|
|
|
|
#error Unknown byteorder. Please append your byteorder to Storable.xs |
836
|
|
|
|
|
|
#endif |
837
|
|
|
|
|
|
#endif |
838
|
|
|
|
|
|
#endif |
839
|
|
|
|
|
|
#endif |
840
|
|
|
|
|
|
|
841
|
|
|
|
|
|
static const char byteorderstr[] = {BYTEORDER_BYTES, 0}; |
842
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
843
|
|
|
|
|
|
static const char byteorderstr_56[] = {BYTEORDER_BYTES_56, 0}; |
844
|
|
|
|
|
|
#endif |
845
|
|
|
|
|
|
|
846
|
|
|
|
|
|
#define STORABLE_BIN_MAJOR 2 /* Binary major "version" */ |
847
|
|
|
|
|
|
#define STORABLE_BIN_MINOR 10 /* Binary minor "version" */ |
848
|
|
|
|
|
|
|
849
|
|
|
|
|
|
#if (PATCHLEVEL <= 5) |
850
|
|
|
|
|
|
#define STORABLE_BIN_WRITE_MINOR 4 |
851
|
|
|
|
|
|
#elif !defined (SvVOK) |
852
|
|
|
|
|
|
/* |
853
|
|
|
|
|
|
* Perl 5.6.0-5.8.0 can do weak references, but not vstring magic. |
854
|
|
|
|
|
|
*/ |
855
|
|
|
|
|
|
#define STORABLE_BIN_WRITE_MINOR 8 |
856
|
|
|
|
|
|
#elif PATCHLEVEL >= 19 |
857
|
|
|
|
|
|
/* Perl 5.19 takes away the special meaning of PL_sv_undef in arrays. */ |
858
|
|
|
|
|
|
#define STORABLE_BIN_WRITE_MINOR 10 |
859
|
|
|
|
|
|
#else |
860
|
|
|
|
|
|
#define STORABLE_BIN_WRITE_MINOR 9 |
861
|
|
|
|
|
|
#endif /* (PATCHLEVEL <= 5) */ |
862
|
|
|
|
|
|
|
863
|
|
|
|
|
|
#if (PATCHLEVEL < 8 || (PATCHLEVEL == 8 && SUBVERSION < 1)) |
864
|
|
|
|
|
|
#define PL_sv_placeholder PL_sv_undef |
865
|
|
|
|
|
|
#endif |
866
|
|
|
|
|
|
|
867
|
|
|
|
|
|
/* |
868
|
|
|
|
|
|
* Useful store shortcuts... |
869
|
|
|
|
|
|
*/ |
870
|
|
|
|
|
|
|
871
|
|
|
|
|
|
/* |
872
|
|
|
|
|
|
* Note that if you put more than one mark for storing a particular |
873
|
|
|
|
|
|
* type of thing, *and* in the retrieve_foo() function you mark both |
874
|
|
|
|
|
|
* the thingy's you get off with SEEN(), you *must* increase the |
875
|
|
|
|
|
|
* tagnum with cxt->tagnum++ along with this macro! |
876
|
|
|
|
|
|
* - samv 20Jan04 |
877
|
|
|
|
|
|
*/ |
878
|
|
|
|
|
|
#define PUTMARK(x) \ |
879
|
|
|
|
|
|
STMT_START { \ |
880
|
|
|
|
|
|
if (!cxt->fio) \ |
881
|
|
|
|
|
|
MBUF_PUTC(x); \ |
882
|
|
|
|
|
|
else if (PerlIO_putc(cxt->fio, x) == EOF) \ |
883
|
|
|
|
|
|
return -1; \ |
884
|
|
|
|
|
|
} STMT_END |
885
|
|
|
|
|
|
|
886
|
|
|
|
|
|
#define WRITE_I32(x) \ |
887
|
|
|
|
|
|
STMT_START { \ |
888
|
|
|
|
|
|
ASSERT(sizeof(x) == sizeof(I32), ("writing an I32")); \ |
889
|
|
|
|
|
|
if (!cxt->fio) \ |
890
|
|
|
|
|
|
MBUF_PUTINT(x); \ |
891
|
|
|
|
|
|
else if (PerlIO_write(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ |
892
|
|
|
|
|
|
return -1; \ |
893
|
|
|
|
|
|
} STMT_END |
894
|
|
|
|
|
|
|
895
|
|
|
|
|
|
#ifdef HAS_HTONL |
896
|
|
|
|
|
|
#define WLEN(x) \ |
897
|
|
|
|
|
|
STMT_START { \ |
898
|
|
|
|
|
|
ASSERT(sizeof(x) == sizeof(int), ("WLEN writing an int")); \ |
899
|
|
|
|
|
|
if (cxt->netorder) { \ |
900
|
|
|
|
|
|
int y = (int) htonl(x); \ |
901
|
|
|
|
|
|
if (!cxt->fio) \ |
902
|
|
|
|
|
|
MBUF_PUTINT(y); \ |
903
|
|
|
|
|
|
else if (PerlIO_write(cxt->fio,oI(&y),oS(sizeof(y))) != oS(sizeof(y))) \ |
904
|
|
|
|
|
|
return -1; \ |
905
|
|
|
|
|
|
} else { \ |
906
|
|
|
|
|
|
if (!cxt->fio) \ |
907
|
|
|
|
|
|
MBUF_PUTINT(x); \ |
908
|
|
|
|
|
|
else if (PerlIO_write(cxt->fio,oI(&x),oS(sizeof(x))) != oS(sizeof(x))) \ |
909
|
|
|
|
|
|
return -1; \ |
910
|
|
|
|
|
|
} \ |
911
|
|
|
|
|
|
} STMT_END |
912
|
|
|
|
|
|
#else |
913
|
|
|
|
|
|
#define WLEN(x) WRITE_I32(x) |
914
|
|
|
|
|
|
#endif |
915
|
|
|
|
|
|
|
916
|
|
|
|
|
|
#define WRITE(x,y) \ |
917
|
|
|
|
|
|
STMT_START { \ |
918
|
|
|
|
|
|
if (!cxt->fio) \ |
919
|
|
|
|
|
|
MBUF_WRITE(x,y); \ |
920
|
|
|
|
|
|
else if (PerlIO_write(cxt->fio, x, y) != y) \ |
921
|
|
|
|
|
|
return -1; \ |
922
|
|
|
|
|
|
} STMT_END |
923
|
|
|
|
|
|
|
924
|
|
|
|
|
|
#define STORE_PV_LEN(pv, len, small, large) \ |
925
|
|
|
|
|
|
STMT_START { \ |
926
|
|
|
|
|
|
if (len <= LG_SCALAR) { \ |
927
|
|
|
|
|
|
unsigned char clen = (unsigned char) len; \ |
928
|
|
|
|
|
|
PUTMARK(small); \ |
929
|
|
|
|
|
|
PUTMARK(clen); \ |
930
|
|
|
|
|
|
if (len) \ |
931
|
|
|
|
|
|
WRITE(pv, len); \ |
932
|
|
|
|
|
|
} else { \ |
933
|
|
|
|
|
|
PUTMARK(large); \ |
934
|
|
|
|
|
|
WLEN(len); \ |
935
|
|
|
|
|
|
WRITE(pv, len); \ |
936
|
|
|
|
|
|
} \ |
937
|
|
|
|
|
|
} STMT_END |
938
|
|
|
|
|
|
|
939
|
|
|
|
|
|
#define STORE_SCALAR(pv, len) STORE_PV_LEN(pv, len, SX_SCALAR, SX_LSCALAR) |
940
|
|
|
|
|
|
|
941
|
|
|
|
|
|
/* |
942
|
|
|
|
|
|
* Store &PL_sv_undef in arrays without recursing through store(). We |
943
|
|
|
|
|
|
* actually use this to represent nonexistent elements, for historical |
944
|
|
|
|
|
|
* reasons. |
945
|
|
|
|
|
|
*/ |
946
|
|
|
|
|
|
#define STORE_SV_UNDEF() \ |
947
|
|
|
|
|
|
STMT_START { \ |
948
|
|
|
|
|
|
cxt->tagnum++; \ |
949
|
|
|
|
|
|
PUTMARK(SX_SV_UNDEF); \ |
950
|
|
|
|
|
|
} STMT_END |
951
|
|
|
|
|
|
|
952
|
|
|
|
|
|
/* |
953
|
|
|
|
|
|
* Useful retrieve shortcuts... |
954
|
|
|
|
|
|
*/ |
955
|
|
|
|
|
|
|
956
|
|
|
|
|
|
#define GETCHAR() \ |
957
|
|
|
|
|
|
(cxt->fio ? PerlIO_getc(cxt->fio) : (mptr >= mend ? EOF : (int) *mptr++)) |
958
|
|
|
|
|
|
|
959
|
|
|
|
|
|
#define GETMARK(x) \ |
960
|
|
|
|
|
|
STMT_START { \ |
961
|
|
|
|
|
|
if (!cxt->fio) \ |
962
|
|
|
|
|
|
MBUF_GETC(x); \ |
963
|
|
|
|
|
|
else if ((int) (x = PerlIO_getc(cxt->fio)) == EOF) \ |
964
|
|
|
|
|
|
return (SV *) 0; \ |
965
|
|
|
|
|
|
} STMT_END |
966
|
|
|
|
|
|
|
967
|
|
|
|
|
|
#define READ_I32(x) \ |
968
|
|
|
|
|
|
STMT_START { \ |
969
|
|
|
|
|
|
ASSERT(sizeof(x) == sizeof(I32), ("reading an I32")); \ |
970
|
|
|
|
|
|
oC(x); \ |
971
|
|
|
|
|
|
if (!cxt->fio) \ |
972
|
|
|
|
|
|
MBUF_GETINT(x); \ |
973
|
|
|
|
|
|
else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ |
974
|
|
|
|
|
|
return (SV *) 0; \ |
975
|
|
|
|
|
|
} STMT_END |
976
|
|
|
|
|
|
|
977
|
|
|
|
|
|
#ifdef HAS_NTOHL |
978
|
|
|
|
|
|
#define RLEN(x) \ |
979
|
|
|
|
|
|
STMT_START { \ |
980
|
|
|
|
|
|
oC(x); \ |
981
|
|
|
|
|
|
if (!cxt->fio) \ |
982
|
|
|
|
|
|
MBUF_GETINT(x); \ |
983
|
|
|
|
|
|
else if (PerlIO_read(cxt->fio, oI(&x), oS(sizeof(x))) != oS(sizeof(x))) \ |
984
|
|
|
|
|
|
return (SV *) 0; \ |
985
|
|
|
|
|
|
if (cxt->netorder) \ |
986
|
|
|
|
|
|
x = (int) ntohl(x); \ |
987
|
|
|
|
|
|
} STMT_END |
988
|
|
|
|
|
|
#else |
989
|
|
|
|
|
|
#define RLEN(x) READ_I32(x) |
990
|
|
|
|
|
|
#endif |
991
|
|
|
|
|
|
|
992
|
|
|
|
|
|
#define READ(x,y) \ |
993
|
|
|
|
|
|
STMT_START { \ |
994
|
|
|
|
|
|
if (!cxt->fio) \ |
995
|
|
|
|
|
|
MBUF_READ(x, y); \ |
996
|
|
|
|
|
|
else if (PerlIO_read(cxt->fio, x, y) != y) \ |
997
|
|
|
|
|
|
return (SV *) 0; \ |
998
|
|
|
|
|
|
} STMT_END |
999
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
#define SAFEREAD(x,y,z) \ |
1001
|
|
|
|
|
|
STMT_START { \ |
1002
|
|
|
|
|
|
if (!cxt->fio) \ |
1003
|
|
|
|
|
|
MBUF_SAFEREAD(x,y,z); \ |
1004
|
|
|
|
|
|
else if (PerlIO_read(cxt->fio, x, y) != y) { \ |
1005
|
|
|
|
|
|
sv_free(z); \ |
1006
|
|
|
|
|
|
return (SV *) 0; \ |
1007
|
|
|
|
|
|
} \ |
1008
|
|
|
|
|
|
} STMT_END |
1009
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
#define SAFEPVREAD(x,y,z) \ |
1011
|
|
|
|
|
|
STMT_START { \ |
1012
|
|
|
|
|
|
if (!cxt->fio) \ |
1013
|
|
|
|
|
|
MBUF_SAFEPVREAD(x,y,z); \ |
1014
|
|
|
|
|
|
else if (PerlIO_read(cxt->fio, x, y) != y) { \ |
1015
|
|
|
|
|
|
Safefree(z); \ |
1016
|
|
|
|
|
|
return (SV *) 0; \ |
1017
|
|
|
|
|
|
} \ |
1018
|
|
|
|
|
|
} STMT_END |
1019
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
/* |
1021
|
|
|
|
|
|
* This macro is used at retrieve time, to remember where object 'y', bearing a |
1022
|
|
|
|
|
|
* given tag 'tagnum', has been retrieved. Next time we see an SX_OBJECT marker, |
1023
|
|
|
|
|
|
* we'll therefore know where it has been retrieved and will be able to |
1024
|
|
|
|
|
|
* share the same reference, as in the original stored memory image. |
1025
|
|
|
|
|
|
* |
1026
|
|
|
|
|
|
* We also need to bless objects ASAP for hooks (which may compute "ref $x" |
1027
|
|
|
|
|
|
* on the objects given to STORABLE_thaw and expect that to be defined), and |
1028
|
|
|
|
|
|
* also for overloaded objects (for which we might not find the stash if the |
1029
|
|
|
|
|
|
* object is not blessed yet--this might occur for overloaded objects that |
1030
|
|
|
|
|
|
* refer to themselves indirectly: if we blessed upon return from a sub |
1031
|
|
|
|
|
|
* retrieve(), the SX_OBJECT marker we'd found could not have overloading |
1032
|
|
|
|
|
|
* restored on it because the underlying object would not be blessed yet!). |
1033
|
|
|
|
|
|
* |
1034
|
|
|
|
|
|
* To achieve that, the class name of the last retrieved object is passed down |
1035
|
|
|
|
|
|
* recursively, and the first SEEN() call for which the class name is not NULL |
1036
|
|
|
|
|
|
* will bless the object. |
1037
|
|
|
|
|
|
* |
1038
|
|
|
|
|
|
* i should be true iff sv is immortal (ie PL_sv_yes, PL_sv_no or PL_sv_undef) |
1039
|
|
|
|
|
|
*/ |
1040
|
|
|
|
|
|
#define SEEN(y,stash,i) \ |
1041
|
|
|
|
|
|
STMT_START { \ |
1042
|
|
|
|
|
|
if (!y) \ |
1043
|
|
|
|
|
|
return (SV *) 0; \ |
1044
|
|
|
|
|
|
if (av_store(cxt->aseen, cxt->tagnum++, i ? (SV*)(y) : SvREFCNT_inc(y)) == 0) \ |
1045
|
|
|
|
|
|
return (SV *) 0; \ |
1046
|
|
|
|
|
|
TRACEME(("aseen(#%d) = 0x%"UVxf" (refcnt=%d)", cxt->tagnum-1, \ |
1047
|
|
|
|
|
|
PTR2UV(y), SvREFCNT(y)-1)); \ |
1048
|
|
|
|
|
|
if (stash) \ |
1049
|
|
|
|
|
|
BLESS((SV *) (y), (HV *)(stash)); \ |
1050
|
|
|
|
|
|
} STMT_END |
1051
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
/* |
1053
|
|
|
|
|
|
* Bless 's' in 'p', via a temporary reference, required by sv_bless(). |
1054
|
|
|
|
|
|
* "A" magic is added before the sv_bless for overloaded classes, this avoids |
1055
|
|
|
|
|
|
* an expensive call to S_reset_amagic in sv_bless. |
1056
|
|
|
|
|
|
*/ |
1057
|
|
|
|
|
|
#define BLESS(s,stash) \ |
1058
|
|
|
|
|
|
STMT_START { \ |
1059
|
|
|
|
|
|
SV *ref; \ |
1060
|
|
|
|
|
|
TRACEME(("blessing 0x%"UVxf" in %s", PTR2UV(s), (HvNAME_get(stash)))); \ |
1061
|
|
|
|
|
|
ref = newRV_noinc(s); \ |
1062
|
|
|
|
|
|
if (cxt->in_retrieve_overloaded && Gv_AMG(stash)) \ |
1063
|
|
|
|
|
|
{ \ |
1064
|
|
|
|
|
|
cxt->in_retrieve_overloaded = 0; \ |
1065
|
|
|
|
|
|
SvAMAGIC_on(ref); \ |
1066
|
|
|
|
|
|
} \ |
1067
|
|
|
|
|
|
(void) sv_bless(ref, stash); \ |
1068
|
|
|
|
|
|
SvRV_set(ref, NULL); \ |
1069
|
|
|
|
|
|
SvREFCNT_dec(ref); \ |
1070
|
|
|
|
|
|
} STMT_END |
1071
|
|
|
|
|
|
/* |
1072
|
|
|
|
|
|
* sort (used in store_hash) - conditionally use qsort when |
1073
|
|
|
|
|
|
* sortsv is not available ( <= 5.6.1 ). |
1074
|
|
|
|
|
|
*/ |
1075
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
#if (PATCHLEVEL <= 6) |
1077
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
1079
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
#define STORE_HASH_SORT \ |
1081
|
|
|
|
|
|
ENTER; { \ |
1082
|
|
|
|
|
|
PerlInterpreter *orig_perl = PERL_GET_CONTEXT; \ |
1083
|
|
|
|
|
|
SAVESPTR(orig_perl); \ |
1084
|
|
|
|
|
|
PERL_SET_CONTEXT(aTHX); \ |
1085
|
|
|
|
|
|
qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); \ |
1086
|
|
|
|
|
|
} LEAVE; |
1087
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
#else /* ! USE_ITHREADS */ |
1089
|
|
|
|
|
|
|
1090
|
|
|
|
|
|
#define STORE_HASH_SORT \ |
1091
|
|
|
|
|
|
qsort((char *) AvARRAY(av), len, sizeof(SV *), sortcmp); |
1092
|
|
|
|
|
|
|
1093
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
1094
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
#else /* PATCHLEVEL > 6 */ |
1096
|
|
|
|
|
|
|
1097
|
|
|
|
|
|
#define STORE_HASH_SORT \ |
1098
|
|
|
|
|
|
sortsv(AvARRAY(av), len, Perl_sv_cmp); |
1099
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
#endif /* PATCHLEVEL <= 6 */ |
1101
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
static int store(pTHX_ stcxt_t *cxt, SV *sv); |
1103
|
|
|
|
|
|
static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname); |
1104
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
#define UNSEE() \ |
1106
|
|
|
|
|
|
STMT_START { \ |
1107
|
|
|
|
|
|
av_pop(cxt->aseen); \ |
1108
|
|
|
|
|
|
cxt->tagnum--; \ |
1109
|
|
|
|
|
|
} STMT_END |
1110
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
/* |
1112
|
|
|
|
|
|
* Dynamic dispatching table for SV store. |
1113
|
|
|
|
|
|
*/ |
1114
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
static int store_ref(pTHX_ stcxt_t *cxt, SV *sv); |
1116
|
|
|
|
|
|
static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv); |
1117
|
|
|
|
|
|
static int store_array(pTHX_ stcxt_t *cxt, AV *av); |
1118
|
|
|
|
|
|
static int store_hash(pTHX_ stcxt_t *cxt, HV *hv); |
1119
|
|
|
|
|
|
static int store_tied(pTHX_ stcxt_t *cxt, SV *sv); |
1120
|
|
|
|
|
|
static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv); |
1121
|
|
|
|
|
|
static int store_code(pTHX_ stcxt_t *cxt, CV *cv); |
1122
|
|
|
|
|
|
static int store_other(pTHX_ stcxt_t *cxt, SV *sv); |
1123
|
|
|
|
|
|
static int store_blessed(pTHX_ stcxt_t *cxt, SV *sv, int type, HV *pkg); |
1124
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
typedef int (*sv_store_t)(pTHX_ stcxt_t *cxt, SV *sv); |
1126
|
|
|
|
|
|
|
1127
|
|
|
|
|
|
static const sv_store_t sv_store[] = { |
1128
|
|
|
|
|
|
(sv_store_t)store_ref, /* svis_REF */ |
1129
|
|
|
|
|
|
(sv_store_t)store_scalar, /* svis_SCALAR */ |
1130
|
|
|
|
|
|
(sv_store_t)store_array, /* svis_ARRAY */ |
1131
|
|
|
|
|
|
(sv_store_t)store_hash, /* svis_HASH */ |
1132
|
|
|
|
|
|
(sv_store_t)store_tied, /* svis_TIED */ |
1133
|
|
|
|
|
|
(sv_store_t)store_tied_item, /* svis_TIED_ITEM */ |
1134
|
|
|
|
|
|
(sv_store_t)store_code, /* svis_CODE */ |
1135
|
|
|
|
|
|
(sv_store_t)store_other, /* svis_OTHER */ |
1136
|
|
|
|
|
|
}; |
1137
|
|
|
|
|
|
|
1138
|
|
|
|
|
|
#define SV_STORE(x) (*sv_store[x]) |
1139
|
|
|
|
|
|
|
1140
|
|
|
|
|
|
/* |
1141
|
|
|
|
|
|
* Dynamic dispatching tables for SV retrieval. |
1142
|
|
|
|
|
|
*/ |
1143
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname); |
1145
|
|
|
|
|
|
static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname); |
1146
|
|
|
|
|
|
static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); |
1147
|
|
|
|
|
|
static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); |
1148
|
|
|
|
|
|
static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname); |
1149
|
|
|
|
|
|
static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname); |
1150
|
|
|
|
|
|
static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname); |
1151
|
|
|
|
|
|
static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname); |
1152
|
|
|
|
|
|
static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname); |
1153
|
|
|
|
|
|
static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname); |
1154
|
|
|
|
|
|
static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname); |
1155
|
|
|
|
|
|
static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname); |
1156
|
|
|
|
|
|
static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname); |
1157
|
|
|
|
|
|
static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname); |
1158
|
|
|
|
|
|
static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname); |
1159
|
|
|
|
|
|
static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname); |
1160
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
typedef SV* (*sv_retrieve_t)(pTHX_ stcxt_t *cxt, const char *name); |
1162
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
static const sv_retrieve_t sv_old_retrieve[] = { |
1164
|
|
|
|
|
|
0, /* SX_OBJECT -- entry unused dynamically */ |
1165
|
|
|
|
|
|
(sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ |
1166
|
|
|
|
|
|
(sv_retrieve_t)old_retrieve_array, /* SX_ARRAY -- for pre-0.6 binaries */ |
1167
|
|
|
|
|
|
(sv_retrieve_t)old_retrieve_hash, /* SX_HASH -- for pre-0.6 binaries */ |
1168
|
|
|
|
|
|
(sv_retrieve_t)retrieve_ref, /* SX_REF */ |
1169
|
|
|
|
|
|
(sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ |
1170
|
|
|
|
|
|
(sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ |
1171
|
|
|
|
|
|
(sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ |
1172
|
|
|
|
|
|
(sv_retrieve_t)retrieve_byte, /* SX_BYTE */ |
1173
|
|
|
|
|
|
(sv_retrieve_t)retrieve_netint, /* SX_NETINT */ |
1174
|
|
|
|
|
|
(sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ |
1175
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */ |
1176
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */ |
1177
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */ |
1178
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_SV_UNDEF not supported */ |
1179
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_SV_YES not supported */ |
1180
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_SV_NO not supported */ |
1181
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_BLESS not supported */ |
1182
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_IX_BLESS not supported */ |
1183
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_HOOK not supported */ |
1184
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_OVERLOADED not supported */ |
1185
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_TIED_KEY not supported */ |
1186
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_TIED_IDX not supported */ |
1187
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_UTF8STR not supported */ |
1188
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_LUTF8STR not supported */ |
1189
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_FLAG_HASH not supported */ |
1190
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_CODE not supported */ |
1191
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_WEAKREF not supported */ |
1192
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_WEAKOVERLOAD not supported */ |
1193
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_VSTRING not supported */ |
1194
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_LVSTRING not supported */ |
1195
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_SVUNDEF_ELEM not supported */ |
1196
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_ERROR */ |
1197
|
|
|
|
|
|
}; |
1198
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname); |
1200
|
|
|
|
|
|
static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname); |
1201
|
|
|
|
|
|
static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname); |
1202
|
|
|
|
|
|
static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname); |
1203
|
|
|
|
|
|
static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname); |
1204
|
|
|
|
|
|
static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname); |
1205
|
|
|
|
|
|
static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname); |
1206
|
|
|
|
|
|
static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname); |
1207
|
|
|
|
|
|
static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname); |
1208
|
|
|
|
|
|
static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname); |
1209
|
|
|
|
|
|
static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname); |
1210
|
|
|
|
|
|
static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname); |
1211
|
|
|
|
|
|
static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname); |
1212
|
|
|
|
|
|
static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname); |
1213
|
|
|
|
|
|
static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname); |
1214
|
|
|
|
|
|
static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname); |
1215
|
|
|
|
|
|
static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname); |
1216
|
|
|
|
|
|
static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname); |
1217
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
static const sv_retrieve_t sv_retrieve[] = { |
1219
|
|
|
|
|
|
0, /* SX_OBJECT -- entry unused dynamically */ |
1220
|
|
|
|
|
|
(sv_retrieve_t)retrieve_lscalar, /* SX_LSCALAR */ |
1221
|
|
|
|
|
|
(sv_retrieve_t)retrieve_array, /* SX_ARRAY */ |
1222
|
|
|
|
|
|
(sv_retrieve_t)retrieve_hash, /* SX_HASH */ |
1223
|
|
|
|
|
|
(sv_retrieve_t)retrieve_ref, /* SX_REF */ |
1224
|
|
|
|
|
|
(sv_retrieve_t)retrieve_undef, /* SX_UNDEF */ |
1225
|
|
|
|
|
|
(sv_retrieve_t)retrieve_integer, /* SX_INTEGER */ |
1226
|
|
|
|
|
|
(sv_retrieve_t)retrieve_double, /* SX_DOUBLE */ |
1227
|
|
|
|
|
|
(sv_retrieve_t)retrieve_byte, /* SX_BYTE */ |
1228
|
|
|
|
|
|
(sv_retrieve_t)retrieve_netint, /* SX_NETINT */ |
1229
|
|
|
|
|
|
(sv_retrieve_t)retrieve_scalar, /* SX_SCALAR */ |
1230
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_array, /* SX_ARRAY */ |
1231
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_hash, /* SX_HASH */ |
1232
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_scalar, /* SX_SCALAR */ |
1233
|
|
|
|
|
|
(sv_retrieve_t)retrieve_sv_undef, /* SX_SV_UNDEF */ |
1234
|
|
|
|
|
|
(sv_retrieve_t)retrieve_sv_yes, /* SX_SV_YES */ |
1235
|
|
|
|
|
|
(sv_retrieve_t)retrieve_sv_no, /* SX_SV_NO */ |
1236
|
|
|
|
|
|
(sv_retrieve_t)retrieve_blessed, /* SX_BLESS */ |
1237
|
|
|
|
|
|
(sv_retrieve_t)retrieve_idx_blessed, /* SX_IX_BLESS */ |
1238
|
|
|
|
|
|
(sv_retrieve_t)retrieve_hook, /* SX_HOOK */ |
1239
|
|
|
|
|
|
(sv_retrieve_t)retrieve_overloaded, /* SX_OVERLOAD */ |
1240
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_key, /* SX_TIED_KEY */ |
1241
|
|
|
|
|
|
(sv_retrieve_t)retrieve_tied_idx, /* SX_TIED_IDX */ |
1242
|
|
|
|
|
|
(sv_retrieve_t)retrieve_utf8str, /* SX_UTF8STR */ |
1243
|
|
|
|
|
|
(sv_retrieve_t)retrieve_lutf8str, /* SX_LUTF8STR */ |
1244
|
|
|
|
|
|
(sv_retrieve_t)retrieve_flag_hash, /* SX_HASH */ |
1245
|
|
|
|
|
|
(sv_retrieve_t)retrieve_code, /* SX_CODE */ |
1246
|
|
|
|
|
|
(sv_retrieve_t)retrieve_weakref, /* SX_WEAKREF */ |
1247
|
|
|
|
|
|
(sv_retrieve_t)retrieve_weakoverloaded, /* SX_WEAKOVERLOAD */ |
1248
|
|
|
|
|
|
(sv_retrieve_t)retrieve_vstring, /* SX_VSTRING */ |
1249
|
|
|
|
|
|
(sv_retrieve_t)retrieve_lvstring, /* SX_LVSTRING */ |
1250
|
|
|
|
|
|
(sv_retrieve_t)retrieve_svundef_elem, /* SX_SVUNDEF_ELEM */ |
1251
|
|
|
|
|
|
(sv_retrieve_t)retrieve_other, /* SX_ERROR */ |
1252
|
|
|
|
|
|
}; |
1253
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
#define RETRIEVE(c,x) (*(c)->retrieve_vtbl[(x) >= SX_ERROR ? SX_ERROR : (x)]) |
1255
|
|
|
|
|
|
|
1256
|
|
|
|
|
|
static SV *mbuf2sv(pTHX); |
1257
|
|
|
|
|
|
|
1258
|
|
|
|
|
|
/*** |
1259
|
|
|
|
|
|
*** Context management. |
1260
|
|
|
|
|
|
***/ |
1261
|
|
|
|
|
|
|
1262
|
|
|
|
|
|
/* |
1263
|
|
|
|
|
|
* init_perinterp |
1264
|
|
|
|
|
|
* |
1265
|
|
|
|
|
|
* Called once per "thread" (interpreter) to initialize some global context. |
1266
|
|
|
|
|
|
*/ |
1267
|
4550
|
|
|
|
|
static void init_perinterp(pTHX) |
1268
|
|
|
|
|
|
{ |
1269
|
9100
|
|
|
|
|
INIT_STCXT; |
1270
|
|
|
|
|
|
|
1271
|
4550
|
|
|
|
|
cxt->netorder = 0; /* true if network order used */ |
1272
|
4550
|
|
|
|
|
cxt->forgive_me = -1; /* whether to be forgiving... */ |
1273
|
4550
|
|
|
|
|
cxt->accept_future_minor = -1; /* would otherwise occur too late */ |
1274
|
4550
|
|
|
|
|
} |
1275
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
/* |
1277
|
|
|
|
|
|
* reset_context |
1278
|
|
|
|
|
|
* |
1279
|
|
|
|
|
|
* Called at the end of every context cleaning, to perform common reset |
1280
|
|
|
|
|
|
* operations. |
1281
|
|
|
|
|
|
*/ |
1282
|
|
|
|
|
|
static void reset_context(stcxt_t *cxt) |
1283
|
|
|
|
|
|
{ |
1284
|
2410324
|
|
|
|
|
cxt->entry = 0; |
1285
|
2410324
|
|
|
|
|
cxt->s_dirty = 0; |
1286
|
2410324
|
|
|
|
|
cxt->optype &= ~(ST_STORE|ST_RETRIEVE); /* Leave ST_CLONE alone */ |
1287
|
|
|
|
|
|
} |
1288
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
/* |
1290
|
|
|
|
|
|
* init_store_context |
1291
|
|
|
|
|
|
* |
1292
|
|
|
|
|
|
* Initialize a new store context for real recursion. |
1293
|
|
|
|
|
|
*/ |
1294
|
|
|
|
|
|
static void init_store_context( |
1295
|
|
|
|
|
|
pTHX_ |
1296
|
|
|
|
|
|
stcxt_t *cxt, |
1297
|
|
|
|
|
|
PerlIO *f, |
1298
|
|
|
|
|
|
int optype, |
1299
|
|
|
|
|
|
int network_order) |
1300
|
|
|
|
|
|
{ |
1301
|
|
|
|
|
|
TRACEME(("init_store_context")); |
1302
|
|
|
|
|
|
|
1303
|
365454
|
|
|
|
|
cxt->netorder = network_order; |
1304
|
365454
|
|
|
|
|
cxt->forgive_me = -1; /* Fetched from perl if needed */ |
1305
|
365454
|
|
|
|
|
cxt->deparse = -1; /* Idem */ |
1306
|
365454
|
|
|
|
|
cxt->eval = NULL; /* Idem */ |
1307
|
365454
|
|
|
|
|
cxt->canonical = -1; /* Idem */ |
1308
|
365454
|
|
|
|
|
cxt->tagnum = -1; /* Reset tag numbers */ |
1309
|
365454
|
|
|
|
|
cxt->classnum = -1; /* Reset class numbers */ |
1310
|
365454
|
|
|
|
|
cxt->fio = f; /* Where I/O are performed */ |
1311
|
365454
|
|
|
|
|
cxt->optype = optype; /* A store, or a deep clone */ |
1312
|
365454
|
|
|
|
|
cxt->entry = 1; /* No recursion yet */ |
1313
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
/* |
1315
|
|
|
|
|
|
* The 'hseen' table is used to keep track of each SV stored and their |
1316
|
|
|
|
|
|
* associated tag numbers is special. It is "abused" because the |
1317
|
|
|
|
|
|
* values stored are not real SV, just integers cast to (SV *), |
1318
|
|
|
|
|
|
* which explains the freeing below. |
1319
|
|
|
|
|
|
* |
1320
|
|
|
|
|
|
* It is also one possible bottleneck to achieve good storing speed, |
1321
|
|
|
|
|
|
* so the "shared keys" optimization is turned off (unlikely to be |
1322
|
|
|
|
|
|
* of any use here), and the hash table is "pre-extended". Together, |
1323
|
|
|
|
|
|
* those optimizations increase the throughput by 12%. |
1324
|
|
|
|
|
|
*/ |
1325
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
1327
|
365454
|
|
|
|
|
cxt->pseen = ptr_table_new(); |
1328
|
365454
|
|
|
|
|
cxt->hseen = 0; |
1329
|
|
|
|
|
|
#else |
1330
|
|
|
|
|
|
cxt->hseen = newHV(); /* Table where seen objects are stored */ |
1331
|
|
|
|
|
|
HvSHAREKEYS_off(cxt->hseen); |
1332
|
|
|
|
|
|
#endif |
1333
|
|
|
|
|
|
/* |
1334
|
|
|
|
|
|
* The following does not work well with perl5.004_04, and causes |
1335
|
|
|
|
|
|
* a core dump later on, in a completely unrelated spot, which |
1336
|
|
|
|
|
|
* makes me think there is a memory corruption going on. |
1337
|
|
|
|
|
|
* |
1338
|
|
|
|
|
|
* Calling hv_ksplit(hseen, HBUCKETS) instead of manually hacking |
1339
|
|
|
|
|
|
* it below does not make any difference. It seems to work fine |
1340
|
|
|
|
|
|
* with perl5.004_68 but given the probable nature of the bug, |
1341
|
|
|
|
|
|
* that does not prove anything. |
1342
|
|
|
|
|
|
* |
1343
|
|
|
|
|
|
* It's a shame because increasing the amount of buckets raises |
1344
|
|
|
|
|
|
* store() throughput by 5%, but until I figure this out, I can't |
1345
|
|
|
|
|
|
* allow for this to go into production. |
1346
|
|
|
|
|
|
* |
1347
|
|
|
|
|
|
* It is reported fixed in 5.005, hence the #if. |
1348
|
|
|
|
|
|
*/ |
1349
|
|
|
|
|
|
#if PERL_VERSION >= 5 |
1350
|
|
|
|
|
|
#define HBUCKETS 4096 /* Buckets for %hseen */ |
1351
|
|
|
|
|
|
#ifndef USE_PTR_TABLE |
1352
|
|
|
|
|
|
HvMAX(cxt->hseen) = HBUCKETS - 1; /* keys %hseen = $HBUCKETS; */ |
1353
|
|
|
|
|
|
#endif |
1354
|
|
|
|
|
|
#endif |
1355
|
|
|
|
|
|
|
1356
|
|
|
|
|
|
/* |
1357
|
|
|
|
|
|
* The 'hclass' hash uses the same settings as 'hseen' above, but it is |
1358
|
|
|
|
|
|
* used to assign sequential tags (numbers) to class names for blessed |
1359
|
|
|
|
|
|
* objects. |
1360
|
|
|
|
|
|
* |
1361
|
|
|
|
|
|
* We turn the shared key optimization on. |
1362
|
|
|
|
|
|
*/ |
1363
|
|
|
|
|
|
|
1364
|
365454
|
|
|
|
|
cxt->hclass = newHV(); /* Where seen classnames are stored */ |
1365
|
|
|
|
|
|
|
1366
|
|
|
|
|
|
#if PERL_VERSION >= 5 |
1367
|
365454
|
|
|
|
|
HvMAX(cxt->hclass) = HBUCKETS - 1; /* keys %hclass = $HBUCKETS; */ |
1368
|
|
|
|
|
|
#endif |
1369
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
/* |
1371
|
|
|
|
|
|
* The 'hook' hash table is used to keep track of the references on |
1372
|
|
|
|
|
|
* the STORABLE_freeze hook routines, when found in some class name. |
1373
|
|
|
|
|
|
* |
1374
|
|
|
|
|
|
* It is assumed that the inheritance tree will not be changed during |
1375
|
|
|
|
|
|
* storing, and that no new method will be dynamically created by the |
1376
|
|
|
|
|
|
* hooks. |
1377
|
|
|
|
|
|
*/ |
1378
|
|
|
|
|
|
|
1379
|
365454
|
|
|
|
|
cxt->hook = newHV(); /* Table where hooks are cached */ |
1380
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
/* |
1382
|
|
|
|
|
|
* The 'hook_seen' array keeps track of all the SVs returned by |
1383
|
|
|
|
|
|
* STORABLE_freeze hooks for us to serialize, so that they are not |
1384
|
|
|
|
|
|
* reclaimed until the end of the serialization process. Each SV is |
1385
|
|
|
|
|
|
* only stored once, the first time it is seen. |
1386
|
|
|
|
|
|
*/ |
1387
|
|
|
|
|
|
|
1388
|
365454
|
|
|
|
|
cxt->hook_seen = newAV(); /* Lists SVs returned by STORABLE_freeze */ |
1389
|
|
|
|
|
|
} |
1390
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
/* |
1392
|
|
|
|
|
|
* clean_store_context |
1393
|
|
|
|
|
|
* |
1394
|
|
|
|
|
|
* Clean store context by |
1395
|
|
|
|
|
|
*/ |
1396
|
365454
|
|
|
|
|
static void clean_store_context(pTHX_ stcxt_t *cxt) |
1397
|
|
|
|
|
|
{ |
1398
|
|
|
|
|
|
HE *he; |
1399
|
|
|
|
|
|
|
1400
|
|
|
|
|
|
TRACEME(("clean_store_context")); |
1401
|
|
|
|
|
|
|
1402
|
|
|
|
|
|
ASSERT(cxt->optype & ST_STORE, ("was performing a store()")); |
1403
|
|
|
|
|
|
|
1404
|
|
|
|
|
|
/* |
1405
|
|
|
|
|
|
* Insert real values into hashes where we stored faked pointers. |
1406
|
|
|
|
|
|
*/ |
1407
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
#ifndef USE_PTR_TABLE |
1409
|
|
|
|
|
|
if (cxt->hseen) { |
1410
|
|
|
|
|
|
hv_iterinit(cxt->hseen); |
1411
|
|
|
|
|
|
while ((he = hv_iternext(cxt->hseen))) /* Extra () for -Wall, grr.. */ |
1412
|
|
|
|
|
|
HeVAL(he) = &PL_sv_undef; |
1413
|
|
|
|
|
|
} |
1414
|
|
|
|
|
|
#endif |
1415
|
|
|
|
|
|
|
1416
|
365454
|
|
|
|
|
if (cxt->hclass) { |
1417
|
365454
|
|
|
|
|
hv_iterinit(cxt->hclass); |
1418
|
731228
|
|
|
|
|
while ((he = hv_iternext(cxt->hclass))) /* Extra () for -Wall, grr.. */ |
1419
|
320
|
|
|
|
|
HeVAL(he) = &PL_sv_undef; |
1420
|
|
|
|
|
|
} |
1421
|
|
|
|
|
|
|
1422
|
|
|
|
|
|
/* |
1423
|
|
|
|
|
|
* And now dispose of them... |
1424
|
|
|
|
|
|
* |
1425
|
|
|
|
|
|
* The surrounding if() protection has been added because there might be |
1426
|
|
|
|
|
|
* some cases where this routine is called more than once, during |
1427
|
|
|
|
|
|
* exceptional events. This was reported by Marc Lehmann when Storable |
1428
|
|
|
|
|
|
* is executed from mod_perl, and the fix was suggested by him. |
1429
|
|
|
|
|
|
* -- RAM, 20/12/2000 |
1430
|
|
|
|
|
|
*/ |
1431
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
1433
|
365454
|
|
|
|
|
if (cxt->pseen) { |
1434
|
365454
|
|
|
|
|
struct ptr_tbl *pseen = cxt->pseen; |
1435
|
365454
|
|
|
|
|
cxt->pseen = 0; |
1436
|
365454
|
|
|
|
|
ptr_table_free(pseen); |
1437
|
|
|
|
|
|
} |
1438
|
|
|
|
|
|
assert(!cxt->hseen); |
1439
|
|
|
|
|
|
#else |
1440
|
|
|
|
|
|
if (cxt->hseen) { |
1441
|
|
|
|
|
|
HV *hseen = cxt->hseen; |
1442
|
|
|
|
|
|
cxt->hseen = 0; |
1443
|
|
|
|
|
|
hv_undef(hseen); |
1444
|
|
|
|
|
|
sv_free((SV *) hseen); |
1445
|
|
|
|
|
|
} |
1446
|
|
|
|
|
|
#endif |
1447
|
|
|
|
|
|
|
1448
|
365454
|
|
|
|
|
if (cxt->hclass) { |
1449
|
365454
|
|
|
|
|
HV *hclass = cxt->hclass; |
1450
|
365454
|
|
|
|
|
cxt->hclass = 0; |
1451
|
365454
|
|
|
|
|
hv_undef(hclass); |
1452
|
365454
|
|
|
|
|
sv_free((SV *) hclass); |
1453
|
|
|
|
|
|
} |
1454
|
|
|
|
|
|
|
1455
|
365454
|
|
|
|
|
if (cxt->hook) { |
1456
|
365454
|
|
|
|
|
HV *hook = cxt->hook; |
1457
|
365454
|
|
|
|
|
cxt->hook = 0; |
1458
|
365454
|
|
|
|
|
hv_undef(hook); |
1459
|
365454
|
|
|
|
|
sv_free((SV *) hook); |
1460
|
|
|
|
|
|
} |
1461
|
|
|
|
|
|
|
1462
|
365454
|
|
|
|
|
if (cxt->hook_seen) { |
1463
|
365454
|
|
|
|
|
AV *hook_seen = cxt->hook_seen; |
1464
|
365454
|
|
|
|
|
cxt->hook_seen = 0; |
1465
|
365454
|
|
|
|
|
av_undef(hook_seen); |
1466
|
365454
|
|
|
|
|
sv_free((SV *) hook_seen); |
1467
|
|
|
|
|
|
} |
1468
|
|
|
|
|
|
|
1469
|
365454
|
|
|
|
|
cxt->forgive_me = -1; /* Fetched from perl if needed */ |
1470
|
365454
|
|
|
|
|
cxt->deparse = -1; /* Idem */ |
1471
|
365454
|
|
|
|
|
if (cxt->eval) { |
1472
|
0
|
|
|
|
|
SvREFCNT_dec(cxt->eval); |
1473
|
|
|
|
|
|
} |
1474
|
365454
|
|
|
|
|
cxt->eval = NULL; /* Idem */ |
1475
|
365454
|
|
|
|
|
cxt->canonical = -1; /* Idem */ |
1476
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
reset_context(cxt); |
1478
|
365454
|
|
|
|
|
} |
1479
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
/* |
1481
|
|
|
|
|
|
* init_retrieve_context |
1482
|
|
|
|
|
|
* |
1483
|
|
|
|
|
|
* Initialize a new retrieve context for real recursion. |
1484
|
|
|
|
|
|
*/ |
1485
|
|
|
|
|
|
static void init_retrieve_context(pTHX_ stcxt_t *cxt, int optype, int is_tainted) |
1486
|
|
|
|
|
|
{ |
1487
|
|
|
|
|
|
TRACEME(("init_retrieve_context")); |
1488
|
|
|
|
|
|
|
1489
|
|
|
|
|
|
/* |
1490
|
|
|
|
|
|
* The hook hash table is used to keep track of the references on |
1491
|
|
|
|
|
|
* the STORABLE_thaw hook routines, when found in some class name. |
1492
|
|
|
|
|
|
* |
1493
|
|
|
|
|
|
* It is assumed that the inheritance tree will not be changed during |
1494
|
|
|
|
|
|
* storing, and that no new method will be dynamically created by the |
1495
|
|
|
|
|
|
* hooks. |
1496
|
|
|
|
|
|
*/ |
1497
|
|
|
|
|
|
|
1498
|
2044722
|
|
|
|
|
cxt->hook = newHV(); /* Caches STORABLE_thaw */ |
1499
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
1501
|
2044722
|
|
|
|
|
cxt->pseen = 0; |
1502
|
|
|
|
|
|
#endif |
1503
|
|
|
|
|
|
|
1504
|
|
|
|
|
|
/* |
1505
|
|
|
|
|
|
* If retrieving an old binary version, the cxt->retrieve_vtbl variable |
1506
|
|
|
|
|
|
* was set to sv_old_retrieve. We'll need a hash table to keep track of |
1507
|
|
|
|
|
|
* the correspondence between the tags and the tag number used by the |
1508
|
|
|
|
|
|
* new retrieve routines. |
1509
|
|
|
|
|
|
*/ |
1510
|
|
|
|
|
|
|
1511
|
4089444
|
|
|
|
|
cxt->hseen = (((void*)cxt->retrieve_vtbl == (void*)sv_old_retrieve) |
1512
|
2044722
|
|
|
|
|
? newHV() : 0); |
1513
|
|
|
|
|
|
|
1514
|
2044722
|
|
|
|
|
cxt->aseen = newAV(); /* Where retrieved objects are kept */ |
1515
|
2044722
|
|
|
|
|
cxt->where_is_undef = -1; /* Special case for PL_sv_undef */ |
1516
|
2044722
|
|
|
|
|
cxt->aclass = newAV(); /* Where seen classnames are kept */ |
1517
|
2044722
|
|
|
|
|
cxt->tagnum = 0; /* Have to count objects... */ |
1518
|
2044722
|
|
|
|
|
cxt->classnum = 0; /* ...and class names as well */ |
1519
|
2044722
|
|
|
|
|
cxt->optype = optype; |
1520
|
2044722
|
|
|
|
|
cxt->s_tainted = is_tainted; |
1521
|
2044722
|
|
|
|
|
cxt->entry = 1; /* No recursion yet */ |
1522
|
|
|
|
|
|
#ifndef HAS_RESTRICTED_HASHES |
1523
|
|
|
|
|
|
cxt->derestrict = -1; /* Fetched from perl if needed */ |
1524
|
|
|
|
|
|
#endif |
1525
|
|
|
|
|
|
#ifndef HAS_UTF8_ALL |
1526
|
|
|
|
|
|
cxt->use_bytes = -1; /* Fetched from perl if needed */ |
1527
|
|
|
|
|
|
#endif |
1528
|
2044722
|
|
|
|
|
cxt->accept_future_minor = -1; /* Fetched from perl if needed */ |
1529
|
2044722
|
|
|
|
|
cxt->in_retrieve_overloaded = 0; |
1530
|
|
|
|
|
|
} |
1531
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
/* |
1533
|
|
|
|
|
|
* clean_retrieve_context |
1534
|
|
|
|
|
|
* |
1535
|
|
|
|
|
|
* Clean retrieve context by |
1536
|
|
|
|
|
|
*/ |
1537
|
2044722
|
|
|
|
|
static void clean_retrieve_context(pTHX_ stcxt_t *cxt) |
1538
|
|
|
|
|
|
{ |
1539
|
|
|
|
|
|
TRACEME(("clean_retrieve_context")); |
1540
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
ASSERT(cxt->optype & ST_RETRIEVE, ("was performing a retrieve()")); |
1542
|
|
|
|
|
|
|
1543
|
2044722
|
|
|
|
|
if (cxt->aseen) { |
1544
|
2044722
|
|
|
|
|
AV *aseen = cxt->aseen; |
1545
|
2044722
|
|
|
|
|
cxt->aseen = 0; |
1546
|
2044722
|
|
|
|
|
av_undef(aseen); |
1547
|
2044722
|
|
|
|
|
sv_free((SV *) aseen); |
1548
|
|
|
|
|
|
} |
1549
|
2044722
|
|
|
|
|
cxt->where_is_undef = -1; |
1550
|
|
|
|
|
|
|
1551
|
2044722
|
|
|
|
|
if (cxt->aclass) { |
1552
|
2044722
|
|
|
|
|
AV *aclass = cxt->aclass; |
1553
|
2044722
|
|
|
|
|
cxt->aclass = 0; |
1554
|
2044722
|
|
|
|
|
av_undef(aclass); |
1555
|
2044722
|
|
|
|
|
sv_free((SV *) aclass); |
1556
|
|
|
|
|
|
} |
1557
|
|
|
|
|
|
|
1558
|
2044722
|
|
|
|
|
if (cxt->hook) { |
1559
|
2044722
|
|
|
|
|
HV *hook = cxt->hook; |
1560
|
2044722
|
|
|
|
|
cxt->hook = 0; |
1561
|
2044722
|
|
|
|
|
hv_undef(hook); |
1562
|
2044722
|
|
|
|
|
sv_free((SV *) hook); |
1563
|
|
|
|
|
|
} |
1564
|
|
|
|
|
|
|
1565
|
2044722
|
|
|
|
|
if (cxt->hseen) { |
1566
|
0
|
|
|
|
|
HV *hseen = cxt->hseen; |
1567
|
0
|
|
|
|
|
cxt->hseen = 0; |
1568
|
0
|
|
|
|
|
hv_undef(hseen); |
1569
|
0
|
|
|
|
|
sv_free((SV *) hseen); /* optional HV, for backward compat. */ |
1570
|
|
|
|
|
|
} |
1571
|
|
|
|
|
|
|
1572
|
|
|
|
|
|
#ifndef HAS_RESTRICTED_HASHES |
1573
|
|
|
|
|
|
cxt->derestrict = -1; /* Fetched from perl if needed */ |
1574
|
|
|
|
|
|
#endif |
1575
|
|
|
|
|
|
#ifndef HAS_UTF8_ALL |
1576
|
|
|
|
|
|
cxt->use_bytes = -1; /* Fetched from perl if needed */ |
1577
|
|
|
|
|
|
#endif |
1578
|
2044722
|
|
|
|
|
cxt->accept_future_minor = -1; /* Fetched from perl if needed */ |
1579
|
|
|
|
|
|
|
1580
|
2044722
|
|
|
|
|
cxt->in_retrieve_overloaded = 0; |
1581
|
|
|
|
|
|
reset_context(cxt); |
1582
|
2044722
|
|
|
|
|
} |
1583
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
/* |
1585
|
|
|
|
|
|
* clean_context |
1586
|
|
|
|
|
|
* |
1587
|
|
|
|
|
|
* A workaround for the CROAK bug: cleanup the last context. |
1588
|
|
|
|
|
|
*/ |
1589
|
192
|
|
|
|
|
static void clean_context(pTHX_ stcxt_t *cxt) |
1590
|
|
|
|
|
|
{ |
1591
|
|
|
|
|
|
TRACEME(("clean_context")); |
1592
|
|
|
|
|
|
|
1593
|
|
|
|
|
|
ASSERT(cxt->s_dirty, ("dirty context")); |
1594
|
|
|
|
|
|
|
1595
|
192
|
|
|
|
|
if (cxt->membuf_ro) |
1596
|
92
|
|
|
|
|
MBUF_RESTORE(); |
1597
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
ASSERT(!cxt->membuf_ro, ("mbase is not read-only")); |
1599
|
|
|
|
|
|
|
1600
|
192
|
|
|
|
|
if (cxt->optype & ST_RETRIEVE) |
1601
|
40
|
|
|
|
|
clean_retrieve_context(aTHX_ cxt); |
1602
|
152
|
|
|
|
|
else if (cxt->optype & ST_STORE) |
1603
|
4
|
|
|
|
|
clean_store_context(aTHX_ cxt); |
1604
|
|
|
|
|
|
else |
1605
|
|
|
|
|
|
reset_context(cxt); |
1606
|
|
|
|
|
|
|
1607
|
|
|
|
|
|
ASSERT(!cxt->s_dirty, ("context is clean")); |
1608
|
|
|
|
|
|
ASSERT(cxt->entry == 0, ("context is reset")); |
1609
|
192
|
|
|
|
|
} |
1610
|
|
|
|
|
|
|
1611
|
|
|
|
|
|
/* |
1612
|
|
|
|
|
|
* allocate_context |
1613
|
|
|
|
|
|
* |
1614
|
|
|
|
|
|
* Allocate a new context and push it on top of the parent one. |
1615
|
|
|
|
|
|
* This new context is made globally visible via SET_STCXT(). |
1616
|
|
|
|
|
|
*/ |
1617
|
158
|
|
|
|
|
static stcxt_t *allocate_context(pTHX_ stcxt_t *parent_cxt) |
1618
|
|
|
|
|
|
{ |
1619
|
|
|
|
|
|
stcxt_t *cxt; |
1620
|
|
|
|
|
|
|
1621
|
|
|
|
|
|
TRACEME(("allocate_context")); |
1622
|
|
|
|
|
|
|
1623
|
|
|
|
|
|
ASSERT(!parent_cxt->s_dirty, ("parent context clean")); |
1624
|
|
|
|
|
|
|
1625
|
316
|
|
|
|
|
NEW_STORABLE_CXT_OBJ(cxt); |
1626
|
158
|
|
|
|
|
cxt->prev = parent_cxt->my_sv; |
1627
|
158
|
|
|
|
|
SET_STCXT(cxt); |
1628
|
|
|
|
|
|
|
1629
|
|
|
|
|
|
ASSERT(!cxt->s_dirty, ("clean context")); |
1630
|
|
|
|
|
|
|
1631
|
158
|
|
|
|
|
return cxt; |
1632
|
|
|
|
|
|
} |
1633
|
|
|
|
|
|
|
1634
|
|
|
|
|
|
/* |
1635
|
|
|
|
|
|
* free_context |
1636
|
|
|
|
|
|
* |
1637
|
|
|
|
|
|
* Free current context, which cannot be the "root" one. |
1638
|
|
|
|
|
|
* Make the context underneath globally visible via SET_STCXT(). |
1639
|
|
|
|
|
|
*/ |
1640
|
0
|
|
|
|
|
static void free_context(pTHX_ stcxt_t *cxt) |
1641
|
|
|
|
|
|
{ |
1642
|
158
|
|
|
|
|
stcxt_t *prev = (stcxt_t *)(cxt->prev ? SvPVX(SvRV(cxt->prev)) : 0); |
1643
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
TRACEME(("free_context")); |
1645
|
|
|
|
|
|
|
1646
|
|
|
|
|
|
ASSERT(!cxt->s_dirty, ("clean context")); |
1647
|
|
|
|
|
|
ASSERT(prev, ("not freeing root context")); |
1648
|
|
|
|
|
|
|
1649
|
158
|
|
|
|
|
SvREFCNT_dec(cxt->my_sv); |
1650
|
158
|
|
|
|
|
SET_STCXT(prev); |
1651
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
ASSERT(cxt, ("context not void")); |
1653
|
0
|
|
|
|
|
} |
1654
|
|
|
|
|
|
|
1655
|
|
|
|
|
|
/*** |
1656
|
|
|
|
|
|
*** Predicates. |
1657
|
|
|
|
|
|
***/ |
1658
|
|
|
|
|
|
|
1659
|
|
|
|
|
|
/* |
1660
|
|
|
|
|
|
* is_storing |
1661
|
|
|
|
|
|
* |
1662
|
|
|
|
|
|
* Tells whether we're in the middle of a store operation. |
1663
|
|
|
|
|
|
*/ |
1664
|
|
|
|
|
|
static int is_storing(pTHX) |
1665
|
|
|
|
|
|
{ |
1666
|
|
|
|
|
|
dSTCXT; |
1667
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
return cxt->entry && (cxt->optype & ST_STORE); |
1669
|
|
|
|
|
|
} |
1670
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
/* |
1672
|
|
|
|
|
|
* is_retrieving |
1673
|
|
|
|
|
|
* |
1674
|
|
|
|
|
|
* Tells whether we're in the middle of a retrieve operation. |
1675
|
|
|
|
|
|
*/ |
1676
|
|
|
|
|
|
static int is_retrieving(pTHX) |
1677
|
|
|
|
|
|
{ |
1678
|
|
|
|
|
|
dSTCXT; |
1679
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
return cxt->entry && (cxt->optype & ST_RETRIEVE); |
1681
|
|
|
|
|
|
} |
1682
|
|
|
|
|
|
|
1683
|
|
|
|
|
|
/* |
1684
|
|
|
|
|
|
* last_op_in_netorder |
1685
|
|
|
|
|
|
* |
1686
|
|
|
|
|
|
* Returns whether last operation was made using network order. |
1687
|
|
|
|
|
|
* |
1688
|
|
|
|
|
|
* This is typically out-of-band information that might prove useful |
1689
|
|
|
|
|
|
* to people wishing to convert native to network order data when used. |
1690
|
|
|
|
|
|
*/ |
1691
|
|
|
|
|
|
static int last_op_in_netorder(pTHX) |
1692
|
|
|
|
|
|
{ |
1693
|
10
|
|
|
|
|
dSTCXT; |
1694
|
|
|
|
|
|
|
1695
|
10
|
|
|
|
|
return cxt->netorder; |
1696
|
|
|
|
|
|
} |
1697
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
/*** |
1699
|
|
|
|
|
|
*** Hook lookup and calling routines. |
1700
|
|
|
|
|
|
***/ |
1701
|
|
|
|
|
|
|
1702
|
|
|
|
|
|
/* |
1703
|
|
|
|
|
|
* pkg_fetchmeth |
1704
|
|
|
|
|
|
* |
1705
|
|
|
|
|
|
* A wrapper on gv_fetchmethod_autoload() which caches results. |
1706
|
|
|
|
|
|
* |
1707
|
|
|
|
|
|
* Returns the routine reference as an SV*, or null if neither the package |
1708
|
|
|
|
|
|
* nor its ancestors know about the method. |
1709
|
|
|
|
|
|
*/ |
1710
|
466
|
|
|
|
|
static SV *pkg_fetchmeth( |
1711
|
|
|
|
|
|
pTHX_ |
1712
|
|
|
|
|
|
HV *cache, |
1713
|
|
|
|
|
|
HV *pkg, |
1714
|
|
|
|
|
|
const char *method) |
1715
|
|
|
|
|
|
{ |
1716
|
|
|
|
|
|
GV *gv; |
1717
|
|
|
|
|
|
SV *sv; |
1718
|
466
|
|
|
|
|
const char *hvname = HvNAME_get(pkg); |
1719
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
/* |
1722
|
|
|
|
|
|
* The following code is the same as the one performed by UNIVERSAL::can |
1723
|
|
|
|
|
|
* in the Perl core. |
1724
|
|
|
|
|
|
*/ |
1725
|
|
|
|
|
|
|
1726
|
466
|
|
|
|
|
gv = gv_fetchmethod_autoload(pkg, method, FALSE); |
1727
|
466
|
|
|
|
|
if (gv && isGV(gv)) { |
1728
|
314
|
|
|
|
|
sv = newRV((SV*) GvCV(gv)); |
1729
|
|
|
|
|
|
TRACEME(("%s->%s: 0x%"UVxf, hvname, method, PTR2UV(sv))); |
1730
|
|
|
|
|
|
} else { |
1731
|
152
|
|
|
|
|
sv = newSVsv(&PL_sv_undef); |
1732
|
|
|
|
|
|
TRACEME(("%s->%s: not found", hvname, method)); |
1733
|
|
|
|
|
|
} |
1734
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
/* |
1736
|
|
|
|
|
|
* Cache the result, ignoring failure: if we can't store the value, |
1737
|
|
|
|
|
|
* it just won't be cached. |
1738
|
|
|
|
|
|
*/ |
1739
|
|
|
|
|
|
|
1740
|
466
|
|
|
|
|
(void) hv_store(cache, hvname, strlen(hvname), sv, 0); |
1741
|
|
|
|
|
|
|
1742
|
466
|
|
|
|
|
return SvOK(sv) ? sv : (SV *) 0; |
1743
|
|
|
|
|
|
} |
1744
|
|
|
|
|
|
|
1745
|
|
|
|
|
|
/* |
1746
|
|
|
|
|
|
* pkg_hide |
1747
|
|
|
|
|
|
* |
1748
|
|
|
|
|
|
* Force cached value to be undef: hook ignored even if present. |
1749
|
|
|
|
|
|
*/ |
1750
|
10
|
|
|
|
|
static void pkg_hide( |
1751
|
|
|
|
|
|
pTHX_ |
1752
|
|
|
|
|
|
HV *cache, |
1753
|
|
|
|
|
|
HV *pkg, |
1754
|
|
|
|
|
|
const char *method) |
1755
|
|
|
|
|
|
{ |
1756
|
10
|
|
|
|
|
const char *hvname = HvNAME_get(pkg); |
1757
|
|
|
|
|
|
PERL_UNUSED_ARG(method); |
1758
|
10
|
|
|
|
|
(void) hv_store(cache, |
1759
|
|
|
|
|
|
hvname, strlen(hvname), newSVsv(&PL_sv_undef), 0); |
1760
|
10
|
|
|
|
|
} |
1761
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
/* |
1763
|
|
|
|
|
|
* pkg_uncache |
1764
|
|
|
|
|
|
* |
1765
|
|
|
|
|
|
* Discard cached value: a whole fetch loop will be retried at next lookup. |
1766
|
|
|
|
|
|
*/ |
1767
|
4
|
|
|
|
|
static void pkg_uncache( |
1768
|
|
|
|
|
|
pTHX_ |
1769
|
|
|
|
|
|
HV *cache, |
1770
|
|
|
|
|
|
HV *pkg, |
1771
|
|
|
|
|
|
const char *method) |
1772
|
|
|
|
|
|
{ |
1773
|
4
|
|
|
|
|
const char *hvname = HvNAME_get(pkg); |
1774
|
|
|
|
|
|
PERL_UNUSED_ARG(method); |
1775
|
4
|
|
|
|
|
(void) hv_delete(cache, hvname, strlen(hvname), G_DISCARD); |
1776
|
4
|
|
|
|
|
} |
1777
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
/* |
1779
|
|
|
|
|
|
* pkg_can |
1780
|
|
|
|
|
|
* |
1781
|
|
|
|
|
|
* Our own "UNIVERSAL::can", which caches results. |
1782
|
|
|
|
|
|
* |
1783
|
|
|
|
|
|
* Returns the routine reference as an SV*, or null if the object does not |
1784
|
|
|
|
|
|
* know about the method. |
1785
|
|
|
|
|
|
*/ |
1786
|
606
|
|
|
|
|
static SV *pkg_can( |
1787
|
|
|
|
|
|
pTHX_ |
1788
|
|
|
|
|
|
HV *cache, |
1789
|
|
|
|
|
|
HV *pkg, |
1790
|
|
|
|
|
|
const char *method) |
1791
|
|
|
|
|
|
{ |
1792
|
|
|
|
|
|
SV **svh; |
1793
|
|
|
|
|
|
SV *sv; |
1794
|
606
|
|
|
|
|
const char *hvname = HvNAME_get(pkg); |
1795
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
TRACEME(("pkg_can for %s->%s", hvname, method)); |
1797
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
/* |
1799
|
|
|
|
|
|
* Look into the cache to see whether we already have determined |
1800
|
|
|
|
|
|
* where the routine was, if any. |
1801
|
|
|
|
|
|
* |
1802
|
|
|
|
|
|
* NOTA BENE: we don't use 'method' at all in our lookup, since we know |
1803
|
|
|
|
|
|
* that only one hook (i.e. always the same) is cached in a given cache. |
1804
|
|
|
|
|
|
*/ |
1805
|
|
|
|
|
|
|
1806
|
606
|
|
|
|
|
svh = hv_fetch(cache, hvname, strlen(hvname), FALSE); |
1807
|
606
|
|
|
|
|
if (svh) { |
1808
|
140
|
|
|
|
|
sv = *svh; |
1809
|
140
|
|
|
|
|
if (!SvOK(sv)) { |
1810
|
|
|
|
|
|
TRACEME(("cached %s->%s: not found", hvname, method)); |
1811
|
|
|
|
|
|
return (SV *) 0; |
1812
|
|
|
|
|
|
} else { |
1813
|
|
|
|
|
|
TRACEME(("cached %s->%s: 0x%"UVxf, |
1814
|
|
|
|
|
|
hvname, method, PTR2UV(sv))); |
1815
|
76
|
|
|
|
|
return sv; |
1816
|
|
|
|
|
|
} |
1817
|
|
|
|
|
|
} |
1818
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
TRACEME(("not cached yet")); |
1820
|
466
|
|
|
|
|
return pkg_fetchmeth(aTHX_ cache, pkg, method); /* Fetch and cache */ |
1821
|
|
|
|
|
|
} |
1822
|
|
|
|
|
|
|
1823
|
|
|
|
|
|
/* |
1824
|
|
|
|
|
|
* scalar_call |
1825
|
|
|
|
|
|
* |
1826
|
|
|
|
|
|
* Call routine as obj->hook(av) in scalar context. |
1827
|
|
|
|
|
|
* Propagates the single returned value if not called in void context. |
1828
|
|
|
|
|
|
*/ |
1829
|
202
|
|
|
|
|
static SV *scalar_call( |
1830
|
|
|
|
|
|
pTHX_ |
1831
|
|
|
|
|
|
SV *obj, |
1832
|
|
|
|
|
|
SV *hook, |
1833
|
|
|
|
|
|
int cloning, |
1834
|
|
|
|
|
|
AV *av, |
1835
|
|
|
|
|
|
I32 flags) |
1836
|
|
|
|
|
|
{ |
1837
|
202
|
|
|
|
|
dSP; |
1838
|
|
|
|
|
|
int count; |
1839
|
|
|
|
|
|
SV *sv = 0; |
1840
|
|
|
|
|
|
|
1841
|
|
|
|
|
|
TRACEME(("scalar_call (cloning=%d)", cloning)); |
1842
|
|
|
|
|
|
|
1843
|
202
|
|
|
|
|
ENTER; |
1844
|
202
|
|
|
|
|
SAVETMPS; |
1845
|
|
|
|
|
|
|
1846
|
202
|
|
|
|
|
PUSHMARK(sp); |
1847
|
202
|
|
|
|
|
XPUSHs(obj); |
1848
|
202
|
|
|
|
|
XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ |
1849
|
202
|
|
|
|
|
if (av) { |
1850
|
202
|
|
|
|
|
SV **ary = AvARRAY(av); |
1851
|
202
|
|
|
|
|
int cnt = AvFILLp(av) + 1; |
1852
|
|
|
|
|
|
int i; |
1853
|
202
|
|
|
|
|
XPUSHs(ary[0]); /* Frozen string */ |
1854
|
396
|
|
|
|
|
for (i = 1; i < cnt; i++) { |
1855
|
|
|
|
|
|
TRACEME(("pushing arg #%d (0x%"UVxf")...", |
1856
|
|
|
|
|
|
i, PTR2UV(ary[i]))); |
1857
|
194
|
|
|
|
|
XPUSHs(sv_2mortal(newRV(ary[i]))); |
1858
|
|
|
|
|
|
} |
1859
|
|
|
|
|
|
} |
1860
|
202
|
|
|
|
|
PUTBACK; |
1861
|
|
|
|
|
|
|
1862
|
|
|
|
|
|
TRACEME(("calling...")); |
1863
|
202
|
|
|
|
|
count = perl_call_sv(hook, flags); /* Go back to Perl code */ |
1864
|
|
|
|
|
|
TRACEME(("count = %d", count)); |
1865
|
|
|
|
|
|
|
1866
|
202
|
|
|
|
|
SPAGAIN; |
1867
|
|
|
|
|
|
|
1868
|
202
|
|
|
|
|
if (count) { |
1869
|
24
|
|
|
|
|
sv = POPs; |
1870
|
|
|
|
|
|
SvREFCNT_inc(sv); /* We're returning it, must stay alive! */ |
1871
|
|
|
|
|
|
} |
1872
|
|
|
|
|
|
|
1873
|
202
|
|
|
|
|
PUTBACK; |
1874
|
202
|
|
|
|
|
FREETMPS; |
1875
|
202
|
|
|
|
|
LEAVE; |
1876
|
|
|
|
|
|
|
1877
|
202
|
|
|
|
|
return sv; |
1878
|
|
|
|
|
|
} |
1879
|
|
|
|
|
|
|
1880
|
|
|
|
|
|
/* |
1881
|
|
|
|
|
|
* array_call |
1882
|
|
|
|
|
|
* |
1883
|
|
|
|
|
|
* Call routine obj->hook(cloning) in list context. |
1884
|
|
|
|
|
|
* Returns the list of returned values in an array. |
1885
|
|
|
|
|
|
*/ |
1886
|
212
|
|
|
|
|
static AV *array_call( |
1887
|
|
|
|
|
|
pTHX_ |
1888
|
|
|
|
|
|
SV *obj, |
1889
|
|
|
|
|
|
SV *hook, |
1890
|
|
|
|
|
|
int cloning) |
1891
|
|
|
|
|
|
{ |
1892
|
212
|
|
|
|
|
dSP; |
1893
|
|
|
|
|
|
int count; |
1894
|
|
|
|
|
|
AV *av; |
1895
|
|
|
|
|
|
int i; |
1896
|
|
|
|
|
|
|
1897
|
|
|
|
|
|
TRACEME(("array_call (cloning=%d)", cloning)); |
1898
|
|
|
|
|
|
|
1899
|
212
|
|
|
|
|
ENTER; |
1900
|
212
|
|
|
|
|
SAVETMPS; |
1901
|
|
|
|
|
|
|
1902
|
212
|
|
|
|
|
PUSHMARK(sp); |
1903
|
212
|
|
|
|
|
XPUSHs(obj); /* Target object */ |
1904
|
212
|
|
|
|
|
XPUSHs(sv_2mortal(newSViv(cloning))); /* Cloning flag */ |
1905
|
212
|
|
|
|
|
PUTBACK; |
1906
|
|
|
|
|
|
|
1907
|
212
|
|
|
|
|
count = perl_call_sv(hook, G_ARRAY); /* Go back to Perl code */ |
1908
|
|
|
|
|
|
|
1909
|
212
|
|
|
|
|
SPAGAIN; |
1910
|
|
|
|
|
|
|
1911
|
212
|
|
|
|
|
av = newAV(); |
1912
|
612
|
|
|
|
|
for (i = count - 1; i >= 0; i--) { |
1913
|
400
|
|
|
|
|
SV *sv = POPs; |
1914
|
400
|
|
|
|
|
av_store(av, i, SvREFCNT_inc(sv)); |
1915
|
|
|
|
|
|
} |
1916
|
|
|
|
|
|
|
1917
|
212
|
|
|
|
|
PUTBACK; |
1918
|
212
|
|
|
|
|
FREETMPS; |
1919
|
212
|
|
|
|
|
LEAVE; |
1920
|
|
|
|
|
|
|
1921
|
212
|
|
|
|
|
return av; |
1922
|
|
|
|
|
|
} |
1923
|
|
|
|
|
|
|
1924
|
|
|
|
|
|
/* |
1925
|
|
|
|
|
|
* known_class |
1926
|
|
|
|
|
|
* |
1927
|
|
|
|
|
|
* Lookup the class name in the 'hclass' table and either assign it a new ID |
1928
|
|
|
|
|
|
* or return the existing one, by filling in 'classnum'. |
1929
|
|
|
|
|
|
* |
1930
|
|
|
|
|
|
* Return true if the class was known, false if the ID was just generated. |
1931
|
|
|
|
|
|
*/ |
1932
|
412
|
|
|
|
|
static int known_class( |
1933
|
|
|
|
|
|
pTHX_ |
1934
|
|
|
|
|
|
stcxt_t *cxt, |
1935
|
|
|
|
|
|
char *name, /* Class name */ |
1936
|
|
|
|
|
|
int len, /* Name length */ |
1937
|
|
|
|
|
|
I32 *classnum) |
1938
|
|
|
|
|
|
{ |
1939
|
|
|
|
|
|
SV **svh; |
1940
|
412
|
|
|
|
|
HV *hclass = cxt->hclass; |
1941
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
TRACEME(("known_class (%s)", name)); |
1943
|
|
|
|
|
|
|
1944
|
|
|
|
|
|
/* |
1945
|
|
|
|
|
|
* Recall that we don't store pointers in this hash table, but tags. |
1946
|
|
|
|
|
|
* Therefore, we need LOW_32BITS() to extract the relevant parts. |
1947
|
|
|
|
|
|
*/ |
1948
|
|
|
|
|
|
|
1949
|
412
|
|
|
|
|
svh = hv_fetch(hclass, name, len, FALSE); |
1950
|
412
|
|
|
|
|
if (svh) { |
1951
|
92
|
|
|
|
|
*classnum = LOW_32BITS(*svh); |
1952
|
92
|
|
|
|
|
return TRUE; |
1953
|
|
|
|
|
|
} |
1954
|
|
|
|
|
|
|
1955
|
|
|
|
|
|
/* |
1956
|
|
|
|
|
|
* Unknown classname, we need to record it. |
1957
|
|
|
|
|
|
*/ |
1958
|
|
|
|
|
|
|
1959
|
320
|
|
|
|
|
cxt->classnum++; |
1960
|
320
|
|
|
|
|
if (!hv_store(hclass, name, len, INT2PTR(SV*, cxt->classnum), 0)) |
1961
|
0
|
|
|
|
|
CROAK(("Unable to record new classname")); |
1962
|
|
|
|
|
|
|
1963
|
320
|
|
|
|
|
*classnum = cxt->classnum; |
1964
|
320
|
|
|
|
|
return FALSE; |
1965
|
|
|
|
|
|
} |
1966
|
|
|
|
|
|
|
1967
|
|
|
|
|
|
/*** |
1968
|
|
|
|
|
|
*** Specific store routines. |
1969
|
|
|
|
|
|
***/ |
1970
|
|
|
|
|
|
|
1971
|
|
|
|
|
|
/* |
1972
|
|
|
|
|
|
* store_ref |
1973
|
|
|
|
|
|
* |
1974
|
|
|
|
|
|
* Store a reference. |
1975
|
|
|
|
|
|
* Layout is SX_REF |
1976
|
|
|
|
|
|
*/ |
1977
|
29559180
|
|
|
|
|
static int store_ref(pTHX_ stcxt_t *cxt, SV *sv) |
1978
|
|
|
|
|
|
{ |
1979
|
|
|
|
|
|
int is_weak = 0; |
1980
|
|
|
|
|
|
TRACEME(("store_ref (0x%"UVxf")", PTR2UV(sv))); |
1981
|
|
|
|
|
|
|
1982
|
|
|
|
|
|
/* |
1983
|
|
|
|
|
|
* Follow reference, and check if target is overloaded. |
1984
|
|
|
|
|
|
*/ |
1985
|
|
|
|
|
|
|
1986
|
|
|
|
|
|
#ifdef SvWEAKREF |
1987
|
29559180
|
|
|
|
|
if (SvWEAKREF(sv)) |
1988
|
|
|
|
|
|
is_weak = 1; |
1989
|
|
|
|
|
|
TRACEME(("ref (0x%"UVxf") is%s weak", PTR2UV(sv), is_weak ? "" : "n't")); |
1990
|
|
|
|
|
|
#endif |
1991
|
29559180
|
|
|
|
|
sv = SvRV(sv); |
1992
|
|
|
|
|
|
|
1993
|
29559180
|
|
|
|
|
if (SvOBJECT(sv)) { |
1994
|
330
|
|
|
|
|
HV *stash = (HV *) SvSTASH(sv); |
1995
|
330
|
|
|
|
|
if (stash && Gv_AMG(stash)) { |
1996
|
|
|
|
|
|
TRACEME(("ref (0x%"UVxf") is overloaded", PTR2UV(sv))); |
1997
|
66
|
|
|
|
|
PUTMARK(is_weak ? SX_WEAKOVERLOAD : SX_OVERLOAD); |
1998
|
|
|
|
|
|
} else |
1999
|
264
|
|
|
|
|
PUTMARK(is_weak ? SX_WEAKREF : SX_REF); |
2000
|
|
|
|
|
|
} else |
2001
|
29558850
|
|
|
|
|
PUTMARK(is_weak ? SX_WEAKREF : SX_REF); |
2002
|
|
|
|
|
|
|
2003
|
29559180
|
|
|
|
|
return store(aTHX_ cxt, sv); |
2004
|
|
|
|
|
|
} |
2005
|
|
|
|
|
|
|
2006
|
|
|
|
|
|
/* |
2007
|
|
|
|
|
|
* store_scalar |
2008
|
|
|
|
|
|
* |
2009
|
|
|
|
|
|
* Store a scalar. |
2010
|
|
|
|
|
|
* |
2011
|
|
|
|
|
|
* Layout is SX_LSCALAR , SX_SCALAR or SX_UNDEF. |
2012
|
|
|
|
|
|
* SX_LUTF8STR and SX_UTF8STR are used for UTF-8 strings. |
2013
|
|
|
|
|
|
* The section is omitted if is 0. |
2014
|
|
|
|
|
|
* |
2015
|
|
|
|
|
|
* For vstrings, the vstring portion is stored first with |
2016
|
|
|
|
|
|
* SX_LVSTRING or SX_VSTRING , followed by |
2017
|
|
|
|
|
|
* SX_(L)SCALAR or SX_(L)UTF8STR with the actual PV. |
2018
|
|
|
|
|
|
* |
2019
|
|
|
|
|
|
* If integer or double, the layout is SX_INTEGER or SX_DOUBLE . |
2020
|
|
|
|
|
|
* Small integers (within [-127, +127]) are stored as SX_BYTE . |
2021
|
|
|
|
|
|
*/ |
2022
|
109623360
|
|
|
|
|
static int store_scalar(pTHX_ stcxt_t *cxt, SV *sv) |
2023
|
|
|
|
|
|
{ |
2024
|
|
|
|
|
|
IV iv; |
2025
|
|
|
|
|
|
char *pv; |
2026
|
|
|
|
|
|
STRLEN len; |
2027
|
109623360
|
|
|
|
|
U32 flags = SvFLAGS(sv); /* "cc -O" may put it in register */ |
2028
|
|
|
|
|
|
|
2029
|
|
|
|
|
|
TRACEME(("store_scalar (0x%"UVxf")", PTR2UV(sv))); |
2030
|
|
|
|
|
|
|
2031
|
|
|
|
|
|
/* |
2032
|
|
|
|
|
|
* For efficiency, break the SV encapsulation by peaking at the flags |
2033
|
|
|
|
|
|
* directly without using the Perl macros to avoid dereferencing |
2034
|
|
|
|
|
|
* sv->sv_flags each time we wish to check the flags. |
2035
|
|
|
|
|
|
*/ |
2036
|
|
|
|
|
|
|
2037
|
109623360
|
|
|
|
|
if (!(flags & SVf_OK)) { /* !SvOK(sv) */ |
2038
|
9352826
|
|
|
|
|
if (sv == &PL_sv_undef) { |
2039
|
|
|
|
|
|
TRACEME(("immortal undef")); |
2040
|
10250
|
|
|
|
|
PUTMARK(SX_SV_UNDEF); |
2041
|
|
|
|
|
|
} else { |
2042
|
|
|
|
|
|
TRACEME(("undef at 0x%"UVxf, PTR2UV(sv))); |
2043
|
9342576
|
|
|
|
|
PUTMARK(SX_UNDEF); |
2044
|
|
|
|
|
|
} |
2045
|
9352826
|
|
|
|
|
return 0; |
2046
|
|
|
|
|
|
} |
2047
|
|
|
|
|
|
|
2048
|
|
|
|
|
|
/* |
2049
|
|
|
|
|
|
* Always store the string representation of a scalar if it exists. |
2050
|
|
|
|
|
|
* Gisle Aas provided me with this test case, better than a long speach: |
2051
|
|
|
|
|
|
* |
2052
|
|
|
|
|
|
* perl -MDevel::Peek -le '$a="abc"; $a+0; Dump($a)' |
2053
|
|
|
|
|
|
* SV = PVNV(0x80c8520) |
2054
|
|
|
|
|
|
* REFCNT = 1 |
2055
|
|
|
|
|
|
* FLAGS = (NOK,POK,pNOK,pPOK) |
2056
|
|
|
|
|
|
* IV = 0 |
2057
|
|
|
|
|
|
* NV = 0 |
2058
|
|
|
|
|
|
* PV = 0x80c83d0 "abc"\0 |
2059
|
|
|
|
|
|
* CUR = 3 |
2060
|
|
|
|
|
|
* LEN = 4 |
2061
|
|
|
|
|
|
* |
2062
|
|
|
|
|
|
* Write SX_SCALAR, length, followed by the actual data. |
2063
|
|
|
|
|
|
* |
2064
|
|
|
|
|
|
* Otherwise, write an SX_BYTE, SX_INTEGER or an SX_DOUBLE as |
2065
|
|
|
|
|
|
* appropriate, followed by the actual (binary) data. A double |
2066
|
|
|
|
|
|
* is written as a string if network order, for portability. |
2067
|
|
|
|
|
|
* |
2068
|
|
|
|
|
|
* NOTE: instead of using SvNOK(sv), we test for SvNOKp(sv). |
2069
|
|
|
|
|
|
* The reason is that when the scalar value is tainted, the SvNOK(sv) |
2070
|
|
|
|
|
|
* value is false. |
2071
|
|
|
|
|
|
* |
2072
|
|
|
|
|
|
* The test for a read-only scalar with both POK and NOK set is meant |
2073
|
|
|
|
|
|
* to quickly detect &PL_sv_yes and &PL_sv_no without having to pay the |
2074
|
|
|
|
|
|
* address comparison for each scalar we store. |
2075
|
|
|
|
|
|
*/ |
2076
|
|
|
|
|
|
|
2077
|
|
|
|
|
|
#define SV_MAYBE_IMMORTAL (SVf_READONLY|SVf_POK|SVf_NOK) |
2078
|
|
|
|
|
|
|
2079
|
100270534
|
|
|
|
|
if ((flags & SV_MAYBE_IMMORTAL) == SV_MAYBE_IMMORTAL) { |
2080
|
12
|
|
|
|
|
if (sv == &PL_sv_yes) { |
2081
|
|
|
|
|
|
TRACEME(("immortal yes")); |
2082
|
6
|
|
|
|
|
PUTMARK(SX_SV_YES); |
2083
|
6
|
|
|
|
|
} else if (sv == &PL_sv_no) { |
2084
|
|
|
|
|
|
TRACEME(("immortal no")); |
2085
|
6
|
|
|
|
|
PUTMARK(SX_SV_NO); |
2086
|
|
|
|
|
|
} else { |
2087
|
0
|
|
|
|
|
pv = SvPV(sv, len); /* We know it's SvPOK */ |
2088
|
0
|
|
|
|
|
goto string; /* Share code below */ |
2089
|
|
|
|
|
|
} |
2090
|
100270522
|
|
|
|
|
} else if (flags & SVf_POK) { |
2091
|
|
|
|
|
|
/* public string - go direct to string read. */ |
2092
|
|
|
|
|
|
goto string_readlen; |
2093
|
64654798
|
|
|
|
|
} else if ( |
2094
|
|
|
|
|
|
#if (PATCHLEVEL <= 6) |
2095
|
|
|
|
|
|
/* For 5.6 and earlier NV flag trumps IV flag, so only use integer |
2096
|
|
|
|
|
|
direct if NV flag is off. */ |
2097
|
|
|
|
|
|
(flags & (SVf_NOK | SVf_IOK)) == SVf_IOK |
2098
|
|
|
|
|
|
#else |
2099
|
|
|
|
|
|
/* 5.7 rules are that if IV public flag is set, IV value is as |
2100
|
|
|
|
|
|
good, if not better, than NV value. */ |
2101
|
64654798
|
|
|
|
|
flags & SVf_IOK |
2102
|
|
|
|
|
|
#endif |
2103
|
|
|
|
|
|
) { |
2104
|
64628088
|
|
|
|
|
iv = SvIV(sv); |
2105
|
|
|
|
|
|
/* |
2106
|
|
|
|
|
|
* Will come here from below with iv set if double is an integer. |
2107
|
|
|
|
|
|
*/ |
2108
|
|
|
|
|
|
integer: |
2109
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
/* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ |
2111
|
|
|
|
|
|
#ifdef SVf_IVisUV |
2112
|
|
|
|
|
|
/* Need to do this out here, else 0xFFFFFFFF becomes iv of -1 |
2113
|
|
|
|
|
|
* (for example) and that ends up in the optimised small integer |
2114
|
|
|
|
|
|
* case. |
2115
|
|
|
|
|
|
*/ |
2116
|
64645798
|
|
|
|
|
if ((flags & SVf_IVisUV) && SvUV(sv) > IV_MAX) { |
2117
|
|
|
|
|
|
TRACEME(("large unsigned integer as string, value = %"UVuf, SvUV(sv))); |
2118
|
|
|
|
|
|
goto string_readlen; |
2119
|
|
|
|
|
|
} |
2120
|
|
|
|
|
|
#endif |
2121
|
|
|
|
|
|
/* |
2122
|
|
|
|
|
|
* Optimize small integers into a single byte, otherwise store as |
2123
|
|
|
|
|
|
* a real integer (converted into network order if they asked). |
2124
|
|
|
|
|
|
*/ |
2125
|
|
|
|
|
|
|
2126
|
64645758
|
|
|
|
|
if (iv >= -128 && iv <= 127) { |
2127
|
37838478
|
|
|
|
|
unsigned char siv = (unsigned char) (iv + 128); /* [0,255] */ |
2128
|
37838478
|
|
|
|
|
PUTMARK(SX_BYTE); |
2129
|
37838478
|
|
|
|
|
PUTMARK(siv); |
2130
|
|
|
|
|
|
TRACEME(("small integer stored as %d", siv)); |
2131
|
26807280
|
|
|
|
|
} else if (cxt->netorder) { |
2132
|
|
|
|
|
|
#ifndef HAS_HTONL |
2133
|
|
|
|
|
|
TRACEME(("no htonl, fall back to string for integer")); |
2134
|
|
|
|
|
|
goto string_readlen; |
2135
|
|
|
|
|
|
#else |
2136
|
|
|
|
|
|
I32 niv; |
2137
|
|
|
|
|
|
|
2138
|
|
|
|
|
|
|
2139
|
|
|
|
|
|
#if IVSIZE > 4 |
2140
|
26341766
|
|
|
|
|
if ( |
2141
|
|
|
|
|
|
#ifdef SVf_IVisUV |
2142
|
|
|
|
|
|
/* Sorry. This isn't in 5.005_56 (IIRC) or earlier. */ |
2143
|
26341766
|
|
|
|
|
((flags & SVf_IVisUV) && SvUV(sv) > (UV)0x7FFFFFFF) || |
2144
|
|
|
|
|
|
#endif |
2145
|
26341766
|
|
|
|
|
(iv > (IV)0x7FFFFFFF) || (iv < -(IV)0x80000000)) { |
2146
|
|
|
|
|
|
/* Bigger than 32 bits. */ |
2147
|
|
|
|
|
|
TRACEME(("large network order integer as string, value = %"IVdf, iv)); |
2148
|
|
|
|
|
|
goto string_readlen; |
2149
|
|
|
|
|
|
} |
2150
|
|
|
|
|
|
#endif |
2151
|
|
|
|
|
|
|
2152
|
26341722
|
|
|
|
|
niv = (I32) htonl((I32) iv); |
2153
|
|
|
|
|
|
TRACEME(("using network order")); |
2154
|
26341722
|
|
|
|
|
PUTMARK(SX_NETINT); |
2155
|
26341750
|
|
|
|
|
WRITE_I32(niv); |
2156
|
|
|
|
|
|
#endif |
2157
|
|
|
|
|
|
} else { |
2158
|
465514
|
|
|
|
|
PUTMARK(SX_INTEGER); |
2159
|
930974
|
|
|
|
|
WRITE(&iv, sizeof(iv)); |
2160
|
|
|
|
|
|
} |
2161
|
|
|
|
|
|
|
2162
|
|
|
|
|
|
TRACEME(("ok (integer 0x%"UVxf", value = %"IVdf")", PTR2UV(sv), iv)); |
2163
|
26710
|
|
|
|
|
} else if (flags & SVf_NOK) { |
2164
|
|
|
|
|
|
NV nv; |
2165
|
|
|
|
|
|
#if (PATCHLEVEL <= 6) |
2166
|
|
|
|
|
|
nv = SvNV(sv); |
2167
|
|
|
|
|
|
/* |
2168
|
|
|
|
|
|
* Watch for number being an integer in disguise. |
2169
|
|
|
|
|
|
*/ |
2170
|
|
|
|
|
|
if (nv == (NV) (iv = I_V(nv))) { |
2171
|
|
|
|
|
|
TRACEME(("double %"NVff" is actually integer %"IVdf, nv, iv)); |
2172
|
|
|
|
|
|
goto integer; /* Share code above */ |
2173
|
|
|
|
|
|
} |
2174
|
|
|
|
|
|
#else |
2175
|
|
|
|
|
|
|
2176
|
26710
|
|
|
|
|
SvIV_please(sv); |
2177
|
26710
|
|
|
|
|
if (SvIOK_notUV(sv)) { |
2178
|
17710
|
|
|
|
|
iv = SvIV(sv); |
2179
|
17710
|
|
|
|
|
goto integer; /* Share code above */ |
2180
|
|
|
|
|
|
} |
2181
|
9000
|
|
|
|
|
nv = SvNV(sv); |
2182
|
|
|
|
|
|
#endif |
2183
|
|
|
|
|
|
|
2184
|
9000
|
|
|
|
|
if (cxt->netorder) { |
2185
|
|
|
|
|
|
TRACEME(("double %"NVff" stored as string", nv)); |
2186
|
|
|
|
|
|
goto string_readlen; /* Share code below */ |
2187
|
|
|
|
|
|
} |
2188
|
|
|
|
|
|
|
2189
|
40
|
|
|
|
|
PUTMARK(SX_DOUBLE); |
2190
|
64
|
|
|
|
|
WRITE(&nv, sizeof(nv)); |
2191
|
|
|
|
|
|
|
2192
|
|
|
|
|
|
TRACEME(("ok (double 0x%"UVxf", value = %"NVff")", PTR2UV(sv), nv)); |
2193
|
|
|
|
|
|
|
2194
|
0
|
|
|
|
|
} else if (flags & (SVp_POK | SVp_NOK | SVp_IOK)) { |
2195
|
|
|
|
|
|
#ifdef SvVOK |
2196
|
|
|
|
|
|
MAGIC *mg; |
2197
|
|
|
|
|
|
#endif |
2198
|
|
|
|
|
|
I32 wlen; /* For 64-bit machines */ |
2199
|
|
|
|
|
|
|
2200
|
|
|
|
|
|
string_readlen: |
2201
|
35624768
|
|
|
|
|
pv = SvPV(sv, len); |
2202
|
|
|
|
|
|
|
2203
|
|
|
|
|
|
/* |
2204
|
|
|
|
|
|
* Will come here from above if it was readonly, POK and NOK but |
2205
|
|
|
|
|
|
* neither &PL_sv_yes nor &PL_sv_no. |
2206
|
|
|
|
|
|
*/ |
2207
|
|
|
|
|
|
string: |
2208
|
|
|
|
|
|
|
2209
|
|
|
|
|
|
#ifdef SvVOK |
2210
|
35624768
|
|
|
|
|
if (SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))) { |
2211
|
|
|
|
|
|
/* The macro passes this by address, not value, and a lot of |
2212
|
|
|
|
|
|
called code assumes that it's 32 bits without checking. */ |
2213
|
4
|
|
|
|
|
const int len = mg->mg_len; |
2214
|
10
|
|
|
|
|
STORE_PV_LEN((const char *)mg->mg_ptr, |
2215
|
|
|
|
|
|
len, SX_VSTRING, SX_LVSTRING); |
2216
|
|
|
|
|
|
} |
2217
|
|
|
|
|
|
#endif |
2218
|
|
|
|
|
|
|
2219
|
35624768
|
|
|
|
|
wlen = (I32) len; /* WLEN via STORE_SCALAR expects I32 */ |
2220
|
35624768
|
|
|
|
|
if (SvUTF8 (sv)) |
2221
|
96224
|
|
|
|
|
STORE_UTF8STR(pv, wlen); |
2222
|
|
|
|
|
|
else |
2223
|
35893756
|
|
|
|
|
STORE_SCALAR(pv, wlen); |
2224
|
|
|
|
|
|
TRACEME(("ok (scalar 0x%"UVxf" '%s', length = %"IVdf")", |
2225
|
|
|
|
|
|
PTR2UV(sv), SvPVX(sv), (IV)len)); |
2226
|
|
|
|
|
|
} else |
2227
|
0
|
|
|
|
|
CROAK(("Can't determine type of %s(0x%"UVxf")", |
2228
|
|
|
|
|
|
sv_reftype(sv, FALSE), |
2229
|
|
|
|
|
|
PTR2UV(sv))); |
2230
|
100270534
|
|
|
|
|
return 0; /* Ok, no recursion on scalars */ |
2231
|
|
|
|
|
|
} |
2232
|
|
|
|
|
|
|
2233
|
|
|
|
|
|
/* |
2234
|
|
|
|
|
|
* store_array |
2235
|
|
|
|
|
|
* |
2236
|
|
|
|
|
|
* Store an array. |
2237
|
|
|
|
|
|
* |
2238
|
|
|
|
|
|
* Layout is SX_ARRAY followed by each item, in increasing index order. |
2239
|
|
|
|
|
|
* Each item is stored as . |
2240
|
|
|
|
|
|
*/ |
2241
|
15218268
|
|
|
|
|
static int store_array(pTHX_ stcxt_t *cxt, AV *av) |
2242
|
|
|
|
|
|
{ |
2243
|
|
|
|
|
|
SV **sav; |
2244
|
15218268
|
|
|
|
|
I32 len = av_len(av) + 1; |
2245
|
|
|
|
|
|
I32 i; |
2246
|
|
|
|
|
|
int ret; |
2247
|
|
|
|
|
|
|
2248
|
|
|
|
|
|
TRACEME(("store_array (0x%"UVxf")", PTR2UV(av))); |
2249
|
|
|
|
|
|
|
2250
|
|
|
|
|
|
/* |
2251
|
|
|
|
|
|
* Signal array by emitting SX_ARRAY, followed by the array length. |
2252
|
|
|
|
|
|
*/ |
2253
|
|
|
|
|
|
|
2254
|
15218268
|
|
|
|
|
PUTMARK(SX_ARRAY); |
2255
|
15274786
|
|
|
|
|
WLEN(len); |
2256
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
2257
|
|
|
|
|
|
|
2258
|
|
|
|
|
|
/* |
2259
|
|
|
|
|
|
* Now store each item recursively. |
2260
|
|
|
|
|
|
*/ |
2261
|
|
|
|
|
|
|
2262
|
82222862
|
|
|
|
|
for (i = 0; i < len; i++) { |
2263
|
82222864
|
|
|
|
|
sav = av_fetch(av, i, 0); |
2264
|
82222864
|
|
|
|
|
if (!sav) { |
2265
|
|
|
|
|
|
TRACEME(("(#%d) nonexistent item", i)); |
2266
|
639026
|
|
|
|
|
STORE_SV_UNDEF(); |
2267
|
639026
|
|
|
|
|
continue; |
2268
|
|
|
|
|
|
} |
2269
|
|
|
|
|
|
#if PATCHLEVEL >= 19 |
2270
|
|
|
|
|
|
/* In 5.19.3 and up, &PL_sv_undef can actually be stored in |
2271
|
|
|
|
|
|
* an array; it no longer represents nonexistent elements. |
2272
|
|
|
|
|
|
* Historically, we have used SX_SV_UNDEF in arrays for |
2273
|
|
|
|
|
|
* nonexistent elements, so we use SX_SVUNDEF_ELEM for |
2274
|
|
|
|
|
|
* &PL_sv_undef itself. */ |
2275
|
81583838
|
|
|
|
|
if (*sav == &PL_sv_undef) { |
2276
|
|
|
|
|
|
TRACEME(("(#%d) undef item", i)); |
2277
|
0
|
|
|
|
|
cxt->tagnum++; |
2278
|
0
|
|
|
|
|
PUTMARK(SX_SVUNDEF_ELEM); |
2279
|
0
|
|
|
|
|
continue; |
2280
|
|
|
|
|
|
} |
2281
|
|
|
|
|
|
#endif |
2282
|
|
|
|
|
|
TRACEME(("(#%d) item", i)); |
2283
|
81583838
|
|
|
|
|
if ((ret = store(aTHX_ cxt, *sav))) /* Extra () for -Wall, grr... */ |
2284
|
|
|
|
|
|
return ret; |
2285
|
|
|
|
|
|
} |
2286
|
|
|
|
|
|
|
2287
|
|
|
|
|
|
TRACEME(("ok (array)")); |
2288
|
|
|
|
|
|
|
2289
|
|
|
|
|
|
return 0; |
2290
|
|
|
|
|
|
} |
2291
|
|
|
|
|
|
|
2292
|
|
|
|
|
|
|
2293
|
|
|
|
|
|
#if (PATCHLEVEL <= 6) |
2294
|
|
|
|
|
|
|
2295
|
|
|
|
|
|
/* |
2296
|
|
|
|
|
|
* sortcmp |
2297
|
|
|
|
|
|
* |
2298
|
|
|
|
|
|
* Sort two SVs |
2299
|
|
|
|
|
|
* Borrowed from perl source file pp_ctl.c, where it is used by pp_sort. |
2300
|
|
|
|
|
|
*/ |
2301
|
|
|
|
|
|
static int |
2302
|
|
|
|
|
|
sortcmp(const void *a, const void *b) |
2303
|
|
|
|
|
|
{ |
2304
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
2305
|
|
|
|
|
|
dTHX; |
2306
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
2307
|
|
|
|
|
|
return sv_cmp(*(SV * const *) a, *(SV * const *) b); |
2308
|
|
|
|
|
|
} |
2309
|
|
|
|
|
|
|
2310
|
|
|
|
|
|
#endif /* PATCHLEVEL <= 6 */ |
2311
|
|
|
|
|
|
|
2312
|
|
|
|
|
|
/* |
2313
|
|
|
|
|
|
* store_hash |
2314
|
|
|
|
|
|
* |
2315
|
|
|
|
|
|
* Store a hash table. |
2316
|
|
|
|
|
|
* |
2317
|
|
|
|
|
|
* For a "normal" hash (not restricted, no utf8 keys): |
2318
|
|
|
|
|
|
* |
2319
|
|
|
|
|
|
* Layout is SX_HASH followed by each key/value pair, in random order. |
2320
|
|
|
|
|
|
* Values are stored as . |
2321
|
|
|
|
|
|
* Keys are stored as , the section being omitted |
2322
|
|
|
|
|
|
* if length is 0. |
2323
|
|
|
|
|
|
* |
2324
|
|
|
|
|
|
* For a "fancy" hash (restricted or utf8 keys): |
2325
|
|
|
|
|
|
* |
2326
|
|
|
|
|
|
* Layout is SX_FLAG_HASH followed by each key/value pair, |
2327
|
|
|
|
|
|
* in random order. |
2328
|
|
|
|
|
|
* Values are stored as . |
2329
|
|
|
|
|
|
* Keys are stored as , the section being omitted |
2330
|
|
|
|
|
|
* if length is 0. |
2331
|
|
|
|
|
|
* Currently the only hash flag is "restricted" |
2332
|
|
|
|
|
|
* Key flags are as for hv.h |
2333
|
|
|
|
|
|
*/ |
2334
|
14705400
|
|
|
|
|
static int store_hash(pTHX_ stcxt_t *cxt, HV *hv) |
2335
|
|
|
|
|
|
{ |
2336
|
|
|
|
|
|
dVAR; |
2337
|
14705400
|
|
|
|
|
I32 len = HvTOTALKEYS(hv); |
2338
|
|
|
|
|
|
I32 i; |
2339
|
|
|
|
|
|
int ret = 0; |
2340
|
|
|
|
|
|
I32 riter; |
2341
|
|
|
|
|
|
HE *eiter; |
2342
|
14705400
|
|
|
|
|
int flagged_hash = ((SvREADONLY(hv) |
2343
|
|
|
|
|
|
#ifdef HAS_HASH_KEY_FLAGS |
2344
|
14705176
|
|
|
|
|
|| HvHASKFLAGS(hv) |
2345
|
|
|
|
|
|
#endif |
2346
|
14705176
|
|
|
|
|
) ? 1 : 0); |
2347
|
14705400
|
|
|
|
|
unsigned char hash_flags = (SvREADONLY(hv) ? SHV_RESTRICTED : 0); |
2348
|
|
|
|
|
|
|
2349
|
|
|
|
|
|
if (flagged_hash) { |
2350
|
|
|
|
|
|
/* needs int cast for C++ compilers, doesn't it? */ |
2351
|
|
|
|
|
|
TRACEME(("store_hash (0x%"UVxf") (flags %x)", PTR2UV(hv), |
2352
|
|
|
|
|
|
(int) hash_flags)); |
2353
|
|
|
|
|
|
} else { |
2354
|
|
|
|
|
|
TRACEME(("store_hash (0x%"UVxf")", PTR2UV(hv))); |
2355
|
|
|
|
|
|
} |
2356
|
|
|
|
|
|
|
2357
|
|
|
|
|
|
/* |
2358
|
|
|
|
|
|
* Signal hash by emitting SX_HASH, followed by the table length. |
2359
|
|
|
|
|
|
*/ |
2360
|
|
|
|
|
|
|
2361
|
14705400
|
|
|
|
|
if (flagged_hash) { |
2362
|
44088
|
|
|
|
|
PUTMARK(SX_FLAG_HASH); |
2363
|
44088
|
|
|
|
|
PUTMARK(hash_flags); |
2364
|
|
|
|
|
|
} else { |
2365
|
14661312
|
|
|
|
|
PUTMARK(SX_HASH); |
2366
|
|
|
|
|
|
} |
2367
|
14709922
|
|
|
|
|
WLEN(len); |
2368
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
2369
|
|
|
|
|
|
|
2370
|
|
|
|
|
|
/* |
2371
|
|
|
|
|
|
* Save possible iteration state via each() on that table. |
2372
|
|
|
|
|
|
*/ |
2373
|
|
|
|
|
|
|
2374
|
14705400
|
|
|
|
|
riter = HvRITER_get(hv); |
2375
|
14705400
|
|
|
|
|
eiter = HvEITER_get(hv); |
2376
|
14705400
|
|
|
|
|
hv_iterinit(hv); |
2377
|
|
|
|
|
|
|
2378
|
|
|
|
|
|
/* |
2379
|
|
|
|
|
|
* Now store each item recursively. |
2380
|
|
|
|
|
|
* |
2381
|
|
|
|
|
|
* If canonical is defined to some true value then store each |
2382
|
|
|
|
|
|
* key/value pair in sorted order otherwise the order is random. |
2383
|
|
|
|
|
|
* Canonical order is irrelevant when a deep clone operation is performed. |
2384
|
|
|
|
|
|
* |
2385
|
|
|
|
|
|
* Fetch the value from perl only once per store() operation, and only |
2386
|
|
|
|
|
|
* when needed. |
2387
|
|
|
|
|
|
*/ |
2388
|
|
|
|
|
|
|
2389
|
14705400
|
|
|
|
|
if ( |
2390
|
44109090
|
|
|
|
|
!(cxt->optype & ST_CLONE) && (cxt->canonical == 1 || |
2391
|
15989088
|
|
|
|
|
(cxt->canonical < 0 && (cxt->canonical = |
2392
|
965850
|
|
|
|
|
(SvTRUE(perl_get_sv("Storable::canonical", GV_ADD)) ? 1 : 0)))) |
2393
|
1596
|
|
|
|
|
) { |
2394
|
|
|
|
|
|
/* |
2395
|
|
|
|
|
|
* Storing in order, sorted by key. |
2396
|
|
|
|
|
|
* Run through the hash, building up an array of keys in a |
2397
|
|
|
|
|
|
* mortal array, sort the array and then run through the |
2398
|
|
|
|
|
|
* array. |
2399
|
|
|
|
|
|
*/ |
2400
|
|
|
|
|
|
|
2401
|
1596
|
|
|
|
|
AV *av = newAV(); |
2402
|
|
|
|
|
|
|
2403
|
|
|
|
|
|
/*av_extend (av, len);*/ |
2404
|
|
|
|
|
|
|
2405
|
|
|
|
|
|
TRACEME(("using canonical order")); |
2406
|
|
|
|
|
|
|
2407
|
19974
|
|
|
|
|
for (i = 0; i < len; i++) { |
2408
|
|
|
|
|
|
#ifdef HAS_RESTRICTED_HASHES |
2409
|
18378
|
|
|
|
|
HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); |
2410
|
|
|
|
|
|
#else |
2411
|
|
|
|
|
|
HE *he = hv_iternext(hv); |
2412
|
|
|
|
|
|
#endif |
2413
|
|
|
|
|
|
SV *key; |
2414
|
|
|
|
|
|
|
2415
|
18378
|
|
|
|
|
if (!he) |
2416
|
0
|
|
|
|
|
CROAK(("Hash %p inconsistent - expected %d keys, %dth is NULL", hv, (int)len, (int)i)); |
2417
|
18378
|
|
|
|
|
key = hv_iterkeysv(he); |
2418
|
18378
|
|
|
|
|
av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ |
2419
|
|
|
|
|
|
} |
2420
|
|
|
|
|
|
|
2421
|
1596
|
|
|
|
|
STORE_HASH_SORT; |
2422
|
|
|
|
|
|
|
2423
|
19974
|
|
|
|
|
for (i = 0; i < len; i++) { |
2424
|
|
|
|
|
|
#ifdef HAS_RESTRICTED_HASHES |
2425
|
18378
|
|
|
|
|
int placeholders = (int)HvPLACEHOLDERS_get(hv); |
2426
|
|
|
|
|
|
#endif |
2427
|
|
|
|
|
|
unsigned char flags = 0; |
2428
|
|
|
|
|
|
char *keyval; |
2429
|
|
|
|
|
|
STRLEN keylen_tmp; |
2430
|
|
|
|
|
|
I32 keylen; |
2431
|
18378
|
|
|
|
|
SV *key = av_shift(av); |
2432
|
|
|
|
|
|
/* This will fail if key is a placeholder. |
2433
|
|
|
|
|
|
Track how many placeholders we have, and error if we |
2434
|
|
|
|
|
|
"see" too many. */ |
2435
|
18378
|
|
|
|
|
HE *he = hv_fetch_ent(hv, key, 0, 0); |
2436
|
|
|
|
|
|
SV *val; |
2437
|
|
|
|
|
|
|
2438
|
18378
|
|
|
|
|
if (he) { |
2439
|
18342
|
|
|
|
|
if (!(val = HeVAL(he))) { |
2440
|
|
|
|
|
|
/* Internal error, not I/O error */ |
2441
|
|
|
|
|
|
return 1; |
2442
|
|
|
|
|
|
} |
2443
|
|
|
|
|
|
} else { |
2444
|
|
|
|
|
|
#ifdef HAS_RESTRICTED_HASHES |
2445
|
|
|
|
|
|
/* Should be a placeholder. */ |
2446
|
36
|
|
|
|
|
if (placeholders-- < 0) { |
2447
|
|
|
|
|
|
/* This should not happen - number of |
2448
|
|
|
|
|
|
retrieves should be identical to |
2449
|
|
|
|
|
|
number of placeholders. */ |
2450
|
|
|
|
|
|
return 1; |
2451
|
|
|
|
|
|
} |
2452
|
|
|
|
|
|
/* Value is never needed, and PL_sv_undef is |
2453
|
|
|
|
|
|
more space efficient to store. */ |
2454
|
|
|
|
|
|
val = &PL_sv_undef; |
2455
|
|
|
|
|
|
ASSERT (flags == 0, |
2456
|
|
|
|
|
|
("Flags not 0 but %d", flags)); |
2457
|
|
|
|
|
|
flags = SHV_K_PLACEHOLDER; |
2458
|
|
|
|
|
|
#else |
2459
|
|
|
|
|
|
return 1; |
2460
|
|
|
|
|
|
#endif |
2461
|
|
|
|
|
|
} |
2462
|
|
|
|
|
|
|
2463
|
|
|
|
|
|
/* |
2464
|
|
|
|
|
|
* Store value first. |
2465
|
|
|
|
|
|
*/ |
2466
|
|
|
|
|
|
|
2467
|
|
|
|
|
|
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); |
2468
|
|
|
|
|
|
|
2469
|
18378
|
|
|
|
|
if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ |
2470
|
|
|
|
|
|
goto out; |
2471
|
|
|
|
|
|
|
2472
|
|
|
|
|
|
/* |
2473
|
|
|
|
|
|
* Write key string. |
2474
|
|
|
|
|
|
* Keys are written after values to make sure retrieval |
2475
|
|
|
|
|
|
* can be optimal in terms of memory usage, where keys are |
2476
|
|
|
|
|
|
* read into a fixed unique buffer called kbuf. |
2477
|
|
|
|
|
|
* See retrieve_hash() for details. |
2478
|
|
|
|
|
|
*/ |
2479
|
|
|
|
|
|
|
2480
|
|
|
|
|
|
/* Implementation of restricted hashes isn't nicely |
2481
|
|
|
|
|
|
abstracted: */ |
2482
|
18378
|
|
|
|
|
if ((hash_flags & SHV_RESTRICTED) |
2483
|
44
|
|
|
|
|
&& SvTRULYREADONLY(val)) { |
2484
|
40
|
|
|
|
|
flags |= SHV_K_LOCKED; |
2485
|
|
|
|
|
|
} |
2486
|
|
|
|
|
|
|
2487
|
18378
|
|
|
|
|
keyval = SvPV(key, keylen_tmp); |
2488
|
18378
|
|
|
|
|
keylen = keylen_tmp; |
2489
|
|
|
|
|
|
#ifdef HAS_UTF8_HASHES |
2490
|
|
|
|
|
|
/* If you build without optimisation on pre 5.6 |
2491
|
|
|
|
|
|
then nothing spots that SvUTF8(key) is always 0, |
2492
|
|
|
|
|
|
so the block isn't optimised away, at which point |
2493
|
|
|
|
|
|
the linker dislikes the reference to |
2494
|
|
|
|
|
|
bytes_from_utf8. */ |
2495
|
18378
|
|
|
|
|
if (SvUTF8(key)) { |
2496
|
|
|
|
|
|
const char *keysave = keyval; |
2497
|
28
|
|
|
|
|
bool is_utf8 = TRUE; |
2498
|
|
|
|
|
|
|
2499
|
|
|
|
|
|
/* Just casting the &klen to (STRLEN) won't work |
2500
|
|
|
|
|
|
well if STRLEN and I32 are of different widths. |
2501
|
|
|
|
|
|
--jhi */ |
2502
|
28
|
|
|
|
|
keyval = (char*)bytes_from_utf8((U8*)keyval, |
2503
|
|
|
|
|
|
&keylen_tmp, |
2504
|
|
|
|
|
|
&is_utf8); |
2505
|
|
|
|
|
|
|
2506
|
|
|
|
|
|
/* If we were able to downgrade here, then than |
2507
|
|
|
|
|
|
means that we have a key which only had chars |
2508
|
|
|
|
|
|
0-255, but was utf8 encoded. */ |
2509
|
|
|
|
|
|
|
2510
|
28
|
|
|
|
|
if (keyval != keysave) { |
2511
|
10
|
|
|
|
|
keylen = keylen_tmp; |
2512
|
10
|
|
|
|
|
flags |= SHV_K_WASUTF8; |
2513
|
|
|
|
|
|
} else { |
2514
|
|
|
|
|
|
/* keylen_tmp can't have changed, so no need |
2515
|
|
|
|
|
|
to assign back to keylen. */ |
2516
|
18
|
|
|
|
|
flags |= SHV_K_UTF8; |
2517
|
|
|
|
|
|
} |
2518
|
|
|
|
|
|
} |
2519
|
|
|
|
|
|
#endif |
2520
|
|
|
|
|
|
|
2521
|
18378
|
|
|
|
|
if (flagged_hash) { |
2522
|
96
|
|
|
|
|
PUTMARK(flags); |
2523
|
|
|
|
|
|
TRACEME(("(#%d) key '%s' flags %x %u", i, keyval, flags, *keyval)); |
2524
|
|
|
|
|
|
} else { |
2525
|
|
|
|
|
|
/* This is a workaround for a bug in 5.8.0 |
2526
|
|
|
|
|
|
that causes the HEK_WASUTF8 flag to be |
2527
|
|
|
|
|
|
set on an HEK without the hash being |
2528
|
|
|
|
|
|
marked as having key flags. We just |
2529
|
|
|
|
|
|
cross our fingers and drop the flag. |
2530
|
|
|
|
|
|
AMS 20030901 */ |
2531
|
|
|
|
|
|
assert (flags == 0 || flags == SHV_K_WASUTF8); |
2532
|
|
|
|
|
|
TRACEME(("(#%d) key '%s'", i, keyval)); |
2533
|
|
|
|
|
|
} |
2534
|
27928
|
|
|
|
|
WLEN(keylen); |
2535
|
18378
|
|
|
|
|
if (keylen) |
2536
|
27928
|
|
|
|
|
WRITE(keyval, keylen); |
2537
|
18378
|
|
|
|
|
if (flags & SHV_K_WASUTF8) |
2538
|
10
|
|
|
|
|
Safefree (keyval); |
2539
|
|
|
|
|
|
} |
2540
|
|
|
|
|
|
|
2541
|
|
|
|
|
|
/* |
2542
|
|
|
|
|
|
* Free up the temporary array |
2543
|
|
|
|
|
|
*/ |
2544
|
|
|
|
|
|
|
2545
|
1596
|
|
|
|
|
av_undef(av); |
2546
|
1596
|
|
|
|
|
sv_free((SV *) av); |
2547
|
|
|
|
|
|
|
2548
|
|
|
|
|
|
} else { |
2549
|
|
|
|
|
|
|
2550
|
|
|
|
|
|
/* |
2551
|
|
|
|
|
|
* Storing in "random" order (in the order the keys are stored |
2552
|
|
|
|
|
|
* within the hash). This is the default and will be faster! |
2553
|
|
|
|
|
|
*/ |
2554
|
|
|
|
|
|
|
2555
|
57579770
|
|
|
|
|
for (i = 0; i < len; i++) { |
2556
|
|
|
|
|
|
char *key = 0; |
2557
|
|
|
|
|
|
I32 len; |
2558
|
|
|
|
|
|
unsigned char flags; |
2559
|
|
|
|
|
|
#ifdef HV_ITERNEXT_WANTPLACEHOLDERS |
2560
|
57579770
|
|
|
|
|
HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); |
2561
|
|
|
|
|
|
#else |
2562
|
|
|
|
|
|
HE *he = hv_iternext(hv); |
2563
|
|
|
|
|
|
#endif |
2564
|
57579770
|
|
|
|
|
SV *val = (he ? hv_iterval(hv, he) : 0); |
2565
|
|
|
|
|
|
SV *key_sv = NULL; |
2566
|
|
|
|
|
|
HEK *hek; |
2567
|
|
|
|
|
|
|
2568
|
57579770
|
|
|
|
|
if (val == 0) |
2569
|
|
|
|
|
|
return 1; /* Internal error, not I/O error */ |
2570
|
|
|
|
|
|
|
2571
|
|
|
|
|
|
/* Implementation of restricted hashes isn't nicely |
2572
|
|
|
|
|
|
abstracted: */ |
2573
|
|
|
|
|
|
flags |
2574
|
57579770
|
|
|
|
|
= (((hash_flags & SHV_RESTRICTED) |
2575
|
10232
|
|
|
|
|
&& SvTRULYREADONLY(val)) |
2576
|
|
|
|
|
|
? SHV_K_LOCKED : 0); |
2577
|
|
|
|
|
|
|
2578
|
57579770
|
|
|
|
|
if (val == &PL_sv_placeholder) { |
2579
|
10208
|
|
|
|
|
flags |= SHV_K_PLACEHOLDER; |
2580
|
|
|
|
|
|
val = &PL_sv_undef; |
2581
|
|
|
|
|
|
} |
2582
|
|
|
|
|
|
|
2583
|
|
|
|
|
|
/* |
2584
|
|
|
|
|
|
* Store value first. |
2585
|
|
|
|
|
|
*/ |
2586
|
|
|
|
|
|
|
2587
|
|
|
|
|
|
TRACEME(("(#%d) value 0x%"UVxf, i, PTR2UV(val))); |
2588
|
|
|
|
|
|
|
2589
|
57579770
|
|
|
|
|
if ((ret = store(aTHX_ cxt, val))) /* Extra () for -Wall, grr... */ |
2590
|
|
|
|
|
|
goto out; |
2591
|
|
|
|
|
|
|
2592
|
|
|
|
|
|
|
2593
|
57579770
|
|
|
|
|
hek = HeKEY_hek(he); |
2594
|
57579770
|
|
|
|
|
len = HEK_LEN(hek); |
2595
|
57579770
|
|
|
|
|
if (len == HEf_SVKEY) { |
2596
|
|
|
|
|
|
/* This is somewhat sick, but the internal APIs are |
2597
|
|
|
|
|
|
* such that XS code could put one of these in in |
2598
|
|
|
|
|
|
* a regular hash. |
2599
|
|
|
|
|
|
* Maybe we should be capable of storing one if |
2600
|
|
|
|
|
|
* found. |
2601
|
|
|
|
|
|
*/ |
2602
|
0
|
|
|
|
|
key_sv = HeKEY_sv(he); |
2603
|
0
|
|
|
|
|
flags |= SHV_K_ISSV; |
2604
|
|
|
|
|
|
} else { |
2605
|
|
|
|
|
|
/* Regular string key. */ |
2606
|
|
|
|
|
|
#ifdef HAS_HASH_KEY_FLAGS |
2607
|
57579770
|
|
|
|
|
if (HEK_UTF8(hek)) |
2608
|
29478
|
|
|
|
|
flags |= SHV_K_UTF8; |
2609
|
57579770
|
|
|
|
|
if (HEK_WASUTF8(hek)) |
2610
|
14370
|
|
|
|
|
flags |= SHV_K_WASUTF8; |
2611
|
|
|
|
|
|
#endif |
2612
|
57579770
|
|
|
|
|
key = HEK_KEY(hek); |
2613
|
|
|
|
|
|
} |
2614
|
|
|
|
|
|
/* |
2615
|
|
|
|
|
|
* Write key string. |
2616
|
|
|
|
|
|
* Keys are written after values to make sure retrieval |
2617
|
|
|
|
|
|
* can be optimal in terms of memory usage, where keys are |
2618
|
|
|
|
|
|
* read into a fixed unique buffer called kbuf. |
2619
|
|
|
|
|
|
* See retrieve_hash() for details. |
2620
|
|
|
|
|
|
*/ |
2621
|
|
|
|
|
|
|
2622
|
57579770
|
|
|
|
|
if (flagged_hash) { |
2623
|
56832
|
|
|
|
|
PUTMARK(flags); |
2624
|
|
|
|
|
|
TRACEME(("(#%d) key '%s' flags %x", i, key, flags)); |
2625
|
|
|
|
|
|
} else { |
2626
|
|
|
|
|
|
/* This is a workaround for a bug in 5.8.0 |
2627
|
|
|
|
|
|
that causes the HEK_WASUTF8 flag to be |
2628
|
|
|
|
|
|
set on an HEK without the hash being |
2629
|
|
|
|
|
|
marked as having key flags. We just |
2630
|
|
|
|
|
|
cross our fingers and drop the flag. |
2631
|
|
|
|
|
|
AMS 20030901 */ |
2632
|
|
|
|
|
|
assert (flags == 0 || flags == SHV_K_WASUTF8); |
2633
|
|
|
|
|
|
TRACEME(("(#%d) key '%s'", i, key)); |
2634
|
|
|
|
|
|
} |
2635
|
57579770
|
|
|
|
|
if (flags & SHV_K_ISSV) { |
2636
|
0
|
|
|
|
|
store(aTHX_ cxt, key_sv); |
2637
|
|
|
|
|
|
} else { |
2638
|
57619870
|
|
|
|
|
WLEN(len); |
2639
|
57579770
|
|
|
|
|
if (len) |
2640
|
57619852
|
|
|
|
|
WRITE(key, len); |
2641
|
|
|
|
|
|
} |
2642
|
|
|
|
|
|
} |
2643
|
|
|
|
|
|
} |
2644
|
|
|
|
|
|
|
2645
|
|
|
|
|
|
TRACEME(("ok (hash 0x%"UVxf")", PTR2UV(hv))); |
2646
|
|
|
|
|
|
|
2647
|
|
|
|
|
|
out: |
2648
|
14705400
|
|
|
|
|
HvRITER_set(hv, riter); /* Restore hash iterator state */ |
2649
|
14705400
|
|
|
|
|
HvEITER_set(hv, eiter); |
2650
|
|
|
|
|
|
|
2651
|
14705400
|
|
|
|
|
return ret; |
2652
|
|
|
|
|
|
} |
2653
|
|
|
|
|
|
|
2654
|
|
|
|
|
|
/* |
2655
|
|
|
|
|
|
* store_code |
2656
|
|
|
|
|
|
* |
2657
|
|
|
|
|
|
* Store a code reference. |
2658
|
|
|
|
|
|
* |
2659
|
|
|
|
|
|
* Layout is SX_CODE followed by a scalar containing the perl |
2660
|
|
|
|
|
|
* source code of the code reference. |
2661
|
|
|
|
|
|
*/ |
2662
|
16
|
|
|
|
|
static int store_code(pTHX_ stcxt_t *cxt, CV *cv) |
2663
|
|
|
|
|
|
{ |
2664
|
|
|
|
|
|
#if PERL_VERSION < 6 |
2665
|
|
|
|
|
|
/* |
2666
|
|
|
|
|
|
* retrieve_code does not work with perl 5.005 or less |
2667
|
|
|
|
|
|
*/ |
2668
|
|
|
|
|
|
return store_other(aTHX_ cxt, (SV*)cv); |
2669
|
|
|
|
|
|
#else |
2670
|
|
|
|
|
|
dSP; |
2671
|
|
|
|
|
|
I32 len; |
2672
|
|
|
|
|
|
int count, reallen; |
2673
|
|
|
|
|
|
SV *text, *bdeparse; |
2674
|
|
|
|
|
|
|
2675
|
|
|
|
|
|
TRACEME(("store_code (0x%"UVxf")", PTR2UV(cv))); |
2676
|
|
|
|
|
|
|
2677
|
16
|
|
|
|
|
if ( |
2678
|
32
|
|
|
|
|
cxt->deparse == 0 || |
2679
|
112
|
|
|
|
|
(cxt->deparse < 0 && !(cxt->deparse = |
2680
|
48
|
|
|
|
|
SvTRUE(perl_get_sv("Storable::Deparse", GV_ADD)) ? 1 : 0)) |
2681
|
|
|
|
|
|
) { |
2682
|
0
|
|
|
|
|
return store_other(aTHX_ cxt, (SV*)cv); |
2683
|
|
|
|
|
|
} |
2684
|
|
|
|
|
|
|
2685
|
|
|
|
|
|
/* |
2686
|
|
|
|
|
|
* Require B::Deparse. At least B::Deparse 0.61 is needed for |
2687
|
|
|
|
|
|
* blessed code references. |
2688
|
|
|
|
|
|
*/ |
2689
|
|
|
|
|
|
/* Ownership of both SVs is passed to load_module, which frees them. */ |
2690
|
16
|
|
|
|
|
load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("B::Deparse",10), newSVnv(0.61)); |
2691
|
16
|
|
|
|
|
SPAGAIN; |
2692
|
|
|
|
|
|
|
2693
|
16
|
|
|
|
|
ENTER; |
2694
|
16
|
|
|
|
|
SAVETMPS; |
2695
|
|
|
|
|
|
|
2696
|
|
|
|
|
|
/* |
2697
|
|
|
|
|
|
* create the B::Deparse object |
2698
|
|
|
|
|
|
*/ |
2699
|
|
|
|
|
|
|
2700
|
16
|
|
|
|
|
PUSHMARK(sp); |
2701
|
16
|
|
|
|
|
XPUSHs(newSVpvs_flags("B::Deparse", SVs_TEMP)); |
2702
|
16
|
|
|
|
|
PUTBACK; |
2703
|
16
|
|
|
|
|
count = call_method("new", G_SCALAR); |
2704
|
16
|
|
|
|
|
SPAGAIN; |
2705
|
16
|
|
|
|
|
if (count != 1) |
2706
|
0
|
|
|
|
|
CROAK(("Unexpected return value from B::Deparse::new\n")); |
2707
|
16
|
|
|
|
|
bdeparse = POPs; |
2708
|
|
|
|
|
|
|
2709
|
|
|
|
|
|
/* |
2710
|
|
|
|
|
|
* call the coderef2text method |
2711
|
|
|
|
|
|
*/ |
2712
|
|
|
|
|
|
|
2713
|
16
|
|
|
|
|
PUSHMARK(sp); |
2714
|
16
|
|
|
|
|
XPUSHs(bdeparse); /* XXX is this already mortal? */ |
2715
|
16
|
|
|
|
|
XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); |
2716
|
16
|
|
|
|
|
PUTBACK; |
2717
|
16
|
|
|
|
|
count = call_method("coderef2text", G_SCALAR); |
2718
|
16
|
|
|
|
|
SPAGAIN; |
2719
|
16
|
|
|
|
|
if (count != 1) |
2720
|
0
|
|
|
|
|
CROAK(("Unexpected return value from B::Deparse::coderef2text\n")); |
2721
|
|
|
|
|
|
|
2722
|
16
|
|
|
|
|
text = POPs; |
2723
|
16
|
|
|
|
|
len = SvCUR(text); |
2724
|
16
|
|
|
|
|
reallen = strlen(SvPV_nolen(text)); |
2725
|
|
|
|
|
|
|
2726
|
|
|
|
|
|
/* |
2727
|
|
|
|
|
|
* Empty code references or XS functions are deparsed as |
2728
|
|
|
|
|
|
* "(prototype) ;" or ";". |
2729
|
|
|
|
|
|
*/ |
2730
|
|
|
|
|
|
|
2731
|
16
|
|
|
|
|
if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { |
2732
|
0
|
|
|
|
|
CROAK(("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n")); |
2733
|
|
|
|
|
|
} |
2734
|
|
|
|
|
|
|
2735
|
|
|
|
|
|
/* |
2736
|
|
|
|
|
|
* Signal code by emitting SX_CODE. |
2737
|
|
|
|
|
|
*/ |
2738
|
|
|
|
|
|
|
2739
|
16
|
|
|
|
|
PUTMARK(SX_CODE); |
2740
|
16
|
|
|
|
|
cxt->tagnum++; /* necessary, as SX_CODE is a SEEN() candidate */ |
2741
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
2742
|
|
|
|
|
|
TRACEME(("code = %s", SvPV_nolen(text))); |
2743
|
|
|
|
|
|
|
2744
|
|
|
|
|
|
/* |
2745
|
|
|
|
|
|
* Now store the source code. |
2746
|
|
|
|
|
|
*/ |
2747
|
|
|
|
|
|
|
2748
|
16
|
|
|
|
|
if(SvUTF8 (text)) |
2749
|
0
|
|
|
|
|
STORE_UTF8STR(SvPV_nolen(text), len); |
2750
|
|
|
|
|
|
else |
2751
|
32
|
|
|
|
|
STORE_SCALAR(SvPV_nolen(text), len); |
2752
|
|
|
|
|
|
|
2753
|
16
|
|
|
|
|
FREETMPS; |
2754
|
16
|
|
|
|
|
LEAVE; |
2755
|
|
|
|
|
|
|
2756
|
|
|
|
|
|
TRACEME(("ok (code)")); |
2757
|
|
|
|
|
|
|
2758
|
16
|
|
|
|
|
return 0; |
2759
|
|
|
|
|
|
#endif |
2760
|
|
|
|
|
|
} |
2761
|
|
|
|
|
|
|
2762
|
|
|
|
|
|
/* |
2763
|
|
|
|
|
|
* store_tied |
2764
|
|
|
|
|
|
* |
2765
|
|
|
|
|
|
* When storing a tied object (be it a tied scalar, array or hash), we lay out |
2766
|
|
|
|
|
|
* a special mark, followed by the underlying tied object. For instance, when |
2767
|
|
|
|
|
|
* dealing with a tied hash, we store SX_TIED_HASH , where |
2768
|
|
|
|
|
|
* stands for the serialization of the tied hash. |
2769
|
|
|
|
|
|
*/ |
2770
|
34
|
|
|
|
|
static int store_tied(pTHX_ stcxt_t *cxt, SV *sv) |
2771
|
|
|
|
|
|
{ |
2772
|
|
|
|
|
|
MAGIC *mg; |
2773
|
|
|
|
|
|
SV *obj = NULL; |
2774
|
|
|
|
|
|
int ret = 0; |
2775
|
34
|
|
|
|
|
int svt = SvTYPE(sv); |
2776
|
|
|
|
|
|
char mtype = 'P'; |
2777
|
|
|
|
|
|
|
2778
|
|
|
|
|
|
TRACEME(("store_tied (0x%"UVxf")", PTR2UV(sv))); |
2779
|
|
|
|
|
|
|
2780
|
|
|
|
|
|
/* |
2781
|
|
|
|
|
|
* We have a small run-time penalty here because we chose to factorise |
2782
|
|
|
|
|
|
* all tieds objects into the same routine, and not have a store_tied_hash, |
2783
|
|
|
|
|
|
* a store_tied_array, etc... |
2784
|
|
|
|
|
|
* |
2785
|
|
|
|
|
|
* Don't use a switch() statement, as most compilers don't optimize that |
2786
|
|
|
|
|
|
* well for 2/3 values. An if() else if() cascade is just fine. We put |
2787
|
|
|
|
|
|
* tied hashes first, as they are the most likely beasts. |
2788
|
|
|
|
|
|
*/ |
2789
|
|
|
|
|
|
|
2790
|
34
|
|
|
|
|
if (svt == SVt_PVHV) { |
2791
|
|
|
|
|
|
TRACEME(("tied hash")); |
2792
|
14
|
|
|
|
|
PUTMARK(SX_TIED_HASH); /* Introduces tied hash */ |
2793
|
20
|
|
|
|
|
} else if (svt == SVt_PVAV) { |
2794
|
|
|
|
|
|
TRACEME(("tied array")); |
2795
|
8
|
|
|
|
|
PUTMARK(SX_TIED_ARRAY); /* Introduces tied array */ |
2796
|
|
|
|
|
|
} else { |
2797
|
|
|
|
|
|
TRACEME(("tied scalar")); |
2798
|
12
|
|
|
|
|
PUTMARK(SX_TIED_SCALAR); /* Introduces tied scalar */ |
2799
|
|
|
|
|
|
mtype = 'q'; |
2800
|
|
|
|
|
|
} |
2801
|
|
|
|
|
|
|
2802
|
34
|
|
|
|
|
if (!(mg = mg_find(sv, mtype))) |
2803
|
0
|
|
|
|
|
CROAK(("No magic '%c' found while storing tied %s", mtype, |
2804
|
|
|
|
|
|
(svt == SVt_PVHV) ? "hash" : |
2805
|
|
|
|
|
|
(svt == SVt_PVAV) ? "array" : "scalar")); |
2806
|
|
|
|
|
|
|
2807
|
|
|
|
|
|
/* |
2808
|
|
|
|
|
|
* The mg->mg_obj found by mg_find() above actually points to the |
2809
|
|
|
|
|
|
* underlying tied Perl object implementation. For instance, if the |
2810
|
|
|
|
|
|
* original SV was that of a tied array, then mg->mg_obj is an AV. |
2811
|
|
|
|
|
|
* |
2812
|
|
|
|
|
|
* Note that we store the Perl object as-is. We don't call its FETCH |
2813
|
|
|
|
|
|
* method along the way. At retrieval time, we won't call its STORE |
2814
|
|
|
|
|
|
* method either, but the tieing magic will be re-installed. In itself, |
2815
|
|
|
|
|
|
* that ensures that the tieing semantics are preserved since further |
2816
|
|
|
|
|
|
* accesses on the retrieved object will indeed call the magic methods... |
2817
|
|
|
|
|
|
*/ |
2818
|
|
|
|
|
|
|
2819
|
|
|
|
|
|
/* [#17040] mg_obj is NULL for scalar self-ties. AMS 20030416 */ |
2820
|
34
|
|
|
|
|
obj = mg->mg_obj ? mg->mg_obj : newSV(0); |
2821
|
34
|
|
|
|
|
if ((ret = store(aTHX_ cxt, obj))) |
2822
|
0
|
|
|
|
|
return ret; |
2823
|
|
|
|
|
|
|
2824
|
|
|
|
|
|
TRACEME(("ok (tied)")); |
2825
|
|
|
|
|
|
|
2826
|
|
|
|
|
|
return 0; |
2827
|
|
|
|
|
|
} |
2828
|
|
|
|
|
|
|
2829
|
|
|
|
|
|
/* |
2830
|
|
|
|
|
|
* store_tied_item |
2831
|
|
|
|
|
|
* |
2832
|
|
|
|
|
|
* Stores a reference to an item within a tied structure: |
2833
|
|
|
|
|
|
* |
2834
|
|
|
|
|
|
* . \$h{key}, stores both the (tied %h) object and 'key'. |
2835
|
|
|
|
|
|
* . \$a[idx], stores both the (tied @a) object and 'idx'. |
2836
|
|
|
|
|
|
* |
2837
|
|
|
|
|
|
* Layout is therefore either: |
2838
|
|
|
|
|
|
* SX_TIED_KEY |
2839
|
|
|
|
|
|
* SX_TIED_IDX |
2840
|
|
|
|
|
|
*/ |
2841
|
4
|
|
|
|
|
static int store_tied_item(pTHX_ stcxt_t *cxt, SV *sv) |
2842
|
|
|
|
|
|
{ |
2843
|
|
|
|
|
|
MAGIC *mg; |
2844
|
|
|
|
|
|
int ret; |
2845
|
|
|
|
|
|
|
2846
|
|
|
|
|
|
TRACEME(("store_tied_item (0x%"UVxf")", PTR2UV(sv))); |
2847
|
|
|
|
|
|
|
2848
|
4
|
|
|
|
|
if (!(mg = mg_find(sv, 'p'))) |
2849
|
0
|
|
|
|
|
CROAK(("No magic 'p' found while storing reference to tied item")); |
2850
|
|
|
|
|
|
|
2851
|
|
|
|
|
|
/* |
2852
|
|
|
|
|
|
* We discriminate between \$h{key} and \$a[idx] via mg_ptr. |
2853
|
|
|
|
|
|
*/ |
2854
|
|
|
|
|
|
|
2855
|
4
|
|
|
|
|
if (mg->mg_ptr) { |
2856
|
|
|
|
|
|
TRACEME(("store_tied_item: storing a ref to a tied hash item")); |
2857
|
2
|
|
|
|
|
PUTMARK(SX_TIED_KEY); |
2858
|
|
|
|
|
|
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); |
2859
|
|
|
|
|
|
|
2860
|
2
|
|
|
|
|
if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ |
2861
|
|
|
|
|
|
return ret; |
2862
|
|
|
|
|
|
|
2863
|
|
|
|
|
|
TRACEME(("store_tied_item: storing PTR 0x%"UVxf, PTR2UV(mg->mg_ptr))); |
2864
|
|
|
|
|
|
|
2865
|
2
|
|
|
|
|
if ((ret = store(aTHX_ cxt, (SV *) mg->mg_ptr))) /* Idem, for -Wall */ |
2866
|
|
|
|
|
|
return ret; |
2867
|
|
|
|
|
|
} else { |
2868
|
2
|
|
|
|
|
I32 idx = mg->mg_len; |
2869
|
|
|
|
|
|
|
2870
|
|
|
|
|
|
TRACEME(("store_tied_item: storing a ref to a tied array item ")); |
2871
|
2
|
|
|
|
|
PUTMARK(SX_TIED_IDX); |
2872
|
|
|
|
|
|
TRACEME(("store_tied_item: storing OBJ 0x%"UVxf, PTR2UV(mg->mg_obj))); |
2873
|
|
|
|
|
|
|
2874
|
2
|
|
|
|
|
if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Idem, for -Wall */ |
2875
|
|
|
|
|
|
return ret; |
2876
|
|
|
|
|
|
|
2877
|
|
|
|
|
|
TRACEME(("store_tied_item: storing IDX %d", idx)); |
2878
|
|
|
|
|
|
|
2879
|
4
|
|
|
|
|
WLEN(idx); |
2880
|
|
|
|
|
|
} |
2881
|
|
|
|
|
|
|
2882
|
|
|
|
|
|
TRACEME(("ok (tied item)")); |
2883
|
|
|
|
|
|
|
2884
|
4
|
|
|
|
|
return 0; |
2885
|
|
|
|
|
|
} |
2886
|
|
|
|
|
|
|
2887
|
|
|
|
|
|
/* |
2888
|
|
|
|
|
|
* store_hook -- dispatched manually, not via sv_store[] |
2889
|
|
|
|
|
|
* |
2890
|
|
|
|
|
|
* The blessed SV is serialized by a hook. |
2891
|
|
|
|
|
|
* |
2892
|
|
|
|
|
|
* Simple Layout is: |
2893
|
|
|
|
|
|
* |
2894
|
|
|
|
|
|
* SX_HOOK [ ] |
2895
|
|
|
|
|
|
* |
2896
|
|
|
|
|
|
* where indicates how long , and are, whether |
2897
|
|
|
|
|
|
* the trailing part [] is present, the type of object (scalar, array or hash). |
2898
|
|
|
|
|
|
* There is also a bit which says how the classname is stored between: |
2899
|
|
|
|
|
|
* |
2900
|
|
|
|
|
|
* |
2901
|
|
|
|
|
|
* |
2902
|
|
|
|
|
|
* |
2903
|
|
|
|
|
|
* and when the form is used (classname already seen), the "large |
2904
|
|
|
|
|
|
* classname" bit in indicates how large the is. |
2905
|
|
|
|
|
|
* |
2906
|
|
|
|
|
|
* The serialized string returned by the hook is of length and comes |
2907
|
|
|
|
|
|
* next. It is an opaque string for us. |
2908
|
|
|
|
|
|
* |
2909
|
|
|
|
|
|
* Those object IDs which are listed last represent the extra references |
2910
|
|
|
|
|
|
* not directly serialized by the hook, but which are linked to the object. |
2911
|
|
|
|
|
|
* |
2912
|
|
|
|
|
|
* When recursion is mandated to resolve object-IDs not yet seen, we have |
2913
|
|
|
|
|
|
* instead, with being flags with bits set to indicate the object type |
2914
|
|
|
|
|
|
* and that recursion was indeed needed: |
2915
|
|
|
|
|
|
* |
2916
|
|
|
|
|
|
* SX_HOOK |
2917
|
|
|
|
|
|
* |
2918
|
|
|
|
|
|
* that same header being repeated between serialized objects obtained through |
2919
|
|
|
|
|
|
* recursion, until we reach flags indicating no recursion, at which point |
2920
|
|
|
|
|
|
* we know we've resynchronized with a single layout, after . |
2921
|
|
|
|
|
|
* |
2922
|
|
|
|
|
|
* When storing a blessed ref to a tied variable, the following format is |
2923
|
|
|
|
|
|
* used: |
2924
|
|
|
|
|
|
* |
2925
|
|
|
|
|
|
* SX_HOOK ... [ ] |
2926
|
|
|
|
|
|
* |
2927
|
|
|
|
|
|
* The first indication carries an object of type SHT_EXTRA, and the |
2928
|
|
|
|
|
|
* real object type is held in the flag. At the very end of the |
2929
|
|
|
|
|
|
* serialization stream, the underlying magic object is serialized, just like |
2930
|
|
|
|
|
|
* any other tied variable. |
2931
|
|
|
|
|
|
*/ |
2932
|
212
|
|
|
|
|
static int store_hook( |
2933
|
|
|
|
|
|
pTHX_ |
2934
|
|
|
|
|
|
stcxt_t *cxt, |
2935
|
|
|
|
|
|
SV *sv, |
2936
|
|
|
|
|
|
int type, |
2937
|
|
|
|
|
|
HV *pkg, |
2938
|
|
|
|
|
|
SV *hook) |
2939
|
|
|
|
|
|
{ |
2940
|
|
|
|
|
|
I32 len; |
2941
|
|
|
|
|
|
char *classname; |
2942
|
|
|
|
|
|
STRLEN len2; |
2943
|
|
|
|
|
|
SV *ref; |
2944
|
|
|
|
|
|
AV *av; |
2945
|
|
|
|
|
|
SV **ary; |
2946
|
|
|
|
|
|
int count; /* really len3 + 1 */ |
2947
|
|
|
|
|
|
unsigned char flags; |
2948
|
|
|
|
|
|
char *pv; |
2949
|
|
|
|
|
|
int i; |
2950
|
|
|
|
|
|
int recursed = 0; /* counts recursion */ |
2951
|
|
|
|
|
|
int obj_type; /* object type, on 2 bits */ |
2952
|
|
|
|
|
|
I32 classnum; |
2953
|
|
|
|
|
|
int ret; |
2954
|
212
|
|
|
|
|
int clone = cxt->optype & ST_CLONE; |
2955
|
|
|
|
|
|
char mtype = '\0'; /* for blessed ref to tied structures */ |
2956
|
|
|
|
|
|
unsigned char eflags = '\0'; /* used when object type is SHT_EXTRA */ |
2957
|
|
|
|
|
|
|
2958
|
|
|
|
|
|
TRACEME(("store_hook, classname \"%s\", tagged #%d", HvNAME_get(pkg), cxt->tagnum)); |
2959
|
|
|
|
|
|
|
2960
|
|
|
|
|
|
/* |
2961
|
|
|
|
|
|
* Determine object type on 2 bits. |
2962
|
|
|
|
|
|
*/ |
2963
|
|
|
|
|
|
|
2964
|
212
|
|
|
|
|
switch (type) { |
2965
|
|
|
|
|
|
case svis_REF: |
2966
|
|
|
|
|
|
case svis_SCALAR: |
2967
|
|
|
|
|
|
obj_type = SHT_SCALAR; |
2968
|
|
|
|
|
|
break; |
2969
|
|
|
|
|
|
case svis_ARRAY: |
2970
|
|
|
|
|
|
obj_type = SHT_ARRAY; |
2971
|
150
|
|
|
|
|
break; |
2972
|
|
|
|
|
|
case svis_HASH: |
2973
|
|
|
|
|
|
obj_type = SHT_HASH; |
2974
|
48
|
|
|
|
|
break; |
2975
|
|
|
|
|
|
case svis_TIED: |
2976
|
|
|
|
|
|
/* |
2977
|
|
|
|
|
|
* Produced by a blessed ref to a tied data structure, $o in the |
2978
|
|
|
|
|
|
* following Perl code. |
2979
|
|
|
|
|
|
* |
2980
|
|
|
|
|
|
* my %h; |
2981
|
|
|
|
|
|
* tie %h, 'FOO'; |
2982
|
|
|
|
|
|
* my $o = bless \%h, 'BAR'; |
2983
|
|
|
|
|
|
* |
2984
|
|
|
|
|
|
* Signal the tie-ing magic by setting the object type as SHT_EXTRA |
2985
|
|
|
|
|
|
* (since we have only 2 bits in to store the type), and an |
2986
|
|
|
|
|
|
* byte flag will be emitted after the FIRST in the |
2987
|
|
|
|
|
|
* stream, carrying what we put in 'eflags'. |
2988
|
|
|
|
|
|
*/ |
2989
|
|
|
|
|
|
obj_type = SHT_EXTRA; |
2990
|
2
|
|
|
|
|
switch (SvTYPE(sv)) { |
2991
|
|
|
|
|
|
case SVt_PVHV: |
2992
|
|
|
|
|
|
eflags = (unsigned char) SHT_THASH; |
2993
|
|
|
|
|
|
mtype = 'P'; |
2994
|
|
|
|
|
|
break; |
2995
|
|
|
|
|
|
case SVt_PVAV: |
2996
|
|
|
|
|
|
eflags = (unsigned char) SHT_TARRAY; |
2997
|
|
|
|
|
|
mtype = 'P'; |
2998
|
|
|
|
|
|
break; |
2999
|
|
|
|
|
|
default: |
3000
|
|
|
|
|
|
eflags = (unsigned char) SHT_TSCALAR; |
3001
|
|
|
|
|
|
mtype = 'q'; |
3002
|
|
|
|
|
|
break; |
3003
|
|
|
|
|
|
} |
3004
|
|
|
|
|
|
break; |
3005
|
|
|
|
|
|
default: |
3006
|
0
|
|
|
|
|
CROAK(("Unexpected object type (%d) in store_hook()", type)); |
3007
|
|
|
|
|
|
} |
3008
|
212
|
|
|
|
|
flags = SHF_NEED_RECURSE | obj_type; |
3009
|
|
|
|
|
|
|
3010
|
212
|
|
|
|
|
classname = HvNAME_get(pkg); |
3011
|
212
|
|
|
|
|
len = strlen(classname); |
3012
|
|
|
|
|
|
|
3013
|
|
|
|
|
|
/* |
3014
|
|
|
|
|
|
* To call the hook, we need to fake a call like: |
3015
|
|
|
|
|
|
* |
3016
|
|
|
|
|
|
* $object->STORABLE_freeze($cloning); |
3017
|
|
|
|
|
|
* |
3018
|
|
|
|
|
|
* but we don't have the $object here. For instance, if $object is |
3019
|
|
|
|
|
|
* a blessed array, what we have in 'sv' is the array, and we can't |
3020
|
|
|
|
|
|
* call a method on those. |
3021
|
|
|
|
|
|
* |
3022
|
|
|
|
|
|
* Therefore, we need to create a temporary reference to the object and |
3023
|
|
|
|
|
|
* make the call on that reference. |
3024
|
|
|
|
|
|
*/ |
3025
|
|
|
|
|
|
|
3026
|
|
|
|
|
|
TRACEME(("about to call STORABLE_freeze on class %s", classname)); |
3027
|
|
|
|
|
|
|
3028
|
212
|
|
|
|
|
ref = newRV_inc(sv); /* Temporary reference */ |
3029
|
212
|
|
|
|
|
av = array_call(aTHX_ ref, hook, clone); /* @a = $object->STORABLE_freeze($c) */ |
3030
|
212
|
|
|
|
|
SvREFCNT_dec(ref); /* Reclaim temporary reference */ |
3031
|
|
|
|
|
|
|
3032
|
212
|
|
|
|
|
count = AvFILLp(av) + 1; |
3033
|
|
|
|
|
|
TRACEME(("store_hook, array holds %d items", count)); |
3034
|
|
|
|
|
|
|
3035
|
|
|
|
|
|
/* |
3036
|
|
|
|
|
|
* If they return an empty list, it means they wish to ignore the |
3037
|
|
|
|
|
|
* hook for this class (and not just this instance -- that's for them |
3038
|
|
|
|
|
|
* to handle if they so wish). |
3039
|
|
|
|
|
|
* |
3040
|
|
|
|
|
|
* Simply disable the cached entry for the hook (it won't be recomputed |
3041
|
|
|
|
|
|
* since it's present in the cache) and recurse to store_blessed(). |
3042
|
|
|
|
|
|
*/ |
3043
|
|
|
|
|
|
|
3044
|
212
|
|
|
|
|
if (!count) { |
3045
|
|
|
|
|
|
/* |
3046
|
|
|
|
|
|
* They must not change their mind in the middle of a serialization. |
3047
|
|
|
|
|
|
*/ |
3048
|
|
|
|
|
|
|
3049
|
10
|
|
|
|
|
if (hv_fetch(cxt->hclass, classname, len, FALSE)) |
3050
|
0
|
|
|
|
|
CROAK(("Too late to ignore hooks for %s class \"%s\"", |
3051
|
|
|
|
|
|
(cxt->optype & ST_CLONE) ? "cloning" : "storing", classname)); |
3052
|
|
|
|
|
|
|
3053
|
10
|
|
|
|
|
pkg_hide(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); |
3054
|
|
|
|
|
|
|
3055
|
|
|
|
|
|
ASSERT(!pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"), ("hook invisible")); |
3056
|
|
|
|
|
|
TRACEME(("ignoring STORABLE_freeze in class \"%s\"", classname)); |
3057
|
|
|
|
|
|
|
3058
|
10
|
|
|
|
|
return store_blessed(aTHX_ cxt, sv, type, pkg); |
3059
|
|
|
|
|
|
} |
3060
|
|
|
|
|
|
|
3061
|
|
|
|
|
|
/* |
3062
|
|
|
|
|
|
* Get frozen string. |
3063
|
|
|
|
|
|
*/ |
3064
|
|
|
|
|
|
|
3065
|
202
|
|
|
|
|
ary = AvARRAY(av); |
3066
|
202
|
|
|
|
|
pv = SvPV(ary[0], len2); |
3067
|
|
|
|
|
|
/* We can't use pkg_can here because it only caches one method per |
3068
|
|
|
|
|
|
* package */ |
3069
|
|
|
|
|
|
{ |
3070
|
202
|
|
|
|
|
GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE); |
3071
|
202
|
|
|
|
|
if (gv && isGV(gv)) { |
3072
|
16
|
|
|
|
|
if (count > 1) |
3073
|
2
|
|
|
|
|
CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname)); |
3074
|
|
|
|
|
|
goto check_done; |
3075
|
|
|
|
|
|
} |
3076
|
|
|
|
|
|
} |
3077
|
|
|
|
|
|
|
3078
|
|
|
|
|
|
/* |
3079
|
|
|
|
|
|
* If they returned more than one item, we need to serialize some |
3080
|
|
|
|
|
|
* extra references if not already done. |
3081
|
|
|
|
|
|
* |
3082
|
|
|
|
|
|
* Loop over the array, starting at position #1, and for each item, |
3083
|
|
|
|
|
|
* ensure it is a reference, serialize it if not already done, and |
3084
|
|
|
|
|
|
* replace the entry with the tag ID of the corresponding serialized |
3085
|
|
|
|
|
|
* object. |
3086
|
|
|
|
|
|
* |
3087
|
|
|
|
|
|
* We CHEAT by not calling av_fetch() and read directly within the |
3088
|
|
|
|
|
|
* array, for speed. |
3089
|
|
|
|
|
|
*/ |
3090
|
|
|
|
|
|
|
3091
|
196
|
|
|
|
|
for (i = 1; i < count; i++) { |
3092
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3093
|
|
|
|
|
|
char *fake_tag; |
3094
|
|
|
|
|
|
#else |
3095
|
|
|
|
|
|
SV **svh; |
3096
|
|
|
|
|
|
#endif |
3097
|
196
|
|
|
|
|
SV *rsv = ary[i]; |
3098
|
|
|
|
|
|
SV *xsv; |
3099
|
|
|
|
|
|
SV *tag; |
3100
|
196
|
|
|
|
|
AV *av_hook = cxt->hook_seen; |
3101
|
|
|
|
|
|
|
3102
|
196
|
|
|
|
|
if (!SvROK(rsv)) |
3103
|
0
|
|
|
|
|
CROAK(("Item #%d returned by STORABLE_freeze " |
3104
|
|
|
|
|
|
"for %s is not a reference", i, classname)); |
3105
|
196
|
|
|
|
|
xsv = SvRV(rsv); /* Follow ref to know what to look for */ |
3106
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
/* |
3108
|
|
|
|
|
|
* Look in hseen and see if we have a tag already. |
3109
|
|
|
|
|
|
* Serialize entry if not done already, and get its tag. |
3110
|
|
|
|
|
|
*/ |
3111
|
|
|
|
|
|
|
3112
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3113
|
|
|
|
|
|
/* Fakery needed because ptr_table_fetch returns zero for a |
3114
|
|
|
|
|
|
failure, whereas the existing code assumes that it can |
3115
|
|
|
|
|
|
safely store a tag zero. So for ptr_tables we store tag+1 |
3116
|
|
|
|
|
|
*/ |
3117
|
196
|
|
|
|
|
if ((fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv))) |
3118
|
|
|
|
|
|
goto sv_seen; /* Avoid moving code too far to the right */ |
3119
|
|
|
|
|
|
#else |
3120
|
|
|
|
|
|
if ((svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE))) |
3121
|
|
|
|
|
|
goto sv_seen; /* Avoid moving code too far to the right */ |
3122
|
|
|
|
|
|
#endif |
3123
|
|
|
|
|
|
|
3124
|
|
|
|
|
|
TRACEME(("listed object %d at 0x%"UVxf" is unknown", i-1, PTR2UV(xsv))); |
3125
|
|
|
|
|
|
|
3126
|
|
|
|
|
|
/* |
3127
|
|
|
|
|
|
* We need to recurse to store that object and get it to be known |
3128
|
|
|
|
|
|
* so that we can resolve the list of object-IDs at retrieve time. |
3129
|
|
|
|
|
|
* |
3130
|
|
|
|
|
|
* The first time we do this, we need to emit the proper header |
3131
|
|
|
|
|
|
* indicating that we recursed, and what the type of object is (the |
3132
|
|
|
|
|
|
* object we're storing via a user-hook). Indeed, during retrieval, |
3133
|
|
|
|
|
|
* we'll have to create the object before recursing to retrieve the |
3134
|
|
|
|
|
|
* others, in case those would point back at that object. |
3135
|
|
|
|
|
|
*/ |
3136
|
|
|
|
|
|
|
3137
|
|
|
|
|
|
/* [SX_HOOK] [] */ |
3138
|
38
|
|
|
|
|
if (!recursed++) { |
3139
|
34
|
|
|
|
|
PUTMARK(SX_HOOK); |
3140
|
34
|
|
|
|
|
PUTMARK(flags); |
3141
|
34
|
|
|
|
|
if (obj_type == SHT_EXTRA) |
3142
|
0
|
|
|
|
|
PUTMARK(eflags); |
3143
|
|
|
|
|
|
} else |
3144
|
4
|
|
|
|
|
PUTMARK(flags); |
3145
|
|
|
|
|
|
|
3146
|
38
|
|
|
|
|
if ((ret = store(aTHX_ cxt, xsv))) /* Given by hook for us to store */ |
3147
|
|
|
|
|
|
return ret; |
3148
|
|
|
|
|
|
|
3149
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3150
|
38
|
|
|
|
|
fake_tag = (char *)ptr_table_fetch(cxt->pseen, xsv); |
3151
|
38
|
|
|
|
|
if (!sv) |
3152
|
0
|
|
|
|
|
CROAK(("Could not serialize item #%d from hook in %s", i, classname)); |
3153
|
|
|
|
|
|
#else |
3154
|
|
|
|
|
|
svh = hv_fetch(cxt->hseen, (char *) &xsv, sizeof(xsv), FALSE); |
3155
|
|
|
|
|
|
if (!svh) |
3156
|
|
|
|
|
|
CROAK(("Could not serialize item #%d from hook in %s", i, classname)); |
3157
|
|
|
|
|
|
#endif |
3158
|
|
|
|
|
|
/* |
3159
|
|
|
|
|
|
* It was the first time we serialized 'xsv'. |
3160
|
|
|
|
|
|
* |
3161
|
|
|
|
|
|
* Keep this SV alive until the end of the serialization: if we |
3162
|
|
|
|
|
|
* disposed of it right now by decrementing its refcount, and it was |
3163
|
|
|
|
|
|
* a temporary value, some next temporary value allocated during |
3164
|
|
|
|
|
|
* another STORABLE_freeze might take its place, and we'd wrongly |
3165
|
|
|
|
|
|
* assume that new SV was already serialized, based on its presence |
3166
|
|
|
|
|
|
* in cxt->hseen. |
3167
|
|
|
|
|
|
* |
3168
|
|
|
|
|
|
* Therefore, push it away in cxt->hook_seen. |
3169
|
|
|
|
|
|
*/ |
3170
|
|
|
|
|
|
|
3171
|
38
|
|
|
|
|
av_store(av_hook, AvFILLp(av_hook)+1, SvREFCNT_inc(xsv)); |
3172
|
|
|
|
|
|
|
3173
|
|
|
|
|
|
sv_seen: |
3174
|
|
|
|
|
|
/* |
3175
|
|
|
|
|
|
* Dispose of the REF they returned. If we saved the 'xsv' away |
3176
|
|
|
|
|
|
* in the array of returned SVs, that will not cause the underlying |
3177
|
|
|
|
|
|
* referenced SV to be reclaimed. |
3178
|
|
|
|
|
|
*/ |
3179
|
|
|
|
|
|
|
3180
|
|
|
|
|
|
ASSERT(SvREFCNT(xsv) > 1, ("SV will survive disposal of its REF")); |
3181
|
196
|
|
|
|
|
SvREFCNT_dec(rsv); /* Dispose of reference */ |
3182
|
|
|
|
|
|
|
3183
|
|
|
|
|
|
/* |
3184
|
|
|
|
|
|
* Replace entry with its tag (not a real SV, so no refcnt increment) |
3185
|
|
|
|
|
|
*/ |
3186
|
|
|
|
|
|
|
3187
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3188
|
196
|
|
|
|
|
tag = (SV *)--fake_tag; |
3189
|
|
|
|
|
|
#else |
3190
|
|
|
|
|
|
tag = *svh; |
3191
|
|
|
|
|
|
#endif |
3192
|
196
|
|
|
|
|
ary[i] = tag; |
3193
|
|
|
|
|
|
TRACEME(("listed object %d at 0x%"UVxf" is tag #%"UVuf, |
3194
|
|
|
|
|
|
i-1, PTR2UV(xsv), PTR2UV(tag))); |
3195
|
|
|
|
|
|
} |
3196
|
|
|
|
|
|
|
3197
|
|
|
|
|
|
/* |
3198
|
|
|
|
|
|
* Allocate a class ID if not already done. |
3199
|
|
|
|
|
|
* |
3200
|
|
|
|
|
|
* This needs to be done after the recursion above, since at retrieval |
3201
|
|
|
|
|
|
* time, we'll see the inner objects first. Many thanks to |
3202
|
|
|
|
|
|
* Salvador Ortiz Garcia who spot that bug and |
3203
|
|
|
|
|
|
* proposed the right fix. -- RAM, 15/09/2000 |
3204
|
|
|
|
|
|
*/ |
3205
|
|
|
|
|
|
|
3206
|
|
|
|
|
|
check_done: |
3207
|
200
|
|
|
|
|
if (!known_class(aTHX_ cxt, classname, len, &classnum)) { |
3208
|
|
|
|
|
|
TRACEME(("first time we see class %s, ID = %d", classname, classnum)); |
3209
|
162
|
|
|
|
|
classnum = -1; /* Mark: we must store classname */ |
3210
|
|
|
|
|
|
} else { |
3211
|
|
|
|
|
|
TRACEME(("already seen class %s, ID = %d", classname, classnum)); |
3212
|
|
|
|
|
|
} |
3213
|
|
|
|
|
|
|
3214
|
|
|
|
|
|
/* |
3215
|
|
|
|
|
|
* Compute leading flags. |
3216
|
|
|
|
|
|
*/ |
3217
|
|
|
|
|
|
|
3218
|
200
|
|
|
|
|
flags = obj_type; |
3219
|
200
|
|
|
|
|
if (((classnum == -1) ? len : classnum) > LG_SCALAR) |
3220
|
0
|
|
|
|
|
flags |= SHF_LARGE_CLASSLEN; |
3221
|
200
|
|
|
|
|
if (classnum != -1) |
3222
|
38
|
|
|
|
|
flags |= SHF_IDX_CLASSNAME; |
3223
|
200
|
|
|
|
|
if (len2 > LG_SCALAR) |
3224
|
48
|
|
|
|
|
flags |= SHF_LARGE_STRLEN; |
3225
|
200
|
|
|
|
|
if (count > 1) |
3226
|
160
|
|
|
|
|
flags |= SHF_HAS_LIST; |
3227
|
200
|
|
|
|
|
if (count > (LG_SCALAR + 1)) |
3228
|
0
|
|
|
|
|
flags |= SHF_LARGE_LISTLEN; |
3229
|
|
|
|
|
|
|
3230
|
|
|
|
|
|
/* |
3231
|
|
|
|
|
|
* We're ready to emit either serialized form: |
3232
|
|
|
|
|
|
* |
3233
|
|
|
|
|
|
* SX_HOOK [ ] |
3234
|
|
|
|
|
|
* SX_HOOK [ ] |
3235
|
|
|
|
|
|
* |
3236
|
|
|
|
|
|
* If we recursed, the SX_HOOK has already been emitted. |
3237
|
|
|
|
|
|
*/ |
3238
|
|
|
|
|
|
|
3239
|
|
|
|
|
|
TRACEME(("SX_HOOK (recursed=%d) flags=0x%x " |
3240
|
|
|
|
|
|
"class=%"IVdf" len=%"IVdf" len2=%"IVdf" len3=%d", |
3241
|
|
|
|
|
|
recursed, flags, (IV)classnum, (IV)len, (IV)len2, count-1)); |
3242
|
|
|
|
|
|
|
3243
|
|
|
|
|
|
/* SX_HOOK [] */ |
3244
|
200
|
|
|
|
|
if (!recursed) { |
3245
|
166
|
|
|
|
|
PUTMARK(SX_HOOK); |
3246
|
166
|
|
|
|
|
PUTMARK(flags); |
3247
|
166
|
|
|
|
|
if (obj_type == SHT_EXTRA) |
3248
|
2
|
|
|
|
|
PUTMARK(eflags); |
3249
|
|
|
|
|
|
} else |
3250
|
34
|
|
|
|
|
PUTMARK(flags); |
3251
|
|
|
|
|
|
|
3252
|
|
|
|
|
|
/* or */ |
3253
|
200
|
|
|
|
|
if (flags & SHF_IDX_CLASSNAME) { |
3254
|
38
|
|
|
|
|
if (flags & SHF_LARGE_CLASSLEN) |
3255
|
0
|
|
|
|
|
WLEN(classnum); |
3256
|
|
|
|
|
|
else { |
3257
|
38
|
|
|
|
|
unsigned char cnum = (unsigned char) classnum; |
3258
|
38
|
|
|
|
|
PUTMARK(cnum); |
3259
|
|
|
|
|
|
} |
3260
|
|
|
|
|
|
} else { |
3261
|
162
|
|
|
|
|
if (flags & SHF_LARGE_CLASSLEN) |
3262
|
0
|
|
|
|
|
WLEN(len); |
3263
|
|
|
|
|
|
else { |
3264
|
162
|
|
|
|
|
unsigned char clen = (unsigned char) len; |
3265
|
162
|
|
|
|
|
PUTMARK(clen); |
3266
|
|
|
|
|
|
} |
3267
|
322
|
|
|
|
|
WRITE(classname, len); /* Final \0 is omitted */ |
3268
|
|
|
|
|
|
} |
3269
|
|
|
|
|
|
|
3270
|
|
|
|
|
|
/* */ |
3271
|
200
|
|
|
|
|
if (flags & SHF_LARGE_STRLEN) { |
3272
|
48
|
|
|
|
|
I32 wlen2 = len2; /* STRLEN might be 8 bytes */ |
3273
|
96
|
|
|
|
|
WLEN(wlen2); /* Must write an I32 for 64-bit machines */ |
3274
|
|
|
|
|
|
} else { |
3275
|
152
|
|
|
|
|
unsigned char clen = (unsigned char) len2; |
3276
|
152
|
|
|
|
|
PUTMARK(clen); |
3277
|
|
|
|
|
|
} |
3278
|
200
|
|
|
|
|
if (len2) |
3279
|
264
|
|
|
|
|
WRITE(pv, (SSize_t)len2); /* Final \0 is omitted */ |
3280
|
|
|
|
|
|
|
3281
|
|
|
|
|
|
/* [ ] */ |
3282
|
200
|
|
|
|
|
if (flags & SHF_HAS_LIST) { |
3283
|
160
|
|
|
|
|
int len3 = count - 1; |
3284
|
160
|
|
|
|
|
if (flags & SHF_LARGE_LISTLEN) |
3285
|
0
|
|
|
|
|
WLEN(len3); |
3286
|
|
|
|
|
|
else { |
3287
|
160
|
|
|
|
|
unsigned char clen = (unsigned char) len3; |
3288
|
160
|
|
|
|
|
PUTMARK(clen); |
3289
|
|
|
|
|
|
} |
3290
|
|
|
|
|
|
|
3291
|
|
|
|
|
|
/* |
3292
|
|
|
|
|
|
* NOTA BENE, for 64-bit machines: the ary[i] below does not yield a |
3293
|
|
|
|
|
|
* real pointer, rather a tag number, well under the 32-bit limit. |
3294
|
|
|
|
|
|
*/ |
3295
|
|
|
|
|
|
|
3296
|
196
|
|
|
|
|
for (i = 1; i < count; i++) { |
3297
|
196
|
|
|
|
|
I32 tagval = htonl(LOW_32BITS(ary[i])); |
3298
|
392
|
|
|
|
|
WRITE_I32(tagval); |
3299
|
|
|
|
|
|
TRACEME(("object %d, tag #%d", i-1, ntohl(tagval))); |
3300
|
|
|
|
|
|
} |
3301
|
|
|
|
|
|
} |
3302
|
|
|
|
|
|
|
3303
|
|
|
|
|
|
/* |
3304
|
|
|
|
|
|
* Free the array. We need extra care for indices after 0, since they |
3305
|
|
|
|
|
|
* don't hold real SVs but integers cast. |
3306
|
|
|
|
|
|
*/ |
3307
|
|
|
|
|
|
|
3308
|
200
|
|
|
|
|
if (count > 1) |
3309
|
160
|
|
|
|
|
AvFILLp(av) = 0; /* Cheat, nothing after 0 interests us */ |
3310
|
200
|
|
|
|
|
av_undef(av); |
3311
|
200
|
|
|
|
|
sv_free((SV *) av); |
3312
|
|
|
|
|
|
|
3313
|
|
|
|
|
|
/* |
3314
|
|
|
|
|
|
* If object was tied, need to insert serialization of the magic object. |
3315
|
|
|
|
|
|
*/ |
3316
|
|
|
|
|
|
|
3317
|
200
|
|
|
|
|
if (obj_type == SHT_EXTRA) { |
3318
|
|
|
|
|
|
MAGIC *mg; |
3319
|
|
|
|
|
|
|
3320
|
2
|
|
|
|
|
if (!(mg = mg_find(sv, mtype))) { |
3321
|
0
|
|
|
|
|
int svt = SvTYPE(sv); |
3322
|
0
|
|
|
|
|
CROAK(("No magic '%c' found while storing ref to tied %s with hook", |
3323
|
|
|
|
|
|
mtype, (svt == SVt_PVHV) ? "hash" : |
3324
|
|
|
|
|
|
(svt == SVt_PVAV) ? "array" : "scalar")); |
3325
|
|
|
|
|
|
} |
3326
|
|
|
|
|
|
|
3327
|
|
|
|
|
|
TRACEME(("handling the magic object 0x%"UVxf" part of 0x%"UVxf, |
3328
|
|
|
|
|
|
PTR2UV(mg->mg_obj), PTR2UV(sv))); |
3329
|
|
|
|
|
|
|
3330
|
|
|
|
|
|
/* |
3331
|
|
|
|
|
|
* [] |
3332
|
|
|
|
|
|
*/ |
3333
|
|
|
|
|
|
|
3334
|
2
|
|
|
|
|
if ((ret = store(aTHX_ cxt, mg->mg_obj))) /* Extra () for -Wall, grr... */ |
3335
|
0
|
|
|
|
|
return ret; |
3336
|
|
|
|
|
|
} |
3337
|
|
|
|
|
|
|
3338
|
|
|
|
|
|
return 0; |
3339
|
|
|
|
|
|
} |
3340
|
|
|
|
|
|
|
3341
|
|
|
|
|
|
/* |
3342
|
|
|
|
|
|
* store_blessed -- dispatched manually, not via sv_store[] |
3343
|
|
|
|
|
|
* |
3344
|
|
|
|
|
|
* Check whether there is a STORABLE_xxx hook defined in the class or in one |
3345
|
|
|
|
|
|
* of its ancestors. If there is, then redispatch to store_hook(); |
3346
|
|
|
|
|
|
* |
3347
|
|
|
|
|
|
* Otherwise, the blessed SV is stored using the following layout: |
3348
|
|
|
|
|
|
* |
3349
|
|
|
|
|
|
* SX_BLESS |
3350
|
|
|
|
|
|
* |
3351
|
|
|
|
|
|
* where indicates whether is stored on 0 or 4 bytes, depending |
3352
|
|
|
|
|
|
* on the high-order bit in flag: if 1, then length follows on 4 bytes. |
3353
|
|
|
|
|
|
* Otherwise, the low order bits give the length, thereby giving a compact |
3354
|
|
|
|
|
|
* representation for class names less than 127 chars long. |
3355
|
|
|
|
|
|
* |
3356
|
|
|
|
|
|
* Each seen is remembered and indexed, so that the next time |
3357
|
|
|
|
|
|
* an object in the blessed in the same is stored, the following |
3358
|
|
|
|
|
|
* will be emitted: |
3359
|
|
|
|
|
|
* |
3360
|
|
|
|
|
|
* SX_IX_BLESS |
3361
|
|
|
|
|
|
* |
3362
|
|
|
|
|
|
* where is the classname index, stored on 0 or 4 bytes depending |
3363
|
|
|
|
|
|
* on the high-order bit in flag (same encoding as above for ). |
3364
|
|
|
|
|
|
*/ |
3365
|
424
|
|
|
|
|
static int store_blessed( |
3366
|
|
|
|
|
|
pTHX_ |
3367
|
|
|
|
|
|
stcxt_t *cxt, |
3368
|
|
|
|
|
|
SV *sv, |
3369
|
|
|
|
|
|
int type, |
3370
|
|
|
|
|
|
HV *pkg) |
3371
|
|
|
|
|
|
{ |
3372
|
|
|
|
|
|
SV *hook; |
3373
|
|
|
|
|
|
I32 len; |
3374
|
|
|
|
|
|
char *classname; |
3375
|
|
|
|
|
|
I32 classnum; |
3376
|
|
|
|
|
|
|
3377
|
|
|
|
|
|
TRACEME(("store_blessed, type %d, class \"%s\"", type, HvNAME_get(pkg))); |
3378
|
|
|
|
|
|
|
3379
|
|
|
|
|
|
/* |
3380
|
|
|
|
|
|
* Look for a hook for this blessed SV and redirect to store_hook() |
3381
|
|
|
|
|
|
* if needed. |
3382
|
|
|
|
|
|
*/ |
3383
|
|
|
|
|
|
|
3384
|
424
|
|
|
|
|
hook = pkg_can(aTHX_ cxt->hook, pkg, "STORABLE_freeze"); |
3385
|
424
|
|
|
|
|
if (hook) |
3386
|
212
|
|
|
|
|
return store_hook(aTHX_ cxt, sv, type, pkg, hook); |
3387
|
|
|
|
|
|
|
3388
|
|
|
|
|
|
/* |
3389
|
|
|
|
|
|
* This is a blessed SV without any serialization hook. |
3390
|
|
|
|
|
|
*/ |
3391
|
|
|
|
|
|
|
3392
|
212
|
|
|
|
|
classname = HvNAME_get(pkg); |
3393
|
212
|
|
|
|
|
len = strlen(classname); |
3394
|
|
|
|
|
|
|
3395
|
|
|
|
|
|
TRACEME(("blessed 0x%"UVxf" in %s, no hook: tagged #%d", |
3396
|
|
|
|
|
|
PTR2UV(sv), classname, cxt->tagnum)); |
3397
|
|
|
|
|
|
|
3398
|
|
|
|
|
|
/* |
3399
|
|
|
|
|
|
* Determine whether it is the first time we see that class name (in which |
3400
|
|
|
|
|
|
* case it will be stored in the SX_BLESS form), or whether we already |
3401
|
|
|
|
|
|
* saw that class name before (in which case the SX_IX_BLESS form will be |
3402
|
|
|
|
|
|
* used). |
3403
|
|
|
|
|
|
*/ |
3404
|
|
|
|
|
|
|
3405
|
212
|
|
|
|
|
if (known_class(aTHX_ cxt, classname, len, &classnum)) { |
3406
|
|
|
|
|
|
TRACEME(("already seen class %s, ID = %d", classname, classnum)); |
3407
|
54
|
|
|
|
|
PUTMARK(SX_IX_BLESS); |
3408
|
54
|
|
|
|
|
if (classnum <= LG_BLESS) { |
3409
|
54
|
|
|
|
|
unsigned char cnum = (unsigned char) classnum; |
3410
|
54
|
|
|
|
|
PUTMARK(cnum); |
3411
|
|
|
|
|
|
} else { |
3412
|
|
|
|
|
|
unsigned char flag = (unsigned char) 0x80; |
3413
|
0
|
|
|
|
|
PUTMARK(flag); |
3414
|
0
|
|
|
|
|
WLEN(classnum); |
3415
|
|
|
|
|
|
} |
3416
|
|
|
|
|
|
} else { |
3417
|
|
|
|
|
|
TRACEME(("first time we see class %s, ID = %d", classname, classnum)); |
3418
|
158
|
|
|
|
|
PUTMARK(SX_BLESS); |
3419
|
158
|
|
|
|
|
if (len <= LG_BLESS) { |
3420
|
156
|
|
|
|
|
unsigned char clen = (unsigned char) len; |
3421
|
156
|
|
|
|
|
PUTMARK(clen); |
3422
|
|
|
|
|
|
} else { |
3423
|
|
|
|
|
|
unsigned char flag = (unsigned char) 0x80; |
3424
|
2
|
|
|
|
|
PUTMARK(flag); |
3425
|
4
|
|
|
|
|
WLEN(len); /* Don't BER-encode, this should be rare */ |
3426
|
|
|
|
|
|
} |
3427
|
294
|
|
|
|
|
WRITE(classname, len); /* Final \0 is omitted */ |
3428
|
|
|
|
|
|
} |
3429
|
|
|
|
|
|
|
3430
|
|
|
|
|
|
/* |
3431
|
|
|
|
|
|
* Now emit the part. |
3432
|
|
|
|
|
|
*/ |
3433
|
|
|
|
|
|
|
3434
|
212
|
|
|
|
|
return SV_STORE(type)(aTHX_ cxt, sv); |
3435
|
|
|
|
|
|
} |
3436
|
|
|
|
|
|
|
3437
|
|
|
|
|
|
/* |
3438
|
|
|
|
|
|
* store_other |
3439
|
|
|
|
|
|
* |
3440
|
|
|
|
|
|
* We don't know how to store the item we reached, so return an error condition. |
3441
|
|
|
|
|
|
* (it's probably a GLOB, some CODE reference, etc...) |
3442
|
|
|
|
|
|
* |
3443
|
|
|
|
|
|
* If they defined the 'forgive_me' variable at the Perl level to some |
3444
|
|
|
|
|
|
* true value, then don't croak, just warn, and store a placeholder string |
3445
|
|
|
|
|
|
* instead. |
3446
|
|
|
|
|
|
*/ |
3447
|
4
|
|
|
|
|
static int store_other(pTHX_ stcxt_t *cxt, SV *sv) |
3448
|
|
|
|
|
|
{ |
3449
|
|
|
|
|
|
I32 len; |
3450
|
|
|
|
|
|
char buf[80]; |
3451
|
|
|
|
|
|
|
3452
|
|
|
|
|
|
TRACEME(("store_other")); |
3453
|
|
|
|
|
|
|
3454
|
|
|
|
|
|
/* |
3455
|
|
|
|
|
|
* Fetch the value from perl only once per store() operation. |
3456
|
|
|
|
|
|
*/ |
3457
|
|
|
|
|
|
|
3458
|
4
|
|
|
|
|
if ( |
3459
|
8
|
|
|
|
|
cxt->forgive_me == 0 || |
3460
|
24
|
|
|
|
|
(cxt->forgive_me < 0 && !(cxt->forgive_me = |
3461
|
12
|
|
|
|
|
SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) |
3462
|
|
|
|
|
|
) |
3463
|
2
|
|
|
|
|
CROAK(("Can't store %s items", sv_reftype(sv, FALSE))); |
3464
|
|
|
|
|
|
|
3465
|
2
|
|
|
|
|
warn("Can't store item %s(0x%"UVxf")", |
3466
|
|
|
|
|
|
sv_reftype(sv, FALSE), PTR2UV(sv)); |
3467
|
|
|
|
|
|
|
3468
|
|
|
|
|
|
/* |
3469
|
|
|
|
|
|
* Store placeholder string as a scalar instead... |
3470
|
|
|
|
|
|
*/ |
3471
|
|
|
|
|
|
|
3472
|
2
|
|
|
|
|
(void) sprintf(buf, "You lost %s(0x%"UVxf")%c", sv_reftype(sv, FALSE), |
3473
|
|
|
|
|
|
PTR2UV(sv), (char) 0); |
3474
|
|
|
|
|
|
|
3475
|
2
|
|
|
|
|
len = strlen(buf); |
3476
|
2
|
|
|
|
|
STORE_SCALAR(buf, len); |
3477
|
|
|
|
|
|
TRACEME(("ok (dummy \"%s\", length = %"IVdf")", buf, (IV) len)); |
3478
|
|
|
|
|
|
|
3479
|
2
|
|
|
|
|
return 0; |
3480
|
|
|
|
|
|
} |
3481
|
|
|
|
|
|
|
3482
|
|
|
|
|
|
/*** |
3483
|
|
|
|
|
|
*** Store driving routines |
3484
|
|
|
|
|
|
***/ |
3485
|
|
|
|
|
|
|
3486
|
|
|
|
|
|
/* |
3487
|
|
|
|
|
|
* sv_type |
3488
|
|
|
|
|
|
* |
3489
|
|
|
|
|
|
* WARNING: partially duplicates Perl's sv_reftype for speed. |
3490
|
|
|
|
|
|
* |
3491
|
|
|
|
|
|
* Returns the type of the SV, identified by an integer. That integer |
3492
|
|
|
|
|
|
* may then be used to index the dynamic routine dispatch table. |
3493
|
|
|
|
|
|
*/ |
3494
|
169096440
|
|
|
|
|
static int sv_type(pTHX_ SV *sv) |
3495
|
|
|
|
|
|
{ |
3496
|
169096440
|
|
|
|
|
switch (SvTYPE(sv)) { |
3497
|
|
|
|
|
|
case SVt_NULL: |
3498
|
|
|
|
|
|
#if PERL_VERSION <= 10 |
3499
|
|
|
|
|
|
case SVt_IV: |
3500
|
|
|
|
|
|
#endif |
3501
|
|
|
|
|
|
case SVt_NV: |
3502
|
|
|
|
|
|
/* |
3503
|
|
|
|
|
|
* No need to check for ROK, that can't be set here since there |
3504
|
|
|
|
|
|
* is no field capable of hodling the xrv_rv reference. |
3505
|
|
|
|
|
|
*/ |
3506
|
|
|
|
|
|
return svis_SCALAR; |
3507
|
|
|
|
|
|
case SVt_PV: |
3508
|
|
|
|
|
|
#if PERL_VERSION <= 10 |
3509
|
|
|
|
|
|
case SVt_RV: |
3510
|
|
|
|
|
|
#else |
3511
|
|
|
|
|
|
case SVt_IV: |
3512
|
|
|
|
|
|
#endif |
3513
|
|
|
|
|
|
case SVt_PVIV: |
3514
|
|
|
|
|
|
case SVt_PVNV: |
3515
|
|
|
|
|
|
/* |
3516
|
|
|
|
|
|
* Starting from SVt_PV, it is possible to have the ROK flag |
3517
|
|
|
|
|
|
* set, the pointer to the other SV being either stored in |
3518
|
|
|
|
|
|
* the xrv_rv (in the case of a pure SVt_RV), or as the |
3519
|
|
|
|
|
|
* xpv_pv field of an SVt_PV and its heirs. |
3520
|
|
|
|
|
|
* |
3521
|
|
|
|
|
|
* However, those SV cannot be magical or they would be an |
3522
|
|
|
|
|
|
* SVt_PVMG at least. |
3523
|
|
|
|
|
|
*/ |
3524
|
129405200
|
|
|
|
|
return SvROK(sv) ? svis_REF : svis_SCALAR; |
3525
|
|
|
|
|
|
case SVt_PVMG: |
3526
|
|
|
|
|
|
case SVt_PVLV: /* Workaround for perl5.004_04 "LVALUE" bug */ |
3527
|
398222
|
|
|
|
|
if (SvRMAGICAL(sv) && (mg_find(sv, 'p'))) |
3528
|
|
|
|
|
|
return svis_TIED_ITEM; |
3529
|
|
|
|
|
|
/* FALL THROUGH */ |
3530
|
|
|
|
|
|
#if PERL_VERSION < 9 |
3531
|
|
|
|
|
|
case SVt_PVBM: |
3532
|
|
|
|
|
|
#endif |
3533
|
398218
|
|
|
|
|
if (SvRMAGICAL(sv) && (mg_find(sv, 'q'))) |
3534
|
|
|
|
|
|
return svis_TIED; |
3535
|
398206
|
|
|
|
|
return SvROK(sv) ? svis_REF : svis_SCALAR; |
3536
|
|
|
|
|
|
case SVt_PVAV: |
3537
|
15218426
|
|
|
|
|
if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) |
3538
|
|
|
|
|
|
return svis_TIED; |
3539
|
15218418
|
|
|
|
|
return svis_ARRAY; |
3540
|
|
|
|
|
|
case SVt_PVHV: |
3541
|
14705462
|
|
|
|
|
if (SvRMAGICAL(sv) && (mg_find(sv, 'P'))) |
3542
|
|
|
|
|
|
return svis_TIED; |
3543
|
14705446
|
|
|
|
|
return svis_HASH; |
3544
|
|
|
|
|
|
case SVt_PVCV: |
3545
|
16
|
|
|
|
|
return svis_CODE; |
3546
|
|
|
|
|
|
#if PERL_VERSION > 8 |
3547
|
|
|
|
|
|
/* case SVt_INVLIST: */ |
3548
|
|
|
|
|
|
#endif |
3549
|
|
|
|
|
|
default: |
3550
|
|
|
|
|
|
break; |
3551
|
|
|
|
|
|
} |
3552
|
|
|
|
|
|
|
3553
|
4
|
|
|
|
|
return svis_OTHER; |
3554
|
|
|
|
|
|
} |
3555
|
|
|
|
|
|
|
3556
|
|
|
|
|
|
/* |
3557
|
|
|
|
|
|
* store |
3558
|
|
|
|
|
|
* |
3559
|
|
|
|
|
|
* Recursively store objects pointed to by the sv to the specified file. |
3560
|
|
|
|
|
|
* |
3561
|
|
|
|
|
|
* Layout is or SX_OBJECT if we reach an already stored |
3562
|
|
|
|
|
|
* object (one for which storage has started -- it may not be over if we have |
3563
|
|
|
|
|
|
* a self-referenced structure). This data set forms a stored . |
3564
|
|
|
|
|
|
*/ |
3565
|
169106700
|
|
|
|
|
static int store(pTHX_ stcxt_t *cxt, SV *sv) |
3566
|
|
|
|
|
|
{ |
3567
|
|
|
|
|
|
SV **svh; |
3568
|
|
|
|
|
|
int ret; |
3569
|
|
|
|
|
|
int type; |
3570
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3571
|
169106700
|
|
|
|
|
struct ptr_tbl *pseen = cxt->pseen; |
3572
|
|
|
|
|
|
#else |
3573
|
|
|
|
|
|
HV *hseen = cxt->hseen; |
3574
|
|
|
|
|
|
#endif |
3575
|
|
|
|
|
|
|
3576
|
|
|
|
|
|
TRACEME(("store (0x%"UVxf")", PTR2UV(sv))); |
3577
|
|
|
|
|
|
|
3578
|
|
|
|
|
|
/* |
3579
|
|
|
|
|
|
* If object has already been stored, do not duplicate data. |
3580
|
|
|
|
|
|
* Simply emit the SX_OBJECT marker followed by its tag data. |
3581
|
|
|
|
|
|
* The tag is always written in network order. |
3582
|
|
|
|
|
|
* |
3583
|
|
|
|
|
|
* NOTA BENE, for 64-bit machines: the "*svh" below does not yield a |
3584
|
|
|
|
|
|
* real pointer, rather a tag number (watch the insertion code below). |
3585
|
|
|
|
|
|
* That means it probably safe to assume it is well under the 32-bit limit, |
3586
|
|
|
|
|
|
* and makes the truncation safe. |
3587
|
|
|
|
|
|
* -- RAM, 14/09/1999 |
3588
|
|
|
|
|
|
*/ |
3589
|
|
|
|
|
|
|
3590
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3591
|
169106700
|
|
|
|
|
svh = (SV **)ptr_table_fetch(pseen, sv); |
3592
|
|
|
|
|
|
#else |
3593
|
|
|
|
|
|
svh = hv_fetch(hseen, (char *) &sv, sizeof(sv), FALSE); |
3594
|
|
|
|
|
|
#endif |
3595
|
169106700
|
|
|
|
|
if (svh) { |
3596
|
|
|
|
|
|
I32 tagval; |
3597
|
|
|
|
|
|
|
3598
|
10260
|
|
|
|
|
if (sv == &PL_sv_undef) { |
3599
|
|
|
|
|
|
/* We have seen PL_sv_undef before, but fake it as |
3600
|
|
|
|
|
|
if we have not. |
3601
|
|
|
|
|
|
|
3602
|
|
|
|
|
|
Not the simplest solution to making restricted |
3603
|
|
|
|
|
|
hashes work on 5.8.0, but it does mean that |
3604
|
|
|
|
|
|
repeated references to the one true undef will |
3605
|
|
|
|
|
|
take up less space in the output file. |
3606
|
|
|
|
|
|
*/ |
3607
|
|
|
|
|
|
/* Need to jump past the next hv_store, because on the |
3608
|
|
|
|
|
|
second store of undef the old hash value will be |
3609
|
|
|
|
|
|
SvREFCNT_dec()ed, and as Storable cheats horribly |
3610
|
|
|
|
|
|
by storing non-SVs in the hash a SEGV will ensure. |
3611
|
|
|
|
|
|
Need to increase the tag number so that the |
3612
|
|
|
|
|
|
receiver has no idea what games we're up to. This |
3613
|
|
|
|
|
|
special casing doesn't affect hooks that store |
3614
|
|
|
|
|
|
undef, as the hook routine does its own lookup into |
3615
|
|
|
|
|
|
hseen. Also this means that any references back |
3616
|
|
|
|
|
|
to PL_sv_undef (from the pathological case of hooks |
3617
|
|
|
|
|
|
storing references to it) will find the seen hash |
3618
|
|
|
|
|
|
entry for the first time, as if we didn't have this |
3619
|
|
|
|
|
|
hackery here. (That hseen lookup works even on 5.8.0 |
3620
|
|
|
|
|
|
because it's a key of &PL_sv_undef and a value |
3621
|
|
|
|
|
|
which is a tag number, not a value which is |
3622
|
|
|
|
|
|
PL_sv_undef.) */ |
3623
|
10028
|
|
|
|
|
cxt->tagnum++; |
3624
|
|
|
|
|
|
type = svis_SCALAR; |
3625
|
10028
|
|
|
|
|
goto undef_special_case; |
3626
|
|
|
|
|
|
} |
3627
|
|
|
|
|
|
|
3628
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3629
|
232
|
|
|
|
|
tagval = htonl(LOW_32BITS(((char *)svh)-1)); |
3630
|
|
|
|
|
|
#else |
3631
|
|
|
|
|
|
tagval = htonl(LOW_32BITS(*svh)); |
3632
|
|
|
|
|
|
#endif |
3633
|
|
|
|
|
|
|
3634
|
|
|
|
|
|
TRACEME(("object 0x%"UVxf" seen as #%d", PTR2UV(sv), ntohl(tagval))); |
3635
|
|
|
|
|
|
|
3636
|
232
|
|
|
|
|
PUTMARK(SX_OBJECT); |
3637
|
420
|
|
|
|
|
WRITE_I32(tagval); |
3638
|
232
|
|
|
|
|
return 0; |
3639
|
|
|
|
|
|
} |
3640
|
|
|
|
|
|
|
3641
|
|
|
|
|
|
/* |
3642
|
|
|
|
|
|
* Allocate a new tag and associate it with the address of the sv being |
3643
|
|
|
|
|
|
* stored, before recursing... |
3644
|
|
|
|
|
|
* |
3645
|
|
|
|
|
|
* In order to avoid creating new SvIVs to hold the tagnum we just |
3646
|
|
|
|
|
|
* cast the tagnum to an SV pointer and store that in the hash. This |
3647
|
|
|
|
|
|
* means that we must clean up the hash manually afterwards, but gives |
3648
|
|
|
|
|
|
* us a 15% throughput increase. |
3649
|
|
|
|
|
|
* |
3650
|
|
|
|
|
|
*/ |
3651
|
|
|
|
|
|
|
3652
|
169096440
|
|
|
|
|
cxt->tagnum++; |
3653
|
|
|
|
|
|
#ifdef USE_PTR_TABLE |
3654
|
169096440
|
|
|
|
|
ptr_table_store(pseen, sv, INT2PTR(SV*, 1 + cxt->tagnum)); |
3655
|
|
|
|
|
|
#else |
3656
|
|
|
|
|
|
if (!hv_store(hseen, |
3657
|
|
|
|
|
|
(char *) &sv, sizeof(sv), INT2PTR(SV*, cxt->tagnum), 0)) |
3658
|
|
|
|
|
|
return -1; |
3659
|
|
|
|
|
|
#endif |
3660
|
|
|
|
|
|
|
3661
|
|
|
|
|
|
/* |
3662
|
|
|
|
|
|
* Store 'sv' and everything beneath it, using appropriate routine. |
3663
|
|
|
|
|
|
* Abort immediately if we get a non-zero status back. |
3664
|
|
|
|
|
|
*/ |
3665
|
|
|
|
|
|
|
3666
|
169096440
|
|
|
|
|
type = sv_type(aTHX_ sv); |
3667
|
|
|
|
|
|
|
3668
|
|
|
|
|
|
undef_special_case: |
3669
|
|
|
|
|
|
TRACEME(("storing 0x%"UVxf" tag #%d, type %d...", |
3670
|
|
|
|
|
|
PTR2UV(sv), cxt->tagnum, type)); |
3671
|
|
|
|
|
|
|
3672
|
169106468
|
|
|
|
|
if (SvOBJECT(sv)) { |
3673
|
414
|
|
|
|
|
HV *pkg = SvSTASH(sv); |
3674
|
414
|
|
|
|
|
ret = store_blessed(aTHX_ cxt, sv, type, pkg); |
3675
|
|
|
|
|
|
} else |
3676
|
169106054
|
|
|
|
|
ret = SV_STORE(type)(aTHX_ cxt, sv); |
3677
|
|
|
|
|
|
|
3678
|
|
|
|
|
|
TRACEME(("%s (stored 0x%"UVxf", refcnt=%d, %s)", |
3679
|
|
|
|
|
|
ret ? "FAILED" : "ok", PTR2UV(sv), |
3680
|
|
|
|
|
|
SvREFCNT(sv), sv_reftype(sv, FALSE))); |
3681
|
|
|
|
|
|
|
3682
|
169106460
|
|
|
|
|
return ret; |
3683
|
|
|
|
|
|
} |
3684
|
|
|
|
|
|
|
3685
|
|
|
|
|
|
/* |
3686
|
|
|
|
|
|
* magic_write |
3687
|
|
|
|
|
|
* |
3688
|
|
|
|
|
|
* Write magic number and system information into the file. |
3689
|
|
|
|
|
|
* Layout is [ |
3690
|
|
|
|
|
|
* ] where is the length of the byteorder hexa string. |
3691
|
|
|
|
|
|
* All size and lenghts are written as single characters here. |
3692
|
|
|
|
|
|
* |
3693
|
|
|
|
|
|
* Note that no byte ordering info is emitted when is true, since |
3694
|
|
|
|
|
|
* integers will be emitted in network order in that case. |
3695
|
|
|
|
|
|
*/ |
3696
|
365454
|
|
|
|
|
static int magic_write(pTHX_ stcxt_t *cxt) |
3697
|
|
|
|
|
|
{ |
3698
|
|
|
|
|
|
/* |
3699
|
|
|
|
|
|
* Starting with 0.6, the "use_network_order" byte flag is also used to |
3700
|
|
|
|
|
|
* indicate the version number of the binary image, encoded in the upper |
3701
|
|
|
|
|
|
* bits. The bit 0 is always used to indicate network order. |
3702
|
|
|
|
|
|
*/ |
3703
|
|
|
|
|
|
/* |
3704
|
|
|
|
|
|
* Starting with 0.7, a full byte is dedicated to the minor version of |
3705
|
|
|
|
|
|
* the binary format, which is incremented only when new markers are |
3706
|
|
|
|
|
|
* introduced, for instance, but when backward compatibility is preserved. |
3707
|
|
|
|
|
|
*/ |
3708
|
|
|
|
|
|
|
3709
|
|
|
|
|
|
/* Make these at compile time. The WRITE() macro is sufficiently complex |
3710
|
|
|
|
|
|
that it saves about 200 bytes doing it this way and only using it |
3711
|
|
|
|
|
|
once. */ |
3712
|
|
|
|
|
|
static const unsigned char network_file_header[] = { |
3713
|
|
|
|
|
|
MAGICSTR_BYTES, |
3714
|
|
|
|
|
|
(STORABLE_BIN_MAJOR << 1) | 1, |
3715
|
|
|
|
|
|
STORABLE_BIN_WRITE_MINOR |
3716
|
|
|
|
|
|
}; |
3717
|
|
|
|
|
|
static const unsigned char file_header[] = { |
3718
|
|
|
|
|
|
MAGICSTR_BYTES, |
3719
|
|
|
|
|
|
(STORABLE_BIN_MAJOR << 1) | 0, |
3720
|
|
|
|
|
|
STORABLE_BIN_WRITE_MINOR, |
3721
|
|
|
|
|
|
/* sizeof the array includes the 0 byte at the end: */ |
3722
|
|
|
|
|
|
(char) sizeof (byteorderstr) - 1, |
3723
|
|
|
|
|
|
BYTEORDER_BYTES, |
3724
|
|
|
|
|
|
(unsigned char) sizeof(int), |
3725
|
|
|
|
|
|
(unsigned char) sizeof(long), |
3726
|
|
|
|
|
|
(unsigned char) sizeof(char *), |
3727
|
|
|
|
|
|
(unsigned char) sizeof(NV) |
3728
|
|
|
|
|
|
}; |
3729
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
3730
|
|
|
|
|
|
static const unsigned char file_header_56[] = { |
3731
|
|
|
|
|
|
MAGICSTR_BYTES, |
3732
|
|
|
|
|
|
(STORABLE_BIN_MAJOR << 1) | 0, |
3733
|
|
|
|
|
|
STORABLE_BIN_WRITE_MINOR, |
3734
|
|
|
|
|
|
/* sizeof the array includes the 0 byte at the end: */ |
3735
|
|
|
|
|
|
(char) sizeof (byteorderstr_56) - 1, |
3736
|
|
|
|
|
|
BYTEORDER_BYTES_56, |
3737
|
|
|
|
|
|
(unsigned char) sizeof(int), |
3738
|
|
|
|
|
|
(unsigned char) sizeof(long), |
3739
|
|
|
|
|
|
(unsigned char) sizeof(char *), |
3740
|
|
|
|
|
|
(unsigned char) sizeof(NV) |
3741
|
|
|
|
|
|
}; |
3742
|
|
|
|
|
|
#endif |
3743
|
|
|
|
|
|
const unsigned char *header; |
3744
|
|
|
|
|
|
SSize_t length; |
3745
|
|
|
|
|
|
|
3746
|
|
|
|
|
|
TRACEME(("magic_write on fd=%d", cxt->fio ? PerlIO_fileno(cxt->fio) : -1)); |
3747
|
|
|
|
|
|
|
3748
|
365454
|
|
|
|
|
if (cxt->netorder) { |
3749
|
|
|
|
|
|
header = network_file_header; |
3750
|
|
|
|
|
|
length = sizeof (network_file_header); |
3751
|
|
|
|
|
|
} else { |
3752
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
3753
|
|
|
|
|
|
if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) { |
3754
|
|
|
|
|
|
header = file_header_56; |
3755
|
|
|
|
|
|
length = sizeof (file_header_56); |
3756
|
|
|
|
|
|
} else |
3757
|
|
|
|
|
|
#endif |
3758
|
|
|
|
|
|
{ |
3759
|
|
|
|
|
|
header = file_header; |
3760
|
|
|
|
|
|
length = sizeof (file_header); |
3761
|
|
|
|
|
|
} |
3762
|
|
|
|
|
|
} |
3763
|
|
|
|
|
|
|
3764
|
365454
|
|
|
|
|
if (!cxt->fio) { |
3765
|
|
|
|
|
|
/* sizeof the array includes the 0 byte at the end. */ |
3766
|
43470
|
|
|
|
|
header += sizeof (magicstr) - 1; |
3767
|
43470
|
|
|
|
|
length -= sizeof (magicstr) - 1; |
3768
|
|
|
|
|
|
} |
3769
|
|
|
|
|
|
|
3770
|
408924
|
|
|
|
|
WRITE( (unsigned char*) header, length); |
3771
|
|
|
|
|
|
|
3772
|
|
|
|
|
|
if (!cxt->netorder) { |
3773
|
|
|
|
|
|
TRACEME(("ok (magic_write byteorder = 0x%lx [%d], I%d L%d P%d D%d)", |
3774
|
|
|
|
|
|
(unsigned long) BYTEORDER, (int) sizeof (byteorderstr) - 1, |
3775
|
|
|
|
|
|
(int) sizeof(int), (int) sizeof(long), |
3776
|
|
|
|
|
|
(int) sizeof(char *), (int) sizeof(NV))); |
3777
|
|
|
|
|
|
} |
3778
|
|
|
|
|
|
return 0; |
3779
|
|
|
|
|
|
} |
3780
|
|
|
|
|
|
|
3781
|
|
|
|
|
|
/* |
3782
|
|
|
|
|
|
* do_store |
3783
|
|
|
|
|
|
* |
3784
|
|
|
|
|
|
* Common code for store operations. |
3785
|
|
|
|
|
|
* |
3786
|
|
|
|
|
|
* When memory store is requested (f = NULL) and a non null SV* is given in |
3787
|
|
|
|
|
|
* 'res', it is filled with a new SV created out of the memory buffer. |
3788
|
|
|
|
|
|
* |
3789
|
|
|
|
|
|
* It is required to provide a non-null 'res' when the operation type is not |
3790
|
|
|
|
|
|
* dclone() and store() is performed to memory. |
3791
|
|
|
|
|
|
*/ |
3792
|
365454
|
|
|
|
|
static int do_store( |
3793
|
|
|
|
|
|
pTHX_ |
3794
|
|
|
|
|
|
PerlIO *f, |
3795
|
|
|
|
|
|
SV *sv, |
3796
|
|
|
|
|
|
int optype, |
3797
|
|
|
|
|
|
int network_order, |
3798
|
|
|
|
|
|
SV **res) |
3799
|
|
|
|
|
|
{ |
3800
|
365454
|
|
|
|
|
dSTCXT; |
3801
|
|
|
|
|
|
int status; |
3802
|
|
|
|
|
|
|
3803
|
|
|
|
|
|
ASSERT(!(f == 0 && !(optype & ST_CLONE)) || res, |
3804
|
|
|
|
|
|
("must supply result SV pointer for real recursion to memory")); |
3805
|
|
|
|
|
|
|
3806
|
|
|
|
|
|
TRACEME(("do_store (optype=%d, netorder=%d)", |
3807
|
|
|
|
|
|
optype, network_order)); |
3808
|
|
|
|
|
|
|
3809
|
365454
|
|
|
|
|
optype |= ST_STORE; |
3810
|
|
|
|
|
|
|
3811
|
|
|
|
|
|
/* |
3812
|
|
|
|
|
|
* Workaround for CROAK leak: if they enter with a "dirty" context, |
3813
|
|
|
|
|
|
* free up memory for them now. |
3814
|
|
|
|
|
|
*/ |
3815
|
|
|
|
|
|
|
3816
|
365454
|
|
|
|
|
if (cxt->s_dirty) |
3817
|
18
|
|
|
|
|
clean_context(aTHX_ cxt); |
3818
|
|
|
|
|
|
|
3819
|
|
|
|
|
|
/* |
3820
|
|
|
|
|
|
* Now that STORABLE_xxx hooks exist, it is possible that they try to |
3821
|
|
|
|
|
|
* re-enter store() via the hooks. We need to stack contexts. |
3822
|
|
|
|
|
|
*/ |
3823
|
|
|
|
|
|
|
3824
|
365454
|
|
|
|
|
if (cxt->entry) |
3825
|
80
|
|
|
|
|
cxt = allocate_context(aTHX_ cxt); |
3826
|
|
|
|
|
|
|
3827
|
365454
|
|
|
|
|
cxt->entry++; |
3828
|
|
|
|
|
|
|
3829
|
|
|
|
|
|
ASSERT(cxt->entry == 1, ("starting new recursion")); |
3830
|
|
|
|
|
|
ASSERT(!cxt->s_dirty, ("clean context")); |
3831
|
|
|
|
|
|
|
3832
|
|
|
|
|
|
/* |
3833
|
|
|
|
|
|
* Ensure sv is actually a reference. From perl, we called something |
3834
|
|
|
|
|
|
* like: |
3835
|
|
|
|
|
|
* pstore(aTHX_ FILE, \@array); |
3836
|
|
|
|
|
|
* so we must get the scalar value behind that reference. |
3837
|
|
|
|
|
|
*/ |
3838
|
|
|
|
|
|
|
3839
|
365454
|
|
|
|
|
if (!SvROK(sv)) |
3840
|
0
|
|
|
|
|
CROAK(("Not a reference")); |
3841
|
365454
|
|
|
|
|
sv = SvRV(sv); /* So follow it to know what to store */ |
3842
|
|
|
|
|
|
|
3843
|
|
|
|
|
|
/* |
3844
|
|
|
|
|
|
* If we're going to store to memory, reset the buffer. |
3845
|
|
|
|
|
|
*/ |
3846
|
|
|
|
|
|
|
3847
|
365454
|
|
|
|
|
if (!f) |
3848
|
43470
|
|
|
|
|
MBUF_INIT(0); |
3849
|
|
|
|
|
|
|
3850
|
|
|
|
|
|
/* |
3851
|
|
|
|
|
|
* Prepare context and emit headers. |
3852
|
|
|
|
|
|
*/ |
3853
|
|
|
|
|
|
|
3854
|
|
|
|
|
|
init_store_context(aTHX_ cxt, f, optype, network_order); |
3855
|
|
|
|
|
|
|
3856
|
365454
|
|
|
|
|
if (-1 == magic_write(aTHX_ cxt)) /* Emit magic and ILP info */ |
3857
|
|
|
|
|
|
return 0; /* Error */ |
3858
|
|
|
|
|
|
|
3859
|
|
|
|
|
|
/* |
3860
|
|
|
|
|
|
* Recursively store object... |
3861
|
|
|
|
|
|
*/ |
3862
|
|
|
|
|
|
|
3863
|
|
|
|
|
|
ASSERT(is_storing(aTHX), ("within store operation")); |
3864
|
|
|
|
|
|
|
3865
|
365454
|
|
|
|
|
status = store(aTHX_ cxt, sv); /* Just do it! */ |
3866
|
|
|
|
|
|
|
3867
|
|
|
|
|
|
/* |
3868
|
|
|
|
|
|
* If they asked for a memory store and they provided an SV pointer, |
3869
|
|
|
|
|
|
* make an SV string out of the buffer and fill their pointer. |
3870
|
|
|
|
|
|
* |
3871
|
|
|
|
|
|
* When asking for ST_REAL, it's MANDATORY for the caller to provide |
3872
|
|
|
|
|
|
* an SV, since context cleanup might free the buffer if we did recurse. |
3873
|
|
|
|
|
|
* (unless caller is dclone(), which is aware of that). |
3874
|
|
|
|
|
|
*/ |
3875
|
|
|
|
|
|
|
3876
|
365450
|
|
|
|
|
if (!cxt->fio && res) |
3877
|
450
|
|
|
|
|
*res = mbuf2sv(aTHX); |
3878
|
|
|
|
|
|
|
3879
|
|
|
|
|
|
/* |
3880
|
|
|
|
|
|
* Final cleanup. |
3881
|
|
|
|
|
|
* |
3882
|
|
|
|
|
|
* The "root" context is never freed, since it is meant to be always |
3883
|
|
|
|
|
|
* handy for the common case where no recursion occurs at all (i.e. |
3884
|
|
|
|
|
|
* we enter store() outside of any Storable code and leave it, period). |
3885
|
|
|
|
|
|
* We know it's the "root" context because there's nothing stacked |
3886
|
|
|
|
|
|
* underneath it. |
3887
|
|
|
|
|
|
* |
3888
|
|
|
|
|
|
* OPTIMIZATION: |
3889
|
|
|
|
|
|
* |
3890
|
|
|
|
|
|
* When deep cloning, we don't free the context: doing so would force |
3891
|
|
|
|
|
|
* us to copy the data in the memory buffer. Sicne we know we're |
3892
|
|
|
|
|
|
* about to enter do_retrieve... |
3893
|
|
|
|
|
|
*/ |
3894
|
|
|
|
|
|
|
3895
|
365450
|
|
|
|
|
clean_store_context(aTHX_ cxt); |
3896
|
365450
|
|
|
|
|
if (cxt->prev && !(cxt->optype & ST_CLONE)) |
3897
|
|
|
|
|
|
free_context(aTHX_ cxt); |
3898
|
|
|
|
|
|
|
3899
|
|
|
|
|
|
TRACEME(("do_store returns %d", status)); |
3900
|
|
|
|
|
|
|
3901
|
365450
|
|
|
|
|
return status == 0; |
3902
|
|
|
|
|
|
} |
3903
|
|
|
|
|
|
|
3904
|
|
|
|
|
|
/*** |
3905
|
|
|
|
|
|
*** Memory stores. |
3906
|
|
|
|
|
|
***/ |
3907
|
|
|
|
|
|
|
3908
|
|
|
|
|
|
/* |
3909
|
|
|
|
|
|
* mbuf2sv |
3910
|
|
|
|
|
|
* |
3911
|
|
|
|
|
|
* Build a new SV out of the content of the internal memory buffer. |
3912
|
|
|
|
|
|
*/ |
3913
|
|
|
|
|
|
static SV *mbuf2sv(pTHX) |
3914
|
|
|
|
|
|
{ |
3915
|
450
|
|
|
|
|
dSTCXT; |
3916
|
|
|
|
|
|
|
3917
|
450
|
|
|
|
|
return newSVpv(mbase, MBUF_SIZE()); |
3918
|
|
|
|
|
|
} |
3919
|
|
|
|
|
|
|
3920
|
|
|
|
|
|
/*** |
3921
|
|
|
|
|
|
*** Specific retrieve callbacks. |
3922
|
|
|
|
|
|
***/ |
3923
|
|
|
|
|
|
|
3924
|
|
|
|
|
|
/* |
3925
|
|
|
|
|
|
* retrieve_other |
3926
|
|
|
|
|
|
* |
3927
|
|
|
|
|
|
* Return an error via croak, since it is not possible that we get here |
3928
|
|
|
|
|
|
* under normal conditions, when facing a file produced via pstore(). |
3929
|
|
|
|
|
|
*/ |
3930
|
16
|
|
|
|
|
static SV *retrieve_other(pTHX_ stcxt_t *cxt, const char *cname) |
3931
|
|
|
|
|
|
{ |
3932
|
|
|
|
|
|
PERL_UNUSED_ARG(cname); |
3933
|
16
|
|
|
|
|
if ( |
3934
|
16
|
|
|
|
|
cxt->ver_major != STORABLE_BIN_MAJOR && |
3935
|
0
|
|
|
|
|
cxt->ver_minor != STORABLE_BIN_MINOR |
3936
|
|
|
|
|
|
) { |
3937
|
0
|
|
|
|
|
CROAK(("Corrupted storable %s (binary v%d.%d), current is v%d.%d", |
3938
|
|
|
|
|
|
cxt->fio ? "file" : "string", |
3939
|
|
|
|
|
|
cxt->ver_major, cxt->ver_minor, |
3940
|
|
|
|
|
|
STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); |
3941
|
|
|
|
|
|
} else { |
3942
|
16
|
|
|
|
|
CROAK(("Corrupted storable %s (binary v%d.%d)", |
3943
|
|
|
|
|
|
cxt->fio ? "file" : "string", |
3944
|
|
|
|
|
|
cxt->ver_major, cxt->ver_minor)); |
3945
|
|
|
|
|
|
} |
3946
|
|
|
|
|
|
|
3947
|
|
|
|
|
|
return (SV *) 0; /* Just in case */ |
3948
|
|
|
|
|
|
} |
3949
|
|
|
|
|
|
|
3950
|
|
|
|
|
|
/* |
3951
|
|
|
|
|
|
* retrieve_idx_blessed |
3952
|
|
|
|
|
|
* |
3953
|
|
|
|
|
|
* Layout is SX_IX_BLESS with SX_IX_BLESS already read. |
3954
|
|
|
|
|
|
* can be coded on either 1 or 5 bytes. |
3955
|
|
|
|
|
|
*/ |
3956
|
38
|
|
|
|
|
static SV *retrieve_idx_blessed(pTHX_ stcxt_t *cxt, const char *cname) |
3957
|
|
|
|
|
|
{ |
3958
|
|
|
|
|
|
I32 idx; |
3959
|
|
|
|
|
|
const char *classname; |
3960
|
|
|
|
|
|
SV **sva; |
3961
|
|
|
|
|
|
SV *sv; |
3962
|
|
|
|
|
|
|
3963
|
|
|
|
|
|
PERL_UNUSED_ARG(cname); |
3964
|
|
|
|
|
|
TRACEME(("retrieve_idx_blessed (#%d)", cxt->tagnum)); |
3965
|
|
|
|
|
|
ASSERT(!cname, ("no bless-into class given here, got %s", cname)); |
3966
|
|
|
|
|
|
|
3967
|
38
|
|
|
|
|
GETMARK(idx); /* Index coded on a single char? */ |
3968
|
38
|
|
|
|
|
if (idx & 0x80) |
3969
|
0
|
|
|
|
|
RLEN(idx); |
3970
|
|
|
|
|
|
|
3971
|
|
|
|
|
|
/* |
3972
|
|
|
|
|
|
* Fetch classname in 'aclass' |
3973
|
|
|
|
|
|
*/ |
3974
|
|
|
|
|
|
|
3975
|
38
|
|
|
|
|
sva = av_fetch(cxt->aclass, idx, FALSE); |
3976
|
38
|
|
|
|
|
if (!sva) |
3977
|
0
|
|
|
|
|
CROAK(("Class name #%"IVdf" should have been seen already", (IV) idx)); |
3978
|
|
|
|
|
|
|
3979
|
38
|
|
|
|
|
classname = SvPVX(*sva); /* We know it's a PV, by construction */ |
3980
|
|
|
|
|
|
|
3981
|
|
|
|
|
|
TRACEME(("class ID %d => %s", idx, classname)); |
3982
|
|
|
|
|
|
|
3983
|
|
|
|
|
|
/* |
3984
|
|
|
|
|
|
* Retrieve object and bless it. |
3985
|
|
|
|
|
|
*/ |
3986
|
|
|
|
|
|
|
3987
|
38
|
|
|
|
|
sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ |
3988
|
|
|
|
|
|
|
3989
|
38
|
|
|
|
|
return sv; |
3990
|
|
|
|
|
|
} |
3991
|
|
|
|
|
|
|
3992
|
|
|
|
|
|
/* |
3993
|
|
|
|
|
|
* retrieve_blessed |
3994
|
|
|
|
|
|
* |
3995
|
|
|
|
|
|
* Layout is SX_BLESS with SX_BLESS already read. |
3996
|
|
|
|
|
|
* can be coded on either 1 or 5 bytes. |
3997
|
|
|
|
|
|
*/ |
3998
|
142
|
|
|
|
|
static SV *retrieve_blessed(pTHX_ stcxt_t *cxt, const char *cname) |
3999
|
|
|
|
|
|
{ |
4000
|
|
|
|
|
|
I32 len; |
4001
|
|
|
|
|
|
SV *sv; |
4002
|
|
|
|
|
|
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ |
4003
|
|
|
|
|
|
char *classname = buf; |
4004
|
|
|
|
|
|
char *malloced_classname = NULL; |
4005
|
|
|
|
|
|
|
4006
|
|
|
|
|
|
PERL_UNUSED_ARG(cname); |
4007
|
|
|
|
|
|
TRACEME(("retrieve_blessed (#%d)", cxt->tagnum)); |
4008
|
|
|
|
|
|
ASSERT(!cname, ("no bless-into class given here, got %s", cname)); |
4009
|
|
|
|
|
|
|
4010
|
|
|
|
|
|
/* |
4011
|
|
|
|
|
|
* Decode class name length and read that name. |
4012
|
|
|
|
|
|
* |
4013
|
|
|
|
|
|
* Short classnames have two advantages: their length is stored on one |
4014
|
|
|
|
|
|
* single byte, and the string can be read on the stack. |
4015
|
|
|
|
|
|
*/ |
4016
|
|
|
|
|
|
|
4017
|
142
|
|
|
|
|
GETMARK(len); /* Length coded on a single char? */ |
4018
|
142
|
|
|
|
|
if (len & 0x80) { |
4019
|
4
|
|
|
|
|
RLEN(len); |
4020
|
|
|
|
|
|
TRACEME(("** allocating %d bytes for class name", len+1)); |
4021
|
2
|
|
|
|
|
New(10003, classname, len+1, char); |
4022
|
|
|
|
|
|
malloced_classname = classname; |
4023
|
|
|
|
|
|
} |
4024
|
262
|
|
|
|
|
SAFEPVREAD(classname, len, malloced_classname); |
4025
|
142
|
|
|
|
|
classname[len] = '\0'; /* Mark string end */ |
4026
|
|
|
|
|
|
|
4027
|
|
|
|
|
|
/* |
4028
|
|
|
|
|
|
* It's a new classname, otherwise it would have been an SX_IX_BLESS. |
4029
|
|
|
|
|
|
*/ |
4030
|
|
|
|
|
|
|
4031
|
|
|
|
|
|
TRACEME(("new class name \"%s\" will bear ID = %d", classname, cxt->classnum)); |
4032
|
|
|
|
|
|
|
4033
|
142
|
|
|
|
|
if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { |
4034
|
0
|
|
|
|
|
Safefree(malloced_classname); |
4035
|
0
|
|
|
|
|
return (SV *) 0; |
4036
|
|
|
|
|
|
} |
4037
|
|
|
|
|
|
|
4038
|
|
|
|
|
|
/* |
4039
|
|
|
|
|
|
* Retrieve object and bless it. |
4040
|
|
|
|
|
|
*/ |
4041
|
|
|
|
|
|
|
4042
|
142
|
|
|
|
|
sv = retrieve(aTHX_ cxt, classname); /* First SV which is SEEN will be blessed */ |
4043
|
142
|
|
|
|
|
if (malloced_classname) |
4044
|
2
|
|
|
|
|
Safefree(malloced_classname); |
4045
|
|
|
|
|
|
|
4046
|
|
|
|
|
|
return sv; |
4047
|
|
|
|
|
|
} |
4048
|
|
|
|
|
|
|
4049
|
|
|
|
|
|
/* |
4050
|
|
|
|
|
|
* retrieve_hook |
4051
|
|
|
|
|
|
* |
4052
|
|
|
|
|
|
* Layout: SX_HOOK [ ] |
4053
|
|
|
|
|
|
* with leading mark already read, as usual. |
4054
|
|
|
|
|
|
* |
4055
|
|
|
|
|
|
* When recursion was involved during serialization of the object, there |
4056
|
|
|
|
|
|
* is an unknown amount of serialized objects after the SX_HOOK mark. Until |
4057
|
|
|
|
|
|
* we reach a marker with the recursion bit cleared. |
4058
|
|
|
|
|
|
* |
4059
|
|
|
|
|
|
* If the first byte contains a type of SHT_EXTRA, then the real type |
4060
|
|
|
|
|
|
* is held in the byte, and if the object is tied, the serialized |
4061
|
|
|
|
|
|
* magic object comes at the very end: |
4062
|
|
|
|
|
|
* |
4063
|
|
|
|
|
|
* SX_HOOK ... [ ] |
4064
|
|
|
|
|
|
* |
4065
|
|
|
|
|
|
* This means the STORABLE_thaw hook will NOT get a tied variable during its |
4066
|
|
|
|
|
|
* processing (since we won't have seen the magic object by the time the hook |
4067
|
|
|
|
|
|
* is called). See comments below for why it was done that way. |
4068
|
|
|
|
|
|
*/ |
4069
|
204
|
|
|
|
|
static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname) |
4070
|
|
|
|
|
|
{ |
4071
|
|
|
|
|
|
I32 len; |
4072
|
|
|
|
|
|
char buf[LG_BLESS + 1]; /* Avoid malloc() if possible */ |
4073
|
|
|
|
|
|
char *classname = buf; |
4074
|
|
|
|
|
|
unsigned int flags; |
4075
|
|
|
|
|
|
I32 len2; |
4076
|
|
|
|
|
|
SV *frozen; |
4077
|
204
|
|
|
|
|
I32 len3 = 0; |
4078
|
|
|
|
|
|
AV *av = 0; |
4079
|
|
|
|
|
|
SV *hook; |
4080
|
|
|
|
|
|
SV *sv; |
4081
|
|
|
|
|
|
SV *rv; |
4082
|
|
|
|
|
|
GV *attach; |
4083
|
|
|
|
|
|
HV *stash; |
4084
|
|
|
|
|
|
int obj_type; |
4085
|
204
|
|
|
|
|
int clone = cxt->optype & ST_CLONE; |
4086
|
|
|
|
|
|
char mtype = '\0'; |
4087
|
|
|
|
|
|
unsigned int extra_type = 0; |
4088
|
|
|
|
|
|
|
4089
|
|
|
|
|
|
PERL_UNUSED_ARG(cname); |
4090
|
|
|
|
|
|
TRACEME(("retrieve_hook (#%d)", cxt->tagnum)); |
4091
|
|
|
|
|
|
ASSERT(!cname, ("no bless-into class given here, got %s", cname)); |
4092
|
|
|
|
|
|
|
4093
|
|
|
|
|
|
/* |
4094
|
|
|
|
|
|
* Read flags, which tell us about the type, and whether we need to recurse. |
4095
|
|
|
|
|
|
*/ |
4096
|
|
|
|
|
|
|
4097
|
204
|
|
|
|
|
GETMARK(flags); |
4098
|
|
|
|
|
|
|
4099
|
|
|
|
|
|
/* |
4100
|
|
|
|
|
|
* Create the (empty) object, and mark it as seen. |
4101
|
|
|
|
|
|
* |
4102
|
|
|
|
|
|
* This must be done now, because tags are incremented, and during |
4103
|
|
|
|
|
|
* serialization, the object tag was affected before recursion could |
4104
|
|
|
|
|
|
* take place. |
4105
|
|
|
|
|
|
*/ |
4106
|
|
|
|
|
|
|
4107
|
204
|
|
|
|
|
obj_type = flags & SHF_TYPE_MASK; |
4108
|
204
|
|
|
|
|
switch (obj_type) { |
4109
|
|
|
|
|
|
case SHT_SCALAR: |
4110
|
2
|
|
|
|
|
sv = newSV(0); |
4111
|
2
|
|
|
|
|
break; |
4112
|
|
|
|
|
|
case SHT_ARRAY: |
4113
|
150
|
|
|
|
|
sv = (SV *) newAV(); |
4114
|
150
|
|
|
|
|
break; |
4115
|
|
|
|
|
|
case SHT_HASH: |
4116
|
50
|
|
|
|
|
sv = (SV *) newHV(); |
4117
|
50
|
|
|
|
|
break; |
4118
|
|
|
|
|
|
case SHT_EXTRA: |
4119
|
|
|
|
|
|
/* |
4120
|
|
|
|
|
|
* Read flag to know the type of the object. |
4121
|
|
|
|
|
|
* Record associated magic type for later. |
4122
|
|
|
|
|
|
*/ |
4123
|
2
|
|
|
|
|
GETMARK(extra_type); |
4124
|
2
|
|
|
|
|
switch (extra_type) { |
4125
|
|
|
|
|
|
case SHT_TSCALAR: |
4126
|
0
|
|
|
|
|
sv = newSV(0); |
4127
|
|
|
|
|
|
mtype = 'q'; |
4128
|
0
|
|
|
|
|
break; |
4129
|
|
|
|
|
|
case SHT_TARRAY: |
4130
|
0
|
|
|
|
|
sv = (SV *) newAV(); |
4131
|
|
|
|
|
|
mtype = 'P'; |
4132
|
0
|
|
|
|
|
break; |
4133
|
|
|
|
|
|
case SHT_THASH: |
4134
|
2
|
|
|
|
|
sv = (SV *) newHV(); |
4135
|
|
|
|
|
|
mtype = 'P'; |
4136
|
2
|
|
|
|
|
break; |
4137
|
|
|
|
|
|
default: |
4138
|
0
|
|
|
|
|
return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ |
4139
|
|
|
|
|
|
} |
4140
|
|
|
|
|
|
break; |
4141
|
|
|
|
|
|
default: |
4142
|
0
|
|
|
|
|
return retrieve_other(aTHX_ cxt, 0); /* Let it croak */ |
4143
|
|
|
|
|
|
} |
4144
|
408
|
|
|
|
|
SEEN(sv, 0, 0); /* Don't bless yet */ |
4145
|
|
|
|
|
|
|
4146
|
|
|
|
|
|
/* |
4147
|
|
|
|
|
|
* Whilst flags tell us to recurse, do so. |
4148
|
|
|
|
|
|
* |
4149
|
|
|
|
|
|
* We don't need to remember the addresses returned by retrieval, because |
4150
|
|
|
|
|
|
* all the references will be obtained through indirection via the object |
4151
|
|
|
|
|
|
* tags in the object-ID list. |
4152
|
|
|
|
|
|
* |
4153
|
|
|
|
|
|
* We need to decrement the reference count for these objects |
4154
|
|
|
|
|
|
* because, if the user doesn't save a reference to them in the hook, |
4155
|
|
|
|
|
|
* they must be freed when this context is cleaned. |
4156
|
|
|
|
|
|
*/ |
4157
|
|
|
|
|
|
|
4158
|
242
|
|
|
|
|
while (flags & SHF_NEED_RECURSE) { |
4159
|
|
|
|
|
|
TRACEME(("retrieve_hook recursing...")); |
4160
|
38
|
|
|
|
|
rv = retrieve(aTHX_ cxt, 0); |
4161
|
38
|
|
|
|
|
if (!rv) |
4162
|
|
|
|
|
|
return (SV *) 0; |
4163
|
38
|
|
|
|
|
SvREFCNT_dec(rv); |
4164
|
|
|
|
|
|
TRACEME(("retrieve_hook back with rv=0x%"UVxf, |
4165
|
|
|
|
|
|
PTR2UV(rv))); |
4166
|
38
|
|
|
|
|
GETMARK(flags); |
4167
|
|
|
|
|
|
} |
4168
|
|
|
|
|
|
|
4169
|
204
|
|
|
|
|
if (flags & SHF_IDX_CLASSNAME) { |
4170
|
|
|
|
|
|
SV **sva; |
4171
|
|
|
|
|
|
I32 idx; |
4172
|
|
|
|
|
|
|
4173
|
|
|
|
|
|
/* |
4174
|
|
|
|
|
|
* Fetch index from 'aclass' |
4175
|
|
|
|
|
|
*/ |
4176
|
|
|
|
|
|
|
4177
|
38
|
|
|
|
|
if (flags & SHF_LARGE_CLASSLEN) |
4178
|
0
|
|
|
|
|
RLEN(idx); |
4179
|
|
|
|
|
|
else |
4180
|
38
|
|
|
|
|
GETMARK(idx); |
4181
|
|
|
|
|
|
|
4182
|
38
|
|
|
|
|
sva = av_fetch(cxt->aclass, idx, FALSE); |
4183
|
38
|
|
|
|
|
if (!sva) |
4184
|
0
|
|
|
|
|
CROAK(("Class name #%"IVdf" should have been seen already", |
4185
|
|
|
|
|
|
(IV) idx)); |
4186
|
|
|
|
|
|
|
4187
|
38
|
|
|
|
|
classname = SvPVX(*sva); /* We know it's a PV, by construction */ |
4188
|
|
|
|
|
|
TRACEME(("class ID %d => %s", idx, classname)); |
4189
|
|
|
|
|
|
|
4190
|
|
|
|
|
|
} else { |
4191
|
|
|
|
|
|
/* |
4192
|
|
|
|
|
|
* Decode class name length and read that name. |
4193
|
|
|
|
|
|
* |
4194
|
|
|
|
|
|
* NOTA BENE: even if the length is stored on one byte, we don't read |
4195
|
|
|
|
|
|
* on the stack. Just like retrieve_blessed(), we limit the name to |
4196
|
|
|
|
|
|
* LG_BLESS bytes. This is an arbitrary decision. |
4197
|
|
|
|
|
|
*/ |
4198
|
|
|
|
|
|
char *malloced_classname = NULL; |
4199
|
|
|
|
|
|
|
4200
|
166
|
|
|
|
|
if (flags & SHF_LARGE_CLASSLEN) |
4201
|
0
|
|
|
|
|
RLEN(len); |
4202
|
|
|
|
|
|
else |
4203
|
166
|
|
|
|
|
GETMARK(len); |
4204
|
|
|
|
|
|
|
4205
|
166
|
|
|
|
|
if (len > LG_BLESS) { |
4206
|
|
|
|
|
|
TRACEME(("** allocating %d bytes for class name", len+1)); |
4207
|
2
|
|
|
|
|
New(10003, classname, len+1, char); |
4208
|
|
|
|
|
|
malloced_classname = classname; |
4209
|
|
|
|
|
|
} |
4210
|
|
|
|
|
|
|
4211
|
330
|
|
|
|
|
SAFEPVREAD(classname, len, malloced_classname); |
4212
|
166
|
|
|
|
|
classname[len] = '\0'; /* Mark string end */ |
4213
|
|
|
|
|
|
|
4214
|
|
|
|
|
|
/* |
4215
|
|
|
|
|
|
* Record new classname. |
4216
|
|
|
|
|
|
*/ |
4217
|
|
|
|
|
|
|
4218
|
166
|
|
|
|
|
if (!av_store(cxt->aclass, cxt->classnum++, newSVpvn(classname, len))) { |
4219
|
0
|
|
|
|
|
Safefree(malloced_classname); |
4220
|
0
|
|
|
|
|
return (SV *) 0; |
4221
|
|
|
|
|
|
} |
4222
|
|
|
|
|
|
} |
4223
|
|
|
|
|
|
|
4224
|
|
|
|
|
|
TRACEME(("class name: %s", classname)); |
4225
|
|
|
|
|
|
|
4226
|
|
|
|
|
|
/* |
4227
|
|
|
|
|
|
* Decode user-frozen string length and read it in an SV. |
4228
|
|
|
|
|
|
* |
4229
|
|
|
|
|
|
* For efficiency reasons, we read data directly into the SV buffer. |
4230
|
|
|
|
|
|
* To understand that code, read retrieve_scalar() |
4231
|
|
|
|
|
|
*/ |
4232
|
|
|
|
|
|
|
4233
|
204
|
|
|
|
|
if (flags & SHF_LARGE_STRLEN) |
4234
|
96
|
|
|
|
|
RLEN(len2); |
4235
|
|
|
|
|
|
else |
4236
|
156
|
|
|
|
|
GETMARK(len2); |
4237
|
|
|
|
|
|
|
4238
|
204
|
|
|
|
|
frozen = NEWSV(10002, len2); |
4239
|
204
|
|
|
|
|
if (len2) { |
4240
|
248
|
|
|
|
|
SAFEREAD(SvPVX(frozen), len2, frozen); |
4241
|
124
|
|
|
|
|
SvCUR_set(frozen, len2); |
4242
|
124
|
|
|
|
|
*SvEND(frozen) = '\0'; |
4243
|
|
|
|
|
|
} |
4244
|
204
|
|
|
|
|
(void) SvPOK_only(frozen); /* Validates string pointer */ |
4245
|
204
|
|
|
|
|
if (cxt->s_tainted) /* Is input source tainted? */ |
4246
|
2
|
|
|
|
|
SvTAINT(frozen); |
4247
|
|
|
|
|
|
|
4248
|
|
|
|
|
|
TRACEME(("frozen string: %d bytes", len2)); |
4249
|
|
|
|
|
|
|
4250
|
|
|
|
|
|
/* |
4251
|
|
|
|
|
|
* Decode object-ID list length, if present. |
4252
|
|
|
|
|
|
*/ |
4253
|
|
|
|
|
|
|
4254
|
204
|
|
|
|
|
if (flags & SHF_HAS_LIST) { |
4255
|
160
|
|
|
|
|
if (flags & SHF_LARGE_LISTLEN) |
4256
|
0
|
|
|
|
|
RLEN(len3); |
4257
|
|
|
|
|
|
else |
4258
|
160
|
|
|
|
|
GETMARK(len3); |
4259
|
160
|
|
|
|
|
if (len3) { |
4260
|
160
|
|
|
|
|
av = newAV(); |
4261
|
160
|
|
|
|
|
av_extend(av, len3 + 1); /* Leave room for [0] */ |
4262
|
160
|
|
|
|
|
AvFILLp(av) = len3; /* About to be filled anyway */ |
4263
|
|
|
|
|
|
} |
4264
|
|
|
|
|
|
} |
4265
|
|
|
|
|
|
|
4266
|
|
|
|
|
|
TRACEME(("has %d object IDs to link", len3)); |
4267
|
|
|
|
|
|
|
4268
|
|
|
|
|
|
/* |
4269
|
|
|
|
|
|
* Read object-ID list into array. |
4270
|
|
|
|
|
|
* Because we pre-extended it, we can cheat and fill it manually. |
4271
|
|
|
|
|
|
* |
4272
|
|
|
|
|
|
* We read object tags and we can convert them into SV* on the fly |
4273
|
|
|
|
|
|
* because we know all the references listed in there (as tags) |
4274
|
|
|
|
|
|
* have been already serialized, hence we have a valid correspondence |
4275
|
|
|
|
|
|
* between each of those tags and the recreated SV. |
4276
|
|
|
|
|
|
*/ |
4277
|
|
|
|
|
|
|
4278
|
204
|
|
|
|
|
if (av) { |
4279
|
160
|
|
|
|
|
SV **ary = AvARRAY(av); |
4280
|
|
|
|
|
|
int i; |
4281
|
356
|
|
|
|
|
for (i = 1; i <= len3; i++) { /* We leave [0] alone */ |
4282
|
|
|
|
|
|
I32 tag; |
4283
|
|
|
|
|
|
SV **svh; |
4284
|
|
|
|
|
|
SV *xsv; |
4285
|
|
|
|
|
|
|
4286
|
392
|
|
|
|
|
READ_I32(tag); |
4287
|
196
|
|
|
|
|
tag = ntohl(tag); |
4288
|
196
|
|
|
|
|
svh = av_fetch(cxt->aseen, tag, FALSE); |
4289
|
196
|
|
|
|
|
if (!svh) { |
4290
|
0
|
|
|
|
|
if (tag == cxt->where_is_undef) { |
4291
|
|
|
|
|
|
/* av_fetch uses PL_sv_undef internally, hence this |
4292
|
|
|
|
|
|
somewhat gruesome hack. */ |
4293
|
0
|
|
|
|
|
xsv = &PL_sv_undef; |
4294
|
|
|
|
|
|
svh = &xsv; |
4295
|
|
|
|
|
|
} else { |
4296
|
0
|
|
|
|
|
CROAK(("Object #%"IVdf" should have been retrieved already", |
4297
|
|
|
|
|
|
(IV) tag)); |
4298
|
|
|
|
|
|
} |
4299
|
|
|
|
|
|
} |
4300
|
196
|
|
|
|
|
xsv = *svh; |
4301
|
392
|
|
|
|
|
ary[i] = SvREFCNT_inc(xsv); |
4302
|
|
|
|
|
|
} |
4303
|
|
|
|
|
|
} |
4304
|
|
|
|
|
|
|
4305
|
|
|
|
|
|
/* |
4306
|
|
|
|
|
|
* Look up the STORABLE_attach hook |
4307
|
|
|
|
|
|
*/ |
4308
|
204
|
|
|
|
|
stash = gv_stashpv(classname, GV_ADD); |
4309
|
|
|
|
|
|
|
4310
|
|
|
|
|
|
/* Handle attach case; again can't use pkg_can because it only |
4311
|
|
|
|
|
|
* caches one method */ |
4312
|
204
|
|
|
|
|
attach = gv_fetchmethod_autoload(stash, "STORABLE_attach", FALSE); |
4313
|
204
|
|
|
|
|
if (attach && isGV(attach)) { |
4314
|
|
|
|
|
|
SV* attached; |
4315
|
26
|
|
|
|
|
SV* attach_hook = newRV((SV*) GvCV(attach)); |
4316
|
|
|
|
|
|
|
4317
|
26
|
|
|
|
|
if (av) |
4318
|
2
|
|
|
|
|
CROAK(("STORABLE_attach called with unexpected references")); |
4319
|
24
|
|
|
|
|
av = newAV(); |
4320
|
24
|
|
|
|
|
av_extend(av, 1); |
4321
|
24
|
|
|
|
|
AvFILLp(av) = 0; |
4322
|
48
|
|
|
|
|
AvARRAY(av)[0] = SvREFCNT_inc(frozen); |
4323
|
24
|
|
|
|
|
rv = newSVpv(classname, 0); |
4324
|
24
|
|
|
|
|
attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR); |
4325
|
|
|
|
|
|
/* Free memory after a call */ |
4326
|
24
|
|
|
|
|
SvREFCNT_dec(rv); |
4327
|
24
|
|
|
|
|
SvREFCNT_dec(frozen); |
4328
|
24
|
|
|
|
|
av_undef(av); |
4329
|
24
|
|
|
|
|
sv_free((SV *) av); |
4330
|
24
|
|
|
|
|
SvREFCNT_dec(attach_hook); |
4331
|
48
|
|
|
|
|
if (attached && |
4332
|
42
|
|
|
|
|
SvROK(attached) && |
4333
|
18
|
|
|
|
|
sv_derived_from(attached, classname) |
4334
|
|
|
|
|
|
) { |
4335
|
10
|
|
|
|
|
UNSEE(); |
4336
|
|
|
|
|
|
/* refcnt of unneeded sv is 2 at this point (one from newHV, second from SEEN call) */ |
4337
|
10
|
|
|
|
|
SvREFCNT_dec(sv); |
4338
|
10
|
|
|
|
|
SvREFCNT_dec(sv); |
4339
|
|
|
|
|
|
/* we need to free RV but preserve value that RV point to */ |
4340
|
10
|
|
|
|
|
sv = SvRV(attached); |
4341
|
20
|
|
|
|
|
SEEN(sv, 0, 0); |
4342
|
10
|
|
|
|
|
SvRV_set(attached, NULL); |
4343
|
10
|
|
|
|
|
SvREFCNT_dec(attached); |
4344
|
10
|
|
|
|
|
if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) |
4345
|
0
|
|
|
|
|
Safefree(classname); |
4346
|
|
|
|
|
|
return sv; |
4347
|
|
|
|
|
|
} |
4348
|
14
|
|
|
|
|
CROAK(("STORABLE_attach did not return a %s object", classname)); |
4349
|
|
|
|
|
|
} |
4350
|
|
|
|
|
|
|
4351
|
|
|
|
|
|
/* |
4352
|
|
|
|
|
|
* Bless the object and look up the STORABLE_thaw hook. |
4353
|
|
|
|
|
|
*/ |
4354
|
|
|
|
|
|
|
4355
|
356
|
|
|
|
|
BLESS(sv, stash); |
4356
|
|
|
|
|
|
|
4357
|
178
|
|
|
|
|
hook = pkg_can(aTHX_ cxt->hook, stash, "STORABLE_thaw"); |
4358
|
178
|
|
|
|
|
if (!hook) { |
4359
|
|
|
|
|
|
/* |
4360
|
|
|
|
|
|
* Hook not found. Maybe they did not require the module where this |
4361
|
|
|
|
|
|
* hook is defined yet? |
4362
|
|
|
|
|
|
* |
4363
|
|
|
|
|
|
* If the load below succeeds, we'll be able to find the hook. |
4364
|
|
|
|
|
|
* Still, it only works reliably when each class is defined in a |
4365
|
|
|
|
|
|
* file of its own. |
4366
|
|
|
|
|
|
*/ |
4367
|
|
|
|
|
|
|
4368
|
|
|
|
|
|
TRACEME(("No STORABLE_thaw defined for objects of class %s", classname)); |
4369
|
|
|
|
|
|
TRACEME(("Going to load module '%s'", classname)); |
4370
|
4
|
|
|
|
|
load_module(PERL_LOADMOD_NOIMPORT, newSVpv(classname, 0), Nullsv); |
4371
|
|
|
|
|
|
|
4372
|
|
|
|
|
|
/* |
4373
|
|
|
|
|
|
* We cache results of pkg_can, so we need to uncache before attempting |
4374
|
|
|
|
|
|
* the lookup again. |
4375
|
|
|
|
|
|
*/ |
4376
|
|
|
|
|
|
|
4377
|
4
|
|
|
|
|
pkg_uncache(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); |
4378
|
4
|
|
|
|
|
hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw"); |
4379
|
|
|
|
|
|
|
4380
|
4
|
|
|
|
|
if (!hook) |
4381
|
0
|
|
|
|
|
CROAK(("No STORABLE_thaw defined for objects of class %s " |
4382
|
|
|
|
|
|
"(even after a \"require %s;\")", classname, classname)); |
4383
|
|
|
|
|
|
} |
4384
|
|
|
|
|
|
|
4385
|
|
|
|
|
|
/* |
4386
|
|
|
|
|
|
* If we don't have an 'av' yet, prepare one. |
4387
|
|
|
|
|
|
* Then insert the frozen string as item [0]. |
4388
|
|
|
|
|
|
*/ |
4389
|
|
|
|
|
|
|
4390
|
178
|
|
|
|
|
if (!av) { |
4391
|
20
|
|
|
|
|
av = newAV(); |
4392
|
20
|
|
|
|
|
av_extend(av, 1); |
4393
|
20
|
|
|
|
|
AvFILLp(av) = 0; |
4394
|
|
|
|
|
|
} |
4395
|
356
|
|
|
|
|
AvARRAY(av)[0] = SvREFCNT_inc(frozen); |
4396
|
|
|
|
|
|
|
4397
|
|
|
|
|
|
/* |
4398
|
|
|
|
|
|
* Call the hook as: |
4399
|
|
|
|
|
|
* |
4400
|
|
|
|
|
|
* $object->STORABLE_thaw($cloning, $frozen, @refs); |
4401
|
|
|
|
|
|
* |
4402
|
|
|
|
|
|
* where $object is our blessed (empty) object, $cloning is a boolean |
4403
|
|
|
|
|
|
* telling whether we're running a deep clone, $frozen is the frozen |
4404
|
|
|
|
|
|
* string the user gave us in his serializing hook, and @refs, which may |
4405
|
|
|
|
|
|
* be empty, is the list of extra references he returned along for us |
4406
|
|
|
|
|
|
* to serialize. |
4407
|
|
|
|
|
|
* |
4408
|
|
|
|
|
|
* In effect, the hook is an alternate creation routine for the class, |
4409
|
|
|
|
|
|
* the object itself being already created by the runtime. |
4410
|
|
|
|
|
|
*/ |
4411
|
|
|
|
|
|
|
4412
|
|
|
|
|
|
TRACEME(("calling STORABLE_thaw on %s at 0x%"UVxf" (%"IVdf" args)", |
4413
|
|
|
|
|
|
classname, PTR2UV(sv), (IV) AvFILLp(av) + 1)); |
4414
|
|
|
|
|
|
|
4415
|
178
|
|
|
|
|
rv = newRV(sv); |
4416
|
178
|
|
|
|
|
(void) scalar_call(aTHX_ rv, hook, clone, av, G_SCALAR|G_DISCARD); |
4417
|
178
|
|
|
|
|
SvREFCNT_dec(rv); |
4418
|
|
|
|
|
|
|
4419
|
|
|
|
|
|
/* |
4420
|
|
|
|
|
|
* Final cleanup. |
4421
|
|
|
|
|
|
*/ |
4422
|
|
|
|
|
|
|
4423
|
178
|
|
|
|
|
SvREFCNT_dec(frozen); |
4424
|
178
|
|
|
|
|
av_undef(av); |
4425
|
178
|
|
|
|
|
sv_free((SV *) av); |
4426
|
178
|
|
|
|
|
if (!(flags & SHF_IDX_CLASSNAME) && classname != buf) |
4427
|
2
|
|
|
|
|
Safefree(classname); |
4428
|
|
|
|
|
|
|
4429
|
|
|
|
|
|
/* |
4430
|
|
|
|
|
|
* If we had an type, then the object was not as simple, and |
4431
|
|
|
|
|
|
* we need to restore extra magic now. |
4432
|
|
|
|
|
|
*/ |
4433
|
|
|
|
|
|
|
4434
|
178
|
|
|
|
|
if (!extra_type) |
4435
|
|
|
|
|
|
return sv; |
4436
|
|
|
|
|
|
|
4437
|
|
|
|
|
|
TRACEME(("retrieving magic object for 0x%"UVxf"...", PTR2UV(sv))); |
4438
|
|
|
|
|
|
|
4439
|
2
|
|
|
|
|
rv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4440
|
|
|
|
|
|
|
4441
|
|
|
|
|
|
TRACEME(("restoring the magic object 0x%"UVxf" part of 0x%"UVxf, |
4442
|
|
|
|
|
|
PTR2UV(rv), PTR2UV(sv))); |
4443
|
|
|
|
|
|
|
4444
|
2
|
|
|
|
|
switch (extra_type) { |
4445
|
|
|
|
|
|
case SHT_TSCALAR: |
4446
|
0
|
|
|
|
|
sv_upgrade(sv, SVt_PVMG); |
4447
|
0
|
|
|
|
|
break; |
4448
|
|
|
|
|
|
case SHT_TARRAY: |
4449
|
0
|
|
|
|
|
sv_upgrade(sv, SVt_PVAV); |
4450
|
0
|
|
|
|
|
AvREAL_off((AV *)sv); |
4451
|
0
|
|
|
|
|
break; |
4452
|
|
|
|
|
|
case SHT_THASH: |
4453
|
2
|
|
|
|
|
sv_upgrade(sv, SVt_PVHV); |
4454
|
2
|
|
|
|
|
break; |
4455
|
|
|
|
|
|
default: |
4456
|
0
|
|
|
|
|
CROAK(("Forgot to deal with extra type %d", extra_type)); |
4457
|
|
|
|
|
|
break; |
4458
|
|
|
|
|
|
} |
4459
|
|
|
|
|
|
|
4460
|
|
|
|
|
|
/* |
4461
|
|
|
|
|
|
* Adding the magic only now, well after the STORABLE_thaw hook was called |
4462
|
|
|
|
|
|
* means the hook cannot know it deals with an object whose variable is |
4463
|
|
|
|
|
|
* tied. But this is happening when retrieving $o in the following case: |
4464
|
|
|
|
|
|
* |
4465
|
|
|
|
|
|
* my %h; |
4466
|
|
|
|
|
|
* tie %h, 'FOO'; |
4467
|
|
|
|
|
|
* my $o = bless \%h, 'BAR'; |
4468
|
|
|
|
|
|
* |
4469
|
|
|
|
|
|
* The 'BAR' class is NOT the one where %h is tied into. Therefore, as |
4470
|
|
|
|
|
|
* far as the 'BAR' class is concerned, the fact that %h is not a REAL |
4471
|
|
|
|
|
|
* hash but a tied one should not matter at all, and remain transparent. |
4472
|
|
|
|
|
|
* This means the magic must be restored by Storable AFTER the hook is |
4473
|
|
|
|
|
|
* called. |
4474
|
|
|
|
|
|
* |
4475
|
|
|
|
|
|
* That looks very reasonable to me, but then I've come up with this |
4476
|
|
|
|
|
|
* after a bug report from David Nesting, who was trying to store such |
4477
|
|
|
|
|
|
* an object and caused Storable to fail. And unfortunately, it was |
4478
|
|
|
|
|
|
* also the easiest way to retrofit support for blessed ref to tied objects |
4479
|
|
|
|
|
|
* into the existing design. -- RAM, 17/02/2001 |
4480
|
|
|
|
|
|
*/ |
4481
|
|
|
|
|
|
|
4482
|
2
|
|
|
|
|
sv_magic(sv, rv, mtype, (char *)NULL, 0); |
4483
|
2
|
|
|
|
|
SvREFCNT_dec(rv); /* Undo refcnt inc from sv_magic() */ |
4484
|
|
|
|
|
|
|
4485
|
2
|
|
|
|
|
return sv; |
4486
|
|
|
|
|
|
} |
4487
|
|
|
|
|
|
|
4488
|
|
|
|
|
|
/* |
4489
|
|
|
|
|
|
* retrieve_ref |
4490
|
|
|
|
|
|
* |
4491
|
|
|
|
|
|
* Retrieve reference to some other scalar. |
4492
|
|
|
|
|
|
* Layout is SX_REF , with SX_REF already read. |
4493
|
|
|
|
|
|
*/ |
4494
|
176639334
|
|
|
|
|
static SV *retrieve_ref(pTHX_ stcxt_t *cxt, const char *cname) |
4495
|
|
|
|
|
|
{ |
4496
|
|
|
|
|
|
SV *rv; |
4497
|
|
|
|
|
|
SV *sv; |
4498
|
|
|
|
|
|
HV *stash; |
4499
|
|
|
|
|
|
|
4500
|
|
|
|
|
|
TRACEME(("retrieve_ref (#%d)", cxt->tagnum)); |
4501
|
|
|
|
|
|
|
4502
|
|
|
|
|
|
/* |
4503
|
|
|
|
|
|
* We need to create the SV that holds the reference to the yet-to-retrieve |
4504
|
|
|
|
|
|
* object now, so that we may record the address in the seen table. |
4505
|
|
|
|
|
|
* Otherwise, if the object to retrieve references us, we won't be able |
4506
|
|
|
|
|
|
* to resolve the SX_OBJECT we'll see at that point! Hence we cannot |
4507
|
|
|
|
|
|
* do the retrieve first and use rv = newRV(sv) since it will be too late |
4508
|
|
|
|
|
|
* for SEEN() recording. |
4509
|
|
|
|
|
|
*/ |
4510
|
|
|
|
|
|
|
4511
|
176639334
|
|
|
|
|
rv = NEWSV(10002, 0); |
4512
|
176639334
|
|
|
|
|
if (cname) |
4513
|
4
|
|
|
|
|
stash = gv_stashpv(cname, GV_ADD); |
4514
|
|
|
|
|
|
else |
4515
|
|
|
|
|
|
stash = 0; |
4516
|
353278672
|
|
|
|
|
SEEN(rv, stash, 0); /* Will return if rv is null */ |
4517
|
176639334
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4518
|
176639334
|
|
|
|
|
if (!sv) |
4519
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4520
|
|
|
|
|
|
|
4521
|
|
|
|
|
|
/* |
4522
|
|
|
|
|
|
* WARNING: breaks RV encapsulation. |
4523
|
|
|
|
|
|
* |
4524
|
|
|
|
|
|
* Now for the tricky part. We have to upgrade our existing SV, so that |
4525
|
|
|
|
|
|
* it is now an RV on sv... Again, we cheat by duplicating the code |
4526
|
|
|
|
|
|
* held in newSVrv(), since we already got our SV from retrieve(). |
4527
|
|
|
|
|
|
* |
4528
|
|
|
|
|
|
* We don't say: |
4529
|
|
|
|
|
|
* |
4530
|
|
|
|
|
|
* SvRV(rv) = SvREFCNT_inc(sv); |
4531
|
|
|
|
|
|
* |
4532
|
|
|
|
|
|
* here because the reference count we got from retrieve() above is |
4533
|
|
|
|
|
|
* already correct: if the object was retrieved from the file, then |
4534
|
|
|
|
|
|
* its reference count is one. Otherwise, if it was retrieved via |
4535
|
|
|
|
|
|
* an SX_OBJECT indication, a ref count increment was done. |
4536
|
|
|
|
|
|
*/ |
4537
|
|
|
|
|
|
|
4538
|
176639334
|
|
|
|
|
if (cname) { |
4539
|
|
|
|
|
|
/* No need to do anything, as rv will already be PVMG. */ |
4540
|
|
|
|
|
|
assert (SvTYPE(rv) == SVt_RV || SvTYPE(rv) >= SVt_PV); |
4541
|
|
|
|
|
|
} else { |
4542
|
176639330
|
|
|
|
|
sv_upgrade(rv, SVt_RV); |
4543
|
|
|
|
|
|
} |
4544
|
|
|
|
|
|
|
4545
|
176639334
|
|
|
|
|
SvRV_set(rv, sv); /* $rv = \$sv */ |
4546
|
176639334
|
|
|
|
|
SvROK_on(rv); |
4547
|
|
|
|
|
|
|
4548
|
|
|
|
|
|
TRACEME(("ok (retrieve_ref at 0x%"UVxf")", PTR2UV(rv))); |
4549
|
|
|
|
|
|
|
4550
|
176639334
|
|
|
|
|
return rv; |
4551
|
|
|
|
|
|
} |
4552
|
|
|
|
|
|
|
4553
|
|
|
|
|
|
/* |
4554
|
|
|
|
|
|
* retrieve_weakref |
4555
|
|
|
|
|
|
* |
4556
|
|
|
|
|
|
* Retrieve weak reference to some other scalar. |
4557
|
|
|
|
|
|
* Layout is SX_WEAKREF , with SX_WEAKREF already read. |
4558
|
|
|
|
|
|
*/ |
4559
|
24
|
|
|
|
|
static SV *retrieve_weakref(pTHX_ stcxt_t *cxt, const char *cname) |
4560
|
|
|
|
|
|
{ |
4561
|
|
|
|
|
|
SV *sv; |
4562
|
|
|
|
|
|
|
4563
|
|
|
|
|
|
TRACEME(("retrieve_weakref (#%d)", cxt->tagnum)); |
4564
|
|
|
|
|
|
|
4565
|
24
|
|
|
|
|
sv = retrieve_ref(aTHX_ cxt, cname); |
4566
|
24
|
|
|
|
|
if (sv) { |
4567
|
|
|
|
|
|
#ifdef SvWEAKREF |
4568
|
24
|
|
|
|
|
sv_rvweaken(sv); |
4569
|
|
|
|
|
|
#else |
4570
|
|
|
|
|
|
WEAKREF_CROAK(); |
4571
|
|
|
|
|
|
#endif |
4572
|
|
|
|
|
|
} |
4573
|
24
|
|
|
|
|
return sv; |
4574
|
|
|
|
|
|
} |
4575
|
|
|
|
|
|
|
4576
|
|
|
|
|
|
/* |
4577
|
|
|
|
|
|
* retrieve_overloaded |
4578
|
|
|
|
|
|
* |
4579
|
|
|
|
|
|
* Retrieve reference to some other scalar with overloading. |
4580
|
|
|
|
|
|
* Layout is SX_OVERLOAD , with SX_OVERLOAD already read. |
4581
|
|
|
|
|
|
*/ |
4582
|
68
|
|
|
|
|
static SV *retrieve_overloaded(pTHX_ stcxt_t *cxt, const char *cname) |
4583
|
68
|
|
|
|
|
{ |
4584
|
|
|
|
|
|
SV *rv; |
4585
|
|
|
|
|
|
SV *sv; |
4586
|
|
|
|
|
|
HV *stash; |
4587
|
|
|
|
|
|
|
4588
|
|
|
|
|
|
TRACEME(("retrieve_overloaded (#%d)", cxt->tagnum)); |
4589
|
|
|
|
|
|
|
4590
|
|
|
|
|
|
/* |
4591
|
|
|
|
|
|
* Same code as retrieve_ref(), duplicated to avoid extra call. |
4592
|
|
|
|
|
|
*/ |
4593
|
|
|
|
|
|
|
4594
|
68
|
|
|
|
|
rv = NEWSV(10002, 0); |
4595
|
68
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4596
|
138
|
|
|
|
|
SEEN(rv, stash, 0); /* Will return if rv is null */ |
4597
|
68
|
|
|
|
|
cxt->in_retrieve_overloaded = 1; /* so sv_bless doesn't call S_reset_amagic */ |
4598
|
68
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4599
|
68
|
|
|
|
|
cxt->in_retrieve_overloaded = 0; |
4600
|
68
|
|
|
|
|
if (!sv) |
4601
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4602
|
|
|
|
|
|
|
4603
|
|
|
|
|
|
/* |
4604
|
|
|
|
|
|
* WARNING: breaks RV encapsulation. |
4605
|
|
|
|
|
|
*/ |
4606
|
|
|
|
|
|
|
4607
|
134
|
|
|
|
|
SvUPGRADE(rv, SVt_RV); |
4608
|
68
|
|
|
|
|
SvRV_set(rv, sv); /* $rv = \$sv */ |
4609
|
68
|
|
|
|
|
SvROK_on(rv); |
4610
|
|
|
|
|
|
|
4611
|
|
|
|
|
|
/* |
4612
|
|
|
|
|
|
* Restore overloading magic. |
4613
|
|
|
|
|
|
*/ |
4614
|
|
|
|
|
|
|
4615
|
68
|
|
|
|
|
stash = SvTYPE(sv) ? (HV *) SvSTASH (sv) : 0; |
4616
|
68
|
|
|
|
|
if (!stash) { |
4617
|
0
|
|
|
|
|
CROAK(("Cannot restore overloading on %s(0x%"UVxf |
4618
|
|
|
|
|
|
") (package )", |
4619
|
|
|
|
|
|
sv_reftype(sv, FALSE), |
4620
|
|
|
|
|
|
PTR2UV(sv))); |
4621
|
|
|
|
|
|
} |
4622
|
68
|
|
|
|
|
if (!Gv_AMG(stash)) { |
4623
|
2
|
|
|
|
|
const char *package = HvNAME_get(stash); |
4624
|
|
|
|
|
|
TRACEME(("No overloading defined for package %s", package)); |
4625
|
|
|
|
|
|
TRACEME(("Going to load module '%s'", package)); |
4626
|
2
|
|
|
|
|
load_module(PERL_LOADMOD_NOIMPORT, newSVpv(package, 0), Nullsv); |
4627
|
2
|
|
|
|
|
if (!Gv_AMG(stash)) { |
4628
|
0
|
|
|
|
|
CROAK(("Cannot restore overloading on %s(0x%"UVxf |
4629
|
|
|
|
|
|
") (package %s) (even after a \"require %s;\")", |
4630
|
|
|
|
|
|
sv_reftype(sv, FALSE), |
4631
|
|
|
|
|
|
PTR2UV(sv), |
4632
|
|
|
|
|
|
package, package)); |
4633
|
|
|
|
|
|
} |
4634
|
|
|
|
|
|
} |
4635
|
|
|
|
|
|
|
4636
|
|
|
|
|
|
SvAMAGIC_on(rv); |
4637
|
|
|
|
|
|
|
4638
|
|
|
|
|
|
TRACEME(("ok (retrieve_overloaded at 0x%"UVxf")", PTR2UV(rv))); |
4639
|
|
|
|
|
|
|
4640
|
|
|
|
|
|
return rv; |
4641
|
|
|
|
|
|
} |
4642
|
|
|
|
|
|
|
4643
|
|
|
|
|
|
/* |
4644
|
|
|
|
|
|
* retrieve_weakoverloaded |
4645
|
|
|
|
|
|
* |
4646
|
|
|
|
|
|
* Retrieve weak overloaded reference to some other scalar. |
4647
|
|
|
|
|
|
* Layout is SX_WEAKOVERLOADED , with SX_WEAKOVERLOADED already read. |
4648
|
|
|
|
|
|
*/ |
4649
|
8
|
|
|
|
|
static SV *retrieve_weakoverloaded(pTHX_ stcxt_t *cxt, const char *cname) |
4650
|
|
|
|
|
|
{ |
4651
|
|
|
|
|
|
SV *sv; |
4652
|
|
|
|
|
|
|
4653
|
|
|
|
|
|
TRACEME(("retrieve_weakoverloaded (#%d)", cxt->tagnum)); |
4654
|
|
|
|
|
|
|
4655
|
8
|
|
|
|
|
sv = retrieve_overloaded(aTHX_ cxt, cname); |
4656
|
8
|
|
|
|
|
if (sv) { |
4657
|
|
|
|
|
|
#ifdef SvWEAKREF |
4658
|
8
|
|
|
|
|
sv_rvweaken(sv); |
4659
|
|
|
|
|
|
#else |
4660
|
|
|
|
|
|
WEAKREF_CROAK(); |
4661
|
|
|
|
|
|
#endif |
4662
|
|
|
|
|
|
} |
4663
|
8
|
|
|
|
|
return sv; |
4664
|
|
|
|
|
|
} |
4665
|
|
|
|
|
|
|
4666
|
|
|
|
|
|
/* |
4667
|
|
|
|
|
|
* retrieve_tied_array |
4668
|
|
|
|
|
|
* |
4669
|
|
|
|
|
|
* Retrieve tied array |
4670
|
|
|
|
|
|
* Layout is SX_TIED_ARRAY , with SX_TIED_ARRAY already read. |
4671
|
|
|
|
|
|
*/ |
4672
|
4
|
|
|
|
|
static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname) |
4673
|
|
|
|
|
|
{ |
4674
|
|
|
|
|
|
SV *tv; |
4675
|
|
|
|
|
|
SV *sv; |
4676
|
|
|
|
|
|
HV *stash; |
4677
|
|
|
|
|
|
|
4678
|
|
|
|
|
|
TRACEME(("retrieve_tied_array (#%d)", cxt->tagnum)); |
4679
|
|
|
|
|
|
|
4680
|
4
|
|
|
|
|
tv = NEWSV(10002, 0); |
4681
|
4
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4682
|
8
|
|
|
|
|
SEEN(tv, cname, 0); /* Will return if tv is null */ |
4683
|
4
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4684
|
4
|
|
|
|
|
if (!sv) |
4685
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4686
|
|
|
|
|
|
|
4687
|
4
|
|
|
|
|
sv_upgrade(tv, SVt_PVAV); |
4688
|
4
|
|
|
|
|
AvREAL_off((AV *)tv); |
4689
|
4
|
|
|
|
|
sv_magic(tv, sv, 'P', (char *)NULL, 0); |
4690
|
4
|
|
|
|
|
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ |
4691
|
|
|
|
|
|
|
4692
|
|
|
|
|
|
TRACEME(("ok (retrieve_tied_array at 0x%"UVxf")", PTR2UV(tv))); |
4693
|
|
|
|
|
|
|
4694
|
4
|
|
|
|
|
return tv; |
4695
|
|
|
|
|
|
} |
4696
|
|
|
|
|
|
|
4697
|
|
|
|
|
|
/* |
4698
|
|
|
|
|
|
* retrieve_tied_hash |
4699
|
|
|
|
|
|
* |
4700
|
|
|
|
|
|
* Retrieve tied hash |
4701
|
|
|
|
|
|
* Layout is SX_TIED_HASH , with SX_TIED_HASH already read. |
4702
|
|
|
|
|
|
*/ |
4703
|
8
|
|
|
|
|
static SV *retrieve_tied_hash(pTHX_ stcxt_t *cxt, const char *cname) |
4704
|
|
|
|
|
|
{ |
4705
|
|
|
|
|
|
SV *tv; |
4706
|
|
|
|
|
|
SV *sv; |
4707
|
|
|
|
|
|
HV *stash; |
4708
|
|
|
|
|
|
|
4709
|
|
|
|
|
|
TRACEME(("retrieve_tied_hash (#%d)", cxt->tagnum)); |
4710
|
|
|
|
|
|
|
4711
|
8
|
|
|
|
|
tv = NEWSV(10002, 0); |
4712
|
8
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4713
|
18
|
|
|
|
|
SEEN(tv, stash, 0); /* Will return if tv is null */ |
4714
|
8
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4715
|
8
|
|
|
|
|
if (!sv) |
4716
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4717
|
|
|
|
|
|
|
4718
|
8
|
|
|
|
|
sv_upgrade(tv, SVt_PVHV); |
4719
|
8
|
|
|
|
|
sv_magic(tv, sv, 'P', (char *)NULL, 0); |
4720
|
8
|
|
|
|
|
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ |
4721
|
|
|
|
|
|
|
4722
|
|
|
|
|
|
TRACEME(("ok (retrieve_tied_hash at 0x%"UVxf")", PTR2UV(tv))); |
4723
|
|
|
|
|
|
|
4724
|
8
|
|
|
|
|
return tv; |
4725
|
|
|
|
|
|
} |
4726
|
|
|
|
|
|
|
4727
|
|
|
|
|
|
/* |
4728
|
|
|
|
|
|
* retrieve_tied_scalar |
4729
|
|
|
|
|
|
* |
4730
|
|
|
|
|
|
* Retrieve tied scalar |
4731
|
|
|
|
|
|
* Layout is SX_TIED_SCALAR , with SX_TIED_SCALAR already read. |
4732
|
|
|
|
|
|
*/ |
4733
|
8
|
|
|
|
|
static SV *retrieve_tied_scalar(pTHX_ stcxt_t *cxt, const char *cname) |
4734
|
|
|
|
|
|
{ |
4735
|
|
|
|
|
|
SV *tv; |
4736
|
|
|
|
|
|
SV *sv, *obj = NULL; |
4737
|
|
|
|
|
|
HV *stash; |
4738
|
|
|
|
|
|
|
4739
|
|
|
|
|
|
TRACEME(("retrieve_tied_scalar (#%d)", cxt->tagnum)); |
4740
|
|
|
|
|
|
|
4741
|
8
|
|
|
|
|
tv = NEWSV(10002, 0); |
4742
|
8
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4743
|
18
|
|
|
|
|
SEEN(tv, stash, 0); /* Will return if rv is null */ |
4744
|
8
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4745
|
8
|
|
|
|
|
if (!sv) { |
4746
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4747
|
|
|
|
|
|
} |
4748
|
8
|
|
|
|
|
else if (SvTYPE(sv) != SVt_NULL) { |
4749
|
|
|
|
|
|
obj = sv; |
4750
|
|
|
|
|
|
} |
4751
|
|
|
|
|
|
|
4752
|
8
|
|
|
|
|
sv_upgrade(tv, SVt_PVMG); |
4753
|
8
|
|
|
|
|
sv_magic(tv, obj, 'q', (char *)NULL, 0); |
4754
|
|
|
|
|
|
|
4755
|
8
|
|
|
|
|
if (obj) { |
4756
|
|
|
|
|
|
/* Undo refcnt inc from sv_magic() */ |
4757
|
6
|
|
|
|
|
SvREFCNT_dec(obj); |
4758
|
|
|
|
|
|
} |
4759
|
|
|
|
|
|
|
4760
|
|
|
|
|
|
TRACEME(("ok (retrieve_tied_scalar at 0x%"UVxf")", PTR2UV(tv))); |
4761
|
|
|
|
|
|
|
4762
|
|
|
|
|
|
return tv; |
4763
|
|
|
|
|
|
} |
4764
|
|
|
|
|
|
|
4765
|
|
|
|
|
|
/* |
4766
|
|
|
|
|
|
* retrieve_tied_key |
4767
|
|
|
|
|
|
* |
4768
|
|
|
|
|
|
* Retrieve reference to value in a tied hash. |
4769
|
|
|
|
|
|
* Layout is SX_TIED_KEY , with SX_TIED_KEY already read. |
4770
|
|
|
|
|
|
*/ |
4771
|
2
|
|
|
|
|
static SV *retrieve_tied_key(pTHX_ stcxt_t *cxt, const char *cname) |
4772
|
|
|
|
|
|
{ |
4773
|
|
|
|
|
|
SV *tv; |
4774
|
|
|
|
|
|
SV *sv; |
4775
|
|
|
|
|
|
SV *key; |
4776
|
|
|
|
|
|
HV *stash; |
4777
|
|
|
|
|
|
|
4778
|
|
|
|
|
|
TRACEME(("retrieve_tied_key (#%d)", cxt->tagnum)); |
4779
|
|
|
|
|
|
|
4780
|
2
|
|
|
|
|
tv = NEWSV(10002, 0); |
4781
|
2
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4782
|
4
|
|
|
|
|
SEEN(tv, stash, 0); /* Will return if tv is null */ |
4783
|
2
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4784
|
2
|
|
|
|
|
if (!sv) |
4785
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4786
|
|
|
|
|
|
|
4787
|
2
|
|
|
|
|
key = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4788
|
2
|
|
|
|
|
if (!key) |
4789
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4790
|
|
|
|
|
|
|
4791
|
2
|
|
|
|
|
sv_upgrade(tv, SVt_PVMG); |
4792
|
2
|
|
|
|
|
sv_magic(tv, sv, 'p', (char *)key, HEf_SVKEY); |
4793
|
2
|
|
|
|
|
SvREFCNT_dec(key); /* Undo refcnt inc from sv_magic() */ |
4794
|
2
|
|
|
|
|
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ |
4795
|
|
|
|
|
|
|
4796
|
2
|
|
|
|
|
return tv; |
4797
|
|
|
|
|
|
} |
4798
|
|
|
|
|
|
|
4799
|
|
|
|
|
|
/* |
4800
|
|
|
|
|
|
* retrieve_tied_idx |
4801
|
|
|
|
|
|
* |
4802
|
|
|
|
|
|
* Retrieve reference to value in a tied array. |
4803
|
|
|
|
|
|
* Layout is SX_TIED_IDX , with SX_TIED_IDX already read. |
4804
|
|
|
|
|
|
*/ |
4805
|
2
|
|
|
|
|
static SV *retrieve_tied_idx(pTHX_ stcxt_t *cxt, const char *cname) |
4806
|
|
|
|
|
|
{ |
4807
|
|
|
|
|
|
SV *tv; |
4808
|
|
|
|
|
|
SV *sv; |
4809
|
|
|
|
|
|
HV *stash; |
4810
|
|
|
|
|
|
I32 idx; |
4811
|
|
|
|
|
|
|
4812
|
|
|
|
|
|
TRACEME(("retrieve_tied_idx (#%d)", cxt->tagnum)); |
4813
|
|
|
|
|
|
|
4814
|
2
|
|
|
|
|
tv = NEWSV(10002, 0); |
4815
|
2
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4816
|
4
|
|
|
|
|
SEEN(tv, stash, 0); /* Will return if tv is null */ |
4817
|
2
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve */ |
4818
|
2
|
|
|
|
|
if (!sv) |
4819
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
4820
|
|
|
|
|
|
|
4821
|
4
|
|
|
|
|
RLEN(idx); /* Retrieve */ |
4822
|
|
|
|
|
|
|
4823
|
2
|
|
|
|
|
sv_upgrade(tv, SVt_PVMG); |
4824
|
2
|
|
|
|
|
sv_magic(tv, sv, 'p', (char *)NULL, idx); |
4825
|
2
|
|
|
|
|
SvREFCNT_dec(sv); /* Undo refcnt inc from sv_magic() */ |
4826
|
|
|
|
|
|
|
4827
|
2
|
|
|
|
|
return tv; |
4828
|
|
|
|
|
|
} |
4829
|
|
|
|
|
|
|
4830
|
|
|
|
|
|
|
4831
|
|
|
|
|
|
/* |
4832
|
|
|
|
|
|
* retrieve_lscalar |
4833
|
|
|
|
|
|
* |
4834
|
|
|
|
|
|
* Retrieve defined long (string) scalar. |
4835
|
|
|
|
|
|
* |
4836
|
|
|
|
|
|
* Layout is SX_LSCALAR , with SX_LSCALAR already read. |
4837
|
|
|
|
|
|
* The scalar is "long" in that is larger than LG_SCALAR so it |
4838
|
|
|
|
|
|
* was not stored on a single byte. |
4839
|
|
|
|
|
|
*/ |
4840
|
12608
|
|
|
|
|
static SV *retrieve_lscalar(pTHX_ stcxt_t *cxt, const char *cname) |
4841
|
|
|
|
|
|
{ |
4842
|
|
|
|
|
|
I32 len; |
4843
|
|
|
|
|
|
SV *sv; |
4844
|
|
|
|
|
|
HV *stash; |
4845
|
|
|
|
|
|
|
4846
|
12614
|
|
|
|
|
RLEN(len); |
4847
|
|
|
|
|
|
TRACEME(("retrieve_lscalar (#%d), len = %"IVdf, cxt->tagnum, (IV) len)); |
4848
|
|
|
|
|
|
|
4849
|
|
|
|
|
|
/* |
4850
|
|
|
|
|
|
* Allocate an empty scalar of the suitable length. |
4851
|
|
|
|
|
|
*/ |
4852
|
|
|
|
|
|
|
4853
|
12608
|
|
|
|
|
sv = NEWSV(10002, len); |
4854
|
12608
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4855
|
25216
|
|
|
|
|
SEEN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ |
4856
|
|
|
|
|
|
|
4857
|
12608
|
|
|
|
|
if (len == 0) { |
4858
|
2
|
|
|
|
|
sv_setpvn(sv, "", 0); |
4859
|
2
|
|
|
|
|
return sv; |
4860
|
|
|
|
|
|
} |
4861
|
|
|
|
|
|
|
4862
|
|
|
|
|
|
/* |
4863
|
|
|
|
|
|
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. |
4864
|
|
|
|
|
|
* |
4865
|
|
|
|
|
|
* Now, for efficiency reasons, read data directly inside the SV buffer, |
4866
|
|
|
|
|
|
* and perform the SV final settings directly by duplicating the final |
4867
|
|
|
|
|
|
* work done by sv_setpv. Since we're going to allocate lots of scalars |
4868
|
|
|
|
|
|
* this way, it's worth the hassle and risk. |
4869
|
|
|
|
|
|
*/ |
4870
|
|
|
|
|
|
|
4871
|
12612
|
|
|
|
|
SAFEREAD(SvPVX(sv), len, sv); |
4872
|
12606
|
|
|
|
|
SvCUR_set(sv, len); /* Record C string length */ |
4873
|
12606
|
|
|
|
|
*SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ |
4874
|
12606
|
|
|
|
|
(void) SvPOK_only(sv); /* Validate string pointer */ |
4875
|
12606
|
|
|
|
|
if (cxt->s_tainted) /* Is input source tainted? */ |
4876
|
12600
|
|
|
|
|
SvTAINT(sv); /* External data cannot be trusted */ |
4877
|
|
|
|
|
|
|
4878
|
|
|
|
|
|
TRACEME(("large scalar len %"IVdf" '%s'", (IV) len, SvPVX(sv))); |
4879
|
|
|
|
|
|
TRACEME(("ok (retrieve_lscalar at 0x%"UVxf")", PTR2UV(sv))); |
4880
|
|
|
|
|
|
|
4881
|
|
|
|
|
|
return sv; |
4882
|
|
|
|
|
|
} |
4883
|
|
|
|
|
|
|
4884
|
|
|
|
|
|
/* |
4885
|
|
|
|
|
|
* retrieve_scalar |
4886
|
|
|
|
|
|
* |
4887
|
|
|
|
|
|
* Retrieve defined short (string) scalar. |
4888
|
|
|
|
|
|
* |
4889
|
|
|
|
|
|
* Layout is SX_SCALAR , with SX_SCALAR already read. |
4890
|
|
|
|
|
|
* The scalar is "short" so is single byte. If it is 0, there |
4891
|
|
|
|
|
|
* is no section. |
4892
|
|
|
|
|
|
*/ |
4893
|
149962640
|
|
|
|
|
static SV *retrieve_scalar(pTHX_ stcxt_t *cxt, const char *cname) |
4894
|
|
|
|
|
|
{ |
4895
|
|
|
|
|
|
int len; |
4896
|
|
|
|
|
|
SV *sv; |
4897
|
|
|
|
|
|
HV *stash; |
4898
|
|
|
|
|
|
|
4899
|
149962640
|
|
|
|
|
GETMARK(len); |
4900
|
|
|
|
|
|
TRACEME(("retrieve_scalar (#%d), len = %d", cxt->tagnum, len)); |
4901
|
|
|
|
|
|
|
4902
|
|
|
|
|
|
/* |
4903
|
|
|
|
|
|
* Allocate an empty scalar of the suitable length. |
4904
|
|
|
|
|
|
*/ |
4905
|
|
|
|
|
|
|
4906
|
149962632
|
|
|
|
|
sv = NEWSV(10002, len); |
4907
|
149962632
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
4908
|
299925276
|
|
|
|
|
SEEN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ |
4909
|
|
|
|
|
|
|
4910
|
|
|
|
|
|
/* |
4911
|
|
|
|
|
|
* WARNING: duplicates parts of sv_setpv and breaks SV data encapsulation. |
4912
|
|
|
|
|
|
*/ |
4913
|
|
|
|
|
|
|
4914
|
149962632
|
|
|
|
|
if (len == 0) { |
4915
|
|
|
|
|
|
/* |
4916
|
|
|
|
|
|
* newSV did not upgrade to SVt_PV so the scalar is undefined. |
4917
|
|
|
|
|
|
* To make it defined with an empty length, upgrade it now... |
4918
|
|
|
|
|
|
* Don't upgrade to a PV if the original type contains more |
4919
|
|
|
|
|
|
* information than a scalar. |
4920
|
|
|
|
|
|
*/ |
4921
|
12956
|
|
|
|
|
if (SvTYPE(sv) <= SVt_PV) { |
4922
|
12954
|
|
|
|
|
sv_upgrade(sv, SVt_PV); |
4923
|
|
|
|
|
|
} |
4924
|
12956
|
|
|
|
|
SvGROW(sv, 1); |
4925
|
12956
|
|
|
|
|
*SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ |
4926
|
|
|
|
|
|
TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv))); |
4927
|
|
|
|
|
|
} else { |
4928
|
|
|
|
|
|
/* |
4929
|
|
|
|
|
|
* Now, for efficiency reasons, read data directly inside the SV buffer, |
4930
|
|
|
|
|
|
* and perform the SV final settings directly by duplicating the final |
4931
|
|
|
|
|
|
* work done by sv_setpv. Since we're going to allocate lots of scalars |
4932
|
|
|
|
|
|
* this way, it's worth the hassle and risk. |
4933
|
|
|
|
|
|
*/ |
4934
|
150277058
|
|
|
|
|
SAFEREAD(SvPVX(sv), len, sv); |
4935
|
149949636
|
|
|
|
|
SvCUR_set(sv, len); /* Record C string length */ |
4936
|
149949636
|
|
|
|
|
*SvEND(sv) = '\0'; /* Ensure it's null terminated anyway */ |
4937
|
|
|
|
|
|
TRACEME(("small scalar len %d '%s'", len, SvPVX(sv))); |
4938
|
|
|
|
|
|
} |
4939
|
|
|
|
|
|
|
4940
|
149962592
|
|
|
|
|
(void) SvPOK_only(sv); /* Validate string pointer */ |
4941
|
149962592
|
|
|
|
|
if (cxt->s_tainted) /* Is input source tainted? */ |
4942
|
149622492
|
|
|
|
|
SvTAINT(sv); /* External data cannot be trusted */ |
4943
|
|
|
|
|
|
|
4944
|
|
|
|
|
|
TRACEME(("ok (retrieve_scalar at 0x%"UVxf")", PTR2UV(sv))); |
4945
|
|
|
|
|
|
return sv; |
4946
|
|
|
|
|
|
} |
4947
|
|
|
|
|
|
|
4948
|
|
|
|
|
|
/* |
4949
|
|
|
|
|
|
* retrieve_utf8str |
4950
|
|
|
|
|
|
* |
4951
|
|
|
|
|
|
* Like retrieve_scalar(), but tag result as utf8. |
4952
|
|
|
|
|
|
* If we're retrieving UTF8 data in a non-UTF8 perl, croaks. |
4953
|
|
|
|
|
|
*/ |
4954
|
813682
|
|
|
|
|
static SV *retrieve_utf8str(pTHX_ stcxt_t *cxt, const char *cname) |
4955
|
|
|
|
|
|
{ |
4956
|
|
|
|
|
|
SV *sv; |
4957
|
|
|
|
|
|
|
4958
|
|
|
|
|
|
TRACEME(("retrieve_utf8str")); |
4959
|
|
|
|
|
|
|
4960
|
813682
|
|
|
|
|
sv = retrieve_scalar(aTHX_ cxt, cname); |
4961
|
813682
|
|
|
|
|
if (sv) { |
4962
|
|
|
|
|
|
#ifdef HAS_UTF8_SCALARS |
4963
|
813682
|
|
|
|
|
SvUTF8_on(sv); |
4964
|
|
|
|
|
|
#else |
4965
|
|
|
|
|
|
if (cxt->use_bytes < 0) |
4966
|
|
|
|
|
|
cxt->use_bytes |
4967
|
|
|
|
|
|
= (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) |
4968
|
|
|
|
|
|
? 1 : 0); |
4969
|
|
|
|
|
|
if (cxt->use_bytes == 0) |
4970
|
|
|
|
|
|
UTF8_CROAK(); |
4971
|
|
|
|
|
|
#endif |
4972
|
|
|
|
|
|
} |
4973
|
|
|
|
|
|
|
4974
|
813682
|
|
|
|
|
return sv; |
4975
|
|
|
|
|
|
} |
4976
|
|
|
|
|
|
|
4977
|
|
|
|
|
|
/* |
4978
|
|
|
|
|
|
* retrieve_lutf8str |
4979
|
|
|
|
|
|
* |
4980
|
|
|
|
|
|
* Like retrieve_lscalar(), but tag result as utf8. |
4981
|
|
|
|
|
|
* If we're retrieving UTF8 data in a non-UTF8 perl, croaks. |
4982
|
|
|
|
|
|
*/ |
4983
|
6
|
|
|
|
|
static SV *retrieve_lutf8str(pTHX_ stcxt_t *cxt, const char *cname) |
4984
|
|
|
|
|
|
{ |
4985
|
|
|
|
|
|
SV *sv; |
4986
|
|
|
|
|
|
|
4987
|
|
|
|
|
|
TRACEME(("retrieve_lutf8str")); |
4988
|
|
|
|
|
|
|
4989
|
6
|
|
|
|
|
sv = retrieve_lscalar(aTHX_ cxt, cname); |
4990
|
6
|
|
|
|
|
if (sv) { |
4991
|
|
|
|
|
|
#ifdef HAS_UTF8_SCALARS |
4992
|
6
|
|
|
|
|
SvUTF8_on(sv); |
4993
|
|
|
|
|
|
#else |
4994
|
|
|
|
|
|
if (cxt->use_bytes < 0) |
4995
|
|
|
|
|
|
cxt->use_bytes |
4996
|
|
|
|
|
|
= (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) |
4997
|
|
|
|
|
|
? 1 : 0); |
4998
|
|
|
|
|
|
if (cxt->use_bytes == 0) |
4999
|
|
|
|
|
|
UTF8_CROAK(); |
5000
|
|
|
|
|
|
#endif |
5001
|
|
|
|
|
|
} |
5002
|
6
|
|
|
|
|
return sv; |
5003
|
|
|
|
|
|
} |
5004
|
|
|
|
|
|
|
5005
|
|
|
|
|
|
/* |
5006
|
|
|
|
|
|
* retrieve_vstring |
5007
|
|
|
|
|
|
* |
5008
|
|
|
|
|
|
* Retrieve a vstring, and then retrieve the stringy scalar following it, |
5009
|
|
|
|
|
|
* attaching the vstring to the scalar via magic. |
5010
|
|
|
|
|
|
* If we're retrieving a vstring in a perl without vstring magic, croaks. |
5011
|
|
|
|
|
|
* |
5012
|
|
|
|
|
|
* The vstring layout mirrors an SX_SCALAR string: |
5013
|
|
|
|
|
|
* SX_VSTRING with SX_VSTRING already read. |
5014
|
|
|
|
|
|
*/ |
5015
|
2
|
|
|
|
|
static SV *retrieve_vstring(pTHX_ stcxt_t *cxt, const char *cname) |
5016
|
|
|
|
|
|
{ |
5017
|
|
|
|
|
|
#ifdef SvVOK |
5018
|
|
|
|
|
|
MAGIC *mg; |
5019
|
|
|
|
|
|
char s[256]; |
5020
|
|
|
|
|
|
int len; |
5021
|
|
|
|
|
|
SV *sv; |
5022
|
|
|
|
|
|
|
5023
|
2
|
|
|
|
|
GETMARK(len); |
5024
|
|
|
|
|
|
TRACEME(("retrieve_vstring (#%d), len = %d", cxt->tagnum, len)); |
5025
|
|
|
|
|
|
|
5026
|
4
|
|
|
|
|
READ(s, len); |
5027
|
|
|
|
|
|
|
5028
|
2
|
|
|
|
|
sv = retrieve(aTHX_ cxt, cname); |
5029
|
|
|
|
|
|
|
5030
|
2
|
|
|
|
|
sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); |
5031
|
|
|
|
|
|
/* 5.10.0 and earlier seem to need this */ |
5032
|
2
|
|
|
|
|
SvRMAGICAL_on(sv); |
5033
|
|
|
|
|
|
|
5034
|
|
|
|
|
|
TRACEME(("ok (retrieve_vstring at 0x%"UVxf")", PTR2UV(sv))); |
5035
|
2
|
|
|
|
|
return sv; |
5036
|
|
|
|
|
|
#else |
5037
|
|
|
|
|
|
VSTRING_CROAK(); |
5038
|
|
|
|
|
|
return Nullsv; |
5039
|
|
|
|
|
|
#endif |
5040
|
|
|
|
|
|
} |
5041
|
|
|
|
|
|
|
5042
|
|
|
|
|
|
/* |
5043
|
|
|
|
|
|
* retrieve_lvstring |
5044
|
|
|
|
|
|
* |
5045
|
|
|
|
|
|
* Like retrieve_vstring, but for longer vstrings. |
5046
|
|
|
|
|
|
*/ |
5047
|
2
|
|
|
|
|
static SV *retrieve_lvstring(pTHX_ stcxt_t *cxt, const char *cname) |
5048
|
|
|
|
|
|
{ |
5049
|
|
|
|
|
|
#ifdef SvVOK |
5050
|
|
|
|
|
|
MAGIC *mg; |
5051
|
|
|
|
|
|
char *s; |
5052
|
|
|
|
|
|
I32 len; |
5053
|
|
|
|
|
|
SV *sv; |
5054
|
|
|
|
|
|
|
5055
|
4
|
|
|
|
|
RLEN(len); |
5056
|
|
|
|
|
|
TRACEME(("retrieve_lvstring (#%d), len = %"IVdf, |
5057
|
|
|
|
|
|
cxt->tagnum, (IV)len)); |
5058
|
|
|
|
|
|
|
5059
|
2
|
|
|
|
|
New(10003, s, len+1, char); |
5060
|
4
|
|
|
|
|
SAFEPVREAD(s, len, s); |
5061
|
|
|
|
|
|
|
5062
|
2
|
|
|
|
|
sv = retrieve(aTHX_ cxt, cname); |
5063
|
|
|
|
|
|
|
5064
|
2
|
|
|
|
|
sv_magic(sv,NULL,PERL_MAGIC_vstring,s,len); |
5065
|
|
|
|
|
|
/* 5.10.0 and earlier seem to need this */ |
5066
|
2
|
|
|
|
|
SvRMAGICAL_on(sv); |
5067
|
|
|
|
|
|
|
5068
|
2
|
|
|
|
|
Safefree(s); |
5069
|
|
|
|
|
|
|
5070
|
|
|
|
|
|
TRACEME(("ok (retrieve_lvstring at 0x%"UVxf")", PTR2UV(sv))); |
5071
|
2
|
|
|
|
|
return sv; |
5072
|
|
|
|
|
|
#else |
5073
|
|
|
|
|
|
VSTRING_CROAK(); |
5074
|
|
|
|
|
|
return Nullsv; |
5075
|
|
|
|
|
|
#endif |
5076
|
|
|
|
|
|
} |
5077
|
|
|
|
|
|
|
5078
|
|
|
|
|
|
/* |
5079
|
|
|
|
|
|
* retrieve_integer |
5080
|
|
|
|
|
|
* |
5081
|
|
|
|
|
|
* Retrieve defined integer. |
5082
|
|
|
|
|
|
* Layout is SX_INTEGER , whith SX_INTEGER already read. |
5083
|
|
|
|
|
|
*/ |
5084
|
465510
|
|
|
|
|
static SV *retrieve_integer(pTHX_ stcxt_t *cxt, const char *cname) |
5085
|
|
|
|
|
|
{ |
5086
|
|
|
|
|
|
SV *sv; |
5087
|
|
|
|
|
|
HV *stash; |
5088
|
|
|
|
|
|
IV iv; |
5089
|
|
|
|
|
|
|
5090
|
|
|
|
|
|
TRACEME(("retrieve_integer (#%d)", cxt->tagnum)); |
5091
|
|
|
|
|
|
|
5092
|
930966
|
|
|
|
|
READ(&iv, sizeof(iv)); |
5093
|
465510
|
|
|
|
|
sv = newSViv(iv); |
5094
|
465510
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5095
|
931020
|
|
|
|
|
SEEN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ |
5096
|
|
|
|
|
|
|
5097
|
|
|
|
|
|
TRACEME(("integer %"IVdf, iv)); |
5098
|
|
|
|
|
|
TRACEME(("ok (retrieve_integer at 0x%"UVxf")", PTR2UV(sv))); |
5099
|
|
|
|
|
|
|
5100
|
|
|
|
|
|
return sv; |
5101
|
|
|
|
|
|
} |
5102
|
|
|
|
|
|
|
5103
|
|
|
|
|
|
/* |
5104
|
|
|
|
|
|
* retrieve_netint |
5105
|
|
|
|
|
|
* |
5106
|
|
|
|
|
|
* Retrieve defined integer in network order. |
5107
|
|
|
|
|
|
* Layout is SX_NETINT , whith SX_NETINT already read. |
5108
|
|
|
|
|
|
*/ |
5109
|
156900912
|
|
|
|
|
static SV *retrieve_netint(pTHX_ stcxt_t *cxt, const char *cname) |
5110
|
|
|
|
|
|
{ |
5111
|
|
|
|
|
|
SV *sv; |
5112
|
|
|
|
|
|
HV *stash; |
5113
|
|
|
|
|
|
I32 iv; |
5114
|
|
|
|
|
|
|
5115
|
|
|
|
|
|
TRACEME(("retrieve_netint (#%d)", cxt->tagnum)); |
5116
|
|
|
|
|
|
|
5117
|
156900938
|
|
|
|
|
READ_I32(iv); |
5118
|
|
|
|
|
|
#ifdef HAS_NTOHL |
5119
|
156900912
|
|
|
|
|
sv = newSViv((int) ntohl(iv)); |
5120
|
|
|
|
|
|
TRACEME(("network integer %d", (int) ntohl(iv))); |
5121
|
|
|
|
|
|
#else |
5122
|
|
|
|
|
|
sv = newSViv(iv); |
5123
|
|
|
|
|
|
TRACEME(("network integer (as-is) %d", iv)); |
5124
|
|
|
|
|
|
#endif |
5125
|
156900912
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5126
|
313801824
|
|
|
|
|
SEEN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ |
5127
|
|
|
|
|
|
|
5128
|
|
|
|
|
|
TRACEME(("ok (retrieve_netint at 0x%"UVxf")", PTR2UV(sv))); |
5129
|
|
|
|
|
|
|
5130
|
|
|
|
|
|
return sv; |
5131
|
|
|
|
|
|
} |
5132
|
|
|
|
|
|
|
5133
|
|
|
|
|
|
/* |
5134
|
|
|
|
|
|
* retrieve_double |
5135
|
|
|
|
|
|
* |
5136
|
|
|
|
|
|
* Retrieve defined double. |
5137
|
|
|
|
|
|
* Layout is SX_DOUBLE , whith SX_DOUBLE already read. |
5138
|
|
|
|
|
|
*/ |
5139
|
32
|
|
|
|
|
static SV *retrieve_double(pTHX_ stcxt_t *cxt, const char *cname) |
5140
|
|
|
|
|
|
{ |
5141
|
|
|
|
|
|
SV *sv; |
5142
|
|
|
|
|
|
HV *stash; |
5143
|
|
|
|
|
|
NV nv; |
5144
|
|
|
|
|
|
|
5145
|
|
|
|
|
|
TRACEME(("retrieve_double (#%d)", cxt->tagnum)); |
5146
|
|
|
|
|
|
|
5147
|
48
|
|
|
|
|
READ(&nv, sizeof(nv)); |
5148
|
32
|
|
|
|
|
sv = newSVnv(nv); |
5149
|
32
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5150
|
64
|
|
|
|
|
SEEN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ |
5151
|
|
|
|
|
|
|
5152
|
|
|
|
|
|
TRACEME(("double %"NVff, nv)); |
5153
|
|
|
|
|
|
TRACEME(("ok (retrieve_double at 0x%"UVxf")", PTR2UV(sv))); |
5154
|
|
|
|
|
|
|
5155
|
|
|
|
|
|
return sv; |
5156
|
|
|
|
|
|
} |
5157
|
|
|
|
|
|
|
5158
|
|
|
|
|
|
/* |
5159
|
|
|
|
|
|
* retrieve_byte |
5160
|
|
|
|
|
|
* |
5161
|
|
|
|
|
|
* Retrieve defined byte (small integer within the [-128, +127] range). |
5162
|
|
|
|
|
|
* Layout is SX_BYTE , whith SX_BYTE already read. |
5163
|
|
|
|
|
|
*/ |
5164
|
223630340
|
|
|
|
|
static SV *retrieve_byte(pTHX_ stcxt_t *cxt, const char *cname) |
5165
|
|
|
|
|
|
{ |
5166
|
|
|
|
|
|
SV *sv; |
5167
|
|
|
|
|
|
HV *stash; |
5168
|
|
|
|
|
|
int siv; |
5169
|
|
|
|
|
|
signed char tmp; /* Workaround for AIX cc bug --H.Merijn Brand */ |
5170
|
|
|
|
|
|
|
5171
|
|
|
|
|
|
TRACEME(("retrieve_byte (#%d)", cxt->tagnum)); |
5172
|
|
|
|
|
|
|
5173
|
223630340
|
|
|
|
|
GETMARK(siv); |
5174
|
|
|
|
|
|
TRACEME(("small integer read as %d", (unsigned char) siv)); |
5175
|
223630340
|
|
|
|
|
tmp = (unsigned char) siv - 128; |
5176
|
223630340
|
|
|
|
|
sv = newSViv(tmp); |
5177
|
223630340
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5178
|
447260680
|
|
|
|
|
SEEN(sv, stash, 0); /* Associate this new scalar with tag "tagnum" */ |
5179
|
|
|
|
|
|
|
5180
|
|
|
|
|
|
TRACEME(("byte %d", tmp)); |
5181
|
|
|
|
|
|
TRACEME(("ok (retrieve_byte at 0x%"UVxf")", PTR2UV(sv))); |
5182
|
|
|
|
|
|
|
5183
|
|
|
|
|
|
return sv; |
5184
|
|
|
|
|
|
} |
5185
|
|
|
|
|
|
|
5186
|
|
|
|
|
|
/* |
5187
|
|
|
|
|
|
* retrieve_undef |
5188
|
|
|
|
|
|
* |
5189
|
|
|
|
|
|
* Return the undefined value. |
5190
|
|
|
|
|
|
*/ |
5191
|
63283156
|
|
|
|
|
static SV *retrieve_undef(pTHX_ stcxt_t *cxt, const char *cname) |
5192
|
|
|
|
|
|
{ |
5193
|
|
|
|
|
|
SV *sv; |
5194
|
|
|
|
|
|
HV *stash; |
5195
|
|
|
|
|
|
|
5196
|
|
|
|
|
|
TRACEME(("retrieve_undef")); |
5197
|
|
|
|
|
|
|
5198
|
63283156
|
|
|
|
|
sv = newSV(0); |
5199
|
63283156
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5200
|
126566316
|
|
|
|
|
SEEN(sv, stash, 0); |
5201
|
|
|
|
|
|
|
5202
|
|
|
|
|
|
return sv; |
5203
|
|
|
|
|
|
} |
5204
|
|
|
|
|
|
|
5205
|
|
|
|
|
|
/* |
5206
|
|
|
|
|
|
* retrieve_sv_undef |
5207
|
|
|
|
|
|
* |
5208
|
|
|
|
|
|
* Return the immortal undefined value. |
5209
|
|
|
|
|
|
*/ |
5210
|
10270
|
|
|
|
|
static SV *retrieve_sv_undef(pTHX_ stcxt_t *cxt, const char *cname) |
5211
|
|
|
|
|
|
{ |
5212
|
|
|
|
|
|
SV *sv = &PL_sv_undef; |
5213
|
|
|
|
|
|
HV *stash; |
5214
|
|
|
|
|
|
|
5215
|
|
|
|
|
|
TRACEME(("retrieve_sv_undef")); |
5216
|
|
|
|
|
|
|
5217
|
|
|
|
|
|
/* Special case PL_sv_undef, as av_fetch uses it internally to mark |
5218
|
|
|
|
|
|
deleted elements, and will return NULL (fetch failed) whenever it |
5219
|
|
|
|
|
|
is fetched. */ |
5220
|
10270
|
|
|
|
|
if (cxt->where_is_undef == -1) { |
5221
|
240
|
|
|
|
|
cxt->where_is_undef = cxt->tagnum; |
5222
|
|
|
|
|
|
} |
5223
|
10270
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5224
|
10270
|
|
|
|
|
SEEN(sv, stash, 1); |
5225
|
|
|
|
|
|
return sv; |
5226
|
|
|
|
|
|
} |
5227
|
|
|
|
|
|
|
5228
|
|
|
|
|
|
/* |
5229
|
|
|
|
|
|
* retrieve_sv_yes |
5230
|
|
|
|
|
|
* |
5231
|
|
|
|
|
|
* Return the immortal yes value. |
5232
|
|
|
|
|
|
*/ |
5233
|
6
|
|
|
|
|
static SV *retrieve_sv_yes(pTHX_ stcxt_t *cxt, const char *cname) |
5234
|
|
|
|
|
|
{ |
5235
|
|
|
|
|
|
SV *sv = &PL_sv_yes; |
5236
|
|
|
|
|
|
HV *stash; |
5237
|
|
|
|
|
|
|
5238
|
|
|
|
|
|
TRACEME(("retrieve_sv_yes")); |
5239
|
|
|
|
|
|
|
5240
|
6
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5241
|
6
|
|
|
|
|
SEEN(sv, stash, 1); |
5242
|
|
|
|
|
|
return sv; |
5243
|
|
|
|
|
|
} |
5244
|
|
|
|
|
|
|
5245
|
|
|
|
|
|
/* |
5246
|
|
|
|
|
|
* retrieve_sv_no |
5247
|
|
|
|
|
|
* |
5248
|
|
|
|
|
|
* Return the immortal no value. |
5249
|
|
|
|
|
|
*/ |
5250
|
6
|
|
|
|
|
static SV *retrieve_sv_no(pTHX_ stcxt_t *cxt, const char *cname) |
5251
|
|
|
|
|
|
{ |
5252
|
|
|
|
|
|
SV *sv = &PL_sv_no; |
5253
|
|
|
|
|
|
HV *stash; |
5254
|
|
|
|
|
|
|
5255
|
|
|
|
|
|
TRACEME(("retrieve_sv_no")); |
5256
|
|
|
|
|
|
|
5257
|
6
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5258
|
6
|
|
|
|
|
SEEN(sv, stash, 1); |
5259
|
|
|
|
|
|
return sv; |
5260
|
|
|
|
|
|
} |
5261
|
|
|
|
|
|
|
5262
|
|
|
|
|
|
/* |
5263
|
|
|
|
|
|
* retrieve_svundef_elem |
5264
|
|
|
|
|
|
* |
5265
|
|
|
|
|
|
* Return &PL_sv_placeholder, representing &PL_sv_undef in an array. This |
5266
|
|
|
|
|
|
* is a bit of a hack, but we already use SX_SV_UNDEF to mean a nonexistent |
5267
|
|
|
|
|
|
* element, for historical reasons. |
5268
|
|
|
|
|
|
*/ |
5269
|
0
|
|
|
|
|
static SV *retrieve_svundef_elem(pTHX_ stcxt_t *cxt, const char *cname) |
5270
|
|
|
|
|
|
{ |
5271
|
|
|
|
|
|
TRACEME(("retrieve_svundef_elem")); |
5272
|
|
|
|
|
|
|
5273
|
|
|
|
|
|
/* SEEN reads the contents of its SV argument, which we are not |
5274
|
|
|
|
|
|
supposed to do with &PL_sv_placeholder. */ |
5275
|
0
|
|
|
|
|
SEEN(&PL_sv_undef, cname, 1); |
5276
|
|
|
|
|
|
|
5277
|
|
|
|
|
|
return &PL_sv_placeholder; |
5278
|
|
|
|
|
|
} |
5279
|
|
|
|
|
|
|
5280
|
|
|
|
|
|
/* |
5281
|
|
|
|
|
|
* retrieve_array |
5282
|
|
|
|
|
|
* |
5283
|
|
|
|
|
|
* Retrieve a whole array. |
5284
|
|
|
|
|
|
* Layout is SX_ARRAY followed by each item, in increasing index order. |
5285
|
|
|
|
|
|
* Each item is stored as . |
5286
|
|
|
|
|
|
* |
5287
|
|
|
|
|
|
* When we come here, SX_ARRAY has been read already. |
5288
|
|
|
|
|
|
*/ |
5289
|
89551546
|
|
|
|
|
static SV *retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) |
5290
|
|
|
|
|
|
{ |
5291
|
|
|
|
|
|
I32 len; |
5292
|
|
|
|
|
|
I32 i; |
5293
|
|
|
|
|
|
AV *av; |
5294
|
|
|
|
|
|
SV *sv; |
5295
|
|
|
|
|
|
HV *stash; |
5296
|
|
|
|
|
|
bool seen_null = FALSE; |
5297
|
|
|
|
|
|
|
5298
|
|
|
|
|
|
TRACEME(("retrieve_array (#%d)", cxt->tagnum)); |
5299
|
|
|
|
|
|
|
5300
|
|
|
|
|
|
/* |
5301
|
|
|
|
|
|
* Read length, and allocate array, then pre-extend it. |
5302
|
|
|
|
|
|
*/ |
5303
|
|
|
|
|
|
|
5304
|
89607628
|
|
|
|
|
RLEN(len); |
5305
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
5306
|
89551546
|
|
|
|
|
av = newAV(); |
5307
|
89551546
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5308
|
179103172
|
|
|
|
|
SEEN(av, stash, 0); /* Will return if array not allocated nicely */ |
5309
|
89551546
|
|
|
|
|
if (len) |
5310
|
89551426
|
|
|
|
|
av_extend(av, len); |
5311
|
|
|
|
|
|
else |
5312
|
|
|
|
|
|
return (SV *) av; /* No data follow if array is empty */ |
5313
|
|
|
|
|
|
|
5314
|
|
|
|
|
|
/* |
5315
|
|
|
|
|
|
* Now get each item in turn... |
5316
|
|
|
|
|
|
*/ |
5317
|
|
|
|
|
|
|
5318
|
560496098
|
|
|
|
|
for (i = 0; i < len; i++) { |
5319
|
|
|
|
|
|
TRACEME(("(#%d) item", i)); |
5320
|
470944672
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ |
5321
|
470944672
|
|
|
|
|
if (!sv) |
5322
|
|
|
|
|
|
return (SV *) 0; |
5323
|
470944672
|
|
|
|
|
if (sv == &PL_sv_undef) { |
5324
|
|
|
|
|
|
seen_null = TRUE; |
5325
|
4
|
|
|
|
|
continue; |
5326
|
|
|
|
|
|
} |
5327
|
470944668
|
|
|
|
|
if (sv == &PL_sv_placeholder) |
5328
|
|
|
|
|
|
sv = &PL_sv_undef; |
5329
|
470944668
|
|
|
|
|
if (av_store(av, i, sv) == 0) |
5330
|
|
|
|
|
|
return (SV *) 0; |
5331
|
|
|
|
|
|
} |
5332
|
89551426
|
|
|
|
|
if (seen_null) av_fill(av, len-1); |
5333
|
|
|
|
|
|
|
5334
|
|
|
|
|
|
TRACEME(("ok (retrieve_array at 0x%"UVxf")", PTR2UV(av))); |
5335
|
|
|
|
|
|
|
5336
|
|
|
|
|
|
return (SV *) av; |
5337
|
|
|
|
|
|
} |
5338
|
|
|
|
|
|
|
5339
|
|
|
|
|
|
/* |
5340
|
|
|
|
|
|
* retrieve_hash |
5341
|
|
|
|
|
|
* |
5342
|
|
|
|
|
|
* Retrieve a whole hash table. |
5343
|
|
|
|
|
|
* Layout is SX_HASH followed by each key/value pair, in random order. |
5344
|
|
|
|
|
|
* Keys are stored as , the section being omitted |
5345
|
|
|
|
|
|
* if length is 0. |
5346
|
|
|
|
|
|
* Values are stored as . |
5347
|
|
|
|
|
|
* |
5348
|
|
|
|
|
|
* When we come here, SX_HASH has been read already. |
5349
|
|
|
|
|
|
*/ |
5350
|
88616266
|
|
|
|
|
static SV *retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) |
5351
|
|
|
|
|
|
{ |
5352
|
|
|
|
|
|
I32 len; |
5353
|
|
|
|
|
|
I32 size; |
5354
|
|
|
|
|
|
I32 i; |
5355
|
|
|
|
|
|
HV *hv; |
5356
|
|
|
|
|
|
SV *sv; |
5357
|
|
|
|
|
|
HV *stash; |
5358
|
|
|
|
|
|
|
5359
|
|
|
|
|
|
TRACEME(("retrieve_hash (#%d)", cxt->tagnum)); |
5360
|
|
|
|
|
|
|
5361
|
|
|
|
|
|
/* |
5362
|
|
|
|
|
|
* Read length, allocate table. |
5363
|
|
|
|
|
|
*/ |
5364
|
|
|
|
|
|
|
5365
|
88618918
|
|
|
|
|
RLEN(len); |
5366
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
5367
|
88616266
|
|
|
|
|
hv = newHV(); |
5368
|
88616266
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5369
|
177232594
|
|
|
|
|
SEEN(hv, stash, 0); /* Will return if table not allocated properly */ |
5370
|
88616266
|
|
|
|
|
if (len == 0) |
5371
|
|
|
|
|
|
return (SV *) hv; /* No data follow if table empty */ |
5372
|
88616232
|
|
|
|
|
hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */ |
5373
|
|
|
|
|
|
|
5374
|
|
|
|
|
|
/* |
5375
|
|
|
|
|
|
* Now get each key/value pair in turn... |
5376
|
|
|
|
|
|
*/ |
5377
|
|
|
|
|
|
|
5378
|
388020138
|
|
|
|
|
for (i = 0; i < len; i++) { |
5379
|
|
|
|
|
|
/* |
5380
|
|
|
|
|
|
* Get value first. |
5381
|
|
|
|
|
|
*/ |
5382
|
|
|
|
|
|
|
5383
|
|
|
|
|
|
TRACEME(("(#%d) value", i)); |
5384
|
299403906
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); |
5385
|
299403906
|
|
|
|
|
if (!sv) |
5386
|
|
|
|
|
|
return (SV *) 0; |
5387
|
|
|
|
|
|
|
5388
|
|
|
|
|
|
/* |
5389
|
|
|
|
|
|
* Get key. |
5390
|
|
|
|
|
|
* Since we're reading into kbuf, we must ensure we're not |
5391
|
|
|
|
|
|
* recursing between the read and the hv_store() where it's used. |
5392
|
|
|
|
|
|
* Hence the key comes after the value. |
5393
|
|
|
|
|
|
*/ |
5394
|
|
|
|
|
|
|
5395
|
299424286
|
|
|
|
|
RLEN(size); /* Get key size */ |
5396
|
299403906
|
|
|
|
|
KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ |
5397
|
299403906
|
|
|
|
|
if (size) |
5398
|
299424270
|
|
|
|
|
READ(kbuf, size); |
5399
|
299403906
|
|
|
|
|
kbuf[size] = '\0'; /* Mark string end, just in case */ |
5400
|
|
|
|
|
|
TRACEME(("(#%d) key '%s'", i, kbuf)); |
5401
|
|
|
|
|
|
|
5402
|
|
|
|
|
|
/* |
5403
|
|
|
|
|
|
* Enter key/value pair into hash table. |
5404
|
|
|
|
|
|
*/ |
5405
|
|
|
|
|
|
|
5406
|
299403906
|
|
|
|
|
if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) |
5407
|
|
|
|
|
|
return (SV *) 0; |
5408
|
|
|
|
|
|
} |
5409
|
|
|
|
|
|
|
5410
|
|
|
|
|
|
TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); |
5411
|
|
|
|
|
|
|
5412
|
|
|
|
|
|
return (SV *) hv; |
5413
|
|
|
|
|
|
} |
5414
|
|
|
|
|
|
|
5415
|
|
|
|
|
|
/* |
5416
|
|
|
|
|
|
* retrieve_hash |
5417
|
|
|
|
|
|
* |
5418
|
|
|
|
|
|
* Retrieve a whole hash table. |
5419
|
|
|
|
|
|
* Layout is SX_HASH followed by each key/value pair, in random order. |
5420
|
|
|
|
|
|
* Keys are stored as , the section being omitted |
5421
|
|
|
|
|
|
* if length is 0. |
5422
|
|
|
|
|
|
* Values are stored as . |
5423
|
|
|
|
|
|
* |
5424
|
|
|
|
|
|
* When we come here, SX_HASH has been read already. |
5425
|
|
|
|
|
|
*/ |
5426
|
515380
|
|
|
|
|
static SV *retrieve_flag_hash(pTHX_ stcxt_t *cxt, const char *cname) |
5427
|
|
|
|
|
|
{ |
5428
|
|
|
|
|
|
dVAR; |
5429
|
|
|
|
|
|
I32 len; |
5430
|
|
|
|
|
|
I32 size; |
5431
|
|
|
|
|
|
I32 i; |
5432
|
|
|
|
|
|
HV *hv; |
5433
|
|
|
|
|
|
SV *sv; |
5434
|
|
|
|
|
|
HV *stash; |
5435
|
|
|
|
|
|
int hash_flags; |
5436
|
|
|
|
|
|
|
5437
|
515380
|
|
|
|
|
GETMARK(hash_flags); |
5438
|
|
|
|
|
|
TRACEME(("retrieve_flag_hash (#%d)", cxt->tagnum)); |
5439
|
|
|
|
|
|
/* |
5440
|
|
|
|
|
|
* Read length, allocate table. |
5441
|
|
|
|
|
|
*/ |
5442
|
|
|
|
|
|
|
5443
|
|
|
|
|
|
#ifndef HAS_RESTRICTED_HASHES |
5444
|
|
|
|
|
|
if (hash_flags & SHV_RESTRICTED) { |
5445
|
|
|
|
|
|
if (cxt->derestrict < 0) |
5446
|
|
|
|
|
|
cxt->derestrict |
5447
|
|
|
|
|
|
= (SvTRUE(perl_get_sv("Storable::downgrade_restricted", GV_ADD)) |
5448
|
|
|
|
|
|
? 1 : 0); |
5449
|
|
|
|
|
|
if (cxt->derestrict == 0) |
5450
|
|
|
|
|
|
RESTRICTED_HASH_CROAK(); |
5451
|
|
|
|
|
|
} |
5452
|
|
|
|
|
|
#endif |
5453
|
|
|
|
|
|
|
5454
|
515734
|
|
|
|
|
RLEN(len); |
5455
|
|
|
|
|
|
TRACEME(("size = %d, flags = %d", len, hash_flags)); |
5456
|
515340
|
|
|
|
|
hv = newHV(); |
5457
|
515340
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5458
|
1030692
|
|
|
|
|
SEEN(hv, stash, 0); /* Will return if table not allocated properly */ |
5459
|
515340
|
|
|
|
|
if (len == 0) |
5460
|
|
|
|
|
|
return (SV *) hv; /* No data follow if table empty */ |
5461
|
515340
|
|
|
|
|
hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */ |
5462
|
|
|
|
|
|
|
5463
|
|
|
|
|
|
/* |
5464
|
|
|
|
|
|
* Now get each key/value pair in turn... |
5465
|
|
|
|
|
|
*/ |
5466
|
|
|
|
|
|
|
5467
|
1070966
|
|
|
|
|
for (i = 0; i < len; i++) { |
5468
|
|
|
|
|
|
int flags; |
5469
|
|
|
|
|
|
int store_flags = 0; |
5470
|
|
|
|
|
|
/* |
5471
|
|
|
|
|
|
* Get value first. |
5472
|
|
|
|
|
|
*/ |
5473
|
|
|
|
|
|
|
5474
|
|
|
|
|
|
TRACEME(("(#%d) value", i)); |
5475
|
555754
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); |
5476
|
555754
|
|
|
|
|
if (!sv) |
5477
|
|
|
|
|
|
return (SV *) 0; |
5478
|
|
|
|
|
|
|
5479
|
555698
|
|
|
|
|
GETMARK(flags); |
5480
|
|
|
|
|
|
#ifdef HAS_RESTRICTED_HASHES |
5481
|
555690
|
|
|
|
|
if ((hash_flags & SHV_RESTRICTED) && (flags & SHV_K_LOCKED)) |
5482
|
10300
|
|
|
|
|
SvREADONLY_on(sv); |
5483
|
|
|
|
|
|
#endif |
5484
|
|
|
|
|
|
|
5485
|
555690
|
|
|
|
|
if (flags & SHV_K_ISSV) { |
5486
|
|
|
|
|
|
/* XXX you can't set a placeholder with an SV key. |
5487
|
|
|
|
|
|
Then again, you can't get an SV key. |
5488
|
|
|
|
|
|
Without messing around beyond what the API is supposed to do. |
5489
|
|
|
|
|
|
*/ |
5490
|
|
|
|
|
|
SV *keysv; |
5491
|
|
|
|
|
|
TRACEME(("(#%d) keysv, flags=%d", i, flags)); |
5492
|
0
|
|
|
|
|
keysv = retrieve(aTHX_ cxt, 0); |
5493
|
0
|
|
|
|
|
if (!keysv) |
5494
|
|
|
|
|
|
return (SV *) 0; |
5495
|
|
|
|
|
|
|
5496
|
0
|
|
|
|
|
if (!hv_store_ent(hv, keysv, sv, 0)) |
5497
|
|
|
|
|
|
return (SV *) 0; |
5498
|
|
|
|
|
|
} else { |
5499
|
|
|
|
|
|
/* |
5500
|
|
|
|
|
|
* Get key. |
5501
|
|
|
|
|
|
* Since we're reading into kbuf, we must ensure we're not |
5502
|
|
|
|
|
|
* recursing between the read and the hv_store() where it's used. |
5503
|
|
|
|
|
|
* Hence the key comes after the value. |
5504
|
|
|
|
|
|
*/ |
5505
|
|
|
|
|
|
|
5506
|
555690
|
|
|
|
|
if (flags & SHV_K_PLACEHOLDER) { |
5507
|
10260
|
|
|
|
|
SvREFCNT_dec (sv); |
5508
|
|
|
|
|
|
sv = &PL_sv_placeholder; |
5509
|
|
|
|
|
|
store_flags |= HVhek_PLACEHOLD; |
5510
|
|
|
|
|
|
} |
5511
|
555690
|
|
|
|
|
if (flags & SHV_K_UTF8) { |
5512
|
|
|
|
|
|
#ifdef HAS_UTF8_HASHES |
5513
|
356596
|
|
|
|
|
store_flags |= HVhek_UTF8; |
5514
|
|
|
|
|
|
#else |
5515
|
|
|
|
|
|
if (cxt->use_bytes < 0) |
5516
|
|
|
|
|
|
cxt->use_bytes |
5517
|
|
|
|
|
|
= (SvTRUE(perl_get_sv("Storable::drop_utf8", GV_ADD)) |
5518
|
|
|
|
|
|
? 1 : 0); |
5519
|
|
|
|
|
|
if (cxt->use_bytes == 0) |
5520
|
|
|
|
|
|
UTF8_CROAK(); |
5521
|
|
|
|
|
|
#endif |
5522
|
|
|
|
|
|
} |
5523
|
|
|
|
|
|
#ifdef HAS_UTF8_HASHES |
5524
|
555690
|
|
|
|
|
if (flags & SHV_K_WASUTF8) |
5525
|
158362
|
|
|
|
|
store_flags |= HVhek_WASUTF8; |
5526
|
|
|
|
|
|
#endif |
5527
|
|
|
|
|
|
|
5528
|
566128
|
|
|
|
|
RLEN(size); /* Get key size */ |
5529
|
555658
|
|
|
|
|
KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ |
5530
|
555658
|
|
|
|
|
if (size) |
5531
|
566080
|
|
|
|
|
READ(kbuf, size); |
5532
|
555626
|
|
|
|
|
kbuf[size] = '\0'; /* Mark string end, just in case */ |
5533
|
|
|
|
|
|
TRACEME(("(#%d) key '%s' flags %X store_flags %X", i, kbuf, |
5534
|
|
|
|
|
|
flags, store_flags)); |
5535
|
|
|
|
|
|
|
5536
|
|
|
|
|
|
/* |
5537
|
|
|
|
|
|
* Enter key/value pair into hash table. |
5538
|
|
|
|
|
|
*/ |
5539
|
|
|
|
|
|
|
5540
|
|
|
|
|
|
#ifdef HAS_RESTRICTED_HASHES |
5541
|
555626
|
|
|
|
|
if (hv_store_flags(hv, kbuf, size, sv, 0, store_flags) == 0) |
5542
|
|
|
|
|
|
return (SV *) 0; |
5543
|
|
|
|
|
|
#else |
5544
|
|
|
|
|
|
if (!(store_flags & HVhek_PLACEHOLD)) |
5545
|
|
|
|
|
|
if (hv_store(hv, kbuf, size, sv, 0) == 0) |
5546
|
|
|
|
|
|
return (SV *) 0; |
5547
|
|
|
|
|
|
#endif |
5548
|
|
|
|
|
|
} |
5549
|
|
|
|
|
|
} |
5550
|
|
|
|
|
|
#ifdef HAS_RESTRICTED_HASHES |
5551
|
515212
|
|
|
|
|
if (hash_flags & SHV_RESTRICTED) |
5552
|
258
|
|
|
|
|
SvREADONLY_on(hv); |
5553
|
|
|
|
|
|
#endif |
5554
|
|
|
|
|
|
|
5555
|
|
|
|
|
|
TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); |
5556
|
|
|
|
|
|
|
5557
|
|
|
|
|
|
return (SV *) hv; |
5558
|
|
|
|
|
|
} |
5559
|
|
|
|
|
|
|
5560
|
|
|
|
|
|
/* |
5561
|
|
|
|
|
|
* retrieve_code |
5562
|
|
|
|
|
|
* |
5563
|
|
|
|
|
|
* Return a code reference. |
5564
|
|
|
|
|
|
*/ |
5565
|
16
|
|
|
|
|
static SV *retrieve_code(pTHX_ stcxt_t *cxt, const char *cname) |
5566
|
|
|
|
|
|
{ |
5567
|
|
|
|
|
|
#if PERL_VERSION < 6 |
5568
|
|
|
|
|
|
CROAK(("retrieve_code does not work with perl 5.005 or less\n")); |
5569
|
|
|
|
|
|
#else |
5570
|
16
|
|
|
|
|
dSP; |
5571
|
|
|
|
|
|
int type, count, tagnum; |
5572
|
|
|
|
|
|
SV *cv; |
5573
|
|
|
|
|
|
SV *sv, *text, *sub, *errsv; |
5574
|
|
|
|
|
|
HV *stash; |
5575
|
|
|
|
|
|
|
5576
|
|
|
|
|
|
TRACEME(("retrieve_code (#%d)", cxt->tagnum)); |
5577
|
|
|
|
|
|
|
5578
|
|
|
|
|
|
/* |
5579
|
|
|
|
|
|
* Insert dummy SV in the aseen array so that we don't screw |
5580
|
|
|
|
|
|
* up the tag numbers. We would just make the internal |
5581
|
|
|
|
|
|
* scalar an untagged item in the stream, but |
5582
|
|
|
|
|
|
* retrieve_scalar() calls SEEN(). So we just increase the |
5583
|
|
|
|
|
|
* tag number. |
5584
|
|
|
|
|
|
*/ |
5585
|
16
|
|
|
|
|
tagnum = cxt->tagnum; |
5586
|
16
|
|
|
|
|
sv = newSViv(0); |
5587
|
16
|
|
|
|
|
stash = cname ? gv_stashpv(cname, GV_ADD) : 0; |
5588
|
32
|
|
|
|
|
SEEN(sv, stash, 0); |
5589
|
|
|
|
|
|
|
5590
|
|
|
|
|
|
/* |
5591
|
|
|
|
|
|
* Retrieve the source of the code reference |
5592
|
|
|
|
|
|
* as a small or large scalar |
5593
|
|
|
|
|
|
*/ |
5594
|
|
|
|
|
|
|
5595
|
16
|
|
|
|
|
GETMARK(type); |
5596
|
16
|
|
|
|
|
switch (type) { |
5597
|
|
|
|
|
|
case SX_SCALAR: |
5598
|
16
|
|
|
|
|
text = retrieve_scalar(aTHX_ cxt, cname); |
5599
|
16
|
|
|
|
|
break; |
5600
|
|
|
|
|
|
case SX_LSCALAR: |
5601
|
0
|
|
|
|
|
text = retrieve_lscalar(aTHX_ cxt, cname); |
5602
|
0
|
|
|
|
|
break; |
5603
|
|
|
|
|
|
case SX_UTF8STR: |
5604
|
0
|
|
|
|
|
text = retrieve_utf8str(aTHX_ cxt, cname); |
5605
|
0
|
|
|
|
|
break; |
5606
|
|
|
|
|
|
case SX_LUTF8STR: |
5607
|
0
|
|
|
|
|
text = retrieve_lutf8str(aTHX_ cxt, cname); |
5608
|
0
|
|
|
|
|
break; |
5609
|
|
|
|
|
|
default: |
5610
|
0
|
|
|
|
|
CROAK(("Unexpected type %d in retrieve_code\n", type)); |
5611
|
|
|
|
|
|
} |
5612
|
|
|
|
|
|
|
5613
|
|
|
|
|
|
/* |
5614
|
|
|
|
|
|
* prepend "sub " to the source |
5615
|
|
|
|
|
|
*/ |
5616
|
|
|
|
|
|
|
5617
|
16
|
|
|
|
|
sub = newSVpvn("sub ", 4); |
5618
|
16
|
|
|
|
|
if (SvUTF8(text)) |
5619
|
0
|
|
|
|
|
SvUTF8_on(sub); |
5620
|
16
|
|
|
|
|
sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ |
5621
|
16
|
|
|
|
|
SvREFCNT_dec(text); |
5622
|
|
|
|
|
|
|
5623
|
|
|
|
|
|
/* |
5624
|
|
|
|
|
|
* evaluate the source to a code reference and use the CV value |
5625
|
|
|
|
|
|
*/ |
5626
|
|
|
|
|
|
|
5627
|
16
|
|
|
|
|
if (cxt->eval == NULL) { |
5628
|
16
|
|
|
|
|
cxt->eval = perl_get_sv("Storable::Eval", GV_ADD); |
5629
|
16
|
|
|
|
|
SvREFCNT_inc(cxt->eval); |
5630
|
|
|
|
|
|
} |
5631
|
16
|
|
|
|
|
if (!SvTRUE(cxt->eval)) { |
5632
|
0
|
|
|
|
|
if ( |
5633
|
0
|
|
|
|
|
cxt->forgive_me == 0 || |
5634
|
0
|
|
|
|
|
(cxt->forgive_me < 0 && !(cxt->forgive_me = |
5635
|
0
|
|
|
|
|
SvTRUE(perl_get_sv("Storable::forgive_me", GV_ADD)) ? 1 : 0)) |
5636
|
|
|
|
|
|
) { |
5637
|
0
|
|
|
|
|
CROAK(("Can't eval, please set $Storable::Eval to a true value")); |
5638
|
|
|
|
|
|
} else { |
5639
|
0
|
|
|
|
|
sv = newSVsv(sub); |
5640
|
|
|
|
|
|
/* fix up the dummy entry... */ |
5641
|
0
|
|
|
|
|
av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); |
5642
|
0
|
|
|
|
|
return sv; |
5643
|
|
|
|
|
|
} |
5644
|
|
|
|
|
|
} |
5645
|
|
|
|
|
|
|
5646
|
16
|
|
|
|
|
ENTER; |
5647
|
16
|
|
|
|
|
SAVETMPS; |
5648
|
|
|
|
|
|
|
5649
|
16
|
|
|
|
|
errsv = get_sv("@", GV_ADD); |
5650
|
16
|
|
|
|
|
sv_setpvn(errsv, "", 0); /* clear $@ */ |
5651
|
16
|
|
|
|
|
if (SvROK(cxt->eval) && SvTYPE(SvRV(cxt->eval)) == SVt_PVCV) { |
5652
|
0
|
|
|
|
|
PUSHMARK(sp); |
5653
|
0
|
|
|
|
|
XPUSHs(sv_2mortal(newSVsv(sub))); |
5654
|
0
|
|
|
|
|
PUTBACK; |
5655
|
0
|
|
|
|
|
count = call_sv(cxt->eval, G_SCALAR); |
5656
|
0
|
|
|
|
|
if (count != 1) |
5657
|
0
|
|
|
|
|
CROAK(("Unexpected return value from $Storable::Eval callback\n")); |
5658
|
|
|
|
|
|
} else { |
5659
|
16
|
|
|
|
|
eval_sv(sub, G_SCALAR); |
5660
|
|
|
|
|
|
} |
5661
|
16
|
|
|
|
|
SPAGAIN; |
5662
|
16
|
|
|
|
|
cv = POPs; |
5663
|
16
|
|
|
|
|
PUTBACK; |
5664
|
|
|
|
|
|
|
5665
|
16
|
|
|
|
|
if (SvTRUE(errsv)) { |
5666
|
0
|
|
|
|
|
CROAK(("code %s caused an error: %s", |
5667
|
|
|
|
|
|
SvPV_nolen(sub), SvPV_nolen(errsv))); |
5668
|
|
|
|
|
|
} |
5669
|
|
|
|
|
|
|
5670
|
16
|
|
|
|
|
if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { |
5671
|
16
|
|
|
|
|
sv = SvRV(cv); |
5672
|
|
|
|
|
|
} else { |
5673
|
0
|
|
|
|
|
CROAK(("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub))); |
5674
|
|
|
|
|
|
} |
5675
|
|
|
|
|
|
|
5676
|
|
|
|
|
|
SvREFCNT_inc(sv); /* XXX seems to be necessary */ |
5677
|
16
|
|
|
|
|
SvREFCNT_dec(sub); |
5678
|
|
|
|
|
|
|
5679
|
32
|
|
|
|
|
FREETMPS; |
5680
|
16
|
|
|
|
|
LEAVE; |
5681
|
|
|
|
|
|
/* fix up the dummy entry... */ |
5682
|
16
|
|
|
|
|
av_store(cxt->aseen, tagnum, SvREFCNT_inc(sv)); |
5683
|
|
|
|
|
|
|
5684
|
16
|
|
|
|
|
return sv; |
5685
|
|
|
|
|
|
#endif |
5686
|
|
|
|
|
|
} |
5687
|
|
|
|
|
|
|
5688
|
|
|
|
|
|
/* |
5689
|
|
|
|
|
|
* old_retrieve_array |
5690
|
|
|
|
|
|
* |
5691
|
|
|
|
|
|
* Retrieve a whole array in pre-0.6 binary format. |
5692
|
|
|
|
|
|
* |
5693
|
|
|
|
|
|
* Layout is SX_ARRAY followed by each item, in increasing index order. |
5694
|
|
|
|
|
|
* Each item is stored as SX_ITEM or SX_IT_UNDEF for "holes". |
5695
|
|
|
|
|
|
* |
5696
|
|
|
|
|
|
* When we come here, SX_ARRAY has been read already. |
5697
|
|
|
|
|
|
*/ |
5698
|
0
|
|
|
|
|
static SV *old_retrieve_array(pTHX_ stcxt_t *cxt, const char *cname) |
5699
|
|
|
|
|
|
{ |
5700
|
|
|
|
|
|
I32 len; |
5701
|
|
|
|
|
|
I32 i; |
5702
|
|
|
|
|
|
AV *av; |
5703
|
|
|
|
|
|
SV *sv; |
5704
|
|
|
|
|
|
int c; |
5705
|
|
|
|
|
|
|
5706
|
|
|
|
|
|
PERL_UNUSED_ARG(cname); |
5707
|
|
|
|
|
|
TRACEME(("old_retrieve_array (#%d)", cxt->tagnum)); |
5708
|
|
|
|
|
|
|
5709
|
|
|
|
|
|
/* |
5710
|
|
|
|
|
|
* Read length, and allocate array, then pre-extend it. |
5711
|
|
|
|
|
|
*/ |
5712
|
|
|
|
|
|
|
5713
|
0
|
|
|
|
|
RLEN(len); |
5714
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
5715
|
0
|
|
|
|
|
av = newAV(); |
5716
|
0
|
|
|
|
|
SEEN(av, 0, 0); /* Will return if array not allocated nicely */ |
5717
|
0
|
|
|
|
|
if (len) |
5718
|
0
|
|
|
|
|
av_extend(av, len); |
5719
|
|
|
|
|
|
else |
5720
|
|
|
|
|
|
return (SV *) av; /* No data follow if array is empty */ |
5721
|
|
|
|
|
|
|
5722
|
|
|
|
|
|
/* |
5723
|
|
|
|
|
|
* Now get each item in turn... |
5724
|
|
|
|
|
|
*/ |
5725
|
|
|
|
|
|
|
5726
|
0
|
|
|
|
|
for (i = 0; i < len; i++) { |
5727
|
0
|
|
|
|
|
GETMARK(c); |
5728
|
0
|
|
|
|
|
if (c == SX_IT_UNDEF) { |
5729
|
|
|
|
|
|
TRACEME(("(#%d) undef item", i)); |
5730
|
0
|
|
|
|
|
continue; /* av_extend() already filled us with undef */ |
5731
|
|
|
|
|
|
} |
5732
|
0
|
|
|
|
|
if (c != SX_ITEM) |
5733
|
0
|
|
|
|
|
(void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ |
5734
|
|
|
|
|
|
TRACEME(("(#%d) item", i)); |
5735
|
0
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Retrieve item */ |
5736
|
0
|
|
|
|
|
if (!sv) |
5737
|
|
|
|
|
|
return (SV *) 0; |
5738
|
0
|
|
|
|
|
if (av_store(av, i, sv) == 0) |
5739
|
|
|
|
|
|
return (SV *) 0; |
5740
|
|
|
|
|
|
} |
5741
|
|
|
|
|
|
|
5742
|
|
|
|
|
|
TRACEME(("ok (old_retrieve_array at 0x%"UVxf")", PTR2UV(av))); |
5743
|
|
|
|
|
|
|
5744
|
|
|
|
|
|
return (SV *) av; |
5745
|
|
|
|
|
|
} |
5746
|
|
|
|
|
|
|
5747
|
|
|
|
|
|
/* |
5748
|
|
|
|
|
|
* old_retrieve_hash |
5749
|
|
|
|
|
|
* |
5750
|
|
|
|
|
|
* Retrieve a whole hash table in pre-0.6 binary format. |
5751
|
|
|
|
|
|
* |
5752
|
|
|
|
|
|
* Layout is SX_HASH followed by each key/value pair, in random order. |
5753
|
|
|
|
|
|
* Keys are stored as SX_KEY , the section being omitted |
5754
|
|
|
|
|
|
* if length is 0. |
5755
|
|
|
|
|
|
* Values are stored as SX_VALUE or SX_VL_UNDEF for "holes". |
5756
|
|
|
|
|
|
* |
5757
|
|
|
|
|
|
* When we come here, SX_HASH has been read already. |
5758
|
|
|
|
|
|
*/ |
5759
|
0
|
|
|
|
|
static SV *old_retrieve_hash(pTHX_ stcxt_t *cxt, const char *cname) |
5760
|
|
|
|
|
|
{ |
5761
|
|
|
|
|
|
I32 len; |
5762
|
|
|
|
|
|
I32 size; |
5763
|
|
|
|
|
|
I32 i; |
5764
|
|
|
|
|
|
HV *hv; |
5765
|
|
|
|
|
|
SV *sv = (SV *) 0; |
5766
|
|
|
|
|
|
int c; |
5767
|
|
|
|
|
|
SV *sv_h_undef = (SV *) 0; /* hv_store() bug */ |
5768
|
|
|
|
|
|
|
5769
|
|
|
|
|
|
PERL_UNUSED_ARG(cname); |
5770
|
|
|
|
|
|
TRACEME(("old_retrieve_hash (#%d)", cxt->tagnum)); |
5771
|
|
|
|
|
|
|
5772
|
|
|
|
|
|
/* |
5773
|
|
|
|
|
|
* Read length, allocate table. |
5774
|
|
|
|
|
|
*/ |
5775
|
|
|
|
|
|
|
5776
|
0
|
|
|
|
|
RLEN(len); |
5777
|
|
|
|
|
|
TRACEME(("size = %d", len)); |
5778
|
0
|
|
|
|
|
hv = newHV(); |
5779
|
0
|
|
|
|
|
SEEN(hv, 0, 0); /* Will return if table not allocated properly */ |
5780
|
0
|
|
|
|
|
if (len == 0) |
5781
|
|
|
|
|
|
return (SV *) hv; /* No data follow if table empty */ |
5782
|
0
|
|
|
|
|
hv_ksplit(hv, len + 1); /* pre-extend hash to save multiple splits */ |
5783
|
|
|
|
|
|
|
5784
|
|
|
|
|
|
/* |
5785
|
|
|
|
|
|
* Now get each key/value pair in turn... |
5786
|
|
|
|
|
|
*/ |
5787
|
|
|
|
|
|
|
5788
|
0
|
|
|
|
|
for (i = 0; i < len; i++) { |
5789
|
|
|
|
|
|
/* |
5790
|
|
|
|
|
|
* Get value first. |
5791
|
|
|
|
|
|
*/ |
5792
|
|
|
|
|
|
|
5793
|
0
|
|
|
|
|
GETMARK(c); |
5794
|
0
|
|
|
|
|
if (c == SX_VL_UNDEF) { |
5795
|
|
|
|
|
|
TRACEME(("(#%d) undef value", i)); |
5796
|
|
|
|
|
|
/* |
5797
|
|
|
|
|
|
* Due to a bug in hv_store(), it's not possible to pass |
5798
|
|
|
|
|
|
* &PL_sv_undef to hv_store() as a value, otherwise the |
5799
|
|
|
|
|
|
* associated key will not be creatable any more. -- RAM, 14/01/97 |
5800
|
|
|
|
|
|
*/ |
5801
|
0
|
|
|
|
|
if (!sv_h_undef) |
5802
|
0
|
|
|
|
|
sv_h_undef = newSVsv(&PL_sv_undef); |
5803
|
|
|
|
|
|
sv = SvREFCNT_inc(sv_h_undef); |
5804
|
0
|
|
|
|
|
} else if (c == SX_VALUE) { |
5805
|
|
|
|
|
|
TRACEME(("(#%d) value", i)); |
5806
|
0
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); |
5807
|
0
|
|
|
|
|
if (!sv) |
5808
|
|
|
|
|
|
return (SV *) 0; |
5809
|
|
|
|
|
|
} else |
5810
|
0
|
|
|
|
|
(void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ |
5811
|
|
|
|
|
|
|
5812
|
|
|
|
|
|
/* |
5813
|
|
|
|
|
|
* Get key. |
5814
|
|
|
|
|
|
* Since we're reading into kbuf, we must ensure we're not |
5815
|
|
|
|
|
|
* recursing between the read and the hv_store() where it's used. |
5816
|
|
|
|
|
|
* Hence the key comes after the value. |
5817
|
|
|
|
|
|
*/ |
5818
|
|
|
|
|
|
|
5819
|
0
|
|
|
|
|
GETMARK(c); |
5820
|
0
|
|
|
|
|
if (c != SX_KEY) |
5821
|
0
|
|
|
|
|
(void) retrieve_other(aTHX_ (stcxt_t *) 0, 0); /* Will croak out */ |
5822
|
0
|
|
|
|
|
RLEN(size); /* Get key size */ |
5823
|
0
|
|
|
|
|
KBUFCHK((STRLEN)size); /* Grow hash key read pool if needed */ |
5824
|
0
|
|
|
|
|
if (size) |
5825
|
0
|
|
|
|
|
READ(kbuf, size); |
5826
|
0
|
|
|
|
|
kbuf[size] = '\0'; /* Mark string end, just in case */ |
5827
|
|
|
|
|
|
TRACEME(("(#%d) key '%s'", i, kbuf)); |
5828
|
|
|
|
|
|
|
5829
|
|
|
|
|
|
/* |
5830
|
|
|
|
|
|
* Enter key/value pair into hash table. |
5831
|
|
|
|
|
|
*/ |
5832
|
|
|
|
|
|
|
5833
|
0
|
|
|
|
|
if (hv_store(hv, kbuf, (U32) size, sv, 0) == 0) |
5834
|
|
|
|
|
|
return (SV *) 0; |
5835
|
|
|
|
|
|
} |
5836
|
|
|
|
|
|
|
5837
|
|
|
|
|
|
TRACEME(("ok (retrieve_hash at 0x%"UVxf")", PTR2UV(hv))); |
5838
|
|
|
|
|
|
|
5839
|
|
|
|
|
|
return (SV *) hv; |
5840
|
|
|
|
|
|
} |
5841
|
|
|
|
|
|
|
5842
|
|
|
|
|
|
/*** |
5843
|
|
|
|
|
|
*** Retrieval engine. |
5844
|
|
|
|
|
|
***/ |
5845
|
|
|
|
|
|
|
5846
|
|
|
|
|
|
/* |
5847
|
|
|
|
|
|
* magic_check |
5848
|
|
|
|
|
|
* |
5849
|
|
|
|
|
|
* Make sure the stored data we're trying to retrieve has been produced |
5850
|
|
|
|
|
|
* on an ILP compatible system with the same byteorder. It croaks out in |
5851
|
|
|
|
|
|
* case an error is detected. [ILP = integer-long-pointer sizes] |
5852
|
|
|
|
|
|
* Returns null if error is detected, &PL_sv_undef otherwise. |
5853
|
|
|
|
|
|
* |
5854
|
|
|
|
|
|
* Note that there's no byte ordering info emitted when network order was |
5855
|
|
|
|
|
|
* used at store time. |
5856
|
|
|
|
|
|
*/ |
5857
|
2044868
|
|
|
|
|
static SV *magic_check(pTHX_ stcxt_t *cxt) |
5858
|
|
|
|
|
|
{ |
5859
|
|
|
|
|
|
/* The worst case for a malicious header would be old magic (which is |
5860
|
|
|
|
|
|
longer), major, minor, byteorder length byte of 255, 255 bytes of |
5861
|
|
|
|
|
|
garbage, sizeof int, long, pointer, NV. |
5862
|
|
|
|
|
|
So the worse of that we can read is 255 bytes of garbage plus 4. |
5863
|
|
|
|
|
|
Err, I am assuming 8 bit bytes here. Please file a bug report if you're |
5864
|
|
|
|
|
|
compiling perl on a system with chars that are larger than 8 bits. |
5865
|
|
|
|
|
|
(Even Crays aren't *that* perverse). |
5866
|
|
|
|
|
|
*/ |
5867
|
|
|
|
|
|
unsigned char buf[4 + 255]; |
5868
|
|
|
|
|
|
unsigned char *current; |
5869
|
|
|
|
|
|
int c; |
5870
|
|
|
|
|
|
int length; |
5871
|
|
|
|
|
|
int use_network_order; |
5872
|
|
|
|
|
|
int use_NV_size; |
5873
|
|
|
|
|
|
int old_magic = 0; |
5874
|
|
|
|
|
|
int version_major; |
5875
|
|
|
|
|
|
int version_minor = 0; |
5876
|
|
|
|
|
|
|
5877
|
|
|
|
|
|
TRACEME(("magic_check")); |
5878
|
|
|
|
|
|
|
5879
|
|
|
|
|
|
/* |
5880
|
|
|
|
|
|
* The "magic number" is only for files, not when freezing in memory. |
5881
|
|
|
|
|
|
*/ |
5882
|
|
|
|
|
|
|
5883
|
2044868
|
|
|
|
|
if (cxt->fio) { |
5884
|
|
|
|
|
|
/* This includes the '\0' at the end. I want to read the extra byte, |
5885
|
|
|
|
|
|
which is usually going to be the major version number. */ |
5886
|
|
|
|
|
|
STRLEN len = sizeof(magicstr); |
5887
|
|
|
|
|
|
STRLEN old_len; |
5888
|
|
|
|
|
|
|
5889
|
2001198
|
|
|
|
|
READ(buf, (SSize_t)(len)); /* Not null-terminated */ |
5890
|
|
|
|
|
|
|
5891
|
|
|
|
|
|
/* Point at the byte after the byte we read. */ |
5892
|
|
|
|
|
|
current = buf + --len; /* Do the -- outside of macros. */ |
5893
|
|
|
|
|
|
|
5894
|
2001176
|
|
|
|
|
if (memNE(buf, magicstr, len)) { |
5895
|
|
|
|
|
|
/* |
5896
|
|
|
|
|
|
* Try to read more bytes to check for the old magic number, which |
5897
|
|
|
|
|
|
* was longer. |
5898
|
|
|
|
|
|
*/ |
5899
|
|
|
|
|
|
|
5900
|
|
|
|
|
|
TRACEME(("trying for old magic number")); |
5901
|
|
|
|
|
|
|
5902
|
|
|
|
|
|
old_len = sizeof(old_magicstr) - 1; |
5903
|
4
|
|
|
|
|
READ(current + 1, (SSize_t)(old_len - len)); |
5904
|
|
|
|
|
|
|
5905
|
4
|
|
|
|
|
if (memNE(buf, old_magicstr, old_len)) |
5906
|
4
|
|
|
|
|
CROAK(("File is not a perl storable")); |
5907
|
|
|
|
|
|
old_magic++; |
5908
|
|
|
|
|
|
current = buf + old_len; |
5909
|
|
|
|
|
|
} |
5910
|
2001172
|
|
|
|
|
use_network_order = *current; |
5911
|
|
|
|
|
|
} else |
5912
|
43670
|
|
|
|
|
GETMARK(use_network_order); |
5913
|
|
|
|
|
|
|
5914
|
|
|
|
|
|
/* |
5915
|
|
|
|
|
|
* Starting with 0.6, the "use_network_order" byte flag is also used to |
5916
|
|
|
|
|
|
* indicate the version number of the binary, and therefore governs the |
5917
|
|
|
|
|
|
* setting of sv_retrieve_vtbl. See magic_write(). |
5918
|
|
|
|
|
|
*/ |
5919
|
2044838
|
|
|
|
|
if (old_magic && use_network_order > 1) { |
5920
|
|
|
|
|
|
/* 0.1 dump - use_network_order is really byte order length */ |
5921
|
|
|
|
|
|
version_major = -1; |
5922
|
|
|
|
|
|
} |
5923
|
|
|
|
|
|
else { |
5924
|
2044838
|
|
|
|
|
version_major = use_network_order >> 1; |
5925
|
|
|
|
|
|
} |
5926
|
2044838
|
|
|
|
|
cxt->retrieve_vtbl = (SV*(**)(pTHX_ stcxt_t *cxt, const char *cname)) (version_major > 0 ? sv_retrieve : sv_old_retrieve); |
5927
|
|
|
|
|
|
|
5928
|
|
|
|
|
|
TRACEME(("magic_check: netorder = 0x%x", use_network_order)); |
5929
|
|
|
|
|
|
|
5930
|
|
|
|
|
|
|
5931
|
|
|
|
|
|
/* |
5932
|
|
|
|
|
|
* Starting with 0.7 (binary major 2), a full byte is dedicated to the |
5933
|
|
|
|
|
|
* minor version of the protocol. See magic_write(). |
5934
|
|
|
|
|
|
*/ |
5935
|
|
|
|
|
|
|
5936
|
2044838
|
|
|
|
|
if (version_major > 1) |
5937
|
2044836
|
|
|
|
|
GETMARK(version_minor); |
5938
|
|
|
|
|
|
|
5939
|
2044830
|
|
|
|
|
cxt->ver_major = version_major; |
5940
|
2044830
|
|
|
|
|
cxt->ver_minor = version_minor; |
5941
|
|
|
|
|
|
|
5942
|
|
|
|
|
|
TRACEME(("binary image version is %d.%d", version_major, version_minor)); |
5943
|
|
|
|
|
|
|
5944
|
|
|
|
|
|
/* |
5945
|
|
|
|
|
|
* Inter-operability sanity check: we can't retrieve something stored |
5946
|
|
|
|
|
|
* using a format more recent than ours, because we have no way to |
5947
|
|
|
|
|
|
* know what has changed, and letting retrieval go would mean a probable |
5948
|
|
|
|
|
|
* failure reporting a "corrupted" storable file. |
5949
|
|
|
|
|
|
*/ |
5950
|
|
|
|
|
|
|
5951
|
2044830
|
|
|
|
|
if ( |
5952
|
2044810
|
|
|
|
|
version_major > STORABLE_BIN_MAJOR || |
5953
|
4089620
|
|
|
|
|
(version_major == STORABLE_BIN_MAJOR && |
5954
|
2044810
|
|
|
|
|
version_minor > STORABLE_BIN_MINOR) |
5955
|
|
|
|
|
|
) { |
5956
|
|
|
|
|
|
int croak_now = 1; |
5957
|
|
|
|
|
|
TRACEME(("but I am version is %d.%d", STORABLE_BIN_MAJOR, |
5958
|
|
|
|
|
|
STORABLE_BIN_MINOR)); |
5959
|
|
|
|
|
|
|
5960
|
52
|
|
|
|
|
if (version_major == STORABLE_BIN_MAJOR) { |
5961
|
|
|
|
|
|
TRACEME(("cxt->accept_future_minor is %d", |
5962
|
|
|
|
|
|
cxt->accept_future_minor)); |
5963
|
32
|
|
|
|
|
if (cxt->accept_future_minor < 0) |
5964
|
|
|
|
|
|
cxt->accept_future_minor |
5965
|
64
|
|
|
|
|
= (SvTRUE(perl_get_sv("Storable::accept_future_minor", |
5966
|
|
|
|
|
|
GV_ADD)) |
5967
|
0
|
|
|
|
|
? 1 : 0); |
5968
|
32
|
|
|
|
|
if (cxt->accept_future_minor == 1) |
5969
|
|
|
|
|
|
croak_now = 0; /* Don't croak yet. */ |
5970
|
|
|
|
|
|
} |
5971
|
52
|
|
|
|
|
if (croak_now) { |
5972
|
36
|
|
|
|
|
CROAK(("Storable binary image v%d.%d more recent than I am (v%d.%d)", |
5973
|
|
|
|
|
|
version_major, version_minor, |
5974
|
|
|
|
|
|
STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR)); |
5975
|
|
|
|
|
|
} |
5976
|
|
|
|
|
|
} |
5977
|
|
|
|
|
|
|
5978
|
|
|
|
|
|
/* |
5979
|
|
|
|
|
|
* If they stored using network order, there's no byte ordering |
5980
|
|
|
|
|
|
* information to check. |
5981
|
|
|
|
|
|
*/ |
5982
|
|
|
|
|
|
|
5983
|
2044794
|
|
|
|
|
if ((cxt->netorder = (use_network_order & 0x1))) /* Extra () for -Wall */ |
5984
|
|
|
|
|
|
return &PL_sv_undef; /* No byte ordering info */ |
5985
|
|
|
|
|
|
|
5986
|
|
|
|
|
|
/* In C truth is 1, falsehood is 0. Very convenient. */ |
5987
|
43654
|
|
|
|
|
use_NV_size = version_major >= 2 && version_minor >= 2; |
5988
|
|
|
|
|
|
|
5989
|
43654
|
|
|
|
|
if (version_major >= 0) { |
5990
|
43654
|
|
|
|
|
GETMARK(c); |
5991
|
|
|
|
|
|
} |
5992
|
|
|
|
|
|
else { |
5993
|
|
|
|
|
|
c = use_network_order; |
5994
|
|
|
|
|
|
} |
5995
|
43650
|
|
|
|
|
length = c + 3 + use_NV_size; |
5996
|
87080
|
|
|
|
|
READ(buf, length); /* Not null-terminated */ |
5997
|
|
|
|
|
|
|
5998
|
|
|
|
|
|
TRACEME(("byte order '%.*s' %d", c, buf, c)); |
5999
|
|
|
|
|
|
|
6000
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
6001
|
|
|
|
|
|
/* No point in caching this in the context as we only need it once per |
6002
|
|
|
|
|
|
retrieve, and we need to recheck it each read. */ |
6003
|
|
|
|
|
|
if (SvTRUE(perl_get_sv("Storable::interwork_56_64bit", GV_ADD))) { |
6004
|
|
|
|
|
|
if ((c != (sizeof (byteorderstr_56) - 1)) |
6005
|
|
|
|
|
|
|| memNE(buf, byteorderstr_56, c)) |
6006
|
|
|
|
|
|
CROAK(("Byte order is not compatible")); |
6007
|
|
|
|
|
|
} else |
6008
|
|
|
|
|
|
#endif |
6009
|
|
|
|
|
|
{ |
6010
|
43602
|
|
|
|
|
if ((c != (sizeof (byteorderstr) - 1)) || memNE(buf, byteorderstr, c)) |
6011
|
4
|
|
|
|
|
CROAK(("Byte order is not compatible")); |
6012
|
|
|
|
|
|
} |
6013
|
|
|
|
|
|
|
6014
|
43598
|
|
|
|
|
current = buf + c; |
6015
|
|
|
|
|
|
|
6016
|
|
|
|
|
|
/* sizeof(int) */ |
6017
|
43598
|
|
|
|
|
if ((int) *current++ != sizeof(int)) |
6018
|
4
|
|
|
|
|
CROAK(("Integer size is not compatible")); |
6019
|
|
|
|
|
|
|
6020
|
|
|
|
|
|
/* sizeof(long) */ |
6021
|
43594
|
|
|
|
|
if ((int) *current++ != sizeof(long)) |
6022
|
4
|
|
|
|
|
CROAK(("Long integer size is not compatible")); |
6023
|
|
|
|
|
|
|
6024
|
|
|
|
|
|
/* sizeof(char *) */ |
6025
|
43590
|
|
|
|
|
if ((int) *current != sizeof(char *)) |
6026
|
4
|
|
|
|
|
CROAK(("Pointer size is not compatible")); |
6027
|
|
|
|
|
|
|
6028
|
43586
|
|
|
|
|
if (use_NV_size) { |
6029
|
|
|
|
|
|
/* sizeof(NV) */ |
6030
|
43586
|
|
|
|
|
if ((int) *++current != sizeof(NV)) |
6031
|
4
|
|
|
|
|
CROAK(("Double size is not compatible")); |
6032
|
|
|
|
|
|
} |
6033
|
|
|
|
|
|
|
6034
|
|
|
|
|
|
return &PL_sv_undef; /* OK */ |
6035
|
|
|
|
|
|
} |
6036
|
|
|
|
|
|
|
6037
|
|
|
|
|
|
/* |
6038
|
|
|
|
|
|
* retrieve |
6039
|
|
|
|
|
|
* |
6040
|
|
|
|
|
|
* Recursively retrieve objects from the specified file and return their |
6041
|
|
|
|
|
|
* root SV (which may be an AV or an HV for what we care). |
6042
|
|
|
|
|
|
* Returns null if there is a problem. |
6043
|
|
|
|
|
|
*/ |
6044
|
949588706
|
|
|
|
|
static SV *retrieve(pTHX_ stcxt_t *cxt, const char *cname) |
6045
|
|
|
|
|
|
{ |
6046
|
|
|
|
|
|
int type; |
6047
|
|
|
|
|
|
SV **svh; |
6048
|
|
|
|
|
|
SV *sv; |
6049
|
|
|
|
|
|
|
6050
|
|
|
|
|
|
TRACEME(("retrieve")); |
6051
|
|
|
|
|
|
|
6052
|
|
|
|
|
|
/* |
6053
|
|
|
|
|
|
* Grab address tag which identifies the object if we are retrieving |
6054
|
|
|
|
|
|
* an older format. Since the new binary format counts objects and no |
6055
|
|
|
|
|
|
* longer explicitly tags them, we must keep track of the correspondence |
6056
|
|
|
|
|
|
* ourselves. |
6057
|
|
|
|
|
|
* |
6058
|
|
|
|
|
|
* The following section will disappear one day when the old format is |
6059
|
|
|
|
|
|
* no longer supported, hence the final "goto" in the "if" block. |
6060
|
|
|
|
|
|
*/ |
6061
|
|
|
|
|
|
|
6062
|
949588706
|
|
|
|
|
if (cxt->hseen) { /* Retrieving old binary */ |
6063
|
|
|
|
|
|
stag_t tag; |
6064
|
0
|
|
|
|
|
if (cxt->netorder) { |
6065
|
|
|
|
|
|
I32 nettag; |
6066
|
0
|
|
|
|
|
READ(&nettag, sizeof(I32)); /* Ordered sequence of I32 */ |
6067
|
0
|
|
|
|
|
tag = (stag_t) nettag; |
6068
|
|
|
|
|
|
} else |
6069
|
0
|
|
|
|
|
READ(&tag, sizeof(stag_t)); /* Original address of the SV */ |
6070
|
|
|
|
|
|
|
6071
|
0
|
|
|
|
|
GETMARK(type); |
6072
|
0
|
|
|
|
|
if (type == SX_OBJECT) { |
6073
|
|
|
|
|
|
I32 tagn; |
6074
|
0
|
|
|
|
|
svh = hv_fetch(cxt->hseen, (char *) &tag, sizeof(tag), FALSE); |
6075
|
0
|
|
|
|
|
if (!svh) |
6076
|
0
|
|
|
|
|
CROAK(("Old tag 0x%"UVxf" should have been mapped already", |
6077
|
|
|
|
|
|
(UV) tag)); |
6078
|
0
|
|
|
|
|
tagn = SvIV(*svh); /* Mapped tag number computed earlier below */ |
6079
|
|
|
|
|
|
|
6080
|
|
|
|
|
|
/* |
6081
|
|
|
|
|
|
* The following code is common with the SX_OBJECT case below. |
6082
|
|
|
|
|
|
*/ |
6083
|
|
|
|
|
|
|
6084
|
0
|
|
|
|
|
svh = av_fetch(cxt->aseen, tagn, FALSE); |
6085
|
0
|
|
|
|
|
if (!svh) |
6086
|
0
|
|
|
|
|
CROAK(("Object #%"IVdf" should have been retrieved already", |
6087
|
|
|
|
|
|
(IV) tagn)); |
6088
|
0
|
|
|
|
|
sv = *svh; |
6089
|
|
|
|
|
|
TRACEME(("has retrieved #%d at 0x%"UVxf, tagn, PTR2UV(sv))); |
6090
|
|
|
|
|
|
SvREFCNT_inc(sv); /* One more reference to this same sv */ |
6091
|
|
|
|
|
|
return sv; /* The SV pointer where object was retrieved */ |
6092
|
|
|
|
|
|
} |
6093
|
|
|
|
|
|
|
6094
|
|
|
|
|
|
/* |
6095
|
|
|
|
|
|
* Map new object, but don't increase tagnum. This will be done |
6096
|
|
|
|
|
|
* by each of the retrieve_* functions when they call SEEN(). |
6097
|
|
|
|
|
|
* |
6098
|
|
|
|
|
|
* The mapping associates the "tag" initially present with a unique |
6099
|
|
|
|
|
|
* tag number. See test for SX_OBJECT above to see how this is perused. |
6100
|
|
|
|
|
|
*/ |
6101
|
|
|
|
|
|
|
6102
|
0
|
|
|
|
|
if (!hv_store(cxt->hseen, (char *) &tag, sizeof(tag), |
6103
|
|
|
|
|
|
newSViv(cxt->tagnum), 0)) |
6104
|
|
|
|
|
|
return (SV *) 0; |
6105
|
|
|
|
|
|
|
6106
|
|
|
|
|
|
goto first_time; |
6107
|
|
|
|
|
|
} |
6108
|
|
|
|
|
|
|
6109
|
|
|
|
|
|
/* |
6110
|
|
|
|
|
|
* Regular post-0.6 binary format. |
6111
|
|
|
|
|
|
*/ |
6112
|
|
|
|
|
|
|
6113
|
949588706
|
|
|
|
|
GETMARK(type); |
6114
|
|
|
|
|
|
|
6115
|
|
|
|
|
|
TRACEME(("retrieve type = %d", type)); |
6116
|
|
|
|
|
|
|
6117
|
|
|
|
|
|
/* |
6118
|
|
|
|
|
|
* Are we dealing with an object we should have already retrieved? |
6119
|
|
|
|
|
|
*/ |
6120
|
|
|
|
|
|
|
6121
|
949588690
|
|
|
|
|
if (type == SX_OBJECT) { |
6122
|
|
|
|
|
|
I32 tag; |
6123
|
316
|
|
|
|
|
READ_I32(tag); |
6124
|
180
|
|
|
|
|
tag = ntohl(tag); |
6125
|
180
|
|
|
|
|
svh = av_fetch(cxt->aseen, tag, FALSE); |
6126
|
180
|
|
|
|
|
if (!svh) |
6127
|
0
|
|
|
|
|
CROAK(("Object #%"IVdf" should have been retrieved already", |
6128
|
|
|
|
|
|
(IV) tag)); |
6129
|
180
|
|
|
|
|
sv = *svh; |
6130
|
|
|
|
|
|
TRACEME(("had retrieved #%d at 0x%"UVxf, tag, PTR2UV(sv))); |
6131
|
|
|
|
|
|
SvREFCNT_inc(sv); /* One more reference to this same sv */ |
6132
|
|
|
|
|
|
return sv; /* The SV pointer where object was retrieved */ |
6133
|
949588510
|
|
|
|
|
} else if (type >= SX_ERROR && cxt->ver_minor > STORABLE_BIN_MINOR) { |
6134
|
8
|
|
|
|
|
if (cxt->accept_future_minor < 0) |
6135
|
|
|
|
|
|
cxt->accept_future_minor |
6136
|
16
|
|
|
|
|
= (SvTRUE(perl_get_sv("Storable::accept_future_minor", |
6137
|
|
|
|
|
|
GV_ADD)) |
6138
|
0
|
|
|
|
|
? 1 : 0); |
6139
|
8
|
|
|
|
|
if (cxt->accept_future_minor == 1) { |
6140
|
8
|
|
|
|
|
CROAK(("Storable binary image v%d.%d contains data of type %d. " |
6141
|
|
|
|
|
|
"This Storable is v%d.%d and can only handle data types up to %d", |
6142
|
|
|
|
|
|
cxt->ver_major, cxt->ver_minor, type, |
6143
|
|
|
|
|
|
STORABLE_BIN_MAJOR, STORABLE_BIN_MINOR, SX_ERROR - 1)); |
6144
|
|
|
|
|
|
} |
6145
|
|
|
|
|
|
} |
6146
|
|
|
|
|
|
|
6147
|
|
|
|
|
|
first_time: /* Will disappear when support for old format is dropped */ |
6148
|
|
|
|
|
|
|
6149
|
|
|
|
|
|
/* |
6150
|
|
|
|
|
|
* Okay, first time through for this one. |
6151
|
|
|
|
|
|
*/ |
6152
|
|
|
|
|
|
|
6153
|
949588502
|
|
|
|
|
sv = RETRIEVE(cxt, type)(aTHX_ cxt, cname); |
6154
|
949588470
|
|
|
|
|
if (!sv) |
6155
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
6156
|
|
|
|
|
|
|
6157
|
|
|
|
|
|
/* |
6158
|
|
|
|
|
|
* Old binary formats (pre-0.7). |
6159
|
|
|
|
|
|
* |
6160
|
|
|
|
|
|
* Final notifications, ended by SX_STORED may now follow. |
6161
|
|
|
|
|
|
* Currently, the only pertinent notification to apply on the |
6162
|
|
|
|
|
|
* freshly retrieved object is either: |
6163
|
|
|
|
|
|
* SX_CLASS for short classnames. |
6164
|
|
|
|
|
|
* SX_LG_CLASS for larger one (rare!). |
6165
|
|
|
|
|
|
* Class name is then read into the key buffer pool used by |
6166
|
|
|
|
|
|
* hash table key retrieval. |
6167
|
|
|
|
|
|
*/ |
6168
|
|
|
|
|
|
|
6169
|
949588254
|
|
|
|
|
if (cxt->ver_major < 2) { |
6170
|
90
|
|
|
|
|
while ((type = GETCHAR()) != SX_STORED) { |
6171
|
|
|
|
|
|
I32 len; |
6172
|
|
|
|
|
|
HV* stash; |
6173
|
14
|
|
|
|
|
switch (type) { |
6174
|
|
|
|
|
|
case SX_CLASS: |
6175
|
14
|
|
|
|
|
GETMARK(len); /* Length coded on a single char */ |
6176
|
|
|
|
|
|
break; |
6177
|
|
|
|
|
|
case SX_LG_CLASS: /* Length coded on a regular integer */ |
6178
|
0
|
|
|
|
|
RLEN(len); |
6179
|
|
|
|
|
|
break; |
6180
|
|
|
|
|
|
case EOF: |
6181
|
|
|
|
|
|
default: |
6182
|
|
|
|
|
|
return (SV *) 0; /* Failed */ |
6183
|
|
|
|
|
|
} |
6184
|
14
|
|
|
|
|
KBUFCHK((STRLEN)len); /* Grow buffer as necessary */ |
6185
|
14
|
|
|
|
|
if (len) |
6186
|
28
|
|
|
|
|
READ(kbuf, len); |
6187
|
14
|
|
|
|
|
kbuf[len] = '\0'; /* Mark string end */ |
6188
|
14
|
|
|
|
|
stash = gv_stashpvn(kbuf, len, GV_ADD); |
6189
|
28
|
|
|
|
|
BLESS(sv, stash); |
6190
|
|
|
|
|
|
} |
6191
|
|
|
|
|
|
} |
6192
|
|
|
|
|
|
|
6193
|
|
|
|
|
|
TRACEME(("ok (retrieved 0x%"UVxf", refcnt=%d, %s)", PTR2UV(sv), |
6194
|
|
|
|
|
|
SvREFCNT(sv) - 1, sv_reftype(sv, FALSE))); |
6195
|
|
|
|
|
|
|
6196
|
|
|
|
|
|
return sv; /* Ok */ |
6197
|
|
|
|
|
|
} |
6198
|
|
|
|
|
|
|
6199
|
|
|
|
|
|
/* |
6200
|
|
|
|
|
|
* do_retrieve |
6201
|
|
|
|
|
|
* |
6202
|
|
|
|
|
|
* Retrieve data held in file and return the root object. |
6203
|
|
|
|
|
|
* Common routine for pretrieve and mretrieve. |
6204
|
|
|
|
|
|
*/ |
6205
|
2044870
|
|
|
|
|
static SV *do_retrieve( |
6206
|
|
|
|
|
|
pTHX_ |
6207
|
|
|
|
|
|
PerlIO *f, |
6208
|
|
|
|
|
|
SV *in, |
6209
|
|
|
|
|
|
int optype) |
6210
|
|
|
|
|
|
{ |
6211
|
2044870
|
|
|
|
|
dSTCXT; |
6212
|
|
|
|
|
|
SV *sv; |
6213
|
|
|
|
|
|
int is_tainted; /* Is input source tainted? */ |
6214
|
|
|
|
|
|
int pre_06_fmt = 0; /* True with pre Storable 0.6 formats */ |
6215
|
|
|
|
|
|
|
6216
|
|
|
|
|
|
TRACEME(("do_retrieve (optype = 0x%x)", optype)); |
6217
|
|
|
|
|
|
|
6218
|
2044870
|
|
|
|
|
optype |= ST_RETRIEVE; |
6219
|
|
|
|
|
|
|
6220
|
|
|
|
|
|
/* |
6221
|
|
|
|
|
|
* Sanity assertions for retrieve dispatch tables. |
6222
|
|
|
|
|
|
*/ |
6223
|
|
|
|
|
|
|
6224
|
|
|
|
|
|
ASSERT(sizeof(sv_old_retrieve) == sizeof(sv_retrieve), |
6225
|
|
|
|
|
|
("old and new retrieve dispatch table have same size")); |
6226
|
|
|
|
|
|
ASSERT(sv_old_retrieve[SX_ERROR] == retrieve_other, |
6227
|
|
|
|
|
|
("SX_ERROR entry correctly initialized in old dispatch table")); |
6228
|
|
|
|
|
|
ASSERT(sv_retrieve[SX_ERROR] == retrieve_other, |
6229
|
|
|
|
|
|
("SX_ERROR entry correctly initialized in new dispatch table")); |
6230
|
|
|
|
|
|
|
6231
|
|
|
|
|
|
/* |
6232
|
|
|
|
|
|
* Workaround for CROAK leak: if they enter with a "dirty" context, |
6233
|
|
|
|
|
|
* free up memory for them now. |
6234
|
|
|
|
|
|
*/ |
6235
|
|
|
|
|
|
|
6236
|
2044870
|
|
|
|
|
if (cxt->s_dirty) |
6237
|
174
|
|
|
|
|
clean_context(aTHX_ cxt); |
6238
|
|
|
|
|
|
|
6239
|
|
|
|
|
|
/* |
6240
|
|
|
|
|
|
* Now that STORABLE_xxx hooks exist, it is possible that they try to |
6241
|
|
|
|
|
|
* re-enter retrieve() via the hooks. |
6242
|
|
|
|
|
|
*/ |
6243
|
|
|
|
|
|
|
6244
|
2044870
|
|
|
|
|
if (cxt->entry) |
6245
|
78
|
|
|
|
|
cxt = allocate_context(aTHX_ cxt); |
6246
|
|
|
|
|
|
|
6247
|
2044870
|
|
|
|
|
cxt->entry++; |
6248
|
|
|
|
|
|
|
6249
|
|
|
|
|
|
ASSERT(cxt->entry == 1, ("starting new recursion")); |
6250
|
|
|
|
|
|
ASSERT(!cxt->s_dirty, ("clean context")); |
6251
|
|
|
|
|
|
|
6252
|
|
|
|
|
|
/* |
6253
|
|
|
|
|
|
* Prepare context. |
6254
|
|
|
|
|
|
* |
6255
|
|
|
|
|
|
* Data is loaded into the memory buffer when f is NULL, unless 'in' is |
6256
|
|
|
|
|
|
* also NULL, in which case we're expecting the data to already lie |
6257
|
|
|
|
|
|
* in the buffer (dclone case). |
6258
|
|
|
|
|
|
*/ |
6259
|
|
|
|
|
|
|
6260
|
2044870
|
|
|
|
|
KBUFINIT(); /* Allocate hash key reading pool once */ |
6261
|
|
|
|
|
|
|
6262
|
2044870
|
|
|
|
|
if (!f && in) { |
6263
|
|
|
|
|
|
#ifdef SvUTF8_on |
6264
|
654
|
|
|
|
|
if (SvUTF8(in)) { |
6265
|
|
|
|
|
|
STRLEN length; |
6266
|
4
|
|
|
|
|
const char *orig = SvPV(in, length); |
6267
|
|
|
|
|
|
char *asbytes; |
6268
|
|
|
|
|
|
/* This is quite deliberate. I want the UTF8 routines |
6269
|
|
|
|
|
|
to encounter the '\0' which perl adds at the end |
6270
|
|
|
|
|
|
of all scalars, so that any new string also has |
6271
|
|
|
|
|
|
this. |
6272
|
|
|
|
|
|
*/ |
6273
|
4
|
|
|
|
|
STRLEN klen_tmp = length + 1; |
6274
|
4
|
|
|
|
|
bool is_utf8 = TRUE; |
6275
|
|
|
|
|
|
|
6276
|
|
|
|
|
|
/* Just casting the &klen to (STRLEN) won't work |
6277
|
|
|
|
|
|
well if STRLEN and I32 are of different widths. |
6278
|
|
|
|
|
|
--jhi */ |
6279
|
4
|
|
|
|
|
asbytes = (char*)bytes_from_utf8((U8*)orig, |
6280
|
|
|
|
|
|
&klen_tmp, |
6281
|
|
|
|
|
|
&is_utf8); |
6282
|
4
|
|
|
|
|
if (is_utf8) { |
6283
|
2
|
|
|
|
|
CROAK(("Frozen string corrupt - contains characters outside 0-255")); |
6284
|
|
|
|
|
|
} |
6285
|
4
|
|
|
|
|
if (asbytes != orig) { |
6286
|
|
|
|
|
|
/* String has been converted. |
6287
|
|
|
|
|
|
There is no need to keep any reference to |
6288
|
|
|
|
|
|
the old string. */ |
6289
|
2
|
|
|
|
|
in = sv_newmortal(); |
6290
|
|
|
|
|
|
/* We donate the SV the malloc()ed string |
6291
|
|
|
|
|
|
bytes_from_utf8 returned us. */ |
6292
|
4
|
|
|
|
|
SvUPGRADE(in, SVt_PV); |
6293
|
2
|
|
|
|
|
SvPOK_on(in); |
6294
|
2
|
|
|
|
|
SvPV_set(in, asbytes); |
6295
|
2
|
|
|
|
|
SvLEN_set(in, klen_tmp); |
6296
|
2
|
|
|
|
|
SvCUR_set(in, klen_tmp - 1); |
6297
|
|
|
|
|
|
} |
6298
|
|
|
|
|
|
} |
6299
|
|
|
|
|
|
#endif |
6300
|
652
|
|
|
|
|
MBUF_SAVE_AND_LOAD(in); |
6301
|
|
|
|
|
|
} |
6302
|
|
|
|
|
|
|
6303
|
|
|
|
|
|
/* |
6304
|
|
|
|
|
|
* Magic number verifications. |
6305
|
|
|
|
|
|
* |
6306
|
|
|
|
|
|
* This needs to be done before calling init_retrieve_context() |
6307
|
|
|
|
|
|
* since the format indication in the file are necessary to conduct |
6308
|
|
|
|
|
|
* some of the initializations. |
6309
|
|
|
|
|
|
*/ |
6310
|
|
|
|
|
|
|
6311
|
2044868
|
|
|
|
|
cxt->fio = f; /* Where I/O are performed */ |
6312
|
|
|
|
|
|
|
6313
|
2044868
|
|
|
|
|
if (!magic_check(aTHX_ cxt)) |
6314
|
86
|
|
|
|
|
CROAK(("Magic number checking on storable %s failed", |
6315
|
|
|
|
|
|
cxt->fio ? "file" : "string")); |
6316
|
|
|
|
|
|
|
6317
|
|
|
|
|
|
TRACEME(("data stored in %s format", |
6318
|
|
|
|
|
|
cxt->netorder ? "net order" : "native")); |
6319
|
|
|
|
|
|
|
6320
|
|
|
|
|
|
/* |
6321
|
|
|
|
|
|
* Check whether input source is tainted, so that we don't wrongly |
6322
|
|
|
|
|
|
* taint perfectly good values... |
6323
|
|
|
|
|
|
* |
6324
|
|
|
|
|
|
* We assume file input is always tainted. If both 'f' and 'in' are |
6325
|
|
|
|
|
|
* NULL, then we come from dclone, and tainted is already filled in |
6326
|
|
|
|
|
|
* the context. That's a kludge, but the whole dclone() thing is |
6327
|
|
|
|
|
|
* already quite a kludge anyway! -- RAM, 15/09/2000. |
6328
|
|
|
|
|
|
*/ |
6329
|
|
|
|
|
|
|
6330
|
2044722
|
|
|
|
|
is_tainted = f ? 1 : (in ? SvTAINTED(in) : cxt->s_tainted); |
6331
|
|
|
|
|
|
TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted")); |
6332
|
|
|
|
|
|
init_retrieve_context(aTHX_ cxt, optype, is_tainted); |
6333
|
|
|
|
|
|
|
6334
|
|
|
|
|
|
ASSERT(is_retrieving(aTHX), ("within retrieve operation")); |
6335
|
|
|
|
|
|
|
6336
|
2044722
|
|
|
|
|
sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */ |
6337
|
|
|
|
|
|
|
6338
|
|
|
|
|
|
/* |
6339
|
|
|
|
|
|
* Final cleanup. |
6340
|
|
|
|
|
|
*/ |
6341
|
|
|
|
|
|
|
6342
|
2044682
|
|
|
|
|
if (!f && in) |
6343
|
560
|
|
|
|
|
MBUF_RESTORE(); |
6344
|
|
|
|
|
|
|
6345
|
2044682
|
|
|
|
|
pre_06_fmt = cxt->hseen != NULL; /* Before we clean context */ |
6346
|
|
|
|
|
|
|
6347
|
|
|
|
|
|
/* |
6348
|
|
|
|
|
|
* The "root" context is never freed. |
6349
|
|
|
|
|
|
*/ |
6350
|
|
|
|
|
|
|
6351
|
2044682
|
|
|
|
|
clean_retrieve_context(aTHX_ cxt); |
6352
|
2044682
|
|
|
|
|
if (cxt->prev) /* This context was stacked */ |
6353
|
|
|
|
|
|
free_context(aTHX_ cxt); /* It was not the "root" context */ |
6354
|
|
|
|
|
|
|
6355
|
|
|
|
|
|
/* |
6356
|
|
|
|
|
|
* Prepare returned value. |
6357
|
|
|
|
|
|
*/ |
6358
|
|
|
|
|
|
|
6359
|
2044682
|
|
|
|
|
if (!sv) { |
6360
|
|
|
|
|
|
TRACEME(("retrieve ERROR")); |
6361
|
|
|
|
|
|
#if (PATCHLEVEL <= 4) |
6362
|
|
|
|
|
|
/* perl 5.00405 seems to screw up at this point with an |
6363
|
|
|
|
|
|
'attempt to modify a read only value' error reported in the |
6364
|
|
|
|
|
|
eval { $self = pretrieve(*FILE) } in _retrieve. |
6365
|
|
|
|
|
|
I can't see what the cause of this error is, but I suspect a |
6366
|
|
|
|
|
|
bug in 5.004, as it seems to be capable of issuing spurious |
6367
|
|
|
|
|
|
errors or core dumping with matches on $@. I'm not going to |
6368
|
|
|
|
|
|
spend time on what could be a fruitless search for the cause, |
6369
|
|
|
|
|
|
so here's a bodge. If you're running 5.004 and don't like |
6370
|
|
|
|
|
|
this inefficiency, either upgrade to a newer perl, or you are |
6371
|
|
|
|
|
|
welcome to find the problem and send in a patch. |
6372
|
|
|
|
|
|
*/ |
6373
|
|
|
|
|
|
return newSV(0); |
6374
|
|
|
|
|
|
#else |
6375
|
|
|
|
|
|
return &PL_sv_undef; /* Something went wrong, return undef */ |
6376
|
|
|
|
|
|
#endif |
6377
|
|
|
|
|
|
} |
6378
|
|
|
|
|
|
|
6379
|
|
|
|
|
|
TRACEME(("retrieve got %s(0x%"UVxf")", |
6380
|
|
|
|
|
|
sv_reftype(sv, FALSE), PTR2UV(sv))); |
6381
|
|
|
|
|
|
|
6382
|
|
|
|
|
|
/* |
6383
|
|
|
|
|
|
* Backward compatibility with Storable-0.5@9 (which we know we |
6384
|
|
|
|
|
|
* are retrieving if hseen is non-null): don't create an extra RV |
6385
|
|
|
|
|
|
* for objects since we special-cased it at store time. |
6386
|
|
|
|
|
|
* |
6387
|
|
|
|
|
|
* Build a reference to the SV returned by pretrieve even if it is |
6388
|
|
|
|
|
|
* already one and not a scalar, for consistency reasons. |
6389
|
|
|
|
|
|
*/ |
6390
|
|
|
|
|
|
|
6391
|
2044506
|
|
|
|
|
if (pre_06_fmt) { /* Was not handling overloading by then */ |
6392
|
|
|
|
|
|
SV *rv; |
6393
|
|
|
|
|
|
TRACEME(("fixing for old formats -- pre 0.6")); |
6394
|
0
|
|
|
|
|
if (sv_type(aTHX_ sv) == svis_REF && (rv = SvRV(sv)) && SvOBJECT(rv)) { |
6395
|
|
|
|
|
|
TRACEME(("ended do_retrieve() with an object -- pre 0.6")); |
6396
|
|
|
|
|
|
return sv; |
6397
|
|
|
|
|
|
} |
6398
|
|
|
|
|
|
} |
6399
|
|
|
|
|
|
|
6400
|
|
|
|
|
|
/* |
6401
|
|
|
|
|
|
* If reference is overloaded, restore behaviour. |
6402
|
|
|
|
|
|
* |
6403
|
|
|
|
|
|
* NB: minor glitch here: normally, overloaded refs are stored specially |
6404
|
|
|
|
|
|
* so that we can croak when behaviour cannot be re-installed, and also |
6405
|
|
|
|
|
|
* avoid testing for overloading magic at each reference retrieval. |
6406
|
|
|
|
|
|
* |
6407
|
|
|
|
|
|
* Unfortunately, the root reference is implicitly stored, so we must |
6408
|
|
|
|
|
|
* check for possible overloading now. Furthermore, if we don't restore |
6409
|
|
|
|
|
|
* overloading, we cannot croak as if the original ref was, because we |
6410
|
|
|
|
|
|
* have no way to determine whether it was an overloaded ref or not in |
6411
|
|
|
|
|
|
* the first place. |
6412
|
|
|
|
|
|
* |
6413
|
|
|
|
|
|
* It's a pity that overloading magic is attached to the rv, and not to |
6414
|
|
|
|
|
|
* the underlying sv as blessing is. |
6415
|
|
|
|
|
|
*/ |
6416
|
|
|
|
|
|
|
6417
|
2044506
|
|
|
|
|
if (SvOBJECT(sv)) { |
6418
|
162
|
|
|
|
|
HV *stash = (HV *) SvSTASH(sv); |
6419
|
162
|
|
|
|
|
SV *rv = newRV_noinc(sv); |
6420
|
162
|
|
|
|
|
if (stash && Gv_AMG(stash)) { |
6421
|
|
|
|
|
|
SvAMAGIC_on(rv); |
6422
|
|
|
|
|
|
TRACEME(("restored overloading on root reference")); |
6423
|
|
|
|
|
|
} |
6424
|
|
|
|
|
|
TRACEME(("ended do_retrieve() with an object")); |
6425
|
|
|
|
|
|
return rv; |
6426
|
|
|
|
|
|
} |
6427
|
|
|
|
|
|
|
6428
|
|
|
|
|
|
TRACEME(("regular do_retrieve() end")); |
6429
|
|
|
|
|
|
|
6430
|
2044344
|
|
|
|
|
return newRV_noinc(sv); |
6431
|
|
|
|
|
|
} |
6432
|
|
|
|
|
|
|
6433
|
|
|
|
|
|
/* |
6434
|
|
|
|
|
|
* pretrieve |
6435
|
|
|
|
|
|
* |
6436
|
|
|
|
|
|
* Retrieve data held in file and return the root object, undef on error. |
6437
|
|
|
|
|
|
*/ |
6438
|
|
|
|
|
|
static SV *pretrieve(pTHX_ PerlIO *f) |
6439
|
|
|
|
|
|
{ |
6440
|
|
|
|
|
|
TRACEME(("pretrieve")); |
6441
|
2001198
|
|
|
|
|
return do_retrieve(aTHX_ f, Nullsv, 0); |
6442
|
|
|
|
|
|
} |
6443
|
|
|
|
|
|
|
6444
|
|
|
|
|
|
/* |
6445
|
|
|
|
|
|
* mretrieve |
6446
|
|
|
|
|
|
* |
6447
|
|
|
|
|
|
* Retrieve data held in scalar and return the root object, undef on error. |
6448
|
|
|
|
|
|
*/ |
6449
|
|
|
|
|
|
static SV *mretrieve(pTHX_ SV *sv) |
6450
|
|
|
|
|
|
{ |
6451
|
|
|
|
|
|
TRACEME(("mretrieve")); |
6452
|
654
|
|
|
|
|
return do_retrieve(aTHX_ (PerlIO*) 0, sv, 0); |
6453
|
|
|
|
|
|
} |
6454
|
|
|
|
|
|
|
6455
|
|
|
|
|
|
/*** |
6456
|
|
|
|
|
|
*** Deep cloning |
6457
|
|
|
|
|
|
***/ |
6458
|
|
|
|
|
|
|
6459
|
|
|
|
|
|
/* |
6460
|
|
|
|
|
|
* dclone |
6461
|
|
|
|
|
|
* |
6462
|
|
|
|
|
|
* Deep clone: returns a fresh copy of the original referenced SV tree. |
6463
|
|
|
|
|
|
* |
6464
|
|
|
|
|
|
* This is achieved by storing the object in memory and restoring from |
6465
|
|
|
|
|
|
* there. Not that efficient, but it should be faster than doing it from |
6466
|
|
|
|
|
|
* pure perl anyway. |
6467
|
|
|
|
|
|
*/ |
6468
|
43018
|
|
|
|
|
static SV *dclone(pTHX_ SV *sv) |
6469
|
|
|
|
|
|
{ |
6470
|
43018
|
|
|
|
|
dSTCXT; |
6471
|
|
|
|
|
|
int size; |
6472
|
|
|
|
|
|
stcxt_t *real_context; |
6473
|
|
|
|
|
|
SV *out; |
6474
|
|
|
|
|
|
|
6475
|
|
|
|
|
|
TRACEME(("dclone")); |
6476
|
|
|
|
|
|
|
6477
|
|
|
|
|
|
/* |
6478
|
|
|
|
|
|
* Workaround for CROAK leak: if they enter with a "dirty" context, |
6479
|
|
|
|
|
|
* free up memory for them now. |
6480
|
|
|
|
|
|
*/ |
6481
|
|
|
|
|
|
|
6482
|
43018
|
|
|
|
|
if (cxt->s_dirty) |
6483
|
0
|
|
|
|
|
clean_context(aTHX_ cxt); |
6484
|
|
|
|
|
|
|
6485
|
|
|
|
|
|
/* |
6486
|
|
|
|
|
|
* Tied elements seem to need special handling. |
6487
|
|
|
|
|
|
*/ |
6488
|
|
|
|
|
|
|
6489
|
43018
|
|
|
|
|
if ((SvTYPE(sv) == SVt_PVLV |
6490
|
|
|
|
|
|
#if PERL_VERSION < 8 |
6491
|
|
|
|
|
|
|| SvTYPE(sv) == SVt_PVMG |
6492
|
|
|
|
|
|
#endif |
6493
|
43022
|
|
|
|
|
) && SvRMAGICAL(sv) && mg_find(sv, 'p')) { |
6494
|
4
|
|
|
|
|
mg_get(sv); |
6495
|
|
|
|
|
|
} |
6496
|
|
|
|
|
|
|
6497
|
|
|
|
|
|
/* |
6498
|
|
|
|
|
|
* do_store() optimizes for dclone by not freeing its context, should |
6499
|
|
|
|
|
|
* we need to allocate one because we're deep cloning from a hook. |
6500
|
|
|
|
|
|
*/ |
6501
|
|
|
|
|
|
|
6502
|
43018
|
|
|
|
|
if (!do_store(aTHX_ (PerlIO*) 0, sv, ST_CLONE, FALSE, (SV**) 0)) |
6503
|
|
|
|
|
|
return &PL_sv_undef; /* Error during store */ |
6504
|
|
|
|
|
|
|
6505
|
|
|
|
|
|
/* |
6506
|
|
|
|
|
|
* Because of the above optimization, we have to refresh the context, |
6507
|
|
|
|
|
|
* since a new one could have been allocated and stacked by do_store(). |
6508
|
|
|
|
|
|
*/ |
6509
|
|
|
|
|
|
|
6510
|
43018
|
|
|
|
|
{ dSTCXT; real_context = cxt; } /* Sub-block needed for macro */ |
6511
|
|
|
|
|
|
cxt = real_context; /* And we need this temporary... */ |
6512
|
|
|
|
|
|
|
6513
|
|
|
|
|
|
/* |
6514
|
|
|
|
|
|
* Now, 'cxt' may refer to a new context. |
6515
|
|
|
|
|
|
*/ |
6516
|
|
|
|
|
|
|
6517
|
|
|
|
|
|
ASSERT(!cxt->s_dirty, ("clean context")); |
6518
|
|
|
|
|
|
ASSERT(!cxt->entry, ("entry will not cause new context allocation")); |
6519
|
|
|
|
|
|
|
6520
|
43018
|
|
|
|
|
size = MBUF_SIZE(); |
6521
|
|
|
|
|
|
TRACEME(("dclone stored %d bytes", size)); |
6522
|
43018
|
|
|
|
|
MBUF_INIT(size); |
6523
|
|
|
|
|
|
|
6524
|
|
|
|
|
|
/* |
6525
|
|
|
|
|
|
* Since we're passing do_retrieve() both a NULL file and sv, we need |
6526
|
|
|
|
|
|
* to pre-compute the taintedness of the input by setting cxt->tainted |
6527
|
|
|
|
|
|
* to whatever state our own input string was. -- RAM, 15/09/2000 |
6528
|
|
|
|
|
|
* |
6529
|
|
|
|
|
|
* do_retrieve() will free non-root context. |
6530
|
|
|
|
|
|
*/ |
6531
|
|
|
|
|
|
|
6532
|
43018
|
|
|
|
|
cxt->s_tainted = SvTAINTED(sv); |
6533
|
43018
|
|
|
|
|
out = do_retrieve(aTHX_ (PerlIO*) 0, Nullsv, ST_CLONE); |
6534
|
|
|
|
|
|
|
6535
|
|
|
|
|
|
TRACEME(("dclone returns 0x%"UVxf, PTR2UV(out))); |
6536
|
|
|
|
|
|
|
6537
|
43018
|
|
|
|
|
return out; |
6538
|
|
|
|
|
|
} |
6539
|
|
|
|
|
|
|
6540
|
|
|
|
|
|
/*** |
6541
|
|
|
|
|
|
*** Glue with perl. |
6542
|
|
|
|
|
|
***/ |
6543
|
|
|
|
|
|
|
6544
|
|
|
|
|
|
/* |
6545
|
|
|
|
|
|
* The Perl IO GV object distinguishes between input and output for sockets |
6546
|
|
|
|
|
|
* but not for plain files. To allow Storable to transparently work on |
6547
|
|
|
|
|
|
* plain files and sockets transparently, we have to ask xsubpp to fetch the |
6548
|
|
|
|
|
|
* right object for us. Hence the OutputStream and InputStream declarations. |
6549
|
|
|
|
|
|
* |
6550
|
|
|
|
|
|
* Before perl 5.004_05, those entries in the standard typemap are not |
6551
|
|
|
|
|
|
* defined in perl include files, so we do that here. |
6552
|
|
|
|
|
|
*/ |
6553
|
|
|
|
|
|
|
6554
|
|
|
|
|
|
#ifndef OutputStream |
6555
|
|
|
|
|
|
#define OutputStream PerlIO * |
6556
|
|
|
|
|
|
#define InputStream PerlIO * |
6557
|
|
|
|
|
|
#endif /* !OutputStream */ |
6558
|
|
|
|
|
|
|
6559
|
|
|
|
|
|
static int |
6560
|
158
|
|
|
|
|
storable_free(pTHX_ SV *sv, MAGIC* mg) { |
6561
|
158
|
|
|
|
|
stcxt_t *cxt = (stcxt_t *)SvPVX(sv); |
6562
|
158
|
|
|
|
|
if (kbuf) |
6563
|
80
|
|
|
|
|
Safefree(kbuf); |
6564
|
158
|
|
|
|
|
if (!cxt->membuf_ro && mbase) |
6565
|
80
|
|
|
|
|
Safefree(mbase); |
6566
|
158
|
|
|
|
|
if (cxt->membuf_ro && (cxt->msaved).arena) |
6567
|
0
|
|
|
|
|
Safefree((cxt->msaved).arena); |
6568
|
158
|
|
|
|
|
return 0; |
6569
|
|
|
|
|
|
} |
6570
|
|
|
|
|
|
|
6571
|
|
|
|
|
|
MODULE = Storable PACKAGE = Storable |
6572
|
|
|
|
|
|
|
6573
|
|
|
|
|
|
PROTOTYPES: ENABLE |
6574
|
|
|
|
|
|
|
6575
|
|
|
|
|
|
BOOT: |
6576
|
|
|
|
|
|
{ |
6577
|
4550
|
|
|
|
|
HV *stash = gv_stashpvn("Storable", 8, GV_ADD); |
6578
|
4550
|
|
|
|
|
newCONSTSUB(stash, "BIN_MAJOR", newSViv(STORABLE_BIN_MAJOR)); |
6579
|
4550
|
|
|
|
|
newCONSTSUB(stash, "BIN_MINOR", newSViv(STORABLE_BIN_MINOR)); |
6580
|
4550
|
|
|
|
|
newCONSTSUB(stash, "BIN_WRITE_MINOR", newSViv(STORABLE_BIN_WRITE_MINOR)); |
6581
|
|
|
|
|
|
|
6582
|
4550
|
|
|
|
|
init_perinterp(aTHX); |
6583
|
4550
|
|
|
|
|
gv_fetchpv("Storable::drop_utf8", GV_ADDMULTI, SVt_PV); |
6584
|
|
|
|
|
|
#ifdef DEBUGME |
6585
|
|
|
|
|
|
/* Only disable the used only once warning if we are in debugging mode. */ |
6586
|
|
|
|
|
|
gv_fetchpv("Storable::DEBUGME", GV_ADDMULTI, SVt_PV); |
6587
|
|
|
|
|
|
#endif |
6588
|
|
|
|
|
|
#ifdef USE_56_INTERWORK_KLUDGE |
6589
|
|
|
|
|
|
gv_fetchpv("Storable::interwork_56_64bit", GV_ADDMULTI, SVt_PV); |
6590
|
|
|
|
|
|
#endif |
6591
|
|
|
|
|
|
} |
6592
|
|
|
|
|
|
|
6593
|
|
|
|
|
|
void |
6594
|
|
|
|
|
|
init_perinterp() |
6595
|
|
|
|
|
|
CODE: |
6596
|
0
|
|
|
|
|
init_perinterp(aTHX); |
6597
|
|
|
|
|
|
|
6598
|
|
|
|
|
|
# pstore |
6599
|
|
|
|
|
|
# |
6600
|
|
|
|
|
|
# Store the transitive data closure of given object to disk. |
6601
|
|
|
|
|
|
# Returns undef on error, a true value otherwise. |
6602
|
|
|
|
|
|
|
6603
|
|
|
|
|
|
# net_pstore |
6604
|
|
|
|
|
|
# |
6605
|
|
|
|
|
|
# Same as pstore(), but network order is used for integers and doubles are |
6606
|
|
|
|
|
|
# emitted as strings. |
6607
|
|
|
|
|
|
|
6608
|
|
|
|
|
|
SV * |
6609
|
|
|
|
|
|
pstore(f,obj) |
6610
|
|
|
|
|
|
OutputStream f |
6611
|
|
|
|
|
|
SV * obj |
6612
|
|
|
|
|
|
ALIAS: |
6613
|
|
|
|
|
|
net_pstore = 1 |
6614
|
|
|
|
|
|
PPCODE: |
6615
|
321984
|
|
|
|
|
RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef; |
6616
|
|
|
|
|
|
/* do_store() can reallocate the stack, so need a sequence point to ensure |
6617
|
|
|
|
|
|
that ST(0) knows about it. Hence using two statements. */ |
6618
|
321982
|
|
|
|
|
ST(0) = RETVAL; |
6619
|
321982
|
|
|
|
|
XSRETURN(1); |
6620
|
|
|
|
|
|
|
6621
|
|
|
|
|
|
# mstore |
6622
|
|
|
|
|
|
# |
6623
|
|
|
|
|
|
# Store the transitive data closure of given object to memory. |
6624
|
|
|
|
|
|
# Returns undef on error, a scalar value containing the data otherwise. |
6625
|
|
|
|
|
|
|
6626
|
|
|
|
|
|
# net_mstore |
6627
|
|
|
|
|
|
# |
6628
|
|
|
|
|
|
# Same as mstore(), but network order is used for integers and doubles are |
6629
|
|
|
|
|
|
# emitted as strings. |
6630
|
|
|
|
|
|
|
6631
|
|
|
|
|
|
SV * |
6632
|
|
|
|
|
|
mstore(obj) |
6633
|
|
|
|
|
|
SV * obj |
6634
|
|
|
|
|
|
ALIAS: |
6635
|
|
|
|
|
|
net_mstore = 1 |
6636
|
|
|
|
|
|
CODE: |
6637
|
452
|
|
|
|
|
if (!do_store(aTHX_ (PerlIO*) 0, obj, 0, ix, &RETVAL)) |
6638
|
0
|
|
|
|
|
RETVAL = &PL_sv_undef; |
6639
|
|
|
|
|
|
OUTPUT: |
6640
|
|
|
|
|
|
RETVAL |
6641
|
|
|
|
|
|
|
6642
|
|
|
|
|
|
SV * |
6643
|
|
|
|
|
|
pretrieve(f) |
6644
|
|
|
|
|
|
InputStream f |
6645
|
|
|
|
|
|
CODE: |
6646
|
|
|
|
|
|
RETVAL = pretrieve(aTHX_ f); |
6647
|
|
|
|
|
|
OUTPUT: |
6648
|
|
|
|
|
|
RETVAL |
6649
|
|
|
|
|
|
|
6650
|
|
|
|
|
|
SV * |
6651
|
|
|
|
|
|
mretrieve(sv) |
6652
|
|
|
|
|
|
SV * sv |
6653
|
|
|
|
|
|
CODE: |
6654
|
|
|
|
|
|
RETVAL = mretrieve(aTHX_ sv); |
6655
|
|
|
|
|
|
OUTPUT: |
6656
|
|
|
|
|
|
RETVAL |
6657
|
|
|
|
|
|
|
6658
|
|
|
|
|
|
SV * |
6659
|
|
|
|
|
|
dclone(sv) |
6660
|
|
|
|
|
|
SV * sv |
6661
|
|
|
|
|
|
CODE: |
6662
|
43018
|
|
|
|
|
RETVAL = dclone(aTHX_ sv); |
6663
|
|
|
|
|
|
OUTPUT: |
6664
|
|
|
|
|
|
RETVAL |
6665
|
|
|
|
|
|
|
6666
|
|
|
|
|
|
void |
6667
|
|
|
|
|
|
last_op_in_netorder() |
6668
|
|
|
|
|
|
ALIAS: |
6669
|
|
|
|
|
|
is_storing = ST_STORE |
6670
|
|
|
|
|
|
is_retrieving = ST_RETRIEVE |
6671
|
|
|
|
|
|
PREINIT: |
6672
|
|
|
|
|
|
bool result; |
6673
|
|
|
|
|
|
PPCODE: |
6674
|
18
|
|
|
|
|
if (ix) { |
6675
|
8
|
|
|
|
|
dSTCXT; |
6676
|
|
|
|
|
|
|
6677
|
8
|
|
|
|
|
result = cxt->entry && (cxt->optype & ix) ? TRUE : FALSE; |
6678
|
|
|
|
|
|
} else { |
6679
|
10
|
|
|
|
|
result = !!last_op_in_netorder(aTHX); |
6680
|
|
|
|
|
|
} |
6681
|
18
|
|
|
|
|
ST(0) = boolSV(result); |
6682
|
18
|
|
|
|
|
XSRETURN(1); |