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