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