line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
/* sv.c |
2
|
|
|
|
|
|
* |
3
|
|
|
|
|
|
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
4
|
|
|
|
|
|
* 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall |
5
|
|
|
|
|
|
* and others |
6
|
|
|
|
|
|
* |
7
|
|
|
|
|
|
* You may distribute under the terms of either the GNU General Public |
8
|
|
|
|
|
|
* License or the Artistic License, as specified in the README file. |
9
|
|
|
|
|
|
* |
10
|
|
|
|
|
|
*/ |
11
|
|
|
|
|
|
|
12
|
|
|
|
|
|
/* |
13
|
|
|
|
|
|
* 'I wonder what the Entish is for "yes" and "no",' he thought. |
14
|
|
|
|
|
|
* --Pippin |
15
|
|
|
|
|
|
* |
16
|
|
|
|
|
|
* [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"] |
17
|
|
|
|
|
|
*/ |
18
|
|
|
|
|
|
|
19
|
|
|
|
|
|
/* |
20
|
|
|
|
|
|
* |
21
|
|
|
|
|
|
* |
22
|
|
|
|
|
|
* This file contains the code that creates, manipulates and destroys |
23
|
|
|
|
|
|
* scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the |
24
|
|
|
|
|
|
* structure of an SV, so their creation and destruction is handled |
25
|
|
|
|
|
|
* here; higher-level functions are in av.c, hv.c, and so on. Opcode |
26
|
|
|
|
|
|
* level functions (eg. substr, split, join) for each of the types are |
27
|
|
|
|
|
|
* in the pp*.c files. |
28
|
|
|
|
|
|
*/ |
29
|
|
|
|
|
|
|
30
|
|
|
|
|
|
#include "EXTERN.h" |
31
|
|
|
|
|
|
#define PERL_IN_SV_C |
32
|
|
|
|
|
|
#include "perl.h" |
33
|
|
|
|
|
|
#include "regcomp.h" |
34
|
|
|
|
|
|
|
35
|
|
|
|
|
|
#ifndef HAS_C99 |
36
|
|
|
|
|
|
# if __STDC_VERSION__ >= 199901L && !defined(VMS) |
37
|
|
|
|
|
|
# define HAS_C99 1 |
38
|
|
|
|
|
|
# endif |
39
|
|
|
|
|
|
#endif |
40
|
|
|
|
|
|
#if HAS_C99 |
41
|
|
|
|
|
|
# include |
42
|
|
|
|
|
|
#endif |
43
|
|
|
|
|
|
|
44
|
|
|
|
|
|
#define FCALL *f |
45
|
|
|
|
|
|
|
46
|
|
|
|
|
|
#ifdef __Lynx__ |
47
|
|
|
|
|
|
/* Missing proto on LynxOS */ |
48
|
|
|
|
|
|
char *gconvert(double, int, int, char *); |
49
|
|
|
|
|
|
#endif |
50
|
|
|
|
|
|
|
51
|
|
|
|
|
|
#ifdef PERL_UTF8_CACHE_ASSERT |
52
|
|
|
|
|
|
/* if adding more checks watch out for the following tests: |
53
|
|
|
|
|
|
* t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t |
54
|
|
|
|
|
|
* lib/utf8.t lib/Unicode/Collate/t/index.t |
55
|
|
|
|
|
|
* --jhi |
56
|
|
|
|
|
|
*/ |
57
|
|
|
|
|
|
# define ASSERT_UTF8_CACHE(cache) \ |
58
|
|
|
|
|
|
STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ |
59
|
|
|
|
|
|
assert((cache)[2] <= (cache)[3]); \ |
60
|
|
|
|
|
|
assert((cache)[3] <= (cache)[1]);} \ |
61
|
|
|
|
|
|
} STMT_END |
62
|
|
|
|
|
|
#else |
63
|
|
|
|
|
|
# define ASSERT_UTF8_CACHE(cache) NOOP |
64
|
|
|
|
|
|
#endif |
65
|
|
|
|
|
|
|
66
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
67
|
|
|
|
|
|
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) |
68
|
|
|
|
|
|
#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next)) |
69
|
|
|
|
|
|
#endif |
70
|
|
|
|
|
|
|
71
|
|
|
|
|
|
/* ============================================================================ |
72
|
|
|
|
|
|
|
73
|
|
|
|
|
|
=head1 Allocation and deallocation of SVs. |
74
|
|
|
|
|
|
|
75
|
|
|
|
|
|
An SV (or AV, HV, etc.) is allocated in two parts: the head (struct |
76
|
|
|
|
|
|
sv, av, hv...) contains type and reference count information, and for |
77
|
|
|
|
|
|
many types, a pointer to the body (struct xrv, xpv, xpviv...), which |
78
|
|
|
|
|
|
contains fields specific to each type. Some types store all they need |
79
|
|
|
|
|
|
in the head, so don't have a body. |
80
|
|
|
|
|
|
|
81
|
|
|
|
|
|
In all but the most memory-paranoid configurations (ex: PURIFY), heads |
82
|
|
|
|
|
|
and bodies are allocated out of arenas, which by default are |
83
|
|
|
|
|
|
approximately 4K chunks of memory parcelled up into N heads or bodies. |
84
|
|
|
|
|
|
Sv-bodies are allocated by their sv-type, guaranteeing size |
85
|
|
|
|
|
|
consistency needed to allocate safely from arrays. |
86
|
|
|
|
|
|
|
87
|
|
|
|
|
|
For SV-heads, the first slot in each arena is reserved, and holds a |
88
|
|
|
|
|
|
link to the next arena, some flags, and a note of the number of slots. |
89
|
|
|
|
|
|
Snaked through each arena chain is a linked list of free items; when |
90
|
|
|
|
|
|
this becomes empty, an extra arena is allocated and divided up into N |
91
|
|
|
|
|
|
items which are threaded into the free list. |
92
|
|
|
|
|
|
|
93
|
|
|
|
|
|
SV-bodies are similar, but they use arena-sets by default, which |
94
|
|
|
|
|
|
separate the link and info from the arena itself, and reclaim the 1st |
95
|
|
|
|
|
|
slot in the arena. SV-bodies are further described later. |
96
|
|
|
|
|
|
|
97
|
|
|
|
|
|
The following global variables are associated with arenas: |
98
|
|
|
|
|
|
|
99
|
|
|
|
|
|
PL_sv_arenaroot pointer to list of SV arenas |
100
|
|
|
|
|
|
PL_sv_root pointer to list of free SV structures |
101
|
|
|
|
|
|
|
102
|
|
|
|
|
|
PL_body_arenas head of linked-list of body arenas |
103
|
|
|
|
|
|
PL_body_roots[] array of pointers to list of free bodies of svtype |
104
|
|
|
|
|
|
arrays are indexed by the svtype needed |
105
|
|
|
|
|
|
|
106
|
|
|
|
|
|
A few special SV heads are not allocated from an arena, but are |
107
|
|
|
|
|
|
instead directly created in the interpreter structure, eg PL_sv_undef. |
108
|
|
|
|
|
|
The size of arenas can be changed from the default by setting |
109
|
|
|
|
|
|
PERL_ARENA_SIZE appropriately at compile time. |
110
|
|
|
|
|
|
|
111
|
|
|
|
|
|
The SV arena serves the secondary purpose of allowing still-live SVs |
112
|
|
|
|
|
|
to be located and destroyed during final cleanup. |
113
|
|
|
|
|
|
|
114
|
|
|
|
|
|
At the lowest level, the macros new_SV() and del_SV() grab and free |
115
|
|
|
|
|
|
an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() |
116
|
|
|
|
|
|
to return the SV to the free list with error checking.) new_SV() calls |
117
|
|
|
|
|
|
more_sv() / sv_add_arena() to add an extra arena if the free list is empty. |
118
|
|
|
|
|
|
SVs in the free list have their SvTYPE field set to all ones. |
119
|
|
|
|
|
|
|
120
|
|
|
|
|
|
At the time of very final cleanup, sv_free_arenas() is called from |
121
|
|
|
|
|
|
perl_destruct() to physically free all the arenas allocated since the |
122
|
|
|
|
|
|
start of the interpreter. |
123
|
|
|
|
|
|
|
124
|
|
|
|
|
|
The function visit() scans the SV arenas list, and calls a specified |
125
|
|
|
|
|
|
function for each SV it finds which is still live - ie which has an SvTYPE |
126
|
|
|
|
|
|
other than all 1's, and a non-zero SvREFCNT. visit() is used by the |
127
|
|
|
|
|
|
following functions (specified as [function that calls visit()] / [function |
128
|
|
|
|
|
|
called by visit() for each SV]): |
129
|
|
|
|
|
|
|
130
|
|
|
|
|
|
sv_report_used() / do_report_used() |
131
|
|
|
|
|
|
dump all remaining SVs (debugging aid) |
132
|
|
|
|
|
|
|
133
|
|
|
|
|
|
sv_clean_objs() / do_clean_objs(),do_clean_named_objs(), |
134
|
|
|
|
|
|
do_clean_named_io_objs(),do_curse() |
135
|
|
|
|
|
|
Attempt to free all objects pointed to by RVs, |
136
|
|
|
|
|
|
try to do the same for all objects indir- |
137
|
|
|
|
|
|
ectly referenced by typeglobs too, and |
138
|
|
|
|
|
|
then do a final sweep, cursing any |
139
|
|
|
|
|
|
objects that remain. Called once from |
140
|
|
|
|
|
|
perl_destruct(), prior to calling sv_clean_all() |
141
|
|
|
|
|
|
below. |
142
|
|
|
|
|
|
|
143
|
|
|
|
|
|
sv_clean_all() / do_clean_all() |
144
|
|
|
|
|
|
SvREFCNT_dec(sv) each remaining SV, possibly |
145
|
|
|
|
|
|
triggering an sv_free(). It also sets the |
146
|
|
|
|
|
|
SVf_BREAK flag on the SV to indicate that the |
147
|
|
|
|
|
|
refcnt has been artificially lowered, and thus |
148
|
|
|
|
|
|
stopping sv_free() from giving spurious warnings |
149
|
|
|
|
|
|
about SVs which unexpectedly have a refcnt |
150
|
|
|
|
|
|
of zero. called repeatedly from perl_destruct() |
151
|
|
|
|
|
|
until there are no SVs left. |
152
|
|
|
|
|
|
|
153
|
|
|
|
|
|
=head2 Arena allocator API Summary |
154
|
|
|
|
|
|
|
155
|
|
|
|
|
|
Private API to rest of sv.c |
156
|
|
|
|
|
|
|
157
|
|
|
|
|
|
new_SV(), del_SV(), |
158
|
|
|
|
|
|
|
159
|
|
|
|
|
|
new_XPVNV(), del_XPVGV(), |
160
|
|
|
|
|
|
etc |
161
|
|
|
|
|
|
|
162
|
|
|
|
|
|
Public API: |
163
|
|
|
|
|
|
|
164
|
|
|
|
|
|
sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() |
165
|
|
|
|
|
|
|
166
|
|
|
|
|
|
=cut |
167
|
|
|
|
|
|
|
168
|
|
|
|
|
|
* ========================================================================= */ |
169
|
|
|
|
|
|
|
170
|
|
|
|
|
|
/* |
171
|
|
|
|
|
|
* "A time to plant, and a time to uproot what was planted..." |
172
|
|
|
|
|
|
*/ |
173
|
|
|
|
|
|
|
174
|
|
|
|
|
|
#ifdef PERL_MEM_LOG |
175
|
|
|
|
|
|
# define MEM_LOG_NEW_SV(sv, file, line, func) \ |
176
|
|
|
|
|
|
Perl_mem_log_new_sv(sv, file, line, func) |
177
|
|
|
|
|
|
# define MEM_LOG_DEL_SV(sv, file, line, func) \ |
178
|
|
|
|
|
|
Perl_mem_log_del_sv(sv, file, line, func) |
179
|
|
|
|
|
|
#else |
180
|
|
|
|
|
|
# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP |
181
|
|
|
|
|
|
# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP |
182
|
|
|
|
|
|
#endif |
183
|
|
|
|
|
|
|
184
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS |
185
|
|
|
|
|
|
# define FREE_SV_DEBUG_FILE(sv) STMT_START { \ |
186
|
|
|
|
|
|
if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ |
187
|
|
|
|
|
|
} STMT_END |
188
|
|
|
|
|
|
# define DEBUG_SV_SERIAL(sv) \ |
189
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ |
190
|
|
|
|
|
|
PTR2UV(sv), (long)(sv)->sv_debug_serial)) |
191
|
|
|
|
|
|
#else |
192
|
|
|
|
|
|
# define FREE_SV_DEBUG_FILE(sv) |
193
|
|
|
|
|
|
# define DEBUG_SV_SERIAL(sv) NOOP |
194
|
|
|
|
|
|
#endif |
195
|
|
|
|
|
|
|
196
|
|
|
|
|
|
#ifdef PERL_POISON |
197
|
|
|
|
|
|
# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) |
198
|
|
|
|
|
|
# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) |
199
|
|
|
|
|
|
/* Whilst I'd love to do this, it seems that things like to check on |
200
|
|
|
|
|
|
unreferenced scalars |
201
|
|
|
|
|
|
# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) |
202
|
|
|
|
|
|
*/ |
203
|
|
|
|
|
|
# define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ |
204
|
|
|
|
|
|
PoisonNew(&SvREFCNT(sv), 1, U32) |
205
|
|
|
|
|
|
#else |
206
|
|
|
|
|
|
# define SvARENA_CHAIN(sv) SvANY(sv) |
207
|
|
|
|
|
|
# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) |
208
|
|
|
|
|
|
# define POSION_SV_HEAD(sv) |
209
|
|
|
|
|
|
#endif |
210
|
|
|
|
|
|
|
211
|
|
|
|
|
|
/* Mark an SV head as unused, and add to free list. |
212
|
|
|
|
|
|
* |
213
|
|
|
|
|
|
* If SVf_BREAK is set, skip adding it to the free list, as this SV had |
214
|
|
|
|
|
|
* its refcount artificially decremented during global destruction, so |
215
|
|
|
|
|
|
* there may be dangling pointers to it. The last thing we want in that |
216
|
|
|
|
|
|
* case is for it to be reused. */ |
217
|
|
|
|
|
|
|
218
|
|
|
|
|
|
#define plant_SV(p) \ |
219
|
|
|
|
|
|
STMT_START { \ |
220
|
|
|
|
|
|
const U32 old_flags = SvFLAGS(p); \ |
221
|
|
|
|
|
|
MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ |
222
|
|
|
|
|
|
DEBUG_SV_SERIAL(p); \ |
223
|
|
|
|
|
|
FREE_SV_DEBUG_FILE(p); \ |
224
|
|
|
|
|
|
POSION_SV_HEAD(p); \ |
225
|
|
|
|
|
|
SvFLAGS(p) = SVTYPEMASK; \ |
226
|
|
|
|
|
|
if (!(old_flags & SVf_BREAK)) { \ |
227
|
|
|
|
|
|
SvARENA_CHAIN_SET(p, PL_sv_root); \ |
228
|
|
|
|
|
|
PL_sv_root = (p); \ |
229
|
|
|
|
|
|
} \ |
230
|
|
|
|
|
|
--PL_sv_count; \ |
231
|
|
|
|
|
|
} STMT_END |
232
|
|
|
|
|
|
|
233
|
|
|
|
|
|
#define uproot_SV(p) \ |
234
|
|
|
|
|
|
STMT_START { \ |
235
|
|
|
|
|
|
(p) = PL_sv_root; \ |
236
|
|
|
|
|
|
PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ |
237
|
|
|
|
|
|
++PL_sv_count; \ |
238
|
|
|
|
|
|
} STMT_END |
239
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
241
|
|
|
|
|
|
/* make some more SVs by adding another arena */ |
242
|
|
|
|
|
|
|
243
|
|
|
|
|
|
STATIC SV* |
244
|
4257580
|
|
|
|
|
S_more_sv(pTHX) |
245
|
|
|
|
|
|
{ |
246
|
|
|
|
|
|
dVAR; |
247
|
|
|
|
|
|
SV* sv; |
248
|
|
|
|
|
|
char *chunk; /* must use New here to match call to */ |
249
|
4257580
|
|
|
|
|
Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ |
250
|
|
|
|
|
|
sv_add_arena(chunk, PERL_ARENA_SIZE, 0); |
251
|
4257580
|
|
|
|
|
uproot_SV(sv); |
252
|
4257580
|
|
|
|
|
return sv; |
253
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
255
|
|
|
|
|
|
/* new_SV(): return a new, empty SV head */ |
256
|
|
|
|
|
|
|
257
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS |
258
|
|
|
|
|
|
/* provide a real function for a debugger to play with */ |
259
|
|
|
|
|
|
STATIC SV* |
260
|
|
|
|
|
|
S_new_SV(pTHX_ const char *file, int line, const char *func) |
261
|
|
|
|
|
|
{ |
262
|
|
|
|
|
|
SV* sv; |
263
|
|
|
|
|
|
|
264
|
|
|
|
|
|
if (PL_sv_root) |
265
|
|
|
|
|
|
uproot_SV(sv); |
266
|
|
|
|
|
|
else |
267
|
|
|
|
|
|
sv = S_more_sv(aTHX); |
268
|
|
|
|
|
|
SvANY(sv) = 0; |
269
|
|
|
|
|
|
SvREFCNT(sv) = 1; |
270
|
|
|
|
|
|
SvFLAGS(sv) = 0; |
271
|
|
|
|
|
|
sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; |
272
|
|
|
|
|
|
sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE |
273
|
|
|
|
|
|
? PL_parser->copline |
274
|
|
|
|
|
|
: PL_curcop |
275
|
|
|
|
|
|
? CopLINE(PL_curcop) |
276
|
|
|
|
|
|
: 0 |
277
|
|
|
|
|
|
); |
278
|
|
|
|
|
|
sv->sv_debug_inpad = 0; |
279
|
|
|
|
|
|
sv->sv_debug_parent = NULL; |
280
|
|
|
|
|
|
sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; |
281
|
|
|
|
|
|
|
282
|
|
|
|
|
|
sv->sv_debug_serial = PL_sv_serial++; |
283
|
|
|
|
|
|
|
284
|
|
|
|
|
|
MEM_LOG_NEW_SV(sv, file, line, func); |
285
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", |
286
|
|
|
|
|
|
PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); |
287
|
|
|
|
|
|
|
288
|
|
|
|
|
|
return sv; |
289
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) |
291
|
|
|
|
|
|
|
292
|
|
|
|
|
|
#else |
293
|
|
|
|
|
|
# define new_SV(p) \ |
294
|
|
|
|
|
|
STMT_START { \ |
295
|
|
|
|
|
|
if (PL_sv_root) \ |
296
|
|
|
|
|
|
uproot_SV(p); \ |
297
|
|
|
|
|
|
else \ |
298
|
|
|
|
|
|
(p) = S_more_sv(aTHX); \ |
299
|
|
|
|
|
|
SvANY(p) = 0; \ |
300
|
|
|
|
|
|
SvREFCNT(p) = 1; \ |
301
|
|
|
|
|
|
SvFLAGS(p) = 0; \ |
302
|
|
|
|
|
|
MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ |
303
|
|
|
|
|
|
} STMT_END |
304
|
|
|
|
|
|
#endif |
305
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
307
|
|
|
|
|
|
/* del_SV(): return an empty SV head to the free list */ |
308
|
|
|
|
|
|
|
309
|
|
|
|
|
|
#ifdef DEBUGGING |
310
|
|
|
|
|
|
|
311
|
|
|
|
|
|
#define del_SV(p) \ |
312
|
|
|
|
|
|
STMT_START { \ |
313
|
|
|
|
|
|
if (DEBUG_D_TEST) \ |
314
|
|
|
|
|
|
del_sv(p); \ |
315
|
|
|
|
|
|
else \ |
316
|
|
|
|
|
|
plant_SV(p); \ |
317
|
|
|
|
|
|
} STMT_END |
318
|
|
|
|
|
|
|
319
|
|
|
|
|
|
STATIC void |
320
|
|
|
|
|
|
S_del_sv(pTHX_ SV *p) |
321
|
|
|
|
|
|
{ |
322
|
|
|
|
|
|
dVAR; |
323
|
|
|
|
|
|
|
324
|
|
|
|
|
|
PERL_ARGS_ASSERT_DEL_SV; |
325
|
|
|
|
|
|
|
326
|
|
|
|
|
|
if (DEBUG_D_TEST) { |
327
|
|
|
|
|
|
SV* sva; |
328
|
|
|
|
|
|
bool ok = 0; |
329
|
|
|
|
|
|
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
330
|
|
|
|
|
|
const SV * const sv = sva + 1; |
331
|
|
|
|
|
|
const SV * const svend = &sva[SvREFCNT(sva)]; |
332
|
|
|
|
|
|
if (p >= sv && p < svend) { |
333
|
|
|
|
|
|
ok = 1; |
334
|
|
|
|
|
|
break; |
335
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
if (!ok) { |
338
|
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
339
|
|
|
|
|
|
"Attempt to free non-arena SV: 0x%"UVxf |
340
|
|
|
|
|
|
pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); |
341
|
|
|
|
|
|
return; |
342
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
plant_SV(p); |
345
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
347
|
|
|
|
|
|
#else /* ! DEBUGGING */ |
348
|
|
|
|
|
|
|
349
|
|
|
|
|
|
#define del_SV(p) plant_SV(p) |
350
|
|
|
|
|
|
|
351
|
|
|
|
|
|
#endif /* DEBUGGING */ |
352
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
354
|
|
|
|
|
|
/* |
355
|
|
|
|
|
|
=head1 SV Manipulation Functions |
356
|
|
|
|
|
|
|
357
|
|
|
|
|
|
=for apidoc sv_add_arena |
358
|
|
|
|
|
|
|
359
|
|
|
|
|
|
Given a chunk of memory, link it to the head of the list of arenas, |
360
|
|
|
|
|
|
and split it into a list of free SVs. |
361
|
|
|
|
|
|
|
362
|
|
|
|
|
|
=cut |
363
|
|
|
|
|
|
*/ |
364
|
|
|
|
|
|
|
365
|
|
|
|
|
|
static void |
366
|
|
|
|
|
|
S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) |
367
|
|
|
|
|
|
{ |
368
|
|
|
|
|
|
dVAR; |
369
|
|
|
|
|
|
SV *const sva = MUTABLE_SV(ptr); |
370
|
|
|
|
|
|
SV* sv; |
371
|
|
|
|
|
|
SV* svend; |
372
|
|
|
|
|
|
|
373
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_ADD_ARENA; |
374
|
|
|
|
|
|
|
375
|
|
|
|
|
|
/* The first SV in an arena isn't an SV. */ |
376
|
4257580
|
|
|
|
|
SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ |
377
|
4257580
|
|
|
|
|
SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ |
378
|
4257580
|
|
|
|
|
SvFLAGS(sva) = flags; /* FAKE if not to be freed */ |
379
|
|
|
|
|
|
|
380
|
4257580
|
|
|
|
|
PL_sv_arenaroot = sva; |
381
|
4257580
|
|
|
|
|
PL_sv_root = sva + 1; |
382
|
|
|
|
|
|
|
383
|
4257580
|
|
|
|
|
svend = &sva[SvREFCNT(sva) - 1]; |
384
|
4257580
|
|
|
|
|
sv = sva + 1; |
385
|
719531020
|
100
|
|
|
|
while (sv < svend) { |
386
|
715273440
|
|
|
|
|
SvARENA_CHAIN_SET(sv, (sv + 1)); |
387
|
|
|
|
|
|
#ifdef DEBUGGING |
388
|
|
|
|
|
|
SvREFCNT(sv) = 0; |
389
|
|
|
|
|
|
#endif |
390
|
|
|
|
|
|
/* Must always set typemask because it's always checked in on cleanup |
391
|
|
|
|
|
|
when the arenas are walked looking for objects. */ |
392
|
715273440
|
|
|
|
|
SvFLAGS(sv) = SVTYPEMASK; |
393
|
715273440
|
|
|
|
|
sv++; |
394
|
|
|
|
|
|
} |
395
|
4257580
|
|
|
|
|
SvARENA_CHAIN_SET(sv, 0); |
396
|
|
|
|
|
|
#ifdef DEBUGGING |
397
|
|
|
|
|
|
SvREFCNT(sv) = 0; |
398
|
|
|
|
|
|
#endif |
399
|
4257580
|
|
|
|
|
SvFLAGS(sv) = SVTYPEMASK; |
400
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
402
|
|
|
|
|
|
/* visit(): call the named function for each non-free SV in the arenas |
403
|
|
|
|
|
|
* whose flags field matches the flags/mask args. */ |
404
|
|
|
|
|
|
|
405
|
|
|
|
|
|
STATIC I32 |
406
|
97372
|
|
|
|
|
S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) |
407
|
|
|
|
|
|
{ |
408
|
|
|
|
|
|
dVAR; |
409
|
|
|
|
|
|
SV* sva; |
410
|
|
|
|
|
|
I32 visited = 0; |
411
|
|
|
|
|
|
|
412
|
|
|
|
|
|
PERL_ARGS_ASSERT_VISIT; |
413
|
|
|
|
|
|
|
414
|
17127050
|
100
|
|
|
|
for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
415
|
17029682
|
|
|
|
|
const SV * const svend = &sva[SvREFCNT(sva)]; |
416
|
|
|
|
|
|
SV* sv; |
417
|
2895045320
|
100
|
|
|
|
for (sv = sva + 1; sv < svend; ++sv) { |
418
|
2878015642
|
100
|
|
|
|
if (SvTYPE(sv) != (svtype)SVTYPEMASK |
419
|
1941832460
|
100
|
|
|
|
&& (sv->sv_flags & mask) == flags |
420
|
95168879
|
100
|
|
|
|
&& SvREFCNT(sv)) |
421
|
|
|
|
|
|
{ |
422
|
95168875
|
|
|
|
|
(FCALL)(aTHX_ sv); |
423
|
95168871
|
|
|
|
|
++visited; |
424
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
} |
427
|
97368
|
|
|
|
|
return visited; |
428
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
430
|
|
|
|
|
|
#ifdef DEBUGGING |
431
|
|
|
|
|
|
|
432
|
|
|
|
|
|
/* called by sv_report_used() for each live SV */ |
433
|
|
|
|
|
|
|
434
|
|
|
|
|
|
static void |
435
|
|
|
|
|
|
do_report_used(pTHX_ SV *const sv) |
436
|
|
|
|
|
|
{ |
437
|
|
|
|
|
|
if (SvTYPE(sv) != (svtype)SVTYPEMASK) { |
438
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "****\n"); |
439
|
|
|
|
|
|
sv_dump(sv); |
440
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
#endif |
443
|
|
|
|
|
|
|
444
|
|
|
|
|
|
/* |
445
|
|
|
|
|
|
=for apidoc sv_report_used |
446
|
|
|
|
|
|
|
447
|
|
|
|
|
|
Dump the contents of all SVs not yet freed (debugging aid). |
448
|
|
|
|
|
|
|
449
|
|
|
|
|
|
=cut |
450
|
|
|
|
|
|
*/ |
451
|
|
|
|
|
|
|
452
|
|
|
|
|
|
void |
453
|
0
|
|
|
|
|
Perl_sv_report_used(pTHX) |
454
|
|
|
|
|
|
{ |
455
|
|
|
|
|
|
#ifdef DEBUGGING |
456
|
|
|
|
|
|
visit(do_report_used, 0, 0); |
457
|
|
|
|
|
|
#else |
458
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
459
|
|
|
|
|
|
#endif |
460
|
0
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
462
|
|
|
|
|
|
/* called by sv_clean_objs() for each live SV */ |
463
|
|
|
|
|
|
|
464
|
|
|
|
|
|
static void |
465
|
39575099
|
|
|
|
|
do_clean_objs(pTHX_ SV *const ref) |
466
|
|
|
|
|
|
{ |
467
|
|
|
|
|
|
dVAR; |
468
|
|
|
|
|
|
assert (SvROK(ref)); |
469
|
|
|
|
|
|
{ |
470
|
39575099
|
|
|
|
|
SV * const target = SvRV(ref); |
471
|
39575099
|
100
|
|
|
|
if (SvOBJECT(target)) { |
472
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); |
473
|
1957680
|
100
|
|
|
|
if (SvWEAKREF(ref)) { |
474
|
2
|
|
|
|
|
sv_del_backref(target, ref); |
475
|
2
|
|
|
|
|
SvWEAKREF_off(ref); |
476
|
2
|
|
|
|
|
SvRV_set(ref, NULL); |
477
|
|
|
|
|
|
} else { |
478
|
1957678
|
|
|
|
|
SvROK_off(ref); |
479
|
1957678
|
|
|
|
|
SvRV_set(ref, NULL); |
480
|
1957678
|
|
|
|
|
SvREFCNT_dec_NN(target); |
481
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
} |
484
|
39575095
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
487
|
|
|
|
|
|
/* clear any slots in a GV which hold objects - except IO; |
488
|
|
|
|
|
|
* called by sv_clean_objs() for each live GV */ |
489
|
|
|
|
|
|
|
490
|
|
|
|
|
|
static void |
491
|
27766979
|
|
|
|
|
do_clean_named_objs(pTHX_ SV *const sv) |
492
|
|
|
|
|
|
{ |
493
|
|
|
|
|
|
dVAR; |
494
|
|
|
|
|
|
SV *obj; |
495
|
|
|
|
|
|
assert(SvTYPE(sv) == SVt_PVGV); |
496
|
|
|
|
|
|
assert(isGV_with_GP(sv)); |
497
|
27766979
|
50
|
|
|
|
if (!GvGP(sv)) |
498
|
27766979
|
|
|
|
|
return; |
499
|
|
|
|
|
|
|
500
|
|
|
|
|
|
/* freeing GP entries may indirectly free the current GV; |
501
|
|
|
|
|
|
* hold onto it while we mess with the GP slots */ |
502
|
|
|
|
|
|
SvREFCNT_inc(sv); |
503
|
|
|
|
|
|
|
504
|
27766979
|
100
|
|
|
|
if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { |
|
|
100
|
|
|
|
|
505
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, |
506
|
|
|
|
|
|
"Cleaning named glob SV object:\n "), sv_dump(obj))); |
507
|
330
|
|
|
|
|
GvSV(sv) = NULL; |
508
|
330
|
|
|
|
|
SvREFCNT_dec_NN(obj); |
509
|
|
|
|
|
|
} |
510
|
27766979
|
100
|
|
|
|
if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { |
|
|
100
|
|
|
|
|
511
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, |
512
|
|
|
|
|
|
"Cleaning named glob AV object:\n "), sv_dump(obj))); |
513
|
4
|
|
|
|
|
GvAV(sv) = NULL; |
514
|
4
|
|
|
|
|
SvREFCNT_dec_NN(obj); |
515
|
|
|
|
|
|
} |
516
|
27766979
|
100
|
|
|
|
if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { |
|
|
100
|
|
|
|
|
517
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, |
518
|
|
|
|
|
|
"Cleaning named glob HV object:\n "), sv_dump(obj))); |
519
|
64
|
|
|
|
|
GvHV(sv) = NULL; |
520
|
64
|
|
|
|
|
SvREFCNT_dec_NN(obj); |
521
|
|
|
|
|
|
} |
522
|
27766979
|
100
|
|
|
|
if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { |
|
|
100
|
|
|
|
|
523
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, |
524
|
|
|
|
|
|
"Cleaning named glob CV object:\n "), sv_dump(obj))); |
525
|
8
|
|
|
|
|
GvCV_set(sv, NULL); |
526
|
8
|
|
|
|
|
SvREFCNT_dec_NN(obj); |
527
|
|
|
|
|
|
} |
528
|
27766979
|
|
|
|
|
SvREFCNT_dec_NN(sv); /* undo the inc above */ |
529
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
531
|
|
|
|
|
|
/* clear any IO slots in a GV which hold objects (except stderr, defout); |
532
|
|
|
|
|
|
* called by sv_clean_objs() for each live GV */ |
533
|
|
|
|
|
|
|
534
|
|
|
|
|
|
static void |
535
|
27821727
|
|
|
|
|
do_clean_named_io_objs(pTHX_ SV *const sv) |
536
|
|
|
|
|
|
{ |
537
|
|
|
|
|
|
dVAR; |
538
|
|
|
|
|
|
SV *obj; |
539
|
|
|
|
|
|
assert(SvTYPE(sv) == SVt_PVGV); |
540
|
|
|
|
|
|
assert(isGV_with_GP(sv)); |
541
|
27821727
|
50
|
|
|
|
if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
542
|
27821727
|
|
|
|
|
return; |
543
|
|
|
|
|
|
|
544
|
|
|
|
|
|
SvREFCNT_inc(sv); |
545
|
27773283
|
50
|
|
|
|
if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
546
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, |
547
|
|
|
|
|
|
"Cleaning named glob IO object:\n "), sv_dump(obj))); |
548
|
270939
|
|
|
|
|
GvIOp(sv) = NULL; |
549
|
270939
|
|
|
|
|
SvREFCNT_dec_NN(obj); |
550
|
|
|
|
|
|
} |
551
|
27773283
|
|
|
|
|
SvREFCNT_dec_NN(sv); /* undo the inc above */ |
552
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
554
|
|
|
|
|
|
/* Void wrapper to pass to visit() */ |
555
|
|
|
|
|
|
static void |
556
|
53514
|
|
|
|
|
do_curse(pTHX_ SV * const sv) { |
557
|
53514
|
100
|
|
|
|
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
558
|
29310
|
50
|
|
|
|
|| (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
559
|
53514
|
|
|
|
|
return; |
560
|
9748
|
|
|
|
|
(void)curse(sv, 0); |
561
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
563
|
|
|
|
|
|
/* |
564
|
|
|
|
|
|
=for apidoc sv_clean_objs |
565
|
|
|
|
|
|
|
566
|
|
|
|
|
|
Attempt to destroy all objects not yet freed. |
567
|
|
|
|
|
|
|
568
|
|
|
|
|
|
=cut |
569
|
|
|
|
|
|
*/ |
570
|
|
|
|
|
|
|
571
|
|
|
|
|
|
void |
572
|
24346
|
|
|
|
|
Perl_sv_clean_objs(pTHX) |
573
|
|
|
|
|
|
{ |
574
|
|
|
|
|
|
dVAR; |
575
|
|
|
|
|
|
GV *olddef, *olderr; |
576
|
24346
|
|
|
|
|
PL_in_clean_objs = TRUE; |
577
|
24346
|
|
|
|
|
visit(do_clean_objs, SVf_ROK, SVf_ROK); |
578
|
|
|
|
|
|
/* Some barnacles may yet remain, clinging to typeglobs. |
579
|
|
|
|
|
|
* Run the non-IO destructors first: they may want to output |
580
|
|
|
|
|
|
* error messages, close files etc */ |
581
|
24342
|
|
|
|
|
visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); |
582
|
24342
|
|
|
|
|
visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); |
583
|
|
|
|
|
|
/* And if there are some very tenacious barnacles clinging to arrays, |
584
|
|
|
|
|
|
closures, or what have you.... */ |
585
|
24342
|
|
|
|
|
visit(do_curse, SVs_OBJECT, SVs_OBJECT); |
586
|
24342
|
|
|
|
|
olddef = PL_defoutgv; |
587
|
24342
|
|
|
|
|
PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ |
588
|
24342
|
100
|
|
|
|
if (olddef && isGV_with_GP(olddef)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
589
|
24224
|
|
|
|
|
do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); |
590
|
24342
|
|
|
|
|
olderr = PL_stderrgv; |
591
|
24342
|
|
|
|
|
PL_stderrgv = NULL; /* disable skip of PL_stderrgv */ |
592
|
24342
|
100
|
|
|
|
if (olderr && isGV_with_GP(olderr)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
593
|
24220
|
|
|
|
|
do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); |
594
|
24342
|
|
|
|
|
SvREFCNT_dec(olddef); |
595
|
24342
|
|
|
|
|
PL_in_clean_objs = FALSE; |
596
|
24342
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
598
|
|
|
|
|
|
/* called by sv_clean_all() for each live SV */ |
599
|
|
|
|
|
|
|
600
|
|
|
|
|
|
static void |
601
|
0
|
|
|
|
|
do_clean_all(pTHX_ SV *const sv) |
602
|
|
|
|
|
|
{ |
603
|
|
|
|
|
|
dVAR; |
604
|
0
|
0
|
|
|
|
if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { |
|
|
0
|
|
|
|
|
605
|
|
|
|
|
|
/* don't clean pid table and strtab */ |
606
|
0
|
|
|
|
|
return; |
607
|
|
|
|
|
|
} |
608
|
|
|
|
|
|
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); |
609
|
0
|
|
|
|
|
SvFLAGS(sv) |= SVf_BREAK; |
610
|
0
|
|
|
|
|
SvREFCNT_dec_NN(sv); |
611
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
613
|
|
|
|
|
|
/* |
614
|
|
|
|
|
|
=for apidoc sv_clean_all |
615
|
|
|
|
|
|
|
616
|
|
|
|
|
|
Decrement the refcnt of each remaining SV, possibly triggering a |
617
|
|
|
|
|
|
cleanup. This function may have to be called multiple times to free |
618
|
|
|
|
|
|
SVs which are in complex self-referential hierarchies. |
619
|
|
|
|
|
|
|
620
|
|
|
|
|
|
=cut |
621
|
|
|
|
|
|
*/ |
622
|
|
|
|
|
|
|
623
|
|
|
|
|
|
I32 |
624
|
0
|
|
|
|
|
Perl_sv_clean_all(pTHX) |
625
|
|
|
|
|
|
{ |
626
|
|
|
|
|
|
dVAR; |
627
|
|
|
|
|
|
I32 cleaned; |
628
|
0
|
|
|
|
|
PL_in_clean_all = TRUE; |
629
|
0
|
|
|
|
|
cleaned = visit(do_clean_all, 0,0); |
630
|
0
|
|
|
|
|
return cleaned; |
631
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
633
|
|
|
|
|
|
/* |
634
|
|
|
|
|
|
ARENASETS: a meta-arena implementation which separates arena-info |
635
|
|
|
|
|
|
into struct arena_set, which contains an array of struct |
636
|
|
|
|
|
|
arena_descs, each holding info for a single arena. By separating |
637
|
|
|
|
|
|
the meta-info from the arena, we recover the 1st slot, formerly |
638
|
|
|
|
|
|
borrowed for list management. The arena_set is about the size of an |
639
|
|
|
|
|
|
arena, avoiding the needless malloc overhead of a naive linked-list. |
640
|
|
|
|
|
|
|
641
|
|
|
|
|
|
The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused |
642
|
|
|
|
|
|
memory in the last arena-set (1/2 on average). In trade, we get |
643
|
|
|
|
|
|
back the 1st slot in each arena (ie 1.7% of a CV-arena, less for |
644
|
|
|
|
|
|
smaller types). The recovery of the wasted space allows use of |
645
|
|
|
|
|
|
small arenas for large, rare body types, by changing array* fields |
646
|
|
|
|
|
|
in body_details_by_type[] below. |
647
|
|
|
|
|
|
*/ |
648
|
|
|
|
|
|
struct arena_desc { |
649
|
|
|
|
|
|
char *arena; /* the raw storage, allocated aligned */ |
650
|
|
|
|
|
|
size_t size; /* its size ~4k typ */ |
651
|
|
|
|
|
|
svtype utype; /* bodytype stored in arena */ |
652
|
|
|
|
|
|
}; |
653
|
|
|
|
|
|
|
654
|
|
|
|
|
|
struct arena_set; |
655
|
|
|
|
|
|
|
656
|
|
|
|
|
|
/* Get the maximum number of elements in set[] such that struct arena_set |
657
|
|
|
|
|
|
will fit within PERL_ARENA_SIZE, which is probably just under 4K, and |
658
|
|
|
|
|
|
therefore likely to be 1 aligned memory page. */ |
659
|
|
|
|
|
|
|
660
|
|
|
|
|
|
#define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ |
661
|
|
|
|
|
|
- 2 * sizeof(int)) / sizeof (struct arena_desc)) |
662
|
|
|
|
|
|
|
663
|
|
|
|
|
|
struct arena_set { |
664
|
|
|
|
|
|
struct arena_set* next; |
665
|
|
|
|
|
|
unsigned int set_size; /* ie ARENAS_PER_SET */ |
666
|
|
|
|
|
|
unsigned int curr; /* index of next available arena-desc */ |
667
|
|
|
|
|
|
struct arena_desc set[ARENAS_PER_SET]; |
668
|
|
|
|
|
|
}; |
669
|
|
|
|
|
|
|
670
|
|
|
|
|
|
/* |
671
|
|
|
|
|
|
=for apidoc sv_free_arenas |
672
|
|
|
|
|
|
|
673
|
|
|
|
|
|
Deallocate the memory used by all arenas. Note that all the individual SV |
674
|
|
|
|
|
|
heads and bodies within the arenas must already have been freed. |
675
|
|
|
|
|
|
|
676
|
|
|
|
|
|
=cut |
677
|
|
|
|
|
|
*/ |
678
|
|
|
|
|
|
void |
679
|
0
|
|
|
|
|
Perl_sv_free_arenas(pTHX) |
680
|
|
|
|
|
|
{ |
681
|
|
|
|
|
|
dVAR; |
682
|
|
|
|
|
|
SV* sva; |
683
|
|
|
|
|
|
SV* svanext; |
684
|
|
|
|
|
|
unsigned int i; |
685
|
|
|
|
|
|
|
686
|
|
|
|
|
|
/* Free arenas here, but be careful about fake ones. (We assume |
687
|
|
|
|
|
|
contiguity of the fake ones with the corresponding real ones.) */ |
688
|
|
|
|
|
|
|
689
|
0
|
0
|
|
|
|
for (sva = PL_sv_arenaroot; sva; sva = svanext) { |
690
|
0
|
|
|
|
|
svanext = MUTABLE_SV(SvANY(sva)); |
691
|
0
|
0
|
|
|
|
while (svanext && SvFAKE(svanext)) |
|
|
0
|
|
|
|
|
692
|
0
|
|
|
|
|
svanext = MUTABLE_SV(SvANY(svanext)); |
693
|
|
|
|
|
|
|
694
|
0
|
0
|
|
|
|
if (!SvFAKE(sva)) |
695
|
0
|
|
|
|
|
Safefree(sva); |
696
|
|
|
|
|
|
} |
697
|
|
|
|
|
|
|
698
|
|
|
|
|
|
{ |
699
|
0
|
|
|
|
|
struct arena_set *aroot = (struct arena_set*) PL_body_arenas; |
700
|
|
|
|
|
|
|
701
|
0
|
0
|
|
|
|
while (aroot) { |
702
|
|
|
|
|
|
struct arena_set *current = aroot; |
703
|
0
|
|
|
|
|
i = aroot->curr; |
704
|
0
|
0
|
|
|
|
while (i--) { |
705
|
|
|
|
|
|
assert(aroot->set[i].arena); |
706
|
0
|
|
|
|
|
Safefree(aroot->set[i].arena); |
707
|
|
|
|
|
|
} |
708
|
0
|
|
|
|
|
aroot = aroot->next; |
709
|
0
|
|
|
|
|
Safefree(current); |
710
|
|
|
|
|
|
} |
711
|
|
|
|
|
|
} |
712
|
0
|
|
|
|
|
PL_body_arenas = 0; |
713
|
|
|
|
|
|
|
714
|
|
|
|
|
|
i = PERL_ARENA_ROOTS_SIZE; |
715
|
0
|
0
|
|
|
|
while (i--) |
716
|
0
|
|
|
|
|
PL_body_roots[i] = 0; |
717
|
|
|
|
|
|
|
718
|
0
|
|
|
|
|
PL_sv_arenaroot = 0; |
719
|
0
|
|
|
|
|
PL_sv_root = 0; |
720
|
0
|
|
|
|
|
} |
721
|
|
|
|
|
|
|
722
|
|
|
|
|
|
/* |
723
|
|
|
|
|
|
Here are mid-level routines that manage the allocation of bodies out |
724
|
|
|
|
|
|
of the various arenas. There are 5 kinds of arenas: |
725
|
|
|
|
|
|
|
726
|
|
|
|
|
|
1. SV-head arenas, which are discussed and handled above |
727
|
|
|
|
|
|
2. regular body arenas |
728
|
|
|
|
|
|
3. arenas for reduced-size bodies |
729
|
|
|
|
|
|
4. Hash-Entry arenas |
730
|
|
|
|
|
|
|
731
|
|
|
|
|
|
Arena types 2 & 3 are chained by body-type off an array of |
732
|
|
|
|
|
|
arena-root pointers, which is indexed by svtype. Some of the |
733
|
|
|
|
|
|
larger/less used body types are malloced singly, since a large |
734
|
|
|
|
|
|
unused block of them is wasteful. Also, several svtypes dont have |
735
|
|
|
|
|
|
bodies; the data fits into the sv-head itself. The arena-root |
736
|
|
|
|
|
|
pointer thus has a few unused root-pointers (which may be hijacked |
737
|
|
|
|
|
|
later for arena types 4,5) |
738
|
|
|
|
|
|
|
739
|
|
|
|
|
|
3 differs from 2 as an optimization; some body types have several |
740
|
|
|
|
|
|
unused fields in the front of the structure (which are kept in-place |
741
|
|
|
|
|
|
for consistency). These bodies can be allocated in smaller chunks, |
742
|
|
|
|
|
|
because the leading fields arent accessed. Pointers to such bodies |
743
|
|
|
|
|
|
are decremented to point at the unused 'ghost' memory, knowing that |
744
|
|
|
|
|
|
the pointers are used with offsets to the real memory. |
745
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
747
|
|
|
|
|
|
=head1 SV-Body Allocation |
748
|
|
|
|
|
|
|
749
|
|
|
|
|
|
Allocation of SV-bodies is similar to SV-heads, differing as follows; |
750
|
|
|
|
|
|
the allocation mechanism is used for many body types, so is somewhat |
751
|
|
|
|
|
|
more complicated, it uses arena-sets, and has no need for still-live |
752
|
|
|
|
|
|
SV detection. |
753
|
|
|
|
|
|
|
754
|
|
|
|
|
|
At the outermost level, (new|del)_X*V macros return bodies of the |
755
|
|
|
|
|
|
appropriate type. These macros call either (new|del)_body_type or |
756
|
|
|
|
|
|
(new|del)_body_allocated macro pairs, depending on specifics of the |
757
|
|
|
|
|
|
type. Most body types use the former pair, the latter pair is used to |
758
|
|
|
|
|
|
allocate body types with "ghost fields". |
759
|
|
|
|
|
|
|
760
|
|
|
|
|
|
"ghost fields" are fields that are unused in certain types, and |
761
|
|
|
|
|
|
consequently don't need to actually exist. They are declared because |
762
|
|
|
|
|
|
they're part of a "base type", which allows use of functions as |
763
|
|
|
|
|
|
methods. The simplest examples are AVs and HVs, 2 aggregate types |
764
|
|
|
|
|
|
which don't use the fields which support SCALAR semantics. |
765
|
|
|
|
|
|
|
766
|
|
|
|
|
|
For these types, the arenas are carved up into appropriately sized |
767
|
|
|
|
|
|
chunks, we thus avoid wasted memory for those unaccessed members. |
768
|
|
|
|
|
|
When bodies are allocated, we adjust the pointer back in memory by the |
769
|
|
|
|
|
|
size of the part not allocated, so it's as if we allocated the full |
770
|
|
|
|
|
|
structure. (But things will all go boom if you write to the part that |
771
|
|
|
|
|
|
is "not there", because you'll be overwriting the last members of the |
772
|
|
|
|
|
|
preceding structure in memory.) |
773
|
|
|
|
|
|
|
774
|
|
|
|
|
|
We calculate the correction using the STRUCT_OFFSET macro on the first |
775
|
|
|
|
|
|
member present. If the allocated structure is smaller (no initial NV |
776
|
|
|
|
|
|
actually allocated) then the net effect is to subtract the size of the NV |
777
|
|
|
|
|
|
from the pointer, to return a new pointer as if an initial NV were actually |
778
|
|
|
|
|
|
allocated. (We were using structures named *_allocated for this, but |
779
|
|
|
|
|
|
this turned out to be a subtle bug, because a structure without an NV |
780
|
|
|
|
|
|
could have a lower alignment constraint, but the compiler is allowed to |
781
|
|
|
|
|
|
optimised accesses based on the alignment constraint of the actual pointer |
782
|
|
|
|
|
|
to the full structure, for example, using a single 64 bit load instruction |
783
|
|
|
|
|
|
because it "knows" that two adjacent 32 bit members will be 8-byte aligned.) |
784
|
|
|
|
|
|
|
785
|
|
|
|
|
|
This is the same trick as was used for NV and IV bodies. Ironically it |
786
|
|
|
|
|
|
doesn't need to be used for NV bodies any more, because NV is now at |
787
|
|
|
|
|
|
the start of the structure. IV bodies don't need it either, because |
788
|
|
|
|
|
|
they are no longer allocated. |
789
|
|
|
|
|
|
|
790
|
|
|
|
|
|
In turn, the new_body_* allocators call S_new_body(), which invokes |
791
|
|
|
|
|
|
new_body_inline macro, which takes a lock, and takes a body off the |
792
|
|
|
|
|
|
linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if |
793
|
|
|
|
|
|
necessary to refresh an empty list. Then the lock is released, and |
794
|
|
|
|
|
|
the body is returned. |
795
|
|
|
|
|
|
|
796
|
|
|
|
|
|
Perl_more_bodies allocates a new arena, and carves it up into an array of N |
797
|
|
|
|
|
|
bodies, which it strings into a linked list. It looks up arena-size |
798
|
|
|
|
|
|
and body-size from the body_details table described below, thus |
799
|
|
|
|
|
|
supporting the multiple body-types. |
800
|
|
|
|
|
|
|
801
|
|
|
|
|
|
If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and |
802
|
|
|
|
|
|
the (new|del)_X*V macros are mapped directly to malloc/free. |
803
|
|
|
|
|
|
|
804
|
|
|
|
|
|
For each sv-type, struct body_details bodies_by_type[] carries |
805
|
|
|
|
|
|
parameters which control these aspects of SV handling: |
806
|
|
|
|
|
|
|
807
|
|
|
|
|
|
Arena_size determines whether arenas are used for this body type, and if |
808
|
|
|
|
|
|
so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to |
809
|
|
|
|
|
|
zero, forcing individual mallocs and frees. |
810
|
|
|
|
|
|
|
811
|
|
|
|
|
|
Body_size determines how big a body is, and therefore how many fit into |
812
|
|
|
|
|
|
each arena. Offset carries the body-pointer adjustment needed for |
813
|
|
|
|
|
|
"ghost fields", and is used in *_allocated macros. |
814
|
|
|
|
|
|
|
815
|
|
|
|
|
|
But its main purpose is to parameterize info needed in |
816
|
|
|
|
|
|
Perl_sv_upgrade(). The info here dramatically simplifies the function |
817
|
|
|
|
|
|
vs the implementation in 5.8.8, making it table-driven. All fields |
818
|
|
|
|
|
|
are used for this, except for arena_size. |
819
|
|
|
|
|
|
|
820
|
|
|
|
|
|
For the sv-types that have no bodies, arenas are not used, so those |
821
|
|
|
|
|
|
PL_body_roots[sv_type] are unused, and can be overloaded. In |
822
|
|
|
|
|
|
something of a special case, SVt_NULL is borrowed for HE arenas; |
823
|
|
|
|
|
|
PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the |
824
|
|
|
|
|
|
bodies_by_type[SVt_NULL] slot is not used, as the table is not |
825
|
|
|
|
|
|
available in hv.c. |
826
|
|
|
|
|
|
|
827
|
|
|
|
|
|
*/ |
828
|
|
|
|
|
|
|
829
|
|
|
|
|
|
struct body_details { |
830
|
|
|
|
|
|
U8 body_size; /* Size to allocate */ |
831
|
|
|
|
|
|
U8 copy; /* Size of structure to copy (may be shorter) */ |
832
|
|
|
|
|
|
U8 offset; |
833
|
|
|
|
|
|
unsigned int type : 4; /* We have space for a sanity check. */ |
834
|
|
|
|
|
|
unsigned int cant_upgrade : 1; /* Cannot upgrade this type */ |
835
|
|
|
|
|
|
unsigned int zero_nv : 1; /* zero the NV when upgrading from this */ |
836
|
|
|
|
|
|
unsigned int arena : 1; /* Allocated from an arena */ |
837
|
|
|
|
|
|
size_t arena_size; /* Size of arena to allocate */ |
838
|
|
|
|
|
|
}; |
839
|
|
|
|
|
|
|
840
|
|
|
|
|
|
#define HADNV FALSE |
841
|
|
|
|
|
|
#define NONV TRUE |
842
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
844
|
|
|
|
|
|
#ifdef PURIFY |
845
|
|
|
|
|
|
/* With -DPURFIY we allocate everything directly, and don't use arenas. |
846
|
|
|
|
|
|
This seems a rather elegant way to simplify some of the code below. */ |
847
|
|
|
|
|
|
#define HASARENA FALSE |
848
|
|
|
|
|
|
#else |
849
|
|
|
|
|
|
#define HASARENA TRUE |
850
|
|
|
|
|
|
#endif |
851
|
|
|
|
|
|
#define NOARENA FALSE |
852
|
|
|
|
|
|
|
853
|
|
|
|
|
|
/* Size the arenas to exactly fit a given number of bodies. A count |
854
|
|
|
|
|
|
of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, |
855
|
|
|
|
|
|
simplifying the default. If count > 0, the arena is sized to fit |
856
|
|
|
|
|
|
only that many bodies, allowing arenas to be used for large, rare |
857
|
|
|
|
|
|
bodies (XPVFM, XPVIO) without undue waste. The arena size is |
858
|
|
|
|
|
|
limited by PERL_ARENA_SIZE, so we can safely oversize the |
859
|
|
|
|
|
|
declarations. |
860
|
|
|
|
|
|
*/ |
861
|
|
|
|
|
|
#define FIT_ARENA0(body_size) \ |
862
|
|
|
|
|
|
((size_t)(PERL_ARENA_SIZE / body_size) * body_size) |
863
|
|
|
|
|
|
#define FIT_ARENAn(count,body_size) \ |
864
|
|
|
|
|
|
( count * body_size <= PERL_ARENA_SIZE) \ |
865
|
|
|
|
|
|
? count * body_size \ |
866
|
|
|
|
|
|
: FIT_ARENA0 (body_size) |
867
|
|
|
|
|
|
#define FIT_ARENA(count,body_size) \ |
868
|
|
|
|
|
|
count \ |
869
|
|
|
|
|
|
? FIT_ARENAn (count, body_size) \ |
870
|
|
|
|
|
|
: FIT_ARENA0 (body_size) |
871
|
|
|
|
|
|
|
872
|
|
|
|
|
|
/* Calculate the length to copy. Specifically work out the length less any |
873
|
|
|
|
|
|
final padding the compiler needed to add. See the comment in sv_upgrade |
874
|
|
|
|
|
|
for why copying the padding proved to be a bug. */ |
875
|
|
|
|
|
|
|
876
|
|
|
|
|
|
#define copy_length(type, last_member) \ |
877
|
|
|
|
|
|
STRUCT_OFFSET(type, last_member) \ |
878
|
|
|
|
|
|
+ sizeof (((type*)SvANY((const SV *)0))->last_member) |
879
|
|
|
|
|
|
|
880
|
|
|
|
|
|
static const struct body_details bodies_by_type[] = { |
881
|
|
|
|
|
|
/* HEs use this offset for their arena. */ |
882
|
|
|
|
|
|
{ 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, |
883
|
|
|
|
|
|
|
884
|
|
|
|
|
|
/* IVs are in the head, so the allocation size is 0. */ |
885
|
|
|
|
|
|
{ 0, |
886
|
|
|
|
|
|
sizeof(IV), /* This is used to copy out the IV body. */ |
887
|
|
|
|
|
|
STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, |
888
|
|
|
|
|
|
NOARENA /* IVS don't need an arena */, 0 |
889
|
|
|
|
|
|
}, |
890
|
|
|
|
|
|
|
891
|
|
|
|
|
|
{ sizeof(NV), sizeof(NV), |
892
|
|
|
|
|
|
STRUCT_OFFSET(XPVNV, xnv_u), |
893
|
|
|
|
|
|
SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, |
894
|
|
|
|
|
|
|
895
|
|
|
|
|
|
{ sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), |
896
|
|
|
|
|
|
copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), |
897
|
|
|
|
|
|
+ STRUCT_OFFSET(XPV, xpv_cur), |
898
|
|
|
|
|
|
SVt_PV, FALSE, NONV, HASARENA, |
899
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, |
900
|
|
|
|
|
|
|
901
|
|
|
|
|
|
{ sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), |
902
|
|
|
|
|
|
copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), |
903
|
|
|
|
|
|
+ STRUCT_OFFSET(XPV, xpv_cur), |
904
|
|
|
|
|
|
SVt_INVLIST, TRUE, NONV, HASARENA, |
905
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, |
906
|
|
|
|
|
|
|
907
|
|
|
|
|
|
{ sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), |
908
|
|
|
|
|
|
copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), |
909
|
|
|
|
|
|
+ STRUCT_OFFSET(XPV, xpv_cur), |
910
|
|
|
|
|
|
SVt_PVIV, FALSE, NONV, HASARENA, |
911
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, |
912
|
|
|
|
|
|
|
913
|
|
|
|
|
|
{ sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), |
914
|
|
|
|
|
|
copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), |
915
|
|
|
|
|
|
+ STRUCT_OFFSET(XPV, xpv_cur), |
916
|
|
|
|
|
|
SVt_PVNV, FALSE, HADNV, HASARENA, |
917
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, |
918
|
|
|
|
|
|
|
919
|
|
|
|
|
|
{ sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, |
920
|
|
|
|
|
|
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, |
921
|
|
|
|
|
|
|
922
|
|
|
|
|
|
{ sizeof(regexp), |
923
|
|
|
|
|
|
sizeof(regexp), |
924
|
|
|
|
|
|
0, |
925
|
|
|
|
|
|
SVt_REGEXP, TRUE, NONV, HASARENA, |
926
|
|
|
|
|
|
FIT_ARENA(0, sizeof(regexp)) |
927
|
|
|
|
|
|
}, |
928
|
|
|
|
|
|
|
929
|
|
|
|
|
|
{ sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, |
930
|
|
|
|
|
|
HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, |
931
|
|
|
|
|
|
|
932
|
|
|
|
|
|
{ sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, |
933
|
|
|
|
|
|
HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, |
934
|
|
|
|
|
|
|
935
|
|
|
|
|
|
{ sizeof(XPVAV), |
936
|
|
|
|
|
|
copy_length(XPVAV, xav_alloc), |
937
|
|
|
|
|
|
0, |
938
|
|
|
|
|
|
SVt_PVAV, TRUE, NONV, HASARENA, |
939
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XPVAV)) }, |
940
|
|
|
|
|
|
|
941
|
|
|
|
|
|
{ sizeof(XPVHV), |
942
|
|
|
|
|
|
copy_length(XPVHV, xhv_max), |
943
|
|
|
|
|
|
0, |
944
|
|
|
|
|
|
SVt_PVHV, TRUE, NONV, HASARENA, |
945
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XPVHV)) }, |
946
|
|
|
|
|
|
|
947
|
|
|
|
|
|
{ sizeof(XPVCV), |
948
|
|
|
|
|
|
sizeof(XPVCV), |
949
|
|
|
|
|
|
0, |
950
|
|
|
|
|
|
SVt_PVCV, TRUE, NONV, HASARENA, |
951
|
|
|
|
|
|
FIT_ARENA(0, sizeof(XPVCV)) }, |
952
|
|
|
|
|
|
|
953
|
|
|
|
|
|
{ sizeof(XPVFM), |
954
|
|
|
|
|
|
sizeof(XPVFM), |
955
|
|
|
|
|
|
0, |
956
|
|
|
|
|
|
SVt_PVFM, TRUE, NONV, NOARENA, |
957
|
|
|
|
|
|
FIT_ARENA(20, sizeof(XPVFM)) }, |
958
|
|
|
|
|
|
|
959
|
|
|
|
|
|
{ sizeof(XPVIO), |
960
|
|
|
|
|
|
sizeof(XPVIO), |
961
|
|
|
|
|
|
0, |
962
|
|
|
|
|
|
SVt_PVIO, TRUE, NONV, HASARENA, |
963
|
|
|
|
|
|
FIT_ARENA(24, sizeof(XPVIO)) }, |
964
|
|
|
|
|
|
}; |
965
|
|
|
|
|
|
|
966
|
|
|
|
|
|
#define new_body_allocated(sv_type) \ |
967
|
|
|
|
|
|
(void *)((char *)S_new_body(aTHX_ sv_type) \ |
968
|
|
|
|
|
|
- bodies_by_type[sv_type].offset) |
969
|
|
|
|
|
|
|
970
|
|
|
|
|
|
/* return a thing to the free list */ |
971
|
|
|
|
|
|
|
972
|
|
|
|
|
|
#define del_body(thing, root) \ |
973
|
|
|
|
|
|
STMT_START { \ |
974
|
|
|
|
|
|
void ** const thing_copy = (void **)thing; \ |
975
|
|
|
|
|
|
*thing_copy = *root; \ |
976
|
|
|
|
|
|
*root = (void*)thing_copy; \ |
977
|
|
|
|
|
|
} STMT_END |
978
|
|
|
|
|
|
|
979
|
|
|
|
|
|
#ifdef PURIFY |
980
|
|
|
|
|
|
|
981
|
|
|
|
|
|
#define new_XNV() safemalloc(sizeof(XPVNV)) |
982
|
|
|
|
|
|
#define new_XPVNV() safemalloc(sizeof(XPVNV)) |
983
|
|
|
|
|
|
#define new_XPVMG() safemalloc(sizeof(XPVMG)) |
984
|
|
|
|
|
|
|
985
|
|
|
|
|
|
#define del_XPVGV(p) safefree(p) |
986
|
|
|
|
|
|
|
987
|
|
|
|
|
|
#else /* !PURIFY */ |
988
|
|
|
|
|
|
|
989
|
|
|
|
|
|
#define new_XNV() new_body_allocated(SVt_NV) |
990
|
|
|
|
|
|
#define new_XPVNV() new_body_allocated(SVt_PVNV) |
991
|
|
|
|
|
|
#define new_XPVMG() new_body_allocated(SVt_PVMG) |
992
|
|
|
|
|
|
|
993
|
|
|
|
|
|
#define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \ |
994
|
|
|
|
|
|
&PL_body_roots[SVt_PVGV]) |
995
|
|
|
|
|
|
|
996
|
|
|
|
|
|
#endif /* PURIFY */ |
997
|
|
|
|
|
|
|
998
|
|
|
|
|
|
/* no arena for you! */ |
999
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
#define new_NOARENA(details) \ |
1001
|
|
|
|
|
|
safemalloc((details)->body_size + (details)->offset) |
1002
|
|
|
|
|
|
#define new_NOARENAZ(details) \ |
1003
|
|
|
|
|
|
safecalloc((details)->body_size + (details)->offset, 1) |
1004
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
void * |
1006
|
4609978
|
|
|
|
|
Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, |
1007
|
|
|
|
|
|
const size_t arena_size) |
1008
|
|
|
|
|
|
{ |
1009
|
|
|
|
|
|
dVAR; |
1010
|
4609978
|
|
|
|
|
void ** const root = &PL_body_roots[sv_type]; |
1011
|
|
|
|
|
|
struct arena_desc *adesc; |
1012
|
4609978
|
|
|
|
|
struct arena_set *aroot = (struct arena_set *) PL_body_arenas; |
1013
|
|
|
|
|
|
unsigned int curr; |
1014
|
|
|
|
|
|
char *start; |
1015
|
|
|
|
|
|
const char *end; |
1016
|
|
|
|
|
|
const size_t good_arena_size = Perl_malloc_good_size(arena_size); |
1017
|
|
|
|
|
|
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) |
1018
|
|
|
|
|
|
static bool done_sanity_check; |
1019
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
/* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global |
1021
|
|
|
|
|
|
* variables like done_sanity_check. */ |
1022
|
|
|
|
|
|
if (!done_sanity_check) { |
1023
|
|
|
|
|
|
unsigned int i = SVt_LAST; |
1024
|
|
|
|
|
|
|
1025
|
|
|
|
|
|
done_sanity_check = TRUE; |
1026
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
while (i--) |
1028
|
|
|
|
|
|
assert (bodies_by_type[i].type == i); |
1029
|
|
|
|
|
|
} |
1030
|
|
|
|
|
|
#endif |
1031
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
assert(arena_size); |
1033
|
|
|
|
|
|
|
1034
|
|
|
|
|
|
/* may need new arena-set to hold new arena */ |
1035
|
4609978
|
100
|
|
|
|
if (!aroot || aroot->curr >= aroot->set_size) { |
|
|
100
|
|
|
|
|
1036
|
|
|
|
|
|
struct arena_set *newroot; |
1037
|
45172
|
|
|
|
|
Newxz(newroot, 1, struct arena_set); |
1038
|
45172
|
|
|
|
|
newroot->set_size = ARENAS_PER_SET; |
1039
|
45172
|
|
|
|
|
newroot->next = aroot; |
1040
|
|
|
|
|
|
aroot = newroot; |
1041
|
45172
|
|
|
|
|
PL_body_arenas = (void *) newroot; |
1042
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); |
1043
|
|
|
|
|
|
} |
1044
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
/* ok, now have arena-set with at least 1 empty/available arena-desc */ |
1046
|
4609978
|
|
|
|
|
curr = aroot->curr++; |
1047
|
4609978
|
|
|
|
|
adesc = &(aroot->set[curr]); |
1048
|
|
|
|
|
|
assert(!adesc->arena); |
1049
|
|
|
|
|
|
|
1050
|
4609978
|
|
|
|
|
Newx(adesc->arena, good_arena_size, char); |
1051
|
4609978
|
|
|
|
|
adesc->size = good_arena_size; |
1052
|
4609978
|
|
|
|
|
adesc->utype = sv_type; |
1053
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", |
1054
|
|
|
|
|
|
curr, (void*)adesc->arena, (UV)good_arena_size)); |
1055
|
|
|
|
|
|
|
1056
|
4609978
|
|
|
|
|
start = (char *) adesc->arena; |
1057
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
/* Get the address of the byte after the end of the last body we can fit. |
1059
|
|
|
|
|
|
Remember, this is integer division: */ |
1060
|
4609978
|
|
|
|
|
end = start + good_arena_size / body_size * body_size; |
1061
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
/* computed count doesn't reflect the 1st slot reservation */ |
1063
|
|
|
|
|
|
#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) |
1064
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, |
1065
|
|
|
|
|
|
"arena %p end %p arena-size %d (from %d) type %d " |
1066
|
|
|
|
|
|
"size %d ct %d\n", |
1067
|
|
|
|
|
|
(void*)start, (void*)end, (int)good_arena_size, |
1068
|
|
|
|
|
|
(int)arena_size, sv_type, (int)body_size, |
1069
|
|
|
|
|
|
(int)good_arena_size / (int)body_size)); |
1070
|
|
|
|
|
|
#else |
1071
|
|
|
|
|
|
DEBUG_m(PerlIO_printf(Perl_debug_log, |
1072
|
|
|
|
|
|
"arena %p end %p arena-size %d type %d size %d ct %d\n", |
1073
|
|
|
|
|
|
(void*)start, (void*)end, |
1074
|
|
|
|
|
|
(int)arena_size, sv_type, (int)body_size, |
1075
|
|
|
|
|
|
(int)good_arena_size / (int)body_size)); |
1076
|
|
|
|
|
|
#endif |
1077
|
4609978
|
|
|
|
|
*root = (void *)start; |
1078
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
while (1) { |
1080
|
|
|
|
|
|
/* Where the next body would start: */ |
1081
|
590962958
|
|
|
|
|
char * const next = start + body_size; |
1082
|
|
|
|
|
|
|
1083
|
590962958
|
100
|
|
|
|
if (next >= end) { |
1084
|
|
|
|
|
|
/* This is the last body: */ |
1085
|
|
|
|
|
|
assert(next == end); |
1086
|
|
|
|
|
|
|
1087
|
4609978
|
|
|
|
|
*(void **)start = 0; |
1088
|
4609978
|
|
|
|
|
return *root; |
1089
|
|
|
|
|
|
} |
1090
|
|
|
|
|
|
|
1091
|
586352980
|
|
|
|
|
*(void**) start = (void *)next; |
1092
|
|
|
|
|
|
start = next; |
1093
|
586352980
|
|
|
|
|
} |
1094
|
|
|
|
|
|
} |
1095
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
/* grab a new thing from the free list, allocating more if necessary. |
1097
|
|
|
|
|
|
The inline version is used for speed in hot routines, and the |
1098
|
|
|
|
|
|
function using it serves the rest (unless PURIFY). |
1099
|
|
|
|
|
|
*/ |
1100
|
|
|
|
|
|
#define new_body_inline(xpv, sv_type) \ |
1101
|
|
|
|
|
|
STMT_START { \ |
1102
|
|
|
|
|
|
void ** const r3wt = &PL_body_roots[sv_type]; \ |
1103
|
|
|
|
|
|
xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ |
1104
|
|
|
|
|
|
? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ |
1105
|
|
|
|
|
|
bodies_by_type[sv_type].body_size,\ |
1106
|
|
|
|
|
|
bodies_by_type[sv_type].arena_size)); \ |
1107
|
|
|
|
|
|
*(r3wt) = *(void**)(xpv); \ |
1108
|
|
|
|
|
|
} STMT_END |
1109
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
#ifndef PURIFY |
1111
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
STATIC void * |
1113
|
35916050
|
|
|
|
|
S_new_body(pTHX_ const svtype sv_type) |
1114
|
|
|
|
|
|
{ |
1115
|
|
|
|
|
|
dVAR; |
1116
|
|
|
|
|
|
void *xpv; |
1117
|
35916050
|
100
|
|
|
|
new_body_inline(xpv, sv_type); |
1118
|
35916050
|
|
|
|
|
return xpv; |
1119
|
|
|
|
|
|
} |
1120
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
#endif |
1122
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
static const struct body_details fake_rv = |
1124
|
|
|
|
|
|
{ 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; |
1125
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
/* |
1127
|
|
|
|
|
|
=for apidoc sv_upgrade |
1128
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
Upgrade an SV to a more complex form. Generally adds a new body type to the |
1130
|
|
|
|
|
|
SV, then copies across as much information as possible from the old body. |
1131
|
|
|
|
|
|
It croaks if the SV is already in a more complex form than requested. You |
1132
|
|
|
|
|
|
generally want to use the C macro wrapper, which checks the type |
1133
|
|
|
|
|
|
before calling C, and hence does not croak. See also |
1134
|
|
|
|
|
|
C. |
1135
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
=cut |
1137
|
|
|
|
|
|
*/ |
1138
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
void |
1140
|
4246335395
|
|
|
|
|
Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) |
1141
|
|
|
|
|
|
{ |
1142
|
|
|
|
|
|
dVAR; |
1143
|
|
|
|
|
|
void* old_body; |
1144
|
|
|
|
|
|
void* new_body; |
1145
|
4246335395
|
|
|
|
|
const svtype old_type = SvTYPE(sv); |
1146
|
|
|
|
|
|
const struct body_details *new_type_details; |
1147
|
4246335395
|
|
|
|
|
const struct body_details *old_type_details |
1148
|
4246335395
|
|
|
|
|
= bodies_by_type + old_type; |
1149
|
|
|
|
|
|
SV *referant = NULL; |
1150
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UPGRADE; |
1152
|
|
|
|
|
|
|
1153
|
4246335395
|
100
|
|
|
|
if (old_type == new_type) |
1154
|
|
|
|
|
|
return; |
1155
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
/* This clause was purposefully added ahead of the early return above to |
1157
|
|
|
|
|
|
the shared string hackery for (sort {$a <=> $b} keys %hash), with the |
1158
|
|
|
|
|
|
inference by Nick I-S that it would fix other troublesome cases. See |
1159
|
|
|
|
|
|
changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent) |
1160
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
Given that shared hash key scalars are no longer PVIV, but PV, there is |
1162
|
|
|
|
|
|
no longer need to unshare so as to free up the IVX slot for its proper |
1163
|
|
|
|
|
|
purpose. So it's safe to move the early return earlier. */ |
1164
|
|
|
|
|
|
|
1165
|
4243940283
|
100
|
|
|
|
if (new_type > SVt_PVMG && SvIsCOW(sv)) { |
|
|
50
|
|
|
|
|
1166
|
0
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
1167
|
|
|
|
|
|
} |
1168
|
|
|
|
|
|
|
1169
|
4243940283
|
|
|
|
|
old_body = SvANY(sv); |
1170
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
/* Copying structures onto other structures that have been neatly zeroed |
1172
|
|
|
|
|
|
has a subtle gotcha. Consider XPVMG |
1173
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
+------+------+------+------+------+-------+-------+ |
1175
|
|
|
|
|
|
| NV | CUR | LEN | IV | MAGIC | STASH | |
1176
|
|
|
|
|
|
+------+------+------+------+------+-------+-------+ |
1177
|
|
|
|
|
|
0 4 8 12 16 20 24 28 |
1178
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
where NVs are aligned to 8 bytes, so that sizeof that structure is |
1180
|
|
|
|
|
|
actually 32 bytes long, with 4 bytes of padding at the end: |
1181
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
+------+------+------+------+------+-------+-------+------+ |
1183
|
|
|
|
|
|
| NV | CUR | LEN | IV | MAGIC | STASH | ??? | |
1184
|
|
|
|
|
|
+------+------+------+------+------+-------+-------+------+ |
1185
|
|
|
|
|
|
0 4 8 12 16 20 24 28 32 |
1186
|
|
|
|
|
|
|
1187
|
|
|
|
|
|
so what happens if you allocate memory for this structure: |
1188
|
|
|
|
|
|
|
1189
|
|
|
|
|
|
+------+------+------+------+------+-------+-------+------+------+... |
1190
|
|
|
|
|
|
| NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | |
1191
|
|
|
|
|
|
+------+------+------+------+------+-------+-------+------+------+... |
1192
|
|
|
|
|
|
0 4 8 12 16 20 24 28 32 36 |
1193
|
|
|
|
|
|
|
1194
|
|
|
|
|
|
zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you |
1195
|
|
|
|
|
|
expect, because you copy the area marked ??? onto GP. Now, ??? may have |
1196
|
|
|
|
|
|
started out as zero once, but it's quite possible that it isn't. So now, |
1197
|
|
|
|
|
|
rather than a nicely zeroed GP, you have it pointing somewhere random. |
1198
|
|
|
|
|
|
Bugs ensue. |
1199
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
(In fact, GP ends up pointing at a previous GP structure, because the |
1201
|
|
|
|
|
|
principle cause of the padding in XPVMG getting garbage is a copy of |
1202
|
|
|
|
|
|
sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now |
1203
|
|
|
|
|
|
this happens to be moot because XPVGV has been re-ordered, with GP |
1204
|
|
|
|
|
|
no longer after STASH) |
1205
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
So we are careful and work out the size of used parts of all the |
1207
|
|
|
|
|
|
structures. */ |
1208
|
|
|
|
|
|
|
1209
|
4243940283
|
|
|
|
|
switch (old_type) { |
1210
|
|
|
|
|
|
case SVt_NULL: |
1211
|
|
|
|
|
|
break; |
1212
|
|
|
|
|
|
case SVt_IV: |
1213
|
170477263
|
100
|
|
|
|
if (SvROK(sv)) { |
1214
|
42598
|
|
|
|
|
referant = SvRV(sv); |
1215
|
|
|
|
|
|
old_type_details = &fake_rv; |
1216
|
42598
|
50
|
|
|
|
if (new_type == SVt_NV) |
1217
|
|
|
|
|
|
new_type = SVt_PVNV; |
1218
|
|
|
|
|
|
} else { |
1219
|
170434665
|
100
|
|
|
|
if (new_type < SVt_PVIV) { |
1220
|
2324856
|
100
|
|
|
|
new_type = (new_type == SVt_NV) |
1221
|
|
|
|
|
|
? SVt_PVNV : SVt_PVIV; |
1222
|
|
|
|
|
|
} |
1223
|
|
|
|
|
|
} |
1224
|
|
|
|
|
|
break; |
1225
|
|
|
|
|
|
case SVt_NV: |
1226
|
2303163
|
100
|
|
|
|
if (new_type < SVt_PVNV) { |
1227
|
|
|
|
|
|
new_type = SVt_PVNV; |
1228
|
|
|
|
|
|
} |
1229
|
|
|
|
|
|
break; |
1230
|
|
|
|
|
|
case SVt_PV: |
1231
|
|
|
|
|
|
assert(new_type > SVt_PV); |
1232
|
|
|
|
|
|
assert(SVt_IV < SVt_PV); |
1233
|
|
|
|
|
|
assert(SVt_NV < SVt_PV); |
1234
|
|
|
|
|
|
break; |
1235
|
|
|
|
|
|
case SVt_PVIV: |
1236
|
|
|
|
|
|
break; |
1237
|
|
|
|
|
|
case SVt_PVNV: |
1238
|
|
|
|
|
|
break; |
1239
|
|
|
|
|
|
case SVt_PVMG: |
1240
|
|
|
|
|
|
/* Because the XPVMG of PL_mess_sv isn't allocated from the arena, |
1241
|
|
|
|
|
|
there's no way that it can be safely upgraded, because perl.c |
1242
|
|
|
|
|
|
expects to Safefree(SvANY(PL_mess_sv)) */ |
1243
|
|
|
|
|
|
assert(sv != PL_mess_sv); |
1244
|
|
|
|
|
|
/* This flag bit is used to mean other things in other scalar types. |
1245
|
|
|
|
|
|
Given that it only has meaning inside the pad, it shouldn't be set |
1246
|
|
|
|
|
|
on anything that can get upgraded. */ |
1247
|
|
|
|
|
|
assert(!SvPAD_TYPED(sv)); |
1248
|
|
|
|
|
|
break; |
1249
|
|
|
|
|
|
default: |
1250
|
0
|
0
|
|
|
|
if (UNLIKELY(old_type_details->cant_upgrade)) |
1251
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, |
1252
|
|
|
|
|
|
sv_reftype(sv, 0), (UV) old_type, (UV) new_type); |
1253
|
|
|
|
|
|
} |
1254
|
|
|
|
|
|
|
1255
|
4243940283
|
50
|
|
|
|
if (UNLIKELY(old_type > new_type)) |
1256
|
0
|
|
|
|
|
Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", |
1257
|
|
|
|
|
|
(int)old_type, (int)new_type); |
1258
|
|
|
|
|
|
|
1259
|
4243940283
|
|
|
|
|
new_type_details = bodies_by_type + new_type; |
1260
|
|
|
|
|
|
|
1261
|
4243940283
|
|
|
|
|
SvFLAGS(sv) &= ~SVTYPEMASK; |
1262
|
4243940283
|
|
|
|
|
SvFLAGS(sv) |= new_type; |
1263
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
/* This can't happen, as SVt_NULL is <= all values of new_type, so one of |
1265
|
|
|
|
|
|
the return statements above will have triggered. */ |
1266
|
|
|
|
|
|
assert (new_type != SVt_NULL); |
1267
|
4243940283
|
|
|
|
|
switch (new_type) { |
1268
|
|
|
|
|
|
case SVt_IV: |
1269
|
|
|
|
|
|
assert(old_type == SVt_NULL); |
1270
|
1904381913
|
|
|
|
|
SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); |
1271
|
1904381913
|
|
|
|
|
SvIV_set(sv, 0); |
1272
|
1904381913
|
|
|
|
|
return; |
1273
|
|
|
|
|
|
case SVt_NV: |
1274
|
|
|
|
|
|
assert(old_type == SVt_NULL); |
1275
|
8784664
|
|
|
|
|
SvANY(sv) = new_XNV(); |
1276
|
8784664
|
|
|
|
|
SvNV_set(sv, 0); |
1277
|
8784664
|
|
|
|
|
return; |
1278
|
|
|
|
|
|
case SVt_PVHV: |
1279
|
|
|
|
|
|
case SVt_PVAV: |
1280
|
|
|
|
|
|
assert(new_type_details->body_size); |
1281
|
|
|
|
|
|
|
1282
|
|
|
|
|
|
#ifndef PURIFY |
1283
|
|
|
|
|
|
assert(new_type_details->arena); |
1284
|
|
|
|
|
|
assert(new_type_details->arena_size); |
1285
|
|
|
|
|
|
/* This points to the start of the allocated area. */ |
1286
|
301470357
|
100
|
|
|
|
new_body_inline(new_body, new_type); |
1287
|
301470357
|
|
|
|
|
Zero(new_body, new_type_details->body_size, char); |
1288
|
301470357
|
|
|
|
|
new_body = ((char *)new_body) - new_type_details->offset; |
1289
|
|
|
|
|
|
#else |
1290
|
|
|
|
|
|
/* We always allocated the full length item with PURIFY. To do this |
1291
|
|
|
|
|
|
we fake things so that arena is false for all 16 types.. */ |
1292
|
|
|
|
|
|
new_body = new_NOARENAZ(new_type_details); |
1293
|
|
|
|
|
|
#endif |
1294
|
301470357
|
|
|
|
|
SvANY(sv) = new_body; |
1295
|
301470357
|
100
|
|
|
|
if (new_type == SVt_PVAV) { |
1296
|
185822768
|
|
|
|
|
AvMAX(sv) = -1; |
1297
|
185822768
|
|
|
|
|
AvFILLp(sv) = -1; |
1298
|
185822768
|
|
|
|
|
AvREAL_only(sv); |
1299
|
185822768
|
50
|
|
|
|
if (old_type_details->body_size) { |
1300
|
0
|
|
|
|
|
AvALLOC(sv) = 0; |
1301
|
|
|
|
|
|
} else { |
1302
|
|
|
|
|
|
/* It will have been zeroed when the new body was allocated. |
1303
|
|
|
|
|
|
Lets not write to it, in case it confuses a write-back |
1304
|
|
|
|
|
|
cache. */ |
1305
|
|
|
|
|
|
} |
1306
|
|
|
|
|
|
} else { |
1307
|
|
|
|
|
|
assert(!SvOK(sv)); |
1308
|
115647589
|
50
|
|
|
|
SvOK_off(sv); |
1309
|
|
|
|
|
|
#ifndef NODEFAULT_SHAREKEYS |
1310
|
115647589
|
|
|
|
|
HvSHAREKEYS_on(sv); /* key-sharing on by default */ |
1311
|
|
|
|
|
|
#endif |
1312
|
|
|
|
|
|
/* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ |
1313
|
115647589
|
|
|
|
|
HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; |
1314
|
|
|
|
|
|
} |
1315
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
/* SVt_NULL isn't the only thing upgraded to AV or HV. |
1317
|
|
|
|
|
|
The target created by newSVrv also is, and it can have magic. |
1318
|
|
|
|
|
|
However, it never has SvPVX set. |
1319
|
|
|
|
|
|
*/ |
1320
|
|
|
|
|
|
if (old_type == SVt_IV) { |
1321
|
|
|
|
|
|
assert(!SvROK(sv)); |
1322
|
|
|
|
|
|
} else if (old_type >= SVt_PV) { |
1323
|
|
|
|
|
|
assert(SvPVX_const(sv) == 0); |
1324
|
|
|
|
|
|
} |
1325
|
|
|
|
|
|
|
1326
|
301470357
|
100
|
|
|
|
if (old_type >= SVt_PVMG) { |
1327
|
1184416
|
|
|
|
|
SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); |
1328
|
1184416
|
|
|
|
|
SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); |
1329
|
|
|
|
|
|
} else { |
1330
|
300285941
|
|
|
|
|
sv->sv_u.svu_array = NULL; /* or svu_hash */ |
1331
|
|
|
|
|
|
} |
1332
|
|
|
|
|
|
break; |
1333
|
|
|
|
|
|
|
1334
|
|
|
|
|
|
case SVt_PVIV: |
1335
|
|
|
|
|
|
/* XXX Is this still needed? Was it ever needed? Surely as there is |
1336
|
|
|
|
|
|
no route from NV to PVIV, NOK can never be true */ |
1337
|
|
|
|
|
|
assert(!SvNOKp(sv)); |
1338
|
|
|
|
|
|
assert(!SvNOK(sv)); |
1339
|
|
|
|
|
|
case SVt_PVIO: |
1340
|
|
|
|
|
|
case SVt_PVFM: |
1341
|
|
|
|
|
|
case SVt_PVGV: |
1342
|
|
|
|
|
|
case SVt_PVCV: |
1343
|
|
|
|
|
|
case SVt_PVLV: |
1344
|
|
|
|
|
|
case SVt_INVLIST: |
1345
|
|
|
|
|
|
case SVt_REGEXP: |
1346
|
|
|
|
|
|
case SVt_PVMG: |
1347
|
|
|
|
|
|
case SVt_PVNV: |
1348
|
|
|
|
|
|
case SVt_PV: |
1349
|
|
|
|
|
|
|
1350
|
|
|
|
|
|
assert(new_type_details->body_size); |
1351
|
|
|
|
|
|
/* We always allocated the full length item with PURIFY. To do this |
1352
|
|
|
|
|
|
we fake things so that arena is false for all 16 types.. */ |
1353
|
2029303349
|
100
|
|
|
|
if(new_type_details->arena) { |
1354
|
|
|
|
|
|
/* This points to the start of the allocated area. */ |
1355
|
2029302717
|
100
|
|
|
|
new_body_inline(new_body, new_type); |
1356
|
2029302717
|
|
|
|
|
Zero(new_body, new_type_details->body_size, char); |
1357
|
2029302717
|
|
|
|
|
new_body = ((char *)new_body) - new_type_details->offset; |
1358
|
|
|
|
|
|
} else { |
1359
|
632
|
|
|
|
|
new_body = new_NOARENAZ(new_type_details); |
1360
|
|
|
|
|
|
} |
1361
|
2029303349
|
|
|
|
|
SvANY(sv) = new_body; |
1362
|
|
|
|
|
|
|
1363
|
2029303349
|
100
|
|
|
|
if (old_type_details->copy) { |
1364
|
|
|
|
|
|
/* There is now the potential for an upgrade from something without |
1365
|
|
|
|
|
|
an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ |
1366
|
219765160
|
|
|
|
|
int offset = old_type_details->offset; |
1367
|
219765160
|
|
|
|
|
int length = old_type_details->copy; |
1368
|
|
|
|
|
|
|
1369
|
219765160
|
50
|
|
|
|
if (new_type_details->offset > old_type_details->offset) { |
1370
|
0
|
|
|
|
|
const int difference |
1371
|
0
|
|
|
|
|
= new_type_details->offset - old_type_details->offset; |
1372
|
0
|
|
|
|
|
offset += difference; |
1373
|
0
|
|
|
|
|
length -= difference; |
1374
|
|
|
|
|
|
} |
1375
|
|
|
|
|
|
assert (length >= 0); |
1376
|
|
|
|
|
|
|
1377
|
219765160
|
|
|
|
|
Copy((char *)old_body + offset, (char *)new_body + offset, length, |
1378
|
|
|
|
|
|
char); |
1379
|
|
|
|
|
|
} |
1380
|
|
|
|
|
|
|
1381
|
|
|
|
|
|
#ifndef NV_ZERO_IS_ALLBITS_ZERO |
1382
|
|
|
|
|
|
/* If NV 0.0 is stores as all bits 0 then Zero() already creates a |
1383
|
|
|
|
|
|
* correct 0.0 for us. Otherwise, if the old body didn't have an |
1384
|
|
|
|
|
|
* NV slot, but the new one does, then we need to initialise the |
1385
|
|
|
|
|
|
* freshly created NV slot with whatever the correct bit pattern is |
1386
|
|
|
|
|
|
* for 0.0 */ |
1387
|
|
|
|
|
|
if (old_type_details->zero_nv && !new_type_details->zero_nv |
1388
|
|
|
|
|
|
&& !isGV_with_GP(sv)) |
1389
|
|
|
|
|
|
SvNV_set(sv, 0); |
1390
|
|
|
|
|
|
#endif |
1391
|
|
|
|
|
|
|
1392
|
2029303349
|
100
|
|
|
|
if (UNLIKELY(new_type == SVt_PVIO)) { |
1393
|
|
|
|
|
|
IO * const io = MUTABLE_IO(sv); |
1394
|
5097139
|
|
|
|
|
GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); |
1395
|
|
|
|
|
|
|
1396
|
5097139
|
|
|
|
|
SvOBJECT_on(io); |
1397
|
|
|
|
|
|
/* Clear the stashcache because a new IO could overrule a package |
1398
|
|
|
|
|
|
name */ |
1399
|
|
|
|
|
|
DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); |
1400
|
5097139
|
|
|
|
|
hv_clear(PL_stashcache); |
1401
|
|
|
|
|
|
|
1402
|
10194278
|
|
|
|
|
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); |
1403
|
5097139
|
|
|
|
|
IoPAGE_LEN(sv) = 60; |
1404
|
|
|
|
|
|
} |
1405
|
2029303349
|
100
|
|
|
|
if (UNLIKELY(new_type == SVt_REGEXP)) |
1406
|
24189608
|
|
|
|
|
sv->sv_u.svu_rx = (regexp *)new_body; |
1407
|
2005113741
|
100
|
|
|
|
else if (old_type < SVt_PV) { |
1408
|
|
|
|
|
|
/* referant will be NULL unless the old type was SVt_IV emulating |
1409
|
|
|
|
|
|
SVt_RV */ |
1410
|
1958086435
|
|
|
|
|
sv->sv_u.svu_rv = referant; |
1411
|
|
|
|
|
|
} |
1412
|
|
|
|
|
|
break; |
1413
|
|
|
|
|
|
default: |
1414
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", |
1415
|
|
|
|
|
|
(unsigned long)new_type); |
1416
|
|
|
|
|
|
} |
1417
|
|
|
|
|
|
|
1418
|
2330773706
|
100
|
|
|
|
if (old_type > SVt_IV) { |
1419
|
|
|
|
|
|
#ifdef PURIFY |
1420
|
|
|
|
|
|
safefree(old_body); |
1421
|
|
|
|
|
|
#else |
1422
|
|
|
|
|
|
/* Note that there is an assumption that all bodies of types that |
1423
|
|
|
|
|
|
can be upgraded came from arenas. Only the more complex non- |
1424
|
|
|
|
|
|
upgradable types are allowed to be directly malloc()ed. */ |
1425
|
|
|
|
|
|
assert(old_type_details->arena); |
1426
|
2158102480
|
|
|
|
|
del_body((void*)((char*)old_body + old_type_details->offset), |
1427
|
|
|
|
|
|
&PL_body_roots[old_type]); |
1428
|
|
|
|
|
|
#endif |
1429
|
|
|
|
|
|
} |
1430
|
|
|
|
|
|
} |
1431
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
/* |
1433
|
|
|
|
|
|
=for apidoc sv_backoff |
1434
|
|
|
|
|
|
|
1435
|
|
|
|
|
|
Remove any string offset. You should normally use the C macro |
1436
|
|
|
|
|
|
wrapper instead. |
1437
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
=cut |
1439
|
|
|
|
|
|
*/ |
1440
|
|
|
|
|
|
|
1441
|
|
|
|
|
|
int |
1442
|
77326
|
|
|
|
|
Perl_sv_backoff(pTHX_ SV *const sv) |
1443
|
|
|
|
|
|
{ |
1444
|
|
|
|
|
|
STRLEN delta; |
1445
|
77326
|
|
|
|
|
const char * const s = SvPVX_const(sv); |
1446
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_BACKOFF; |
1448
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
1449
|
|
|
|
|
|
|
1450
|
|
|
|
|
|
assert(SvOOK(sv)); |
1451
|
|
|
|
|
|
assert(SvTYPE(sv) != SVt_PVHV); |
1452
|
|
|
|
|
|
assert(SvTYPE(sv) != SVt_PVAV); |
1453
|
|
|
|
|
|
|
1454
|
77326
|
50
|
|
|
|
SvOOK_offset(sv, delta); |
|
|
100
|
|
|
|
|
1455
|
|
|
|
|
|
|
1456
|
77326
|
|
|
|
|
SvLEN_set(sv, SvLEN(sv) + delta); |
1457
|
77326
|
|
|
|
|
SvPV_set(sv, SvPVX(sv) - delta); |
1458
|
77326
|
|
|
|
|
Move(s, SvPVX(sv), SvCUR(sv)+1, char); |
1459
|
77326
|
|
|
|
|
SvFLAGS(sv) &= ~SVf_OOK; |
1460
|
77326
|
|
|
|
|
return 0; |
1461
|
|
|
|
|
|
} |
1462
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
/* |
1464
|
|
|
|
|
|
=for apidoc sv_grow |
1465
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
Expands the character buffer in the SV. If necessary, uses C and |
1467
|
|
|
|
|
|
upgrades the SV to C. Returns a pointer to the character buffer. |
1468
|
|
|
|
|
|
Use the C wrapper instead. |
1469
|
|
|
|
|
|
|
1470
|
|
|
|
|
|
=cut |
1471
|
|
|
|
|
|
*/ |
1472
|
|
|
|
|
|
|
1473
|
|
|
|
|
|
static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags); |
1474
|
|
|
|
|
|
|
1475
|
|
|
|
|
|
char * |
1476
|
1046735576
|
|
|
|
|
Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) |
1477
|
|
|
|
|
|
{ |
1478
|
|
|
|
|
|
char *s; |
1479
|
|
|
|
|
|
|
1480
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_GROW; |
1481
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
#ifdef HAS_64K_LIMIT |
1483
|
|
|
|
|
|
if (newlen >= 0x10000) { |
1484
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, |
1485
|
|
|
|
|
|
"Allocation too large: %"UVxf"\n", (UV)newlen); |
1486
|
|
|
|
|
|
my_exit(1); |
1487
|
|
|
|
|
|
} |
1488
|
|
|
|
|
|
#endif /* HAS_64K_LIMIT */ |
1489
|
1046735576
|
50
|
|
|
|
if (SvROK(sv)) |
1490
|
0
|
|
|
|
|
sv_unref(sv); |
1491
|
1046735576
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_PV) { |
1492
|
24346
|
|
|
|
|
sv_upgrade(sv, SVt_PV); |
1493
|
24346
|
|
|
|
|
s = SvPVX_mutable(sv); |
1494
|
|
|
|
|
|
} |
1495
|
1046711230
|
100
|
|
|
|
else if (SvOOK(sv)) { /* pv is offset? */ |
1496
|
14562
|
|
|
|
|
sv_backoff(sv); |
1497
|
14562
|
|
|
|
|
s = SvPVX_mutable(sv); |
1498
|
14562
|
100
|
|
|
|
if (newlen > SvLEN(sv)) |
1499
|
6344
|
|
|
|
|
newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ |
1500
|
|
|
|
|
|
#ifdef HAS_64K_LIMIT |
1501
|
|
|
|
|
|
if (newlen >= 0x10000) |
1502
|
|
|
|
|
|
newlen = 0xFFFF; |
1503
|
|
|
|
|
|
#endif |
1504
|
|
|
|
|
|
} |
1505
|
|
|
|
|
|
else |
1506
|
|
|
|
|
|
{ |
1507
|
1046696668
|
100
|
|
|
|
if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); |
1508
|
1046696668
|
|
|
|
|
s = SvPVX_mutable(sv); |
1509
|
|
|
|
|
|
} |
1510
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
#ifdef PERL_NEW_COPY_ON_WRITE |
1512
|
|
|
|
|
|
/* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare) |
1513
|
|
|
|
|
|
* to store the COW count. So in general, allocate one more byte than |
1514
|
|
|
|
|
|
* asked for, to make it likely this byte is always spare: and thus |
1515
|
|
|
|
|
|
* make more strings COW-able. |
1516
|
|
|
|
|
|
* If the new size is a big power of two, don't bother: we assume the |
1517
|
|
|
|
|
|
* caller wanted a nice 2^N sized block and will be annoyed at getting |
1518
|
|
|
|
|
|
* 2^N+1 */ |
1519
|
1046735576
|
100
|
|
|
|
if (newlen & 0xff) |
1520
|
1046623352
|
|
|
|
|
newlen++; |
1521
|
|
|
|
|
|
#endif |
1522
|
|
|
|
|
|
|
1523
|
1046735576
|
100
|
|
|
|
if (newlen > SvLEN(sv)) { /* need more room? */ |
1524
|
1037760184
|
|
|
|
|
STRLEN minlen = SvCUR(sv); |
1525
|
1037760184
|
|
|
|
|
minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; |
1526
|
1037760184
|
100
|
|
|
|
if (newlen < minlen) |
1527
|
|
|
|
|
|
newlen = minlen; |
1528
|
|
|
|
|
|
#ifndef Perl_safesysmalloc_size |
1529
|
1037760184
|
50
|
|
|
|
newlen = PERL_STRLEN_ROUNDUP(newlen); |
1530
|
|
|
|
|
|
#endif |
1531
|
1037760184
|
100
|
|
|
|
if (SvLEN(sv) && s) { |
1532
|
37573464
|
|
|
|
|
s = (char*)saferealloc(s, newlen); |
1533
|
|
|
|
|
|
} |
1534
|
|
|
|
|
|
else { |
1535
|
1000186720
|
|
|
|
|
s = (char*)safemalloc(newlen); |
1536
|
1000186720
|
100
|
|
|
|
if (SvPVX_const(sv) && SvCUR(sv)) { |
|
|
50
|
|
|
|
|
1537
|
72
|
|
|
|
|
Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); |
1538
|
|
|
|
|
|
} |
1539
|
|
|
|
|
|
} |
1540
|
1037760184
|
|
|
|
|
SvPV_set(sv, s); |
1541
|
|
|
|
|
|
#ifdef Perl_safesysmalloc_size |
1542
|
|
|
|
|
|
/* Do this here, do it once, do it right, and then we will never get |
1543
|
|
|
|
|
|
called back into sv_grow() unless there really is some growing |
1544
|
|
|
|
|
|
needed. */ |
1545
|
|
|
|
|
|
SvLEN_set(sv, Perl_safesysmalloc_size(s)); |
1546
|
|
|
|
|
|
#else |
1547
|
1037760184
|
|
|
|
|
SvLEN_set(sv, newlen); |
1548
|
|
|
|
|
|
#endif |
1549
|
|
|
|
|
|
} |
1550
|
1046735576
|
|
|
|
|
return s; |
1551
|
|
|
|
|
|
} |
1552
|
|
|
|
|
|
|
1553
|
|
|
|
|
|
/* |
1554
|
|
|
|
|
|
=for apidoc sv_setiv |
1555
|
|
|
|
|
|
|
1556
|
|
|
|
|
|
Copies an integer into the given SV, upgrading first if necessary. |
1557
|
|
|
|
|
|
Does not handle 'set' magic. See also C. |
1558
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
=cut |
1560
|
|
|
|
|
|
*/ |
1561
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
void |
1563
|
1792820924
|
|
|
|
|
Perl_sv_setiv(pTHX_ SV *const sv, const IV i) |
1564
|
|
|
|
|
|
{ |
1565
|
|
|
|
|
|
dVAR; |
1566
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETIV; |
1568
|
|
|
|
|
|
|
1569
|
1792820924
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
1570
|
1792820922
|
|
|
|
|
switch (SvTYPE(sv)) { |
1571
|
|
|
|
|
|
case SVt_NULL: |
1572
|
|
|
|
|
|
case SVt_NV: |
1573
|
770672422
|
|
|
|
|
sv_upgrade(sv, SVt_IV); |
1574
|
770672422
|
|
|
|
|
break; |
1575
|
|
|
|
|
|
case SVt_PV: |
1576
|
8926
|
|
|
|
|
sv_upgrade(sv, SVt_PVIV); |
1577
|
8926
|
|
|
|
|
break; |
1578
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
case SVt_PVGV: |
1580
|
2
|
50
|
|
|
|
if (!isGV_with_GP(sv)) |
|
|
50
|
|
|
|
|
1581
|
|
|
|
|
|
break; |
1582
|
|
|
|
|
|
case SVt_PVAV: |
1583
|
|
|
|
|
|
case SVt_PVHV: |
1584
|
|
|
|
|
|
case SVt_PVCV: |
1585
|
|
|
|
|
|
case SVt_PVFM: |
1586
|
|
|
|
|
|
case SVt_PVIO: |
1587
|
|
|
|
|
|
/* diag_listed_as: Can't coerce %s to %s in %s */ |
1588
|
3
|
50
|
|
|
|
Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), |
1589
|
1
|
0
|
|
|
|
OP_DESC(PL_op)); |
1590
|
|
|
|
|
|
default: NOOP; |
1591
|
|
|
|
|
|
} |
1592
|
1792820920
|
50
|
|
|
|
(void)SvIOK_only(sv); /* validate number */ |
1593
|
1792820920
|
|
|
|
|
SvIV_set(sv, i); |
1594
|
1792820920
|
100
|
|
|
|
SvTAINT(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
1595
|
1792820920
|
|
|
|
|
} |
1596
|
|
|
|
|
|
|
1597
|
|
|
|
|
|
/* |
1598
|
|
|
|
|
|
=for apidoc sv_setiv_mg |
1599
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
1601
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
=cut |
1603
|
|
|
|
|
|
*/ |
1604
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
void |
1606
|
108
|
|
|
|
|
Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i) |
1607
|
|
|
|
|
|
{ |
1608
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETIV_MG; |
1609
|
|
|
|
|
|
|
1610
|
108
|
|
|
|
|
sv_setiv(sv,i); |
1611
|
108
|
100
|
|
|
|
SvSETMAGIC(sv); |
1612
|
108
|
|
|
|
|
} |
1613
|
|
|
|
|
|
|
1614
|
|
|
|
|
|
/* |
1615
|
|
|
|
|
|
=for apidoc sv_setuv |
1616
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
Copies an unsigned integer into the given SV, upgrading first if necessary. |
1618
|
|
|
|
|
|
Does not handle 'set' magic. See also C. |
1619
|
|
|
|
|
|
|
1620
|
|
|
|
|
|
=cut |
1621
|
|
|
|
|
|
*/ |
1622
|
|
|
|
|
|
|
1623
|
|
|
|
|
|
void |
1624
|
250556095
|
|
|
|
|
Perl_sv_setuv(pTHX_ SV *const sv, const UV u) |
1625
|
|
|
|
|
|
{ |
1626
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETUV; |
1627
|
|
|
|
|
|
|
1628
|
|
|
|
|
|
/* With the if statement to ensure that integers are stored as IVs whenever |
1629
|
|
|
|
|
|
possible: |
1630
|
|
|
|
|
|
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 |
1631
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
without |
1633
|
|
|
|
|
|
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 |
1634
|
|
|
|
|
|
|
1635
|
|
|
|
|
|
If you wish to remove the following if statement, so that this routine |
1636
|
|
|
|
|
|
(and its callers) always return UVs, please benchmark to see what the |
1637
|
|
|
|
|
|
effect is. Modern CPUs may be different. Or may not :-) |
1638
|
|
|
|
|
|
*/ |
1639
|
250556095
|
100
|
|
|
|
if (u <= (UV)IV_MAX) { |
1640
|
249527411
|
|
|
|
|
sv_setiv(sv, (IV)u); |
1641
|
374971525
|
|
|
|
|
return; |
1642
|
|
|
|
|
|
} |
1643
|
1028684
|
|
|
|
|
sv_setiv(sv, 0); |
1644
|
1028684
|
|
|
|
|
SvIsUV_on(sv); |
1645
|
1028684
|
|
|
|
|
SvUV_set(sv, u); |
1646
|
|
|
|
|
|
} |
1647
|
|
|
|
|
|
|
1648
|
|
|
|
|
|
/* |
1649
|
|
|
|
|
|
=for apidoc sv_setuv_mg |
1650
|
|
|
|
|
|
|
1651
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
1652
|
|
|
|
|
|
|
1653
|
|
|
|
|
|
=cut |
1654
|
|
|
|
|
|
*/ |
1655
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
void |
1657
|
12
|
|
|
|
|
Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u) |
1658
|
|
|
|
|
|
{ |
1659
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETUV_MG; |
1660
|
|
|
|
|
|
|
1661
|
12
|
|
|
|
|
sv_setuv(sv,u); |
1662
|
10
|
100
|
|
|
|
SvSETMAGIC(sv); |
1663
|
10
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
/* |
1666
|
|
|
|
|
|
=for apidoc sv_setnv |
1667
|
|
|
|
|
|
|
1668
|
|
|
|
|
|
Copies a double into the given SV, upgrading first if necessary. |
1669
|
|
|
|
|
|
Does not handle 'set' magic. See also C. |
1670
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
=cut |
1672
|
|
|
|
|
|
*/ |
1673
|
|
|
|
|
|
|
1674
|
|
|
|
|
|
void |
1675
|
106016696
|
|
|
|
|
Perl_sv_setnv(pTHX_ SV *const sv, const NV num) |
1676
|
|
|
|
|
|
{ |
1677
|
|
|
|
|
|
dVAR; |
1678
|
|
|
|
|
|
|
1679
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETNV; |
1680
|
|
|
|
|
|
|
1681
|
106016696
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
1682
|
106016696
|
|
|
|
|
switch (SvTYPE(sv)) { |
1683
|
|
|
|
|
|
case SVt_NULL: |
1684
|
|
|
|
|
|
case SVt_IV: |
1685
|
4942782
|
|
|
|
|
sv_upgrade(sv, SVt_NV); |
1686
|
4942782
|
|
|
|
|
break; |
1687
|
|
|
|
|
|
case SVt_PV: |
1688
|
|
|
|
|
|
case SVt_PVIV: |
1689
|
36
|
|
|
|
|
sv_upgrade(sv, SVt_PVNV); |
1690
|
36
|
|
|
|
|
break; |
1691
|
|
|
|
|
|
|
1692
|
|
|
|
|
|
case SVt_PVGV: |
1693
|
2
|
50
|
|
|
|
if (!isGV_with_GP(sv)) |
|
|
50
|
|
|
|
|
1694
|
|
|
|
|
|
break; |
1695
|
|
|
|
|
|
case SVt_PVAV: |
1696
|
|
|
|
|
|
case SVt_PVHV: |
1697
|
|
|
|
|
|
case SVt_PVCV: |
1698
|
|
|
|
|
|
case SVt_PVFM: |
1699
|
|
|
|
|
|
case SVt_PVIO: |
1700
|
|
|
|
|
|
/* diag_listed_as: Can't coerce %s to %s in %s */ |
1701
|
3
|
50
|
|
|
|
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), |
1702
|
1
|
0
|
|
|
|
OP_DESC(PL_op)); |
1703
|
|
|
|
|
|
default: NOOP; |
1704
|
|
|
|
|
|
} |
1705
|
106016694
|
|
|
|
|
SvNV_set(sv, num); |
1706
|
106016694
|
50
|
|
|
|
(void)SvNOK_only(sv); /* validate number */ |
1707
|
106016694
|
100
|
|
|
|
SvTAINT(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
1708
|
106016694
|
|
|
|
|
} |
1709
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
/* |
1711
|
|
|
|
|
|
=for apidoc sv_setnv_mg |
1712
|
|
|
|
|
|
|
1713
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
1714
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
=cut |
1716
|
|
|
|
|
|
*/ |
1717
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
void |
1719
|
1536621
|
|
|
|
|
Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) |
1720
|
|
|
|
|
|
{ |
1721
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETNV_MG; |
1722
|
|
|
|
|
|
|
1723
|
1536621
|
|
|
|
|
sv_setnv(sv,num); |
1724
|
1536621
|
100
|
|
|
|
SvSETMAGIC(sv); |
1725
|
1536621
|
|
|
|
|
} |
1726
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
/* Return a cleaned-up, printable version of sv, for non-numeric, or |
1728
|
|
|
|
|
|
* not incrementable warning display. |
1729
|
|
|
|
|
|
* Originally part of S_not_a_number(). |
1730
|
|
|
|
|
|
* The return value may be != tmpbuf. |
1731
|
|
|
|
|
|
*/ |
1732
|
|
|
|
|
|
|
1733
|
|
|
|
|
|
STATIC const char * |
1734
|
92
|
|
|
|
|
S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { |
1735
|
|
|
|
|
|
const char *pv; |
1736
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DISPLAY; |
1738
|
|
|
|
|
|
|
1739
|
110
|
100
|
|
|
|
if (DO_UTF8(sv)) { |
|
|
50
|
|
|
|
|
1740
|
18
|
|
|
|
|
SV *dsv = newSVpvs_flags("", SVs_TEMP); |
1741
|
18
|
|
|
|
|
pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT); |
1742
|
|
|
|
|
|
} else { |
1743
|
|
|
|
|
|
char *d = tmpbuf; |
1744
|
74
|
|
|
|
|
const char * const limit = tmpbuf + tmpbuf_size - 8; |
1745
|
|
|
|
|
|
/* each *s can expand to 4 chars + "...\0", |
1746
|
|
|
|
|
|
i.e. need room for 8 chars */ |
1747
|
|
|
|
|
|
|
1748
|
74
|
|
|
|
|
const char *s = SvPVX_const(sv); |
1749
|
74
|
|
|
|
|
const char * const end = s + SvCUR(sv); |
1750
|
522
|
100
|
|
|
|
for ( ; s < end && d < limit; s++ ) { |
1751
|
448
|
|
|
|
|
int ch = *s & 0xFF; |
1752
|
448
|
50
|
|
|
|
if (! isASCII(ch) && !isPRINT_LC(ch)) { |
|
|
0
|
|
|
|
|
1753
|
0
|
|
|
|
|
*d++ = 'M'; |
1754
|
0
|
|
|
|
|
*d++ = '-'; |
1755
|
|
|
|
|
|
|
1756
|
|
|
|
|
|
/* Map to ASCII "equivalent" of Latin1 */ |
1757
|
0
|
|
|
|
|
ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); |
1758
|
|
|
|
|
|
} |
1759
|
448
|
50
|
|
|
|
if (ch == '\n') { |
1760
|
0
|
|
|
|
|
*d++ = '\\'; |
1761
|
0
|
|
|
|
|
*d++ = 'n'; |
1762
|
|
|
|
|
|
} |
1763
|
448
|
50
|
|
|
|
else if (ch == '\r') { |
1764
|
0
|
|
|
|
|
*d++ = '\\'; |
1765
|
0
|
|
|
|
|
*d++ = 'r'; |
1766
|
|
|
|
|
|
} |
1767
|
448
|
50
|
|
|
|
else if (ch == '\f') { |
1768
|
0
|
|
|
|
|
*d++ = '\\'; |
1769
|
0
|
|
|
|
|
*d++ = 'f'; |
1770
|
|
|
|
|
|
} |
1771
|
448
|
50
|
|
|
|
else if (ch == '\\') { |
1772
|
0
|
|
|
|
|
*d++ = '\\'; |
1773
|
0
|
|
|
|
|
*d++ = '\\'; |
1774
|
|
|
|
|
|
} |
1775
|
448
|
100
|
|
|
|
else if (ch == '\0') { |
1776
|
22
|
|
|
|
|
*d++ = '\\'; |
1777
|
22
|
|
|
|
|
*d++ = '0'; |
1778
|
|
|
|
|
|
} |
1779
|
426
|
50
|
|
|
|
else if (isPRINT_LC(ch)) |
1780
|
426
|
|
|
|
|
*d++ = ch; |
1781
|
|
|
|
|
|
else { |
1782
|
0
|
|
|
|
|
*d++ = '^'; |
1783
|
0
|
0
|
|
|
|
*d++ = toCTRL(ch); |
1784
|
|
|
|
|
|
} |
1785
|
|
|
|
|
|
} |
1786
|
74
|
50
|
|
|
|
if (s < end) { |
1787
|
0
|
|
|
|
|
*d++ = '.'; |
1788
|
0
|
|
|
|
|
*d++ = '.'; |
1789
|
0
|
|
|
|
|
*d++ = '.'; |
1790
|
|
|
|
|
|
} |
1791
|
74
|
|
|
|
|
*d = '\0'; |
1792
|
|
|
|
|
|
pv = tmpbuf; |
1793
|
|
|
|
|
|
} |
1794
|
|
|
|
|
|
|
1795
|
92
|
|
|
|
|
return pv; |
1796
|
|
|
|
|
|
} |
1797
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
/* Print an "isn't numeric" warning, using a cleaned-up, |
1799
|
|
|
|
|
|
* printable version of the offending string |
1800
|
|
|
|
|
|
*/ |
1801
|
|
|
|
|
|
|
1802
|
|
|
|
|
|
STATIC void |
1803
|
88
|
|
|
|
|
S_not_a_number(pTHX_ SV *const sv) |
1804
|
|
|
|
|
|
{ |
1805
|
|
|
|
|
|
dVAR; |
1806
|
|
|
|
|
|
char tmpbuf[64]; |
1807
|
|
|
|
|
|
const char *pv; |
1808
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
PERL_ARGS_ASSERT_NOT_A_NUMBER; |
1810
|
|
|
|
|
|
|
1811
|
88
|
|
|
|
|
pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); |
1812
|
|
|
|
|
|
|
1813
|
88
|
50
|
|
|
|
if (PL_op) |
1814
|
132
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
1815
|
|
|
|
|
|
/* diag_listed_as: Argument "%s" isn't numeric%s */ |
1816
|
|
|
|
|
|
"Argument \"%s\" isn't numeric in %s", pv, |
1817
|
44
|
0
|
|
|
|
OP_DESC(PL_op)); |
1818
|
|
|
|
|
|
else |
1819
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
1820
|
|
|
|
|
|
/* diag_listed_as: Argument "%s" isn't numeric%s */ |
1821
|
|
|
|
|
|
"Argument \"%s\" isn't numeric", pv); |
1822
|
74
|
|
|
|
|
} |
1823
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
STATIC void |
1825
|
|
|
|
|
|
S_not_incrementable(pTHX_ SV *const sv) { |
1826
|
|
|
|
|
|
dVAR; |
1827
|
|
|
|
|
|
char tmpbuf[64]; |
1828
|
|
|
|
|
|
const char *pv; |
1829
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
PERL_ARGS_ASSERT_NOT_INCREMENTABLE; |
1831
|
|
|
|
|
|
|
1832
|
4
|
|
|
|
|
pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); |
1833
|
|
|
|
|
|
|
1834
|
4
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
1835
|
|
|
|
|
|
"Argument \"%s\" treated as 0 in increment (++)", pv); |
1836
|
|
|
|
|
|
} |
1837
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
/* |
1839
|
|
|
|
|
|
=for apidoc looks_like_number |
1840
|
|
|
|
|
|
|
1841
|
|
|
|
|
|
Test if the content of an SV looks like a number (or is a number). |
1842
|
|
|
|
|
|
C and C are treated as numbers (so will not issue a |
1843
|
|
|
|
|
|
non-numeric warning), even if your atof() doesn't grok them. Get-magic is |
1844
|
|
|
|
|
|
ignored. |
1845
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
=cut |
1847
|
|
|
|
|
|
*/ |
1848
|
|
|
|
|
|
|
1849
|
|
|
|
|
|
I32 |
1850
|
3586
|
|
|
|
|
Perl_looks_like_number(pTHX_ SV *const sv) |
1851
|
|
|
|
|
|
{ |
1852
|
|
|
|
|
|
const char *sbegin; |
1853
|
|
|
|
|
|
STRLEN len; |
1854
|
|
|
|
|
|
|
1855
|
|
|
|
|
|
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; |
1856
|
|
|
|
|
|
|
1857
|
3586
|
100
|
|
|
|
if (SvPOK(sv) || SvPOKp(sv)) { |
1858
|
3518
|
100
|
|
|
|
sbegin = SvPV_nomg_const(sv, len); |
1859
|
|
|
|
|
|
} |
1860
|
|
|
|
|
|
else |
1861
|
1827
|
|
|
|
|
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); |
1862
|
3518
|
|
|
|
|
return grok_number(sbegin, len, NULL); |
1863
|
|
|
|
|
|
} |
1864
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
STATIC bool |
1866
|
50
|
|
|
|
|
S_glob_2number(pTHX_ GV * const gv) |
1867
|
|
|
|
|
|
{ |
1868
|
|
|
|
|
|
PERL_ARGS_ASSERT_GLOB_2NUMBER; |
1869
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
/* We know that all GVs stringify to something that is not-a-number, |
1871
|
|
|
|
|
|
so no need to test that. */ |
1872
|
50
|
100
|
|
|
|
if (ckWARN(WARN_NUMERIC)) |
1873
|
|
|
|
|
|
{ |
1874
|
28
|
|
|
|
|
SV *const buffer = sv_newmortal(); |
1875
|
28
|
|
|
|
|
gv_efullname3(buffer, gv, "*"); |
1876
|
28
|
|
|
|
|
not_a_number(buffer); |
1877
|
|
|
|
|
|
} |
1878
|
|
|
|
|
|
/* We just want something true to return, so that S_sv_2iuv_common |
1879
|
|
|
|
|
|
can tail call us and return true. */ |
1880
|
50
|
|
|
|
|
return TRUE; |
1881
|
|
|
|
|
|
} |
1882
|
|
|
|
|
|
|
1883
|
|
|
|
|
|
/* Actually, ISO C leaves conversion of UV to IV undefined, but |
1884
|
|
|
|
|
|
until proven guilty, assume that things are not that bad... */ |
1885
|
|
|
|
|
|
|
1886
|
|
|
|
|
|
/* |
1887
|
|
|
|
|
|
NV_PRESERVES_UV: |
1888
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
As 64 bit platforms often have an NV that doesn't preserve all bits of |
1890
|
|
|
|
|
|
an IV (an assumption perl has been based on to date) it becomes necessary |
1891
|
|
|
|
|
|
to remove the assumption that the NV always carries enough precision to |
1892
|
|
|
|
|
|
recreate the IV whenever needed, and that the NV is the canonical form. |
1893
|
|
|
|
|
|
Instead, IV/UV and NV need to be given equal rights. So as to not lose |
1894
|
|
|
|
|
|
precision as a side effect of conversion (which would lead to insanity |
1895
|
|
|
|
|
|
and the dragon(s) in t/op/numconvert.t getting very angry) the intent is |
1896
|
|
|
|
|
|
1) to distinguish between IV/UV/NV slots that have cached a valid |
1897
|
|
|
|
|
|
conversion where precision was lost and IV/UV/NV slots that have a |
1898
|
|
|
|
|
|
valid conversion which has lost no precision |
1899
|
|
|
|
|
|
2) to ensure that if a numeric conversion to one form is requested that |
1900
|
|
|
|
|
|
would lose precision, the precise conversion (or differently |
1901
|
|
|
|
|
|
imprecise conversion) is also performed and cached, to prevent |
1902
|
|
|
|
|
|
requests for different numeric formats on the same SV causing |
1903
|
|
|
|
|
|
lossy conversion chains. (lossless conversion chains are perfectly |
1904
|
|
|
|
|
|
acceptable (still)) |
1905
|
|
|
|
|
|
|
1906
|
|
|
|
|
|
|
1907
|
|
|
|
|
|
flags are used: |
1908
|
|
|
|
|
|
SvIOKp is true if the IV slot contains a valid value |
1909
|
|
|
|
|
|
SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) |
1910
|
|
|
|
|
|
SvNOKp is true if the NV slot contains a valid value |
1911
|
|
|
|
|
|
SvNOK is true only if the NV value is accurate |
1912
|
|
|
|
|
|
|
1913
|
|
|
|
|
|
so |
1914
|
|
|
|
|
|
while converting from PV to NV, check to see if converting that NV to an |
1915
|
|
|
|
|
|
IV(or UV) would lose accuracy over a direct conversion from PV to |
1916
|
|
|
|
|
|
IV(or UV). If it would, cache both conversions, return NV, but mark |
1917
|
|
|
|
|
|
SV as IOK NOKp (ie not NOK). |
1918
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
While converting from PV to IV, check to see if converting that IV to an |
1920
|
|
|
|
|
|
NV would lose accuracy over a direct conversion from PV to NV. If it |
1921
|
|
|
|
|
|
would, cache both conversions, flag similarly. |
1922
|
|
|
|
|
|
|
1923
|
|
|
|
|
|
Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite |
1924
|
|
|
|
|
|
correctly because if IV & NV were set NV *always* overruled. |
1925
|
|
|
|
|
|
Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning |
1926
|
|
|
|
|
|
changes - now IV and NV together means that the two are interchangeable: |
1927
|
|
|
|
|
|
SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; |
1928
|
|
|
|
|
|
|
1929
|
|
|
|
|
|
The benefit of this is that operations such as pp_add know that if |
1930
|
|
|
|
|
|
SvIOK is true for both left and right operands, then integer addition |
1931
|
|
|
|
|
|
can be used instead of floating point (for cases where the result won't |
1932
|
|
|
|
|
|
overflow). Before, floating point was always used, which could lead to |
1933
|
|
|
|
|
|
loss of precision compared with integer addition. |
1934
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
* making IV and NV equal status should make maths accurate on 64 bit |
1936
|
|
|
|
|
|
platforms |
1937
|
|
|
|
|
|
* may speed up maths somewhat if pp_add and friends start to use |
1938
|
|
|
|
|
|
integers when possible instead of fp. (Hopefully the overhead in |
1939
|
|
|
|
|
|
looking for SvIOK and checking for overflow will not outweigh the |
1940
|
|
|
|
|
|
fp to integer speedup) |
1941
|
|
|
|
|
|
* will slow down integer operations (callers of SvIV) on "inaccurate" |
1942
|
|
|
|
|
|
values, as the change from SvIOK to SvIOKp will cause a call into |
1943
|
|
|
|
|
|
sv_2iv each time rather than a macro access direct to the IV slot |
1944
|
|
|
|
|
|
* should speed up number->string conversion on integers as IV is |
1945
|
|
|
|
|
|
favoured when IV and NV are equally accurate |
1946
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
#################################################################### |
1948
|
|
|
|
|
|
You had better be using SvIOK_notUV if you want an IV for arithmetic: |
1949
|
|
|
|
|
|
SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. |
1950
|
|
|
|
|
|
On the other hand, SvUOK is true iff UV. |
1951
|
|
|
|
|
|
#################################################################### |
1952
|
|
|
|
|
|
|
1953
|
|
|
|
|
|
Your mileage will vary depending your CPU's relative fp to integer |
1954
|
|
|
|
|
|
performance ratio. |
1955
|
|
|
|
|
|
*/ |
1956
|
|
|
|
|
|
|
1957
|
|
|
|
|
|
#ifndef NV_PRESERVES_UV |
1958
|
|
|
|
|
|
# define IS_NUMBER_UNDERFLOW_IV 1 |
1959
|
|
|
|
|
|
# define IS_NUMBER_UNDERFLOW_UV 2 |
1960
|
|
|
|
|
|
# define IS_NUMBER_IV_AND_UV 2 |
1961
|
|
|
|
|
|
# define IS_NUMBER_OVERFLOW_IV 4 |
1962
|
|
|
|
|
|
# define IS_NUMBER_OVERFLOW_UV 5 |
1963
|
|
|
|
|
|
|
1964
|
|
|
|
|
|
/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ |
1965
|
|
|
|
|
|
|
1966
|
|
|
|
|
|
/* For sv_2nv these three cases are "SvNOK and don't bother casting" */ |
1967
|
|
|
|
|
|
STATIC int |
1968
|
22976
|
|
|
|
|
S_sv_2iuv_non_preserve(pTHX_ SV *const sv |
1969
|
|
|
|
|
|
# ifdef DEBUGGING |
1970
|
|
|
|
|
|
, I32 numtype |
1971
|
|
|
|
|
|
# endif |
1972
|
|
|
|
|
|
) |
1973
|
|
|
|
|
|
{ |
1974
|
|
|
|
|
|
dVAR; |
1975
|
|
|
|
|
|
|
1976
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; |
1977
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); |
1979
|
22976
|
100
|
|
|
|
if (SvNVX(sv) < (NV)IV_MIN) { |
1980
|
17118
|
|
|
|
|
(void)SvIOKp_on(sv); |
1981
|
17118
|
|
|
|
|
(void)SvNOK_on(sv); |
1982
|
17118
|
|
|
|
|
SvIV_set(sv, IV_MIN); |
1983
|
17118
|
|
|
|
|
return IS_NUMBER_UNDERFLOW_IV; |
1984
|
|
|
|
|
|
} |
1985
|
5858
|
100
|
|
|
|
if (SvNVX(sv) > (NV)UV_MAX) { |
1986
|
5744
|
|
|
|
|
(void)SvIOKp_on(sv); |
1987
|
5744
|
|
|
|
|
(void)SvNOK_on(sv); |
1988
|
5744
|
|
|
|
|
SvIsUV_on(sv); |
1989
|
5744
|
|
|
|
|
SvUV_set(sv, UV_MAX); |
1990
|
5744
|
|
|
|
|
return IS_NUMBER_OVERFLOW_UV; |
1991
|
|
|
|
|
|
} |
1992
|
114
|
|
|
|
|
(void)SvIOKp_on(sv); |
1993
|
114
|
|
|
|
|
(void)SvNOK_on(sv); |
1994
|
|
|
|
|
|
/* Can't use strtol etc to convert this string. (See truth table in |
1995
|
|
|
|
|
|
sv_2iv */ |
1996
|
114
|
50
|
|
|
|
if (SvNVX(sv) <= (UV)IV_MAX) { |
1997
|
0
|
|
|
|
|
SvIV_set(sv, I_V(SvNVX(sv))); |
1998
|
0
|
0
|
|
|
|
if ((NV)(SvIVX(sv)) == SvNVX(sv)) { |
1999
|
0
|
|
|
|
|
SvIOK_on(sv); /* Integer is precise. NOK, IOK */ |
2000
|
|
|
|
|
|
} else { |
2001
|
|
|
|
|
|
/* Integer is imprecise. NOK, IOKp */ |
2002
|
|
|
|
|
|
} |
2003
|
|
|
|
|
|
return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; |
2004
|
|
|
|
|
|
} |
2005
|
114
|
|
|
|
|
SvIsUV_on(sv); |
2006
|
114
|
|
|
|
|
SvUV_set(sv, U_V(SvNVX(sv))); |
2007
|
114
|
50
|
|
|
|
if ((NV)(SvUVX(sv)) == SvNVX(sv)) { |
2008
|
114
|
50
|
|
|
|
if (SvUVX(sv) == UV_MAX) { |
2009
|
|
|
|
|
|
/* As we know that NVs don't preserve UVs, UV_MAX cannot |
2010
|
|
|
|
|
|
possibly be preserved by NV. Hence, it must be overflow. |
2011
|
|
|
|
|
|
NOK, IOKp */ |
2012
|
|
|
|
|
|
return IS_NUMBER_OVERFLOW_UV; |
2013
|
|
|
|
|
|
} |
2014
|
11488
|
|
|
|
|
SvIOK_on(sv); /* Integer is precise. NOK, UOK */ |
2015
|
|
|
|
|
|
} else { |
2016
|
|
|
|
|
|
/* Integer is imprecise. NOK, IOKp */ |
2017
|
|
|
|
|
|
} |
2018
|
|
|
|
|
|
return IS_NUMBER_OVERFLOW_IV; |
2019
|
|
|
|
|
|
} |
2020
|
|
|
|
|
|
#endif /* !NV_PRESERVES_UV*/ |
2021
|
|
|
|
|
|
|
2022
|
|
|
|
|
|
STATIC bool |
2023
|
28046981
|
|
|
|
|
S_sv_2iuv_common(pTHX_ SV *const sv) |
2024
|
|
|
|
|
|
{ |
2025
|
|
|
|
|
|
dVAR; |
2026
|
|
|
|
|
|
|
2027
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2IUV_COMMON; |
2028
|
|
|
|
|
|
|
2029
|
28046981
|
100
|
|
|
|
if (SvNOKp(sv)) { |
2030
|
|
|
|
|
|
/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv |
2031
|
|
|
|
|
|
* without also getting a cached IV/UV from it at the same time |
2032
|
|
|
|
|
|
* (ie PV->NV conversion should detect loss of accuracy and cache |
2033
|
|
|
|
|
|
* IV or UV at same time to avoid this. */ |
2034
|
|
|
|
|
|
/* IV-over-UV optimisation - choose to cache IV if possible */ |
2035
|
|
|
|
|
|
|
2036
|
16304457
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_NV) |
2037
|
714435
|
|
|
|
|
sv_upgrade(sv, SVt_PVNV); |
2038
|
|
|
|
|
|
|
2039
|
16304457
|
|
|
|
|
(void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ |
2040
|
|
|
|
|
|
/* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost |
2041
|
|
|
|
|
|
certainly cast into the IV range at IV_MAX, whereas the correct |
2042
|
|
|
|
|
|
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary |
2043
|
|
|
|
|
|
cases go to UV */ |
2044
|
|
|
|
|
|
#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) |
2045
|
|
|
|
|
|
if (Perl_isnan(SvNVX(sv))) { |
2046
|
|
|
|
|
|
SvUV_set(sv, 0); |
2047
|
|
|
|
|
|
SvIsUV_on(sv); |
2048
|
|
|
|
|
|
return FALSE; |
2049
|
|
|
|
|
|
} |
2050
|
|
|
|
|
|
#endif |
2051
|
16304457
|
100
|
|
|
|
if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
2052
|
16289819
|
|
|
|
|
SvIV_set(sv, I_V(SvNVX(sv))); |
2053
|
16289819
|
100
|
|
|
|
if (SvNVX(sv) == (NV) SvIVX(sv) |
2054
|
|
|
|
|
|
#ifndef NV_PRESERVES_UV |
2055
|
6386230
|
100
|
|
|
|
&& (((UV)1 << NV_PRESERVES_UV_BITS) > |
2056
|
6386230
|
|
|
|
|
(UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) |
2057
|
|
|
|
|
|
/* Don't flag it as "accurately an integer" if the number |
2058
|
|
|
|
|
|
came from a (by definition imprecise) NV operation, and |
2059
|
|
|
|
|
|
we're outside the range of NV integer precision */ |
2060
|
|
|
|
|
|
#endif |
2061
|
|
|
|
|
|
) { |
2062
|
6384030
|
100
|
|
|
|
if (SvNOK(sv)) |
2063
|
6384022
|
|
|
|
|
SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ |
2064
|
|
|
|
|
|
else { |
2065
|
|
|
|
|
|
/* scalar has trailing garbage, eg "42a" */ |
2066
|
|
|
|
|
|
} |
2067
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, |
2068
|
|
|
|
|
|
"0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", |
2069
|
|
|
|
|
|
PTR2UV(sv), |
2070
|
|
|
|
|
|
SvNVX(sv), |
2071
|
|
|
|
|
|
SvIVX(sv))); |
2072
|
|
|
|
|
|
|
2073
|
|
|
|
|
|
} else { |
2074
|
|
|
|
|
|
/* IV not precise. No need to convert from PV, as NV |
2075
|
|
|
|
|
|
conversion would already have cached IV if it detected |
2076
|
|
|
|
|
|
that PV->IV would be better than PV->NV->IV |
2077
|
|
|
|
|
|
flags already correct - don't set public IOK. */ |
2078
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, |
2079
|
|
|
|
|
|
"0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", |
2080
|
|
|
|
|
|
PTR2UV(sv), |
2081
|
|
|
|
|
|
SvNVX(sv), |
2082
|
|
|
|
|
|
SvIVX(sv))); |
2083
|
|
|
|
|
|
} |
2084
|
|
|
|
|
|
/* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, |
2085
|
|
|
|
|
|
but the cast (NV)IV_MIN rounds to a the value less (more |
2086
|
|
|
|
|
|
negative) than IV_MIN which happens to be equal to SvNVX ?? |
2087
|
|
|
|
|
|
Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and |
2088
|
|
|
|
|
|
NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and |
2089
|
|
|
|
|
|
(NV)UVX == NVX are both true, but the values differ. :-( |
2090
|
|
|
|
|
|
Hopefully for 2s complement IV_MIN is something like |
2091
|
|
|
|
|
|
0x8000000000000000 which will be exact. NWC */ |
2092
|
|
|
|
|
|
} |
2093
|
|
|
|
|
|
else { |
2094
|
14638
|
|
|
|
|
SvUV_set(sv, U_V(SvNVX(sv))); |
2095
|
14638
|
100
|
|
|
|
if ( |
2096
|
14638
|
|
|
|
|
(SvNVX(sv) == (NV) SvUVX(sv)) |
2097
|
|
|
|
|
|
#ifndef NV_PRESERVES_UV |
2098
|
|
|
|
|
|
/* Make sure it's not 0xFFFFFFFFFFFFFFFF */ |
2099
|
|
|
|
|
|
/*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ |
2100
|
1160
|
50
|
|
|
|
&& (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) |
2101
|
|
|
|
|
|
/* Don't flag it as "accurately an integer" if the number |
2102
|
|
|
|
|
|
came from a (by definition imprecise) NV operation, and |
2103
|
|
|
|
|
|
we're outside the range of NV integer precision */ |
2104
|
|
|
|
|
|
#endif |
2105
|
0
|
0
|
|
|
|
&& SvNOK(sv) |
2106
|
|
|
|
|
|
) |
2107
|
0
|
|
|
|
|
SvIOK_on(sv); |
2108
|
14638
|
|
|
|
|
SvIsUV_on(sv); |
2109
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, |
2110
|
|
|
|
|
|
"0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", |
2111
|
|
|
|
|
|
PTR2UV(sv), |
2112
|
|
|
|
|
|
SvUVX(sv), |
2113
|
|
|
|
|
|
SvUVX(sv))); |
2114
|
|
|
|
|
|
} |
2115
|
|
|
|
|
|
} |
2116
|
11742524
|
100
|
|
|
|
else if (SvPOKp(sv)) { |
2117
|
|
|
|
|
|
UV value; |
2118
|
3423444
|
|
|
|
|
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); |
2119
|
|
|
|
|
|
/* We want to avoid a possible problem when we cache an IV/ a UV which |
2120
|
|
|
|
|
|
may be later translated to an NV, and the resulting NV is not |
2121
|
|
|
|
|
|
the same as the direct translation of the initial string |
2122
|
|
|
|
|
|
(eg 123.456 can shortcut to the IV 123 with atol(), but we must |
2123
|
|
|
|
|
|
be careful to ensure that the value with the .456 is around if the |
2124
|
|
|
|
|
|
NV value is requested in the future). |
2125
|
|
|
|
|
|
|
2126
|
|
|
|
|
|
This means that if we cache such an IV/a UV, we need to cache the |
2127
|
|
|
|
|
|
NV as well. Moreover, we trade speed for space, and do not |
2128
|
|
|
|
|
|
cache the NV if we are sure it's not needed. |
2129
|
|
|
|
|
|
*/ |
2130
|
|
|
|
|
|
|
2131
|
|
|
|
|
|
/* SVt_PVNV is one higher than SVt_PVIV, hence this order */ |
2132
|
3423444
|
100
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2133
|
|
|
|
|
|
== IS_NUMBER_IN_UV) { |
2134
|
|
|
|
|
|
/* It's definitely an integer, only upgrade to PVIV */ |
2135
|
3348820
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_PVIV) |
2136
|
812452
|
|
|
|
|
sv_upgrade(sv, SVt_PVIV); |
2137
|
3348820
|
|
|
|
|
(void)SvIOK_on(sv); |
2138
|
74624
|
100
|
|
|
|
} else if (SvTYPE(sv) < SVt_PVNV) |
2139
|
39240
|
|
|
|
|
sv_upgrade(sv, SVt_PVNV); |
2140
|
|
|
|
|
|
|
2141
|
|
|
|
|
|
/* If NVs preserve UVs then we only use the UV value if we know that |
2142
|
|
|
|
|
|
we aren't going to call atof() below. If NVs don't preserve UVs |
2143
|
|
|
|
|
|
then the value returned may have more precision than atof() will |
2144
|
|
|
|
|
|
return, even though value isn't perfectly accurate. */ |
2145
|
3423444
|
100
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV |
2146
|
|
|
|
|
|
#ifdef NV_PRESERVES_UV |
2147
|
|
|
|
|
|
| IS_NUMBER_NOT_INT |
2148
|
|
|
|
|
|
#endif |
2149
|
3423444
|
|
|
|
|
)) == IS_NUMBER_IN_UV) { |
2150
|
|
|
|
|
|
/* This won't turn off the public IOK flag if it was set above */ |
2151
|
3391576
|
|
|
|
|
(void)SvIOKp_on(sv); |
2152
|
|
|
|
|
|
|
2153
|
3391576
|
100
|
|
|
|
if (!(numtype & IS_NUMBER_NEG)) { |
2154
|
|
|
|
|
|
/* positive */; |
2155
|
3361862
|
100
|
|
|
|
if (value <= (UV)IV_MAX) { |
2156
|
3343770
|
|
|
|
|
SvIV_set(sv, (IV)value); |
2157
|
|
|
|
|
|
} else { |
2158
|
|
|
|
|
|
/* it didn't overflow, and it was positive. */ |
2159
|
18092
|
|
|
|
|
SvUV_set(sv, value); |
2160
|
18092
|
|
|
|
|
SvIsUV_on(sv); |
2161
|
|
|
|
|
|
} |
2162
|
|
|
|
|
|
} else { |
2163
|
|
|
|
|
|
/* 2s complement assumption */ |
2164
|
29714
|
50
|
|
|
|
if (value <= (UV)IV_MIN) { |
2165
|
29714
|
|
|
|
|
SvIV_set(sv, -(IV)value); |
2166
|
|
|
|
|
|
} else { |
2167
|
|
|
|
|
|
/* Too negative for an IV. This is a double upgrade, but |
2168
|
|
|
|
|
|
I'm assuming it will be rare. */ |
2169
|
0
|
0
|
|
|
|
if (SvTYPE(sv) < SVt_PVNV) |
2170
|
0
|
|
|
|
|
sv_upgrade(sv, SVt_PVNV); |
2171
|
0
|
|
|
|
|
SvNOK_on(sv); |
2172
|
0
|
|
|
|
|
SvIOK_off(sv); |
2173
|
0
|
|
|
|
|
SvIOKp_on(sv); |
2174
|
0
|
|
|
|
|
SvNV_set(sv, -(NV)value); |
2175
|
0
|
|
|
|
|
SvIV_set(sv, IV_MIN); |
2176
|
|
|
|
|
|
} |
2177
|
|
|
|
|
|
} |
2178
|
|
|
|
|
|
} |
2179
|
|
|
|
|
|
/* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we |
2180
|
|
|
|
|
|
will be in the previous block to set the IV slot, and the next |
2181
|
|
|
|
|
|
block to set the NV slot. So no else here. */ |
2182
|
|
|
|
|
|
|
2183
|
3423444
|
100
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2184
|
|
|
|
|
|
!= IS_NUMBER_IN_UV) { |
2185
|
|
|
|
|
|
/* It wasn't an (integer that doesn't overflow the UV). */ |
2186
|
74624
|
|
|
|
|
SvNV_set(sv, Atof(SvPVX_const(sv))); |
2187
|
|
|
|
|
|
|
2188
|
74624
|
100
|
|
|
|
if (! numtype && ckWARN(WARN_NUMERIC)) |
|
|
100
|
|
|
|
|
2189
|
54
|
|
|
|
|
not_a_number(sv); |
2190
|
|
|
|
|
|
|
2191
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
2192
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", |
2193
|
|
|
|
|
|
PTR2UV(sv), SvNVX(sv))); |
2194
|
|
|
|
|
|
#else |
2195
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", |
2196
|
|
|
|
|
|
PTR2UV(sv), SvNVX(sv))); |
2197
|
|
|
|
|
|
#endif |
2198
|
|
|
|
|
|
|
2199
|
|
|
|
|
|
#ifdef NV_PRESERVES_UV |
2200
|
|
|
|
|
|
(void)SvIOKp_on(sv); |
2201
|
|
|
|
|
|
(void)SvNOK_on(sv); |
2202
|
|
|
|
|
|
if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
2203
|
|
|
|
|
|
SvIV_set(sv, I_V(SvNVX(sv))); |
2204
|
|
|
|
|
|
if ((NV)(SvIVX(sv)) == SvNVX(sv)) { |
2205
|
|
|
|
|
|
SvIOK_on(sv); |
2206
|
|
|
|
|
|
} else { |
2207
|
|
|
|
|
|
NOOP; /* Integer is imprecise. NOK, IOKp */ |
2208
|
|
|
|
|
|
} |
2209
|
|
|
|
|
|
/* UV will not work better than IV */ |
2210
|
|
|
|
|
|
} else { |
2211
|
|
|
|
|
|
if (SvNVX(sv) > (NV)UV_MAX) { |
2212
|
|
|
|
|
|
SvIsUV_on(sv); |
2213
|
|
|
|
|
|
/* Integer is inaccurate. NOK, IOKp, is UV */ |
2214
|
|
|
|
|
|
SvUV_set(sv, UV_MAX); |
2215
|
|
|
|
|
|
} else { |
2216
|
|
|
|
|
|
SvUV_set(sv, U_V(SvNVX(sv))); |
2217
|
|
|
|
|
|
/* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs |
2218
|
|
|
|
|
|
NV preservse UV so can do correct comparison. */ |
2219
|
|
|
|
|
|
if ((NV)(SvUVX(sv)) == SvNVX(sv)) { |
2220
|
|
|
|
|
|
SvIOK_on(sv); |
2221
|
|
|
|
|
|
} else { |
2222
|
|
|
|
|
|
NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ |
2223
|
|
|
|
|
|
} |
2224
|
|
|
|
|
|
} |
2225
|
|
|
|
|
|
SvIsUV_on(sv); |
2226
|
|
|
|
|
|
} |
2227
|
|
|
|
|
|
#else /* NV_PRESERVES_UV */ |
2228
|
74612
|
100
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2229
|
|
|
|
|
|
== (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { |
2230
|
|
|
|
|
|
/* The IV/UV slot will have been set from value returned by |
2231
|
|
|
|
|
|
grok_number above. The NV slot has just been set using |
2232
|
|
|
|
|
|
Atof. */ |
2233
|
42756
|
|
|
|
|
SvNOK_on(sv); |
2234
|
|
|
|
|
|
assert (SvIOKp(sv)); |
2235
|
|
|
|
|
|
} else { |
2236
|
31856
|
100
|
|
|
|
if (((UV)1 << NV_PRESERVES_UV_BITS) > |
2237
|
31856
|
100
|
|
|
|
U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { |
2238
|
|
|
|
|
|
/* Small enough to preserve all bits. */ |
2239
|
8880
|
|
|
|
|
(void)SvIOKp_on(sv); |
2240
|
8880
|
|
|
|
|
SvNOK_on(sv); |
2241
|
8880
|
|
|
|
|
SvIV_set(sv, I_V(SvNVX(sv))); |
2242
|
8880
|
100
|
|
|
|
if ((NV)(SvIVX(sv)) == SvNVX(sv)) |
2243
|
8374
|
|
|
|
|
SvIOK_on(sv); |
2244
|
|
|
|
|
|
/* Assumption: first non-preserved integer is < IV_MAX, |
2245
|
|
|
|
|
|
this NV is in the preserved range, therefore: */ |
2246
|
8880
|
100
|
|
|
|
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) |
|
|
50
|
|
|
|
|
2247
|
|
|
|
|
|
< (UV)IV_MAX)) { |
2248
|
0
|
|
|
|
|
Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); |
2249
|
|
|
|
|
|
} |
2250
|
|
|
|
|
|
} else { |
2251
|
|
|
|
|
|
/* IN_UV NOT_INT |
2252
|
|
|
|
|
|
0 0 already failed to read UV. |
2253
|
|
|
|
|
|
0 1 already failed to read UV. |
2254
|
|
|
|
|
|
1 0 you won't get here in this case. IV/UV |
2255
|
|
|
|
|
|
slot set, public IOK, Atof() unneeded. |
2256
|
|
|
|
|
|
1 1 already read UV. |
2257
|
|
|
|
|
|
so there's no point in sv_2iuv_non_preserve() attempting |
2258
|
|
|
|
|
|
to use atol, strtol, strtoul etc. */ |
2259
|
|
|
|
|
|
# ifdef DEBUGGING |
2260
|
|
|
|
|
|
sv_2iuv_non_preserve (sv, numtype); |
2261
|
|
|
|
|
|
# else |
2262
|
22976
|
|
|
|
|
sv_2iuv_non_preserve (sv); |
2263
|
|
|
|
|
|
# endif |
2264
|
|
|
|
|
|
} |
2265
|
|
|
|
|
|
} |
2266
|
|
|
|
|
|
#endif /* NV_PRESERVES_UV */ |
2267
|
|
|
|
|
|
/* It might be more code efficient to go through the entire logic above |
2268
|
|
|
|
|
|
and conditionally set with SvIOKp_on() rather than SvIOK(), but it |
2269
|
|
|
|
|
|
gets complex and potentially buggy, so more programmer efficient |
2270
|
|
|
|
|
|
to do it this way, by turning off the public flags: */ |
2271
|
74612
|
100
|
|
|
|
if (!numtype) |
2272
|
6720
|
|
|
|
|
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); |
2273
|
|
|
|
|
|
} |
2274
|
|
|
|
|
|
} |
2275
|
|
|
|
|
|
else { |
2276
|
8319080
|
100
|
|
|
|
if (isGV_with_GP(sv)) |
|
|
50
|
|
|
|
|
2277
|
18
|
|
|
|
|
return glob_2number(MUTABLE_GV(sv)); |
2278
|
|
|
|
|
|
|
2279
|
8319062
|
100
|
|
|
|
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
|
|
100
|
|
|
|
|
2280
|
274
|
|
|
|
|
report_uninit(sv); |
2281
|
8319062
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_IV) |
2282
|
|
|
|
|
|
/* Typically the caller expects that sv_any is not NULL now. */ |
2283
|
14047762
|
|
|
|
|
sv_upgrade(sv, SVt_IV); |
2284
|
|
|
|
|
|
/* Return 0 from the caller. */ |
2285
|
|
|
|
|
|
return TRUE; |
2286
|
|
|
|
|
|
} |
2287
|
|
|
|
|
|
return FALSE; |
2288
|
|
|
|
|
|
} |
2289
|
|
|
|
|
|
|
2290
|
|
|
|
|
|
/* |
2291
|
|
|
|
|
|
=for apidoc sv_2iv_flags |
2292
|
|
|
|
|
|
|
2293
|
|
|
|
|
|
Return the integer value of an SV, doing any necessary string |
2294
|
|
|
|
|
|
conversion. If flags includes SV_GMAGIC, does an mg_get() first. |
2295
|
|
|
|
|
|
Normally used via the C and C macros. |
2296
|
|
|
|
|
|
|
2297
|
|
|
|
|
|
=cut |
2298
|
|
|
|
|
|
*/ |
2299
|
|
|
|
|
|
|
2300
|
|
|
|
|
|
IV |
2301
|
27762857
|
|
|
|
|
Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) |
2302
|
|
|
|
|
|
{ |
2303
|
|
|
|
|
|
dVAR; |
2304
|
|
|
|
|
|
|
2305
|
27762857
|
50
|
|
|
|
if (!sv) |
2306
|
|
|
|
|
|
return 0; |
2307
|
|
|
|
|
|
|
2308
|
|
|
|
|
|
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2309
|
|
|
|
|
|
&& SvTYPE(sv) != SVt_PVFM); |
2310
|
|
|
|
|
|
|
2311
|
27762857
|
100
|
|
|
|
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) |
|
|
100
|
|
|
|
|
2312
|
23688
|
|
|
|
|
mg_get(sv); |
2313
|
|
|
|
|
|
|
2314
|
27762857
|
100
|
|
|
|
if (SvROK(sv)) { |
2315
|
70282
|
50
|
|
|
|
if (SvAMAGIC(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2316
|
|
|
|
|
|
SV * tmpstr; |
2317
|
498
|
50
|
|
|
|
if (flags & SV_SKIP_OVERLOAD) |
2318
|
|
|
|
|
|
return 0; |
2319
|
498
|
|
|
|
|
tmpstr = AMG_CALLunary(sv, numer_amg); |
2320
|
498
|
50
|
|
|
|
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
2321
|
498
|
100
|
|
|
|
return SvIV(tmpstr); |
2322
|
|
|
|
|
|
} |
2323
|
|
|
|
|
|
} |
2324
|
69784
|
|
|
|
|
return PTR2IV(SvRV(sv)); |
2325
|
|
|
|
|
|
} |
2326
|
|
|
|
|
|
|
2327
|
27692575
|
50
|
|
|
|
if (SvVALID(sv) || isREGEXP(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2328
|
|
|
|
|
|
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
2329
|
|
|
|
|
|
the same flag bit as SVf_IVisUV, so must not let them cache IVs. |
2330
|
|
|
|
|
|
In practice they are extremely unlikely to actually get anywhere |
2331
|
|
|
|
|
|
accessible by user Perl code - the only way that I'm aware of is when |
2332
|
|
|
|
|
|
a constant subroutine which is used as the second argument to index. |
2333
|
|
|
|
|
|
|
2334
|
|
|
|
|
|
Regexps have no SvIVX and SvNVX fields. |
2335
|
|
|
|
|
|
*/ |
2336
|
|
|
|
|
|
assert(isREGEXP(sv) || SvPOKp(sv)); |
2337
|
|
|
|
|
|
{ |
2338
|
|
|
|
|
|
UV value; |
2339
|
|
|
|
|
|
const char * const ptr = |
2340
|
3
|
50
|
|
|
|
isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); |
|
|
0
|
|
|
|
|
2341
|
2
|
|
|
|
|
const int numtype |
2342
|
2
|
|
|
|
|
= grok_number(ptr, SvCUR(sv), &value); |
2343
|
|
|
|
|
|
|
2344
|
2
|
50
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2345
|
|
|
|
|
|
== IS_NUMBER_IN_UV) { |
2346
|
|
|
|
|
|
/* It's definitely an integer */ |
2347
|
0
|
0
|
|
|
|
if (numtype & IS_NUMBER_NEG) { |
2348
|
0
|
0
|
|
|
|
if (value < (UV)IV_MIN) |
2349
|
0
|
|
|
|
|
return -(IV)value; |
2350
|
|
|
|
|
|
} else { |
2351
|
0
|
0
|
|
|
|
if (value < (UV)IV_MAX) |
2352
|
0
|
|
|
|
|
return (IV)value; |
2353
|
|
|
|
|
|
} |
2354
|
|
|
|
|
|
} |
2355
|
2
|
50
|
|
|
|
if (!numtype) { |
2356
|
2
|
50
|
|
|
|
if (ckWARN(WARN_NUMERIC)) |
2357
|
0
|
|
|
|
|
not_a_number(sv); |
2358
|
|
|
|
|
|
} |
2359
|
2
|
|
|
|
|
return I_V(Atof(ptr)); |
2360
|
|
|
|
|
|
} |
2361
|
|
|
|
|
|
} |
2362
|
|
|
|
|
|
|
2363
|
27692573
|
100
|
|
|
|
if (SvTHINKFIRST(sv)) { |
2364
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
2365
|
|
|
|
|
|
if (SvIsCOW(sv)) { |
2366
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
2367
|
|
|
|
|
|
} |
2368
|
|
|
|
|
|
#endif |
2369
|
2097016
|
100
|
|
|
|
if (SvREADONLY(sv) && !SvOK(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2370
|
74
|
100
|
|
|
|
if (ckWARN(WARN_UNINITIALIZED)) |
2371
|
32
|
|
|
|
|
report_uninit(sv); |
2372
|
|
|
|
|
|
return 0; |
2373
|
|
|
|
|
|
} |
2374
|
|
|
|
|
|
} |
2375
|
|
|
|
|
|
|
2376
|
27692499
|
100
|
|
|
|
if (!SvIOKp(sv)) { |
2377
|
27668001
|
100
|
|
|
|
if (S_sv_2iuv_common(aTHX_ sv)) |
2378
|
|
|
|
|
|
return 0; |
2379
|
|
|
|
|
|
} |
2380
|
|
|
|
|
|
|
2381
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", |
2382
|
|
|
|
|
|
PTR2UV(sv),SvIVX(sv))); |
2383
|
23569127
|
100
|
|
|
|
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); |
2384
|
|
|
|
|
|
} |
2385
|
|
|
|
|
|
|
2386
|
|
|
|
|
|
/* |
2387
|
|
|
|
|
|
=for apidoc sv_2uv_flags |
2388
|
|
|
|
|
|
|
2389
|
|
|
|
|
|
Return the unsigned integer value of an SV, doing any necessary string |
2390
|
|
|
|
|
|
conversion. If flags includes SV_GMAGIC, does an mg_get() first. |
2391
|
|
|
|
|
|
Normally used via the C and C macros. |
2392
|
|
|
|
|
|
|
2393
|
|
|
|
|
|
=cut |
2394
|
|
|
|
|
|
*/ |
2395
|
|
|
|
|
|
|
2396
|
|
|
|
|
|
UV |
2397
|
28676011
|
|
|
|
|
Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) |
2398
|
|
|
|
|
|
{ |
2399
|
|
|
|
|
|
dVAR; |
2400
|
|
|
|
|
|
|
2401
|
28676011
|
50
|
|
|
|
if (!sv) |
2402
|
|
|
|
|
|
return 0; |
2403
|
|
|
|
|
|
|
2404
|
28676011
|
100
|
|
|
|
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) |
|
|
100
|
|
|
|
|
2405
|
12
|
|
|
|
|
mg_get(sv); |
2406
|
|
|
|
|
|
|
2407
|
28676011
|
100
|
|
|
|
if (SvROK(sv)) { |
2408
|
12498064
|
50
|
|
|
|
if (SvAMAGIC(sv)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2409
|
|
|
|
|
|
SV *tmpstr; |
2410
|
12495574
|
50
|
|
|
|
if (flags & SV_SKIP_OVERLOAD) |
2411
|
|
|
|
|
|
return 0; |
2412
|
12495574
|
|
|
|
|
tmpstr = AMG_CALLunary(sv, numer_amg); |
2413
|
12495574
|
100
|
|
|
|
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
2414
|
6
|
50
|
|
|
|
return SvUV(tmpstr); |
2415
|
|
|
|
|
|
} |
2416
|
|
|
|
|
|
} |
2417
|
12498058
|
|
|
|
|
return PTR2UV(SvRV(sv)); |
2418
|
|
|
|
|
|
} |
2419
|
|
|
|
|
|
|
2420
|
16177947
|
50
|
|
|
|
if (SvVALID(sv) || isREGEXP(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2421
|
|
|
|
|
|
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
2422
|
|
|
|
|
|
the same flag bit as SVf_IVisUV, so must not let them cache IVs. |
2423
|
|
|
|
|
|
Regexps have no SvIVX and SvNVX fields. */ |
2424
|
|
|
|
|
|
assert(isREGEXP(sv) || SvPOKp(sv)); |
2425
|
|
|
|
|
|
{ |
2426
|
|
|
|
|
|
UV value; |
2427
|
|
|
|
|
|
const char * const ptr = |
2428
|
3
|
50
|
|
|
|
isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); |
|
|
0
|
|
|
|
|
2429
|
2
|
|
|
|
|
const int numtype |
2430
|
2
|
|
|
|
|
= grok_number(ptr, SvCUR(sv), &value); |
2431
|
|
|
|
|
|
|
2432
|
2
|
50
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2433
|
|
|
|
|
|
== IS_NUMBER_IN_UV) { |
2434
|
|
|
|
|
|
/* It's definitely an integer */ |
2435
|
0
|
0
|
|
|
|
if (!(numtype & IS_NUMBER_NEG)) |
2436
|
0
|
|
|
|
|
return value; |
2437
|
|
|
|
|
|
} |
2438
|
2
|
50
|
|
|
|
if (!numtype) { |
2439
|
2
|
50
|
|
|
|
if (ckWARN(WARN_NUMERIC)) |
2440
|
0
|
|
|
|
|
not_a_number(sv); |
2441
|
|
|
|
|
|
} |
2442
|
2
|
|
|
|
|
return U_V(Atof(ptr)); |
2443
|
|
|
|
|
|
} |
2444
|
|
|
|
|
|
} |
2445
|
|
|
|
|
|
|
2446
|
16177945
|
100
|
|
|
|
if (SvTHINKFIRST(sv)) { |
2447
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
2448
|
|
|
|
|
|
if (SvIsCOW(sv)) { |
2449
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
2450
|
|
|
|
|
|
} |
2451
|
|
|
|
|
|
#endif |
2452
|
2978976
|
100
|
|
|
|
if (SvREADONLY(sv) && !SvOK(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2453
|
12
|
100
|
|
|
|
if (ckWARN(WARN_UNINITIALIZED)) |
2454
|
8
|
|
|
|
|
report_uninit(sv); |
2455
|
|
|
|
|
|
return 0; |
2456
|
|
|
|
|
|
} |
2457
|
|
|
|
|
|
} |
2458
|
|
|
|
|
|
|
2459
|
16177933
|
100
|
|
|
|
if (!SvIOKp(sv)) { |
2460
|
378980
|
100
|
|
|
|
if (S_sv_2iuv_common(aTHX_ sv)) |
2461
|
|
|
|
|
|
return 0; |
2462
|
|
|
|
|
|
} |
2463
|
|
|
|
|
|
|
2464
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", |
2465
|
|
|
|
|
|
PTR2UV(sv),SvUVX(sv))); |
2466
|
22425969
|
100
|
|
|
|
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); |
2467
|
|
|
|
|
|
} |
2468
|
|
|
|
|
|
|
2469
|
|
|
|
|
|
/* |
2470
|
|
|
|
|
|
=for apidoc sv_2nv_flags |
2471
|
|
|
|
|
|
|
2472
|
|
|
|
|
|
Return the num value of an SV, doing any necessary string or integer |
2473
|
|
|
|
|
|
conversion. If flags includes SV_GMAGIC, does an mg_get() first. |
2474
|
|
|
|
|
|
Normally used via the C and C macros. |
2475
|
|
|
|
|
|
|
2476
|
|
|
|
|
|
=cut |
2477
|
|
|
|
|
|
*/ |
2478
|
|
|
|
|
|
|
2479
|
|
|
|
|
|
NV |
2480
|
8993530
|
|
|
|
|
Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) |
2481
|
|
|
|
|
|
{ |
2482
|
|
|
|
|
|
dVAR; |
2483
|
8993530
|
50
|
|
|
|
if (!sv) |
2484
|
|
|
|
|
|
return 0.0; |
2485
|
|
|
|
|
|
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2486
|
|
|
|
|
|
&& SvTYPE(sv) != SVt_PVFM); |
2487
|
8993530
|
100
|
|
|
|
if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2488
|
|
|
|
|
|
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
2489
|
|
|
|
|
|
the same flag bit as SVf_IVisUV, so must not let them cache NVs. |
2490
|
|
|
|
|
|
Regexps have no SvIVX and SvNVX fields. */ |
2491
|
|
|
|
|
|
const char *ptr; |
2492
|
696
|
100
|
|
|
|
if (flags & SV_GMAGIC) |
2493
|
460
|
|
|
|
|
mg_get(sv); |
2494
|
696
|
100
|
|
|
|
if (SvNOKp(sv)) |
2495
|
8
|
|
|
|
|
return SvNVX(sv); |
2496
|
688
|
100
|
|
|
|
if (SvPOKp(sv) && !SvIOKp(sv)) { |
2497
|
32
|
|
|
|
|
ptr = SvPVX_const(sv); |
2498
|
|
|
|
|
|
grokpv: |
2499
|
54
|
50
|
|
|
|
if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && |
2500
|
12
|
|
|
|
|
!grok_number(ptr, SvCUR(sv), NULL)) |
2501
|
4
|
|
|
|
|
not_a_number(sv); |
2502
|
42
|
|
|
|
|
return Atof(ptr); |
2503
|
|
|
|
|
|
} |
2504
|
656
|
100
|
|
|
|
if (SvIOKp(sv)) { |
2505
|
602
|
50
|
|
|
|
if (SvIsUV(sv)) |
2506
|
0
|
|
|
|
|
return (NV)SvUVX(sv); |
2507
|
|
|
|
|
|
else |
2508
|
602
|
|
|
|
|
return (NV)SvIVX(sv); |
2509
|
|
|
|
|
|
} |
2510
|
54
|
50
|
|
|
|
if (SvROK(sv)) { |
2511
|
|
|
|
|
|
goto return_rok; |
2512
|
|
|
|
|
|
} |
2513
|
54
|
100
|
|
|
|
if (isREGEXP(sv)) { |
|
|
50
|
|
|
|
|
2514
|
10
|
|
|
|
|
ptr = RX_WRAPPED((REGEXP *)sv); |
2515
|
10
|
|
|
|
|
goto grokpv; |
2516
|
|
|
|
|
|
} |
2517
|
|
|
|
|
|
assert(SvTYPE(sv) >= SVt_PVMG); |
2518
|
|
|
|
|
|
/* This falls through to the report_uninit near the end of the |
2519
|
|
|
|
|
|
function. */ |
2520
|
8992834
|
100
|
|
|
|
} else if (SvTHINKFIRST(sv)) { |
2521
|
893742
|
100
|
|
|
|
if (SvROK(sv)) { |
2522
|
|
|
|
|
|
return_rok: |
2523
|
52
|
50
|
|
|
|
if (SvAMAGIC(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2524
|
|
|
|
|
|
SV *tmpstr; |
2525
|
52
|
50
|
|
|
|
if (flags & SV_SKIP_OVERLOAD) |
2526
|
|
|
|
|
|
return 0; |
2527
|
52
|
|
|
|
|
tmpstr = AMG_CALLunary(sv, numer_amg); |
2528
|
52
|
100
|
|
|
|
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
2529
|
44
|
100
|
|
|
|
return SvNV(tmpstr); |
2530
|
|
|
|
|
|
} |
2531
|
|
|
|
|
|
} |
2532
|
8
|
|
|
|
|
return PTR2NV(SvRV(sv)); |
2533
|
|
|
|
|
|
} |
2534
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
2535
|
|
|
|
|
|
if (SvIsCOW(sv)) { |
2536
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
2537
|
|
|
|
|
|
} |
2538
|
|
|
|
|
|
#endif |
2539
|
893690
|
100
|
|
|
|
if (SvREADONLY(sv) && !SvOK(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
2540
|
405766
|
100
|
|
|
|
if (ckWARN(WARN_UNINITIALIZED)) |
2541
|
174
|
|
|
|
|
report_uninit(sv); |
2542
|
|
|
|
|
|
return 0.0; |
2543
|
|
|
|
|
|
} |
2544
|
|
|
|
|
|
} |
2545
|
8587060
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_NV) { |
2546
|
|
|
|
|
|
/* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ |
2547
|
1934284
|
|
|
|
|
sv_upgrade(sv, SVt_NV); |
2548
|
|
|
|
|
|
#ifdef USE_LONG_DOUBLE |
2549
|
|
|
|
|
|
DEBUG_c({ |
2550
|
|
|
|
|
|
STORE_NUMERIC_LOCAL_SET_STANDARD(); |
2551
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, |
2552
|
|
|
|
|
|
"0x%"UVxf" num(%" PERL_PRIgldbl ")\n", |
2553
|
|
|
|
|
|
PTR2UV(sv), SvNVX(sv)); |
2554
|
|
|
|
|
|
RESTORE_NUMERIC_LOCAL(); |
2555
|
|
|
|
|
|
}); |
2556
|
|
|
|
|
|
#else |
2557
|
|
|
|
|
|
DEBUG_c({ |
2558
|
|
|
|
|
|
STORE_NUMERIC_LOCAL_SET_STANDARD(); |
2559
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", |
2560
|
|
|
|
|
|
PTR2UV(sv), SvNVX(sv)); |
2561
|
|
|
|
|
|
RESTORE_NUMERIC_LOCAL(); |
2562
|
|
|
|
|
|
}); |
2563
|
|
|
|
|
|
#endif |
2564
|
|
|
|
|
|
} |
2565
|
6652776
|
100
|
|
|
|
else if (SvTYPE(sv) < SVt_PVNV) |
2566
|
3070706
|
|
|
|
|
sv_upgrade(sv, SVt_PVNV); |
2567
|
8587060
|
100
|
|
|
|
if (SvNOKp(sv)) { |
2568
|
23814
|
|
|
|
|
return SvNVX(sv); |
2569
|
|
|
|
|
|
} |
2570
|
8563246
|
100
|
|
|
|
if (SvIOKp(sv)) { |
2571
|
8222466
|
100
|
|
|
|
SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); |
2572
|
|
|
|
|
|
#ifdef NV_PRESERVES_UV |
2573
|
|
|
|
|
|
if (SvIOK(sv)) |
2574
|
|
|
|
|
|
SvNOK_on(sv); |
2575
|
|
|
|
|
|
else |
2576
|
|
|
|
|
|
SvNOKp_on(sv); |
2577
|
|
|
|
|
|
#else |
2578
|
|
|
|
|
|
/* Only set the public NV OK flag if this NV preserves the IV */ |
2579
|
|
|
|
|
|
/* Check it's not 0xFFFFFFFFFFFFFFFF */ |
2580
|
20511392
|
50
|
|
|
|
if (SvIOK(sv) && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2581
|
4072435
|
100
|
|
|
|
SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) |
2582
|
8215650
|
|
|
|
|
: (SvIVX(sv) == I_V(SvNVX(sv)))) |
2583
|
8211708
|
|
|
|
|
SvNOK_on(sv); |
2584
|
|
|
|
|
|
else |
2585
|
10758
|
|
|
|
|
SvNOKp_on(sv); |
2586
|
|
|
|
|
|
#endif |
2587
|
|
|
|
|
|
} |
2588
|
340780
|
100
|
|
|
|
else if (SvPOKp(sv)) { |
2589
|
|
|
|
|
|
UV value; |
2590
|
336584
|
|
|
|
|
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); |
2591
|
336584
|
100
|
|
|
|
if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) |
|
|
100
|
|
|
|
|
2592
|
2
|
|
|
|
|
not_a_number(sv); |
2593
|
|
|
|
|
|
#ifdef NV_PRESERVES_UV |
2594
|
|
|
|
|
|
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2595
|
|
|
|
|
|
== IS_NUMBER_IN_UV) { |
2596
|
|
|
|
|
|
/* It's definitely an integer */ |
2597
|
|
|
|
|
|
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); |
2598
|
|
|
|
|
|
} else |
2599
|
|
|
|
|
|
SvNV_set(sv, Atof(SvPVX_const(sv))); |
2600
|
|
|
|
|
|
if (numtype) |
2601
|
|
|
|
|
|
SvNOK_on(sv); |
2602
|
|
|
|
|
|
else |
2603
|
|
|
|
|
|
SvNOKp_on(sv); |
2604
|
|
|
|
|
|
#else |
2605
|
336582
|
|
|
|
|
SvNV_set(sv, Atof(SvPVX_const(sv))); |
2606
|
|
|
|
|
|
/* Only set the public NV OK flag if this NV preserves the value in |
2607
|
|
|
|
|
|
the PV at least as well as an IV/UV would. |
2608
|
|
|
|
|
|
Not sure how to do this 100% reliably. */ |
2609
|
|
|
|
|
|
/* if that shift count is out of range then Configure's test is |
2610
|
|
|
|
|
|
wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == |
2611
|
|
|
|
|
|
UV_BITS */ |
2612
|
336582
|
100
|
|
|
|
if (((UV)1 << NV_PRESERVES_UV_BITS) > |
2613
|
336582
|
100
|
|
|
|
U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { |
2614
|
334058
|
|
|
|
|
SvNOK_on(sv); /* Definitely small enough to preserve all bits */ |
2615
|
2524
|
100
|
|
|
|
} else if (!(numtype & IS_NUMBER_IN_UV)) { |
2616
|
|
|
|
|
|
/* Can't use strtol etc to convert this string, so don't try. |
2617
|
|
|
|
|
|
sv_2iv and sv_2uv will use the NV to convert, not the PV. */ |
2618
|
718
|
|
|
|
|
SvNOK_on(sv); |
2619
|
|
|
|
|
|
} else { |
2620
|
|
|
|
|
|
/* value has been set. It may not be precise. */ |
2621
|
1806
|
100
|
|
|
|
if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { |
|
|
50
|
|
|
|
|
2622
|
|
|
|
|
|
/* 2s complement assumption for (UV)IV_MIN */ |
2623
|
0
|
|
|
|
|
SvNOK_on(sv); /* Integer is too negative. */ |
2624
|
|
|
|
|
|
} else { |
2625
|
1806
|
|
|
|
|
SvNOKp_on(sv); |
2626
|
1806
|
|
|
|
|
SvIOKp_on(sv); |
2627
|
|
|
|
|
|
|
2628
|
1806
|
100
|
|
|
|
if (numtype & IS_NUMBER_NEG) { |
2629
|
594
|
|
|
|
|
SvIV_set(sv, -(IV)value); |
2630
|
1212
|
100
|
|
|
|
} else if (value <= (UV)IV_MAX) { |
2631
|
462
|
|
|
|
|
SvIV_set(sv, (IV)value); |
2632
|
|
|
|
|
|
} else { |
2633
|
750
|
|
|
|
|
SvUV_set(sv, value); |
2634
|
750
|
|
|
|
|
SvIsUV_on(sv); |
2635
|
|
|
|
|
|
} |
2636
|
|
|
|
|
|
|
2637
|
1806
|
50
|
|
|
|
if (numtype & IS_NUMBER_NOT_INT) { |
2638
|
|
|
|
|
|
/* I believe that even if the original PV had decimals, |
2639
|
|
|
|
|
|
they are lost beyond the limit of the FP precision. |
2640
|
|
|
|
|
|
However, neither is canonical, so both only get p |
2641
|
|
|
|
|
|
flags. NWC, 2000/11/25 */ |
2642
|
|
|
|
|
|
/* Both already have p flags, so do nothing */ |
2643
|
|
|
|
|
|
} else { |
2644
|
1806
|
|
|
|
|
const NV nv = SvNVX(sv); |
2645
|
1806
|
100
|
|
|
|
if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
2646
|
1042
|
100
|
|
|
|
if (SvIVX(sv) == I_V(nv)) { |
2647
|
246
|
|
|
|
|
SvNOK_on(sv); |
2648
|
|
|
|
|
|
} else { |
2649
|
|
|
|
|
|
/* It had no "." so it must be integer. */ |
2650
|
|
|
|
|
|
} |
2651
|
1042
|
|
|
|
|
SvIOK_on(sv); |
2652
|
|
|
|
|
|
} else { |
2653
|
|
|
|
|
|
/* between IV_MAX and NV(UV_MAX). |
2654
|
|
|
|
|
|
Could be slightly > UV_MAX */ |
2655
|
|
|
|
|
|
|
2656
|
764
|
50
|
|
|
|
if (numtype & IS_NUMBER_NOT_INT) { |
2657
|
|
|
|
|
|
/* UV and NV both imprecise. */ |
2658
|
|
|
|
|
|
} else { |
2659
|
764
|
|
|
|
|
const UV nv_as_uv = U_V(nv); |
2660
|
|
|
|
|
|
|
2661
|
764
|
100
|
|
|
|
if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { |
|
|
100
|
|
|
|
|
2662
|
246
|
|
|
|
|
SvNOK_on(sv); |
2663
|
|
|
|
|
|
} |
2664
|
764
|
|
|
|
|
SvIOK_on(sv); |
2665
|
|
|
|
|
|
} |
2666
|
|
|
|
|
|
} |
2667
|
|
|
|
|
|
} |
2668
|
|
|
|
|
|
} |
2669
|
|
|
|
|
|
} |
2670
|
|
|
|
|
|
/* It might be more code efficient to go through the entire logic above |
2671
|
|
|
|
|
|
and conditionally set with SvNOKp_on() rather than SvNOK(), but it |
2672
|
|
|
|
|
|
gets complex and potentially buggy, so more programmer efficient |
2673
|
|
|
|
|
|
to do it this way, by turning off the public flags: */ |
2674
|
336582
|
100
|
|
|
|
if (!numtype) |
2675
|
1656
|
|
|
|
|
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); |
2676
|
|
|
|
|
|
#endif /* NV_PRESERVES_UV */ |
2677
|
|
|
|
|
|
} |
2678
|
|
|
|
|
|
else { |
2679
|
4196
|
100
|
|
|
|
if (isGV_with_GP(sv)) { |
|
|
50
|
|
|
|
|
2680
|
32
|
|
|
|
|
glob_2number(MUTABLE_GV(sv)); |
2681
|
32
|
|
|
|
|
return 0.0; |
2682
|
|
|
|
|
|
} |
2683
|
|
|
|
|
|
|
2684
|
4164
|
50
|
|
|
|
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
|
|
100
|
|
|
|
|
2685
|
306
|
|
|
|
|
report_uninit(sv); |
2686
|
|
|
|
|
|
assert (SvTYPE(sv) >= SVt_NV); |
2687
|
|
|
|
|
|
/* Typically the caller expects that sv_any is not NULL now. */ |
2688
|
|
|
|
|
|
/* XXX Ilya implies that this is a bug in callers that assume this |
2689
|
|
|
|
|
|
and ideally should be fixed. */ |
2690
|
|
|
|
|
|
return 0.0; |
2691
|
|
|
|
|
|
} |
2692
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
2693
|
|
|
|
|
|
DEBUG_c({ |
2694
|
|
|
|
|
|
STORE_NUMERIC_LOCAL_SET_STANDARD(); |
2695
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", |
2696
|
|
|
|
|
|
PTR2UV(sv), SvNVX(sv)); |
2697
|
|
|
|
|
|
RESTORE_NUMERIC_LOCAL(); |
2698
|
|
|
|
|
|
}); |
2699
|
|
|
|
|
|
#else |
2700
|
|
|
|
|
|
DEBUG_c({ |
2701
|
|
|
|
|
|
STORE_NUMERIC_LOCAL_SET_STANDARD(); |
2702
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", |
2703
|
|
|
|
|
|
PTR2UV(sv), SvNVX(sv)); |
2704
|
|
|
|
|
|
RESTORE_NUMERIC_LOCAL(); |
2705
|
|
|
|
|
|
}); |
2706
|
|
|
|
|
|
#endif |
2707
|
8776288
|
|
|
|
|
return SvNVX(sv); |
2708
|
|
|
|
|
|
} |
2709
|
|
|
|
|
|
|
2710
|
|
|
|
|
|
/* |
2711
|
|
|
|
|
|
=for apidoc sv_2num |
2712
|
|
|
|
|
|
|
2713
|
|
|
|
|
|
Return an SV with the numeric value of the source SV, doing any necessary |
2714
|
|
|
|
|
|
reference or overload conversion. You must use the C macro to |
2715
|
|
|
|
|
|
access this function. |
2716
|
|
|
|
|
|
|
2717
|
|
|
|
|
|
=cut |
2718
|
|
|
|
|
|
*/ |
2719
|
|
|
|
|
|
|
2720
|
|
|
|
|
|
SV * |
2721
|
4668699
|
|
|
|
|
Perl_sv_2num(pTHX_ SV *const sv) |
2722
|
|
|
|
|
|
{ |
2723
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2NUM; |
2724
|
|
|
|
|
|
|
2725
|
4669624
|
100
|
|
|
|
if (!SvROK(sv)) |
2726
|
|
|
|
|
|
return sv; |
2727
|
4667774
|
50
|
|
|
|
if (SvAMAGIC(sv)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2728
|
563436
|
|
|
|
|
SV * const tmpsv = AMG_CALLunary(sv, numer_amg); |
2729
|
563436
|
100
|
|
|
|
TAINT_IF(tmpsv && SvTAINTED(tmpsv)); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
2730
|
563436
|
100
|
|
|
|
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
2731
|
|
|
|
|
|
return sv_2num(tmpsv); |
2732
|
|
|
|
|
|
} |
2733
|
4666849
|
|
|
|
|
return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); |
2734
|
|
|
|
|
|
} |
2735
|
|
|
|
|
|
|
2736
|
|
|
|
|
|
/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or |
2737
|
|
|
|
|
|
* UV as a string towards the end of buf, and return pointers to start and |
2738
|
|
|
|
|
|
* end of it. |
2739
|
|
|
|
|
|
* |
2740
|
|
|
|
|
|
* We assume that buf is at least TYPE_CHARS(UV) long. |
2741
|
|
|
|
|
|
*/ |
2742
|
|
|
|
|
|
|
2743
|
|
|
|
|
|
static char * |
2744
|
|
|
|
|
|
S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) |
2745
|
|
|
|
|
|
{ |
2746
|
|
|
|
|
|
char *ptr = buf + TYPE_CHARS(UV); |
2747
|
|
|
|
|
|
char * const ebuf = ptr; |
2748
|
|
|
|
|
|
int sign; |
2749
|
|
|
|
|
|
|
2750
|
|
|
|
|
|
PERL_ARGS_ASSERT_UIV_2BUF; |
2751
|
|
|
|
|
|
|
2752
|
190248255
|
100
|
|
|
|
if (is_uv) |
2753
|
|
|
|
|
|
sign = 0; |
2754
|
190230923
|
0
|
|
|
|
else if (iv >= 0) { |
|
|
100
|
|
|
|
|
2755
|
190132539
|
|
|
|
|
uv = iv; |
2756
|
|
|
|
|
|
sign = 0; |
2757
|
|
|
|
|
|
} else { |
2758
|
95213454
|
|
|
|
|
uv = -iv; |
2759
|
|
|
|
|
|
sign = 1; |
2760
|
|
|
|
|
|
} |
2761
|
|
|
|
|
|
do { |
2762
|
1429742796
|
|
|
|
|
*--ptr = '0' + (char)(uv % 10); |
2763
|
1429742796
|
0
|
|
|
|
} while (uv /= 10); |
|
|
100
|
|
|
|
|
2764
|
190248255
|
0
|
|
|
|
if (sign) |
|
|
100
|
|
|
|
|
2765
|
98384
|
|
|
|
|
*--ptr = '-'; |
2766
|
|
|
|
|
|
*peob = ebuf; |
2767
|
|
|
|
|
|
return ptr; |
2768
|
|
|
|
|
|
} |
2769
|
|
|
|
|
|
|
2770
|
|
|
|
|
|
/* |
2771
|
|
|
|
|
|
=for apidoc sv_2pv_flags |
2772
|
|
|
|
|
|
|
2773
|
|
|
|
|
|
Returns a pointer to the string value of an SV, and sets *lp to its length. |
2774
|
|
|
|
|
|
If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a |
2775
|
|
|
|
|
|
string if necessary. Normally invoked via the C macro. |
2776
|
|
|
|
|
|
C and C usually end up here too. |
2777
|
|
|
|
|
|
|
2778
|
|
|
|
|
|
=cut |
2779
|
|
|
|
|
|
*/ |
2780
|
|
|
|
|
|
|
2781
|
|
|
|
|
|
char * |
2782
|
223911065
|
|
|
|
|
Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) |
2783
|
|
|
|
|
|
{ |
2784
|
|
|
|
|
|
dVAR; |
2785
|
|
|
|
|
|
char *s; |
2786
|
|
|
|
|
|
|
2787
|
223911065
|
50
|
|
|
|
if (!sv) { |
2788
|
0
|
0
|
|
|
|
if (lp) |
2789
|
0
|
|
|
|
|
*lp = 0; |
2790
|
|
|
|
|
|
return (char *)""; |
2791
|
|
|
|
|
|
} |
2792
|
|
|
|
|
|
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2793
|
|
|
|
|
|
&& SvTYPE(sv) != SVt_PVFM); |
2794
|
223911065
|
100
|
|
|
|
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) |
|
|
100
|
|
|
|
|
2795
|
14085628
|
|
|
|
|
mg_get(sv); |
2796
|
223911059
|
100
|
|
|
|
if (SvROK(sv)) { |
2797
|
4191280
|
50
|
|
|
|
if (SvAMAGIC(sv)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
2798
|
|
|
|
|
|
SV *tmpstr; |
2799
|
2008748
|
100
|
|
|
|
if (flags & SV_SKIP_OVERLOAD) |
2800
|
|
|
|
|
|
return NULL; |
2801
|
2008516
|
|
|
|
|
tmpstr = AMG_CALLunary(sv, string_amg); |
2802
|
2008516
|
100
|
|
|
|
TAINT_IF(tmpstr && SvTAINTED(tmpstr)); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
2803
|
2008516
|
100
|
|
|
|
if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
2804
|
|
|
|
|
|
/* Unwrap this: */ |
2805
|
|
|
|
|
|
/* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); |
2806
|
|
|
|
|
|
*/ |
2807
|
|
|
|
|
|
|
2808
|
|
|
|
|
|
char *pv; |
2809
|
68268
|
100
|
|
|
|
if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { |
2810
|
65352
|
100
|
|
|
|
if (flags & SV_CONST_RETURN) { |
2811
|
61848
|
|
|
|
|
pv = (char *) SvPVX_const(tmpstr); |
2812
|
|
|
|
|
|
} else { |
2813
|
3504
|
|
|
|
|
pv = (flags & SV_MUTABLE_RETURN) |
2814
|
|
|
|
|
|
? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); |
2815
|
|
|
|
|
|
} |
2816
|
65352
|
100
|
|
|
|
if (lp) |
2817
|
65312
|
|
|
|
|
*lp = SvCUR(tmpstr); |
2818
|
|
|
|
|
|
} else { |
2819
|
2916
|
|
|
|
|
pv = sv_2pv_flags(tmpstr, lp, flags); |
2820
|
|
|
|
|
|
} |
2821
|
68268
|
100
|
|
|
|
if (SvUTF8(tmpstr)) |
2822
|
334
|
|
|
|
|
SvUTF8_on(sv); |
2823
|
|
|
|
|
|
else |
2824
|
67934
|
|
|
|
|
SvUTF8_off(sv); |
2825
|
|
|
|
|
|
return pv; |
2826
|
|
|
|
|
|
} |
2827
|
|
|
|
|
|
} |
2828
|
|
|
|
|
|
{ |
2829
|
|
|
|
|
|
STRLEN len; |
2830
|
|
|
|
|
|
char *retval; |
2831
|
|
|
|
|
|
char *buffer; |
2832
|
4122780
|
|
|
|
|
SV *const referent = SvRV(sv); |
2833
|
|
|
|
|
|
|
2834
|
4122780
|
50
|
|
|
|
if (!referent) { |
2835
|
|
|
|
|
|
len = 7; |
2836
|
0
|
|
|
|
|
retval = buffer = savepvn("NULLREF", len); |
2837
|
4329372
|
100
|
|
|
|
} else if (SvTYPE(referent) == SVt_REGEXP && |
|
|
100
|
|
|
|
|
2838
|
206620
|
100
|
|
|
|
(!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || |
2839
|
28
|
|
|
|
|
amagic_is_enabled(string_amg))) { |
2840
|
|
|
|
|
|
REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); |
2841
|
|
|
|
|
|
|
2842
|
|
|
|
|
|
assert(re); |
2843
|
|
|
|
|
|
|
2844
|
|
|
|
|
|
/* If the regex is UTF-8 we want the containing scalar to |
2845
|
|
|
|
|
|
have an UTF-8 flag too */ |
2846
|
413162
|
100
|
|
|
|
if (RX_UTF8(re)) |
2847
|
40
|
|
|
|
|
SvUTF8_on(sv); |
2848
|
|
|
|
|
|
else |
2849
|
413122
|
|
|
|
|
SvUTF8_off(sv); |
2850
|
|
|
|
|
|
|
2851
|
413162
|
50
|
|
|
|
if (lp) |
2852
|
413162
|
|
|
|
|
*lp = RX_WRAPLEN(re); |
2853
|
|
|
|
|
|
|
2854
|
413162
|
|
|
|
|
return RX_WRAPPED(re); |
2855
|
|
|
|
|
|
} else { |
2856
|
3709618
|
|
|
|
|
const char *const typestr = sv_reftype(referent, 0); |
2857
|
3709618
|
|
|
|
|
const STRLEN typelen = strlen(typestr); |
2858
|
3709618
|
|
|
|
|
UV addr = PTR2UV(referent); |
2859
|
|
|
|
|
|
const char *stashname = NULL; |
2860
|
|
|
|
|
|
STRLEN stashnamelen = 0; /* hush, gcc */ |
2861
|
|
|
|
|
|
const char *buffer_end; |
2862
|
|
|
|
|
|
|
2863
|
3709618
|
100
|
|
|
|
if (SvOBJECT(referent)) { |
2864
|
2624002
|
50
|
|
|
|
const HEK *const name = HvNAME_HEK(SvSTASH(referent)); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
2865
|
|
|
|
|
|
|
2866
|
2624002
|
100
|
|
|
|
if (name) { |
2867
|
2623998
|
|
|
|
|
stashname = HEK_KEY(name); |
2868
|
2623998
|
|
|
|
|
stashnamelen = HEK_LEN(name); |
2869
|
|
|
|
|
|
|
2870
|
2623998
|
100
|
|
|
|
if (HEK_UTF8(name)) { |
2871
|
174
|
|
|
|
|
SvUTF8_on(sv); |
2872
|
|
|
|
|
|
} else { |
2873
|
2623824
|
|
|
|
|
SvUTF8_off(sv); |
2874
|
|
|
|
|
|
} |
2875
|
|
|
|
|
|
} else { |
2876
|
|
|
|
|
|
stashname = "__ANON__"; |
2877
|
|
|
|
|
|
stashnamelen = 8; |
2878
|
|
|
|
|
|
} |
2879
|
2624002
|
|
|
|
|
len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ |
2880
|
|
|
|
|
|
+ 2 * sizeof(UV) + 2 /* )\0 */; |
2881
|
|
|
|
|
|
} else { |
2882
|
1085616
|
|
|
|
|
len = typelen + 3 /* (0x */ |
2883
|
|
|
|
|
|
+ 2 * sizeof(UV) + 2 /* )\0 */; |
2884
|
|
|
|
|
|
} |
2885
|
|
|
|
|
|
|
2886
|
3709618
|
|
|
|
|
Newx(buffer, len, char); |
2887
|
3709618
|
|
|
|
|
buffer_end = retval = buffer + len; |
2888
|
|
|
|
|
|
|
2889
|
|
|
|
|
|
/* Working backwards */ |
2890
|
3709618
|
|
|
|
|
*--retval = '\0'; |
2891
|
3709618
|
|
|
|
|
*--retval = ')'; |
2892
|
|
|
|
|
|
do { |
2893
|
25961388
|
|
|
|
|
*--retval = PL_hexdigit[addr & 15]; |
2894
|
25961388
|
100
|
|
|
|
} while (addr >>= 4); |
2895
|
3709618
|
|
|
|
|
*--retval = 'x'; |
2896
|
3709618
|
|
|
|
|
*--retval = '0'; |
2897
|
3709618
|
|
|
|
|
*--retval = '('; |
2898
|
|
|
|
|
|
|
2899
|
3709618
|
|
|
|
|
retval -= typelen; |
2900
|
3709618
|
|
|
|
|
memcpy(retval, typestr, typelen); |
2901
|
|
|
|
|
|
|
2902
|
3709618
|
100
|
|
|
|
if (stashname) { |
2903
|
2624002
|
|
|
|
|
*--retval = '='; |
2904
|
2624002
|
|
|
|
|
retval -= stashnamelen; |
2905
|
2624002
|
|
|
|
|
memcpy(retval, stashname, stashnamelen); |
2906
|
|
|
|
|
|
} |
2907
|
|
|
|
|
|
/* retval may not necessarily have reached the start of the |
2908
|
|
|
|
|
|
buffer here. */ |
2909
|
|
|
|
|
|
assert (retval >= buffer); |
2910
|
|
|
|
|
|
|
2911
|
3709618
|
|
|
|
|
len = buffer_end - retval - 1; /* -1 for that \0 */ |
2912
|
|
|
|
|
|
} |
2913
|
3709618
|
100
|
|
|
|
if (lp) |
2914
|
3683200
|
|
|
|
|
*lp = len; |
2915
|
3709618
|
|
|
|
|
SAVEFREEPV(buffer); |
2916
|
3709618
|
|
|
|
|
return retval; |
2917
|
|
|
|
|
|
} |
2918
|
|
|
|
|
|
} |
2919
|
|
|
|
|
|
|
2920
|
219719779
|
100
|
|
|
|
if (SvPOKp(sv)) { |
2921
|
27682226
|
100
|
|
|
|
if (lp) |
2922
|
27680776
|
|
|
|
|
*lp = SvCUR(sv); |
2923
|
27682226
|
100
|
|
|
|
if (flags & SV_MUTABLE_RETURN) |
2924
|
650
|
|
|
|
|
return SvPVX_mutable(sv); |
2925
|
27681576
|
100
|
|
|
|
if (flags & SV_CONST_RETURN) |
2926
|
27656214
|
|
|
|
|
return (char *)SvPVX_const(sv); |
2927
|
25362
|
|
|
|
|
return SvPVX(sv); |
2928
|
|
|
|
|
|
} |
2929
|
|
|
|
|
|
|
2930
|
192037553
|
100
|
|
|
|
if (SvIOK(sv)) { |
2931
|
|
|
|
|
|
/* I'm assuming that if both IV and NV are equally valid then |
2932
|
|
|
|
|
|
converting the IV is going to be more efficient */ |
2933
|
190248255
|
|
|
|
|
const U32 isUIOK = SvIsUV(sv); |
2934
|
|
|
|
|
|
char buf[TYPE_CHARS(UV)]; |
2935
|
|
|
|
|
|
char *ebuf, *ptr; |
2936
|
|
|
|
|
|
STRLEN len; |
2937
|
|
|
|
|
|
|
2938
|
190248255
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_PVIV) |
2939
|
162469671
|
|
|
|
|
sv_upgrade(sv, SVt_PVIV); |
2940
|
190248255
|
|
|
|
|
ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); |
2941
|
190248255
|
|
|
|
|
len = ebuf - ptr; |
2942
|
|
|
|
|
|
/* inlined from sv_setpvn */ |
2943
|
190248255
|
100
|
|
|
|
s = SvGROW_mutable(sv, len + 1); |
2944
|
|
|
|
|
|
Move(ptr, s, len, char); |
2945
|
190248255
|
|
|
|
|
s += len; |
2946
|
190248255
|
|
|
|
|
*s = '\0'; |
2947
|
190248255
|
|
|
|
|
SvPOK_on(sv); |
2948
|
|
|
|
|
|
} |
2949
|
1789298
|
100
|
|
|
|
else if (SvNOK(sv)) { |
2950
|
125340
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_PVNV) |
2951
|
15410
|
|
|
|
|
sv_upgrade(sv, SVt_PVNV); |
2952
|
125340
|
100
|
|
|
|
if (SvNVX(sv) == 0.0) { |
2953
|
4042
|
100
|
|
|
|
s = SvGROW_mutable(sv, 2); |
2954
|
4042
|
|
|
|
|
*s++ = '0'; |
2955
|
4042
|
|
|
|
|
*s = '\0'; |
2956
|
|
|
|
|
|
} else { |
2957
|
121298
|
|
|
|
|
dSAVE_ERRNO; |
2958
|
|
|
|
|
|
/* The +20 is pure guesswork. Configure test needed. --jhi */ |
2959
|
121298
|
100
|
|
|
|
s = SvGROW_mutable(sv, NV_DIG + 20); |
2960
|
|
|
|
|
|
/* some Xenix systems wipe out errno here */ |
2961
|
|
|
|
|
|
|
2962
|
|
|
|
|
|
#ifndef USE_LOCALE_NUMERIC |
2963
|
|
|
|
|
|
Gconvert(SvNVX(sv), NV_DIG, 0, s); |
2964
|
|
|
|
|
|
SvPOK_on(sv); |
2965
|
|
|
|
|
|
#else |
2966
|
|
|
|
|
|
/* Gconvert always uses the current locale. That's the right thing |
2967
|
|
|
|
|
|
* to do if we're supposed to be using locales. But otherwise, we |
2968
|
|
|
|
|
|
* want the result to be based on the C locale, so we need to |
2969
|
|
|
|
|
|
* change to the C locale during the Gconvert and then change back. |
2970
|
|
|
|
|
|
* But if we're already in the C locale (PL_numeric_standard is |
2971
|
|
|
|
|
|
* TRUE in that case), no need to do any changing */ |
2972
|
121298
|
100
|
|
|
|
if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) { |
|
|
50
|
|
|
|
|
2973
|
121294
|
|
|
|
|
Gconvert(SvNVX(sv), NV_DIG, 0, s); |
2974
|
|
|
|
|
|
|
2975
|
|
|
|
|
|
/* If the radix character is UTF-8, and actually is in the |
2976
|
|
|
|
|
|
* output, turn on the UTF-8 flag for the scalar */ |
2977
|
121294
|
50
|
|
|
|
if (! PL_numeric_standard |
2978
|
0
|
0
|
|
|
|
&& PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) |
|
|
0
|
|
|
|
|
2979
|
0
|
0
|
|
|
|
&& instr(s, SvPVX_const(PL_numeric_radix_sv))) |
2980
|
|
|
|
|
|
{ |
2981
|
0
|
|
|
|
|
SvUTF8_on(sv); |
2982
|
|
|
|
|
|
} |
2983
|
|
|
|
|
|
} |
2984
|
|
|
|
|
|
else { |
2985
|
4
|
|
|
|
|
char *loc = savepv(setlocale(LC_NUMERIC, NULL)); |
2986
|
4
|
|
|
|
|
setlocale(LC_NUMERIC, "C"); |
2987
|
4
|
|
|
|
|
Gconvert(SvNVX(sv), NV_DIG, 0, s); |
2988
|
4
|
|
|
|
|
setlocale(LC_NUMERIC, loc); |
2989
|
4
|
|
|
|
|
Safefree(loc); |
2990
|
|
|
|
|
|
|
2991
|
|
|
|
|
|
} |
2992
|
|
|
|
|
|
|
2993
|
|
|
|
|
|
/* We don't call SvPOK_on(), because it may come to pass that the |
2994
|
|
|
|
|
|
* locale changes so that the stringification we just did is no |
2995
|
|
|
|
|
|
* longer correct. We will have to re-stringify every time it is |
2996
|
|
|
|
|
|
* needed */ |
2997
|
|
|
|
|
|
#endif |
2998
|
121298
|
|
|
|
|
RESTORE_ERRNO; |
2999
|
821082
|
100
|
|
|
|
while (*s) s++; |
3000
|
|
|
|
|
|
} |
3001
|
|
|
|
|
|
#ifdef hcx |
3002
|
|
|
|
|
|
if (s[-1] == '.') |
3003
|
|
|
|
|
|
*--s = '\0'; |
3004
|
|
|
|
|
|
#endif |
3005
|
|
|
|
|
|
} |
3006
|
1663958
|
100
|
|
|
|
else if (isGV_with_GP(sv)) { |
|
|
50
|
|
|
|
|
3007
|
|
|
|
|
|
GV *const gv = MUTABLE_GV(sv); |
3008
|
1666
|
|
|
|
|
SV *const buffer = sv_newmortal(); |
3009
|
|
|
|
|
|
|
3010
|
1666
|
|
|
|
|
gv_efullname3(buffer, gv, "*"); |
3011
|
|
|
|
|
|
|
3012
|
|
|
|
|
|
assert(SvPOK(buffer)); |
3013
|
1666
|
100
|
|
|
|
if (SvUTF8(buffer)) |
3014
|
134
|
|
|
|
|
SvUTF8_on(sv); |
3015
|
1666
|
100
|
|
|
|
if (lp) |
3016
|
1646
|
|
|
|
|
*lp = SvCUR(buffer); |
3017
|
1666
|
|
|
|
|
return SvPVX(buffer); |
3018
|
|
|
|
|
|
} |
3019
|
1662292
|
100
|
|
|
|
else if (isREGEXP(sv)) { |
|
|
100
|
|
|
|
|
3020
|
1593132
|
50
|
|
|
|
if (lp) *lp = RX_WRAPLEN((REGEXP *)sv); |
3021
|
1593132
|
|
|
|
|
return RX_WRAPPED((REGEXP *)sv); |
3022
|
|
|
|
|
|
} |
3023
|
|
|
|
|
|
else { |
3024
|
69160
|
100
|
|
|
|
if (lp) |
3025
|
69092
|
|
|
|
|
*lp = 0; |
3026
|
69160
|
100
|
|
|
|
if (flags & SV_UNDEF_RETURNS_NULL) |
3027
|
|
|
|
|
|
return NULL; |
3028
|
69136
|
100
|
|
|
|
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
|
|
100
|
|
|
|
|
3029
|
2264
|
|
|
|
|
report_uninit(sv); |
3030
|
|
|
|
|
|
/* Typically the caller expects that sv_any is not NULL now. */ |
3031
|
69098
|
100
|
|
|
|
if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) |
|
|
100
|
|
|
|
|
3032
|
2092
|
|
|
|
|
sv_upgrade(sv, SVt_PV); |
3033
|
|
|
|
|
|
return (char *)""; |
3034
|
|
|
|
|
|
} |
3035
|
|
|
|
|
|
|
3036
|
|
|
|
|
|
{ |
3037
|
190373595
|
|
|
|
|
const STRLEN len = s - SvPVX_const(sv); |
3038
|
190373595
|
100
|
|
|
|
if (lp) |
3039
|
190371357
|
|
|
|
|
*lp = len; |
3040
|
190373595
|
|
|
|
|
SvCUR_set(sv, len); |
3041
|
|
|
|
|
|
} |
3042
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", |
3043
|
|
|
|
|
|
PTR2UV(sv),SvPVX_const(sv))); |
3044
|
190373595
|
100
|
|
|
|
if (flags & SV_CONST_RETURN) |
3045
|
190085597
|
|
|
|
|
return (char *)SvPVX_const(sv); |
3046
|
287998
|
100
|
|
|
|
if (flags & SV_MUTABLE_RETURN) |
3047
|
8
|
|
|
|
|
return SvPVX_mutable(sv); |
3048
|
112144318
|
|
|
|
|
return SvPVX(sv); |
3049
|
|
|
|
|
|
} |
3050
|
|
|
|
|
|
|
3051
|
|
|
|
|
|
/* |
3052
|
|
|
|
|
|
=for apidoc sv_copypv |
3053
|
|
|
|
|
|
|
3054
|
|
|
|
|
|
Copies a stringified representation of the source SV into the |
3055
|
|
|
|
|
|
destination SV. Automatically performs any necessary mg_get and |
3056
|
|
|
|
|
|
coercion of numeric values into strings. Guaranteed to preserve |
3057
|
|
|
|
|
|
UTF8 flag even from overloaded objects. Similar in nature to |
3058
|
|
|
|
|
|
sv_2pv[_flags] but operates directly on an SV instead of just the |
3059
|
|
|
|
|
|
string. Mostly uses sv_2pv_flags to do its work, except when that |
3060
|
|
|
|
|
|
would lose the UTF-8'ness of the PV. |
3061
|
|
|
|
|
|
|
3062
|
|
|
|
|
|
=for apidoc sv_copypv_nomg |
3063
|
|
|
|
|
|
|
3064
|
|
|
|
|
|
Like sv_copypv, but doesn't invoke get magic first. |
3065
|
|
|
|
|
|
|
3066
|
|
|
|
|
|
=for apidoc sv_copypv_flags |
3067
|
|
|
|
|
|
|
3068
|
|
|
|
|
|
Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags |
3069
|
|
|
|
|
|
include SV_GMAGIC. |
3070
|
|
|
|
|
|
|
3071
|
|
|
|
|
|
=cut |
3072
|
|
|
|
|
|
*/ |
3073
|
|
|
|
|
|
|
3074
|
|
|
|
|
|
void |
3075
|
0
|
|
|
|
|
Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) |
3076
|
|
|
|
|
|
{ |
3077
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_COPYPV; |
3078
|
|
|
|
|
|
|
3079
|
0
|
|
|
|
|
sv_copypv_flags(dsv, ssv, 0); |
3080
|
0
|
|
|
|
|
} |
3081
|
|
|
|
|
|
|
3082
|
|
|
|
|
|
void |
3083
|
6811770
|
|
|
|
|
Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) |
3084
|
|
|
|
|
|
{ |
3085
|
|
|
|
|
|
STRLEN len; |
3086
|
|
|
|
|
|
const char *s; |
3087
|
|
|
|
|
|
|
3088
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_COPYPV_FLAGS; |
3089
|
|
|
|
|
|
|
3090
|
6811770
|
100
|
|
|
|
if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv)) |
|
|
100
|
|
|
|
|
3091
|
40500
|
|
|
|
|
mg_get(ssv); |
3092
|
6811768
|
100
|
|
|
|
s = SvPV_nomg_const(ssv,len); |
3093
|
6811768
|
|
|
|
|
sv_setpvn(dsv,s,len); |
3094
|
6811768
|
100
|
|
|
|
if (SvUTF8(ssv)) |
3095
|
361862
|
|
|
|
|
SvUTF8_on(dsv); |
3096
|
|
|
|
|
|
else |
3097
|
6449906
|
|
|
|
|
SvUTF8_off(dsv); |
3098
|
6811768
|
|
|
|
|
} |
3099
|
|
|
|
|
|
|
3100
|
|
|
|
|
|
/* |
3101
|
|
|
|
|
|
=for apidoc sv_2pvbyte |
3102
|
|
|
|
|
|
|
3103
|
|
|
|
|
|
Return a pointer to the byte-encoded representation of the SV, and set *lp |
3104
|
|
|
|
|
|
to its length. May cause the SV to be downgraded from UTF-8 as a |
3105
|
|
|
|
|
|
side-effect. |
3106
|
|
|
|
|
|
|
3107
|
|
|
|
|
|
Usually accessed via the C macro. |
3108
|
|
|
|
|
|
|
3109
|
|
|
|
|
|
=cut |
3110
|
|
|
|
|
|
*/ |
3111
|
|
|
|
|
|
|
3112
|
|
|
|
|
|
char * |
3113
|
1780
|
|
|
|
|
Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) |
3114
|
1780
|
100
|
|
|
|
{ |
3115
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2PVBYTE; |
3116
|
|
|
|
|
|
|
3117
|
904
|
|
|
|
|
SvGETMAGIC(sv); |
3118
|
1780
|
100
|
|
|
|
if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) |
|
|
50
|
|
|
|
|
3119
|
1768
|
100
|
|
|
|
|| isGV_with_GP(sv) || SvROK(sv)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3120
|
22
|
|
|
|
|
SV *sv2 = sv_newmortal(); |
3121
|
22
|
|
|
|
|
sv_copypv_nomg(sv2,sv); |
3122
|
|
|
|
|
|
sv = sv2; |
3123
|
|
|
|
|
|
} |
3124
|
1780
|
|
|
|
|
sv_utf8_downgrade(sv,0); |
3125
|
1772
|
100
|
|
|
|
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3126
|
|
|
|
|
|
} |
3127
|
|
|
|
|
|
|
3128
|
|
|
|
|
|
/* |
3129
|
|
|
|
|
|
=for apidoc sv_2pvutf8 |
3130
|
|
|
|
|
|
|
3131
|
|
|
|
|
|
Return a pointer to the UTF-8-encoded representation of the SV, and set *lp |
3132
|
|
|
|
|
|
to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. |
3133
|
|
|
|
|
|
|
3134
|
|
|
|
|
|
Usually accessed via the C macro. |
3135
|
|
|
|
|
|
|
3136
|
|
|
|
|
|
=cut |
3137
|
|
|
|
|
|
*/ |
3138
|
|
|
|
|
|
|
3139
|
|
|
|
|
|
char * |
3140
|
392
|
|
|
|
|
Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) |
3141
|
|
|
|
|
|
{ |
3142
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2PVUTF8; |
3143
|
|
|
|
|
|
|
3144
|
776
|
100
|
|
|
|
if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3145
|
388
|
100
|
|
|
|
|| isGV_with_GP(sv) || SvROK(sv)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3146
|
8
|
|
|
|
|
sv = sv_mortalcopy(sv); |
3147
|
|
|
|
|
|
else |
3148
|
198
|
|
|
|
|
SvGETMAGIC(sv); |
3149
|
392
|
|
|
|
|
sv_utf8_upgrade_nomg(sv); |
3150
|
392
|
100
|
|
|
|
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3151
|
|
|
|
|
|
} |
3152
|
|
|
|
|
|
|
3153
|
|
|
|
|
|
|
3154
|
|
|
|
|
|
/* |
3155
|
|
|
|
|
|
=for apidoc sv_2bool |
3156
|
|
|
|
|
|
|
3157
|
|
|
|
|
|
This macro is only used by sv_true() or its macro equivalent, and only if |
3158
|
|
|
|
|
|
the latter's argument is neither SvPOK, SvIOK nor SvNOK. |
3159
|
|
|
|
|
|
It calls sv_2bool_flags with the SV_GMAGIC flag. |
3160
|
|
|
|
|
|
|
3161
|
|
|
|
|
|
=for apidoc sv_2bool_flags |
3162
|
|
|
|
|
|
|
3163
|
|
|
|
|
|
This function is only used by sv_true() and friends, and only if |
3164
|
|
|
|
|
|
the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags |
3165
|
|
|
|
|
|
contain SV_GMAGIC, then it does an mg_get() first. |
3166
|
|
|
|
|
|
|
3167
|
|
|
|
|
|
|
3168
|
|
|
|
|
|
=cut |
3169
|
|
|
|
|
|
*/ |
3170
|
|
|
|
|
|
|
3171
|
|
|
|
|
|
bool |
3172
|
117332049
|
|
|
|
|
Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags) |
3173
|
|
|
|
|
|
{ |
3174
|
|
|
|
|
|
dVAR; |
3175
|
|
|
|
|
|
|
3176
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; |
3177
|
|
|
|
|
|
|
3178
|
117332049
|
100
|
|
|
|
if(flags & SV_GMAGIC) SvGETMAGIC(sv); |
|
|
50
|
|
|
|
|
3179
|
|
|
|
|
|
|
3180
|
117332049
|
100
|
|
|
|
if (!SvOK(sv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3181
|
|
|
|
|
|
return 0; |
3182
|
116897113
|
100
|
|
|
|
if (SvROK(sv)) { |
3183
|
114118443
|
50
|
|
|
|
if (SvAMAGIC(sv)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3184
|
122850
|
|
|
|
|
SV * const tmpsv = AMG_CALLunary(sv, bool__amg); |
3185
|
122850
|
100
|
|
|
|
if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
3186
|
23542
|
50
|
|
|
|
return cBOOL(SvTRUE(tmpsv)); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
3187
|
|
|
|
|
|
} |
3188
|
114094901
|
|
|
|
|
return SvRV(sv) != 0; |
3189
|
|
|
|
|
|
} |
3190
|
2778670
|
100
|
|
|
|
if (isREGEXP(sv)) |
|
|
50
|
|
|
|
|
3191
|
2
|
|
|
|
|
return |
3192
|
2
|
50
|
|
|
|
RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3193
|
60072277
|
50
|
|
|
|
return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3194
|
|
|
|
|
|
} |
3195
|
|
|
|
|
|
|
3196
|
|
|
|
|
|
/* |
3197
|
|
|
|
|
|
=for apidoc sv_utf8_upgrade |
3198
|
|
|
|
|
|
|
3199
|
|
|
|
|
|
Converts the PV of an SV to its UTF-8-encoded form. |
3200
|
|
|
|
|
|
Forces the SV to string form if it is not already. |
3201
|
|
|
|
|
|
Will C on C if appropriate. |
3202
|
|
|
|
|
|
Always sets the SvUTF8 flag to avoid future validity checks even |
3203
|
|
|
|
|
|
if the whole string is the same in UTF-8 as not. |
3204
|
|
|
|
|
|
Returns the number of bytes in the converted string |
3205
|
|
|
|
|
|
|
3206
|
|
|
|
|
|
This is not a general purpose byte encoding to Unicode interface: |
3207
|
|
|
|
|
|
use the Encode extension for that. |
3208
|
|
|
|
|
|
|
3209
|
|
|
|
|
|
=for apidoc sv_utf8_upgrade_nomg |
3210
|
|
|
|
|
|
|
3211
|
|
|
|
|
|
Like sv_utf8_upgrade, but doesn't do magic on C. |
3212
|
|
|
|
|
|
|
3213
|
|
|
|
|
|
=for apidoc sv_utf8_upgrade_flags |
3214
|
|
|
|
|
|
|
3215
|
|
|
|
|
|
Converts the PV of an SV to its UTF-8-encoded form. |
3216
|
|
|
|
|
|
Forces the SV to string form if it is not already. |
3217
|
|
|
|
|
|
Always sets the SvUTF8 flag to avoid future validity checks even |
3218
|
|
|
|
|
|
if all the bytes are invariant in UTF-8. |
3219
|
|
|
|
|
|
If C has C bit set, |
3220
|
|
|
|
|
|
will C on C if appropriate, else not. |
3221
|
|
|
|
|
|
Returns the number of bytes in the converted string |
3222
|
|
|
|
|
|
C and |
3223
|
|
|
|
|
|
C are implemented in terms of this function. |
3224
|
|
|
|
|
|
|
3225
|
|
|
|
|
|
This is not a general purpose byte encoding to Unicode interface: |
3226
|
|
|
|
|
|
use the Encode extension for that. |
3227
|
|
|
|
|
|
|
3228
|
|
|
|
|
|
=cut |
3229
|
|
|
|
|
|
|
3230
|
|
|
|
|
|
The grow version is currently not externally documented. It adds a parameter, |
3231
|
|
|
|
|
|
extra, which is the number of unused bytes the string of 'sv' is guaranteed to |
3232
|
|
|
|
|
|
have free after it upon return. This allows the caller to reserve extra space |
3233
|
|
|
|
|
|
that it intends to fill, to avoid extra grows. |
3234
|
|
|
|
|
|
|
3235
|
|
|
|
|
|
Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE, |
3236
|
|
|
|
|
|
which can be used to tell this function to not first check to see if there are |
3237
|
|
|
|
|
|
any characters that are different in UTF-8 (variant characters) which would |
3238
|
|
|
|
|
|
force it to allocate a new string to sv, but to assume there are. Typically |
3239
|
|
|
|
|
|
this flag is used by a routine that has already parsed the string to find that |
3240
|
|
|
|
|
|
there are such characters, and passes this information on so that the work |
3241
|
|
|
|
|
|
doesn't have to be repeated. |
3242
|
|
|
|
|
|
|
3243
|
|
|
|
|
|
(One might think that the calling routine could pass in the position of the |
3244
|
|
|
|
|
|
first such variant, so it wouldn't have to be found again. But that is not the |
3245
|
|
|
|
|
|
case, because typically when the caller is likely to use this flag, it won't be |
3246
|
|
|
|
|
|
calling this routine unless it finds something that won't fit into a byte. |
3247
|
|
|
|
|
|
Otherwise it tries to not upgrade and just use bytes. But some things that |
3248
|
|
|
|
|
|
do fit into a byte are variants in utf8, and the caller may not have been |
3249
|
|
|
|
|
|
keeping track of these.) |
3250
|
|
|
|
|
|
|
3251
|
|
|
|
|
|
If the routine itself changes the string, it adds a trailing NUL. Such a NUL |
3252
|
|
|
|
|
|
isn't guaranteed due to having other routines do the work in some input cases, |
3253
|
|
|
|
|
|
or if the input is already flagged as being in utf8. |
3254
|
|
|
|
|
|
|
3255
|
|
|
|
|
|
The speed of this could perhaps be improved for many cases if someone wanted to |
3256
|
|
|
|
|
|
write a fast function that counts the number of variant characters in a string, |
3257
|
|
|
|
|
|
especially if it could return the position of the first one. |
3258
|
|
|
|
|
|
|
3259
|
|
|
|
|
|
*/ |
3260
|
|
|
|
|
|
|
3261
|
|
|
|
|
|
STRLEN |
3262
|
5384668
|
|
|
|
|
Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) |
3263
|
|
|
|
|
|
{ |
3264
|
|
|
|
|
|
dVAR; |
3265
|
|
|
|
|
|
|
3266
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; |
3267
|
|
|
|
|
|
|
3268
|
5384668
|
50
|
|
|
|
if (sv == &PL_sv_undef) |
3269
|
|
|
|
|
|
return 0; |
3270
|
5384668
|
100
|
|
|
|
if (!SvPOK_nog(sv)) { |
3271
|
350202
|
|
|
|
|
STRLEN len = 0; |
3272
|
350202
|
50
|
|
|
|
if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { |
|
|
0
|
|
|
|
|
3273
|
0
|
|
|
|
|
(void) sv_2pv_flags(sv,&len, flags); |
3274
|
0
|
0
|
|
|
|
if (SvUTF8(sv)) { |
3275
|
0
|
0
|
|
|
|
if (extra) SvGROW(sv, SvCUR(sv) + extra); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3276
|
0
|
|
|
|
|
return len; |
3277
|
|
|
|
|
|
} |
3278
|
|
|
|
|
|
} else { |
3279
|
350202
|
50
|
|
|
|
(void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); |
3280
|
|
|
|
|
|
} |
3281
|
|
|
|
|
|
} |
3282
|
|
|
|
|
|
|
3283
|
5384668
|
100
|
|
|
|
if (SvUTF8(sv)) { |
3284
|
855316
|
50
|
|
|
|
if (extra) SvGROW(sv, SvCUR(sv) + extra); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3285
|
855316
|
|
|
|
|
return SvCUR(sv); |
3286
|
|
|
|
|
|
} |
3287
|
|
|
|
|
|
|
3288
|
4529352
|
100
|
|
|
|
if (SvIsCOW(sv)) { |
3289
|
517012
|
|
|
|
|
S_sv_uncow(aTHX_ sv, 0); |
3290
|
|
|
|
|
|
} |
3291
|
|
|
|
|
|
|
3292
|
4529352
|
100
|
|
|
|
if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) { |
|
|
50
|
|
|
|
|
3293
|
55058
|
|
|
|
|
sv_recode_to_utf8(sv, PL_encoding); |
3294
|
55054
|
100
|
|
|
|
if (extra) SvGROW(sv, SvCUR(sv) + extra); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3295
|
55054
|
|
|
|
|
return SvCUR(sv); |
3296
|
|
|
|
|
|
} |
3297
|
|
|
|
|
|
|
3298
|
4474294
|
100
|
|
|
|
if (SvCUR(sv) == 0) { |
3299
|
947628
|
100
|
|
|
|
if (extra) SvGROW(sv, extra); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3300
|
|
|
|
|
|
} else { /* Assume Latin-1/EBCDIC */ |
3301
|
|
|
|
|
|
/* This function could be much more efficient if we |
3302
|
|
|
|
|
|
* had a FLAG in SVs to signal if there are any variant |
3303
|
|
|
|
|
|
* chars in the PV. Given that there isn't such a flag |
3304
|
|
|
|
|
|
* make the loop as fast as possible (although there are certainly ways |
3305
|
|
|
|
|
|
* to speed this up, eg. through vectorization) */ |
3306
|
3526666
|
|
|
|
|
U8 * s = (U8 *) SvPVX_const(sv); |
3307
|
3526666
|
|
|
|
|
U8 * e = (U8 *) SvEND(sv); |
3308
|
|
|
|
|
|
U8 *t = s; |
3309
|
|
|
|
|
|
STRLEN two_byte_count = 0; |
3310
|
|
|
|
|
|
|
3311
|
3526666
|
100
|
|
|
|
if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; |
3312
|
|
|
|
|
|
|
3313
|
|
|
|
|
|
/* See if really will need to convert to utf8. We mustn't rely on our |
3314
|
|
|
|
|
|
* incoming SV being well formed and having a trailing '\0', as certain |
3315
|
|
|
|
|
|
* code in pp_formline can send us partially built SVs. */ |
3316
|
|
|
|
|
|
|
3317
|
40563332
|
100
|
|
|
|
while (t < e) { |
3318
|
37381256
|
|
|
|
|
const U8 ch = *t++; |
3319
|
37381256
|
100
|
|
|
|
if (NATIVE_IS_INVARIANT(ch)) continue; |
3320
|
|
|
|
|
|
|
3321
|
|
|
|
|
|
t--; /* t already incremented; re-point to first variant */ |
3322
|
|
|
|
|
|
two_byte_count = 1; |
3323
|
|
|
|
|
|
goto must_be_utf8; |
3324
|
|
|
|
|
|
} |
3325
|
|
|
|
|
|
|
3326
|
|
|
|
|
|
/* utf8 conversion not needed because all are invariants. Mark as |
3327
|
|
|
|
|
|
* UTF-8 even if no variant - saves scanning loop */ |
3328
|
3182076
|
|
|
|
|
SvUTF8_on(sv); |
3329
|
3182076
|
100
|
|
|
|
if (extra) SvGROW(sv, SvCUR(sv) + extra); |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3330
|
3182076
|
|
|
|
|
return SvCUR(sv); |
3331
|
|
|
|
|
|
|
3332
|
|
|
|
|
|
must_be_utf8: |
3333
|
|
|
|
|
|
|
3334
|
|
|
|
|
|
/* Here, the string should be converted to utf8, either because of an |
3335
|
|
|
|
|
|
* input flag (two_byte_count = 0), or because a character that |
3336
|
|
|
|
|
|
* requires 2 bytes was found (two_byte_count = 1). t points either to |
3337
|
|
|
|
|
|
* the beginning of the string (if we didn't examine anything), or to |
3338
|
|
|
|
|
|
* the first variant. In either case, everything from s to t - 1 will |
3339
|
|
|
|
|
|
* occupy only 1 byte each on output. |
3340
|
|
|
|
|
|
* |
3341
|
|
|
|
|
|
* There are two main ways to convert. One is to create a new string |
3342
|
|
|
|
|
|
* and go through the input starting from the beginning, appending each |
3343
|
|
|
|
|
|
* converted value onto the new string as we go along. It's probably |
3344
|
|
|
|
|
|
* best to allocate enough space in the string for the worst possible |
3345
|
|
|
|
|
|
* case rather than possibly running out of space and having to |
3346
|
|
|
|
|
|
* reallocate and then copy what we've done so far. Since everything |
3347
|
|
|
|
|
|
* from s to t - 1 is invariant, the destination can be initialized |
3348
|
|
|
|
|
|
* with these using a fast memory copy |
3349
|
|
|
|
|
|
* |
3350
|
|
|
|
|
|
* The other way is to figure out exactly how big the string should be |
3351
|
|
|
|
|
|
* by parsing the entire input. Then you don't have to make it big |
3352
|
|
|
|
|
|
* enough to handle the worst possible case, and more importantly, if |
3353
|
|
|
|
|
|
* the string you already have is large enough, you don't have to |
3354
|
|
|
|
|
|
* allocate a new string, you can copy the last character in the input |
3355
|
|
|
|
|
|
* string to the final position(s) that will be occupied by the |
3356
|
|
|
|
|
|
* converted string and go backwards, stopping at t, since everything |
3357
|
|
|
|
|
|
* before that is invariant. |
3358
|
|
|
|
|
|
* |
3359
|
|
|
|
|
|
* There are advantages and disadvantages to each method. |
3360
|
|
|
|
|
|
* |
3361
|
|
|
|
|
|
* In the first method, we can allocate a new string, do the memory |
3362
|
|
|
|
|
|
* copy from the s to t - 1, and then proceed through the rest of the |
3363
|
|
|
|
|
|
* string byte-by-byte. |
3364
|
|
|
|
|
|
* |
3365
|
|
|
|
|
|
* In the second method, we proceed through the rest of the input |
3366
|
|
|
|
|
|
* string just calculating how big the converted string will be. Then |
3367
|
|
|
|
|
|
* there are two cases: |
3368
|
|
|
|
|
|
* 1) if the string has enough extra space to handle the converted |
3369
|
|
|
|
|
|
* value. We go backwards through the string, converting until we |
3370
|
|
|
|
|
|
* get to the position we are at now, and then stop. If this |
3371
|
|
|
|
|
|
* position is far enough along in the string, this method is |
3372
|
|
|
|
|
|
* faster than the other method. If the memory copy were the same |
3373
|
|
|
|
|
|
* speed as the byte-by-byte loop, that position would be about |
3374
|
|
|
|
|
|
* half-way, as at the half-way mark, parsing to the end and back |
3375
|
|
|
|
|
|
* is one complete string's parse, the same amount as starting |
3376
|
|
|
|
|
|
* over and going all the way through. Actually, it would be |
3377
|
|
|
|
|
|
* somewhat less than half-way, as it's faster to just count bytes |
3378
|
|
|
|
|
|
* than to also copy, and we don't have the overhead of allocating |
3379
|
|
|
|
|
|
* a new string, changing the scalar to use it, and freeing the |
3380
|
|
|
|
|
|
* existing one. But if the memory copy is fast, the break-even |
3381
|
|
|
|
|
|
* point is somewhere after half way. The counting loop could be |
3382
|
|
|
|
|
|
* sped up by vectorization, etc, to move the break-even point |
3383
|
|
|
|
|
|
* further towards the beginning. |
3384
|
|
|
|
|
|
* 2) if the string doesn't have enough space to handle the converted |
3385
|
|
|
|
|
|
* value. A new string will have to be allocated, and one might |
3386
|
|
|
|
|
|
* as well, given that, start from the beginning doing the first |
3387
|
|
|
|
|
|
* method. We've spent extra time parsing the string and in |
3388
|
|
|
|
|
|
* exchange all we've gotten is that we know precisely how big to |
3389
|
|
|
|
|
|
* make the new one. Perl is more optimized for time than space, |
3390
|
|
|
|
|
|
* so this case is a loser. |
3391
|
|
|
|
|
|
* So what I've decided to do is not use the 2nd method unless it is |
3392
|
|
|
|
|
|
* guaranteed that a new string won't have to be allocated, assuming |
3393
|
|
|
|
|
|
* the worst case. I also decided not to put any more conditions on it |
3394
|
|
|
|
|
|
* than this, for now. It seems likely that, since the worst case is |
3395
|
|
|
|
|
|
* twice as big as the unknown portion of the string (plus 1), we won't |
3396
|
|
|
|
|
|
* be guaranteed enough space, causing us to go to the first method, |
3397
|
|
|
|
|
|
* unless the string is short, or the first variant character is near |
3398
|
|
|
|
|
|
* the end of it. In either of these cases, it seems best to use the |
3399
|
|
|
|
|
|
* 2nd method. The only circumstance I can think of where this would |
3400
|
|
|
|
|
|
* be really slower is if the string had once had much more data in it |
3401
|
|
|
|
|
|
* than it does now, but there is still a substantial amount in it */ |
3402
|
|
|
|
|
|
|
3403
|
|
|
|
|
|
{ |
3404
|
344590
|
|
|
|
|
STRLEN invariant_head = t - s; |
3405
|
344590
|
|
|
|
|
STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; |
3406
|
344590
|
100
|
|
|
|
if (SvLEN(sv) < size) { |
3407
|
|
|
|
|
|
|
3408
|
|
|
|
|
|
/* Here, have decided to allocate a new string */ |
3409
|
|
|
|
|
|
|
3410
|
|
|
|
|
|
U8 *dst; |
3411
|
|
|
|
|
|
U8 *d; |
3412
|
|
|
|
|
|
|
3413
|
4134
|
|
|
|
|
Newx(dst, size, U8); |
3414
|
|
|
|
|
|
|
3415
|
|
|
|
|
|
/* If no known invariants at the beginning of the input string, |
3416
|
|
|
|
|
|
* set so starts from there. Otherwise, can use memory copy to |
3417
|
|
|
|
|
|
* get up to where we are now, and then start from here */ |
3418
|
|
|
|
|
|
|
3419
|
4404
|
100
|
|
|
|
if (invariant_head <= 0) { |
3420
|
|
|
|
|
|
d = dst; |
3421
|
|
|
|
|
|
} else { |
3422
|
540
|
|
|
|
|
Copy(s, dst, invariant_head, char); |
3423
|
540
|
|
|
|
|
d = dst + invariant_head; |
3424
|
|
|
|
|
|
} |
3425
|
|
|
|
|
|
|
3426
|
205176
|
100
|
|
|
|
while (t < e) { |
3427
|
201042
|
|
|
|
|
append_utf8_from_native_byte(*t, &d); |
3428
|
201042
|
|
|
|
|
t++; |
3429
|
|
|
|
|
|
} |
3430
|
4134
|
|
|
|
|
*d = '\0'; |
3431
|
4134
|
50
|
|
|
|
SvPV_free(sv); /* No longer using pre-existing string */ |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3432
|
4134
|
|
|
|
|
SvPV_set(sv, (char*)dst); |
3433
|
4134
|
|
|
|
|
SvCUR_set(sv, d - dst); |
3434
|
4134
|
|
|
|
|
SvLEN_set(sv, size); |
3435
|
|
|
|
|
|
} else { |
3436
|
|
|
|
|
|
|
3437
|
|
|
|
|
|
/* Here, have decided to get the exact size of the string. |
3438
|
|
|
|
|
|
* Currently this happens only when we know that there is |
3439
|
|
|
|
|
|
* guaranteed enough space to fit the converted string, so |
3440
|
|
|
|
|
|
* don't have to worry about growing. If two_byte_count is 0, |
3441
|
|
|
|
|
|
* then t points to the first byte of the string which hasn't |
3442
|
|
|
|
|
|
* been examined yet. Otherwise two_byte_count is 1, and t |
3443
|
|
|
|
|
|
* points to the first byte in the string that will expand to |
3444
|
|
|
|
|
|
* two. Depending on this, start examining at t or 1 after t. |
3445
|
|
|
|
|
|
* */ |
3446
|
|
|
|
|
|
|
3447
|
340456
|
|
|
|
|
U8 *d = t + two_byte_count; |
3448
|
|
|
|
|
|
|
3449
|
|
|
|
|
|
|
3450
|
|
|
|
|
|
/* Count up the remaining bytes that expand to two */ |
3451
|
|
|
|
|
|
|
3452
|
871014
|
100
|
|
|
|
while (d < e) { |
3453
|
360330
|
|
|
|
|
const U8 chr = *d++; |
3454
|
360330
|
100
|
|
|
|
if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++; |
3455
|
|
|
|
|
|
} |
3456
|
|
|
|
|
|
|
3457
|
|
|
|
|
|
/* The string will expand by just the number of bytes that |
3458
|
|
|
|
|
|
* occupy two positions. But we are one afterwards because of |
3459
|
|
|
|
|
|
* the increment just above. This is the place to put the |
3460
|
|
|
|
|
|
* trailing NUL, and to set the length before we decrement */ |
3461
|
|
|
|
|
|
|
3462
|
340456
|
|
|
|
|
d += two_byte_count; |
3463
|
340456
|
|
|
|
|
SvCUR_set(sv, d - s); |
3464
|
340456
|
|
|
|
|
*d-- = '\0'; |
3465
|
|
|
|
|
|
|
3466
|
|
|
|
|
|
|
3467
|
|
|
|
|
|
/* Having decremented d, it points to the position to put the |
3468
|
|
|
|
|
|
* very last byte of the expanded string. Go backwards through |
3469
|
|
|
|
|
|
* the string, copying and expanding as we go, stopping when we |
3470
|
|
|
|
|
|
* get to the part that is invariant the rest of the way down */ |
3471
|
|
|
|
|
|
|
3472
|
340456
|
|
|
|
|
e--; |
3473
|
1138618
|
100
|
|
|
|
while (e >= t) { |
3474
|
627934
|
100
|
|
|
|
if (NATIVE_IS_INVARIANT(*e)) { |
3475
|
218304
|
|
|
|
|
*d-- = *e; |
3476
|
|
|
|
|
|
} else { |
3477
|
409630
|
|
|
|
|
*d-- = UTF8_EIGHT_BIT_LO(*e); |
3478
|
409630
|
|
|
|
|
*d-- = UTF8_EIGHT_BIT_HI(*e); |
3479
|
|
|
|
|
|
} |
3480
|
627934
|
|
|
|
|
e--; |
3481
|
|
|
|
|
|
} |
3482
|
|
|
|
|
|
} |
3483
|
|
|
|
|
|
|
3484
|
344590
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
100
|
|
|
|
|
3485
|
|
|
|
|
|
/* Update pos. We do it at the end rather than during |
3486
|
|
|
|
|
|
* the upgrade, to avoid slowing down the common case |
3487
|
|
|
|
|
|
* (upgrade without pos). |
3488
|
|
|
|
|
|
* pos can be stored as either bytes or characters. Since |
3489
|
|
|
|
|
|
* this was previously a byte string we can just turn off |
3490
|
|
|
|
|
|
* the bytes flag. */ |
3491
|
540
|
|
|
|
|
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); |
3492
|
540
|
100
|
|
|
|
if (mg) { |
3493
|
328
|
|
|
|
|
mg->mg_flags &= ~MGf_BYTES; |
3494
|
|
|
|
|
|
} |
3495
|
540
|
100
|
|
|
|
if ((mg = mg_find(sv, PERL_MAGIC_utf8))) |
3496
|
220
|
|
|
|
|
magic_setutf8(sv,mg); /* clear UTF8 cache */ |
3497
|
|
|
|
|
|
} |
3498
|
|
|
|
|
|
} |
3499
|
|
|
|
|
|
} |
3500
|
|
|
|
|
|
|
3501
|
|
|
|
|
|
/* Mark as UTF-8 even if no variant - saves scanning loop */ |
3502
|
1292218
|
|
|
|
|
SvUTF8_on(sv); |
3503
|
3338441
|
|
|
|
|
return SvCUR(sv); |
3504
|
|
|
|
|
|
} |
3505
|
|
|
|
|
|
|
3506
|
|
|
|
|
|
/* |
3507
|
|
|
|
|
|
=for apidoc sv_utf8_downgrade |
3508
|
|
|
|
|
|
|
3509
|
|
|
|
|
|
Attempts to convert the PV of an SV from characters to bytes. |
3510
|
|
|
|
|
|
If the PV contains a character that cannot fit |
3511
|
|
|
|
|
|
in a byte, this conversion will fail; |
3512
|
|
|
|
|
|
in this case, either returns false or, if C is not |
3513
|
|
|
|
|
|
true, croaks. |
3514
|
|
|
|
|
|
|
3515
|
|
|
|
|
|
This is not a general purpose Unicode to byte encoding interface: |
3516
|
|
|
|
|
|
use the Encode extension for that. |
3517
|
|
|
|
|
|
|
3518
|
|
|
|
|
|
=cut |
3519
|
|
|
|
|
|
*/ |
3520
|
|
|
|
|
|
|
3521
|
|
|
|
|
|
bool |
3522
|
877692
|
|
|
|
|
Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) |
3523
|
|
|
|
|
|
{ |
3524
|
|
|
|
|
|
dVAR; |
3525
|
|
|
|
|
|
|
3526
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; |
3527
|
|
|
|
|
|
|
3528
|
877692
|
100
|
|
|
|
if (SvPOKp(sv) && SvUTF8(sv)) { |
3529
|
170456
|
100
|
|
|
|
if (SvCUR(sv)) { |
3530
|
|
|
|
|
|
U8 *s; |
3531
|
|
|
|
|
|
STRLEN len; |
3532
|
|
|
|
|
|
int mg_flags = SV_GMAGIC; |
3533
|
|
|
|
|
|
|
3534
|
170454
|
100
|
|
|
|
if (SvIsCOW(sv)) { |
3535
|
860
|
|
|
|
|
S_sv_uncow(aTHX_ sv, 0); |
3536
|
|
|
|
|
|
} |
3537
|
170454
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
100
|
|
|
|
|
3538
|
|
|
|
|
|
/* update pos */ |
3539
|
416
|
|
|
|
|
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); |
3540
|
416
|
100
|
|
|
|
if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3541
|
0
|
|
|
|
|
mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, |
3542
|
|
|
|
|
|
SV_GMAGIC|SV_CONST_RETURN); |
3543
|
|
|
|
|
|
mg_flags = 0; /* sv_pos_b2u does get magic */ |
3544
|
|
|
|
|
|
} |
3545
|
416
|
100
|
|
|
|
if ((mg = mg_find(sv, PERL_MAGIC_utf8))) |
3546
|
380
|
|
|
|
|
magic_setutf8(sv,mg); /* clear UTF8 cache */ |
3547
|
|
|
|
|
|
|
3548
|
|
|
|
|
|
} |
3549
|
170454
|
50
|
|
|
|
s = (U8 *) SvPV_flags(sv, len, mg_flags); |
3550
|
|
|
|
|
|
|
3551
|
170454
|
100
|
|
|
|
if (!utf8_to_bytes(s, &len)) { |
3552
|
766
|
100
|
|
|
|
if (fail_ok) |
3553
|
|
|
|
|
|
return FALSE; |
3554
|
|
|
|
|
|
else { |
3555
|
30
|
50
|
|
|
|
if (PL_op) |
3556
|
45
|
50
|
|
|
|
Perl_croak(aTHX_ "Wide character in %s", |
3557
|
15
|
0
|
|
|
|
OP_DESC(PL_op)); |
3558
|
|
|
|
|
|
else |
3559
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Wide character"); |
3560
|
|
|
|
|
|
} |
3561
|
|
|
|
|
|
} |
3562
|
169688
|
|
|
|
|
SvCUR_set(sv, len); |
3563
|
|
|
|
|
|
} |
3564
|
|
|
|
|
|
} |
3565
|
876926
|
|
|
|
|
SvUTF8_off(sv); |
3566
|
877294
|
|
|
|
|
return TRUE; |
3567
|
|
|
|
|
|
} |
3568
|
|
|
|
|
|
|
3569
|
|
|
|
|
|
/* |
3570
|
|
|
|
|
|
=for apidoc sv_utf8_encode |
3571
|
|
|
|
|
|
|
3572
|
|
|
|
|
|
Converts the PV of an SV to UTF-8, but then turns the C |
3573
|
|
|
|
|
|
flag off so that it looks like octets again. |
3574
|
|
|
|
|
|
|
3575
|
|
|
|
|
|
=cut |
3576
|
|
|
|
|
|
*/ |
3577
|
|
|
|
|
|
|
3578
|
|
|
|
|
|
void |
3579
|
931500
|
|
|
|
|
Perl_sv_utf8_encode(pTHX_ SV *const sv) |
3580
|
|
|
|
|
|
{ |
3581
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UTF8_ENCODE; |
3582
|
|
|
|
|
|
|
3583
|
931500
|
100
|
|
|
|
if (SvREADONLY(sv)) { |
3584
|
2
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
3585
|
|
|
|
|
|
} |
3586
|
931498
|
|
|
|
|
(void) sv_utf8_upgrade(sv); |
3587
|
931498
|
|
|
|
|
SvUTF8_off(sv); |
3588
|
931498
|
|
|
|
|
} |
3589
|
|
|
|
|
|
|
3590
|
|
|
|
|
|
/* |
3591
|
|
|
|
|
|
=for apidoc sv_utf8_decode |
3592
|
|
|
|
|
|
|
3593
|
|
|
|
|
|
If the PV of the SV is an octet sequence in UTF-8 |
3594
|
|
|
|
|
|
and contains a multiple-byte character, the C flag is turned on |
3595
|
|
|
|
|
|
so that it looks like a character. If the PV contains only single-byte |
3596
|
|
|
|
|
|
characters, the C flag stays off. |
3597
|
|
|
|
|
|
Scans PV for validity and returns false if the PV is invalid UTF-8. |
3598
|
|
|
|
|
|
|
3599
|
|
|
|
|
|
=cut |
3600
|
|
|
|
|
|
*/ |
3601
|
|
|
|
|
|
|
3602
|
|
|
|
|
|
bool |
3603
|
4930
|
|
|
|
|
Perl_sv_utf8_decode(pTHX_ SV *const sv) |
3604
|
|
|
|
|
|
{ |
3605
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UTF8_DECODE; |
3606
|
|
|
|
|
|
|
3607
|
4930
|
50
|
|
|
|
if (SvPOKp(sv)) { |
3608
|
|
|
|
|
|
const U8 *start, *c; |
3609
|
|
|
|
|
|
const U8 *e; |
3610
|
|
|
|
|
|
|
3611
|
|
|
|
|
|
/* The octets may have got themselves encoded - get them back as |
3612
|
|
|
|
|
|
* bytes |
3613
|
|
|
|
|
|
*/ |
3614
|
4930
|
100
|
|
|
|
if (!sv_utf8_downgrade(sv, TRUE)) |
3615
|
|
|
|
|
|
return FALSE; |
3616
|
|
|
|
|
|
|
3617
|
|
|
|
|
|
/* it is actually just a matter of turning the utf8 flag on, but |
3618
|
|
|
|
|
|
* we want to make sure everything inside is valid utf8 first. |
3619
|
|
|
|
|
|
*/ |
3620
|
4926
|
|
|
|
|
c = start = (const U8 *) SvPVX_const(sv); |
3621
|
4926
|
100
|
|
|
|
if (!is_utf8_string(c, SvCUR(sv))) |
3622
|
|
|
|
|
|
return FALSE; |
3623
|
4920
|
|
|
|
|
e = (const U8 *) SvEND(sv); |
3624
|
350950
|
100
|
|
|
|
while (c < e) { |
3625
|
347834
|
|
|
|
|
const U8 ch = *c++; |
3626
|
347834
|
100
|
|
|
|
if (!UTF8_IS_INVARIANT(ch)) { |
3627
|
4264
|
|
|
|
|
SvUTF8_on(sv); |
3628
|
4264
|
|
|
|
|
break; |
3629
|
|
|
|
|
|
} |
3630
|
|
|
|
|
|
} |
3631
|
4920
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
50
|
|
|
|
|
3632
|
|
|
|
|
|
/* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC |
3633
|
|
|
|
|
|
after this, clearing pos. Does anything on CPAN |
3634
|
|
|
|
|
|
need this? */ |
3635
|
|
|
|
|
|
/* adjust pos to the start of a UTF8 char sequence */ |
3636
|
26
|
|
|
|
|
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); |
3637
|
26
|
100
|
|
|
|
if (mg) { |
3638
|
24
|
|
|
|
|
I32 pos = mg->mg_len; |
3639
|
24
|
100
|
|
|
|
if (pos > 0) { |
3640
|
36
|
50
|
|
|
|
for (c = start + pos; c > start; c--) { |
3641
|
36
|
100
|
|
|
|
if (UTF8_IS_START(*c)) |
3642
|
|
|
|
|
|
break; |
3643
|
|
|
|
|
|
} |
3644
|
20
|
|
|
|
|
mg->mg_len = c - start; |
3645
|
|
|
|
|
|
} |
3646
|
|
|
|
|
|
} |
3647
|
26
|
100
|
|
|
|
if ((mg = mg_find(sv, PERL_MAGIC_utf8))) |
3648
|
2477
|
|
|
|
|
magic_setutf8(sv,mg); /* clear UTF8 cache */ |
3649
|
|
|
|
|
|
} |
3650
|
|
|
|
|
|
} |
3651
|
|
|
|
|
|
return TRUE; |
3652
|
|
|
|
|
|
} |
3653
|
|
|
|
|
|
|
3654
|
|
|
|
|
|
/* |
3655
|
|
|
|
|
|
=for apidoc sv_setsv |
3656
|
|
|
|
|
|
|
3657
|
|
|
|
|
|
Copies the contents of the source SV C into the destination SV |
3658
|
|
|
|
|
|
C. The source SV may be destroyed if it is mortal, so don't use this |
3659
|
|
|
|
|
|
function if the source SV needs to be reused. Does not handle 'set' magic. |
3660
|
|
|
|
|
|
Loosely speaking, it performs a copy-by-value, obliterating any previous |
3661
|
|
|
|
|
|
content of the destination. |
3662
|
|
|
|
|
|
|
3663
|
|
|
|
|
|
You probably want to use one of the assortment of wrappers, such as |
3664
|
|
|
|
|
|
C, C, C and |
3665
|
|
|
|
|
|
C. |
3666
|
|
|
|
|
|
|
3667
|
|
|
|
|
|
=for apidoc sv_setsv_flags |
3668
|
|
|
|
|
|
|
3669
|
|
|
|
|
|
Copies the contents of the source SV C into the destination SV |
3670
|
|
|
|
|
|
C. The source SV may be destroyed if it is mortal, so don't use this |
3671
|
|
|
|
|
|
function if the source SV needs to be reused. Does not handle 'set' magic. |
3672
|
|
|
|
|
|
Loosely speaking, it performs a copy-by-value, obliterating any previous |
3673
|
|
|
|
|
|
content of the destination. |
3674
|
|
|
|
|
|
If the C parameter has the C bit set, will C on |
3675
|
|
|
|
|
|
C if appropriate, else not. If the C |
3676
|
|
|
|
|
|
parameter has the C bit set then the |
3677
|
|
|
|
|
|
buffers of temps will not be stolen. |
3678
|
|
|
|
|
|
and C are implemented in terms of this function. |
3679
|
|
|
|
|
|
|
3680
|
|
|
|
|
|
You probably want to use one of the assortment of wrappers, such as |
3681
|
|
|
|
|
|
C, C, C and |
3682
|
|
|
|
|
|
C. |
3683
|
|
|
|
|
|
|
3684
|
|
|
|
|
|
This is the primary function for copying scalars, and most other |
3685
|
|
|
|
|
|
copy-ish functions and macros use this underneath. |
3686
|
|
|
|
|
|
|
3687
|
|
|
|
|
|
=cut |
3688
|
|
|
|
|
|
*/ |
3689
|
|
|
|
|
|
|
3690
|
|
|
|
|
|
static void |
3691
|
27508108
|
|
|
|
|
S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) |
3692
|
|
|
|
|
|
{ |
3693
|
|
|
|
|
|
I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */ |
3694
|
|
|
|
|
|
HV *old_stash = NULL; |
3695
|
|
|
|
|
|
|
3696
|
|
|
|
|
|
PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; |
3697
|
|
|
|
|
|
|
3698
|
54919784
|
100
|
|
|
|
if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) { |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
3699
|
27411676
|
|
|
|
|
const char * const name = GvNAME(sstr); |
3700
|
27411676
|
|
|
|
|
const STRLEN len = GvNAMELEN(sstr); |
3701
|
|
|
|
|
|
{ |
3702
|
27411676
|
100
|
|
|
|
if (dtype >= SVt_PV) { |
3703
|
27054806
|
100
|
|
|
|
SvPV_free(dstr); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3704
|
27054806
|
|
|
|
|
SvPV_set(dstr, 0); |
3705
|
27054806
|
|
|
|
|
SvLEN_set(dstr, 0); |
3706
|
27054806
|
|
|
|
|
SvCUR_set(dstr, 0); |
3707
|
|
|
|
|
|
} |
3708
|
41117378
|
|
|
|
|
SvUPGRADE(dstr, SVt_PVGV); |
3709
|
27411676
|
50
|
|
|
|
(void)SvOK_off(dstr); |
3710
|
|
|
|
|
|
/* We have to turn this on here, even though we turn it off |
3711
|
|
|
|
|
|
below, as GvSTASH will fail an assertion otherwise. */ |
3712
|
27411676
|
|
|
|
|
isGV_with_GP_on(dstr); |
3713
|
|
|
|
|
|
} |
3714
|
27411676
|
|
|
|
|
GvSTASH(dstr) = GvSTASH(sstr); |
3715
|
27411676
|
100
|
|
|
|
if (GvSTASH(dstr)) |
3716
|
27411624
|
|
|
|
|
Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); |
3717
|
27411676
|
100
|
|
|
|
gv_name_set(MUTABLE_GV(dstr), name, len, |
3718
|
|
|
|
|
|
GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 )); |
3719
|
27411676
|
|
|
|
|
SvFAKE_on(dstr); /* can coerce to non-glob */ |
3720
|
|
|
|
|
|
} |
3721
|
|
|
|
|
|
|
3722
|
27508108
|
50
|
|
|
|
if(GvGP(MUTABLE_GV(sstr))) { |
3723
|
|
|
|
|
|
/* If source has method cache entry, clear it */ |
3724
|
27508108
|
100
|
|
|
|
if(GvCVGEN(sstr)) { |
3725
|
749856
|
|
|
|
|
SvREFCNT_dec(GvCV(sstr)); |
3726
|
749856
|
|
|
|
|
GvCV_set(sstr, NULL); |
3727
|
749856
|
|
|
|
|
GvCVGEN(sstr) = 0; |
3728
|
|
|
|
|
|
} |
3729
|
|
|
|
|
|
/* If source has a real method, then a method is |
3730
|
|
|
|
|
|
going to change */ |
3731
|
26758252
|
100
|
|
|
|
else if( |
3732
|
32982001
|
100
|
|
|
|
GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3733
|
|
|
|
|
|
) { |
3734
|
|
|
|
|
|
mro_changes = 1; |
3735
|
|
|
|
|
|
} |
3736
|
|
|
|
|
|
} |
3737
|
|
|
|
|
|
|
3738
|
|
|
|
|
|
/* If dest already had a real method, that's a change as well */ |
3739
|
27508108
|
100
|
|
|
|
if( |
3740
|
7904170
|
100
|
|
|
|
!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3741
|
46
|
100
|
|
|
|
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3742
|
|
|
|
|
|
) { |
3743
|
|
|
|
|
|
mro_changes = 1; |
3744
|
|
|
|
|
|
} |
3745
|
|
|
|
|
|
|
3746
|
|
|
|
|
|
/* We don't need to check the name of the destination if it was not a |
3747
|
|
|
|
|
|
glob to begin with. */ |
3748
|
27508108
|
100
|
|
|
|
if(dtype == SVt_PVGV) { |
3749
|
96432
|
|
|
|
|
const char * const name = GvNAME((const GV *)dstr); |
3750
|
96432
|
100
|
|
|
|
if( |
3751
|
96432
|
100
|
|
|
|
strEQ(name,"ISA") |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3752
|
|
|
|
|
|
/* The stash may have been detached from the symbol table, so |
3753
|
|
|
|
|
|
check its name. */ |
3754
|
16
|
100
|
|
|
|
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3755
|
|
|
|
|
|
) |
3756
|
|
|
|
|
|
mro_changes = 2; |
3757
|
|
|
|
|
|
else { |
3758
|
96420
|
|
|
|
|
const STRLEN len = GvNAMELEN(dstr); |
3759
|
96420
|
100
|
|
|
|
if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
3760
|
96288
|
100
|
|
|
|
|| (len == 1 && name[0] == ':')) { |
|
|
50
|
|
|
|
|
3761
|
|
|
|
|
|
mro_changes = 3; |
3762
|
|
|
|
|
|
|
3763
|
|
|
|
|
|
/* Set aside the old stash, so we can reset isa caches on |
3764
|
|
|
|
|
|
its subclasses. */ |
3765
|
132
|
50
|
|
|
|
if((old_stash = GvHV(dstr))) |
3766
|
|
|
|
|
|
/* Make sure we do not lose it early. */ |
3767
|
132
|
|
|
|
|
SvREFCNT_inc_simple_void_NN( |
3768
|
|
|
|
|
|
sv_2mortal((SV *)old_stash) |
3769
|
|
|
|
|
|
); |
3770
|
|
|
|
|
|
} |
3771
|
|
|
|
|
|
} |
3772
|
|
|
|
|
|
} |
3773
|
|
|
|
|
|
|
3774
|
27508108
|
|
|
|
|
gp_free(MUTABLE_GV(dstr)); |
3775
|
27508108
|
|
|
|
|
isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */ |
3776
|
27508108
|
50
|
|
|
|
(void)SvOK_off(dstr); |
3777
|
27508108
|
|
|
|
|
isGV_with_GP_on(dstr); |
3778
|
27508108
|
|
|
|
|
GvINTRO_off(dstr); /* one-shot flag */ |
3779
|
27508108
|
|
|
|
|
GvGP_set(dstr, gp_ref(GvGP(sstr))); |
3780
|
27508108
|
100
|
|
|
|
if (SvTAINTED(sstr)) |
|
|
50
|
|
|
|
|
3781
|
0
|
0
|
|
|
|
SvTAINT(dstr); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
3782
|
27508108
|
100
|
|
|
|
if (GvIMPORTED(dstr) != GVf_IMPORTED |
3783
|
27507988
|
100
|
|
|
|
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) |
3784
|
|
|
|
|
|
{ |
3785
|
24987980
|
|
|
|
|
GvIMPORTED_on(dstr); |
3786
|
|
|
|
|
|
} |
3787
|
27508108
|
|
|
|
|
GvMULTI_on(dstr); |
3788
|
27508108
|
100
|
|
|
|
if(mro_changes == 2) { |
3789
|
12
|
100
|
|
|
|
if (GvAV((const GV *)sstr)) { |
3790
|
|
|
|
|
|
MAGIC *mg; |
3791
|
10
|
|
|
|
|
SV * const sref = (SV *)GvAV((const GV *)dstr); |
3792
|
10
|
50
|
|
|
|
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { |
|
|
50
|
|
|
|
|
3793
|
10
|
50
|
|
|
|
if (SvTYPE(mg->mg_obj) != SVt_PVAV) { |
3794
|
10
|
|
|
|
|
AV * const ary = newAV(); |
3795
|
10
|
|
|
|
|
av_push(ary, mg->mg_obj); /* takes the refcount */ |
3796
|
10
|
|
|
|
|
mg->mg_obj = (SV *)ary; |
3797
|
|
|
|
|
|
} |
3798
|
10
|
|
|
|
|
av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr)); |
3799
|
|
|
|
|
|
} |
3800
|
0
|
|
|
|
|
else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); |
3801
|
|
|
|
|
|
} |
3802
|
12
|
|
|
|
|
mro_isa_changed_in(GvSTASH(dstr)); |
3803
|
|
|
|
|
|
} |
3804
|
27508096
|
100
|
|
|
|
else if(mro_changes == 3) { |
3805
|
132
|
|
|
|
|
HV * const stash = GvHV(dstr); |
3806
|
132
|
50
|
|
|
|
if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3807
|
132
|
|
|
|
|
mro_package_moved( |
3808
|
|
|
|
|
|
stash, old_stash, |
3809
|
|
|
|
|
|
(GV *)dstr, 0 |
3810
|
|
|
|
|
|
); |
3811
|
|
|
|
|
|
} |
3812
|
27507964
|
100
|
|
|
|
else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); |
3813
|
27508108
|
50
|
|
|
|
if (GvIO(dstr) && dtype == SVt_PVGV) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3814
|
|
|
|
|
|
DEBUG_o(Perl_deb(aTHX_ |
3815
|
|
|
|
|
|
"glob_assign_glob clearing PL_stashcache\n")); |
3816
|
|
|
|
|
|
/* It's a cache. It will rebuild itself quite happily. |
3817
|
|
|
|
|
|
It's a lot of effort to work out exactly which key (or keys) |
3818
|
|
|
|
|
|
might be invalidated by the creation of the this file handle. |
3819
|
|
|
|
|
|
*/ |
3820
|
6480
|
|
|
|
|
hv_clear(PL_stashcache); |
3821
|
|
|
|
|
|
} |
3822
|
27508108
|
|
|
|
|
return; |
3823
|
|
|
|
|
|
} |
3824
|
|
|
|
|
|
|
3825
|
|
|
|
|
|
static void |
3826
|
2270345
|
|
|
|
|
S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) |
3827
|
|
|
|
|
|
{ |
3828
|
2270345
|
|
|
|
|
SV * const sref = SvRV(sstr); |
3829
|
|
|
|
|
|
SV *dref; |
3830
|
2270345
|
|
|
|
|
const int intro = GvINTRO(dstr); |
3831
|
|
|
|
|
|
SV **location; |
3832
|
|
|
|
|
|
U8 import_flag = 0; |
3833
|
2270345
|
|
|
|
|
const U32 stype = SvTYPE(sref); |
3834
|
|
|
|
|
|
|
3835
|
|
|
|
|
|
PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; |
3836
|
|
|
|
|
|
|
3837
|
2270345
|
100
|
|
|
|
if (intro) { |
3838
|
311899
|
|
|
|
|
GvINTRO_off(dstr); /* one-shot flag */ |
3839
|
311899
|
|
|
|
|
GvLINE(dstr) = CopLINE(PL_curcop); |
3840
|
311899
|
|
|
|
|
GvEGV(dstr) = MUTABLE_GV(dstr); |
3841
|
|
|
|
|
|
} |
3842
|
2270345
|
|
|
|
|
GvMULTI_on(dstr); |
3843
|
2270345
|
|
|
|
|
switch (stype) { |
3844
|
|
|
|
|
|
case SVt_PVCV: |
3845
|
1768343
|
|
|
|
|
location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */ |
3846
|
|
|
|
|
|
import_flag = GVf_IMPORTED_CV; |
3847
|
1768343
|
|
|
|
|
goto common; |
3848
|
|
|
|
|
|
case SVt_PVHV: |
3849
|
101700
|
|
|
|
|
location = (SV **) &GvHV(dstr); |
3850
|
|
|
|
|
|
import_flag = GVf_IMPORTED_HV; |
3851
|
101700
|
|
|
|
|
goto common; |
3852
|
|
|
|
|
|
case SVt_PVAV: |
3853
|
125240
|
|
|
|
|
location = (SV **) &GvAV(dstr); |
3854
|
|
|
|
|
|
import_flag = GVf_IMPORTED_AV; |
3855
|
125240
|
|
|
|
|
goto common; |
3856
|
|
|
|
|
|
case SVt_PVIO: |
3857
|
20
|
|
|
|
|
location = (SV **) &GvIOp(dstr); |
3858
|
20
|
|
|
|
|
goto common; |
3859
|
|
|
|
|
|
case SVt_PVFM: |
3860
|
24
|
|
|
|
|
location = (SV **) &GvFORM(dstr); |
3861
|
24
|
|
|
|
|
goto common; |
3862
|
|
|
|
|
|
default: |
3863
|
275018
|
|
|
|
|
location = &GvSV(dstr); |
3864
|
|
|
|
|
|
import_flag = GVf_IMPORTED_SV; |
3865
|
|
|
|
|
|
common: |
3866
|
2270345
|
100
|
|
|
|
if (intro) { |
3867
|
311899
|
100
|
|
|
|
if (stype == SVt_PVCV) { |
3868
|
|
|
|
|
|
/*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/ |
3869
|
297598
|
100
|
|
|
|
if (GvCVGEN(dstr)) { |
3870
|
18
|
|
|
|
|
SvREFCNT_dec(GvCV(dstr)); |
3871
|
18
|
|
|
|
|
GvCV_set(dstr, NULL); |
3872
|
18
|
|
|
|
|
GvCVGEN(dstr) = 0; /* Switch off cacheness. */ |
3873
|
|
|
|
|
|
} |
3874
|
|
|
|
|
|
} |
3875
|
|
|
|
|
|
/* SAVEt_GVSLOT takes more room on the savestack and has more |
3876
|
|
|
|
|
|
overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs |
3877
|
|
|
|
|
|
leave_scope needs access to the GV so it can reset method |
3878
|
|
|
|
|
|
caches. We must use SAVEt_GVSLOT whenever the type is |
3879
|
|
|
|
|
|
SVt_PVCV, even if the stash is anonymous, as the stash may |
3880
|
|
|
|
|
|
gain a name somehow before leave_scope. */ |
3881
|
311899
|
100
|
|
|
|
if (stype == SVt_PVCV) { |
3882
|
|
|
|
|
|
/* There is no save_pushptrptrptr. Creating it for this |
3883
|
|
|
|
|
|
one call site would be overkill. So inline the ss add |
3884
|
|
|
|
|
|
routines here. */ |
3885
|
297598
|
|
|
|
|
dSS_ADD; |
3886
|
297598
|
|
|
|
|
SS_ADD_PTR(dstr); |
3887
|
297598
|
|
|
|
|
SS_ADD_PTR(location); |
3888
|
595196
|
|
|
|
|
SS_ADD_PTR(SvREFCNT_inc(*location)); |
3889
|
297598
|
|
|
|
|
SS_ADD_UV(SAVEt_GVSLOT); |
3890
|
297598
|
50
|
|
|
|
SS_ADD_END(4); |
3891
|
|
|
|
|
|
} |
3892
|
14301
|
|
|
|
|
else SAVEGENERICSV(*location); |
3893
|
|
|
|
|
|
} |
3894
|
2270345
|
|
|
|
|
dref = *location; |
3895
|
2270345
|
100
|
|
|
|
if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
3896
|
1738169
|
|
|
|
|
CV* const cv = MUTABLE_CV(*location); |
3897
|
1738169
|
100
|
|
|
|
if (cv) { |
3898
|
476808
|
100
|
|
|
|
if (!GvCVGEN((const GV *)dstr) && |
|
|
100
|
|
|
|
|
3899
|
476802
|
50
|
|
|
|
(CvROOT(cv) || CvXSUB(cv)) && |
|
|
100
|
|
|
|
|
3900
|
|
|
|
|
|
/* redundant check that avoids creating the extra SV |
3901
|
|
|
|
|
|
most of the time: */ |
3902
|
446446
|
100
|
|
|
|
(CvCONST(cv) || ckWARN(WARN_REDEFINE))) |
3903
|
|
|
|
|
|
{ |
3904
|
18574
|
|
|
|
|
SV * const new_const_sv = |
3905
|
18574
|
|
|
|
|
CvCONST((const CV *)sref) |
3906
|
|
|
|
|
|
? cv_const_sv((const CV *)sref) |
3907
|
18574
|
100
|
|
|
|
: NULL; |
3908
|
18574
|
100
|
|
|
|
report_redefined_cv( |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3909
|
|
|
|
|
|
sv_2mortal(Perl_newSVpvf(aTHX_ |
3910
|
|
|
|
|
|
"%"HEKf"::%"HEKf, |
3911
|
|
|
|
|
|
HEKfARG( |
3912
|
|
|
|
|
|
HvNAME_HEK(GvSTASH((const GV *)dstr)) |
3913
|
|
|
|
|
|
), |
3914
|
|
|
|
|
|
HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))) |
3915
|
|
|
|
|
|
)), |
3916
|
|
|
|
|
|
cv, |
3917
|
|
|
|
|
|
CvCONST((const CV *)sref) ? &new_const_sv : NULL |
3918
|
|
|
|
|
|
); |
3919
|
|
|
|
|
|
} |
3920
|
317868
|
100
|
|
|
|
if (!intro) |
3921
|
27352
|
100
|
|
|
|
cv_ckproto_len_flags(cv, (const GV *)dstr, |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3922
|
|
|
|
|
|
SvPOK(sref) ? CvPROTO(sref) : NULL, |
3923
|
|
|
|
|
|
SvPOK(sref) ? CvPROTOLEN(sref) : 0, |
3924
|
|
|
|
|
|
SvPOK(sref) ? SvUTF8(sref) : 0); |
3925
|
|
|
|
|
|
} |
3926
|
1738163
|
|
|
|
|
GvCVGEN(dstr) = 0; /* Switch off cacheness. */ |
3927
|
1738163
|
|
|
|
|
GvASSUMECV_on(dstr); |
3928
|
1738163
|
50
|
|
|
|
if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ |
|
|
100
|
|
|
|
|
3929
|
|
|
|
|
|
} |
3930
|
2270339
|
|
|
|
|
*location = SvREFCNT_inc_simple_NN(sref); |
3931
|
2270339
|
100
|
|
|
|
if (import_flag && !(GvFLAGS(dstr) & import_flag) |
|
|
100
|
|
|
|
|
3932
|
1927310
|
100
|
|
|
|
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { |
3933
|
1503927
|
|
|
|
|
GvFLAGS(dstr) |= import_flag; |
3934
|
|
|
|
|
|
} |
3935
|
2270339
|
100
|
|
|
|
if (stype == SVt_PVHV) { |
3936
|
101700
|
|
|
|
|
const char * const name = GvNAME((GV*)dstr); |
3937
|
101700
|
|
|
|
|
const STRLEN len = GvNAMELEN(dstr); |
3938
|
101700
|
100
|
|
|
|
if ( |
3939
|
|
|
|
|
|
( |
3940
|
101694
|
100
|
|
|
|
(len > 1 && name[len-2] == ':' && name[len-1] == ':') |
|
|
50
|
|
|
|
|
3941
|
101652
|
100
|
|
|
|
|| (len == 1 && name[0] == ':') |
|
|
50
|
|
|
|
|
3942
|
|
|
|
|
|
) |
3943
|
48
|
50
|
|
|
|
&& (!dref || HvENAME_get(dref)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3944
|
|
|
|
|
|
) { |
3945
|
48
|
|
|
|
|
mro_package_moved( |
3946
|
|
|
|
|
|
(HV *)sref, (HV *)dref, |
3947
|
|
|
|
|
|
(GV *)dstr, 0 |
3948
|
|
|
|
|
|
); |
3949
|
|
|
|
|
|
} |
3950
|
|
|
|
|
|
} |
3951
|
2168639
|
100
|
|
|
|
else if ( |
3952
|
2168639
|
|
|
|
|
stype == SVt_PVAV && sref != dref |
3953
|
9944
|
100
|
|
|
|
&& strEQ(GvNAME((GV*)dstr), "ISA") |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
3954
|
|
|
|
|
|
/* The stash may have been detached from the symbol table, so |
3955
|
|
|
|
|
|
check its name before doing anything. */ |
3956
|
78
|
100
|
|
|
|
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
3957
|
74
|
|
|
|
|
) { |
3958
|
|
|
|
|
|
MAGIC *mg; |
3959
|
74
|
50
|
|
|
|
MAGIC * const omg = dref && SvSMAGICAL(dref) |
3960
|
|
|
|
|
|
? mg_find(dref, PERL_MAGIC_isa) |
3961
|
148
|
50
|
|
|
|
: NULL; |
3962
|
74
|
100
|
|
|
|
if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { |
|
|
50
|
|
|
|
|
3963
|
54
|
100
|
|
|
|
if (SvTYPE(mg->mg_obj) != SVt_PVAV) { |
3964
|
24
|
|
|
|
|
AV * const ary = newAV(); |
3965
|
24
|
|
|
|
|
av_push(ary, mg->mg_obj); /* takes the refcount */ |
3966
|
24
|
|
|
|
|
mg->mg_obj = (SV *)ary; |
3967
|
|
|
|
|
|
} |
3968
|
54
|
50
|
|
|
|
if (omg) { |
3969
|
54
|
50
|
|
|
|
if (SvTYPE(omg->mg_obj) == SVt_PVAV) { |
3970
|
0
|
|
|
|
|
SV **svp = AvARRAY((AV *)omg->mg_obj); |
3971
|
0
|
|
|
|
|
I32 items = AvFILLp((AV *)omg->mg_obj) + 1; |
3972
|
0
|
0
|
|
|
|
while (items--) |
3973
|
0
|
|
|
|
|
av_push( |
3974
|
|
|
|
|
|
(AV *)mg->mg_obj, |
3975
|
|
|
|
|
|
SvREFCNT_inc_simple_NN(*svp++) |
3976
|
|
|
|
|
|
); |
3977
|
|
|
|
|
|
} |
3978
|
|
|
|
|
|
else |
3979
|
54
|
|
|
|
|
av_push( |
3980
|
|
|
|
|
|
(AV *)mg->mg_obj, |
3981
|
|
|
|
|
|
SvREFCNT_inc_simple_NN(omg->mg_obj) |
3982
|
|
|
|
|
|
); |
3983
|
|
|
|
|
|
} |
3984
|
|
|
|
|
|
else |
3985
|
0
|
|
|
|
|
av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr)); |
3986
|
|
|
|
|
|
} |
3987
|
|
|
|
|
|
else |
3988
|
|
|
|
|
|
{ |
3989
|
20
|
50
|
|
|
|
sv_magic( |
3990
|
|
|
|
|
|
sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0 |
3991
|
|
|
|
|
|
); |
3992
|
20
|
|
|
|
|
mg = mg_find(sref, PERL_MAGIC_isa); |
3993
|
|
|
|
|
|
} |
3994
|
|
|
|
|
|
/* Since the *ISA assignment could have affected more than |
3995
|
|
|
|
|
|
one stash, don't call mro_isa_changed_in directly, but let |
3996
|
|
|
|
|
|
magic_clearisa do it for us, as it already has the logic for |
3997
|
|
|
|
|
|
dealing with globs vs arrays of globs. */ |
3998
|
|
|
|
|
|
assert(mg); |
3999
|
74
|
|
|
|
|
Perl_magic_clearisa(aTHX_ NULL, mg); |
4000
|
|
|
|
|
|
} |
4001
|
2168565
|
100
|
|
|
|
else if (stype == SVt_PVIO) { |
4002
|
|
|
|
|
|
DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n")); |
4003
|
|
|
|
|
|
/* It's a cache. It will rebuild itself quite happily. |
4004
|
|
|
|
|
|
It's a lot of effort to work out exactly which key (or keys) |
4005
|
|
|
|
|
|
might be invalidated by the creation of the this file handle. |
4006
|
|
|
|
|
|
*/ |
4007
|
20
|
|
|
|
|
hv_clear(PL_stashcache); |
4008
|
|
|
|
|
|
} |
4009
|
|
|
|
|
|
break; |
4010
|
|
|
|
|
|
} |
4011
|
2270339
|
100
|
|
|
|
if (!intro) SvREFCNT_dec(dref); |
4012
|
2270339
|
50
|
|
|
|
if (SvTAINTED(sstr)) |
|
|
0
|
|
|
|
|
4013
|
0
|
0
|
|
|
|
SvTAINT(dstr); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4014
|
2270339
|
|
|
|
|
return; |
4015
|
|
|
|
|
|
} |
4016
|
|
|
|
|
|
|
4017
|
|
|
|
|
|
/* Work around compiler warnings about unsigned >= THRESHOLD when thres- |
4018
|
|
|
|
|
|
hold is 0. */ |
4019
|
|
|
|
|
|
#if SV_COW_THRESHOLD |
4020
|
|
|
|
|
|
# define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD) |
4021
|
|
|
|
|
|
#else |
4022
|
|
|
|
|
|
# define GE_COW_THRESHOLD(len) 1 |
4023
|
|
|
|
|
|
#endif |
4024
|
|
|
|
|
|
#if SV_COWBUF_THRESHOLD |
4025
|
|
|
|
|
|
# define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD) |
4026
|
|
|
|
|
|
#else |
4027
|
|
|
|
|
|
# define GE_COWBUF_THRESHOLD(len) 1 |
4028
|
|
|
|
|
|
#endif |
4029
|
|
|
|
|
|
|
4030
|
|
|
|
|
|
void |
4031
|
2006120706
|
|
|
|
|
Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) |
4032
|
|
|
|
|
|
{ |
4033
|
|
|
|
|
|
dVAR; |
4034
|
|
|
|
|
|
U32 sflags; |
4035
|
|
|
|
|
|
int dtype; |
4036
|
|
|
|
|
|
svtype stype; |
4037
|
|
|
|
|
|
|
4038
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETSV_FLAGS; |
4039
|
|
|
|
|
|
|
4040
|
2006120706
|
100
|
|
|
|
if (sstr == dstr) |
4041
|
|
|
|
|
|
return; |
4042
|
|
|
|
|
|
|
4043
|
2006118310
|
50
|
|
|
|
if (SvIS_FREED(dstr)) { |
4044
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: attempt to copy value %" SVf |
4045
|
|
|
|
|
|
" to a freed scalar %p", SVfARG(sstr), (void *)dstr); |
4046
|
|
|
|
|
|
} |
4047
|
2006118310
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(dstr); |
4048
|
2006118248
|
100
|
|
|
|
if (!sstr) |
4049
|
|
|
|
|
|
sstr = &PL_sv_undef; |
4050
|
2006118248
|
100
|
|
|
|
if (SvIS_FREED(sstr)) { |
4051
|
2
|
|
|
|
|
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", |
4052
|
|
|
|
|
|
(void*)sstr, (void*)dstr); |
4053
|
|
|
|
|
|
} |
4054
|
2006118246
|
|
|
|
|
stype = SvTYPE(sstr); |
4055
|
2006118246
|
|
|
|
|
dtype = SvTYPE(dstr); |
4056
|
|
|
|
|
|
|
4057
|
|
|
|
|
|
/* There's a lot of redundancy below but we're going for speed here */ |
4058
|
|
|
|
|
|
|
4059
|
2006118246
|
|
|
|
|
switch (stype) { |
4060
|
|
|
|
|
|
case SVt_NULL: |
4061
|
|
|
|
|
|
undef_sstr: |
4062
|
100088469
|
100
|
|
|
|
if (dtype != SVt_PVGV && dtype != SVt_PVLV) { |
4063
|
99946025
|
50
|
|
|
|
(void)SvOK_off(dstr); |
4064
|
|
|
|
|
|
return; |
4065
|
|
|
|
|
|
} |
4066
|
|
|
|
|
|
break; |
4067
|
|
|
|
|
|
case SVt_IV: |
4068
|
943707383
|
100
|
|
|
|
if (SvIOK(sstr)) { |
4069
|
444678728
|
|
|
|
|
switch (dtype) { |
4070
|
|
|
|
|
|
case SVt_NULL: |
4071
|
234767721
|
|
|
|
|
sv_upgrade(dstr, SVt_IV); |
4072
|
234767721
|
|
|
|
|
break; |
4073
|
|
|
|
|
|
case SVt_NV: |
4074
|
|
|
|
|
|
case SVt_PV: |
4075
|
321834
|
|
|
|
|
sv_upgrade(dstr, SVt_PVIV); |
4076
|
321834
|
|
|
|
|
break; |
4077
|
|
|
|
|
|
case SVt_PVGV: |
4078
|
|
|
|
|
|
case SVt_PVLV: |
4079
|
|
|
|
|
|
goto end_of_first_switch; |
4080
|
|
|
|
|
|
} |
4081
|
439777188
|
50
|
|
|
|
(void)SvIOK_only(dstr); |
4082
|
439777188
|
|
|
|
|
SvIV_set(dstr, SvIVX(sstr)); |
4083
|
439777188
|
100
|
|
|
|
if (SvIsUV(sstr)) |
4084
|
53936
|
|
|
|
|
SvIsUV_on(dstr); |
4085
|
|
|
|
|
|
/* SvTAINTED can only be true if the SV has taint magic, which in |
4086
|
|
|
|
|
|
turn means that the SV type is PVMG (or greater). This is the |
4087
|
|
|
|
|
|
case statement for SVt_IV, so this cannot be true (whatever gcov |
4088
|
|
|
|
|
|
may say). */ |
4089
|
|
|
|
|
|
assert(!SvTAINTED(sstr)); |
4090
|
|
|
|
|
|
return; |
4091
|
|
|
|
|
|
} |
4092
|
499028655
|
100
|
|
|
|
if (!SvROK(sstr)) |
4093
|
|
|
|
|
|
goto undef_sstr; |
4094
|
487511553
|
100
|
|
|
|
if (dtype < SVt_PV && dtype != SVt_IV) |
4095
|
83497489
|
|
|
|
|
sv_upgrade(dstr, SVt_IV); |
4096
|
|
|
|
|
|
break; |
4097
|
|
|
|
|
|
|
4098
|
|
|
|
|
|
case SVt_NV: |
4099
|
9360370
|
100
|
|
|
|
if (SvNOK(sstr)) { |
4100
|
9360368
|
|
|
|
|
switch (dtype) { |
4101
|
|
|
|
|
|
case SVt_NULL: |
4102
|
|
|
|
|
|
case SVt_IV: |
4103
|
3905078
|
|
|
|
|
sv_upgrade(dstr, SVt_NV); |
4104
|
3905078
|
|
|
|
|
break; |
4105
|
|
|
|
|
|
case SVt_PV: |
4106
|
|
|
|
|
|
case SVt_PVIV: |
4107
|
49314
|
|
|
|
|
sv_upgrade(dstr, SVt_PVNV); |
4108
|
49314
|
|
|
|
|
break; |
4109
|
|
|
|
|
|
case SVt_PVGV: |
4110
|
|
|
|
|
|
case SVt_PVLV: |
4111
|
|
|
|
|
|
goto end_of_first_switch; |
4112
|
|
|
|
|
|
} |
4113
|
9342822
|
|
|
|
|
SvNV_set(dstr, SvNVX(sstr)); |
4114
|
9342822
|
50
|
|
|
|
(void)SvNOK_only(dstr); |
4115
|
|
|
|
|
|
/* SvTAINTED can only be true if the SV has taint magic, which in |
4116
|
|
|
|
|
|
turn means that the SV type is PVMG (or greater). This is the |
4117
|
|
|
|
|
|
case statement for SVt_NV, so this cannot be true (whatever gcov |
4118
|
|
|
|
|
|
may say). */ |
4119
|
|
|
|
|
|
assert(!SvTAINTED(sstr)); |
4120
|
9342822
|
|
|
|
|
return; |
4121
|
|
|
|
|
|
} |
4122
|
|
|
|
|
|
goto undef_sstr; |
4123
|
|
|
|
|
|
|
4124
|
|
|
|
|
|
case SVt_PV: |
4125
|
607288604
|
100
|
|
|
|
if (dtype < SVt_PV) |
4126
|
241946151
|
|
|
|
|
sv_upgrade(dstr, SVt_PV); |
4127
|
|
|
|
|
|
break; |
4128
|
|
|
|
|
|
case SVt_PVIV: |
4129
|
42444802
|
100
|
|
|
|
if (dtype < SVt_PVIV) |
4130
|
14761326
|
|
|
|
|
sv_upgrade(dstr, SVt_PVIV); |
4131
|
|
|
|
|
|
break; |
4132
|
|
|
|
|
|
case SVt_PVNV: |
4133
|
131918240
|
100
|
|
|
|
if (dtype < SVt_PVNV) |
4134
|
81943090
|
|
|
|
|
sv_upgrade(dstr, SVt_PVNV); |
4135
|
|
|
|
|
|
break; |
4136
|
|
|
|
|
|
default: |
4137
|
|
|
|
|
|
{ |
4138
|
0
|
|
|
|
|
const char * const type = sv_reftype(sstr,0); |
4139
|
0
|
0
|
|
|
|
if (PL_op) |
4140
|
|
|
|
|
|
/* diag_listed_as: Bizarre copy of %s */ |
4141
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); |
|
|
0
|
|
|
|
|
4142
|
|
|
|
|
|
else |
4143
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Bizarre copy of %s", type); |
4144
|
|
|
|
|
|
} |
4145
|
|
|
|
|
|
break; |
4146
|
|
|
|
|
|
|
4147
|
|
|
|
|
|
case SVt_REGEXP: |
4148
|
|
|
|
|
|
upgregexp: |
4149
|
66
|
100
|
|
|
|
if (dtype < SVt_REGEXP) |
4150
|
|
|
|
|
|
{ |
4151
|
56
|
100
|
|
|
|
if (dtype >= SVt_PV) { |
4152
|
26
|
100
|
|
|
|
SvPV_free(dstr); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4153
|
26
|
|
|
|
|
SvPV_set(dstr, 0); |
4154
|
26
|
|
|
|
|
SvLEN_set(dstr, 0); |
4155
|
26
|
|
|
|
|
SvCUR_set(dstr, 0); |
4156
|
|
|
|
|
|
} |
4157
|
56
|
|
|
|
|
sv_upgrade(dstr, SVt_REGEXP); |
4158
|
|
|
|
|
|
} |
4159
|
|
|
|
|
|
break; |
4160
|
|
|
|
|
|
|
4161
|
|
|
|
|
|
case SVt_INVLIST: |
4162
|
|
|
|
|
|
case SVt_PVLV: |
4163
|
|
|
|
|
|
case SVt_PVGV: |
4164
|
|
|
|
|
|
case SVt_PVMG: |
4165
|
182827422
|
100
|
|
|
|
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { |
|
|
100
|
|
|
|
|
4166
|
16885509
|
|
|
|
|
mg_get(sstr); |
4167
|
16885507
|
100
|
|
|
|
if (SvTYPE(sstr) != stype) |
4168
|
4
|
|
|
|
|
stype = SvTYPE(sstr); |
4169
|
|
|
|
|
|
} |
4170
|
182827420
|
100
|
|
|
|
if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) { |
|
|
50
|
|
|
|
|
4171
|
27476775
|
|
|
|
|
glob_assign_glob(dstr, sstr, dtype); |
4172
|
27476775
|
|
|
|
|
return; |
4173
|
|
|
|
|
|
} |
4174
|
232551168
|
100
|
|
|
|
if (stype == SVt_PVLV) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
4175
|
|
|
|
|
|
{ |
4176
|
450119
|
50
|
|
|
|
if (isREGEXP(sstr)) goto upgregexp; |
|
|
100
|
|
|
|
|
4177
|
464056
|
|
|
|
|
SvUPGRADE(dstr, SVt_PVNV); |
4178
|
|
|
|
|
|
} |
4179
|
|
|
|
|
|
else |
4180
|
146750178
|
|
|
|
|
SvUPGRADE(dstr, (svtype)stype); |
4181
|
|
|
|
|
|
} |
4182
|
|
|
|
|
|
end_of_first_switch: |
4183
|
|
|
|
|
|
|
4184
|
|
|
|
|
|
/* dstr may have been upgraded. */ |
4185
|
1429575434
|
|
|
|
|
dtype = SvTYPE(dstr); |
4186
|
1429575434
|
|
|
|
|
sflags = SvFLAGS(sstr); |
4187
|
|
|
|
|
|
|
4188
|
1429575434
|
100
|
|
|
|
if (dtype == SVt_PVCV) { |
4189
|
|
|
|
|
|
/* Assigning to a subroutine sets the prototype. */ |
4190
|
32
|
50
|
|
|
|
if (SvOK(sstr)) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4191
|
|
|
|
|
|
STRLEN len; |
4192
|
16
|
50
|
|
|
|
const char *const ptr = SvPV_const(sstr, len); |
4193
|
|
|
|
|
|
|
4194
|
16
|
50
|
|
|
|
SvGROW(dstr, len + 1); |
|
|
100
|
|
|
|
|
4195
|
16
|
|
|
|
|
Copy(ptr, SvPVX(dstr), len + 1, char); |
4196
|
16
|
|
|
|
|
SvCUR_set(dstr, len); |
4197
|
16
|
|
|
|
|
SvPOK_only(dstr); |
4198
|
16
|
|
|
|
|
SvFLAGS(dstr) |= sflags & SVf_UTF8; |
4199
|
16
|
|
|
|
|
CvAUTOLOAD_off(dstr); |
4200
|
|
|
|
|
|
} else { |
4201
|
0
|
0
|
|
|
|
SvOK_off(dstr); |
4202
|
|
|
|
|
|
} |
4203
|
|
|
|
|
|
} |
4204
|
1429575418
|
50
|
|
|
|
else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) { |
4205
|
0
|
|
|
|
|
const char * const type = sv_reftype(dstr,0); |
4206
|
0
|
0
|
|
|
|
if (PL_op) |
4207
|
|
|
|
|
|
/* diag_listed_as: Cannot copy to %s */ |
4208
|
0
|
0
|
|
|
|
Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); |
|
|
0
|
|
|
|
|
4209
|
|
|
|
|
|
else |
4210
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Cannot copy to %s", type); |
4211
|
1429575418
|
100
|
|
|
|
} else if (sflags & SVf_ROK) { |
4212
|
548545323
|
100
|
|
|
|
if (isGV_with_GP(dstr) |
|
|
50
|
|
|
|
|
4213
|
2304772
|
100
|
|
|
|
&& SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4214
|
34427
|
|
|
|
|
sstr = SvRV(sstr); |
4215
|
34427
|
100
|
|
|
|
if (sstr == dstr) { |
4216
|
3094
|
50
|
|
|
|
if (GvIMPORTED(dstr) != GVf_IMPORTED |
4217
|
3094
|
50
|
|
|
|
&& CopSTASH_ne(PL_curcop, GvSTASH(dstr))) |
4218
|
|
|
|
|
|
{ |
4219
|
3094
|
|
|
|
|
GvIMPORTED_on(dstr); |
4220
|
|
|
|
|
|
} |
4221
|
3094
|
|
|
|
|
GvMULTI_on(dstr); |
4222
|
3094
|
|
|
|
|
return; |
4223
|
|
|
|
|
|
} |
4224
|
31333
|
|
|
|
|
glob_assign_glob(dstr, sstr, dtype); |
4225
|
31333
|
|
|
|
|
return; |
4226
|
|
|
|
|
|
} |
4227
|
|
|
|
|
|
|
4228
|
548510896
|
100
|
|
|
|
if (dtype >= SVt_PV) { |
4229
|
118957336
|
100
|
|
|
|
if (isGV_with_GP(dstr)) { |
|
|
50
|
|
|
|
|
4230
|
2270345
|
|
|
|
|
glob_assign_ref(dstr, sstr); |
4231
|
2270339
|
|
|
|
|
return; |
4232
|
|
|
|
|
|
} |
4233
|
116686991
|
100
|
|
|
|
if (SvPVX_const(dstr)) { |
4234
|
1667224
|
50
|
|
|
|
SvPV_free(dstr); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4235
|
1667224
|
|
|
|
|
SvLEN_set(dstr, 0); |
4236
|
1667224
|
|
|
|
|
SvCUR_set(dstr, 0); |
4237
|
|
|
|
|
|
} |
4238
|
|
|
|
|
|
} |
4239
|
546240551
|
50
|
|
|
|
(void)SvOK_off(dstr); |
4240
|
1092481102
|
|
|
|
|
SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); |
4241
|
546240551
|
|
|
|
|
SvFLAGS(dstr) |= sflags & SVf_ROK; |
4242
|
|
|
|
|
|
assert(!(sflags & SVp_NOK)); |
4243
|
|
|
|
|
|
assert(!(sflags & SVp_IOK)); |
4244
|
|
|
|
|
|
assert(!(sflags & SVf_NOK)); |
4245
|
|
|
|
|
|
assert(!(sflags & SVf_IOK)); |
4246
|
|
|
|
|
|
} |
4247
|
881030095
|
100
|
|
|
|
else if (isGV_with_GP(dstr)) { |
|
|
50
|
|
|
|
|
4248
|
106
|
100
|
|
|
|
if (!(sflags & SVf_OK)) { |
4249
|
28
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), |
4250
|
|
|
|
|
|
"Undefined value assigned to typeglob"); |
4251
|
|
|
|
|
|
} |
4252
|
|
|
|
|
|
else { |
4253
|
78
|
|
|
|
|
GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV); |
4254
|
78
|
50
|
|
|
|
if (dstr != (const SV *)gv) { |
4255
|
78
|
|
|
|
|
const char * const name = GvNAME((const GV *)dstr); |
4256
|
78
|
|
|
|
|
const STRLEN len = GvNAMELEN(dstr); |
4257
|
|
|
|
|
|
HV *old_stash = NULL; |
4258
|
|
|
|
|
|
bool reset_isa = FALSE; |
4259
|
78
|
100
|
|
|
|
if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4260
|
34
|
100
|
|
|
|
|| (len == 1 && name[0] == ':')) { |
|
|
50
|
|
|
|
|
4261
|
|
|
|
|
|
/* Set aside the old stash, so we can reset isa caches |
4262
|
|
|
|
|
|
on its subclasses. */ |
4263
|
44
|
50
|
|
|
|
if((old_stash = GvHV(dstr))) { |
4264
|
|
|
|
|
|
/* Make sure we do not lose it early. */ |
4265
|
44
|
|
|
|
|
SvREFCNT_inc_simple_void_NN( |
4266
|
|
|
|
|
|
sv_2mortal((SV *)old_stash) |
4267
|
|
|
|
|
|
); |
4268
|
|
|
|
|
|
} |
4269
|
|
|
|
|
|
reset_isa = TRUE; |
4270
|
|
|
|
|
|
} |
4271
|
|
|
|
|
|
|
4272
|
78
|
50
|
|
|
|
if (GvGP(dstr)) |
4273
|
78
|
|
|
|
|
gp_free(MUTABLE_GV(dstr)); |
4274
|
76
|
|
|
|
|
GvGP_set(dstr, gp_ref(GvGP(gv))); |
4275
|
|
|
|
|
|
|
4276
|
76
|
100
|
|
|
|
if (reset_isa) { |
4277
|
44
|
|
|
|
|
HV * const stash = GvHV(dstr); |
4278
|
44
|
50
|
|
|
|
if( |
4279
|
44
|
50
|
|
|
|
old_stash ? (HV *)HvENAME_get(old_stash) : stash |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4280
|
|
|
|
|
|
) |
4281
|
44
|
|
|
|
|
mro_package_moved( |
4282
|
|
|
|
|
|
stash, old_stash, |
4283
|
|
|
|
|
|
(GV *)dstr, 0 |
4284
|
|
|
|
|
|
); |
4285
|
|
|
|
|
|
} |
4286
|
|
|
|
|
|
} |
4287
|
|
|
|
|
|
} |
4288
|
|
|
|
|
|
} |
4289
|
881029989
|
100
|
|
|
|
else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV) |
4290
|
5653373
|
100
|
|
|
|
&& (stype == SVt_REGEXP || isREGEXP(sstr))) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4291
|
66
|
|
|
|
|
reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); |
4292
|
|
|
|
|
|
} |
4293
|
881029923
|
100
|
|
|
|
else if (sflags & SVp_POK) { |
4294
|
|
|
|
|
|
bool isSwipe = 0; |
4295
|
817703680
|
|
|
|
|
const STRLEN cur = SvCUR(sstr); |
4296
|
817703680
|
|
|
|
|
const STRLEN len = SvLEN(sstr); |
4297
|
|
|
|
|
|
|
4298
|
|
|
|
|
|
/* |
4299
|
|
|
|
|
|
* Check to see if we can just swipe the string. If so, it's a |
4300
|
|
|
|
|
|
* possible small lose on short strings, but a big win on long ones. |
4301
|
|
|
|
|
|
* It might even be a win on short strings if SvPVX_const(dstr) |
4302
|
|
|
|
|
|
* has to be allocated and SvPVX_const(sstr) has to be freed. |
4303
|
|
|
|
|
|
* Likewise if we can set up COW rather than doing an actual copy, we |
4304
|
|
|
|
|
|
* drop to the else clause, as the swipe code and the COW setup code |
4305
|
|
|
|
|
|
* have much in common. |
4306
|
|
|
|
|
|
*/ |
4307
|
|
|
|
|
|
|
4308
|
|
|
|
|
|
/* Whichever path we take through the next code, we want this true, |
4309
|
|
|
|
|
|
and doing it now facilitates the COW check. */ |
4310
|
817703680
|
|
|
|
|
(void)SvPOK_only(dstr); |
4311
|
|
|
|
|
|
|
4312
|
817703680
|
100
|
|
|
|
if ( |
4313
|
|
|
|
|
|
/* If we're already COW then this clause is not true, and if COW |
4314
|
|
|
|
|
|
is allowed then we drop down to the else and make dest COW |
4315
|
|
|
|
|
|
with us. If caller hasn't said that we're allowed to COW |
4316
|
|
|
|
|
|
shared hash keys then we don't do the COW setup, even if the |
4317
|
|
|
|
|
|
source scalar is a shared hash key scalar. */ |
4318
|
817703680
|
|
|
|
|
(((flags & SV_COW_SHARED_HASH_KEYS) |
4319
|
778547945
|
|
|
|
|
? !(sflags & SVf_IsCOW) |
4320
|
|
|
|
|
|
#ifdef PERL_NEW_COPY_ON_WRITE |
4321
|
354552683
|
100
|
|
|
|
|| (len && |
|
|
100
|
|
|
|
|
4322
|
258440152
|
100
|
|
|
|
((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur) |
4323
|
|
|
|
|
|
/* If this is a regular (non-hek) COW, only so many COW |
4324
|
|
|
|
|
|
"copies" are possible. */ |
4325
|
229232425
|
100
|
|
|
|
|| CowREFCNT(sstr) == SV_COW_REFCNT_MAX)) |
4326
|
|
|
|
|
|
#endif |
4327
|
|
|
|
|
|
: 1 /* If making a COW copy is forbidden then the behaviour we |
4328
|
|
|
|
|
|
desire is as if the source SV isn't actually already |
4329
|
|
|
|
|
|
COW, even if it is. So we act as if the source flags |
4330
|
|
|
|
|
|
are not COW, rather than actually testing them. */ |
4331
|
|
|
|
|
|
) |
4332
|
|
|
|
|
|
#ifndef PERL_ANY_COW |
4333
|
|
|
|
|
|
/* The change that added SV_COW_SHARED_HASH_KEYS makes the logic |
4334
|
|
|
|
|
|
when PERL_OLD_COPY_ON_WRITE is defined a little wrong. |
4335
|
|
|
|
|
|
Conceptually PERL_OLD_COPY_ON_WRITE being defined should |
4336
|
|
|
|
|
|
override SV_COW_SHARED_HASH_KEYS, because it means "always COW" |
4337
|
|
|
|
|
|
but in turn, it's somewhat dead code, never expected to go |
4338
|
|
|
|
|
|
live, but more kept as a placeholder on how to do it better |
4339
|
|
|
|
|
|
in a newer implementation. */ |
4340
|
|
|
|
|
|
/* If we are COW and dstr is a suitable target then we drop down |
4341
|
|
|
|
|
|
into the else and make dest a COW of us. */ |
4342
|
|
|
|
|
|
|| (SvFLAGS(dstr) & SVf_BREAK) |
4343
|
|
|
|
|
|
#endif |
4344
|
|
|
|
|
|
) |
4345
|
1273974723
|
100
|
|
|
|
&& |
|
|
100
|
|
|
|
|
4346
|
495426778
|
|
|
|
|
!(isSwipe = |
4347
|
|
|
|
|
|
#ifdef PERL_NEW_COPY_ON_WRITE |
4348
|
|
|
|
|
|
/* slated for free anyway (and not COW)? */ |
4349
|
495426778
|
|
|
|
|
(sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP && |
4350
|
|
|
|
|
|
#else |
4351
|
|
|
|
|
|
(sflags & SVs_TEMP) && /* slated for free anyway? */ |
4352
|
|
|
|
|
|
#endif |
4353
|
93339748
|
100
|
|
|
|
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */ |
4354
|
93339748
|
|
|
|
|
(!(flags & SV_NOSTEAL)) && |
4355
|
|
|
|
|
|
/* and we're allowed to steal temps */ |
4356
|
587302430
|
100
|
|
|
|
SvREFCNT(sstr) == 1 && /* and no other references to it? */ |
|
|
100
|
|
|
|
|
4357
|
|
|
|
|
|
len) /* and really is a string */ |
4358
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
4359
|
587165357
|
100
|
|
|
|
&& ((flags & SV_COW_SHARED_HASH_KEYS) |
|
|
100
|
|
|
|
|
4360
|
425116316
|
100
|
|
|
|
? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS |
4361
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4362
|
|
|
|
|
|
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS |
4363
|
|
|
|
|
|
&& SvTYPE(sstr) >= SVt_PVIV && len |
4364
|
|
|
|
|
|
# else |
4365
|
266031612
|
50
|
|
|
|
&& !(SvFLAGS(dstr) & SVf_BREAK) |
4366
|
266031612
|
|
|
|
|
&& !(sflags & SVf_IsCOW) |
4367
|
266031612
|
100
|
|
|
|
&& GE_COW_THRESHOLD(cur) && cur+1 < len |
|
|
100
|
|
|
|
|
4368
|
242506690
|
100
|
|
|
|
&& (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1) |
4369
|
|
|
|
|
|
# endif |
4370
|
|
|
|
|
|
)) |
4371
|
|
|
|
|
|
: 1) |
4372
|
|
|
|
|
|
#endif |
4373
|
|
|
|
|
|
) { |
4374
|
|
|
|
|
|
/* Failed the swipe test, and it's not a shared hash key either. |
4375
|
|
|
|
|
|
Have to copy the string. */ |
4376
|
228699921
|
50
|
|
|
|
SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */ |
|
|
100
|
|
|
|
|
4377
|
228699921
|
|
|
|
|
Move(SvPVX_const(sstr),SvPVX(dstr),cur,char); |
4378
|
228699921
|
|
|
|
|
SvCUR_set(dstr, cur); |
4379
|
228699921
|
|
|
|
|
*SvEND(dstr) = '\0'; |
4380
|
|
|
|
|
|
} else { |
4381
|
|
|
|
|
|
/* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always |
4382
|
|
|
|
|
|
be true in here. */ |
4383
|
|
|
|
|
|
/* Either it's a shared hash key, or it's suitable for |
4384
|
|
|
|
|
|
copy-on-write or we can swipe the string. */ |
4385
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
4386
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n"); |
4387
|
|
|
|
|
|
sv_dump(sstr); |
4388
|
|
|
|
|
|
sv_dump(dstr); |
4389
|
|
|
|
|
|
} |
4390
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
4391
|
589003759
|
100
|
|
|
|
if (!isSwipe) { |
4392
|
498747387
|
100
|
|
|
|
if (!(sflags & SVf_IsCOW)) { |
4393
|
176470485
|
|
|
|
|
SvIsCOW_on(sstr); |
4394
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4395
|
|
|
|
|
|
/* Make the source SV into a loop of 1. |
4396
|
|
|
|
|
|
(about to become 2) */ |
4397
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(sstr, sstr); |
4398
|
|
|
|
|
|
# else |
4399
|
176470485
|
|
|
|
|
CowREFCNT(sstr) = 0; |
4400
|
|
|
|
|
|
# endif |
4401
|
|
|
|
|
|
} |
4402
|
|
|
|
|
|
} |
4403
|
|
|
|
|
|
#endif |
4404
|
|
|
|
|
|
/* Initial code is common. */ |
4405
|
589003759
|
100
|
|
|
|
if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */ |
4406
|
62494203
|
100
|
|
|
|
SvPV_free(dstr); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
4407
|
|
|
|
|
|
} |
4408
|
|
|
|
|
|
|
4409
|
589003759
|
100
|
|
|
|
if (!isSwipe) { |
4410
|
|
|
|
|
|
/* making another shared SV. */ |
4411
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
4412
|
498747387
|
100
|
|
|
|
if (len) { |
4413
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4414
|
|
|
|
|
|
assert (SvTYPE(dstr) >= SVt_PVIV); |
4415
|
|
|
|
|
|
/* SvIsCOW_normal */ |
4416
|
|
|
|
|
|
/* splice us in between source and next-after-source. */ |
4417
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); |
4418
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(sstr, dstr); |
4419
|
|
|
|
|
|
# else |
4420
|
402757514
|
|
|
|
|
CowREFCNT(sstr)++; |
4421
|
|
|
|
|
|
# endif |
4422
|
402757514
|
|
|
|
|
SvPV_set(dstr, SvPVX_mutable(sstr)); |
4423
|
|
|
|
|
|
} else |
4424
|
|
|
|
|
|
#endif |
4425
|
|
|
|
|
|
{ |
4426
|
|
|
|
|
|
/* SvIsCOW_shared_hash */ |
4427
|
|
|
|
|
|
DEBUG_C(PerlIO_printf(Perl_debug_log, |
4428
|
|
|
|
|
|
"Copy on write: Sharing hash\n")); |
4429
|
|
|
|
|
|
|
4430
|
|
|
|
|
|
assert (SvTYPE(dstr) >= SVt_PV); |
4431
|
95989873
|
|
|
|
|
SvPV_set(dstr, |
4432
|
|
|
|
|
|
HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))))); |
4433
|
|
|
|
|
|
} |
4434
|
498747387
|
|
|
|
|
SvLEN_set(dstr, len); |
4435
|
498747387
|
|
|
|
|
SvCUR_set(dstr, cur); |
4436
|
498747387
|
|
|
|
|
SvIsCOW_on(dstr); |
4437
|
|
|
|
|
|
} |
4438
|
|
|
|
|
|
else |
4439
|
|
|
|
|
|
{ /* Passes the swipe test. */ |
4440
|
90256372
|
|
|
|
|
SvPV_set(dstr, SvPVX_mutable(sstr)); |
4441
|
90256372
|
|
|
|
|
SvLEN_set(dstr, SvLEN(sstr)); |
4442
|
90256372
|
|
|
|
|
SvCUR_set(dstr, SvCUR(sstr)); |
4443
|
|
|
|
|
|
|
4444
|
90256372
|
|
|
|
|
SvTEMP_off(dstr); |
4445
|
90256372
|
50
|
|
|
|
(void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ |
4446
|
90256372
|
|
|
|
|
SvPV_set(sstr, NULL); |
4447
|
90256372
|
|
|
|
|
SvLEN_set(sstr, 0); |
4448
|
90256372
|
|
|
|
|
SvCUR_set(sstr, 0); |
4449
|
90256372
|
|
|
|
|
SvTEMP_off(sstr); |
4450
|
|
|
|
|
|
} |
4451
|
|
|
|
|
|
} |
4452
|
817703680
|
100
|
|
|
|
if (sflags & SVp_NOK) { |
4453
|
98888985
|
|
|
|
|
SvNV_set(dstr, SvNVX(sstr)); |
4454
|
|
|
|
|
|
} |
4455
|
817703680
|
100
|
|
|
|
if (sflags & SVp_IOK) { |
4456
|
105167063
|
|
|
|
|
SvIV_set(dstr, SvIVX(sstr)); |
4457
|
|
|
|
|
|
/* Must do this otherwise some other overloaded use of 0x80000000 |
4458
|
|
|
|
|
|
gets confused. I guess SVpbm_VALID */ |
4459
|
105167063
|
100
|
|
|
|
if (sflags & SVf_IVisUV) |
4460
|
260
|
|
|
|
|
SvIsUV_on(dstr); |
4461
|
|
|
|
|
|
} |
4462
|
817703680
|
|
|
|
|
SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); |
4463
|
|
|
|
|
|
{ |
4464
|
817703680
|
100
|
|
|
|
const MAGIC * const smg = SvVSTRING_mg(sstr); |
4465
|
817703680
|
100
|
|
|
|
if (smg) { |
4466
|
690
|
|
|
|
|
sv_magic(dstr, NULL, PERL_MAGIC_vstring, |
4467
|
|
|
|
|
|
smg->mg_ptr, smg->mg_len); |
4468
|
690
|
|
|
|
|
SvRMAGICAL_on(dstr); |
4469
|
|
|
|
|
|
} |
4470
|
|
|
|
|
|
} |
4471
|
|
|
|
|
|
} |
4472
|
63326243
|
100
|
|
|
|
else if (sflags & (SVp_IOK|SVp_NOK)) { |
4473
|
55718483
|
50
|
|
|
|
(void)SvOK_off(dstr); |
4474
|
55718483
|
|
|
|
|
SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); |
4475
|
55718483
|
100
|
|
|
|
if (sflags & SVp_IOK) { |
4476
|
|
|
|
|
|
/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ |
4477
|
50039455
|
|
|
|
|
SvIV_set(dstr, SvIVX(sstr)); |
4478
|
|
|
|
|
|
} |
4479
|
55718483
|
100
|
|
|
|
if (sflags & SVp_NOK) { |
4480
|
6100894
|
|
|
|
|
SvNV_set(dstr, SvNVX(sstr)); |
4481
|
|
|
|
|
|
} |
4482
|
|
|
|
|
|
} |
4483
|
|
|
|
|
|
else { |
4484
|
7607760
|
50
|
|
|
|
if (isGV_with_GP(sstr)) { |
|
|
0
|
|
|
|
|
4485
|
0
|
|
|
|
|
gv_efullname3(dstr, MUTABLE_GV(sstr), "*"); |
4486
|
|
|
|
|
|
} |
4487
|
|
|
|
|
|
else |
4488
|
7607760
|
50
|
|
|
|
(void)SvOK_off(dstr); |
4489
|
|
|
|
|
|
} |
4490
|
1427270660
|
100
|
|
|
|
if (SvTAINTED(sstr)) |
|
|
100
|
|
|
|
|
4491
|
1005702010
|
50
|
|
|
|
SvTAINT(dstr); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
4492
|
|
|
|
|
|
} |
4493
|
|
|
|
|
|
|
4494
|
|
|
|
|
|
/* |
4495
|
|
|
|
|
|
=for apidoc sv_setsv_mg |
4496
|
|
|
|
|
|
|
4497
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
4498
|
|
|
|
|
|
|
4499
|
|
|
|
|
|
=cut |
4500
|
|
|
|
|
|
*/ |
4501
|
|
|
|
|
|
|
4502
|
|
|
|
|
|
void |
4503
|
44
|
|
|
|
|
Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr) |
4504
|
|
|
|
|
|
{ |
4505
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETSV_MG; |
4506
|
|
|
|
|
|
|
4507
|
44
|
|
|
|
|
sv_setsv(dstr,sstr); |
4508
|
44
|
100
|
|
|
|
SvSETMAGIC(dstr); |
4509
|
44
|
|
|
|
|
} |
4510
|
|
|
|
|
|
|
4511
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
4512
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4513
|
|
|
|
|
|
# define SVt_COW SVt_PVIV |
4514
|
|
|
|
|
|
# else |
4515
|
|
|
|
|
|
# define SVt_COW SVt_PV |
4516
|
|
|
|
|
|
# endif |
4517
|
|
|
|
|
|
SV * |
4518
|
60628184
|
|
|
|
|
Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) |
4519
|
60628184
|
100
|
|
|
|
{ |
4520
|
60628184
|
|
|
|
|
STRLEN cur = SvCUR(sstr); |
4521
|
60628184
|
|
|
|
|
STRLEN len = SvLEN(sstr); |
4522
|
|
|
|
|
|
char *new_pv; |
4523
|
|
|
|
|
|
|
4524
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETSV_COW; |
4525
|
|
|
|
|
|
|
4526
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
4527
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", |
4528
|
|
|
|
|
|
(void*)sstr, (void*)dstr); |
4529
|
|
|
|
|
|
sv_dump(sstr); |
4530
|
|
|
|
|
|
if (dstr) |
4531
|
|
|
|
|
|
sv_dump(dstr); |
4532
|
|
|
|
|
|
} |
4533
|
|
|
|
|
|
|
4534
|
60628184
|
100
|
|
|
|
if (dstr) { |
4535
|
55163380
|
50
|
|
|
|
if (SvTHINKFIRST(dstr)) |
4536
|
0
|
|
|
|
|
sv_force_normal_flags(dstr, SV_COW_DROP_PV); |
4537
|
55163380
|
100
|
|
|
|
else if (SvPVX_const(dstr)) |
4538
|
22283121
|
|
|
|
|
Safefree(SvPVX_mutable(dstr)); |
4539
|
|
|
|
|
|
} |
4540
|
|
|
|
|
|
else |
4541
|
5464804
|
100
|
|
|
|
new_SV(dstr); |
4542
|
35565095
|
|
|
|
|
SvUPGRADE(dstr, SVt_COW); |
4543
|
|
|
|
|
|
|
4544
|
|
|
|
|
|
assert (SvPOK(sstr)); |
4545
|
|
|
|
|
|
assert (SvPOKp(sstr)); |
4546
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4547
|
|
|
|
|
|
assert (!SvIOK(sstr)); |
4548
|
|
|
|
|
|
assert (!SvIOKp(sstr)); |
4549
|
|
|
|
|
|
assert (!SvNOK(sstr)); |
4550
|
|
|
|
|
|
assert (!SvNOKp(sstr)); |
4551
|
|
|
|
|
|
# endif |
4552
|
|
|
|
|
|
|
4553
|
69208094
|
100
|
|
|
|
if (SvIsCOW(sstr)) { |
|
|
50
|
|
|
|
|
4554
|
|
|
|
|
|
|
4555
|
43101406
|
100
|
|
|
|
if (SvLEN(sstr) == 0) { |
4556
|
|
|
|
|
|
/* source is a COW shared hash key. */ |
4557
|
|
|
|
|
|
DEBUG_C(PerlIO_printf(Perl_debug_log, |
4558
|
|
|
|
|
|
"Fast copy on write: Sharing hash\n")); |
4559
|
29230252
|
|
|
|
|
new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))); |
4560
|
29230252
|
|
|
|
|
goto common_exit; |
4561
|
|
|
|
|
|
} |
4562
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4563
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr)); |
4564
|
|
|
|
|
|
# else |
4565
|
|
|
|
|
|
assert(SvCUR(sstr)+1 < SvLEN(sstr)); |
4566
|
|
|
|
|
|
assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX); |
4567
|
|
|
|
|
|
# endif |
4568
|
|
|
|
|
|
} else { |
4569
|
|
|
|
|
|
assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS); |
4570
|
8579910
|
|
|
|
|
SvUPGRADE(sstr, SVt_COW); |
4571
|
17526778
|
|
|
|
|
SvIsCOW_on(sstr); |
4572
|
|
|
|
|
|
DEBUG_C(PerlIO_printf(Perl_debug_log, |
4573
|
|
|
|
|
|
"Fast copy on write: Converting sstr to COW\n")); |
4574
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4575
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(dstr, sstr); |
4576
|
|
|
|
|
|
# else |
4577
|
17526778
|
|
|
|
|
CowREFCNT(sstr) = 0; |
4578
|
|
|
|
|
|
# endif |
4579
|
|
|
|
|
|
} |
4580
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4581
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(sstr, dstr); |
4582
|
|
|
|
|
|
# else |
4583
|
31397932
|
|
|
|
|
CowREFCNT(sstr)++; |
4584
|
|
|
|
|
|
# endif |
4585
|
31397932
|
|
|
|
|
new_pv = SvPVX_mutable(sstr); |
4586
|
|
|
|
|
|
|
4587
|
|
|
|
|
|
common_exit: |
4588
|
60628184
|
|
|
|
|
SvPV_set(dstr, new_pv); |
4589
|
60628184
|
|
|
|
|
SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); |
4590
|
60628184
|
100
|
|
|
|
if (SvUTF8(sstr)) |
4591
|
1099562
|
|
|
|
|
SvUTF8_on(dstr); |
4592
|
60628184
|
|
|
|
|
SvLEN_set(dstr, len); |
4593
|
60628184
|
|
|
|
|
SvCUR_set(dstr, cur); |
4594
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
4595
|
|
|
|
|
|
sv_dump(dstr); |
4596
|
|
|
|
|
|
} |
4597
|
60628184
|
|
|
|
|
return dstr; |
4598
|
|
|
|
|
|
} |
4599
|
|
|
|
|
|
#endif |
4600
|
|
|
|
|
|
|
4601
|
|
|
|
|
|
/* |
4602
|
|
|
|
|
|
=for apidoc sv_setpvn |
4603
|
|
|
|
|
|
|
4604
|
|
|
|
|
|
Copies a string into an SV. The C parameter indicates the number of |
4605
|
|
|
|
|
|
bytes to be copied. If the C argument is NULL the SV will become |
4606
|
|
|
|
|
|
undefined. Does not handle 'set' magic. See C. |
4607
|
|
|
|
|
|
|
4608
|
|
|
|
|
|
=cut |
4609
|
|
|
|
|
|
*/ |
4610
|
|
|
|
|
|
|
4611
|
|
|
|
|
|
void |
4612
|
659470505
|
|
|
|
|
Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) |
4613
|
658315909
|
100
|
|
|
|
{ |
4614
|
|
|
|
|
|
dVAR; |
4615
|
|
|
|
|
|
char *dptr; |
4616
|
|
|
|
|
|
|
4617
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVN; |
4618
|
|
|
|
|
|
|
4619
|
659470505
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
4620
|
659470505
|
100
|
|
|
|
if (!ptr) { |
4621
|
1154596
|
50
|
|
|
|
(void)SvOK_off(sv); |
4622
|
659470505
|
|
|
|
|
return; |
4623
|
|
|
|
|
|
} |
4624
|
|
|
|
|
|
else { |
4625
|
|
|
|
|
|
/* len is STRLEN which is unsigned, need to copy to signed */ |
4626
|
658315909
|
|
|
|
|
const IV iv = len; |
4627
|
658315909
|
50
|
|
|
|
if (iv < 0) |
4628
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" |
4629
|
|
|
|
|
|
IVdf, iv); |
4630
|
|
|
|
|
|
} |
4631
|
712136246
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); |
4632
|
|
|
|
|
|
|
4633
|
658315909
|
50
|
|
|
|
dptr = SvGROW(sv, len + 1); |
|
|
100
|
|
|
|
|
4634
|
|
|
|
|
|
Move(ptr,dptr,len,char); |
4635
|
658315909
|
|
|
|
|
dptr[len] = '\0'; |
4636
|
658315909
|
|
|
|
|
SvCUR_set(sv, len); |
4637
|
658315909
|
|
|
|
|
(void)SvPOK_only_UTF8(sv); /* validate pointer */ |
4638
|
658315909
|
100
|
|
|
|
SvTAINT(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4639
|
658315909
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv); |
4640
|
|
|
|
|
|
} |
4641
|
|
|
|
|
|
|
4642
|
|
|
|
|
|
/* |
4643
|
|
|
|
|
|
=for apidoc sv_setpvn_mg |
4644
|
|
|
|
|
|
|
4645
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
4646
|
|
|
|
|
|
|
4647
|
|
|
|
|
|
=cut |
4648
|
|
|
|
|
|
*/ |
4649
|
|
|
|
|
|
|
4650
|
|
|
|
|
|
void |
4651
|
2
|
|
|
|
|
Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) |
4652
|
|
|
|
|
|
{ |
4653
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVN_MG; |
4654
|
|
|
|
|
|
|
4655
|
2
|
|
|
|
|
sv_setpvn(sv,ptr,len); |
4656
|
2
|
50
|
|
|
|
SvSETMAGIC(sv); |
4657
|
2
|
|
|
|
|
} |
4658
|
|
|
|
|
|
|
4659
|
|
|
|
|
|
/* |
4660
|
|
|
|
|
|
=for apidoc sv_setpv |
4661
|
|
|
|
|
|
|
4662
|
|
|
|
|
|
Copies a string into an SV. The string must be null-terminated. Does not |
4663
|
|
|
|
|
|
handle 'set' magic. See C. |
4664
|
|
|
|
|
|
|
4665
|
|
|
|
|
|
=cut |
4666
|
|
|
|
|
|
*/ |
4667
|
|
|
|
|
|
|
4668
|
|
|
|
|
|
void |
4669
|
48726902
|
|
|
|
|
Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) |
4670
|
45973750
|
100
|
|
|
|
{ |
4671
|
|
|
|
|
|
dVAR; |
4672
|
|
|
|
|
|
STRLEN len; |
4673
|
|
|
|
|
|
|
4674
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPV; |
4675
|
|
|
|
|
|
|
4676
|
48726902
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
4677
|
48726902
|
100
|
|
|
|
if (!ptr) { |
4678
|
2753152
|
50
|
|
|
|
(void)SvOK_off(sv); |
4679
|
48726902
|
|
|
|
|
return; |
4680
|
|
|
|
|
|
} |
4681
|
45973750
|
|
|
|
|
len = strlen(ptr); |
4682
|
29104202
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); |
4683
|
|
|
|
|
|
|
4684
|
45973750
|
50
|
|
|
|
SvGROW(sv, len + 1); |
|
|
100
|
|
|
|
|
4685
|
45973750
|
|
|
|
|
Move(ptr,SvPVX(sv),len+1,char); |
4686
|
45973750
|
|
|
|
|
SvCUR_set(sv, len); |
4687
|
45973750
|
|
|
|
|
(void)SvPOK_only_UTF8(sv); /* validate pointer */ |
4688
|
45973750
|
100
|
|
|
|
SvTAINT(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4689
|
45973750
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv); |
4690
|
|
|
|
|
|
} |
4691
|
|
|
|
|
|
|
4692
|
|
|
|
|
|
/* |
4693
|
|
|
|
|
|
=for apidoc sv_setpv_mg |
4694
|
|
|
|
|
|
|
4695
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
4696
|
|
|
|
|
|
|
4697
|
|
|
|
|
|
=cut |
4698
|
|
|
|
|
|
*/ |
4699
|
|
|
|
|
|
|
4700
|
|
|
|
|
|
void |
4701
|
454022
|
|
|
|
|
Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr) |
4702
|
|
|
|
|
|
{ |
4703
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPV_MG; |
4704
|
|
|
|
|
|
|
4705
|
454022
|
|
|
|
|
sv_setpv(sv,ptr); |
4706
|
454022
|
100
|
|
|
|
SvSETMAGIC(sv); |
4707
|
454022
|
|
|
|
|
} |
4708
|
|
|
|
|
|
|
4709
|
|
|
|
|
|
void |
4710
|
261753296
|
|
|
|
|
Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek) |
4711
|
|
|
|
|
|
{ |
4712
|
|
|
|
|
|
dVAR; |
4713
|
|
|
|
|
|
|
4714
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETHEK; |
4715
|
|
|
|
|
|
|
4716
|
261753296
|
50
|
|
|
|
if (!hek) { |
4717
|
|
|
|
|
|
return; |
4718
|
|
|
|
|
|
} |
4719
|
|
|
|
|
|
|
4720
|
261753296
|
50
|
|
|
|
if (HEK_LEN(hek) == HEf_SVKEY) { |
4721
|
0
|
|
|
|
|
sv_setsv(sv, *(SV**)HEK_KEY(hek)); |
4722
|
0
|
|
|
|
|
return; |
4723
|
261753212
|
100
|
|
|
|
} else { |
4724
|
261753296
|
|
|
|
|
const int flags = HEK_FLAGS(hek); |
4725
|
261753296
|
100
|
|
|
|
if (flags & HVhek_WASUTF8) { |
4726
|
84
|
|
|
|
|
STRLEN utf8_len = HEK_LEN(hek); |
4727
|
84
|
|
|
|
|
char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len); |
4728
|
84
|
|
|
|
|
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); |
4729
|
84
|
|
|
|
|
SvUTF8_on(sv); |
4730
|
84
|
|
|
|
|
return; |
4731
|
261753212
|
50
|
|
|
|
} else if (flags & HVhek_UNSHARED) { |
4732
|
0
|
|
|
|
|
sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek)); |
4733
|
0
|
0
|
|
|
|
if (HEK_UTF8(hek)) |
4734
|
0
|
|
|
|
|
SvUTF8_on(sv); |
4735
|
0
|
|
|
|
|
else SvUTF8_off(sv); |
4736
|
|
|
|
|
|
return; |
4737
|
|
|
|
|
|
} |
4738
|
|
|
|
|
|
{ |
4739
|
261753212
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
4740
|
131130896
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); |
4741
|
261753212
|
100
|
|
|
|
SvPV_free(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4742
|
261753212
|
|
|
|
|
SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); |
4743
|
261753212
|
|
|
|
|
SvCUR_set(sv, HEK_LEN(hek)); |
4744
|
261753212
|
|
|
|
|
SvLEN_set(sv, 0); |
4745
|
261753212
|
|
|
|
|
SvIsCOW_on(sv); |
4746
|
261753212
|
|
|
|
|
SvPOK_on(sv); |
4747
|
261753212
|
100
|
|
|
|
if (HEK_UTF8(hek)) |
4748
|
1298
|
|
|
|
|
SvUTF8_on(sv); |
4749
|
261752605
|
|
|
|
|
else SvUTF8_off(sv); |
4750
|
|
|
|
|
|
return; |
4751
|
|
|
|
|
|
} |
4752
|
|
|
|
|
|
} |
4753
|
|
|
|
|
|
} |
4754
|
|
|
|
|
|
|
4755
|
|
|
|
|
|
|
4756
|
|
|
|
|
|
/* |
4757
|
|
|
|
|
|
=for apidoc sv_usepvn_flags |
4758
|
|
|
|
|
|
|
4759
|
|
|
|
|
|
Tells an SV to use C to find its string value. Normally the |
4760
|
|
|
|
|
|
string is stored inside the SV but sv_usepvn allows the SV to use an |
4761
|
|
|
|
|
|
outside string. The C should point to memory that was allocated |
4762
|
|
|
|
|
|
by C. It must be the start of a mallocked block |
4763
|
|
|
|
|
|
of memory, and not a pointer to the middle of it. The |
4764
|
|
|
|
|
|
string length, C, must be supplied. By default |
4765
|
|
|
|
|
|
this function will realloc (i.e. move) the memory pointed to by C, |
4766
|
|
|
|
|
|
so that pointer should not be freed or used by the programmer after |
4767
|
|
|
|
|
|
giving it to sv_usepvn, and neither should any pointers from "behind" |
4768
|
|
|
|
|
|
that pointer (e.g. ptr + 1) be used. |
4769
|
|
|
|
|
|
|
4770
|
|
|
|
|
|
If C & SV_SMAGIC is true, will call SvSETMAGIC. If C & |
4771
|
|
|
|
|
|
SV_HAS_TRAILING_NUL is true, then C must be NUL, and the realloc |
4772
|
|
|
|
|
|
will be skipped (i.e. the buffer is actually at least 1 byte longer than |
4773
|
|
|
|
|
|
C, and already meets the requirements for storing in C). |
4774
|
|
|
|
|
|
|
4775
|
|
|
|
|
|
=cut |
4776
|
|
|
|
|
|
*/ |
4777
|
|
|
|
|
|
|
4778
|
|
|
|
|
|
void |
4779
|
334644
|
|
|
|
|
Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) |
4780
|
334644
|
100
|
|
|
|
{ |
4781
|
|
|
|
|
|
dVAR; |
4782
|
|
|
|
|
|
STRLEN allocate; |
4783
|
|
|
|
|
|
|
4784
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_USEPVN_FLAGS; |
4785
|
|
|
|
|
|
|
4786
|
334644
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
4787
|
165296
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); |
4788
|
334644
|
50
|
|
|
|
if (!ptr) { |
4789
|
0
|
0
|
|
|
|
(void)SvOK_off(sv); |
4790
|
0
|
0
|
|
|
|
if (flags & SV_SMAGIC) |
4791
|
0
|
0
|
|
|
|
SvSETMAGIC(sv); |
4792
|
334644
|
|
|
|
|
return; |
4793
|
|
|
|
|
|
} |
4794
|
334644
|
100
|
|
|
|
if (SvPVX_const(sv)) |
4795
|
50510
|
50
|
|
|
|
SvPV_free(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
4796
|
|
|
|
|
|
|
4797
|
|
|
|
|
|
#ifdef DEBUGGING |
4798
|
|
|
|
|
|
if (flags & SV_HAS_TRAILING_NUL) |
4799
|
|
|
|
|
|
assert(ptr[len] == '\0'); |
4800
|
|
|
|
|
|
#endif |
4801
|
|
|
|
|
|
|
4802
|
334644
|
|
|
|
|
allocate = (flags & SV_HAS_TRAILING_NUL) |
4803
|
334764
|
100
|
|
|
|
? len + 1 : |
4804
|
|
|
|
|
|
#ifdef Perl_safesysmalloc_size |
4805
|
|
|
|
|
|
len + 1; |
4806
|
|
|
|
|
|
#else |
4807
|
120
|
50
|
|
|
|
PERL_STRLEN_ROUNDUP(len + 1); |
4808
|
|
|
|
|
|
#endif |
4809
|
334644
|
100
|
|
|
|
if (flags & SV_HAS_TRAILING_NUL) { |
4810
|
|
|
|
|
|
/* It's long enough - do nothing. |
4811
|
|
|
|
|
|
Specifically Perl_newCONSTSUB is relying on this. */ |
4812
|
|
|
|
|
|
} else { |
4813
|
|
|
|
|
|
#ifdef DEBUGGING |
4814
|
|
|
|
|
|
/* Force a move to shake out bugs in callers. */ |
4815
|
|
|
|
|
|
char *new_ptr = (char*)safemalloc(allocate); |
4816
|
|
|
|
|
|
Copy(ptr, new_ptr, len, char); |
4817
|
|
|
|
|
|
PoisonFree(ptr,len,char); |
4818
|
|
|
|
|
|
Safefree(ptr); |
4819
|
|
|
|
|
|
ptr = new_ptr; |
4820
|
|
|
|
|
|
#else |
4821
|
120
|
|
|
|
|
ptr = (char*) saferealloc (ptr, allocate); |
4822
|
|
|
|
|
|
#endif |
4823
|
|
|
|
|
|
} |
4824
|
|
|
|
|
|
#ifdef Perl_safesysmalloc_size |
4825
|
|
|
|
|
|
SvLEN_set(sv, Perl_safesysmalloc_size(ptr)); |
4826
|
|
|
|
|
|
#else |
4827
|
334644
|
|
|
|
|
SvLEN_set(sv, allocate); |
4828
|
|
|
|
|
|
#endif |
4829
|
334644
|
|
|
|
|
SvCUR_set(sv, len); |
4830
|
334644
|
|
|
|
|
SvPV_set(sv, ptr); |
4831
|
334644
|
100
|
|
|
|
if (!(flags & SV_HAS_TRAILING_NUL)) { |
4832
|
120
|
|
|
|
|
ptr[len] = '\0'; |
4833
|
|
|
|
|
|
} |
4834
|
334644
|
|
|
|
|
(void)SvPOK_only_UTF8(sv); /* validate pointer */ |
4835
|
334644
|
100
|
|
|
|
SvTAINT(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
4836
|
334644
|
100
|
|
|
|
if (flags & SV_SMAGIC) |
4837
|
2
|
50
|
|
|
|
SvSETMAGIC(sv); |
4838
|
|
|
|
|
|
} |
4839
|
|
|
|
|
|
|
4840
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
4841
|
|
|
|
|
|
/* Need to do this *after* making the SV normal, as we need the buffer |
4842
|
|
|
|
|
|
pointer to remain valid until after we've copied it. If we let go too early, |
4843
|
|
|
|
|
|
another thread could invalidate it by unsharing last of the same hash key |
4844
|
|
|
|
|
|
(which it can do by means other than releasing copy-on-write Svs) |
4845
|
|
|
|
|
|
or by changing the other copy-on-write SVs in the loop. */ |
4846
|
|
|
|
|
|
STATIC void |
4847
|
|
|
|
|
|
S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after) |
4848
|
|
|
|
|
|
{ |
4849
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_RELEASE_COW; |
4850
|
|
|
|
|
|
|
4851
|
|
|
|
|
|
{ /* this SV was SvIsCOW_normal(sv) */ |
4852
|
|
|
|
|
|
/* we need to find the SV pointing to us. */ |
4853
|
|
|
|
|
|
SV *current = SV_COW_NEXT_SV(after); |
4854
|
|
|
|
|
|
|
4855
|
|
|
|
|
|
if (current == sv) { |
4856
|
|
|
|
|
|
/* The SV we point to points back to us (there were only two of us |
4857
|
|
|
|
|
|
in the loop.) |
4858
|
|
|
|
|
|
Hence other SV is no longer copy on write either. */ |
4859
|
|
|
|
|
|
SvIsCOW_off(after); |
4860
|
|
|
|
|
|
} else { |
4861
|
|
|
|
|
|
/* We need to follow the pointers around the loop. */ |
4862
|
|
|
|
|
|
SV *next; |
4863
|
|
|
|
|
|
while ((next = SV_COW_NEXT_SV(current)) != sv) { |
4864
|
|
|
|
|
|
assert (next); |
4865
|
|
|
|
|
|
current = next; |
4866
|
|
|
|
|
|
/* don't loop forever if the structure is bust, and we have |
4867
|
|
|
|
|
|
a pointer into a closed loop. */ |
4868
|
|
|
|
|
|
assert (current != after); |
4869
|
|
|
|
|
|
assert (SvPVX_const(current) == pvx); |
4870
|
|
|
|
|
|
} |
4871
|
|
|
|
|
|
/* Make the SV before us point to the SV after us. */ |
4872
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(current, after); |
4873
|
|
|
|
|
|
} |
4874
|
|
|
|
|
|
} |
4875
|
|
|
|
|
|
} |
4876
|
|
|
|
|
|
#endif |
4877
|
|
|
|
|
|
/* |
4878
|
|
|
|
|
|
=for apidoc sv_force_normal_flags |
4879
|
|
|
|
|
|
|
4880
|
|
|
|
|
|
Undo various types of fakery on an SV, where fakery means |
4881
|
|
|
|
|
|
"more than" a string: if the PV is a shared string, make |
4882
|
|
|
|
|
|
a private copy; if we're a ref, stop refing; if we're a glob, downgrade to |
4883
|
|
|
|
|
|
an xpvmg; if we're a copy-on-write scalar, this is the on-write time when |
4884
|
|
|
|
|
|
we do the copy, and is also used locally; if this is a |
4885
|
|
|
|
|
|
vstring, drop the vstring magic. If C is set |
4886
|
|
|
|
|
|
then a copy-on-write scalar drops its PV buffer (if any) and becomes |
4887
|
|
|
|
|
|
SvPOK_off rather than making a copy. (Used where this |
4888
|
|
|
|
|
|
scalar is about to be set to some other value.) In addition, |
4889
|
|
|
|
|
|
the C parameter gets passed to C |
4890
|
|
|
|
|
|
when unreffing. C calls this function |
4891
|
|
|
|
|
|
with flags set to 0. |
4892
|
|
|
|
|
|
|
4893
|
|
|
|
|
|
=cut |
4894
|
|
|
|
|
|
*/ |
4895
|
|
|
|
|
|
|
4896
|
|
|
|
|
|
static void |
4897
|
767424465
|
|
|
|
|
S_sv_uncow(pTHX_ SV * const sv, const U32 flags) |
4898
|
|
|
|
|
|
{ |
4899
|
|
|
|
|
|
dVAR; |
4900
|
|
|
|
|
|
|
4901
|
|
|
|
|
|
assert(SvIsCOW(sv)); |
4902
|
|
|
|
|
|
{ |
4903
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
4904
|
767424465
|
|
|
|
|
const char * const pvx = SvPVX_const(sv); |
4905
|
767424465
|
|
|
|
|
const STRLEN len = SvLEN(sv); |
4906
|
767424465
|
|
|
|
|
const STRLEN cur = SvCUR(sv); |
4907
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4908
|
|
|
|
|
|
/* next COW sv in the loop. If len is 0 then this is a shared-hash |
4909
|
|
|
|
|
|
key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as |
4910
|
|
|
|
|
|
we'll fail an assertion. */ |
4911
|
|
|
|
|
|
SV * const next = len ? SV_COW_NEXT_SV(sv) : 0; |
4912
|
|
|
|
|
|
# endif |
4913
|
|
|
|
|
|
|
4914
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
4915
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, |
4916
|
|
|
|
|
|
"Copy on write: Force normal %ld\n", |
4917
|
|
|
|
|
|
(long) flags); |
4918
|
|
|
|
|
|
sv_dump(sv); |
4919
|
|
|
|
|
|
} |
4920
|
767424465
|
|
|
|
|
SvIsCOW_off(sv); |
4921
|
|
|
|
|
|
# ifdef PERL_NEW_COPY_ON_WRITE |
4922
|
767424465
|
100
|
|
|
|
if (len && CowREFCNT(sv) == 0) |
|
|
100
|
|
|
|
|
4923
|
|
|
|
|
|
/* We own the buffer ourselves. */ |
4924
|
|
|
|
|
|
NOOP; |
4925
|
|
|
|
|
|
else |
4926
|
|
|
|
|
|
# endif |
4927
|
|
|
|
|
|
{ |
4928
|
|
|
|
|
|
|
4929
|
|
|
|
|
|
/* This SV doesn't own the buffer, so need to Newx() a new one: */ |
4930
|
|
|
|
|
|
# ifdef PERL_NEW_COPY_ON_WRITE |
4931
|
|
|
|
|
|
/* Must do this first, since the macro uses SvPVX. */ |
4932
|
653693286
|
100
|
|
|
|
if (len) CowREFCNT(sv)--; |
4933
|
|
|
|
|
|
# endif |
4934
|
653693286
|
|
|
|
|
SvPV_set(sv, NULL); |
4935
|
653693286
|
|
|
|
|
SvLEN_set(sv, 0); |
4936
|
653693286
|
100
|
|
|
|
if (flags & SV_COW_DROP_PV) { |
4937
|
|
|
|
|
|
/* OK, so we don't need to copy our buffer. */ |
4938
|
640364794
|
|
|
|
|
SvPOK_off(sv); |
4939
|
|
|
|
|
|
} else { |
4940
|
13328492
|
50
|
|
|
|
SvGROW(sv, cur + 1); |
|
|
50
|
|
|
|
|
4941
|
13328492
|
|
|
|
|
Move(pvx,SvPVX(sv),cur,char); |
4942
|
13328492
|
|
|
|
|
SvCUR_set(sv, cur); |
4943
|
13328492
|
|
|
|
|
*SvEND(sv) = '\0'; |
4944
|
|
|
|
|
|
} |
4945
|
653693286
|
100
|
|
|
|
if (len) { |
4946
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
4947
|
|
|
|
|
|
sv_release_COW(sv, pvx, next); |
4948
|
|
|
|
|
|
# endif |
4949
|
|
|
|
|
|
} else { |
4950
|
366171262
|
|
|
|
|
unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); |
4951
|
|
|
|
|
|
} |
4952
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
4953
|
|
|
|
|
|
sv_dump(sv); |
4954
|
|
|
|
|
|
} |
4955
|
|
|
|
|
|
} |
4956
|
|
|
|
|
|
#else |
4957
|
|
|
|
|
|
const char * const pvx = SvPVX_const(sv); |
4958
|
|
|
|
|
|
const STRLEN len = SvCUR(sv); |
4959
|
|
|
|
|
|
SvIsCOW_off(sv); |
4960
|
|
|
|
|
|
SvPV_set(sv, NULL); |
4961
|
|
|
|
|
|
SvLEN_set(sv, 0); |
4962
|
|
|
|
|
|
if (flags & SV_COW_DROP_PV) { |
4963
|
|
|
|
|
|
/* OK, so we don't need to copy our buffer. */ |
4964
|
|
|
|
|
|
SvPOK_off(sv); |
4965
|
|
|
|
|
|
} else { |
4966
|
|
|
|
|
|
SvGROW(sv, len + 1); |
4967
|
|
|
|
|
|
Move(pvx,SvPVX(sv),len,char); |
4968
|
|
|
|
|
|
*SvEND(sv) = '\0'; |
4969
|
|
|
|
|
|
} |
4970
|
|
|
|
|
|
unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); |
4971
|
|
|
|
|
|
#endif |
4972
|
|
|
|
|
|
} |
4973
|
767424465
|
|
|
|
|
} |
4974
|
|
|
|
|
|
|
4975
|
|
|
|
|
|
void |
4976
|
1252285707
|
|
|
|
|
Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) |
4977
|
|
|
|
|
|
{ |
4978
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; |
4979
|
|
|
|
|
|
|
4980
|
1252285707
|
100
|
|
|
|
if (SvREADONLY(sv)) |
4981
|
78
|
|
|
|
|
Perl_croak_no_modify(); |
4982
|
1252285629
|
100
|
|
|
|
else if (SvIsCOW(sv)) |
4983
|
757655483
|
|
|
|
|
S_sv_uncow(aTHX_ sv, flags); |
4984
|
1252285629
|
100
|
|
|
|
if (SvROK(sv)) |
4985
|
465097065
|
|
|
|
|
sv_unref_flags(sv, flags); |
4986
|
787188564
|
100
|
|
|
|
else if (SvFAKE(sv) && isGV_with_GP(sv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4987
|
|
|
|
|
|
sv_unglob(sv, flags); |
4988
|
760105808
|
100
|
|
|
|
else if (SvFAKE(sv) && isREGEXP(sv)) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
4989
|
|
|
|
|
|
/* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous |
4990
|
|
|
|
|
|
to sv_unglob. We only need it here, so inline it. */ |
4991
|
52
|
|
|
|
|
const bool islv = SvTYPE(sv) == SVt_PVLV; |
4992
|
73
|
100
|
|
|
|
const svtype new_type = |
|
|
100
|
|
|
|
|
4993
|
62
|
100
|
|
|
|
islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; |
4994
|
52
|
|
|
|
|
SV *const temp = newSV_type(new_type); |
4995
|
|
|
|
|
|
regexp *const temp_p = ReANY((REGEXP *)sv); |
4996
|
|
|
|
|
|
|
4997
|
52
|
100
|
|
|
|
if (new_type == SVt_PVMG) { |
4998
|
6
|
|
|
|
|
SvMAGIC_set(temp, SvMAGIC(sv)); |
4999
|
6
|
|
|
|
|
SvMAGIC_set(sv, NULL); |
5000
|
6
|
|
|
|
|
SvSTASH_set(temp, SvSTASH(sv)); |
5001
|
6
|
|
|
|
|
SvSTASH_set(sv, NULL); |
5002
|
|
|
|
|
|
} |
5003
|
52
|
100
|
|
|
|
if (!islv) SvCUR_set(temp, SvCUR(sv)); |
5004
|
|
|
|
|
|
/* Remember that SvPVX is in the head, not the body. But |
5005
|
|
|
|
|
|
RX_WRAPPED is in the body. */ |
5006
|
|
|
|
|
|
assert(ReANY((REGEXP *)sv)->mother_re); |
5007
|
|
|
|
|
|
/* Their buffer is already owned by someone else. */ |
5008
|
52
|
100
|
|
|
|
if (flags & SV_COW_DROP_PV) { |
5009
|
|
|
|
|
|
/* SvLEN is already 0. For SVt_REGEXP, we have a brand new |
5010
|
|
|
|
|
|
zeroed body. For SVt_PVLV, it should have been set to 0 |
5011
|
|
|
|
|
|
before turning into a regexp. */ |
5012
|
|
|
|
|
|
assert(!SvLEN(islv ? sv : temp)); |
5013
|
44
|
|
|
|
|
sv->sv_u.svu_pv = 0; |
5014
|
|
|
|
|
|
} |
5015
|
|
|
|
|
|
else { |
5016
|
12
|
|
|
|
|
sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); |
5017
|
8
|
100
|
|
|
|
SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); |
5018
|
8
|
|
|
|
|
SvPOK_on(sv); |
5019
|
|
|
|
|
|
} |
5020
|
|
|
|
|
|
|
5021
|
|
|
|
|
|
/* Now swap the rest of the bodies. */ |
5022
|
|
|
|
|
|
|
5023
|
52
|
|
|
|
|
SvFAKE_off(sv); |
5024
|
52
|
100
|
|
|
|
if (!islv) { |
5025
|
42
|
|
|
|
|
SvFLAGS(sv) &= ~SVTYPEMASK; |
5026
|
42
|
|
|
|
|
SvFLAGS(sv) |= new_type; |
5027
|
42
|
|
|
|
|
SvANY(sv) = SvANY(temp); |
5028
|
|
|
|
|
|
} |
5029
|
|
|
|
|
|
|
5030
|
52
|
|
|
|
|
SvFLAGS(temp) &= ~(SVTYPEMASK); |
5031
|
52
|
|
|
|
|
SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; |
5032
|
52
|
|
|
|
|
SvANY(temp) = temp_p; |
5033
|
52
|
|
|
|
|
temp->sv_u.svu_rx = (regexp *)temp_p; |
5034
|
|
|
|
|
|
|
5035
|
52
|
|
|
|
|
SvREFCNT_dec_NN(temp); |
5036
|
|
|
|
|
|
} |
5037
|
760105704
|
100
|
|
|
|
else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring); |
|
|
100
|
|
|
|
|
5038
|
1252285627
|
|
|
|
|
} |
5039
|
|
|
|
|
|
|
5040
|
|
|
|
|
|
/* |
5041
|
|
|
|
|
|
=for apidoc sv_chop |
5042
|
|
|
|
|
|
|
5043
|
|
|
|
|
|
Efficient removal of characters from the beginning of the string buffer. |
5044
|
|
|
|
|
|
SvPOK(sv), or at least SvPOKp(sv), must be true and the C must be a |
5045
|
|
|
|
|
|
pointer to somewhere inside the string buffer. The C becomes the first |
5046
|
|
|
|
|
|
character of the adjusted string. Uses the "OOK hack". On return, only |
5047
|
|
|
|
|
|
SvPOK(sv) and SvPOKp(sv) among the OK flags will be true. |
5048
|
|
|
|
|
|
|
5049
|
|
|
|
|
|
Beware: after this function returns, C and SvPVX_const(sv) may no longer |
5050
|
|
|
|
|
|
refer to the same chunk of data. |
5051
|
|
|
|
|
|
|
5052
|
|
|
|
|
|
The unfortunate similarity of this function's name to that of Perl's C |
5053
|
|
|
|
|
|
operator is strictly coincidental. This function works from the left; |
5054
|
|
|
|
|
|
C works from the right. |
5055
|
|
|
|
|
|
|
5056
|
|
|
|
|
|
=cut |
5057
|
|
|
|
|
|
*/ |
5058
|
|
|
|
|
|
|
5059
|
|
|
|
|
|
void |
5060
|
1277240
|
|
|
|
|
Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) |
5061
|
|
|
|
|
|
{ |
5062
|
|
|
|
|
|
STRLEN delta; |
5063
|
|
|
|
|
|
STRLEN old_delta; |
5064
|
|
|
|
|
|
U8 *p; |
5065
|
|
|
|
|
|
#ifdef DEBUGGING |
5066
|
|
|
|
|
|
const U8 *evacp; |
5067
|
|
|
|
|
|
STRLEN evacn; |
5068
|
|
|
|
|
|
#endif |
5069
|
|
|
|
|
|
STRLEN max_delta; |
5070
|
|
|
|
|
|
|
5071
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CHOP; |
5072
|
|
|
|
|
|
|
5073
|
1277240
|
100
|
|
|
|
if (!ptr || !SvPOKp(sv)) |
|
|
100
|
|
|
|
|
5074
|
|
|
|
|
|
return; |
5075
|
1277044
|
|
|
|
|
delta = ptr - SvPVX_const(sv); |
5076
|
1277044
|
100
|
|
|
|
if (!delta) { |
5077
|
|
|
|
|
|
/* Nothing to do. */ |
5078
|
|
|
|
|
|
return; |
5079
|
|
|
|
|
|
} |
5080
|
1267350
|
100
|
|
|
|
max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); |
5081
|
1267350
|
50
|
|
|
|
if (delta > max_delta) |
5082
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", |
5083
|
0
|
|
|
|
|
ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); |
5084
|
|
|
|
|
|
/* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */ |
5085
|
1267350
|
100
|
|
|
|
SV_CHECK_THINKFIRST(sv); |
5086
|
1267350
|
|
|
|
|
SvPOK_only_UTF8(sv); |
5087
|
|
|
|
|
|
|
5088
|
1267350
|
100
|
|
|
|
if (!SvOOK(sv)) { |
5089
|
591426
|
50
|
|
|
|
if (!SvLEN(sv)) { /* make copy of shared string */ |
5090
|
0
|
|
|
|
|
const char *pvx = SvPVX_const(sv); |
5091
|
0
|
|
|
|
|
const STRLEN len = SvCUR(sv); |
5092
|
0
|
0
|
|
|
|
SvGROW(sv, len + 1); |
|
|
0
|
|
|
|
|
5093
|
0
|
|
|
|
|
Move(pvx,SvPVX(sv),len,char); |
5094
|
0
|
|
|
|
|
*SvEND(sv) = '\0'; |
5095
|
|
|
|
|
|
} |
5096
|
591426
|
|
|
|
|
SvOOK_on(sv); |
5097
|
591426
|
|
|
|
|
old_delta = 0; |
5098
|
|
|
|
|
|
} else { |
5099
|
675924
|
50
|
|
|
|
SvOOK_offset(sv, old_delta); |
|
|
100
|
|
|
|
|
5100
|
|
|
|
|
|
} |
5101
|
1267350
|
|
|
|
|
SvLEN_set(sv, SvLEN(sv) - delta); |
5102
|
1267350
|
|
|
|
|
SvCUR_set(sv, SvCUR(sv) - delta); |
5103
|
1267350
|
|
|
|
|
SvPV_set(sv, SvPVX(sv) + delta); |
5104
|
|
|
|
|
|
|
5105
|
1267350
|
|
|
|
|
p = (U8 *)SvPVX_const(sv); |
5106
|
|
|
|
|
|
|
5107
|
|
|
|
|
|
#ifdef DEBUGGING |
5108
|
|
|
|
|
|
/* how many bytes were evacuated? we will fill them with sentinel |
5109
|
|
|
|
|
|
bytes, except for the part holding the new offset of course. */ |
5110
|
|
|
|
|
|
evacn = delta; |
5111
|
|
|
|
|
|
if (old_delta) |
5112
|
|
|
|
|
|
evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN)); |
5113
|
|
|
|
|
|
assert(evacn); |
5114
|
|
|
|
|
|
assert(evacn <= delta + old_delta); |
5115
|
|
|
|
|
|
evacp = p - evacn; |
5116
|
|
|
|
|
|
#endif |
5117
|
|
|
|
|
|
|
5118
|
|
|
|
|
|
/* This sets 'delta' to the accumulated value of all deltas so far */ |
5119
|
1267350
|
|
|
|
|
delta += old_delta; |
5120
|
|
|
|
|
|
assert(delta); |
5121
|
|
|
|
|
|
|
5122
|
|
|
|
|
|
/* If 'delta' fits in a byte, store it just prior to the new beginning of |
5123
|
|
|
|
|
|
* the string; otherwise store a 0 byte there and store 'delta' just prior |
5124
|
|
|
|
|
|
* to that, using as many bytes as a STRLEN occupies. Thus it overwrites a |
5125
|
|
|
|
|
|
* portion of the chopped part of the string */ |
5126
|
1267350
|
100
|
|
|
|
if (delta < 0x100) { |
5127
|
886110
|
|
|
|
|
*--p = (U8) delta; |
5128
|
|
|
|
|
|
} else { |
5129
|
381240
|
|
|
|
|
*--p = 0; |
5130
|
381240
|
|
|
|
|
p -= sizeof(STRLEN); |
5131
|
381240
|
|
|
|
|
Copy((U8*)&delta, p, sizeof(STRLEN), U8); |
5132
|
|
|
|
|
|
} |
5133
|
|
|
|
|
|
|
5134
|
|
|
|
|
|
#ifdef DEBUGGING |
5135
|
|
|
|
|
|
/* Fill the preceding buffer with sentinals to verify that no-one is |
5136
|
|
|
|
|
|
using it. */ |
5137
|
|
|
|
|
|
while (p > evacp) { |
5138
|
|
|
|
|
|
--p; |
5139
|
|
|
|
|
|
*p = (U8)PTR2UV(p); |
5140
|
|
|
|
|
|
} |
5141
|
|
|
|
|
|
#endif |
5142
|
|
|
|
|
|
} |
5143
|
|
|
|
|
|
|
5144
|
|
|
|
|
|
/* |
5145
|
|
|
|
|
|
=for apidoc sv_catpvn |
5146
|
|
|
|
|
|
|
5147
|
|
|
|
|
|
Concatenates the string onto the end of the string which is in the SV. The |
5148
|
|
|
|
|
|
C indicates number of bytes to copy. If the SV has the UTF-8 |
5149
|
|
|
|
|
|
status set, then the bytes appended should be valid UTF-8. |
5150
|
|
|
|
|
|
Handles 'get' magic, but not 'set' magic. See C. |
5151
|
|
|
|
|
|
|
5152
|
|
|
|
|
|
=for apidoc sv_catpvn_flags |
5153
|
|
|
|
|
|
|
5154
|
|
|
|
|
|
Concatenates the string onto the end of the string which is in the SV. The |
5155
|
|
|
|
|
|
C indicates number of bytes to copy. If the SV has the UTF-8 |
5156
|
|
|
|
|
|
status set, then the bytes appended should be valid UTF-8. |
5157
|
|
|
|
|
|
If C has the C bit set, will |
5158
|
|
|
|
|
|
C on C afterwards if appropriate. |
5159
|
|
|
|
|
|
C and C are implemented |
5160
|
|
|
|
|
|
in terms of this function. |
5161
|
|
|
|
|
|
|
5162
|
|
|
|
|
|
=cut |
5163
|
|
|
|
|
|
*/ |
5164
|
|
|
|
|
|
|
5165
|
|
|
|
|
|
void |
5166
|
489230917
|
|
|
|
|
Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags) |
5167
|
|
|
|
|
|
{ |
5168
|
|
|
|
|
|
dVAR; |
5169
|
|
|
|
|
|
STRLEN dlen; |
5170
|
489230917
|
100
|
|
|
|
const char * const dstr = SvPV_force_flags(dsv, dlen, flags); |
5171
|
|
|
|
|
|
|
5172
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPVN_FLAGS; |
5173
|
|
|
|
|
|
assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8)); |
5174
|
|
|
|
|
|
|
5175
|
489230917
|
100
|
|
|
|
if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) { |
|
|
100
|
|
|
|
|
5176
|
489002249
|
100
|
|
|
|
if (flags & SV_CATUTF8 && !SvUTF8(dsv)) { |
|
|
100
|
|
|
|
|
5177
|
73922
|
|
|
|
|
sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1); |
5178
|
73922
|
|
|
|
|
dlen = SvCUR(dsv); |
5179
|
|
|
|
|
|
} |
5180
|
488928327
|
50
|
|
|
|
else SvGROW(dsv, dlen + slen + 1); |
|
|
100
|
|
|
|
|
5181
|
489002249
|
100
|
|
|
|
if (sstr == dstr) |
5182
|
32
|
|
|
|
|
sstr = SvPVX_const(dsv); |
5183
|
489002249
|
|
|
|
|
Move(sstr, SvPVX(dsv) + dlen, slen, char); |
5184
|
489002249
|
|
|
|
|
SvCUR_set(dsv, SvCUR(dsv) + slen); |
5185
|
|
|
|
|
|
} |
5186
|
|
|
|
|
|
else { |
5187
|
|
|
|
|
|
/* We inline bytes_to_utf8, to avoid an extra malloc. */ |
5188
|
228668
|
|
|
|
|
const char * const send = sstr + slen; |
5189
|
|
|
|
|
|
U8 *d; |
5190
|
|
|
|
|
|
|
5191
|
|
|
|
|
|
/* Something this code does not account for, which I think is |
5192
|
|
|
|
|
|
impossible; it would require the same pv to be treated as |
5193
|
|
|
|
|
|
bytes *and* utf8, which would indicate a bug elsewhere. */ |
5194
|
|
|
|
|
|
assert(sstr != dstr); |
5195
|
|
|
|
|
|
|
5196
|
228668
|
50
|
|
|
|
SvGROW(dsv, dlen + slen * 2 + 1); |
|
|
100
|
|
|
|
|
5197
|
228668
|
|
|
|
|
d = (U8 *)SvPVX(dsv) + dlen; |
5198
|
|
|
|
|
|
|
5199
|
3680454
|
100
|
|
|
|
while (sstr < send) { |
5200
|
3337452
|
|
|
|
|
append_utf8_from_native_byte(*sstr, &d); |
5201
|
3337452
|
|
|
|
|
sstr++; |
5202
|
|
|
|
|
|
} |
5203
|
228668
|
|
|
|
|
SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv)); |
5204
|
|
|
|
|
|
} |
5205
|
489230917
|
|
|
|
|
*SvEND(dsv) = '\0'; |
5206
|
489230917
|
|
|
|
|
(void)SvPOK_only_UTF8(dsv); /* validate pointer */ |
5207
|
489230917
|
100
|
|
|
|
SvTAINT(dsv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5208
|
489230917
|
100
|
|
|
|
if (flags & SV_SMAGIC) |
5209
|
38110
|
100
|
|
|
|
SvSETMAGIC(dsv); |
5210
|
489230917
|
|
|
|
|
} |
5211
|
|
|
|
|
|
|
5212
|
|
|
|
|
|
/* |
5213
|
|
|
|
|
|
=for apidoc sv_catsv |
5214
|
|
|
|
|
|
|
5215
|
|
|
|
|
|
Concatenates the string from SV C onto the end of the string in SV |
5216
|
|
|
|
|
|
C. If C is null, does nothing; otherwise modifies only C. |
5217
|
|
|
|
|
|
Handles 'get' magic on both SVs, but no 'set' magic. See C and |
5218
|
|
|
|
|
|
C. |
5219
|
|
|
|
|
|
|
5220
|
|
|
|
|
|
=for apidoc sv_catsv_flags |
5221
|
|
|
|
|
|
|
5222
|
|
|
|
|
|
Concatenates the string from SV C onto the end of the string in SV |
5223
|
|
|
|
|
|
C. If C is null, does nothing; otherwise modifies only C. |
5224
|
|
|
|
|
|
If C include C bit set, will call C on both SVs if |
5225
|
|
|
|
|
|
appropriate. If C include C, C will be called on |
5226
|
|
|
|
|
|
the modified SV afterward, if appropriate. C, C, |
5227
|
|
|
|
|
|
and C are implemented in terms of this function. |
5228
|
|
|
|
|
|
|
5229
|
|
|
|
|
|
=cut */ |
5230
|
|
|
|
|
|
|
5231
|
|
|
|
|
|
void |
5232
|
84306832
|
|
|
|
|
Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) |
5233
|
|
|
|
|
|
{ |
5234
|
|
|
|
|
|
dVAR; |
5235
|
|
|
|
|
|
|
5236
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATSV_FLAGS; |
5237
|
|
|
|
|
|
|
5238
|
84306832
|
50
|
|
|
|
if (ssv) { |
5239
|
|
|
|
|
|
STRLEN slen; |
5240
|
84306832
|
100
|
|
|
|
const char *spv = SvPV_flags_const(ssv, slen, flags); |
5241
|
84306832
|
50
|
|
|
|
if (spv) { |
5242
|
104740130
|
100
|
|
|
|
if (flags & SV_GMAGIC) |
|
|
100
|
|
|
|
|
5243
|
20433302
|
|
|
|
|
SvGETMAGIC(dsv); |
5244
|
84306832
|
100
|
|
|
|
sv_catpvn_flags(dsv, spv, slen, |
|
|
50
|
|
|
|
|
5245
|
|
|
|
|
|
DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES); |
5246
|
84306832
|
100
|
|
|
|
if (flags & SV_SMAGIC) |
5247
|
2
|
50
|
|
|
|
SvSETMAGIC(dsv); |
5248
|
|
|
|
|
|
} |
5249
|
|
|
|
|
|
} |
5250
|
84306832
|
|
|
|
|
} |
5251
|
|
|
|
|
|
|
5252
|
|
|
|
|
|
/* |
5253
|
|
|
|
|
|
=for apidoc sv_catpv |
5254
|
|
|
|
|
|
|
5255
|
|
|
|
|
|
Concatenates the string onto the end of the string which is in the SV. |
5256
|
|
|
|
|
|
If the SV has the UTF-8 status set, then the bytes appended should be |
5257
|
|
|
|
|
|
valid UTF-8. Handles 'get' magic, but not 'set' magic. See C. |
5258
|
|
|
|
|
|
|
5259
|
|
|
|
|
|
=cut */ |
5260
|
|
|
|
|
|
|
5261
|
|
|
|
|
|
void |
5262
|
1678538
|
|
|
|
|
Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr) |
5263
|
|
|
|
|
|
{ |
5264
|
|
|
|
|
|
dVAR; |
5265
|
|
|
|
|
|
STRLEN len; |
5266
|
|
|
|
|
|
STRLEN tlen; |
5267
|
|
|
|
|
|
char *junk; |
5268
|
|
|
|
|
|
|
5269
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPV; |
5270
|
|
|
|
|
|
|
5271
|
1678538
|
50
|
|
|
|
if (!ptr) |
5272
|
1678538
|
|
|
|
|
return; |
5273
|
1678538
|
100
|
|
|
|
junk = SvPV_force(sv, tlen); |
5274
|
1678538
|
|
|
|
|
len = strlen(ptr); |
5275
|
1678538
|
50
|
|
|
|
SvGROW(sv, tlen + len + 1); |
|
|
100
|
|
|
|
|
5276
|
1678538
|
50
|
|
|
|
if (ptr == junk) |
5277
|
0
|
|
|
|
|
ptr = SvPVX_const(sv); |
5278
|
1678538
|
|
|
|
|
Move(ptr,SvPVX(sv)+tlen,len+1,char); |
5279
|
1678538
|
|
|
|
|
SvCUR_set(sv, SvCUR(sv) + len); |
5280
|
1678538
|
|
|
|
|
(void)SvPOK_only_UTF8(sv); /* validate pointer */ |
5281
|
1678538
|
100
|
|
|
|
SvTAINT(sv); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
5282
|
|
|
|
|
|
} |
5283
|
|
|
|
|
|
|
5284
|
|
|
|
|
|
/* |
5285
|
|
|
|
|
|
=for apidoc sv_catpv_flags |
5286
|
|
|
|
|
|
|
5287
|
|
|
|
|
|
Concatenates the string onto the end of the string which is in the SV. |
5288
|
|
|
|
|
|
If the SV has the UTF-8 status set, then the bytes appended should |
5289
|
|
|
|
|
|
be valid UTF-8. If C has the C bit set, will C |
5290
|
|
|
|
|
|
on the modified SV if appropriate. |
5291
|
|
|
|
|
|
|
5292
|
|
|
|
|
|
=cut |
5293
|
|
|
|
|
|
*/ |
5294
|
|
|
|
|
|
|
5295
|
|
|
|
|
|
void |
5296
|
1196
|
|
|
|
|
Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags) |
5297
|
|
|
|
|
|
{ |
5298
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPV_FLAGS; |
5299
|
1196
|
|
|
|
|
sv_catpvn_flags(dstr, sstr, strlen(sstr), flags); |
5300
|
1196
|
|
|
|
|
} |
5301
|
|
|
|
|
|
|
5302
|
|
|
|
|
|
/* |
5303
|
|
|
|
|
|
=for apidoc sv_catpv_mg |
5304
|
|
|
|
|
|
|
5305
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
5306
|
|
|
|
|
|
|
5307
|
|
|
|
|
|
=cut |
5308
|
|
|
|
|
|
*/ |
5309
|
|
|
|
|
|
|
5310
|
|
|
|
|
|
void |
5311
|
2
|
|
|
|
|
Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr) |
5312
|
|
|
|
|
|
{ |
5313
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPV_MG; |
5314
|
|
|
|
|
|
|
5315
|
2
|
|
|
|
|
sv_catpv(sv,ptr); |
5316
|
2
|
50
|
|
|
|
SvSETMAGIC(sv); |
5317
|
2
|
|
|
|
|
} |
5318
|
|
|
|
|
|
|
5319
|
|
|
|
|
|
/* |
5320
|
|
|
|
|
|
=for apidoc newSV |
5321
|
|
|
|
|
|
|
5322
|
|
|
|
|
|
Creates a new SV. A non-zero C parameter indicates the number of |
5323
|
|
|
|
|
|
bytes of preallocated string space the SV should have. An extra byte for a |
5324
|
|
|
|
|
|
trailing NUL is also reserved. (SvPOK is not set for the SV even if string |
5325
|
|
|
|
|
|
space is allocated.) The reference count for the new SV is set to 1. |
5326
|
|
|
|
|
|
|
5327
|
|
|
|
|
|
In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first |
5328
|
|
|
|
|
|
parameter, I, a debug aid which allowed callers to identify themselves. |
5329
|
|
|
|
|
|
This aid has been superseded by a new build option, PERL_MEM_LOG (see |
5330
|
|
|
|
|
|
L). The older API is still there for use in XS |
5331
|
|
|
|
|
|
modules supporting older perls. |
5332
|
|
|
|
|
|
|
5333
|
|
|
|
|
|
=cut |
5334
|
|
|
|
|
|
*/ |
5335
|
|
|
|
|
|
|
5336
|
|
|
|
|
|
SV * |
5337
|
1007187639
|
|
|
|
|
Perl_newSV(pTHX_ const STRLEN len) |
5338
|
|
|
|
|
|
{ |
5339
|
|
|
|
|
|
dVAR; |
5340
|
|
|
|
|
|
SV *sv; |
5341
|
|
|
|
|
|
|
5342
|
1007187639
|
100
|
|
|
|
new_SV(sv); |
5343
|
1007187639
|
100
|
|
|
|
if (len) { |
5344
|
175817824
|
|
|
|
|
sv_upgrade(sv, SVt_PV); |
5345
|
175817824
|
50
|
|
|
|
SvGROW(sv, len + 1); |
|
|
50
|
|
|
|
|
5346
|
|
|
|
|
|
} |
5347
|
1007187639
|
|
|
|
|
return sv; |
5348
|
|
|
|
|
|
} |
5349
|
|
|
|
|
|
/* |
5350
|
|
|
|
|
|
=for apidoc sv_magicext |
5351
|
|
|
|
|
|
|
5352
|
|
|
|
|
|
Adds magic to an SV, upgrading it if necessary. Applies the |
5353
|
|
|
|
|
|
supplied vtable and returns a pointer to the magic added. |
5354
|
|
|
|
|
|
|
5355
|
|
|
|
|
|
Note that C will allow things that C will not. |
5356
|
|
|
|
|
|
In particular, you can add magic to SvREADONLY SVs, and add more than |
5357
|
|
|
|
|
|
one instance of the same 'how'. |
5358
|
|
|
|
|
|
|
5359
|
|
|
|
|
|
If C is greater than zero then a C I of C is |
5360
|
|
|
|
|
|
stored, if C is zero then C is stored as-is and - as another |
5361
|
|
|
|
|
|
special case - if C<(name && namlen == HEf_SVKEY)> then C is assumed |
5362
|
|
|
|
|
|
to contain an C and is stored as-is with its REFCNT incremented. |
5363
|
|
|
|
|
|
|
5364
|
|
|
|
|
|
(This is now used as a subroutine by C.) |
5365
|
|
|
|
|
|
|
5366
|
|
|
|
|
|
=cut |
5367
|
|
|
|
|
|
*/ |
5368
|
|
|
|
|
|
MAGIC * |
5369
|
68366284
|
|
|
|
|
Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, |
5370
|
|
|
|
|
|
const MGVTBL *const vtable, const char *const name, const I32 namlen) |
5371
|
68366284
|
100
|
|
|
|
{ |
5372
|
|
|
|
|
|
dVAR; |
5373
|
|
|
|
|
|
MAGIC* mg; |
5374
|
|
|
|
|
|
|
5375
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_MAGICEXT; |
5376
|
|
|
|
|
|
|
5377
|
|
|
|
|
|
if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); } |
5378
|
|
|
|
|
|
|
5379
|
56464578
|
|
|
|
|
SvUPGRADE(sv, SVt_PVMG); |
5380
|
68366284
|
|
|
|
|
Newxz(mg, 1, MAGIC); |
5381
|
68366284
|
|
|
|
|
mg->mg_moremagic = SvMAGIC(sv); |
5382
|
68366284
|
|
|
|
|
SvMAGIC_set(sv, mg); |
5383
|
|
|
|
|
|
|
5384
|
|
|
|
|
|
/* Sometimes a magic contains a reference loop, where the sv and |
5385
|
|
|
|
|
|
object refer to each other. To prevent a reference loop that |
5386
|
|
|
|
|
|
would prevent such objects being freed, we look for such loops |
5387
|
|
|
|
|
|
and if we find one we avoid incrementing the object refcount. |
5388
|
|
|
|
|
|
|
5389
|
|
|
|
|
|
Note we cannot do this to avoid self-tie loops as intervening RV must |
5390
|
|
|
|
|
|
have its REFCNT incremented to keep it in existence. |
5391
|
|
|
|
|
|
|
5392
|
|
|
|
|
|
*/ |
5393
|
68366284
|
100
|
|
|
|
if (!obj || obj == sv || |
5394
|
25357114
|
100
|
|
|
|
how == PERL_MAGIC_arylen || |
5395
|
25341630
|
100
|
|
|
|
how == PERL_MAGIC_symtab || |
5396
|
22107459
|
100
|
|
|
|
(SvTYPE(obj) == SVt_PVGV && |
5397
|
7277245
|
50
|
|
|
|
(GvSV(obj) == sv || GvHV(obj) == (const HV *)sv |
5398
|
452070
|
50
|
|
|
|
|| GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv |
|
|
0
|
|
|
|
|
5399
|
0
|
0
|
|
|
|
|| GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) |
|
|
0
|
|
|
|
|
5400
|
|
|
|
|
|
{ |
5401
|
65139855
|
|
|
|
|
mg->mg_obj = obj; |
5402
|
|
|
|
|
|
} |
5403
|
|
|
|
|
|
else { |
5404
|
3226429
|
|
|
|
|
mg->mg_obj = SvREFCNT_inc_simple(obj); |
5405
|
3226429
|
|
|
|
|
mg->mg_flags |= MGf_REFCOUNTED; |
5406
|
|
|
|
|
|
} |
5407
|
|
|
|
|
|
|
5408
|
|
|
|
|
|
/* Normal self-ties simply pass a null object, and instead of |
5409
|
|
|
|
|
|
using mg_obj directly, use the SvTIED_obj macro to produce a |
5410
|
|
|
|
|
|
new RV as needed. For glob "self-ties", we are tieing the PVIO |
5411
|
|
|
|
|
|
with an RV obj pointing to the glob containing the PVIO. In |
5412
|
|
|
|
|
|
this case, to avoid a reference loop, we need to weaken the |
5413
|
|
|
|
|
|
reference. |
5414
|
|
|
|
|
|
*/ |
5415
|
|
|
|
|
|
|
5416
|
68366284
|
100
|
|
|
|
if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && |
|
|
100
|
|
|
|
|
5417
|
32280
|
50
|
|
|
|
obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
5418
|
|
|
|
|
|
{ |
5419
|
29666
|
|
|
|
|
sv_rvweaken(obj); |
5420
|
|
|
|
|
|
} |
5421
|
|
|
|
|
|
|
5422
|
68366284
|
|
|
|
|
mg->mg_type = how; |
5423
|
68366284
|
|
|
|
|
mg->mg_len = namlen; |
5424
|
68366284
|
100
|
|
|
|
if (name) { |
5425
|
29783903
|
100
|
|
|
|
if (namlen > 0) |
5426
|
16666191
|
|
|
|
|
mg->mg_ptr = savepvn(name, namlen); |
5427
|
13117712
|
100
|
|
|
|
else if (namlen == HEf_SVKEY) { |
5428
|
|
|
|
|
|
/* Yes, this is casting away const. This is only for the case of |
5429
|
|
|
|
|
|
HEf_SVKEY. I think we need to document this aberation of the |
5430
|
|
|
|
|
|
constness of the API, rather than making name non-const, as |
5431
|
|
|
|
|
|
that change propagating outwards a long way. */ |
5432
|
12406639
|
|
|
|
|
mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); |
5433
|
|
|
|
|
|
} else |
5434
|
711073
|
|
|
|
|
mg->mg_ptr = (char *) name; |
5435
|
|
|
|
|
|
} |
5436
|
68366284
|
|
|
|
|
mg->mg_virtual = (MGVTBL *) vtable; |
5437
|
|
|
|
|
|
|
5438
|
68366284
|
|
|
|
|
mg_magical(sv); |
5439
|
68366284
|
|
|
|
|
return mg; |
5440
|
|
|
|
|
|
} |
5441
|
|
|
|
|
|
|
5442
|
|
|
|
|
|
MAGIC * |
5443
|
2005931
|
|
|
|
|
Perl_sv_magicext_mglob(pTHX_ SV *sv) |
5444
|
|
|
|
|
|
{ |
5445
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB; |
5446
|
2005931
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { |
|
|
100
|
|
|
|
|
5447
|
|
|
|
|
|
/* This sv is only a delegate. //g magic must be attached to |
5448
|
|
|
|
|
|
its target. */ |
5449
|
6
|
|
|
|
|
vivify_defelem(sv); |
5450
|
6
|
|
|
|
|
sv = LvTARG(sv); |
5451
|
|
|
|
|
|
} |
5452
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
5453
|
|
|
|
|
|
if (SvIsCOW(sv)) |
5454
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
5455
|
|
|
|
|
|
#endif |
5456
|
2005931
|
|
|
|
|
return sv_magicext(sv, NULL, PERL_MAGIC_regex_global, |
5457
|
|
|
|
|
|
&PL_vtbl_mglob, 0, 0); |
5458
|
|
|
|
|
|
} |
5459
|
|
|
|
|
|
|
5460
|
|
|
|
|
|
/* |
5461
|
|
|
|
|
|
=for apidoc sv_magic |
5462
|
|
|
|
|
|
|
5463
|
|
|
|
|
|
Adds magic to an SV. First upgrades C to type C if |
5464
|
|
|
|
|
|
necessary, then adds a new magic item of type C to the head of the |
5465
|
|
|
|
|
|
magic list. |
5466
|
|
|
|
|
|
|
5467
|
|
|
|
|
|
See C (which C now calls) for a description of the |
5468
|
|
|
|
|
|
handling of the C and C arguments. |
5469
|
|
|
|
|
|
|
5470
|
|
|
|
|
|
You need to use C to add magic to SvREADONLY SVs and also |
5471
|
|
|
|
|
|
to add more than one instance of the same 'how'. |
5472
|
|
|
|
|
|
|
5473
|
|
|
|
|
|
=cut |
5474
|
|
|
|
|
|
*/ |
5475
|
|
|
|
|
|
|
5476
|
|
|
|
|
|
void |
5477
|
42044472
|
|
|
|
|
Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, |
5478
|
|
|
|
|
|
const char *const name, const I32 namlen) |
5479
|
|
|
|
|
|
{ |
5480
|
|
|
|
|
|
dVAR; |
5481
|
|
|
|
|
|
const MGVTBL *vtable; |
5482
|
|
|
|
|
|
MAGIC* mg; |
5483
|
|
|
|
|
|
unsigned int flags; |
5484
|
|
|
|
|
|
unsigned int vtable_index; |
5485
|
|
|
|
|
|
|
5486
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_MAGIC; |
5487
|
|
|
|
|
|
|
5488
|
42044472
|
50
|
|
|
|
if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data) |
5489
|
62725472
|
50
|
|
|
|
|| ((flags = PL_magic_data[how]), |
5490
|
42044472
|
|
|
|
|
(vtable_index = flags & PERL_MAGIC_VTABLE_MASK) |
5491
|
|
|
|
|
|
> magic_vtable_max)) |
5492
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); |
5493
|
|
|
|
|
|
|
5494
|
|
|
|
|
|
/* PERL_MAGIC_ext is reserved for use by extensions not perl internals. |
5495
|
|
|
|
|
|
Useful for attaching extension internal data to perl vars. |
5496
|
|
|
|
|
|
Note that multiple extensions may clash if magical scalars |
5497
|
|
|
|
|
|
etc holding private data from one are passed to another. */ |
5498
|
|
|
|
|
|
|
5499
|
|
|
|
|
|
vtable = (vtable_index == magic_vtable_max) |
5500
|
42044472
|
100
|
|
|
|
? NULL : PL_magic_vtables + vtable_index; |
5501
|
|
|
|
|
|
|
5502
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
5503
|
|
|
|
|
|
if (SvIsCOW(sv)) |
5504
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
5505
|
|
|
|
|
|
#endif |
5506
|
42044472
|
100
|
|
|
|
if (SvREADONLY(sv)) { |
5507
|
10852
|
100
|
|
|
|
if ( |
5508
|
10852
|
|
|
|
|
!PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) |
5509
|
|
|
|
|
|
) |
5510
|
|
|
|
|
|
{ |
5511
|
6
|
|
|
|
|
Perl_croak_no_modify(); |
5512
|
|
|
|
|
|
} |
5513
|
|
|
|
|
|
} |
5514
|
42044466
|
100
|
|
|
|
if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
5515
|
540272
|
100
|
|
|
|
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { |
|
|
100
|
|
|
|
|
5516
|
|
|
|
|
|
/* sv_magic() refuses to add a magic of the same 'how' as an |
5517
|
|
|
|
|
|
existing one |
5518
|
|
|
|
|
|
*/ |
5519
|
458912
|
100
|
|
|
|
if (how == PERL_MAGIC_taint) |
5520
|
11748
|
|
|
|
|
mg->mg_len |= 1; |
5521
|
42044466
|
|
|
|
|
return; |
5522
|
|
|
|
|
|
} |
5523
|
|
|
|
|
|
} |
5524
|
|
|
|
|
|
|
5525
|
|
|
|
|
|
/* Force pos to be stored as characters, not bytes. */ |
5526
|
41585554
|
100
|
|
|
|
if (SvMAGICAL(sv) && DO_UTF8(sv) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
5527
|
30
|
50
|
|
|
|
&& (mg = mg_find(sv, PERL_MAGIC_regex_global)) |
5528
|
0
|
0
|
|
|
|
&& mg->mg_len != -1 |
5529
|
0
|
0
|
|
|
|
&& mg->mg_flags & MGf_BYTES) { |
5530
|
0
|
|
|
|
|
mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len, |
5531
|
|
|
|
|
|
SV_CONST_RETURN); |
5532
|
0
|
|
|
|
|
mg->mg_flags &= ~MGf_BYTES; |
5533
|
|
|
|
|
|
} |
5534
|
|
|
|
|
|
|
5535
|
|
|
|
|
|
/* Rest of work is done else where */ |
5536
|
41585554
|
|
|
|
|
mg = sv_magicext(sv,obj,how,vtable,name,namlen); |
5537
|
|
|
|
|
|
|
5538
|
41585554
|
|
|
|
|
switch (how) { |
5539
|
|
|
|
|
|
case PERL_MAGIC_taint: |
5540
|
111660
|
|
|
|
|
mg->mg_len = 1; |
5541
|
111660
|
|
|
|
|
break; |
5542
|
|
|
|
|
|
case PERL_MAGIC_ext: |
5543
|
|
|
|
|
|
case PERL_MAGIC_dbfile: |
5544
|
7342
|
|
|
|
|
SvRMAGICAL_on(sv); |
5545
|
7342
|
|
|
|
|
break; |
5546
|
|
|
|
|
|
} |
5547
|
|
|
|
|
|
} |
5548
|
|
|
|
|
|
|
5549
|
|
|
|
|
|
static int |
5550
|
71755084
|
|
|
|
|
S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags) |
5551
|
|
|
|
|
|
{ |
5552
|
|
|
|
|
|
MAGIC* mg; |
5553
|
|
|
|
|
|
MAGIC** mgp; |
5554
|
|
|
|
|
|
|
5555
|
|
|
|
|
|
assert(flags <= 1); |
5556
|
|
|
|
|
|
|
5557
|
71755084
|
100
|
|
|
|
if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) |
|
|
100
|
|
|
|
|
5558
|
|
|
|
|
|
return 0; |
5559
|
42431063
|
|
|
|
|
mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); |
5560
|
85749056
|
100
|
|
|
|
for (mg = *mgp; mg; mg = *mgp) { |
5561
|
43317993
|
|
|
|
|
const MGVTBL* const virt = mg->mg_virtual; |
5562
|
43317993
|
100
|
|
|
|
if (mg->mg_type == type && (!flags || virt == vtbl)) { |
|
|
100
|
|
|
|
|
5563
|
4871794
|
|
|
|
|
*mgp = mg->mg_moremagic; |
5564
|
4871794
|
100
|
|
|
|
if (virt && virt->svt_free) |
|
|
100
|
|
|
|
|
5565
|
1914540
|
|
|
|
|
virt->svt_free(aTHX_ sv, mg); |
5566
|
4871794
|
100
|
|
|
|
if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { |
|
|
50
|
|
|
|
|
5567
|
3290388
|
100
|
|
|
|
if (mg->mg_len > 0) |
5568
|
364754
|
|
|
|
|
Safefree(mg->mg_ptr); |
5569
|
2925634
|
100
|
|
|
|
else if (mg->mg_len == HEf_SVKEY) |
5570
|
2925626
|
|
|
|
|
SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); |
5571
|
8
|
50
|
|
|
|
else if (mg->mg_type == PERL_MAGIC_utf8) |
5572
|
0
|
|
|
|
|
Safefree(mg->mg_ptr); |
5573
|
|
|
|
|
|
} |
5574
|
4871794
|
100
|
|
|
|
if (mg->mg_flags & MGf_REFCOUNTED) |
5575
|
32796
|
|
|
|
|
SvREFCNT_dec(mg->mg_obj); |
5576
|
4871794
|
|
|
|
|
Safefree(mg); |
5577
|
|
|
|
|
|
} |
5578
|
|
|
|
|
|
else |
5579
|
38446199
|
|
|
|
|
mgp = &mg->mg_moremagic; |
5580
|
|
|
|
|
|
} |
5581
|
42431063
|
100
|
|
|
|
if (SvMAGIC(sv)) { |
5582
|
37599393
|
50
|
|
|
|
if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ |
5583
|
37599393
|
|
|
|
|
mg_magical(sv); /* else fix the flags now */ |
5584
|
|
|
|
|
|
} |
5585
|
|
|
|
|
|
else { |
5586
|
4831670
|
|
|
|
|
SvMAGICAL_off(sv); |
5587
|
38445099
|
|
|
|
|
SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; |
5588
|
|
|
|
|
|
} |
5589
|
|
|
|
|
|
return 0; |
5590
|
|
|
|
|
|
} |
5591
|
|
|
|
|
|
|
5592
|
|
|
|
|
|
/* |
5593
|
|
|
|
|
|
=for apidoc sv_unmagic |
5594
|
|
|
|
|
|
|
5595
|
|
|
|
|
|
Removes all magic of type C from an SV. |
5596
|
|
|
|
|
|
|
5597
|
|
|
|
|
|
=cut |
5598
|
|
|
|
|
|
*/ |
5599
|
|
|
|
|
|
|
5600
|
|
|
|
|
|
int |
5601
|
71755080
|
|
|
|
|
Perl_sv_unmagic(pTHX_ SV *const sv, const int type) |
5602
|
|
|
|
|
|
{ |
5603
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UNMAGIC; |
5604
|
71755080
|
|
|
|
|
return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0); |
5605
|
|
|
|
|
|
} |
5606
|
|
|
|
|
|
|
5607
|
|
|
|
|
|
/* |
5608
|
|
|
|
|
|
=for apidoc sv_unmagicext |
5609
|
|
|
|
|
|
|
5610
|
|
|
|
|
|
Removes all magic of type C with the specified C from an SV. |
5611
|
|
|
|
|
|
|
5612
|
|
|
|
|
|
=cut |
5613
|
|
|
|
|
|
*/ |
5614
|
|
|
|
|
|
|
5615
|
|
|
|
|
|
int |
5616
|
4
|
|
|
|
|
Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) |
5617
|
|
|
|
|
|
{ |
5618
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UNMAGICEXT; |
5619
|
4
|
|
|
|
|
return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1); |
5620
|
|
|
|
|
|
} |
5621
|
|
|
|
|
|
|
5622
|
|
|
|
|
|
/* |
5623
|
|
|
|
|
|
=for apidoc sv_rvweaken |
5624
|
|
|
|
|
|
|
5625
|
|
|
|
|
|
Weaken a reference: set the C flag on this RV; give the |
5626
|
|
|
|
|
|
referred-to SV C magic if it hasn't already; and |
5627
|
|
|
|
|
|
push a back-reference to this RV onto the array of backreferences |
5628
|
|
|
|
|
|
associated with that magic. If the RV is magical, set magic will be |
5629
|
|
|
|
|
|
called after the RV is cleared. |
5630
|
|
|
|
|
|
|
5631
|
|
|
|
|
|
=cut |
5632
|
|
|
|
|
|
*/ |
5633
|
|
|
|
|
|
|
5634
|
|
|
|
|
|
SV * |
5635
|
69932
|
|
|
|
|
Perl_sv_rvweaken(pTHX_ SV *const sv) |
5636
|
|
|
|
|
|
{ |
5637
|
|
|
|
|
|
SV *tsv; |
5638
|
|
|
|
|
|
|
5639
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_RVWEAKEN; |
5640
|
|
|
|
|
|
|
5641
|
69932
|
50
|
|
|
|
if (!SvOK(sv)) /* let undefs pass */ |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
5642
|
|
|
|
|
|
return sv; |
5643
|
69932
|
50
|
|
|
|
if (!SvROK(sv)) |
5644
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't weaken a nonreference"); |
5645
|
69932
|
50
|
|
|
|
else if (SvWEAKREF(sv)) { |
5646
|
0
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); |
5647
|
0
|
|
|
|
|
return sv; |
5648
|
|
|
|
|
|
} |
5649
|
69932
|
100
|
|
|
|
else if (SvREADONLY(sv)) croak_no_modify(); |
5650
|
69930
|
|
|
|
|
tsv = SvRV(sv); |
5651
|
69930
|
|
|
|
|
Perl_sv_add_backref(aTHX_ tsv, sv); |
5652
|
69930
|
|
|
|
|
SvWEAKREF_on(sv); |
5653
|
69930
|
|
|
|
|
SvREFCNT_dec_NN(tsv); |
5654
|
69930
|
|
|
|
|
return sv; |
5655
|
|
|
|
|
|
} |
5656
|
|
|
|
|
|
|
5657
|
|
|
|
|
|
/* Give tsv backref magic if it hasn't already got it, then push a |
5658
|
|
|
|
|
|
* back-reference to sv onto the array associated with the backref magic. |
5659
|
|
|
|
|
|
* |
5660
|
|
|
|
|
|
* As an optimisation, if there's only one backref and it's not an AV, |
5661
|
|
|
|
|
|
* store it directly in the HvAUX or mg_obj slot, avoiding the need to |
5662
|
|
|
|
|
|
* allocate an AV. (Whether the slot holds an AV tells us whether this is |
5663
|
|
|
|
|
|
* active.) |
5664
|
|
|
|
|
|
*/ |
5665
|
|
|
|
|
|
|
5666
|
|
|
|
|
|
/* A discussion about the backreferences array and its refcount: |
5667
|
|
|
|
|
|
* |
5668
|
|
|
|
|
|
* The AV holding the backreferences is pointed to either as the mg_obj of |
5669
|
|
|
|
|
|
* PERL_MAGIC_backref, or in the specific case of a HV, from the |
5670
|
|
|
|
|
|
* xhv_backreferences field. The array is created with a refcount |
5671
|
|
|
|
|
|
* of 2. This means that if during global destruction the array gets |
5672
|
|
|
|
|
|
* picked on before its parent to have its refcount decremented by the |
5673
|
|
|
|
|
|
* random zapper, it won't actually be freed, meaning it's still there for |
5674
|
|
|
|
|
|
* when its parent gets freed. |
5675
|
|
|
|
|
|
* |
5676
|
|
|
|
|
|
* When the parent SV is freed, the extra ref is killed by |
5677
|
|
|
|
|
|
* Perl_sv_kill_backrefs. The other ref is killed, in the case of magic, |
5678
|
|
|
|
|
|
* by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs. |
5679
|
|
|
|
|
|
* |
5680
|
|
|
|
|
|
* When a single backref SV is stored directly, it is not reference |
5681
|
|
|
|
|
|
* counted. |
5682
|
|
|
|
|
|
*/ |
5683
|
|
|
|
|
|
|
5684
|
|
|
|
|
|
void |
5685
|
107122203
|
|
|
|
|
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) |
5686
|
|
|
|
|
|
{ |
5687
|
|
|
|
|
|
dVAR; |
5688
|
|
|
|
|
|
SV **svp; |
5689
|
|
|
|
|
|
AV *av = NULL; |
5690
|
|
|
|
|
|
MAGIC *mg = NULL; |
5691
|
|
|
|
|
|
|
5692
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_ADD_BACKREF; |
5693
|
|
|
|
|
|
|
5694
|
|
|
|
|
|
/* find slot to store array or singleton backref */ |
5695
|
|
|
|
|
|
|
5696
|
107122203
|
100
|
|
|
|
if (SvTYPE(tsv) == SVt_PVHV) { |
5697
|
85119467
|
|
|
|
|
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); |
5698
|
|
|
|
|
|
} else { |
5699
|
22002736
|
100
|
|
|
|
if (! ((mg = |
5700
|
22002736
|
100
|
|
|
|
(SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL)))) |
5701
|
|
|
|
|
|
{ |
5702
|
17488666
|
|
|
|
|
sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0); |
5703
|
17488666
|
|
|
|
|
mg = mg_find(tsv, PERL_MAGIC_backref); |
5704
|
|
|
|
|
|
} |
5705
|
22002736
|
|
|
|
|
svp = &(mg->mg_obj); |
5706
|
|
|
|
|
|
} |
5707
|
|
|
|
|
|
|
5708
|
|
|
|
|
|
/* create or retrieve the array */ |
5709
|
|
|
|
|
|
|
5710
|
107122203
|
100
|
|
|
|
if ( (!*svp && SvTYPE(sv) == SVt_PVAV) |
|
|
50
|
|
|
|
|
5711
|
107122203
|
100
|
|
|
|
|| (*svp && SvTYPE(*svp) != SVt_PVAV) |
|
|
100
|
|
|
|
|
5712
|
|
|
|
|
|
) { |
5713
|
|
|
|
|
|
/* create array */ |
5714
|
1406124
|
|
|
|
|
av = newAV(); |
5715
|
1406124
|
|
|
|
|
AvREAL_off(av); |
5716
|
1406124
|
50
|
|
|
|
SvREFCNT_inc_simple_void(av); |
5717
|
|
|
|
|
|
/* av now has a refcnt of 2; see discussion above */ |
5718
|
1406124
|
50
|
|
|
|
if (*svp) { |
5719
|
|
|
|
|
|
/* move single existing backref to the array */ |
5720
|
1406124
|
|
|
|
|
av_extend(av, 1); |
5721
|
1406124
|
|
|
|
|
AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ |
5722
|
|
|
|
|
|
} |
5723
|
1406124
|
|
|
|
|
*svp = (SV*)av; |
5724
|
1406124
|
100
|
|
|
|
if (mg) |
5725
|
91292
|
|
|
|
|
mg->mg_flags |= MGf_REFCOUNTED; |
5726
|
|
|
|
|
|
} |
5727
|
|
|
|
|
|
else |
5728
|
105716079
|
|
|
|
|
av = MUTABLE_AV(*svp); |
5729
|
|
|
|
|
|
|
5730
|
107122203
|
100
|
|
|
|
if (!av) { |
5731
|
|
|
|
|
|
/* optimisation: store single backref directly in HvAUX or mg_obj */ |
5732
|
20882494
|
|
|
|
|
*svp = sv; |
5733
|
117259114
|
|
|
|
|
return; |
5734
|
|
|
|
|
|
} |
5735
|
|
|
|
|
|
/* push new backref */ |
5736
|
|
|
|
|
|
assert(SvTYPE(av) == SVt_PVAV); |
5737
|
86239709
|
100
|
|
|
|
if (AvFILLp(av) >= AvMAX(av)) { |
5738
|
6912012
|
|
|
|
|
av_extend(av, AvFILLp(av)+1); |
5739
|
|
|
|
|
|
} |
5740
|
86239709
|
|
|
|
|
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */ |
5741
|
|
|
|
|
|
} |
5742
|
|
|
|
|
|
|
5743
|
|
|
|
|
|
/* delete a back-reference to ourselves from the backref magic associated |
5744
|
|
|
|
|
|
* with the SV we point to. |
5745
|
|
|
|
|
|
*/ |
5746
|
|
|
|
|
|
|
5747
|
|
|
|
|
|
void |
5748
|
44350633
|
|
|
|
|
Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) |
5749
|
|
|
|
|
|
{ |
5750
|
|
|
|
|
|
dVAR; |
5751
|
|
|
|
|
|
SV **svp = NULL; |
5752
|
|
|
|
|
|
|
5753
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DEL_BACKREF; |
5754
|
|
|
|
|
|
|
5755
|
44350633
|
100
|
|
|
|
if (SvTYPE(tsv) == SVt_PVHV) { |
5756
|
42039604
|
50
|
|
|
|
if (SvOOK(tsv)) |
5757
|
42039604
|
|
|
|
|
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); |
5758
|
|
|
|
|
|
} |
5759
|
2311029
|
50
|
|
|
|
else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) { |
|
|
0
|
|
|
|
|
5760
|
|
|
|
|
|
/* It's possible for the the last (strong) reference to tsv to have |
5761
|
|
|
|
|
|
become freed *before* the last thing holding a weak reference. |
5762
|
|
|
|
|
|
If both survive longer than the backreferences array, then when |
5763
|
|
|
|
|
|
the referent's reference count drops to 0 and it is freed, it's |
5764
|
|
|
|
|
|
not able to chase the backreferences, so they aren't NULLed. |
5765
|
|
|
|
|
|
|
5766
|
|
|
|
|
|
For example, a CV holds a weak reference to its stash. If both the |
5767
|
|
|
|
|
|
CV and the stash survive longer than the backreferences array, |
5768
|
|
|
|
|
|
and the CV gets picked for the SvBREAK() treatment first, |
5769
|
|
|
|
|
|
*and* it turns out that the stash is only being kept alive because |
5770
|
|
|
|
|
|
of an our variable in the pad of the CV, then midway during CV |
5771
|
|
|
|
|
|
destruction the stash gets freed, but CvSTASH() isn't set to NULL. |
5772
|
|
|
|
|
|
It ends up pointing to the freed HV. Hence it's chased in here, and |
5773
|
|
|
|
|
|
if this block wasn't here, it would hit the !svp panic just below. |
5774
|
|
|
|
|
|
|
5775
|
|
|
|
|
|
I don't believe that "better" destruction ordering is going to help |
5776
|
|
|
|
|
|
here - during global destruction there's always going to be the |
5777
|
|
|
|
|
|
chance that something goes out of order. We've tried to make it |
5778
|
|
|
|
|
|
foolproof before, and it only resulted in evolutionary pressure on |
5779
|
|
|
|
|
|
fools. Which made us look foolish for our hubris. :-( |
5780
|
|
|
|
|
|
*/ |
5781
|
|
|
|
|
|
return; |
5782
|
|
|
|
|
|
} |
5783
|
|
|
|
|
|
else { |
5784
|
|
|
|
|
|
MAGIC *const mg |
5785
|
2311029
|
100
|
|
|
|
= SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; |
5786
|
2311029
|
100
|
|
|
|
svp = mg ? &(mg->mg_obj) : NULL; |
5787
|
|
|
|
|
|
} |
5788
|
|
|
|
|
|
|
5789
|
44350633
|
100
|
|
|
|
if (!svp) |
5790
|
2
|
|
|
|
|
Perl_croak(aTHX_ "panic: del_backref, svp=0"); |
5791
|
44350631
|
50
|
|
|
|
if (!*svp) { |
5792
|
|
|
|
|
|
/* It's possible that sv is being freed recursively part way through the |
5793
|
|
|
|
|
|
freeing of tsv. If this happens, the backreferences array of tsv has |
5794
|
|
|
|
|
|
already been freed, and so svp will be NULL. If this is the case, |
5795
|
|
|
|
|
|
we should not panic. Instead, nothing needs doing, so return. */ |
5796
|
0
|
0
|
|
|
|
if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) |
|
|
0
|
|
|
|
|
5797
|
|
|
|
|
|
return; |
5798
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, |
5799
|
0
|
|
|
|
|
*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); |
5800
|
|
|
|
|
|
} |
5801
|
|
|
|
|
|
|
5802
|
44350631
|
100
|
|
|
|
if (SvTYPE(*svp) == SVt_PVAV) { |
5803
|
|
|
|
|
|
#ifdef DEBUGGING |
5804
|
|
|
|
|
|
int count = 1; |
5805
|
|
|
|
|
|
#endif |
5806
|
42002502
|
|
|
|
|
AV * const av = (AV*)*svp; |
5807
|
|
|
|
|
|
SSize_t fill; |
5808
|
|
|
|
|
|
assert(!SvIS_FREED(av)); |
5809
|
42002502
|
|
|
|
|
fill = AvFILLp(av); |
5810
|
|
|
|
|
|
assert(fill > -1); |
5811
|
42002502
|
|
|
|
|
svp = AvARRAY(av); |
5812
|
|
|
|
|
|
/* for an SV with N weak references to it, if all those |
5813
|
|
|
|
|
|
* weak refs are deleted, then sv_del_backref will be called |
5814
|
|
|
|
|
|
* N times and O(N^2) compares will be done within the backref |
5815
|
|
|
|
|
|
* array. To ameliorate this potential slowness, we: |
5816
|
|
|
|
|
|
* 1) make sure this code is as tight as possible; |
5817
|
|
|
|
|
|
* 2) when looking for SV, look for it at both the head and tail of the |
5818
|
|
|
|
|
|
* array first before searching the rest, since some create/destroy |
5819
|
|
|
|
|
|
* patterns will cause the backrefs to be freed in order. |
5820
|
|
|
|
|
|
*/ |
5821
|
42002502
|
100
|
|
|
|
if (*svp == sv) { |
5822
|
108922
|
|
|
|
|
AvARRAY(av)++; |
5823
|
108922
|
|
|
|
|
AvMAX(av)--; |
5824
|
|
|
|
|
|
} |
5825
|
|
|
|
|
|
else { |
5826
|
41893580
|
|
|
|
|
SV **p = &svp[fill]; |
5827
|
41893580
|
|
|
|
|
SV *const topsv = *p; |
5828
|
41893580
|
100
|
|
|
|
if (topsv != sv) { |
5829
|
|
|
|
|
|
#ifdef DEBUGGING |
5830
|
|
|
|
|
|
count = 0; |
5831
|
|
|
|
|
|
#endif |
5832
|
88427380
|
50
|
|
|
|
while (--p > svp) { |
5833
|
88427380
|
100
|
|
|
|
if (*p == sv) { |
5834
|
|
|
|
|
|
/* We weren't the last entry. |
5835
|
|
|
|
|
|
An unordered list has this property that you |
5836
|
|
|
|
|
|
can take the last element off the end to fill |
5837
|
|
|
|
|
|
the hole, and it's still an unordered list :-) |
5838
|
|
|
|
|
|
*/ |
5839
|
981156
|
|
|
|
|
*p = topsv; |
5840
|
|
|
|
|
|
#ifdef DEBUGGING |
5841
|
|
|
|
|
|
count++; |
5842
|
|
|
|
|
|
#else |
5843
|
1487212
|
|
|
|
|
break; /* should only be one */ |
5844
|
|
|
|
|
|
#endif |
5845
|
|
|
|
|
|
} |
5846
|
|
|
|
|
|
} |
5847
|
|
|
|
|
|
} |
5848
|
|
|
|
|
|
} |
5849
|
|
|
|
|
|
assert(count ==1); |
5850
|
42002502
|
|
|
|
|
AvFILLp(av) = fill-1; |
5851
|
|
|
|
|
|
} |
5852
|
2348129
|
50
|
|
|
|
else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) { |
|
|
0
|
|
|
|
|
5853
|
|
|
|
|
|
/* freed AV; skip */ |
5854
|
|
|
|
|
|
} |
5855
|
|
|
|
|
|
else { |
5856
|
|
|
|
|
|
/* optimisation: only a single backref, stored directly */ |
5857
|
2348129
|
50
|
|
|
|
if (*svp != sv) |
5858
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv); |
5859
|
23518380
|
|
|
|
|
*svp = NULL; |
5860
|
|
|
|
|
|
} |
5861
|
|
|
|
|
|
|
5862
|
|
|
|
|
|
} |
5863
|
|
|
|
|
|
|
5864
|
|
|
|
|
|
void |
5865
|
1551076
|
|
|
|
|
Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) |
5866
|
|
|
|
|
|
{ |
5867
|
|
|
|
|
|
SV **svp; |
5868
|
|
|
|
|
|
SV **last; |
5869
|
|
|
|
|
|
bool is_array; |
5870
|
|
|
|
|
|
|
5871
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_KILL_BACKREFS; |
5872
|
|
|
|
|
|
|
5873
|
1551076
|
100
|
|
|
|
if (!av) |
5874
|
|
|
|
|
|
return; |
5875
|
|
|
|
|
|
|
5876
|
|
|
|
|
|
/* after multiple passes through Perl_sv_clean_all() for a thingy |
5877
|
|
|
|
|
|
* that has badly leaked, the backref array may have gotten freed, |
5878
|
|
|
|
|
|
* since we only protect it against 1 round of cleanup */ |
5879
|
1526670
|
50
|
|
|
|
if (SvIS_FREED(av)) { |
5880
|
0
|
0
|
|
|
|
if (PL_in_clean_all) /* All is fair */ |
5881
|
|
|
|
|
|
return; |
5882
|
0
|
|
|
|
|
Perl_croak(aTHX_ |
5883
|
|
|
|
|
|
"panic: magic_killbackrefs (freed backref AV/SV)"); |
5884
|
|
|
|
|
|
} |
5885
|
|
|
|
|
|
|
5886
|
|
|
|
|
|
|
5887
|
1526670
|
|
|
|
|
is_array = (SvTYPE(av) == SVt_PVAV); |
5888
|
1526670
|
100
|
|
|
|
if (is_array) { |
5889
|
|
|
|
|
|
assert(!SvIS_FREED(av)); |
5890
|
518
|
|
|
|
|
svp = AvARRAY(av); |
5891
|
518
|
50
|
|
|
|
if (svp) |
5892
|
518
|
|
|
|
|
last = svp + AvFILLp(av); |
5893
|
|
|
|
|
|
} |
5894
|
|
|
|
|
|
else { |
5895
|
|
|
|
|
|
/* optimisation: only a single backref, stored directly */ |
5896
|
|
|
|
|
|
svp = (SV**)&av; |
5897
|
|
|
|
|
|
last = svp; |
5898
|
|
|
|
|
|
} |
5899
|
|
|
|
|
|
|
5900
|
1526670
|
50
|
|
|
|
if (svp) { |
5901
|
3058746
|
100
|
|
|
|
while (svp <= last) { |
5902
|
1532076
|
50
|
|
|
|
if (*svp) { |
5903
|
1532076
|
|
|
|
|
SV *const referrer = *svp; |
5904
|
1532076
|
100
|
|
|
|
if (SvWEAKREF(referrer)) { |
5905
|
|
|
|
|
|
/* XXX Should we check that it hasn't changed? */ |
5906
|
|
|
|
|
|
assert(SvROK(referrer)); |
5907
|
45454
|
|
|
|
|
SvRV_set(referrer, 0); |
5908
|
45454
|
50
|
|
|
|
SvOK_off(referrer); |
5909
|
45454
|
|
|
|
|
SvWEAKREF_off(referrer); |
5910
|
45454
|
100
|
|
|
|
SvSETMAGIC(referrer); |
5911
|
1486622
|
100
|
|
|
|
} else if (SvTYPE(referrer) == SVt_PVGV || |
5912
|
|
|
|
|
|
SvTYPE(referrer) == SVt_PVLV) { |
5913
|
|
|
|
|
|
assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */ |
5914
|
|
|
|
|
|
/* You lookin' at me? */ |
5915
|
|
|
|
|
|
assert(GvSTASH(referrer)); |
5916
|
|
|
|
|
|
assert(GvSTASH(referrer) == (const HV *)sv); |
5917
|
4834
|
|
|
|
|
GvSTASH(referrer) = 0; |
5918
|
1481788
|
50
|
|
|
|
} else if (SvTYPE(referrer) == SVt_PVCV || |
5919
|
|
|
|
|
|
SvTYPE(referrer) == SVt_PVFM) { |
5920
|
1481788
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */ |
5921
|
|
|
|
|
|
/* You lookin' at me? */ |
5922
|
|
|
|
|
|
assert(CvSTASH(referrer)); |
5923
|
|
|
|
|
|
assert(CvSTASH(referrer) == (const HV *)sv); |
5924
|
1074
|
|
|
|
|
SvANY(MUTABLE_CV(referrer))->xcv_stash = 0; |
5925
|
|
|
|
|
|
} |
5926
|
|
|
|
|
|
else { |
5927
|
|
|
|
|
|
assert(SvTYPE(sv) == SVt_PVGV); |
5928
|
|
|
|
|
|
/* You lookin' at me? */ |
5929
|
|
|
|
|
|
assert(CvGV(referrer)); |
5930
|
|
|
|
|
|
assert(CvGV(referrer) == (const GV *)sv); |
5931
|
1480714
|
|
|
|
|
anonymise_cv_maybe(MUTABLE_GV(sv), |
5932
|
|
|
|
|
|
MUTABLE_CV(referrer)); |
5933
|
|
|
|
|
|
} |
5934
|
|
|
|
|
|
|
5935
|
|
|
|
|
|
} else { |
5936
|
0
|
|
|
|
|
Perl_croak(aTHX_ |
5937
|
|
|
|
|
|
"panic: magic_killbackrefs (flags=%"UVxf")", |
5938
|
0
|
|
|
|
|
(UV)SvFLAGS(referrer)); |
5939
|
|
|
|
|
|
} |
5940
|
|
|
|
|
|
|
5941
|
1532076
|
100
|
|
|
|
if (is_array) |
5942
|
5924
|
|
|
|
|
*svp = NULL; |
5943
|
|
|
|
|
|
} |
5944
|
1532076
|
|
|
|
|
svp++; |
5945
|
|
|
|
|
|
} |
5946
|
|
|
|
|
|
} |
5947
|
1526670
|
100
|
|
|
|
if (is_array) { |
5948
|
518
|
|
|
|
|
AvFILLp(av) = -1; |
5949
|
811616
|
|
|
|
|
SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ |
5950
|
|
|
|
|
|
} |
5951
|
|
|
|
|
|
return; |
5952
|
|
|
|
|
|
} |
5953
|
|
|
|
|
|
|
5954
|
|
|
|
|
|
/* |
5955
|
|
|
|
|
|
=for apidoc sv_insert |
5956
|
|
|
|
|
|
|
5957
|
|
|
|
|
|
Inserts a string at the specified offset/length within the SV. Similar to |
5958
|
|
|
|
|
|
the Perl substr() function. Handles get magic. |
5959
|
|
|
|
|
|
|
5960
|
|
|
|
|
|
=for apidoc sv_insert_flags |
5961
|
|
|
|
|
|
|
5962
|
|
|
|
|
|
Same as C, but the extra C are passed to the |
5963
|
|
|
|
|
|
C that applies to C. |
5964
|
|
|
|
|
|
|
5965
|
|
|
|
|
|
=cut |
5966
|
|
|
|
|
|
*/ |
5967
|
|
|
|
|
|
|
5968
|
|
|
|
|
|
void |
5969
|
3014032
|
|
|
|
|
Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) |
5970
|
|
|
|
|
|
{ |
5971
|
|
|
|
|
|
dVAR; |
5972
|
|
|
|
|
|
char *big; |
5973
|
|
|
|
|
|
char *mid; |
5974
|
|
|
|
|
|
char *midend; |
5975
|
|
|
|
|
|
char *bigend; |
5976
|
|
|
|
|
|
SSize_t i; /* better be sizeof(STRLEN) or bad things happen */ |
5977
|
|
|
|
|
|
STRLEN curlen; |
5978
|
|
|
|
|
|
|
5979
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_INSERT_FLAGS; |
5980
|
|
|
|
|
|
|
5981
|
3014032
|
50
|
|
|
|
if (!bigstr) |
5982
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Can't modify nonexistent substring"); |
5983
|
3014032
|
100
|
|
|
|
SvPV_force_flags(bigstr, curlen, flags); |
5984
|
3014032
|
|
|
|
|
(void)SvPOK_only_UTF8(bigstr); |
5985
|
3014032
|
50
|
|
|
|
if (offset + len > curlen) { |
5986
|
0
|
0
|
|
|
|
SvGROW(bigstr, offset+len+1); |
|
|
0
|
|
|
|
|
5987
|
0
|
|
|
|
|
Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); |
5988
|
0
|
|
|
|
|
SvCUR_set(bigstr, offset+len); |
5989
|
|
|
|
|
|
} |
5990
|
|
|
|
|
|
|
5991
|
3014032
|
100
|
|
|
|
SvTAINT(bigstr); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
5992
|
3014032
|
|
|
|
|
i = littlelen - len; |
5993
|
3014032
|
100
|
|
|
|
if (i > 0) { /* string might grow */ |
5994
|
1927566
|
50
|
|
|
|
big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); |
|
|
100
|
|
|
|
|
5995
|
1927566
|
|
|
|
|
mid = big + offset + len; |
5996
|
1927566
|
|
|
|
|
midend = bigend = big + SvCUR(bigstr); |
5997
|
1927566
|
|
|
|
|
bigend += i; |
5998
|
1927566
|
|
|
|
|
*bigend = '\0'; |
5999
|
50493219
|
100
|
|
|
|
while (midend > mid) /* shove everything down */ |
6000
|
47602230
|
|
|
|
|
*--bigend = *--midend; |
6001
|
1927566
|
|
|
|
|
Move(little,big+offset,littlelen,char); |
6002
|
1927566
|
|
|
|
|
SvCUR_set(bigstr, SvCUR(bigstr) + i); |
6003
|
1927566
|
100
|
|
|
|
SvSETMAGIC(bigstr); |
6004
|
|
|
|
|
|
return; |
6005
|
|
|
|
|
|
} |
6006
|
1086466
|
100
|
|
|
|
else if (i == 0) { |
6007
|
64320
|
|
|
|
|
Move(little,SvPVX(bigstr)+offset,len,char); |
6008
|
64320
|
100
|
|
|
|
SvSETMAGIC(bigstr); |
6009
|
|
|
|
|
|
return; |
6010
|
|
|
|
|
|
} |
6011
|
|
|
|
|
|
|
6012
|
1022146
|
|
|
|
|
big = SvPVX(bigstr); |
6013
|
1022146
|
|
|
|
|
mid = big + offset; |
6014
|
1022146
|
|
|
|
|
midend = mid + len; |
6015
|
1022146
|
|
|
|
|
bigend = big + SvCUR(bigstr); |
6016
|
|
|
|
|
|
|
6017
|
1022146
|
50
|
|
|
|
if (midend > bigend) |
6018
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", |
6019
|
|
|
|
|
|
midend, bigend); |
6020
|
|
|
|
|
|
|
6021
|
1022146
|
100
|
|
|
|
if (mid - big > bigend - midend) { /* faster to shorten from end */ |
6022
|
16960
|
100
|
|
|
|
if (littlelen) { |
6023
|
|
|
|
|
|
Move(little, mid, littlelen,char); |
6024
|
1450
|
|
|
|
|
mid += littlelen; |
6025
|
|
|
|
|
|
} |
6026
|
16960
|
|
|
|
|
i = bigend - midend; |
6027
|
16960
|
100
|
|
|
|
if (i > 0) { |
6028
|
1862
|
|
|
|
|
Move(midend, mid, i,char); |
6029
|
1862
|
|
|
|
|
mid += i; |
6030
|
|
|
|
|
|
} |
6031
|
16960
|
|
|
|
|
*mid = '\0'; |
6032
|
16960
|
|
|
|
|
SvCUR_set(bigstr, mid - big); |
6033
|
|
|
|
|
|
} |
6034
|
1005186
|
100
|
|
|
|
else if ((i = mid - big)) { /* faster from front */ |
6035
|
2890
|
|
|
|
|
midend -= littlelen; |
6036
|
|
|
|
|
|
mid = midend; |
6037
|
2890
|
|
|
|
|
Move(big, midend - i, i, char); |
6038
|
2890
|
|
|
|
|
sv_chop(bigstr,midend-i); |
6039
|
2890
|
100
|
|
|
|
if (littlelen) |
6040
|
|
|
|
|
|
Move(little, mid, littlelen,char); |
6041
|
|
|
|
|
|
} |
6042
|
1002296
|
100
|
|
|
|
else if (littlelen) { |
6043
|
894
|
|
|
|
|
midend -= littlelen; |
6044
|
894
|
|
|
|
|
sv_chop(bigstr,midend); |
6045
|
|
|
|
|
|
Move(little,midend,littlelen,char); |
6046
|
|
|
|
|
|
} |
6047
|
|
|
|
|
|
else { |
6048
|
1001402
|
|
|
|
|
sv_chop(bigstr,midend); |
6049
|
|
|
|
|
|
} |
6050
|
2018449
|
100
|
|
|
|
SvSETMAGIC(bigstr); |
6051
|
|
|
|
|
|
} |
6052
|
|
|
|
|
|
|
6053
|
|
|
|
|
|
/* |
6054
|
|
|
|
|
|
=for apidoc sv_replace |
6055
|
|
|
|
|
|
|
6056
|
|
|
|
|
|
Make the first argument a copy of the second, then delete the original. |
6057
|
|
|
|
|
|
The target SV physically takes over ownership of the body of the source SV |
6058
|
|
|
|
|
|
and inherits its flags; however, the target keeps any magic it owns, |
6059
|
|
|
|
|
|
and any magic in the source is discarded. |
6060
|
|
|
|
|
|
Note that this is a rather specialist SV copying operation; most of the |
6061
|
|
|
|
|
|
time you'll want to use C or one of its many macro front-ends. |
6062
|
|
|
|
|
|
|
6063
|
|
|
|
|
|
=cut |
6064
|
|
|
|
|
|
*/ |
6065
|
|
|
|
|
|
|
6066
|
|
|
|
|
|
void |
6067
|
15204556
|
|
|
|
|
Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) |
6068
|
|
|
|
|
|
{ |
6069
|
|
|
|
|
|
dVAR; |
6070
|
15204556
|
|
|
|
|
const U32 refcnt = SvREFCNT(sv); |
6071
|
|
|
|
|
|
|
6072
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_REPLACE; |
6073
|
|
|
|
|
|
|
6074
|
15204556
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
6075
|
15204556
|
50
|
|
|
|
if (SvREFCNT(nsv) != 1) { |
6076
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" |
6077
|
0
|
|
|
|
|
" (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); |
6078
|
|
|
|
|
|
} |
6079
|
15204556
|
50
|
|
|
|
if (SvMAGICAL(sv)) { |
6080
|
0
|
0
|
|
|
|
if (SvMAGICAL(nsv)) |
6081
|
0
|
|
|
|
|
mg_free(nsv); |
6082
|
|
|
|
|
|
else |
6083
|
0
|
|
|
|
|
sv_upgrade(nsv, SVt_PVMG); |
6084
|
0
|
|
|
|
|
SvMAGIC_set(nsv, SvMAGIC(sv)); |
6085
|
0
|
|
|
|
|
SvFLAGS(nsv) |= SvMAGICAL(sv); |
6086
|
0
|
|
|
|
|
SvMAGICAL_off(sv); |
6087
|
0
|
|
|
|
|
SvMAGIC_set(sv, NULL); |
6088
|
|
|
|
|
|
} |
6089
|
15204556
|
|
|
|
|
SvREFCNT(sv) = 0; |
6090
|
15204556
|
|
|
|
|
sv_clear(sv); |
6091
|
|
|
|
|
|
assert(!SvREFCNT(sv)); |
6092
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS |
6093
|
|
|
|
|
|
sv->sv_flags = nsv->sv_flags; |
6094
|
|
|
|
|
|
sv->sv_any = nsv->sv_any; |
6095
|
|
|
|
|
|
sv->sv_refcnt = nsv->sv_refcnt; |
6096
|
|
|
|
|
|
sv->sv_u = nsv->sv_u; |
6097
|
|
|
|
|
|
#else |
6098
|
15204556
|
|
|
|
|
StructCopy(nsv,sv,SV); |
6099
|
|
|
|
|
|
#endif |
6100
|
15204556
|
50
|
|
|
|
if(SvTYPE(sv) == SVt_IV) { |
6101
|
|
|
|
|
|
SvANY(sv) |
6102
|
0
|
|
|
|
|
= (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); |
6103
|
|
|
|
|
|
} |
6104
|
|
|
|
|
|
|
6105
|
|
|
|
|
|
|
6106
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
6107
|
|
|
|
|
|
if (SvIsCOW_normal(nsv)) { |
6108
|
|
|
|
|
|
/* We need to follow the pointers around the loop to make the |
6109
|
|
|
|
|
|
previous SV point to sv, rather than nsv. */ |
6110
|
|
|
|
|
|
SV *next; |
6111
|
|
|
|
|
|
SV *current = nsv; |
6112
|
|
|
|
|
|
while ((next = SV_COW_NEXT_SV(current)) != nsv) { |
6113
|
|
|
|
|
|
assert(next); |
6114
|
|
|
|
|
|
current = next; |
6115
|
|
|
|
|
|
assert(SvPVX_const(current) == SvPVX_const(nsv)); |
6116
|
|
|
|
|
|
} |
6117
|
|
|
|
|
|
/* Make the SV before us point to the SV after us. */ |
6118
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
6119
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "previous is\n"); |
6120
|
|
|
|
|
|
sv_dump(current); |
6121
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, |
6122
|
|
|
|
|
|
"move it from 0x%"UVxf" to 0x%"UVxf"\n", |
6123
|
|
|
|
|
|
(UV) SV_COW_NEXT_SV(current), (UV) sv); |
6124
|
|
|
|
|
|
} |
6125
|
|
|
|
|
|
SV_COW_NEXT_SV_SET(current, sv); |
6126
|
|
|
|
|
|
} |
6127
|
|
|
|
|
|
#endif |
6128
|
15204556
|
|
|
|
|
SvREFCNT(sv) = refcnt; |
6129
|
15204556
|
|
|
|
|
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */ |
6130
|
15204556
|
|
|
|
|
SvREFCNT(nsv) = 0; |
6131
|
15204556
|
50
|
|
|
|
del_SV(nsv); |
6132
|
15204556
|
|
|
|
|
} |
6133
|
|
|
|
|
|
|
6134
|
|
|
|
|
|
/* We're about to free a GV which has a CV that refers back to us. |
6135
|
|
|
|
|
|
* If that CV will outlive us, make it anonymous (i.e. fix up its CvGV |
6136
|
|
|
|
|
|
* field) */ |
6137
|
|
|
|
|
|
|
6138
|
|
|
|
|
|
STATIC void |
6139
|
1480714
|
|
|
|
|
S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) |
6140
|
|
|
|
|
|
{ |
6141
|
|
|
|
|
|
SV *gvname; |
6142
|
|
|
|
|
|
GV *anongv; |
6143
|
|
|
|
|
|
|
6144
|
|
|
|
|
|
PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE; |
6145
|
|
|
|
|
|
|
6146
|
|
|
|
|
|
/* be assertive! */ |
6147
|
|
|
|
|
|
assert(SvREFCNT(gv) == 0); |
6148
|
|
|
|
|
|
assert(isGV(gv) && isGV_with_GP(gv)); |
6149
|
|
|
|
|
|
assert(GvGP(gv)); |
6150
|
|
|
|
|
|
assert(!CvANON(cv)); |
6151
|
|
|
|
|
|
assert(CvGV(cv) == gv); |
6152
|
|
|
|
|
|
assert(!CvNAMED(cv)); |
6153
|
|
|
|
|
|
|
6154
|
|
|
|
|
|
/* will the CV shortly be freed by gp_free() ? */ |
6155
|
1480714
|
100
|
|
|
|
if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6156
|
1480442
|
|
|
|
|
SvANY(cv)->xcv_gv_u.xcv_gv = NULL; |
6157
|
2185116
|
|
|
|
|
return; |
6158
|
|
|
|
|
|
} |
6159
|
|
|
|
|
|
|
6160
|
|
|
|
|
|
/* if not, anonymise: */ |
6161
|
480
|
50
|
|
|
|
gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv))) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
6162
|
208
|
50
|
|
|
|
? newSVhek(HvENAME_HEK(GvSTASH(gv))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6163
|
709
|
100
|
|
|
|
: newSVpvn_flags( "__ANON__", 8, 0 ); |
|
|
100
|
|
|
|
|
6164
|
272
|
|
|
|
|
sv_catpvs(gvname, "::__ANON__"); |
6165
|
272
|
|
|
|
|
anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); |
6166
|
272
|
|
|
|
|
SvREFCNT_dec_NN(gvname); |
6167
|
|
|
|
|
|
|
6168
|
272
|
|
|
|
|
CvANON_on(cv); |
6169
|
272
|
|
|
|
|
CvCVGV_RC_on(cv); |
6170
|
408
|
|
|
|
|
SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv)); |
6171
|
|
|
|
|
|
} |
6172
|
|
|
|
|
|
|
6173
|
|
|
|
|
|
|
6174
|
|
|
|
|
|
/* |
6175
|
|
|
|
|
|
=for apidoc sv_clear |
6176
|
|
|
|
|
|
|
6177
|
|
|
|
|
|
Clear an SV: call any destructors, free up any memory used by the body, |
6178
|
|
|
|
|
|
and free the body itself. The SV's head is I freed, although |
6179
|
|
|
|
|
|
its type is set to all 1's so that it won't inadvertently be assumed |
6180
|
|
|
|
|
|
to be live during global destruction etc. |
6181
|
|
|
|
|
|
This function should only be called when REFCNT is zero. Most of the time |
6182
|
|
|
|
|
|
you'll want to call C (or its macro wrapper C) |
6183
|
|
|
|
|
|
instead. |
6184
|
|
|
|
|
|
|
6185
|
|
|
|
|
|
=cut |
6186
|
|
|
|
|
|
*/ |
6187
|
|
|
|
|
|
|
6188
|
|
|
|
|
|
void |
6189
|
2362998773
|
|
|
|
|
Perl_sv_clear(pTHX_ SV *const orig_sv) |
6190
|
|
|
|
|
|
{ |
6191
|
|
|
|
|
|
dVAR; |
6192
|
|
|
|
|
|
HV *stash; |
6193
|
|
|
|
|
|
U32 type; |
6194
|
|
|
|
|
|
const struct body_details *sv_type_details; |
6195
|
|
|
|
|
|
SV* iter_sv = NULL; |
6196
|
|
|
|
|
|
SV* next_sv = NULL; |
6197
|
|
|
|
|
|
SV *sv = orig_sv; |
6198
|
|
|
|
|
|
STRLEN hash_index; |
6199
|
|
|
|
|
|
|
6200
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CLEAR; |
6201
|
|
|
|
|
|
|
6202
|
|
|
|
|
|
/* within this loop, sv is the SV currently being freed, and |
6203
|
|
|
|
|
|
* iter_sv is the most recent AV or whatever that's being iterated |
6204
|
|
|
|
|
|
* over to provide more SVs */ |
6205
|
|
|
|
|
|
|
6206
|
7395423869
|
100
|
|
|
|
while (sv) { |
6207
|
|
|
|
|
|
|
6208
|
3856485731
|
|
|
|
|
type = SvTYPE(sv); |
6209
|
|
|
|
|
|
|
6210
|
|
|
|
|
|
assert(SvREFCNT(sv) == 0); |
6211
|
|
|
|
|
|
assert(SvTYPE(sv) != (svtype)SVTYPEMASK); |
6212
|
|
|
|
|
|
|
6213
|
3856485731
|
100
|
|
|
|
if (type <= SVt_IV) { |
6214
|
|
|
|
|
|
/* See the comment in sv.h about the collusion between this |
6215
|
|
|
|
|
|
* early return and the overloading of the NULL slots in the |
6216
|
|
|
|
|
|
* size table. */ |
6217
|
1819468336
|
100
|
|
|
|
if (SvROK(sv)) |
6218
|
|
|
|
|
|
goto free_rv; |
6219
|
950989246
|
|
|
|
|
SvFLAGS(sv) &= SVf_BREAK; |
6220
|
950989246
|
|
|
|
|
SvFLAGS(sv) |= SVTYPEMASK; |
6221
|
950989246
|
|
|
|
|
goto free_head; |
6222
|
|
|
|
|
|
} |
6223
|
|
|
|
|
|
|
6224
|
|
|
|
|
|
assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */ |
6225
|
|
|
|
|
|
|
6226
|
2037017395
|
100
|
|
|
|
if (type >= SVt_PVMG) { |
6227
|
852788996
|
100
|
|
|
|
if (SvOBJECT(sv)) { |
6228
|
484513073
|
100
|
|
|
|
if (!curse(sv, 1)) goto get_next_sv; |
6229
|
484513063
|
|
|
|
|
type = SvTYPE(sv); /* destructor may have changed it */ |
6230
|
|
|
|
|
|
} |
6231
|
|
|
|
|
|
/* Free back-references before magic, in case the magic calls |
6232
|
|
|
|
|
|
* Perl code that has weak references to sv. */ |
6233
|
852788986
|
100
|
|
|
|
if (type == SVt_PVHV) { |
6234
|
109270814
|
|
|
|
|
Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); |
6235
|
109270814
|
100
|
|
|
|
if (SvMAGIC(sv)) |
6236
|
1416582
|
|
|
|
|
mg_free(sv); |
6237
|
|
|
|
|
|
} |
6238
|
743518172
|
100
|
|
|
|
else if (type == SVt_PVMG && SvPAD_OUR(sv)) { |
|
|
100
|
|
|
|
|
6239
|
44289
|
50
|
|
|
|
SvREFCNT_dec(SvOURSTASH(sv)); |
6240
|
|
|
|
|
|
} |
6241
|
743473883
|
100
|
|
|
|
else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) { |
|
|
100
|
|
|
|
|
6242
|
|
|
|
|
|
assert(!SvMAGICAL(sv)); |
6243
|
739122315
|
100
|
|
|
|
} else if (SvMAGIC(sv)) { |
6244
|
|
|
|
|
|
/* Free back-references before other types of magic. */ |
6245
|
37118062
|
|
|
|
|
sv_unmagic(sv, PERL_MAGIC_backref); |
6246
|
37118062
|
|
|
|
|
mg_free(sv); |
6247
|
|
|
|
|
|
} |
6248
|
852788986
|
|
|
|
|
SvMAGICAL_off(sv); |
6249
|
852788986
|
100
|
|
|
|
if (type == SVt_PVMG && SvPAD_TYPED(sv)) |
|
|
100
|
|
|
|
|
6250
|
44
|
|
|
|
|
SvREFCNT_dec(SvSTASH(sv)); |
6251
|
|
|
|
|
|
} |
6252
|
2037017385
|
|
|
|
|
switch (type) { |
6253
|
|
|
|
|
|
/* case SVt_INVLIST: */ |
6254
|
|
|
|
|
|
case SVt_PVIO: |
6255
|
5918376
|
|
|
|
|
if (IoIFP(sv) && |
6256
|
1618330
|
100
|
|
|
|
IoIFP(sv) != PerlIO_stdin() && |
6257
|
1569932
|
100
|
|
|
|
IoIFP(sv) != PerlIO_stdout() && |
6258
|
1521492
|
100
|
|
|
|
IoIFP(sv) != PerlIO_stderr() && |
6259
|
748637
|
|
|
|
|
!(IoFLAGS(sv) & IOf_FAKE_DIRP)) |
6260
|
|
|
|
|
|
{ |
6261
|
740551
|
|
|
|
|
io_close(MUTABLE_IO(sv), FALSE); |
6262
|
|
|
|
|
|
} |
6263
|
5097121
|
100
|
|
|
|
if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) |
|
|
100
|
|
|
|
|
6264
|
4522
|
|
|
|
|
PerlDir_close(IoDIRP(sv)); |
6265
|
5097121
|
|
|
|
|
IoDIRP(sv) = (DIR*)NULL; |
6266
|
5097121
|
|
|
|
|
Safefree(IoTOP_NAME(sv)); |
6267
|
5097121
|
|
|
|
|
Safefree(IoFMT_NAME(sv)); |
6268
|
5097121
|
|
|
|
|
Safefree(IoBOTTOM_NAME(sv)); |
6269
|
5097121
|
100
|
|
|
|
if ((const GV *)sv == PL_statgv) |
6270
|
2
|
|
|
|
|
PL_statgv = NULL; |
6271
|
|
|
|
|
|
goto freescalar; |
6272
|
|
|
|
|
|
case SVt_REGEXP: |
6273
|
|
|
|
|
|
/* FIXME for plugins */ |
6274
|
|
|
|
|
|
freeregexp: |
6275
|
20183530
|
|
|
|
|
pregfree2((REGEXP*) sv); |
6276
|
20183530
|
|
|
|
|
goto freescalar; |
6277
|
|
|
|
|
|
case SVt_PVCV: |
6278
|
|
|
|
|
|
case SVt_PVFM: |
6279
|
8896490
|
|
|
|
|
cv_undef(MUTABLE_CV(sv)); |
6280
|
|
|
|
|
|
/* If we're in a stash, we don't own a reference to it. |
6281
|
|
|
|
|
|
* However it does have a back reference to us, which needs to |
6282
|
|
|
|
|
|
* be cleared. */ |
6283
|
8896488
|
100
|
|
|
|
if ((stash = CvSTASH(sv))) |
6284
|
6718933
|
|
|
|
|
sv_del_backref(MUTABLE_SV(stash), sv); |
6285
|
|
|
|
|
|
goto freescalar; |
6286
|
|
|
|
|
|
case SVt_PVHV: |
6287
|
109270814
|
100
|
|
|
|
if (PL_last_swash_hv == (const HV *)sv) { |
6288
|
7784
|
|
|
|
|
PL_last_swash_hv = NULL; |
6289
|
|
|
|
|
|
} |
6290
|
109270814
|
100
|
|
|
|
if (HvTOTALKEYS((HV*)sv) > 0) { |
6291
|
|
|
|
|
|
const char *name; |
6292
|
|
|
|
|
|
/* this statement should match the one at the beginning of |
6293
|
|
|
|
|
|
* hv_undef_flags() */ |
6294
|
101741269
|
100
|
|
|
|
if ( PL_phase != PERL_PHASE_DESTRUCT |
6295
|
85653313
|
100
|
|
|
|
&& (name = HvNAME((HV*)sv))) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6296
|
|
|
|
|
|
{ |
6297
|
536
|
50
|
|
|
|
if (PL_stashcache) { |
6298
|
|
|
|
|
|
DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n", |
6299
|
|
|
|
|
|
sv)); |
6300
|
536
|
50
|
|
|
|
(void)hv_delete(PL_stashcache, name, |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
6301
|
|
|
|
|
|
HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD); |
6302
|
|
|
|
|
|
} |
6303
|
536
|
|
|
|
|
hv_name_set((HV*)sv, NULL, 0, 0); |
6304
|
|
|
|
|
|
} |
6305
|
|
|
|
|
|
|
6306
|
|
|
|
|
|
/* save old iter_sv in unused SvSTASH field */ |
6307
|
|
|
|
|
|
assert(!SvOBJECT(sv)); |
6308
|
101741269
|
|
|
|
|
SvSTASH(sv) = (HV*)iter_sv; |
6309
|
|
|
|
|
|
iter_sv = sv; |
6310
|
|
|
|
|
|
|
6311
|
|
|
|
|
|
/* save old hash_index in unused SvMAGIC field */ |
6312
|
|
|
|
|
|
assert(!SvMAGICAL(sv)); |
6313
|
|
|
|
|
|
assert(!SvMAGIC(sv)); |
6314
|
101741269
|
|
|
|
|
((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; |
6315
|
101741269
|
|
|
|
|
hash_index = 0; |
6316
|
|
|
|
|
|
|
6317
|
101741269
|
|
|
|
|
next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); |
6318
|
101741269
|
|
|
|
|
goto get_next_sv; /* process this new sv */ |
6319
|
|
|
|
|
|
} |
6320
|
|
|
|
|
|
/* free empty hash */ |
6321
|
7529545
|
|
|
|
|
Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); |
6322
|
|
|
|
|
|
assert(!HvARRAY((HV*)sv)); |
6323
|
7529545
|
|
|
|
|
break; |
6324
|
|
|
|
|
|
case SVt_PVAV: |
6325
|
|
|
|
|
|
{ |
6326
|
|
|
|
|
|
AV* av = MUTABLE_AV(sv); |
6327
|
136032616
|
50
|
|
|
|
if (PL_comppad == av) { |
6328
|
0
|
|
|
|
|
PL_comppad = NULL; |
6329
|
0
|
|
|
|
|
PL_curpad = NULL; |
6330
|
|
|
|
|
|
} |
6331
|
136032616
|
100
|
|
|
|
if (AvREAL(av) && AvFILLp(av) > -1) { |
|
|
100
|
|
|
|
|
6332
|
113088646
|
|
|
|
|
next_sv = AvARRAY(av)[AvFILLp(av)--]; |
6333
|
|
|
|
|
|
/* save old iter_sv in top-most slot of AV, |
6334
|
|
|
|
|
|
* and pray that it doesn't get wiped in the meantime */ |
6335
|
113088646
|
|
|
|
|
AvARRAY(av)[AvMAX(av)] = iter_sv; |
6336
|
|
|
|
|
|
iter_sv = sv; |
6337
|
113088646
|
|
|
|
|
goto get_next_sv; /* process this new sv */ |
6338
|
|
|
|
|
|
} |
6339
|
22943970
|
|
|
|
|
Safefree(AvALLOC(av)); |
6340
|
|
|
|
|
|
} |
6341
|
|
|
|
|
|
|
6342
|
22943970
|
|
|
|
|
break; |
6343
|
|
|
|
|
|
case SVt_PVLV: |
6344
|
5747671
|
100
|
|
|
|
if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ |
6345
|
387591
|
|
|
|
|
SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); |
6346
|
387591
|
|
|
|
|
HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; |
6347
|
387591
|
|
|
|
|
PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); |
6348
|
|
|
|
|
|
} |
6349
|
5360080
|
100
|
|
|
|
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ |
6350
|
5288302
|
|
|
|
|
SvREFCNT_dec(LvTARG(sv)); |
6351
|
5747671
|
50
|
|
|
|
if (isREGEXP(sv)) goto freeregexp; |
|
|
50
|
|
|
|
|
6352
|
|
|
|
|
|
case SVt_PVGV: |
6353
|
14186468
|
100
|
|
|
|
if (isGV_with_GP(sv)) { |
|
|
50
|
|
|
|
|
6354
|
8438819
|
100
|
|
|
|
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6355
|
1729838
|
50
|
|
|
|
&& HvENAME_get(stash)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
6356
|
1729830
|
|
|
|
|
mro_method_changed_in(stash); |
6357
|
8438819
|
|
|
|
|
gp_free(MUTABLE_GV(sv)); |
6358
|
8438817
|
50
|
|
|
|
if (GvNAME_HEK(sv)) |
6359
|
8438817
|
|
|
|
|
unshare_hek(GvNAME_HEK(sv)); |
6360
|
|
|
|
|
|
/* If we're in a stash, we don't own a reference to it. |
6361
|
|
|
|
|
|
* However it does have a back reference to us, which |
6362
|
|
|
|
|
|
* needs to be cleared. */ |
6363
|
8438817
|
50
|
|
|
|
if (!SvVALID(sv) && (stash = GvSTASH(sv))) |
|
|
100
|
|
|
|
|
6364
|
8235843
|
|
|
|
|
sv_del_backref(MUTABLE_SV(stash), sv); |
6365
|
|
|
|
|
|
} |
6366
|
|
|
|
|
|
/* FIXME. There are probably more unreferenced pointers to SVs |
6367
|
|
|
|
|
|
* in the interpreter struct that we should check and tidy in |
6368
|
|
|
|
|
|
* a similar fashion to this: */ |
6369
|
|
|
|
|
|
/* See also S_sv_unglob, which does the same thing. */ |
6370
|
14186466
|
100
|
|
|
|
if ((const GV *)sv == PL_last_in_gv) |
6371
|
221790
|
|
|
|
|
PL_last_in_gv = NULL; |
6372
|
13964676
|
100
|
|
|
|
else if ((const GV *)sv == PL_statgv) |
6373
|
3170
|
|
|
|
|
PL_statgv = NULL; |
6374
|
13961506
|
100
|
|
|
|
else if ((const GV *)sv == PL_stderrgv) |
6375
|
4
|
|
|
|
|
PL_stderrgv = NULL; |
6376
|
|
|
|
|
|
case SVt_PVMG: |
6377
|
|
|
|
|
|
case SVt_PVNV: |
6378
|
|
|
|
|
|
case SVt_PVIV: |
6379
|
|
|
|
|
|
case SVt_INVLIST: |
6380
|
|
|
|
|
|
case SVt_PV: |
6381
|
|
|
|
|
|
freescalar: |
6382
|
|
|
|
|
|
/* Don't bother with SvOOK_off(sv); as we're only going to |
6383
|
|
|
|
|
|
* free it. */ |
6384
|
1786215039
|
100
|
|
|
|
if (SvOOK(sv)) { |
6385
|
|
|
|
|
|
STRLEN offset; |
6386
|
36594
|
50
|
|
|
|
SvOOK_offset(sv, offset); |
|
|
100
|
|
|
|
|
6387
|
36594
|
|
|
|
|
SvPV_set(sv, SvPVX_mutable(sv) - offset); |
6388
|
|
|
|
|
|
/* Don't even bother with turning off the OOK flag. */ |
6389
|
|
|
|
|
|
} |
6390
|
1786215039
|
100
|
|
|
|
if (SvROK(sv)) { |
6391
|
|
|
|
|
|
free_rv: |
6392
|
|
|
|
|
|
{ |
6393
|
874163145
|
|
|
|
|
SV * const target = SvRV(sv); |
6394
|
874163145
|
100
|
|
|
|
if (SvWEAKREF(sv)) |
6395
|
24406
|
|
|
|
|
sv_del_backref(target, sv); |
6396
|
|
|
|
|
|
else |
6397
|
|
|
|
|
|
next_sv = target; |
6398
|
|
|
|
|
|
} |
6399
|
|
|
|
|
|
} |
6400
|
|
|
|
|
|
#ifdef PERL_ANY_COW |
6401
|
1780530984
|
100
|
|
|
|
else if (SvPVX_const(sv) |
6402
|
1089249623
|
100
|
|
|
|
&& !(SvTYPE(sv) == SVt_PVIO |
|
|
100
|
|
|
|
|
6403
|
80702
|
|
|
|
|
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))) |
6404
|
|
|
|
|
|
{ |
6405
|
1089137196
|
100
|
|
|
|
if (SvIsCOW(sv)) { |
6406
|
|
|
|
|
|
if (DEBUG_C_TEST) { |
6407
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); |
6408
|
|
|
|
|
|
sv_dump(sv); |
6409
|
|
|
|
|
|
} |
6410
|
455177718
|
100
|
|
|
|
if (SvLEN(sv)) { |
6411
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
6412
|
|
|
|
|
|
sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv)); |
6413
|
|
|
|
|
|
# else |
6414
|
322020175
|
100
|
|
|
|
if (CowREFCNT(sv)) { |
6415
|
143231133
|
|
|
|
|
CowREFCNT(sv)--; |
6416
|
143231133
|
|
|
|
|
SvLEN_set(sv, 0); |
6417
|
|
|
|
|
|
} |
6418
|
|
|
|
|
|
# endif |
6419
|
|
|
|
|
|
} else { |
6420
|
133157543
|
|
|
|
|
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); |
6421
|
|
|
|
|
|
} |
6422
|
|
|
|
|
|
|
6423
|
|
|
|
|
|
} |
6424
|
|
|
|
|
|
# ifdef PERL_OLD_COPY_ON_WRITE |
6425
|
|
|
|
|
|
else |
6426
|
|
|
|
|
|
# endif |
6427
|
1089137196
|
100
|
|
|
|
if (SvLEN(sv)) { |
6428
|
808903330
|
|
|
|
|
Safefree(SvPVX_mutable(sv)); |
6429
|
|
|
|
|
|
} |
6430
|
|
|
|
|
|
} |
6431
|
|
|
|
|
|
#else |
6432
|
|
|
|
|
|
else if (SvPVX_const(sv) && SvLEN(sv) |
6433
|
|
|
|
|
|
&& !(SvTYPE(sv) == SVt_PVIO |
6434
|
|
|
|
|
|
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP))) |
6435
|
|
|
|
|
|
Safefree(SvPVX_mutable(sv)); |
6436
|
|
|
|
|
|
else if (SvPVX_const(sv) && SvIsCOW(sv)) { |
6437
|
|
|
|
|
|
unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); |
6438
|
|
|
|
|
|
} |
6439
|
|
|
|
|
|
#endif |
6440
|
|
|
|
|
|
break; |
6441
|
|
|
|
|
|
case SVt_NV: |
6442
|
|
|
|
|
|
break; |
6443
|
|
|
|
|
|
} |
6444
|
|
|
|
|
|
|
6445
|
|
|
|
|
|
free_body: |
6446
|
|
|
|
|
|
|
6447
|
2905496469
|
|
|
|
|
SvFLAGS(sv) &= SVf_BREAK; |
6448
|
2905496469
|
|
|
|
|
SvFLAGS(sv) |= SVTYPEMASK; |
6449
|
|
|
|
|
|
|
6450
|
2905496469
|
|
|
|
|
sv_type_details = bodies_by_type + type; |
6451
|
2905496469
|
100
|
|
|
|
if (sv_type_details->arena) { |
6452
|
2037016995
|
|
|
|
|
del_body(((char *)SvANY(sv) + sv_type_details->offset), |
6453
|
|
|
|
|
|
&PL_body_roots[type]); |
6454
|
|
|
|
|
|
} |
6455
|
868479474
|
100
|
|
|
|
else if (sv_type_details->body_size) { |
6456
|
384
|
|
|
|
|
safefree(SvANY(sv)); |
6457
|
|
|
|
|
|
} |
6458
|
|
|
|
|
|
|
6459
|
|
|
|
|
|
free_head: |
6460
|
|
|
|
|
|
/* caller is responsible for freeing the head of the original sv */ |
6461
|
3856485715
|
100
|
|
|
|
if (sv != orig_sv && !SvREFCNT(sv)) |
|
|
50
|
|
|
|
|
6462
|
2950995198
|
50
|
|
|
|
del_SV(sv); |
6463
|
|
|
|
|
|
|
6464
|
|
|
|
|
|
/* grab and free next sv, if any */ |
6465
|
|
|
|
|
|
get_next_sv: |
6466
|
|
|
|
|
|
while (1) { |
6467
|
|
|
|
|
|
sv = NULL; |
6468
|
4396425635
|
100
|
|
|
|
if (next_sv) { |
6469
|
|
|
|
|
|
sv = next_sv; |
6470
|
|
|
|
|
|
next_sv = NULL; |
6471
|
|
|
|
|
|
} |
6472
|
3308939968
|
100
|
|
|
|
else if (!iter_sv) { |
6473
|
|
|
|
|
|
break; |
6474
|
945941205
|
100
|
|
|
|
} else if (SvTYPE(iter_sv) == SVt_PVAV) { |
6475
|
|
|
|
|
|
AV *const av = (AV*)iter_sv; |
6476
|
537779305
|
100
|
|
|
|
if (AvFILLp(av) > -1) { |
6477
|
424690659
|
|
|
|
|
sv = AvARRAY(av)[AvFILLp(av)--]; |
6478
|
|
|
|
|
|
} |
6479
|
|
|
|
|
|
else { /* no more elements of current AV to free */ |
6480
|
|
|
|
|
|
sv = iter_sv; |
6481
|
113088646
|
|
|
|
|
type = SvTYPE(sv); |
6482
|
|
|
|
|
|
/* restore previous value, squirrelled away */ |
6483
|
113088646
|
|
|
|
|
iter_sv = AvARRAY(av)[AvMAX(av)]; |
6484
|
113088646
|
|
|
|
|
Safefree(AvALLOC(av)); |
6485
|
113088646
|
|
|
|
|
goto free_body; |
6486
|
|
|
|
|
|
} |
6487
|
408161900
|
50
|
|
|
|
} else if (SvTYPE(iter_sv) == SVt_PVHV) { |
6488
|
408161900
|
|
|
|
|
sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); |
6489
|
408161900
|
100
|
|
|
|
if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { |
|
|
100
|
|
|
|
|
6490
|
|
|
|
|
|
/* no more elements of current HV to free */ |
6491
|
|
|
|
|
|
sv = iter_sv; |
6492
|
101741269
|
|
|
|
|
type = SvTYPE(sv); |
6493
|
|
|
|
|
|
/* Restore previous values of iter_sv and hash_index, |
6494
|
|
|
|
|
|
* squirrelled away */ |
6495
|
|
|
|
|
|
assert(!SvOBJECT(sv)); |
6496
|
101741269
|
|
|
|
|
iter_sv = (SV*)SvSTASH(sv); |
6497
|
|
|
|
|
|
assert(!SvMAGICAL(sv)); |
6498
|
101741269
|
|
|
|
|
hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; |
6499
|
|
|
|
|
|
#ifdef DEBUGGING |
6500
|
|
|
|
|
|
/* perl -DA does not like rubbish in SvMAGIC. */ |
6501
|
|
|
|
|
|
SvMAGIC_set(sv, 0); |
6502
|
|
|
|
|
|
#endif |
6503
|
|
|
|
|
|
|
6504
|
|
|
|
|
|
/* free any remaining detritus from the hash struct */ |
6505
|
101741269
|
|
|
|
|
Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); |
6506
|
|
|
|
|
|
assert(!HvARRAY((HV*)sv)); |
6507
|
101741269
|
|
|
|
|
goto free_body; |
6508
|
|
|
|
|
|
} |
6509
|
|
|
|
|
|
} |
6510
|
|
|
|
|
|
|
6511
|
|
|
|
|
|
/* unrolled SvREFCNT_dec and sv_free2 follows: */ |
6512
|
|
|
|
|
|
|
6513
|
1818596957
|
100
|
|
|
|
if (!sv) |
6514
|
3549521
|
|
|
|
|
continue; |
6515
|
1815047436
|
50
|
|
|
|
if (!SvREFCNT(sv)) { |
6516
|
0
|
|
|
|
|
sv_free(sv); |
6517
|
0
|
|
|
|
|
continue; |
6518
|
|
|
|
|
|
} |
6519
|
1815047436
|
100
|
|
|
|
if (--(SvREFCNT(sv))) |
6520
|
321560478
|
|
|
|
|
continue; |
6521
|
|
|
|
|
|
#ifdef DEBUGGING |
6522
|
|
|
|
|
|
if (SvTEMP(sv)) { |
6523
|
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), |
6524
|
|
|
|
|
|
"Attempt to free temp prematurely: SV 0x%"UVxf |
6525
|
|
|
|
|
|
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); |
6526
|
|
|
|
|
|
continue; |
6527
|
|
|
|
|
|
} |
6528
|
|
|
|
|
|
#endif |
6529
|
1493486958
|
100
|
|
|
|
if (SvIMMORTAL(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
6530
|
|
|
|
|
|
/* make sure SvREFCNT(sv)==0 happens very seldom */ |
6531
|
0
|
|
|
|
|
SvREFCNT(sv) = SvREFCNT_IMMORTAL; |
6532
|
1934262694
|
|
|
|
|
continue; |
6533
|
|
|
|
|
|
} |
6534
|
|
|
|
|
|
break; |
6535
|
|
|
|
|
|
} /* while 1 */ |
6536
|
|
|
|
|
|
|
6537
|
|
|
|
|
|
} /* while sv */ |
6538
|
2362998763
|
|
|
|
|
} |
6539
|
|
|
|
|
|
|
6540
|
|
|
|
|
|
/* This routine curses the sv itself, not the object referenced by sv. So |
6541
|
|
|
|
|
|
sv does not have to be ROK. */ |
6542
|
|
|
|
|
|
|
6543
|
|
|
|
|
|
static bool |
6544
|
484522821
|
|
|
|
|
S_curse(pTHX_ SV * const sv, const bool check_refcnt) { |
6545
|
|
|
|
|
|
dVAR; |
6546
|
|
|
|
|
|
|
6547
|
|
|
|
|
|
PERL_ARGS_ASSERT_CURSE; |
6548
|
|
|
|
|
|
assert(SvOBJECT(sv)); |
6549
|
|
|
|
|
|
|
6550
|
969045642
|
|
|
|
|
if (PL_defstash && /* Still have a symbol table? */ |
6551
|
484522821
|
|
|
|
|
SvDESTROYABLE(sv)) |
6552
|
|
|
|
|
|
{ |
6553
|
484522821
|
|
|
|
|
dSP; |
6554
|
|
|
|
|
|
HV* stash; |
6555
|
|
|
|
|
|
do { |
6556
|
484522823
|
|
|
|
|
stash = SvSTASH(sv); |
6557
|
|
|
|
|
|
assert(SvTYPE(stash) == SVt_PVHV); |
6558
|
484522823
|
50
|
|
|
|
if (HvNAME(stash)) { |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
6559
|
|
|
|
|
|
CV* destructor = NULL; |
6560
|
|
|
|
|
|
assert (SvOOK(stash)); |
6561
|
484522819
|
100
|
|
|
|
if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash); |
6562
|
725781965
|
100
|
|
|
|
if (!destructor || HvMROMETA(stash)->destroy_gen |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
6563
|
482578038
|
|
|
|
|
!= PL_sub_generation) |
6564
|
|
|
|
|
|
{ |
6565
|
4176239
|
|
|
|
|
GV * const gv = |
6566
|
|
|
|
|
|
gv_fetchmeth_autoload(stash, "DESTROY", 7, 0); |
6567
|
4176239
|
100
|
|
|
|
if (gv) destructor = GvCV(gv); |
6568
|
4176239
|
100
|
|
|
|
if (!SvOBJECT(stash)) |
6569
|
|
|
|
|
|
{ |
6570
|
8352474
|
|
|
|
|
SvSTASH(stash) = |
6571
|
4176237
|
100
|
|
|
|
destructor ? (HV *)destructor : ((HV *)0)+1; |
6572
|
4176237
|
|
|
|
|
HvAUX(stash)->xhv_mro_meta->destroy_gen = |
6573
|
|
|
|
|
|
PL_sub_generation; |
6574
|
|
|
|
|
|
} |
6575
|
|
|
|
|
|
} |
6576
|
|
|
|
|
|
assert(!destructor || destructor == ((CV *)0)+1 |
6577
|
|
|
|
|
|
|| SvTYPE(destructor) == SVt_PVCV); |
6578
|
484522819
|
100
|
|
|
|
if (destructor && destructor != ((CV *)0)+1 |
6579
|
|
|
|
|
|
/* A constant subroutine can have no side effects, so |
6580
|
|
|
|
|
|
don't bother calling it. */ |
6581
|
7534121
|
100
|
|
|
|
&& !CvCONST(destructor) |
6582
|
|
|
|
|
|
/* Don't bother calling an empty destructor or one that |
6583
|
|
|
|
|
|
returns immediately. */ |
6584
|
5447115
|
100
|
|
|
|
&& (CvISXSUB(destructor) |
6585
|
4707460
|
100
|
|
|
|
|| (CvSTART(destructor) |
6586
|
7060287
|
100
|
|
|
|
&& (CvSTART(destructor)->op_next->op_type |
6587
|
4707458
|
|
|
|
|
!= OP_LEAVESUB) |
6588
|
1438989
|
100
|
|
|
|
&& (CvSTART(destructor)->op_next->op_type |
6589
|
959326
|
|
|
|
|
!= OP_PUSHMARK |
6590
|
489
|
50
|
|
|
|
|| CvSTART(destructor)->op_next->op_next->op_type |
6591
|
326
|
|
|
|
|
!= OP_RETURN |
6592
|
|
|
|
|
|
) |
6593
|
|
|
|
|
|
)) |
6594
|
|
|
|
|
|
) |
6595
|
1698981
|
50
|
|
|
|
{ |
6596
|
1698981
|
|
|
|
|
SV* const tmpref = newRV(sv); |
6597
|
1698981
|
|
|
|
|
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ |
6598
|
1698981
|
|
|
|
|
ENTER; |
6599
|
1698981
|
100
|
|
|
|
PUSHSTACKi(PERLSI_DESTROY); |
6600
|
849311
|
|
|
|
|
EXTEND(SP, 2); |
6601
|
1698981
|
50
|
|
|
|
PUSHMARK(SP); |
6602
|
1698981
|
|
|
|
|
PUSHs(tmpref); |
6603
|
1698981
|
|
|
|
|
PUTBACK; |
6604
|
1698981
|
|
|
|
|
call_sv(MUTABLE_SV(destructor), |
6605
|
|
|
|
|
|
G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); |
6606
|
1698981
|
50
|
|
|
|
POPSTACK; |
6607
|
1698981
|
|
|
|
|
SPAGAIN; |
6608
|
1698981
|
|
|
|
|
LEAVE; |
6609
|
1698981
|
50
|
|
|
|
if(SvREFCNT(tmpref) < 2) { |
6610
|
|
|
|
|
|
/* tmpref is not kept alive! */ |
6611
|
1698981
|
|
|
|
|
SvREFCNT(sv)--; |
6612
|
1698981
|
|
|
|
|
SvRV_set(tmpref, NULL); |
6613
|
1698981
|
|
|
|
|
SvROK_off(tmpref); |
6614
|
|
|
|
|
|
} |
6615
|
1698981
|
|
|
|
|
SvREFCNT_dec_NN(tmpref); |
6616
|
|
|
|
|
|
} |
6617
|
|
|
|
|
|
} |
6618
|
484522823
|
50
|
|
|
|
} while (SvOBJECT(sv) && SvSTASH(sv) != stash); |
|
|
100
|
|
|
|
|
6619
|
|
|
|
|
|
|
6620
|
|
|
|
|
|
|
6621
|
484522821
|
100
|
|
|
|
if (check_refcnt && SvREFCNT(sv)) { |
|
|
100
|
|
|
|
|
6622
|
10
|
100
|
|
|
|
if (PL_in_clean_objs) |
6623
|
10
|
50
|
|
|
|
Perl_croak(aTHX_ |
|
|
50
|
|
|
|
|
6624
|
|
|
|
|
|
"DESTROY created new reference to dead object '%"HEKf"'", |
6625
|
8
|
50
|
|
|
|
HEKfARG(HvNAME_HEK(stash))); |
6626
|
|
|
|
|
|
/* DESTROY gave object new lease on life */ |
6627
|
|
|
|
|
|
return FALSE; |
6628
|
|
|
|
|
|
} |
6629
|
|
|
|
|
|
} |
6630
|
|
|
|
|
|
|
6631
|
484522811
|
50
|
|
|
|
if (SvOBJECT(sv)) { |
6632
|
484522811
|
|
|
|
|
HV * const stash = SvSTASH(sv); |
6633
|
|
|
|
|
|
/* Curse before freeing the stash, as freeing the stash could cause |
6634
|
|
|
|
|
|
a recursive call into S_curse. */ |
6635
|
484522811
|
|
|
|
|
SvOBJECT_off(sv); /* Curse the object. */ |
6636
|
484522811
|
|
|
|
|
SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ |
6637
|
484522814
|
|
|
|
|
SvREFCNT_dec(stash); /* possibly of changed persuasion */ |
6638
|
|
|
|
|
|
} |
6639
|
|
|
|
|
|
return TRUE; |
6640
|
|
|
|
|
|
} |
6641
|
|
|
|
|
|
|
6642
|
|
|
|
|
|
/* |
6643
|
|
|
|
|
|
=for apidoc sv_newref |
6644
|
|
|
|
|
|
|
6645
|
|
|
|
|
|
Increment an SV's reference count. Use the C wrapper |
6646
|
|
|
|
|
|
instead. |
6647
|
|
|
|
|
|
|
6648
|
|
|
|
|
|
=cut |
6649
|
|
|
|
|
|
*/ |
6650
|
|
|
|
|
|
|
6651
|
|
|
|
|
|
SV * |
6652
|
0
|
|
|
|
|
Perl_sv_newref(pTHX_ SV *const sv) |
6653
|
|
|
|
|
|
{ |
6654
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
6655
|
0
|
0
|
|
|
|
if (sv) |
6656
|
0
|
|
|
|
|
(SvREFCNT(sv))++; |
6657
|
0
|
|
|
|
|
return sv; |
6658
|
|
|
|
|
|
} |
6659
|
|
|
|
|
|
|
6660
|
|
|
|
|
|
/* |
6661
|
|
|
|
|
|
=for apidoc sv_free |
6662
|
|
|
|
|
|
|
6663
|
|
|
|
|
|
Decrement an SV's reference count, and if it drops to zero, call |
6664
|
|
|
|
|
|
C to invoke destructors and free up any memory used by |
6665
|
|
|
|
|
|
the body; finally, deallocate the SV's head itself. |
6666
|
|
|
|
|
|
Normally called via a wrapper macro C. |
6667
|
|
|
|
|
|
|
6668
|
|
|
|
|
|
=cut |
6669
|
|
|
|
|
|
*/ |
6670
|
|
|
|
|
|
|
6671
|
|
|
|
|
|
void |
6672
|
7268240
|
|
|
|
|
Perl_sv_free(pTHX_ SV *const sv) |
6673
|
|
|
|
|
|
{ |
6674
|
7268240
|
|
|
|
|
SvREFCNT_dec(sv); |
6675
|
7268240
|
|
|
|
|
} |
6676
|
|
|
|
|
|
|
6677
|
|
|
|
|
|
|
6678
|
|
|
|
|
|
/* Private helper function for SvREFCNT_dec(). |
6679
|
|
|
|
|
|
* Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */ |
6680
|
|
|
|
|
|
|
6681
|
|
|
|
|
|
void |
6682
|
2346371909
|
|
|
|
|
Perl_sv_free2(pTHX_ SV *const sv, const U32 rc) |
6683
|
|
|
|
|
|
{ |
6684
|
|
|
|
|
|
dVAR; |
6685
|
|
|
|
|
|
|
6686
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_FREE2; |
6687
|
|
|
|
|
|
|
6688
|
2346371909
|
100
|
|
|
|
if (LIKELY( rc == 1 )) { |
6689
|
|
|
|
|
|
/* normal case */ |
6690
|
2346371907
|
|
|
|
|
SvREFCNT(sv) = 0; |
6691
|
|
|
|
|
|
|
6692
|
|
|
|
|
|
#ifdef DEBUGGING |
6693
|
|
|
|
|
|
if (SvTEMP(sv)) { |
6694
|
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), |
6695
|
|
|
|
|
|
"Attempt to free temp prematurely: SV 0x%"UVxf |
6696
|
|
|
|
|
|
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); |
6697
|
|
|
|
|
|
return; |
6698
|
|
|
|
|
|
} |
6699
|
|
|
|
|
|
#endif |
6700
|
2346371907
|
100
|
|
|
|
if (SvIMMORTAL(sv)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
6701
|
|
|
|
|
|
/* make sure SvREFCNT(sv)==0 happens very seldom */ |
6702
|
0
|
|
|
|
|
SvREFCNT(sv) = SvREFCNT_IMMORTAL; |
6703
|
0
|
|
|
|
|
return; |
6704
|
|
|
|
|
|
} |
6705
|
2346371907
|
|
|
|
|
sv_clear(sv); |
6706
|
2346371897
|
100
|
|
|
|
if (! SvREFCNT(sv)) /* may have have been resurrected */ |
6707
|
2346371895
|
50
|
|
|
|
del_SV(sv); |
6708
|
|
|
|
|
|
return; |
6709
|
|
|
|
|
|
} |
6710
|
|
|
|
|
|
|
6711
|
|
|
|
|
|
/* handle exceptional cases */ |
6712
|
|
|
|
|
|
|
6713
|
|
|
|
|
|
assert(rc == 0); |
6714
|
|
|
|
|
|
|
6715
|
2
|
50
|
|
|
|
if (SvFLAGS(sv) & SVf_BREAK) |
6716
|
|
|
|
|
|
/* this SV's refcnt has been artificially decremented to |
6717
|
|
|
|
|
|
* trigger cleanup */ |
6718
|
|
|
|
|
|
return; |
6719
|
2
|
50
|
|
|
|
if (PL_in_clean_all) /* All is fair */ |
6720
|
|
|
|
|
|
return; |
6721
|
2
|
50
|
|
|
|
if (SvIMMORTAL(sv)) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
6722
|
|
|
|
|
|
/* make sure SvREFCNT(sv)==0 happens very seldom */ |
6723
|
0
|
|
|
|
|
SvREFCNT(sv) = SvREFCNT_IMMORTAL; |
6724
|
0
|
|
|
|
|
return; |
6725
|
|
|
|
|
|
} |
6726
|
2
|
50
|
|
|
|
if (ckWARN_d(WARN_INTERNAL)) { |
6727
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP |
6728
|
|
|
|
|
|
Perl_dump_sv_child(aTHX_ sv); |
6729
|
|
|
|
|
|
#else |
6730
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS |
6731
|
|
|
|
|
|
sv_dump(sv); |
6732
|
|
|
|
|
|
#endif |
6733
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_ABORT |
6734
|
|
|
|
|
|
if (PL_warnhook == PERL_WARNHOOK_FATAL |
6735
|
|
|
|
|
|
|| ckDEAD(packWARN(WARN_INTERNAL))) { |
6736
|
|
|
|
|
|
/* Don't let Perl_warner cause us to escape our fate: */ |
6737
|
|
|
|
|
|
abort(); |
6738
|
|
|
|
|
|
} |
6739
|
|
|
|
|
|
#endif |
6740
|
|
|
|
|
|
/* This may not return: */ |
6741
|
1178508754
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), |
6742
|
|
|
|
|
|
"Attempt to free unreferenced scalar: SV 0x%"UVxf |
6743
|
|
|
|
|
|
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); |
6744
|
|
|
|
|
|
#endif |
6745
|
|
|
|
|
|
} |
6746
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_ABORT |
6747
|
|
|
|
|
|
abort(); |
6748
|
|
|
|
|
|
#endif |
6749
|
|
|
|
|
|
|
6750
|
|
|
|
|
|
} |
6751
|
|
|
|
|
|
|
6752
|
|
|
|
|
|
|
6753
|
|
|
|
|
|
/* |
6754
|
|
|
|
|
|
=for apidoc sv_len |
6755
|
|
|
|
|
|
|
6756
|
|
|
|
|
|
Returns the length of the string in the SV. Handles magic and type |
6757
|
|
|
|
|
|
coercion and sets the UTF8 flag appropriately. See also C, which |
6758
|
|
|
|
|
|
gives raw access to the xpv_cur slot. |
6759
|
|
|
|
|
|
|
6760
|
|
|
|
|
|
=cut |
6761
|
|
|
|
|
|
*/ |
6762
|
|
|
|
|
|
|
6763
|
|
|
|
|
|
STRLEN |
6764
|
4926
|
|
|
|
|
Perl_sv_len(pTHX_ SV *const sv) |
6765
|
|
|
|
|
|
{ |
6766
|
|
|
|
|
|
STRLEN len; |
6767
|
|
|
|
|
|
|
6768
|
4926
|
50
|
|
|
|
if (!sv) |
6769
|
|
|
|
|
|
return 0; |
6770
|
|
|
|
|
|
|
6771
|
4926
|
50
|
|
|
|
(void)SvPV_const(sv, len); |
6772
|
4926
|
|
|
|
|
return len; |
6773
|
|
|
|
|
|
} |
6774
|
|
|
|
|
|
|
6775
|
|
|
|
|
|
/* |
6776
|
|
|
|
|
|
=for apidoc sv_len_utf8 |
6777
|
|
|
|
|
|
|
6778
|
|
|
|
|
|
Returns the number of characters in the string in an SV, counting wide |
6779
|
|
|
|
|
|
UTF-8 bytes as a single character. Handles magic and type coercion. |
6780
|
|
|
|
|
|
|
6781
|
|
|
|
|
|
=cut |
6782
|
|
|
|
|
|
*/ |
6783
|
|
|
|
|
|
|
6784
|
|
|
|
|
|
/* |
6785
|
|
|
|
|
|
* The length is cached in PERL_MAGIC_utf8, in the mg_len field. Also the |
6786
|
|
|
|
|
|
* mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below. |
6787
|
|
|
|
|
|
* (Note that the mg_len is not the length of the mg_ptr field. |
6788
|
|
|
|
|
|
* This allows the cache to store the character length of the string without |
6789
|
|
|
|
|
|
* needing to malloc() extra storage to attach to the mg_ptr.) |
6790
|
|
|
|
|
|
* |
6791
|
|
|
|
|
|
*/ |
6792
|
|
|
|
|
|
|
6793
|
|
|
|
|
|
STRLEN |
6794
|
8916366
|
|
|
|
|
Perl_sv_len_utf8(pTHX_ SV *const sv) |
6795
|
8916366
|
50
|
|
|
|
{ |
6796
|
8916366
|
50
|
|
|
|
if (!sv) |
6797
|
|
|
|
|
|
return 0; |
6798
|
|
|
|
|
|
|
6799
|
4458183
|
|
|
|
|
SvGETMAGIC(sv); |
6800
|
8916366
|
|
|
|
|
return sv_len_utf8_nomg(sv); |
6801
|
|
|
|
|
|
} |
6802
|
|
|
|
|
|
|
6803
|
|
|
|
|
|
STRLEN |
6804
|
39188311
|
|
|
|
|
Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) |
6805
|
|
|
|
|
|
{ |
6806
|
|
|
|
|
|
dVAR; |
6807
|
|
|
|
|
|
STRLEN len; |
6808
|
39188311
|
100
|
|
|
|
const U8 *s = (U8*)SvPV_nomg_const(sv, len); |
6809
|
|
|
|
|
|
|
6810
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG; |
6811
|
|
|
|
|
|
|
6812
|
39188311
|
50
|
|
|
|
if (PL_utf8cache && SvUTF8(sv)) { |
|
|
100
|
|
|
|
|
6813
|
|
|
|
|
|
STRLEN ulen; |
6814
|
4080340
|
100
|
|
|
|
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; |
6815
|
|
|
|
|
|
|
6816
|
4080340
|
100
|
|
|
|
if (mg && (mg->mg_len != -1 || mg->mg_ptr)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
6817
|
2641054
|
100
|
|
|
|
if (mg->mg_len != -1) |
6818
|
2641046
|
|
|
|
|
ulen = mg->mg_len; |
6819
|
|
|
|
|
|
else { |
6820
|
|
|
|
|
|
/* We can use the offset cache for a headstart. |
6821
|
|
|
|
|
|
The longer value is stored in the first pair. */ |
6822
|
8
|
|
|
|
|
STRLEN *cache = (STRLEN *) mg->mg_ptr; |
6823
|
|
|
|
|
|
|
6824
|
8
|
|
|
|
|
ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1], |
6825
|
|
|
|
|
|
s + len); |
6826
|
|
|
|
|
|
} |
6827
|
|
|
|
|
|
|
6828
|
2641054
|
50
|
|
|
|
if (PL_utf8cache < 0) { |
6829
|
0
|
|
|
|
|
const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); |
6830
|
0
|
|
|
|
|
assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv); |
6831
|
|
|
|
|
|
} |
6832
|
|
|
|
|
|
} |
6833
|
|
|
|
|
|
else { |
6834
|
1439286
|
|
|
|
|
ulen = Perl_utf8_length(aTHX_ s, s + len); |
6835
|
1439286
|
|
|
|
|
utf8_mg_len_cache_update(sv, &mg, ulen); |
6836
|
|
|
|
|
|
} |
6837
|
4080340
|
|
|
|
|
return ulen; |
6838
|
|
|
|
|
|
} |
6839
|
37148141
|
50
|
|
|
|
return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len; |
6840
|
|
|
|
|
|
} |
6841
|
|
|
|
|
|
|
6842
|
|
|
|
|
|
/* Walk forwards to find the byte corresponding to the passed in UTF-8 |
6843
|
|
|
|
|
|
offset. */ |
6844
|
|
|
|
|
|
static STRLEN |
6845
|
|
|
|
|
|
S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, |
6846
|
|
|
|
|
|
STRLEN *const uoffset_p, bool *const at_end) |
6847
|
|
|
|
|
|
{ |
6848
|
|
|
|
|
|
const U8 *s = start; |
6849
|
|
|
|
|
|
STRLEN uoffset = *uoffset_p; |
6850
|
|
|
|
|
|
|
6851
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS; |
6852
|
|
|
|
|
|
|
6853
|
436
|
100
|
|
|
|
while (s < send && uoffset) { |
|
|
100
|
|
|
|
|
6854
|
340
|
|
|
|
|
--uoffset; |
6855
|
340
|
|
|
|
|
s += UTF8SKIP(s); |
6856
|
|
|
|
|
|
} |
6857
|
96
|
50
|
|
|
|
if (s == send) { |
|
|
100
|
|
|
|
|
6858
|
|
|
|
|
|
*at_end = TRUE; |
6859
|
|
|
|
|
|
} |
6860
|
64
|
50
|
|
|
|
else if (s > send) { |
|
|
50
|
|
|
|
|
6861
|
|
|
|
|
|
*at_end = TRUE; |
6862
|
|
|
|
|
|
/* This is the existing behaviour. Possibly it should be a croak, as |
6863
|
|
|
|
|
|
it's actually a bounds error */ |
6864
|
|
|
|
|
|
s = send; |
6865
|
|
|
|
|
|
} |
6866
|
96
|
|
|
|
|
*uoffset_p -= uoffset; |
6867
|
96
|
|
|
|
|
return s - start; |
6868
|
|
|
|
|
|
} |
6869
|
|
|
|
|
|
|
6870
|
|
|
|
|
|
/* Given the length of the string in both bytes and UTF-8 characters, decide |
6871
|
|
|
|
|
|
whether to walk forwards or backwards to find the byte corresponding to |
6872
|
|
|
|
|
|
the passed in UTF-8 offset. */ |
6873
|
|
|
|
|
|
static STRLEN |
6874
|
150170
|
|
|
|
|
S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, |
6875
|
|
|
|
|
|
STRLEN uoffset, const STRLEN uend) |
6876
|
|
|
|
|
|
{ |
6877
|
150170
|
|
|
|
|
STRLEN backw = uend - uoffset; |
6878
|
|
|
|
|
|
|
6879
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY; |
6880
|
|
|
|
|
|
|
6881
|
150170
|
100
|
|
|
|
if (uoffset < 2 * backw) { |
6882
|
|
|
|
|
|
/* The assumption is that going forwards is twice the speed of going |
6883
|
|
|
|
|
|
forward (that's where the 2 * backw comes from). |
6884
|
|
|
|
|
|
(The real figure of course depends on the UTF-8 data.) */ |
6885
|
|
|
|
|
|
const U8 *s = start; |
6886
|
|
|
|
|
|
|
6887
|
295116
|
50
|
|
|
|
while (s < send && uoffset--) |
|
|
100
|
|
|
|
|
6888
|
151610
|
|
|
|
|
s += UTF8SKIP(s); |
6889
|
|
|
|
|
|
assert (s <= send); |
6890
|
143506
|
50
|
|
|
|
if (s > send) |
6891
|
|
|
|
|
|
s = send; |
6892
|
143506
|
|
|
|
|
return s - start; |
6893
|
|
|
|
|
|
} |
6894
|
|
|
|
|
|
|
6895
|
8738
|
100
|
|
|
|
while (backw--) { |
6896
|
2074
|
|
|
|
|
send--; |
6897
|
8761
|
100
|
|
|
|
while (UTF8_IS_CONTINUATION(*send)) |
6898
|
2318
|
|
|
|
|
send--; |
6899
|
|
|
|
|
|
} |
6900
|
78417
|
|
|
|
|
return send - start; |
6901
|
|
|
|
|
|
} |
6902
|
|
|
|
|
|
|
6903
|
|
|
|
|
|
/* For the string representation of the given scalar, find the byte |
6904
|
|
|
|
|
|
corresponding to the passed in UTF-8 offset. uoffset0 and boffset0 |
6905
|
|
|
|
|
|
give another position in the string, *before* the sought offset, which |
6906
|
|
|
|
|
|
(which is always true, as 0, 0 is a valid pair of positions), which should |
6907
|
|
|
|
|
|
help reduce the amount of linear searching. |
6908
|
|
|
|
|
|
If *mgp is non-NULL, it should point to the UTF-8 cache magic, which |
6909
|
|
|
|
|
|
will be used to reduce the amount of linear searching. The cache will be |
6910
|
|
|
|
|
|
created if necessary, and the found value offered to it for update. */ |
6911
|
|
|
|
|
|
static STRLEN |
6912
|
302274
|
|
|
|
|
S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, |
6913
|
|
|
|
|
|
const U8 *const send, STRLEN uoffset, |
6914
|
|
|
|
|
|
STRLEN uoffset0, STRLEN boffset0) |
6915
|
|
|
|
|
|
{ |
6916
|
|
|
|
|
|
STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ |
6917
|
|
|
|
|
|
bool found = FALSE; |
6918
|
|
|
|
|
|
bool at_end = FALSE; |
6919
|
|
|
|
|
|
|
6920
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_U2B_CACHED; |
6921
|
|
|
|
|
|
|
6922
|
|
|
|
|
|
assert (uoffset >= uoffset0); |
6923
|
|
|
|
|
|
|
6924
|
302274
|
100
|
|
|
|
if (!uoffset) |
6925
|
|
|
|
|
|
return 0; |
6926
|
|
|
|
|
|
|
6927
|
268568
|
100
|
|
|
|
if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv) |
6928
|
268516
|
50
|
|
|
|
&& PL_utf8cache |
6929
|
417762
|
100
|
|
|
|
&& (*mgp || (SvTYPE(sv) >= SVt_PVMG && |
6930
|
149246
|
|
|
|
|
(*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { |
6931
|
268476
|
100
|
|
|
|
if ((*mgp)->mg_ptr) { |
6932
|
237464
|
|
|
|
|
STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; |
6933
|
237464
|
100
|
|
|
|
if (cache[0] == uoffset) { |
6934
|
|
|
|
|
|
/* An exact match. */ |
6935
|
118066
|
|
|
|
|
return cache[1]; |
6936
|
|
|
|
|
|
} |
6937
|
119398
|
100
|
|
|
|
if (cache[2] == uoffset) { |
6938
|
|
|
|
|
|
/* An exact match. */ |
6939
|
236
|
|
|
|
|
return cache[3]; |
6940
|
|
|
|
|
|
} |
6941
|
|
|
|
|
|
|
6942
|
119162
|
100
|
|
|
|
if (cache[0] < uoffset) { |
6943
|
|
|
|
|
|
/* The cache already knows part of the way. */ |
6944
|
119108
|
100
|
|
|
|
if (cache[0] > uoffset0) { |
6945
|
|
|
|
|
|
/* The cache knows more than the passed in pair */ |
6946
|
32
|
|
|
|
|
uoffset0 = cache[0]; |
6947
|
32
|
|
|
|
|
boffset0 = cache[1]; |
6948
|
|
|
|
|
|
} |
6949
|
119108
|
100
|
|
|
|
if ((*mgp)->mg_len != -1) { |
6950
|
|
|
|
|
|
/* And we know the end too. */ |
6951
|
119106
|
|
|
|
|
boffset = boffset0 |
6952
|
119106
|
|
|
|
|
+ sv_pos_u2b_midway(start + boffset0, send, |
6953
|
|
|
|
|
|
uoffset - uoffset0, |
6954
|
119106
|
|
|
|
|
(*mgp)->mg_len - uoffset0); |
6955
|
|
|
|
|
|
} else { |
6956
|
2
|
|
|
|
|
uoffset -= uoffset0; |
6957
|
2
|
|
|
|
|
boffset = boffset0 |
6958
|
2
|
|
|
|
|
+ sv_pos_u2b_forwards(start + boffset0, |
6959
|
|
|
|
|
|
send, &uoffset, &at_end); |
6960
|
2
|
|
|
|
|
uoffset += uoffset0; |
6961
|
|
|
|
|
|
} |
6962
|
|
|
|
|
|
} |
6963
|
54
|
100
|
|
|
|
else if (cache[2] < uoffset) { |
6964
|
|
|
|
|
|
/* We're between the two cache entries. */ |
6965
|
44
|
100
|
|
|
|
if (cache[2] > uoffset0) { |
6966
|
|
|
|
|
|
/* and the cache knows more than the passed in pair */ |
6967
|
18
|
|
|
|
|
uoffset0 = cache[2]; |
6968
|
18
|
|
|
|
|
boffset0 = cache[3]; |
6969
|
|
|
|
|
|
} |
6970
|
|
|
|
|
|
|
6971
|
44
|
|
|
|
|
boffset = boffset0 |
6972
|
44
|
|
|
|
|
+ sv_pos_u2b_midway(start + boffset0, |
6973
|
|
|
|
|
|
start + cache[1], |
6974
|
|
|
|
|
|
uoffset - uoffset0, |
6975
|
44
|
|
|
|
|
cache[0] - uoffset0); |
6976
|
|
|
|
|
|
} else { |
6977
|
10
|
|
|
|
|
boffset = boffset0 |
6978
|
10
|
|
|
|
|
+ sv_pos_u2b_midway(start + boffset0, |
6979
|
|
|
|
|
|
start + cache[3], |
6980
|
|
|
|
|
|
uoffset - uoffset0, |
6981
|
10
|
|
|
|
|
cache[2] - uoffset0); |
6982
|
|
|
|
|
|
} |
6983
|
|
|
|
|
|
found = TRUE; |
6984
|
|
|
|
|
|
} |
6985
|
31012
|
100
|
|
|
|
else if ((*mgp)->mg_len != -1) { |
6986
|
|
|
|
|
|
/* If we can take advantage of a passed in offset, do so. */ |
6987
|
|
|
|
|
|
/* In fact, offset0 is either 0, or less than offset, so don't |
6988
|
|
|
|
|
|
need to worry about the other possibility. */ |
6989
|
31010
|
|
|
|
|
boffset = boffset0 |
6990
|
31010
|
|
|
|
|
+ sv_pos_u2b_midway(start + boffset0, send, |
6991
|
|
|
|
|
|
uoffset - uoffset0, |
6992
|
31010
|
|
|
|
|
(*mgp)->mg_len - uoffset0); |
6993
|
|
|
|
|
|
found = TRUE; |
6994
|
|
|
|
|
|
} |
6995
|
|
|
|
|
|
} |
6996
|
|
|
|
|
|
|
6997
|
150266
|
100
|
|
|
|
if (!found || PL_utf8cache < 0) { |
|
|
50
|
|
|
|
|
6998
|
|
|
|
|
|
STRLEN real_boffset; |
6999
|
94
|
|
|
|
|
uoffset -= uoffset0; |
7000
|
141
|
|
|
|
|
real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0, |
7001
|
|
|
|
|
|
send, &uoffset, &at_end); |
7002
|
94
|
|
|
|
|
uoffset += uoffset0; |
7003
|
|
|
|
|
|
|
7004
|
94
|
50
|
|
|
|
if (found && PL_utf8cache < 0) |
|
|
0
|
|
|
|
|
7005
|
47
|
|
|
|
|
assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset, |
7006
|
|
|
|
|
|
real_boffset, sv); |
7007
|
|
|
|
|
|
boffset = real_boffset; |
7008
|
|
|
|
|
|
} |
7009
|
|
|
|
|
|
|
7010
|
150266
|
50
|
|
|
|
if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) { |
|
|
100
|
|
|
|
|
7011
|
150242
|
100
|
|
|
|
if (at_end) |
7012
|
28
|
|
|
|
|
utf8_mg_len_cache_update(sv, mgp, uoffset); |
7013
|
|
|
|
|
|
else |
7014
|
226244
|
|
|
|
|
utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); |
7015
|
|
|
|
|
|
} |
7016
|
|
|
|
|
|
return boffset; |
7017
|
|
|
|
|
|
} |
7018
|
|
|
|
|
|
|
7019
|
|
|
|
|
|
|
7020
|
|
|
|
|
|
/* |
7021
|
|
|
|
|
|
=for apidoc sv_pos_u2b_flags |
7022
|
|
|
|
|
|
|
7023
|
|
|
|
|
|
Converts the offset from a count of UTF-8 chars from |
7024
|
|
|
|
|
|
the start of the string, to a count of the equivalent number of bytes; if |
7025
|
|
|
|
|
|
lenp is non-zero, it does the same to lenp, but this time starting from |
7026
|
|
|
|
|
|
the offset, rather than from the start |
7027
|
|
|
|
|
|
of the string. Handles type coercion. |
7028
|
|
|
|
|
|
I is passed to C, and usually should be |
7029
|
|
|
|
|
|
C to handle magic. |
7030
|
|
|
|
|
|
|
7031
|
|
|
|
|
|
=cut |
7032
|
|
|
|
|
|
*/ |
7033
|
|
|
|
|
|
|
7034
|
|
|
|
|
|
/* |
7035
|
|
|
|
|
|
* sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential |
7036
|
|
|
|
|
|
* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and |
7037
|
|
|
|
|
|
* byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). |
7038
|
|
|
|
|
|
* |
7039
|
|
|
|
|
|
*/ |
7040
|
|
|
|
|
|
|
7041
|
|
|
|
|
|
STRLEN |
7042
|
153708
|
|
|
|
|
Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, |
7043
|
|
|
|
|
|
U32 flags) |
7044
|
|
|
|
|
|
{ |
7045
|
|
|
|
|
|
const U8 *start; |
7046
|
|
|
|
|
|
STRLEN len; |
7047
|
|
|
|
|
|
STRLEN boffset; |
7048
|
|
|
|
|
|
|
7049
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS; |
7050
|
|
|
|
|
|
|
7051
|
153708
|
100
|
|
|
|
start = (U8*)SvPV_flags(sv, len, flags); |
7052
|
153708
|
100
|
|
|
|
if (len) { |
7053
|
153698
|
|
|
|
|
const U8 * const send = start + len; |
7054
|
153698
|
|
|
|
|
MAGIC *mg = NULL; |
7055
|
153698
|
|
|
|
|
boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); |
7056
|
|
|
|
|
|
|
7057
|
153698
|
100
|
|
|
|
if (lenp |
7058
|
150456
|
100
|
|
|
|
&& *lenp /* don't bother doing work for 0, as its bytes equivalent |
7059
|
|
|
|
|
|
is 0, and *lenp is already set to that. */) { |
7060
|
|
|
|
|
|
/* Convert the relative offset to absolute. */ |
7061
|
148576
|
|
|
|
|
const STRLEN uoffset2 = uoffset + *lenp; |
7062
|
148576
|
|
|
|
|
const STRLEN boffset2 |
7063
|
148576
|
|
|
|
|
= sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, |
7064
|
|
|
|
|
|
uoffset, boffset) - boffset; |
7065
|
|
|
|
|
|
|
7066
|
148576
|
|
|
|
|
*lenp = boffset2; |
7067
|
|
|
|
|
|
} |
7068
|
|
|
|
|
|
} else { |
7069
|
10
|
50
|
|
|
|
if (lenp) |
7070
|
10
|
|
|
|
|
*lenp = 0; |
7071
|
|
|
|
|
|
boffset = 0; |
7072
|
|
|
|
|
|
} |
7073
|
|
|
|
|
|
|
7074
|
153708
|
|
|
|
|
return boffset; |
7075
|
|
|
|
|
|
} |
7076
|
|
|
|
|
|
|
7077
|
|
|
|
|
|
/* |
7078
|
|
|
|
|
|
=for apidoc sv_pos_u2b |
7079
|
|
|
|
|
|
|
7080
|
|
|
|
|
|
Converts the value pointed to by offsetp from a count of UTF-8 chars from |
7081
|
|
|
|
|
|
the start of the string, to a count of the equivalent number of bytes; if |
7082
|
|
|
|
|
|
lenp is non-zero, it does the same to lenp, but this time starting from |
7083
|
|
|
|
|
|
the offset, rather than from the start of the string. Handles magic and |
7084
|
|
|
|
|
|
type coercion. |
7085
|
|
|
|
|
|
|
7086
|
|
|
|
|
|
Use C in preference, which correctly handles strings longer |
7087
|
|
|
|
|
|
than 2Gb. |
7088
|
|
|
|
|
|
|
7089
|
|
|
|
|
|
=cut |
7090
|
|
|
|
|
|
*/ |
7091
|
|
|
|
|
|
|
7092
|
|
|
|
|
|
/* |
7093
|
|
|
|
|
|
* sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential |
7094
|
|
|
|
|
|
* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and |
7095
|
|
|
|
|
|
* byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). |
7096
|
|
|
|
|
|
* |
7097
|
|
|
|
|
|
*/ |
7098
|
|
|
|
|
|
|
7099
|
|
|
|
|
|
/* This function is subject to size and sign problems */ |
7100
|
|
|
|
|
|
|
7101
|
|
|
|
|
|
void |
7102
|
114
|
|
|
|
|
Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp) |
7103
|
|
|
|
|
|
{ |
7104
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_U2B; |
7105
|
|
|
|
|
|
|
7106
|
114
|
100
|
|
|
|
if (lenp) { |
7107
|
44
|
|
|
|
|
STRLEN ulen = (STRLEN)*lenp; |
7108
|
44
|
|
|
|
|
*offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, |
7109
|
|
|
|
|
|
SV_GMAGIC|SV_CONST_RETURN); |
7110
|
44
|
|
|
|
|
*lenp = (I32)ulen; |
7111
|
|
|
|
|
|
} else { |
7112
|
70
|
|
|
|
|
*offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, |
7113
|
|
|
|
|
|
SV_GMAGIC|SV_CONST_RETURN); |
7114
|
|
|
|
|
|
} |
7115
|
114
|
|
|
|
|
} |
7116
|
|
|
|
|
|
|
7117
|
|
|
|
|
|
static void |
7118
|
1440696
|
|
|
|
|
S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, |
7119
|
|
|
|
|
|
const STRLEN ulen) |
7120
|
|
|
|
|
|
{ |
7121
|
|
|
|
|
|
PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE; |
7122
|
1440696
|
100
|
|
|
|
if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv)) |
7123
|
1440696
|
|
|
|
|
return; |
7124
|
|
|
|
|
|
|
7125
|
2369074
|
100
|
|
|
|
if (!*mgp && (SvTYPE(sv) < SVt_PVMG || |
7126
|
929360
|
|
|
|
|
!(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { |
7127
|
1345914
|
|
|
|
|
*mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); |
7128
|
|
|
|
|
|
} |
7129
|
|
|
|
|
|
assert(*mgp); |
7130
|
|
|
|
|
|
|
7131
|
1439714
|
|
|
|
|
(*mgp)->mg_len = ulen; |
7132
|
|
|
|
|
|
} |
7133
|
|
|
|
|
|
|
7134
|
|
|
|
|
|
/* Create and update the UTF8 magic offset cache, with the proffered utf8/ |
7135
|
|
|
|
|
|
byte length pairing. The (byte) length of the total SV is passed in too, |
7136
|
|
|
|
|
|
as blen, because for some (more esoteric) SVs, the call to SvPV_const() |
7137
|
|
|
|
|
|
may not have updated SvCUR, so we can't rely on reading it directly. |
7138
|
|
|
|
|
|
|
7139
|
|
|
|
|
|
The proffered utf8/byte length pairing isn't used if the cache already has |
7140
|
|
|
|
|
|
two pairs, and swapping either for the proffered pair would increase the |
7141
|
|
|
|
|
|
RMS of the intervals between known byte offsets. |
7142
|
|
|
|
|
|
|
7143
|
|
|
|
|
|
The cache itself consists of 4 STRLEN values |
7144
|
|
|
|
|
|
0: larger UTF-8 offset |
7145
|
|
|
|
|
|
1: corresponding byte offset |
7146
|
|
|
|
|
|
2: smaller UTF-8 offset |
7147
|
|
|
|
|
|
3: corresponding byte offset |
7148
|
|
|
|
|
|
|
7149
|
|
|
|
|
|
Unused cache pairs have the value 0, 0. |
7150
|
|
|
|
|
|
Keeping the cache "backwards" means that the invariant of |
7151
|
|
|
|
|
|
cache[0] >= cache[2] is maintained even with empty slots, which means that |
7152
|
|
|
|
|
|
the code that uses it doesn't need to worry if only 1 entry has actually |
7153
|
|
|
|
|
|
been set to non-zero. It also makes the "position beyond the end of the |
7154
|
|
|
|
|
|
cache" logic much simpler, as the first slot is always the one to start |
7155
|
|
|
|
|
|
from. |
7156
|
|
|
|
|
|
*/ |
7157
|
|
|
|
|
|
static void |
7158
|
2167556
|
|
|
|
|
S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte, |
7159
|
|
|
|
|
|
const STRLEN utf8, const STRLEN blen) |
7160
|
|
|
|
|
|
{ |
7161
|
|
|
|
|
|
STRLEN *cache; |
7162
|
|
|
|
|
|
|
7163
|
|
|
|
|
|
PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE; |
7164
|
|
|
|
|
|
|
7165
|
2167556
|
100
|
|
|
|
if (SvREADONLY(sv)) |
7166
|
2167556
|
|
|
|
|
return; |
7167
|
|
|
|
|
|
|
7168
|
2167666
|
100
|
|
|
|
if (!*mgp && (SvTYPE(sv) < SVt_PVMG || |
7169
|
136
|
|
|
|
|
!(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { |
7170
|
188
|
|
|
|
|
*mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, |
7171
|
|
|
|
|
|
0); |
7172
|
188
|
|
|
|
|
(*mgp)->mg_len = -1; |
7173
|
|
|
|
|
|
} |
7174
|
|
|
|
|
|
assert(*mgp); |
7175
|
|
|
|
|
|
|
7176
|
2167530
|
100
|
|
|
|
if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) { |
7177
|
31494
|
|
|
|
|
Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); |
7178
|
31494
|
|
|
|
|
(*mgp)->mg_ptr = (char *) cache; |
7179
|
|
|
|
|
|
} |
7180
|
|
|
|
|
|
assert(cache); |
7181
|
|
|
|
|
|
|
7182
|
2167530
|
100
|
|
|
|
if (PL_utf8cache < 0 && SvPOKp(sv)) { |
|
|
50
|
|
|
|
|
7183
|
|
|
|
|
|
/* SvPOKp() because it's possible that sv has string overloading, and |
7184
|
|
|
|
|
|
therefore is a reference, hence SvPVX() is actually a pointer. |
7185
|
|
|
|
|
|
This cures the (very real) symptoms of RT 69422, but I'm not actually |
7186
|
|
|
|
|
|
sure whether we should even be caching the results of UTF-8 |
7187
|
|
|
|
|
|
operations on overloading, given that nothing stops overloading |
7188
|
|
|
|
|
|
returning a different value every time it's called. */ |
7189
|
2
|
|
|
|
|
const U8 *start = (const U8 *) SvPVX_const(sv); |
7190
|
2
|
|
|
|
|
const STRLEN realutf8 = utf8_length(start, start + byte); |
7191
|
|
|
|
|
|
|
7192
|
2
|
|
|
|
|
assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8, |
7193
|
|
|
|
|
|
sv); |
7194
|
|
|
|
|
|
} |
7195
|
|
|
|
|
|
|
7196
|
|
|
|
|
|
/* Cache is held with the later position first, to simplify the code |
7197
|
|
|
|
|
|
that deals with unbounded ends. */ |
7198
|
|
|
|
|
|
|
7199
|
|
|
|
|
|
ASSERT_UTF8_CACHE(cache); |
7200
|
2167530
|
100
|
|
|
|
if (cache[1] == 0) { |
7201
|
|
|
|
|
|
/* Cache is totally empty */ |
7202
|
31498
|
|
|
|
|
cache[0] = utf8; |
7203
|
31498
|
|
|
|
|
cache[1] = byte; |
7204
|
2136032
|
100
|
|
|
|
} else if (cache[3] == 0) { |
7205
|
2826
|
100
|
|
|
|
if (byte > cache[1]) { |
7206
|
|
|
|
|
|
/* New one is larger, so goes first. */ |
7207
|
2808
|
|
|
|
|
cache[2] = cache[0]; |
7208
|
2808
|
|
|
|
|
cache[3] = cache[1]; |
7209
|
2808
|
|
|
|
|
cache[0] = utf8; |
7210
|
2808
|
|
|
|
|
cache[1] = byte; |
7211
|
|
|
|
|
|
} else { |
7212
|
18
|
|
|
|
|
cache[2] = utf8; |
7213
|
18
|
|
|
|
|
cache[3] = byte; |
7214
|
|
|
|
|
|
} |
7215
|
|
|
|
|
|
} else { |
7216
|
|
|
|
|
|
#define THREEWAY_SQUARE(a,b,c,d) \ |
7217
|
|
|
|
|
|
((float)((d) - (c))) * ((float)((d) - (c))) \ |
7218
|
|
|
|
|
|
+ ((float)((c) - (b))) * ((float)((c) - (b))) \ |
7219
|
|
|
|
|
|
+ ((float)((b) - (a))) * ((float)((b) - (a))) |
7220
|
|
|
|
|
|
|
7221
|
|
|
|
|
|
/* Cache has 2 slots in use, and we know three potential pairs. |
7222
|
|
|
|
|
|
Keep the two that give the lowest RMS distance. Do the |
7223
|
|
|
|
|
|
calculation in bytes simply because we always know the byte |
7224
|
|
|
|
|
|
length. squareroot has the same ordering as the positive value, |
7225
|
|
|
|
|
|
so don't bother with the actual square root. */ |
7226
|
2133206
|
100
|
|
|
|
if (byte > cache[1]) { |
7227
|
|
|
|
|
|
/* New position is after the existing pair of pairs. */ |
7228
|
2133128
|
|
|
|
|
const float keep_earlier |
7229
|
2133128
|
|
|
|
|
= THREEWAY_SQUARE(0, cache[3], byte, blen); |
7230
|
2133128
|
|
|
|
|
const float keep_later |
7231
|
2133128
|
|
|
|
|
= THREEWAY_SQUARE(0, cache[1], byte, blen); |
7232
|
|
|
|
|
|
|
7233
|
2133128
|
100
|
|
|
|
if (keep_later < keep_earlier) { |
7234
|
1328
|
|
|
|
|
cache[2] = cache[0]; |
7235
|
1328
|
|
|
|
|
cache[3] = cache[1]; |
7236
|
1328
|
|
|
|
|
cache[0] = utf8; |
7237
|
1328
|
|
|
|
|
cache[1] = byte; |
7238
|
|
|
|
|
|
} |
7239
|
|
|
|
|
|
else { |
7240
|
2131800
|
|
|
|
|
cache[0] = utf8; |
7241
|
2131800
|
|
|
|
|
cache[1] = byte; |
7242
|
|
|
|
|
|
} |
7243
|
|
|
|
|
|
} |
7244
|
78
|
100
|
|
|
|
else if (byte > cache[3]) { |
7245
|
|
|
|
|
|
/* New position is between the existing pair of pairs. */ |
7246
|
60
|
|
|
|
|
const float keep_earlier |
7247
|
60
|
|
|
|
|
= THREEWAY_SQUARE(0, cache[3], byte, blen); |
7248
|
60
|
|
|
|
|
const float keep_later |
7249
|
60
|
|
|
|
|
= THREEWAY_SQUARE(0, byte, cache[1], blen); |
7250
|
|
|
|
|
|
|
7251
|
60
|
100
|
|
|
|
if (keep_later < keep_earlier) { |
7252
|
12
|
|
|
|
|
cache[2] = utf8; |
7253
|
12
|
|
|
|
|
cache[3] = byte; |
7254
|
|
|
|
|
|
} |
7255
|
|
|
|
|
|
else { |
7256
|
48
|
|
|
|
|
cache[0] = utf8; |
7257
|
48
|
|
|
|
|
cache[1] = byte; |
7258
|
|
|
|
|
|
} |
7259
|
|
|
|
|
|
} |
7260
|
|
|
|
|
|
else { |
7261
|
|
|
|
|
|
/* New position is before the existing pair of pairs. */ |
7262
|
18
|
|
|
|
|
const float keep_earlier |
7263
|
18
|
|
|
|
|
= THREEWAY_SQUARE(0, byte, cache[3], blen); |
7264
|
18
|
|
|
|
|
const float keep_later |
7265
|
18
|
|
|
|
|
= THREEWAY_SQUARE(0, byte, cache[1], blen); |
7266
|
|
|
|
|
|
|
7267
|
18
|
100
|
|
|
|
if (keep_later < keep_earlier) { |
7268
|
8
|
|
|
|
|
cache[2] = utf8; |
7269
|
8
|
|
|
|
|
cache[3] = byte; |
7270
|
|
|
|
|
|
} |
7271
|
|
|
|
|
|
else { |
7272
|
10
|
|
|
|
|
cache[0] = cache[2]; |
7273
|
10
|
|
|
|
|
cache[1] = cache[3]; |
7274
|
10
|
|
|
|
|
cache[2] = utf8; |
7275
|
10
|
|
|
|
|
cache[3] = byte; |
7276
|
|
|
|
|
|
} |
7277
|
|
|
|
|
|
} |
7278
|
|
|
|
|
|
} |
7279
|
|
|
|
|
|
ASSERT_UTF8_CACHE(cache); |
7280
|
|
|
|
|
|
} |
7281
|
|
|
|
|
|
|
7282
|
|
|
|
|
|
/* We already know all of the way, now we may be able to walk back. The same |
7283
|
|
|
|
|
|
assumption is made as in S_sv_pos_u2b_midway(), namely that walking |
7284
|
|
|
|
|
|
backward is half the speed of walking forward. */ |
7285
|
|
|
|
|
|
static STRLEN |
7286
|
18498
|
|
|
|
|
S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, |
7287
|
|
|
|
|
|
const U8 *end, STRLEN endu) |
7288
|
|
|
|
|
|
{ |
7289
|
18498
|
|
|
|
|
const STRLEN forw = target - s; |
7290
|
18498
|
|
|
|
|
STRLEN backw = end - target; |
7291
|
|
|
|
|
|
|
7292
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY; |
7293
|
|
|
|
|
|
|
7294
|
18498
|
100
|
|
|
|
if (forw < 2 * backw) { |
7295
|
16962
|
|
|
|
|
return utf8_length(s, target); |
7296
|
|
|
|
|
|
} |
7297
|
|
|
|
|
|
|
7298
|
10383
|
100
|
|
|
|
while (end > target) { |
7299
|
366
|
|
|
|
|
end--; |
7300
|
577
|
100
|
|
|
|
while (UTF8_IS_CONTINUATION(*end)) { |
7301
|
28
|
|
|
|
|
end--; |
7302
|
|
|
|
|
|
} |
7303
|
366
|
|
|
|
|
endu--; |
7304
|
|
|
|
|
|
} |
7305
|
|
|
|
|
|
return endu; |
7306
|
|
|
|
|
|
} |
7307
|
|
|
|
|
|
|
7308
|
|
|
|
|
|
/* |
7309
|
|
|
|
|
|
=for apidoc sv_pos_b2u_flags |
7310
|
|
|
|
|
|
|
7311
|
|
|
|
|
|
Converts the offset from a count of bytes from the start of the string, to |
7312
|
|
|
|
|
|
a count of the equivalent number of UTF-8 chars. Handles type coercion. |
7313
|
|
|
|
|
|
I is passed to C, and usually should be |
7314
|
|
|
|
|
|
C to handle magic. |
7315
|
|
|
|
|
|
|
7316
|
|
|
|
|
|
=cut |
7317
|
|
|
|
|
|
*/ |
7318
|
|
|
|
|
|
|
7319
|
|
|
|
|
|
/* |
7320
|
|
|
|
|
|
* sv_pos_b2u_flags() uses, like sv_pos_u2b_flags(), the mg_ptr of the |
7321
|
|
|
|
|
|
* potential PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 |
7322
|
|
|
|
|
|
* and byte offsets. |
7323
|
|
|
|
|
|
* |
7324
|
|
|
|
|
|
*/ |
7325
|
|
|
|
|
|
STRLEN |
7326
|
2018734
|
|
|
|
|
Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags) |
7327
|
|
|
|
|
|
{ |
7328
|
|
|
|
|
|
const U8* s; |
7329
|
|
|
|
|
|
STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */ |
7330
|
|
|
|
|
|
STRLEN blen; |
7331
|
2018734
|
|
|
|
|
MAGIC* mg = NULL; |
7332
|
|
|
|
|
|
const U8* send; |
7333
|
|
|
|
|
|
bool found = FALSE; |
7334
|
|
|
|
|
|
|
7335
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_B2U_FLAGS; |
7336
|
|
|
|
|
|
|
7337
|
2018734
|
50
|
|
|
|
s = (const U8*)SvPV_flags(sv, blen, flags); |
7338
|
|
|
|
|
|
|
7339
|
2018734
|
50
|
|
|
|
if (blen < offset) |
7340
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf |
7341
|
|
|
|
|
|
", byte=%"UVuf, (UV)blen, (UV)offset); |
7342
|
|
|
|
|
|
|
7343
|
2018734
|
|
|
|
|
send = s + offset; |
7344
|
|
|
|
|
|
|
7345
|
2018734
|
100
|
|
|
|
if (!SvREADONLY(sv) |
7346
|
2018724
|
50
|
|
|
|
&& PL_utf8cache |
7347
|
2018724
|
100
|
|
|
|
&& SvTYPE(sv) >= SVt_PVMG |
7348
|
2018696
|
100
|
|
|
|
&& (mg = mg_find(sv, PERL_MAGIC_utf8))) |
7349
|
|
|
|
|
|
{ |
7350
|
2018552
|
100
|
|
|
|
if (mg->mg_ptr) { |
7351
|
2016918
|
|
|
|
|
STRLEN * const cache = (STRLEN *) mg->mg_ptr; |
7352
|
2016918
|
100
|
|
|
|
if (cache[1] == offset) { |
7353
|
|
|
|
|
|
/* An exact match. */ |
7354
|
4
|
|
|
|
|
return cache[0]; |
7355
|
|
|
|
|
|
} |
7356
|
2016914
|
100
|
|
|
|
if (cache[3] == offset) { |
7357
|
|
|
|
|
|
/* An exact match. */ |
7358
|
6
|
|
|
|
|
return cache[2]; |
7359
|
|
|
|
|
|
} |
7360
|
|
|
|
|
|
|
7361
|
2016908
|
100
|
|
|
|
if (cache[1] < offset) { |
7362
|
|
|
|
|
|
/* We already know part of the way. */ |
7363
|
2016866
|
100
|
|
|
|
if (mg->mg_len != -1) { |
7364
|
|
|
|
|
|
/* Actually, we know the end too. */ |
7365
|
16822
|
|
|
|
|
len = cache[0] |
7366
|
25233
|
|
|
|
|
+ S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, |
7367
|
33644
|
|
|
|
|
s + blen, mg->mg_len - cache[0]); |
7368
|
|
|
|
|
|
} else { |
7369
|
2000044
|
|
|
|
|
len = cache[0] + utf8_length(s + cache[1], send); |
7370
|
|
|
|
|
|
} |
7371
|
|
|
|
|
|
} |
7372
|
42
|
100
|
|
|
|
else if (cache[3] < offset) { |
7373
|
|
|
|
|
|
/* We're between the two cached pairs, so we do the calculation |
7374
|
|
|
|
|
|
offset by the byte/utf-8 positions for the earlier pair, |
7375
|
|
|
|
|
|
then add the utf-8 characters from the string start to |
7376
|
|
|
|
|
|
there. */ |
7377
|
51
|
|
|
|
|
len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, |
7378
|
34
|
|
|
|
|
s + cache[1], cache[0] - cache[2]) |
7379
|
34
|
|
|
|
|
+ cache[2]; |
7380
|
|
|
|
|
|
|
7381
|
|
|
|
|
|
} |
7382
|
|
|
|
|
|
else { /* cache[3] > offset */ |
7383
|
8
|
|
|
|
|
len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], |
7384
|
|
|
|
|
|
cache[2]); |
7385
|
|
|
|
|
|
|
7386
|
|
|
|
|
|
} |
7387
|
|
|
|
|
|
ASSERT_UTF8_CACHE(cache); |
7388
|
|
|
|
|
|
found = TRUE; |
7389
|
1634
|
50
|
|
|
|
} else if (mg->mg_len != -1) { |
7390
|
1634
|
|
|
|
|
len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); |
7391
|
|
|
|
|
|
found = TRUE; |
7392
|
|
|
|
|
|
} |
7393
|
|
|
|
|
|
} |
7394
|
2018724
|
100
|
|
|
|
if (!found || PL_utf8cache < 0) { |
|
|
100
|
|
|
|
|
7395
|
184
|
|
|
|
|
const STRLEN real_len = utf8_length(s, send); |
7396
|
|
|
|
|
|
|
7397
|
184
|
100
|
|
|
|
if (found && PL_utf8cache < 0) |
|
|
50
|
|
|
|
|
7398
|
93
|
|
|
|
|
assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv); |
7399
|
|
|
|
|
|
len = real_len; |
7400
|
|
|
|
|
|
} |
7401
|
|
|
|
|
|
|
7402
|
2018724
|
50
|
|
|
|
if (PL_utf8cache) { |
7403
|
2018724
|
100
|
|
|
|
if (blen == offset) |
7404
|
1382
|
|
|
|
|
utf8_mg_len_cache_update(sv, &mg, len); |
7405
|
|
|
|
|
|
else |
7406
|
2018038
|
|
|
|
|
utf8_mg_pos_cache_update(sv, &mg, offset, len, blen); |
7407
|
|
|
|
|
|
} |
7408
|
|
|
|
|
|
|
7409
|
|
|
|
|
|
return len; |
7410
|
|
|
|
|
|
} |
7411
|
|
|
|
|
|
|
7412
|
|
|
|
|
|
/* |
7413
|
|
|
|
|
|
=for apidoc sv_pos_b2u |
7414
|
|
|
|
|
|
|
7415
|
|
|
|
|
|
Converts the value pointed to by offsetp from a count of bytes from the |
7416
|
|
|
|
|
|
start of the string, to a count of the equivalent number of UTF-8 chars. |
7417
|
|
|
|
|
|
Handles magic and type coercion. |
7418
|
|
|
|
|
|
|
7419
|
|
|
|
|
|
Use C in preference, which correctly handles strings |
7420
|
|
|
|
|
|
longer than 2Gb. |
7421
|
|
|
|
|
|
|
7422
|
|
|
|
|
|
=cut |
7423
|
|
|
|
|
|
*/ |
7424
|
|
|
|
|
|
|
7425
|
|
|
|
|
|
/* |
7426
|
|
|
|
|
|
* sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential |
7427
|
|
|
|
|
|
* PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and |
7428
|
|
|
|
|
|
* byte offsets. |
7429
|
|
|
|
|
|
* |
7430
|
|
|
|
|
|
*/ |
7431
|
|
|
|
|
|
void |
7432
|
258
|
|
|
|
|
Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp) |
7433
|
|
|
|
|
|
{ |
7434
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_POS_B2U; |
7435
|
|
|
|
|
|
|
7436
|
258
|
50
|
|
|
|
if (!sv) |
7437
|
258
|
|
|
|
|
return; |
7438
|
|
|
|
|
|
|
7439
|
258
|
|
|
|
|
*offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp, |
7440
|
|
|
|
|
|
SV_GMAGIC|SV_CONST_RETURN); |
7441
|
|
|
|
|
|
} |
7442
|
|
|
|
|
|
|
7443
|
|
|
|
|
|
static void |
7444
|
4
|
|
|
|
|
S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache, |
7445
|
|
|
|
|
|
STRLEN real, SV *const sv) |
7446
|
|
|
|
|
|
{ |
7447
|
|
|
|
|
|
PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT; |
7448
|
|
|
|
|
|
|
7449
|
|
|
|
|
|
/* As this is debugging only code, save space by keeping this test here, |
7450
|
|
|
|
|
|
rather than inlining it in all the callers. */ |
7451
|
4
|
50
|
|
|
|
if (from_cache == real) |
7452
|
4
|
|
|
|
|
return; |
7453
|
|
|
|
|
|
|
7454
|
|
|
|
|
|
/* Need to turn the assertions off otherwise we may recurse infinitely |
7455
|
|
|
|
|
|
while printing error messages. */ |
7456
|
0
|
|
|
|
|
SAVEI8(PL_utf8cache); |
7457
|
0
|
|
|
|
|
PL_utf8cache = 0; |
7458
|
0
|
|
|
|
|
Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf, |
7459
|
|
|
|
|
|
func, (UV) from_cache, (UV) real, SVfARG(sv)); |
7460
|
|
|
|
|
|
} |
7461
|
|
|
|
|
|
|
7462
|
|
|
|
|
|
/* |
7463
|
|
|
|
|
|
=for apidoc sv_eq |
7464
|
|
|
|
|
|
|
7465
|
|
|
|
|
|
Returns a boolean indicating whether the strings in the two SVs are |
7466
|
|
|
|
|
|
identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will |
7467
|
|
|
|
|
|
coerce its args to strings if necessary. |
7468
|
|
|
|
|
|
|
7469
|
|
|
|
|
|
=for apidoc sv_eq_flags |
7470
|
|
|
|
|
|
|
7471
|
|
|
|
|
|
Returns a boolean indicating whether the strings in the two SVs are |
7472
|
|
|
|
|
|
identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings |
7473
|
|
|
|
|
|
if necessary. If the flags include SV_GMAGIC, it handles get-magic, too. |
7474
|
|
|
|
|
|
|
7475
|
|
|
|
|
|
=cut |
7476
|
|
|
|
|
|
*/ |
7477
|
|
|
|
|
|
|
7478
|
|
|
|
|
|
I32 |
7479
|
428916282
|
|
|
|
|
Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) |
7480
|
|
|
|
|
|
{ |
7481
|
|
|
|
|
|
dVAR; |
7482
|
|
|
|
|
|
const char *pv1; |
7483
|
|
|
|
|
|
STRLEN cur1; |
7484
|
|
|
|
|
|
const char *pv2; |
7485
|
|
|
|
|
|
STRLEN cur2; |
7486
|
|
|
|
|
|
I32 eq = 0; |
7487
|
|
|
|
|
|
SV* svrecode = NULL; |
7488
|
|
|
|
|
|
|
7489
|
428916282
|
50
|
|
|
|
if (!sv1) { |
7490
|
|
|
|
|
|
pv1 = ""; |
7491
|
0
|
|
|
|
|
cur1 = 0; |
7492
|
|
|
|
|
|
} |
7493
|
|
|
|
|
|
else { |
7494
|
|
|
|
|
|
/* if pv1 and pv2 are the same, second SvPV_const call may |
7495
|
|
|
|
|
|
* invalidate pv1 (if we are handling magic), so we may need to |
7496
|
|
|
|
|
|
* make a copy */ |
7497
|
428916282
|
100
|
|
|
|
if (sv1 == sv2 && flags & SV_GMAGIC |
|
|
50
|
|
|
|
|
7498
|
0
|
0
|
|
|
|
&& (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { |
7499
|
0
|
0
|
|
|
|
pv1 = SvPV_const(sv1, cur1); |
7500
|
0
|
|
|
|
|
sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); |
7501
|
|
|
|
|
|
} |
7502
|
428916282
|
100
|
|
|
|
pv1 = SvPV_flags_const(sv1, cur1, flags); |
7503
|
|
|
|
|
|
} |
7504
|
|
|
|
|
|
|
7505
|
428916282
|
50
|
|
|
|
if (!sv2){ |
7506
|
|
|
|
|
|
pv2 = ""; |
7507
|
0
|
|
|
|
|
cur2 = 0; |
7508
|
|
|
|
|
|
} |
7509
|
|
|
|
|
|
else |
7510
|
428916282
|
100
|
|
|
|
pv2 = SvPV_flags_const(sv2, cur2, flags); |
7511
|
|
|
|
|
|
|
7512
|
428916282
|
100
|
|
|
|
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
7513
|
|
|
|
|
|
/* Differing utf8ness. |
7514
|
|
|
|
|
|
* Do not UTF8size the comparands as a side-effect. */ |
7515
|
261786
|
100
|
|
|
|
if (PL_encoding) { |
7516
|
21766
|
100
|
|
|
|
if (SvUTF8(sv1)) { |
7517
|
21584
|
|
|
|
|
svrecode = newSVpvn(pv2, cur2); |
7518
|
21584
|
|
|
|
|
sv_recode_to_utf8(svrecode, PL_encoding); |
7519
|
21584
|
50
|
|
|
|
pv2 = SvPV_const(svrecode, cur2); |
7520
|
|
|
|
|
|
} |
7521
|
|
|
|
|
|
else { |
7522
|
182
|
|
|
|
|
svrecode = newSVpvn(pv1, cur1); |
7523
|
182
|
|
|
|
|
sv_recode_to_utf8(svrecode, PL_encoding); |
7524
|
182
|
50
|
|
|
|
pv1 = SvPV_const(svrecode, cur1); |
7525
|
|
|
|
|
|
} |
7526
|
|
|
|
|
|
/* Now both are in UTF-8. */ |
7527
|
21766
|
100
|
|
|
|
if (cur1 != cur2) { |
7528
|
236
|
|
|
|
|
SvREFCNT_dec_NN(svrecode); |
7529
|
236
|
|
|
|
|
return FALSE; |
7530
|
|
|
|
|
|
} |
7531
|
|
|
|
|
|
} |
7532
|
|
|
|
|
|
else { |
7533
|
240020
|
100
|
|
|
|
if (SvUTF8(sv1)) { |
7534
|
|
|
|
|
|
/* sv1 is the UTF-8 one */ |
7535
|
235214
|
|
|
|
|
return bytes_cmp_utf8((const U8*)pv2, cur2, |
7536
|
|
|
|
|
|
(const U8*)pv1, cur1) == 0; |
7537
|
|
|
|
|
|
} |
7538
|
|
|
|
|
|
else { |
7539
|
|
|
|
|
|
/* sv2 is the UTF-8 one */ |
7540
|
4806
|
|
|
|
|
return bytes_cmp_utf8((const U8*)pv1, cur1, |
7541
|
|
|
|
|
|
(const U8*)pv2, cur2) == 0; |
7542
|
|
|
|
|
|
} |
7543
|
|
|
|
|
|
} |
7544
|
|
|
|
|
|
} |
7545
|
|
|
|
|
|
|
7546
|
428676026
|
100
|
|
|
|
if (cur1 == cur2) |
7547
|
135262398
|
100
|
|
|
|
eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1); |
|
|
100
|
|
|
|
|
7548
|
|
|
|
|
|
|
7549
|
428676026
|
|
|
|
|
SvREFCNT_dec(svrecode); |
7550
|
|
|
|
|
|
|
7551
|
428796154
|
|
|
|
|
return eq; |
7552
|
|
|
|
|
|
} |
7553
|
|
|
|
|
|
|
7554
|
|
|
|
|
|
/* |
7555
|
|
|
|
|
|
=for apidoc sv_cmp |
7556
|
|
|
|
|
|
|
7557
|
|
|
|
|
|
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the |
7558
|
|
|
|
|
|
string in C is less than, equal to, or greater than the string in |
7559
|
|
|
|
|
|
C. Is UTF-8 and 'use bytes' aware, handles get magic, and will |
7560
|
|
|
|
|
|
coerce its args to strings if necessary. See also C. |
7561
|
|
|
|
|
|
|
7562
|
|
|
|
|
|
=for apidoc sv_cmp_flags |
7563
|
|
|
|
|
|
|
7564
|
|
|
|
|
|
Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the |
7565
|
|
|
|
|
|
string in C is less than, equal to, or greater than the string in |
7566
|
|
|
|
|
|
C. Is UTF-8 and 'use bytes' aware and will coerce its args to strings |
7567
|
|
|
|
|
|
if necessary. If the flags include SV_GMAGIC, it handles get magic. See |
7568
|
|
|
|
|
|
also C. |
7569
|
|
|
|
|
|
|
7570
|
|
|
|
|
|
=cut |
7571
|
|
|
|
|
|
*/ |
7572
|
|
|
|
|
|
|
7573
|
|
|
|
|
|
I32 |
7574
|
189596769
|
|
|
|
|
Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2) |
7575
|
|
|
|
|
|
{ |
7576
|
189596769
|
|
|
|
|
return sv_cmp_flags(sv1, sv2, SV_GMAGIC); |
7577
|
|
|
|
|
|
} |
7578
|
|
|
|
|
|
|
7579
|
|
|
|
|
|
I32 |
7580
|
195807651
|
|
|
|
|
Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, |
7581
|
|
|
|
|
|
const U32 flags) |
7582
|
|
|
|
|
|
{ |
7583
|
|
|
|
|
|
dVAR; |
7584
|
|
|
|
|
|
STRLEN cur1, cur2; |
7585
|
|
|
|
|
|
const char *pv1, *pv2; |
7586
|
|
|
|
|
|
I32 cmp; |
7587
|
|
|
|
|
|
SV *svrecode = NULL; |
7588
|
|
|
|
|
|
|
7589
|
195807651
|
100
|
|
|
|
if (!sv1) { |
7590
|
|
|
|
|
|
pv1 = ""; |
7591
|
2
|
|
|
|
|
cur1 = 0; |
7592
|
|
|
|
|
|
} |
7593
|
|
|
|
|
|
else |
7594
|
195807649
|
100
|
|
|
|
pv1 = SvPV_flags_const(sv1, cur1, flags); |
7595
|
|
|
|
|
|
|
7596
|
195807651
|
100
|
|
|
|
if (!sv2) { |
7597
|
|
|
|
|
|
pv2 = ""; |
7598
|
8
|
|
|
|
|
cur2 = 0; |
7599
|
|
|
|
|
|
} |
7600
|
|
|
|
|
|
else |
7601
|
195807643
|
100
|
|
|
|
pv2 = SvPV_flags_const(sv2, cur2, flags); |
7602
|
|
|
|
|
|
|
7603
|
195807651
|
100
|
|
|
|
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
7604
|
|
|
|
|
|
/* Differing utf8ness. |
7605
|
|
|
|
|
|
* Do not UTF8size the comparands as a side-effect. */ |
7606
|
34072
|
100
|
|
|
|
if (SvUTF8(sv1)) { |
7607
|
18536
|
100
|
|
|
|
if (PL_encoding) { |
7608
|
422
|
|
|
|
|
svrecode = newSVpvn(pv2, cur2); |
7609
|
422
|
|
|
|
|
sv_recode_to_utf8(svrecode, PL_encoding); |
7610
|
422
|
50
|
|
|
|
pv2 = SvPV_const(svrecode, cur2); |
7611
|
|
|
|
|
|
} |
7612
|
|
|
|
|
|
else { |
7613
|
18114
|
|
|
|
|
const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, |
7614
|
|
|
|
|
|
(const U8*)pv1, cur1); |
7615
|
18114
|
100
|
|
|
|
return retval ? retval < 0 ? -1 : +1 : 0; |
|
|
100
|
|
|
|
|
7616
|
|
|
|
|
|
} |
7617
|
|
|
|
|
|
} |
7618
|
|
|
|
|
|
else { |
7619
|
15536
|
100
|
|
|
|
if (PL_encoding) { |
7620
|
462
|
|
|
|
|
svrecode = newSVpvn(pv1, cur1); |
7621
|
462
|
|
|
|
|
sv_recode_to_utf8(svrecode, PL_encoding); |
7622
|
462
|
50
|
|
|
|
pv1 = SvPV_const(svrecode, cur1); |
7623
|
|
|
|
|
|
} |
7624
|
|
|
|
|
|
else { |
7625
|
15074
|
|
|
|
|
const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, |
7626
|
|
|
|
|
|
(const U8*)pv2, cur2); |
7627
|
15074
|
100
|
|
|
|
return retval ? retval < 0 ? -1 : +1 : 0; |
|
|
100
|
|
|
|
|
7628
|
|
|
|
|
|
} |
7629
|
|
|
|
|
|
} |
7630
|
|
|
|
|
|
} |
7631
|
|
|
|
|
|
|
7632
|
195774463
|
100
|
|
|
|
if (!cur1) { |
7633
|
13808
|
100
|
|
|
|
cmp = cur2 ? -1 : 0; |
7634
|
195760655
|
100
|
|
|
|
} else if (!cur2) { |
7635
|
|
|
|
|
|
cmp = 1; |
7636
|
|
|
|
|
|
} else { |
7637
|
195760045
|
|
|
|
|
const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2); |
7638
|
|
|
|
|
|
|
7639
|
195760045
|
100
|
|
|
|
if (retval) { |
7640
|
192725103
|
100
|
|
|
|
cmp = retval < 0 ? -1 : 1; |
7641
|
3034942
|
100
|
|
|
|
} else if (cur1 == cur2) { |
7642
|
|
|
|
|
|
cmp = 0; |
7643
|
|
|
|
|
|
} else { |
7644
|
2435684
|
100
|
|
|
|
cmp = cur1 < cur2 ? -1 : 1; |
7645
|
|
|
|
|
|
} |
7646
|
|
|
|
|
|
} |
7647
|
|
|
|
|
|
|
7648
|
195774463
|
|
|
|
|
SvREFCNT_dec(svrecode); |
7649
|
|
|
|
|
|
|
7650
|
195791057
|
|
|
|
|
return cmp; |
7651
|
|
|
|
|
|
} |
7652
|
|
|
|
|
|
|
7653
|
|
|
|
|
|
/* |
7654
|
|
|
|
|
|
=for apidoc sv_cmp_locale |
7655
|
|
|
|
|
|
|
7656
|
|
|
|
|
|
Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and |
7657
|
|
|
|
|
|
'use bytes' aware, handles get magic, and will coerce its args to strings |
7658
|
|
|
|
|
|
if necessary. See also C. |
7659
|
|
|
|
|
|
|
7660
|
|
|
|
|
|
=for apidoc sv_cmp_locale_flags |
7661
|
|
|
|
|
|
|
7662
|
|
|
|
|
|
Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and |
7663
|
|
|
|
|
|
'use bytes' aware and will coerce its args to strings if necessary. If the |
7664
|
|
|
|
|
|
flags contain SV_GMAGIC, it handles get magic. See also C. |
7665
|
|
|
|
|
|
|
7666
|
|
|
|
|
|
=cut |
7667
|
|
|
|
|
|
*/ |
7668
|
|
|
|
|
|
|
7669
|
|
|
|
|
|
I32 |
7670
|
0
|
|
|
|
|
Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2) |
7671
|
|
|
|
|
|
{ |
7672
|
0
|
|
|
|
|
return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC); |
7673
|
|
|
|
|
|
} |
7674
|
|
|
|
|
|
|
7675
|
|
|
|
|
|
I32 |
7676
|
0
|
|
|
|
|
Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, |
7677
|
|
|
|
|
|
const U32 flags) |
7678
|
|
|
|
|
|
{ |
7679
|
|
|
|
|
|
dVAR; |
7680
|
|
|
|
|
|
#ifdef USE_LOCALE_COLLATE |
7681
|
|
|
|
|
|
|
7682
|
|
|
|
|
|
char *pv1, *pv2; |
7683
|
|
|
|
|
|
STRLEN len1, len2; |
7684
|
|
|
|
|
|
I32 retval; |
7685
|
|
|
|
|
|
|
7686
|
0
|
0
|
|
|
|
if (PL_collation_standard) |
7687
|
|
|
|
|
|
goto raw_compare; |
7688
|
|
|
|
|
|
|
7689
|
0
|
|
|
|
|
len1 = 0; |
7690
|
0
|
0
|
|
|
|
pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL; |
7691
|
0
|
|
|
|
|
len2 = 0; |
7692
|
0
|
0
|
|
|
|
pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL; |
7693
|
|
|
|
|
|
|
7694
|
0
|
0
|
|
|
|
if (!pv1 || !len1) { |
|
|
0
|
|
|
|
|
7695
|
0
|
0
|
|
|
|
if (pv2 && len2) |
|
|
0
|
|
|
|
|
7696
|
|
|
|
|
|
return -1; |
7697
|
|
|
|
|
|
else |
7698
|
|
|
|
|
|
goto raw_compare; |
7699
|
|
|
|
|
|
} |
7700
|
|
|
|
|
|
else { |
7701
|
0
|
0
|
|
|
|
if (!pv2 || !len2) |
|
|
0
|
|
|
|
|
7702
|
|
|
|
|
|
return 1; |
7703
|
|
|
|
|
|
} |
7704
|
|
|
|
|
|
|
7705
|
0
|
|
|
|
|
retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); |
7706
|
|
|
|
|
|
|
7707
|
0
|
0
|
|
|
|
if (retval) |
7708
|
0
|
0
|
|
|
|
return retval < 0 ? -1 : 1; |
7709
|
|
|
|
|
|
|
7710
|
|
|
|
|
|
/* |
7711
|
|
|
|
|
|
* When the result of collation is equality, that doesn't mean |
7712
|
|
|
|
|
|
* that there are no differences -- some locales exclude some |
7713
|
|
|
|
|
|
* characters from consideration. So to avoid false equalities, |
7714
|
|
|
|
|
|
* we use the raw string as a tiebreaker. |
7715
|
|
|
|
|
|
*/ |
7716
|
|
|
|
|
|
|
7717
|
|
|
|
|
|
raw_compare: |
7718
|
|
|
|
|
|
/*FALLTHROUGH*/ |
7719
|
|
|
|
|
|
|
7720
|
|
|
|
|
|
#endif /* USE_LOCALE_COLLATE */ |
7721
|
|
|
|
|
|
|
7722
|
0
|
|
|
|
|
return sv_cmp(sv1, sv2); |
7723
|
|
|
|
|
|
} |
7724
|
|
|
|
|
|
|
7725
|
|
|
|
|
|
|
7726
|
|
|
|
|
|
#ifdef USE_LOCALE_COLLATE |
7727
|
|
|
|
|
|
|
7728
|
|
|
|
|
|
/* |
7729
|
|
|
|
|
|
=for apidoc sv_collxfrm |
7730
|
|
|
|
|
|
|
7731
|
|
|
|
|
|
This calls C with the SV_GMAGIC flag. See |
7732
|
|
|
|
|
|
C. |
7733
|
|
|
|
|
|
|
7734
|
|
|
|
|
|
=for apidoc sv_collxfrm_flags |
7735
|
|
|
|
|
|
|
7736
|
|
|
|
|
|
Add Collate Transform magic to an SV if it doesn't already have it. If the |
7737
|
|
|
|
|
|
flags contain SV_GMAGIC, it handles get-magic. |
7738
|
|
|
|
|
|
|
7739
|
|
|
|
|
|
Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the |
7740
|
|
|
|
|
|
scalar data of the variable, but transformed to such a format that a normal |
7741
|
|
|
|
|
|
memory comparison can be used to compare the data according to the locale |
7742
|
|
|
|
|
|
settings. |
7743
|
|
|
|
|
|
|
7744
|
|
|
|
|
|
=cut |
7745
|
|
|
|
|
|
*/ |
7746
|
|
|
|
|
|
|
7747
|
|
|
|
|
|
char * |
7748
|
0
|
|
|
|
|
Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) |
7749
|
|
|
|
|
|
{ |
7750
|
|
|
|
|
|
dVAR; |
7751
|
|
|
|
|
|
MAGIC *mg; |
7752
|
|
|
|
|
|
|
7753
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS; |
7754
|
|
|
|
|
|
|
7755
|
0
|
0
|
|
|
|
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; |
7756
|
0
|
0
|
|
|
|
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
7757
|
|
|
|
|
|
const char *s; |
7758
|
|
|
|
|
|
char *xf; |
7759
|
|
|
|
|
|
STRLEN len, xlen; |
7760
|
|
|
|
|
|
|
7761
|
0
|
0
|
|
|
|
if (mg) |
7762
|
0
|
|
|
|
|
Safefree(mg->mg_ptr); |
7763
|
0
|
0
|
|
|
|
s = SvPV_flags_const(sv, len, flags); |
7764
|
0
|
0
|
|
|
|
if ((xf = mem_collxfrm(s, len, &xlen))) { |
7765
|
0
|
0
|
|
|
|
if (! mg) { |
7766
|
|
|
|
|
|
#ifdef PERL_OLD_COPY_ON_WRITE |
7767
|
|
|
|
|
|
if (SvIsCOW(sv)) |
7768
|
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
7769
|
|
|
|
|
|
#endif |
7770
|
0
|
|
|
|
|
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, |
7771
|
|
|
|
|
|
0, 0); |
7772
|
|
|
|
|
|
assert(mg); |
7773
|
|
|
|
|
|
} |
7774
|
0
|
|
|
|
|
mg->mg_ptr = xf; |
7775
|
0
|
|
|
|
|
mg->mg_len = xlen; |
7776
|
|
|
|
|
|
} |
7777
|
|
|
|
|
|
else { |
7778
|
0
|
0
|
|
|
|
if (mg) { |
7779
|
0
|
|
|
|
|
mg->mg_ptr = NULL; |
7780
|
0
|
|
|
|
|
mg->mg_len = -1; |
7781
|
|
|
|
|
|
} |
7782
|
|
|
|
|
|
} |
7783
|
|
|
|
|
|
} |
7784
|
0
|
0
|
|
|
|
if (mg && mg->mg_ptr) { |
|
|
0
|
|
|
|
|
7785
|
0
|
|
|
|
|
*nxp = mg->mg_len; |
7786
|
0
|
|
|
|
|
return mg->mg_ptr + sizeof(PL_collation_ix); |
7787
|
|
|
|
|
|
} |
7788
|
|
|
|
|
|
else { |
7789
|
0
|
|
|
|
|
*nxp = 0; |
7790
|
0
|
|
|
|
|
return NULL; |
7791
|
|
|
|
|
|
} |
7792
|
|
|
|
|
|
} |
7793
|
|
|
|
|
|
|
7794
|
|
|
|
|
|
#endif /* USE_LOCALE_COLLATE */ |
7795
|
|
|
|
|
|
|
7796
|
|
|
|
|
|
static char * |
7797
|
14
|
|
|
|
|
S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append) |
7798
|
|
|
|
|
|
{ |
7799
|
14
|
|
|
|
|
SV * const tsv = newSV(0); |
7800
|
14
|
|
|
|
|
ENTER; |
7801
|
14
|
|
|
|
|
SAVEFREESV(tsv); |
7802
|
14
|
|
|
|
|
sv_gets(tsv, fp, 0); |
7803
|
10
|
|
|
|
|
sv_utf8_upgrade_nomg(tsv); |
7804
|
10
|
|
|
|
|
SvCUR_set(sv,append); |
7805
|
10
|
|
|
|
|
sv_catsv(sv,tsv); |
7806
|
10
|
|
|
|
|
LEAVE; |
7807
|
10
|
50
|
|
|
|
return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; |
7808
|
|
|
|
|
|
} |
7809
|
|
|
|
|
|
|
7810
|
|
|
|
|
|
static char * |
7811
|
4456
|
|
|
|
|
S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) |
7812
|
|
|
|
|
|
{ |
7813
|
|
|
|
|
|
SSize_t bytesread; |
7814
|
4456
|
50
|
|
|
|
const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ |
7815
|
|
|
|
|
|
/* Grab the size of the record we're getting */ |
7816
|
4456
|
50
|
|
|
|
char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; |
|
|
100
|
|
|
|
|
7817
|
|
|
|
|
|
|
7818
|
|
|
|
|
|
/* Go yank in */ |
7819
|
|
|
|
|
|
#ifdef VMS |
7820
|
|
|
|
|
|
#include |
7821
|
|
|
|
|
|
int fd; |
7822
|
|
|
|
|
|
Stat_t st; |
7823
|
|
|
|
|
|
|
7824
|
|
|
|
|
|
/* With a true, record-oriented file on VMS, we need to use read directly |
7825
|
|
|
|
|
|
* to ensure that we respect RMS record boundaries. The user is responsible |
7826
|
|
|
|
|
|
* for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum |
7827
|
|
|
|
|
|
* record size) field. N.B. This is likely to produce invalid results on |
7828
|
|
|
|
|
|
* varying-width character data when a record ends mid-character. |
7829
|
|
|
|
|
|
*/ |
7830
|
|
|
|
|
|
fd = PerlIO_fileno(fp); |
7831
|
|
|
|
|
|
if (fd != -1 |
7832
|
|
|
|
|
|
&& PerlLIO_fstat(fd, &st) == 0 |
7833
|
|
|
|
|
|
&& (st.st_fab_rfm == FAB$C_VAR |
7834
|
|
|
|
|
|
|| st.st_fab_rfm == FAB$C_VFC |
7835
|
|
|
|
|
|
|| st.st_fab_rfm == FAB$C_FIX)) { |
7836
|
|
|
|
|
|
|
7837
|
|
|
|
|
|
bytesread = PerlLIO_read(fd, buffer, recsize); |
7838
|
|
|
|
|
|
} |
7839
|
|
|
|
|
|
else /* in-memory file from PerlIO::Scalar |
7840
|
|
|
|
|
|
* or not a record-oriented file |
7841
|
|
|
|
|
|
*/ |
7842
|
|
|
|
|
|
#endif |
7843
|
|
|
|
|
|
{ |
7844
|
4456
|
|
|
|
|
bytesread = PerlIO_read(fp, buffer, recsize); |
7845
|
|
|
|
|
|
|
7846
|
|
|
|
|
|
/* At this point, the logic in sv_get() means that sv will |
7847
|
|
|
|
|
|
be treated as utf-8 if the handle is utf8. |
7848
|
|
|
|
|
|
*/ |
7849
|
4456
|
100
|
|
|
|
if (PerlIO_isutf8(fp) && bytesread > 0) { |
|
|
50
|
|
|
|
|
7850
|
12
|
|
|
|
|
char *bend = buffer + bytesread; |
7851
|
|
|
|
|
|
char *bufp = buffer; |
7852
|
|
|
|
|
|
size_t charcount = 0; |
7853
|
|
|
|
|
|
bool charstart = TRUE; |
7854
|
|
|
|
|
|
STRLEN skip = 0; |
7855
|
|
|
|
|
|
|
7856
|
40
|
100
|
|
|
|
while (charcount < recsize) { |
7857
|
|
|
|
|
|
/* count accumulated characters */ |
7858
|
70
|
100
|
|
|
|
while (bufp < bend) { |
7859
|
54
|
100
|
|
|
|
if (charstart) { |
7860
|
46
|
|
|
|
|
skip = UTF8SKIP(bufp); |
7861
|
|
|
|
|
|
} |
7862
|
54
|
100
|
|
|
|
if (bufp + skip > bend) { |
7863
|
|
|
|
|
|
/* partial at the end */ |
7864
|
|
|
|
|
|
charstart = FALSE; |
7865
|
|
|
|
|
|
break; |
7866
|
|
|
|
|
|
} |
7867
|
|
|
|
|
|
else { |
7868
|
44
|
|
|
|
|
++charcount; |
7869
|
44
|
|
|
|
|
bufp += skip; |
7870
|
|
|
|
|
|
charstart = TRUE; |
7871
|
|
|
|
|
|
} |
7872
|
|
|
|
|
|
} |
7873
|
|
|
|
|
|
|
7874
|
26
|
100
|
|
|
|
if (charcount < recsize) { |
7875
|
|
|
|
|
|
STRLEN readsize; |
7876
|
18
|
|
|
|
|
STRLEN bufp_offset = bufp - buffer; |
7877
|
|
|
|
|
|
SSize_t morebytesread; |
7878
|
|
|
|
|
|
|
7879
|
|
|
|
|
|
/* originally I read enough to fill any incomplete |
7880
|
|
|
|
|
|
character and the first byte of the next |
7881
|
|
|
|
|
|
character if needed, but if there's many |
7882
|
|
|
|
|
|
multi-byte encoded characters we're going to be |
7883
|
|
|
|
|
|
making a read call for every character beyond |
7884
|
|
|
|
|
|
the original read size. |
7885
|
|
|
|
|
|
|
7886
|
|
|
|
|
|
So instead, read the rest of the character if |
7887
|
|
|
|
|
|
any, and enough bytes to match at least the |
7888
|
|
|
|
|
|
start bytes for each character we're going to |
7889
|
|
|
|
|
|
read. |
7890
|
|
|
|
|
|
*/ |
7891
|
18
|
100
|
|
|
|
if (charstart) |
7892
|
8
|
|
|
|
|
readsize = recsize - charcount; |
7893
|
|
|
|
|
|
else |
7894
|
10
|
|
|
|
|
readsize = skip - (bend - bufp) + recsize - charcount - 1; |
7895
|
18
|
50
|
|
|
|
buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; |
|
|
50
|
|
|
|
|
7896
|
18
|
|
|
|
|
bend = buffer + bytesread; |
7897
|
18
|
|
|
|
|
morebytesread = PerlIO_read(fp, bend, readsize); |
7898
|
18
|
100
|
|
|
|
if (morebytesread <= 0) { |
7899
|
|
|
|
|
|
/* we're done, if we still have incomplete |
7900
|
|
|
|
|
|
characters the check code in sv_gets() will |
7901
|
|
|
|
|
|
warn about them. |
7902
|
|
|
|
|
|
|
7903
|
|
|
|
|
|
I'd originally considered doing |
7904
|
|
|
|
|
|
PerlIO_ungetc() on all but the lead |
7905
|
|
|
|
|
|
character of the incomplete character, but |
7906
|
|
|
|
|
|
read() doesn't do that, so I don't. |
7907
|
|
|
|
|
|
*/ |
7908
|
|
|
|
|
|
break; |
7909
|
|
|
|
|
|
} |
7910
|
|
|
|
|
|
|
7911
|
|
|
|
|
|
/* prepare to scan some more */ |
7912
|
14
|
|
|
|
|
bytesread += morebytesread; |
7913
|
14
|
|
|
|
|
bend = buffer + bytesread; |
7914
|
18
|
|
|
|
|
bufp = buffer + bufp_offset; |
7915
|
|
|
|
|
|
} |
7916
|
|
|
|
|
|
} |
7917
|
|
|
|
|
|
} |
7918
|
|
|
|
|
|
} |
7919
|
|
|
|
|
|
|
7920
|
4456
|
50
|
|
|
|
if (bytesread < 0) |
7921
|
|
|
|
|
|
bytesread = 0; |
7922
|
4456
|
|
|
|
|
SvCUR_set(sv, bytesread + append); |
7923
|
4456
|
|
|
|
|
buffer[bytesread] = '\0'; |
7924
|
4456
|
100
|
|
|
|
return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; |
7925
|
|
|
|
|
|
} |
7926
|
|
|
|
|
|
|
7927
|
|
|
|
|
|
/* |
7928
|
|
|
|
|
|
=for apidoc sv_gets |
7929
|
|
|
|
|
|
|
7930
|
|
|
|
|
|
Get a line from the filehandle and store it into the SV, optionally |
7931
|
|
|
|
|
|
appending to the currently-stored string. If C is not 0, the |
7932
|
|
|
|
|
|
line is appended to the SV instead of overwriting it. C should |
7933
|
|
|
|
|
|
be set to the byte offset that the appended string should start at |
7934
|
|
|
|
|
|
in the SV (typically, C is a suitable choice). |
7935
|
|
|
|
|
|
|
7936
|
|
|
|
|
|
=cut |
7937
|
|
|
|
|
|
*/ |
7938
|
|
|
|
|
|
|
7939
|
|
|
|
|
|
char * |
7940
|
224921090
|
|
|
|
|
Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) |
7941
|
224921090
|
100
|
|
|
|
{ |
7942
|
|
|
|
|
|
dVAR; |
7943
|
|
|
|
|
|
const char *rsptr; |
7944
|
|
|
|
|
|
STRLEN rslen; |
7945
|
|
|
|
|
|
STDCHAR rslast; |
7946
|
|
|
|
|
|
STDCHAR *bp; |
7947
|
|
|
|
|
|
I32 cnt; |
7948
|
|
|
|
|
|
I32 i = 0; |
7949
|
|
|
|
|
|
I32 rspara = 0; |
7950
|
|
|
|
|
|
|
7951
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_GETS; |
7952
|
|
|
|
|
|
|
7953
|
224921090
|
100
|
|
|
|
if (SvTHINKFIRST(sv)) |
7954
|
2716762
|
100
|
|
|
|
sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); |
7955
|
|
|
|
|
|
/* XXX. If you make this PVIV, then copy on write can copy scalars read |
7956
|
|
|
|
|
|
from <>. |
7957
|
|
|
|
|
|
However, perlbench says it's slower, because the existing swipe code |
7958
|
|
|
|
|
|
is faster than copy on write. |
7959
|
|
|
|
|
|
Swings and roundabouts. */ |
7960
|
108659411
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); |
7961
|
|
|
|
|
|
|
7962
|
224921090
|
100
|
|
|
|
if (append) { |
7963
|
6308500
|
100
|
|
|
|
if (PerlIO_isutf8(fp)) { |
7964
|
26
|
100
|
|
|
|
if (!SvUTF8(sv)) { |
7965
|
12
|
|
|
|
|
sv_utf8_upgrade_nomg(sv); |
7966
|
12
|
|
|
|
|
sv_pos_u2b(sv,&append,0); |
7967
|
|
|
|
|
|
} |
7968
|
6308474
|
100
|
|
|
|
} else if (SvUTF8(sv)) { |
7969
|
14
|
|
|
|
|
return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); |
7970
|
|
|
|
|
|
} |
7971
|
|
|
|
|
|
} |
7972
|
|
|
|
|
|
|
7973
|
224921076
|
|
|
|
|
SvPOK_only(sv); |
7974
|
224921076
|
100
|
|
|
|
if (!append) { |
7975
|
218612590
|
|
|
|
|
SvCUR_set(sv,0); |
7976
|
|
|
|
|
|
} |
7977
|
224921076
|
100
|
|
|
|
if (PerlIO_isutf8(fp)) |
7978
|
22286
|
|
|
|
|
SvUTF8_on(sv); |
7979
|
|
|
|
|
|
|
7980
|
224921076
|
100
|
|
|
|
if (IN_PERL_COMPILETIME) { |
7981
|
|
|
|
|
|
/* we always read code in line mode */ |
7982
|
|
|
|
|
|
rsptr = "\n"; |
7983
|
215402929
|
|
|
|
|
rslen = 1; |
7984
|
|
|
|
|
|
} |
7985
|
9558445
|
100
|
|
|
|
else if (RsSNARF(PL_rs)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
7986
|
|
|
|
|
|
/* If it is a regular disk file use size from stat() as estimate |
7987
|
|
|
|
|
|
of amount we are going to read -- may result in mallocing |
7988
|
|
|
|
|
|
more memory than we really need if the layers below reduce |
7989
|
|
|
|
|
|
the size we read (e.g. CRLF or a gzip layer). |
7990
|
|
|
|
|
|
*/ |
7991
|
|
|
|
|
|
Stat_t st; |
7992
|
80596
|
50
|
|
|
|
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { |
|
|
100
|
|
|
|
|
7993
|
15386
|
|
|
|
|
const Off_t offset = PerlIO_tell(fp); |
7994
|
15386
|
100
|
|
|
|
if (offset != (Off_t) -1 && st.st_size + append > offset) { |
|
|
100
|
|
|
|
|
7995
|
14316
|
50
|
|
|
|
(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); |
|
|
100
|
|
|
|
|
7996
|
|
|
|
|
|
} |
7997
|
|
|
|
|
|
} |
7998
|
|
|
|
|
|
rsptr = NULL; |
7999
|
40298
|
|
|
|
|
rslen = 0; |
8000
|
|
|
|
|
|
} |
8001
|
9477849
|
100
|
|
|
|
else if (RsRECORD(PL_rs)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
8002
|
4456
|
|
|
|
|
return S_sv_gets_read_record(aTHX_ sv, fp, append); |
8003
|
|
|
|
|
|
} |
8004
|
9473393
|
100
|
|
|
|
else if (RsPARA(PL_rs)) { |
|
|
100
|
|
|
|
|
8005
|
|
|
|
|
|
rsptr = "\n\n"; |
8006
|
332698
|
|
|
|
|
rslen = 2; |
8007
|
332698
|
|
|
|
|
rspara = 1; |
8008
|
|
|
|
|
|
} |
8009
|
|
|
|
|
|
else { |
8010
|
|
|
|
|
|
/* Get $/ i.e. PL_rs into same encoding as stream wants */ |
8011
|
9140695
|
100
|
|
|
|
if (PerlIO_isutf8(fp)) { |
8012
|
21534
|
100
|
|
|
|
rsptr = SvPVutf8(PL_rs, rslen); |
8013
|
|
|
|
|
|
} |
8014
|
|
|
|
|
|
else { |
8015
|
9119161
|
100
|
|
|
|
if (SvUTF8(PL_rs)) { |
8016
|
48
|
100
|
|
|
|
if (!sv_utf8_downgrade(PL_rs, TRUE)) { |
8017
|
4
|
|
|
|
|
Perl_croak(aTHX_ "Wide character in $/"); |
8018
|
|
|
|
|
|
} |
8019
|
|
|
|
|
|
} |
8020
|
9119157
|
100
|
|
|
|
rsptr = SvPV_const(PL_rs, rslen); |
8021
|
|
|
|
|
|
} |
8022
|
|
|
|
|
|
} |
8023
|
|
|
|
|
|
|
8024
|
224916616
|
100
|
|
|
|
rslast = rslen ? rsptr[rslen - 1] : '\0'; |
8025
|
|
|
|
|
|
|
8026
|
224916616
|
100
|
|
|
|
if (rspara) { /* have to do this both before and after */ |
8027
|
|
|
|
|
|
do { /* to make sure file boundaries work right */ |
8028
|
332908
|
100
|
|
|
|
if (PerlIO_eof(fp)) |
8029
|
|
|
|
|
|
return 0; |
8030
|
331228
|
|
|
|
|
i = PerlIO_getc(fp); |
8031
|
331228
|
100
|
|
|
|
if (i != '\n') { |
8032
|
331018
|
50
|
|
|
|
if (i == -1) |
8033
|
|
|
|
|
|
return 0; |
8034
|
331018
|
|
|
|
|
PerlIO_ungetc(fp,i); |
8035
|
331018
|
|
|
|
|
break; |
8036
|
|
|
|
|
|
} |
8037
|
210
|
50
|
|
|
|
} while (i != EOF); |
8038
|
|
|
|
|
|
} |
8039
|
|
|
|
|
|
|
8040
|
|
|
|
|
|
/* See if we know enough about I/O mechanism to cheat it ! */ |
8041
|
|
|
|
|
|
|
8042
|
|
|
|
|
|
/* This used to be #ifdef test - it is made run-time test for ease |
8043
|
|
|
|
|
|
of abstracting out stdio interface. One call should be cheap |
8044
|
|
|
|
|
|
enough here - and may even be a macro allowing compile |
8045
|
|
|
|
|
|
time optimization. |
8046
|
|
|
|
|
|
*/ |
8047
|
|
|
|
|
|
|
8048
|
224914936
|
100
|
|
|
|
if (PerlIO_fast_gets(fp)) { |
8049
|
|
|
|
|
|
|
8050
|
|
|
|
|
|
/* |
8051
|
|
|
|
|
|
* We're going to steal some values from the stdio struct |
8052
|
|
|
|
|
|
* and put EVERYTHING in the innermost loop into registers. |
8053
|
|
|
|
|
|
*/ |
8054
|
|
|
|
|
|
STDCHAR *ptr; |
8055
|
|
|
|
|
|
STRLEN bpx; |
8056
|
|
|
|
|
|
I32 shortbuffered; |
8057
|
|
|
|
|
|
|
8058
|
|
|
|
|
|
#if defined(VMS) && defined(PERLIO_IS_STDIO) |
8059
|
|
|
|
|
|
/* An ungetc()d char is handled separately from the regular |
8060
|
|
|
|
|
|
* buffer, so we getc() it back out and stuff it in the buffer. |
8061
|
|
|
|
|
|
*/ |
8062
|
|
|
|
|
|
i = PerlIO_getc(fp); |
8063
|
|
|
|
|
|
if (i == EOF) return 0; |
8064
|
|
|
|
|
|
*(--((*fp)->_ptr)) = (unsigned char) i; |
8065
|
|
|
|
|
|
(*fp)->_cnt++; |
8066
|
|
|
|
|
|
#endif |
8067
|
|
|
|
|
|
|
8068
|
|
|
|
|
|
/* Here is some breathtakingly efficient cheating */ |
8069
|
|
|
|
|
|
|
8070
|
224914920
|
|
|
|
|
cnt = PerlIO_get_cnt(fp); /* get count into register */ |
8071
|
|
|
|
|
|
/* make sure we have the room */ |
8072
|
224914920
|
100
|
|
|
|
if ((I32)(SvLEN(sv) - append) <= cnt + 1) { |
8073
|
|
|
|
|
|
/* Not room for all of it |
8074
|
|
|
|
|
|
if we are looking for a separator and room for some |
8075
|
|
|
|
|
|
*/ |
8076
|
6853665
|
100
|
|
|
|
if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { |
|
|
100
|
|
|
|
|
8077
|
|
|
|
|
|
/* just process what we have room for */ |
8078
|
4138301
|
|
|
|
|
shortbuffered = cnt - SvLEN(sv) + append + 1; |
8079
|
4138301
|
|
|
|
|
cnt -= shortbuffered; |
8080
|
|
|
|
|
|
} |
8081
|
|
|
|
|
|
else { |
8082
|
|
|
|
|
|
shortbuffered = 0; |
8083
|
|
|
|
|
|
/* remember that cnt can be negative */ |
8084
|
2715364
|
50
|
|
|
|
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8085
|
|
|
|
|
|
} |
8086
|
|
|
|
|
|
} |
8087
|
|
|
|
|
|
else |
8088
|
|
|
|
|
|
shortbuffered = 0; |
8089
|
224914920
|
|
|
|
|
bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */ |
8090
|
226909651
|
|
|
|
|
ptr = (STDCHAR*)PerlIO_get_ptr(fp); |
8091
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8092
|
|
|
|
|
|
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); |
8093
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8094
|
|
|
|
|
|
"Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", |
8095
|
|
|
|
|
|
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), |
8096
|
|
|
|
|
|
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); |
8097
|
|
|
|
|
|
for (;;) { |
8098
|
|
|
|
|
|
screamer: |
8099
|
228848413
|
100
|
|
|
|
if (cnt > 0) { |
8100
|
227291699
|
100
|
|
|
|
if (rslen) { |
8101
|
6481523933
|
100
|
|
|
|
while (cnt > 0) { /* this | eat */ |
8102
|
6480266449
|
|
|
|
|
cnt--; |
8103
|
6597696861
|
100
|
|
|
|
if ((*bp++ = *ptr++) == rslast) /* really | dust */ |
8104
|
|
|
|
|
|
goto thats_all_folks; /* screams | sed :-) */ |
8105
|
|
|
|
|
|
} |
8106
|
|
|
|
|
|
} |
8107
|
|
|
|
|
|
else { |
8108
|
61040
|
|
|
|
|
Copy(ptr, bp, cnt, char); /* this | eat */ |
8109
|
61040
|
|
|
|
|
bp += cnt; /* screams | dust */ |
8110
|
61040
|
|
|
|
|
ptr += cnt; /* louder | sed :-) */ |
8111
|
|
|
|
|
|
cnt = 0; |
8112
|
|
|
|
|
|
assert (!shortbuffered); |
8113
|
61040
|
|
|
|
|
goto cannot_be_shortbuffered; |
8114
|
|
|
|
|
|
} |
8115
|
|
|
|
|
|
} |
8116
|
|
|
|
|
|
|
8117
|
2814198
|
100
|
|
|
|
if (shortbuffered) { /* oh well, must extend */ |
8118
|
|
|
|
|
|
cnt = shortbuffered; |
8119
|
|
|
|
|
|
shortbuffered = 0; |
8120
|
649767
|
|
|
|
|
bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ |
8121
|
649767
|
|
|
|
|
SvCUR_set(sv, bpx); |
8122
|
649767
|
50
|
|
|
|
SvGROW(sv, SvLEN(sv) + append + cnt + 2); |
|
|
50
|
|
|
|
|
8123
|
649767
|
|
|
|
|
bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ |
8124
|
649767
|
|
|
|
|
continue; |
8125
|
|
|
|
|
|
} |
8126
|
|
|
|
|
|
|
8127
|
|
|
|
|
|
cannot_be_shortbuffered: |
8128
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8129
|
|
|
|
|
|
"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", |
8130
|
|
|
|
|
|
PTR2UV(ptr),(long)cnt)); |
8131
|
2225471
|
|
|
|
|
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ |
8132
|
|
|
|
|
|
|
8133
|
|
|
|
|
|
DEBUG_Pv(PerlIO_printf(Perl_debug_log, |
8134
|
|
|
|
|
|
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", |
8135
|
|
|
|
|
|
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), |
8136
|
|
|
|
|
|
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); |
8137
|
|
|
|
|
|
|
8138
|
|
|
|
|
|
/* This used to call 'filbuf' in stdio form, but as that behaves like |
8139
|
|
|
|
|
|
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing |
8140
|
|
|
|
|
|
another abstraction. */ |
8141
|
2225471
|
|
|
|
|
i = PerlIO_getc(fp); /* get more characters */ |
8142
|
|
|
|
|
|
|
8143
|
|
|
|
|
|
DEBUG_Pv(PerlIO_printf(Perl_debug_log, |
8144
|
|
|
|
|
|
"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", |
8145
|
|
|
|
|
|
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), |
8146
|
|
|
|
|
|
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); |
8147
|
|
|
|
|
|
|
8148
|
2225467
|
|
|
|
|
cnt = PerlIO_get_cnt(fp); |
8149
|
2225467
|
|
|
|
|
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ |
8150
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8151
|
|
|
|
|
|
"Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); |
8152
|
|
|
|
|
|
|
8153
|
2225467
|
100
|
|
|
|
if (i == EOF) /* all done for ever? */ |
8154
|
|
|
|
|
|
goto thats_really_all_folks; |
8155
|
|
|
|
|
|
|
8156
|
1955309
|
|
|
|
|
bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ |
8157
|
1955309
|
|
|
|
|
SvCUR_set(sv, bpx); |
8158
|
1955309
|
50
|
|
|
|
SvGROW(sv, bpx + cnt + 2); |
|
|
100
|
|
|
|
|
8159
|
1955309
|
|
|
|
|
bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ |
8160
|
|
|
|
|
|
|
8161
|
1955309
|
|
|
|
|
*bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ |
8162
|
|
|
|
|
|
|
8163
|
1955309
|
100
|
|
|
|
if (rslen && (STDCHAR)i == rslast) /* all done for now? */ |
|
|
100
|
|
|
|
|
8164
|
|
|
|
|
|
goto thats_all_folks; |
8165
|
|
|
|
|
|
} |
8166
|
|
|
|
|
|
|
8167
|
|
|
|
|
|
thats_all_folks: |
8168
|
335238738
|
100
|
|
|
|
if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8169
|
226024844
|
|
|
|
|
memNE((char*)bp - rslen, rsptr, rslen)) |
8170
|
|
|
|
|
|
goto screamer; /* go back to the fray */ |
8171
|
|
|
|
|
|
thats_really_all_folks: |
8172
|
224914916
|
100
|
|
|
|
if (shortbuffered) |
8173
|
3488273
|
|
|
|
|
cnt += shortbuffered; |
8174
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8175
|
|
|
|
|
|
"Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); |
8176
|
224914916
|
|
|
|
|
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ |
8177
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8178
|
|
|
|
|
|
"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", |
8179
|
|
|
|
|
|
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), |
8180
|
|
|
|
|
|
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); |
8181
|
224914916
|
|
|
|
|
*bp = '\0'; |
8182
|
224914924
|
|
|
|
|
SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ |
8183
|
|
|
|
|
|
DEBUG_P(PerlIO_printf(Perl_debug_log, |
8184
|
|
|
|
|
|
"Screamer: done, len=%ld, string=|%.*s|\n", |
8185
|
|
|
|
|
|
(long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); |
8186
|
|
|
|
|
|
} |
8187
|
|
|
|
|
|
else |
8188
|
|
|
|
|
|
{ |
8189
|
|
|
|
|
|
/*The big, slow, and stupid way. */ |
8190
|
|
|
|
|
|
#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ |
8191
|
|
|
|
|
|
STDCHAR *buf = NULL; |
8192
|
|
|
|
|
|
Newx(buf, 8192, STDCHAR); |
8193
|
|
|
|
|
|
assert(buf); |
8194
|
|
|
|
|
|
#else |
8195
|
|
|
|
|
|
STDCHAR buf[8192]; |
8196
|
|
|
|
|
|
#endif |
8197
|
|
|
|
|
|
|
8198
|
|
|
|
|
|
screamer2: |
8199
|
16
|
100
|
|
|
|
if (rslen) { |
8200
|
|
|
|
|
|
const STDCHAR * const bpe = buf + sizeof(buf); |
8201
|
|
|
|
|
|
bp = buf; |
8202
|
24
|
100
|
|
|
|
while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
8203
|
|
|
|
|
|
; /* keep reading */ |
8204
|
8
|
|
|
|
|
cnt = bp - buf; |
8205
|
|
|
|
|
|
} |
8206
|
|
|
|
|
|
else { |
8207
|
8
|
|
|
|
|
cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); |
8208
|
|
|
|
|
|
/* Accommodate broken VAXC compiler, which applies U8 cast to |
8209
|
|
|
|
|
|
* both args of ?: operator, causing EOF to change into 255 |
8210
|
|
|
|
|
|
*/ |
8211
|
8
|
100
|
|
|
|
if (cnt > 0) |
8212
|
4
|
|
|
|
|
i = (U8)buf[cnt - 1]; |
8213
|
|
|
|
|
|
else |
8214
|
|
|
|
|
|
i = EOF; |
8215
|
|
|
|
|
|
} |
8216
|
|
|
|
|
|
|
8217
|
16
|
50
|
|
|
|
if (cnt < 0) |
8218
|
|
|
|
|
|
cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ |
8219
|
16
|
50
|
|
|
|
if (append) |
8220
|
0
|
|
|
|
|
sv_catpvn_nomg(sv, (char *) buf, cnt); |
8221
|
|
|
|
|
|
else |
8222
|
16
|
|
|
|
|
sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */ |
8223
|
|
|
|
|
|
|
8224
|
19
|
100
|
|
|
|
if (i != EOF && /* joy */ |
|
|
100
|
|
|
|
|
8225
|
5
|
50
|
|
|
|
(!rslen || |
8226
|
3
|
50
|
|
|
|
SvCUR(sv) < rslen || |
8227
|
2
|
|
|
|
|
memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) |
8228
|
|
|
|
|
|
{ |
8229
|
4
|
|
|
|
|
append = -1; |
8230
|
|
|
|
|
|
/* |
8231
|
|
|
|
|
|
* If we're reading from a TTY and we get a short read, |
8232
|
|
|
|
|
|
* indicating that the user hit his EOF character, we need |
8233
|
|
|
|
|
|
* to notice it now, because if we try to read from the TTY |
8234
|
|
|
|
|
|
* again, the EOF condition will disappear. |
8235
|
|
|
|
|
|
* |
8236
|
|
|
|
|
|
* The comparison of cnt to sizeof(buf) is an optimization |
8237
|
|
|
|
|
|
* that prevents unnecessary calls to feof(). |
8238
|
|
|
|
|
|
* |
8239
|
|
|
|
|
|
* - jik 9/25/96 |
8240
|
|
|
|
|
|
*/ |
8241
|
4
|
50
|
|
|
|
if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) |
|
|
50
|
|
|
|
|
8242
|
|
|
|
|
|
goto screamer2; |
8243
|
|
|
|
|
|
} |
8244
|
|
|
|
|
|
|
8245
|
|
|
|
|
|
#ifdef USE_HEAP_INSTEAD_OF_STACK |
8246
|
|
|
|
|
|
Safefree(buf); |
8247
|
|
|
|
|
|
#endif |
8248
|
|
|
|
|
|
} |
8249
|
|
|
|
|
|
|
8250
|
224914932
|
100
|
|
|
|
if (rspara) { /* have to do this both before and after */ |
8251
|
338138
|
100
|
|
|
|
while (i != EOF) { /* to make sure file boundaries work right */ |
8252
|
336784
|
|
|
|
|
i = PerlIO_getc(fp); |
8253
|
336784
|
100
|
|
|
|
if (i != '\n') { |
8254
|
329664
|
|
|
|
|
PerlIO_ungetc(fp,i); |
8255
|
495173
|
|
|
|
|
break; |
8256
|
|
|
|
|
|
} |
8257
|
|
|
|
|
|
} |
8258
|
|
|
|
|
|
} |
8259
|
|
|
|
|
|
|
8260
|
224918005
|
100
|
|
|
|
return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; |
8261
|
|
|
|
|
|
} |
8262
|
|
|
|
|
|
|
8263
|
|
|
|
|
|
/* |
8264
|
|
|
|
|
|
=for apidoc sv_inc |
8265
|
|
|
|
|
|
|
8266
|
|
|
|
|
|
Auto-increment of the value in the SV, doing string to numeric conversion |
8267
|
|
|
|
|
|
if necessary. Handles 'get' magic and operator overloading. |
8268
|
|
|
|
|
|
|
8269
|
|
|
|
|
|
=cut |
8270
|
|
|
|
|
|
*/ |
8271
|
|
|
|
|
|
|
8272
|
|
|
|
|
|
void |
8273
|
3812452
|
|
|
|
|
Perl_sv_inc(pTHX_ SV *const sv) |
8274
|
3812452
|
100
|
|
|
|
{ |
8275
|
3812452
|
50
|
|
|
|
if (!sv) |
8276
|
3812428
|
|
|
|
|
return; |
8277
|
1877256
|
|
|
|
|
SvGETMAGIC(sv); |
8278
|
3812452
|
|
|
|
|
sv_inc_nomg(sv); |
8279
|
|
|
|
|
|
} |
8280
|
|
|
|
|
|
|
8281
|
|
|
|
|
|
/* |
8282
|
|
|
|
|
|
=for apidoc sv_inc_nomg |
8283
|
|
|
|
|
|
|
8284
|
|
|
|
|
|
Auto-increment of the value in the SV, doing string to numeric conversion |
8285
|
|
|
|
|
|
if necessary. Handles operator overloading. Skips handling 'get' magic. |
8286
|
|
|
|
|
|
|
8287
|
|
|
|
|
|
=cut |
8288
|
|
|
|
|
|
*/ |
8289
|
|
|
|
|
|
|
8290
|
|
|
|
|
|
void |
8291
|
17086394
|
|
|
|
|
Perl_sv_inc_nomg(pTHX_ SV *const sv) |
8292
|
|
|
|
|
|
{ |
8293
|
|
|
|
|
|
dVAR; |
8294
|
|
|
|
|
|
char *d; |
8295
|
|
|
|
|
|
int flags; |
8296
|
|
|
|
|
|
|
8297
|
17086394
|
50
|
|
|
|
if (!sv) |
8298
|
|
|
|
|
|
return; |
8299
|
17086394
|
100
|
|
|
|
if (SvTHINKFIRST(sv)) { |
8300
|
235432
|
100
|
|
|
|
if (SvREADONLY(sv)) { |
8301
|
4
|
|
|
|
|
Perl_croak_no_modify(); |
8302
|
|
|
|
|
|
} |
8303
|
235428
|
100
|
|
|
|
if (SvROK(sv)) { |
8304
|
|
|
|
|
|
IV i; |
8305
|
208
|
50
|
|
|
|
if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
8306
|
|
|
|
|
|
return; |
8307
|
2
|
|
|
|
|
i = PTR2IV(SvRV(sv)); |
8308
|
2
|
|
|
|
|
sv_unref(sv); |
8309
|
2
|
|
|
|
|
sv_setiv(sv, i); |
8310
|
|
|
|
|
|
} |
8311
|
235220
|
|
|
|
|
else sv_force_normal_flags(sv, 0); |
8312
|
|
|
|
|
|
} |
8313
|
17086184
|
|
|
|
|
flags = SvFLAGS(sv); |
8314
|
17086184
|
100
|
|
|
|
if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { |
8315
|
|
|
|
|
|
/* It's (privately or publicly) a float, but not tested as an |
8316
|
|
|
|
|
|
integer, so test it to see. */ |
8317
|
2568264
|
50
|
|
|
|
(void) SvIV(sv); |
8318
|
2568264
|
|
|
|
|
flags = SvFLAGS(sv); |
8319
|
|
|
|
|
|
} |
8320
|
17086184
|
100
|
|
|
|
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { |
|
|
50
|
|
|
|
|
8321
|
|
|
|
|
|
/* It's publicly an integer, or privately an integer-not-float */ |
8322
|
|
|
|
|
|
#ifdef PERL_PRESERVE_IVUV |
8323
|
|
|
|
|
|
oops_its_int: |
8324
|
|
|
|
|
|
#endif |
8325
|
4403608
|
100
|
|
|
|
if (SvIsUV(sv)) { |
8326
|
2692
|
100
|
|
|
|
if (SvUVX(sv) == UV_MAX) |
8327
|
778
|
|
|
|
|
sv_setnv(sv, UV_MAX_P1); |
8328
|
|
|
|
|
|
else |
8329
|
1914
|
50
|
|
|
|
(void)SvIOK_only_UV(sv); |
8330
|
2692
|
|
|
|
|
SvUV_set(sv, SvUVX(sv) + 1); |
8331
|
|
|
|
|
|
} else { |
8332
|
4400916
|
100
|
|
|
|
if (SvIVX(sv) == IV_MAX) |
8333
|
4
|
|
|
|
|
sv_setuv(sv, (UV)IV_MAX + 1); |
8334
|
|
|
|
|
|
else { |
8335
|
4400912
|
50
|
|
|
|
(void)SvIOK_only(sv); |
8336
|
4400912
|
|
|
|
|
SvIV_set(sv, SvIVX(sv) + 1); |
8337
|
|
|
|
|
|
} |
8338
|
|
|
|
|
|
} |
8339
|
|
|
|
|
|
return; |
8340
|
|
|
|
|
|
} |
8341
|
12683338
|
100
|
|
|
|
if (flags & SVp_NOK) { |
8342
|
1104
|
|
|
|
|
const NV was = SvNVX(sv); |
8343
|
1104
|
100
|
|
|
|
if (NV_OVERFLOWS_INTEGERS_AT && |
8344
|
|
|
|
|
|
was >= NV_OVERFLOWS_INTEGERS_AT) { |
8345
|
|
|
|
|
|
/* diag_listed_as: Lost precision when %s %f by 1 */ |
8346
|
232
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), |
8347
|
|
|
|
|
|
"Lost precision when incrementing %" NVff " by 1", |
8348
|
|
|
|
|
|
was); |
8349
|
|
|
|
|
|
} |
8350
|
1104
|
50
|
|
|
|
(void)SvNOK_only(sv); |
8351
|
1104
|
|
|
|
|
SvNV_set(sv, was + 1.0); |
8352
|
1104
|
|
|
|
|
return; |
8353
|
|
|
|
|
|
} |
8354
|
|
|
|
|
|
|
8355
|
12682234
|
100
|
|
|
|
if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { |
|
|
100
|
|
|
|
|
8356
|
12600906
|
100
|
|
|
|
if ((flags & SVTYPEMASK) < SVt_PVIV) |
8357
|
12600214
|
100
|
|
|
|
sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); |
8358
|
12600906
|
50
|
|
|
|
(void)SvIOK_only(sv); |
8359
|
12600906
|
|
|
|
|
SvIV_set(sv, 1); |
8360
|
12600906
|
|
|
|
|
return; |
8361
|
|
|
|
|
|
} |
8362
|
81328
|
|
|
|
|
d = SvPVX(sv); |
8363
|
148794
|
100
|
|
|
|
while (isALPHA(*d)) d++; |
8364
|
162822
|
100
|
|
|
|
while (isDIGIT(*d)) d++; |
8365
|
81328
|
100
|
|
|
|
if (d < SvEND(sv)) { |
8366
|
1450
|
|
|
|
|
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); |
8367
|
|
|
|
|
|
#ifdef PERL_PRESERVE_IVUV |
8368
|
|
|
|
|
|
/* Got to punt this as an integer if needs be, but we don't issue |
8369
|
|
|
|
|
|
warnings. Probably ought to make the sv_iv_please() that does |
8370
|
|
|
|
|
|
the conversion if possible, and silently. */ |
8371
|
1450
|
100
|
|
|
|
if (numtype && !(numtype & IS_NUMBER_INFINITY)) { |
|
|
50
|
|
|
|
|
8372
|
|
|
|
|
|
/* Need to try really hard to see if it's an integer. |
8373
|
|
|
|
|
|
9.22337203685478e+18 is an integer. |
8374
|
|
|
|
|
|
but "9.22337203685478e+18" + 0 is UV=9223372036854779904 |
8375
|
|
|
|
|
|
so $a="9.22337203685478e+18"; $a+0; $a++ |
8376
|
|
|
|
|
|
needs to be the same as $a="9.22337203685478e+18"; $a++ |
8377
|
|
|
|
|
|
or we go insane. */ |
8378
|
|
|
|
|
|
|
8379
|
1434
|
|
|
|
|
(void) sv_2iv(sv); |
8380
|
1434
|
100
|
|
|
|
if (SvIOK(sv)) |
8381
|
|
|
|
|
|
goto oops_its_int; |
8382
|
|
|
|
|
|
|
8383
|
|
|
|
|
|
/* sv_2iv *should* have made this an NV */ |
8384
|
672
|
50
|
|
|
|
if (flags & SVp_NOK) { |
8385
|
0
|
0
|
|
|
|
(void)SvNOK_only(sv); |
8386
|
0
|
|
|
|
|
SvNV_set(sv, SvNVX(sv) + 1.0); |
8387
|
0
|
|
|
|
|
return; |
8388
|
|
|
|
|
|
} |
8389
|
|
|
|
|
|
/* I don't think we can get here. Maybe I should assert this |
8390
|
|
|
|
|
|
And if we do get here I suspect that sv_setnv will croak. NWC |
8391
|
|
|
|
|
|
Fall through. */ |
8392
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
8393
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", |
8394
|
|
|
|
|
|
SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); |
8395
|
|
|
|
|
|
#else |
8396
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", |
8397
|
|
|
|
|
|
SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); |
8398
|
|
|
|
|
|
#endif |
8399
|
|
|
|
|
|
} |
8400
|
|
|
|
|
|
#endif /* PERL_PRESERVE_IVUV */ |
8401
|
688
|
100
|
|
|
|
if (!numtype && ckWARN(WARN_NUMERIC)) |
|
|
100
|
|
|
|
|
8402
|
|
|
|
|
|
not_incrementable(sv); |
8403
|
688
|
|
|
|
|
sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); |
8404
|
688
|
|
|
|
|
return; |
8405
|
|
|
|
|
|
} |
8406
|
79878
|
|
|
|
|
d--; |
8407
|
123891
|
100
|
|
|
|
while (d >= SvPVX_const(sv)) { |
8408
|
83920
|
100
|
|
|
|
if (isDIGIT(*d)) { |
8409
|
26504
|
100
|
|
|
|
if (++*d <= '9') |
8410
|
|
|
|
|
|
return; |
8411
|
2498
|
|
|
|
|
*(d--) = '0'; |
8412
|
|
|
|
|
|
} |
8413
|
|
|
|
|
|
else { |
8414
|
|
|
|
|
|
#ifdef EBCDIC |
8415
|
|
|
|
|
|
/* MKS: The original code here died if letters weren't consecutive. |
8416
|
|
|
|
|
|
* at least it didn't have to worry about non-C locales. The |
8417
|
|
|
|
|
|
* new code assumes that ('z'-'a')==('Z'-'A'), letters are |
8418
|
|
|
|
|
|
* arranged in order (although not consecutively) and that only |
8419
|
|
|
|
|
|
* [A-Za-z] are accepted by isALPHA in the C locale. |
8420
|
|
|
|
|
|
*/ |
8421
|
|
|
|
|
|
if (*d != 'z' && *d != 'Z') { |
8422
|
|
|
|
|
|
do { ++*d; } while (!isALPHA(*d)); |
8423
|
|
|
|
|
|
return; |
8424
|
|
|
|
|
|
} |
8425
|
|
|
|
|
|
*(d--) -= 'z' - 'a'; |
8426
|
|
|
|
|
|
#else |
8427
|
57416
|
|
|
|
|
++*d; |
8428
|
57416
|
100
|
|
|
|
if (isALPHA(*d)) |
8429
|
|
|
|
|
|
return; |
8430
|
2825
|
|
|
|
|
*(d--) -= 'z' - 'a' + 1; |
8431
|
|
|
|
|
|
#endif |
8432
|
|
|
|
|
|
} |
8433
|
|
|
|
|
|
} |
8434
|
|
|
|
|
|
/* oh,oh, the number grew */ |
8435
|
32
|
50
|
|
|
|
SvGROW(sv, SvCUR(sv) + 2); |
|
|
50
|
|
|
|
|
8436
|
32
|
|
|
|
|
SvCUR_set(sv, SvCUR(sv) + 1); |
8437
|
154
|
100
|
|
|
|
for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) |
8438
|
122
|
|
|
|
|
*d = d[-1]; |
8439
|
32
|
100
|
|
|
|
if (isDIGIT(d[1])) |
8440
|
12
|
|
|
|
|
*d = '1'; |
8441
|
|
|
|
|
|
else |
8442
|
8573255
|
|
|
|
|
*d = d[1]; |
8443
|
|
|
|
|
|
} |
8444
|
|
|
|
|
|
|
8445
|
|
|
|
|
|
/* |
8446
|
|
|
|
|
|
=for apidoc sv_dec |
8447
|
|
|
|
|
|
|
8448
|
|
|
|
|
|
Auto-decrement of the value in the SV, doing string to numeric conversion |
8449
|
|
|
|
|
|
if necessary. Handles 'get' magic and operator overloading. |
8450
|
|
|
|
|
|
|
8451
|
|
|
|
|
|
=cut |
8452
|
|
|
|
|
|
*/ |
8453
|
|
|
|
|
|
|
8454
|
|
|
|
|
|
void |
8455
|
30340
|
|
|
|
|
Perl_sv_dec(pTHX_ SV *const sv) |
8456
|
30340
|
100
|
|
|
|
{ |
8457
|
|
|
|
|
|
dVAR; |
8458
|
30340
|
50
|
|
|
|
if (!sv) |
8459
|
30320
|
|
|
|
|
return; |
8460
|
15216
|
|
|
|
|
SvGETMAGIC(sv); |
8461
|
30340
|
|
|
|
|
sv_dec_nomg(sv); |
8462
|
|
|
|
|
|
} |
8463
|
|
|
|
|
|
|
8464
|
|
|
|
|
|
/* |
8465
|
|
|
|
|
|
=for apidoc sv_dec_nomg |
8466
|
|
|
|
|
|
|
8467
|
|
|
|
|
|
Auto-decrement of the value in the SV, doing string to numeric conversion |
8468
|
|
|
|
|
|
if necessary. Handles operator overloading. Skips handling 'get' magic. |
8469
|
|
|
|
|
|
|
8470
|
|
|
|
|
|
=cut |
8471
|
|
|
|
|
|
*/ |
8472
|
|
|
|
|
|
|
8473
|
|
|
|
|
|
void |
8474
|
107516
|
|
|
|
|
Perl_sv_dec_nomg(pTHX_ SV *const sv) |
8475
|
|
|
|
|
|
{ |
8476
|
|
|
|
|
|
dVAR; |
8477
|
|
|
|
|
|
int flags; |
8478
|
|
|
|
|
|
|
8479
|
107516
|
50
|
|
|
|
if (!sv) |
8480
|
|
|
|
|
|
return; |
8481
|
107516
|
100
|
|
|
|
if (SvTHINKFIRST(sv)) { |
8482
|
76456
|
50
|
|
|
|
if (SvREADONLY(sv)) { |
8483
|
0
|
|
|
|
|
Perl_croak_no_modify(); |
8484
|
|
|
|
|
|
} |
8485
|
76456
|
100
|
|
|
|
if (SvROK(sv)) { |
8486
|
|
|
|
|
|
IV i; |
8487
|
258
|
50
|
|
|
|
if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
8488
|
|
|
|
|
|
return; |
8489
|
2
|
|
|
|
|
i = PTR2IV(SvRV(sv)); |
8490
|
2
|
|
|
|
|
sv_unref(sv); |
8491
|
2
|
|
|
|
|
sv_setiv(sv, i); |
8492
|
|
|
|
|
|
} |
8493
|
76198
|
|
|
|
|
else sv_force_normal_flags(sv, 0); |
8494
|
|
|
|
|
|
} |
8495
|
|
|
|
|
|
/* Unlike sv_inc we don't have to worry about string-never-numbers |
8496
|
|
|
|
|
|
and keeping them magic. But we mustn't warn on punting */ |
8497
|
107260
|
|
|
|
|
flags = SvFLAGS(sv); |
8498
|
107260
|
100
|
|
|
|
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { |
|
|
50
|
|
|
|
|
8499
|
|
|
|
|
|
/* It's publicly an integer, or privately an integer-not-float */ |
8500
|
|
|
|
|
|
#ifdef PERL_PRESERVE_IVUV |
8501
|
|
|
|
|
|
oops_its_int: |
8502
|
|
|
|
|
|
#endif |
8503
|
104702
|
100
|
|
|
|
if (SvIsUV(sv)) { |
8504
|
3264
|
50
|
|
|
|
if (SvUVX(sv) == 0) { |
8505
|
0
|
0
|
|
|
|
(void)SvIOK_only(sv); |
8506
|
0
|
|
|
|
|
SvIV_set(sv, -1); |
8507
|
|
|
|
|
|
} |
8508
|
|
|
|
|
|
else { |
8509
|
3264
|
50
|
|
|
|
(void)SvIOK_only_UV(sv); |
8510
|
3264
|
|
|
|
|
SvUV_set(sv, SvUVX(sv) - 1); |
8511
|
|
|
|
|
|
} |
8512
|
|
|
|
|
|
} else { |
8513
|
101438
|
100
|
|
|
|
if (SvIVX(sv) == IV_MIN) { |
8514
|
1364
|
|
|
|
|
sv_setnv(sv, (NV)IV_MIN); |
8515
|
1364
|
|
|
|
|
goto oops_its_num; |
8516
|
|
|
|
|
|
} |
8517
|
|
|
|
|
|
else { |
8518
|
100074
|
50
|
|
|
|
(void)SvIOK_only(sv); |
8519
|
100074
|
|
|
|
|
SvIV_set(sv, SvIVX(sv) - 1); |
8520
|
|
|
|
|
|
} |
8521
|
|
|
|
|
|
} |
8522
|
|
|
|
|
|
return; |
8523
|
|
|
|
|
|
} |
8524
|
4662
|
100
|
|
|
|
if (flags & SVp_NOK) { |
8525
|
|
|
|
|
|
oops_its_num: |
8526
|
|
|
|
|
|
{ |
8527
|
3206
|
|
|
|
|
const NV was = SvNVX(sv); |
8528
|
3206
|
100
|
|
|
|
if (NV_OVERFLOWS_INTEGERS_AT && |
8529
|
|
|
|
|
|
was <= -NV_OVERFLOWS_INTEGERS_AT) { |
8530
|
|
|
|
|
|
/* diag_listed_as: Lost precision when %s %f by 1 */ |
8531
|
2020
|
|
|
|
|
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), |
8532
|
|
|
|
|
|
"Lost precision when decrementing %" NVff " by 1", |
8533
|
|
|
|
|
|
was); |
8534
|
|
|
|
|
|
} |
8535
|
3206
|
50
|
|
|
|
(void)SvNOK_only(sv); |
8536
|
3206
|
|
|
|
|
SvNV_set(sv, was - 1.0); |
8537
|
3206
|
|
|
|
|
return; |
8538
|
|
|
|
|
|
} |
8539
|
|
|
|
|
|
} |
8540
|
2820
|
100
|
|
|
|
if (!(flags & SVp_POK)) { |
8541
|
30
|
100
|
|
|
|
if ((flags & SVTYPEMASK) < SVt_PVIV) |
8542
|
22
|
100
|
|
|
|
sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); |
8543
|
30
|
|
|
|
|
SvIV_set(sv, -1); |
8544
|
30
|
50
|
|
|
|
(void)SvIOK_only(sv); |
8545
|
30
|
|
|
|
|
return; |
8546
|
|
|
|
|
|
} |
8547
|
|
|
|
|
|
#ifdef PERL_PRESERVE_IVUV |
8548
|
|
|
|
|
|
{ |
8549
|
2790
|
|
|
|
|
const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); |
8550
|
2790
|
100
|
|
|
|
if (numtype && !(numtype & IS_NUMBER_INFINITY)) { |
|
|
50
|
|
|
|
|
8551
|
|
|
|
|
|
/* Need to try really hard to see if it's an integer. |
8552
|
|
|
|
|
|
9.22337203685478e+18 is an integer. |
8553
|
|
|
|
|
|
but "9.22337203685478e+18" + 0 is UV=9223372036854779904 |
8554
|
|
|
|
|
|
so $a="9.22337203685478e+18"; $a+0; $a-- |
8555
|
|
|
|
|
|
needs to be the same as $a="9.22337203685478e+18"; $a-- |
8556
|
|
|
|
|
|
or we go insane. */ |
8557
|
|
|
|
|
|
|
8558
|
2776
|
|
|
|
|
(void) sv_2iv(sv); |
8559
|
2776
|
100
|
|
|
|
if (SvIOK(sv)) |
8560
|
|
|
|
|
|
goto oops_its_int; |
8561
|
|
|
|
|
|
|
8562
|
|
|
|
|
|
/* sv_2iv *should* have made this an NV */ |
8563
|
672
|
50
|
|
|
|
if (flags & SVp_NOK) { |
8564
|
0
|
0
|
|
|
|
(void)SvNOK_only(sv); |
8565
|
0
|
|
|
|
|
SvNV_set(sv, SvNVX(sv) - 1.0); |
8566
|
0
|
|
|
|
|
return; |
8567
|
|
|
|
|
|
} |
8568
|
|
|
|
|
|
/* I don't think we can get here. Maybe I should assert this |
8569
|
|
|
|
|
|
And if we do get here I suspect that sv_setnv will croak. NWC |
8570
|
|
|
|
|
|
Fall through. */ |
8571
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
8572
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", |
8573
|
|
|
|
|
|
SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); |
8574
|
|
|
|
|
|
#else |
8575
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", |
8576
|
|
|
|
|
|
SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); |
8577
|
|
|
|
|
|
#endif |
8578
|
|
|
|
|
|
} |
8579
|
|
|
|
|
|
} |
8580
|
|
|
|
|
|
#endif /* PERL_PRESERVE_IVUV */ |
8581
|
54091
|
|
|
|
|
sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ |
8582
|
|
|
|
|
|
} |
8583
|
|
|
|
|
|
|
8584
|
|
|
|
|
|
/* this define is used to eliminate a chunk of duplicated but shared logic |
8585
|
|
|
|
|
|
* it has the suffix __SV_C to signal that it isnt API, and isnt meant to be |
8586
|
|
|
|
|
|
* used anywhere but here - yves |
8587
|
|
|
|
|
|
*/ |
8588
|
|
|
|
|
|
#define PUSH_EXTEND_MORTAL__SV_C(AnSv) \ |
8589
|
|
|
|
|
|
STMT_START { \ |
8590
|
|
|
|
|
|
EXTEND_MORTAL(1); \ |
8591
|
|
|
|
|
|
PL_tmps_stack[++PL_tmps_ix] = (AnSv); \ |
8592
|
|
|
|
|
|
} STMT_END |
8593
|
|
|
|
|
|
|
8594
|
|
|
|
|
|
/* |
8595
|
|
|
|
|
|
=for apidoc sv_mortalcopy |
8596
|
|
|
|
|
|
|
8597
|
|
|
|
|
|
Creates a new SV which is a copy of the original SV (using C). |
8598
|
|
|
|
|
|
The new SV is marked as mortal. It will be destroyed "soon", either by an |
8599
|
|
|
|
|
|
explicit call to FREETMPS, or by an implicit call at places such as |
8600
|
|
|
|
|
|
statement boundaries. See also C and C. |
8601
|
|
|
|
|
|
|
8602
|
|
|
|
|
|
=cut |
8603
|
|
|
|
|
|
*/ |
8604
|
|
|
|
|
|
|
8605
|
|
|
|
|
|
/* Make a string that will exist for the duration of the expression |
8606
|
|
|
|
|
|
* evaluation. Actually, it may have to last longer than that, but |
8607
|
|
|
|
|
|
* hopefully we won't free it until it has been assigned to a |
8608
|
|
|
|
|
|
* permanent location. */ |
8609
|
|
|
|
|
|
|
8610
|
|
|
|
|
|
SV * |
8611
|
383562987
|
|
|
|
|
Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) |
8612
|
|
|
|
|
|
{ |
8613
|
|
|
|
|
|
dVAR; |
8614
|
|
|
|
|
|
SV *sv; |
8615
|
|
|
|
|
|
|
8616
|
575134761
|
50
|
|
|
|
if (flags & SV_GMAGIC) |
|
|
100
|
|
|
|
|
8617
|
191975916
|
|
|
|
|
SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ |
8618
|
383562959
|
100
|
|
|
|
new_SV(sv); |
8619
|
383562959
|
|
|
|
|
sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC); |
8620
|
383562959
|
100
|
|
|
|
PUSH_EXTEND_MORTAL__SV_C(sv); |
8621
|
383562959
|
|
|
|
|
SvTEMP_on(sv); |
8622
|
383562959
|
|
|
|
|
return sv; |
8623
|
|
|
|
|
|
} |
8624
|
|
|
|
|
|
|
8625
|
|
|
|
|
|
/* |
8626
|
|
|
|
|
|
=for apidoc sv_newmortal |
8627
|
|
|
|
|
|
|
8628
|
|
|
|
|
|
Creates a new null SV which is mortal. The reference count of the SV is |
8629
|
|
|
|
|
|
set to 1. It will be destroyed "soon", either by an explicit call to |
8630
|
|
|
|
|
|
FREETMPS, or by an implicit call at places such as statement boundaries. |
8631
|
|
|
|
|
|
See also C and C. |
8632
|
|
|
|
|
|
|
8633
|
|
|
|
|
|
=cut |
8634
|
|
|
|
|
|
*/ |
8635
|
|
|
|
|
|
|
8636
|
|
|
|
|
|
SV * |
8637
|
657288811
|
|
|
|
|
Perl_sv_newmortal(pTHX) |
8638
|
|
|
|
|
|
{ |
8639
|
|
|
|
|
|
dVAR; |
8640
|
|
|
|
|
|
SV *sv; |
8641
|
|
|
|
|
|
|
8642
|
657288811
|
100
|
|
|
|
new_SV(sv); |
8643
|
657288811
|
|
|
|
|
SvFLAGS(sv) = SVs_TEMP; |
8644
|
657288811
|
100
|
|
|
|
PUSH_EXTEND_MORTAL__SV_C(sv); |
8645
|
657288811
|
|
|
|
|
return sv; |
8646
|
|
|
|
|
|
} |
8647
|
|
|
|
|
|
|
8648
|
|
|
|
|
|
|
8649
|
|
|
|
|
|
/* |
8650
|
|
|
|
|
|
=for apidoc newSVpvn_flags |
8651
|
|
|
|
|
|
|
8652
|
|
|
|
|
|
Creates a new SV and copies a string into it. The reference count for the |
8653
|
|
|
|
|
|
SV is set to 1. Note that if C is zero, Perl will create a zero length |
8654
|
|
|
|
|
|
string. You are responsible for ensuring that the source string is at least |
8655
|
|
|
|
|
|
C bytes long. If the C argument is NULL the new SV will be undefined. |
8656
|
|
|
|
|
|
Currently the only flag bits accepted are C and C. |
8657
|
|
|
|
|
|
If C is set, then C is called on the result before |
8658
|
|
|
|
|
|
returning. If C is set, C |
8659
|
|
|
|
|
|
is considered to be in UTF-8 and the |
8660
|
|
|
|
|
|
C flag will be set on the new SV. |
8661
|
|
|
|
|
|
C is a convenience wrapper for this function, defined as |
8662
|
|
|
|
|
|
|
8663
|
|
|
|
|
|
#define newSVpvn_utf8(s, len, u) \ |
8664
|
|
|
|
|
|
newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) |
8665
|
|
|
|
|
|
|
8666
|
|
|
|
|
|
=cut |
8667
|
|
|
|
|
|
*/ |
8668
|
|
|
|
|
|
|
8669
|
|
|
|
|
|
SV * |
8670
|
216553523
|
|
|
|
|
Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) |
8671
|
|
|
|
|
|
{ |
8672
|
|
|
|
|
|
dVAR; |
8673
|
|
|
|
|
|
SV *sv; |
8674
|
|
|
|
|
|
|
8675
|
|
|
|
|
|
/* All the flags we don't support must be zero. |
8676
|
|
|
|
|
|
And we're new code so I'm going to assert this from the start. */ |
8677
|
|
|
|
|
|
assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); |
8678
|
216553523
|
100
|
|
|
|
new_SV(sv); |
8679
|
216553523
|
|
|
|
|
sv_setpvn(sv,s,len); |
8680
|
|
|
|
|
|
|
8681
|
|
|
|
|
|
/* This code used to do a sv_2mortal(), however we now unroll the call to |
8682
|
|
|
|
|
|
* sv_2mortal() and do what it does ourselves here. Since we have asserted |
8683
|
|
|
|
|
|
* that flags can only have the SVf_UTF8 and/or SVs_TEMP flags set above we |
8684
|
|
|
|
|
|
* can use it to enable the sv flags directly (bypassing SvTEMP_on), which |
8685
|
|
|
|
|
|
* in turn means we dont need to mask out the SVf_UTF8 flag below, which |
8686
|
|
|
|
|
|
* means that we eliminate quite a few steps than it looks - Yves |
8687
|
|
|
|
|
|
* (explaining patch by gfx) */ |
8688
|
|
|
|
|
|
|
8689
|
216553523
|
|
|
|
|
SvFLAGS(sv) |= flags; |
8690
|
|
|
|
|
|
|
8691
|
216553523
|
100
|
|
|
|
if(flags & SVs_TEMP){ |
8692
|
84595689
|
100
|
|
|
|
PUSH_EXTEND_MORTAL__SV_C(sv); |
8693
|
|
|
|
|
|
} |
8694
|
|
|
|
|
|
|
8695
|
216553523
|
|
|
|
|
return sv; |
8696
|
|
|
|
|
|
} |
8697
|
|
|
|
|
|
|
8698
|
|
|
|
|
|
/* |
8699
|
|
|
|
|
|
=for apidoc sv_2mortal |
8700
|
|
|
|
|
|
|
8701
|
|
|
|
|
|
Marks an existing SV as mortal. The SV will be destroyed "soon", either |
8702
|
|
|
|
|
|
by an explicit call to FREETMPS, or by an implicit call at places such as |
8703
|
|
|
|
|
|
statement boundaries. SvTEMP() is turned on which means that the SV's |
8704
|
|
|
|
|
|
string buffer can be "stolen" if this SV is copied. See also C |
8705
|
|
|
|
|
|
and C. |
8706
|
|
|
|
|
|
|
8707
|
|
|
|
|
|
=cut |
8708
|
|
|
|
|
|
*/ |
8709
|
|
|
|
|
|
|
8710
|
|
|
|
|
|
SV * |
8711
|
456497214
|
|
|
|
|
Perl_sv_2mortal(pTHX_ SV *const sv) |
8712
|
|
|
|
|
|
{ |
8713
|
|
|
|
|
|
dVAR; |
8714
|
456497214
|
100
|
|
|
|
if (!sv) |
8715
|
|
|
|
|
|
return NULL; |
8716
|
456484722
|
100
|
|
|
|
if (SvIMMORTAL(sv)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
8717
|
|
|
|
|
|
return sv; |
8718
|
439612180
|
100
|
|
|
|
PUSH_EXTEND_MORTAL__SV_C(sv); |
8719
|
439612180
|
|
|
|
|
SvTEMP_on(sv); |
8720
|
448055926
|
|
|
|
|
return sv; |
8721
|
|
|
|
|
|
} |
8722
|
|
|
|
|
|
|
8723
|
|
|
|
|
|
/* |
8724
|
|
|
|
|
|
=for apidoc newSVpv |
8725
|
|
|
|
|
|
|
8726
|
|
|
|
|
|
Creates a new SV and copies a string into it. The reference count for the |
8727
|
|
|
|
|
|
SV is set to 1. If C is zero, Perl will compute the length using |
8728
|
|
|
|
|
|
strlen(). For efficiency, consider using C instead. |
8729
|
|
|
|
|
|
|
8730
|
|
|
|
|
|
=cut |
8731
|
|
|
|
|
|
*/ |
8732
|
|
|
|
|
|
|
8733
|
|
|
|
|
|
SV * |
8734
|
97702044
|
|
|
|
|
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) |
8735
|
|
|
|
|
|
{ |
8736
|
|
|
|
|
|
dVAR; |
8737
|
|
|
|
|
|
SV *sv; |
8738
|
|
|
|
|
|
|
8739
|
97702044
|
100
|
|
|
|
new_SV(sv); |
8740
|
97702044
|
100
|
|
|
|
sv_setpvn(sv, s, len || s == NULL ? len : strlen(s)); |
8741
|
97702044
|
|
|
|
|
return sv; |
8742
|
|
|
|
|
|
} |
8743
|
|
|
|
|
|
|
8744
|
|
|
|
|
|
/* |
8745
|
|
|
|
|
|
=for apidoc newSVpvn |
8746
|
|
|
|
|
|
|
8747
|
|
|
|
|
|
Creates a new SV and copies a buffer into it, which may contain NUL characters |
8748
|
|
|
|
|
|
(C<\0>) and other binary data. The reference count for the SV is set to 1. |
8749
|
|
|
|
|
|
Note that if C is zero, Perl will create a zero length (Perl) string. You |
8750
|
|
|
|
|
|
are responsible for ensuring that the source buffer is at least |
8751
|
|
|
|
|
|
C bytes long. If the C argument is NULL the new SV will be |
8752
|
|
|
|
|
|
undefined. |
8753
|
|
|
|
|
|
|
8754
|
|
|
|
|
|
=cut |
8755
|
|
|
|
|
|
*/ |
8756
|
|
|
|
|
|
|
8757
|
|
|
|
|
|
SV * |
8758
|
53663752
|
|
|
|
|
Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len) |
8759
|
|
|
|
|
|
{ |
8760
|
|
|
|
|
|
dVAR; |
8761
|
|
|
|
|
|
SV *sv; |
8762
|
|
|
|
|
|
|
8763
|
53663752
|
100
|
|
|
|
new_SV(sv); |
8764
|
53663752
|
|
|
|
|
sv_setpvn(sv,buffer,len); |
8765
|
53663752
|
|
|
|
|
return sv; |
8766
|
|
|
|
|
|
} |
8767
|
|
|
|
|
|
|
8768
|
|
|
|
|
|
/* |
8769
|
|
|
|
|
|
=for apidoc newSVhek |
8770
|
|
|
|
|
|
|
8771
|
|
|
|
|
|
Creates a new SV from the hash key structure. It will generate scalars that |
8772
|
|
|
|
|
|
point to the shared string table where possible. Returns a new (undefined) |
8773
|
|
|
|
|
|
SV if the hek is NULL. |
8774
|
|
|
|
|
|
|
8775
|
|
|
|
|
|
=cut |
8776
|
|
|
|
|
|
*/ |
8777
|
|
|
|
|
|
|
8778
|
|
|
|
|
|
SV * |
8779
|
111975385
|
|
|
|
|
Perl_newSVhek(pTHX_ const HEK *const hek) |
8780
|
|
|
|
|
|
{ |
8781
|
|
|
|
|
|
dVAR; |
8782
|
111975385
|
100
|
|
|
|
if (!hek) { |
8783
|
|
|
|
|
|
SV *sv; |
8784
|
|
|
|
|
|
|
8785
|
4
|
50
|
|
|
|
new_SV(sv); |
8786
|
4
|
|
|
|
|
return sv; |
8787
|
|
|
|
|
|
} |
8788
|
|
|
|
|
|
|
8789
|
111975381
|
100
|
|
|
|
if (HEK_LEN(hek) == HEf_SVKEY) { |
8790
|
2015198
|
|
|
|
|
return newSVsv(*(SV**)HEK_KEY(hek)); |
8791
|
|
|
|
|
|
} else { |
8792
|
109960183
|
|
|
|
|
const int flags = HEK_FLAGS(hek); |
8793
|
109960183
|
100
|
|
|
|
if (flags & HVhek_WASUTF8) { |
8794
|
|
|
|
|
|
/* Trouble :-) |
8795
|
|
|
|
|
|
Andreas would like keys he put in as utf8 to come back as utf8 |
8796
|
|
|
|
|
|
*/ |
8797
|
7930
|
|
|
|
|
STRLEN utf8_len = HEK_LEN(hek); |
8798
|
7930
|
|
|
|
|
SV * const sv = newSV_type(SVt_PV); |
8799
|
7930
|
|
|
|
|
char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); |
8800
|
|
|
|
|
|
/* bytes_to_utf8() allocates a new string, which we can repurpose: */ |
8801
|
7930
|
|
|
|
|
sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); |
8802
|
7930
|
|
|
|
|
SvUTF8_on (sv); |
8803
|
7930
|
|
|
|
|
return sv; |
8804
|
109952253
|
50
|
|
|
|
} else if (flags & HVhek_UNSHARED) { |
8805
|
|
|
|
|
|
/* A hash that isn't using shared hash keys has to have |
8806
|
|
|
|
|
|
the flag in every key so that we know not to try to call |
8807
|
|
|
|
|
|
share_hek_hek on it. */ |
8808
|
|
|
|
|
|
|
8809
|
0
|
|
|
|
|
SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); |
8810
|
0
|
0
|
|
|
|
if (HEK_UTF8(hek)) |
8811
|
0
|
|
|
|
|
SvUTF8_on (sv); |
8812
|
|
|
|
|
|
return sv; |
8813
|
|
|
|
|
|
} |
8814
|
|
|
|
|
|
/* This will be overwhelminly the most common case. */ |
8815
|
|
|
|
|
|
{ |
8816
|
|
|
|
|
|
/* Inline most of newSVpvn_share(), because share_hek_hek() is far |
8817
|
|
|
|
|
|
more efficient than sharepvn(). */ |
8818
|
|
|
|
|
|
SV *sv; |
8819
|
|
|
|
|
|
|
8820
|
109952253
|
100
|
|
|
|
new_SV(sv); |
8821
|
109952253
|
|
|
|
|
sv_upgrade(sv, SVt_PV); |
8822
|
109952253
|
|
|
|
|
SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); |
8823
|
109952253
|
|
|
|
|
SvCUR_set(sv, HEK_LEN(hek)); |
8824
|
109952253
|
|
|
|
|
SvLEN_set(sv, 0); |
8825
|
109952253
|
|
|
|
|
SvIsCOW_on(sv); |
8826
|
109952253
|
|
|
|
|
SvPOK_on(sv); |
8827
|
109952253
|
100
|
|
|
|
if (HEK_UTF8(hek)) |
8828
|
56355391
|
|
|
|
|
SvUTF8_on(sv); |
8829
|
|
|
|
|
|
return sv; |
8830
|
|
|
|
|
|
} |
8831
|
|
|
|
|
|
} |
8832
|
|
|
|
|
|
} |
8833
|
|
|
|
|
|
|
8834
|
|
|
|
|
|
/* |
8835
|
|
|
|
|
|
=for apidoc newSVpvn_share |
8836
|
|
|
|
|
|
|
8837
|
|
|
|
|
|
Creates a new SV with its SvPVX_const pointing to a shared string in the string |
8838
|
|
|
|
|
|
table. If the string does not already exist in the table, it is |
8839
|
|
|
|
|
|
created first. Turns on the SvIsCOW flag (or READONLY |
8840
|
|
|
|
|
|
and FAKE in 5.16 and earlier). If the C parameter |
8841
|
|
|
|
|
|
is non-zero, that value is used; otherwise the hash is computed. |
8842
|
|
|
|
|
|
The string's hash can later be retrieved from the SV |
8843
|
|
|
|
|
|
with the C macro. The idea here is |
8844
|
|
|
|
|
|
that as the string table is used for shared hash keys these strings will have |
8845
|
|
|
|
|
|
SvPVX_const == HeKEY and hash lookup will avoid string compare. |
8846
|
|
|
|
|
|
|
8847
|
|
|
|
|
|
=cut |
8848
|
|
|
|
|
|
*/ |
8849
|
|
|
|
|
|
|
8850
|
|
|
|
|
|
SV * |
8851
|
31889316
|
|
|
|
|
Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) |
8852
|
|
|
|
|
|
{ |
8853
|
|
|
|
|
|
dVAR; |
8854
|
|
|
|
|
|
SV *sv; |
8855
|
31889316
|
|
|
|
|
bool is_utf8 = FALSE; |
8856
|
|
|
|
|
|
const char *const orig_src = src; |
8857
|
|
|
|
|
|
|
8858
|
31889316
|
100
|
|
|
|
if (len < 0) { |
8859
|
472
|
|
|
|
|
STRLEN tmplen = -len; |
8860
|
472
|
|
|
|
|
is_utf8 = TRUE; |
8861
|
|
|
|
|
|
/* See the note in hv.c:hv_fetch() --jhi */ |
8862
|
472
|
|
|
|
|
src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); |
8863
|
472
|
|
|
|
|
len = tmplen; |
8864
|
|
|
|
|
|
} |
8865
|
31889316
|
100
|
|
|
|
if (!hash) |
8866
|
31889314
|
|
|
|
|
PERL_HASH(hash, src, len); |
8867
|
31889316
|
100
|
|
|
|
new_SV(sv); |
8868
|
|
|
|
|
|
/* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it |
8869
|
|
|
|
|
|
changes here, update it there too. */ |
8870
|
31889316
|
|
|
|
|
sv_upgrade(sv, SVt_PV); |
8871
|
31889316
|
100
|
|
|
|
SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); |
8872
|
31889316
|
|
|
|
|
SvCUR_set(sv, len); |
8873
|
31889316
|
|
|
|
|
SvLEN_set(sv, 0); |
8874
|
31889316
|
|
|
|
|
SvIsCOW_on(sv); |
8875
|
31889316
|
|
|
|
|
SvPOK_on(sv); |
8876
|
31889316
|
100
|
|
|
|
if (is_utf8) |
8877
|
432
|
|
|
|
|
SvUTF8_on(sv); |
8878
|
31889316
|
100
|
|
|
|
if (src != orig_src) |
8879
|
40
|
|
|
|
|
Safefree(src); |
8880
|
31889316
|
|
|
|
|
return sv; |
8881
|
|
|
|
|
|
} |
8882
|
|
|
|
|
|
|
8883
|
|
|
|
|
|
/* |
8884
|
|
|
|
|
|
=for apidoc newSVpv_share |
8885
|
|
|
|
|
|
|
8886
|
|
|
|
|
|
Like C, but takes a nul-terminated string instead of a |
8887
|
|
|
|
|
|
string/length pair. |
8888
|
|
|
|
|
|
|
8889
|
|
|
|
|
|
=cut |
8890
|
|
|
|
|
|
*/ |
8891
|
|
|
|
|
|
|
8892
|
|
|
|
|
|
SV * |
8893
|
16349
|
|
|
|
|
Perl_newSVpv_share(pTHX_ const char *src, U32 hash) |
8894
|
|
|
|
|
|
{ |
8895
|
16349
|
|
|
|
|
return newSVpvn_share(src, strlen(src), hash); |
8896
|
|
|
|
|
|
} |
8897
|
|
|
|
|
|
|
8898
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
8899
|
|
|
|
|
|
|
8900
|
|
|
|
|
|
/* pTHX_ magic can't cope with varargs, so this is a no-context |
8901
|
|
|
|
|
|
* version of the main function, (which may itself be aliased to us). |
8902
|
|
|
|
|
|
* Don't access this version directly. |
8903
|
|
|
|
|
|
*/ |
8904
|
|
|
|
|
|
|
8905
|
|
|
|
|
|
SV * |
8906
|
|
|
|
|
|
Perl_newSVpvf_nocontext(const char *const pat, ...) |
8907
|
|
|
|
|
|
{ |
8908
|
|
|
|
|
|
dTHX; |
8909
|
|
|
|
|
|
SV *sv; |
8910
|
|
|
|
|
|
va_list args; |
8911
|
|
|
|
|
|
|
8912
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT; |
8913
|
|
|
|
|
|
|
8914
|
|
|
|
|
|
va_start(args, pat); |
8915
|
|
|
|
|
|
sv = vnewSVpvf(pat, &args); |
8916
|
|
|
|
|
|
va_end(args); |
8917
|
|
|
|
|
|
return sv; |
8918
|
|
|
|
|
|
} |
8919
|
|
|
|
|
|
#endif |
8920
|
|
|
|
|
|
|
8921
|
|
|
|
|
|
/* |
8922
|
|
|
|
|
|
=for apidoc newSVpvf |
8923
|
|
|
|
|
|
|
8924
|
|
|
|
|
|
Creates a new SV and initializes it with the string formatted like |
8925
|
|
|
|
|
|
C. |
8926
|
|
|
|
|
|
|
8927
|
|
|
|
|
|
=cut |
8928
|
|
|
|
|
|
*/ |
8929
|
|
|
|
|
|
|
8930
|
|
|
|
|
|
SV * |
8931
|
119492
|
|
|
|
|
Perl_newSVpvf(pTHX_ const char *const pat, ...) |
8932
|
|
|
|
|
|
{ |
8933
|
|
|
|
|
|
SV *sv; |
8934
|
|
|
|
|
|
va_list args; |
8935
|
|
|
|
|
|
|
8936
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWSVPVF; |
8937
|
|
|
|
|
|
|
8938
|
119492
|
|
|
|
|
va_start(args, pat); |
8939
|
119492
|
|
|
|
|
sv = vnewSVpvf(pat, &args); |
8940
|
119492
|
|
|
|
|
va_end(args); |
8941
|
119492
|
|
|
|
|
return sv; |
8942
|
|
|
|
|
|
} |
8943
|
|
|
|
|
|
|
8944
|
|
|
|
|
|
/* backend for newSVpvf() and newSVpvf_nocontext() */ |
8945
|
|
|
|
|
|
|
8946
|
|
|
|
|
|
SV * |
8947
|
235502
|
|
|
|
|
Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) |
8948
|
|
|
|
|
|
{ |
8949
|
|
|
|
|
|
dVAR; |
8950
|
|
|
|
|
|
SV *sv; |
8951
|
|
|
|
|
|
|
8952
|
|
|
|
|
|
PERL_ARGS_ASSERT_VNEWSVPVF; |
8953
|
|
|
|
|
|
|
8954
|
235502
|
100
|
|
|
|
new_SV(sv); |
8955
|
235502
|
|
|
|
|
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
8956
|
235502
|
|
|
|
|
return sv; |
8957
|
|
|
|
|
|
} |
8958
|
|
|
|
|
|
|
8959
|
|
|
|
|
|
/* |
8960
|
|
|
|
|
|
=for apidoc newSVnv |
8961
|
|
|
|
|
|
|
8962
|
|
|
|
|
|
Creates a new SV and copies a floating point value into it. |
8963
|
|
|
|
|
|
The reference count for the SV is set to 1. |
8964
|
|
|
|
|
|
|
8965
|
|
|
|
|
|
=cut |
8966
|
|
|
|
|
|
*/ |
8967
|
|
|
|
|
|
|
8968
|
|
|
|
|
|
SV * |
8969
|
972583
|
|
|
|
|
Perl_newSVnv(pTHX_ const NV n) |
8970
|
|
|
|
|
|
{ |
8971
|
|
|
|
|
|
dVAR; |
8972
|
|
|
|
|
|
SV *sv; |
8973
|
|
|
|
|
|
|
8974
|
972583
|
100
|
|
|
|
new_SV(sv); |
8975
|
972583
|
|
|
|
|
sv_setnv(sv,n); |
8976
|
972583
|
|
|
|
|
return sv; |
8977
|
|
|
|
|
|
} |
8978
|
|
|
|
|
|
|
8979
|
|
|
|
|
|
/* |
8980
|
|
|
|
|
|
=for apidoc newSViv |
8981
|
|
|
|
|
|
|
8982
|
|
|
|
|
|
Creates a new SV and copies an integer into it. The reference count for the |
8983
|
|
|
|
|
|
SV is set to 1. |
8984
|
|
|
|
|
|
|
8985
|
|
|
|
|
|
=cut |
8986
|
|
|
|
|
|
*/ |
8987
|
|
|
|
|
|
|
8988
|
|
|
|
|
|
SV * |
8989
|
584303381
|
|
|
|
|
Perl_newSViv(pTHX_ const IV i) |
8990
|
|
|
|
|
|
{ |
8991
|
|
|
|
|
|
dVAR; |
8992
|
|
|
|
|
|
SV *sv; |
8993
|
|
|
|
|
|
|
8994
|
584303381
|
100
|
|
|
|
new_SV(sv); |
8995
|
584303381
|
|
|
|
|
sv_setiv(sv,i); |
8996
|
584303381
|
|
|
|
|
return sv; |
8997
|
|
|
|
|
|
} |
8998
|
|
|
|
|
|
|
8999
|
|
|
|
|
|
/* |
9000
|
|
|
|
|
|
=for apidoc newSVuv |
9001
|
|
|
|
|
|
|
9002
|
|
|
|
|
|
Creates a new SV and copies an unsigned integer into it. |
9003
|
|
|
|
|
|
The reference count for the SV is set to 1. |
9004
|
|
|
|
|
|
|
9005
|
|
|
|
|
|
=cut |
9006
|
|
|
|
|
|
*/ |
9007
|
|
|
|
|
|
|
9008
|
|
|
|
|
|
SV * |
9009
|
64244900
|
|
|
|
|
Perl_newSVuv(pTHX_ const UV u) |
9010
|
|
|
|
|
|
{ |
9011
|
|
|
|
|
|
dVAR; |
9012
|
|
|
|
|
|
SV *sv; |
9013
|
|
|
|
|
|
|
9014
|
64244900
|
100
|
|
|
|
new_SV(sv); |
9015
|
64244900
|
|
|
|
|
sv_setuv(sv,u); |
9016
|
64244900
|
|
|
|
|
return sv; |
9017
|
|
|
|
|
|
} |
9018
|
|
|
|
|
|
|
9019
|
|
|
|
|
|
/* |
9020
|
|
|
|
|
|
=for apidoc newSV_type |
9021
|
|
|
|
|
|
|
9022
|
|
|
|
|
|
Creates a new SV, of the type specified. The reference count for the new SV |
9023
|
|
|
|
|
|
is set to 1. |
9024
|
|
|
|
|
|
|
9025
|
|
|
|
|
|
=cut |
9026
|
|
|
|
|
|
*/ |
9027
|
|
|
|
|
|
|
9028
|
|
|
|
|
|
SV * |
9029
|
565702697
|
|
|
|
|
Perl_newSV_type(pTHX_ const svtype type) |
9030
|
|
|
|
|
|
{ |
9031
|
|
|
|
|
|
SV *sv; |
9032
|
|
|
|
|
|
|
9033
|
565702697
|
100
|
|
|
|
new_SV(sv); |
9034
|
565702697
|
|
|
|
|
sv_upgrade(sv, type); |
9035
|
565702697
|
|
|
|
|
return sv; |
9036
|
|
|
|
|
|
} |
9037
|
|
|
|
|
|
|
9038
|
|
|
|
|
|
/* |
9039
|
|
|
|
|
|
=for apidoc newRV_noinc |
9040
|
|
|
|
|
|
|
9041
|
|
|
|
|
|
Creates an RV wrapper for an SV. The reference count for the original |
9042
|
|
|
|
|
|
SV is B incremented. |
9043
|
|
|
|
|
|
|
9044
|
|
|
|
|
|
=cut |
9045
|
|
|
|
|
|
*/ |
9046
|
|
|
|
|
|
|
9047
|
|
|
|
|
|
SV * |
9048
|
99043456
|
|
|
|
|
Perl_newRV_noinc(pTHX_ SV *const tmpRef) |
9049
|
|
|
|
|
|
{ |
9050
|
|
|
|
|
|
dVAR; |
9051
|
99043456
|
|
|
|
|
SV *sv = newSV_type(SVt_IV); |
9052
|
|
|
|
|
|
|
9053
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWRV_NOINC; |
9054
|
|
|
|
|
|
|
9055
|
99043456
|
|
|
|
|
SvTEMP_off(tmpRef); |
9056
|
99043456
|
|
|
|
|
SvRV_set(sv, tmpRef); |
9057
|
99043456
|
|
|
|
|
SvROK_on(sv); |
9058
|
99043456
|
|
|
|
|
return sv; |
9059
|
|
|
|
|
|
} |
9060
|
|
|
|
|
|
|
9061
|
|
|
|
|
|
/* newRV_inc is the official function name to use now. |
9062
|
|
|
|
|
|
* newRV_inc is in fact #defined to newRV in sv.h |
9063
|
|
|
|
|
|
*/ |
9064
|
|
|
|
|
|
|
9065
|
|
|
|
|
|
SV * |
9066
|
69595667
|
|
|
|
|
Perl_newRV(pTHX_ SV *const sv) |
9067
|
|
|
|
|
|
{ |
9068
|
|
|
|
|
|
dVAR; |
9069
|
|
|
|
|
|
|
9070
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWRV; |
9071
|
|
|
|
|
|
|
9072
|
69595667
|
|
|
|
|
return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); |
9073
|
|
|
|
|
|
} |
9074
|
|
|
|
|
|
|
9075
|
|
|
|
|
|
/* |
9076
|
|
|
|
|
|
=for apidoc newSVsv |
9077
|
|
|
|
|
|
|
9078
|
|
|
|
|
|
Creates a new SV which is an exact duplicate of the original SV. |
9079
|
|
|
|
|
|
(Uses C.) |
9080
|
|
|
|
|
|
|
9081
|
|
|
|
|
|
=cut |
9082
|
|
|
|
|
|
*/ |
9083
|
|
|
|
|
|
|
9084
|
|
|
|
|
|
SV * |
9085
|
48349991
|
|
|
|
|
Perl_newSVsv(pTHX_ SV *const old) |
9086
|
48349991
|
100
|
|
|
|
{ |
9087
|
|
|
|
|
|
dVAR; |
9088
|
|
|
|
|
|
SV *sv; |
9089
|
|
|
|
|
|
|
9090
|
48349991
|
50
|
|
|
|
if (!old) |
9091
|
|
|
|
|
|
return NULL; |
9092
|
48349991
|
50
|
|
|
|
if (SvTYPE(old) == (svtype)SVTYPEMASK) { |
9093
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); |
9094
|
0
|
|
|
|
|
return NULL; |
9095
|
|
|
|
|
|
} |
9096
|
|
|
|
|
|
/* Do this here, otherwise we leak the new SV if this croaks. */ |
9097
|
24025090
|
|
|
|
|
SvGETMAGIC(old); |
9098
|
48349987
|
100
|
|
|
|
new_SV(sv); |
9099
|
|
|
|
|
|
/* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games |
9100
|
|
|
|
|
|
with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */ |
9101
|
48349987
|
|
|
|
|
sv_setsv_flags(sv, old, SV_NOSTEAL); |
9102
|
48349987
|
|
|
|
|
return sv; |
9103
|
|
|
|
|
|
} |
9104
|
|
|
|
|
|
|
9105
|
|
|
|
|
|
/* |
9106
|
|
|
|
|
|
=for apidoc sv_reset |
9107
|
|
|
|
|
|
|
9108
|
|
|
|
|
|
Underlying implementation for the C Perl function. |
9109
|
|
|
|
|
|
Note that the perl-level function is vaguely deprecated. |
9110
|
|
|
|
|
|
|
9111
|
|
|
|
|
|
=cut |
9112
|
|
|
|
|
|
*/ |
9113
|
|
|
|
|
|
|
9114
|
|
|
|
|
|
void |
9115
|
0
|
|
|
|
|
Perl_sv_reset(pTHX_ const char *s, HV *const stash) |
9116
|
|
|
|
|
|
{ |
9117
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_RESET; |
9118
|
|
|
|
|
|
|
9119
|
0
|
0
|
|
|
|
sv_resetpvn(*s ? s : NULL, strlen(s), stash); |
9120
|
0
|
|
|
|
|
} |
9121
|
|
|
|
|
|
|
9122
|
|
|
|
|
|
void |
9123
|
58
|
|
|
|
|
Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) |
9124
|
|
|
|
|
|
{ |
9125
|
|
|
|
|
|
dVAR; |
9126
|
|
|
|
|
|
char todo[PERL_UCHAR_MAX+1]; |
9127
|
|
|
|
|
|
const char *send; |
9128
|
|
|
|
|
|
|
9129
|
58
|
50
|
|
|
|
if (!stash || SvTYPE(stash) != SVt_PVHV) |
|
|
100
|
|
|
|
|
9130
|
|
|
|
|
|
return; |
9131
|
|
|
|
|
|
|
9132
|
56
|
100
|
|
|
|
if (!s) { /* reset ?? searches */ |
9133
|
24
|
|
|
|
|
MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); |
9134
|
24
|
100
|
|
|
|
if (mg) { |
9135
|
12
|
|
|
|
|
const U32 count = mg->mg_len / sizeof(PMOP**); |
9136
|
12
|
|
|
|
|
PMOP **pmp = (PMOP**) mg->mg_ptr; |
9137
|
12
|
|
|
|
|
PMOP *const *const end = pmp + count; |
9138
|
|
|
|
|
|
|
9139
|
30
|
100
|
|
|
|
while (pmp < end) { |
9140
|
|
|
|
|
|
#ifdef USE_ITHREADS |
9141
|
|
|
|
|
|
SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); |
9142
|
|
|
|
|
|
#else |
9143
|
12
|
|
|
|
|
(*pmp)->op_pmflags &= ~PMf_USED; |
9144
|
|
|
|
|
|
#endif |
9145
|
12
|
|
|
|
|
++pmp; |
9146
|
|
|
|
|
|
} |
9147
|
|
|
|
|
|
} |
9148
|
|
|
|
|
|
return; |
9149
|
|
|
|
|
|
} |
9150
|
|
|
|
|
|
|
9151
|
|
|
|
|
|
/* reset variables */ |
9152
|
|
|
|
|
|
|
9153
|
32
|
50
|
|
|
|
if (!HvARRAY(stash)) |
9154
|
|
|
|
|
|
return; |
9155
|
|
|
|
|
|
|
9156
|
|
|
|
|
|
Zero(todo, 256, char); |
9157
|
32
|
|
|
|
|
send = s + len; |
9158
|
99
|
100
|
|
|
|
while (s < send) { |
9159
|
|
|
|
|
|
I32 max; |
9160
|
38
|
|
|
|
|
I32 i = (unsigned char)*s; |
9161
|
38
|
100
|
|
|
|
if (s[1] == '-') { |
9162
|
2
|
|
|
|
|
s += 2; |
9163
|
|
|
|
|
|
} |
9164
|
38
|
|
|
|
|
max = (unsigned char)*s++; |
9165
|
78
|
100
|
|
|
|
for ( ; i <= max; i++) { |
9166
|
40
|
|
|
|
|
todo[i] = 1; |
9167
|
|
|
|
|
|
} |
9168
|
3555
|
100
|
|
|
|
for (i = 0; i <= (I32) HvMAX(stash); i++) { |
9169
|
|
|
|
|
|
HE *entry; |
9170
|
7366
|
100
|
|
|
|
for (entry = HvARRAY(stash)[i]; |
9171
|
|
|
|
|
|
entry; |
9172
|
2062
|
|
|
|
|
entry = HeNEXT(entry)) |
9173
|
|
|
|
|
|
{ |
9174
|
|
|
|
|
|
GV *gv; |
9175
|
|
|
|
|
|
SV *sv; |
9176
|
|
|
|
|
|
|
9177
|
2062
|
100
|
|
|
|
if (!todo[(U8)*HeKEY(entry)]) |
9178
|
1934
|
|
|
|
|
continue; |
9179
|
128
|
|
|
|
|
gv = MUTABLE_GV(HeVAL(entry)); |
9180
|
128
|
|
|
|
|
sv = GvSV(gv); |
9181
|
128
|
100
|
|
|
|
if (sv && !SvREADONLY(sv)) { |
|
|
100
|
|
|
|
|
9182
|
90
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(sv); |
9183
|
90
|
100
|
|
|
|
if (!isGV(sv)) SvOK_off(sv); |
|
|
50
|
|
|
|
|
9184
|
|
|
|
|
|
} |
9185
|
128
|
100
|
|
|
|
if (GvAV(gv)) { |
9186
|
26
|
|
|
|
|
av_clear(GvAV(gv)); |
9187
|
|
|
|
|
|
} |
9188
|
128
|
100
|
|
|
|
if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9189
|
24
|
|
|
|
|
hv_clear(GvHV(gv)); |
9190
|
|
|
|
|
|
} |
9191
|
|
|
|
|
|
} |
9192
|
|
|
|
|
|
} |
9193
|
|
|
|
|
|
} |
9194
|
|
|
|
|
|
} |
9195
|
|
|
|
|
|
|
9196
|
|
|
|
|
|
/* |
9197
|
|
|
|
|
|
=for apidoc sv_2io |
9198
|
|
|
|
|
|
|
9199
|
|
|
|
|
|
Using various gambits, try to get an IO from an SV: the IO slot if its a |
9200
|
|
|
|
|
|
GV; or the recursive result if we're an RV; or the IO slot of the symbol |
9201
|
|
|
|
|
|
named after the PV if we're a string. |
9202
|
|
|
|
|
|
|
9203
|
|
|
|
|
|
'Get' magic is ignored on the sv passed in, but will be called on |
9204
|
|
|
|
|
|
C if sv is an RV. |
9205
|
|
|
|
|
|
|
9206
|
|
|
|
|
|
=cut |
9207
|
|
|
|
|
|
*/ |
9208
|
|
|
|
|
|
|
9209
|
|
|
|
|
|
IO* |
9210
|
3072535
|
|
|
|
|
Perl_sv_2io(pTHX_ SV *const sv) |
9211
|
|
|
|
|
|
{ |
9212
|
|
|
|
|
|
IO* io; |
9213
|
|
|
|
|
|
GV* gv; |
9214
|
|
|
|
|
|
|
9215
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2IO; |
9216
|
|
|
|
|
|
|
9217
|
3818624
|
|
|
|
|
switch (SvTYPE(sv)) { |
9218
|
|
|
|
|
|
case SVt_PVIO: |
9219
|
|
|
|
|
|
io = MUTABLE_IO(sv); |
9220
|
|
|
|
|
|
break; |
9221
|
|
|
|
|
|
case SVt_PVGV: |
9222
|
|
|
|
|
|
case SVt_PVLV: |
9223
|
3070005
|
50
|
|
|
|
if (isGV_with_GP(sv)) { |
|
|
50
|
|
|
|
|
9224
|
|
|
|
|
|
gv = MUTABLE_GV(sv); |
9225
|
3070005
|
50
|
|
|
|
io = GvIO(gv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9226
|
3070005
|
100
|
|
|
|
if (!io) |
9227
|
6
|
|
|
|
|
Perl_croak(aTHX_ "Bad filehandle: %"HEKf, |
9228
|
6
|
|
|
|
|
HEKfARG(GvNAME_HEK(gv))); |
9229
|
|
|
|
|
|
break; |
9230
|
|
|
|
|
|
} |
9231
|
|
|
|
|
|
/* FALL THROUGH */ |
9232
|
|
|
|
|
|
default: |
9233
|
748619
|
50
|
|
|
|
if (!SvOK(sv)) |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
9234
|
0
|
|
|
|
|
Perl_croak(aTHX_ PL_no_usym, "filehandle"); |
9235
|
1121484
|
100
|
|
|
|
if (SvROK(sv)) { |
|
|
50
|
|
|
|
|
9236
|
372865
|
|
|
|
|
SvGETMAGIC(SvRV(sv)); |
9237
|
746089
|
|
|
|
|
return sv_2io(SvRV(sv)); |
9238
|
|
|
|
|
|
} |
9239
|
2530
|
|
|
|
|
gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); |
9240
|
2530
|
100
|
|
|
|
if (gv) |
9241
|
2526
|
50
|
|
|
|
io = GvIO(gv); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9242
|
|
|
|
|
|
else |
9243
|
|
|
|
|
|
io = 0; |
9244
|
2530
|
100
|
|
|
|
if (!io) { |
9245
|
|
|
|
|
|
SV *newsv = sv; |
9246
|
4
|
50
|
|
|
|
if (SvGMAGICAL(sv)) { |
9247
|
0
|
|
|
|
|
newsv = sv_newmortal(); |
9248
|
0
|
|
|
|
|
sv_setsv_nomg(newsv, sv); |
9249
|
|
|
|
|
|
} |
9250
|
1536805
|
|
|
|
|
Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv)); |
9251
|
|
|
|
|
|
} |
9252
|
|
|
|
|
|
break; |
9253
|
|
|
|
|
|
} |
9254
|
|
|
|
|
|
return io; |
9255
|
|
|
|
|
|
} |
9256
|
|
|
|
|
|
|
9257
|
|
|
|
|
|
/* |
9258
|
|
|
|
|
|
=for apidoc sv_2cv |
9259
|
|
|
|
|
|
|
9260
|
|
|
|
|
|
Using various gambits, try to get a CV from an SV; in addition, try if |
9261
|
|
|
|
|
|
possible to set C<*st> and C<*gvp> to the stash and GV associated with it. |
9262
|
|
|
|
|
|
The flags in C are passed to gv_fetchsv. |
9263
|
|
|
|
|
|
|
9264
|
|
|
|
|
|
=cut |
9265
|
|
|
|
|
|
*/ |
9266
|
|
|
|
|
|
|
9267
|
|
|
|
|
|
CV * |
9268
|
5248032
|
|
|
|
|
Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) |
9269
|
|
|
|
|
|
{ |
9270
|
|
|
|
|
|
dVAR; |
9271
|
|
|
|
|
|
GV *gv = NULL; |
9272
|
|
|
|
|
|
CV *cv = NULL; |
9273
|
|
|
|
|
|
|
9274
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_2CV; |
9275
|
|
|
|
|
|
|
9276
|
5248032
|
50
|
|
|
|
if (!sv) { |
9277
|
0
|
|
|
|
|
*st = NULL; |
9278
|
0
|
|
|
|
|
*gvp = NULL; |
9279
|
0
|
|
|
|
|
return NULL; |
9280
|
|
|
|
|
|
} |
9281
|
7847896
|
100
|
|
|
|
switch (SvTYPE(sv)) { |
9282
|
|
|
|
|
|
case SVt_PVCV: |
9283
|
82
|
|
|
|
|
*st = CvSTASH(sv); |
9284
|
82
|
|
|
|
|
*gvp = NULL; |
9285
|
82
|
|
|
|
|
return MUTABLE_CV(sv); |
9286
|
|
|
|
|
|
case SVt_PVHV: |
9287
|
|
|
|
|
|
case SVt_PVAV: |
9288
|
0
|
|
|
|
|
*st = NULL; |
9289
|
0
|
|
|
|
|
*gvp = NULL; |
9290
|
0
|
|
|
|
|
return NULL; |
9291
|
|
|
|
|
|
default: |
9292
|
2708274
|
|
|
|
|
SvGETMAGIC(sv); |
9293
|
5247950
|
100
|
|
|
|
if (SvROK(sv)) { |
9294
|
207203
|
50
|
|
|
|
if (SvAMAGIC(sv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
9295
|
0
|
|
|
|
|
sv = amagic_deref_call(sv, to_cv_amg); |
9296
|
|
|
|
|
|
|
9297
|
207203
|
|
|
|
|
sv = SvRV(sv); |
9298
|
207203
|
100
|
|
|
|
if (SvTYPE(sv) == SVt_PVCV) { |
9299
|
|
|
|
|
|
cv = MUTABLE_CV(sv); |
9300
|
207181
|
|
|
|
|
*gvp = NULL; |
9301
|
207181
|
|
|
|
|
*st = CvSTASH(cv); |
9302
|
207181
|
|
|
|
|
return cv; |
9303
|
|
|
|
|
|
} |
9304
|
22
|
50
|
|
|
|
else if(SvGETMAGIC(sv), isGV_with_GP(sv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9305
|
|
|
|
|
|
gv = MUTABLE_GV(sv); |
9306
|
|
|
|
|
|
else |
9307
|
14
|
|
|
|
|
Perl_croak(aTHX_ "Not a subroutine reference"); |
9308
|
|
|
|
|
|
} |
9309
|
5040747
|
100
|
|
|
|
else if (isGV_with_GP(sv)) { |
|
|
50
|
|
|
|
|
9310
|
|
|
|
|
|
gv = MUTABLE_GV(sv); |
9311
|
|
|
|
|
|
} |
9312
|
|
|
|
|
|
else { |
9313
|
3088499
|
|
|
|
|
gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV); |
9314
|
|
|
|
|
|
} |
9315
|
5040755
|
|
|
|
|
*gvp = gv; |
9316
|
5040755
|
100
|
|
|
|
if (!gv) { |
9317
|
589198
|
|
|
|
|
*st = NULL; |
9318
|
589198
|
|
|
|
|
return NULL; |
9319
|
|
|
|
|
|
} |
9320
|
|
|
|
|
|
/* Some flags to gv_fetchsv mean don't really create the GV */ |
9321
|
4451557
|
100
|
|
|
|
if (!isGV_with_GP(gv)) { |
|
|
100
|
|
|
|
|
9322
|
683758
|
|
|
|
|
*st = NULL; |
9323
|
683758
|
|
|
|
|
return NULL; |
9324
|
|
|
|
|
|
} |
9325
|
3767799
|
100
|
|
|
|
*st = GvESTASH(gv); |
9326
|
3767799
|
100
|
|
|
|
if (lref & ~GV_ADDMG && !GvCVu(gv)) { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9327
|
|
|
|
|
|
/* XXX this is probably not what they think they're getting. |
9328
|
|
|
|
|
|
* It has the same effect as "sub name;", i.e. just a forward |
9329
|
|
|
|
|
|
* declaration! */ |
9330
|
38080
|
|
|
|
|
newSTUB(gv,0); |
9331
|
|
|
|
|
|
} |
9332
|
4512225
|
100
|
|
|
|
return GvCVu(gv); |
9333
|
|
|
|
|
|
} |
9334
|
|
|
|
|
|
} |
9335
|
|
|
|
|
|
|
9336
|
|
|
|
|
|
/* |
9337
|
|
|
|
|
|
=for apidoc sv_true |
9338
|
|
|
|
|
|
|
9339
|
|
|
|
|
|
Returns true if the SV has a true value by Perl's rules. |
9340
|
|
|
|
|
|
Use the C macro instead, which may call C or may |
9341
|
|
|
|
|
|
instead use an in-line version. |
9342
|
|
|
|
|
|
|
9343
|
|
|
|
|
|
=cut |
9344
|
|
|
|
|
|
*/ |
9345
|
|
|
|
|
|
|
9346
|
|
|
|
|
|
I32 |
9347
|
0
|
|
|
|
|
Perl_sv_true(pTHX_ SV *const sv) |
9348
|
|
|
|
|
|
{ |
9349
|
0
|
0
|
|
|
|
if (!sv) |
9350
|
|
|
|
|
|
return 0; |
9351
|
0
|
0
|
|
|
|
if (SvPOK(sv)) { |
9352
|
0
|
|
|
|
|
const XPV* const tXpv = (XPV*)SvANY(sv); |
9353
|
0
|
0
|
|
|
|
if (tXpv && |
|
|
0
|
|
|
|
|
9354
|
0
|
0
|
|
|
|
(tXpv->xpv_cur > 1 || |
9355
|
0
|
0
|
|
|
|
(tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) |
9356
|
|
|
|
|
|
return 1; |
9357
|
|
|
|
|
|
else |
9358
|
0
|
|
|
|
|
return 0; |
9359
|
|
|
|
|
|
} |
9360
|
|
|
|
|
|
else { |
9361
|
0
|
0
|
|
|
|
if (SvIOK(sv)) |
9362
|
0
|
|
|
|
|
return SvIVX(sv) != 0; |
9363
|
|
|
|
|
|
else { |
9364
|
0
|
0
|
|
|
|
if (SvNOK(sv)) |
9365
|
0
|
|
|
|
|
return SvNVX(sv) != 0.0; |
9366
|
|
|
|
|
|
else |
9367
|
0
|
|
|
|
|
return sv_2bool(sv); |
9368
|
|
|
|
|
|
} |
9369
|
|
|
|
|
|
} |
9370
|
|
|
|
|
|
} |
9371
|
|
|
|
|
|
|
9372
|
|
|
|
|
|
/* |
9373
|
|
|
|
|
|
=for apidoc sv_pvn_force |
9374
|
|
|
|
|
|
|
9375
|
|
|
|
|
|
Get a sensible string out of the SV somehow. |
9376
|
|
|
|
|
|
A private implementation of the C macro for compilers which |
9377
|
|
|
|
|
|
can't cope with complex macro expressions. Always use the macro instead. |
9378
|
|
|
|
|
|
|
9379
|
|
|
|
|
|
=for apidoc sv_pvn_force_flags |
9380
|
|
|
|
|
|
|
9381
|
|
|
|
|
|
Get a sensible string out of the SV somehow. |
9382
|
|
|
|
|
|
If C has C bit set, will C on C if |
9383
|
|
|
|
|
|
appropriate, else not. C and C are |
9384
|
|
|
|
|
|
implemented in terms of this function. |
9385
|
|
|
|
|
|
You normally want to use the various wrapper macros instead: see |
9386
|
|
|
|
|
|
C and C |
9387
|
|
|
|
|
|
|
9388
|
|
|
|
|
|
=cut |
9389
|
|
|
|
|
|
*/ |
9390
|
|
|
|
|
|
|
9391
|
|
|
|
|
|
char * |
9392
|
12775742
|
|
|
|
|
Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) |
9393
|
|
|
|
|
|
{ |
9394
|
|
|
|
|
|
dVAR; |
9395
|
|
|
|
|
|
|
9396
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; |
9397
|
|
|
|
|
|
|
9398
|
12775742
|
100
|
|
|
|
if (flags & SV_GMAGIC) SvGETMAGIC(sv); |
|
|
100
|
|
|
|
|
9399
|
12775742
|
100
|
|
|
|
if (SvTHINKFIRST(sv) && (!SvROK(sv) || SvREADONLY(sv))) |
|
|
100
|
|
|
|
|
9400
|
12369752
|
|
|
|
|
sv_force_normal_flags(sv, 0); |
9401
|
|
|
|
|
|
|
9402
|
12775738
|
100
|
|
|
|
if (SvPOK(sv)) { |
9403
|
12400810
|
100
|
|
|
|
if (lp) |
9404
|
9181017
|
|
|
|
|
*lp = SvCUR(sv); |
9405
|
|
|
|
|
|
} |
9406
|
|
|
|
|
|
else { |
9407
|
|
|
|
|
|
char *s; |
9408
|
|
|
|
|
|
STRLEN len; |
9409
|
|
|
|
|
|
|
9410
|
374928
|
50
|
|
|
|
if (SvTYPE(sv) > SVt_PVLV |
9411
|
374928
|
100
|
|
|
|
|| isGV_with_GP(sv)) |
|
|
50
|
|
|
|
|
9412
|
|
|
|
|
|
/* diag_listed_as: Can't coerce %s to %s in %s */ |
9413
|
3
|
50
|
|
|
|
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), |
9414
|
1
|
0
|
|
|
|
OP_DESC(PL_op)); |
9415
|
374926
|
|
|
|
|
s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); |
9416
|
374926
|
100
|
|
|
|
if (!s) { |
9417
|
|
|
|
|
|
s = (char *)""; |
9418
|
|
|
|
|
|
} |
9419
|
374926
|
100
|
|
|
|
if (lp) |
9420
|
357640
|
|
|
|
|
*lp = len; |
9421
|
|
|
|
|
|
|
9422
|
725668
|
100
|
|
|
|
if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ |
|
|
100
|
|
|
|
|
9423
|
350742
|
100
|
|
|
|
if (SvROK(sv)) |
9424
|
350606
|
|
|
|
|
sv_unref(sv); |
9425
|
187891
|
|
|
|
|
SvUPGRADE(sv, SVt_PV); /* Never FALSE */ |
9426
|
350742
|
50
|
|
|
|
SvGROW(sv, len + 1); |
|
|
100
|
|
|
|
|
9427
|
350742
|
|
|
|
|
Move(s,SvPVX(sv),len,char); |
9428
|
350742
|
|
|
|
|
SvCUR_set(sv, len); |
9429
|
350742
|
|
|
|
|
SvPVX(sv)[len] = '\0'; |
9430
|
|
|
|
|
|
} |
9431
|
374926
|
100
|
|
|
|
if (!SvPOK(sv)) { |
9432
|
359108
|
|
|
|
|
SvPOK_on(sv); /* validate pointer */ |
9433
|
359108
|
50
|
|
|
|
SvTAINT(sv); |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
9434
|
|
|
|
|
|
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", |
9435
|
|
|
|
|
|
PTR2UV(sv),SvPVX_const(sv))); |
9436
|
|
|
|
|
|
} |
9437
|
|
|
|
|
|
} |
9438
|
12775736
|
|
|
|
|
(void)SvPOK_only_UTF8(sv); |
9439
|
12775736
|
|
|
|
|
return SvPVX_mutable(sv); |
9440
|
|
|
|
|
|
} |
9441
|
|
|
|
|
|
|
9442
|
|
|
|
|
|
/* |
9443
|
|
|
|
|
|
=for apidoc sv_pvbyten_force |
9444
|
|
|
|
|
|
|
9445
|
|
|
|
|
|
The backend for the C macro. Always use the macro |
9446
|
|
|
|
|
|
instead. |
9447
|
|
|
|
|
|
|
9448
|
|
|
|
|
|
=cut |
9449
|
|
|
|
|
|
*/ |
9450
|
|
|
|
|
|
|
9451
|
|
|
|
|
|
char * |
9452
|
2174
|
|
|
|
|
Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp) |
9453
|
|
|
|
|
|
{ |
9454
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE; |
9455
|
|
|
|
|
|
|
9456
|
2174
|
|
|
|
|
sv_pvn_force(sv,lp); |
9457
|
2174
|
|
|
|
|
sv_utf8_downgrade(sv,0); |
9458
|
2172
|
|
|
|
|
*lp = SvCUR(sv); |
9459
|
2172
|
|
|
|
|
return SvPVX(sv); |
9460
|
|
|
|
|
|
} |
9461
|
|
|
|
|
|
|
9462
|
|
|
|
|
|
/* |
9463
|
|
|
|
|
|
=for apidoc sv_pvutf8n_force |
9464
|
|
|
|
|
|
|
9465
|
|
|
|
|
|
The backend for the C macro. Always use the macro |
9466
|
|
|
|
|
|
instead. |
9467
|
|
|
|
|
|
|
9468
|
|
|
|
|
|
=cut |
9469
|
|
|
|
|
|
*/ |
9470
|
|
|
|
|
|
|
9471
|
|
|
|
|
|
char * |
9472
|
782
|
|
|
|
|
Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) |
9473
|
|
|
|
|
|
{ |
9474
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE; |
9475
|
|
|
|
|
|
|
9476
|
782
|
|
|
|
|
sv_pvn_force(sv,0); |
9477
|
782
|
|
|
|
|
sv_utf8_upgrade_nomg(sv); |
9478
|
782
|
|
|
|
|
*lp = SvCUR(sv); |
9479
|
782
|
|
|
|
|
return SvPVX(sv); |
9480
|
|
|
|
|
|
} |
9481
|
|
|
|
|
|
|
9482
|
|
|
|
|
|
/* |
9483
|
|
|
|
|
|
=for apidoc sv_reftype |
9484
|
|
|
|
|
|
|
9485
|
|
|
|
|
|
Returns a string describing what the SV is a reference to. |
9486
|
|
|
|
|
|
|
9487
|
|
|
|
|
|
=cut |
9488
|
|
|
|
|
|
*/ |
9489
|
|
|
|
|
|
|
9490
|
|
|
|
|
|
const char * |
9491
|
17740459
|
|
|
|
|
Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) |
9492
|
|
|
|
|
|
{ |
9493
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_REFTYPE; |
9494
|
17740459
|
100
|
|
|
|
if (ob && SvOBJECT(sv)) { |
|
|
50
|
|
|
|
|
9495
|
13514
|
50
|
|
|
|
return SvPV_nolen_const(sv_ref(NULL, sv, ob)); |
9496
|
|
|
|
|
|
} |
9497
|
|
|
|
|
|
else { |
9498
|
17726945
|
|
|
|
|
switch (SvTYPE(sv)) { |
9499
|
|
|
|
|
|
case SVt_NULL: |
9500
|
|
|
|
|
|
case SVt_IV: |
9501
|
|
|
|
|
|
case SVt_NV: |
9502
|
|
|
|
|
|
case SVt_PV: |
9503
|
|
|
|
|
|
case SVt_PVIV: |
9504
|
|
|
|
|
|
case SVt_PVNV: |
9505
|
|
|
|
|
|
case SVt_PVMG: |
9506
|
13601559
|
100
|
|
|
|
if (SvVOK(sv)) |
|
|
100
|
|
|
|
|
9507
|
|
|
|
|
|
return "VSTRING"; |
9508
|
13601511
|
100
|
|
|
|
if (SvROK(sv)) |
9509
|
|
|
|
|
|
return "REF"; |
9510
|
|
|
|
|
|
else |
9511
|
13566361
|
|
|
|
|
return "SCALAR"; |
9512
|
|
|
|
|
|
|
9513
|
180
|
100
|
|
|
|
case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" |
|
|
100
|
|
|
|
|
9514
|
|
|
|
|
|
/* tied lvalues should appear to be |
9515
|
|
|
|
|
|
* scalars for backwards compatibility */ |
9516
|
96
|
|
|
|
|
: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') |
9517
|
|
|
|
|
|
? "SCALAR" : "LVALUE"); |
9518
|
|
|
|
|
|
case SVt_PVAV: return "ARRAY"; |
9519
|
1099230
|
|
|
|
|
case SVt_PVHV: return "HASH"; |
9520
|
302000
|
|
|
|
|
case SVt_PVCV: return "CODE"; |
9521
|
503294
|
50
|
|
|
|
case SVt_PVGV: return (char *) (isGV_with_GP(sv) |
|
|
50
|
|
|
|
|
9522
|
|
|
|
|
|
? "GLOB" : "SCALAR"); |
9523
|
34
|
|
|
|
|
case SVt_PVFM: return "FORMAT"; |
9524
|
48
|
|
|
|
|
case SVt_PVIO: return "IO"; |
9525
|
0
|
|
|
|
|
case SVt_INVLIST: return "INVLIST"; |
9526
|
86
|
|
|
|
|
case SVt_REGEXP: return "REGEXP"; |
9527
|
8876707
|
|
|
|
|
default: return "UNKNOWN"; |
9528
|
|
|
|
|
|
} |
9529
|
|
|
|
|
|
} |
9530
|
|
|
|
|
|
} |
9531
|
|
|
|
|
|
|
9532
|
|
|
|
|
|
/* |
9533
|
|
|
|
|
|
=for apidoc sv_ref |
9534
|
|
|
|
|
|
|
9535
|
|
|
|
|
|
Returns a SV describing what the SV passed in is a reference to. |
9536
|
|
|
|
|
|
|
9537
|
|
|
|
|
|
=cut |
9538
|
|
|
|
|
|
*/ |
9539
|
|
|
|
|
|
|
9540
|
|
|
|
|
|
SV * |
9541
|
257341116
|
|
|
|
|
Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob) |
9542
|
|
|
|
|
|
{ |
9543
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_REF; |
9544
|
|
|
|
|
|
|
9545
|
257341116
|
100
|
|
|
|
if (!dst) |
9546
|
27028
|
|
|
|
|
dst = sv_newmortal(); |
9547
|
|
|
|
|
|
|
9548
|
257341116
|
50
|
|
|
|
if (ob && SvOBJECT(sv)) { |
|
|
100
|
|
|
|
|
9549
|
508238186
|
50
|
|
|
|
HvNAME_get(SvSTASH(sv)) |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9550
|
254119086
|
50
|
|
|
|
? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))) |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
9551
|
508238184
|
50
|
|
|
|
: sv_setpvn(dst, "__ANON__", 8); |
|
|
100
|
|
|
|
|
9552
|
|
|
|
|
|
} |
9553
|
|
|
|
|
|
else { |
9554
|
3222026
|
|
|
|
|
const char * reftype = sv_reftype(sv, 0); |
9555
|
3222026
|
|
|
|
|
sv_setpv(dst, reftype); |
9556
|
|
|
|
|
|
} |
9557
|
257341116
|
|
|
|
|
return dst; |
9558
|
|
|
|
|
|
} |
9559
|
|
|
|
|
|
|
9560
|
|
|
|
|
|
/* |
9561
|
|
|
|
|
|
=for apidoc sv_isobject |
9562
|
|
|
|
|
|
|
9563
|
|
|
|
|
|
Returns a boolean indicating whether the SV is an RV pointing to a blessed |
9564
|
|
|
|
|
|
object. If the SV is not an RV, or if the object is not blessed, then this |
9565
|
|
|
|
|
|
will return false. |
9566
|
|
|
|
|
|
|
9567
|
|
|
|
|
|
=cut |
9568
|
|
|
|
|
|
*/ |
9569
|
|
|
|
|
|
|
9570
|
|
|
|
|
|
int |
9571
|
1103458
|
|
|
|
|
Perl_sv_isobject(pTHX_ SV *sv) |
9572
|
1103458
|
100
|
|
|
|
{ |
9573
|
1103458
|
50
|
|
|
|
if (!sv) |
9574
|
|
|
|
|
|
return 0; |
9575
|
541312
|
|
|
|
|
SvGETMAGIC(sv); |
9576
|
1103458
|
100
|
|
|
|
if (!SvROK(sv)) |
9577
|
|
|
|
|
|
return 0; |
9578
|
289750
|
|
|
|
|
sv = SvRV(sv); |
9579
|
289750
|
100
|
|
|
|
if (!SvOBJECT(sv)) |
9580
|
|
|
|
|
|
return 0; |
9581
|
702536
|
|
|
|
|
return 1; |
9582
|
|
|
|
|
|
} |
9583
|
|
|
|
|
|
|
9584
|
|
|
|
|
|
/* |
9585
|
|
|
|
|
|
=for apidoc sv_isa |
9586
|
|
|
|
|
|
|
9587
|
|
|
|
|
|
Returns a boolean indicating whether the SV is blessed into the specified |
9588
|
|
|
|
|
|
class. This does not check for subtypes; use C to verify |
9589
|
|
|
|
|
|
an inheritance relationship. |
9590
|
|
|
|
|
|
|
9591
|
|
|
|
|
|
=cut |
9592
|
|
|
|
|
|
*/ |
9593
|
|
|
|
|
|
|
9594
|
|
|
|
|
|
int |
9595
|
132
|
|
|
|
|
Perl_sv_isa(pTHX_ SV *sv, const char *const name) |
9596
|
132
|
50
|
|
|
|
{ |
9597
|
|
|
|
|
|
const char *hvname; |
9598
|
|
|
|
|
|
|
9599
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_ISA; |
9600
|
|
|
|
|
|
|
9601
|
132
|
50
|
|
|
|
if (!sv) |
9602
|
|
|
|
|
|
return 0; |
9603
|
66
|
|
|
|
|
SvGETMAGIC(sv); |
9604
|
132
|
100
|
|
|
|
if (!SvROK(sv)) |
9605
|
|
|
|
|
|
return 0; |
9606
|
98
|
|
|
|
|
sv = SvRV(sv); |
9607
|
98
|
50
|
|
|
|
if (!SvOBJECT(sv)) |
9608
|
|
|
|
|
|
return 0; |
9609
|
98
|
50
|
|
|
|
hvname = HvNAME_get(SvSTASH(sv)); |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
9610
|
98
|
50
|
|
|
|
if (!hvname) |
9611
|
|
|
|
|
|
return 0; |
9612
|
|
|
|
|
|
|
9613
|
115
|
|
|
|
|
return strEQ(hvname, name); |
9614
|
|
|
|
|
|
} |
9615
|
|
|
|
|
|
|
9616
|
|
|
|
|
|
/* |
9617
|
|
|
|
|
|
=for apidoc newSVrv |
9618
|
|
|
|
|
|
|
9619
|
|
|
|
|
|
Creates a new SV for the existing RV, C, to point to. If C is not an |
9620
|
|
|
|
|
|
RV then it will be upgraded to one. If C is non-null then the new |
9621
|
|
|
|
|
|
SV will be blessed in the specified package. The new SV is returned and its |
9622
|
|
|
|
|
|
reference count is 1. The reference count 1 is owned by C. |
9623
|
|
|
|
|
|
|
9624
|
|
|
|
|
|
=cut |
9625
|
|
|
|
|
|
*/ |
9626
|
|
|
|
|
|
|
9627
|
|
|
|
|
|
SV* |
9628
|
469101332
|
|
|
|
|
Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) |
9629
|
|
|
|
|
|
{ |
9630
|
|
|
|
|
|
dVAR; |
9631
|
|
|
|
|
|
SV *sv; |
9632
|
|
|
|
|
|
|
9633
|
|
|
|
|
|
PERL_ARGS_ASSERT_NEWSVRV; |
9634
|
|
|
|
|
|
|
9635
|
469101332
|
100
|
|
|
|
new_SV(sv); |
9636
|
|
|
|
|
|
|
9637
|
469101332
|
100
|
|
|
|
SV_CHECK_THINKFIRST_COW_DROP(rv); |
9638
|
|
|
|
|
|
|
9639
|
469101332
|
100
|
|
|
|
if (SvTYPE(rv) >= SVt_PVMG) { |
9640
|
832
|
|
|
|
|
const U32 refcnt = SvREFCNT(rv); |
9641
|
832
|
|
|
|
|
SvREFCNT(rv) = 0; |
9642
|
832
|
|
|
|
|
sv_clear(rv); |
9643
|
832
|
|
|
|
|
SvFLAGS(rv) = 0; |
9644
|
832
|
|
|
|
|
SvREFCNT(rv) = refcnt; |
9645
|
|
|
|
|
|
|
9646
|
832
|
|
|
|
|
sv_upgrade(rv, SVt_IV); |
9647
|
469100500
|
50
|
|
|
|
} else if (SvROK(rv)) { |
9648
|
0
|
|
|
|
|
SvREFCNT_dec(SvRV(rv)); |
9649
|
|
|
|
|
|
} else { |
9650
|
469100500
|
100
|
|
|
|
prepare_SV_for_RV(rv); |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
9651
|
|
|
|
|
|
} |
9652
|
|
|
|
|
|
|
9653
|
469101332
|
50
|
|
|
|
SvOK_off(rv); |
9654
|
469101332
|
|
|
|
|
SvRV_set(rv, sv); |
9655
|
469101332
|
|
|
|
|
SvROK_on(rv); |
9656
|
|
|
|
|
|
|
9657
|
469101332
|
100
|
|
|
|
if (classname) { |
9658
|
469101330
|
|
|
|
|
HV* const stash = gv_stashpv(classname, GV_ADD); |
9659
|
469101330
|
|
|
|
|
(void)sv_bless(rv, stash); |
9660
|
|
|
|
|
|
} |
9661
|
469101332
|
|
|
|
|
return sv; |
9662
|
|
|
|
|
|
} |
9663
|
|
|
|
|
|
|
9664
|
|
|
|
|
|
/* |
9665
|
|
|
|
|
|
=for apidoc sv_setref_pv |
9666
|
|
|
|
|
|
|
9667
|
|
|
|
|
|
Copies a pointer into a new SV, optionally blessing the SV. The C |
9668
|
|
|
|
|
|
argument will be upgraded to an RV. That RV will be modified to point to |
9669
|
|
|
|
|
|
the new SV. If the C argument is NULL then C will be placed |
9670
|
|
|
|
|
|
into the SV. The C argument indicates the package for the |
9671
|
|
|
|
|
|
blessing. Set C to C to avoid the blessing. The new SV |
9672
|
|
|
|
|
|
will have a reference count of 1, and the RV will be returned. |
9673
|
|
|
|
|
|
|
9674
|
|
|
|
|
|
Do not use with other Perl types such as HV, AV, SV, CV, because those |
9675
|
|
|
|
|
|
objects will become corrupted by the pointer copy process. |
9676
|
|
|
|
|
|
|
9677
|
|
|
|
|
|
Note that C copies the string while this copies the pointer. |
9678
|
|
|
|
|
|
|
9679
|
|
|
|
|
|
=cut |
9680
|
|
|
|
|
|
*/ |
9681
|
|
|
|
|
|
|
9682
|
|
|
|
|
|
SV* |
9683
|
28768
|
|
|
|
|
Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) |
9684
|
|
|
|
|
|
{ |
9685
|
|
|
|
|
|
dVAR; |
9686
|
|
|
|
|
|
|
9687
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETREF_PV; |
9688
|
|
|
|
|
|
|
9689
|
28768
|
100
|
|
|
|
if (!pv) { |
9690
|
18
|
|
|
|
|
sv_setsv(rv, &PL_sv_undef); |
9691
|
18
|
50
|
|
|
|
SvSETMAGIC(rv); |
9692
|
|
|
|
|
|
} |
9693
|
|
|
|
|
|
else |
9694
|
28750
|
|
|
|
|
sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); |
9695
|
28768
|
|
|
|
|
return rv; |
9696
|
|
|
|
|
|
} |
9697
|
|
|
|
|
|
|
9698
|
|
|
|
|
|
/* |
9699
|
|
|
|
|
|
=for apidoc sv_setref_iv |
9700
|
|
|
|
|
|
|
9701
|
|
|
|
|
|
Copies an integer into a new SV, optionally blessing the SV. The C |
9702
|
|
|
|
|
|
argument will be upgraded to an RV. That RV will be modified to point to |
9703
|
|
|
|
|
|
the new SV. The C argument indicates the package for the |
9704
|
|
|
|
|
|
blessing. Set C to C to avoid the blessing. The new SV |
9705
|
|
|
|
|
|
will have a reference count of 1, and the RV will be returned. |
9706
|
|
|
|
|
|
|
9707
|
|
|
|
|
|
=cut |
9708
|
|
|
|
|
|
*/ |
9709
|
|
|
|
|
|
|
9710
|
|
|
|
|
|
SV* |
9711
|
0
|
|
|
|
|
Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv) |
9712
|
|
|
|
|
|
{ |
9713
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETREF_IV; |
9714
|
|
|
|
|
|
|
9715
|
0
|
|
|
|
|
sv_setiv(newSVrv(rv,classname), iv); |
9716
|
0
|
|
|
|
|
return rv; |
9717
|
|
|
|
|
|
} |
9718
|
|
|
|
|
|
|
9719
|
|
|
|
|
|
/* |
9720
|
|
|
|
|
|
=for apidoc sv_setref_uv |
9721
|
|
|
|
|
|
|
9722
|
|
|
|
|
|
Copies an unsigned integer into a new SV, optionally blessing the SV. The C |
9723
|
|
|
|
|
|
argument will be upgraded to an RV. That RV will be modified to point to |
9724
|
|
|
|
|
|
the new SV. The C argument indicates the package for the |
9725
|
|
|
|
|
|
blessing. Set C to C to avoid the blessing. The new SV |
9726
|
|
|
|
|
|
will have a reference count of 1, and the RV will be returned. |
9727
|
|
|
|
|
|
|
9728
|
|
|
|
|
|
=cut |
9729
|
|
|
|
|
|
*/ |
9730
|
|
|
|
|
|
|
9731
|
|
|
|
|
|
SV* |
9732
|
0
|
|
|
|
|
Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv) |
9733
|
|
|
|
|
|
{ |
9734
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETREF_UV; |
9735
|
|
|
|
|
|
|
9736
|
0
|
|
|
|
|
sv_setuv(newSVrv(rv,classname), uv); |
9737
|
0
|
|
|
|
|
return rv; |
9738
|
|
|
|
|
|
} |
9739
|
|
|
|
|
|
|
9740
|
|
|
|
|
|
/* |
9741
|
|
|
|
|
|
=for apidoc sv_setref_nv |
9742
|
|
|
|
|
|
|
9743
|
|
|
|
|
|
Copies a double into a new SV, optionally blessing the SV. The C |
9744
|
|
|
|
|
|
argument will be upgraded to an RV. That RV will be modified to point to |
9745
|
|
|
|
|
|
the new SV. The C argument indicates the package for the |
9746
|
|
|
|
|
|
blessing. Set C to C to avoid the blessing. The new SV |
9747
|
|
|
|
|
|
will have a reference count of 1, and the RV will be returned. |
9748
|
|
|
|
|
|
|
9749
|
|
|
|
|
|
=cut |
9750
|
|
|
|
|
|
*/ |
9751
|
|
|
|
|
|
|
9752
|
|
|
|
|
|
SV* |
9753
|
0
|
|
|
|
|
Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv) |
9754
|
|
|
|
|
|
{ |
9755
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETREF_NV; |
9756
|
|
|
|
|
|
|
9757
|
0
|
|
|
|
|
sv_setnv(newSVrv(rv,classname), nv); |
9758
|
0
|
|
|
|
|
return rv; |
9759
|
|
|
|
|
|
} |
9760
|
|
|
|
|
|
|
9761
|
|
|
|
|
|
/* |
9762
|
|
|
|
|
|
=for apidoc sv_setref_pvn |
9763
|
|
|
|
|
|
|
9764
|
|
|
|
|
|
Copies a string into a new SV, optionally blessing the SV. The length of the |
9765
|
|
|
|
|
|
string must be specified with C. The C argument will be upgraded to |
9766
|
|
|
|
|
|
an RV. That RV will be modified to point to the new SV. The C |
9767
|
|
|
|
|
|
argument indicates the package for the blessing. Set C to |
9768
|
|
|
|
|
|
C to avoid the blessing. The new SV will have a reference count |
9769
|
|
|
|
|
|
of 1, and the RV will be returned. |
9770
|
|
|
|
|
|
|
9771
|
|
|
|
|
|
Note that C copies the pointer while this copies the string. |
9772
|
|
|
|
|
|
|
9773
|
|
|
|
|
|
=cut |
9774
|
|
|
|
|
|
*/ |
9775
|
|
|
|
|
|
|
9776
|
|
|
|
|
|
SV* |
9777
|
0
|
|
|
|
|
Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname, |
9778
|
|
|
|
|
|
const char *const pv, const STRLEN n) |
9779
|
|
|
|
|
|
{ |
9780
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETREF_PVN; |
9781
|
|
|
|
|
|
|
9782
|
0
|
|
|
|
|
sv_setpvn(newSVrv(rv,classname), pv, n); |
9783
|
0
|
|
|
|
|
return rv; |
9784
|
|
|
|
|
|
} |
9785
|
|
|
|
|
|
|
9786
|
|
|
|
|
|
/* |
9787
|
|
|
|
|
|
=for apidoc sv_bless |
9788
|
|
|
|
|
|
|
9789
|
|
|
|
|
|
Blesses an SV into a specified package. The SV must be an RV. The package |
9790
|
|
|
|
|
|
must be designated by its stash (see C). The reference count |
9791
|
|
|
|
|
|
of the SV is unaffected. |
9792
|
|
|
|
|
|
|
9793
|
|
|
|
|
|
=cut |
9794
|
|
|
|
|
|
*/ |
9795
|
|
|
|
|
|
|
9796
|
|
|
|
|
|
SV* |
9797
|
479452858
|
|
|
|
|
Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) |
9798
|
958905712
|
100
|
|
|
|
{ |
|
|
100
|
|
|
|
|
9799
|
|
|
|
|
|
dVAR; |
9800
|
|
|
|
|
|
SV *tmpRef; |
9801
|
|
|
|
|
|
|
9802
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_BLESS; |
9803
|
|
|
|
|
|
|
9804
|
239697997
|
|
|
|
|
SvGETMAGIC(sv); |
9805
|
479452858
|
100
|
|
|
|
if (!SvROK(sv)) |
9806
|
2
|
|
|
|
|
Perl_croak(aTHX_ "Can't bless non-reference value"); |
9807
|
479452856
|
|
|
|
|
tmpRef = SvRV(sv); |
9808
|
479452856
|
100
|
|
|
|
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { |
9809
|
27162
|
100
|
|
|
|
if (SvREADONLY(tmpRef)) |
9810
|
2
|
|
|
|
|
Perl_croak_no_modify(); |
9811
|
27160
|
50
|
|
|
|
if (SvOBJECT(tmpRef)) { |
9812
|
27160
|
|
|
|
|
SvREFCNT_dec(SvSTASH(tmpRef)); |
9813
|
|
|
|
|
|
} |
9814
|
|
|
|
|
|
} |
9815
|
479452854
|
|
|
|
|
SvOBJECT_on(tmpRef); |
9816
|
710334900
|
|
|
|
|
SvUPGRADE(tmpRef, SVt_PVMG); |
9817
|
958905708
|
|
|
|
|
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); |
9818
|
|
|
|
|
|
|
9819
|
479452854
|
100
|
|
|
|
if(SvSMAGICAL(tmpRef)) |
9820
|
26
|
50
|
|
|
|
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) |
|
|
100
|
|
|
|
|
9821
|
8
|
|
|
|
|
mg_set(tmpRef); |
9822
|
|
|
|
|
|
|
9823
|
|
|
|
|
|
|
9824
|
|
|
|
|
|
|
9825
|
479452854
|
|
|
|
|
return sv; |
9826
|
|
|
|
|
|
} |
9827
|
|
|
|
|
|
|
9828
|
|
|
|
|
|
/* Downgrades a PVGV to a PVMG. If it's actually a PVLV, we leave the type |
9829
|
|
|
|
|
|
* as it is after unglobbing it. |
9830
|
|
|
|
|
|
*/ |
9831
|
|
|
|
|
|
|
9832
|
|
|
|
|
|
PERL_STATIC_INLINE void |
9833
|
|
|
|
|
|
S_sv_unglob(pTHX_ SV *const sv, U32 flags) |
9834
|
|
|
|
|
|
{ |
9835
|
|
|
|
|
|
dVAR; |
9836
|
|
|
|
|
|
void *xpvmg; |
9837
|
|
|
|
|
|
HV *stash; |
9838
|
27082808
|
100
|
|
|
|
SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal(); |
9839
|
|
|
|
|
|
|
9840
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UNGLOB; |
9841
|
|
|
|
|
|
|
9842
|
|
|
|
|
|
assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); |
9843
|
27082808
|
|
|
|
|
SvFAKE_off(sv); |
9844
|
27082808
|
100
|
|
|
|
if (!(flags & SV_COW_DROP_PV)) |
9845
|
88
|
|
|
|
|
gv_efullname3(temp, MUTABLE_GV(sv), "*"); |
9846
|
|
|
|
|
|
|
9847
|
27082808
|
50
|
|
|
|
if (GvGP(sv)) { |
9848
|
27082808
|
50
|
|
|
|
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
9849
|
19297452
|
50
|
|
|
|
&& HvNAME_get(stash)) |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
9850
|
19297452
|
|
|
|
|
mro_method_changed_in(stash); |
9851
|
27082808
|
|
|
|
|
gp_free(MUTABLE_GV(sv)); |
9852
|
|
|
|
|
|
} |
9853
|
27082808
|
100
|
|
|
|
if (GvSTASH(sv)) { |
9854
|
27082774
|
|
|
|
|
sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); |
9855
|
27082774
|
|
|
|
|
GvSTASH(sv) = NULL; |
9856
|
|
|
|
|
|
} |
9857
|
27082808
|
|
|
|
|
GvMULTI_off(sv); |
9858
|
27082808
|
50
|
|
|
|
if (GvNAME_HEK(sv)) { |
9859
|
27082808
|
|
|
|
|
unshare_hek(GvNAME_HEK(sv)); |
9860
|
|
|
|
|
|
} |
9861
|
27082808
|
|
|
|
|
isGV_with_GP_off(sv); |
9862
|
|
|
|
|
|
|
9863
|
27082808
|
100
|
|
|
|
if(SvTYPE(sv) == SVt_PVGV) { |
9864
|
|
|
|
|
|
/* need to keep SvANY(sv) in the right arena */ |
9865
|
27082694
|
|
|
|
|
xpvmg = new_XPVMG(); |
9866
|
27082694
|
|
|
|
|
StructCopy(SvANY(sv), xpvmg, XPVMG); |
9867
|
27082694
|
|
|
|
|
del_XPVGV(SvANY(sv)); |
9868
|
27082694
|
|
|
|
|
SvANY(sv) = xpvmg; |
9869
|
|
|
|
|
|
|
9870
|
27082694
|
|
|
|
|
SvFLAGS(sv) &= ~SVTYPEMASK; |
9871
|
27082694
|
|
|
|
|
SvFLAGS(sv) |= SVt_PVMG; |
9872
|
|
|
|
|
|
} |
9873
|
|
|
|
|
|
|
9874
|
|
|
|
|
|
/* Intentionally not calling any local SET magic, as this isn't so much a |
9875
|
|
|
|
|
|
set operation as merely an internal storage change. */ |
9876
|
27082808
|
100
|
|
|
|
if (flags & SV_COW_DROP_PV) SvOK_off(sv); |
|
|
50
|
|
|
|
|
9877
|
88
|
|
|
|
|
else sv_setsv_flags(sv, temp, 0); |
9878
|
|
|
|
|
|
|
9879
|
27082808
|
100
|
|
|
|
if ((const GV *)sv == PL_last_in_gv) |
9880
|
12
|
|
|
|
|
PL_last_in_gv = NULL; |
9881
|
27082796
|
100
|
|
|
|
else if ((const GV *)sv == PL_statgv) |
9882
|
10
|
|
|
|
|
PL_statgv = NULL; |
9883
|
|
|
|
|
|
} |
9884
|
|
|
|
|
|
|
9885
|
|
|
|
|
|
/* |
9886
|
|
|
|
|
|
=for apidoc sv_unref_flags |
9887
|
|
|
|
|
|
|
9888
|
|
|
|
|
|
Unsets the RV status of the SV, and decrements the reference count of |
9889
|
|
|
|
|
|
whatever was being referenced by the RV. This can almost be thought of |
9890
|
|
|
|
|
|
as a reversal of C. The C argument can contain |
9891
|
|
|
|
|
|
C to force the reference count to be decremented |
9892
|
|
|
|
|
|
(otherwise the decrementing is conditional on the reference count being |
9893
|
|
|
|
|
|
different from one or the reference being a readonly SV). |
9894
|
|
|
|
|
|
See C. |
9895
|
|
|
|
|
|
|
9896
|
|
|
|
|
|
=cut |
9897
|
|
|
|
|
|
*/ |
9898
|
|
|
|
|
|
|
9899
|
|
|
|
|
|
void |
9900
|
465447685
|
|
|
|
|
Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) |
9901
|
|
|
|
|
|
{ |
9902
|
465447685
|
|
|
|
|
SV* const target = SvRV(ref); |
9903
|
|
|
|
|
|
|
9904
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UNREF_FLAGS; |
9905
|
|
|
|
|
|
|
9906
|
465447685
|
100
|
|
|
|
if (SvWEAKREF(ref)) { |
9907
|
36
|
|
|
|
|
sv_del_backref(target, ref); |
9908
|
36
|
|
|
|
|
SvWEAKREF_off(ref); |
9909
|
36
|
|
|
|
|
SvRV_set(ref, NULL); |
9910
|
465447701
|
|
|
|
|
return; |
9911
|
|
|
|
|
|
} |
9912
|
465447649
|
|
|
|
|
SvRV_set(ref, NULL); |
9913
|
465447649
|
|
|
|
|
SvROK_off(ref); |
9914
|
|
|
|
|
|
/* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was |
9915
|
|
|
|
|
|
assigned to as BEGIN {$a = \"Foo"} will fail. */ |
9916
|
465447649
|
100
|
|
|
|
if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) |
|
|
100
|
|
|
|
|
9917
|
446404657
|
|
|
|
|
SvREFCNT_dec_NN(target); |
9918
|
|
|
|
|
|
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ |
9919
|
19042992
|
|
|
|
|
sv_2mortal(target); /* Schedule for freeing later */ |
9920
|
|
|
|
|
|
} |
9921
|
|
|
|
|
|
|
9922
|
|
|
|
|
|
/* |
9923
|
|
|
|
|
|
=for apidoc sv_untaint |
9924
|
|
|
|
|
|
|
9925
|
|
|
|
|
|
Untaint an SV. Use C instead. |
9926
|
|
|
|
|
|
|
9927
|
|
|
|
|
|
=cut |
9928
|
|
|
|
|
|
*/ |
9929
|
|
|
|
|
|
|
9930
|
|
|
|
|
|
void |
9931
|
17538
|
|
|
|
|
Perl_sv_untaint(pTHX_ SV *const sv) |
9932
|
|
|
|
|
|
{ |
9933
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_UNTAINT; |
9934
|
|
|
|
|
|
|
9935
|
17538
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
50
|
|
|
|
|
9936
|
5574
|
|
|
|
|
MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); |
9937
|
5574
|
100
|
|
|
|
if (mg) |
9938
|
14
|
|
|
|
|
mg->mg_len &= ~1; |
9939
|
|
|
|
|
|
} |
9940
|
17538
|
|
|
|
|
} |
9941
|
|
|
|
|
|
|
9942
|
|
|
|
|
|
/* |
9943
|
|
|
|
|
|
=for apidoc sv_tainted |
9944
|
|
|
|
|
|
|
9945
|
|
|
|
|
|
Test an SV for taintedness. Use C instead. |
9946
|
|
|
|
|
|
|
9947
|
|
|
|
|
|
=cut |
9948
|
|
|
|
|
|
*/ |
9949
|
|
|
|
|
|
|
9950
|
|
|
|
|
|
bool |
9951
|
60396687
|
|
|
|
|
Perl_sv_tainted(pTHX_ SV *const sv) |
9952
|
|
|
|
|
|
{ |
9953
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_TAINTED; |
9954
|
|
|
|
|
|
|
9955
|
60396687
|
50
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
50
|
|
|
|
|
9956
|
60396687
|
|
|
|
|
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); |
9957
|
60396687
|
100
|
|
|
|
if (mg && (mg->mg_len & 1) ) |
|
|
100
|
|
|
|
|
9958
|
|
|
|
|
|
return TRUE; |
9959
|
|
|
|
|
|
} |
9960
|
60390655
|
|
|
|
|
return FALSE; |
9961
|
|
|
|
|
|
} |
9962
|
|
|
|
|
|
|
9963
|
|
|
|
|
|
/* |
9964
|
|
|
|
|
|
=for apidoc sv_setpviv |
9965
|
|
|
|
|
|
|
9966
|
|
|
|
|
|
Copies an integer into the given SV, also updating its string value. |
9967
|
|
|
|
|
|
Does not handle 'set' magic. See C. |
9968
|
|
|
|
|
|
|
9969
|
|
|
|
|
|
=cut |
9970
|
|
|
|
|
|
*/ |
9971
|
|
|
|
|
|
|
9972
|
|
|
|
|
|
void |
9973
|
0
|
|
|
|
|
Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv) |
9974
|
|
|
|
|
|
{ |
9975
|
|
|
|
|
|
char buf[TYPE_CHARS(UV)]; |
9976
|
|
|
|
|
|
char *ebuf; |
9977
|
|
|
|
|
|
char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); |
9978
|
|
|
|
|
|
|
9979
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVIV; |
9980
|
|
|
|
|
|
|
9981
|
0
|
|
|
|
|
sv_setpvn(sv, ptr, ebuf - ptr); |
9982
|
0
|
|
|
|
|
} |
9983
|
|
|
|
|
|
|
9984
|
|
|
|
|
|
/* |
9985
|
|
|
|
|
|
=for apidoc sv_setpviv_mg |
9986
|
|
|
|
|
|
|
9987
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
9988
|
|
|
|
|
|
|
9989
|
|
|
|
|
|
=cut |
9990
|
|
|
|
|
|
*/ |
9991
|
|
|
|
|
|
|
9992
|
|
|
|
|
|
void |
9993
|
0
|
|
|
|
|
Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) |
9994
|
|
|
|
|
|
{ |
9995
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVIV_MG; |
9996
|
|
|
|
|
|
|
9997
|
0
|
|
|
|
|
sv_setpviv(sv, iv); |
9998
|
0
|
0
|
|
|
|
SvSETMAGIC(sv); |
9999
|
0
|
|
|
|
|
} |
10000
|
|
|
|
|
|
|
10001
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
10002
|
|
|
|
|
|
|
10003
|
|
|
|
|
|
/* pTHX_ magic can't cope with varargs, so this is a no-context |
10004
|
|
|
|
|
|
* version of the main function, (which may itself be aliased to us). |
10005
|
|
|
|
|
|
* Don't access this version directly. |
10006
|
|
|
|
|
|
*/ |
10007
|
|
|
|
|
|
|
10008
|
|
|
|
|
|
void |
10009
|
|
|
|
|
|
Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...) |
10010
|
|
|
|
|
|
{ |
10011
|
|
|
|
|
|
dTHX; |
10012
|
|
|
|
|
|
va_list args; |
10013
|
|
|
|
|
|
|
10014
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT; |
10015
|
|
|
|
|
|
|
10016
|
|
|
|
|
|
va_start(args, pat); |
10017
|
|
|
|
|
|
sv_vsetpvf(sv, pat, &args); |
10018
|
|
|
|
|
|
va_end(args); |
10019
|
|
|
|
|
|
} |
10020
|
|
|
|
|
|
|
10021
|
|
|
|
|
|
/* pTHX_ magic can't cope with varargs, so this is a no-context |
10022
|
|
|
|
|
|
* version of the main function, (which may itself be aliased to us). |
10023
|
|
|
|
|
|
* Don't access this version directly. |
10024
|
|
|
|
|
|
*/ |
10025
|
|
|
|
|
|
|
10026
|
|
|
|
|
|
void |
10027
|
|
|
|
|
|
Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) |
10028
|
|
|
|
|
|
{ |
10029
|
|
|
|
|
|
dTHX; |
10030
|
|
|
|
|
|
va_list args; |
10031
|
|
|
|
|
|
|
10032
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT; |
10033
|
|
|
|
|
|
|
10034
|
|
|
|
|
|
va_start(args, pat); |
10035
|
|
|
|
|
|
sv_vsetpvf_mg(sv, pat, &args); |
10036
|
|
|
|
|
|
va_end(args); |
10037
|
|
|
|
|
|
} |
10038
|
|
|
|
|
|
#endif |
10039
|
|
|
|
|
|
|
10040
|
|
|
|
|
|
/* |
10041
|
|
|
|
|
|
=for apidoc sv_setpvf |
10042
|
|
|
|
|
|
|
10043
|
|
|
|
|
|
Works like C but copies the text into the SV instead of |
10044
|
|
|
|
|
|
appending it. Does not handle 'set' magic. See C. |
10045
|
|
|
|
|
|
|
10046
|
|
|
|
|
|
=cut |
10047
|
|
|
|
|
|
*/ |
10048
|
|
|
|
|
|
|
10049
|
|
|
|
|
|
void |
10050
|
4685153
|
|
|
|
|
Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...) |
10051
|
|
|
|
|
|
{ |
10052
|
|
|
|
|
|
va_list args; |
10053
|
|
|
|
|
|
|
10054
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVF; |
10055
|
|
|
|
|
|
|
10056
|
4685153
|
|
|
|
|
va_start(args, pat); |
10057
|
4685153
|
|
|
|
|
sv_vsetpvf(sv, pat, &args); |
10058
|
4685153
|
|
|
|
|
va_end(args); |
10059
|
4685153
|
|
|
|
|
} |
10060
|
|
|
|
|
|
|
10061
|
|
|
|
|
|
/* |
10062
|
|
|
|
|
|
=for apidoc sv_vsetpvf |
10063
|
|
|
|
|
|
|
10064
|
|
|
|
|
|
Works like C but copies the text into the SV instead of |
10065
|
|
|
|
|
|
appending it. Does not handle 'set' magic. See C. |
10066
|
|
|
|
|
|
|
10067
|
|
|
|
|
|
Usually used via its frontend C. |
10068
|
|
|
|
|
|
|
10069
|
|
|
|
|
|
=cut |
10070
|
|
|
|
|
|
*/ |
10071
|
|
|
|
|
|
|
10072
|
|
|
|
|
|
void |
10073
|
4685155
|
|
|
|
|
Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) |
10074
|
|
|
|
|
|
{ |
10075
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VSETPVF; |
10076
|
|
|
|
|
|
|
10077
|
4685155
|
|
|
|
|
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
10078
|
4685155
|
|
|
|
|
} |
10079
|
|
|
|
|
|
|
10080
|
|
|
|
|
|
/* |
10081
|
|
|
|
|
|
=for apidoc sv_setpvf_mg |
10082
|
|
|
|
|
|
|
10083
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
10084
|
|
|
|
|
|
|
10085
|
|
|
|
|
|
=cut |
10086
|
|
|
|
|
|
*/ |
10087
|
|
|
|
|
|
|
10088
|
|
|
|
|
|
void |
10089
|
6
|
|
|
|
|
Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) |
10090
|
|
|
|
|
|
{ |
10091
|
|
|
|
|
|
va_list args; |
10092
|
|
|
|
|
|
|
10093
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_SETPVF_MG; |
10094
|
|
|
|
|
|
|
10095
|
6
|
|
|
|
|
va_start(args, pat); |
10096
|
6
|
|
|
|
|
sv_vsetpvf_mg(sv, pat, &args); |
10097
|
6
|
|
|
|
|
va_end(args); |
10098
|
6
|
|
|
|
|
} |
10099
|
|
|
|
|
|
|
10100
|
|
|
|
|
|
/* |
10101
|
|
|
|
|
|
=for apidoc sv_vsetpvf_mg |
10102
|
|
|
|
|
|
|
10103
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
10104
|
|
|
|
|
|
|
10105
|
|
|
|
|
|
Usually used via its frontend C. |
10106
|
|
|
|
|
|
|
10107
|
|
|
|
|
|
=cut |
10108
|
|
|
|
|
|
*/ |
10109
|
|
|
|
|
|
|
10110
|
|
|
|
|
|
void |
10111
|
6
|
|
|
|
|
Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) |
10112
|
|
|
|
|
|
{ |
10113
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VSETPVF_MG; |
10114
|
|
|
|
|
|
|
10115
|
6
|
|
|
|
|
sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
10116
|
6
|
50
|
|
|
|
SvSETMAGIC(sv); |
10117
|
6
|
|
|
|
|
} |
10118
|
|
|
|
|
|
|
10119
|
|
|
|
|
|
#if defined(PERL_IMPLICIT_CONTEXT) |
10120
|
|
|
|
|
|
|
10121
|
|
|
|
|
|
/* pTHX_ magic can't cope with varargs, so this is a no-context |
10122
|
|
|
|
|
|
* version of the main function, (which may itself be aliased to us). |
10123
|
|
|
|
|
|
* Don't access this version directly. |
10124
|
|
|
|
|
|
*/ |
10125
|
|
|
|
|
|
|
10126
|
|
|
|
|
|
void |
10127
|
|
|
|
|
|
Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) |
10128
|
|
|
|
|
|
{ |
10129
|
|
|
|
|
|
dTHX; |
10130
|
|
|
|
|
|
va_list args; |
10131
|
|
|
|
|
|
|
10132
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT; |
10133
|
|
|
|
|
|
|
10134
|
|
|
|
|
|
va_start(args, pat); |
10135
|
|
|
|
|
|
sv_vcatpvf(sv, pat, &args); |
10136
|
|
|
|
|
|
va_end(args); |
10137
|
|
|
|
|
|
} |
10138
|
|
|
|
|
|
|
10139
|
|
|
|
|
|
/* pTHX_ magic can't cope with varargs, so this is a no-context |
10140
|
|
|
|
|
|
* version of the main function, (which may itself be aliased to us). |
10141
|
|
|
|
|
|
* Don't access this version directly. |
10142
|
|
|
|
|
|
*/ |
10143
|
|
|
|
|
|
|
10144
|
|
|
|
|
|
void |
10145
|
|
|
|
|
|
Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) |
10146
|
|
|
|
|
|
{ |
10147
|
|
|
|
|
|
dTHX; |
10148
|
|
|
|
|
|
va_list args; |
10149
|
|
|
|
|
|
|
10150
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT; |
10151
|
|
|
|
|
|
|
10152
|
|
|
|
|
|
va_start(args, pat); |
10153
|
|
|
|
|
|
sv_vcatpvf_mg(sv, pat, &args); |
10154
|
|
|
|
|
|
va_end(args); |
10155
|
|
|
|
|
|
} |
10156
|
|
|
|
|
|
#endif |
10157
|
|
|
|
|
|
|
10158
|
|
|
|
|
|
/* |
10159
|
|
|
|
|
|
=for apidoc sv_catpvf |
10160
|
|
|
|
|
|
|
10161
|
|
|
|
|
|
Processes its arguments like C and appends the formatted |
10162
|
|
|
|
|
|
output to an SV. If the appended data contains "wide" characters |
10163
|
|
|
|
|
|
(including, but not limited to, SVs with a UTF-8 PV formatted with %s, |
10164
|
|
|
|
|
|
and characters >255 formatted with %c), the original SV might get |
10165
|
|
|
|
|
|
upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See |
10166
|
|
|
|
|
|
C. If the original SV was UTF-8, the pattern should be |
10167
|
|
|
|
|
|
valid UTF-8; if the original SV was bytes, the pattern should be too. |
10168
|
|
|
|
|
|
|
10169
|
|
|
|
|
|
=cut */ |
10170
|
|
|
|
|
|
|
10171
|
|
|
|
|
|
void |
10172
|
1553291
|
|
|
|
|
Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) |
10173
|
|
|
|
|
|
{ |
10174
|
|
|
|
|
|
va_list args; |
10175
|
|
|
|
|
|
|
10176
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPVF; |
10177
|
|
|
|
|
|
|
10178
|
1553291
|
|
|
|
|
va_start(args, pat); |
10179
|
1553291
|
|
|
|
|
sv_vcatpvf(sv, pat, &args); |
10180
|
1553291
|
|
|
|
|
va_end(args); |
10181
|
1553291
|
|
|
|
|
} |
10182
|
|
|
|
|
|
|
10183
|
|
|
|
|
|
/* |
10184
|
|
|
|
|
|
=for apidoc sv_vcatpvf |
10185
|
|
|
|
|
|
|
10186
|
|
|
|
|
|
Processes its arguments like C and appends the formatted output |
10187
|
|
|
|
|
|
to an SV. Does not handle 'set' magic. See C. |
10188
|
|
|
|
|
|
|
10189
|
|
|
|
|
|
Usually used via its frontend C. |
10190
|
|
|
|
|
|
|
10191
|
|
|
|
|
|
=cut |
10192
|
|
|
|
|
|
*/ |
10193
|
|
|
|
|
|
|
10194
|
|
|
|
|
|
void |
10195
|
1553293
|
|
|
|
|
Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) |
10196
|
|
|
|
|
|
{ |
10197
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VCATPVF; |
10198
|
|
|
|
|
|
|
10199
|
1553293
|
|
|
|
|
sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
10200
|
1553293
|
|
|
|
|
} |
10201
|
|
|
|
|
|
|
10202
|
|
|
|
|
|
/* |
10203
|
|
|
|
|
|
=for apidoc sv_catpvf_mg |
10204
|
|
|
|
|
|
|
10205
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
10206
|
|
|
|
|
|
|
10207
|
|
|
|
|
|
=cut |
10208
|
|
|
|
|
|
*/ |
10209
|
|
|
|
|
|
|
10210
|
|
|
|
|
|
void |
10211
|
6
|
|
|
|
|
Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) |
10212
|
|
|
|
|
|
{ |
10213
|
|
|
|
|
|
va_list args; |
10214
|
|
|
|
|
|
|
10215
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CATPVF_MG; |
10216
|
|
|
|
|
|
|
10217
|
6
|
|
|
|
|
va_start(args, pat); |
10218
|
6
|
|
|
|
|
sv_vcatpvf_mg(sv, pat, &args); |
10219
|
6
|
|
|
|
|
va_end(args); |
10220
|
6
|
|
|
|
|
} |
10221
|
|
|
|
|
|
|
10222
|
|
|
|
|
|
/* |
10223
|
|
|
|
|
|
=for apidoc sv_vcatpvf_mg |
10224
|
|
|
|
|
|
|
10225
|
|
|
|
|
|
Like C, but also handles 'set' magic. |
10226
|
|
|
|
|
|
|
10227
|
|
|
|
|
|
Usually used via its frontend C. |
10228
|
|
|
|
|
|
|
10229
|
|
|
|
|
|
=cut |
10230
|
|
|
|
|
|
*/ |
10231
|
|
|
|
|
|
|
10232
|
|
|
|
|
|
void |
10233
|
6
|
|
|
|
|
Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) |
10234
|
|
|
|
|
|
{ |
10235
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VCATPVF_MG; |
10236
|
|
|
|
|
|
|
10237
|
6
|
|
|
|
|
sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); |
10238
|
6
|
50
|
|
|
|
SvSETMAGIC(sv); |
10239
|
6
|
|
|
|
|
} |
10240
|
|
|
|
|
|
|
10241
|
|
|
|
|
|
/* |
10242
|
|
|
|
|
|
=for apidoc sv_vsetpvfn |
10243
|
|
|
|
|
|
|
10244
|
|
|
|
|
|
Works like C but copies the text into the SV instead of |
10245
|
|
|
|
|
|
appending it. |
10246
|
|
|
|
|
|
|
10247
|
|
|
|
|
|
Usually used via one of its frontends C and C. |
10248
|
|
|
|
|
|
|
10249
|
|
|
|
|
|
=cut |
10250
|
|
|
|
|
|
*/ |
10251
|
|
|
|
|
|
|
10252
|
|
|
|
|
|
void |
10253
|
10301269
|
|
|
|
|
Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, |
10254
|
|
|
|
|
|
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) |
10255
|
|
|
|
|
|
{ |
10256
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VSETPVFN; |
10257
|
|
|
|
|
|
|
10258
|
10301269
|
|
|
|
|
sv_setpvs(sv, ""); |
10259
|
10301269
|
|
|
|
|
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0); |
10260
|
10301237
|
|
|
|
|
} |
10261
|
|
|
|
|
|
|
10262
|
|
|
|
|
|
|
10263
|
|
|
|
|
|
/* |
10264
|
|
|
|
|
|
* Warn of missing argument to sprintf, and then return a defined value |
10265
|
|
|
|
|
|
* to avoid inappropriate "use of uninit" warnings [perl #71000]. |
10266
|
|
|
|
|
|
*/ |
10267
|
|
|
|
|
|
#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ |
10268
|
|
|
|
|
|
STATIC SV* |
10269
|
208
|
|
|
|
|
S_vcatpvfn_missing_argument(pTHX) { |
10270
|
208
|
100
|
|
|
|
if (ckWARN(WARN_MISSING)) { |
10271
|
204
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", |
10272
|
153
|
50
|
|
|
|
PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); |
|
|
0
|
|
|
|
|
10273
|
|
|
|
|
|
} |
10274
|
206
|
|
|
|
|
return &PL_sv_no; |
10275
|
|
|
|
|
|
} |
10276
|
|
|
|
|
|
|
10277
|
|
|
|
|
|
|
10278
|
|
|
|
|
|
STATIC I32 |
10279
|
54207043
|
|
|
|
|
S_expect_number(pTHX_ char **const pattern) |
10280
|
|
|
|
|
|
{ |
10281
|
|
|
|
|
|
dVAR; |
10282
|
|
|
|
|
|
I32 var = 0; |
10283
|
|
|
|
|
|
|
10284
|
|
|
|
|
|
PERL_ARGS_ASSERT_EXPECT_NUMBER; |
10285
|
|
|
|
|
|
|
10286
|
54207043
|
100
|
|
|
|
switch (**pattern) { |
10287
|
|
|
|
|
|
case '1': case '2': case '3': |
10288
|
|
|
|
|
|
case '4': case '5': case '6': |
10289
|
|
|
|
|
|
case '7': case '8': case '9': |
10290
|
3579391
|
|
|
|
|
var = *(*pattern)++ - '0'; |
10291
|
5483167
|
100
|
|
|
|
while (isDIGIT(**pattern)) { |
10292
|
115352
|
|
|
|
|
const I32 tmp = var * 10 + (*(*pattern)++ - '0'); |
10293
|
115352
|
100
|
|
|
|
if (tmp < var) |
10294
|
12
|
50
|
|
|
|
Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn")); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
10295
|
|
|
|
|
|
var = tmp; |
10296
|
|
|
|
|
|
} |
10297
|
|
|
|
|
|
} |
10298
|
54207031
|
|
|
|
|
return var; |
10299
|
|
|
|
|
|
} |
10300
|
|
|
|
|
|
|
10301
|
|
|
|
|
|
STATIC char * |
10302
|
856
|
|
|
|
|
S_F0convert(NV nv, char *const endbuf, STRLEN *const len) |
10303
|
|
|
|
|
|
{ |
10304
|
856
|
|
|
|
|
const int neg = nv < 0; |
10305
|
|
|
|
|
|
UV uv; |
10306
|
|
|
|
|
|
|
10307
|
|
|
|
|
|
PERL_ARGS_ASSERT_F0CONVERT; |
10308
|
|
|
|
|
|
|
10309
|
856
|
100
|
|
|
|
if (neg) |
10310
|
34
|
|
|
|
|
nv = -nv; |
10311
|
856
|
100
|
|
|
|
if (nv < UV_MAX) { |
10312
|
|
|
|
|
|
char *p = endbuf; |
10313
|
848
|
|
|
|
|
nv += 0.5; |
10314
|
848
|
|
|
|
|
uv = (UV)nv; |
10315
|
848
|
100
|
|
|
|
if (uv & 1 && uv == nv) |
|
|
50
|
|
|
|
|
10316
|
424
|
|
|
|
|
uv--; /* Round to even */ |
10317
|
|
|
|
|
|
do { |
10318
|
4150
|
|
|
|
|
const unsigned dig = uv % 10; |
10319
|
4150
|
|
|
|
|
*--p = '0' + dig; |
10320
|
4150
|
100
|
|
|
|
} while (uv /= 10); |
10321
|
848
|
100
|
|
|
|
if (neg) |
10322
|
34
|
|
|
|
|
*--p = '-'; |
10323
|
848
|
|
|
|
|
*len = endbuf - p; |
10324
|
852
|
|
|
|
|
return p; |
10325
|
|
|
|
|
|
} |
10326
|
|
|
|
|
|
return NULL; |
10327
|
|
|
|
|
|
} |
10328
|
|
|
|
|
|
|
10329
|
|
|
|
|
|
|
10330
|
|
|
|
|
|
/* |
10331
|
|
|
|
|
|
=for apidoc sv_vcatpvfn |
10332
|
|
|
|
|
|
|
10333
|
|
|
|
|
|
=for apidoc sv_vcatpvfn_flags |
10334
|
|
|
|
|
|
|
10335
|
|
|
|
|
|
Processes its arguments like C and appends the formatted output |
10336
|
|
|
|
|
|
to an SV. Uses an array of SVs if the C style variable argument list is |
10337
|
|
|
|
|
|
missing (NULL). When running with taint checks enabled, indicates via |
10338
|
|
|
|
|
|
C if results are untrustworthy (often due to the use of |
10339
|
|
|
|
|
|
locales). |
10340
|
|
|
|
|
|
|
10341
|
|
|
|
|
|
If called as C or flags include C, calls get magic. |
10342
|
|
|
|
|
|
|
10343
|
|
|
|
|
|
Usually used via one of its frontends C and C. |
10344
|
|
|
|
|
|
|
10345
|
|
|
|
|
|
=cut |
10346
|
|
|
|
|
|
*/ |
10347
|
|
|
|
|
|
|
10348
|
|
|
|
|
|
#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ |
10349
|
|
|
|
|
|
vecstr = (U8*)SvPV_const(vecsv,veclen);\ |
10350
|
|
|
|
|
|
vec_utf8 = DO_UTF8(vecsv); |
10351
|
|
|
|
|
|
|
10352
|
|
|
|
|
|
/* XXX maybe_tainted is never assigned to, so the doc above is lying. */ |
10353
|
|
|
|
|
|
|
10354
|
|
|
|
|
|
void |
10355
|
1553299
|
|
|
|
|
Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, |
10356
|
|
|
|
|
|
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) |
10357
|
|
|
|
|
|
{ |
10358
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VCATPVFN; |
10359
|
|
|
|
|
|
|
10360
|
1553299
|
|
|
|
|
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC); |
10361
|
1553299
|
|
|
|
|
} |
10362
|
|
|
|
|
|
|
10363
|
|
|
|
|
|
void |
10364
|
11854568
|
|
|
|
|
Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, |
10365
|
|
|
|
|
|
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, |
10366
|
|
|
|
|
|
const U32 flags) |
10367
|
|
|
|
|
|
{ |
10368
|
|
|
|
|
|
dVAR; |
10369
|
|
|
|
|
|
char *p; |
10370
|
|
|
|
|
|
char *q; |
10371
|
|
|
|
|
|
const char *patend; |
10372
|
|
|
|
|
|
STRLEN origlen; |
10373
|
|
|
|
|
|
I32 svix = 0; |
10374
|
|
|
|
|
|
static const char nullstr[] = "(null)"; |
10375
|
|
|
|
|
|
SV *argsv = NULL; |
10376
|
11854568
|
100
|
|
|
|
bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */ |
|
|
50
|
|
|
|
|
10377
|
|
|
|
|
|
const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */ |
10378
|
|
|
|
|
|
SV *nsv = NULL; |
10379
|
|
|
|
|
|
/* Times 4: a decimal digit takes more than 3 binary digits. |
10380
|
|
|
|
|
|
* NV_DIG: mantissa takes than many decimal digits. |
10381
|
|
|
|
|
|
* Plus 32: Playing safe. */ |
10382
|
|
|
|
|
|
char ebuf[IV_DIG * 4 + NV_DIG + 32]; |
10383
|
|
|
|
|
|
/* large enough for "%#.#f" --chip */ |
10384
|
|
|
|
|
|
/* what about long double NVs? --jhi */ |
10385
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
10386
|
|
|
|
|
|
SV* oldlocale = NULL; |
10387
|
|
|
|
|
|
#endif |
10388
|
|
|
|
|
|
|
10389
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS; |
10390
|
|
|
|
|
|
PERL_UNUSED_ARG(maybe_tainted); |
10391
|
|
|
|
|
|
|
10392
|
12625278
|
100
|
|
|
|
if (flags & SV_GMAGIC) |
|
|
100
|
|
|
|
|
10393
|
771002
|
|
|
|
|
SvGETMAGIC(sv); |
10394
|
|
|
|
|
|
|
10395
|
|
|
|
|
|
/* no matter what, this is a string now */ |
10396
|
11854568
|
100
|
|
|
|
(void)SvPV_force_nomg(sv, origlen); |
10397
|
|
|
|
|
|
|
10398
|
|
|
|
|
|
/* special-case "", "%s", and "%-p" (SVf - see below) */ |
10399
|
11854568
|
100
|
|
|
|
if (patlen == 0) |
10400
|
|
|
|
|
|
return; |
10401
|
11854550
|
100
|
|
|
|
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
10402
|
1438
|
100
|
|
|
|
if (args) { |
10403
|
1072
|
50
|
|
|
|
const char * const s = va_arg(*args, char*); |
10404
|
1072
|
50
|
|
|
|
sv_catpv_nomg(sv, s ? s : nullstr); |
10405
|
|
|
|
|
|
} |
10406
|
548
|
100
|
|
|
|
else if (svix < svmax) { |
|
|
50
|
|
|
|
|
10407
|
|
|
|
|
|
/* we want get magic on the source but not the target. sv_catsv can't do that, though */ |
10408
|
182
|
|
|
|
|
SvGETMAGIC(*svargs); |
10409
|
364
|
|
|
|
|
sv_catsv_nomg(sv, *svargs); |
10410
|
|
|
|
|
|
} |
10411
|
|
|
|
|
|
else |
10412
|
2
|
|
|
|
|
S_vcatpvfn_missing_argument(aTHX); |
10413
|
|
|
|
|
|
return; |
10414
|
|
|
|
|
|
} |
10415
|
11941971
|
100
|
|
|
|
if (args && patlen == 3 && pat[0] == '%' && |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
10416
|
116007
|
50
|
|
|
|
pat[1] == '-' && pat[2] == 'p') { |
10417
|
27148
|
50
|
|
|
|
argsv = MUTABLE_SV(va_arg(*args, void*)); |
10418
|
27148
|
|
|
|
|
sv_catsv_nomg(sv, argsv); |
10419
|
27148
|
|
|
|
|
return; |
10420
|
|
|
|
|
|
} |
10421
|
|
|
|
|
|
|
10422
|
|
|
|
|
|
#ifndef USE_LONG_DOUBLE |
10423
|
|
|
|
|
|
/* special-case "%.[gf]" */ |
10424
|
11825964
|
100
|
|
|
|
if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.' |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
10425
|
1232
|
100
|
|
|
|
&& (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) { |
10426
|
|
|
|
|
|
unsigned digits = 0; |
10427
|
|
|
|
|
|
const char *pp; |
10428
|
|
|
|
|
|
|
10429
|
1096
|
|
|
|
|
pp = pat + 2; |
10430
|
2156
|
100
|
|
|
|
while (*pp >= '0' && *pp <= '9') |
10431
|
512
|
|
|
|
|
digits = 10 * digits + (*pp++ - '0'); |
10432
|
1096
|
100
|
|
|
|
if (pp - pat == (int)patlen - 1 && svix < svmax) { |
10433
|
386
|
100
|
|
|
|
const NV nv = SvNV(*svargs); |
10434
|
386
|
100
|
|
|
|
if (*pp == 'g') { |
10435
|
|
|
|
|
|
/* Add check for digits != 0 because it seems that some |
10436
|
|
|
|
|
|
gconverts are buggy in this case, and we don't yet have |
10437
|
|
|
|
|
|
a Configure test for this. */ |
10438
|
128
|
100
|
|
|
|
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { |
10439
|
|
|
|
|
|
/* 0, point, slack */ |
10440
|
124
|
|
|
|
|
Gconvert(nv, (int)digits, 0, ebuf); |
10441
|
124
|
|
|
|
|
sv_catpv_nomg(sv, ebuf); |
10442
|
124
|
50
|
|
|
|
if (*ebuf) /* May return an empty string for digits==0 */ |
10443
|
|
|
|
|
|
return; |
10444
|
|
|
|
|
|
} |
10445
|
258
|
100
|
|
|
|
} else if (!digits) { |
10446
|
|
|
|
|
|
STRLEN l; |
10447
|
|
|
|
|
|
|
10448
|
32
|
50
|
|
|
|
if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { |
10449
|
32
|
|
|
|
|
sv_catpvn_nomg(sv, p, l); |
10450
|
32
|
|
|
|
|
return; |
10451
|
|
|
|
|
|
} |
10452
|
|
|
|
|
|
} |
10453
|
|
|
|
|
|
} |
10454
|
|
|
|
|
|
} |
10455
|
|
|
|
|
|
#endif /* !USE_LONG_DOUBLE */ |
10456
|
|
|
|
|
|
|
10457
|
11825808
|
100
|
|
|
|
if (!args && svix < svmax && DO_UTF8(*svargs)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
10458
|
|
|
|
|
|
has_utf8 = TRUE; |
10459
|
|
|
|
|
|
|
10460
|
11825808
|
|
|
|
|
patend = (char*)pat + patlen; |
10461
|
32176696
|
100
|
|
|
|
for (p = (char*)pat; p < patend; p = q) { |
10462
|
|
|
|
|
|
bool alt = FALSE; |
10463
|
|
|
|
|
|
bool left = FALSE; |
10464
|
|
|
|
|
|
bool vectorize = FALSE; |
10465
|
|
|
|
|
|
bool vectorarg = FALSE; |
10466
|
|
|
|
|
|
bool vec_utf8 = FALSE; |
10467
|
|
|
|
|
|
char fill = ' '; |
10468
|
|
|
|
|
|
char plus = 0; |
10469
|
|
|
|
|
|
char intsize = 0; |
10470
|
|
|
|
|
|
STRLEN width = 0; |
10471
|
|
|
|
|
|
STRLEN zeros = 0; |
10472
|
|
|
|
|
|
bool has_precis = FALSE; |
10473
|
|
|
|
|
|
STRLEN precis = 0; |
10474
|
|
|
|
|
|
const I32 osvix = svix; |
10475
|
|
|
|
|
|
bool is_utf8 = FALSE; /* is this item utf8? */ |
10476
|
|
|
|
|
|
#ifdef HAS_LDBL_SPRINTF_BUG |
10477
|
|
|
|
|
|
/* This is to try to fix a bug with irix/nonstop-ux/powerux and |
10478
|
|
|
|
|
|
with sfio - Allen */ |
10479
|
|
|
|
|
|
bool fix_ldbl_sprintf_bug = FALSE; |
10480
|
|
|
|
|
|
#endif |
10481
|
|
|
|
|
|
|
10482
|
|
|
|
|
|
char esignbuf[4]; |
10483
|
|
|
|
|
|
U8 utf8buf[UTF8_MAXBYTES+1]; |
10484
|
|
|
|
|
|
STRLEN esignlen = 0; |
10485
|
|
|
|
|
|
|
10486
|
|
|
|
|
|
const char *eptr = NULL; |
10487
|
|
|
|
|
|
const char *fmtstart; |
10488
|
27127559
|
|
|
|
|
STRLEN elen = 0; |
10489
|
|
|
|
|
|
SV *vecsv = NULL; |
10490
|
|
|
|
|
|
const U8 *vecstr = NULL; |
10491
|
27127559
|
|
|
|
|
STRLEN veclen = 0; |
10492
|
27127559
|
|
|
|
|
char c = 0; |
10493
|
|
|
|
|
|
int i; |
10494
|
|
|
|
|
|
unsigned base = 0; |
10495
|
|
|
|
|
|
IV iv = 0; |
10496
|
|
|
|
|
|
UV uv = 0; |
10497
|
|
|
|
|
|
/* we need a long double target in case HAS_LONG_DOUBLE but |
10498
|
|
|
|
|
|
not USE_LONG_DOUBLE |
10499
|
|
|
|
|
|
*/ |
10500
|
|
|
|
|
|
#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE |
10501
|
|
|
|
|
|
long double nv; |
10502
|
|
|
|
|
|
#else |
10503
|
|
|
|
|
|
NV nv; |
10504
|
|
|
|
|
|
#endif |
10505
|
|
|
|
|
|
STRLEN have; |
10506
|
|
|
|
|
|
STRLEN need; |
10507
|
|
|
|
|
|
STRLEN gap; |
10508
|
|
|
|
|
|
const char *dotstr = "."; |
10509
|
27127559
|
|
|
|
|
STRLEN dotstrlen = 1; |
10510
|
|
|
|
|
|
I32 efix = 0; /* explicit format parameter index */ |
10511
|
|
|
|
|
|
I32 ewix = 0; /* explicit width index */ |
10512
|
|
|
|
|
|
I32 epix = 0; /* explicit precision index */ |
10513
|
|
|
|
|
|
I32 evix = 0; /* explicit vector index */ |
10514
|
|
|
|
|
|
bool asterisk = FALSE; |
10515
|
|
|
|
|
|
|
10516
|
|
|
|
|
|
/* echo everything up to the next format specification */ |
10517
|
73173442
|
100
|
|
|
|
for (q = p; q < patend && *q != '%'; ++q) ; |
|
|
100
|
|
|
|
|
10518
|
27127559
|
100
|
|
|
|
if (q > p) { |
10519
|
24562191
|
100
|
|
|
|
if (has_utf8 && !pat_utf8) |
|
|
100
|
|
|
|
|
10520
|
34842
|
100
|
|
|
|
sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv); |
10521
|
|
|
|
|
|
else |
10522
|
24527349
|
|
|
|
|
sv_catpvn_nomg(sv, p, q - p); |
10523
|
24562191
|
|
|
|
|
p = q; |
10524
|
|
|
|
|
|
} |
10525
|
27127559
|
100
|
|
|
|
if (q++ >= patend) |
10526
|
|
|
|
|
|
break; |
10527
|
|
|
|
|
|
|
10528
|
20350920
|
|
|
|
|
fmtstart = q; |
10529
|
|
|
|
|
|
|
10530
|
|
|
|
|
|
/* |
10531
|
|
|
|
|
|
We allow format specification elements in this order: |
10532
|
|
|
|
|
|
\d+\$ explicit format parameter index |
10533
|
|
|
|
|
|
[-+ 0#]+ flags |
10534
|
|
|
|
|
|
v|\*(\d+\$)?v vector with optional (optionally specified) arg |
10535
|
|
|
|
|
|
0 flag (as above): repeated to allow "v02" |
10536
|
|
|
|
|
|
\d+|\*(\d+\$)? width using optional (optionally specified) arg |
10537
|
|
|
|
|
|
\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg |
10538
|
|
|
|
|
|
[hlqLV] size |
10539
|
|
|
|
|
|
[%bcdefginopsuxDFOUX] format (mandatory) |
10540
|
|
|
|
|
|
*/ |
10541
|
|
|
|
|
|
|
10542
|
20350920
|
100
|
|
|
|
if (args) { |
10543
|
|
|
|
|
|
/* |
10544
|
|
|
|
|
|
As of perl5.9.3, printf format checking is on by default. |
10545
|
|
|
|
|
|
Internally, perl uses %p formats to provide an escape to |
10546
|
|
|
|
|
|
some extended formatting. This block deals with those |
10547
|
|
|
|
|
|
extensions: if it does not match, (char*)q is reset and |
10548
|
|
|
|
|
|
the normal format processing code is used. |
10549
|
|
|
|
|
|
|
10550
|
|
|
|
|
|
Currently defined extensions are: |
10551
|
|
|
|
|
|
%p include pointer address (standard) |
10552
|
|
|
|
|
|
%-p (SVf) include an SV (previously %_) |
10553
|
|
|
|
|
|
%-p include an SV with precision |
10554
|
|
|
|
|
|
%2p include a HEK |
10555
|
|
|
|
|
|
%3p include a HEK with precision of 256 |
10556
|
|
|
|
|
|
%4p char* preceded by utf8 flag and length |
10557
|
|
|
|
|
|
%p (where num is 1 or > 4) reserved for future |
10558
|
|
|
|
|
|
extensions |
10559
|
|
|
|
|
|
|
10560
|
|
|
|
|
|
Robin Barker 2005-07-14 (but modified since) |
10561
|
|
|
|
|
|
|
10562
|
|
|
|
|
|
%1p (VDf) removed. RMB 2007-10-19 |
10563
|
|
|
|
|
|
*/ |
10564
|
14442327
|
|
|
|
|
char* r = q; |
10565
|
|
|
|
|
|
bool sv = FALSE; |
10566
|
|
|
|
|
|
STRLEN n = 0; |
10567
|
14442327
|
100
|
|
|
|
if (*q == '-') |
10568
|
413088
|
|
|
|
|
sv = *q++; |
10569
|
14029239
|
100
|
|
|
|
else if (strnEQ(q, UTF8f, sizeof(UTF8f)-1)) { /* UTF8f */ |
10570
|
|
|
|
|
|
/* The argument has already gone through cBOOL, so the cast |
10571
|
|
|
|
|
|
is safe. */ |
10572
|
2348
|
50
|
|
|
|
is_utf8 = (bool)va_arg(*args, int); |
10573
|
2348
|
100
|
|
|
|
elen = va_arg(*args, UV); |
10574
|
2348
|
100
|
|
|
|
eptr = va_arg(*args, char *); |
10575
|
2348
|
|
|
|
|
q += sizeof(UTF8f)-1; |
10576
|
2348
|
|
|
|
|
goto string; |
10577
|
|
|
|
|
|
} |
10578
|
14439979
|
|
|
|
|
n = expect_number(&q); |
10579
|
14439979
|
100
|
|
|
|
if (*q++ == 'p') { |
10580
|
451594
|
100
|
|
|
|
if (sv) { /* SVf */ |
10581
|
413070
|
100
|
|
|
|
if (n) { |
10582
|
|
|
|
|
|
precis = n; |
10583
|
|
|
|
|
|
has_precis = TRUE; |
10584
|
|
|
|
|
|
} |
10585
|
413070
|
100
|
|
|
|
argsv = MUTABLE_SV(va_arg(*args, void*)); |
10586
|
413070
|
100
|
|
|
|
eptr = SvPV_const(argsv, elen); |
10587
|
413070
|
100
|
|
|
|
if (DO_UTF8(argsv)) |
|
|
50
|
|
|
|
|
10588
|
|
|
|
|
|
is_utf8 = TRUE; |
10589
|
|
|
|
|
|
goto string; |
10590
|
|
|
|
|
|
} |
10591
|
38524
|
100
|
|
|
|
else if (n==2 || n==3) { /* HEKf */ |
10592
|
38520
|
50
|
|
|
|
HEK * const hek = va_arg(*args, HEK *); |
10593
|
38520
|
|
|
|
|
eptr = HEK_KEY(hek); |
10594
|
38520
|
|
|
|
|
elen = HEK_LEN(hek); |
10595
|
38520
|
100
|
|
|
|
if (HEK_UTF8(hek)) is_utf8 = TRUE; |
10596
|
38520
|
50
|
|
|
|
if (n==3) precis = 256, has_precis = TRUE; |
10597
|
|
|
|
|
|
goto string; |
10598
|
|
|
|
|
|
} |
10599
|
4
|
50
|
|
|
|
else if (n) { |
10600
|
0
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
10601
|
|
|
|
|
|
"internal %%p might conflict with future printf extensions"); |
10602
|
|
|
|
|
|
} |
10603
|
|
|
|
|
|
} |
10604
|
13988389
|
|
|
|
|
q = r; |
10605
|
|
|
|
|
|
} |
10606
|
|
|
|
|
|
|
10607
|
19896982
|
100
|
|
|
|
if ( (width = expect_number(&q)) ) { |
10608
|
33048
|
100
|
|
|
|
if (*q == '$') { |
10609
|
102
|
|
|
|
|
++q; |
10610
|
9948619
|
|
|
|
|
efix = width; |
10611
|
|
|
|
|
|
} else { |
10612
|
|
|
|
|
|
goto gotwidth; |
10613
|
|
|
|
|
|
} |
10614
|
|
|
|
|
|
} |
10615
|
|
|
|
|
|
|
10616
|
|
|
|
|
|
/* FLAGS */ |
10617
|
|
|
|
|
|
|
10618
|
33720054
|
100
|
|
|
|
while (*q) { |
10619
|
23768695
|
|
|
|
|
switch (*q) { |
10620
|
|
|
|
|
|
case ' ': |
10621
|
|
|
|
|
|
case '+': |
10622
|
3970
|
100
|
|
|
|
if (plus == '+' && *q == ' ') /* '+' over ' ' */ |
|
|
100
|
|
|
|
|
10623
|
560
|
|
|
|
|
q++; |
10624
|
|
|
|
|
|
else |
10625
|
3410
|
|
|
|
|
plus = *q++; |
10626
|
3970
|
|
|
|
|
continue; |
10627
|
|
|
|
|
|
|
10628
|
|
|
|
|
|
case '-': |
10629
|
|
|
|
|
|
left = TRUE; |
10630
|
125006
|
|
|
|
|
q++; |
10631
|
125006
|
|
|
|
|
continue; |
10632
|
|
|
|
|
|
|
10633
|
|
|
|
|
|
case '0': |
10634
|
3403997
|
|
|
|
|
fill = *q++; |
10635
|
3403997
|
|
|
|
|
continue; |
10636
|
|
|
|
|
|
|
10637
|
|
|
|
|
|
case '#': |
10638
|
|
|
|
|
|
alt = TRUE; |
10639
|
371708
|
|
|
|
|
q++; |
10640
|
2139454
|
|
|
|
|
continue; |
10641
|
|
|
|
|
|
|
10642
|
|
|
|
|
|
default: |
10643
|
|
|
|
|
|
break; |
10644
|
|
|
|
|
|
} |
10645
|
|
|
|
|
|
break; |
10646
|
|
|
|
|
|
} |
10647
|
|
|
|
|
|
|
10648
|
|
|
|
|
|
tryasterisk: |
10649
|
19869596
|
100
|
|
|
|
if (*q == '*') { |
10650
|
49636
|
|
|
|
|
q++; |
10651
|
49636
|
100
|
|
|
|
if ( (ewix = expect_number(&q)) ) |
10652
|
16
|
100
|
|
|
|
if (*q++ != '$') |
10653
|
|
|
|
|
|
goto unknown; |
10654
|
|
|
|
|
|
asterisk = TRUE; |
10655
|
|
|
|
|
|
} |
10656
|
19869592
|
100
|
|
|
|
if (*q == 'v') { |
10657
|
5574
|
|
|
|
|
q++; |
10658
|
5574
|
100
|
|
|
|
if (vectorize) |
10659
|
|
|
|
|
|
goto unknown; |
10660
|
5572
|
100
|
|
|
|
if ((vectorarg = asterisk)) { |
10661
|
|
|
|
|
|
evix = ewix; |
10662
|
|
|
|
|
|
ewix = 0; |
10663
|
|
|
|
|
|
asterisk = FALSE; |
10664
|
|
|
|
|
|
} |
10665
|
|
|
|
|
|
vectorize = TRUE; |
10666
|
|
|
|
|
|
goto tryasterisk; |
10667
|
|
|
|
|
|
} |
10668
|
|
|
|
|
|
|
10669
|
19864018
|
100
|
|
|
|
if (!asterisk) |
10670
|
|
|
|
|
|
{ |
10671
|
19814490
|
100
|
|
|
|
if( *q == '0' ) |
10672
|
4
|
|
|
|
|
fill = *q++; |
10673
|
19814490
|
|
|
|
|
width = expect_number(&q); |
10674
|
|
|
|
|
|
} |
10675
|
|
|
|
|
|
|
10676
|
19864018
|
100
|
|
|
|
if (vectorize && vectorarg) { |
|
|
100
|
|
|
|
|
10677
|
|
|
|
|
|
/* vectorizing, but not with the default "." */ |
10678
|
102
|
50
|
|
|
|
if (args) |
10679
|
0
|
0
|
|
|
|
vecsv = va_arg(*args, SV*); |
10680
|
102
|
100
|
|
|
|
else if (evix) { |
10681
|
2
|
|
|
|
|
vecsv = (evix > 0 && evix <= svmax) |
10682
|
2
|
50
|
|
|
|
? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); |
10683
|
|
|
|
|
|
} else { |
10684
|
|
|
|
|
|
vecsv = svix < svmax |
10685
|
100
|
50
|
|
|
|
? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); |
10686
|
|
|
|
|
|
} |
10687
|
102
|
50
|
|
|
|
dotstr = SvPV_const(vecsv, dotstrlen); |
10688
|
|
|
|
|
|
/* Keep the DO_UTF8 test *after* the SvPV call, else things go |
10689
|
|
|
|
|
|
bad with tied or overloaded values that return UTF8. */ |
10690
|
102
|
100
|
|
|
|
if (DO_UTF8(vecsv)) |
|
|
50
|
|
|
|
|
10691
|
|
|
|
|
|
is_utf8 = TRUE; |
10692
|
84
|
100
|
|
|
|
else if (has_utf8) { |
10693
|
12
|
|
|
|
|
vecsv = sv_mortalcopy(vecsv); |
10694
|
12
|
|
|
|
|
sv_utf8_upgrade(vecsv); |
10695
|
12
|
50
|
|
|
|
dotstr = SvPV_const(vecsv, dotstrlen); |
10696
|
|
|
|
|
|
is_utf8 = TRUE; |
10697
|
|
|
|
|
|
} |
10698
|
|
|
|
|
|
} |
10699
|
|
|
|
|
|
|
10700
|
19864018
|
100
|
|
|
|
if (asterisk) { |
10701
|
49528
|
100
|
|
|
|
if (args) |
10702
|
37882
|
100
|
|
|
|
i = va_arg(*args, int); |
10703
|
|
|
|
|
|
else |
10704
|
23290
|
100
|
|
|
|
i = (ewix ? ewix <= svmax : svix < svmax) ? |
|
|
100
|
|
|
|
|
10705
|
11644
|
100
|
|
|
|
SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; |
|
|
50
|
|
|
|
|
10706
|
49528
|
|
|
|
|
left |= (i < 0); |
10707
|
49528
|
|
|
|
|
width = (i < 0) ? -i : i; |
10708
|
|
|
|
|
|
} |
10709
|
|
|
|
|
|
gotwidth: |
10710
|
|
|
|
|
|
|
10711
|
|
|
|
|
|
/* PRECISION */ |
10712
|
|
|
|
|
|
|
10713
|
19896964
|
100
|
|
|
|
if (*q == '.') { |
10714
|
14386
|
|
|
|
|
q++; |
10715
|
14386
|
100
|
|
|
|
if (*q == '*') { |
10716
|
5956
|
|
|
|
|
q++; |
10717
|
5956
|
50
|
|
|
|
if ( ((epix = expect_number(&q))) && (*q++ != '$') ) |
|
|
0
|
|
|
|
|
10718
|
|
|
|
|
|
goto unknown; |
10719
|
|
|
|
|
|
/* XXX: todo, support specified precision parameter */ |
10720
|
5956
|
50
|
|
|
|
if (epix) |
10721
|
|
|
|
|
|
goto unknown; |
10722
|
5956
|
100
|
|
|
|
if (args) |
10723
|
5150
|
100
|
|
|
|
i = va_arg(*args, int); |
10724
|
|
|
|
|
|
else |
10725
|
1612
|
50
|
|
|
|
i = (ewix ? ewix <= svmax : svix < svmax) |
10726
|
1612
|
50
|
|
|
|
? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10727
|
5956
|
|
|
|
|
precis = i; |
10728
|
5956
|
|
|
|
|
has_precis = !(i < 0); |
10729
|
|
|
|
|
|
} |
10730
|
|
|
|
|
|
else { |
10731
|
|
|
|
|
|
precis = 0; |
10732
|
16860
|
100
|
|
|
|
while (isDIGIT(*q)) |
10733
|
8430
|
|
|
|
|
precis = precis * 10 + (*q++ - '0'); |
10734
|
|
|
|
|
|
has_precis = TRUE; |
10735
|
|
|
|
|
|
} |
10736
|
|
|
|
|
|
} |
10737
|
|
|
|
|
|
|
10738
|
19896964
|
100
|
|
|
|
if (vectorize) { |
10739
|
5568
|
50
|
|
|
|
if (args) { |
10740
|
0
|
0
|
|
|
|
VECTORIZE_ARGS |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
10741
|
|
|
|
|
|
} |
10742
|
5568
|
100
|
|
|
|
else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) { |
|
|
100
|
|
|
|
|
10743
|
5056
|
50
|
|
|
|
vecsv = svargs[efix ? efix-1 : svix++]; |
10744
|
5056
|
100
|
|
|
|
vecstr = (U8*)SvPV_const(vecsv,veclen); |
10745
|
5056
|
100
|
|
|
|
vec_utf8 = DO_UTF8(vecsv); |
|
|
100
|
|
|
|
|
10746
|
|
|
|
|
|
|
10747
|
|
|
|
|
|
/* if this is a version object, we need to convert |
10748
|
|
|
|
|
|
* back into v-string notation and then let the |
10749
|
|
|
|
|
|
* vectorize happen normally |
10750
|
|
|
|
|
|
*/ |
10751
|
5056
|
100
|
|
|
|
if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { |
|
|
50
|
|
|
|
|
10752
|
4740
|
100
|
|
|
|
if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { |
10753
|
8
|
|
|
|
|
Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF), |
10754
|
|
|
|
|
|
"vector argument not supported with alpha versions"); |
10755
|
8
|
|
|
|
|
goto vdblank; |
10756
|
|
|
|
|
|
} |
10757
|
4732
|
|
|
|
|
vecsv = sv_newmortal(); |
10758
|
4732
|
|
|
|
|
scan_vstring((char *)vecstr, (char *)vecstr + veclen, |
10759
|
|
|
|
|
|
vecsv); |
10760
|
4732
|
50
|
|
|
|
vecstr = (U8*)SvPV_const(vecsv, veclen); |
10761
|
4732
|
100
|
|
|
|
vec_utf8 = DO_UTF8(vecsv); |
|
|
50
|
|
|
|
|
10762
|
|
|
|
|
|
} |
10763
|
|
|
|
|
|
} |
10764
|
|
|
|
|
|
else { |
10765
|
|
|
|
|
|
vdblank: |
10766
|
|
|
|
|
|
vecstr = (U8*)""; |
10767
|
520
|
|
|
|
|
veclen = 0; |
10768
|
|
|
|
|
|
} |
10769
|
|
|
|
|
|
} |
10770
|
|
|
|
|
|
|
10771
|
|
|
|
|
|
/* SIZE */ |
10772
|
|
|
|
|
|
|
10773
|
19896964
|
|
|
|
|
switch (*q) { |
10774
|
|
|
|
|
|
#ifdef WIN32 |
10775
|
|
|
|
|
|
case 'I': /* Ix, I32x, and I64x */ |
10776
|
|
|
|
|
|
# ifdef USE_64_BIT_INT |
10777
|
|
|
|
|
|
if (q[1] == '6' && q[2] == '4') { |
10778
|
|
|
|
|
|
q += 3; |
10779
|
|
|
|
|
|
intsize = 'q'; |
10780
|
|
|
|
|
|
break; |
10781
|
|
|
|
|
|
} |
10782
|
|
|
|
|
|
# endif |
10783
|
|
|
|
|
|
if (q[1] == '3' && q[2] == '2') { |
10784
|
|
|
|
|
|
q += 3; |
10785
|
|
|
|
|
|
break; |
10786
|
|
|
|
|
|
} |
10787
|
|
|
|
|
|
# ifdef USE_64_BIT_INT |
10788
|
|
|
|
|
|
intsize = 'q'; |
10789
|
|
|
|
|
|
# endif |
10790
|
|
|
|
|
|
q++; |
10791
|
|
|
|
|
|
break; |
10792
|
|
|
|
|
|
#endif |
10793
|
|
|
|
|
|
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) |
10794
|
|
|
|
|
|
case 'L': /* Ld */ |
10795
|
|
|
|
|
|
/*FALLTHROUGH*/ |
10796
|
|
|
|
|
|
#ifdef HAS_QUAD |
10797
|
|
|
|
|
|
case 'q': /* qd */ |
10798
|
|
|
|
|
|
#endif |
10799
|
|
|
|
|
|
intsize = 'q'; |
10800
|
60
|
|
|
|
|
q++; |
10801
|
60
|
|
|
|
|
break; |
10802
|
|
|
|
|
|
#endif |
10803
|
|
|
|
|
|
case 'l': |
10804
|
8215543
|
|
|
|
|
++q; |
10805
|
|
|
|
|
|
#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE) |
10806
|
8215543
|
100
|
|
|
|
if (*q == 'l') { /* lld, llf */ |
10807
|
|
|
|
|
|
intsize = 'q'; |
10808
|
54
|
|
|
|
|
++q; |
10809
|
|
|
|
|
|
} |
10810
|
|
|
|
|
|
else |
10811
|
|
|
|
|
|
#endif |
10812
|
|
|
|
|
|
intsize = 'l'; |
10813
|
|
|
|
|
|
break; |
10814
|
|
|
|
|
|
case 'h': |
10815
|
12
|
100
|
|
|
|
if (*++q == 'h') { /* hhd, hhu */ |
10816
|
|
|
|
|
|
intsize = 'c'; |
10817
|
2
|
|
|
|
|
++q; |
10818
|
|
|
|
|
|
} |
10819
|
|
|
|
|
|
else |
10820
|
|
|
|
|
|
intsize = 'h'; |
10821
|
|
|
|
|
|
break; |
10822
|
|
|
|
|
|
case 'V': |
10823
|
|
|
|
|
|
case 'z': |
10824
|
|
|
|
|
|
case 't': |
10825
|
|
|
|
|
|
#if HAS_C99 |
10826
|
|
|
|
|
|
case 'j': |
10827
|
|
|
|
|
|
#endif |
10828
|
22
|
|
|
|
|
intsize = *q++; |
10829
|
22
|
|
|
|
|
break; |
10830
|
|
|
|
|
|
} |
10831
|
|
|
|
|
|
|
10832
|
|
|
|
|
|
/* CONVERSION */ |
10833
|
|
|
|
|
|
|
10834
|
19896964
|
100
|
|
|
|
if (*q == '%') { |
10835
|
14548
|
|
|
|
|
eptr = q++; |
10836
|
14548
|
|
|
|
|
elen = 1; |
10837
|
14548
|
100
|
|
|
|
if (vectorize) { |
10838
|
4
|
|
|
|
|
c = '%'; |
10839
|
4
|
|
|
|
|
goto unknown; |
10840
|
|
|
|
|
|
} |
10841
|
|
|
|
|
|
goto string; |
10842
|
|
|
|
|
|
} |
10843
|
|
|
|
|
|
|
10844
|
19882416
|
100
|
|
|
|
if (!vectorize && !args) { |
|
|
100
|
|
|
|
|
10845
|
5888529
|
100
|
|
|
|
if (efix) { |
10846
|
100
|
|
|
|
|
const I32 i = efix-1; |
10847
|
100
|
|
|
|
|
argsv = (i >= 0 && i < svmax) |
10848
|
100
|
100
|
|
|
|
? svargs[i] : S_vcatpvfn_missing_argument(aTHX); |
10849
|
|
|
|
|
|
} else { |
10850
|
5888429
|
|
|
|
|
argsv = (svix >= 0 && svix < svmax) |
10851
|
5888429
|
100
|
|
|
|
? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); |
10852
|
|
|
|
|
|
} |
10853
|
|
|
|
|
|
} |
10854
|
|
|
|
|
|
|
10855
|
19882414
|
|
|
|
|
switch (c = *q++) { |
10856
|
|
|
|
|
|
|
10857
|
|
|
|
|
|
/* STRINGS */ |
10858
|
|
|
|
|
|
|
10859
|
|
|
|
|
|
case 'c': |
10860
|
255754
|
100
|
|
|
|
if (vectorize) |
10861
|
|
|
|
|
|
goto unknown; |
10862
|
255750
|
100
|
|
|
|
uv = (args) ? va_arg(*args, int) : SvIV(argsv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
10863
|
255750
|
100
|
|
|
|
if ((uv > 255 || |
|
|
50
|
|
|
|
|
10864
|
0
|
0
|
|
|
|
(!NATIVE_IS_INVARIANT(uv) && SvUTF8(sv))) |
10865
|
18
|
50
|
|
|
|
&& !IN_BYTES) { |
10866
|
|
|
|
|
|
eptr = (char*)utf8buf; |
10867
|
18
|
|
|
|
|
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; |
10868
|
18
|
|
|
|
|
is_utf8 = TRUE; |
10869
|
|
|
|
|
|
} |
10870
|
|
|
|
|
|
else { |
10871
|
255732
|
|
|
|
|
c = (char)uv; |
10872
|
|
|
|
|
|
eptr = &c; |
10873
|
255732
|
|
|
|
|
elen = 1; |
10874
|
|
|
|
|
|
} |
10875
|
|
|
|
|
|
goto string; |
10876
|
|
|
|
|
|
|
10877
|
|
|
|
|
|
case 's': |
10878
|
6086202
|
100
|
|
|
|
if (vectorize) |
10879
|
|
|
|
|
|
goto unknown; |
10880
|
6086198
|
100
|
|
|
|
if (args) { |
10881
|
5322416
|
100
|
|
|
|
eptr = va_arg(*args, char*); |
10882
|
5322416
|
50
|
|
|
|
if (eptr) |
10883
|
5322416
|
|
|
|
|
elen = strlen(eptr); |
10884
|
|
|
|
|
|
else { |
10885
|
|
|
|
|
|
eptr = (char *)nullstr; |
10886
|
0
|
|
|
|
|
elen = sizeof nullstr - 1; |
10887
|
|
|
|
|
|
} |
10888
|
|
|
|
|
|
} |
10889
|
|
|
|
|
|
else { |
10890
|
763782
|
100
|
|
|
|
eptr = SvPV_const(argsv, elen); |
10891
|
763782
|
100
|
|
|
|
if (DO_UTF8(argsv)) { |
|
|
50
|
|
|
|
|
10892
|
|
|
|
|
|
STRLEN old_precis = precis; |
10893
|
404
|
100
|
|
|
|
if (has_precis && precis < elen) { |
|
|
100
|
|
|
|
|
10894
|
80
|
50
|
|
|
|
STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10895
|
80
|
|
|
|
|
STRLEN p = precis > ulen ? ulen : precis; |
10896
|
80
|
|
|
|
|
precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0); |
10897
|
|
|
|
|
|
/* sticks at end */ |
10898
|
|
|
|
|
|
} |
10899
|
404
|
100
|
|
|
|
if (width) { /* fudge width (can't fudge elen) */ |
10900
|
108
|
100
|
|
|
|
if (has_precis && precis < elen) |
|
|
100
|
|
|
|
|
10901
|
22
|
|
|
|
|
width += precis - old_precis; |
10902
|
|
|
|
|
|
else |
10903
|
86
|
|
|
|
|
width += |
10904
|
86
|
50
|
|
|
|
elen - sv_or_pv_len_utf8(argsv,eptr,elen); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
10905
|
|
|
|
|
|
} |
10906
|
|
|
|
|
|
is_utf8 = TRUE; |
10907
|
|
|
|
|
|
} |
10908
|
|
|
|
|
|
} |
10909
|
|
|
|
|
|
|
10910
|
|
|
|
|
|
string: |
10911
|
6810430
|
100
|
|
|
|
if (has_precis && precis < elen) |
|
|
100
|
|
|
|
|
10912
|
4178
|
|
|
|
|
elen = precis; |
10913
|
|
|
|
|
|
break; |
10914
|
|
|
|
|
|
|
10915
|
|
|
|
|
|
/* INTEGERS */ |
10916
|
|
|
|
|
|
|
10917
|
|
|
|
|
|
case 'p': |
10918
|
14
|
100
|
|
|
|
if (alt || vectorize) |
|
|
100
|
|
|
|
|
10919
|
|
|
|
|
|
goto unknown; |
10920
|
8
|
100
|
|
|
|
uv = PTR2UV(args ? va_arg(*args, void*) : argsv); |
|
|
50
|
|
|
|
|
10921
|
|
|
|
|
|
base = 16; |
10922
|
11
|
|
|
|
|
goto integer; |
10923
|
|
|
|
|
|
|
10924
|
|
|
|
|
|
case 'D': |
10925
|
|
|
|
|
|
#ifdef IV_IS_QUAD |
10926
|
|
|
|
|
|
intsize = 'q'; |
10927
|
|
|
|
|
|
#else |
10928
|
|
|
|
|
|
intsize = 'l'; |
10929
|
|
|
|
|
|
#endif |
10930
|
|
|
|
|
|
/*FALLTHROUGH*/ |
10931
|
|
|
|
|
|
case 'd': |
10932
|
|
|
|
|
|
case 'i': |
10933
|
|
|
|
|
|
#if vdNUMBER |
10934
|
|
|
|
|
|
format_vd: |
10935
|
|
|
|
|
|
#endif |
10936
|
4504012
|
100
|
|
|
|
if (vectorize) { |
10937
|
|
|
|
|
|
STRLEN ulen; |
10938
|
4926
|
100
|
|
|
|
if (!veclen) |
10939
|
20
|
|
|
|
|
continue; |
10940
|
4906
|
100
|
|
|
|
if (vec_utf8) |
10941
|
76
|
|
|
|
|
uv = utf8n_to_uvchr(vecstr, veclen, &ulen, |
10942
|
|
|
|
|
|
UTF8_ALLOW_ANYUV); |
10943
|
|
|
|
|
|
else { |
10944
|
4830
|
|
|
|
|
uv = *vecstr; |
10945
|
4830
|
|
|
|
|
ulen = 1; |
10946
|
|
|
|
|
|
} |
10947
|
4906
|
|
|
|
|
vecstr += ulen; |
10948
|
4906
|
|
|
|
|
veclen -= ulen; |
10949
|
4906
|
100
|
|
|
|
if (plus) |
10950
|
8
|
|
|
|
|
esignbuf[esignlen++] = plus; |
10951
|
|
|
|
|
|
} |
10952
|
4499086
|
100
|
|
|
|
else if (args) { |
10953
|
4149799
|
|
|
|
|
switch (intsize) { |
10954
|
0
|
0
|
|
|
|
case 'c': iv = (char)va_arg(*args, int); break; |
10955
|
0
|
0
|
|
|
|
case 'h': iv = (short)va_arg(*args, int); break; |
10956
|
4057523
|
100
|
|
|
|
case 'l': iv = va_arg(*args, long); break; |
10957
|
0
|
0
|
|
|
|
case 'V': iv = va_arg(*args, IV); break; |
10958
|
0
|
0
|
|
|
|
case 'z': iv = va_arg(*args, SSize_t); break; |
10959
|
0
|
0
|
|
|
|
case 't': iv = va_arg(*args, ptrdiff_t); break; |
10960
|
92276
|
100
|
|
|
|
default: iv = va_arg(*args, int); break; |
10961
|
|
|
|
|
|
#if HAS_C99 |
10962
|
|
|
|
|
|
case 'j': iv = va_arg(*args, intmax_t); break; |
10963
|
|
|
|
|
|
#endif |
10964
|
|
|
|
|
|
case 'q': |
10965
|
|
|
|
|
|
#ifdef HAS_QUAD |
10966
|
0
|
0
|
|
|
|
iv = va_arg(*args, Quad_t); break; |
10967
|
|
|
|
|
|
#else |
10968
|
|
|
|
|
|
goto unknown; |
10969
|
|
|
|
|
|
#endif |
10970
|
|
|
|
|
|
} |
10971
|
|
|
|
|
|
} |
10972
|
|
|
|
|
|
else { |
10973
|
349287
|
100
|
|
|
|
IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ |
10974
|
349287
|
|
|
|
|
switch (intsize) { |
10975
|
2
|
|
|
|
|
case 'c': iv = (char)tiv; break; |
10976
|
2
|
|
|
|
|
case 'h': iv = (short)tiv; break; |
10977
|
|
|
|
|
|
case 'l': iv = (long)tiv; break; |
10978
|
|
|
|
|
|
case 'V': |
10979
|
|
|
|
|
|
default: iv = tiv; break; |
10980
|
|
|
|
|
|
case 'q': |
10981
|
|
|
|
|
|
#ifdef HAS_QUAD |
10982
|
|
|
|
|
|
iv = (Quad_t)tiv; break; |
10983
|
|
|
|
|
|
#else |
10984
|
|
|
|
|
|
goto unknown; |
10985
|
|
|
|
|
|
#endif |
10986
|
|
|
|
|
|
} |
10987
|
|
|
|
|
|
} |
10988
|
4503992
|
100
|
|
|
|
if ( !vectorize ) /* we already set uv above */ |
10989
|
|
|
|
|
|
{ |
10990
|
4499086
|
100
|
|
|
|
if (iv >= 0) { |
10991
|
4482742
|
|
|
|
|
uv = iv; |
10992
|
4482742
|
100
|
|
|
|
if (plus) |
10993
|
1262
|
|
|
|
|
esignbuf[esignlen++] = plus; |
10994
|
|
|
|
|
|
} |
10995
|
|
|
|
|
|
else { |
10996
|
16344
|
|
|
|
|
uv = -iv; |
10997
|
2650326
|
|
|
|
|
esignbuf[esignlen++] = '-'; |
10998
|
|
|
|
|
|
} |
10999
|
|
|
|
|
|
} |
11000
|
|
|
|
|
|
base = 10; |
11001
|
|
|
|
|
|
goto integer; |
11002
|
|
|
|
|
|
|
11003
|
|
|
|
|
|
case 'U': |
11004
|
|
|
|
|
|
#ifdef IV_IS_QUAD |
11005
|
|
|
|
|
|
intsize = 'q'; |
11006
|
|
|
|
|
|
#else |
11007
|
|
|
|
|
|
intsize = 'l'; |
11008
|
|
|
|
|
|
#endif |
11009
|
|
|
|
|
|
/*FALLTHROUGH*/ |
11010
|
|
|
|
|
|
case 'u': |
11011
|
|
|
|
|
|
base = 10; |
11012
|
|
|
|
|
|
goto uns_integer; |
11013
|
|
|
|
|
|
|
11014
|
|
|
|
|
|
case 'B': |
11015
|
|
|
|
|
|
case 'b': |
11016
|
|
|
|
|
|
base = 2; |
11017
|
|
|
|
|
|
goto uns_integer; |
11018
|
|
|
|
|
|
|
11019
|
|
|
|
|
|
case 'O': |
11020
|
|
|
|
|
|
#ifdef IV_IS_QUAD |
11021
|
|
|
|
|
|
intsize = 'q'; |
11022
|
|
|
|
|
|
#else |
11023
|
|
|
|
|
|
intsize = 'l'; |
11024
|
|
|
|
|
|
#endif |
11025
|
|
|
|
|
|
/*FALLTHROUGH*/ |
11026
|
|
|
|
|
|
case 'o': |
11027
|
|
|
|
|
|
base = 8; |
11028
|
|
|
|
|
|
goto uns_integer; |
11029
|
|
|
|
|
|
|
11030
|
|
|
|
|
|
case 'X': |
11031
|
|
|
|
|
|
case 'x': |
11032
|
|
|
|
|
|
base = 16; |
11033
|
|
|
|
|
|
|
11034
|
|
|
|
|
|
uns_integer: |
11035
|
9008362
|
100
|
|
|
|
if (vectorize) { |
11036
|
|
|
|
|
|
STRLEN ulen; |
11037
|
|
|
|
|
|
vector: |
11038
|
10164
|
100
|
|
|
|
if (!veclen) |
11039
|
16
|
|
|
|
|
continue; |
11040
|
10148
|
100
|
|
|
|
if (vec_utf8) |
11041
|
212
|
|
|
|
|
uv = utf8n_to_uvchr(vecstr, veclen, &ulen, |
11042
|
|
|
|
|
|
UTF8_ALLOW_ANYUV); |
11043
|
|
|
|
|
|
else { |
11044
|
9936
|
|
|
|
|
uv = *vecstr; |
11045
|
9936
|
|
|
|
|
ulen = 1; |
11046
|
|
|
|
|
|
} |
11047
|
10148
|
|
|
|
|
vecstr += ulen; |
11048
|
10148
|
|
|
|
|
veclen -= ulen; |
11049
|
|
|
|
|
|
} |
11050
|
9008236
|
100
|
|
|
|
else if (args) { |
11051
|
4259478
|
|
|
|
|
switch (intsize) { |
11052
|
0
|
0
|
|
|
|
case 'c': uv = (unsigned char)va_arg(*args, unsigned); break; |
11053
|
0
|
0
|
|
|
|
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; |
11054
|
4157740
|
100
|
|
|
|
case 'l': uv = va_arg(*args, unsigned long); break; |
11055
|
0
|
0
|
|
|
|
case 'V': uv = va_arg(*args, UV); break; |
11056
|
0
|
0
|
|
|
|
case 'z': uv = va_arg(*args, Size_t); break; |
11057
|
0
|
0
|
|
|
|
case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ |
11058
|
|
|
|
|
|
#if HAS_C99 |
11059
|
|
|
|
|
|
case 'j': uv = va_arg(*args, uintmax_t); break; |
11060
|
|
|
|
|
|
#endif |
11061
|
101738
|
50
|
|
|
|
default: uv = va_arg(*args, unsigned); break; |
11062
|
|
|
|
|
|
case 'q': |
11063
|
|
|
|
|
|
#ifdef HAS_QUAD |
11064
|
0
|
0
|
|
|
|
uv = va_arg(*args, Uquad_t); break; |
11065
|
|
|
|
|
|
#else |
11066
|
|
|
|
|
|
goto unknown; |
11067
|
|
|
|
|
|
#endif |
11068
|
|
|
|
|
|
} |
11069
|
|
|
|
|
|
} |
11070
|
|
|
|
|
|
else { |
11071
|
4748758
|
100
|
|
|
|
UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ |
11072
|
4748758
|
|
|
|
|
switch (intsize) { |
11073
|
0
|
|
|
|
|
case 'c': uv = (unsigned char)tuv; break; |
11074
|
0
|
|
|
|
|
case 'h': uv = (unsigned short)tuv; break; |
11075
|
|
|
|
|
|
case 'l': uv = (unsigned long)tuv; break; |
11076
|
|
|
|
|
|
case 'V': |
11077
|
|
|
|
|
|
default: uv = tuv; break; |
11078
|
|
|
|
|
|
case 'q': |
11079
|
|
|
|
|
|
#ifdef HAS_QUAD |
11080
|
|
|
|
|
|
uv = (Uquad_t)tuv; break; |
11081
|
|
|
|
|
|
#else |
11082
|
|
|
|
|
|
goto unknown; |
11083
|
|
|
|
|
|
#endif |
11084
|
|
|
|
|
|
} |
11085
|
|
|
|
|
|
} |
11086
|
|
|
|
|
|
|
11087
|
|
|
|
|
|
integer: |
11088
|
|
|
|
|
|
{ |
11089
|
|
|
|
|
|
char *ptr = ebuf + sizeof ebuf; |
11090
|
13522384
|
100
|
|
|
|
bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */ |
|
|
100
|
|
|
|
|
11091
|
|
|
|
|
|
zeros = 0; |
11092
|
|
|
|
|
|
|
11093
|
13522384
|
|
|
|
|
switch (base) { |
11094
|
|
|
|
|
|
unsigned dig; |
11095
|
|
|
|
|
|
case 16: |
11096
|
5268128
|
100
|
|
|
|
p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit); |
11097
|
|
|
|
|
|
do { |
11098
|
16850100
|
|
|
|
|
dig = uv & 15; |
11099
|
16850100
|
|
|
|
|
*--ptr = p[dig]; |
11100
|
16850100
|
100
|
|
|
|
} while (uv >>= 4); |
11101
|
5268128
|
100
|
|
|
|
if (tempalt) { |
11102
|
323474
|
|
|
|
|
esignbuf[esignlen++] = '0'; |
11103
|
534155
|
|
|
|
|
esignbuf[esignlen++] = c; /* 'x' or 'X' */ |
11104
|
|
|
|
|
|
} |
11105
|
|
|
|
|
|
break; |
11106
|
|
|
|
|
|
case 8: |
11107
|
|
|
|
|
|
do { |
11108
|
1202276
|
|
|
|
|
dig = uv & 7; |
11109
|
1202276
|
|
|
|
|
*--ptr = '0' + dig; |
11110
|
1202276
|
100
|
|
|
|
} while (uv >>= 3); |
11111
|
421362
|
100
|
|
|
|
if (alt && *ptr != '0') |
|
|
100
|
|
|
|
|
11112
|
2451
|
|
|
|
|
*--ptr = '0'; |
11113
|
|
|
|
|
|
break; |
11114
|
|
|
|
|
|
case 2: |
11115
|
|
|
|
|
|
do { |
11116
|
17056
|
|
|
|
|
dig = uv & 1; |
11117
|
17056
|
|
|
|
|
*--ptr = '0' + dig; |
11118
|
17056
|
100
|
|
|
|
} while (uv >>= 1); |
11119
|
4430
|
100
|
|
|
|
if (tempalt) { |
11120
|
54
|
|
|
|
|
esignbuf[esignlen++] = '0'; |
11121
|
3923104
|
|
|
|
|
esignbuf[esignlen++] = c; |
11122
|
|
|
|
|
|
} |
11123
|
|
|
|
|
|
break; |
11124
|
|
|
|
|
|
default: /* it had better be ten or less */ |
11125
|
|
|
|
|
|
do { |
11126
|
21882022
|
|
|
|
|
dig = uv % base; |
11127
|
21882022
|
|
|
|
|
*--ptr = '0' + dig; |
11128
|
21882022
|
100
|
|
|
|
} while (uv /= base); |
11129
|
|
|
|
|
|
break; |
11130
|
|
|
|
|
|
} |
11131
|
13522384
|
|
|
|
|
elen = (ebuf + sizeof ebuf) - ptr; |
11132
|
|
|
|
|
|
eptr = ptr; |
11133
|
13522384
|
100
|
|
|
|
if (has_precis) { |
11134
|
4152
|
100
|
|
|
|
if (precis > elen) |
11135
|
3598
|
|
|
|
|
zeros = precis - elen; |
11136
|
554
|
100
|
|
|
|
else if (precis == 0 && elen == 1 && *eptr == '0' |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
11137
|
84
|
100
|
|
|
|
&& !(base == 8 && alt)) /* "%#.0o" prints "0" */ |
|
|
100
|
|
|
|
|
11138
|
76
|
|
|
|
|
elen = 0; |
11139
|
|
|
|
|
|
|
11140
|
|
|
|
|
|
/* a precision nullifies the 0 flag. */ |
11141
|
4152
|
100
|
|
|
|
if (fill == '0') |
11142
|
|
|
|
|
|
fill = ' '; |
11143
|
|
|
|
|
|
} |
11144
|
|
|
|
|
|
} |
11145
|
|
|
|
|
|
break; |
11146
|
|
|
|
|
|
|
11147
|
|
|
|
|
|
/* FLOATING POINT */ |
11148
|
|
|
|
|
|
|
11149
|
|
|
|
|
|
case 'F': |
11150
|
6
|
|
|
|
|
c = 'f'; /* maybe %F isn't supported here */ |
11151
|
|
|
|
|
|
/*FALLTHROUGH*/ |
11152
|
|
|
|
|
|
case 'e': case 'E': |
11153
|
|
|
|
|
|
case 'f': |
11154
|
|
|
|
|
|
case 'g': case 'G': |
11155
|
27416
|
100
|
|
|
|
if (vectorize) |
11156
|
|
|
|
|
|
goto unknown; |
11157
|
|
|
|
|
|
|
11158
|
|
|
|
|
|
/* This is evil, but floating point is even more evil */ |
11159
|
|
|
|
|
|
|
11160
|
|
|
|
|
|
/* for SV-style calling, we can only get NV |
11161
|
|
|
|
|
|
for C-style calling, we assume %f is double; |
11162
|
|
|
|
|
|
for simplicity we allow any of %Lf, %llf, %qf for long double |
11163
|
|
|
|
|
|
*/ |
11164
|
27392
|
100
|
|
|
|
switch (intsize) { |
11165
|
|
|
|
|
|
case 'V': |
11166
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
11167
|
|
|
|
|
|
intsize = 'q'; |
11168
|
|
|
|
|
|
#endif |
11169
|
|
|
|
|
|
break; |
11170
|
|
|
|
|
|
/* [perl #20339] - we should accept and ignore %lf rather than die */ |
11171
|
|
|
|
|
|
case 'l': |
11172
|
|
|
|
|
|
/*FALLTHROUGH*/ |
11173
|
|
|
|
|
|
default: |
11174
|
|
|
|
|
|
#if defined(USE_LONG_DOUBLE) |
11175
|
|
|
|
|
|
intsize = args ? 0 : 'q'; |
11176
|
|
|
|
|
|
#endif |
11177
|
|
|
|
|
|
break; |
11178
|
|
|
|
|
|
case 'q': |
11179
|
|
|
|
|
|
#if defined(HAS_LONG_DOUBLE) |
11180
|
|
|
|
|
|
break; |
11181
|
|
|
|
|
|
#else |
11182
|
|
|
|
|
|
/*FALLTHROUGH*/ |
11183
|
|
|
|
|
|
#endif |
11184
|
|
|
|
|
|
case 'c': |
11185
|
|
|
|
|
|
case 'h': |
11186
|
|
|
|
|
|
case 'z': |
11187
|
|
|
|
|
|
case 't': |
11188
|
|
|
|
|
|
case 'j': |
11189
|
|
|
|
|
|
goto unknown; |
11190
|
|
|
|
|
|
} |
11191
|
|
|
|
|
|
|
11192
|
|
|
|
|
|
/* now we need (long double) if intsize == 'q', else (double) */ |
11193
|
|
|
|
|
|
nv = (args) ? |
11194
|
|
|
|
|
|
#if LONG_DOUBLESIZE > DOUBLESIZE |
11195
|
|
|
|
|
|
intsize == 'q' ? |
11196
|
2290
|
50
|
|
|
|
va_arg(*args, long double) : |
11197
|
916
|
50
|
|
|
|
va_arg(*args, double) |
11198
|
|
|
|
|
|
#else |
11199
|
|
|
|
|
|
va_arg(*args, double) |
11200
|
|
|
|
|
|
#endif |
11201
|
40627
|
100
|
|
|
|
: SvNV(argsv); |
|
|
100
|
|
|
|
|
11202
|
|
|
|
|
|
|
11203
|
|
|
|
|
|
need = 0; |
11204
|
|
|
|
|
|
/* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything |
11205
|
|
|
|
|
|
else. frexp() has some unspecified behaviour for those three */ |
11206
|
27390
|
100
|
|
|
|
if (c != 'e' && c != 'E' && (nv * 0) == 0) { |
|
|
100
|
|
|
|
|
11207
|
27000
|
|
|
|
|
i = PERL_INT_MIN; |
11208
|
|
|
|
|
|
/* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this |
11209
|
|
|
|
|
|
will cast our (long double) to (double) */ |
11210
|
27000
|
|
|
|
|
(void)Perl_frexp(nv, &i); |
11211
|
27000
|
50
|
|
|
|
if (i == PERL_INT_MIN) |
11212
|
0
|
|
|
|
|
Perl_die(aTHX_ "panic: frexp"); |
11213
|
27000
|
100
|
|
|
|
if (i > 0) |
11214
|
23828
|
|
|
|
|
need = BIT_DIGITS(i); |
11215
|
|
|
|
|
|
} |
11216
|
27390
|
100
|
|
|
|
need += has_precis ? precis : 6; /* known default */ |
11217
|
|
|
|
|
|
|
11218
|
27390
|
100
|
|
|
|
if (need < width) |
11219
|
|
|
|
|
|
need = width; |
11220
|
|
|
|
|
|
|
11221
|
|
|
|
|
|
#ifdef HAS_LDBL_SPRINTF_BUG |
11222
|
|
|
|
|
|
/* This is to try to fix a bug with irix/nonstop-ux/powerux and |
11223
|
|
|
|
|
|
with sfio - Allen */ |
11224
|
|
|
|
|
|
|
11225
|
|
|
|
|
|
# ifdef DBL_MAX |
11226
|
|
|
|
|
|
# define MY_DBL_MAX DBL_MAX |
11227
|
|
|
|
|
|
# else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */ |
11228
|
|
|
|
|
|
# if DOUBLESIZE >= 8 |
11229
|
|
|
|
|
|
# define MY_DBL_MAX 1.7976931348623157E+308L |
11230
|
|
|
|
|
|
# else |
11231
|
|
|
|
|
|
# define MY_DBL_MAX 3.40282347E+38L |
11232
|
|
|
|
|
|
# endif |
11233
|
|
|
|
|
|
# endif |
11234
|
|
|
|
|
|
|
11235
|
|
|
|
|
|
# ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */ |
11236
|
|
|
|
|
|
# define MY_DBL_MAX_BUG 1L |
11237
|
|
|
|
|
|
# else |
11238
|
|
|
|
|
|
# define MY_DBL_MAX_BUG MY_DBL_MAX |
11239
|
|
|
|
|
|
# endif |
11240
|
|
|
|
|
|
|
11241
|
|
|
|
|
|
# ifdef DBL_MIN |
11242
|
|
|
|
|
|
# define MY_DBL_MIN DBL_MIN |
11243
|
|
|
|
|
|
# else /* XXX guessing! -Allen */ |
11244
|
|
|
|
|
|
# if DOUBLESIZE >= 8 |
11245
|
|
|
|
|
|
# define MY_DBL_MIN 2.2250738585072014E-308L |
11246
|
|
|
|
|
|
# else |
11247
|
|
|
|
|
|
# define MY_DBL_MIN 1.17549435E-38L |
11248
|
|
|
|
|
|
# endif |
11249
|
|
|
|
|
|
# endif |
11250
|
|
|
|
|
|
|
11251
|
|
|
|
|
|
if ((intsize == 'q') && (c == 'f') && |
11252
|
|
|
|
|
|
((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && |
11253
|
|
|
|
|
|
(need < DBL_DIG)) { |
11254
|
|
|
|
|
|
/* it's going to be short enough that |
11255
|
|
|
|
|
|
* long double precision is not needed */ |
11256
|
|
|
|
|
|
|
11257
|
|
|
|
|
|
if ((nv <= 0L) && (nv >= -0L)) |
11258
|
|
|
|
|
|
fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ |
11259
|
|
|
|
|
|
else { |
11260
|
|
|
|
|
|
/* would use Perl_fp_class as a double-check but not |
11261
|
|
|
|
|
|
* functional on IRIX - see perl.h comments */ |
11262
|
|
|
|
|
|
|
11263
|
|
|
|
|
|
if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { |
11264
|
|
|
|
|
|
/* It's within the range that a double can represent */ |
11265
|
|
|
|
|
|
#if defined(DBL_MAX) && !defined(DBL_MIN) |
11266
|
|
|
|
|
|
if ((nv >= ((long double)1/DBL_MAX)) || |
11267
|
|
|
|
|
|
(nv <= (-(long double)1/DBL_MAX))) |
11268
|
|
|
|
|
|
#endif |
11269
|
|
|
|
|
|
fix_ldbl_sprintf_bug = TRUE; |
11270
|
|
|
|
|
|
} |
11271
|
|
|
|
|
|
} |
11272
|
|
|
|
|
|
if (fix_ldbl_sprintf_bug == TRUE) { |
11273
|
|
|
|
|
|
double temp; |
11274
|
|
|
|
|
|
|
11275
|
|
|
|
|
|
intsize = 0; |
11276
|
|
|
|
|
|
temp = (double)nv; |
11277
|
|
|
|
|
|
nv = (NV)temp; |
11278
|
|
|
|
|
|
} |
11279
|
|
|
|
|
|
} |
11280
|
|
|
|
|
|
|
11281
|
|
|
|
|
|
# undef MY_DBL_MAX |
11282
|
|
|
|
|
|
# undef MY_DBL_MAX_BUG |
11283
|
|
|
|
|
|
# undef MY_DBL_MIN |
11284
|
|
|
|
|
|
|
11285
|
|
|
|
|
|
#endif /* HAS_LDBL_SPRINTF_BUG */ |
11286
|
|
|
|
|
|
|
11287
|
27390
|
|
|
|
|
need += 20; /* fudge factor */ |
11288
|
27390
|
100
|
|
|
|
if (PL_efloatsize < need) { |
11289
|
506
|
|
|
|
|
Safefree(PL_efloatbuf); |
11290
|
506
|
|
|
|
|
PL_efloatsize = need + 20; /* more fudge */ |
11291
|
506
|
|
|
|
|
Newx(PL_efloatbuf, PL_efloatsize, char); |
11292
|
506
|
|
|
|
|
PL_efloatbuf[0] = '\0'; |
11293
|
|
|
|
|
|
} |
11294
|
|
|
|
|
|
|
11295
|
27390
|
100
|
|
|
|
if ( !(width || left || plus || alt) && fill != '0' |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
11296
|
24102
|
100
|
|
|
|
&& has_precis && intsize != 'q' ) { /* Shortcuts */ |
|
|
50
|
|
|
|
|
11297
|
|
|
|
|
|
/* See earlier comment about buggy Gconvert when digits, |
11298
|
|
|
|
|
|
aka precis is 0 */ |
11299
|
2036
|
100
|
|
|
|
if ( c == 'g' && precis) { |
11300
|
76
|
|
|
|
|
Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); |
11301
|
|
|
|
|
|
/* May return an empty string for digits==0 */ |
11302
|
76
|
50
|
|
|
|
if (*PL_efloatbuf) { |
11303
|
76
|
|
|
|
|
elen = strlen(PL_efloatbuf); |
11304
|
76
|
|
|
|
|
goto float_converted; |
11305
|
|
|
|
|
|
} |
11306
|
1960
|
100
|
|
|
|
} else if ( c == 'f' && !precis) { |
11307
|
824
|
100
|
|
|
|
if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) |
11308
|
|
|
|
|
|
break; |
11309
|
|
|
|
|
|
} |
11310
|
|
|
|
|
|
} |
11311
|
|
|
|
|
|
{ |
11312
|
|
|
|
|
|
char *ptr = ebuf + sizeof ebuf; |
11313
|
26498
|
|
|
|
|
*--ptr = '\0'; |
11314
|
26498
|
|
|
|
|
*--ptr = c; |
11315
|
|
|
|
|
|
/* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ |
11316
|
|
|
|
|
|
#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) |
11317
|
26498
|
50
|
|
|
|
if (intsize == 'q') { |
11318
|
|
|
|
|
|
/* Copy the one or more characters in a long double |
11319
|
|
|
|
|
|
* format before the 'base' ([efgEFG]) character to |
11320
|
|
|
|
|
|
* the format string. */ |
11321
|
|
|
|
|
|
static char const prifldbl[] = PERL_PRIfldbl; |
11322
|
|
|
|
|
|
char const *p = prifldbl + sizeof(prifldbl) - 3; |
11323
|
0
|
0
|
|
|
|
while (p >= prifldbl) { *--ptr = *p--; } |
11324
|
|
|
|
|
|
} |
11325
|
|
|
|
|
|
#endif |
11326
|
26498
|
100
|
|
|
|
if (has_precis) { |
11327
|
4182
|
|
|
|
|
base = precis; |
11328
|
4186
|
100
|
|
|
|
do { *--ptr = '0' + (base % 10); } while (base /= 10); |
11329
|
4182
|
|
|
|
|
*--ptr = '.'; |
11330
|
|
|
|
|
|
} |
11331
|
26498
|
100
|
|
|
|
if (width) { |
11332
|
1180
|
|
|
|
|
base = width; |
11333
|
1210
|
100
|
|
|
|
do { *--ptr = '0' + (base % 10); } while (base /= 10); |
11334
|
|
|
|
|
|
} |
11335
|
26498
|
100
|
|
|
|
if (fill == '0') |
11336
|
2074
|
|
|
|
|
*--ptr = fill; |
11337
|
26498
|
100
|
|
|
|
if (left) |
11338
|
20
|
|
|
|
|
*--ptr = '-'; |
11339
|
26498
|
100
|
|
|
|
if (plus) |
11340
|
38
|
|
|
|
|
*--ptr = plus; |
11341
|
26498
|
100
|
|
|
|
if (alt) |
11342
|
20
|
|
|
|
|
*--ptr = '#'; |
11343
|
26498
|
|
|
|
|
*--ptr = '%'; |
11344
|
|
|
|
|
|
|
11345
|
|
|
|
|
|
/* No taint. Otherwise we are in the strange situation |
11346
|
|
|
|
|
|
* where printf() taints but print($float) doesn't. |
11347
|
|
|
|
|
|
* --jhi */ |
11348
|
|
|
|
|
|
|
11349
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
11350
|
26498
|
100
|
|
|
|
if (! PL_numeric_standard && ! IN_SOME_LOCALE_FORM) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
11351
|
|
|
|
|
|
|
11352
|
|
|
|
|
|
/* We use a mortal SV, so that any failures (such as if |
11353
|
|
|
|
|
|
* warnings are made fatal) won't leak */ |
11354
|
0
|
|
|
|
|
char *oldlocale_string = setlocale(LC_NUMERIC, NULL); |
11355
|
0
|
|
|
|
|
oldlocale = newSVpvn_flags(oldlocale_string, |
11356
|
|
|
|
|
|
strlen(oldlocale_string), |
11357
|
|
|
|
|
|
SVs_TEMP); |
11358
|
0
|
|
|
|
|
PL_numeric_standard = TRUE; |
11359
|
0
|
|
|
|
|
setlocale(LC_NUMERIC, "C"); |
11360
|
|
|
|
|
|
} |
11361
|
|
|
|
|
|
#endif |
11362
|
|
|
|
|
|
|
11363
|
|
|
|
|
|
#if defined(HAS_LONG_DOUBLE) |
11364
|
52996
|
50
|
|
|
|
elen = ((intsize == 'q') |
11365
|
0
|
0
|
|
|
|
? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) |
|
|
0
|
|
|
|
|
11366
|
39747
|
50
|
|
|
|
: my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); |
|
|
50
|
|
|
|
|
11367
|
|
|
|
|
|
#else |
11368
|
|
|
|
|
|
elen = my_sprintf(PL_efloatbuf, ptr, nv); |
11369
|
|
|
|
|
|
#endif |
11370
|
|
|
|
|
|
} |
11371
|
|
|
|
|
|
float_converted: |
11372
|
26574
|
|
|
|
|
eptr = PL_efloatbuf; |
11373
|
|
|
|
|
|
|
11374
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
11375
|
26574
|
50
|
|
|
|
if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) |
|
|
0
|
|
|
|
|
11376
|
0
|
0
|
|
|
|
&& instr(eptr, SvPVX_const(PL_numeric_radix_sv))) |
11377
|
|
|
|
|
|
{ |
11378
|
|
|
|
|
|
is_utf8 = TRUE; |
11379
|
|
|
|
|
|
} |
11380
|
|
|
|
|
|
#endif |
11381
|
|
|
|
|
|
|
11382
|
|
|
|
|
|
break; |
11383
|
|
|
|
|
|
|
11384
|
|
|
|
|
|
/* SPECIAL */ |
11385
|
|
|
|
|
|
|
11386
|
|
|
|
|
|
case 'n': |
11387
|
14
|
100
|
|
|
|
if (vectorize) |
11388
|
|
|
|
|
|
goto unknown; |
11389
|
10
|
|
|
|
|
i = SvCUR(sv) - origlen; |
11390
|
10
|
50
|
|
|
|
if (args) { |
11391
|
0
|
|
|
|
|
switch (intsize) { |
11392
|
0
|
0
|
|
|
|
case 'c': *(va_arg(*args, char*)) = i; break; |
11393
|
0
|
0
|
|
|
|
case 'h': *(va_arg(*args, short*)) = i; break; |
11394
|
0
|
0
|
|
|
|
default: *(va_arg(*args, int*)) = i; break; |
11395
|
0
|
0
|
|
|
|
case 'l': *(va_arg(*args, long*)) = i; break; |
11396
|
0
|
0
|
|
|
|
case 'V': *(va_arg(*args, IV*)) = i; break; |
11397
|
0
|
0
|
|
|
|
case 'z': *(va_arg(*args, SSize_t*)) = i; break; |
11398
|
0
|
0
|
|
|
|
case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; |
11399
|
|
|
|
|
|
#if HAS_C99 |
11400
|
|
|
|
|
|
case 'j': *(va_arg(*args, intmax_t*)) = i; break; |
11401
|
|
|
|
|
|
#endif |
11402
|
|
|
|
|
|
case 'q': |
11403
|
|
|
|
|
|
#ifdef HAS_QUAD |
11404
|
0
|
0
|
|
|
|
*(va_arg(*args, Quad_t*)) = i; break; |
11405
|
|
|
|
|
|
#else |
11406
|
|
|
|
|
|
goto unknown; |
11407
|
|
|
|
|
|
#endif |
11408
|
|
|
|
|
|
} |
11409
|
|
|
|
|
|
} |
11410
|
|
|
|
|
|
else |
11411
|
10
|
100
|
|
|
|
sv_setuv_mg(argsv, has_utf8 ? (UV)sv_len_utf8(sv) : (UV)i); |
11412
|
8
|
|
|
|
|
continue; /* not "break" */ |
11413
|
|
|
|
|
|
|
11414
|
|
|
|
|
|
/* UNKNOWN */ |
11415
|
|
|
|
|
|
|
11416
|
|
|
|
|
|
default: |
11417
|
|
|
|
|
|
unknown: |
11418
|
694
|
50
|
|
|
|
if (!args |
11419
|
694
|
50
|
|
|
|
&& (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) |
11420
|
694
|
100
|
|
|
|
&& ckWARN(WARN_PRINTF)) |
11421
|
|
|
|
|
|
{ |
11422
|
662
|
|
|
|
|
SV * const msg = sv_newmortal(); |
11423
|
662
|
100
|
|
|
|
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", |
11424
|
662
|
|
|
|
|
(PL_op->op_type == OP_PRTF) ? "" : "s"); |
11425
|
662
|
100
|
|
|
|
if (fmtstart < patend) { |
11426
|
656
|
|
|
|
|
const char * const fmtend = q < patend ? q : patend; |
11427
|
|
|
|
|
|
const char * f; |
11428
|
656
|
|
|
|
|
sv_catpvs(msg, "\"%"); |
11429
|
1996
|
100
|
|
|
|
for (f = fmtstart; f < fmtend; f++) { |
11430
|
1340
|
100
|
|
|
|
if (isPRINT(*f)) { |
11431
|
1006
|
|
|
|
|
sv_catpvn_nomg(msg, f, 1); |
11432
|
|
|
|
|
|
} else { |
11433
|
334
|
|
|
|
|
Perl_sv_catpvf(aTHX_ msg, |
11434
|
334
|
|
|
|
|
"\\%03"UVof, (UV)*f & 0xFF); |
11435
|
|
|
|
|
|
} |
11436
|
|
|
|
|
|
} |
11437
|
656
|
|
|
|
|
sv_catpvs(msg, "\""); |
11438
|
|
|
|
|
|
} else { |
11439
|
6
|
|
|
|
|
sv_catpvs(msg, "end of string"); |
11440
|
|
|
|
|
|
} |
11441
|
662
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ |
11442
|
|
|
|
|
|
} |
11443
|
|
|
|
|
|
|
11444
|
|
|
|
|
|
/* output mangled stuff ... */ |
11445
|
678
|
100
|
|
|
|
if (c == '\0') |
11446
|
78
|
|
|
|
|
--q; |
11447
|
|
|
|
|
|
eptr = p; |
11448
|
678
|
|
|
|
|
elen = q - p; |
11449
|
|
|
|
|
|
|
11450
|
|
|
|
|
|
/* ... right here, because formatting flags should not apply */ |
11451
|
678
|
50
|
|
|
|
SvGROW(sv, SvCUR(sv) + elen + 1); |
|
|
50
|
|
|
|
|
11452
|
678
|
|
|
|
|
p = SvEND(sv); |
11453
|
678
|
|
|
|
|
Copy(eptr, p, elen, char); |
11454
|
678
|
|
|
|
|
p += elen; |
11455
|
678
|
|
|
|
|
*p = '\0'; |
11456
|
678
|
|
|
|
|
SvCUR_set(sv, p - SvPVX_const(sv)); |
11457
|
|
|
|
|
|
svix = osvix; |
11458
|
678
|
|
|
|
|
continue; /* not "break" */ |
11459
|
|
|
|
|
|
} |
11460
|
|
|
|
|
|
|
11461
|
20360204
|
100
|
|
|
|
if (is_utf8 != has_utf8) { |
11462
|
138074
|
100
|
|
|
|
if (is_utf8) { |
11463
|
34800
|
100
|
|
|
|
if (SvCUR(sv)) |
11464
|
34782
|
|
|
|
|
sv_utf8_upgrade(sv); |
11465
|
|
|
|
|
|
} |
11466
|
|
|
|
|
|
else { |
11467
|
103274
|
|
|
|
|
const STRLEN old_elen = elen; |
11468
|
103274
|
|
|
|
|
SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); |
11469
|
103274
|
|
|
|
|
sv_utf8_upgrade(nsv); |
11470
|
103274
|
|
|
|
|
eptr = SvPVX_const(nsv); |
11471
|
103274
|
|
|
|
|
elen = SvCUR(nsv); |
11472
|
|
|
|
|
|
|
11473
|
103274
|
100
|
|
|
|
if (width) { /* fudge width (can't fudge elen) */ |
11474
|
14
|
|
|
|
|
width += elen - old_elen; |
11475
|
|
|
|
|
|
} |
11476
|
|
|
|
|
|
is_utf8 = TRUE; |
11477
|
|
|
|
|
|
} |
11478
|
|
|
|
|
|
} |
11479
|
|
|
|
|
|
|
11480
|
20360204
|
|
|
|
|
have = esignlen + zeros + elen; |
11481
|
20360204
|
50
|
|
|
|
if (have < zeros) |
11482
|
0
|
|
|
|
|
croak_memory_wrap(); |
11483
|
|
|
|
|
|
|
11484
|
20360204
|
|
|
|
|
need = (have > width ? have : width); |
11485
|
20360204
|
|
|
|
|
gap = need - have; |
11486
|
|
|
|
|
|
|
11487
|
20360204
|
50
|
|
|
|
if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) |
11488
|
0
|
|
|
|
|
croak_memory_wrap(); |
11489
|
20360204
|
50
|
|
|
|
SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); |
|
|
100
|
|
|
|
|
11490
|
20360204
|
|
|
|
|
p = SvEND(sv); |
11491
|
20360204
|
100
|
|
|
|
if (esignlen && fill == '0') { |
11492
|
|
|
|
|
|
int i; |
11493
|
2974
|
100
|
|
|
|
for (i = 0; i < (int)esignlen; i++) |
11494
|
2136
|
|
|
|
|
*p++ = esignbuf[i]; |
11495
|
|
|
|
|
|
} |
11496
|
20360204
|
100
|
|
|
|
if (gap && !left) { |
|
|
100
|
|
|
|
|
11497
|
1151707
|
|
|
|
|
memset(p, fill, gap); |
11498
|
1151707
|
|
|
|
|
p += gap; |
11499
|
|
|
|
|
|
} |
11500
|
20360204
|
100
|
|
|
|
if (esignlen && fill != '0') { |
11501
|
|
|
|
|
|
int i; |
11502
|
832267
|
100
|
|
|
|
for (i = 0; i < (int)esignlen; i++) |
11503
|
662534
|
|
|
|
|
*p++ = esignbuf[i]; |
11504
|
|
|
|
|
|
} |
11505
|
20360204
|
100
|
|
|
|
if (zeros) { |
11506
|
|
|
|
|
|
int i; |
11507
|
7396
|
100
|
|
|
|
for (i = zeros; i; i--) |
11508
|
3798
|
|
|
|
|
*p++ = '0'; |
11509
|
|
|
|
|
|
} |
11510
|
20360204
|
100
|
|
|
|
if (elen) { |
11511
|
20240342
|
|
|
|
|
Copy(eptr, p, elen, char); |
11512
|
20240342
|
|
|
|
|
p += elen; |
11513
|
|
|
|
|
|
} |
11514
|
20360204
|
100
|
|
|
|
if (gap && left) { |
|
|
100
|
|
|
|
|
11515
|
|
|
|
|
|
memset(p, ' ', gap); |
11516
|
75216
|
|
|
|
|
p += gap; |
11517
|
|
|
|
|
|
} |
11518
|
20360204
|
100
|
|
|
|
if (vectorize) { |
11519
|
15054
|
100
|
|
|
|
if (veclen) { |
11520
|
10038
|
|
|
|
|
Copy(dotstr, p, dotstrlen, char); |
11521
|
10038
|
|
|
|
|
p += dotstrlen; |
11522
|
|
|
|
|
|
} |
11523
|
|
|
|
|
|
else |
11524
|
|
|
|
|
|
vectorize = FALSE; /* done iterating over vecstr */ |
11525
|
|
|
|
|
|
} |
11526
|
20360204
|
100
|
|
|
|
if (is_utf8) |
11527
|
|
|
|
|
|
has_utf8 = TRUE; |
11528
|
20360204
|
100
|
|
|
|
if (has_utf8) |
11529
|
138600
|
|
|
|
|
SvUTF8_on(sv); |
11530
|
20360204
|
|
|
|
|
*p = '\0'; |
11531
|
20360204
|
|
|
|
|
SvCUR_set(sv, p - SvPVX_const(sv)); |
11532
|
20360204
|
100
|
|
|
|
if (vectorize) { |
11533
|
|
|
|
|
|
esignlen = 0; |
11534
|
|
|
|
|
|
goto vector; |
11535
|
|
|
|
|
|
} |
11536
|
|
|
|
|
|
} |
11537
|
11825776
|
100
|
|
|
|
SvTAINT(sv); |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
11538
|
|
|
|
|
|
|
11539
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC /* Done outside loop, so don't have to save/restore |
11540
|
|
|
|
|
|
each iteration. */ |
11541
|
11825776
|
50
|
|
|
|
if (oldlocale) { |
11542
|
0
|
|
|
|
|
setlocale(LC_NUMERIC, SvPVX(oldlocale)); |
11543
|
5939865
|
|
|
|
|
PL_numeric_standard = FALSE; |
11544
|
|
|
|
|
|
} |
11545
|
|
|
|
|
|
#endif |
11546
|
|
|
|
|
|
} |
11547
|
|
|
|
|
|
|
11548
|
|
|
|
|
|
/* ========================================================================= |
11549
|
|
|
|
|
|
|
11550
|
|
|
|
|
|
=head1 Cloning an interpreter |
11551
|
|
|
|
|
|
|
11552
|
|
|
|
|
|
All the macros and functions in this section are for the private use of |
11553
|
|
|
|
|
|
the main function, perl_clone(). |
11554
|
|
|
|
|
|
|
11555
|
|
|
|
|
|
The foo_dup() functions make an exact copy of an existing foo thingy. |
11556
|
|
|
|
|
|
During the course of a cloning, a hash table is used to map old addresses |
11557
|
|
|
|
|
|
to new addresses. The table is created and manipulated with the |
11558
|
|
|
|
|
|
ptr_table_* functions. |
11559
|
|
|
|
|
|
|
11560
|
|
|
|
|
|
=cut |
11561
|
|
|
|
|
|
|
11562
|
|
|
|
|
|
* =========================================================================*/ |
11563
|
|
|
|
|
|
|
11564
|
|
|
|
|
|
|
11565
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
11566
|
|
|
|
|
|
|
11567
|
|
|
|
|
|
/* XXX Remove this so it doesn't have to go thru the macro and return for nothing */ |
11568
|
|
|
|
|
|
#ifndef GpREFCNT_inc |
11569
|
|
|
|
|
|
# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) |
11570
|
|
|
|
|
|
#endif |
11571
|
|
|
|
|
|
|
11572
|
|
|
|
|
|
|
11573
|
|
|
|
|
|
/* Certain cases in Perl_ss_dup have been merged, by relying on the fact |
11574
|
|
|
|
|
|
that currently av_dup, gv_dup and hv_dup are the same as sv_dup. |
11575
|
|
|
|
|
|
If this changes, please unmerge ss_dup. |
11576
|
|
|
|
|
|
Likewise, sv_dup_inc_multiple() relies on this fact. */ |
11577
|
|
|
|
|
|
#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup_inc(s,t)) |
11578
|
|
|
|
|
|
#define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) |
11579
|
|
|
|
|
|
#define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t)) |
11580
|
|
|
|
|
|
#define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) |
11581
|
|
|
|
|
|
#define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t)) |
11582
|
|
|
|
|
|
#define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) |
11583
|
|
|
|
|
|
#define cv_dup_inc(s,t) MUTABLE_CV(sv_dup_inc((const SV *)s,t)) |
11584
|
|
|
|
|
|
#define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) |
11585
|
|
|
|
|
|
#define io_dup_inc(s,t) MUTABLE_IO(sv_dup_inc((const SV *)s,t)) |
11586
|
|
|
|
|
|
#define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) |
11587
|
|
|
|
|
|
#define gv_dup_inc(s,t) MUTABLE_GV(sv_dup_inc((const SV *)s,t)) |
11588
|
|
|
|
|
|
#define SAVEPV(p) ((p) ? savepv(p) : NULL) |
11589
|
|
|
|
|
|
#define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) |
11590
|
|
|
|
|
|
|
11591
|
|
|
|
|
|
/* clone a parser */ |
11592
|
|
|
|
|
|
|
11593
|
|
|
|
|
|
yy_parser * |
11594
|
|
|
|
|
|
Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) |
11595
|
|
|
|
|
|
{ |
11596
|
|
|
|
|
|
yy_parser *parser; |
11597
|
|
|
|
|
|
|
11598
|
|
|
|
|
|
PERL_ARGS_ASSERT_PARSER_DUP; |
11599
|
|
|
|
|
|
|
11600
|
|
|
|
|
|
if (!proto) |
11601
|
|
|
|
|
|
return NULL; |
11602
|
|
|
|
|
|
|
11603
|
|
|
|
|
|
/* look for it in the table first */ |
11604
|
|
|
|
|
|
parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); |
11605
|
|
|
|
|
|
if (parser) |
11606
|
|
|
|
|
|
return parser; |
11607
|
|
|
|
|
|
|
11608
|
|
|
|
|
|
/* create anew and remember what it is */ |
11609
|
|
|
|
|
|
Newxz(parser, 1, yy_parser); |
11610
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, proto, parser); |
11611
|
|
|
|
|
|
|
11612
|
|
|
|
|
|
/* XXX these not yet duped */ |
11613
|
|
|
|
|
|
parser->old_parser = NULL; |
11614
|
|
|
|
|
|
parser->stack = NULL; |
11615
|
|
|
|
|
|
parser->ps = NULL; |
11616
|
|
|
|
|
|
parser->stack_size = 0; |
11617
|
|
|
|
|
|
/* XXX parser->stack->state = 0; */ |
11618
|
|
|
|
|
|
|
11619
|
|
|
|
|
|
/* XXX eventually, just Copy() most of the parser struct ? */ |
11620
|
|
|
|
|
|
|
11621
|
|
|
|
|
|
parser->lex_brackets = proto->lex_brackets; |
11622
|
|
|
|
|
|
parser->lex_casemods = proto->lex_casemods; |
11623
|
|
|
|
|
|
parser->lex_brackstack = savepvn(proto->lex_brackstack, |
11624
|
|
|
|
|
|
(proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); |
11625
|
|
|
|
|
|
parser->lex_casestack = savepvn(proto->lex_casestack, |
11626
|
|
|
|
|
|
(proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); |
11627
|
|
|
|
|
|
parser->lex_defer = proto->lex_defer; |
11628
|
|
|
|
|
|
parser->lex_dojoin = proto->lex_dojoin; |
11629
|
|
|
|
|
|
parser->lex_expect = proto->lex_expect; |
11630
|
|
|
|
|
|
parser->lex_formbrack = proto->lex_formbrack; |
11631
|
|
|
|
|
|
parser->lex_inpat = proto->lex_inpat; |
11632
|
|
|
|
|
|
parser->lex_inwhat = proto->lex_inwhat; |
11633
|
|
|
|
|
|
parser->lex_op = proto->lex_op; |
11634
|
|
|
|
|
|
parser->lex_repl = sv_dup_inc(proto->lex_repl, param); |
11635
|
|
|
|
|
|
parser->lex_starts = proto->lex_starts; |
11636
|
|
|
|
|
|
parser->lex_stuff = sv_dup_inc(proto->lex_stuff, param); |
11637
|
|
|
|
|
|
parser->multi_close = proto->multi_close; |
11638
|
|
|
|
|
|
parser->multi_open = proto->multi_open; |
11639
|
|
|
|
|
|
parser->multi_start = proto->multi_start; |
11640
|
|
|
|
|
|
parser->multi_end = proto->multi_end; |
11641
|
|
|
|
|
|
parser->preambled = proto->preambled; |
11642
|
|
|
|
|
|
parser->sublex_info = proto->sublex_info; /* XXX not quite right */ |
11643
|
|
|
|
|
|
parser->linestr = sv_dup_inc(proto->linestr, param); |
11644
|
|
|
|
|
|
parser->expect = proto->expect; |
11645
|
|
|
|
|
|
parser->copline = proto->copline; |
11646
|
|
|
|
|
|
parser->last_lop_op = proto->last_lop_op; |
11647
|
|
|
|
|
|
parser->lex_state = proto->lex_state; |
11648
|
|
|
|
|
|
parser->rsfp = fp_dup(proto->rsfp, '<', param); |
11649
|
|
|
|
|
|
/* rsfp_filters entries have fake IoDIRP() */ |
11650
|
|
|
|
|
|
parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); |
11651
|
|
|
|
|
|
parser->in_my = proto->in_my; |
11652
|
|
|
|
|
|
parser->in_my_stash = hv_dup(proto->in_my_stash, param); |
11653
|
|
|
|
|
|
parser->error_count = proto->error_count; |
11654
|
|
|
|
|
|
|
11655
|
|
|
|
|
|
|
11656
|
|
|
|
|
|
parser->linestr = sv_dup_inc(proto->linestr, param); |
11657
|
|
|
|
|
|
|
11658
|
|
|
|
|
|
{ |
11659
|
|
|
|
|
|
char * const ols = SvPVX(proto->linestr); |
11660
|
|
|
|
|
|
char * const ls = SvPVX(parser->linestr); |
11661
|
|
|
|
|
|
|
11662
|
|
|
|
|
|
parser->bufptr = ls + (proto->bufptr >= ols ? |
11663
|
|
|
|
|
|
proto->bufptr - ols : 0); |
11664
|
|
|
|
|
|
parser->oldbufptr = ls + (proto->oldbufptr >= ols ? |
11665
|
|
|
|
|
|
proto->oldbufptr - ols : 0); |
11666
|
|
|
|
|
|
parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? |
11667
|
|
|
|
|
|
proto->oldoldbufptr - ols : 0); |
11668
|
|
|
|
|
|
parser->linestart = ls + (proto->linestart >= ols ? |
11669
|
|
|
|
|
|
proto->linestart - ols : 0); |
11670
|
|
|
|
|
|
parser->last_uni = ls + (proto->last_uni >= ols ? |
11671
|
|
|
|
|
|
proto->last_uni - ols : 0); |
11672
|
|
|
|
|
|
parser->last_lop = ls + (proto->last_lop >= ols ? |
11673
|
|
|
|
|
|
proto->last_lop - ols : 0); |
11674
|
|
|
|
|
|
|
11675
|
|
|
|
|
|
parser->bufend = ls + SvCUR(parser->linestr); |
11676
|
|
|
|
|
|
} |
11677
|
|
|
|
|
|
|
11678
|
|
|
|
|
|
Copy(proto->tokenbuf, parser->tokenbuf, 256, char); |
11679
|
|
|
|
|
|
|
11680
|
|
|
|
|
|
|
11681
|
|
|
|
|
|
#ifdef PERL_MAD |
11682
|
|
|
|
|
|
parser->endwhite = proto->endwhite; |
11683
|
|
|
|
|
|
parser->faketokens = proto->faketokens; |
11684
|
|
|
|
|
|
parser->lasttoke = proto->lasttoke; |
11685
|
|
|
|
|
|
parser->nextwhite = proto->nextwhite; |
11686
|
|
|
|
|
|
parser->realtokenstart = proto->realtokenstart; |
11687
|
|
|
|
|
|
parser->skipwhite = proto->skipwhite; |
11688
|
|
|
|
|
|
parser->thisclose = proto->thisclose; |
11689
|
|
|
|
|
|
parser->thismad = proto->thismad; |
11690
|
|
|
|
|
|
parser->thisopen = proto->thisopen; |
11691
|
|
|
|
|
|
parser->thisstuff = proto->thisstuff; |
11692
|
|
|
|
|
|
parser->thistoken = proto->thistoken; |
11693
|
|
|
|
|
|
parser->thiswhite = proto->thiswhite; |
11694
|
|
|
|
|
|
|
11695
|
|
|
|
|
|
Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE); |
11696
|
|
|
|
|
|
parser->curforce = proto->curforce; |
11697
|
|
|
|
|
|
#else |
11698
|
|
|
|
|
|
Copy(proto->nextval, parser->nextval, 5, YYSTYPE); |
11699
|
|
|
|
|
|
Copy(proto->nexttype, parser->nexttype, 5, I32); |
11700
|
|
|
|
|
|
parser->nexttoke = proto->nexttoke; |
11701
|
|
|
|
|
|
#endif |
11702
|
|
|
|
|
|
|
11703
|
|
|
|
|
|
/* XXX should clone saved_curcop here, but we aren't passed |
11704
|
|
|
|
|
|
* proto_perl; so do it in perl_clone_using instead */ |
11705
|
|
|
|
|
|
|
11706
|
|
|
|
|
|
return parser; |
11707
|
|
|
|
|
|
} |
11708
|
|
|
|
|
|
|
11709
|
|
|
|
|
|
|
11710
|
|
|
|
|
|
/* duplicate a file handle */ |
11711
|
|
|
|
|
|
|
11712
|
|
|
|
|
|
PerlIO * |
11713
|
|
|
|
|
|
Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) |
11714
|
|
|
|
|
|
{ |
11715
|
|
|
|
|
|
PerlIO *ret; |
11716
|
|
|
|
|
|
|
11717
|
|
|
|
|
|
PERL_ARGS_ASSERT_FP_DUP; |
11718
|
|
|
|
|
|
PERL_UNUSED_ARG(type); |
11719
|
|
|
|
|
|
|
11720
|
|
|
|
|
|
if (!fp) |
11721
|
|
|
|
|
|
return (PerlIO*)NULL; |
11722
|
|
|
|
|
|
|
11723
|
|
|
|
|
|
/* look for it in the table first */ |
11724
|
|
|
|
|
|
ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); |
11725
|
|
|
|
|
|
if (ret) |
11726
|
|
|
|
|
|
return ret; |
11727
|
|
|
|
|
|
|
11728
|
|
|
|
|
|
/* create anew and remember what it is */ |
11729
|
|
|
|
|
|
ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); |
11730
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, fp, ret); |
11731
|
|
|
|
|
|
return ret; |
11732
|
|
|
|
|
|
} |
11733
|
|
|
|
|
|
|
11734
|
|
|
|
|
|
/* duplicate a directory handle */ |
11735
|
|
|
|
|
|
|
11736
|
|
|
|
|
|
DIR * |
11737
|
|
|
|
|
|
Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) |
11738
|
|
|
|
|
|
{ |
11739
|
|
|
|
|
|
DIR *ret; |
11740
|
|
|
|
|
|
|
11741
|
|
|
|
|
|
#ifdef HAS_FCHDIR |
11742
|
|
|
|
|
|
DIR *pwd; |
11743
|
|
|
|
|
|
const Direntry_t *dirent; |
11744
|
|
|
|
|
|
char smallbuf[256]; |
11745
|
|
|
|
|
|
char *name = NULL; |
11746
|
|
|
|
|
|
STRLEN len = 0; |
11747
|
|
|
|
|
|
long pos; |
11748
|
|
|
|
|
|
#endif |
11749
|
|
|
|
|
|
|
11750
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
11751
|
|
|
|
|
|
PERL_ARGS_ASSERT_DIRP_DUP; |
11752
|
|
|
|
|
|
|
11753
|
|
|
|
|
|
if (!dp) |
11754
|
|
|
|
|
|
return (DIR*)NULL; |
11755
|
|
|
|
|
|
|
11756
|
|
|
|
|
|
/* look for it in the table first */ |
11757
|
|
|
|
|
|
ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp); |
11758
|
|
|
|
|
|
if (ret) |
11759
|
|
|
|
|
|
return ret; |
11760
|
|
|
|
|
|
|
11761
|
|
|
|
|
|
#ifdef HAS_FCHDIR |
11762
|
|
|
|
|
|
|
11763
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
11764
|
|
|
|
|
|
|
11765
|
|
|
|
|
|
/* create anew */ |
11766
|
|
|
|
|
|
|
11767
|
|
|
|
|
|
/* open the current directory (so we can switch back) */ |
11768
|
|
|
|
|
|
if (!(pwd = PerlDir_open("."))) return (DIR *)NULL; |
11769
|
|
|
|
|
|
|
11770
|
|
|
|
|
|
/* chdir to our dir handle and open the present working directory */ |
11771
|
|
|
|
|
|
if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) { |
11772
|
|
|
|
|
|
PerlDir_close(pwd); |
11773
|
|
|
|
|
|
return (DIR *)NULL; |
11774
|
|
|
|
|
|
} |
11775
|
|
|
|
|
|
/* Now we should have two dir handles pointing to the same dir. */ |
11776
|
|
|
|
|
|
|
11777
|
|
|
|
|
|
/* Be nice to the calling code and chdir back to where we were. */ |
11778
|
|
|
|
|
|
fchdir(my_dirfd(pwd)); /* If this fails, then what? */ |
11779
|
|
|
|
|
|
|
11780
|
|
|
|
|
|
/* We have no need of the pwd handle any more. */ |
11781
|
|
|
|
|
|
PerlDir_close(pwd); |
11782
|
|
|
|
|
|
|
11783
|
|
|
|
|
|
#ifdef DIRNAMLEN |
11784
|
|
|
|
|
|
# define d_namlen(d) (d)->d_namlen |
11785
|
|
|
|
|
|
#else |
11786
|
|
|
|
|
|
# define d_namlen(d) strlen((d)->d_name) |
11787
|
|
|
|
|
|
#endif |
11788
|
|
|
|
|
|
/* Iterate once through dp, to get the file name at the current posi- |
11789
|
|
|
|
|
|
tion. Then step back. */ |
11790
|
|
|
|
|
|
pos = PerlDir_tell(dp); |
11791
|
|
|
|
|
|
if ((dirent = PerlDir_read(dp))) { |
11792
|
|
|
|
|
|
len = d_namlen(dirent); |
11793
|
|
|
|
|
|
if (len <= sizeof smallbuf) name = smallbuf; |
11794
|
|
|
|
|
|
else Newx(name, len, char); |
11795
|
|
|
|
|
|
Move(dirent->d_name, name, len, char); |
11796
|
|
|
|
|
|
} |
11797
|
|
|
|
|
|
PerlDir_seek(dp, pos); |
11798
|
|
|
|
|
|
|
11799
|
|
|
|
|
|
/* Iterate through the new dir handle, till we find a file with the |
11800
|
|
|
|
|
|
right name. */ |
11801
|
|
|
|
|
|
if (!dirent) /* just before the end */ |
11802
|
|
|
|
|
|
for(;;) { |
11803
|
|
|
|
|
|
pos = PerlDir_tell(ret); |
11804
|
|
|
|
|
|
if (PerlDir_read(ret)) continue; /* not there yet */ |
11805
|
|
|
|
|
|
PerlDir_seek(ret, pos); /* step back */ |
11806
|
|
|
|
|
|
break; |
11807
|
|
|
|
|
|
} |
11808
|
|
|
|
|
|
else { |
11809
|
|
|
|
|
|
const long pos0 = PerlDir_tell(ret); |
11810
|
|
|
|
|
|
for(;;) { |
11811
|
|
|
|
|
|
pos = PerlDir_tell(ret); |
11812
|
|
|
|
|
|
if ((dirent = PerlDir_read(ret))) { |
11813
|
|
|
|
|
|
if (len == d_namlen(dirent) |
11814
|
|
|
|
|
|
&& memEQ(name, dirent->d_name, len)) { |
11815
|
|
|
|
|
|
/* found it */ |
11816
|
|
|
|
|
|
PerlDir_seek(ret, pos); /* step back */ |
11817
|
|
|
|
|
|
break; |
11818
|
|
|
|
|
|
} |
11819
|
|
|
|
|
|
/* else we are not there yet; keep iterating */ |
11820
|
|
|
|
|
|
} |
11821
|
|
|
|
|
|
else { /* This is not meant to happen. The best we can do is |
11822
|
|
|
|
|
|
reset the iterator to the beginning. */ |
11823
|
|
|
|
|
|
PerlDir_seek(ret, pos0); |
11824
|
|
|
|
|
|
break; |
11825
|
|
|
|
|
|
} |
11826
|
|
|
|
|
|
} |
11827
|
|
|
|
|
|
} |
11828
|
|
|
|
|
|
#undef d_namlen |
11829
|
|
|
|
|
|
|
11830
|
|
|
|
|
|
if (name && name != smallbuf) |
11831
|
|
|
|
|
|
Safefree(name); |
11832
|
|
|
|
|
|
#endif |
11833
|
|
|
|
|
|
|
11834
|
|
|
|
|
|
#ifdef WIN32 |
11835
|
|
|
|
|
|
ret = win32_dirp_dup(dp, param); |
11836
|
|
|
|
|
|
#endif |
11837
|
|
|
|
|
|
|
11838
|
|
|
|
|
|
/* pop it in the pointer table */ |
11839
|
|
|
|
|
|
if (ret) |
11840
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, dp, ret); |
11841
|
|
|
|
|
|
|
11842
|
|
|
|
|
|
return ret; |
11843
|
|
|
|
|
|
} |
11844
|
|
|
|
|
|
|
11845
|
|
|
|
|
|
/* duplicate a typeglob */ |
11846
|
|
|
|
|
|
|
11847
|
|
|
|
|
|
GP * |
11848
|
|
|
|
|
|
Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) |
11849
|
|
|
|
|
|
{ |
11850
|
|
|
|
|
|
GP *ret; |
11851
|
|
|
|
|
|
|
11852
|
|
|
|
|
|
PERL_ARGS_ASSERT_GP_DUP; |
11853
|
|
|
|
|
|
|
11854
|
|
|
|
|
|
if (!gp) |
11855
|
|
|
|
|
|
return (GP*)NULL; |
11856
|
|
|
|
|
|
/* look for it in the table first */ |
11857
|
|
|
|
|
|
ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); |
11858
|
|
|
|
|
|
if (ret) |
11859
|
|
|
|
|
|
return ret; |
11860
|
|
|
|
|
|
|
11861
|
|
|
|
|
|
/* create anew and remember what it is */ |
11862
|
|
|
|
|
|
Newxz(ret, 1, GP); |
11863
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, gp, ret); |
11864
|
|
|
|
|
|
|
11865
|
|
|
|
|
|
/* clone */ |
11866
|
|
|
|
|
|
/* ret->gp_refcnt must be 0 before any other dups are called. We're relying |
11867
|
|
|
|
|
|
on Newxz() to do this for us. */ |
11868
|
|
|
|
|
|
ret->gp_sv = sv_dup_inc(gp->gp_sv, param); |
11869
|
|
|
|
|
|
ret->gp_io = io_dup_inc(gp->gp_io, param); |
11870
|
|
|
|
|
|
ret->gp_form = cv_dup_inc(gp->gp_form, param); |
11871
|
|
|
|
|
|
ret->gp_av = av_dup_inc(gp->gp_av, param); |
11872
|
|
|
|
|
|
ret->gp_hv = hv_dup_inc(gp->gp_hv, param); |
11873
|
|
|
|
|
|
ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ |
11874
|
|
|
|
|
|
ret->gp_cv = cv_dup_inc(gp->gp_cv, param); |
11875
|
|
|
|
|
|
ret->gp_cvgen = gp->gp_cvgen; |
11876
|
|
|
|
|
|
ret->gp_line = gp->gp_line; |
11877
|
|
|
|
|
|
ret->gp_file_hek = hek_dup(gp->gp_file_hek, param); |
11878
|
|
|
|
|
|
return ret; |
11879
|
|
|
|
|
|
} |
11880
|
|
|
|
|
|
|
11881
|
|
|
|
|
|
/* duplicate a chain of magic */ |
11882
|
|
|
|
|
|
|
11883
|
|
|
|
|
|
MAGIC * |
11884
|
|
|
|
|
|
Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) |
11885
|
|
|
|
|
|
{ |
11886
|
|
|
|
|
|
MAGIC *mgret = NULL; |
11887
|
|
|
|
|
|
MAGIC **mgprev_p = &mgret; |
11888
|
|
|
|
|
|
|
11889
|
|
|
|
|
|
PERL_ARGS_ASSERT_MG_DUP; |
11890
|
|
|
|
|
|
|
11891
|
|
|
|
|
|
for (; mg; mg = mg->mg_moremagic) { |
11892
|
|
|
|
|
|
MAGIC *nmg; |
11893
|
|
|
|
|
|
|
11894
|
|
|
|
|
|
if ((param->flags & CLONEf_JOIN_IN) |
11895
|
|
|
|
|
|
&& mg->mg_type == PERL_MAGIC_backref) |
11896
|
|
|
|
|
|
/* when joining, we let the individual SVs add themselves to |
11897
|
|
|
|
|
|
* backref as needed. */ |
11898
|
|
|
|
|
|
continue; |
11899
|
|
|
|
|
|
|
11900
|
|
|
|
|
|
Newx(nmg, 1, MAGIC); |
11901
|
|
|
|
|
|
*mgprev_p = nmg; |
11902
|
|
|
|
|
|
mgprev_p = &(nmg->mg_moremagic); |
11903
|
|
|
|
|
|
|
11904
|
|
|
|
|
|
/* There was a comment "XXX copy dynamic vtable?" but as we don't have |
11905
|
|
|
|
|
|
dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates |
11906
|
|
|
|
|
|
from the original commit adding Perl_mg_dup() - revision 4538. |
11907
|
|
|
|
|
|
Similarly there is the annotation "XXX random ptr?" next to the |
11908
|
|
|
|
|
|
assignment to nmg->mg_ptr. */ |
11909
|
|
|
|
|
|
*nmg = *mg; |
11910
|
|
|
|
|
|
|
11911
|
|
|
|
|
|
/* FIXME for plugins |
11912
|
|
|
|
|
|
if (nmg->mg_type == PERL_MAGIC_qr) { |
11913
|
|
|
|
|
|
nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); |
11914
|
|
|
|
|
|
} |
11915
|
|
|
|
|
|
else |
11916
|
|
|
|
|
|
*/ |
11917
|
|
|
|
|
|
nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) |
11918
|
|
|
|
|
|
? nmg->mg_type == PERL_MAGIC_backref |
11919
|
|
|
|
|
|
/* The backref AV has its reference |
11920
|
|
|
|
|
|
* count deliberately bumped by 1 */ |
11921
|
|
|
|
|
|
? SvREFCNT_inc(av_dup_inc((const AV *) |
11922
|
|
|
|
|
|
nmg->mg_obj, param)) |
11923
|
|
|
|
|
|
: sv_dup_inc(nmg->mg_obj, param) |
11924
|
|
|
|
|
|
: sv_dup(nmg->mg_obj, param); |
11925
|
|
|
|
|
|
|
11926
|
|
|
|
|
|
if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { |
11927
|
|
|
|
|
|
if (nmg->mg_len > 0) { |
11928
|
|
|
|
|
|
nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); |
11929
|
|
|
|
|
|
if (nmg->mg_type == PERL_MAGIC_overload_table && |
11930
|
|
|
|
|
|
AMT_AMAGIC((AMT*)nmg->mg_ptr)) |
11931
|
|
|
|
|
|
{ |
11932
|
|
|
|
|
|
AMT * const namtp = (AMT*)nmg->mg_ptr; |
11933
|
|
|
|
|
|
sv_dup_inc_multiple((SV**)(namtp->table), |
11934
|
|
|
|
|
|
(SV**)(namtp->table), NofAMmeth, param); |
11935
|
|
|
|
|
|
} |
11936
|
|
|
|
|
|
} |
11937
|
|
|
|
|
|
else if (nmg->mg_len == HEf_SVKEY) |
11938
|
|
|
|
|
|
nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); |
11939
|
|
|
|
|
|
} |
11940
|
|
|
|
|
|
if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { |
11941
|
|
|
|
|
|
nmg->mg_virtual->svt_dup(aTHX_ nmg, param); |
11942
|
|
|
|
|
|
} |
11943
|
|
|
|
|
|
} |
11944
|
|
|
|
|
|
return mgret; |
11945
|
|
|
|
|
|
} |
11946
|
|
|
|
|
|
|
11947
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
11948
|
|
|
|
|
|
|
11949
|
|
|
|
|
|
struct ptr_tbl_arena { |
11950
|
|
|
|
|
|
struct ptr_tbl_arena *next; |
11951
|
|
|
|
|
|
struct ptr_tbl_ent array[1023/3]; /* as ptr_tbl_ent has 3 pointers. */ |
11952
|
|
|
|
|
|
}; |
11953
|
|
|
|
|
|
|
11954
|
|
|
|
|
|
/* create a new pointer-mapping table */ |
11955
|
|
|
|
|
|
|
11956
|
|
|
|
|
|
PTR_TBL_t * |
11957
|
366176
|
|
|
|
|
Perl_ptr_table_new(pTHX) |
11958
|
|
|
|
|
|
{ |
11959
|
|
|
|
|
|
PTR_TBL_t *tbl; |
11960
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
11961
|
|
|
|
|
|
|
11962
|
366176
|
|
|
|
|
Newx(tbl, 1, PTR_TBL_t); |
11963
|
366176
|
|
|
|
|
tbl->tbl_max = 511; |
11964
|
366176
|
|
|
|
|
tbl->tbl_items = 0; |
11965
|
366176
|
|
|
|
|
tbl->tbl_arena = NULL; |
11966
|
366176
|
|
|
|
|
tbl->tbl_arena_next = NULL; |
11967
|
366176
|
|
|
|
|
tbl->tbl_arena_end = NULL; |
11968
|
366176
|
50
|
|
|
|
Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); |
11969
|
366176
|
|
|
|
|
return tbl; |
11970
|
|
|
|
|
|
} |
11971
|
|
|
|
|
|
|
11972
|
|
|
|
|
|
#define PTR_TABLE_HASH(ptr) \ |
11973
|
|
|
|
|
|
((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) |
11974
|
|
|
|
|
|
|
11975
|
|
|
|
|
|
/* map an existing pointer using a table */ |
11976
|
|
|
|
|
|
|
11977
|
|
|
|
|
|
STATIC PTR_TBL_ENT_t * |
11978
|
|
|
|
|
|
S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) |
11979
|
|
|
|
|
|
{ |
11980
|
|
|
|
|
|
PTR_TBL_ENT_t *tblent; |
11981
|
338571340
|
|
|
|
|
const UV hash = PTR_TABLE_HASH(sv); |
11982
|
|
|
|
|
|
|
11983
|
|
|
|
|
|
PERL_ARGS_ASSERT_PTR_TABLE_FIND; |
11984
|
|
|
|
|
|
|
11985
|
338571340
|
|
|
|
|
tblent = tbl->tbl_ary[hash & tbl->tbl_max]; |
11986
|
317437498
|
100
|
|
|
|
for (; tblent; tblent = tblent->next) { |
|
|
100
|
|
|
|
|
11987
|
147978318
|
50
|
|
|
|
if (tblent->oldval == sv) |
|
|
100
|
|
|
|
|
11988
|
|
|
|
|
|
return tblent; |
11989
|
|
|
|
|
|
} |
11990
|
|
|
|
|
|
return NULL; |
11991
|
|
|
|
|
|
} |
11992
|
|
|
|
|
|
|
11993
|
|
|
|
|
|
void * |
11994
|
169290928
|
|
|
|
|
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) |
11995
|
|
|
|
|
|
{ |
11996
|
|
|
|
|
|
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv); |
11997
|
|
|
|
|
|
|
11998
|
|
|
|
|
|
PERL_ARGS_ASSERT_PTR_TABLE_FETCH; |
11999
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
12000
|
|
|
|
|
|
|
12001
|
169290928
|
100
|
|
|
|
return tblent ? tblent->newval : NULL; |
12002
|
|
|
|
|
|
} |
12003
|
|
|
|
|
|
|
12004
|
|
|
|
|
|
/* add a new entry to a pointer-mapping table */ |
12005
|
|
|
|
|
|
|
12006
|
|
|
|
|
|
void |
12007
|
169280412
|
|
|
|
|
Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) |
12008
|
|
|
|
|
|
{ |
12009
|
|
|
|
|
|
PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); |
12010
|
|
|
|
|
|
|
12011
|
|
|
|
|
|
PERL_ARGS_ASSERT_PTR_TABLE_STORE; |
12012
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
12013
|
|
|
|
|
|
|
12014
|
169280412
|
50
|
|
|
|
if (tblent) { |
12015
|
0
|
|
|
|
|
tblent->newval = newsv; |
12016
|
|
|
|
|
|
} else { |
12017
|
169280412
|
|
|
|
|
const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; |
12018
|
|
|
|
|
|
|
12019
|
169280412
|
100
|
|
|
|
if (tbl->tbl_arena_next == tbl->tbl_arena_end) { |
12020
|
|
|
|
|
|
struct ptr_tbl_arena *new_arena; |
12021
|
|
|
|
|
|
|
12022
|
719932
|
|
|
|
|
Newx(new_arena, 1, struct ptr_tbl_arena); |
12023
|
719932
|
|
|
|
|
new_arena->next = tbl->tbl_arena; |
12024
|
719932
|
|
|
|
|
tbl->tbl_arena = new_arena; |
12025
|
719932
|
|
|
|
|
tbl->tbl_arena_next = new_arena->array; |
12026
|
719932
|
|
|
|
|
tbl->tbl_arena_end = new_arena->array |
12027
|
719932
|
|
|
|
|
+ sizeof(new_arena->array) / sizeof(new_arena->array[0]); |
12028
|
|
|
|
|
|
} |
12029
|
|
|
|
|
|
|
12030
|
169280412
|
|
|
|
|
tblent = tbl->tbl_arena_next++; |
12031
|
|
|
|
|
|
|
12032
|
169280412
|
|
|
|
|
tblent->oldval = oldsv; |
12033
|
169280412
|
|
|
|
|
tblent->newval = newsv; |
12034
|
169280412
|
|
|
|
|
tblent->next = tbl->tbl_ary[entry]; |
12035
|
169280412
|
|
|
|
|
tbl->tbl_ary[entry] = tblent; |
12036
|
169280412
|
|
|
|
|
tbl->tbl_items++; |
12037
|
169280412
|
100
|
|
|
|
if (tblent->next && tbl->tbl_items > tbl->tbl_max) |
|
|
100
|
|
|
|
|
12038
|
114128
|
|
|
|
|
ptr_table_split(tbl); |
12039
|
|
|
|
|
|
} |
12040
|
169280412
|
|
|
|
|
} |
12041
|
|
|
|
|
|
|
12042
|
|
|
|
|
|
/* double the hash bucket size of an existing ptr table */ |
12043
|
|
|
|
|
|
|
12044
|
|
|
|
|
|
void |
12045
|
114130
|
|
|
|
|
Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) |
12046
|
|
|
|
|
|
{ |
12047
|
114130
|
|
|
|
|
PTR_TBL_ENT_t **ary = tbl->tbl_ary; |
12048
|
114130
|
|
|
|
|
const UV oldsize = tbl->tbl_max + 1; |
12049
|
114130
|
|
|
|
|
UV newsize = oldsize * 2; |
12050
|
|
|
|
|
|
UV i; |
12051
|
|
|
|
|
|
|
12052
|
|
|
|
|
|
PERL_ARGS_ASSERT_PTR_TABLE_SPLIT; |
12053
|
|
|
|
|
|
PERL_UNUSED_CONTEXT; |
12054
|
|
|
|
|
|
|
12055
|
114130
|
50
|
|
|
|
Renew(ary, newsize, PTR_TBL_ENT_t*); |
12056
|
114130
|
50
|
|
|
|
Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); |
12057
|
114130
|
|
|
|
|
tbl->tbl_max = --newsize; |
12058
|
114130
|
|
|
|
|
tbl->tbl_ary = ary; |
12059
|
145558994
|
100
|
|
|
|
for (i=0; i < oldsize; i++, ary++) { |
12060
|
|
|
|
|
|
PTR_TBL_ENT_t **entp = ary; |
12061
|
145444864
|
|
|
|
|
PTR_TBL_ENT_t *ent = *ary; |
12062
|
|
|
|
|
|
PTR_TBL_ENT_t **curentp; |
12063
|
145444864
|
100
|
|
|
|
if (!ent) |
12064
|
48989868
|
|
|
|
|
continue; |
12065
|
96454996
|
|
|
|
|
curentp = ary + oldsize; |
12066
|
|
|
|
|
|
do { |
12067
|
145571460
|
100
|
|
|
|
if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { |
12068
|
72859810
|
|
|
|
|
*entp = ent->next; |
12069
|
72859810
|
|
|
|
|
ent->next = *curentp; |
12070
|
72859810
|
|
|
|
|
*curentp = ent; |
12071
|
|
|
|
|
|
} |
12072
|
|
|
|
|
|
else |
12073
|
72711650
|
|
|
|
|
entp = &ent->next; |
12074
|
145571460
|
|
|
|
|
ent = *entp; |
12075
|
145571460
|
100
|
|
|
|
} while (ent); |
12076
|
|
|
|
|
|
} |
12077
|
114130
|
|
|
|
|
} |
12078
|
|
|
|
|
|
|
12079
|
|
|
|
|
|
/* remove all the entries from a ptr table */ |
12080
|
|
|
|
|
|
/* Deprecated - will be removed post 5.14 */ |
12081
|
|
|
|
|
|
|
12082
|
|
|
|
|
|
void |
12083
|
2
|
|
|
|
|
Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) |
12084
|
|
|
|
|
|
{ |
12085
|
2
|
50
|
|
|
|
if (tbl && tbl->tbl_items) { |
|
|
50
|
|
|
|
|
12086
|
2
|
|
|
|
|
struct ptr_tbl_arena *arena = tbl->tbl_arena; |
12087
|
|
|
|
|
|
|
12088
|
2
|
50
|
|
|
|
Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent **); |
12089
|
|
|
|
|
|
|
12090
|
4
|
100
|
|
|
|
while (arena) { |
12091
|
2
|
|
|
|
|
struct ptr_tbl_arena *next = arena->next; |
12092
|
|
|
|
|
|
|
12093
|
2
|
|
|
|
|
Safefree(arena); |
12094
|
|
|
|
|
|
arena = next; |
12095
|
|
|
|
|
|
}; |
12096
|
|
|
|
|
|
|
12097
|
2
|
|
|
|
|
tbl->tbl_items = 0; |
12098
|
2
|
|
|
|
|
tbl->tbl_arena = NULL; |
12099
|
2
|
|
|
|
|
tbl->tbl_arena_next = NULL; |
12100
|
2
|
|
|
|
|
tbl->tbl_arena_end = NULL; |
12101
|
|
|
|
|
|
} |
12102
|
2
|
|
|
|
|
} |
12103
|
|
|
|
|
|
|
12104
|
|
|
|
|
|
/* clear and free a ptr table */ |
12105
|
|
|
|
|
|
|
12106
|
|
|
|
|
|
void |
12107
|
366176
|
|
|
|
|
Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) |
12108
|
|
|
|
|
|
{ |
12109
|
|
|
|
|
|
struct ptr_tbl_arena *arena; |
12110
|
|
|
|
|
|
|
12111
|
366176
|
50
|
|
|
|
if (!tbl) { |
12112
|
366176
|
|
|
|
|
return; |
12113
|
|
|
|
|
|
} |
12114
|
|
|
|
|
|
|
12115
|
366176
|
|
|
|
|
arena = tbl->tbl_arena; |
12116
|
|
|
|
|
|
|
12117
|
1268835
|
100
|
|
|
|
while (arena) { |
12118
|
719930
|
|
|
|
|
struct ptr_tbl_arena *next = arena->next; |
12119
|
|
|
|
|
|
|
12120
|
719930
|
|
|
|
|
Safefree(arena); |
12121
|
|
|
|
|
|
arena = next; |
12122
|
|
|
|
|
|
} |
12123
|
|
|
|
|
|
|
12124
|
366176
|
|
|
|
|
Safefree(tbl->tbl_ary); |
12125
|
366176
|
|
|
|
|
Safefree(tbl); |
12126
|
|
|
|
|
|
} |
12127
|
|
|
|
|
|
|
12128
|
|
|
|
|
|
#if defined(USE_ITHREADS) |
12129
|
|
|
|
|
|
|
12130
|
|
|
|
|
|
void |
12131
|
|
|
|
|
|
Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param) |
12132
|
|
|
|
|
|
{ |
12133
|
|
|
|
|
|
PERL_ARGS_ASSERT_RVPV_DUP; |
12134
|
|
|
|
|
|
|
12135
|
|
|
|
|
|
assert(!isREGEXP(sstr)); |
12136
|
|
|
|
|
|
if (SvROK(sstr)) { |
12137
|
|
|
|
|
|
if (SvWEAKREF(sstr)) { |
12138
|
|
|
|
|
|
SvRV_set(dstr, sv_dup(SvRV_const(sstr), param)); |
12139
|
|
|
|
|
|
if (param->flags & CLONEf_JOIN_IN) { |
12140
|
|
|
|
|
|
/* if joining, we add any back references individually rather |
12141
|
|
|
|
|
|
* than copying the whole backref array */ |
12142
|
|
|
|
|
|
Perl_sv_add_backref(aTHX_ SvRV(dstr), dstr); |
12143
|
|
|
|
|
|
} |
12144
|
|
|
|
|
|
} |
12145
|
|
|
|
|
|
else |
12146
|
|
|
|
|
|
SvRV_set(dstr, sv_dup_inc(SvRV_const(sstr), param)); |
12147
|
|
|
|
|
|
} |
12148
|
|
|
|
|
|
else if (SvPVX_const(sstr)) { |
12149
|
|
|
|
|
|
/* Has something there */ |
12150
|
|
|
|
|
|
if (SvLEN(sstr)) { |
12151
|
|
|
|
|
|
/* Normal PV - clone whole allocated space */ |
12152
|
|
|
|
|
|
SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1)); |
12153
|
|
|
|
|
|
/* sstr may not be that normal, but actually copy on write. |
12154
|
|
|
|
|
|
But we are a true, independent SV, so: */ |
12155
|
|
|
|
|
|
SvIsCOW_off(dstr); |
12156
|
|
|
|
|
|
} |
12157
|
|
|
|
|
|
else { |
12158
|
|
|
|
|
|
/* Special case - not normally malloced for some reason */ |
12159
|
|
|
|
|
|
if (isGV_with_GP(sstr)) { |
12160
|
|
|
|
|
|
/* Don't need to do anything here. */ |
12161
|
|
|
|
|
|
} |
12162
|
|
|
|
|
|
else if ((SvIsCOW(sstr))) { |
12163
|
|
|
|
|
|
/* A "shared" PV - clone it as "shared" PV */ |
12164
|
|
|
|
|
|
SvPV_set(dstr, |
12165
|
|
|
|
|
|
HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)), |
12166
|
|
|
|
|
|
param))); |
12167
|
|
|
|
|
|
} |
12168
|
|
|
|
|
|
else { |
12169
|
|
|
|
|
|
/* Some other special case - random pointer */ |
12170
|
|
|
|
|
|
SvPV_set(dstr, (char *) SvPVX_const(sstr)); |
12171
|
|
|
|
|
|
} |
12172
|
|
|
|
|
|
} |
12173
|
|
|
|
|
|
} |
12174
|
|
|
|
|
|
else { |
12175
|
|
|
|
|
|
/* Copy the NULL */ |
12176
|
|
|
|
|
|
SvPV_set(dstr, NULL); |
12177
|
|
|
|
|
|
} |
12178
|
|
|
|
|
|
} |
12179
|
|
|
|
|
|
|
12180
|
|
|
|
|
|
/* duplicate a list of SVs. source and dest may point to the same memory. */ |
12181
|
|
|
|
|
|
static SV ** |
12182
|
|
|
|
|
|
S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, |
12183
|
|
|
|
|
|
SSize_t items, CLONE_PARAMS *const param) |
12184
|
|
|
|
|
|
{ |
12185
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE; |
12186
|
|
|
|
|
|
|
12187
|
|
|
|
|
|
while (items-- > 0) { |
12188
|
|
|
|
|
|
*dest++ = sv_dup_inc(*source++, param); |
12189
|
|
|
|
|
|
} |
12190
|
|
|
|
|
|
|
12191
|
|
|
|
|
|
return dest; |
12192
|
|
|
|
|
|
} |
12193
|
|
|
|
|
|
|
12194
|
|
|
|
|
|
/* duplicate an SV of any type (including AV, HV etc) */ |
12195
|
|
|
|
|
|
|
12196
|
|
|
|
|
|
static SV * |
12197
|
|
|
|
|
|
S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) |
12198
|
|
|
|
|
|
{ |
12199
|
|
|
|
|
|
dVAR; |
12200
|
|
|
|
|
|
SV *dstr; |
12201
|
|
|
|
|
|
|
12202
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DUP_COMMON; |
12203
|
|
|
|
|
|
|
12204
|
|
|
|
|
|
if (SvTYPE(sstr) == (svtype)SVTYPEMASK) { |
12205
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS_ABORT |
12206
|
|
|
|
|
|
abort(); |
12207
|
|
|
|
|
|
#endif |
12208
|
|
|
|
|
|
return NULL; |
12209
|
|
|
|
|
|
} |
12210
|
|
|
|
|
|
/* look for it in the table first */ |
12211
|
|
|
|
|
|
dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr)); |
12212
|
|
|
|
|
|
if (dstr) |
12213
|
|
|
|
|
|
return dstr; |
12214
|
|
|
|
|
|
|
12215
|
|
|
|
|
|
if(param->flags & CLONEf_JOIN_IN) { |
12216
|
|
|
|
|
|
/** We are joining here so we don't want do clone |
12217
|
|
|
|
|
|
something that is bad **/ |
12218
|
|
|
|
|
|
if (SvTYPE(sstr) == SVt_PVHV) { |
12219
|
|
|
|
|
|
const HEK * const hvname = HvNAME_HEK(sstr); |
12220
|
|
|
|
|
|
if (hvname) { |
12221
|
|
|
|
|
|
/** don't clone stashes if they already exist **/ |
12222
|
|
|
|
|
|
dstr = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), |
12223
|
|
|
|
|
|
HEK_UTF8(hvname) ? SVf_UTF8 : 0)); |
12224
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, sstr, dstr); |
12225
|
|
|
|
|
|
return dstr; |
12226
|
|
|
|
|
|
} |
12227
|
|
|
|
|
|
} |
12228
|
|
|
|
|
|
else if (SvTYPE(sstr) == SVt_PVGV && !SvFAKE(sstr)) { |
12229
|
|
|
|
|
|
HV *stash = GvSTASH(sstr); |
12230
|
|
|
|
|
|
const HEK * hvname; |
12231
|
|
|
|
|
|
if (stash && (hvname = HvNAME_HEK(stash))) { |
12232
|
|
|
|
|
|
/** don't clone GVs if they already exist **/ |
12233
|
|
|
|
|
|
SV **svp; |
12234
|
|
|
|
|
|
stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), |
12235
|
|
|
|
|
|
HEK_UTF8(hvname) ? SVf_UTF8 : 0); |
12236
|
|
|
|
|
|
svp = hv_fetch( |
12237
|
|
|
|
|
|
stash, GvNAME(sstr), |
12238
|
|
|
|
|
|
GvNAMEUTF8(sstr) |
12239
|
|
|
|
|
|
? -GvNAMELEN(sstr) |
12240
|
|
|
|
|
|
: GvNAMELEN(sstr), |
12241
|
|
|
|
|
|
0 |
12242
|
|
|
|
|
|
); |
12243
|
|
|
|
|
|
if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { |
12244
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, sstr, *svp); |
12245
|
|
|
|
|
|
return *svp; |
12246
|
|
|
|
|
|
} |
12247
|
|
|
|
|
|
} |
12248
|
|
|
|
|
|
} |
12249
|
|
|
|
|
|
} |
12250
|
|
|
|
|
|
|
12251
|
|
|
|
|
|
/* create anew and remember what it is */ |
12252
|
|
|
|
|
|
new_SV(dstr); |
12253
|
|
|
|
|
|
|
12254
|
|
|
|
|
|
#ifdef DEBUG_LEAKING_SCALARS |
12255
|
|
|
|
|
|
dstr->sv_debug_optype = sstr->sv_debug_optype; |
12256
|
|
|
|
|
|
dstr->sv_debug_line = sstr->sv_debug_line; |
12257
|
|
|
|
|
|
dstr->sv_debug_inpad = sstr->sv_debug_inpad; |
12258
|
|
|
|
|
|
dstr->sv_debug_parent = (SV*)sstr; |
12259
|
|
|
|
|
|
FREE_SV_DEBUG_FILE(dstr); |
12260
|
|
|
|
|
|
dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file); |
12261
|
|
|
|
|
|
#endif |
12262
|
|
|
|
|
|
|
12263
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, sstr, dstr); |
12264
|
|
|
|
|
|
|
12265
|
|
|
|
|
|
/* clone */ |
12266
|
|
|
|
|
|
SvFLAGS(dstr) = SvFLAGS(sstr); |
12267
|
|
|
|
|
|
SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ |
12268
|
|
|
|
|
|
SvREFCNT(dstr) = 0; /* must be before any other dups! */ |
12269
|
|
|
|
|
|
|
12270
|
|
|
|
|
|
#ifdef DEBUGGING |
12271
|
|
|
|
|
|
if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx) |
12272
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", |
12273
|
|
|
|
|
|
(void*)PL_watch_pvx, SvPVX_const(sstr)); |
12274
|
|
|
|
|
|
#endif |
12275
|
|
|
|
|
|
|
12276
|
|
|
|
|
|
/* don't clone objects whose class has asked us not to */ |
12277
|
|
|
|
|
|
if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { |
12278
|
|
|
|
|
|
SvFLAGS(dstr) = 0; |
12279
|
|
|
|
|
|
return dstr; |
12280
|
|
|
|
|
|
} |
12281
|
|
|
|
|
|
|
12282
|
|
|
|
|
|
switch (SvTYPE(sstr)) { |
12283
|
|
|
|
|
|
case SVt_NULL: |
12284
|
|
|
|
|
|
SvANY(dstr) = NULL; |
12285
|
|
|
|
|
|
break; |
12286
|
|
|
|
|
|
case SVt_IV: |
12287
|
|
|
|
|
|
SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); |
12288
|
|
|
|
|
|
if(SvROK(sstr)) { |
12289
|
|
|
|
|
|
Perl_rvpv_dup(aTHX_ dstr, sstr, param); |
12290
|
|
|
|
|
|
} else { |
12291
|
|
|
|
|
|
SvIV_set(dstr, SvIVX(sstr)); |
12292
|
|
|
|
|
|
} |
12293
|
|
|
|
|
|
break; |
12294
|
|
|
|
|
|
case SVt_NV: |
12295
|
|
|
|
|
|
SvANY(dstr) = new_XNV(); |
12296
|
|
|
|
|
|
SvNV_set(dstr, SvNVX(sstr)); |
12297
|
|
|
|
|
|
break; |
12298
|
|
|
|
|
|
default: |
12299
|
|
|
|
|
|
{ |
12300
|
|
|
|
|
|
/* These are all the types that need complex bodies allocating. */ |
12301
|
|
|
|
|
|
void *new_body; |
12302
|
|
|
|
|
|
const svtype sv_type = SvTYPE(sstr); |
12303
|
|
|
|
|
|
const struct body_details *const sv_type_details |
12304
|
|
|
|
|
|
= bodies_by_type + sv_type; |
12305
|
|
|
|
|
|
|
12306
|
|
|
|
|
|
switch (sv_type) { |
12307
|
|
|
|
|
|
default: |
12308
|
|
|
|
|
|
Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); |
12309
|
|
|
|
|
|
break; |
12310
|
|
|
|
|
|
|
12311
|
|
|
|
|
|
case SVt_PVGV: |
12312
|
|
|
|
|
|
case SVt_PVIO: |
12313
|
|
|
|
|
|
case SVt_PVFM: |
12314
|
|
|
|
|
|
case SVt_PVHV: |
12315
|
|
|
|
|
|
case SVt_PVAV: |
12316
|
|
|
|
|
|
case SVt_PVCV: |
12317
|
|
|
|
|
|
case SVt_PVLV: |
12318
|
|
|
|
|
|
case SVt_REGEXP: |
12319
|
|
|
|
|
|
case SVt_PVMG: |
12320
|
|
|
|
|
|
case SVt_PVNV: |
12321
|
|
|
|
|
|
case SVt_PVIV: |
12322
|
|
|
|
|
|
case SVt_INVLIST: |
12323
|
|
|
|
|
|
case SVt_PV: |
12324
|
|
|
|
|
|
assert(sv_type_details->body_size); |
12325
|
|
|
|
|
|
if (sv_type_details->arena) { |
12326
|
|
|
|
|
|
new_body_inline(new_body, sv_type); |
12327
|
|
|
|
|
|
new_body |
12328
|
|
|
|
|
|
= (void*)((char*)new_body - sv_type_details->offset); |
12329
|
|
|
|
|
|
} else { |
12330
|
|
|
|
|
|
new_body = new_NOARENA(sv_type_details); |
12331
|
|
|
|
|
|
} |
12332
|
|
|
|
|
|
} |
12333
|
|
|
|
|
|
assert(new_body); |
12334
|
|
|
|
|
|
SvANY(dstr) = new_body; |
12335
|
|
|
|
|
|
|
12336
|
|
|
|
|
|
#ifndef PURIFY |
12337
|
|
|
|
|
|
Copy(((char*)SvANY(sstr)) + sv_type_details->offset, |
12338
|
|
|
|
|
|
((char*)SvANY(dstr)) + sv_type_details->offset, |
12339
|
|
|
|
|
|
sv_type_details->copy, char); |
12340
|
|
|
|
|
|
#else |
12341
|
|
|
|
|
|
Copy(((char*)SvANY(sstr)), |
12342
|
|
|
|
|
|
((char*)SvANY(dstr)), |
12343
|
|
|
|
|
|
sv_type_details->body_size + sv_type_details->offset, char); |
12344
|
|
|
|
|
|
#endif |
12345
|
|
|
|
|
|
|
12346
|
|
|
|
|
|
if (sv_type != SVt_PVAV && sv_type != SVt_PVHV |
12347
|
|
|
|
|
|
&& !isGV_with_GP(dstr) |
12348
|
|
|
|
|
|
&& !isREGEXP(dstr) |
12349
|
|
|
|
|
|
&& !(sv_type == SVt_PVIO && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))) |
12350
|
|
|
|
|
|
Perl_rvpv_dup(aTHX_ dstr, sstr, param); |
12351
|
|
|
|
|
|
|
12352
|
|
|
|
|
|
/* The Copy above means that all the source (unduplicated) pointers |
12353
|
|
|
|
|
|
are now in the destination. We can check the flags and the |
12354
|
|
|
|
|
|
pointers in either, but it's possible that there's less cache |
12355
|
|
|
|
|
|
missing by always going for the destination. |
12356
|
|
|
|
|
|
FIXME - instrument and check that assumption */ |
12357
|
|
|
|
|
|
if (sv_type >= SVt_PVMG) { |
12358
|
|
|
|
|
|
if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) { |
12359
|
|
|
|
|
|
SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param)); |
12360
|
|
|
|
|
|
} else if (sv_type == SVt_PVAV && AvPAD_NAMELIST(dstr)) { |
12361
|
|
|
|
|
|
NOOP; |
12362
|
|
|
|
|
|
} else if (SvMAGIC(dstr)) |
12363
|
|
|
|
|
|
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); |
12364
|
|
|
|
|
|
if (SvOBJECT(dstr) && SvSTASH(dstr)) |
12365
|
|
|
|
|
|
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); |
12366
|
|
|
|
|
|
else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */ |
12367
|
|
|
|
|
|
} |
12368
|
|
|
|
|
|
|
12369
|
|
|
|
|
|
/* The cast silences a GCC warning about unhandled types. */ |
12370
|
|
|
|
|
|
switch ((int)sv_type) { |
12371
|
|
|
|
|
|
case SVt_PV: |
12372
|
|
|
|
|
|
break; |
12373
|
|
|
|
|
|
case SVt_PVIV: |
12374
|
|
|
|
|
|
break; |
12375
|
|
|
|
|
|
case SVt_PVNV: |
12376
|
|
|
|
|
|
break; |
12377
|
|
|
|
|
|
case SVt_PVMG: |
12378
|
|
|
|
|
|
break; |
12379
|
|
|
|
|
|
case SVt_REGEXP: |
12380
|
|
|
|
|
|
duprex: |
12381
|
|
|
|
|
|
/* FIXME for plugins */ |
12382
|
|
|
|
|
|
dstr->sv_u.svu_rx = ((REGEXP *)dstr)->sv_any; |
12383
|
|
|
|
|
|
re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); |
12384
|
|
|
|
|
|
break; |
12385
|
|
|
|
|
|
case SVt_PVLV: |
12386
|
|
|
|
|
|
/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ |
12387
|
|
|
|
|
|
if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ |
12388
|
|
|
|
|
|
LvTARG(dstr) = dstr; |
12389
|
|
|
|
|
|
else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ |
12390
|
|
|
|
|
|
LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param)); |
12391
|
|
|
|
|
|
else |
12392
|
|
|
|
|
|
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); |
12393
|
|
|
|
|
|
if (isREGEXP(sstr)) goto duprex; |
12394
|
|
|
|
|
|
case SVt_PVGV: |
12395
|
|
|
|
|
|
/* non-GP case already handled above */ |
12396
|
|
|
|
|
|
if(isGV_with_GP(sstr)) { |
12397
|
|
|
|
|
|
GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); |
12398
|
|
|
|
|
|
/* Don't call sv_add_backref here as it's going to be |
12399
|
|
|
|
|
|
created as part of the magic cloning of the symbol |
12400
|
|
|
|
|
|
table--unless this is during a join and the stash |
12401
|
|
|
|
|
|
is not actually being cloned. */ |
12402
|
|
|
|
|
|
/* Danger Will Robinson - GvGP(dstr) isn't initialised |
12403
|
|
|
|
|
|
at the point of this comment. */ |
12404
|
|
|
|
|
|
GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); |
12405
|
|
|
|
|
|
if (param->flags & CLONEf_JOIN_IN) |
12406
|
|
|
|
|
|
Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); |
12407
|
|
|
|
|
|
GvGP_set(dstr, gp_dup(GvGP(sstr), param)); |
12408
|
|
|
|
|
|
(void)GpREFCNT_inc(GvGP(dstr)); |
12409
|
|
|
|
|
|
} |
12410
|
|
|
|
|
|
break; |
12411
|
|
|
|
|
|
case SVt_PVIO: |
12412
|
|
|
|
|
|
/* PL_parser->rsfp_filters entries have fake IoDIRP() */ |
12413
|
|
|
|
|
|
if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { |
12414
|
|
|
|
|
|
/* I have no idea why fake dirp (rsfps) |
12415
|
|
|
|
|
|
should be treated differently but otherwise |
12416
|
|
|
|
|
|
we end up with leaks -- sky*/ |
12417
|
|
|
|
|
|
IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param); |
12418
|
|
|
|
|
|
IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param); |
12419
|
|
|
|
|
|
IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param); |
12420
|
|
|
|
|
|
} else { |
12421
|
|
|
|
|
|
IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param); |
12422
|
|
|
|
|
|
IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param); |
12423
|
|
|
|
|
|
IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param); |
12424
|
|
|
|
|
|
if (IoDIRP(dstr)) { |
12425
|
|
|
|
|
|
IoDIRP(dstr) = dirp_dup(IoDIRP(dstr), param); |
12426
|
|
|
|
|
|
} else { |
12427
|
|
|
|
|
|
NOOP; |
12428
|
|
|
|
|
|
/* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */ |
12429
|
|
|
|
|
|
} |
12430
|
|
|
|
|
|
IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(dstr), param); |
12431
|
|
|
|
|
|
} |
12432
|
|
|
|
|
|
if (IoOFP(dstr) == IoIFP(sstr)) |
12433
|
|
|
|
|
|
IoOFP(dstr) = IoIFP(dstr); |
12434
|
|
|
|
|
|
else |
12435
|
|
|
|
|
|
IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); |
12436
|
|
|
|
|
|
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr)); |
12437
|
|
|
|
|
|
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr)); |
12438
|
|
|
|
|
|
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); |
12439
|
|
|
|
|
|
break; |
12440
|
|
|
|
|
|
case SVt_PVAV: |
12441
|
|
|
|
|
|
/* avoid cloning an empty array */ |
12442
|
|
|
|
|
|
if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) { |
12443
|
|
|
|
|
|
SV **dst_ary, **src_ary; |
12444
|
|
|
|
|
|
SSize_t items = AvFILLp((const AV *)sstr) + 1; |
12445
|
|
|
|
|
|
|
12446
|
|
|
|
|
|
src_ary = AvARRAY((const AV *)sstr); |
12447
|
|
|
|
|
|
Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*); |
12448
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, src_ary, dst_ary); |
12449
|
|
|
|
|
|
AvARRAY(MUTABLE_AV(dstr)) = dst_ary; |
12450
|
|
|
|
|
|
AvALLOC((const AV *)dstr) = dst_ary; |
12451
|
|
|
|
|
|
if (AvREAL((const AV *)sstr)) { |
12452
|
|
|
|
|
|
dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, |
12453
|
|
|
|
|
|
param); |
12454
|
|
|
|
|
|
} |
12455
|
|
|
|
|
|
else { |
12456
|
|
|
|
|
|
while (items-- > 0) |
12457
|
|
|
|
|
|
*dst_ary++ = sv_dup(*src_ary++, param); |
12458
|
|
|
|
|
|
} |
12459
|
|
|
|
|
|
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); |
12460
|
|
|
|
|
|
while (items-- > 0) { |
12461
|
|
|
|
|
|
*dst_ary++ = &PL_sv_undef; |
12462
|
|
|
|
|
|
} |
12463
|
|
|
|
|
|
} |
12464
|
|
|
|
|
|
else { |
12465
|
|
|
|
|
|
AvARRAY(MUTABLE_AV(dstr)) = NULL; |
12466
|
|
|
|
|
|
AvALLOC((const AV *)dstr) = (SV**)NULL; |
12467
|
|
|
|
|
|
AvMAX( (const AV *)dstr) = -1; |
12468
|
|
|
|
|
|
AvFILLp((const AV *)dstr) = -1; |
12469
|
|
|
|
|
|
} |
12470
|
|
|
|
|
|
break; |
12471
|
|
|
|
|
|
case SVt_PVHV: |
12472
|
|
|
|
|
|
if (HvARRAY((const HV *)sstr)) { |
12473
|
|
|
|
|
|
STRLEN i = 0; |
12474
|
|
|
|
|
|
const bool sharekeys = !!HvSHAREKEYS(sstr); |
12475
|
|
|
|
|
|
XPVHV * const dxhv = (XPVHV*)SvANY(dstr); |
12476
|
|
|
|
|
|
XPVHV * const sxhv = (XPVHV*)SvANY(sstr); |
12477
|
|
|
|
|
|
char *darray; |
12478
|
|
|
|
|
|
Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) |
12479
|
|
|
|
|
|
+ (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), |
12480
|
|
|
|
|
|
char); |
12481
|
|
|
|
|
|
HvARRAY(dstr) = (HE**)darray; |
12482
|
|
|
|
|
|
while (i <= sxhv->xhv_max) { |
12483
|
|
|
|
|
|
const HE * const source = HvARRAY(sstr)[i]; |
12484
|
|
|
|
|
|
HvARRAY(dstr)[i] = source |
12485
|
|
|
|
|
|
? he_dup(source, sharekeys, param) : 0; |
12486
|
|
|
|
|
|
++i; |
12487
|
|
|
|
|
|
} |
12488
|
|
|
|
|
|
if (SvOOK(sstr)) { |
12489
|
|
|
|
|
|
const struct xpvhv_aux * const saux = HvAUX(sstr); |
12490
|
|
|
|
|
|
struct xpvhv_aux * const daux = HvAUX(dstr); |
12491
|
|
|
|
|
|
/* This flag isn't copied. */ |
12492
|
|
|
|
|
|
SvOOK_on(dstr); |
12493
|
|
|
|
|
|
|
12494
|
|
|
|
|
|
if (saux->xhv_name_count) { |
12495
|
|
|
|
|
|
HEK ** const sname = saux->xhv_name_u.xhvnameu_names; |
12496
|
|
|
|
|
|
const I32 count |
12497
|
|
|
|
|
|
= saux->xhv_name_count < 0 |
12498
|
|
|
|
|
|
? -saux->xhv_name_count |
12499
|
|
|
|
|
|
: saux->xhv_name_count; |
12500
|
|
|
|
|
|
HEK **shekp = sname + count; |
12501
|
|
|
|
|
|
HEK **dhekp; |
12502
|
|
|
|
|
|
Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); |
12503
|
|
|
|
|
|
dhekp = daux->xhv_name_u.xhvnameu_names + count; |
12504
|
|
|
|
|
|
while (shekp-- > sname) { |
12505
|
|
|
|
|
|
dhekp--; |
12506
|
|
|
|
|
|
*dhekp = hek_dup(*shekp, param); |
12507
|
|
|
|
|
|
} |
12508
|
|
|
|
|
|
} |
12509
|
|
|
|
|
|
else { |
12510
|
|
|
|
|
|
daux->xhv_name_u.xhvnameu_name |
12511
|
|
|
|
|
|
= hek_dup(saux->xhv_name_u.xhvnameu_name, |
12512
|
|
|
|
|
|
param); |
12513
|
|
|
|
|
|
} |
12514
|
|
|
|
|
|
daux->xhv_name_count = saux->xhv_name_count; |
12515
|
|
|
|
|
|
|
12516
|
|
|
|
|
|
daux->xhv_fill_lazy = saux->xhv_fill_lazy; |
12517
|
|
|
|
|
|
daux->xhv_riter = saux->xhv_riter; |
12518
|
|
|
|
|
|
daux->xhv_eiter = saux->xhv_eiter |
12519
|
|
|
|
|
|
? he_dup(saux->xhv_eiter, |
12520
|
|
|
|
|
|
cBOOL(HvSHAREKEYS(sstr)), param) : 0; |
12521
|
|
|
|
|
|
/* backref array needs refcnt=2; see sv_add_backref */ |
12522
|
|
|
|
|
|
daux->xhv_backreferences = |
12523
|
|
|
|
|
|
(param->flags & CLONEf_JOIN_IN) |
12524
|
|
|
|
|
|
/* when joining, we let the individual GVs and |
12525
|
|
|
|
|
|
* CVs add themselves to backref as |
12526
|
|
|
|
|
|
* needed. This avoids pulling in stuff |
12527
|
|
|
|
|
|
* that isn't required, and simplifies the |
12528
|
|
|
|
|
|
* case where stashes aren't cloned back |
12529
|
|
|
|
|
|
* if they already exist in the parent |
12530
|
|
|
|
|
|
* thread */ |
12531
|
|
|
|
|
|
? NULL |
12532
|
|
|
|
|
|
: saux->xhv_backreferences |
12533
|
|
|
|
|
|
? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV) |
12534
|
|
|
|
|
|
? MUTABLE_AV(SvREFCNT_inc( |
12535
|
|
|
|
|
|
sv_dup_inc((const SV *) |
12536
|
|
|
|
|
|
saux->xhv_backreferences, param))) |
12537
|
|
|
|
|
|
: MUTABLE_AV(sv_dup((const SV *) |
12538
|
|
|
|
|
|
saux->xhv_backreferences, param)) |
12539
|
|
|
|
|
|
: 0; |
12540
|
|
|
|
|
|
|
12541
|
|
|
|
|
|
daux->xhv_mro_meta = saux->xhv_mro_meta |
12542
|
|
|
|
|
|
? mro_meta_dup(saux->xhv_mro_meta, param) |
12543
|
|
|
|
|
|
: 0; |
12544
|
|
|
|
|
|
|
12545
|
|
|
|
|
|
/* Record stashes for possible cloning in Perl_clone(). */ |
12546
|
|
|
|
|
|
if (HvNAME(sstr)) |
12547
|
|
|
|
|
|
av_push(param->stashes, dstr); |
12548
|
|
|
|
|
|
} |
12549
|
|
|
|
|
|
} |
12550
|
|
|
|
|
|
else |
12551
|
|
|
|
|
|
HvARRAY(MUTABLE_HV(dstr)) = NULL; |
12552
|
|
|
|
|
|
break; |
12553
|
|
|
|
|
|
case SVt_PVCV: |
12554
|
|
|
|
|
|
if (!(param->flags & CLONEf_COPY_STACKS)) { |
12555
|
|
|
|
|
|
CvDEPTH(dstr) = 0; |
12556
|
|
|
|
|
|
} |
12557
|
|
|
|
|
|
/*FALLTHROUGH*/ |
12558
|
|
|
|
|
|
case SVt_PVFM: |
12559
|
|
|
|
|
|
/* NOTE: not refcounted */ |
12560
|
|
|
|
|
|
SvANY(MUTABLE_CV(dstr))->xcv_stash = |
12561
|
|
|
|
|
|
hv_dup(CvSTASH(dstr), param); |
12562
|
|
|
|
|
|
if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dstr)) |
12563
|
|
|
|
|
|
Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dstr)), dstr); |
12564
|
|
|
|
|
|
if (!CvISXSUB(dstr)) { |
12565
|
|
|
|
|
|
OP_REFCNT_LOCK; |
12566
|
|
|
|
|
|
CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr)); |
12567
|
|
|
|
|
|
OP_REFCNT_UNLOCK; |
12568
|
|
|
|
|
|
CvSLABBED_off(dstr); |
12569
|
|
|
|
|
|
} else if (CvCONST(dstr)) { |
12570
|
|
|
|
|
|
CvXSUBANY(dstr).any_ptr = |
12571
|
|
|
|
|
|
sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); |
12572
|
|
|
|
|
|
} |
12573
|
|
|
|
|
|
assert(!CvSLABBED(dstr)); |
12574
|
|
|
|
|
|
if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr)); |
12575
|
|
|
|
|
|
if (CvNAMED(dstr)) |
12576
|
|
|
|
|
|
SvANY((CV *)dstr)->xcv_gv_u.xcv_hek = |
12577
|
|
|
|
|
|
share_hek_hek(CvNAME_HEK((CV *)sstr)); |
12578
|
|
|
|
|
|
/* don't dup if copying back - CvGV isn't refcounted, so the |
12579
|
|
|
|
|
|
* duped GV may never be freed. A bit of a hack! DAPM */ |
12580
|
|
|
|
|
|
else |
12581
|
|
|
|
|
|
SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv = |
12582
|
|
|
|
|
|
CvCVGV_RC(dstr) |
12583
|
|
|
|
|
|
? gv_dup_inc(CvGV(sstr), param) |
12584
|
|
|
|
|
|
: (param->flags & CLONEf_JOIN_IN) |
12585
|
|
|
|
|
|
? NULL |
12586
|
|
|
|
|
|
: gv_dup(CvGV(sstr), param); |
12587
|
|
|
|
|
|
|
12588
|
|
|
|
|
|
CvPADLIST(dstr) = padlist_dup(CvPADLIST(sstr), param); |
12589
|
|
|
|
|
|
CvOUTSIDE(dstr) = |
12590
|
|
|
|
|
|
CvWEAKOUTSIDE(sstr) |
12591
|
|
|
|
|
|
? cv_dup( CvOUTSIDE(dstr), param) |
12592
|
|
|
|
|
|
: cv_dup_inc(CvOUTSIDE(dstr), param); |
12593
|
|
|
|
|
|
break; |
12594
|
|
|
|
|
|
} |
12595
|
|
|
|
|
|
} |
12596
|
|
|
|
|
|
} |
12597
|
|
|
|
|
|
|
12598
|
|
|
|
|
|
return dstr; |
12599
|
|
|
|
|
|
} |
12600
|
|
|
|
|
|
|
12601
|
|
|
|
|
|
SV * |
12602
|
|
|
|
|
|
Perl_sv_dup_inc(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) |
12603
|
|
|
|
|
|
{ |
12604
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DUP_INC; |
12605
|
|
|
|
|
|
return sstr ? SvREFCNT_inc(sv_dup_common(sstr, param)) : NULL; |
12606
|
|
|
|
|
|
} |
12607
|
|
|
|
|
|
|
12608
|
|
|
|
|
|
SV * |
12609
|
|
|
|
|
|
Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) |
12610
|
|
|
|
|
|
{ |
12611
|
|
|
|
|
|
SV *dstr = sstr ? sv_dup_common(sstr, param) : NULL; |
12612
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_DUP; |
12613
|
|
|
|
|
|
|
12614
|
|
|
|
|
|
/* Track every SV that (at least initially) had a reference count of 0. |
12615
|
|
|
|
|
|
We need to do this by holding an actual reference to it in this array. |
12616
|
|
|
|
|
|
If we attempt to cheat, turn AvREAL_off(), and store only pointers |
12617
|
|
|
|
|
|
(akin to the stashes hash, and the perl stack), we come unstuck if |
12618
|
|
|
|
|
|
a weak reference (or other SV legitimately SvREFCNT() == 0 for this |
12619
|
|
|
|
|
|
thread) is manipulated in a CLONE method, because CLONE runs before the |
12620
|
|
|
|
|
|
unreferenced array is walked to find SVs still with SvREFCNT() == 0 |
12621
|
|
|
|
|
|
(and fix things up by giving each a reference via the temps stack). |
12622
|
|
|
|
|
|
Instead, during CLONE, if the 0-referenced SV has SvREFCNT_inc() and |
12623
|
|
|
|
|
|
then SvREFCNT_dec(), it will be cleaned up (and added to the free list) |
12624
|
|
|
|
|
|
before the walk of unreferenced happens and a reference to that is SV |
12625
|
|
|
|
|
|
added to the temps stack. At which point we have the same SV considered |
12626
|
|
|
|
|
|
to be in use, and free to be re-used. Not good. |
12627
|
|
|
|
|
|
*/ |
12628
|
|
|
|
|
|
if (dstr && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dstr)) { |
12629
|
|
|
|
|
|
assert(param->unreferenced); |
12630
|
|
|
|
|
|
av_push(param->unreferenced, SvREFCNT_inc(dstr)); |
12631
|
|
|
|
|
|
} |
12632
|
|
|
|
|
|
|
12633
|
|
|
|
|
|
return dstr; |
12634
|
|
|
|
|
|
} |
12635
|
|
|
|
|
|
|
12636
|
|
|
|
|
|
/* duplicate a context */ |
12637
|
|
|
|
|
|
|
12638
|
|
|
|
|
|
PERL_CONTEXT * |
12639
|
|
|
|
|
|
Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) |
12640
|
|
|
|
|
|
{ |
12641
|
|
|
|
|
|
PERL_CONTEXT *ncxs; |
12642
|
|
|
|
|
|
|
12643
|
|
|
|
|
|
PERL_ARGS_ASSERT_CX_DUP; |
12644
|
|
|
|
|
|
|
12645
|
|
|
|
|
|
if (!cxs) |
12646
|
|
|
|
|
|
return (PERL_CONTEXT*)NULL; |
12647
|
|
|
|
|
|
|
12648
|
|
|
|
|
|
/* look for it in the table first */ |
12649
|
|
|
|
|
|
ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); |
12650
|
|
|
|
|
|
if (ncxs) |
12651
|
|
|
|
|
|
return ncxs; |
12652
|
|
|
|
|
|
|
12653
|
|
|
|
|
|
/* create anew and remember what it is */ |
12654
|
|
|
|
|
|
Newx(ncxs, max + 1, PERL_CONTEXT); |
12655
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, cxs, ncxs); |
12656
|
|
|
|
|
|
Copy(cxs, ncxs, max + 1, PERL_CONTEXT); |
12657
|
|
|
|
|
|
|
12658
|
|
|
|
|
|
while (ix >= 0) { |
12659
|
|
|
|
|
|
PERL_CONTEXT * const ncx = &ncxs[ix]; |
12660
|
|
|
|
|
|
if (CxTYPE(ncx) == CXt_SUBST) { |
12661
|
|
|
|
|
|
Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); |
12662
|
|
|
|
|
|
} |
12663
|
|
|
|
|
|
else { |
12664
|
|
|
|
|
|
ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); |
12665
|
|
|
|
|
|
switch (CxTYPE(ncx)) { |
12666
|
|
|
|
|
|
case CXt_SUB: |
12667
|
|
|
|
|
|
ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 |
12668
|
|
|
|
|
|
? cv_dup_inc(ncx->blk_sub.cv, param) |
12669
|
|
|
|
|
|
: cv_dup(ncx->blk_sub.cv,param)); |
12670
|
|
|
|
|
|
ncx->blk_sub.argarray = (CxHASARGS(ncx) |
12671
|
|
|
|
|
|
? av_dup_inc(ncx->blk_sub.argarray, |
12672
|
|
|
|
|
|
param) |
12673
|
|
|
|
|
|
: NULL); |
12674
|
|
|
|
|
|
ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray, |
12675
|
|
|
|
|
|
param); |
12676
|
|
|
|
|
|
ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, |
12677
|
|
|
|
|
|
ncx->blk_sub.oldcomppad); |
12678
|
|
|
|
|
|
break; |
12679
|
|
|
|
|
|
case CXt_EVAL: |
12680
|
|
|
|
|
|
ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, |
12681
|
|
|
|
|
|
param); |
12682
|
|
|
|
|
|
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); |
12683
|
|
|
|
|
|
ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param); |
12684
|
|
|
|
|
|
break; |
12685
|
|
|
|
|
|
case CXt_LOOP_LAZYSV: |
12686
|
|
|
|
|
|
ncx->blk_loop.state_u.lazysv.end |
12687
|
|
|
|
|
|
= sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); |
12688
|
|
|
|
|
|
/* We are taking advantage of av_dup_inc and sv_dup_inc |
12689
|
|
|
|
|
|
actually being the same function, and order equivalence of |
12690
|
|
|
|
|
|
the two unions. |
12691
|
|
|
|
|
|
We can assert the later [but only at run time :-(] */ |
12692
|
|
|
|
|
|
assert ((void *) &ncx->blk_loop.state_u.ary.ary == |
12693
|
|
|
|
|
|
(void *) &ncx->blk_loop.state_u.lazysv.cur); |
12694
|
|
|
|
|
|
case CXt_LOOP_FOR: |
12695
|
|
|
|
|
|
ncx->blk_loop.state_u.ary.ary |
12696
|
|
|
|
|
|
= av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); |
12697
|
|
|
|
|
|
case CXt_LOOP_LAZYIV: |
12698
|
|
|
|
|
|
case CXt_LOOP_PLAIN: |
12699
|
|
|
|
|
|
if (CxPADLOOP(ncx)) { |
12700
|
|
|
|
|
|
ncx->blk_loop.itervar_u.oldcomppad |
12701
|
|
|
|
|
|
= (PAD*)ptr_table_fetch(PL_ptr_table, |
12702
|
|
|
|
|
|
ncx->blk_loop.itervar_u.oldcomppad); |
12703
|
|
|
|
|
|
} else { |
12704
|
|
|
|
|
|
ncx->blk_loop.itervar_u.gv |
12705
|
|
|
|
|
|
= gv_dup((const GV *)ncx->blk_loop.itervar_u.gv, |
12706
|
|
|
|
|
|
param); |
12707
|
|
|
|
|
|
} |
12708
|
|
|
|
|
|
break; |
12709
|
|
|
|
|
|
case CXt_FORMAT: |
12710
|
|
|
|
|
|
ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param); |
12711
|
|
|
|
|
|
ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); |
12712
|
|
|
|
|
|
ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, |
12713
|
|
|
|
|
|
param); |
12714
|
|
|
|
|
|
break; |
12715
|
|
|
|
|
|
case CXt_BLOCK: |
12716
|
|
|
|
|
|
case CXt_NULL: |
12717
|
|
|
|
|
|
case CXt_WHEN: |
12718
|
|
|
|
|
|
case CXt_GIVEN: |
12719
|
|
|
|
|
|
break; |
12720
|
|
|
|
|
|
} |
12721
|
|
|
|
|
|
} |
12722
|
|
|
|
|
|
--ix; |
12723
|
|
|
|
|
|
} |
12724
|
|
|
|
|
|
return ncxs; |
12725
|
|
|
|
|
|
} |
12726
|
|
|
|
|
|
|
12727
|
|
|
|
|
|
/* duplicate a stack info structure */ |
12728
|
|
|
|
|
|
|
12729
|
|
|
|
|
|
PERL_SI * |
12730
|
|
|
|
|
|
Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) |
12731
|
|
|
|
|
|
{ |
12732
|
|
|
|
|
|
PERL_SI *nsi; |
12733
|
|
|
|
|
|
|
12734
|
|
|
|
|
|
PERL_ARGS_ASSERT_SI_DUP; |
12735
|
|
|
|
|
|
|
12736
|
|
|
|
|
|
if (!si) |
12737
|
|
|
|
|
|
return (PERL_SI*)NULL; |
12738
|
|
|
|
|
|
|
12739
|
|
|
|
|
|
/* look for it in the table first */ |
12740
|
|
|
|
|
|
nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); |
12741
|
|
|
|
|
|
if (nsi) |
12742
|
|
|
|
|
|
return nsi; |
12743
|
|
|
|
|
|
|
12744
|
|
|
|
|
|
/* create anew and remember what it is */ |
12745
|
|
|
|
|
|
Newxz(nsi, 1, PERL_SI); |
12746
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, si, nsi); |
12747
|
|
|
|
|
|
|
12748
|
|
|
|
|
|
nsi->si_stack = av_dup_inc(si->si_stack, param); |
12749
|
|
|
|
|
|
nsi->si_cxix = si->si_cxix; |
12750
|
|
|
|
|
|
nsi->si_cxmax = si->si_cxmax; |
12751
|
|
|
|
|
|
nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); |
12752
|
|
|
|
|
|
nsi->si_type = si->si_type; |
12753
|
|
|
|
|
|
nsi->si_prev = si_dup(si->si_prev, param); |
12754
|
|
|
|
|
|
nsi->si_next = si_dup(si->si_next, param); |
12755
|
|
|
|
|
|
nsi->si_markoff = si->si_markoff; |
12756
|
|
|
|
|
|
|
12757
|
|
|
|
|
|
return nsi; |
12758
|
|
|
|
|
|
} |
12759
|
|
|
|
|
|
|
12760
|
|
|
|
|
|
#define POPINT(ss,ix) ((ss)[--(ix)].any_i32) |
12761
|
|
|
|
|
|
#define TOPINT(ss,ix) ((ss)[ix].any_i32) |
12762
|
|
|
|
|
|
#define POPLONG(ss,ix) ((ss)[--(ix)].any_long) |
12763
|
|
|
|
|
|
#define TOPLONG(ss,ix) ((ss)[ix].any_long) |
12764
|
|
|
|
|
|
#define POPIV(ss,ix) ((ss)[--(ix)].any_iv) |
12765
|
|
|
|
|
|
#define TOPIV(ss,ix) ((ss)[ix].any_iv) |
12766
|
|
|
|
|
|
#define POPUV(ss,ix) ((ss)[--(ix)].any_uv) |
12767
|
|
|
|
|
|
#define TOPUV(ss,ix) ((ss)[ix].any_uv) |
12768
|
|
|
|
|
|
#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool) |
12769
|
|
|
|
|
|
#define TOPBOOL(ss,ix) ((ss)[ix].any_bool) |
12770
|
|
|
|
|
|
#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) |
12771
|
|
|
|
|
|
#define TOPPTR(ss,ix) ((ss)[ix].any_ptr) |
12772
|
|
|
|
|
|
#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) |
12773
|
|
|
|
|
|
#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) |
12774
|
|
|
|
|
|
#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) |
12775
|
|
|
|
|
|
#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) |
12776
|
|
|
|
|
|
|
12777
|
|
|
|
|
|
/* XXXXX todo */ |
12778
|
|
|
|
|
|
#define pv_dup_inc(p) SAVEPV(p) |
12779
|
|
|
|
|
|
#define pv_dup(p) SAVEPV(p) |
12780
|
|
|
|
|
|
#define svp_dup_inc(p,pp) any_dup(p,pp) |
12781
|
|
|
|
|
|
|
12782
|
|
|
|
|
|
/* map any object to the new equivent - either something in the |
12783
|
|
|
|
|
|
* ptr table, or something in the interpreter structure |
12784
|
|
|
|
|
|
*/ |
12785
|
|
|
|
|
|
|
12786
|
|
|
|
|
|
void * |
12787
|
|
|
|
|
|
Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) |
12788
|
|
|
|
|
|
{ |
12789
|
|
|
|
|
|
void *ret; |
12790
|
|
|
|
|
|
|
12791
|
|
|
|
|
|
PERL_ARGS_ASSERT_ANY_DUP; |
12792
|
|
|
|
|
|
|
12793
|
|
|
|
|
|
if (!v) |
12794
|
|
|
|
|
|
return (void*)NULL; |
12795
|
|
|
|
|
|
|
12796
|
|
|
|
|
|
/* look for it in the table first */ |
12797
|
|
|
|
|
|
ret = ptr_table_fetch(PL_ptr_table, v); |
12798
|
|
|
|
|
|
if (ret) |
12799
|
|
|
|
|
|
return ret; |
12800
|
|
|
|
|
|
|
12801
|
|
|
|
|
|
/* see if it is part of the interpreter structure */ |
12802
|
|
|
|
|
|
if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) |
12803
|
|
|
|
|
|
ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); |
12804
|
|
|
|
|
|
else { |
12805
|
|
|
|
|
|
ret = v; |
12806
|
|
|
|
|
|
} |
12807
|
|
|
|
|
|
|
12808
|
|
|
|
|
|
return ret; |
12809
|
|
|
|
|
|
} |
12810
|
|
|
|
|
|
|
12811
|
|
|
|
|
|
/* duplicate the save stack */ |
12812
|
|
|
|
|
|
|
12813
|
|
|
|
|
|
ANY * |
12814
|
|
|
|
|
|
Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) |
12815
|
|
|
|
|
|
{ |
12816
|
|
|
|
|
|
dVAR; |
12817
|
|
|
|
|
|
ANY * const ss = proto_perl->Isavestack; |
12818
|
|
|
|
|
|
const I32 max = proto_perl->Isavestack_max; |
12819
|
|
|
|
|
|
I32 ix = proto_perl->Isavestack_ix; |
12820
|
|
|
|
|
|
ANY *nss; |
12821
|
|
|
|
|
|
const SV *sv; |
12822
|
|
|
|
|
|
const GV *gv; |
12823
|
|
|
|
|
|
const AV *av; |
12824
|
|
|
|
|
|
const HV *hv; |
12825
|
|
|
|
|
|
void* ptr; |
12826
|
|
|
|
|
|
int intval; |
12827
|
|
|
|
|
|
long longval; |
12828
|
|
|
|
|
|
GP *gp; |
12829
|
|
|
|
|
|
IV iv; |
12830
|
|
|
|
|
|
I32 i; |
12831
|
|
|
|
|
|
char *c = NULL; |
12832
|
|
|
|
|
|
void (*dptr) (void*); |
12833
|
|
|
|
|
|
void (*dxptr) (pTHX_ void*); |
12834
|
|
|
|
|
|
|
12835
|
|
|
|
|
|
PERL_ARGS_ASSERT_SS_DUP; |
12836
|
|
|
|
|
|
|
12837
|
|
|
|
|
|
Newxz(nss, max, ANY); |
12838
|
|
|
|
|
|
|
12839
|
|
|
|
|
|
while (ix > 0) { |
12840
|
|
|
|
|
|
const UV uv = POPUV(ss,ix); |
12841
|
|
|
|
|
|
const U8 type = (U8)uv & SAVE_MASK; |
12842
|
|
|
|
|
|
|
12843
|
|
|
|
|
|
TOPUV(nss,ix) = uv; |
12844
|
|
|
|
|
|
switch (type) { |
12845
|
|
|
|
|
|
case SAVEt_CLEARSV: |
12846
|
|
|
|
|
|
case SAVEt_CLEARPADRANGE: |
12847
|
|
|
|
|
|
break; |
12848
|
|
|
|
|
|
case SAVEt_HELEM: /* hash element */ |
12849
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12850
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12851
|
|
|
|
|
|
/* fall through */ |
12852
|
|
|
|
|
|
case SAVEt_ITEM: /* normal string */ |
12853
|
|
|
|
|
|
case SAVEt_GVSV: /* scalar slot in GV */ |
12854
|
|
|
|
|
|
case SAVEt_SV: /* scalar reference */ |
12855
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12856
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12857
|
|
|
|
|
|
/* fall through */ |
12858
|
|
|
|
|
|
case SAVEt_FREESV: |
12859
|
|
|
|
|
|
case SAVEt_MORTALIZESV: |
12860
|
|
|
|
|
|
case SAVEt_READONLY_OFF: |
12861
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12862
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12863
|
|
|
|
|
|
break; |
12864
|
|
|
|
|
|
case SAVEt_SHARED_PVREF: /* char* in shared space */ |
12865
|
|
|
|
|
|
c = (char*)POPPTR(ss,ix); |
12866
|
|
|
|
|
|
TOPPTR(nss,ix) = savesharedpv(c); |
12867
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12868
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12869
|
|
|
|
|
|
break; |
12870
|
|
|
|
|
|
case SAVEt_GENERIC_SVREF: /* generic sv */ |
12871
|
|
|
|
|
|
case SAVEt_SVREF: /* scalar reference */ |
12872
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12873
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12874
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12875
|
|
|
|
|
|
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ |
12876
|
|
|
|
|
|
break; |
12877
|
|
|
|
|
|
case SAVEt_GVSLOT: /* any slot in GV */ |
12878
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12879
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12880
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12881
|
|
|
|
|
|
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ |
12882
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12883
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12884
|
|
|
|
|
|
break; |
12885
|
|
|
|
|
|
case SAVEt_HV: /* hash reference */ |
12886
|
|
|
|
|
|
case SAVEt_AV: /* array reference */ |
12887
|
|
|
|
|
|
sv = (const SV *) POPPTR(ss,ix); |
12888
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
12889
|
|
|
|
|
|
/* fall through */ |
12890
|
|
|
|
|
|
case SAVEt_COMPPAD: |
12891
|
|
|
|
|
|
case SAVEt_NSTAB: |
12892
|
|
|
|
|
|
sv = (const SV *) POPPTR(ss,ix); |
12893
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup(sv, param); |
12894
|
|
|
|
|
|
break; |
12895
|
|
|
|
|
|
case SAVEt_INT: /* int reference */ |
12896
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12897
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12898
|
|
|
|
|
|
intval = (int)POPINT(ss,ix); |
12899
|
|
|
|
|
|
TOPINT(nss,ix) = intval; |
12900
|
|
|
|
|
|
break; |
12901
|
|
|
|
|
|
case SAVEt_LONG: /* long reference */ |
12902
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12903
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12904
|
|
|
|
|
|
longval = (long)POPLONG(ss,ix); |
12905
|
|
|
|
|
|
TOPLONG(nss,ix) = longval; |
12906
|
|
|
|
|
|
break; |
12907
|
|
|
|
|
|
case SAVEt_I32: /* I32 reference */ |
12908
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12909
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12910
|
|
|
|
|
|
i = POPINT(ss,ix); |
12911
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
12912
|
|
|
|
|
|
break; |
12913
|
|
|
|
|
|
case SAVEt_IV: /* IV reference */ |
12914
|
|
|
|
|
|
case SAVEt_STRLEN: /* STRLEN/size_t ref */ |
12915
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12916
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12917
|
|
|
|
|
|
iv = POPIV(ss,ix); |
12918
|
|
|
|
|
|
TOPIV(nss,ix) = iv; |
12919
|
|
|
|
|
|
break; |
12920
|
|
|
|
|
|
case SAVEt_HPTR: /* HV* reference */ |
12921
|
|
|
|
|
|
case SAVEt_APTR: /* AV* reference */ |
12922
|
|
|
|
|
|
case SAVEt_SPTR: /* SV* reference */ |
12923
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12924
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12925
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
12926
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup(sv, param); |
12927
|
|
|
|
|
|
break; |
12928
|
|
|
|
|
|
case SAVEt_VPTR: /* random* reference */ |
12929
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12930
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12931
|
|
|
|
|
|
/* Fall through */ |
12932
|
|
|
|
|
|
case SAVEt_INT_SMALL: |
12933
|
|
|
|
|
|
case SAVEt_I32_SMALL: |
12934
|
|
|
|
|
|
case SAVEt_I16: /* I16 reference */ |
12935
|
|
|
|
|
|
case SAVEt_I8: /* I8 reference */ |
12936
|
|
|
|
|
|
case SAVEt_BOOL: |
12937
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12938
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12939
|
|
|
|
|
|
break; |
12940
|
|
|
|
|
|
case SAVEt_GENERIC_PVREF: /* generic char* */ |
12941
|
|
|
|
|
|
case SAVEt_PPTR: /* char* reference */ |
12942
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12943
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
12944
|
|
|
|
|
|
c = (char*)POPPTR(ss,ix); |
12945
|
|
|
|
|
|
TOPPTR(nss,ix) = pv_dup(c); |
12946
|
|
|
|
|
|
break; |
12947
|
|
|
|
|
|
case SAVEt_GP: /* scalar reference */ |
12948
|
|
|
|
|
|
gp = (GP*)POPPTR(ss,ix); |
12949
|
|
|
|
|
|
TOPPTR(nss,ix) = gp = gp_dup(gp, param); |
12950
|
|
|
|
|
|
(void)GpREFCNT_inc(gp); |
12951
|
|
|
|
|
|
gv = (const GV *)POPPTR(ss,ix); |
12952
|
|
|
|
|
|
TOPPTR(nss,ix) = gv_dup_inc(gv, param); |
12953
|
|
|
|
|
|
break; |
12954
|
|
|
|
|
|
case SAVEt_FREEOP: |
12955
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12956
|
|
|
|
|
|
if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { |
12957
|
|
|
|
|
|
/* these are assumed to be refcounted properly */ |
12958
|
|
|
|
|
|
OP *o; |
12959
|
|
|
|
|
|
switch (((OP*)ptr)->op_type) { |
12960
|
|
|
|
|
|
case OP_LEAVESUB: |
12961
|
|
|
|
|
|
case OP_LEAVESUBLV: |
12962
|
|
|
|
|
|
case OP_LEAVEEVAL: |
12963
|
|
|
|
|
|
case OP_LEAVE: |
12964
|
|
|
|
|
|
case OP_SCOPE: |
12965
|
|
|
|
|
|
case OP_LEAVEWRITE: |
12966
|
|
|
|
|
|
TOPPTR(nss,ix) = ptr; |
12967
|
|
|
|
|
|
o = (OP*)ptr; |
12968
|
|
|
|
|
|
OP_REFCNT_LOCK; |
12969
|
|
|
|
|
|
(void) OpREFCNT_inc(o); |
12970
|
|
|
|
|
|
OP_REFCNT_UNLOCK; |
12971
|
|
|
|
|
|
break; |
12972
|
|
|
|
|
|
default: |
12973
|
|
|
|
|
|
TOPPTR(nss,ix) = NULL; |
12974
|
|
|
|
|
|
break; |
12975
|
|
|
|
|
|
} |
12976
|
|
|
|
|
|
} |
12977
|
|
|
|
|
|
else |
12978
|
|
|
|
|
|
TOPPTR(nss,ix) = NULL; |
12979
|
|
|
|
|
|
break; |
12980
|
|
|
|
|
|
case SAVEt_FREECOPHH: |
12981
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
12982
|
|
|
|
|
|
TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr); |
12983
|
|
|
|
|
|
break; |
12984
|
|
|
|
|
|
case SAVEt_ADELETE: |
12985
|
|
|
|
|
|
av = (const AV *)POPPTR(ss,ix); |
12986
|
|
|
|
|
|
TOPPTR(nss,ix) = av_dup_inc(av, param); |
12987
|
|
|
|
|
|
i = POPINT(ss,ix); |
12988
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
12989
|
|
|
|
|
|
break; |
12990
|
|
|
|
|
|
case SAVEt_DELETE: |
12991
|
|
|
|
|
|
hv = (const HV *)POPPTR(ss,ix); |
12992
|
|
|
|
|
|
TOPPTR(nss,ix) = hv_dup_inc(hv, param); |
12993
|
|
|
|
|
|
i = POPINT(ss,ix); |
12994
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
12995
|
|
|
|
|
|
/* Fall through */ |
12996
|
|
|
|
|
|
case SAVEt_FREEPV: |
12997
|
|
|
|
|
|
c = (char*)POPPTR(ss,ix); |
12998
|
|
|
|
|
|
TOPPTR(nss,ix) = pv_dup_inc(c); |
12999
|
|
|
|
|
|
break; |
13000
|
|
|
|
|
|
case SAVEt_STACK_POS: /* Position on Perl stack */ |
13001
|
|
|
|
|
|
i = POPINT(ss,ix); |
13002
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
13003
|
|
|
|
|
|
break; |
13004
|
|
|
|
|
|
case SAVEt_DESTRUCTOR: |
13005
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13006
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ |
13007
|
|
|
|
|
|
dptr = POPDPTR(ss,ix); |
13008
|
|
|
|
|
|
TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), |
13009
|
|
|
|
|
|
any_dup(FPTR2DPTR(void *, dptr), |
13010
|
|
|
|
|
|
proto_perl)); |
13011
|
|
|
|
|
|
break; |
13012
|
|
|
|
|
|
case SAVEt_DESTRUCTOR_X: |
13013
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13014
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ |
13015
|
|
|
|
|
|
dxptr = POPDXPTR(ss,ix); |
13016
|
|
|
|
|
|
TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), |
13017
|
|
|
|
|
|
any_dup(FPTR2DPTR(void *, dxptr), |
13018
|
|
|
|
|
|
proto_perl)); |
13019
|
|
|
|
|
|
break; |
13020
|
|
|
|
|
|
case SAVEt_REGCONTEXT: |
13021
|
|
|
|
|
|
case SAVEt_ALLOC: |
13022
|
|
|
|
|
|
ix -= uv >> SAVE_TIGHT_SHIFT; |
13023
|
|
|
|
|
|
break; |
13024
|
|
|
|
|
|
case SAVEt_AELEM: /* array element */ |
13025
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
13026
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
13027
|
|
|
|
|
|
i = POPINT(ss,ix); |
13028
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
13029
|
|
|
|
|
|
av = (const AV *)POPPTR(ss,ix); |
13030
|
|
|
|
|
|
TOPPTR(nss,ix) = av_dup_inc(av, param); |
13031
|
|
|
|
|
|
break; |
13032
|
|
|
|
|
|
case SAVEt_OP: |
13033
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13034
|
|
|
|
|
|
TOPPTR(nss,ix) = ptr; |
13035
|
|
|
|
|
|
break; |
13036
|
|
|
|
|
|
case SAVEt_HINTS: |
13037
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13038
|
|
|
|
|
|
ptr = cophh_copy((COPHH*)ptr); |
13039
|
|
|
|
|
|
TOPPTR(nss,ix) = ptr; |
13040
|
|
|
|
|
|
i = POPINT(ss,ix); |
13041
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
13042
|
|
|
|
|
|
if (i & HINT_LOCALIZE_HH) { |
13043
|
|
|
|
|
|
hv = (const HV *)POPPTR(ss,ix); |
13044
|
|
|
|
|
|
TOPPTR(nss,ix) = hv_dup_inc(hv, param); |
13045
|
|
|
|
|
|
} |
13046
|
|
|
|
|
|
break; |
13047
|
|
|
|
|
|
case SAVEt_PADSV_AND_MORTALIZE: |
13048
|
|
|
|
|
|
longval = (long)POPLONG(ss,ix); |
13049
|
|
|
|
|
|
TOPLONG(nss,ix) = longval; |
13050
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13051
|
|
|
|
|
|
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); |
13052
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
13053
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup_inc(sv, param); |
13054
|
|
|
|
|
|
break; |
13055
|
|
|
|
|
|
case SAVEt_SET_SVFLAGS: |
13056
|
|
|
|
|
|
i = POPINT(ss,ix); |
13057
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
13058
|
|
|
|
|
|
i = POPINT(ss,ix); |
13059
|
|
|
|
|
|
TOPINT(nss,ix) = i; |
13060
|
|
|
|
|
|
sv = (const SV *)POPPTR(ss,ix); |
13061
|
|
|
|
|
|
TOPPTR(nss,ix) = sv_dup(sv, param); |
13062
|
|
|
|
|
|
break; |
13063
|
|
|
|
|
|
case SAVEt_COMPILE_WARNINGS: |
13064
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13065
|
|
|
|
|
|
TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); |
13066
|
|
|
|
|
|
break; |
13067
|
|
|
|
|
|
case SAVEt_PARSER: |
13068
|
|
|
|
|
|
ptr = POPPTR(ss,ix); |
13069
|
|
|
|
|
|
TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); |
13070
|
|
|
|
|
|
break; |
13071
|
|
|
|
|
|
default: |
13072
|
|
|
|
|
|
Perl_croak(aTHX_ |
13073
|
|
|
|
|
|
"panic: ss_dup inconsistency (%"IVdf")", (IV) type); |
13074
|
|
|
|
|
|
} |
13075
|
|
|
|
|
|
} |
13076
|
|
|
|
|
|
|
13077
|
|
|
|
|
|
return nss; |
13078
|
|
|
|
|
|
} |
13079
|
|
|
|
|
|
|
13080
|
|
|
|
|
|
|
13081
|
|
|
|
|
|
/* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE |
13082
|
|
|
|
|
|
* flag to the result. This is done for each stash before cloning starts, |
13083
|
|
|
|
|
|
* so we know which stashes want their objects cloned */ |
13084
|
|
|
|
|
|
|
13085
|
|
|
|
|
|
static void |
13086
|
|
|
|
|
|
do_mark_cloneable_stash(pTHX_ SV *const sv) |
13087
|
|
|
|
|
|
{ |
13088
|
|
|
|
|
|
const HEK * const hvname = HvNAME_HEK((const HV *)sv); |
13089
|
|
|
|
|
|
if (hvname) { |
13090
|
|
|
|
|
|
GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); |
13091
|
|
|
|
|
|
SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ |
13092
|
|
|
|
|
|
if (cloner && GvCV(cloner)) { |
13093
|
|
|
|
|
|
dSP; |
13094
|
|
|
|
|
|
UV status; |
13095
|
|
|
|
|
|
|
13096
|
|
|
|
|
|
ENTER; |
13097
|
|
|
|
|
|
SAVETMPS; |
13098
|
|
|
|
|
|
PUSHMARK(SP); |
13099
|
|
|
|
|
|
mXPUSHs(newSVhek(hvname)); |
13100
|
|
|
|
|
|
PUTBACK; |
13101
|
|
|
|
|
|
call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); |
13102
|
|
|
|
|
|
SPAGAIN; |
13103
|
|
|
|
|
|
status = POPu; |
13104
|
|
|
|
|
|
PUTBACK; |
13105
|
|
|
|
|
|
FREETMPS; |
13106
|
|
|
|
|
|
LEAVE; |
13107
|
|
|
|
|
|
if (status) |
13108
|
|
|
|
|
|
SvFLAGS(sv) &= ~SVphv_CLONEABLE; |
13109
|
|
|
|
|
|
} |
13110
|
|
|
|
|
|
} |
13111
|
|
|
|
|
|
} |
13112
|
|
|
|
|
|
|
13113
|
|
|
|
|
|
|
13114
|
|
|
|
|
|
|
13115
|
|
|
|
|
|
/* |
13116
|
|
|
|
|
|
=for apidoc perl_clone |
13117
|
|
|
|
|
|
|
13118
|
|
|
|
|
|
Create and return a new interpreter by cloning the current one. |
13119
|
|
|
|
|
|
|
13120
|
|
|
|
|
|
perl_clone takes these flags as parameters: |
13121
|
|
|
|
|
|
|
13122
|
|
|
|
|
|
CLONEf_COPY_STACKS - is used to, well, copy the stacks also, |
13123
|
|
|
|
|
|
without it we only clone the data and zero the stacks, |
13124
|
|
|
|
|
|
with it we copy the stacks and the new perl interpreter is |
13125
|
|
|
|
|
|
ready to run at the exact same point as the previous one. |
13126
|
|
|
|
|
|
The pseudo-fork code uses COPY_STACKS while the |
13127
|
|
|
|
|
|
threads->create doesn't. |
13128
|
|
|
|
|
|
|
13129
|
|
|
|
|
|
CLONEf_KEEP_PTR_TABLE - |
13130
|
|
|
|
|
|
perl_clone keeps a ptr_table with the pointer of the old |
13131
|
|
|
|
|
|
variable as a key and the new variable as a value, |
13132
|
|
|
|
|
|
this allows it to check if something has been cloned and not |
13133
|
|
|
|
|
|
clone it again but rather just use the value and increase the |
13134
|
|
|
|
|
|
refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill |
13135
|
|
|
|
|
|
the ptr_table using the function |
13136
|
|
|
|
|
|
C, |
13137
|
|
|
|
|
|
reason to keep it around is if you want to dup some of your own |
13138
|
|
|
|
|
|
variable who are outside the graph perl scans, example of this |
13139
|
|
|
|
|
|
code is in threads.xs create. |
13140
|
|
|
|
|
|
|
13141
|
|
|
|
|
|
CLONEf_CLONE_HOST - |
13142
|
|
|
|
|
|
This is a win32 thing, it is ignored on unix, it tells perls |
13143
|
|
|
|
|
|
win32host code (which is c++) to clone itself, this is needed on |
13144
|
|
|
|
|
|
win32 if you want to run two threads at the same time, |
13145
|
|
|
|
|
|
if you just want to do some stuff in a separate perl interpreter |
13146
|
|
|
|
|
|
and then throw it away and return to the original one, |
13147
|
|
|
|
|
|
you don't need to do anything. |
13148
|
|
|
|
|
|
|
13149
|
|
|
|
|
|
=cut |
13150
|
|
|
|
|
|
*/ |
13151
|
|
|
|
|
|
|
13152
|
|
|
|
|
|
/* XXX the above needs expanding by someone who actually understands it ! */ |
13153
|
|
|
|
|
|
EXTERN_C PerlInterpreter * |
13154
|
|
|
|
|
|
perl_clone_host(PerlInterpreter* proto_perl, UV flags); |
13155
|
|
|
|
|
|
|
13156
|
|
|
|
|
|
PerlInterpreter * |
13157
|
|
|
|
|
|
perl_clone(PerlInterpreter *proto_perl, UV flags) |
13158
|
|
|
|
|
|
{ |
13159
|
|
|
|
|
|
dVAR; |
13160
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_SYS |
13161
|
|
|
|
|
|
|
13162
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_CLONE; |
13163
|
|
|
|
|
|
|
13164
|
|
|
|
|
|
/* perlhost.h so we need to call into it |
13165
|
|
|
|
|
|
to clone the host, CPerlHost should have a c interface, sky */ |
13166
|
|
|
|
|
|
|
13167
|
|
|
|
|
|
if (flags & CLONEf_CLONE_HOST) { |
13168
|
|
|
|
|
|
return perl_clone_host(proto_perl,flags); |
13169
|
|
|
|
|
|
} |
13170
|
|
|
|
|
|
return perl_clone_using(proto_perl, flags, |
13171
|
|
|
|
|
|
proto_perl->IMem, |
13172
|
|
|
|
|
|
proto_perl->IMemShared, |
13173
|
|
|
|
|
|
proto_perl->IMemParse, |
13174
|
|
|
|
|
|
proto_perl->IEnv, |
13175
|
|
|
|
|
|
proto_perl->IStdIO, |
13176
|
|
|
|
|
|
proto_perl->ILIO, |
13177
|
|
|
|
|
|
proto_perl->IDir, |
13178
|
|
|
|
|
|
proto_perl->ISock, |
13179
|
|
|
|
|
|
proto_perl->IProc); |
13180
|
|
|
|
|
|
} |
13181
|
|
|
|
|
|
|
13182
|
|
|
|
|
|
PerlInterpreter * |
13183
|
|
|
|
|
|
perl_clone_using(PerlInterpreter *proto_perl, UV flags, |
13184
|
|
|
|
|
|
struct IPerlMem* ipM, struct IPerlMem* ipMS, |
13185
|
|
|
|
|
|
struct IPerlMem* ipMP, struct IPerlEnv* ipE, |
13186
|
|
|
|
|
|
struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, |
13187
|
|
|
|
|
|
struct IPerlDir* ipD, struct IPerlSock* ipS, |
13188
|
|
|
|
|
|
struct IPerlProc* ipP) |
13189
|
|
|
|
|
|
{ |
13190
|
|
|
|
|
|
/* XXX many of the string copies here can be optimized if they're |
13191
|
|
|
|
|
|
* constants; they need to be allocated as common memory and just |
13192
|
|
|
|
|
|
* their pointers copied. */ |
13193
|
|
|
|
|
|
|
13194
|
|
|
|
|
|
IV i; |
13195
|
|
|
|
|
|
CLONE_PARAMS clone_params; |
13196
|
|
|
|
|
|
CLONE_PARAMS* const param = &clone_params; |
13197
|
|
|
|
|
|
|
13198
|
|
|
|
|
|
PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); |
13199
|
|
|
|
|
|
|
13200
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_CLONE_USING; |
13201
|
|
|
|
|
|
#else /* !PERL_IMPLICIT_SYS */ |
13202
|
|
|
|
|
|
IV i; |
13203
|
|
|
|
|
|
CLONE_PARAMS clone_params; |
13204
|
|
|
|
|
|
CLONE_PARAMS* param = &clone_params; |
13205
|
|
|
|
|
|
PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); |
13206
|
|
|
|
|
|
|
13207
|
|
|
|
|
|
PERL_ARGS_ASSERT_PERL_CLONE; |
13208
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_SYS */ |
13209
|
|
|
|
|
|
|
13210
|
|
|
|
|
|
/* for each stash, determine whether its objects should be cloned */ |
13211
|
|
|
|
|
|
S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); |
13212
|
|
|
|
|
|
PERL_SET_THX(my_perl); |
13213
|
|
|
|
|
|
|
13214
|
|
|
|
|
|
#ifdef DEBUGGING |
13215
|
|
|
|
|
|
PoisonNew(my_perl, 1, PerlInterpreter); |
13216
|
|
|
|
|
|
PL_op = NULL; |
13217
|
|
|
|
|
|
PL_curcop = NULL; |
13218
|
|
|
|
|
|
PL_defstash = NULL; /* may be used by perl malloc() */ |
13219
|
|
|
|
|
|
PL_markstack = 0; |
13220
|
|
|
|
|
|
PL_scopestack = 0; |
13221
|
|
|
|
|
|
PL_scopestack_name = 0; |
13222
|
|
|
|
|
|
PL_savestack = 0; |
13223
|
|
|
|
|
|
PL_savestack_ix = 0; |
13224
|
|
|
|
|
|
PL_savestack_max = -1; |
13225
|
|
|
|
|
|
PL_sig_pending = 0; |
13226
|
|
|
|
|
|
PL_parser = NULL; |
13227
|
|
|
|
|
|
Zero(&PL_debug_pad, 1, struct perl_debug_pad); |
13228
|
|
|
|
|
|
# ifdef DEBUG_LEAKING_SCALARS |
13229
|
|
|
|
|
|
PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000; |
13230
|
|
|
|
|
|
# endif |
13231
|
|
|
|
|
|
#else /* !DEBUGGING */ |
13232
|
|
|
|
|
|
Zero(my_perl, 1, PerlInterpreter); |
13233
|
|
|
|
|
|
#endif /* DEBUGGING */ |
13234
|
|
|
|
|
|
|
13235
|
|
|
|
|
|
#ifdef PERL_IMPLICIT_SYS |
13236
|
|
|
|
|
|
/* host pointers */ |
13237
|
|
|
|
|
|
PL_Mem = ipM; |
13238
|
|
|
|
|
|
PL_MemShared = ipMS; |
13239
|
|
|
|
|
|
PL_MemParse = ipMP; |
13240
|
|
|
|
|
|
PL_Env = ipE; |
13241
|
|
|
|
|
|
PL_StdIO = ipStd; |
13242
|
|
|
|
|
|
PL_LIO = ipLIO; |
13243
|
|
|
|
|
|
PL_Dir = ipD; |
13244
|
|
|
|
|
|
PL_Sock = ipS; |
13245
|
|
|
|
|
|
PL_Proc = ipP; |
13246
|
|
|
|
|
|
#endif /* PERL_IMPLICIT_SYS */ |
13247
|
|
|
|
|
|
|
13248
|
|
|
|
|
|
|
13249
|
|
|
|
|
|
param->flags = flags; |
13250
|
|
|
|
|
|
/* Nothing in the core code uses this, but we make it available to |
13251
|
|
|
|
|
|
extensions (using mg_dup). */ |
13252
|
|
|
|
|
|
param->proto_perl = proto_perl; |
13253
|
|
|
|
|
|
/* Likely nothing will use this, but it is initialised to be consistent |
13254
|
|
|
|
|
|
with Perl_clone_params_new(). */ |
13255
|
|
|
|
|
|
param->new_perl = my_perl; |
13256
|
|
|
|
|
|
param->unreferenced = NULL; |
13257
|
|
|
|
|
|
|
13258
|
|
|
|
|
|
|
13259
|
|
|
|
|
|
INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl); |
13260
|
|
|
|
|
|
|
13261
|
|
|
|
|
|
PL_body_arenas = NULL; |
13262
|
|
|
|
|
|
Zero(&PL_body_roots, 1, PL_body_roots); |
13263
|
|
|
|
|
|
|
13264
|
|
|
|
|
|
PL_sv_count = 0; |
13265
|
|
|
|
|
|
PL_sv_root = NULL; |
13266
|
|
|
|
|
|
PL_sv_arenaroot = NULL; |
13267
|
|
|
|
|
|
|
13268
|
|
|
|
|
|
PL_debug = proto_perl->Idebug; |
13269
|
|
|
|
|
|
|
13270
|
|
|
|
|
|
/* dbargs array probably holds garbage */ |
13271
|
|
|
|
|
|
PL_dbargs = NULL; |
13272
|
|
|
|
|
|
|
13273
|
|
|
|
|
|
PL_compiling = proto_perl->Icompiling; |
13274
|
|
|
|
|
|
|
13275
|
|
|
|
|
|
/* pseudo environmental stuff */ |
13276
|
|
|
|
|
|
PL_origargc = proto_perl->Iorigargc; |
13277
|
|
|
|
|
|
PL_origargv = proto_perl->Iorigargv; |
13278
|
|
|
|
|
|
|
13279
|
|
|
|
|
|
#if !NO_TAINT_SUPPORT |
13280
|
|
|
|
|
|
/* Set tainting stuff before PerlIO_debug can possibly get called */ |
13281
|
|
|
|
|
|
PL_tainting = proto_perl->Itainting; |
13282
|
|
|
|
|
|
PL_taint_warn = proto_perl->Itaint_warn; |
13283
|
|
|
|
|
|
#else |
13284
|
|
|
|
|
|
PL_tainting = FALSE; |
13285
|
|
|
|
|
|
PL_taint_warn = FALSE; |
13286
|
|
|
|
|
|
#endif |
13287
|
|
|
|
|
|
|
13288
|
|
|
|
|
|
PL_minus_c = proto_perl->Iminus_c; |
13289
|
|
|
|
|
|
|
13290
|
|
|
|
|
|
PL_localpatches = proto_perl->Ilocalpatches; |
13291
|
|
|
|
|
|
PL_splitstr = proto_perl->Isplitstr; |
13292
|
|
|
|
|
|
PL_minus_n = proto_perl->Iminus_n; |
13293
|
|
|
|
|
|
PL_minus_p = proto_perl->Iminus_p; |
13294
|
|
|
|
|
|
PL_minus_l = proto_perl->Iminus_l; |
13295
|
|
|
|
|
|
PL_minus_a = proto_perl->Iminus_a; |
13296
|
|
|
|
|
|
PL_minus_E = proto_perl->Iminus_E; |
13297
|
|
|
|
|
|
PL_minus_F = proto_perl->Iminus_F; |
13298
|
|
|
|
|
|
PL_doswitches = proto_perl->Idoswitches; |
13299
|
|
|
|
|
|
PL_dowarn = proto_perl->Idowarn; |
13300
|
|
|
|
|
|
#ifdef PERL_SAWAMPERSAND |
13301
|
|
|
|
|
|
PL_sawampersand = proto_perl->Isawampersand; |
13302
|
|
|
|
|
|
#endif |
13303
|
|
|
|
|
|
PL_unsafe = proto_perl->Iunsafe; |
13304
|
|
|
|
|
|
PL_perldb = proto_perl->Iperldb; |
13305
|
|
|
|
|
|
PL_perl_destruct_level = proto_perl->Iperl_destruct_level; |
13306
|
|
|
|
|
|
PL_exit_flags = proto_perl->Iexit_flags; |
13307
|
|
|
|
|
|
|
13308
|
|
|
|
|
|
/* XXX time(&PL_basetime) when asked for? */ |
13309
|
|
|
|
|
|
PL_basetime = proto_perl->Ibasetime; |
13310
|
|
|
|
|
|
|
13311
|
|
|
|
|
|
PL_maxsysfd = proto_perl->Imaxsysfd; |
13312
|
|
|
|
|
|
PL_statusvalue = proto_perl->Istatusvalue; |
13313
|
|
|
|
|
|
#ifdef VMS |
13314
|
|
|
|
|
|
PL_statusvalue_vms = proto_perl->Istatusvalue_vms; |
13315
|
|
|
|
|
|
#else |
13316
|
|
|
|
|
|
PL_statusvalue_posix = proto_perl->Istatusvalue_posix; |
13317
|
|
|
|
|
|
#endif |
13318
|
|
|
|
|
|
|
13319
|
|
|
|
|
|
/* RE engine related */ |
13320
|
|
|
|
|
|
PL_regmatch_slab = NULL; |
13321
|
|
|
|
|
|
PL_reg_curpm = NULL; |
13322
|
|
|
|
|
|
|
13323
|
|
|
|
|
|
PL_sub_generation = proto_perl->Isub_generation; |
13324
|
|
|
|
|
|
|
13325
|
|
|
|
|
|
/* funky return mechanisms */ |
13326
|
|
|
|
|
|
PL_forkprocess = proto_perl->Iforkprocess; |
13327
|
|
|
|
|
|
|
13328
|
|
|
|
|
|
/* internal state */ |
13329
|
|
|
|
|
|
PL_maxo = proto_perl->Imaxo; |
13330
|
|
|
|
|
|
|
13331
|
|
|
|
|
|
PL_main_start = proto_perl->Imain_start; |
13332
|
|
|
|
|
|
PL_eval_root = proto_perl->Ieval_root; |
13333
|
|
|
|
|
|
PL_eval_start = proto_perl->Ieval_start; |
13334
|
|
|
|
|
|
|
13335
|
|
|
|
|
|
PL_filemode = proto_perl->Ifilemode; |
13336
|
|
|
|
|
|
PL_lastfd = proto_perl->Ilastfd; |
13337
|
|
|
|
|
|
PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ |
13338
|
|
|
|
|
|
PL_Argv = NULL; |
13339
|
|
|
|
|
|
PL_Cmd = NULL; |
13340
|
|
|
|
|
|
PL_gensym = proto_perl->Igensym; |
13341
|
|
|
|
|
|
|
13342
|
|
|
|
|
|
PL_laststatval = proto_perl->Ilaststatval; |
13343
|
|
|
|
|
|
PL_laststype = proto_perl->Ilaststype; |
13344
|
|
|
|
|
|
PL_mess_sv = NULL; |
13345
|
|
|
|
|
|
|
13346
|
|
|
|
|
|
PL_profiledata = NULL; |
13347
|
|
|
|
|
|
|
13348
|
|
|
|
|
|
PL_generation = proto_perl->Igeneration; |
13349
|
|
|
|
|
|
|
13350
|
|
|
|
|
|
PL_in_clean_objs = proto_perl->Iin_clean_objs; |
13351
|
|
|
|
|
|
PL_in_clean_all = proto_perl->Iin_clean_all; |
13352
|
|
|
|
|
|
|
13353
|
|
|
|
|
|
PL_delaymagic_uid = proto_perl->Idelaymagic_uid; |
13354
|
|
|
|
|
|
PL_delaymagic_euid = proto_perl->Idelaymagic_euid; |
13355
|
|
|
|
|
|
PL_delaymagic_gid = proto_perl->Idelaymagic_gid; |
13356
|
|
|
|
|
|
PL_delaymagic_egid = proto_perl->Idelaymagic_egid; |
13357
|
|
|
|
|
|
PL_nomemok = proto_perl->Inomemok; |
13358
|
|
|
|
|
|
PL_an = proto_perl->Ian; |
13359
|
|
|
|
|
|
PL_evalseq = proto_perl->Ievalseq; |
13360
|
|
|
|
|
|
PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ |
13361
|
|
|
|
|
|
PL_origalen = proto_perl->Iorigalen; |
13362
|
|
|
|
|
|
|
13363
|
|
|
|
|
|
PL_sighandlerp = proto_perl->Isighandlerp; |
13364
|
|
|
|
|
|
|
13365
|
|
|
|
|
|
PL_runops = proto_perl->Irunops; |
13366
|
|
|
|
|
|
|
13367
|
|
|
|
|
|
PL_subline = proto_perl->Isubline; |
13368
|
|
|
|
|
|
|
13369
|
|
|
|
|
|
#ifdef FCRYPT |
13370
|
|
|
|
|
|
PL_cryptseen = proto_perl->Icryptseen; |
13371
|
|
|
|
|
|
#endif |
13372
|
|
|
|
|
|
|
13373
|
|
|
|
|
|
#ifdef USE_LOCALE_COLLATE |
13374
|
|
|
|
|
|
PL_collation_ix = proto_perl->Icollation_ix; |
13375
|
|
|
|
|
|
PL_collation_standard = proto_perl->Icollation_standard; |
13376
|
|
|
|
|
|
PL_collxfrm_base = proto_perl->Icollxfrm_base; |
13377
|
|
|
|
|
|
PL_collxfrm_mult = proto_perl->Icollxfrm_mult; |
13378
|
|
|
|
|
|
#endif /* USE_LOCALE_COLLATE */ |
13379
|
|
|
|
|
|
|
13380
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
13381
|
|
|
|
|
|
PL_numeric_standard = proto_perl->Inumeric_standard; |
13382
|
|
|
|
|
|
PL_numeric_local = proto_perl->Inumeric_local; |
13383
|
|
|
|
|
|
#endif /* !USE_LOCALE_NUMERIC */ |
13384
|
|
|
|
|
|
|
13385
|
|
|
|
|
|
/* Did the locale setup indicate UTF-8? */ |
13386
|
|
|
|
|
|
PL_utf8locale = proto_perl->Iutf8locale; |
13387
|
|
|
|
|
|
/* Unicode features (see perlrun/-C) */ |
13388
|
|
|
|
|
|
PL_unicode = proto_perl->Iunicode; |
13389
|
|
|
|
|
|
|
13390
|
|
|
|
|
|
/* Pre-5.8 signals control */ |
13391
|
|
|
|
|
|
PL_signals = proto_perl->Isignals; |
13392
|
|
|
|
|
|
|
13393
|
|
|
|
|
|
/* times() ticks per second */ |
13394
|
|
|
|
|
|
PL_clocktick = proto_perl->Iclocktick; |
13395
|
|
|
|
|
|
|
13396
|
|
|
|
|
|
/* Recursion stopper for PerlIO_find_layer */ |
13397
|
|
|
|
|
|
PL_in_load_module = proto_perl->Iin_load_module; |
13398
|
|
|
|
|
|
|
13399
|
|
|
|
|
|
/* sort() routine */ |
13400
|
|
|
|
|
|
PL_sort_RealCmp = proto_perl->Isort_RealCmp; |
13401
|
|
|
|
|
|
|
13402
|
|
|
|
|
|
/* Not really needed/useful since the reenrant_retint is "volatile", |
13403
|
|
|
|
|
|
* but do it for consistency's sake. */ |
13404
|
|
|
|
|
|
PL_reentrant_retint = proto_perl->Ireentrant_retint; |
13405
|
|
|
|
|
|
|
13406
|
|
|
|
|
|
/* Hooks to shared SVs and locks. */ |
13407
|
|
|
|
|
|
PL_sharehook = proto_perl->Isharehook; |
13408
|
|
|
|
|
|
PL_lockhook = proto_perl->Ilockhook; |
13409
|
|
|
|
|
|
PL_unlockhook = proto_perl->Iunlockhook; |
13410
|
|
|
|
|
|
PL_threadhook = proto_perl->Ithreadhook; |
13411
|
|
|
|
|
|
PL_destroyhook = proto_perl->Idestroyhook; |
13412
|
|
|
|
|
|
PL_signalhook = proto_perl->Isignalhook; |
13413
|
|
|
|
|
|
|
13414
|
|
|
|
|
|
PL_globhook = proto_perl->Iglobhook; |
13415
|
|
|
|
|
|
|
13416
|
|
|
|
|
|
/* swatch cache */ |
13417
|
|
|
|
|
|
PL_last_swash_hv = NULL; /* reinits on demand */ |
13418
|
|
|
|
|
|
PL_last_swash_klen = 0; |
13419
|
|
|
|
|
|
PL_last_swash_key[0]= '\0'; |
13420
|
|
|
|
|
|
PL_last_swash_tmps = (U8*)NULL; |
13421
|
|
|
|
|
|
PL_last_swash_slen = 0; |
13422
|
|
|
|
|
|
|
13423
|
|
|
|
|
|
PL_srand_called = proto_perl->Isrand_called; |
13424
|
|
|
|
|
|
|
13425
|
|
|
|
|
|
if (flags & CLONEf_COPY_STACKS) { |
13426
|
|
|
|
|
|
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ |
13427
|
|
|
|
|
|
PL_tmps_ix = proto_perl->Itmps_ix; |
13428
|
|
|
|
|
|
PL_tmps_max = proto_perl->Itmps_max; |
13429
|
|
|
|
|
|
PL_tmps_floor = proto_perl->Itmps_floor; |
13430
|
|
|
|
|
|
|
13431
|
|
|
|
|
|
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] |
13432
|
|
|
|
|
|
* NOTE: unlike the others! */ |
13433
|
|
|
|
|
|
PL_scopestack_ix = proto_perl->Iscopestack_ix; |
13434
|
|
|
|
|
|
PL_scopestack_max = proto_perl->Iscopestack_max; |
13435
|
|
|
|
|
|
|
13436
|
|
|
|
|
|
/* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] |
13437
|
|
|
|
|
|
* NOTE: unlike the others! */ |
13438
|
|
|
|
|
|
PL_savestack_ix = proto_perl->Isavestack_ix; |
13439
|
|
|
|
|
|
PL_savestack_max = proto_perl->Isavestack_max; |
13440
|
|
|
|
|
|
} |
13441
|
|
|
|
|
|
|
13442
|
|
|
|
|
|
PL_start_env = proto_perl->Istart_env; /* XXXXXX */ |
13443
|
|
|
|
|
|
PL_top_env = &PL_start_env; |
13444
|
|
|
|
|
|
|
13445
|
|
|
|
|
|
PL_op = proto_perl->Iop; |
13446
|
|
|
|
|
|
|
13447
|
|
|
|
|
|
PL_Sv = NULL; |
13448
|
|
|
|
|
|
PL_Xpv = (XPV*)NULL; |
13449
|
|
|
|
|
|
my_perl->Ina = proto_perl->Ina; |
13450
|
|
|
|
|
|
|
13451
|
|
|
|
|
|
PL_statbuf = proto_perl->Istatbuf; |
13452
|
|
|
|
|
|
PL_statcache = proto_perl->Istatcache; |
13453
|
|
|
|
|
|
|
13454
|
|
|
|
|
|
#ifdef HAS_TIMES |
13455
|
|
|
|
|
|
PL_timesbuf = proto_perl->Itimesbuf; |
13456
|
|
|
|
|
|
#endif |
13457
|
|
|
|
|
|
|
13458
|
|
|
|
|
|
#if !NO_TAINT_SUPPORT |
13459
|
|
|
|
|
|
PL_tainted = proto_perl->Itainted; |
13460
|
|
|
|
|
|
#else |
13461
|
|
|
|
|
|
PL_tainted = FALSE; |
13462
|
|
|
|
|
|
#endif |
13463
|
|
|
|
|
|
PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ |
13464
|
|
|
|
|
|
|
13465
|
|
|
|
|
|
PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ |
13466
|
|
|
|
|
|
|
13467
|
|
|
|
|
|
PL_restartjmpenv = proto_perl->Irestartjmpenv; |
13468
|
|
|
|
|
|
PL_restartop = proto_perl->Irestartop; |
13469
|
|
|
|
|
|
PL_in_eval = proto_perl->Iin_eval; |
13470
|
|
|
|
|
|
PL_delaymagic = proto_perl->Idelaymagic; |
13471
|
|
|
|
|
|
PL_phase = proto_perl->Iphase; |
13472
|
|
|
|
|
|
PL_localizing = proto_perl->Ilocalizing; |
13473
|
|
|
|
|
|
|
13474
|
|
|
|
|
|
PL_hv_fetch_ent_mh = NULL; |
13475
|
|
|
|
|
|
PL_modcount = proto_perl->Imodcount; |
13476
|
|
|
|
|
|
PL_lastgotoprobe = NULL; |
13477
|
|
|
|
|
|
PL_dumpindent = proto_perl->Idumpindent; |
13478
|
|
|
|
|
|
|
13479
|
|
|
|
|
|
PL_efloatbuf = NULL; /* reinits on demand */ |
13480
|
|
|
|
|
|
PL_efloatsize = 0; /* reinits on demand */ |
13481
|
|
|
|
|
|
|
13482
|
|
|
|
|
|
/* regex stuff */ |
13483
|
|
|
|
|
|
|
13484
|
|
|
|
|
|
PL_colorset = 0; /* reinits PL_colors[] */ |
13485
|
|
|
|
|
|
/*PL_colors[6] = {0,0,0,0,0,0};*/ |
13486
|
|
|
|
|
|
|
13487
|
|
|
|
|
|
/* Pluggable optimizer */ |
13488
|
|
|
|
|
|
PL_peepp = proto_perl->Ipeepp; |
13489
|
|
|
|
|
|
PL_rpeepp = proto_perl->Irpeepp; |
13490
|
|
|
|
|
|
/* op_free() hook */ |
13491
|
|
|
|
|
|
PL_opfreehook = proto_perl->Iopfreehook; |
13492
|
|
|
|
|
|
|
13493
|
|
|
|
|
|
#ifdef USE_REENTRANT_API |
13494
|
|
|
|
|
|
/* XXX: things like -Dm will segfault here in perlio, but doing |
13495
|
|
|
|
|
|
* PERL_SET_CONTEXT(proto_perl); |
13496
|
|
|
|
|
|
* breaks too many other things |
13497
|
|
|
|
|
|
*/ |
13498
|
|
|
|
|
|
Perl_reentrant_init(aTHX); |
13499
|
|
|
|
|
|
#endif |
13500
|
|
|
|
|
|
|
13501
|
|
|
|
|
|
/* create SV map for pointer relocation */ |
13502
|
|
|
|
|
|
PL_ptr_table = ptr_table_new(); |
13503
|
|
|
|
|
|
|
13504
|
|
|
|
|
|
/* initialize these special pointers as early as possible */ |
13505
|
|
|
|
|
|
init_constants(); |
13506
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); |
13507
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); |
13508
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); |
13509
|
|
|
|
|
|
|
13510
|
|
|
|
|
|
/* create (a non-shared!) shared string table */ |
13511
|
|
|
|
|
|
PL_strtab = newHV(); |
13512
|
|
|
|
|
|
HvSHAREKEYS_off(PL_strtab); |
13513
|
|
|
|
|
|
hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab)); |
13514
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); |
13515
|
|
|
|
|
|
|
13516
|
|
|
|
|
|
Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); |
13517
|
|
|
|
|
|
|
13518
|
|
|
|
|
|
/* This PV will be free'd special way so must set it same way op.c does */ |
13519
|
|
|
|
|
|
PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); |
13520
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); |
13521
|
|
|
|
|
|
|
13522
|
|
|
|
|
|
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); |
13523
|
|
|
|
|
|
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); |
13524
|
|
|
|
|
|
CopHINTHASH_set(&PL_compiling, cophh_copy(CopHINTHASH_get(&PL_compiling))); |
13525
|
|
|
|
|
|
PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); |
13526
|
|
|
|
|
|
|
13527
|
|
|
|
|
|
param->stashes = newAV(); /* Setup array of objects to call clone on */ |
13528
|
|
|
|
|
|
/* This makes no difference to the implementation, as it always pushes |
13529
|
|
|
|
|
|
and shifts pointers to other SVs without changing their reference |
13530
|
|
|
|
|
|
count, with the array becoming empty before it is freed. However, it |
13531
|
|
|
|
|
|
makes it conceptually clear what is going on, and will avoid some |
13532
|
|
|
|
|
|
work inside av.c, filling slots between AvFILL() and AvMAX() with |
13533
|
|
|
|
|
|
&PL_sv_undef, and SvREFCNT_dec()ing those. */ |
13534
|
|
|
|
|
|
AvREAL_off(param->stashes); |
13535
|
|
|
|
|
|
|
13536
|
|
|
|
|
|
if (!(flags & CLONEf_COPY_STACKS)) { |
13537
|
|
|
|
|
|
param->unreferenced = newAV(); |
13538
|
|
|
|
|
|
} |
13539
|
|
|
|
|
|
|
13540
|
|
|
|
|
|
#ifdef PERLIO_LAYERS |
13541
|
|
|
|
|
|
/* Clone PerlIO tables as soon as we can handle general xx_dup() */ |
13542
|
|
|
|
|
|
PerlIO_clone(aTHX_ proto_perl, param); |
13543
|
|
|
|
|
|
#endif |
13544
|
|
|
|
|
|
|
13545
|
|
|
|
|
|
PL_envgv = gv_dup(proto_perl->Ienvgv, param); |
13546
|
|
|
|
|
|
PL_incgv = gv_dup(proto_perl->Iincgv, param); |
13547
|
|
|
|
|
|
PL_hintgv = gv_dup(proto_perl->Ihintgv, param); |
13548
|
|
|
|
|
|
PL_origfilename = SAVEPV(proto_perl->Iorigfilename); |
13549
|
|
|
|
|
|
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); |
13550
|
|
|
|
|
|
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); |
13551
|
|
|
|
|
|
|
13552
|
|
|
|
|
|
/* switches */ |
13553
|
|
|
|
|
|
PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); |
13554
|
|
|
|
|
|
PL_apiversion = sv_dup_inc(proto_perl->Iapiversion, param); |
13555
|
|
|
|
|
|
PL_inplace = SAVEPV(proto_perl->Iinplace); |
13556
|
|
|
|
|
|
PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); |
13557
|
|
|
|
|
|
|
13558
|
|
|
|
|
|
/* magical thingies */ |
13559
|
|
|
|
|
|
|
13560
|
|
|
|
|
|
PL_encoding = sv_dup(proto_perl->Iencoding, param); |
13561
|
|
|
|
|
|
|
13562
|
|
|
|
|
|
sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ |
13563
|
|
|
|
|
|
sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ |
13564
|
|
|
|
|
|
sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ |
13565
|
|
|
|
|
|
|
13566
|
|
|
|
|
|
|
13567
|
|
|
|
|
|
/* Clone the regex array */ |
13568
|
|
|
|
|
|
/* ORANGE FIXME for plugins, probably in the SV dup code. |
13569
|
|
|
|
|
|
newSViv(PTR2IV(CALLREGDUPE( |
13570
|
|
|
|
|
|
INT2PTR(REGEXP *, SvIVX(regex)), param)))) |
13571
|
|
|
|
|
|
*/ |
13572
|
|
|
|
|
|
PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); |
13573
|
|
|
|
|
|
PL_regex_pad = AvARRAY(PL_regex_padav); |
13574
|
|
|
|
|
|
|
13575
|
|
|
|
|
|
PL_stashpadmax = proto_perl->Istashpadmax; |
13576
|
|
|
|
|
|
PL_stashpadix = proto_perl->Istashpadix ; |
13577
|
|
|
|
|
|
Newx(PL_stashpad, PL_stashpadmax, HV *); |
13578
|
|
|
|
|
|
{ |
13579
|
|
|
|
|
|
PADOFFSET o = 0; |
13580
|
|
|
|
|
|
for (; o < PL_stashpadmax; ++o) |
13581
|
|
|
|
|
|
PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); |
13582
|
|
|
|
|
|
} |
13583
|
|
|
|
|
|
|
13584
|
|
|
|
|
|
/* shortcuts to various I/O objects */ |
13585
|
|
|
|
|
|
PL_ofsgv = gv_dup_inc(proto_perl->Iofsgv, param); |
13586
|
|
|
|
|
|
PL_stdingv = gv_dup(proto_perl->Istdingv, param); |
13587
|
|
|
|
|
|
PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); |
13588
|
|
|
|
|
|
PL_defgv = gv_dup(proto_perl->Idefgv, param); |
13589
|
|
|
|
|
|
PL_argvgv = gv_dup(proto_perl->Iargvgv, param); |
13590
|
|
|
|
|
|
PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); |
13591
|
|
|
|
|
|
PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); |
13592
|
|
|
|
|
|
|
13593
|
|
|
|
|
|
/* shortcuts to regexp stuff */ |
13594
|
|
|
|
|
|
PL_replgv = gv_dup(proto_perl->Ireplgv, param); |
13595
|
|
|
|
|
|
|
13596
|
|
|
|
|
|
/* shortcuts to misc objects */ |
13597
|
|
|
|
|
|
PL_errgv = gv_dup(proto_perl->Ierrgv, param); |
13598
|
|
|
|
|
|
|
13599
|
|
|
|
|
|
/* shortcuts to debugging objects */ |
13600
|
|
|
|
|
|
PL_DBgv = gv_dup(proto_perl->IDBgv, param); |
13601
|
|
|
|
|
|
PL_DBline = gv_dup(proto_perl->IDBline, param); |
13602
|
|
|
|
|
|
PL_DBsub = gv_dup(proto_perl->IDBsub, param); |
13603
|
|
|
|
|
|
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); |
13604
|
|
|
|
|
|
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); |
13605
|
|
|
|
|
|
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); |
13606
|
|
|
|
|
|
|
13607
|
|
|
|
|
|
/* symbol tables */ |
13608
|
|
|
|
|
|
PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); |
13609
|
|
|
|
|
|
PL_curstash = hv_dup_inc(proto_perl->Icurstash, param); |
13610
|
|
|
|
|
|
PL_debstash = hv_dup(proto_perl->Idebstash, param); |
13611
|
|
|
|
|
|
PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); |
13612
|
|
|
|
|
|
PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); |
13613
|
|
|
|
|
|
|
13614
|
|
|
|
|
|
PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); |
13615
|
|
|
|
|
|
PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); |
13616
|
|
|
|
|
|
PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); |
13617
|
|
|
|
|
|
PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); |
13618
|
|
|
|
|
|
PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); |
13619
|
|
|
|
|
|
PL_endav = av_dup_inc(proto_perl->Iendav, param); |
13620
|
|
|
|
|
|
PL_checkav = av_dup_inc(proto_perl->Icheckav, param); |
13621
|
|
|
|
|
|
PL_initav = av_dup_inc(proto_perl->Iinitav, param); |
13622
|
|
|
|
|
|
|
13623
|
|
|
|
|
|
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); |
13624
|
|
|
|
|
|
|
13625
|
|
|
|
|
|
/* subprocess state */ |
13626
|
|
|
|
|
|
PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); |
13627
|
|
|
|
|
|
|
13628
|
|
|
|
|
|
if (proto_perl->Iop_mask) |
13629
|
|
|
|
|
|
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); |
13630
|
|
|
|
|
|
else |
13631
|
|
|
|
|
|
PL_op_mask = NULL; |
13632
|
|
|
|
|
|
/* PL_asserting = proto_perl->Iasserting; */ |
13633
|
|
|
|
|
|
|
13634
|
|
|
|
|
|
/* current interpreter roots */ |
13635
|
|
|
|
|
|
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); |
13636
|
|
|
|
|
|
OP_REFCNT_LOCK; |
13637
|
|
|
|
|
|
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); |
13638
|
|
|
|
|
|
OP_REFCNT_UNLOCK; |
13639
|
|
|
|
|
|
|
13640
|
|
|
|
|
|
/* runtime control stuff */ |
13641
|
|
|
|
|
|
PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); |
13642
|
|
|
|
|
|
|
13643
|
|
|
|
|
|
PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); |
13644
|
|
|
|
|
|
|
13645
|
|
|
|
|
|
PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); |
13646
|
|
|
|
|
|
|
13647
|
|
|
|
|
|
/* interpreter atexit processing */ |
13648
|
|
|
|
|
|
PL_exitlistlen = proto_perl->Iexitlistlen; |
13649
|
|
|
|
|
|
if (PL_exitlistlen) { |
13650
|
|
|
|
|
|
Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); |
13651
|
|
|
|
|
|
Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); |
13652
|
|
|
|
|
|
} |
13653
|
|
|
|
|
|
else |
13654
|
|
|
|
|
|
PL_exitlist = (PerlExitListEntry*)NULL; |
13655
|
|
|
|
|
|
|
13656
|
|
|
|
|
|
PL_my_cxt_size = proto_perl->Imy_cxt_size; |
13657
|
|
|
|
|
|
if (PL_my_cxt_size) { |
13658
|
|
|
|
|
|
Newx(PL_my_cxt_list, PL_my_cxt_size, void *); |
13659
|
|
|
|
|
|
Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); |
13660
|
|
|
|
|
|
#ifdef PERL_GLOBAL_STRUCT_PRIVATE |
13661
|
|
|
|
|
|
Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); |
13662
|
|
|
|
|
|
Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); |
13663
|
|
|
|
|
|
#endif |
13664
|
|
|
|
|
|
} |
13665
|
|
|
|
|
|
else { |
13666
|
|
|
|
|
|
PL_my_cxt_list = (void**)NULL; |
13667
|
|
|
|
|
|
#ifdef PERL_GLOBAL_STRUCT_PRIVATE |
13668
|
|
|
|
|
|
PL_my_cxt_keys = (const char**)NULL; |
13669
|
|
|
|
|
|
#endif |
13670
|
|
|
|
|
|
} |
13671
|
|
|
|
|
|
PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); |
13672
|
|
|
|
|
|
PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); |
13673
|
|
|
|
|
|
PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); |
13674
|
|
|
|
|
|
PL_custom_ops = hv_dup_inc(proto_perl->Icustom_ops, param); |
13675
|
|
|
|
|
|
|
13676
|
|
|
|
|
|
PL_compcv = cv_dup(proto_perl->Icompcv, param); |
13677
|
|
|
|
|
|
|
13678
|
|
|
|
|
|
PAD_CLONE_VARS(proto_perl, param); |
13679
|
|
|
|
|
|
|
13680
|
|
|
|
|
|
#ifdef HAVE_INTERP_INTERN |
13681
|
|
|
|
|
|
sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); |
13682
|
|
|
|
|
|
#endif |
13683
|
|
|
|
|
|
|
13684
|
|
|
|
|
|
PL_DBcv = cv_dup(proto_perl->IDBcv, param); |
13685
|
|
|
|
|
|
|
13686
|
|
|
|
|
|
#ifdef PERL_USES_PL_PIDSTATUS |
13687
|
|
|
|
|
|
PL_pidstatus = newHV(); /* XXX flag for cloning? */ |
13688
|
|
|
|
|
|
#endif |
13689
|
|
|
|
|
|
PL_osname = SAVEPV(proto_perl->Iosname); |
13690
|
|
|
|
|
|
PL_parser = parser_dup(proto_perl->Iparser, param); |
13691
|
|
|
|
|
|
|
13692
|
|
|
|
|
|
/* XXX this only works if the saved cop has already been cloned */ |
13693
|
|
|
|
|
|
if (proto_perl->Iparser) { |
13694
|
|
|
|
|
|
PL_parser->saved_curcop = (COP*)any_dup( |
13695
|
|
|
|
|
|
proto_perl->Iparser->saved_curcop, |
13696
|
|
|
|
|
|
proto_perl); |
13697
|
|
|
|
|
|
} |
13698
|
|
|
|
|
|
|
13699
|
|
|
|
|
|
PL_subname = sv_dup_inc(proto_perl->Isubname, param); |
13700
|
|
|
|
|
|
|
13701
|
|
|
|
|
|
#ifdef USE_LOCALE_COLLATE |
13702
|
|
|
|
|
|
PL_collation_name = SAVEPV(proto_perl->Icollation_name); |
13703
|
|
|
|
|
|
#endif /* USE_LOCALE_COLLATE */ |
13704
|
|
|
|
|
|
|
13705
|
|
|
|
|
|
#ifdef USE_LOCALE_NUMERIC |
13706
|
|
|
|
|
|
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); |
13707
|
|
|
|
|
|
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); |
13708
|
|
|
|
|
|
#endif /* !USE_LOCALE_NUMERIC */ |
13709
|
|
|
|
|
|
|
13710
|
|
|
|
|
|
/* Unicode inversion lists */ |
13711
|
|
|
|
|
|
PL_ASCII = sv_dup_inc(proto_perl->IASCII, param); |
13712
|
|
|
|
|
|
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); |
13713
|
|
|
|
|
|
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); |
13714
|
|
|
|
|
|
|
13715
|
|
|
|
|
|
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param); |
13716
|
|
|
|
|
|
PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param); |
13717
|
|
|
|
|
|
|
13718
|
|
|
|
|
|
/* utf8 character class swashes */ |
13719
|
|
|
|
|
|
for (i = 0; i < POSIX_SWASH_COUNT; i++) { |
13720
|
|
|
|
|
|
PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param); |
13721
|
|
|
|
|
|
} |
13722
|
|
|
|
|
|
for (i = 0; i < POSIX_CC_COUNT; i++) { |
13723
|
|
|
|
|
|
PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param); |
13724
|
|
|
|
|
|
PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param); |
13725
|
|
|
|
|
|
PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); |
13726
|
|
|
|
|
|
} |
13727
|
|
|
|
|
|
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); |
13728
|
|
|
|
|
|
PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param); |
13729
|
|
|
|
|
|
PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); |
13730
|
|
|
|
|
|
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); |
13731
|
|
|
|
|
|
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); |
13732
|
|
|
|
|
|
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); |
13733
|
|
|
|
|
|
PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); |
13734
|
|
|
|
|
|
PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); |
13735
|
|
|
|
|
|
PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param); |
13736
|
|
|
|
|
|
PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param); |
13737
|
|
|
|
|
|
PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param); |
13738
|
|
|
|
|
|
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); |
13739
|
|
|
|
|
|
PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); |
13740
|
|
|
|
|
|
PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param); |
13741
|
|
|
|
|
|
PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param); |
13742
|
|
|
|
|
|
PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param); |
13743
|
|
|
|
|
|
|
13744
|
|
|
|
|
|
if (proto_perl->Ipsig_pend) { |
13745
|
|
|
|
|
|
Newxz(PL_psig_pend, SIG_SIZE, int); |
13746
|
|
|
|
|
|
} |
13747
|
|
|
|
|
|
else { |
13748
|
|
|
|
|
|
PL_psig_pend = (int*)NULL; |
13749
|
|
|
|
|
|
} |
13750
|
|
|
|
|
|
|
13751
|
|
|
|
|
|
if (proto_perl->Ipsig_name) { |
13752
|
|
|
|
|
|
Newx(PL_psig_name, 2 * SIG_SIZE, SV*); |
13753
|
|
|
|
|
|
sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, |
13754
|
|
|
|
|
|
param); |
13755
|
|
|
|
|
|
PL_psig_ptr = PL_psig_name + SIG_SIZE; |
13756
|
|
|
|
|
|
} |
13757
|
|
|
|
|
|
else { |
13758
|
|
|
|
|
|
PL_psig_ptr = (SV**)NULL; |
13759
|
|
|
|
|
|
PL_psig_name = (SV**)NULL; |
13760
|
|
|
|
|
|
} |
13761
|
|
|
|
|
|
|
13762
|
|
|
|
|
|
if (flags & CLONEf_COPY_STACKS) { |
13763
|
|
|
|
|
|
Newx(PL_tmps_stack, PL_tmps_max, SV*); |
13764
|
|
|
|
|
|
sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, |
13765
|
|
|
|
|
|
PL_tmps_ix+1, param); |
13766
|
|
|
|
|
|
|
13767
|
|
|
|
|
|
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */ |
13768
|
|
|
|
|
|
i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; |
13769
|
|
|
|
|
|
Newxz(PL_markstack, i, I32); |
13770
|
|
|
|
|
|
PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max |
13771
|
|
|
|
|
|
- proto_perl->Imarkstack); |
13772
|
|
|
|
|
|
PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr |
13773
|
|
|
|
|
|
- proto_perl->Imarkstack); |
13774
|
|
|
|
|
|
Copy(proto_perl->Imarkstack, PL_markstack, |
13775
|
|
|
|
|
|
PL_markstack_ptr - PL_markstack + 1, I32); |
13776
|
|
|
|
|
|
|
13777
|
|
|
|
|
|
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] |
13778
|
|
|
|
|
|
* NOTE: unlike the others! */ |
13779
|
|
|
|
|
|
Newxz(PL_scopestack, PL_scopestack_max, I32); |
13780
|
|
|
|
|
|
Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); |
13781
|
|
|
|
|
|
|
13782
|
|
|
|
|
|
#ifdef DEBUGGING |
13783
|
|
|
|
|
|
Newxz(PL_scopestack_name, PL_scopestack_max, const char *); |
13784
|
|
|
|
|
|
Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); |
13785
|
|
|
|
|
|
#endif |
13786
|
|
|
|
|
|
/* reset stack AV to correct length before its duped via |
13787
|
|
|
|
|
|
* PL_curstackinfo */ |
13788
|
|
|
|
|
|
AvFILLp(proto_perl->Icurstack) = |
13789
|
|
|
|
|
|
proto_perl->Istack_sp - proto_perl->Istack_base; |
13790
|
|
|
|
|
|
|
13791
|
|
|
|
|
|
/* NOTE: si_dup() looks at PL_markstack */ |
13792
|
|
|
|
|
|
PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); |
13793
|
|
|
|
|
|
|
13794
|
|
|
|
|
|
/* PL_curstack = PL_curstackinfo->si_stack; */ |
13795
|
|
|
|
|
|
PL_curstack = av_dup(proto_perl->Icurstack, param); |
13796
|
|
|
|
|
|
PL_mainstack = av_dup(proto_perl->Imainstack, param); |
13797
|
|
|
|
|
|
|
13798
|
|
|
|
|
|
/* next PUSHs() etc. set *(PL_stack_sp+1) */ |
13799
|
|
|
|
|
|
PL_stack_base = AvARRAY(PL_curstack); |
13800
|
|
|
|
|
|
PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp |
13801
|
|
|
|
|
|
- proto_perl->Istack_base); |
13802
|
|
|
|
|
|
PL_stack_max = PL_stack_base + AvMAX(PL_curstack); |
13803
|
|
|
|
|
|
|
13804
|
|
|
|
|
|
/*Newxz(PL_savestack, PL_savestack_max, ANY);*/ |
13805
|
|
|
|
|
|
PL_savestack = ss_dup(proto_perl, param); |
13806
|
|
|
|
|
|
} |
13807
|
|
|
|
|
|
else { |
13808
|
|
|
|
|
|
init_stacks(); |
13809
|
|
|
|
|
|
ENTER; /* perl_destruct() wants to LEAVE; */ |
13810
|
|
|
|
|
|
} |
13811
|
|
|
|
|
|
|
13812
|
|
|
|
|
|
PL_statgv = gv_dup(proto_perl->Istatgv, param); |
13813
|
|
|
|
|
|
PL_statname = sv_dup_inc(proto_perl->Istatname, param); |
13814
|
|
|
|
|
|
|
13815
|
|
|
|
|
|
PL_rs = sv_dup_inc(proto_perl->Irs, param); |
13816
|
|
|
|
|
|
PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); |
13817
|
|
|
|
|
|
PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); |
13818
|
|
|
|
|
|
PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); |
13819
|
|
|
|
|
|
PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); |
13820
|
|
|
|
|
|
PL_formtarget = sv_dup(proto_perl->Iformtarget, param); |
13821
|
|
|
|
|
|
|
13822
|
|
|
|
|
|
PL_errors = sv_dup_inc(proto_perl->Ierrors, param); |
13823
|
|
|
|
|
|
|
13824
|
|
|
|
|
|
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); |
13825
|
|
|
|
|
|
PL_firstgv = gv_dup(proto_perl->Ifirstgv, param); |
13826
|
|
|
|
|
|
PL_secondgv = gv_dup(proto_perl->Isecondgv, param); |
13827
|
|
|
|
|
|
|
13828
|
|
|
|
|
|
PL_stashcache = newHV(); |
13829
|
|
|
|
|
|
|
13830
|
|
|
|
|
|
PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, |
13831
|
|
|
|
|
|
proto_perl->Iwatchaddr); |
13832
|
|
|
|
|
|
PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; |
13833
|
|
|
|
|
|
if (PL_debug && PL_watchaddr) { |
13834
|
|
|
|
|
|
PerlIO_printf(Perl_debug_log, |
13835
|
|
|
|
|
|
"WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n", |
13836
|
|
|
|
|
|
PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), |
13837
|
|
|
|
|
|
PTR2UV(PL_watchok)); |
13838
|
|
|
|
|
|
} |
13839
|
|
|
|
|
|
|
13840
|
|
|
|
|
|
PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); |
13841
|
|
|
|
|
|
PL_blockhooks = av_dup_inc(proto_perl->Iblockhooks, param); |
13842
|
|
|
|
|
|
PL_utf8_foldclosures = hv_dup_inc(proto_perl->Iutf8_foldclosures, param); |
13843
|
|
|
|
|
|
|
13844
|
|
|
|
|
|
/* Call the ->CLONE method, if it exists, for each of the stashes |
13845
|
|
|
|
|
|
identified by sv_dup() above. |
13846
|
|
|
|
|
|
*/ |
13847
|
|
|
|
|
|
while(av_len(param->stashes) != -1) { |
13848
|
|
|
|
|
|
HV* const stash = MUTABLE_HV(av_shift(param->stashes)); |
13849
|
|
|
|
|
|
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); |
13850
|
|
|
|
|
|
if (cloner && GvCV(cloner)) { |
13851
|
|
|
|
|
|
dSP; |
13852
|
|
|
|
|
|
ENTER; |
13853
|
|
|
|
|
|
SAVETMPS; |
13854
|
|
|
|
|
|
PUSHMARK(SP); |
13855
|
|
|
|
|
|
mXPUSHs(newSVhek(HvNAME_HEK(stash))); |
13856
|
|
|
|
|
|
PUTBACK; |
13857
|
|
|
|
|
|
call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); |
13858
|
|
|
|
|
|
FREETMPS; |
13859
|
|
|
|
|
|
LEAVE; |
13860
|
|
|
|
|
|
} |
13861
|
|
|
|
|
|
} |
13862
|
|
|
|
|
|
|
13863
|
|
|
|
|
|
if (!(flags & CLONEf_KEEP_PTR_TABLE)) { |
13864
|
|
|
|
|
|
ptr_table_free(PL_ptr_table); |
13865
|
|
|
|
|
|
PL_ptr_table = NULL; |
13866
|
|
|
|
|
|
} |
13867
|
|
|
|
|
|
|
13868
|
|
|
|
|
|
if (!(flags & CLONEf_COPY_STACKS)) { |
13869
|
|
|
|
|
|
unreferenced_to_tmp_stack(param->unreferenced); |
13870
|
|
|
|
|
|
} |
13871
|
|
|
|
|
|
|
13872
|
|
|
|
|
|
SvREFCNT_dec(param->stashes); |
13873
|
|
|
|
|
|
|
13874
|
|
|
|
|
|
/* orphaned? eg threads->new inside BEGIN or use */ |
13875
|
|
|
|
|
|
if (PL_compcv && ! SvREFCNT(PL_compcv)) { |
13876
|
|
|
|
|
|
SvREFCNT_inc_simple_void(PL_compcv); |
13877
|
|
|
|
|
|
SAVEFREESV(PL_compcv); |
13878
|
|
|
|
|
|
} |
13879
|
|
|
|
|
|
|
13880
|
|
|
|
|
|
return my_perl; |
13881
|
|
|
|
|
|
} |
13882
|
|
|
|
|
|
|
13883
|
|
|
|
|
|
static void |
13884
|
|
|
|
|
|
S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) |
13885
|
|
|
|
|
|
{ |
13886
|
|
|
|
|
|
PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK; |
13887
|
|
|
|
|
|
|
13888
|
|
|
|
|
|
if (AvFILLp(unreferenced) > -1) { |
13889
|
|
|
|
|
|
SV **svp = AvARRAY(unreferenced); |
13890
|
|
|
|
|
|
SV **const last = svp + AvFILLp(unreferenced); |
13891
|
|
|
|
|
|
SSize_t count = 0; |
13892
|
|
|
|
|
|
|
13893
|
|
|
|
|
|
do { |
13894
|
|
|
|
|
|
if (SvREFCNT(*svp) == 1) |
13895
|
|
|
|
|
|
++count; |
13896
|
|
|
|
|
|
} while (++svp <= last); |
13897
|
|
|
|
|
|
|
13898
|
|
|
|
|
|
EXTEND_MORTAL(count); |
13899
|
|
|
|
|
|
svp = AvARRAY(unreferenced); |
13900
|
|
|
|
|
|
|
13901
|
|
|
|
|
|
do { |
13902
|
|
|
|
|
|
if (SvREFCNT(*svp) == 1) { |
13903
|
|
|
|
|
|
/* Our reference is the only one to this SV. This means that |
13904
|
|
|
|
|
|
in this thread, the scalar effectively has a 0 reference. |
13905
|
|
|
|
|
|
That doesn't work (cleanup never happens), so donate our |
13906
|
|
|
|
|
|
reference to it onto the save stack. */ |
13907
|
|
|
|
|
|
PL_tmps_stack[++PL_tmps_ix] = *svp; |
13908
|
|
|
|
|
|
} else { |
13909
|
|
|
|
|
|
/* As an optimisation, because we are already walking the |
13910
|
|
|
|
|
|
entire array, instead of above doing either |
13911
|
|
|
|
|
|
SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead |
13912
|
|
|
|
|
|
release our reference to the scalar, so that at the end of |
13913
|
|
|
|
|
|
the array owns zero references to the scalars it happens to |
13914
|
|
|
|
|
|
point to. We are effectively converting the array from |
13915
|
|
|
|
|
|
AvREAL() on to AvREAL() off. This saves the av_clear() |
13916
|
|
|
|
|
|
(triggered by the SvREFCNT_dec(unreferenced) below) from |
13917
|
|
|
|
|
|
walking the array a second time. */ |
13918
|
|
|
|
|
|
SvREFCNT_dec(*svp); |
13919
|
|
|
|
|
|
} |
13920
|
|
|
|
|
|
|
13921
|
|
|
|
|
|
} while (++svp <= last); |
13922
|
|
|
|
|
|
AvREAL_off(unreferenced); |
13923
|
|
|
|
|
|
} |
13924
|
|
|
|
|
|
SvREFCNT_dec_NN(unreferenced); |
13925
|
|
|
|
|
|
} |
13926
|
|
|
|
|
|
|
13927
|
|
|
|
|
|
void |
13928
|
|
|
|
|
|
Perl_clone_params_del(CLONE_PARAMS *param) |
13929
|
|
|
|
|
|
{ |
13930
|
|
|
|
|
|
/* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT |
13931
|
|
|
|
|
|
happy: */ |
13932
|
|
|
|
|
|
PerlInterpreter *const to = param->new_perl; |
13933
|
|
|
|
|
|
dTHXa(to); |
13934
|
|
|
|
|
|
PerlInterpreter *const was = PERL_GET_THX; |
13935
|
|
|
|
|
|
|
13936
|
|
|
|
|
|
PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; |
13937
|
|
|
|
|
|
|
13938
|
|
|
|
|
|
if (was != to) { |
13939
|
|
|
|
|
|
PERL_SET_THX(to); |
13940
|
|
|
|
|
|
} |
13941
|
|
|
|
|
|
|
13942
|
|
|
|
|
|
SvREFCNT_dec(param->stashes); |
13943
|
|
|
|
|
|
if (param->unreferenced) |
13944
|
|
|
|
|
|
unreferenced_to_tmp_stack(param->unreferenced); |
13945
|
|
|
|
|
|
|
13946
|
|
|
|
|
|
Safefree(param); |
13947
|
|
|
|
|
|
|
13948
|
|
|
|
|
|
if (was != to) { |
13949
|
|
|
|
|
|
PERL_SET_THX(was); |
13950
|
|
|
|
|
|
} |
13951
|
|
|
|
|
|
} |
13952
|
|
|
|
|
|
|
13953
|
|
|
|
|
|
CLONE_PARAMS * |
13954
|
|
|
|
|
|
Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) |
13955
|
|
|
|
|
|
{ |
13956
|
|
|
|
|
|
dVAR; |
13957
|
|
|
|
|
|
/* Need to play this game, as newAV() can call safesysmalloc(), and that |
13958
|
|
|
|
|
|
does a dTHX; to get the context from thread local storage. |
13959
|
|
|
|
|
|
FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to |
13960
|
|
|
|
|
|
a version that passes in my_perl. */ |
13961
|
|
|
|
|
|
PerlInterpreter *const was = PERL_GET_THX; |
13962
|
|
|
|
|
|
CLONE_PARAMS *param; |
13963
|
|
|
|
|
|
|
13964
|
|
|
|
|
|
PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; |
13965
|
|
|
|
|
|
|
13966
|
|
|
|
|
|
if (was != to) { |
13967
|
|
|
|
|
|
PERL_SET_THX(to); |
13968
|
|
|
|
|
|
} |
13969
|
|
|
|
|
|
|
13970
|
|
|
|
|
|
/* Given that we've set the context, we can do this unshared. */ |
13971
|
|
|
|
|
|
Newx(param, 1, CLONE_PARAMS); |
13972
|
|
|
|
|
|
|
13973
|
|
|
|
|
|
param->flags = 0; |
13974
|
|
|
|
|
|
param->proto_perl = from; |
13975
|
|
|
|
|
|
param->new_perl = to; |
13976
|
|
|
|
|
|
param->stashes = (AV *)Perl_newSV_type(to, SVt_PVAV); |
13977
|
|
|
|
|
|
AvREAL_off(param->stashes); |
13978
|
|
|
|
|
|
param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); |
13979
|
|
|
|
|
|
|
13980
|
|
|
|
|
|
if (was != to) { |
13981
|
|
|
|
|
|
PERL_SET_THX(was); |
13982
|
|
|
|
|
|
} |
13983
|
|
|
|
|
|
return param; |
13984
|
|
|
|
|
|
} |
13985
|
|
|
|
|
|
|
13986
|
|
|
|
|
|
#endif /* USE_ITHREADS */ |
13987
|
|
|
|
|
|
|
13988
|
|
|
|
|
|
void |
13989
|
24346
|
|
|
|
|
Perl_init_constants(pTHX) |
13990
|
|
|
|
|
|
{ |
13991
|
24346
|
|
|
|
|
SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL; |
13992
|
24346
|
|
|
|
|
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; |
13993
|
24346
|
|
|
|
|
SvANY(&PL_sv_undef) = NULL; |
13994
|
|
|
|
|
|
|
13995
|
24346
|
|
|
|
|
SvANY(&PL_sv_no) = new_XPVNV(); |
13996
|
24346
|
|
|
|
|
SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; |
13997
|
24346
|
|
|
|
|
SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY |
13998
|
|
|
|
|
|
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |
13999
|
|
|
|
|
|
|SVp_POK|SVf_POK; |
14000
|
|
|
|
|
|
|
14001
|
24346
|
|
|
|
|
SvANY(&PL_sv_yes) = new_XPVNV(); |
14002
|
24346
|
|
|
|
|
SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; |
14003
|
24346
|
|
|
|
|
SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY |
14004
|
|
|
|
|
|
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |
14005
|
|
|
|
|
|
|SVp_POK|SVf_POK; |
14006
|
|
|
|
|
|
|
14007
|
24346
|
|
|
|
|
SvPV_set(&PL_sv_no, (char*)PL_No); |
14008
|
24346
|
|
|
|
|
SvCUR_set(&PL_sv_no, 0); |
14009
|
24346
|
|
|
|
|
SvLEN_set(&PL_sv_no, 0); |
14010
|
24346
|
|
|
|
|
SvIV_set(&PL_sv_no, 0); |
14011
|
24346
|
|
|
|
|
SvNV_set(&PL_sv_no, 0); |
14012
|
|
|
|
|
|
|
14013
|
24346
|
|
|
|
|
SvPV_set(&PL_sv_yes, (char*)PL_Yes); |
14014
|
24346
|
|
|
|
|
SvCUR_set(&PL_sv_yes, 1); |
14015
|
24346
|
|
|
|
|
SvLEN_set(&PL_sv_yes, 0); |
14016
|
24346
|
|
|
|
|
SvIV_set(&PL_sv_yes, 1); |
14017
|
24346
|
|
|
|
|
SvNV_set(&PL_sv_yes, 1); |
14018
|
24346
|
|
|
|
|
} |
14019
|
|
|
|
|
|
|
14020
|
|
|
|
|
|
/* |
14021
|
|
|
|
|
|
=head1 Unicode Support |
14022
|
|
|
|
|
|
|
14023
|
|
|
|
|
|
=for apidoc sv_recode_to_utf8 |
14024
|
|
|
|
|
|
|
14025
|
|
|
|
|
|
The encoding is assumed to be an Encode object, on entry the PV |
14026
|
|
|
|
|
|
of the sv is assumed to be octets in that encoding, and the sv |
14027
|
|
|
|
|
|
will be converted into Unicode (and UTF-8). |
14028
|
|
|
|
|
|
|
14029
|
|
|
|
|
|
If the sv already is UTF-8 (or if it is not POK), or if the encoding |
14030
|
|
|
|
|
|
is not a reference, nothing is done to the sv. If the encoding is not |
14031
|
|
|
|
|
|
an C Encoding object, bad things will happen. |
14032
|
|
|
|
|
|
(See F and L.) |
14033
|
|
|
|
|
|
|
14034
|
|
|
|
|
|
The PV of the sv is returned. |
14035
|
|
|
|
|
|
|
14036
|
|
|
|
|
|
=cut */ |
14037
|
|
|
|
|
|
|
14038
|
|
|
|
|
|
char * |
14039
|
185856
|
|
|
|
|
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) |
14040
|
|
|
|
|
|
{ |
14041
|
|
|
|
|
|
dVAR; |
14042
|
|
|
|
|
|
|
14043
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; |
14044
|
|
|
|
|
|
|
14045
|
371678
|
100
|
|
|
|
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
14046
|
|
|
|
|
|
SV *uni; |
14047
|
|
|
|
|
|
STRLEN len; |
14048
|
|
|
|
|
|
const char *s; |
14049
|
185822
|
|
|
|
|
dSP; |
14050
|
185822
|
|
|
|
|
ENTER; |
14051
|
185822
|
|
|
|
|
SAVETMPS; |
14052
|
185822
|
|
|
|
|
save_re_context(); |
14053
|
185822
|
50
|
|
|
|
PUSHMARK(sp); |
14054
|
92911
|
|
|
|
|
EXTEND(SP, 3); |
14055
|
185822
|
|
|
|
|
PUSHs(encoding); |
14056
|
185822
|
|
|
|
|
PUSHs(sv); |
14057
|
|
|
|
|
|
/* |
14058
|
|
|
|
|
|
NI-S 2002/07/09 |
14059
|
|
|
|
|
|
Passing sv_yes is wrong - it needs to be or'ed set of constants |
14060
|
|
|
|
|
|
for Encode::XS, while UTf-8 decode (currently) assumes a true value means |
14061
|
|
|
|
|
|
remove converted chars from source. |
14062
|
|
|
|
|
|
|
14063
|
|
|
|
|
|
Both will default the value - let them. |
14064
|
|
|
|
|
|
|
14065
|
|
|
|
|
|
XPUSHs(&PL_sv_yes); |
14066
|
|
|
|
|
|
*/ |
14067
|
185822
|
|
|
|
|
PUTBACK; |
14068
|
185822
|
|
|
|
|
call_method("decode", G_SCALAR); |
14069
|
185818
|
|
|
|
|
SPAGAIN; |
14070
|
185818
|
|
|
|
|
uni = POPs; |
14071
|
185818
|
|
|
|
|
PUTBACK; |
14072
|
185818
|
50
|
|
|
|
s = SvPV_const(uni, len); |
14073
|
185818
|
50
|
|
|
|
if (s != SvPVX_const(sv)) { |
14074
|
185818
|
100
|
|
|
|
SvGROW(sv, len + 1); |
|
|
50
|
|
|
|
|
14075
|
185818
|
|
|
|
|
Move(s, SvPVX(sv), len + 1, char); |
14076
|
185818
|
|
|
|
|
SvCUR_set(sv, len); |
14077
|
|
|
|
|
|
} |
14078
|
185818
|
50
|
|
|
|
FREETMPS; |
14079
|
185818
|
|
|
|
|
LEAVE; |
14080
|
185818
|
100
|
|
|
|
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { |
|
|
100
|
|
|
|
|
14081
|
|
|
|
|
|
/* clear pos and any utf8 cache */ |
14082
|
94
|
|
|
|
|
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); |
14083
|
94
|
50
|
|
|
|
if (mg) |
14084
|
0
|
|
|
|
|
mg->mg_len = -1; |
14085
|
94
|
50
|
|
|
|
if ((mg = mg_find(sv, PERL_MAGIC_utf8))) |
14086
|
94
|
|
|
|
|
magic_setutf8(sv,mg); /* clear UTF8 cache */ |
14087
|
|
|
|
|
|
} |
14088
|
185818
|
|
|
|
|
SvUTF8_on(sv); |
14089
|
185818
|
|
|
|
|
return SvPVX(sv); |
14090
|
|
|
|
|
|
} |
14091
|
92943
|
100
|
|
|
|
return SvPOKp(sv) ? SvPVX(sv) : NULL; |
14092
|
|
|
|
|
|
} |
14093
|
|
|
|
|
|
|
14094
|
|
|
|
|
|
/* |
14095
|
|
|
|
|
|
=for apidoc sv_cat_decode |
14096
|
|
|
|
|
|
|
14097
|
|
|
|
|
|
The encoding is assumed to be an Encode object, the PV of the ssv is |
14098
|
|
|
|
|
|
assumed to be octets in that encoding and decoding the input starts |
14099
|
|
|
|
|
|
from the position which (PV + *offset) pointed to. The dsv will be |
14100
|
|
|
|
|
|
concatenated the decoded UTF-8 string from ssv. Decoding will terminate |
14101
|
|
|
|
|
|
when the string tstr appears in decoding output or the input ends on |
14102
|
|
|
|
|
|
the PV of the ssv. The value which the offset points will be modified |
14103
|
|
|
|
|
|
to the last input position on the ssv. |
14104
|
|
|
|
|
|
|
14105
|
|
|
|
|
|
Returns TRUE if the terminator was found, else returns FALSE. |
14106
|
|
|
|
|
|
|
14107
|
|
|
|
|
|
=cut */ |
14108
|
|
|
|
|
|
|
14109
|
|
|
|
|
|
bool |
14110
|
1692
|
|
|
|
|
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, |
14111
|
|
|
|
|
|
SV *ssv, int *offset, char *tstr, int tlen) |
14112
|
|
|
|
|
|
{ |
14113
|
|
|
|
|
|
dVAR; |
14114
|
|
|
|
|
|
bool ret = FALSE; |
14115
|
|
|
|
|
|
|
14116
|
|
|
|
|
|
PERL_ARGS_ASSERT_SV_CAT_DECODE; |
14117
|
|
|
|
|
|
|
14118
|
3384
|
50
|
|
|
|
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
14119
|
|
|
|
|
|
SV *offsv; |
14120
|
1692
|
|
|
|
|
dSP; |
14121
|
1692
|
|
|
|
|
ENTER; |
14122
|
1692
|
|
|
|
|
SAVETMPS; |
14123
|
1692
|
|
|
|
|
save_re_context(); |
14124
|
1692
|
50
|
|
|
|
PUSHMARK(sp); |
14125
|
846
|
|
|
|
|
EXTEND(SP, 6); |
14126
|
1692
|
|
|
|
|
PUSHs(encoding); |
14127
|
1692
|
|
|
|
|
PUSHs(dsv); |
14128
|
1692
|
|
|
|
|
PUSHs(ssv); |
14129
|
1692
|
|
|
|
|
offsv = newSViv(*offset); |
14130
|
1692
|
|
|
|
|
mPUSHs(offsv); |
14131
|
1692
|
|
|
|
|
mPUSHp(tstr, tlen); |
14132
|
1692
|
|
|
|
|
PUTBACK; |
14133
|
1692
|
|
|
|
|
call_method("cat_decode", G_SCALAR); |
14134
|
1692
|
|
|
|
|
SPAGAIN; |
14135
|
1692
|
50
|
|
|
|
ret = SvTRUE(TOPs); |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
14136
|
1692
|
50
|
|
|
|
*offset = SvIV(offsv); |
14137
|
1692
|
|
|
|
|
PUTBACK; |
14138
|
1692
|
50
|
|
|
|
FREETMPS; |
14139
|
1692
|
|
|
|
|
LEAVE; |
14140
|
|
|
|
|
|
} |
14141
|
|
|
|
|
|
else |
14142
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); |
14143
|
1692
|
|
|
|
|
return ret; |
14144
|
|
|
|
|
|
|
14145
|
|
|
|
|
|
} |
14146
|
|
|
|
|
|
|
14147
|
|
|
|
|
|
/* --------------------------------------------------------------------- |
14148
|
|
|
|
|
|
* |
14149
|
|
|
|
|
|
* support functions for report_uninit() |
14150
|
|
|
|
|
|
*/ |
14151
|
|
|
|
|
|
|
14152
|
|
|
|
|
|
/* the maxiumum size of array or hash where we will scan looking |
14153
|
|
|
|
|
|
* for the undefined element that triggered the warning */ |
14154
|
|
|
|
|
|
|
14155
|
|
|
|
|
|
#define FUV_MAX_SEARCH_SIZE 1000 |
14156
|
|
|
|
|
|
|
14157
|
|
|
|
|
|
/* Look for an entry in the hash whose value has the same SV as val; |
14158
|
|
|
|
|
|
* If so, return a mortal copy of the key. */ |
14159
|
|
|
|
|
|
|
14160
|
|
|
|
|
|
STATIC SV* |
14161
|
82
|
|
|
|
|
S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) |
14162
|
|
|
|
|
|
{ |
14163
|
|
|
|
|
|
dVAR; |
14164
|
|
|
|
|
|
HE **array; |
14165
|
|
|
|
|
|
I32 i; |
14166
|
|
|
|
|
|
|
14167
|
|
|
|
|
|
PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; |
14168
|
|
|
|
|
|
|
14169
|
115
|
50
|
|
|
|
if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
14170
|
66
|
|
|
|
|
(HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) |
14171
|
|
|
|
|
|
return NULL; |
14172
|
|
|
|
|
|
|
14173
|
62
|
|
|
|
|
array = HvARRAY(hv); |
14174
|
|
|
|
|
|
|
14175
|
297
|
50
|
|
|
|
for (i=HvMAX(hv); i>=0; i--) { |
14176
|
|
|
|
|
|
HE *entry; |
14177
|
268
|
100
|
|
|
|
for (entry = array[i]; entry; entry = HeNEXT(entry)) { |
14178
|
74
|
100
|
|
|
|
if (HeVAL(entry) != val) |
14179
|
12
|
|
|
|
|
continue; |
14180
|
93
|
50
|
|
|
|
if ( HeVAL(entry) == &PL_sv_undef || |
|
|
50
|
|
|
|
|
14181
|
62
|
|
|
|
|
HeVAL(entry) == &PL_sv_placeholder) |
14182
|
0
|
|
|
|
|
continue; |
14183
|
62
|
50
|
|
|
|
if (!HeKEY(entry)) |
14184
|
|
|
|
|
|
return NULL; |
14185
|
62
|
50
|
|
|
|
if (HeKLEN(entry) == HEf_SVKEY) |
14186
|
0
|
|
|
|
|
return sv_mortalcopy(HeKEY_sv(entry)); |
14187
|
62
|
|
|
|
|
return sv_2mortal(newSVhek(HeKEY_hek(entry))); |
14188
|
|
|
|
|
|
} |
14189
|
|
|
|
|
|
} |
14190
|
|
|
|
|
|
return NULL; |
14191
|
|
|
|
|
|
} |
14192
|
|
|
|
|
|
|
14193
|
|
|
|
|
|
/* Look for an entry in the array whose value has the same SV as val; |
14194
|
|
|
|
|
|
* If so, return the index, otherwise return -1. */ |
14195
|
|
|
|
|
|
|
14196
|
|
|
|
|
|
STATIC I32 |
14197
|
|
|
|
|
|
S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) |
14198
|
|
|
|
|
|
{ |
14199
|
|
|
|
|
|
dVAR; |
14200
|
|
|
|
|
|
|
14201
|
|
|
|
|
|
PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; |
14202
|
|
|
|
|
|
|
14203
|
75
|
50
|
|
|
|
if (!av || SvMAGICAL(av) || !AvARRAY(av) || |
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
14204
|
30
|
|
|
|
|
(AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) |
14205
|
|
|
|
|
|
return -1; |
14206
|
|
|
|
|
|
|
14207
|
30
|
50
|
|
|
|
if (val != &PL_sv_undef) { |
|
|
50
|
|
|
|
|
14208
|
30
|
|
|
|
|
SV ** const svp = AvARRAY(av); |
14209
|
|
|
|
|
|
I32 i; |
14210
|
|
|
|
|
|
|
14211
|
2468
|
100
|
|
|
|
for (i=AvFILLp(av); i>=0; i--) |
|
|
50
|
|
|
|
|
14212
|
2464
|
100
|
|
|
|
if (svp[i] == val) |
|
|
100
|
|
|
|
|
14213
|
|
|
|
|
|
return i; |
14214
|
|
|
|
|
|
} |
14215
|
|
|
|
|
|
return -1; |
14216
|
|
|
|
|
|
} |
14217
|
|
|
|
|
|
|
14218
|
|
|
|
|
|
/* varname(): return the name of a variable, optionally with a subscript. |
14219
|
|
|
|
|
|
* If gv is non-zero, use the name of that global, along with gvtype (one |
14220
|
|
|
|
|
|
* of "$", "@", "%"); otherwise use the name of the lexical at pad offset |
14221
|
|
|
|
|
|
* targ. Depending on the value of the subscript_type flag, return: |
14222
|
|
|
|
|
|
*/ |
14223
|
|
|
|
|
|
|
14224
|
|
|
|
|
|
#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ |
14225
|
|
|
|
|
|
#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ |
14226
|
|
|
|
|
|
#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ |
14227
|
|
|
|
|
|
#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ |
14228
|
|
|
|
|
|
|
14229
|
|
|
|
|
|
SV* |
14230
|
2710
|
|
|
|
|
Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, |
14231
|
|
|
|
|
|
const SV *const keyname, I32 aindex, int subscript_type) |
14232
|
|
|
|
|
|
{ |
14233
|
|
|
|
|
|
|
14234
|
2710
|
|
|
|
|
SV * const name = sv_newmortal(); |
14235
|
2710
|
100
|
|
|
|
if (gv && isGV(gv)) { |
|
|
100
|
|
|
|
|
14236
|
|
|
|
|
|
char buffer[2]; |
14237
|
906
|
|
|
|
|
buffer[0] = gvtype; |
14238
|
906
|
|
|
|
|
buffer[1] = 0; |
14239
|
|
|
|
|
|
|
14240
|
|
|
|
|
|
/* as gv_fullname4(), but add literal '^' for $^FOO names */ |
14241
|
|
|
|
|
|
|
14242
|
906
|
|
|
|
|
gv_fullname4(name, gv, buffer, 0); |
14243
|
|
|
|
|
|
|
14244
|
906
|
100
|
|
|
|
if ((unsigned int)SvPVX(name)[1] <= 26) { |
14245
|
4
|
|
|
|
|
buffer[0] = '^'; |
14246
|
4
|
|
|
|
|
buffer[1] = SvPVX(name)[1] + 'A' - 1; |
14247
|
|
|
|
|
|
|
14248
|
|
|
|
|
|
/* Swap the 1 unprintable control character for the 2 byte pretty |
14249
|
|
|
|
|
|
version - ie substr($name, 1, 1) = $buffer; */ |
14250
|
4
|
|
|
|
|
sv_insert(name, 1, 1, buffer, 2); |
14251
|
|
|
|
|
|
} |
14252
|
|
|
|
|
|
} |
14253
|
|
|
|
|
|
else { |
14254
|
1804
|
100
|
|
|
|
CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); |
14255
|
|
|
|
|
|
SV *sv; |
14256
|
|
|
|
|
|
AV *av; |
14257
|
|
|
|
|
|
|
14258
|
|
|
|
|
|
assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); |
14259
|
|
|
|
|
|
|
14260
|
1804
|
50
|
|
|
|
if (!cv || !CvPADLIST(cv)) |
|
|
50
|
|
|
|
|
14261
|
|
|
|
|
|
return NULL; |
14262
|
1804
|
|
|
|
|
av = *PadlistARRAY(CvPADLIST(cv)); |
14263
|
1804
|
|
|
|
|
sv = *av_fetch(av, targ, FALSE); |
14264
|
1804
|
|
|
|
|
sv_setsv_flags(name, sv, 0); |
14265
|
|
|
|
|
|
} |
14266
|
|
|
|
|
|
|
14267
|
2710
|
100
|
|
|
|
if (subscript_type == FUV_SUBSCRIPT_HASH) { |
14268
|
76
|
|
|
|
|
SV * const sv = newSV(0); |
14269
|
76
|
|
|
|
|
*SvPVX(name) = '$'; |
14270
|
114
|
|
|
|
|
Perl_sv_catpvf(aTHX_ name, "{%s}", |
14271
|
152
|
|
|
|
|
pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL, |
14272
|
|
|
|
|
|
PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); |
14273
|
76
|
|
|
|
|
SvREFCNT_dec_NN(sv); |
14274
|
|
|
|
|
|
} |
14275
|
2634
|
100
|
|
|
|
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { |
14276
|
122
|
|
|
|
|
*SvPVX(name) = '$'; |
14277
|
122
|
|
|
|
|
Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); |
14278
|
|
|
|
|
|
} |
14279
|
2512
|
100
|
|
|
|
else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { |
14280
|
|
|
|
|
|
/* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ |
14281
|
1366
|
|
|
|
|
Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); |
14282
|
|
|
|
|
|
} |
14283
|
|
|
|
|
|
|
14284
|
|
|
|
|
|
return name; |
14285
|
|
|
|
|
|
} |
14286
|
|
|
|
|
|
|
14287
|
|
|
|
|
|
|
14288
|
|
|
|
|
|
/* |
14289
|
|
|
|
|
|
=for apidoc find_uninit_var |
14290
|
|
|
|
|
|
|
14291
|
|
|
|
|
|
Find the name of the undefined variable (if any) that caused the operator |
14292
|
|
|
|
|
|
to issue a "Use of uninitialized value" warning. |
14293
|
|
|
|
|
|
If match is true, only return a name if its value matches uninit_sv. |
14294
|
|
|
|
|
|
So roughly speaking, if a unary operator (such as OP_COS) generates a |
14295
|
|
|
|
|
|
warning, then following the direct child of the op may yield an |
14296
|
|
|
|
|
|
OP_PADSV or OP_GV that gives the name of the undefined variable. On the |
14297
|
|
|
|
|
|
other hand, with OP_ADD there are two branches to follow, so we only print |
14298
|
|
|
|
|
|
the variable name if we get an exact match. |
14299
|
|
|
|
|
|
|
14300
|
|
|
|
|
|
The name is returned as a mortal SV. |
14301
|
|
|
|
|
|
|
14302
|
|
|
|
|
|
Assumes that PL_op is the op that originally triggered the error, and that |
14303
|
|
|
|
|
|
PL_comppad/PL_curpad points to the currently executing pad. |
14304
|
|
|
|
|
|
|
14305
|
|
|
|
|
|
=cut |
14306
|
|
|
|
|
|
*/ |
14307
|
|
|
|
|
|
|
14308
|
|
|
|
|
|
STATIC SV * |
14309
|
9816
|
|
|
|
|
S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, |
14310
|
|
|
|
|
|
bool match) |
14311
|
|
|
|
|
|
{ |
14312
|
|
|
|
|
|
dVAR; |
14313
|
|
|
|
|
|
SV *sv; |
14314
|
|
|
|
|
|
const GV *gv; |
14315
|
|
|
|
|
|
const OP *o, *o2, *kid; |
14316
|
|
|
|
|
|
|
14317
|
9816
|
50
|
|
|
|
if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
14318
|
|
|
|
|
|
uninit_sv == &PL_sv_placeholder))) |
14319
|
|
|
|
|
|
return NULL; |
14320
|
|
|
|
|
|
|
14321
|
9408
|
|
|
|
|
switch (obase->op_type) { |
14322
|
|
|
|
|
|
|
14323
|
|
|
|
|
|
case OP_RV2AV: |
14324
|
|
|
|
|
|
case OP_RV2HV: |
14325
|
|
|
|
|
|
case OP_PADAV: |
14326
|
|
|
|
|
|
case OP_PADHV: |
14327
|
|
|
|
|
|
{ |
14328
|
128
|
|
|
|
|
const bool pad = ( obase->op_type == OP_PADAV |
14329
|
|
|
|
|
|
|| obase->op_type == OP_PADHV |
14330
|
64
|
|
|
|
|
|| obase->op_type == OP_PADRANGE |
14331
|
|
|
|
|
|
); |
14332
|
|
|
|
|
|
|
14333
|
128
|
|
|
|
|
const bool hash = ( obase->op_type == OP_PADHV |
14334
|
64
|
|
|
|
|
|| obase->op_type == OP_RV2HV |
14335
|
64
|
100
|
|
|
|
|| (obase->op_type == OP_PADRANGE |
|
|
50
|
|
|
|
|
14336
|
21
|
0
|
|
|
|
&& SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV) |
14337
|
|
|
|
|
|
); |
14338
|
|
|
|
|
|
I32 index = 0; |
14339
|
|
|
|
|
|
SV *keysv = NULL; |
14340
|
|
|
|
|
|
int subscript_type = FUV_SUBSCRIPT_WITHIN; |
14341
|
|
|
|
|
|
|
14342
|
64
|
100
|
|
|
|
if (pad) { /* @lex, %lex */ |
14343
|
30
|
|
|
|
|
sv = PAD_SVl(obase->op_targ); |
14344
|
|
|
|
|
|
gv = NULL; |
14345
|
|
|
|
|
|
} |
14346
|
|
|
|
|
|
else { |
14347
|
34
|
100
|
|
|
|
if (cUNOPx(obase)->op_first->op_type == OP_GV) { |
14348
|
|
|
|
|
|
/* @global, %global */ |
14349
|
16
|
|
|
|
|
gv = cGVOPx_gv(cUNOPx(obase)->op_first); |
14350
|
16
|
50
|
|
|
|
if (!gv) |
14351
|
|
|
|
|
|
break; |
14352
|
16
|
100
|
|
|
|
sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); |
14353
|
|
|
|
|
|
} |
14354
|
18
|
100
|
|
|
|
else if (obase == PL_op) /* @{expr}, %{expr} */ |
14355
|
14
|
|
|
|
|
return find_uninit_var(cUNOPx(obase)->op_first, |
14356
|
|
|
|
|
|
uninit_sv, match); |
14357
|
|
|
|
|
|
else /* @{expr}, %{expr} as a sub-expression */ |
14358
|
|
|
|
|
|
return NULL; |
14359
|
|
|
|
|
|
} |
14360
|
|
|
|
|
|
|
14361
|
|
|
|
|
|
/* attempt to find a match within the aggregate */ |
14362
|
46
|
100
|
|
|
|
if (hash) { |
14363
|
16
|
|
|
|
|
keysv = find_hash_subscript((const HV*)sv, uninit_sv); |
14364
|
16
|
100
|
|
|
|
if (keysv) |
14365
|
|
|
|
|
|
subscript_type = FUV_SUBSCRIPT_HASH; |
14366
|
|
|
|
|
|
} |
14367
|
|
|
|
|
|
else { |
14368
|
|
|
|
|
|
index = find_array_subscript((const AV *)sv, uninit_sv); |
14369
|
30
|
100
|
|
|
|
if (index >= 0) |
14370
|
|
|
|
|
|
subscript_type = FUV_SUBSCRIPT_ARRAY; |
14371
|
|
|
|
|
|
} |
14372
|
|
|
|
|
|
|
14373
|
46
|
100
|
|
|
|
if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) |
|
|
100
|
|
|
|
|
14374
|
|
|
|
|
|
break; |
14375
|
|
|
|
|
|
|
14376
|
30
|
100
|
|
|
|
return varname(gv, hash ? '%' : '@', obase->op_targ, |
14377
|
|
|
|
|
|
keysv, index, subscript_type); |
14378
|
|
|
|
|
|
} |
14379
|
|
|
|
|
|
|
14380
|
|
|
|
|
|
case OP_RV2SV: |
14381
|
14
|
50
|
|
|
|
if (cUNOPx(obase)->op_first->op_type == OP_GV) { |
14382
|
|
|
|
|
|
/* $global */ |
14383
|
0
|
|
|
|
|
gv = cGVOPx_gv(cUNOPx(obase)->op_first); |
14384
|
0
|
0
|
|
|
|
if (!gv || !GvSTASH(gv)) |
|
|
0
|
|
|
|
|
14385
|
|
|
|
|
|
break; |
14386
|
0
|
0
|
|
|
|
if (match && (GvSV(gv) != uninit_sv)) |
|
|
0
|
|
|
|
|
14387
|
|
|
|
|
|
break; |
14388
|
0
|
|
|
|
|
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); |
14389
|
|
|
|
|
|
} |
14390
|
|
|
|
|
|
/* ${expr} */ |
14391
|
14
|
|
|
|
|
return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1); |
14392
|
|
|
|
|
|
|
14393
|
|
|
|
|
|
case OP_PADSV: |
14394
|
2058
|
100
|
|
|
|
if (match && PAD_SVl(obase->op_targ) != uninit_sv) |
|
|
100
|
|
|
|
|
14395
|
|
|
|
|
|
break; |
14396
|
1680
|
|
|
|
|
return varname(NULL, '$', obase->op_targ, |
14397
|
|
|
|
|
|
NULL, 0, FUV_SUBSCRIPT_NONE); |
14398
|
|
|
|
|
|
|
14399
|
|
|
|
|
|
case OP_GVSV: |
14400
|
1084
|
|
|
|
|
gv = cGVOPx_gv(obase); |
14401
|
1084
|
50
|
|
|
|
if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) |
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
14402
|
|
|
|
|
|
break; |
14403
|
786
|
|
|
|
|
return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); |
14404
|
|
|
|
|
|
|
14405
|
|
|
|
|
|
case OP_AELEMFAST_LEX: |
14406
|
28
|
100
|
|
|
|
if (match) { |
14407
|
|
|
|
|
|
SV **svp; |
14408
|
16
|
|
|
|
|
AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); |
14409
|
16
|
50
|
|
|
|
if (!av || SvRMAGICAL(av)) |
|
|
100
|
|
|
|
|
14410
|
|
|
|
|
|
break; |
14411
|
8
|
|
|
|
|
svp = av_fetch(av, (I32)obase->op_private, FALSE); |
14412
|
8
|
100
|
|
|
|
if (!svp || *svp != uninit_sv) |
|
|
100
|
|
|
|
|
14413
|
|
|
|
|
|
break; |
14414
|
|
|
|
|
|
} |
14415
|
16
|
|
|
|
|
return varname(NULL, '$', obase->op_targ, |
14416
|
|
|
|
|
|
NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); |
14417
|
|
|
|
|
|
case OP_AELEMFAST: |
14418
|
|
|
|
|
|
{ |
14419
|
50
|
|
|
|
|
gv = cGVOPx_gv(obase); |
14420
|
50
|
50
|
|
|
|
if (!gv) |
14421
|
|
|
|
|
|
break; |
14422
|
50
|
100
|
|
|
|
if (match) { |
14423
|
|
|
|
|
|
SV **svp; |
14424
|
36
|
|
|
|
|
AV *const av = GvAV(gv); |
14425
|
36
|
50
|
|
|
|
if (!av || SvRMAGICAL(av)) |
|
|
50
|
|
|
|
|
14426
|
|
|
|
|
|
break; |
14427
|
36
|
|
|
|
|
svp = av_fetch(av, (I32)obase->op_private, FALSE); |
14428
|
36
|
100
|
|
|
|
if (!svp || *svp != uninit_sv) |
|
|
100
|
|
|
|
|
14429
|
|
|
|
|
|
break; |
14430
|
|
|
|
|
|
} |
14431
|
46
|
|
|
|
|
return varname(gv, '$', 0, |
14432
|
|
|
|
|
|
NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); |
14433
|
|
|
|
|
|
} |
14434
|
|
|
|
|
|
break; |
14435
|
|
|
|
|
|
|
14436
|
|
|
|
|
|
case OP_EXISTS: |
14437
|
8
|
|
|
|
|
o = cUNOPx(obase)->op_first; |
14438
|
12
|
50
|
|
|
|
if (!o || o->op_type != OP_NULL || |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
14439
|
8
|
|
|
|
|
! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) |
14440
|
|
|
|
|
|
break; |
14441
|
8
|
|
|
|
|
return find_uninit_var(cBINOPo->op_last, uninit_sv, match); |
14442
|
|
|
|
|
|
|
14443
|
|
|
|
|
|
case OP_AELEM: |
14444
|
|
|
|
|
|
case OP_HELEM: |
14445
|
|
|
|
|
|
{ |
14446
|
|
|
|
|
|
bool negate = FALSE; |
14447
|
|
|
|
|
|
|
14448
|
206
|
100
|
|
|
|
if (PL_op == obase) |
14449
|
|
|
|
|
|
/* $a[uninit_expr] or $h{uninit_expr} */ |
14450
|
20
|
|
|
|
|
return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); |
14451
|
|
|
|
|
|
|
14452
|
|
|
|
|
|
gv = NULL; |
14453
|
186
|
|
|
|
|
o = cBINOPx(obase)->op_first; |
14454
|
186
|
|
|
|
|
kid = cBINOPx(obase)->op_last; |
14455
|
|
|
|
|
|
|
14456
|
|
|
|
|
|
/* get the av or hv, and optionally the gv */ |
14457
|
|
|
|
|
|
sv = NULL; |
14458
|
186
|
100
|
|
|
|
if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { |
14459
|
124
|
|
|
|
|
sv = PAD_SV(o->op_targ); |
14460
|
|
|
|
|
|
} |
14461
|
62
|
50
|
|
|
|
else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) |
14462
|
62
|
50
|
|
|
|
&& cUNOPo->op_first->op_type == OP_GV) |
14463
|
|
|
|
|
|
{ |
14464
|
62
|
|
|
|
|
gv = cGVOPx_gv(cUNOPo->op_first); |
14465
|
62
|
50
|
|
|
|
if (!gv) |
14466
|
|
|
|
|
|
break; |
14467
|
|
|
|
|
|
sv = o->op_type |
14468
|
62
|
100
|
|
|
|
== OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); |
14469
|
|
|
|
|
|
} |
14470
|
186
|
50
|
|
|
|
if (!sv) |
14471
|
|
|
|
|
|
break; |
14472
|
|
|
|
|
|
|
14473
|
186
|
50
|
|
|
|
if (kid && kid->op_type == OP_NEGATE) { |
|
|
50
|
|
|
|
|
14474
|
|
|
|
|
|
negate = TRUE; |
14475
|
0
|
|
|
|
|
kid = cUNOPx(kid)->op_first; |
14476
|
|
|
|
|
|
} |
14477
|
|
|
|
|
|
|
14478
|
186
|
50
|
|
|
|
if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { |
|
|
100
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
14479
|
|
|
|
|
|
/* index is constant */ |
14480
|
|
|
|
|
|
SV* kidsv; |
14481
|
90
|
50
|
|
|
|
if (negate) { |
14482
|
0
|
|
|
|
|
kidsv = sv_2mortal(newSVpvs("-")); |
14483
|
0
|
|
|
|
|
sv_catsv(kidsv, cSVOPx_sv(kid)); |
14484
|
|
|
|
|
|
} |
14485
|
|
|
|
|
|
else |
14486
|
90
|
|
|
|
|
kidsv = cSVOPx_sv(kid); |
14487
|
90
|
100
|
|
|
|
if (match) { |
14488
|
66
|
100
|
|
|
|
if (SvMAGICAL(sv)) |
14489
|
|
|
|
|
|
break; |
14490
|
50
|
100
|
|
|
|
if (obase->op_type == OP_HELEM) { |
14491
|
12
|
|
|
|
|
HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0); |
14492
|
12
|
50
|
|
|
|
if (!he || HeVAL(he) != uninit_sv) |
|
|
100
|
|
|
|
|
14493
|
|
|
|
|
|
break; |
14494
|
|
|
|
|
|
} |
14495
|
|
|
|
|
|
else { |
14496
|
38
|
|
|
|
|
SV * const opsv = cSVOPx_sv(kid); |
14497
|
38
|
50
|
|
|
|
const IV opsviv = SvIV(opsv); |
14498
|
38
|
50
|
|
|
|
SV * const * const svp = av_fetch(MUTABLE_AV(sv), |
14499
|
|
|
|
|
|
negate ? - opsviv : opsviv, |
14500
|
|
|
|
|
|
FALSE); |
14501
|
38
|
100
|
|
|
|
if (!svp || *svp != uninit_sv) |
|
|
100
|
|
|
|
|
14502
|
|
|
|
|
|
break; |
14503
|
|
|
|
|
|
} |
14504
|
|
|
|
|
|
} |
14505
|
48
|
100
|
|
|
|
if (obase->op_type == OP_HELEM) |
14506
|
14
|
|
|
|
|
return varname(gv, '%', o->op_targ, |
14507
|
|
|
|
|
|
kidsv, 0, FUV_SUBSCRIPT_HASH); |
14508
|
|
|
|
|
|
else |
14509
|
34
|
50
|
|
|
|
return varname(gv, '@', o->op_targ, NULL, |
|
|
0
|
|
|
|
|
|
|
50
|
|
|
|
|
14510
|
|
|
|
|
|
negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), |
14511
|
|
|
|
|
|
FUV_SUBSCRIPT_ARRAY); |
14512
|
|
|
|
|
|
} |
14513
|
|
|
|
|
|
else { |
14514
|
|
|
|
|
|
/* index is an expression; |
14515
|
|
|
|
|
|
* attempt to find a match within the aggregate */ |
14516
|
96
|
100
|
|
|
|
if (obase->op_type == OP_HELEM) { |
14517
|
66
|
|
|
|
|
SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); |
14518
|
66
|
100
|
|
|
|
if (keysv) |
14519
|
52
|
|
|
|
|
return varname(gv, '%', o->op_targ, |
14520
|
|
|
|
|
|
keysv, 0, FUV_SUBSCRIPT_HASH); |
14521
|
|
|
|
|
|
} |
14522
|
|
|
|
|
|
else { |
14523
|
|
|
|
|
|
const I32 index |
14524
|
|
|
|
|
|
= find_array_subscript((const AV *)sv, uninit_sv); |
14525
|
30
|
100
|
|
|
|
if (index >= 0) |
14526
|
10
|
|
|
|
|
return varname(gv, '@', o->op_targ, |
14527
|
|
|
|
|
|
NULL, index, FUV_SUBSCRIPT_ARRAY); |
14528
|
|
|
|
|
|
} |
14529
|
34
|
100
|
|
|
|
if (match) |
14530
|
|
|
|
|
|
break; |
14531
|
18
|
100
|
|
|
|
return varname(gv, |
14532
|
|
|
|
|
|
(o->op_type == OP_PADAV || o->op_type == OP_RV2AV) |
14533
|
|
|
|
|
|
? '@' : '%', |
14534
|
|
|
|
|
|
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); |
14535
|
|
|
|
|
|
} |
14536
|
|
|
|
|
|
break; |
14537
|
|
|
|
|
|
} |
14538
|
|
|
|
|
|
|
14539
|
|
|
|
|
|
case OP_AASSIGN: |
14540
|
|
|
|
|
|
/* only examine RHS */ |
14541
|
2
|
|
|
|
|
return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); |
14542
|
|
|
|
|
|
|
14543
|
|
|
|
|
|
case OP_OPEN: |
14544
|
16
|
|
|
|
|
o = cUNOPx(obase)->op_first; |
14545
|
16
|
50
|
|
|
|
if ( o->op_type == OP_PUSHMARK |
14546
|
0
|
0
|
|
|
|
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) |
|
|
0
|
|
|
|
|
14547
|
|
|
|
|
|
) |
14548
|
16
|
|
|
|
|
o = o->op_sibling; |
14549
|
|
|
|
|
|
|
14550
|
16
|
100
|
|
|
|
if (!o->op_sibling) { |
14551
|
|
|
|
|
|
/* one-arg version of open is highly magical */ |
14552
|
|
|
|
|
|
|
14553
|
8
|
100
|
|
|
|
if (o->op_type == OP_GV) { /* open FOO; */ |
14554
|
2
|
|
|
|
|
gv = cGVOPx_gv(o); |
14555
|
2
|
50
|
|
|
|
if (match && GvSV(gv) != uninit_sv) |
|
|
0
|
|
|
|
|
14556
|
|
|
|
|
|
break; |
14557
|
2
|
|
|
|
|
return varname(gv, '$', 0, |
14558
|
|
|
|
|
|
NULL, 0, FUV_SUBSCRIPT_NONE); |
14559
|
|
|
|
|
|
} |
14560
|
|
|
|
|
|
/* other possibilities not handled are: |
14561
|
|
|
|
|
|
* open $x; or open my $x; should return '${*$x}' |
14562
|
|
|
|
|
|
* open expr; should return '$'.expr ideally |
14563
|
|
|
|
|
|
*/ |
14564
|
|
|
|
|
|
break; |
14565
|
|
|
|
|
|
} |
14566
|
|
|
|
|
|
goto do_op; |
14567
|
|
|
|
|
|
|
14568
|
|
|
|
|
|
/* ops where $_ may be an implicit arg */ |
14569
|
|
|
|
|
|
case OP_TRANS: |
14570
|
|
|
|
|
|
case OP_TRANSR: |
14571
|
|
|
|
|
|
case OP_SUBST: |
14572
|
|
|
|
|
|
case OP_MATCH: |
14573
|
1026
|
100
|
|
|
|
if ( !(obase->op_flags & OPf_STACKED)) { |
14574
|
75
|
50
|
|
|
|
if (uninit_sv == ((obase->op_private & OPpTARGET_MY) |
14575
|
24
|
|
|
|
|
? PAD_SVl(obase->op_targ) |
14576
|
62
|
100
|
|
|
|
: DEFSV)) |
|
|
50
|
|
|
|
|
14577
|
|
|
|
|
|
{ |
14578
|
50
|
|
|
|
|
sv = sv_newmortal(); |
14579
|
50
|
|
|
|
|
sv_setpvs(sv, "$_"); |
14580
|
50
|
|
|
|
|
return sv; |
14581
|
|
|
|
|
|
} |
14582
|
|
|
|
|
|
} |
14583
|
|
|
|
|
|
goto do_op; |
14584
|
|
|
|
|
|
|
14585
|
|
|
|
|
|
case OP_PRTF: |
14586
|
|
|
|
|
|
case OP_PRINT: |
14587
|
|
|
|
|
|
case OP_SAY: |
14588
|
|
|
|
|
|
match = 1; /* print etc can return undef on defined args */ |
14589
|
|
|
|
|
|
/* skip filehandle as it can't produce 'undef' warning */ |
14590
|
146
|
|
|
|
|
o = cUNOPx(obase)->op_first; |
14591
|
146
|
100
|
|
|
|
if ((obase->op_flags & OPf_STACKED) |
14592
|
38
|
50
|
|
|
|
&& |
14593
|
38
|
|
|
|
|
( o->op_type == OP_PUSHMARK |
14594
|
0
|
0
|
|
|
|
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK))) |
|
|
0
|
|
|
|
|
14595
|
38
|
|
|
|
|
o = o->op_sibling->op_sibling; |
14596
|
|
|
|
|
|
goto do_op2; |
14597
|
|
|
|
|
|
|
14598
|
|
|
|
|
|
|
14599
|
|
|
|
|
|
case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ |
14600
|
|
|
|
|
|
case OP_CUSTOM: /* XS or custom code could trigger random warnings */ |
14601
|
|
|
|
|
|
|
14602
|
|
|
|
|
|
/* the following ops are capable of returning PL_sv_undef even for |
14603
|
|
|
|
|
|
* defined arg(s) */ |
14604
|
|
|
|
|
|
|
14605
|
|
|
|
|
|
case OP_BACKTICK: |
14606
|
|
|
|
|
|
case OP_PIPE_OP: |
14607
|
|
|
|
|
|
case OP_FILENO: |
14608
|
|
|
|
|
|
case OP_BINMODE: |
14609
|
|
|
|
|
|
case OP_TIED: |
14610
|
|
|
|
|
|
case OP_GETC: |
14611
|
|
|
|
|
|
case OP_SYSREAD: |
14612
|
|
|
|
|
|
case OP_SEND: |
14613
|
|
|
|
|
|
case OP_IOCTL: |
14614
|
|
|
|
|
|
case OP_SOCKET: |
14615
|
|
|
|
|
|
case OP_SOCKPAIR: |
14616
|
|
|
|
|
|
case OP_BIND: |
14617
|
|
|
|
|
|
case OP_CONNECT: |
14618
|
|
|
|
|
|
case OP_LISTEN: |
14619
|
|
|
|
|
|
case OP_ACCEPT: |
14620
|
|
|
|
|
|
case OP_SHUTDOWN: |
14621
|
|
|
|
|
|
case OP_SSOCKOPT: |
14622
|
|
|
|
|
|
case OP_GETPEERNAME: |
14623
|
|
|
|
|
|
case OP_FTRREAD: |
14624
|
|
|
|
|
|
case OP_FTRWRITE: |
14625
|
|
|
|
|
|
case OP_FTREXEC: |
14626
|
|
|
|
|
|
case OP_FTROWNED: |
14627
|
|
|
|
|
|
case OP_FTEREAD: |
14628
|
|
|
|
|
|
case OP_FTEWRITE: |
14629
|
|
|
|
|
|
case OP_FTEEXEC: |
14630
|
|
|
|
|
|
case OP_FTEOWNED: |
14631
|
|
|
|
|
|
case OP_FTIS: |
14632
|
|
|
|
|
|
case OP_FTZERO: |
14633
|
|
|
|
|
|
case OP_FTSIZE: |
14634
|
|
|
|
|
|
case OP_FTFILE: |
14635
|
|
|
|
|
|
case OP_FTDIR: |
14636
|
|
|
|
|
|
case OP_FTLINK: |
14637
|
|
|
|
|
|
case OP_FTPIPE: |
14638
|
|
|
|
|
|
case OP_FTSOCK: |
14639
|
|
|
|
|
|
case OP_FTBLK: |
14640
|
|
|
|
|
|
case OP_FTCHR: |
14641
|
|
|
|
|
|
case OP_FTTTY: |
14642
|
|
|
|
|
|
case OP_FTSUID: |
14643
|
|
|
|
|
|
case OP_FTSGID: |
14644
|
|
|
|
|
|
case OP_FTSVTX: |
14645
|
|
|
|
|
|
case OP_FTTEXT: |
14646
|
|
|
|
|
|
case OP_FTBINARY: |
14647
|
|
|
|
|
|
case OP_FTMTIME: |
14648
|
|
|
|
|
|
case OP_FTATIME: |
14649
|
|
|
|
|
|
case OP_FTCTIME: |
14650
|
|
|
|
|
|
case OP_READLINK: |
14651
|
|
|
|
|
|
case OP_OPEN_DIR: |
14652
|
|
|
|
|
|
case OP_READDIR: |
14653
|
|
|
|
|
|
case OP_TELLDIR: |
14654
|
|
|
|
|
|
case OP_SEEKDIR: |
14655
|
|
|
|
|
|
case OP_REWINDDIR: |
14656
|
|
|
|
|
|
case OP_CLOSEDIR: |
14657
|
|
|
|
|
|
case OP_GMTIME: |
14658
|
|
|
|
|
|
case OP_ALARM: |
14659
|
|
|
|
|
|
case OP_SEMGET: |
14660
|
|
|
|
|
|
case OP_GETLOGIN: |
14661
|
|
|
|
|
|
case OP_UNDEF: |
14662
|
|
|
|
|
|
case OP_SUBSTR: |
14663
|
|
|
|
|
|
case OP_AEACH: |
14664
|
|
|
|
|
|
case OP_EACH: |
14665
|
|
|
|
|
|
case OP_SORT: |
14666
|
|
|
|
|
|
case OP_CALLER: |
14667
|
|
|
|
|
|
case OP_DOFILE: |
14668
|
|
|
|
|
|
case OP_PROTOTYPE: |
14669
|
|
|
|
|
|
case OP_NCMP: |
14670
|
|
|
|
|
|
case OP_SMARTMATCH: |
14671
|
|
|
|
|
|
case OP_UNPACK: |
14672
|
|
|
|
|
|
case OP_SYSOPEN: |
14673
|
|
|
|
|
|
case OP_SYSSEEK: |
14674
|
|
|
|
|
|
match = 1; |
14675
|
292
|
|
|
|
|
goto do_op; |
14676
|
|
|
|
|
|
|
14677
|
|
|
|
|
|
case OP_ENTERSUB: |
14678
|
|
|
|
|
|
case OP_GOTO: |
14679
|
|
|
|
|
|
/* XXX tmp hack: these two may call an XS sub, and currently |
14680
|
|
|
|
|
|
XS subs don't have a SUB entry on the context stack, so CV and |
14681
|
|
|
|
|
|
pad determination goes wrong, and BAD things happen. So, just |
14682
|
|
|
|
|
|
don't try to determine the value under those circumstances. |
14683
|
|
|
|
|
|
Need a better fix at dome point. DAPM 11/2007 */ |
14684
|
|
|
|
|
|
break; |
14685
|
|
|
|
|
|
|
14686
|
|
|
|
|
|
case OP_FLIP: |
14687
|
|
|
|
|
|
case OP_FLOP: |
14688
|
|
|
|
|
|
{ |
14689
|
70
|
|
|
|
|
GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); |
14690
|
70
|
100
|
|
|
|
if (gv && GvSV(gv) == uninit_sv) |
|
|
100
|
|
|
|
|
14691
|
22
|
|
|
|
|
return newSVpvs_flags("$.", SVs_TEMP); |
14692
|
|
|
|
|
|
goto do_op; |
14693
|
|
|
|
|
|
} |
14694
|
|
|
|
|
|
|
14695
|
|
|
|
|
|
case OP_POS: |
14696
|
|
|
|
|
|
/* def-ness of rval pos() is independent of the def-ness of its arg */ |
14697
|
12
|
100
|
|
|
|
if ( !(obase->op_flags & OPf_MOD)) |
14698
|
|
|
|
|
|
break; |
14699
|
|
|
|
|
|
|
14700
|
|
|
|
|
|
case OP_SCHOMP: |
14701
|
|
|
|
|
|
case OP_CHOMP: |
14702
|
24
|
100
|
|
|
|
if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) |
|
|
100
|
|
|
|
|
14703
|
6
|
|
|
|
|
return newSVpvs_flags("${$/}", SVs_TEMP); |
14704
|
|
|
|
|
|
/*FALLTHROUGH*/ |
14705
|
|
|
|
|
|
|
14706
|
|
|
|
|
|
default: |
14707
|
|
|
|
|
|
do_op: |
14708
|
5632
|
100
|
|
|
|
if (!(obase->op_flags & OPf_KIDS)) |
14709
|
|
|
|
|
|
break; |
14710
|
5260
|
|
|
|
|
o = cUNOPx(obase)->op_first; |
14711
|
|
|
|
|
|
|
14712
|
|
|
|
|
|
do_op2: |
14713
|
5406
|
50
|
|
|
|
if (!o) |
14714
|
|
|
|
|
|
break; |
14715
|
|
|
|
|
|
|
14716
|
|
|
|
|
|
/* This loop checks all the kid ops, skipping any that cannot pos- |
14717
|
|
|
|
|
|
* sibly be responsible for the uninitialized value; i.e., defined |
14718
|
|
|
|
|
|
* constants and ops that return nothing. If there is only one op |
14719
|
|
|
|
|
|
* left that is not skipped, then we *know* it is responsible for |
14720
|
|
|
|
|
|
* the uninitialized value. If there is more than one op left, we |
14721
|
|
|
|
|
|
* have to look for an exact match in the while() loop below. |
14722
|
|
|
|
|
|
* Note that we skip padrange, because the individual pad ops that |
14723
|
|
|
|
|
|
* it replaced are still in the tree, so we work on them instead. |
14724
|
|
|
|
|
|
*/ |
14725
|
|
|
|
|
|
o2 = NULL; |
14726
|
10671
|
100
|
|
|
|
for (kid=o; kid; kid = kid->op_sibling) { |
14727
|
8990
|
50
|
|
|
|
if (kid) { |
14728
|
8990
|
|
|
|
|
const OPCODE type = kid->op_type; |
14729
|
8990
|
100
|
|
|
|
if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) |
|
|
50
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
14730
|
7054
|
100
|
|
|
|
|| (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) |
|
|
100
|
|
|
|
|
14731
|
6816
|
|
|
|
|
|| (type == OP_PUSHMARK) |
14732
|
6816
|
100
|
|
|
|
|| (type == OP_PADRANGE) |
14733
|
|
|
|
|
|
) |
14734
|
2568
|
|
|
|
|
continue; |
14735
|
|
|
|
|
|
} |
14736
|
6422
|
100
|
|
|
|
if (o2) { /* more than one found */ |
14737
|
|
|
|
|
|
o2 = NULL; |
14738
|
|
|
|
|
|
break; |
14739
|
|
|
|
|
|
} |
14740
|
|
|
|
|
|
o2 = kid; |
14741
|
|
|
|
|
|
} |
14742
|
5406
|
100
|
|
|
|
if (o2) |
14743
|
4378
|
|
|
|
|
return find_uninit_var(o2, uninit_sv, match); |
14744
|
|
|
|
|
|
|
14745
|
|
|
|
|
|
/* scan all args */ |
14746
|
7280
|
100
|
|
|
|
while (o) { |
14747
|
2272
|
|
|
|
|
sv = find_uninit_var(o, uninit_sv, 1); |
14748
|
2272
|
100
|
|
|
|
if (sv) |
14749
|
|
|
|
|
|
return sv; |
14750
|
1444
|
|
|
|
|
o = o->op_sibling; |
14751
|
|
|
|
|
|
} |
14752
|
|
|
|
|
|
break; |
14753
|
|
|
|
|
|
} |
14754
|
|
|
|
|
|
return NULL; |
14755
|
|
|
|
|
|
} |
14756
|
|
|
|
|
|
|
14757
|
|
|
|
|
|
|
14758
|
|
|
|
|
|
/* |
14759
|
|
|
|
|
|
=for apidoc report_uninit |
14760
|
|
|
|
|
|
|
14761
|
|
|
|
|
|
Print appropriate "Use of uninitialized variable" warning. |
14762
|
|
|
|
|
|
|
14763
|
|
|
|
|
|
=cut |
14764
|
|
|
|
|
|
*/ |
14765
|
|
|
|
|
|
|
14766
|
|
|
|
|
|
void |
14767
|
3128
|
|
|
|
|
Perl_report_uninit(pTHX_ const SV *uninit_sv) |
14768
|
|
|
|
|
|
{ |
14769
|
|
|
|
|
|
dVAR; |
14770
|
3128
|
50
|
|
|
|
if (PL_op) { |
14771
|
|
|
|
|
|
SV* varname = NULL; |
14772
|
3128
|
100
|
|
|
|
if (uninit_sv && PL_curpad) { |
|
|
100
|
|
|
|
|
14773
|
3108
|
|
|
|
|
varname = find_uninit_var(PL_op, uninit_sv,0); |
14774
|
3108
|
100
|
|
|
|
if (varname) |
14775
|
2766
|
|
|
|
|
sv_insert(varname, 0, 0, " ", 1); |
14776
|
|
|
|
|
|
} |
14777
|
|
|
|
|
|
/* diag_listed_as: Use of uninitialized value%s */ |
14778
|
4692
|
50
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv, |
|
|
100
|
|
|
|
|
14779
|
|
|
|
|
|
SVfARG(varname ? varname : &PL_sv_no), |
14780
|
1564
|
0
|
|
|
|
" in ", OP_DESC(PL_op)); |
14781
|
|
|
|
|
|
} |
14782
|
|
|
|
|
|
else |
14783
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, |
14784
|
|
|
|
|
|
"", "", ""); |
14785
|
1006270
|
|
|
|
|
} |
14786
|
|
|
|
|
|
|
14787
|
|
|
|
|
|
/* |
14788
|
|
|
|
|
|
* Local variables: |
14789
|
|
|
|
|
|
* c-indentation-style: bsd |
14790
|
|
|
|
|
|
* c-basic-offset: 4 |
14791
|
|
|
|
|
|
* indent-tabs-mode: nil |
14792
|
|
|
|
|
|
* End: |
14793
|
|
|
|
|
|
* |
14794
|
|
|
|
|
|
* ex: set ts=8 sts=4 sw=4 et: |
14795
|
|
|
|
|
|
*/ |