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