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