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