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