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