Commit | Line | Data |
---|---|---|
5356d32e | 1 | /* sv.c |
79072805 | 2 | * |
1129b882 | 3 | * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, |
83706693 RGS |
4 | * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall |
5 | * and others | |
79072805 LW |
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 | * | |
4ac71550 TC |
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 | /* | |
645c22ef DM |
20 | * |
21 | * | |
5e045b90 AMS |
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. | |
79072805 LW |
28 | */ |
29 | ||
30 | #include "EXTERN.h" | |
864dbfa3 | 31 | #define PERL_IN_SV_C |
79072805 | 32 | #include "perl.h" |
d2f185dc | 33 | #include "regcomp.h" |
9d9a81f0 CB |
34 | #ifdef __VMS |
35 | # include <rms.h> | |
36 | #endif | |
79072805 | 37 | |
2f8ed50e OS |
38 | #ifdef __Lynx__ |
39 | /* Missing proto on LynxOS */ | |
40 | char *gconvert(double, int, int, char *); | |
41 | #endif | |
42 | ||
a4eca1d4 JH |
43 | #ifdef USE_QUADMATH |
44 | # define SNPRINTF_G(nv, buffer, size, ndig) \ | |
45 | quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv)) | |
46 | #else | |
47 | # define SNPRINTF_G(nv, buffer, size, ndig) \ | |
48 | PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer)) | |
49 | #endif | |
50 | ||
9f53080a | 51 | #ifndef SV_COW_THRESHOLD |
e8c6a474 | 52 | # define SV_COW_THRESHOLD 0 /* COW iff len > K */ |
9f53080a FC |
53 | #endif |
54 | #ifndef SV_COWBUF_THRESHOLD | |
e8c6a474 | 55 | # define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */ |
9f53080a FC |
56 | #endif |
57 | #ifndef SV_COW_MAX_WASTE_THRESHOLD | |
e8c6a474 | 58 | # define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */ |
9f53080a FC |
59 | #endif |
60 | #ifndef SV_COWBUF_WASTE_THRESHOLD | |
e8c6a474 | 61 | # define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */ |
9f53080a FC |
62 | #endif |
63 | #ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD | |
e8c6a474 | 64 | # define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */ |
9f53080a FC |
65 | #endif |
66 | #ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD | |
e8c6a474 | 67 | # define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */ |
e8c6a474 YO |
68 | #endif |
69 | /* Work around compiler warnings about unsigned >= THRESHOLD when thres- | |
70 | hold is 0. */ | |
71 | #if SV_COW_THRESHOLD | |
72 | # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD) | |
73 | #else | |
74 | # define GE_COW_THRESHOLD(cur) 1 | |
75 | #endif | |
76 | #if SV_COWBUF_THRESHOLD | |
77 | # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD) | |
78 | #else | |
79 | # define GE_COWBUF_THRESHOLD(cur) 1 | |
80 | #endif | |
81 | #if SV_COW_MAX_WASTE_THRESHOLD | |
82 | # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD) | |
83 | #else | |
84 | # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1 | |
85 | #endif | |
86 | #if SV_COWBUF_WASTE_THRESHOLD | |
87 | # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD) | |
88 | #else | |
89 | # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1 | |
90 | #endif | |
91 | #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD | |
92 | # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur)) | |
93 | #else | |
94 | # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1 | |
95 | #endif | |
96 | #if SV_COWBUF_WASTE_FACTOR_THRESHOLD | |
97 | # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur)) | |
98 | #else | |
99 | # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1 | |
100 | #endif | |
101 | ||
102 | #define CHECK_COW_THRESHOLD(cur,len) (\ | |
103 | GE_COW_THRESHOLD((cur)) && \ | |
104 | GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \ | |
105 | GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \ | |
106 | ) | |
107 | #define CHECK_COWBUF_THRESHOLD(cur,len) (\ | |
108 | GE_COWBUF_THRESHOLD((cur)) && \ | |
109 | GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \ | |
110 | GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \ | |
111 | ) | |
cca0492e | 112 | |
e23c8137 | 113 | #ifdef PERL_UTF8_CACHE_ASSERT |
ab455f60 | 114 | /* if adding more checks watch out for the following tests: |
e23c8137 JH |
115 | * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t |
116 | * lib/utf8.t lib/Unicode/Collate/t/index.t | |
117 | * --jhi | |
118 | */ | |
6f207bd3 | 119 | # define ASSERT_UTF8_CACHE(cache) \ |
ab455f60 NC |
120 | STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ |
121 | assert((cache)[2] <= (cache)[3]); \ | |
122 | assert((cache)[3] <= (cache)[1]);} \ | |
123 | } STMT_END | |
e23c8137 | 124 | #else |
6f207bd3 | 125 | # define ASSERT_UTF8_CACHE(cache) NOOP |
e23c8137 JH |
126 | #endif |
127 | ||
645c22ef DM |
128 | /* ============================================================================ |
129 | ||
130 | =head1 Allocation and deallocation of SVs. | |
d2a0f284 JC |
131 | An SV (or AV, HV, etc.) is allocated in two parts: the head (struct |
132 | sv, av, hv...) contains type and reference count information, and for | |
133 | many types, a pointer to the body (struct xrv, xpv, xpviv...), which | |
134 | contains fields specific to each type. Some types store all they need | |
135 | in the head, so don't have a body. | |
136 | ||
486ec47a | 137 | In all but the most memory-paranoid configurations (ex: PURIFY), heads |
d2a0f284 JC |
138 | and bodies are allocated out of arenas, which by default are |
139 | approximately 4K chunks of memory parcelled up into N heads or bodies. | |
93e68bfb JC |
140 | Sv-bodies are allocated by their sv-type, guaranteeing size |
141 | consistency needed to allocate safely from arrays. | |
142 | ||
d2a0f284 JC |
143 | For SV-heads, the first slot in each arena is reserved, and holds a |
144 | link to the next arena, some flags, and a note of the number of slots. | |
145 | Snaked through each arena chain is a linked list of free items; when | |
146 | this becomes empty, an extra arena is allocated and divided up into N | |
147 | items which are threaded into the free list. | |
148 | ||
149 | SV-bodies are similar, but they use arena-sets by default, which | |
150 | separate the link and info from the arena itself, and reclaim the 1st | |
151 | slot in the arena. SV-bodies are further described later. | |
645c22ef DM |
152 | |
153 | The following global variables are associated with arenas: | |
154 | ||
7fefc6c1 KW |
155 | PL_sv_arenaroot pointer to list of SV arenas |
156 | PL_sv_root pointer to list of free SV structures | |
645c22ef | 157 | |
7fefc6c1 KW |
158 | PL_body_arenas head of linked-list of body arenas |
159 | PL_body_roots[] array of pointers to list of free bodies of svtype | |
160 | arrays are indexed by the svtype needed | |
93e68bfb | 161 | |
d2a0f284 JC |
162 | A few special SV heads are not allocated from an arena, but are |
163 | instead directly created in the interpreter structure, eg PL_sv_undef. | |
93e68bfb JC |
164 | The size of arenas can be changed from the default by setting |
165 | PERL_ARENA_SIZE appropriately at compile time. | |
645c22ef DM |
166 | |
167 | The SV arena serves the secondary purpose of allowing still-live SVs | |
168 | to be located and destroyed during final cleanup. | |
169 | ||
170 | At the lowest level, the macros new_SV() and del_SV() grab and free | |
171 | an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv() | |
172 | to return the SV to the free list with error checking.) new_SV() calls | |
173 | more_sv() / sv_add_arena() to add an extra arena if the free list is empty. | |
174 | SVs in the free list have their SvTYPE field set to all ones. | |
175 | ||
ff276b08 | 176 | At the time of very final cleanup, sv_free_arenas() is called from |
645c22ef | 177 | perl_destruct() to physically free all the arenas allocated since the |
6a93a7e5 | 178 | start of the interpreter. |
645c22ef | 179 | |
645c22ef DM |
180 | The function visit() scans the SV arenas list, and calls a specified |
181 | function for each SV it finds which is still live - ie which has an SvTYPE | |
182 | other than all 1's, and a non-zero SvREFCNT. visit() is used by the | |
183 | following functions (specified as [function that calls visit()] / [function | |
184 | called by visit() for each SV]): | |
185 | ||
186 | sv_report_used() / do_report_used() | |
f2524eef | 187 | dump all remaining SVs (debugging aid) |
645c22ef | 188 | |
e4487e9b | 189 | sv_clean_objs() / do_clean_objs(),do_clean_named_objs(), |
e76981f9 | 190 | do_clean_named_io_objs(),do_curse() |
645c22ef | 191 | Attempt to free all objects pointed to by RVs, |
e76981f9 FC |
192 | try to do the same for all objects indir- |
193 | ectly referenced by typeglobs too, and | |
194 | then do a final sweep, cursing any | |
195 | objects that remain. Called once from | |
645c22ef DM |
196 | perl_destruct(), prior to calling sv_clean_all() |
197 | below. | |
198 | ||
199 | sv_clean_all() / do_clean_all() | |
200 | SvREFCNT_dec(sv) each remaining SV, possibly | |
201 | triggering an sv_free(). It also sets the | |
202 | SVf_BREAK flag on the SV to indicate that the | |
203 | refcnt has been artificially lowered, and thus | |
204 | stopping sv_free() from giving spurious warnings | |
205 | about SVs which unexpectedly have a refcnt | |
206 | of zero. called repeatedly from perl_destruct() | |
207 | until there are no SVs left. | |
208 | ||
93e68bfb | 209 | =head2 Arena allocator API Summary |
645c22ef DM |
210 | |
211 | Private API to rest of sv.c | |
212 | ||
213 | new_SV(), del_SV(), | |
214 | ||
df0f0429 | 215 | new_XPVNV(), del_XPVGV(), |
645c22ef DM |
216 | etc |
217 | ||
218 | Public API: | |
219 | ||
8cf8f3d1 | 220 | sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() |
645c22ef | 221 | |
645c22ef DM |
222 | =cut |
223 | ||
3e8320cc | 224 | * ========================================================================= */ |
645c22ef | 225 | |
4561caa4 CS |
226 | /* |
227 | * "A time to plant, and a time to uproot what was planted..." | |
228 | */ | |
229 | ||
d7a2c63c MHM |
230 | #ifdef PERL_MEM_LOG |
231 | # define MEM_LOG_NEW_SV(sv, file, line, func) \ | |
232 | Perl_mem_log_new_sv(sv, file, line, func) | |
233 | # define MEM_LOG_DEL_SV(sv, file, line, func) \ | |
234 | Perl_mem_log_del_sv(sv, file, line, func) | |
235 | #else | |
236 | # define MEM_LOG_NEW_SV(sv, file, line, func) NOOP | |
237 | # define MEM_LOG_DEL_SV(sv, file, line, func) NOOP | |
238 | #endif | |
239 | ||
fd0854ff | 240 | #ifdef DEBUG_LEAKING_SCALARS |
484e6108 FC |
241 | # define FREE_SV_DEBUG_FILE(sv) STMT_START { \ |
242 | if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ | |
243 | } STMT_END | |
d7a2c63c MHM |
244 | # define DEBUG_SV_SERIAL(sv) \ |
245 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ | |
246 | PTR2UV(sv), (long)(sv)->sv_debug_serial)) | |
fd0854ff DM |
247 | #else |
248 | # define FREE_SV_DEBUG_FILE(sv) | |
d7a2c63c | 249 | # define DEBUG_SV_SERIAL(sv) NOOP |
fd0854ff DM |
250 | #endif |
251 | ||
48614a46 NC |
252 | #ifdef PERL_POISON |
253 | # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) | |
daba3364 | 254 | # define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) |
48614a46 NC |
255 | /* Whilst I'd love to do this, it seems that things like to check on |
256 | unreferenced scalars | |
ce5dbf61 | 257 | # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) |
48614a46 | 258 | */ |
ce5dbf61 | 259 | # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ |
7e337ee0 | 260 | PoisonNew(&SvREFCNT(sv), 1, U32) |
48614a46 NC |
261 | #else |
262 | # define SvARENA_CHAIN(sv) SvANY(sv) | |
3eef1deb | 263 | # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) |
ce5dbf61 | 264 | # define POISON_SV_HEAD(sv) |
48614a46 NC |
265 | #endif |
266 | ||
990198f0 DM |
267 | /* Mark an SV head as unused, and add to free list. |
268 | * | |
269 | * If SVf_BREAK is set, skip adding it to the free list, as this SV had | |
270 | * its refcount artificially decremented during global destruction, so | |
271 | * there may be dangling pointers to it. The last thing we want in that | |
272 | * case is for it to be reused. */ | |
273 | ||
053fc874 GS |
274 | #define plant_SV(p) \ |
275 | STMT_START { \ | |
990198f0 | 276 | const U32 old_flags = SvFLAGS(p); \ |
d7a2c63c MHM |
277 | MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ |
278 | DEBUG_SV_SERIAL(p); \ | |
fd0854ff | 279 | FREE_SV_DEBUG_FILE(p); \ |
ce5dbf61 | 280 | POISON_SV_HEAD(p); \ |
053fc874 | 281 | SvFLAGS(p) = SVTYPEMASK; \ |
990198f0 | 282 | if (!(old_flags & SVf_BREAK)) { \ |
3eef1deb | 283 | SvARENA_CHAIN_SET(p, PL_sv_root); \ |
990198f0 DM |
284 | PL_sv_root = (p); \ |
285 | } \ | |
053fc874 GS |
286 | --PL_sv_count; \ |
287 | } STMT_END | |
a0d0e21e | 288 | |
053fc874 GS |
289 | #define uproot_SV(p) \ |
290 | STMT_START { \ | |
291 | (p) = PL_sv_root; \ | |
daba3364 | 292 | PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ |
053fc874 GS |
293 | ++PL_sv_count; \ |
294 | } STMT_END | |
295 | ||
645c22ef | 296 | |
cac9b346 NC |
297 | /* make some more SVs by adding another arena */ |
298 | ||
cac9b346 NC |
299 | STATIC SV* |
300 | S_more_sv(pTHX) | |
301 | { | |
302 | SV* sv; | |
9a87bd09 NC |
303 | char *chunk; /* must use New here to match call to */ |
304 | Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ | |
305 | sv_add_arena(chunk, PERL_ARENA_SIZE, 0); | |
cac9b346 NC |
306 | uproot_SV(sv); |
307 | return sv; | |
308 | } | |
309 | ||
645c22ef DM |
310 | /* new_SV(): return a new, empty SV head */ |
311 | ||
eba0f806 DM |
312 | #ifdef DEBUG_LEAKING_SCALARS |
313 | /* provide a real function for a debugger to play with */ | |
314 | STATIC SV* | |
d7a2c63c | 315 | S_new_SV(pTHX_ const char *file, int line, const char *func) |
eba0f806 DM |
316 | { |
317 | SV* sv; | |
318 | ||
eba0f806 DM |
319 | if (PL_sv_root) |
320 | uproot_SV(sv); | |
321 | else | |
cac9b346 | 322 | sv = S_more_sv(aTHX); |
eba0f806 DM |
323 | SvANY(sv) = 0; |
324 | SvREFCNT(sv) = 1; | |
325 | SvFLAGS(sv) = 0; | |
fd0854ff | 326 | sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; |
e385c3bf DM |
327 | sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE |
328 | ? PL_parser->copline | |
329 | : PL_curcop | |
f24aceb1 DM |
330 | ? CopLINE(PL_curcop) |
331 | : 0 | |
e385c3bf | 332 | ); |
fd0854ff | 333 | sv->sv_debug_inpad = 0; |
cd676548 | 334 | sv->sv_debug_parent = NULL; |
484e6108 | 335 | sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; |
d7a2c63c MHM |
336 | |
337 | sv->sv_debug_serial = PL_sv_serial++; | |
338 | ||
339 | MEM_LOG_NEW_SV(sv, file, line, func); | |
340 | DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", | |
341 | PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); | |
342 | ||
eba0f806 DM |
343 | return sv; |
344 | } | |
d7a2c63c | 345 | # define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) |
eba0f806 DM |
346 | |
347 | #else | |
348 | # define new_SV(p) \ | |
053fc874 | 349 | STMT_START { \ |
053fc874 GS |
350 | if (PL_sv_root) \ |
351 | uproot_SV(p); \ | |
352 | else \ | |
cac9b346 | 353 | (p) = S_more_sv(aTHX); \ |
053fc874 GS |
354 | SvANY(p) = 0; \ |
355 | SvREFCNT(p) = 1; \ | |
356 | SvFLAGS(p) = 0; \ | |
d7a2c63c | 357 | MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ |
053fc874 | 358 | } STMT_END |
eba0f806 | 359 | #endif |
463ee0b2 | 360 | |
645c22ef DM |
361 | |
362 | /* del_SV(): return an empty SV head to the free list */ | |
363 | ||
a0d0e21e | 364 | #ifdef DEBUGGING |
4561caa4 | 365 | |
053fc874 GS |
366 | #define del_SV(p) \ |
367 | STMT_START { \ | |
aea4f609 | 368 | if (DEBUG_D_TEST) \ |
053fc874 GS |
369 | del_sv(p); \ |
370 | else \ | |
371 | plant_SV(p); \ | |
053fc874 | 372 | } STMT_END |
a0d0e21e | 373 | |
76e3520e | 374 | STATIC void |
cea2e8a9 | 375 | S_del_sv(pTHX_ SV *p) |
463ee0b2 | 376 | { |
7918f24d NC |
377 | PERL_ARGS_ASSERT_DEL_SV; |
378 | ||
aea4f609 | 379 | if (DEBUG_D_TEST) { |
4633a7c4 | 380 | SV* sva; |
a3b680e6 | 381 | bool ok = 0; |
daba3364 | 382 | for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
53c1dcc0 AL |
383 | const SV * const sv = sva + 1; |
384 | const SV * const svend = &sva[SvREFCNT(sva)]; | |
c0ff570e | 385 | if (p >= sv && p < svend) { |
a0d0e21e | 386 | ok = 1; |
c0ff570e NC |
387 | break; |
388 | } | |
a0d0e21e LW |
389 | } |
390 | if (!ok) { | |
9b387841 NC |
391 | Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), |
392 | "Attempt to free non-arena SV: 0x%"UVxf | |
393 | pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); | |
a0d0e21e LW |
394 | return; |
395 | } | |
396 | } | |
4561caa4 | 397 | plant_SV(p); |
463ee0b2 | 398 | } |
a0d0e21e | 399 | |
4561caa4 CS |
400 | #else /* ! DEBUGGING */ |
401 | ||
402 | #define del_SV(p) plant_SV(p) | |
403 | ||
404 | #endif /* DEBUGGING */ | |
463ee0b2 | 405 | |
645c22ef DM |
406 | |
407 | /* | |
ccfc67b7 JH |
408 | =head1 SV Manipulation Functions |
409 | ||
645c22ef DM |
410 | =for apidoc sv_add_arena |
411 | ||
412 | Given a chunk of memory, link it to the head of the list of arenas, | |
413 | and split it into a list of free SVs. | |
414 | ||
415 | =cut | |
416 | */ | |
417 | ||
d2bd4e7f NC |
418 | static void |
419 | S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) | |
463ee0b2 | 420 | { |
daba3364 | 421 | SV *const sva = MUTABLE_SV(ptr); |
eb578fdb KW |
422 | SV* sv; |
423 | SV* svend; | |
4633a7c4 | 424 | |
7918f24d NC |
425 | PERL_ARGS_ASSERT_SV_ADD_ARENA; |
426 | ||
4633a7c4 | 427 | /* The first SV in an arena isn't an SV. */ |
3280af22 | 428 | SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ |
4633a7c4 LW |
429 | SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ |
430 | SvFLAGS(sva) = flags; /* FAKE if not to be freed */ | |
431 | ||
3280af22 NIS |
432 | PL_sv_arenaroot = sva; |
433 | PL_sv_root = sva + 1; | |
4633a7c4 LW |
434 | |
435 | svend = &sva[SvREFCNT(sva) - 1]; | |
436 | sv = sva + 1; | |
463ee0b2 | 437 | while (sv < svend) { |
3eef1deb | 438 | SvARENA_CHAIN_SET(sv, (sv + 1)); |
03e36789 | 439 | #ifdef DEBUGGING |
978b032e | 440 | SvREFCNT(sv) = 0; |
03e36789 | 441 | #endif |
4b69cbe3 | 442 | /* Must always set typemask because it's always checked in on cleanup |
03e36789 | 443 | when the arenas are walked looking for objects. */ |
8990e307 | 444 | SvFLAGS(sv) = SVTYPEMASK; |
463ee0b2 LW |
445 | sv++; |
446 | } | |
3eef1deb | 447 | SvARENA_CHAIN_SET(sv, 0); |
03e36789 NC |
448 | #ifdef DEBUGGING |
449 | SvREFCNT(sv) = 0; | |
450 | #endif | |
4633a7c4 LW |
451 | SvFLAGS(sv) = SVTYPEMASK; |
452 | } | |
453 | ||
055972dc DM |
454 | /* visit(): call the named function for each non-free SV in the arenas |
455 | * whose flags field matches the flags/mask args. */ | |
645c22ef | 456 | |
5226ed68 | 457 | STATIC I32 |
de37a194 | 458 | S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) |
8990e307 | 459 | { |
4633a7c4 | 460 | SV* sva; |
5226ed68 | 461 | I32 visited = 0; |
8990e307 | 462 | |
7918f24d NC |
463 | PERL_ARGS_ASSERT_VISIT; |
464 | ||
daba3364 | 465 | for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { |
eb578fdb KW |
466 | const SV * const svend = &sva[SvREFCNT(sva)]; |
467 | SV* sv; | |
4561caa4 | 468 | for (sv = sva + 1; sv < svend; ++sv) { |
e4787c0c | 469 | if (SvTYPE(sv) != (svtype)SVTYPEMASK |
055972dc DM |
470 | && (sv->sv_flags & mask) == flags |
471 | && SvREFCNT(sv)) | |
472 | { | |
942481a7 | 473 | (*f)(aTHX_ sv); |
5226ed68 JH |
474 | ++visited; |
475 | } | |
8990e307 LW |
476 | } |
477 | } | |
5226ed68 | 478 | return visited; |
8990e307 LW |
479 | } |
480 | ||
758a08c3 JH |
481 | #ifdef DEBUGGING |
482 | ||
645c22ef DM |
483 | /* called by sv_report_used() for each live SV */ |
484 | ||
485 | static void | |
5fa45a31 | 486 | do_report_used(pTHX_ SV *const sv) |
645c22ef | 487 | { |
e4787c0c | 488 | if (SvTYPE(sv) != (svtype)SVTYPEMASK) { |
645c22ef DM |
489 | PerlIO_printf(Perl_debug_log, "****\n"); |
490 | sv_dump(sv); | |
491 | } | |
492 | } | |
758a08c3 | 493 | #endif |
645c22ef DM |
494 | |
495 | /* | |
496 | =for apidoc sv_report_used | |
497 | ||
fde67290 | 498 | Dump the contents of all SVs not yet freed (debugging aid). |
645c22ef DM |
499 | |
500 | =cut | |
501 | */ | |
502 | ||
8990e307 | 503 | void |
864dbfa3 | 504 | Perl_sv_report_used(pTHX) |
4561caa4 | 505 | { |
ff270d3a | 506 | #ifdef DEBUGGING |
055972dc | 507 | visit(do_report_used, 0, 0); |
96a5add6 AL |
508 | #else |
509 | PERL_UNUSED_CONTEXT; | |
ff270d3a | 510 | #endif |
4561caa4 CS |
511 | } |
512 | ||
645c22ef DM |
513 | /* called by sv_clean_objs() for each live SV */ |
514 | ||
515 | static void | |
de37a194 | 516 | do_clean_objs(pTHX_ SV *const ref) |
645c22ef | 517 | { |
ea724faa NC |
518 | assert (SvROK(ref)); |
519 | { | |
823a54a3 AL |
520 | SV * const target = SvRV(ref); |
521 | if (SvOBJECT(target)) { | |
522 | DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); | |
523 | if (SvWEAKREF(ref)) { | |
524 | sv_del_backref(target, ref); | |
525 | SvWEAKREF_off(ref); | |
526 | SvRV_set(ref, NULL); | |
527 | } else { | |
528 | SvROK_off(ref); | |
529 | SvRV_set(ref, NULL); | |
fc2b2dca | 530 | SvREFCNT_dec_NN(target); |
823a54a3 | 531 | } |
645c22ef DM |
532 | } |
533 | } | |
645c22ef DM |
534 | } |
535 | ||
645c22ef | 536 | |
e4487e9b DM |
537 | /* clear any slots in a GV which hold objects - except IO; |
538 | * called by sv_clean_objs() for each live GV */ | |
539 | ||
645c22ef | 540 | static void |
f30de749 | 541 | do_clean_named_objs(pTHX_ SV *const sv) |
645c22ef | 542 | { |
57ef47cc | 543 | SV *obj; |
ea724faa | 544 | assert(SvTYPE(sv) == SVt_PVGV); |
d011219a | 545 | assert(isGV_with_GP(sv)); |
57ef47cc DM |
546 | if (!GvGP(sv)) |
547 | return; | |
548 | ||
549 | /* freeing GP entries may indirectly free the current GV; | |
550 | * hold onto it while we mess with the GP slots */ | |
551 | SvREFCNT_inc(sv); | |
552 | ||
553 | if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { | |
554 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
555 | "Cleaning named glob SV object:\n "), sv_dump(obj))); | |
556 | GvSV(sv) = NULL; | |
fc2b2dca | 557 | SvREFCNT_dec_NN(obj); |
57ef47cc DM |
558 | } |
559 | if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { | |
560 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
561 | "Cleaning named glob AV object:\n "), sv_dump(obj))); | |
562 | GvAV(sv) = NULL; | |
fc2b2dca | 563 | SvREFCNT_dec_NN(obj); |
57ef47cc DM |
564 | } |
565 | if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { | |
566 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
567 | "Cleaning named glob HV object:\n "), sv_dump(obj))); | |
568 | GvHV(sv) = NULL; | |
fc2b2dca | 569 | SvREFCNT_dec_NN(obj); |
57ef47cc DM |
570 | } |
571 | if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { | |
572 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
573 | "Cleaning named glob CV object:\n "), sv_dump(obj))); | |
c43ae56f | 574 | GvCV_set(sv, NULL); |
fc2b2dca | 575 | SvREFCNT_dec_NN(obj); |
57ef47cc | 576 | } |
fc2b2dca | 577 | SvREFCNT_dec_NN(sv); /* undo the inc above */ |
e4487e9b DM |
578 | } |
579 | ||
68b590d9 | 580 | /* clear any IO slots in a GV which hold objects (except stderr, defout); |
e4487e9b DM |
581 | * called by sv_clean_objs() for each live GV */ |
582 | ||
583 | static void | |
584 | do_clean_named_io_objs(pTHX_ SV *const sv) | |
585 | { | |
e4487e9b DM |
586 | SV *obj; |
587 | assert(SvTYPE(sv) == SVt_PVGV); | |
588 | assert(isGV_with_GP(sv)); | |
68b590d9 | 589 | if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv) |
e4487e9b DM |
590 | return; |
591 | ||
592 | SvREFCNT_inc(sv); | |
57ef47cc DM |
593 | if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { |
594 | DEBUG_D((PerlIO_printf(Perl_debug_log, | |
595 | "Cleaning named glob IO object:\n "), sv_dump(obj))); | |
596 | GvIOp(sv) = NULL; | |
fc2b2dca | 597 | SvREFCNT_dec_NN(obj); |
645c22ef | 598 | } |
fc2b2dca | 599 | SvREFCNT_dec_NN(sv); /* undo the inc above */ |
645c22ef | 600 | } |
645c22ef | 601 | |
4155e4fe FC |
602 | /* Void wrapper to pass to visit() */ |
603 | static void | |
604 | do_curse(pTHX_ SV * const sv) { | |
c2910e6c FC |
605 | if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) |
606 | || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) | |
4155e4fe FC |
607 | return; |
608 | (void)curse(sv, 0); | |
609 | } | |
610 | ||
645c22ef DM |
611 | /* |
612 | =for apidoc sv_clean_objs | |
613 | ||
fde67290 | 614 | Attempt to destroy all objects not yet freed. |
645c22ef DM |
615 | |
616 | =cut | |
617 | */ | |
618 | ||
4561caa4 | 619 | void |
864dbfa3 | 620 | Perl_sv_clean_objs(pTHX) |
4561caa4 | 621 | { |
68b590d9 | 622 | GV *olddef, *olderr; |
3280af22 | 623 | PL_in_clean_objs = TRUE; |
055972dc | 624 | visit(do_clean_objs, SVf_ROK, SVf_ROK); |
e4487e9b DM |
625 | /* Some barnacles may yet remain, clinging to typeglobs. |
626 | * Run the non-IO destructors first: they may want to output | |
627 | * error messages, close files etc */ | |
d011219a | 628 | visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); |
e4487e9b | 629 | visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP); |
4155e4fe FC |
630 | /* And if there are some very tenacious barnacles clinging to arrays, |
631 | closures, or what have you.... */ | |
632 | visit(do_curse, SVs_OBJECT, SVs_OBJECT); | |
68b590d9 DM |
633 | olddef = PL_defoutgv; |
634 | PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ | |
635 | if (olddef && isGV_with_GP(olddef)) | |
636 | do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); | |
637 | olderr = PL_stderrgv; | |
638 | PL_stderrgv = NULL; /* disable skip of PL_stderrgv */ | |
639 | if (olderr && isGV_with_GP(olderr)) | |
640 | do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); | |
641 | SvREFCNT_dec(olddef); | |
3280af22 | 642 | PL_in_clean_objs = FALSE; |
4561caa4 CS |
643 | } |
644 | ||
645c22ef DM |
645 | /* called by sv_clean_all() for each live SV */ |
646 | ||
647 | static void | |
de37a194 | 648 | do_clean_all(pTHX_ SV *const sv) |
645c22ef | 649 | { |
daba3364 | 650 | if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { |
cddfcddc | 651 | /* don't clean pid table and strtab */ |
d17ea597 | 652 | return; |
cddfcddc | 653 | } |
645c22ef DM |
654 | DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); |
655 | SvFLAGS(sv) |= SVf_BREAK; | |
fc2b2dca | 656 | SvREFCNT_dec_NN(sv); |
645c22ef DM |
657 | } |
658 | ||
659 | /* | |
660 | =for apidoc sv_clean_all | |
661 | ||
662 | Decrement the refcnt of each remaining SV, possibly triggering a | |
fde67290 | 663 | cleanup. This function may have to be called multiple times to free |
ff276b08 | 664 | SVs which are in complex self-referential hierarchies. |
645c22ef DM |
665 | |
666 | =cut | |
667 | */ | |
668 | ||
5226ed68 | 669 | I32 |
864dbfa3 | 670 | Perl_sv_clean_all(pTHX) |
8990e307 | 671 | { |
5226ed68 | 672 | I32 cleaned; |
3280af22 | 673 | PL_in_clean_all = TRUE; |
055972dc | 674 | cleaned = visit(do_clean_all, 0,0); |
5226ed68 | 675 | return cleaned; |
8990e307 | 676 | } |
463ee0b2 | 677 | |
5e258f8c JC |
678 | /* |
679 | ARENASETS: a meta-arena implementation which separates arena-info | |
680 | into struct arena_set, which contains an array of struct | |
681 | arena_descs, each holding info for a single arena. By separating | |
682 | the meta-info from the arena, we recover the 1st slot, formerly | |
683 | borrowed for list management. The arena_set is about the size of an | |
39244528 | 684 | arena, avoiding the needless malloc overhead of a naive linked-list. |
5e258f8c JC |
685 | |
686 | The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused | |
687 | memory in the last arena-set (1/2 on average). In trade, we get | |
688 | back the 1st slot in each arena (ie 1.7% of a CV-arena, less for | |
d2a0f284 | 689 | smaller types). The recovery of the wasted space allows use of |
e15dad31 JC |
690 | small arenas for large, rare body types, by changing array* fields |
691 | in body_details_by_type[] below. | |
5e258f8c | 692 | */ |
5e258f8c | 693 | struct arena_desc { |
398c677b NC |
694 | char *arena; /* the raw storage, allocated aligned */ |
695 | size_t size; /* its size ~4k typ */ | |
e5973ed5 | 696 | svtype utype; /* bodytype stored in arena */ |
5e258f8c JC |
697 | }; |
698 | ||
e6148039 NC |
699 | struct arena_set; |
700 | ||
701 | /* Get the maximum number of elements in set[] such that struct arena_set | |
e15dad31 | 702 | will fit within PERL_ARENA_SIZE, which is probably just under 4K, and |
e6148039 NC |
703 | therefore likely to be 1 aligned memory page. */ |
704 | ||
705 | #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ | |
706 | - 2 * sizeof(int)) / sizeof (struct arena_desc)) | |
5e258f8c JC |
707 | |
708 | struct arena_set { | |
709 | struct arena_set* next; | |
0a848332 NC |
710 | unsigned int set_size; /* ie ARENAS_PER_SET */ |
711 | unsigned int curr; /* index of next available arena-desc */ | |
5e258f8c JC |
712 | struct arena_desc set[ARENAS_PER_SET]; |
713 | }; | |
714 | ||
645c22ef DM |
715 | /* |
716 | =for apidoc sv_free_arenas | |
717 | ||
fde67290 | 718 | Deallocate the memory used by all arenas. Note that all the individual SV |
645c22ef DM |
719 | heads and bodies within the arenas must already have been freed. |
720 | ||
721 | =cut | |
7fefc6c1 | 722 | |
645c22ef | 723 | */ |
4633a7c4 | 724 | void |
864dbfa3 | 725 | Perl_sv_free_arenas(pTHX) |
4633a7c4 LW |
726 | { |
727 | SV* sva; | |
728 | SV* svanext; | |
0a848332 | 729 | unsigned int i; |
4633a7c4 LW |
730 | |
731 | /* Free arenas here, but be careful about fake ones. (We assume | |
732 | contiguity of the fake ones with the corresponding real ones.) */ | |
733 | ||
3280af22 | 734 | for (sva = PL_sv_arenaroot; sva; sva = svanext) { |
daba3364 | 735 | svanext = MUTABLE_SV(SvANY(sva)); |
4633a7c4 | 736 | while (svanext && SvFAKE(svanext)) |
daba3364 | 737 | svanext = MUTABLE_SV(SvANY(svanext)); |
4633a7c4 LW |
738 | |
739 | if (!SvFAKE(sva)) | |
1df70142 | 740 | Safefree(sva); |
4633a7c4 | 741 | } |
93e68bfb | 742 | |
5e258f8c | 743 | { |
0a848332 NC |
744 | struct arena_set *aroot = (struct arena_set*) PL_body_arenas; |
745 | ||
746 | while (aroot) { | |
747 | struct arena_set *current = aroot; | |
748 | i = aroot->curr; | |
749 | while (i--) { | |
5e258f8c JC |
750 | assert(aroot->set[i].arena); |
751 | Safefree(aroot->set[i].arena); | |
752 | } | |
0a848332 NC |
753 | aroot = aroot->next; |
754 | Safefree(current); | |
5e258f8c JC |
755 | } |
756 | } | |
dc8220bf | 757 | PL_body_arenas = 0; |
fdda85ca | 758 | |
0a848332 NC |
759 | i = PERL_ARENA_ROOTS_SIZE; |
760 | while (i--) | |
93e68bfb | 761 | PL_body_roots[i] = 0; |
93e68bfb | 762 | |
3280af22 NIS |
763 | PL_sv_arenaroot = 0; |
764 | PL_sv_root = 0; | |
4633a7c4 LW |
765 | } |
766 | ||
bd81e77b NC |
767 | /* |
768 | Here are mid-level routines that manage the allocation of bodies out | |
769 | of the various arenas. There are 5 kinds of arenas: | |
29489e7c | 770 | |
bd81e77b NC |
771 | 1. SV-head arenas, which are discussed and handled above |
772 | 2. regular body arenas | |
773 | 3. arenas for reduced-size bodies | |
774 | 4. Hash-Entry arenas | |
29489e7c | 775 | |
bd81e77b NC |
776 | Arena types 2 & 3 are chained by body-type off an array of |
777 | arena-root pointers, which is indexed by svtype. Some of the | |
778 | larger/less used body types are malloced singly, since a large | |
779 | unused block of them is wasteful. Also, several svtypes dont have | |
780 | bodies; the data fits into the sv-head itself. The arena-root | |
781 | pointer thus has a few unused root-pointers (which may be hijacked | |
782 | later for arena types 4,5) | |
29489e7c | 783 | |
bd81e77b NC |
784 | 3 differs from 2 as an optimization; some body types have several |
785 | unused fields in the front of the structure (which are kept in-place | |
786 | for consistency). These bodies can be allocated in smaller chunks, | |
787 | because the leading fields arent accessed. Pointers to such bodies | |
788 | are decremented to point at the unused 'ghost' memory, knowing that | |
789 | the pointers are used with offsets to the real memory. | |
29489e7c | 790 | |
d2a0f284 JC |
791 | |
792 | =head1 SV-Body Allocation | |
793 | ||
f554dfc5 MH |
794 | =cut |
795 | ||
d2a0f284 JC |
796 | Allocation of SV-bodies is similar to SV-heads, differing as follows; |
797 | the allocation mechanism is used for many body types, so is somewhat | |
798 | more complicated, it uses arena-sets, and has no need for still-live | |
799 | SV detection. | |
800 | ||
801 | At the outermost level, (new|del)_X*V macros return bodies of the | |
802 | appropriate type. These macros call either (new|del)_body_type or | |
803 | (new|del)_body_allocated macro pairs, depending on specifics of the | |
804 | type. Most body types use the former pair, the latter pair is used to | |
805 | allocate body types with "ghost fields". | |
806 | ||
807 | "ghost fields" are fields that are unused in certain types, and | |
69ba284b | 808 | consequently don't need to actually exist. They are declared because |
d2a0f284 JC |
809 | they're part of a "base type", which allows use of functions as |
810 | methods. The simplest examples are AVs and HVs, 2 aggregate types | |
811 | which don't use the fields which support SCALAR semantics. | |
812 | ||
69ba284b | 813 | For these types, the arenas are carved up into appropriately sized |
d2a0f284 JC |
814 | chunks, we thus avoid wasted memory for those unaccessed members. |
815 | When bodies are allocated, we adjust the pointer back in memory by the | |
69ba284b | 816 | size of the part not allocated, so it's as if we allocated the full |
d2a0f284 JC |
817 | structure. (But things will all go boom if you write to the part that |
818 | is "not there", because you'll be overwriting the last members of the | |
819 | preceding structure in memory.) | |
820 | ||
69ba284b | 821 | We calculate the correction using the STRUCT_OFFSET macro on the first |
a05ea1cf | 822 | member present. If the allocated structure is smaller (no initial NV |
69ba284b NC |
823 | actually allocated) then the net effect is to subtract the size of the NV |
824 | from the pointer, to return a new pointer as if an initial NV were actually | |
a05ea1cf | 825 | allocated. (We were using structures named *_allocated for this, but |
69ba284b NC |
826 | this turned out to be a subtle bug, because a structure without an NV |
827 | could have a lower alignment constraint, but the compiler is allowed to | |
828 | optimised accesses based on the alignment constraint of the actual pointer | |
829 | to the full structure, for example, using a single 64 bit load instruction | |
830 | because it "knows" that two adjacent 32 bit members will be 8-byte aligned.) | |
d2a0f284 | 831 | |
a05ea1cf | 832 | This is the same trick as was used for NV and IV bodies. Ironically it |
d2a0f284 | 833 | doesn't need to be used for NV bodies any more, because NV is now at |
5b306eef DD |
834 | the start of the structure. IV bodies, and also in some builds NV bodies, |
835 | don't need it either, because they are no longer allocated. | |
d2a0f284 JC |
836 | |
837 | In turn, the new_body_* allocators call S_new_body(), which invokes | |
838 | new_body_inline macro, which takes a lock, and takes a body off the | |
1e30fcd5 | 839 | linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if |
d2a0f284 JC |
840 | necessary to refresh an empty list. Then the lock is released, and |
841 | the body is returned. | |
842 | ||
99816f8d | 843 | Perl_more_bodies allocates a new arena, and carves it up into an array of N |
d2a0f284 JC |
844 | bodies, which it strings into a linked list. It looks up arena-size |
845 | and body-size from the body_details table described below, thus | |
846 | supporting the multiple body-types. | |
847 | ||
848 | If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and | |
849 | the (new|del)_X*V macros are mapped directly to malloc/free. | |
850 | ||
d2a0f284 JC |
851 | For each sv-type, struct body_details bodies_by_type[] carries |
852 | parameters which control these aspects of SV handling: | |
853 | ||
854 | Arena_size determines whether arenas are used for this body type, and if | |
855 | so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to | |
856 | zero, forcing individual mallocs and frees. | |
857 | ||
858 | Body_size determines how big a body is, and therefore how many fit into | |
859 | each arena. Offset carries the body-pointer adjustment needed for | |
69ba284b | 860 | "ghost fields", and is used in *_allocated macros. |
d2a0f284 JC |
861 | |
862 | But its main purpose is to parameterize info needed in | |
863 | Perl_sv_upgrade(). The info here dramatically simplifies the function | |
69ba284b | 864 | vs the implementation in 5.8.8, making it table-driven. All fields |
d2a0f284 JC |
865 | are used for this, except for arena_size. |
866 | ||
867 | For the sv-types that have no bodies, arenas are not used, so those | |
868 | PL_body_roots[sv_type] are unused, and can be overloaded. In | |
869 | something of a special case, SVt_NULL is borrowed for HE arenas; | |
c6f8b1d0 | 870 | PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the |
d2a0f284 | 871 | bodies_by_type[SVt_NULL] slot is not used, as the table is not |
c6f8b1d0 | 872 | available in hv.c. |
d2a0f284 | 873 | |
29489e7c DM |
874 | */ |
875 | ||
bd81e77b | 876 | struct body_details { |
0fb58b32 | 877 | U8 body_size; /* Size to allocate */ |
10666ae3 | 878 | U8 copy; /* Size of structure to copy (may be shorter) */ |
5b306eef DD |
879 | U8 offset; /* Size of unalloced ghost fields to first alloced field*/ |
880 | PERL_BITFIELD8 type : 4; /* We have space for a sanity check. */ | |
881 | PERL_BITFIELD8 cant_upgrade : 1;/* Cannot upgrade this type */ | |
882 | PERL_BITFIELD8 zero_nv : 1; /* zero the NV when upgrading from this */ | |
883 | PERL_BITFIELD8 arena : 1; /* Allocated from an arena */ | |
884 | U32 arena_size; /* Size of arena to allocate */ | |
bd81e77b | 885 | }; |
29489e7c | 886 | |
bd81e77b NC |
887 | #define HADNV FALSE |
888 | #define NONV TRUE | |
29489e7c | 889 | |
d2a0f284 | 890 | |
bd81e77b NC |
891 | #ifdef PURIFY |
892 | /* With -DPURFIY we allocate everything directly, and don't use arenas. | |
893 | This seems a rather elegant way to simplify some of the code below. */ | |
894 | #define HASARENA FALSE | |
895 | #else | |
896 | #define HASARENA TRUE | |
897 | #endif | |
898 | #define NOARENA FALSE | |
29489e7c | 899 | |
d2a0f284 JC |
900 | /* Size the arenas to exactly fit a given number of bodies. A count |
901 | of 0 fits the max number bodies into a PERL_ARENA_SIZE.block, | |
902 | simplifying the default. If count > 0, the arena is sized to fit | |
903 | only that many bodies, allowing arenas to be used for large, rare | |
904 | bodies (XPVFM, XPVIO) without undue waste. The arena size is | |
905 | limited by PERL_ARENA_SIZE, so we can safely oversize the | |
906 | declarations. | |
907 | */ | |
95db5f15 MB |
908 | #define FIT_ARENA0(body_size) \ |
909 | ((size_t)(PERL_ARENA_SIZE / body_size) * body_size) | |
910 | #define FIT_ARENAn(count,body_size) \ | |
911 | ( count * body_size <= PERL_ARENA_SIZE) \ | |
912 | ? count * body_size \ | |
913 | : FIT_ARENA0 (body_size) | |
914 | #define FIT_ARENA(count,body_size) \ | |
cd1dc8e2 | 915 | (U32)(count \ |
95db5f15 | 916 | ? FIT_ARENAn (count, body_size) \ |
cd1dc8e2 | 917 | : FIT_ARENA0 (body_size)) |
d2a0f284 | 918 | |
bd81e77b NC |
919 | /* Calculate the length to copy. Specifically work out the length less any |
920 | final padding the compiler needed to add. See the comment in sv_upgrade | |
921 | for why copying the padding proved to be a bug. */ | |
29489e7c | 922 | |
bd81e77b NC |
923 | #define copy_length(type, last_member) \ |
924 | STRUCT_OFFSET(type, last_member) \ | |
daba3364 | 925 | + sizeof (((type*)SvANY((const SV *)0))->last_member) |
29489e7c | 926 | |
bd81e77b | 927 | static const struct body_details bodies_by_type[] = { |
829cd18a NC |
928 | /* HEs use this offset for their arena. */ |
929 | { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 }, | |
d2a0f284 | 930 | |
db93c0c4 NC |
931 | /* IVs are in the head, so the allocation size is 0. */ |
932 | { 0, | |
d2a0f284 | 933 | sizeof(IV), /* This is used to copy out the IV body. */ |
10666ae3 | 934 | STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV, |
db93c0c4 | 935 | NOARENA /* IVS don't need an arena */, 0 |
d2a0f284 JC |
936 | }, |
937 | ||
5b306eef DD |
938 | #if NVSIZE <= IVSIZE |
939 | { 0, sizeof(NV), | |
940 | STRUCT_OFFSET(XPVNV, xnv_u), | |
941 | SVt_NV, FALSE, HADNV, NOARENA, 0 }, | |
942 | #else | |
6e128786 NC |
943 | { sizeof(NV), sizeof(NV), |
944 | STRUCT_OFFSET(XPVNV, xnv_u), | |
945 | SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, | |
5b306eef | 946 | #endif |
d2a0f284 | 947 | |
bc337e5c | 948 | { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur), |
889d28b2 NC |
949 | copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur), |
950 | + STRUCT_OFFSET(XPV, xpv_cur), | |
69ba284b | 951 | SVt_PV, FALSE, NONV, HASARENA, |
889d28b2 | 952 | FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) }, |
d2a0f284 | 953 | |
d361b004 KW |
954 | { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur), |
955 | copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur), | |
956 | + STRUCT_OFFSET(XPV, xpv_cur), | |
957 | SVt_INVLIST, TRUE, NONV, HASARENA, | |
958 | FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
e94d9b54 | 959 | |
bc337e5c | 960 | { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur), |
889d28b2 NC |
961 | copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur), |
962 | + STRUCT_OFFSET(XPV, xpv_cur), | |
963 | SVt_PVIV, FALSE, NONV, HASARENA, | |
964 | FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
d2a0f284 | 965 | |
bc337e5c | 966 | { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur), |
889d28b2 NC |
967 | copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur), |
968 | + STRUCT_OFFSET(XPV, xpv_cur), | |
969 | SVt_PVNV, FALSE, HADNV, HASARENA, | |
970 | FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) }, | |
d2a0f284 | 971 | |
6e128786 | 972 | { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, |
d2a0f284 | 973 | HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, |
4df7f6af | 974 | |
601dfd0a NC |
975 | { sizeof(regexp), |
976 | sizeof(regexp), | |
977 | 0, | |
ecff11eb | 978 | SVt_REGEXP, TRUE, NONV, HASARENA, |
eaeb1e7f | 979 | FIT_ARENA(0, sizeof(regexp)) |
5c35adbb | 980 | }, |
4df7f6af | 981 | |
10666ae3 | 982 | { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, |
d2a0f284 JC |
983 | HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, |
984 | ||
10666ae3 | 985 | { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, |
d2a0f284 JC |
986 | HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, |
987 | ||
601dfd0a | 988 | { sizeof(XPVAV), |
4f7003f5 | 989 | copy_length(XPVAV, xav_alloc), |
601dfd0a | 990 | 0, |
69ba284b | 991 | SVt_PVAV, TRUE, NONV, HASARENA, |
601dfd0a | 992 | FIT_ARENA(0, sizeof(XPVAV)) }, |
d2a0f284 | 993 | |
601dfd0a | 994 | { sizeof(XPVHV), |
359164a0 | 995 | copy_length(XPVHV, xhv_max), |
601dfd0a | 996 | 0, |
69ba284b | 997 | SVt_PVHV, TRUE, NONV, HASARENA, |
601dfd0a | 998 | FIT_ARENA(0, sizeof(XPVHV)) }, |
d2a0f284 | 999 | |
601dfd0a NC |
1000 | { sizeof(XPVCV), |
1001 | sizeof(XPVCV), | |
1002 | 0, | |
69ba284b | 1003 | SVt_PVCV, TRUE, NONV, HASARENA, |
601dfd0a | 1004 | FIT_ARENA(0, sizeof(XPVCV)) }, |
69ba284b | 1005 | |
601dfd0a NC |
1006 | { sizeof(XPVFM), |
1007 | sizeof(XPVFM), | |
1008 | 0, | |
69ba284b | 1009 | SVt_PVFM, TRUE, NONV, NOARENA, |
601dfd0a | 1010 | FIT_ARENA(20, sizeof(XPVFM)) }, |
d2a0f284 | 1011 | |
601dfd0a NC |
1012 | { sizeof(XPVIO), |
1013 | sizeof(XPVIO), | |
1014 | 0, | |
b6f60916 | 1015 | SVt_PVIO, TRUE, NONV, HASARENA, |
601dfd0a | 1016 | FIT_ARENA(24, sizeof(XPVIO)) }, |
bd81e77b | 1017 | }; |
29489e7c | 1018 | |
bd81e77b | 1019 | #define new_body_allocated(sv_type) \ |
d2a0f284 | 1020 | (void *)((char *)S_new_body(aTHX_ sv_type) \ |
bd81e77b | 1021 | - bodies_by_type[sv_type].offset) |
29489e7c | 1022 | |
26359cfa NC |
1023 | /* return a thing to the free list */ |
1024 | ||
1025 | #define del_body(thing, root) \ | |
1026 | STMT_START { \ | |
1027 | void ** const thing_copy = (void **)thing; \ | |
1028 | *thing_copy = *root; \ | |
1029 | *root = (void*)thing_copy; \ | |
1030 | } STMT_END | |
29489e7c | 1031 | |
bd81e77b | 1032 | #ifdef PURIFY |
5b306eef DD |
1033 | #if !(NVSIZE <= IVSIZE) |
1034 | # define new_XNV() safemalloc(sizeof(XPVNV)) | |
1035 | #endif | |
beeec492 NC |
1036 | #define new_XPVNV() safemalloc(sizeof(XPVNV)) |
1037 | #define new_XPVMG() safemalloc(sizeof(XPVMG)) | |
29489e7c | 1038 | |
beeec492 | 1039 | #define del_XPVGV(p) safefree(p) |
29489e7c | 1040 | |
bd81e77b | 1041 | #else /* !PURIFY */ |
29489e7c | 1042 | |
5b306eef DD |
1043 | #if !(NVSIZE <= IVSIZE) |
1044 | # define new_XNV() new_body_allocated(SVt_NV) | |
1045 | #endif | |
65ac1738 | 1046 | #define new_XPVNV() new_body_allocated(SVt_PVNV) |
65ac1738 | 1047 | #define new_XPVMG() new_body_allocated(SVt_PVMG) |
645c22ef | 1048 | |
26359cfa NC |
1049 | #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \ |
1050 | &PL_body_roots[SVt_PVGV]) | |
1d7c1841 | 1051 | |
bd81e77b | 1052 | #endif /* PURIFY */ |
93e68bfb | 1053 | |
bd81e77b | 1054 | /* no arena for you! */ |
93e68bfb | 1055 | |
bd81e77b | 1056 | #define new_NOARENA(details) \ |
beeec492 | 1057 | safemalloc((details)->body_size + (details)->offset) |
bd81e77b | 1058 | #define new_NOARENAZ(details) \ |
beeec492 | 1059 | safecalloc((details)->body_size + (details)->offset, 1) |
d2a0f284 | 1060 | |
1e30fcd5 NC |
1061 | void * |
1062 | Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, | |
1063 | const size_t arena_size) | |
d2a0f284 | 1064 | { |
d2a0f284 | 1065 | void ** const root = &PL_body_roots[sv_type]; |
99816f8d NC |
1066 | struct arena_desc *adesc; |
1067 | struct arena_set *aroot = (struct arena_set *) PL_body_arenas; | |
1068 | unsigned int curr; | |
d2a0f284 JC |
1069 | char *start; |
1070 | const char *end; | |
02982131 | 1071 | const size_t good_arena_size = Perl_malloc_good_size(arena_size); |
20b7effb JH |
1072 | #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT) |
1073 | dVAR; | |
1074 | #endif | |
0b2d3faa | 1075 | #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) |
23e9d66c NC |
1076 | static bool done_sanity_check; |
1077 | ||
0b2d3faa JH |
1078 | /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global |
1079 | * variables like done_sanity_check. */ | |
10666ae3 | 1080 | if (!done_sanity_check) { |
ea471437 | 1081 | unsigned int i = SVt_LAST; |
10666ae3 NC |
1082 | |
1083 | done_sanity_check = TRUE; | |
1084 | ||
1085 | while (i--) | |
1086 | assert (bodies_by_type[i].type == i); | |
1087 | } | |
1088 | #endif | |
1089 | ||
02982131 | 1090 | assert(arena_size); |
23e9d66c | 1091 | |
99816f8d NC |
1092 | /* may need new arena-set to hold new arena */ |
1093 | if (!aroot || aroot->curr >= aroot->set_size) { | |
1094 | struct arena_set *newroot; | |
1095 | Newxz(newroot, 1, struct arena_set); | |
1096 | newroot->set_size = ARENAS_PER_SET; | |
1097 | newroot->next = aroot; | |
1098 | aroot = newroot; | |
1099 | PL_body_arenas = (void *) newroot; | |
1100 | DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); | |
1101 | } | |
1102 | ||
1103 | /* ok, now have arena-set with at least 1 empty/available arena-desc */ | |
1104 | curr = aroot->curr++; | |
1105 | adesc = &(aroot->set[curr]); | |
1106 | assert(!adesc->arena); | |
1107 | ||
1108 | Newx(adesc->arena, good_arena_size, char); | |
1109 | adesc->size = good_arena_size; | |
1110 | adesc->utype = sv_type; | |
1111 | DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", | |
1112 | curr, (void*)adesc->arena, (UV)good_arena_size)); | |
1113 | ||
1114 | start = (char *) adesc->arena; | |
d2a0f284 | 1115 | |
29657bb6 NC |
1116 | /* Get the address of the byte after the end of the last body we can fit. |
1117 | Remember, this is integer division: */ | |
02982131 | 1118 | end = start + good_arena_size / body_size * body_size; |
d2a0f284 | 1119 | |
486ec47a | 1120 | /* computed count doesn't reflect the 1st slot reservation */ |
d8fca402 NC |
1121 | #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) |
1122 | DEBUG_m(PerlIO_printf(Perl_debug_log, | |
1123 | "arena %p end %p arena-size %d (from %d) type %d " | |
1124 | "size %d ct %d\n", | |
02982131 NC |
1125 | (void*)start, (void*)end, (int)good_arena_size, |
1126 | (int)arena_size, sv_type, (int)body_size, | |
1127 | (int)good_arena_size / (int)body_size)); | |
d8fca402 | 1128 | #else |
d2a0f284 JC |
1129 | DEBUG_m(PerlIO_printf(Perl_debug_log, |
1130 | "arena %p end %p arena-size %d type %d size %d ct %d\n", | |
6c9570dc | 1131 | (void*)start, (void*)end, |
02982131 NC |
1132 | (int)arena_size, sv_type, (int)body_size, |
1133 | (int)good_arena_size / (int)body_size)); | |
d8fca402 | 1134 | #endif |
d2a0f284 JC |
1135 | *root = (void *)start; |
1136 | ||
29657bb6 NC |
1137 | while (1) { |
1138 | /* Where the next body would start: */ | |
d2a0f284 | 1139 | char * const next = start + body_size; |
29657bb6 NC |
1140 | |
1141 | if (next >= end) { | |
1142 | /* This is the last body: */ | |
1143 | assert(next == end); | |
1144 | ||
1145 | *(void **)start = 0; | |
1146 | return *root; | |
1147 | } | |
1148 | ||
d2a0f284 JC |
1149 | *(void**) start = (void *)next; |
1150 | start = next; | |
1151 | } | |
d2a0f284 JC |
1152 | } |
1153 | ||
1154 | /* grab a new thing from the free list, allocating more if necessary. | |
1155 | The inline version is used for speed in hot routines, and the | |
1156 | function using it serves the rest (unless PURIFY). | |
1157 | */ | |
1158 | #define new_body_inline(xpv, sv_type) \ | |
1159 | STMT_START { \ | |
1160 | void ** const r3wt = &PL_body_roots[sv_type]; \ | |
11b79775 | 1161 | xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ |
1e30fcd5 | 1162 | ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ |
02982131 NC |
1163 | bodies_by_type[sv_type].body_size,\ |
1164 | bodies_by_type[sv_type].arena_size)); \ | |
d2a0f284 | 1165 | *(r3wt) = *(void**)(xpv); \ |
d2a0f284 JC |
1166 | } STMT_END |
1167 | ||
1168 | #ifndef PURIFY | |
1169 | ||
1170 | STATIC void * | |
de37a194 | 1171 | S_new_body(pTHX_ const svtype sv_type) |
d2a0f284 | 1172 | { |
d2a0f284 JC |
1173 | void *xpv; |
1174 | new_body_inline(xpv, sv_type); | |
1175 | return xpv; | |
1176 | } | |
1177 | ||
1178 | #endif | |
93e68bfb | 1179 | |
238b27b3 NC |
1180 | static const struct body_details fake_rv = |
1181 | { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; | |
1182 | ||
bd81e77b NC |
1183 | /* |
1184 | =for apidoc sv_upgrade | |
93e68bfb | 1185 | |
bd81e77b NC |
1186 | Upgrade an SV to a more complex form. Generally adds a new body type to the |
1187 | SV, then copies across as much information as possible from the old body. | |
9521ca61 FC |
1188 | It croaks if the SV is already in a more complex form than requested. You |
1189 | generally want to use the C<SvUPGRADE> macro wrapper, which checks the type | |
1190 | before calling C<sv_upgrade>, and hence does not croak. See also | |
fbe13c60 | 1191 | C<L</svtype>>. |
93e68bfb | 1192 | |
bd81e77b | 1193 | =cut |
93e68bfb | 1194 | */ |
93e68bfb | 1195 | |
bd81e77b | 1196 | void |
5aaab254 | 1197 | Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) |
cac9b346 | 1198 | { |
bd81e77b NC |
1199 | void* old_body; |
1200 | void* new_body; | |
42d0e0b7 | 1201 | const svtype old_type = SvTYPE(sv); |
d2a0f284 | 1202 | const struct body_details *new_type_details; |
238b27b3 | 1203 | const struct body_details *old_type_details |
bd81e77b | 1204 | = bodies_by_type + old_type; |
4df7f6af | 1205 | SV *referant = NULL; |
cac9b346 | 1206 | |
7918f24d NC |
1207 | PERL_ARGS_ASSERT_SV_UPGRADE; |
1208 | ||
1776cbe8 NC |
1209 | if (old_type == new_type) |
1210 | return; | |
1211 | ||
1212 | /* This clause was purposefully added ahead of the early return above to | |
1213 | the shared string hackery for (sort {$a <=> $b} keys %hash), with the | |
1214 | inference by Nick I-S that it would fix other troublesome cases. See | |
1215 | changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent) | |
1216 | ||
1217 | Given that shared hash key scalars are no longer PVIV, but PV, there is | |
1218 | no longer need to unshare so as to free up the IVX slot for its proper | |
1219 | purpose. So it's safe to move the early return earlier. */ | |
1220 | ||
093085a8 | 1221 | if (new_type > SVt_PVMG && SvIsCOW(sv)) { |
bd81e77b NC |
1222 | sv_force_normal_flags(sv, 0); |
1223 | } | |
cac9b346 | 1224 | |
bd81e77b | 1225 | old_body = SvANY(sv); |
de042e1d | 1226 | |
bd81e77b NC |
1227 | /* Copying structures onto other structures that have been neatly zeroed |
1228 | has a subtle gotcha. Consider XPVMG | |
cac9b346 | 1229 | |
bd81e77b NC |
1230 | +------+------+------+------+------+-------+-------+ |
1231 | | NV | CUR | LEN | IV | MAGIC | STASH | | |
1232 | +------+------+------+------+------+-------+-------+ | |
1233 | 0 4 8 12 16 20 24 28 | |
645c22ef | 1234 | |
bd81e77b NC |
1235 | where NVs are aligned to 8 bytes, so that sizeof that structure is |
1236 | actually 32 bytes long, with 4 bytes of padding at the end: | |
08742458 | 1237 | |
bd81e77b NC |
1238 | +------+------+------+------+------+-------+-------+------+ |
1239 | | NV | CUR | LEN | IV | MAGIC | STASH | ??? | | |
1240 | +------+------+------+------+------+-------+-------+------+ | |
1241 | 0 4 8 12 16 20 24 28 32 | |
08742458 | 1242 | |
bd81e77b | 1243 | so what happens if you allocate memory for this structure: |
30f9da9e | 1244 | |
bd81e77b NC |
1245 | +------+------+------+------+------+-------+-------+------+------+... |
1246 | | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME | | |
1247 | +------+------+------+------+------+-------+-------+------+------+... | |
1248 | 0 4 8 12 16 20 24 28 32 36 | |
bfc44f79 | 1249 | |
bd81e77b NC |
1250 | zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you |
1251 | expect, because you copy the area marked ??? onto GP. Now, ??? may have | |
1252 | started out as zero once, but it's quite possible that it isn't. So now, | |
1253 | rather than a nicely zeroed GP, you have it pointing somewhere random. | |
1254 | Bugs ensue. | |
bfc44f79 | 1255 | |
bd81e77b NC |
1256 | (In fact, GP ends up pointing at a previous GP structure, because the |
1257 | principle cause of the padding in XPVMG getting garbage is a copy of | |
6c9e42f7 NC |
1258 | sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now |
1259 | this happens to be moot because XPVGV has been re-ordered, with GP | |
1260 | no longer after STASH) | |
30f9da9e | 1261 | |
bd81e77b NC |
1262 | So we are careful and work out the size of used parts of all the |
1263 | structures. */ | |
bfc44f79 | 1264 | |
bd81e77b NC |
1265 | switch (old_type) { |
1266 | case SVt_NULL: | |
1267 | break; | |
1268 | case SVt_IV: | |
4df7f6af NC |
1269 | if (SvROK(sv)) { |
1270 | referant = SvRV(sv); | |
238b27b3 NC |
1271 | old_type_details = &fake_rv; |
1272 | if (new_type == SVt_NV) | |
1273 | new_type = SVt_PVNV; | |
4df7f6af NC |
1274 | } else { |
1275 | if (new_type < SVt_PVIV) { | |
1276 | new_type = (new_type == SVt_NV) | |
1277 | ? SVt_PVNV : SVt_PVIV; | |
1278 | } | |
bd81e77b NC |
1279 | } |
1280 | break; | |
1281 | case SVt_NV: | |
1282 | if (new_type < SVt_PVNV) { | |
1283 | new_type = SVt_PVNV; | |
bd81e77b NC |
1284 | } |
1285 | break; | |
bd81e77b NC |
1286 | case SVt_PV: |
1287 | assert(new_type > SVt_PV); | |
6d59e610 LM |
1288 | STATIC_ASSERT_STMT(SVt_IV < SVt_PV); |
1289 | STATIC_ASSERT_STMT(SVt_NV < SVt_PV); | |
bd81e77b NC |
1290 | break; |
1291 | case SVt_PVIV: | |
1292 | break; | |
1293 | case SVt_PVNV: | |
1294 | break; | |
1295 | case SVt_PVMG: | |
1296 | /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, | |
1297 | there's no way that it can be safely upgraded, because perl.c | |
1298 | expects to Safefree(SvANY(PL_mess_sv)) */ | |
1299 | assert(sv != PL_mess_sv); | |
bd81e77b NC |
1300 | break; |
1301 | default: | |
2439e033 | 1302 | if (UNLIKELY(old_type_details->cant_upgrade)) |
c81225bc NC |
1303 | Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, |
1304 | sv_reftype(sv, 0), (UV) old_type, (UV) new_type); | |
bd81e77b | 1305 | } |
3376de98 | 1306 | |
2439e033 | 1307 | if (UNLIKELY(old_type > new_type)) |
3376de98 NC |
1308 | Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", |
1309 | (int)old_type, (int)new_type); | |
1310 | ||
2fa1109b | 1311 | new_type_details = bodies_by_type + new_type; |
645c22ef | 1312 | |
bd81e77b NC |
1313 | SvFLAGS(sv) &= ~SVTYPEMASK; |
1314 | SvFLAGS(sv) |= new_type; | |
932e9ff9 | 1315 | |
ab4416c0 NC |
1316 | /* This can't happen, as SVt_NULL is <= all values of new_type, so one of |
1317 | the return statements above will have triggered. */ | |
1318 | assert (new_type != SVt_NULL); | |
bd81e77b | 1319 | switch (new_type) { |
bd81e77b NC |
1320 | case SVt_IV: |
1321 | assert(old_type == SVt_NULL); | |
dc6369ef | 1322 | SET_SVANY_FOR_BODYLESS_IV(sv); |
bd81e77b NC |
1323 | SvIV_set(sv, 0); |
1324 | return; | |
1325 | case SVt_NV: | |
1326 | assert(old_type == SVt_NULL); | |
5b306eef | 1327 | #if NVSIZE <= IVSIZE |
dc6369ef | 1328 | SET_SVANY_FOR_BODYLESS_NV(sv); |
5b306eef | 1329 | #else |
bd81e77b | 1330 | SvANY(sv) = new_XNV(); |
5b306eef | 1331 | #endif |
bd81e77b NC |
1332 | SvNV_set(sv, 0); |
1333 | return; | |
bd81e77b | 1334 | case SVt_PVHV: |
bd81e77b | 1335 | case SVt_PVAV: |
d2a0f284 | 1336 | assert(new_type_details->body_size); |
c1ae03ae NC |
1337 | |
1338 | #ifndef PURIFY | |
1339 | assert(new_type_details->arena); | |
d2a0f284 | 1340 | assert(new_type_details->arena_size); |
c1ae03ae | 1341 | /* This points to the start of the allocated area. */ |
d2a0f284 JC |
1342 | new_body_inline(new_body, new_type); |
1343 | Zero(new_body, new_type_details->body_size, char); | |
c1ae03ae NC |
1344 | new_body = ((char *)new_body) - new_type_details->offset; |
1345 | #else | |
1346 | /* We always allocated the full length item with PURIFY. To do this | |
1347 | we fake things so that arena is false for all 16 types.. */ | |
1348 | new_body = new_NOARENAZ(new_type_details); | |
1349 | #endif | |
1350 | SvANY(sv) = new_body; | |
1351 | if (new_type == SVt_PVAV) { | |
1352 | AvMAX(sv) = -1; | |
1353 | AvFILLp(sv) = -1; | |
1354 | AvREAL_only(sv); | |
64484faa | 1355 | if (old_type_details->body_size) { |
ac572bf4 NC |
1356 | AvALLOC(sv) = 0; |
1357 | } else { | |
1358 | /* It will have been zeroed when the new body was allocated. | |
1359 | Lets not write to it, in case it confuses a write-back | |
1360 | cache. */ | |
1361 | } | |
78ac7dd9 NC |
1362 | } else { |
1363 | assert(!SvOK(sv)); | |
1364 | SvOK_off(sv); | |
1365 | #ifndef NODEFAULT_SHAREKEYS | |
1366 | HvSHAREKEYS_on(sv); /* key-sharing on by default */ | |
1367 | #endif | |
586fc6a3 SM |
1368 | /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ |
1369 | HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; | |
c1ae03ae | 1370 | } |
aeb18a1e | 1371 | |
bd81e77b NC |
1372 | /* SVt_NULL isn't the only thing upgraded to AV or HV. |
1373 | The target created by newSVrv also is, and it can have magic. | |
1374 | However, it never has SvPVX set. | |
1375 | */ | |
4df7f6af NC |
1376 | if (old_type == SVt_IV) { |
1377 | assert(!SvROK(sv)); | |
1378 | } else if (old_type >= SVt_PV) { | |
bd81e77b NC |
1379 | assert(SvPVX_const(sv) == 0); |
1380 | } | |
aeb18a1e | 1381 | |
bd81e77b | 1382 | if (old_type >= SVt_PVMG) { |
e736a858 | 1383 | SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); |
bd81e77b | 1384 | SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); |
797c7171 NC |
1385 | } else { |
1386 | sv->sv_u.svu_array = NULL; /* or svu_hash */ | |
bd81e77b NC |
1387 | } |
1388 | break; | |
93e68bfb | 1389 | |
bd81e77b NC |
1390 | case SVt_PVIV: |
1391 | /* XXX Is this still needed? Was it ever needed? Surely as there is | |
1392 | no route from NV to PVIV, NOK can never be true */ | |
1393 | assert(!SvNOKp(sv)); | |
1394 | assert(!SvNOK(sv)); | |
2b5060ae | 1395 | /* FALLTHROUGH */ |
bd81e77b NC |
1396 | case SVt_PVIO: |
1397 | case SVt_PVFM: | |
bd81e77b NC |
1398 | case SVt_PVGV: |
1399 | case SVt_PVCV: | |
1400 | case SVt_PVLV: | |
d361b004 | 1401 | case SVt_INVLIST: |
12c45b25 | 1402 | case SVt_REGEXP: |
bd81e77b NC |
1403 | case SVt_PVMG: |
1404 | case SVt_PVNV: | |
1405 | case SVt_PV: | |
93e68bfb | 1406 | |
d2a0f284 | 1407 | assert(new_type_details->body_size); |
bd81e77b NC |
1408 | /* We always allocated the full length item with PURIFY. To do this |
1409 | we fake things so that arena is false for all 16 types.. */ | |
1410 | if(new_type_details->arena) { | |
1411 | /* This points to the start of the allocated area. */ | |
d2a0f284 JC |
1412 | new_body_inline(new_body, new_type); |
1413 | Zero(new_body, new_type_details->body_size, char); | |
bd81e77b NC |
1414 | new_body = ((char *)new_body) - new_type_details->offset; |
1415 | } else { | |
1416 | new_body = new_NOARENAZ(new_type_details); | |
1417 | } | |
1418 | SvANY(sv) = new_body; | |
5e2fc214 | 1419 | |
bd81e77b | 1420 | if (old_type_details->copy) { |
f9ba3d20 NC |
1421 | /* There is now the potential for an upgrade from something without |
1422 | an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ | |
1423 | int offset = old_type_details->offset; | |
1424 | int length = old_type_details->copy; | |
1425 | ||
1426 | if (new_type_details->offset > old_type_details->offset) { | |
d4c19fe8 | 1427 | const int difference |
f9ba3d20 NC |
1428 | = new_type_details->offset - old_type_details->offset; |
1429 | offset += difference; | |
1430 | length -= difference; | |
1431 | } | |
1432 | assert (length >= 0); | |
1433 | ||
1434 | Copy((char *)old_body + offset, (char *)new_body + offset, length, | |
1435 | char); | |
bd81e77b NC |
1436 | } |
1437 | ||
1438 | #ifndef NV_ZERO_IS_ALLBITS_ZERO | |
f2524eef | 1439 | /* If NV 0.0 is stores as all bits 0 then Zero() already creates a |
e5ce394c NC |
1440 | * correct 0.0 for us. Otherwise, if the old body didn't have an |
1441 | * NV slot, but the new one does, then we need to initialise the | |
1442 | * freshly created NV slot with whatever the correct bit pattern is | |
1443 | * for 0.0 */ | |
e22a937e NC |
1444 | if (old_type_details->zero_nv && !new_type_details->zero_nv |
1445 | && !isGV_with_GP(sv)) | |
bd81e77b | 1446 | SvNV_set(sv, 0); |
82048762 | 1447 | #endif |
5e2fc214 | 1448 | |
2439e033 | 1449 | if (UNLIKELY(new_type == SVt_PVIO)) { |
85dca89a | 1450 | IO * const io = MUTABLE_IO(sv); |
d963bf01 | 1451 | GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); |
85dca89a NC |
1452 | |
1453 | SvOBJECT_on(io); | |
1454 | /* Clear the stashcache because a new IO could overrule a package | |
1455 | name */ | |
103f5a36 | 1456 | DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); |
85dca89a NC |
1457 | hv_clear(PL_stashcache); |
1458 | ||
85dca89a | 1459 | SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); |
f2524eef | 1460 | IoPAGE_LEN(sv) = 60; |
85dca89a | 1461 | } |
2439e033 | 1462 | if (UNLIKELY(new_type == SVt_REGEXP)) |
8d919b0a FC |
1463 | sv->sv_u.svu_rx = (regexp *)new_body; |
1464 | else if (old_type < SVt_PV) { | |
4df7f6af NC |
1465 | /* referant will be NULL unless the old type was SVt_IV emulating |
1466 | SVt_RV */ | |
1467 | sv->sv_u.svu_rv = referant; | |
1468 | } | |
bd81e77b NC |
1469 | break; |
1470 | default: | |
afd78fd5 JH |
1471 | Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", |
1472 | (unsigned long)new_type); | |
bd81e77b | 1473 | } |
73171d91 | 1474 | |
5b306eef DD |
1475 | /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV, |
1476 | and sometimes SVt_NV */ | |
1477 | if (old_type_details->body_size) { | |
bd81e77b | 1478 | #ifdef PURIFY |
beeec492 | 1479 | safefree(old_body); |
bd81e77b | 1480 | #else |
bc786448 GG |
1481 | /* Note that there is an assumption that all bodies of types that |
1482 | can be upgraded came from arenas. Only the more complex non- | |
1483 | upgradable types are allowed to be directly malloc()ed. */ | |
1484 | assert(old_type_details->arena); | |
bd81e77b NC |
1485 | del_body((void*)((char*)old_body + old_type_details->offset), |
1486 | &PL_body_roots[old_type]); | |
1487 | #endif | |
1488 | } | |
1489 | } | |
73171d91 | 1490 | |
bd81e77b NC |
1491 | /* |
1492 | =for apidoc sv_backoff | |
73171d91 | 1493 | |
fde67290 | 1494 | Remove any string offset. You should normally use the C<SvOOK_off> macro |
bd81e77b | 1495 | wrapper instead. |
73171d91 | 1496 | |
bd81e77b | 1497 | =cut |
73171d91 NC |
1498 | */ |
1499 | ||
fa7a1e49 DD |
1500 | /* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS |
1501 | prior to 5.23.4 this function always returned 0 | |
1502 | */ | |
1503 | ||
1504 | void | |
ddeaf645 | 1505 | Perl_sv_backoff(SV *const sv) |
bd81e77b | 1506 | { |
69240efd | 1507 | STRLEN delta; |
7a4bba22 | 1508 | const char * const s = SvPVX_const(sv); |
7918f24d NC |
1509 | |
1510 | PERL_ARGS_ASSERT_SV_BACKOFF; | |
7918f24d | 1511 | |
bd81e77b NC |
1512 | assert(SvOOK(sv)); |
1513 | assert(SvTYPE(sv) != SVt_PVHV); | |
1514 | assert(SvTYPE(sv) != SVt_PVAV); | |
7a4bba22 | 1515 | |
69240efd NC |
1516 | SvOOK_offset(sv, delta); |
1517 | ||
7a4bba22 NC |
1518 | SvLEN_set(sv, SvLEN(sv) + delta); |
1519 | SvPV_set(sv, SvPVX(sv) - delta); | |
bd81e77b | 1520 | SvFLAGS(sv) &= ~SVf_OOK; |
fa7a1e49 DD |
1521 | Move(s, SvPVX(sv), SvCUR(sv)+1, char); |
1522 | return; | |
bd81e77b | 1523 | } |
73171d91 | 1524 | |
bd81e77b NC |
1525 | /* |
1526 | =for apidoc sv_grow | |
73171d91 | 1527 | |
bd81e77b NC |
1528 | Expands the character buffer in the SV. If necessary, uses C<sv_unref> and |
1529 | upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer. | |
1530 | Use the C<SvGROW> wrapper instead. | |
93e68bfb | 1531 | |
bd81e77b NC |
1532 | =cut |
1533 | */ | |
93e68bfb | 1534 | |
e0060e30 FC |
1535 | static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags); |
1536 | ||
bd81e77b | 1537 | char * |
5aaab254 | 1538 | Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) |
bd81e77b | 1539 | { |
eb578fdb | 1540 | char *s; |
93e68bfb | 1541 | |
7918f24d NC |
1542 | PERL_ARGS_ASSERT_SV_GROW; |
1543 | ||
bd81e77b NC |
1544 | if (SvROK(sv)) |
1545 | sv_unref(sv); | |
1546 | if (SvTYPE(sv) < SVt_PV) { | |
1547 | sv_upgrade(sv, SVt_PV); | |
1548 | s = SvPVX_mutable(sv); | |
1549 | } | |
1550 | else if (SvOOK(sv)) { /* pv is offset? */ | |
1551 | sv_backoff(sv); | |
1552 | s = SvPVX_mutable(sv); | |
1553 | if (newlen > SvLEN(sv)) | |
1554 | newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ | |
bd81e77b NC |
1555 | } |
1556 | else | |
db2c6cb3 | 1557 | { |
e0060e30 | 1558 | if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); |
bd81e77b | 1559 | s = SvPVX_mutable(sv); |
db2c6cb3 | 1560 | } |
aeb18a1e | 1561 | |
93c10d60 | 1562 | #ifdef PERL_COPY_ON_WRITE |
cbcb2a16 | 1563 | /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare) |
3c239bea | 1564 | * to store the COW count. So in general, allocate one more byte than |
cbcb2a16 DM |
1565 | * asked for, to make it likely this byte is always spare: and thus |
1566 | * make more strings COW-able. | |
1567 | * If the new size is a big power of two, don't bother: we assume the | |
1568 | * caller wanted a nice 2^N sized block and will be annoyed at getting | |
fa8f4f85 TC |
1569 | * 2^N+1. |
1570 | * Only increment if the allocation isn't MEM_SIZE_MAX, | |
1571 | * otherwise it will wrap to 0. | |
1572 | */ | |
1573 | if (newlen & 0xff && newlen != MEM_SIZE_MAX) | |
cbcb2a16 DM |
1574 | newlen++; |
1575 | #endif | |
1576 | ||
ce861ea7 YO |
1577 | #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size) |
1578 | #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC | |
1579 | #endif | |
1580 | ||
bd81e77b | 1581 | if (newlen > SvLEN(sv)) { /* need more room? */ |
f1200559 | 1582 | STRLEN minlen = SvCUR(sv); |
3c239bea | 1583 | minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; |
f1200559 WH |
1584 | if (newlen < minlen) |
1585 | newlen = minlen; | |
ce861ea7 | 1586 | #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC |
7c641603 KW |
1587 | |
1588 | /* Don't round up on the first allocation, as odds are pretty good that | |
1589 | * the initial request is accurate as to what is really needed */ | |
ce861ea7 | 1590 | if (SvLEN(sv)) { |
9efda33a TC |
1591 | STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen); |
1592 | if (rounded > newlen) | |
1593 | newlen = rounded; | |
ce861ea7 | 1594 | } |
bd81e77b | 1595 | #endif |
98653f18 | 1596 | if (SvLEN(sv) && s) { |
10edeb5d | 1597 | s = (char*)saferealloc(s, newlen); |
bd81e77b NC |
1598 | } |
1599 | else { | |
10edeb5d | 1600 | s = (char*)safemalloc(newlen); |
bd81e77b NC |
1601 | if (SvPVX_const(sv) && SvCUR(sv)) { |
1602 | Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); | |
1603 | } | |
1604 | } | |
1605 | SvPV_set(sv, s); | |
ce861ea7 | 1606 | #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC |
98653f18 NC |
1607 | /* Do this here, do it once, do it right, and then we will never get |
1608 | called back into sv_grow() unless there really is some growing | |
1609 | needed. */ | |
ca7c1a29 | 1610 | SvLEN_set(sv, Perl_safesysmalloc_size(s)); |
98653f18 | 1611 | #else |
bd81e77b | 1612 | SvLEN_set(sv, newlen); |
98653f18 | 1613 | #endif |
bd81e77b NC |
1614 | } |
1615 | return s; | |
1616 | } | |
aeb18a1e | 1617 | |
bd81e77b NC |
1618 | /* |
1619 | =for apidoc sv_setiv | |
932e9ff9 | 1620 | |
bd81e77b | 1621 | Copies an integer into the given SV, upgrading first if necessary. |
fbe13c60 | 1622 | Does not handle 'set' magic. See also C<L</sv_setiv_mg>>. |
463ee0b2 | 1623 | |
bd81e77b NC |
1624 | =cut |
1625 | */ | |
463ee0b2 | 1626 | |
bd81e77b | 1627 | void |
5aaab254 | 1628 | Perl_sv_setiv(pTHX_ SV *const sv, const IV i) |
bd81e77b | 1629 | { |
7918f24d NC |
1630 | PERL_ARGS_ASSERT_SV_SETIV; |
1631 | ||
bd81e77b NC |
1632 | SV_CHECK_THINKFIRST_COW_DROP(sv); |
1633 | switch (SvTYPE(sv)) { | |
1634 | case SVt_NULL: | |
bd81e77b | 1635 | case SVt_NV: |
3376de98 | 1636 | sv_upgrade(sv, SVt_IV); |
bd81e77b | 1637 | break; |
bd81e77b NC |
1638 | case SVt_PV: |
1639 | sv_upgrade(sv, SVt_PVIV); | |
1640 | break; | |
463ee0b2 | 1641 | |
bd81e77b | 1642 | case SVt_PVGV: |
6e592b3a BM |
1643 | if (!isGV_with_GP(sv)) |
1644 | break; | |
bd81e77b NC |
1645 | case SVt_PVAV: |
1646 | case SVt_PVHV: | |
1647 | case SVt_PVCV: | |
1648 | case SVt_PVFM: | |
1649 | case SVt_PVIO: | |
22e74366 | 1650 | /* diag_listed_as: Can't coerce %s to %s in %s */ |
bd81e77b NC |
1651 | Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), |
1652 | OP_DESC(PL_op)); | |
0103ca14 | 1653 | break; |
42d0e0b7 | 1654 | default: NOOP; |
bd81e77b NC |
1655 | } |
1656 | (void)SvIOK_only(sv); /* validate number */ | |
1657 | SvIV_set(sv, i); | |
1658 | SvTAINT(sv); | |
1659 | } | |
932e9ff9 | 1660 | |
bd81e77b NC |
1661 | /* |
1662 | =for apidoc sv_setiv_mg | |
d33b2eba | 1663 | |
bd81e77b | 1664 | Like C<sv_setiv>, but also handles 'set' magic. |
1c846c1f | 1665 | |
bd81e77b NC |
1666 | =cut |
1667 | */ | |
d33b2eba | 1668 | |
bd81e77b | 1669 | void |
5aaab254 | 1670 | Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i) |
bd81e77b | 1671 | { |
7918f24d NC |
1672 | PERL_ARGS_ASSERT_SV_SETIV_MG; |
1673 | ||
bd81e77b NC |
1674 | sv_setiv(sv,i); |
1675 | SvSETMAGIC(sv); | |
1676 | } | |
727879eb | 1677 | |
bd81e77b NC |
1678 | /* |
1679 | =for apidoc sv_setuv | |
d33b2eba | 1680 | |
bd81e77b | 1681 | Copies an unsigned integer into the given SV, upgrading first if necessary. |
fbe13c60 | 1682 | Does not handle 'set' magic. See also C<L</sv_setuv_mg>>. |
9b94d1dd | 1683 | |
bd81e77b NC |
1684 | =cut |
1685 | */ | |
d33b2eba | 1686 | |
bd81e77b | 1687 | void |
5aaab254 | 1688 | Perl_sv_setuv(pTHX_ SV *const sv, const UV u) |
bd81e77b | 1689 | { |
7918f24d NC |
1690 | PERL_ARGS_ASSERT_SV_SETUV; |
1691 | ||
013abb9b NC |
1692 | /* With the if statement to ensure that integers are stored as IVs whenever |
1693 | possible: | |
bd81e77b | 1694 | u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 |
d33b2eba | 1695 | |
bd81e77b NC |
1696 | without |
1697 | u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 | |
1c846c1f | 1698 | |
013abb9b NC |
1699 | If you wish to remove the following if statement, so that this routine |
1700 | (and its callers) always return UVs, please benchmark to see what the | |
1701 | effect is. Modern CPUs may be different. Or may not :-) | |
bd81e77b NC |
1702 | */ |
1703 | if (u <= (UV)IV_MAX) { | |
1704 | sv_setiv(sv, (IV)u); | |
1705 | return; | |
1706 | } | |
1707 | sv_setiv(sv, 0); | |
1708 | SvIsUV_on(sv); | |
1709 | SvUV_set(sv, u); | |
1710 | } | |
d33b2eba | 1711 | |
bd81e77b NC |
1712 | /* |
1713 | =for apidoc sv_setuv_mg | |
727879eb | 1714 | |
bd81e77b | 1715 | Like C<sv_setuv>, but also handles 'set' magic. |
9b94d1dd | 1716 | |
bd81e77b NC |
1717 | =cut |
1718 | */ | |
5e2fc214 | 1719 | |
bd81e77b | 1720 | void |
5aaab254 | 1721 | Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u) |
bd81e77b | 1722 | { |
7918f24d NC |
1723 | PERL_ARGS_ASSERT_SV_SETUV_MG; |
1724 | ||
bd81e77b NC |
1725 | sv_setuv(sv,u); |
1726 | SvSETMAGIC(sv); | |
1727 | } | |
5e2fc214 | 1728 | |
954c1994 | 1729 | /* |
bd81e77b | 1730 | =for apidoc sv_setnv |
954c1994 | 1731 | |
bd81e77b | 1732 | Copies a double into the given SV, upgrading first if necessary. |
fbe13c60 | 1733 | Does not handle 'set' magic. See also C<L</sv_setnv_mg>>. |
954c1994 GS |
1734 | |
1735 | =cut | |
1736 | */ | |
1737 | ||
63f97190 | 1738 | void |
5aaab254 | 1739 | Perl_sv_setnv(pTHX_ SV *const sv, const NV num) |
79072805 | 1740 | { |
7918f24d NC |
1741 | PERL_ARGS_ASSERT_SV_SETNV; |
1742 | ||
bd81e77b NC |
1743 | SV_CHECK_THINKFIRST_COW_DROP(sv); |
1744 | switch (SvTYPE(sv)) { | |
79072805 | 1745 | case SVt_NULL: |
79072805 | 1746 | case SVt_IV: |
bd81e77b | 1747 | sv_upgrade(sv, SVt_NV); |
79072805 LW |
1748 | break; |
1749 | case SVt_PV: | |
79072805 | 1750 | case SVt_PVIV: |
bd81e77b | 1751 | sv_upgrade(sv, SVt_PVNV); |
79072805 | 1752 | break; |
bd4b1eb5 | 1753 | |
bd4b1eb5 | 1754 | case SVt_PVGV: |
6e592b3a BM |
1755 | if (!isGV_with_GP(sv)) |
1756 | break; | |
bd81e77b NC |
1757 | case SVt_PVAV: |
1758 | case SVt_PVHV: | |
79072805 | 1759 | case SVt_PVCV: |
bd81e77b NC |
1760 | case SVt_PVFM: |
1761 | case SVt_PVIO: | |
22e74366 | 1762 | /* diag_listed_as: Can't coerce %s to %s in %s */ |
bd81e77b | 1763 | Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), |
94bbb3f4 | 1764 | OP_DESC(PL_op)); |
0103ca14 | 1765 | break; |
42d0e0b7 | 1766 | default: NOOP; |
2068cd4d | 1767 | } |
bd81e77b NC |
1768 | SvNV_set(sv, num); |
1769 | (void)SvNOK_only(sv); /* validate number */ | |
1770 | SvTAINT(sv); | |
79072805 LW |
1771 | } |
1772 | ||
645c22ef | 1773 | /* |
bd81e77b | 1774 | =for apidoc sv_setnv_mg |
645c22ef | 1775 | |
bd81e77b | 1776 | Like C<sv_setnv>, but also handles 'set' magic. |
645c22ef DM |
1777 | |
1778 | =cut | |
1779 | */ | |
1780 | ||
bd81e77b | 1781 | void |
5aaab254 | 1782 | Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num) |
79072805 | 1783 | { |
7918f24d NC |
1784 | PERL_ARGS_ASSERT_SV_SETNV_MG; |
1785 | ||
bd81e77b NC |
1786 | sv_setnv(sv,num); |
1787 | SvSETMAGIC(sv); | |
79072805 LW |
1788 | } |
1789 | ||
3f7602fa TC |
1790 | /* Return a cleaned-up, printable version of sv, for non-numeric, or |
1791 | * not incrementable warning display. | |
1792 | * Originally part of S_not_a_number(). | |
1793 | * The return value may be != tmpbuf. | |
bd81e77b | 1794 | */ |
954c1994 | 1795 | |
3f7602fa TC |
1796 | STATIC const char * |
1797 | S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { | |
1798 | const char *pv; | |
94463019 | 1799 | |
3f7602fa | 1800 | PERL_ARGS_ASSERT_SV_DISPLAY; |
7918f24d | 1801 | |
94463019 | 1802 | if (DO_UTF8(sv)) { |
3f7602fa | 1803 | SV *dsv = newSVpvs_flags("", SVs_TEMP); |
37b8cdd1 | 1804 | pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT); |
94463019 JH |
1805 | } else { |
1806 | char *d = tmpbuf; | |
3f7602fa | 1807 | const char * const limit = tmpbuf + tmpbuf_size - 8; |
94463019 JH |
1808 | /* each *s can expand to 4 chars + "...\0", |
1809 | i.e. need room for 8 chars */ | |
ecdeb87c | 1810 | |
00b6aa41 AL |
1811 | const char *s = SvPVX_const(sv); |
1812 | const char * const end = s + SvCUR(sv); | |
1813 | for ( ; s < end && d < limit; s++ ) { | |
94463019 | 1814 | int ch = *s & 0xFF; |
bd27cf70 | 1815 | if (! isASCII(ch) && !isPRINT_LC(ch)) { |
94463019 JH |
1816 | *d++ = 'M'; |
1817 | *d++ = '-'; | |
bd27cf70 KW |
1818 | |
1819 | /* Map to ASCII "equivalent" of Latin1 */ | |
1820 | ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); | |
94463019 JH |
1821 | } |
1822 | if (ch == '\n') { | |
1823 | *d++ = '\\'; | |
1824 | *d++ = 'n'; | |
1825 | } | |
1826 | else if (ch == '\r') { | |
1827 | *d++ = '\\'; | |
1828 | *d++ = 'r'; | |
1829 | } | |
1830 | else if (ch == '\f') { | |
1831 | *d++ = '\\'; | |
1832 | *d++ = 'f'; | |
1833 | } | |
1834 | else if (ch == '\\') { | |
1835 | *d++ = '\\'; | |
1836 | *d++ = '\\'; | |
1837 | } | |
1838 | else if (ch == '\0') { | |
1839 | *d++ = '\\'; | |
1840 | *d++ = '0'; | |
1841 | } | |
1842 | else if (isPRINT_LC(ch)) | |
1843 | *d++ = ch; | |
1844 | else { | |
1845 | *d++ = '^'; | |
1846 | *d++ = toCTRL(ch); | |
1847 | } | |
1848 | } | |
1849 | if (s < end) { | |
1850 | *d++ = '.'; | |
1851 | *d++ = '.'; | |
1852 | *d++ = '.'; | |
1853 | } | |
1854 | *d = '\0'; | |
1855 | pv = tmpbuf; | |
a0d0e21e | 1856 | } |
a0d0e21e | 1857 | |
3f7602fa TC |
1858 | return pv; |
1859 | } | |
1860 | ||
1861 | /* Print an "isn't numeric" warning, using a cleaned-up, | |
1862 | * printable version of the offending string | |
1863 | */ | |
1864 | ||
1865 | STATIC void | |
1866 | S_not_a_number(pTHX_ SV *const sv) | |
1867 | { | |
3f7602fa TC |
1868 | char tmpbuf[64]; |
1869 | const char *pv; | |
1870 | ||
1871 | PERL_ARGS_ASSERT_NOT_A_NUMBER; | |
1872 | ||
1873 | pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); | |
1874 | ||
533c011a | 1875 | if (PL_op) |
9014280d | 1876 | Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
734856a2 | 1877 | /* diag_listed_as: Argument "%s" isn't numeric%s */ |
94463019 JH |
1878 | "Argument \"%s\" isn't numeric in %s", pv, |
1879 | OP_DESC(PL_op)); | |
a0d0e21e | 1880 | else |
9014280d | 1881 | Perl_warner(aTHX_ packWARN(WARN_NUMERIC), |
734856a2 | 1882 | /* diag_listed_as: Argument "%s" isn't numeric%s */ |
94463019 | 1883 | "Argument \"%s\" isn't numeric", pv); |
a0d0e21e LW |
1884 | } |
1885 | ||
3f7602fa TC |
1886 | STATIC void |
1887 | S_not_incrementable(pTHX_ SV *const sv) { | |
3f7602fa TC |
1888 | char tmpbuf[64]; |
1889 | const char *pv; | |
1890 | ||
1891 | PERL_ARGS_ASSERT_NOT_INCREMENTABLE; | |
1892 | ||
1893 | pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); | |
1894 | ||
1895 | Perl_warner(aTHX_ packWARN(WARN_NUMERIC), | |
1896 | "Argument \"%s\" treated as 0 in increment (++)", pv); | |
1897 | } | |
1898 | ||
c2988b20 NC |
1899 | /* |
1900 | =for apidoc looks_like_number | |
1901 | ||
645c22ef DM |
1902 | Test if the content of an SV looks like a number (or is a number). |
1903 | C<Inf> and C<Infinity> are treated as numbers (so will not issue a | |
796b6530 | 1904 | non-numeric warning), even if your C<atof()> doesn't grok them. Get-magic is |
f52e41ad | 1905 | ignored. |
c2988b20 NC |
1906 | |
1907 | =cut | |
1908 | */ | |
1909 | ||
1910 | I32 | |
aad570aa | 1911 | Perl_looks_like_number(pTHX_ SV *const sv) |
c2988b20 | 1912 | { |
eb578fdb | 1913 | const char *sbegin; |
c2988b20 | 1914 | STRLEN len; |
ea2485eb | 1915 | int numtype; |
c2988b20 | 1916 | |
7918f24d NC |
1917 | PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; |
1918 | ||
f52e41ad FC |
1919 | if (SvPOK(sv) || SvPOKp(sv)) { |
1920 | sbegin = SvPV_nomg_const(sv, len); | |
c2988b20 | 1921 | } |
c2988b20 | 1922 | else |
e0ab1c0e | 1923 | return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); |
ea2485eb JH |
1924 | numtype = grok_number(sbegin, len, NULL); |
1925 | return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype; | |
c2988b20 | 1926 | } |
25da4f38 | 1927 | |
19f6321d NC |
1928 | STATIC bool |
1929 | S_glob_2number(pTHX_ GV * const gv) | |
180488f8 | 1930 | { |
7918f24d NC |
1931 | PERL_ARGS_ASSERT_GLOB_2NUMBER; |
1932 | ||
675c862f AL |
1933 | /* We know that all GVs stringify to something that is not-a-number, |
1934 | so no need to test that. */ | |
1935 | if (ckWARN(WARN_NUMERIC)) | |
8e629ff4 FC |
1936 | { |
1937 | SV *const buffer = sv_newmortal(); | |
1938 | gv_efullname3(buffer, gv, "*"); | |
675c862f | 1939 | not_a_number(buffer); |
8e629ff4 | 1940 | } |
675c862f AL |
1941 | /* We just want something true to return, so that S_sv_2iuv_common |
1942 | can tail call us and return true. */ | |
19f6321d | 1943 | return TRUE; |
675c862f AL |
1944 | } |
1945 | ||
25da4f38 IZ |
1946 | /* Actually, ISO C leaves conversion of UV to IV undefined, but |
1947 | until proven guilty, assume that things are not that bad... */ | |
1948 | ||
645c22ef DM |
1949 | /* |
1950 | NV_PRESERVES_UV: | |
1951 | ||
1952 | As 64 bit platforms often have an NV that doesn't preserve all bits of | |
28e5dec8 JH |
1953 | an IV (an assumption perl has been based on to date) it becomes necessary |
1954 | to remove the assumption that the NV always carries enough precision to | |
1955 | recreate the IV whenever needed, and that the NV is the canonical form. | |
1956 | Instead, IV/UV and NV need to be given equal rights. So as to not lose | |
645c22ef | 1957 | precision as a side effect of conversion (which would lead to insanity |
28e5dec8 | 1958 | and the dragon(s) in t/op/numconvert.t getting very angry) the intent is |
8a4a3196 KW |
1959 | 1) to distinguish between IV/UV/NV slots that have a valid conversion cached |
1960 | where precision was lost, and IV/UV/NV slots that have a valid conversion | |
1961 | which has lost no precision | |
645c22ef | 1962 | 2) to ensure that if a numeric conversion to one form is requested that |
28e5dec8 JH |
1963 | would lose precision, the precise conversion (or differently |
1964 | imprecise conversion) is also performed and cached, to prevent | |
1965 | requests for different numeric formats on the same SV causing | |
1966 | lossy conversion chains. (lossless conversion chains are perfectly | |
1967 | acceptable (still)) | |
1968 | ||
1969 | ||
1970 | flags are used: | |
1971 | SvIOKp is true if the IV slot contains a valid value | |
1972 | SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true) | |
1973 | SvNOKp is true if the NV slot contains a valid value | |
1974 | SvNOK is true only if the NV value is accurate | |
1975 | ||
1976 | so | |
645c22ef | 1977 | while converting from PV to NV, check to see if converting that NV to an |
28e5dec8 JH |
1978 | IV(or UV) would lose accuracy over a direct conversion from PV to |
1979 | IV(or UV). If it would, cache both conversions, return NV, but mark | |
1980 | SV as IOK NOKp (ie not NOK). | |
1981 | ||
645c22ef | 1982 | While converting from PV to IV, check to see if converting that IV to an |
28e5dec8 JH |
1983 | NV would lose accuracy over a direct conversion from PV to NV. If it |
1984 | would, cache both conversions, flag similarly. | |
1985 | ||
1986 | Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite | |
1987 | correctly because if IV & NV were set NV *always* overruled. | |
645c22ef DM |
1988 | Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning |
1989 | changes - now IV and NV together means that the two are interchangeable: | |
28e5dec8 | 1990 | SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX; |
d460ef45 | 1991 | |
645c22ef DM |
1992 | The benefit of this is that operations such as pp_add know that if |
1993 | SvIOK is true for both left and right operands, then integer addition | |
1994 | can be used instead of floating point (for cases where the result won't | |
1995 | overflow). Before, floating point was always used, which could lead to | |
28e5dec8 JH |
1996 | loss of precision compared with integer addition. |
1997 | ||
1998 | * making IV and NV equal status should make maths accurate on 64 bit | |
1999 | platforms | |
2000 | * may speed up maths somewhat if pp_add and friends start to use | |
645c22ef | 2001 | integers when possible instead of fp. (Hopefully the overhead in |
28e5dec8 JH |
2002 | looking for SvIOK and checking for overflow will not outweigh the |
2003 | fp to integer speedup) | |
2004 | * will slow down integer operations (callers of SvIV) on "inaccurate" | |
2005 | values, as the change from SvIOK to SvIOKp will cause a call into | |
2006 | sv_2iv each time rather than a macro access direct to the IV slot | |
2007 | * should speed up number->string conversion on integers as IV is | |
645c22ef | 2008 | favoured when IV and NV are equally accurate |
28e5dec8 JH |
2009 | |
2010 | #################################################################### | |
645c22ef DM |
2011 | You had better be using SvIOK_notUV if you want an IV for arithmetic: |
2012 | SvIOK is true if (IV or UV), so you might be getting (IV)SvUV. | |
2013 | On the other hand, SvUOK is true iff UV. | |
28e5dec8 JH |
2014 | #################################################################### |
2015 | ||
645c22ef | 2016 | Your mileage will vary depending your CPU's relative fp to integer |
28e5dec8 JH |
2017 | performance ratio. |
2018 | */ | |
2019 | ||
2020 | #ifndef NV_PRESERVES_UV | |
645c22ef DM |
2021 | # define IS_NUMBER_UNDERFLOW_IV 1 |
2022 | # define IS_NUMBER_UNDERFLOW_UV 2 | |
2023 | # define IS_NUMBER_IV_AND_UV 2 | |
2024 | # define IS_NUMBER_OVERFLOW_IV 4 | |
2025 | # define IS_NUMBER_OVERFLOW_UV 5 | |
2026 | ||
2027 | /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */ | |
28e5dec8 JH |
2028 | |
2029 | /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ | |
2030 | STATIC int | |
5aaab254 | 2031 | S_sv_2iuv_non_preserve(pTHX_ SV *const sv |
47031da6 NC |
2032 | # ifdef DEBUGGING |
2033 | , I32 numtype | |
2034 | # endif | |
2035 | ) | |
28e5dec8 | 2036 | { |
7918f24d | 2037 | PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; |
23491f1d | 2038 | PERL_UNUSED_CONTEXT; |
7918f24d | 2039 | |
3f7c398e | 2040 | 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)); |
28e5dec8 JH |
2041 | if (SvNVX(sv) < (NV)IV_MIN) { |
2042 | (void)SvIOKp_on(sv); | |
2043 | (void)SvNOK_on(sv); | |
45977657 | 2044 | SvIV_set(sv, IV_MIN); |
28e5dec8 JH |
2045 | return IS_NUMBER_UNDERFLOW_IV; |
2046 | } | |
2047 | if (SvNVX(sv) > (NV)UV_MAX) { | |
2048 | (void)SvIOKp_on(sv); | |
2049 | (void)SvNOK_on(sv); | |
2050 | SvIsUV_on(sv); | |
607fa7f2 | 2051 | SvUV_set(sv, UV_MAX); |
28e5dec8 JH |
2052 | return IS_NUMBER_OVERFLOW_UV; |
2053 | } | |
c2988b20 NC |
2054 | (void)SvIOKp_on(sv); |
2055 | (void)SvNOK_on(sv); | |
2056 | /* Can't use strtol etc to convert this string. (See truth table in | |
2057 | sv_2iv */ | |
2058 | if (SvNVX(sv) <= (UV)IV_MAX) { | |
45977657 | 2059 | SvIV_set(sv, I_V(SvNVX(sv))); |
659c4b96 | 2060 | if ((NV)(SvIVX(sv)) == SvNVX(sv)) { |
c2988b20 NC |
2061 | SvIOK_on(sv); /* Integer is precise. NOK, IOK */ |
2062 | } else { | |
2063 | /* Integer is imprecise. NOK, IOKp */ | |
2064 | } | |
2065 | return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV; | |
2066 | } | |
2067 | SvIsUV_on(sv); | |
607fa7f2 | 2068 | SvUV_set(sv, U_V(SvNVX(sv))); |
659c4b96 | 2069 | if ((NV)(SvUVX(sv)) == SvNVX(sv)) { |
c2988b20 NC |
2070 | if (SvUVX(sv) == UV_MAX) { |
2071 | /* As we know that NVs don't preserve UVs, UV_MAX cannot | |
2072 | possibly be preserved by NV. Hence, it must be overflow. | |
2073 | NOK, IOKp */ | |
2074 | return IS_NUMBER_OVERFLOW_UV; | |
2075 | } | |
2076 | SvIOK_on(sv); /* Integer is precise. NOK, UOK */ | |
2077 | } else { | |
2078 | /* Integer is imprecise. NOK, IOKp */ | |
28e5dec8 | 2079 | } |
c2988b20 | 2080 | return IS_NUMBER_OVERFLOW_IV; |
28e5dec8 | 2081 | } |
645c22ef DM |
2082 | #endif /* !NV_PRESERVES_UV*/ |
2083 | ||
a13f4dff | 2084 | /* If numtype is infnan, set the NV of the sv accordingly. |
5564cd7f | 2085 | * If numtype is anything else, try setting the NV using Atof(PV). */ |
3c81f0b3 DD |
2086 | #ifdef USING_MSVC6 |
2087 | # pragma warning(push) | |
2088 | # pragma warning(disable:4756;disable:4056) | |
2089 | #endif | |
a13f4dff | 2090 | static void |
3823048b | 2091 | S_sv_setnv(pTHX_ SV* sv, int numtype) |
a13f4dff | 2092 | { |
07925c5e | 2093 | bool pok = cBOOL(SvPOK(sv)); |
5564cd7f | 2094 | bool nok = FALSE; |
a13f4dff JH |
2095 | if ((numtype & IS_NUMBER_INFINITY)) { |
2096 | SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF); | |
5564cd7f | 2097 | nok = TRUE; |
a13f4dff JH |
2098 | } |
2099 | else if ((numtype & IS_NUMBER_NAN)) { | |
3823048b | 2100 | SvNV_set(sv, NV_NAN); |
d48bd569 | 2101 | nok = TRUE; |
a13f4dff | 2102 | } |
d48bd569 | 2103 | else if (pok) { |
a13f4dff | 2104 | SvNV_set(sv, Atof(SvPVX_const(sv))); |
d48bd569 JH |
2105 | /* Purposefully no true nok here, since we don't want to blow |
2106 | * away the possible IOK/UV of an existing sv. */ | |
2107 | } | |
5564cd7f | 2108 | if (nok) { |
d48bd569 | 2109 | SvNOK_only(sv); /* No IV or UV please, this is pure infnan. */ |
5564cd7f JH |
2110 | if (pok) |
2111 | SvPOK_on(sv); /* PV is okay, though. */ | |
2112 | } | |
a13f4dff | 2113 | } |
3c81f0b3 DD |
2114 | #ifdef USING_MSVC6 |
2115 | # pragma warning(pop) | |
2116 | #endif | |
a13f4dff | 2117 | |
af359546 | 2118 | STATIC bool |
7918f24d NC |
2119 | S_sv_2iuv_common(pTHX_ SV *const sv) |
2120 | { | |
7918f24d NC |
2121 | PERL_ARGS_ASSERT_SV_2IUV_COMMON; |
2122 | ||
af359546 | 2123 | if (SvNOKp(sv)) { |
28e5dec8 JH |
2124 | /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv |
2125 | * without also getting a cached IV/UV from it at the same time | |
2126 | * (ie PV->NV conversion should detect loss of accuracy and cache | |
af359546 NC |
2127 | * IV or UV at same time to avoid this. */ |
2128 | /* IV-over-UV optimisation - choose to cache IV if possible */ | |
25da4f38 IZ |
2129 | |
2130 | if (SvTYPE(sv) == SVt_NV) | |
2131 | sv_upgrade(sv, SVt_PVNV); | |
2132 | ||
28e5dec8 JH |
2133 | (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ |
2134 | /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost | |
2135 | certainly cast into the IV range at IV_MAX, whereas the correct | |
2136 | answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary | |
2137 | cases go to UV */ | |
e91de695 JH |
2138 | #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) |
2139 | if (Perl_isnan(SvNVX(sv))) { | |
2140 | SvUV_set(sv, 0); | |
2141 | SvIsUV_on(sv); | |
2142 | return FALSE; | |
2143 | } | |
2144 | #endif | |
28e5dec8 | 2145 | if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
45977657 | 2146 | SvIV_set(sv, I_V(SvNVX(sv))); |
659c4b96 | 2147 | if (SvNVX(sv) == (NV) SvIVX(sv) |
28e5dec8 | 2148 | #ifndef NV_PRESERVES_UV |
53e2bfb7 | 2149 | && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */ |
28e5dec8 JH |
2150 | && (((UV)1 << NV_PRESERVES_UV_BITS) > |
2151 | (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) | |
2152 | /* Don't flag it as "accurately an integer" if the number | |
2153 | came from a (by definition imprecise) NV operation, and | |
2154 | we're outside the range of NV integer precision */ | |
2155 | #endif | |
2156 | ) { | |
a43d94f2 NC |
2157 | if (SvNOK(sv)) |
2158 | SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ | |
2159 | else { | |
2160 | /* scalar has trailing garbage, eg "42a" */ | |
2161 | } | |
28e5dec8 | 2162 | DEBUG_c(PerlIO_printf(Perl_debug_log, |
7234c960 | 2163 | "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", |
28e5dec8 JH |
2164 | PTR2UV(sv), |
2165 | SvNVX(sv), | |
2166 | SvIVX(sv))); | |
2167 | ||
2168 | } else { | |
2169 | /* IV not precise. No need to convert from PV, as NV | |
2170 | conversion would already have cached IV if it detected | |
2171 | that PV->IV would be better than PV->NV->IV | |
2172 | flags already correct - don't set public IOK. */ | |
2173 | DEBUG_c(PerlIO_printf(Perl_debug_log, | |
7234c960 | 2174 | "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", |
28e5dec8 JH |
2175 | PTR2UV(sv), |
2176 | SvNVX(sv), | |
2177 | SvIVX(sv))); | |
2178 | } | |
2179 | /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, | |
2180 | but the cast (NV)IV_MIN rounds to a the value less (more | |
2181 | negative) than IV_MIN which happens to be equal to SvNVX ?? | |
2182 | Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and | |
2183 | NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and | |
2184 | (NV)UVX == NVX are both true, but the values differ. :-( | |
2185 | Hopefully for 2s complement IV_MIN is something like | |
2186 | 0x8000000000000000 which will be exact. NWC */ | |
d460ef45 | 2187 | } |
25da4f38 | 2188 | else { |
607fa7f2 | 2189 | SvUV_set(sv, U_V(SvNVX(sv))); |
28e5dec8 | 2190 | if ( |
659c4b96 | 2191 | (SvNVX(sv) == (NV) SvUVX(sv)) |
28e5dec8 JH |
2192 | #ifndef NV_PRESERVES_UV |
2193 | /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ | |
2194 | /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ | |
2195 | && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) | |
2196 | /* Don't flag it as "accurately an integer" if the number | |
2197 | came from a (by definition imprecise) NV operation, and | |
2198 | we're outside the range of NV integer precision */ | |
2199 | #endif | |
a43d94f2 | 2200 | && SvNOK(sv) |
28e5dec8 JH |
2201 | ) |
2202 | SvIOK_on(sv); | |
25da4f38 | 2203 | SvIsUV_on(sv); |
1c846c1f | 2204 | DEBUG_c(PerlIO_printf(Perl_debug_log, |
57def98f | 2205 | "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n", |
56431972 | 2206 | PTR2UV(sv), |
57def98f JH |
2207 | SvUVX(sv), |
2208 | SvUVX(sv))); | |
25da4f38 | 2209 | } |
748a9306 | 2210 | } |
cd84013a | 2211 | else if (SvPOKp(sv)) { |
c2988b20 | 2212 | UV value; |
3823048b | 2213 | const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); |
af359546 | 2214 | /* We want to avoid a possible problem when we cache an IV/ a UV which |
25da4f38 | 2215 | may be later translated to an NV, and the resulting NV is not |
c2988b20 NC |
2216 | the same as the direct translation of the initial string |
2217 | (eg 123.456 can shortcut to the IV 123 with atol(), but we must | |
2218 | be careful to ensure that the value with the .456 is around if the | |
2219 | NV value is requested in the future). | |
1c846c1f | 2220 | |
af359546 | 2221 | This means that if we cache such an IV/a UV, we need to cache the |
25da4f38 | 2222 | NV as well. Moreover, we trade speed for space, and do not |
28e5dec8 | 2223 | cache the NV if we are sure it's not needed. |
25da4f38 | 2224 | */ |
16b7a9a4 | 2225 | |
c2988b20 NC |
2226 | /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ |
2227 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2228 | == IS_NUMBER_IN_UV) { | |
5e045b90 | 2229 | /* It's definitely an integer, only upgrade to PVIV */ |
28e5dec8 JH |
2230 | if (SvTYPE(sv) < SVt_PVIV) |
2231 | sv_upgrade(sv, SVt_PVIV); | |
f7bbb42a | 2232 | (void)SvIOK_on(sv); |
c2988b20 NC |
2233 | } else if (SvTYPE(sv) < SVt_PVNV) |
2234 | sv_upgrade(sv, SVt_PVNV); | |
28e5dec8 | 2235 | |
a13f4dff | 2236 | if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) { |
75a57a38 | 2237 | if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING))) |
6b322424 | 2238 | not_a_number(sv); |
3823048b | 2239 | S_sv_setnv(aTHX_ sv, numtype); |
a13f4dff JH |
2240 | return FALSE; |
2241 | } | |
2242 | ||
f2524eef | 2243 | /* If NVs preserve UVs then we only use the UV value if we know that |
c2988b20 NC |
2244 | we aren't going to call atof() below. If NVs don't preserve UVs |
2245 | then the value returned may have more precision than atof() will | |
2246 | return, even though value isn't perfectly accurate. */ | |
2247 | if ((numtype & (IS_NUMBER_IN_UV | |
2248 | #ifdef NV_PRESERVES_UV | |
2249 | | IS_NUMBER_NOT_INT | |
2250 | #endif | |
2251 | )) == IS_NUMBER_IN_UV) { | |
2252 | /* This won't turn off the public IOK flag if it was set above */ | |
2253 | (void)SvIOKp_on(sv); | |
2254 | ||
2255 | if (!(numtype & IS_NUMBER_NEG)) { | |
2256 | /* positive */; | |
2257 | if (value <= (UV)IV_MAX) { | |
45977657 | 2258 | SvIV_set(sv, (IV)value); |
c2988b20 | 2259 | } else { |
af359546 | 2260 | /* it didn't overflow, and it was positive. */ |
607fa7f2 | 2261 | SvUV_set(sv, value); |
c2988b20 NC |
2262 | SvIsUV_on(sv); |
2263 | } | |
2264 | } else { | |
2265 | /* 2s complement assumption */ | |
2266 | if (value <= (UV)IV_MIN) { | |
53e2bfb7 DM |
2267 | SvIV_set(sv, value == (UV)IV_MIN |
2268 | ? IV_MIN : -(IV)value); | |
c2988b20 NC |
2269 | } else { |
2270 | /* Too negative for an IV. This is a double upgrade, but | |
d1be9408 | 2271 | I'm assuming it will be rare. */ |
c2988b20 NC |
2272 | if (SvTYPE(sv) < SVt_PVNV) |
2273 | sv_upgrade(sv, SVt_PVNV); | |
2274 | SvNOK_on(sv); | |
2275 | SvIOK_off(sv); | |
2276 | SvIOKp_on(sv); | |
9d6ce603 | 2277 | SvNV_set(sv, -(NV)value); |
45977657 | 2278 | SvIV_set(sv, IV_MIN); |
c2988b20 NC |
2279 | } |
2280 | } | |
2281 | } | |
2282 | /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we | |
2283 | will be in the previous block to set the IV slot, and the next | |
2284 | block to set the NV slot. So no else here. */ | |
2285 | ||
2286 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2287 | != IS_NUMBER_IN_UV) { | |
2288 | /* It wasn't an (integer that doesn't overflow the UV). */ | |
3823048b | 2289 | S_sv_setnv(aTHX_ sv, numtype); |
28e5dec8 | 2290 | |
c2988b20 NC |
2291 | if (! numtype && ckWARN(WARN_NUMERIC)) |
2292 | not_a_number(sv); | |
28e5dec8 | 2293 | |
88cb8500 | 2294 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n", |
c2988b20 | 2295 | PTR2UV(sv), SvNVX(sv))); |
28e5dec8 | 2296 | |
28e5dec8 | 2297 | #ifdef NV_PRESERVES_UV |
af359546 NC |
2298 | (void)SvIOKp_on(sv); |
2299 | (void)SvNOK_on(sv); | |
e91de695 JH |
2300 | #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) |
2301 | if (Perl_isnan(SvNVX(sv))) { | |
2302 | SvUV_set(sv, 0); | |
2303 | SvIsUV_on(sv); | |
2304 | return FALSE; | |
2305 | } | |
2306 | #endif | |
af359546 NC |
2307 | if (SvNVX(sv) < (NV)IV_MAX + 0.5) { |
2308 | SvIV_set(sv, I_V(SvNVX(sv))); | |
2309 | if ((NV)(SvIVX(sv)) == SvNVX(sv)) { | |
2310 | SvIOK_on(sv); | |
2311 | } else { | |
6f207bd3 | 2312 | NOOP; /* Integer is imprecise. NOK, IOKp */ |
af359546 NC |
2313 | } |
2314 | /* UV will not work better than IV */ | |
2315 | } else { | |
2316 | if (SvNVX(sv) > (NV)UV_MAX) { | |
2317 | SvIsUV_on(sv); | |
2318 | /* Integer is inaccurate. NOK, IOKp, is UV */ | |
2319 | SvUV_set(sv, UV_MAX); | |
af359546 NC |
2320 | } else { |
2321 | SvUV_set(sv, U_V(SvNVX(sv))); | |
2322 | /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs | |
2323 | NV preservse UV so can do correct comparison. */ | |
2324 | if ((NV)(SvUVX(sv)) == SvNVX(sv)) { | |
2325 | SvIOK_on(sv); | |
af359546 | 2326 | } else { |
6f207bd3 | 2327 | NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ |
af359546 NC |
2328 | } |
2329 | } | |
4b0c9573 | 2330 | SvIsUV_on(sv); |
af359546 | 2331 | } |
28e5dec8 | 2332 | #else /* NV_PRESERVES_UV */ |
c2988b20 NC |
2333 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2334 | == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) { | |
af359546 | 2335 | /* The IV/UV slot will have been set from value returned by |
c2988b20 NC |
2336 | grok_number above. The NV slot has just been set using |
2337 | Atof. */ | |
560b0c46 | 2338 | SvNOK_on(sv); |
c2988b20 NC |
2339 | assert (SvIOKp(sv)); |
2340 | } else { | |
2341 | if (((UV)1 << NV_PRESERVES_UV_BITS) > | |
2342 | U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { | |
2343 | /* Small enough to preserve all bits. */ | |
2344 | (void)SvIOKp_on(sv); | |
2345 | SvNOK_on(sv); | |
45977657 | 2346 | SvIV_set(sv, I_V(SvNVX(sv))); |
659c4b96 | 2347 | if ((NV)(SvIVX(sv)) == SvNVX(sv)) |
c2988b20 NC |
2348 | SvIOK_on(sv); |
2349 | /* Assumption: first non-preserved integer is < IV_MAX, | |
2350 | this NV is in the preserved range, therefore: */ | |
2351 | if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) | |
2352 | < (UV)IV_MAX)) { | |
32fdb065 | 2353 | 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); |
c2988b20 NC |
2354 | } |
2355 | } else { | |
2356 | /* IN_UV NOT_INT | |
2357 | 0 0 already failed to read UV. | |
2358 | 0 1 already failed to read UV. | |
2359 | 1 0 you won't get here in this case. IV/UV | |
2360 | slot set, public IOK, Atof() unneeded. | |
2361 | 1 1 already read UV. | |
2362 | so there's no point in sv_2iuv_non_preserve() attempting | |
2363 | to use atol, strtol, strtoul etc. */ | |
47031da6 | 2364 | # ifdef DEBUGGING |
40a17c4c | 2365 | sv_2iuv_non_preserve (sv, numtype); |
47031da6 NC |
2366 | # else |
2367 | sv_2iuv_non_preserve (sv); | |
2368 | # endif | |
c2988b20 NC |
2369 | } |
2370 | } | |
28e5dec8 | 2371 | #endif /* NV_PRESERVES_UV */ |
a43d94f2 NC |
2372 | /* It might be more code efficient to go through the entire logic above |
2373 | and conditionally set with SvIOKp_on() rather than SvIOK(), but it | |
2374 | gets complex and potentially buggy, so more programmer efficient | |
2375 | to do it this way, by turning off the public flags: */ | |
2376 | if (!numtype) | |
2377 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); | |
25da4f38 | 2378 | } |
af359546 NC |
2379 | } |
2380 | else { | |
675c862f | 2381 | if (isGV_with_GP(sv)) |
159b6efe | 2382 | return glob_2number(MUTABLE_GV(sv)); |
180488f8 | 2383 | |
4f62cd62 | 2384 | if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
af359546 | 2385 | report_uninit(sv); |
25da4f38 IZ |
2386 | if (SvTYPE(sv) < SVt_IV) |
2387 | /* Typically the caller expects that sv_any is not NULL now. */ | |
2388 | sv_upgrade(sv, SVt_IV); | |
af359546 NC |
2389 | /* Return 0 from the caller. */ |
2390 | return TRUE; | |
2391 | } | |
2392 | return FALSE; | |
2393 | } | |
2394 | ||
2395 | /* | |
2396 | =for apidoc sv_2iv_flags | |
2397 | ||
2398 | Return the integer value of an SV, doing any necessary string | |
c5608a1f | 2399 | conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. |
af359546 NC |
2400 | Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros. |
2401 | ||
2402 | =cut | |
2403 | */ | |
2404 | ||
2405 | IV | |
5aaab254 | 2406 | Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) |
af359546 | 2407 | { |
1061065f | 2408 | PERL_ARGS_ASSERT_SV_2IV_FLAGS; |
4bac9ae4 | 2409 | |
217f6fa3 FC |
2410 | assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2411 | && SvTYPE(sv) != SVt_PVFM); | |
2412 | ||
4bac9ae4 CS |
2413 | if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) |
2414 | mg_get(sv); | |
2415 | ||
2416 | if (SvROK(sv)) { | |
2417 | if (SvAMAGIC(sv)) { | |
2418 | SV * tmpstr; | |
2419 | if (flags & SV_SKIP_OVERLOAD) | |
2420 | return 0; | |
2421 | tmpstr = AMG_CALLunary(sv, numer_amg); | |
2422 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { | |
2423 | return SvIV(tmpstr); | |
2424 | } | |
2425 | } | |
2426 | return PTR2IV(SvRV(sv)); | |
2427 | } | |
2428 | ||
8d919b0a | 2429 | if (SvVALID(sv) || isREGEXP(sv)) { |
2b2b6d6d NC |
2430 | /* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
2431 | the same flag bit as SVf_IVisUV, so must not let them cache IVs. | |
2432 | In practice they are extremely unlikely to actually get anywhere | |
2433 | accessible by user Perl code - the only way that I'm aware of is when | |
2434 | a constant subroutine which is used as the second argument to index. | |
cd84013a FC |
2435 | |
2436 | Regexps have no SvIVX and SvNVX fields. | |
2b2b6d6d | 2437 | */ |
8d919b0a | 2438 | assert(isREGEXP(sv) || SvPOKp(sv)); |
e20b6c3b | 2439 | { |
71c558c3 | 2440 | UV value; |
8d919b0a FC |
2441 | const char * const ptr = |
2442 | isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); | |
e91de695 JH |
2443 | const int numtype |
2444 | = grok_number(ptr, SvCUR(sv), &value); | |
71c558c3 NC |
2445 | |
2446 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2447 | == IS_NUMBER_IN_UV) { | |
2448 | /* It's definitely an integer */ | |
2449 | if (numtype & IS_NUMBER_NEG) { | |
2450 | if (value < (UV)IV_MIN) | |
2451 | return -(IV)value; | |
2452 | } else { | |
2453 | if (value < (UV)IV_MAX) | |
2454 | return (IV)value; | |
2455 | } | |
2456 | } | |
058b8ae2 | 2457 | |
e91de695 JH |
2458 | /* Quite wrong but no good choices. */ |
2459 | if ((numtype & IS_NUMBER_INFINITY)) { | |
2460 | return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX; | |
2461 | } else if ((numtype & IS_NUMBER_NAN)) { | |
2462 | return 0; /* So wrong. */ | |
2463 | } | |
2464 | ||
71c558c3 NC |
2465 | if (!numtype) { |
2466 | if (ckWARN(WARN_NUMERIC)) | |
2467 | not_a_number(sv); | |
2468 | } | |
8d919b0a | 2469 | return I_V(Atof(ptr)); |
e20b6c3b | 2470 | } |
4bac9ae4 CS |
2471 | } |
2472 | ||
2473 | if (SvTHINKFIRST(sv)) { | |
af359546 NC |
2474 | if (SvREADONLY(sv) && !SvOK(sv)) { |
2475 | if (ckWARN(WARN_UNINITIALIZED)) | |
2476 | report_uninit(sv); | |
2477 | return 0; | |
2478 | } | |
2479 | } | |
4bac9ae4 | 2480 | |
af359546 NC |
2481 | if (!SvIOKp(sv)) { |
2482 | if (S_sv_2iuv_common(aTHX_ sv)) | |
2483 | return 0; | |
79072805 | 2484 | } |
4bac9ae4 | 2485 | |
1d7c1841 GS |
2486 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n", |
2487 | PTR2UV(sv),SvIVX(sv))); | |
25da4f38 | 2488 | return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); |
79072805 LW |
2489 | } |
2490 | ||
645c22ef | 2491 | /* |
891f9566 | 2492 | =for apidoc sv_2uv_flags |
645c22ef DM |
2493 | |
2494 | Return the unsigned integer value of an SV, doing any necessary string | |
c5608a1f | 2495 | conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. |
891f9566 | 2496 | Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros. |
645c22ef DM |
2497 | |
2498 | =cut | |
2499 | */ | |
2500 | ||
ff68c719 | 2501 | UV |
5aaab254 | 2502 | Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) |
ff68c719 | 2503 | { |
1061065f | 2504 | PERL_ARGS_ASSERT_SV_2UV_FLAGS; |
4bac9ae4 CS |
2505 | |
2506 | if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) | |
2507 | mg_get(sv); | |
2508 | ||
2509 | if (SvROK(sv)) { | |
2510 | if (SvAMAGIC(sv)) { | |
2511 | SV *tmpstr; | |
2512 | if (flags & SV_SKIP_OVERLOAD) | |
2513 | return 0; | |
2514 | tmpstr = AMG_CALLunary(sv, numer_amg); | |
2515 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { | |
2516 | return SvUV(tmpstr); | |
2517 | } | |
2518 | } | |
2519 | return PTR2UV(SvRV(sv)); | |
2520 | } | |
2521 | ||
8d919b0a | 2522 | if (SvVALID(sv) || isREGEXP(sv)) { |
2b2b6d6d | 2523 | /* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
cd84013a FC |
2524 | the same flag bit as SVf_IVisUV, so must not let them cache IVs. |
2525 | Regexps have no SvIVX and SvNVX fields. */ | |
8d919b0a | 2526 | assert(isREGEXP(sv) || SvPOKp(sv)); |
e20b6c3b | 2527 | { |
71c558c3 | 2528 | UV value; |
8d919b0a FC |
2529 | const char * const ptr = |
2530 | isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); | |
e91de695 JH |
2531 | const int numtype |
2532 | = grok_number(ptr, SvCUR(sv), &value); | |
71c558c3 NC |
2533 | |
2534 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) | |
2535 | == IS_NUMBER_IN_UV) { | |
2536 | /* It's definitely an integer */ | |
2537 | if (!(numtype & IS_NUMBER_NEG)) | |
2538 | return value; | |
2539 | } | |
058b8ae2 | 2540 | |
e91de695 JH |
2541 | /* Quite wrong but no good choices. */ |
2542 | if ((numtype & IS_NUMBER_INFINITY)) { | |
2543 | return UV_MAX; /* So wrong. */ | |
2544 | } else if ((numtype & IS_NUMBER_NAN)) { | |
2545 | return 0; /* So wrong. */ | |
2546 | } | |
2547 | ||
71c558c3 NC |
2548 | if (!numtype) { |
2549 | if (ckWARN(WARN_NUMERIC)) | |
2550 | not_a_number(sv); | |
2551 | } | |
8d919b0a | 2552 | return U_V(Atof(ptr)); |
e20b6c3b | 2553 | } |
4bac9ae4 CS |
2554 | } |
2555 | ||
2556 | if (SvTHINKFIRST(sv)) { | |
0336b60e | 2557 | if (SvREADONLY(sv) && !SvOK(sv)) { |
0336b60e | 2558 | if (ckWARN(WARN_UNINITIALIZED)) |
29489e7c | 2559 | report_uninit(sv); |
ff68c719 PP |
2560 | return 0; |
2561 | } | |
2562 | } | |
4bac9ae4 | 2563 | |
af359546 NC |
2564 | if (!SvIOKp(sv)) { |
2565 | if (S_sv_2iuv_common(aTHX_ sv)) | |
2566 | return 0; | |
ff68c719 | 2567 | } |
25da4f38 | 2568 | |
1d7c1841 GS |
2569 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", |
2570 | PTR2UV(sv),SvUVX(sv))); | |
25da4f38 | 2571 | return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); |
ff68c719 PP |
2572 | } |
2573 | ||
645c22ef | 2574 | /* |
196007d1 | 2575 | =for apidoc sv_2nv_flags |
645c22ef DM |
2576 | |
2577 | Return the num value of an SV, doing any necessary string or integer | |
c5608a1f | 2578 | conversion. If C<flags> has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. |
39d5de13 | 2579 | Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros. |
645c22ef DM |
2580 | |
2581 | =cut | |
2582 | */ | |
2583 | ||
65202027 | 2584 | NV |
5aaab254 | 2585 | Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) |
79072805 | 2586 | { |
1061065f DD |
2587 | PERL_ARGS_ASSERT_SV_2NV_FLAGS; |
2588 | ||
217f6fa3 FC |
2589 | assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV |
2590 | && SvTYPE(sv) != SVt_PVFM); | |
8d919b0a | 2591 | if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { |
2b2b6d6d | 2592 | /* FBMs use the space for SvIVX and SvNVX for other purposes, and use |
cd84013a FC |
2593 | the same flag bit as SVf_IVisUV, so must not let them cache NVs. |
2594 | Regexps have no SvIVX and SvNVX fields. */ | |
8d919b0a | 2595 | const char *ptr; |
39d5de13 DM |
2596 | if (flags & SV_GMAGIC) |
2597 | mg_get(sv); | |
463ee0b2 LW |
2598 | if (SvNOKp(sv)) |
2599 | return SvNVX(sv); | |
cd84013a | 2600 | if (SvPOKp(sv) && !SvIOKp(sv)) { |
8d919b0a FC |
2601 | ptr = SvPVX_const(sv); |
2602 | grokpv: | |
041457d9 | 2603 | if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && |
8d919b0a | 2604 | !grok_number(ptr, SvCUR(sv), NULL)) |
a0d0e21e | 2605 | not_a_number(sv); |
8d919b0a | 2606 | return Atof(ptr); |
a0d0e21e | 2607 | } |
25da4f38 | 2608 | if (SvIOKp(sv)) { |
1c846c1f | 2609 | if (SvIsUV(sv)) |
65202027 | 2610 | return (NV)SvUVX(sv); |
25da4f38 | 2611 | else |
65202027 | 2612 | return (NV)SvIVX(sv); |
47a72cb8 NC |
2613 | } |
2614 | if (SvROK(sv)) { | |
2615 | goto return_rok; | |
2616 | } | |
8d919b0a FC |
2617 | if (isREGEXP(sv)) { |
2618 | ptr = RX_WRAPPED((REGEXP *)sv); | |
2619 | goto grokpv; | |
2620 | } | |
47a72cb8 NC |
2621 | assert(SvTYPE(sv) >= SVt_PVMG); |
2622 | /* This falls through to the report_uninit near the end of the | |
2623 | function. */ | |
2624 | } else if (SvTHINKFIRST(sv)) { | |
a0d0e21e | 2625 | if (SvROK(sv)) { |
47a72cb8 | 2626 | return_rok: |
deb46114 | 2627 | if (SvAMAGIC(sv)) { |
aee036bb DM |
2628 | SV *tmpstr; |
2629 | if (flags & SV_SKIP_OVERLOAD) | |
2630 | return 0; | |
31d632c3 | 2631 | tmpstr = AMG_CALLunary(sv, numer_amg); |
deb46114 NC |
2632 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { |
2633 | return SvNV(tmpstr); | |
2634 | } | |
2635 | } | |
2636 | return PTR2NV(SvRV(sv)); | |
a0d0e21e | 2637 | } |
0336b60e | 2638 | if (SvREADONLY(sv) && !SvOK(sv)) { |
599cee73 | 2639 | if (ckWARN(WARN_UNINITIALIZED)) |
29489e7c | 2640 | report_uninit(sv); |
ed6116ce LW |
2641 | return 0.0; |
2642 | } | |
79072805 LW |
2643 | } |
2644 | if (SvTYPE(sv) < SVt_NV) { | |
7e25a7e9 NC |
2645 | /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ |
2646 | sv_upgrade(sv, SVt_NV); | |
097ee67d | 2647 | DEBUG_c({ |
f93f4e46 | 2648 | STORE_NUMERIC_LOCAL_SET_STANDARD(); |
1d7c1841 | 2649 | PerlIO_printf(Perl_debug_log, |
88cb8500 | 2650 | "0x%"UVxf" num(%" NVgf ")\n", |
1d7c1841 | 2651 | PTR2UV(sv), SvNVX(sv)); |
097ee67d JH |
2652 | RESTORE_NUMERIC_LOCAL(); |
2653 | }); | |
79072805 LW |
2654 | } |
2655 | else if (SvTYPE(sv) < SVt_PVNV) | |
2656 | sv_upgrade(sv, SVt_PVNV); | |
59d8ce62 NC |
2657 | if (SvNOKp(sv)) { |
2658 | return SvNVX(sv); | |
61604483 | 2659 | } |
59d8ce62 | 2660 | if (SvIOKp(sv)) { |
9d6ce603 | 2661 | SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); |
28e5dec8 | 2662 | #ifdef NV_PRESERVES_UV |
a43d94f2 NC |
2663 | if (SvIOK(sv)) |
2664 | SvNOK_on(sv); | |
2665 | else | |
2666 | SvNOKp_on(sv); | |
28e5dec8 JH |
2667 | #else |
2668 | /* Only set the public NV OK flag if this NV preserves the IV */ | |
2669 | /* Check it's not 0xFFFFFFFFFFFFFFFF */ | |
a43d94f2 NC |
2670 | if (SvIOK(sv) && |
2671 | SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) | |
28e5dec8 JH |
2672 | : (SvIVX(sv) == I_V(SvNVX(sv)))) |
2673 | SvNOK_on(sv); | |
2674 | else | |
2675 | SvNOKp_on(sv); | |
2676 | #endif | |
93a17b20 | 2677 | } |
cd84013a | 2678 | else if (SvPOKp(sv)) { |
c2988b20 | 2679 | UV value; |
3823048b | 2680 | const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); |
041457d9 | 2681 | if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) |
a0d0e21e | 2682 | not_a_number(sv); |
28e5dec8 | 2683 | #ifdef NV_PRESERVES_UV |
c2988b20 NC |
2684 | if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) |
2685 | == IS_NUMBER_IN_UV) { | |
5e045b90 | 2686 | /* It's definitely an integer */ |
9d6ce603 | 2687 | SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); |
66d83377 | 2688 | } else { |
3823048b | 2689 | S_sv_setnv(aTHX_ sv, numtype); |
66d83377 | 2690 | } |
a43d94f2 NC |
2691 | if (numtype) |
2692 | SvNOK_on(sv); | |
2693 | else | |
2694 | SvNOKp_on(sv); | |
28e5dec8 | 2695 | #else |
e91de695 JH |
2696 | SvNV_set(sv, Atof(SvPVX_const(sv))); |
2697 | /* Only set the public NV OK flag if this NV preserves the value in | |
2698 | the PV at least as well as an IV/UV would. | |
2699 | Not sure how to do this 100% reliably. */ | |
2700 | /* if that shift count is out of range then Configure's test is | |
2701 | wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == | |
2702 | UV_BITS */ | |
2703 | if (((UV)1 << NV_PRESERVES_UV_BITS) > | |
2704 | U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { | |
2705 | SvNOK_on(sv); /* Definitely small enough to preserve all bits */ | |
2706 | } else if (!(numtype & IS_NUMBER_IN_UV)) { | |
2707 | /* Can't use strtol etc to convert this string, so don't try. | |
2708 | sv_2iv and sv_2uv will use the NV to convert, not the PV. */ | |
c2988b20 NC |
2709 | SvNOK_on(sv); |
2710 | } else { | |
e91de695 | 2711 | /* value has been set. It may not be precise. */ |
53e2bfb7 | 2712 | if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) { |
e91de695 JH |
2713 | /* 2s complement assumption for (UV)IV_MIN */ |
2714 | SvNOK_on(sv); /* Integer is too negative. */ | |
c2988b20 | 2715 | } else { |
e91de695 JH |
2716 | SvNOKp_on(sv); |
2717 | SvIOKp_on(sv); | |
6fa402ec | 2718 | |
e91de695 | 2719 | if (numtype & IS_NUMBER_NEG) { |
02b08bbc DM |
2720 | /* -IV_MIN is undefined, but we should never reach |
2721 | * this point with both IS_NUMBER_NEG and value == | |
2722 | * (UV)IV_MIN */ | |
2723 | assert(value != (UV)IV_MIN); | |
e91de695 JH |
2724 | SvIV_set(sv, -(IV)value); |
2725 | } else if (value <= (UV)IV_MAX) { | |
2726 | SvIV_set(sv, (IV)value); | |
2727 | } else { | |
2728 | SvUV_set(sv, value); | |
2729 | SvIsUV_on(sv); | |
2730 | } | |
c2988b20 | 2731 | |
e91de695 JH |
2732 | if (numtype & IS_NUMBER_NOT_INT) { |
2733 | /* I believe that even if the original PV had decimals, | |
2734 | they are lost beyond the limit of the FP precision. | |
2735 | However, neither is canonical, so both only get p | |
2736 | flags. NWC, 2000/11/25 */ | |
2737 | /* Both already have p flags, so do nothing */ | |
2738 | } else { | |
2739 | const NV nv = SvNVX(sv); | |
2740 | /* XXX should this spot have NAN_COMPARE_BROKEN, too? */ | |
2741 | if (SvNVX(sv) < (NV)IV_MAX + 0.5) { | |
2742 | if (SvIVX(sv) == I_V(nv)) { | |
2743 | SvNOK_on(sv); | |
2744 | } else { | |
2745 | /* It had no "." so it must be integer. */ | |
2746 | } | |
2747 | SvIOK_on(sv); | |
0f83c5a4 | 2748 | } else { |
e91de695 JH |
2749 | /* between IV_MAX and NV(UV_MAX). |
2750 | Could be slightly > UV_MAX */ | |
2751 | ||
2752 | if (numtype & IS_NUMBER_NOT_INT) { | |
2753 | /* UV and NV both imprecise. */ | |
0f83c5a4 | 2754 | } else { |
e91de695 JH |
2755 | const UV nv_as_uv = U_V(nv); |
2756 | ||
2757 | if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { | |
2758 | SvNOK_on(sv); | |
c2988b20 | 2759 | } |
e91de695 | 2760 | SvIOK_on(sv); |
c2988b20 NC |
2761 | } |
2762 | } | |
2763 | } | |
2764 | } | |
0f83c5a4 | 2765 | } |
e91de695 JH |
2766 | /* It might be more code efficient to go through the entire logic above |
2767 | and conditionally set with SvNOKp_on() rather than SvNOK(), but it | |
2768 | gets complex and potentially buggy, so more programmer efficient | |
2769 | to do it this way, by turning off the public flags: */ | |
2770 | if (!numtype) | |
2771 | SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); | |
28e5dec8 | 2772 | #endif /* NV_PRESERVES_UV */ |
93a17b20 | 2773 | } |
79072805 | 2774 | else { |
e91de695 JH |
2775 | if (isGV_with_GP(sv)) { |
2776 | glob_2number(MUTABLE_GV(sv)); | |
2777 | return 0.0; | |
2778 | } | |
180488f8 | 2779 | |
e91de695 JH |
2780 | if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
2781 | report_uninit(sv); | |
2782 | assert (SvTYPE(sv) >= SVt_NV); | |
2783 | /* Typically the caller expects that sv_any is not NULL now. */ | |
2784 | /* XXX Ilya implies that this is a bug in callers that assume this | |
2785 | and ideally should be fixed. */ | |
2786 | return 0.0; | |
79072805 | 2787 | } |
097ee67d | 2788 | DEBUG_c({ |
e91de695 JH |
2789 | STORE_NUMERIC_LOCAL_SET_STANDARD(); |
2790 | PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n", | |
2791 | PTR2UV(sv), SvNVX(sv)); | |
2792 | RESTORE_NUMERIC_LOCAL(); | |
2793 | }); | |
463ee0b2 | 2794 | return SvNVX(sv); |
79072805 LW |
2795 | } |
2796 | ||
800401ee JH |
2797 | /* |
2798 | =for apidoc sv_2num | |
2799 | ||
2800 | Return an SV with the numeric value of the source SV, doing any necessary | |
d024d1a7 FC |
2801 | reference or overload conversion. The caller is expected to have handled |
2802 | get-magic already. | |
800401ee JH |
2803 | |
2804 | =cut | |
2805 | */ | |
2806 | ||
2807 | SV * | |
5aaab254 | 2808 | Perl_sv_2num(pTHX_ SV *const sv) |
800401ee | 2809 | { |
7918f24d NC |
2810 | PERL_ARGS_ASSERT_SV_2NUM; |
2811 | ||
b9ee0594 RGS |
2812 | if (!SvROK(sv)) |
2813 | return sv; | |
800401ee | 2814 | if (SvAMAGIC(sv)) { |
31d632c3 | 2815 | SV * const tmpsv = AMG_CALLunary(sv, numer_amg); |
a02ec77a | 2816 | TAINT_IF(tmpsv && SvTAINTED(tmpsv)); |
800401ee JH |
2817 | if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) |
2818 | return sv_2num(tmpsv); | |
2819 | } | |
2820 | return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); | |
2821 | } | |
2822 | ||
645c22ef DM |
2823 | /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or |
2824 | * UV as a string towards the end of buf, and return pointers to start and | |
2825 | * end of it. | |
2826 | * | |
2827 | * We assume that buf is at least TYPE_CHARS(UV) long. | |
2828 | */ | |
2829 | ||
864dbfa3 | 2830 | static char * |
5de3775c | 2831 | S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) |
25da4f38 | 2832 | { |
25da4f38 | 2833 | char *ptr = buf + TYPE_CHARS(UV); |
823a54a3 | 2834 | char * const ebuf = ptr; |
25da4f38 | 2835 | int sign; |
25da4f38 | 2836 | |
7918f24d NC |
2837 | PERL_ARGS_ASSERT_UIV_2BUF; |
2838 | ||
25da4f38 IZ |
2839 | if (is_uv) |
2840 | sign = 0; | |
2841 | else if (iv >= 0) { | |
2842 | uv = iv; | |
2843 | sign = 0; | |
2844 | } else { | |
53e2bfb7 | 2845 | uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv); |
25da4f38 IZ |
2846 | sign = 1; |
2847 | } | |
2848 | do { | |
eb160463 | 2849 | *--ptr = '0' + (char)(uv % 10); |
25da4f38 IZ |
2850 | } while (uv /= 10); |
2851 | if (sign) | |
2852 | *--ptr = '-'; | |
2853 | *peob = ebuf; | |
2854 | return ptr; | |
2855 | } | |
2856 | ||
bfaa02d5 JH |
2857 | /* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an |
2858 | * infinity or a not-a-number, writes the appropriate strings to the | |
2859 | * buffer, including a zero byte. On success returns the written length, | |
3bde2d43 JH |
2860 | * excluding the zero byte, on failure (not an infinity, not a nan) |
2861 | * returns zero, assert-fails on maxlen being too short. | |
3823048b JH |
2862 | * |
2863 | * XXX for "Inf", "-Inf", and "NaN", we could have three read-only | |
2864 | * shared string constants we point to, instead of generating a new | |
2865 | * string for each instance. */ | |
bfaa02d5 | 2866 | STATIC size_t |
3823048b | 2867 | S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) { |
3bde2d43 | 2868 | char* s = buffer; |
bfaa02d5 | 2869 | assert(maxlen >= 4); |
3bde2d43 JH |
2870 | if (Perl_isinf(nv)) { |
2871 | if (nv < 0) { | |
2872 | if (maxlen < 5) /* "-Inf\0" */ | |
2873 | return 0; | |
2874 | *s++ = '-'; | |
2875 | } else if (plus) { | |
2876 | *s++ = '+'; | |
6e915616 | 2877 | } |
3bde2d43 JH |
2878 | *s++ = 'I'; |
2879 | *s++ = 'n'; | |
2880 | *s++ = 'f'; | |
2881 | } | |
2882 | else if (Perl_isnan(nv)) { | |
2883 | *s++ = 'N'; | |
2884 | *s++ = 'a'; | |
2885 | *s++ = 'N'; | |
2886 | /* XXX optionally output the payload mantissa bits as | |
2887 | * "(unsigned)" (to match the nan("...") C99 function, | |
2888 | * or maybe as "(0xhhh...)" would make more sense... | |
2889 | * provide a format string so that the user can decide? | |
2890 | * NOTE: would affect the maxlen and assert() logic.*/ | |
2891 | } | |
2892 | else { | |
2893 | return 0; | |
bfaa02d5 | 2894 | } |
3bde2d43 JH |
2895 | assert((s == buffer + 3) || (s == buffer + 4)); |
2896 | *s++ = 0; | |
2897 | return s - buffer - 1; /* -1: excluding the zero byte */ | |
bfaa02d5 JH |
2898 | } |
2899 | ||
2900 | /* | |
2901 | =for apidoc sv_2pv_flags | |
2902 | ||
796b6530 | 2903 | Returns a pointer to the string value of an SV, and sets C<*lp> to its length. |
c5608a1f | 2904 | If flags has the C<SV_GMAGIC> bit set, does an C<mg_get()> first. Coerces C<sv> to a |
bfaa02d5 JH |
2905 | string if necessary. Normally invoked via the C<SvPV_flags> macro. |
2906 | C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too. | |
2907 | ||
2908 | =cut | |
2909 | */ | |
2910 | ||
2911 | char * | |
2912 | Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) | |
2913 | { | |
2914 | char *s; | |
2915 | ||
2916 | PERL_ARGS_ASSERT_SV_2PV_FLAGS; | |
2917 | ||
2918 | assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV | |
2919 | && SvTYPE(sv) != SVt_PVFM); | |
2920 | if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) | |
2921 | mg_get(sv); | |
2922 | if (SvROK(sv)) { | |
2923 | if (SvAMAGIC(sv)) { | |
2924 | SV *tmpstr; | |
2925 | if (flags & SV_SKIP_OVERLOAD) | |
2926 | return NULL; | |
2927 | tmpstr = AMG_CALLunary(sv, string_amg); | |
2928 | TAINT_IF(tmpstr && SvTAINTED(tmpstr)); | |
2929 | if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { | |
2930 | /* Unwrap this: */ | |
2931 | /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); | |
2932 | */ | |
2933 | ||
2934 | char *pv; | |
2935 | if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { | |
2936 | if (flags & SV_CONST_RETURN) { | |
2937 | pv = (char *) SvPVX_const(tmpstr); | |
2938 | } else { | |
2939 | pv = (flags & SV_MUTABLE_RETURN) | |
2940 | ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); | |
2941 | } | |
2942 | if (lp) | |
2943 | *lp = SvCUR(tmpstr); | |
2944 | } else { | |
2945 | pv = sv_2pv_flags(tmpstr, lp, flags); | |
2946 | } | |
2947 | if (SvUTF8(tmpstr)) | |
2948 | SvUTF8_on(sv); | |
2949 | else | |
2950 | SvUTF8_off(sv); | |
2951 | return pv; | |
2952 | } | |
2953 | } | |
2954 | { | |
2955 | STRLEN len; | |
2956 | char *retval; | |
2957 | char *buffer; | |
2958 | SV *const referent = SvRV(sv); | |
2959 | ||
2960 | if (!referent) { | |
2961 | len = 7; | |
2962 | retval = buffer = savepvn("NULLREF", len); | |
2963 | } else if (SvTYPE(referent) == SVt_REGEXP && | |
2964 | (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || | |
2965 | amagic_is_enabled(string_amg))) { | |
2966 | REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); | |
2967 | ||
2968 | assert(re); | |
2969 | ||
2970 | /* If the regex is UTF-8 we want the containing scalar to | |
2971 | have an UTF-8 flag too */ | |
2972 | if (RX_UTF8(re)) | |
2973 | SvUTF8_on(sv); | |
2974 | else | |
2975 | SvUTF8_off(sv); | |
2976 | ||
2977 | if (lp) | |
2978 | *lp = RX_WRAPLEN(re); | |
2979 | ||
2980 | return RX_WRAPPED(re); | |
2981 | } else { | |
2982 | const char *const typestr = sv_reftype(referent, 0); | |
2983 | const STRLEN typelen = strlen(typestr); | |
2984 | UV addr = PTR2UV(referent); | |
2985 | const char *stashname = NULL; | |
2986 | STRLEN stashnamelen = 0; /* hush, gcc */ | |
2987 | const char *buffer_end; | |
2988 | ||
2989 | if (SvOBJECT(referent)) { | |
2990 | const HEK *const name = HvNAME_HEK(SvSTASH(referent)); | |
2991 | ||
2992 | if (name) { | |
2993 | stashname = HEK_KEY(name); | |
2994 | stashnamelen = HEK_LEN(name); | |
2995 | ||
2996 | if (HEK_UTF8(name)) { | |
2997 | SvUTF8_on(sv); | |
2998 | } else { | |
2999 | SvUTF8_off(sv); | |
3000 | } | |
3001 | } else { | |
3002 | stashname = "__ANON__"; | |
3003 | stashnamelen = 8; | |
3004 | } | |
3005 | len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ | |
3006 | + 2 * sizeof(UV) + 2 /* )\0 */; | |
3007 | } else { | |
3008 | len = typelen + 3 /* (0x */ | |
3009 | + 2 * sizeof(UV) + 2 /* )\0 */; | |
3010 | } | |
fafee734 | 3011 | |
4bac9ae4 CS |
3012 | Newx(buffer, len, char); |
3013 | buffer_end = retval = buffer + len; | |
3014 | ||
3015 | /* Working backwards */ | |
3016 | *--retval = '\0'; | |
3017 | *--retval = ')'; | |
3018 | do { | |
3019 | *--retval = PL_hexdigit[addr & 15]; | |
3020 | } while (addr >>= 4); | |
3021 | *--retval = 'x'; | |
3022 | *--retval = '0'; | |
3023 | *--retval = '('; | |
3024 | ||
3025 | retval -= typelen; | |
3026 | memcpy(retval, typestr, typelen); | |
3027 | ||
3028 | if (stashname) { | |
3029 | *--retval = '='; | |
3030 | retval -= stashnamelen; | |
3031 | memcpy(retval, stashname, stashnamelen); | |
c080367d | 3032 | } |
4bac9ae4 CS |
3033 | /* retval may not necessarily have reached the start of the |
3034 | buffer here. */ | |
3035 | assert (retval >= buffer); | |
3036 | ||
3037 | len = buffer_end - retval - 1; /* -1 for that \0 */ | |
463ee0b2 | 3038 | } |
cdb061a3 | 3039 | if (lp) |
4bac9ae4 CS |
3040 | *lp = len; |
3041 | SAVEFREEPV(buffer); | |
3042 | return retval; | |
79072805 | 3043 | } |
79072805 | 3044 | } |
4bac9ae4 CS |
3045 | |
3046 | if (SvPOKp(sv)) { | |
3047 | if (lp) | |
3048 | *lp = SvCUR(sv); | |
3049 | if (flags & SV_MUTABLE_RETURN) | |
3050 | return SvPVX_mutable(sv); | |
3051 | if (flags & SV_CONST_RETURN) | |
3052 | return (char *)SvPVX_const(sv); | |
3053 | return SvPVX(sv); | |
3054 | } | |
3055 | ||
3056 | if (SvIOK(sv)) { | |
28e5dec8 JH |
3057 | /* I'm assuming that if both IV and NV are equally valid then |
3058 | converting the IV is going to be more efficient */ | |
e1ec3a88 | 3059 | const U32 isUIOK = SvIsUV(sv); |
28e5dec8 JH |
3060 | char buf[TYPE_CHARS(UV)]; |
3061 | char *ebuf, *ptr; | |
97a130b8 | 3062 | STRLEN len; |
28e5dec8 JH |
3063 | |
3064 | if (SvTYPE(sv) < SVt_PVIV) | |
3065 | sv_upgrade(sv, SVt_PVIV); | |
4ea1d550 | 3066 | ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); |
97a130b8 | 3067 | len = ebuf - ptr; |
5902b6a9 | 3068 | /* inlined from sv_setpvn */ |
97a130b8 NC |
3069 | s = SvGROW_mutable(sv, len + 1); |
3070 | Move(ptr, s, len, char); | |
3071 | s += len; | |
28e5dec8 | 3072 | *s = '\0'; |
b127e37e | 3073 | SvPOK_on(sv); |
28e5dec8 | 3074 | } |
4bac9ae4 | 3075 | else if (SvNOK(sv)) { |
79072805 LW |
3076 | if (SvTYPE(sv) < SVt_PVNV) |
3077 | sv_upgrade(sv, SVt_PVNV); | |
128eeacb DD |
3078 | if (SvNVX(sv) == 0.0 |
3079 | #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) | |
3080 | && !Perl_isnan(SvNVX(sv)) | |
3081 | #endif | |
3082 | ) { | |
29912d93 NC |
3083 | s = SvGROW_mutable(sv, 2); |
3084 | *s++ = '0'; | |
3085 | *s = '\0'; | |
3086 | } else { | |
5e85836e | 3087 | STRLEN len; |
fb8cdbc5 | 3088 | STRLEN size = 5; /* "-Inf\0" */ |
0c7e610f | 3089 | |
fb8cdbc5 | 3090 | s = SvGROW_mutable(sv, size); |
3823048b | 3091 | len = S_infnan_2pv(SvNVX(sv), s, size, 0); |
fb8cdbc5 | 3092 | if (len > 0) { |
0c7e610f | 3093 | s += len; |
fb8cdbc5 JH |
3094 | SvPOK_on(sv); |
3095 | } | |
0c7e610f | 3096 | else { |
0c7e610f | 3097 | /* some Xenix systems wipe out errno here */ |
fb8cdbc5 JH |
3098 | dSAVE_ERRNO; |
3099 | ||
3840bff0 JH |
3100 | size = |
3101 | 1 + /* sign */ | |
3102 | 1 + /* "." */ | |
3103 | NV_DIG + | |
3104 | 1 + /* "e" */ | |
3105 | 1 + /* sign */ | |
3106 | 5 + /* exponent digits */ | |
3107 | 1 + /* \0 */ | |
3108 | 2; /* paranoia */ | |
b127e37e | 3109 | |
fb8cdbc5 | 3110 | s = SvGROW_mutable(sv, size); |
b127e37e | 3111 | #ifndef USE_LOCALE_NUMERIC |
a4eca1d4 JH |
3112 | SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG); |
3113 | ||
0c7e610f JH |
3114 | SvPOK_on(sv); |
3115 | #else | |
28acfe03 | 3116 | { |
3840bff0 | 3117 | bool local_radix; |
67d796ae KW |
3118 | DECLARATION_FOR_LC_NUMERIC_MANIPULATION; |
3119 | STORE_LC_NUMERIC_SET_TO_NEEDED(); | |
3840bff0 JH |
3120 | |
3121 | local_radix = | |
3122 | PL_numeric_local && | |
3123 | PL_numeric_radix_sv && | |
3124 | SvUTF8(PL_numeric_radix_sv); | |
3125 | if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) { | |
3126 | size += SvLEN(PL_numeric_radix_sv) - 1; | |
3127 | s = SvGROW_mutable(sv, size); | |
3128 | } | |
3129 | ||
a4eca1d4 | 3130 | SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG); |
0c7e610f JH |
3131 | |
3132 | /* If the radix character is UTF-8, and actually is in the | |
3133 | * output, turn on the UTF-8 flag for the scalar */ | |
3840bff0 JH |
3134 | if (local_radix && |
3135 | instr(s, SvPVX_const(PL_numeric_radix_sv))) { | |
3136 | SvUTF8_on(sv); | |
3137 | } | |
3138 | ||
0c7e610f | 3139 | RESTORE_LC_NUMERIC(); |
28acfe03 | 3140 | } |
68e8f474 | 3141 | |
0c7e610f JH |
3142 | /* We don't call SvPOK_on(), because it may come to |
3143 | * pass that the locale changes so that the | |
3144 | * stringification we just did is no longer correct. We | |
3145 | * will have to re-stringify every time it is needed */ | |
b127e37e | 3146 | #endif |
0c7e610f JH |
3147 | RESTORE_ERRNO; |
3148 | } | |
3149 | while (*s) s++; | |
bbce6d69 | 3150 | } |
79072805 | 3151 | } |
4bac9ae4 CS |
3152 | else if (isGV_with_GP(sv)) { |
3153 | GV *const gv = MUTABLE_GV(sv); | |
3154 | SV *const buffer = sv_newmortal(); | |
8d1c3e26 | 3155 | |
4bac9ae4 | 3156 | gv_efullname3(buffer, gv, "*"); |
180488f8 | 3157 | |
4bac9ae4 CS |
3158 | assert(SvPOK(buffer)); |
3159 | if (SvUTF8(buffer)) | |
3160 | SvUTF8_on(sv); | |
3161 | if (lp) | |
3162 | *lp = SvCUR(buffer); | |
3163 | return SvPVX(buffer); | |
3164 | } | |
8d919b0a FC |
3165 | else if (isREGEXP(sv)) { |
3166 | if (lp) *lp = RX_WRAPLEN((REGEXP *)sv); | |
3167 | return RX_WRAPPED((REGEXP *)sv); | |
3168 | } | |
4bac9ae4 | 3169 | else { |
cdb061a3 | 3170 | if (lp) |
00b6aa41 | 3171 | *lp = 0; |
9f621bb0 NC |
3172 | if (flags & SV_UNDEF_RETURNS_NULL) |
3173 | return NULL; | |
4f62cd62 | 3174 | if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) |
9f621bb0 | 3175 | report_uninit(sv); |
4bac9ae4 CS |
3176 | /* Typically the caller expects that sv_any is not NULL now. */ |
3177 | if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) | |
25da4f38 | 3178 | sv_upgrade(sv, SVt_PV); |
73d840c0 | 3179 | return (char *)""; |
79072805 | 3180 | } |
4bac9ae4 | 3181 | |
cdb061a3 | 3182 | { |
823a54a3 | 3183 | const STRLEN len = s - SvPVX_const(sv); |
cdb061a3 NC |
3184 | if (lp) |
3185 | *lp = len; | |
3186 | SvCUR_set(sv, len); | |
3187 | } | |
1d7c1841 | 3188 | DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n", |
3f7c398e | 3189 | PTR2UV(sv),SvPVX_const(sv))); |
4d84ee25 NC |
3190 | if (flags & SV_CONST_RETURN) |
3191 | return (char *)SvPVX_const(sv); | |
10516c54 NC |
3192 | if (flags & SV_MUTABLE_RETURN) |
3193 | return SvPVX_mutable(sv); | |
463ee0b2 LW |
3194 | return SvPVX(sv); |
3195 | } | |
3196 | ||
645c22ef | 3197 | /* |
6050d10e JP |
3198 | =for apidoc sv_copypv |
3199 | ||
3200 | Copies a stringified representation of the source SV into the | |
796b6530 | 3201 | destination SV. Automatically performs any necessary C<mg_get> and |
54f0641b | 3202 | coercion of numeric values into strings. Guaranteed to preserve |
796b6530 KW |
3203 | C<UTF8> flag even from overloaded objects. Similar in nature to |
3204 | C<sv_2pv[_flags]> but operates directly on an SV instead of just the | |
3205 | string. Mostly uses C<sv_2pv_flags> to do its work, except when that | |
6050d10e JP |
3206 | would lose the UTF-8'ness of the PV. |
3207 | ||
4bac9ae4 CS |
3208 | =for apidoc sv_copypv_nomg |
3209 | ||
796b6530 | 3210 | Like C<sv_copypv>, but doesn't invoke get magic first. |
4bac9ae4 CS |
3211 | |
3212 | =for apidoc sv_copypv_flags | |
3213 | ||
796b6530 | 3214 | Implementation of C<sv_copypv> and C<sv_copypv_nomg>. Calls get magic iff flags |
c5608a1f | 3215 | has the C<SV_GMAGIC> bit set. |
4bac9ae4 | 3216 | |
6050d10e JP |
3217 | =cut |
3218 | */ | |
3219 | ||
3220 | void | |
5aaab254 | 3221 | Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) |
4bac9ae4 | 3222 | { |
446eaa42 | 3223 | STRLEN len; |
4bac9ae4 | 3224 | const char *s; |
7918f24d | 3225 | |
4bac9ae4 | 3226 | PERL_ARGS_ASSERT_SV_COPYPV_FLAGS; |
7918f24d | 3227 | |
c77ed9ca | 3228 | s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC)); |
cb50f42d | 3229 | sv_setpvn(dsv,s,len); |
446eaa42 | 3230 | if (SvUTF8(ssv)) |
cb50f42d | 3231 | SvUTF8_on(dsv); |
446eaa42 | 3232 | else |
cb50f42d | 3233 | SvUTF8_off(dsv); |
6050d10e JP |
3234 | } |
3235 | ||
3236 | /* | |
645c22ef DM |
3237 | =for apidoc sv_2pvbyte |
3238 | ||
796b6530 | 3239 | Return a pointer to the byte-encoded representation of the SV, and set C<*lp> |
1e54db1a | 3240 | to its length. May cause the SV to be downgraded from UTF-8 as a |
645c22ef DM |
3241 | side-effect. |
3242 | ||
3243 | Usually accessed via the C<SvPVbyte> macro. | |
3244 | ||
3245 | =cut | |
3246 | */ | |
3247 | ||
7340a771 | 3248 | char * |
5aaab254 | 3249 | Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp) |
7340a771 | 3250 | { |
7918f24d NC |
3251 | PERL_ARGS_ASSERT_SV_2PVBYTE; |
3252 | ||
48120f8f | 3253 | SvGETMAGIC(sv); |
4499db73 FC |
3254 | if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) |
3255 | || isGV_with_GP(sv) || SvROK(sv)) { | |
a901b181 | 3256 | SV *sv2 = sv_newmortal(); |
48120f8f | 3257 | sv_copypv_nomg(sv2,sv); |
a901b181 FC |
3258 | sv = sv2; |
3259 | } | |
0875d2fe | 3260 | sv_utf8_downgrade(sv,0); |
71eb6d8c | 3261 | return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); |
7340a771 GS |
3262 | } |
3263 | ||
645c22ef | 3264 | /* |
035cbb0e RGS |
3265 | =for apidoc sv_2pvutf8 |
3266 | ||
796b6530 | 3267 | Return a pointer to the UTF-8-encoded representation of the SV, and set C<*lp> |
035cbb0e RGS |
3268 | to its length. May cause the SV to be upgraded to UTF-8 as a side-effect. |
3269 | ||
3270 | Usually accessed via the C<SvPVutf8> macro. | |
3271 | ||
3272 | =cut | |
3273 | */ | |
645c22ef | 3274 | |
7340a771 | 3275 | char * |
5aaab254 | 3276 | Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp) |
7340a771 | 3277 | { |
7918f24d NC |
3278 | PERL_ARGS_ASSERT_SV_2PVUTF8; |
3279 | ||
4499db73 FC |
3280 | if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) |
3281 | || isGV_with_GP(sv) || SvROK(sv)) | |
fe46cbda | 3282 | sv = sv_mortalcopy(sv); |
4bac9ae4 CS |
3283 | else |
3284 | SvGETMAGIC(sv); | |
3285 | sv_utf8_upgrade_nomg(sv); | |
c3ec315f | 3286 | return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); |
7340a771 | 3287 | } |
1c846c1f | 3288 | |
7ee2227d | 3289 | |
645c22ef DM |
3290 | /* |
3291 | =for apidoc sv_2bool | |
3292 | ||
796b6530 KW |
3293 | This macro is only used by C<sv_true()> or its macro equivalent, and only if |
3294 | the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>. | |
3295 | It calls C<sv_2bool_flags> with the C<SV_GMAGIC> flag. | |
06c841cf FC |
3296 | |
3297 | =for apidoc sv_2bool_flags | |
3298 | ||
796b6530 KW |
3299 | This function is only used by C<sv_true()> and friends, and only if |
3300 | the latter's argument is neither C<SvPOK>, C<SvIOK> nor C<SvNOK>. If the flags | |
3301 | contain C<SV_GMAGIC>, then it does an C<mg_get()> first. | |
06c841cf | 3302 | |
645c22ef DM |
3303 | |
3304 | =cut | |
3305 | */ | |
3306 | ||
463ee0b2 | 3307 | bool |
9d176cd8 | 3308 | Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) |
463ee0b2 | 3309 | { |
06c841cf | 3310 | PERL_ARGS_ASSERT_SV_2BOOL_FLAGS; |
7918f24d | 3311 | |
9d176cd8 | 3312 | restart: |
06c841cf | 3313 | if(flags & SV_GMAGIC) SvGETMAGIC(sv); |
463ee0b2 | 3314 | |
a0d0e21e LW |
3315 | if (!SvOK(sv)) |
3316 | return 0; | |
3317 | if (SvROK(sv)) { | |
fabdb6c0 | 3318 | if (SvAMAGIC(sv)) { |
31d632c3 | 3319 | SV * const tmpsv = AMG_CALLunary(sv, bool__amg); |
9d176cd8 DD |
3320 | if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { |
3321 | bool svb; | |
3322 | sv = tmpsv; | |
3323 | if(SvGMAGICAL(sv)) { | |
3324 | flags = SV_GMAGIC; | |
3325 | goto restart; /* call sv_2bool */ | |
3326 | } | |
3327 | /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */ | |
3328 | else if(!SvOK(sv)) { | |
3329 | svb = 0; | |
3330 | } | |
3331 | else if(SvPOK(sv)) { | |
3332 | svb = SvPVXtrue(sv); | |
3333 | } | |
3334 | else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) { | |
3335 | svb = (SvIOK(sv) && SvIVX(sv) != 0) | |
659c4b96 | 3336 | || (SvNOK(sv) && SvNVX(sv) != 0.0); |
9d176cd8 DD |
3337 | } |
3338 | else { | |
3339 | flags = 0; | |
3340 | goto restart; /* call sv_2bool_nomg */ | |
3341 | } | |
3342 | return cBOOL(svb); | |
3343 | } | |
fabdb6c0 AL |
3344 | } |
3345 | return SvRV(sv) != 0; | |
a0d0e21e | 3346 | } |
85b7d9b3 FC |
3347 | if (isREGEXP(sv)) |
3348 | return | |
3349 | RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); | |
4bac9ae4 | 3350 | return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0); |
79072805 LW |
3351 | } |
3352 | ||
c461cf8f JH |
3353 | /* |
3354 | =for apidoc sv_utf8_upgrade | |
3355 | ||
78ea37eb | 3356 | Converts the PV of an SV to its UTF-8-encoded form. |
645c22ef | 3357 | Forces the SV to string form if it is not already. |
2bbc8d55 | 3358 | Will C<mg_get> on C<sv> if appropriate. |
796b6530 | 3359 | Always sets the C<SvUTF8> flag to avoid future validity checks even |
2bbc8d55 SP |
3360 | if the whole string is the same in UTF-8 as not. |
3361 | Returns the number of bytes in the converted string | |
c461cf8f | 3362 | |
0efd0472 | 3363 | This is not a general purpose byte encoding to Unicode interface: |
13a6c0e0 JH |
3364 | use the Encode extension for that. |
3365 | ||
fe749c9a KW |
3366 | =for apidoc sv_utf8_upgrade_nomg |
3367 | ||
796b6530 | 3368 | Like C<sv_utf8_upgrade>, but doesn't do magic on C<sv>. |
fe749c9a | 3369 | |
8d6d96c1 HS |
3370 | =for apidoc sv_utf8_upgrade_flags |
3371 | ||
78ea37eb | 3372 | Converts the PV of an SV to its UTF-8-encoded form. |
645c22ef | 3373 | Forces the SV to string form if it is not already. |
8d6d96c1 | 3374 | Always sets the SvUTF8 flag to avoid future validity checks even |
960b0271 FC |
3375 | if all the bytes are invariant in UTF-8. |
3376 | If C<flags> has C<SV_GMAGIC> bit set, | |
2bbc8d55 | 3377 | will C<mg_get> on C<sv> if appropriate, else not. |
2a590426 | 3378 | |
796b6530 | 3379 | If C<flags> has C<SV_FORCE_UTF8_UPGRADE> set, this function assumes that the PV |
2a590426 KW |
3380 | will expand when converted to UTF-8, and skips the extra work of checking for |
3381 | that. Typically this flag is used by a routine that has already parsed the | |
3382 | string and found such characters, and passes this information on so that the | |
3383 | work doesn't have to be repeated. | |
3384 | ||
3385 | Returns the number of bytes in the converted string. | |
8d6d96c1 | 3386 | |
0efd0472 | 3387 | This is not a general purpose byte encoding to Unicode interface: |
13a6c0e0 JH |
3388 | use the Encode extension for that. |
3389 | ||
2a590426 | 3390 | =for apidoc sv_utf8_upgrade_flags_grow |
b3ab6785 | 3391 | |
796b6530 KW |
3392 | Like C<sv_utf8_upgrade_flags>, but has an additional parameter C<extra>, which is |
3393 | the number of unused bytes the string of C<sv> is guaranteed to have free after | |
2a590426 KW |
3394 | it upon return. This allows the caller to reserve extra space that it intends |
3395 | to fill, to avoid extra grows. | |
b3ab6785 | 3396 | |
2a590426 KW |
3397 | C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags> |
3398 | are implemented in terms of this function. | |
3399 | ||
3400 | Returns the number of bytes in the converted string (not including the spares). | |
3401 | ||
3402 | =cut | |
b3ab6785 KW |
3403 | |
3404 | (One might think that the calling routine could pass in the position of the | |
2a590426 KW |
3405 | first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't |
3406 | have to be found again. But that is not the case, because typically when the | |
3407 | caller is likely to use this flag, it won't be calling this routine unless it | |
3408 | finds something that won't fit into a byte. Otherwise it tries to not upgrade | |
3409 | and just use bytes. But some things that do fit into a byte are variants in | |
3410 | utf8, and the caller may not have been keeping track of these.) | |
b3ab6785 | 3411 | |
6602b933 KW |
3412 | If the routine itself changes the string, it adds a trailing C<NUL>. Such a |
3413 | C<NUL> isn't guaranteed due to having other routines do the work in some input | |
3414 | cases, or if the input is already flagged as being in utf8. | |
b3ab6785 KW |
3415 | |
3416 | The speed of this could perhaps be improved for many cases if someone wanted to | |
3417 | write a fast function that counts the number of variant characters in a string, | |
3418 | especially if it could return the position of the first one. | |
3419 | ||
8d6d96c1 HS |
3420 | */ |
3421 | ||
3422 | STRLEN | |
5aaab254 | 3423 | Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) |
8d6d96c1 | 3424 | { |
b3ab6785 | 3425 | PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; |
7918f24d | 3426 | |
808c356f RGS |
3427 | if (sv == &PL_sv_undef) |
3428 | return 0; | |
892f9127 | 3429 | if (!SvPOK_nog(sv)) { |
e0e62c2a | 3430 | STRLEN len = 0; |
d52b7888 NC |
3431 | if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { |
3432 | (void) sv_2pv_flags(sv,&len, flags); | |
b3ab6785 KW |
3433 | if (SvUTF8(sv)) { |
3434 | if (extra) SvGROW(sv, SvCUR(sv) + extra); | |
d52b7888 | 3435 | return len; |
b3ab6785 | 3436 | } |
d52b7888 | 3437 | } else { |
33fb6f35 | 3438 | (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); |
d52b7888 | 3439 | } |
e0e62c2a | 3440 | } |
4411f3b6 | 3441 | |
f5cee72b | 3442 | if (SvUTF8(sv)) { |
b3ab6785 | 3443 | if (extra) SvGROW(sv, SvCUR(sv) + extra); |
5fec3b1d | 3444 | return SvCUR(sv); |
f5cee72b | 3445 | } |
5fec3b1d | 3446 | |
765f542d | 3447 | if (SvIsCOW(sv)) { |
c56ed9f6 | 3448 | S_sv_uncow(aTHX_ sv, 0); |
db42d148 NIS |
3449 | } |
3450 | ||
47e13f24 | 3451 | if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) { |
ad2de1b2 | 3452 | sv_recode_to_utf8(sv, _get_encoding()); |
b3ab6785 KW |
3453 | if (extra) SvGROW(sv, SvCUR(sv) + extra); |
3454 | return SvCUR(sv); | |
3455 | } | |
3456 | ||
4e93345f KW |
3457 | if (SvCUR(sv) == 0) { |
3458 | if (extra) SvGROW(sv, extra); | |
3459 | } else { /* Assume Latin-1/EBCDIC */ | |
c4e7c712 | 3460 | /* This function could be much more efficient if we |
2bbc8d55 | 3461 | * had a FLAG in SVs to signal if there are any variant |
c4e7c712 | 3462 | * chars in the PV. Given that there isn't such a flag |
b3ab6785 KW |
3463 | * make the loop as fast as possible (although there are certainly ways |
3464 | * to speed this up, eg. through vectorization) */ | |
3465 | U8 * s = (U8 *) SvPVX_const(sv); | |
3466 | U8 * e = (U8 *) SvEND(sv); | |
3467 | U8 *t = s; | |
3468 | STRLEN two_byte_count = 0; | |
c4e7c712 | 3469 | |
b3ab6785 KW |
3470 | if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; |
3471 | ||
3472 | /* See if really will need to convert to utf8. We mustn't rely on our | |
3473 | * incoming SV being well formed and having a trailing '\0', as certain | |
3474 | * code in pp_formline can send us partially built SVs. */ | |
3475 | ||
c4e7c712 | 3476 | while (t < e) { |
53c1dcc0 | 3477 | const U8 ch = *t++; |
6f2d5cbc | 3478 | if (NATIVE_BYTE_IS_INVARIANT(ch)) continue; |
b3ab6785 KW |
3479 | |
3480 | t--; /* t already incremented; re-point to first variant */ | |
3481 | two_byte_count = 1; | |
3482 | goto must_be_utf8; | |
c4e7c712 | 3483 | } |
b3ab6785 KW |
3484 | |
3485 | /* utf8 conversion not needed because all are invariants. Mark as | |
3486 | * UTF-8 even if no variant - saves scanning loop */ | |
c4e7c712 | 3487 | SvUTF8_on(sv); |
7f0bfbea | 3488 | if (extra) SvGROW(sv, SvCUR(sv) + extra); |
b3ab6785 KW |
3489 | return SvCUR(sv); |
3490 | ||
7b52d656 | 3491 | must_be_utf8: |
b3ab6785 KW |
3492 | |
3493 | /* Here, the string should be converted to utf8, either because of an | |
3494 | * input flag (two_byte_count = 0), or because a character that | |
3495 | * requires 2 bytes was found (two_byte_count = 1). t points either to | |
3496 | * the beginning of the string (if we didn't examine anything), or to | |
3497 | * the first variant. In either case, everything from s to t - 1 will | |
3498 | * occupy only 1 byte each on output. | |
3499 | * | |
3500 | * There are two main ways to convert. One is to create a new string | |
3501 | * and go through the input starting from the beginning, appending each | |
3502 | * converted value onto the new string as we go along. It's probably | |
3503 | * best to allocate enough space in the string for the worst possible | |
3504 | * case rather than possibly running out of space and having to | |
3505 | * reallocate and then copy what we've done so far. Since everything | |
3506 | * from s to t - 1 is invariant, the destination can be initialized | |
3507 | * with these using a fast memory copy | |
3508 | * | |
3509 | * The other way is to figure out exactly how big the string should be | |
3510 | * by parsing the entire input. Then you don't have to make it big | |
3511 | * enough to handle the worst possible case, and more importantly, if | |
3512 | * the string you already have is large enough, you don't have to | |
3513 | * allocate a new string, you can copy the last character in the input | |
3514 | * string to the final position(s) that will be occupied by the | |
3515 | * converted string and go backwards, stopping at t, since everything | |
3516 | * before that is invariant. | |
3517 | * | |
3518 | * There are advantages and disadvantages to each method. | |
3519 | * | |
3520 | * In the first method, we can allocate a new string, do the memory | |
3521 | * copy from the s to t - 1, and then proceed through the rest of the | |
3522 | * string byte-by-byte. | |
3523 | * | |
3524 | * In the second method, we proceed through the rest of the input | |
3525 | * string just calculating how big the converted string will be. Then | |
3526 | * there are two cases: | |
3527 | * 1) if the string has enough extra space to handle the converted | |
3528 | * value. We go backwards through the string, converting until we | |
3529 | * get to the position we are at now, and then stop. If this | |
3530 | * position is far enough along in the string, this method is | |
3531 | * faster than the other method. If the memory copy were the same | |
3532 | * speed as the byte-by-byte loop, that position would be about | |
3533 | * half-way, as at the half-way mark, parsing to the end and back | |
3534 | * is one complete string's parse, the same amount as starting | |
3535 | * over and going all the way through. Actually, it would be | |
3536 | * somewhat less than half-way, as it's faster to just count bytes | |
3537 | * than to also copy, and we don't have the overhead of allocating | |
3538 | * a new string, changing the scalar to use it, and freeing the | |
3539 | * existing one. But if the memory copy is fast, the break-even | |
3540 | * point is somewhere after half way. The counting loop could be | |
3541 | * sped up by vectorization, etc, to move the break-even point | |
3542 | * further towards the beginning. | |
3543 | * 2) if the string doesn't have enough space to handle the converted | |
3544 | * value. A new string will have to be allocated, and one might | |
3545 | * as well, given that, start from the beginning doing the first | |
3546 | * method. We've spent extra time parsing the string and in | |
3547 | * exchange all we've gotten is that we know precisely how big to | |
3548 | * make the new one. Perl is more optimized for time than space, | |
3549 | * so this case is a loser. | |
3550 | * So what I've decided to do is not use the 2nd method unless it is | |
3551 | * guaranteed that a new string won't have to be allocated, assuming | |
3552 | * the worst case. I also decided not to put any more conditions on it | |
3553 | * than this, for now. It seems likely that, since the worst case is | |
3554 | * twice as big as the unknown portion of the string (plus 1), we won't | |
3555 | * be guaranteed enough space, causing us to go to the first method, | |
3556 | * unless the string is short, or the first variant character is near | |
3557 | * the end of it. In either of these cases, it seems best to use the | |
3558 | * 2nd method. The only circumstance I can think of where this would | |
3559 | * be really slower is if the string had once had much more data in it | |
3560 | * than it does now, but there is still a substantial amount in it */ | |
3561 | ||
3562 | { | |
3563 | STRLEN invariant_head = t - s; | |
3564 | STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; | |
3565 | if (SvLEN(sv) < size) { | |
3566 | ||
3567 | /* Here, have decided to allocate a new string */ | |
3568 | ||
3569 | U8 *dst; | |
3570 | U8 *d; | |
3571 | ||
3572 | Newx(dst, size, U8); | |
3573 | ||
3574 | /* If no known invariants at the beginning of the input string, | |
3575 | * set so starts from there. Otherwise, can use memory copy to | |
3576 | * get up to where we are now, and then start from here */ | |
3577 | ||
5b26a7b3 | 3578 | if (invariant_head == 0) { |
b3ab6785 KW |
3579 | d = dst; |
3580 | } else { | |
3581 | Copy(s, dst, invariant_head, char); | |
3582 | d = dst + invariant_head; | |
3583 | } | |
3584 | ||
3585 | while (t < e) { | |
55d09dc8 KW |
3586 | append_utf8_from_native_byte(*t, &d); |
3587 | t++; | |
b3ab6785 KW |
3588 | } |
3589 | *d = '\0'; | |
3590 | SvPV_free(sv); /* No longer using pre-existing string */ | |
3591 | SvPV_set(sv, (char*)dst); | |
3592 | SvCUR_set(sv, d - dst); | |
3593 | SvLEN_set(sv, size); | |
3594 | } else { | |
3595 | ||
3596 | /* Here, have decided to get the exact size of the string. | |
3597 | * Currently this happens only when we know that there is | |
3598 | * guaranteed enough space to fit the converted string, so | |
3599 | * don't have to worry about growing. If two_byte_count is 0, | |
3600 | * then t points to the first byte of the string which hasn't | |
3601 | * been examined yet. Otherwise two_byte_count is 1, and t | |
3602 | * points to the first byte in the string that will expand to | |
3603 | * two. Depending on this, start examining at t or 1 after t. | |
3604 | * */ | |