This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Correct the paramter to Perl_op_xmldump(). The one that got away from
[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 156void
de37a194 157Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
77354fb4 158{
97aff369 159 dVAR;
77354fb4
NC
160 void *new_chunk;
161 U32 new_chunk_size;
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
de37a194 335Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const 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
de37a194 373S_visit(pTHX_ SVFUNC_t f, const U32 flags, const 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
de37a194 430do_clean_objs(pTHX_ SV *const 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
de37a194 506do_clean_all(pTHX_ SV *const 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*
de37a194 666Perl_get_arena(pTHX_ const size_t arena_size, const 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
288b8c02 919 /* something big */
08e44740
NC
920 { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
921 + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
922 SVt_REGEXP, FALSE, NONV, HASARENA,
923 FIT_ARENA(0, sizeof(struct regexp_allocated))
5c35adbb 924 },
4df7f6af 925
bd81e77b 926 /* 48 */
10666ae3 927 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
d2a0f284
JC
928 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
929
bd81e77b 930 /* 64 */
10666ae3 931 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
d2a0f284
JC
932 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
933
934 { sizeof(xpvav_allocated),
935 copy_length(XPVAV, xmg_stash)
936 - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
937 + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
9c59bb28 938 SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
d2a0f284
JC
939
940 { sizeof(xpvhv_allocated),
941 copy_length(XPVHV, xmg_stash)
942 - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
943 + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
9c59bb28 944 SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
d2a0f284 945
c84c4652 946 /* 56 */
4115f141 947 { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
c84c4652 948 + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
10666ae3 949 SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
d2a0f284 950
4115f141 951 { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
3038937b 952 + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
10666ae3 953 SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
d2a0f284
JC
954
955 /* XPVIO is 84 bytes, fits 48x */
167f2c4d
NC
956 { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
957 + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
958 SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
bd81e77b 959};
29489e7c 960
d2a0f284
JC
961#define new_body_type(sv_type) \
962 (void *)((char *)S_new_body(aTHX_ sv_type))
29489e7c 963
bd81e77b
NC
964#define del_body_type(p, sv_type) \
965 del_body(p, &PL_body_roots[sv_type])
29489e7c 966
29489e7c 967
bd81e77b 968#define new_body_allocated(sv_type) \
d2a0f284 969 (void *)((char *)S_new_body(aTHX_ sv_type) \
bd81e77b 970 - bodies_by_type[sv_type].offset)
29489e7c 971
bd81e77b
NC
972#define del_body_allocated(p, sv_type) \
973 del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
29489e7c 974
29489e7c 975
bd81e77b
NC
976#define my_safemalloc(s) (void*)safemalloc(s)
977#define my_safecalloc(s) (void*)safecalloc(s, 1)
978#define my_safefree(p) safefree((char*)p)
29489e7c 979
bd81e77b 980#ifdef PURIFY
29489e7c 981
bd81e77b
NC
982#define new_XNV() my_safemalloc(sizeof(XPVNV))
983#define del_XNV(p) my_safefree(p)
29489e7c 984
bd81e77b
NC
985#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
986#define del_XPVNV(p) my_safefree(p)
29489e7c 987
bd81e77b
NC
988#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
989#define del_XPVAV(p) my_safefree(p)
29489e7c 990
bd81e77b
NC
991#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
992#define del_XPVHV(p) my_safefree(p)
29489e7c 993
bd81e77b
NC
994#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
995#define del_XPVMG(p) my_safefree(p)
29489e7c 996
bd81e77b
NC
997#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
998#define del_XPVGV(p) my_safefree(p)
29489e7c 999
bd81e77b 1000#else /* !PURIFY */
29489e7c 1001
bd81e77b
NC
1002#define new_XNV() new_body_type(SVt_NV)
1003#define del_XNV(p) del_body_type(p, SVt_NV)
29489e7c 1004
bd81e77b
NC
1005#define new_XPVNV() new_body_type(SVt_PVNV)
1006#define del_XPVNV(p) del_body_type(p, SVt_PVNV)
29489e7c 1007
bd81e77b
NC
1008#define new_XPVAV() new_body_allocated(SVt_PVAV)
1009#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
645c22ef 1010
bd81e77b
NC
1011#define new_XPVHV() new_body_allocated(SVt_PVHV)
1012#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
645c22ef 1013
bd81e77b
NC
1014#define new_XPVMG() new_body_type(SVt_PVMG)
1015#define del_XPVMG(p) del_body_type(p, SVt_PVMG)
645c22ef 1016
bd81e77b
NC
1017#define new_XPVGV() new_body_type(SVt_PVGV)
1018#define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1d7c1841 1019
bd81e77b 1020#endif /* PURIFY */
93e68bfb 1021
bd81e77b 1022/* no arena for you! */
93e68bfb 1023
bd81e77b 1024#define new_NOARENA(details) \
d2a0f284 1025 my_safemalloc((details)->body_size + (details)->offset)
bd81e77b 1026#define new_NOARENAZ(details) \
d2a0f284
JC
1027 my_safecalloc((details)->body_size + (details)->offset)
1028
1029STATIC void *
de37a194 1030S_more_bodies (pTHX_ const svtype sv_type)
d2a0f284
JC
1031{
1032 dVAR;
1033 void ** const root = &PL_body_roots[sv_type];
96a5add6 1034 const struct body_details * const bdp = &bodies_by_type[sv_type];
d2a0f284
JC
1035 const size_t body_size = bdp->body_size;
1036 char *start;
1037 const char *end;
0b2d3faa 1038#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
23e9d66c
NC
1039 static bool done_sanity_check;
1040
0b2d3faa
JH
1041 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1042 * variables like done_sanity_check. */
10666ae3 1043 if (!done_sanity_check) {
ea471437 1044 unsigned int i = SVt_LAST;
10666ae3
NC
1045
1046 done_sanity_check = TRUE;
1047
1048 while (i--)
1049 assert (bodies_by_type[i].type == i);
1050 }
1051#endif
1052
23e9d66c
NC
1053 assert(bdp->arena_size);
1054
0a848332 1055 start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type);
d2a0f284
JC
1056
1057 end = start + bdp->arena_size - body_size;
1058
d2a0f284
JC
1059 /* computed count doesnt reflect the 1st slot reservation */
1060 DEBUG_m(PerlIO_printf(Perl_debug_log,
1061 "arena %p end %p arena-size %d type %d size %d ct %d\n",
6c9570dc 1062 (void*)start, (void*)end,
0e84aef4
JH
1063 (int)bdp->arena_size, sv_type, (int)body_size,
1064 (int)bdp->arena_size / (int)body_size));
d2a0f284
JC
1065
1066 *root = (void *)start;
1067
1068 while (start < end) {
1069 char * const next = start + body_size;
1070 *(void**) start = (void *)next;
1071 start = next;
1072 }
1073 *(void **)start = 0;
1074
1075 return *root;
1076}
1077
1078/* grab a new thing from the free list, allocating more if necessary.
1079 The inline version is used for speed in hot routines, and the
1080 function using it serves the rest (unless PURIFY).
1081*/
1082#define new_body_inline(xpv, sv_type) \
1083 STMT_START { \
1084 void ** const r3wt = &PL_body_roots[sv_type]; \
11b79775
DD
1085 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1086 ? *((void **)(r3wt)) : more_bodies(sv_type)); \
d2a0f284 1087 *(r3wt) = *(void**)(xpv); \
d2a0f284
JC
1088 } STMT_END
1089
1090#ifndef PURIFY
1091
1092STATIC void *
de37a194 1093S_new_body(pTHX_ const svtype sv_type)
d2a0f284
JC
1094{
1095 dVAR;
1096 void *xpv;
1097 new_body_inline(xpv, sv_type);
1098 return xpv;
1099}
1100
1101#endif
93e68bfb 1102
238b27b3
NC
1103static const struct body_details fake_rv =
1104 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1105
bd81e77b
NC
1106/*
1107=for apidoc sv_upgrade
93e68bfb 1108
bd81e77b
NC
1109Upgrade an SV to a more complex form. Generally adds a new body type to the
1110SV, then copies across as much information as possible from the old body.
1111You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
93e68bfb 1112
bd81e77b 1113=cut
93e68bfb 1114*/
93e68bfb 1115
bd81e77b 1116void
aad570aa 1117Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
cac9b346 1118{
97aff369 1119 dVAR;
bd81e77b
NC
1120 void* old_body;
1121 void* new_body;
42d0e0b7 1122 const svtype old_type = SvTYPE(sv);
d2a0f284 1123 const struct body_details *new_type_details;
238b27b3 1124 const struct body_details *old_type_details
bd81e77b 1125 = bodies_by_type + old_type;
4df7f6af 1126 SV *referant = NULL;
cac9b346 1127
bd81e77b
NC
1128 if (new_type != SVt_PV && SvIsCOW(sv)) {
1129 sv_force_normal_flags(sv, 0);
1130 }
cac9b346 1131
bd81e77b
NC
1132 if (old_type == new_type)
1133 return;
cac9b346 1134
bd81e77b 1135 old_body = SvANY(sv);
de042e1d 1136
bd81e77b
NC
1137 /* Copying structures onto other structures that have been neatly zeroed
1138 has a subtle gotcha. Consider XPVMG
cac9b346 1139
bd81e77b
NC
1140 +------+------+------+------+------+-------+-------+
1141 | NV | CUR | LEN | IV | MAGIC | STASH |
1142 +------+------+------+------+------+-------+-------+
1143 0 4 8 12 16 20 24 28
645c22ef 1144
bd81e77b
NC
1145 where NVs are aligned to 8 bytes, so that sizeof that structure is
1146 actually 32 bytes long, with 4 bytes of padding at the end:
08742458 1147
bd81e77b
NC
1148 +------+------+------+------+------+-------+-------+------+
1149 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1150 +------+------+------+------+------+-------+-------+------+
1151 0 4 8 12 16 20 24 28 32
08742458 1152
bd81e77b 1153 so what happens if you allocate memory for this structure:
30f9da9e 1154
bd81e77b
NC
1155 +------+------+------+------+------+-------+-------+------+------+...
1156 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1157 +------+------+------+------+------+-------+-------+------+------+...
1158 0 4 8 12 16 20 24 28 32 36
bfc44f79 1159
bd81e77b
NC
1160 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1161 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1162 started out as zero once, but it's quite possible that it isn't. So now,
1163 rather than a nicely zeroed GP, you have it pointing somewhere random.
1164 Bugs ensue.
bfc44f79 1165
bd81e77b
NC
1166 (In fact, GP ends up pointing at a previous GP structure, because the
1167 principle cause of the padding in XPVMG getting garbage is a copy of
6c9e42f7
NC
1168 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1169 this happens to be moot because XPVGV has been re-ordered, with GP
1170 no longer after STASH)
30f9da9e 1171
bd81e77b
NC
1172 So we are careful and work out the size of used parts of all the
1173 structures. */
bfc44f79 1174
bd81e77b
NC
1175 switch (old_type) {
1176 case SVt_NULL:
1177 break;
1178 case SVt_IV:
4df7f6af
NC
1179 if (SvROK(sv)) {
1180 referant = SvRV(sv);
238b27b3
NC
1181 old_type_details = &fake_rv;
1182 if (new_type == SVt_NV)
1183 new_type = SVt_PVNV;
4df7f6af
NC
1184 } else {
1185 if (new_type < SVt_PVIV) {
1186 new_type = (new_type == SVt_NV)
1187 ? SVt_PVNV : SVt_PVIV;
1188 }
bd81e77b
NC
1189 }
1190 break;
1191 case SVt_NV:
1192 if (new_type < SVt_PVNV) {
1193 new_type = SVt_PVNV;
bd81e77b
NC
1194 }
1195 break;
bd81e77b
NC
1196 case SVt_PV:
1197 assert(new_type > SVt_PV);
1198 assert(SVt_IV < SVt_PV);
1199 assert(SVt_NV < SVt_PV);
1200 break;
1201 case SVt_PVIV:
1202 break;
1203 case SVt_PVNV:
1204 break;
1205 case SVt_PVMG:
1206 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1207 there's no way that it can be safely upgraded, because perl.c
1208 expects to Safefree(SvANY(PL_mess_sv)) */
1209 assert(sv != PL_mess_sv);
1210 /* This flag bit is used to mean other things in other scalar types.
1211 Given that it only has meaning inside the pad, it shouldn't be set
1212 on anything that can get upgraded. */
00b1698f 1213 assert(!SvPAD_TYPED(sv));
bd81e77b
NC
1214 break;
1215 default:
1216 if (old_type_details->cant_upgrade)
c81225bc
NC
1217 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1218 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
bd81e77b 1219 }
3376de98
NC
1220
1221 if (old_type > new_type)
1222 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1223 (int)old_type, (int)new_type);
1224
2fa1109b 1225 new_type_details = bodies_by_type + new_type;
645c22ef 1226
bd81e77b
NC
1227 SvFLAGS(sv) &= ~SVTYPEMASK;
1228 SvFLAGS(sv) |= new_type;
932e9ff9 1229
ab4416c0
NC
1230 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1231 the return statements above will have triggered. */
1232 assert (new_type != SVt_NULL);
bd81e77b 1233 switch (new_type) {
bd81e77b
NC
1234 case SVt_IV:
1235 assert(old_type == SVt_NULL);
1236 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1237 SvIV_set(sv, 0);
1238 return;
1239 case SVt_NV:
1240 assert(old_type == SVt_NULL);
1241 SvANY(sv) = new_XNV();
1242 SvNV_set(sv, 0);
1243 return;
bd81e77b 1244 case SVt_PVHV:
bd81e77b 1245 case SVt_PVAV:
d2a0f284 1246 assert(new_type_details->body_size);
c1ae03ae
NC
1247
1248#ifndef PURIFY
1249 assert(new_type_details->arena);
d2a0f284 1250 assert(new_type_details->arena_size);
c1ae03ae 1251 /* This points to the start of the allocated area. */
d2a0f284
JC
1252 new_body_inline(new_body, new_type);
1253 Zero(new_body, new_type_details->body_size, char);
c1ae03ae
NC
1254 new_body = ((char *)new_body) - new_type_details->offset;
1255#else
1256 /* We always allocated the full length item with PURIFY. To do this
1257 we fake things so that arena is false for all 16 types.. */
1258 new_body = new_NOARENAZ(new_type_details);
1259#endif
1260 SvANY(sv) = new_body;
1261 if (new_type == SVt_PVAV) {
1262 AvMAX(sv) = -1;
1263 AvFILLp(sv) = -1;
1264 AvREAL_only(sv);
64484faa 1265 if (old_type_details->body_size) {
ac572bf4
NC
1266 AvALLOC(sv) = 0;
1267 } else {
1268 /* It will have been zeroed when the new body was allocated.
1269 Lets not write to it, in case it confuses a write-back
1270 cache. */
1271 }
78ac7dd9
NC
1272 } else {
1273 assert(!SvOK(sv));
1274 SvOK_off(sv);
1275#ifndef NODEFAULT_SHAREKEYS
1276 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1277#endif
1278 HvMAX(sv) = 7; /* (start with 8 buckets) */
64484faa 1279 if (old_type_details->body_size) {
78ac7dd9
NC
1280 HvFILL(sv) = 0;
1281 } else {
1282 /* It will have been zeroed when the new body was allocated.
1283 Lets not write to it, in case it confuses a write-back
1284 cache. */
1285 }
c1ae03ae 1286 }
aeb18a1e 1287
bd81e77b
NC
1288 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1289 The target created by newSVrv also is, and it can have magic.
1290 However, it never has SvPVX set.
1291 */
4df7f6af
NC
1292 if (old_type == SVt_IV) {
1293 assert(!SvROK(sv));
1294 } else if (old_type >= SVt_PV) {
bd81e77b
NC
1295 assert(SvPVX_const(sv) == 0);
1296 }
aeb18a1e 1297
bd81e77b 1298 if (old_type >= SVt_PVMG) {
e736a858 1299 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
bd81e77b 1300 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
797c7171
NC
1301 } else {
1302 sv->sv_u.svu_array = NULL; /* or svu_hash */
bd81e77b
NC
1303 }
1304 break;
93e68bfb 1305
93e68bfb 1306
bd81e77b
NC
1307 case SVt_PVIV:
1308 /* XXX Is this still needed? Was it ever needed? Surely as there is
1309 no route from NV to PVIV, NOK can never be true */
1310 assert(!SvNOKp(sv));
1311 assert(!SvNOK(sv));
1312 case SVt_PVIO:
1313 case SVt_PVFM:
bd81e77b
NC
1314 case SVt_PVGV:
1315 case SVt_PVCV:
1316 case SVt_PVLV:
5c35adbb 1317 case SVt_REGEXP:
bd81e77b
NC
1318 case SVt_PVMG:
1319 case SVt_PVNV:
1320 case SVt_PV:
93e68bfb 1321
d2a0f284 1322 assert(new_type_details->body_size);
bd81e77b
NC
1323 /* We always allocated the full length item with PURIFY. To do this
1324 we fake things so that arena is false for all 16 types.. */
1325 if(new_type_details->arena) {
1326 /* This points to the start of the allocated area. */
d2a0f284
JC
1327 new_body_inline(new_body, new_type);
1328 Zero(new_body, new_type_details->body_size, char);
bd81e77b
NC
1329 new_body = ((char *)new_body) - new_type_details->offset;
1330 } else {
1331 new_body = new_NOARENAZ(new_type_details);
1332 }
1333 SvANY(sv) = new_body;
5e2fc214 1334
bd81e77b 1335 if (old_type_details->copy) {
f9ba3d20
NC
1336 /* There is now the potential for an upgrade from something without
1337 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1338 int offset = old_type_details->offset;
1339 int length = old_type_details->copy;
1340
1341 if (new_type_details->offset > old_type_details->offset) {
d4c19fe8 1342 const int difference
f9ba3d20
NC
1343 = new_type_details->offset - old_type_details->offset;
1344 offset += difference;
1345 length -= difference;
1346 }
1347 assert (length >= 0);
1348
1349 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1350 char);
bd81e77b
NC
1351 }
1352
1353#ifndef NV_ZERO_IS_ALLBITS_ZERO
f2524eef 1354 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
e5ce394c
NC
1355 * correct 0.0 for us. Otherwise, if the old body didn't have an
1356 * NV slot, but the new one does, then we need to initialise the
1357 * freshly created NV slot with whatever the correct bit pattern is
1358 * for 0.0 */
e22a937e
NC
1359 if (old_type_details->zero_nv && !new_type_details->zero_nv
1360 && !isGV_with_GP(sv))
bd81e77b 1361 SvNV_set(sv, 0);
82048762 1362#endif
5e2fc214 1363
bd81e77b 1364 if (new_type == SVt_PVIO)
f2524eef 1365 IoPAGE_LEN(sv) = 60;
4df7f6af
NC
1366 if (old_type < SVt_PV) {
1367 /* referant will be NULL unless the old type was SVt_IV emulating
1368 SVt_RV */
1369 sv->sv_u.svu_rv = referant;
1370 }
bd81e77b
NC
1371 break;
1372 default:
afd78fd5
JH
1373 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1374 (unsigned long)new_type);
bd81e77b 1375 }
73171d91 1376
d2a0f284
JC
1377 if (old_type_details->arena) {
1378 /* If there was an old body, then we need to free it.
1379 Note that there is an assumption that all bodies of types that
1380 can be upgraded came from arenas. Only the more complex non-
1381 upgradable types are allowed to be directly malloc()ed. */
bd81e77b
NC
1382#ifdef PURIFY
1383 my_safefree(old_body);
1384#else
1385 del_body((void*)((char*)old_body + old_type_details->offset),
1386 &PL_body_roots[old_type]);
1387#endif
1388 }
1389}
73171d91 1390
bd81e77b
NC
1391/*
1392=for apidoc sv_backoff
73171d91 1393
bd81e77b
NC
1394Remove any string offset. You should normally use the C<SvOOK_off> macro
1395wrapper instead.
73171d91 1396
bd81e77b 1397=cut
73171d91
NC
1398*/
1399
bd81e77b 1400int
aad570aa 1401Perl_sv_backoff(pTHX_ register SV *const sv)
bd81e77b 1402{
69240efd 1403 STRLEN delta;
7a4bba22 1404 const char * const s = SvPVX_const(sv);
96a5add6 1405 PERL_UNUSED_CONTEXT;
bd81e77b
NC
1406 assert(SvOOK(sv));
1407 assert(SvTYPE(sv) != SVt_PVHV);
1408 assert(SvTYPE(sv) != SVt_PVAV);
7a4bba22 1409
69240efd
NC
1410 SvOOK_offset(sv, delta);
1411
7a4bba22
NC
1412 SvLEN_set(sv, SvLEN(sv) + delta);
1413 SvPV_set(sv, SvPVX(sv) - delta);
1414 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
bd81e77b
NC
1415 SvFLAGS(sv) &= ~SVf_OOK;
1416 return 0;
1417}
73171d91 1418
bd81e77b
NC
1419/*
1420=for apidoc sv_grow
73171d91 1421
bd81e77b
NC
1422Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1423upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1424Use the C<SvGROW> wrapper instead.
93e68bfb 1425
bd81e77b
NC
1426=cut
1427*/
93e68bfb 1428
bd81e77b 1429char *
aad570aa 1430Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
bd81e77b
NC
1431{
1432 register char *s;
93e68bfb 1433
5db06880
NC
1434 if (PL_madskills && newlen >= 0x100000) {
1435 PerlIO_printf(Perl_debug_log,
1436 "Allocation too large: %"UVxf"\n", (UV)newlen);
1437 }
bd81e77b
NC
1438#ifdef HAS_64K_LIMIT
1439 if (newlen >= 0x10000) {
1440 PerlIO_printf(Perl_debug_log,
1441 "Allocation too large: %"UVxf"\n", (UV)newlen);
1442 my_exit(1);
1443 }
1444#endif /* HAS_64K_LIMIT */
1445 if (SvROK(sv))
1446 sv_unref(sv);
1447 if (SvTYPE(sv) < SVt_PV) {
1448 sv_upgrade(sv, SVt_PV);
1449 s = SvPVX_mutable(sv);
1450 }
1451 else if (SvOOK(sv)) { /* pv is offset? */
1452 sv_backoff(sv);
1453 s = SvPVX_mutable(sv);
1454 if (newlen > SvLEN(sv))
1455 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1456#ifdef HAS_64K_LIMIT
1457 if (newlen >= 0x10000)
1458 newlen = 0xFFFF;
1459#endif
1460 }
1461 else
1462 s = SvPVX_mutable(sv);
aeb18a1e 1463
bd81e77b
NC
1464 if (newlen > SvLEN(sv)) { /* need more room? */
1465 newlen = PERL_STRLEN_ROUNDUP(newlen);
1466 if (SvLEN(sv) && s) {
1467#ifdef MYMALLOC
1468 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1469 if (newlen <= l) {
1470 SvLEN_set(sv, l);
1471 return s;
1472 } else
1473#endif
10edeb5d 1474 s = (char*)saferealloc(s, newlen);
bd81e77b
NC
1475 }
1476 else {
10edeb5d 1477 s = (char*)safemalloc(newlen);
bd81e77b
NC
1478 if (SvPVX_const(sv) && SvCUR(sv)) {
1479 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1480 }
1481 }
1482 SvPV_set(sv, s);
1483 SvLEN_set(sv, newlen);
1484 }
1485 return s;
1486}
aeb18a1e 1487
bd81e77b
NC
1488/*
1489=for apidoc sv_setiv
932e9ff9 1490
bd81e77b
NC
1491Copies an integer into the given SV, upgrading first if necessary.
1492Does not handle 'set' magic. See also C<sv_setiv_mg>.
463ee0b2 1493
bd81e77b
NC
1494=cut
1495*/
463ee0b2 1496
bd81e77b 1497void
aad570aa 1498Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
bd81e77b 1499{
97aff369 1500 dVAR;
bd81e77b
NC
1501 SV_CHECK_THINKFIRST_COW_DROP(sv);
1502 switch (SvTYPE(sv)) {
1503 case SVt_NULL:
bd81e77b 1504 case SVt_NV:
3376de98 1505 sv_upgrade(sv, SVt_IV);
bd81e77b 1506 break;
bd81e77b
NC
1507 case SVt_PV:
1508 sv_upgrade(sv, SVt_PVIV);
1509 break;
463ee0b2 1510
bd81e77b
NC
1511 case SVt_PVGV:
1512 case SVt_PVAV:
1513 case SVt_PVHV:
1514 case SVt_PVCV:
1515 case SVt_PVFM:
1516 case SVt_PVIO:
1517 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1518 OP_DESC(PL_op));
42d0e0b7 1519 default: NOOP;
bd81e77b
NC
1520 }
1521 (void)SvIOK_only(sv); /* validate number */
1522 SvIV_set(sv, i);
1523 SvTAINT(sv);
1524}
932e9ff9 1525
bd81e77b
NC
1526/*
1527=for apidoc sv_setiv_mg
d33b2eba 1528
bd81e77b 1529Like C<sv_setiv>, but also handles 'set' magic.
1c846c1f 1530
bd81e77b
NC
1531=cut
1532*/
d33b2eba 1533
bd81e77b 1534void
aad570aa 1535Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
bd81e77b
NC
1536{
1537 sv_setiv(sv,i);
1538 SvSETMAGIC(sv);
1539}
727879eb 1540
bd81e77b
NC
1541/*
1542=for apidoc sv_setuv
d33b2eba 1543
bd81e77b
NC
1544Copies an unsigned integer into the given SV, upgrading first if necessary.
1545Does not handle 'set' magic. See also C<sv_setuv_mg>.
9b94d1dd 1546
bd81e77b
NC
1547=cut
1548*/
d33b2eba 1549
bd81e77b 1550void
aad570aa 1551Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
bd81e77b
NC
1552{
1553 /* With these two if statements:
1554 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d33b2eba 1555
bd81e77b
NC
1556 without
1557 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1c846c1f 1558
bd81e77b
NC
1559 If you wish to remove them, please benchmark to see what the effect is
1560 */
1561 if (u <= (UV)IV_MAX) {
1562 sv_setiv(sv, (IV)u);
1563 return;
1564 }
1565 sv_setiv(sv, 0);
1566 SvIsUV_on(sv);
1567 SvUV_set(sv, u);
1568}
d33b2eba 1569
bd81e77b
NC
1570/*
1571=for apidoc sv_setuv_mg
727879eb 1572
bd81e77b 1573Like C<sv_setuv>, but also handles 'set' magic.
9b94d1dd 1574
bd81e77b
NC
1575=cut
1576*/
5e2fc214 1577
bd81e77b 1578void
aad570aa 1579Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
bd81e77b 1580{
bd81e77b
NC
1581 sv_setuv(sv,u);
1582 SvSETMAGIC(sv);
1583}
5e2fc214 1584
954c1994 1585/*
bd81e77b 1586=for apidoc sv_setnv
954c1994 1587
bd81e77b
NC
1588Copies a double into the given SV, upgrading first if necessary.
1589Does not handle 'set' magic. See also C<sv_setnv_mg>.
954c1994
GS
1590
1591=cut
1592*/
1593
63f97190 1594void
aad570aa 1595Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
79072805 1596{
97aff369 1597 dVAR;
bd81e77b
NC
1598 SV_CHECK_THINKFIRST_COW_DROP(sv);
1599 switch (SvTYPE(sv)) {
79072805 1600 case SVt_NULL:
79072805 1601 case SVt_IV:
bd81e77b 1602 sv_upgrade(sv, SVt_NV);
79072805
LW
1603 break;
1604 case SVt_PV:
79072805 1605 case SVt_PVIV:
bd81e77b 1606 sv_upgrade(sv, SVt_PVNV);
79072805 1607 break;
bd4b1eb5 1608
bd4b1eb5 1609 case SVt_PVGV:
bd81e77b
NC
1610 case SVt_PVAV:
1611 case SVt_PVHV:
79072805 1612 case SVt_PVCV:
bd81e77b
NC
1613 case SVt_PVFM:
1614 case SVt_PVIO:
1615 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1616 OP_NAME(PL_op));
42d0e0b7 1617 default: NOOP;
2068cd4d 1618 }
bd81e77b
NC
1619 SvNV_set(sv, num);
1620 (void)SvNOK_only(sv); /* validate number */
1621 SvTAINT(sv);
79072805
LW
1622}
1623
645c22ef 1624/*
bd81e77b 1625=for apidoc sv_setnv_mg
645c22ef 1626
bd81e77b 1627Like C<sv_setnv>, but also handles 'set' magic.
645c22ef
DM
1628
1629=cut
1630*/
1631
bd81e77b 1632void
aad570aa 1633Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
79072805 1634{
bd81e77b
NC
1635 sv_setnv(sv,num);
1636 SvSETMAGIC(sv);
79072805
LW
1637}
1638
bd81e77b
NC
1639/* Print an "isn't numeric" warning, using a cleaned-up,
1640 * printable version of the offending string
1641 */
954c1994 1642
bd81e77b 1643STATIC void
aad570aa 1644S_not_a_number(pTHX_ SV *const sv)
79072805 1645{
97aff369 1646 dVAR;
bd81e77b
NC
1647 SV *dsv;
1648 char tmpbuf[64];
1649 const char *pv;
94463019
JH
1650
1651 if (DO_UTF8(sv)) {
84bafc02 1652 dsv = newSVpvs_flags("", SVs_TEMP);
94463019
JH
1653 pv = sv_uni_display(dsv, sv, 10, 0);
1654 } else {
1655 char *d = tmpbuf;
551405c4 1656 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
94463019
JH
1657 /* each *s can expand to 4 chars + "...\0",
1658 i.e. need room for 8 chars */
ecdeb87c 1659
00b6aa41
AL
1660 const char *s = SvPVX_const(sv);
1661 const char * const end = s + SvCUR(sv);
1662 for ( ; s < end && d < limit; s++ ) {
94463019
JH
1663 int ch = *s & 0xFF;
1664 if (ch & 128 && !isPRINT_LC(ch)) {
1665 *d++ = 'M';
1666 *d++ = '-';
1667 ch &= 127;
1668 }
1669 if (ch == '\n') {
1670 *d++ = '\\';
1671 *d++ = 'n';
1672 }
1673 else if (ch == '\r') {
1674 *d++ = '\\';
1675 *d++ = 'r';
1676 }
1677 else if (ch == '\f') {
1678 *d++ = '\\';
1679 *d++ = 'f';
1680 }
1681 else if (ch == '\\') {
1682 *d++ = '\\';
1683 *d++ = '\\';
1684 }
1685 else if (ch == '\0') {
1686 *d++ = '\\';
1687 *d++ = '0';
1688 }
1689 else if (isPRINT_LC(ch))
1690 *d++ = ch;
1691 else {
1692 *d++ = '^';
1693 *d++ = toCTRL(ch);
1694 }
1695 }
1696 if (s < end) {
1697 *d++ = '.';
1698 *d++ = '.';
1699 *d++ = '.';
1700 }
1701 *d = '\0';
1702 pv = tmpbuf;
a0d0e21e 1703 }
a0d0e21e 1704
533c011a 1705 if (PL_op)
9014280d 1706 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019
JH
1707 "Argument \"%s\" isn't numeric in %s", pv,
1708 OP_DESC(PL_op));
a0d0e21e 1709 else
9014280d 1710 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019 1711 "Argument \"%s\" isn't numeric", pv);
a0d0e21e
LW
1712}
1713
c2988b20
NC
1714/*
1715=for apidoc looks_like_number
1716
645c22ef
DM
1717Test if the content of an SV looks like a number (or is a number).
1718C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1719non-numeric warning), even if your atof() doesn't grok them.
c2988b20
NC
1720
1721=cut
1722*/
1723
1724I32
aad570aa 1725Perl_looks_like_number(pTHX_ SV *const sv)
c2988b20 1726{
a3b680e6 1727 register const char *sbegin;
c2988b20
NC
1728 STRLEN len;
1729
1730 if (SvPOK(sv)) {
3f7c398e 1731 sbegin = SvPVX_const(sv);
c2988b20
NC
1732 len = SvCUR(sv);
1733 }
1734 else if (SvPOKp(sv))
83003860 1735 sbegin = SvPV_const(sv, len);
c2988b20 1736 else
e0ab1c0e 1737 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
c2988b20
NC
1738 return grok_number(sbegin, len, NULL);
1739}
25da4f38 1740
19f6321d
NC
1741STATIC bool
1742S_glob_2number(pTHX_ GV * const gv)
180488f8
NC
1743{
1744 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1745 SV *const buffer = sv_newmortal();
1746
1747 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1748 is on. */
1749 SvFAKE_off(gv);
1750 gv_efullname3(buffer, gv, "*");
1751 SvFLAGS(gv) |= wasfake;
1752
675c862f
AL
1753 /* We know that all GVs stringify to something that is not-a-number,
1754 so no need to test that. */
1755 if (ckWARN(WARN_NUMERIC))
1756 not_a_number(buffer);
1757 /* We just want something true to return, so that S_sv_2iuv_common
1758 can tail call us and return true. */
19f6321d 1759 return TRUE;
675c862f
AL
1760}
1761
1762STATIC char *
19f6321d 1763S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
675c862f
AL
1764{
1765 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1766 SV *const buffer = sv_newmortal();
1767
1768 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1769 is on. */
1770 SvFAKE_off(gv);
1771 gv_efullname3(buffer, gv, "*");
1772 SvFLAGS(gv) |= wasfake;
1773
1774 assert(SvPOK(buffer));
a6d61a6c
NC
1775 if (len) {
1776 *len = SvCUR(buffer);
1777 }
675c862f 1778 return SvPVX(buffer);
180488f8
NC
1779}
1780
25da4f38
IZ
1781/* Actually, ISO C leaves conversion of UV to IV undefined, but
1782 until proven guilty, assume that things are not that bad... */
1783
645c22ef
DM
1784/*
1785 NV_PRESERVES_UV:
1786
1787 As 64 bit platforms often have an NV that doesn't preserve all bits of
28e5dec8
JH
1788 an IV (an assumption perl has been based on to date) it becomes necessary
1789 to remove the assumption that the NV always carries enough precision to
1790 recreate the IV whenever needed, and that the NV is the canonical form.
1791 Instead, IV/UV and NV need to be given equal rights. So as to not lose
645c22ef 1792 precision as a side effect of conversion (which would lead to insanity
28e5dec8
JH
1793 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1794 1) to distinguish between IV/UV/NV slots that have cached a valid
1795 conversion where precision was lost and IV/UV/NV slots that have a
1796 valid conversion which has lost no precision
645c22ef 1797 2) to ensure that if a numeric conversion to one form is requested that
28e5dec8
JH
1798 would lose precision, the precise conversion (or differently
1799 imprecise conversion) is also performed and cached, to prevent
1800 requests for different numeric formats on the same SV causing
1801 lossy conversion chains. (lossless conversion chains are perfectly
1802 acceptable (still))
1803
1804
1805 flags are used:
1806 SvIOKp is true if the IV slot contains a valid value
1807 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1808 SvNOKp is true if the NV slot contains a valid value
1809 SvNOK is true only if the NV value is accurate
1810
1811 so
645c22ef 1812 while converting from PV to NV, check to see if converting that NV to an
28e5dec8
JH
1813 IV(or UV) would lose accuracy over a direct conversion from PV to
1814 IV(or UV). If it would, cache both conversions, return NV, but mark
1815 SV as IOK NOKp (ie not NOK).
1816
645c22ef 1817 While converting from PV to IV, check to see if converting that IV to an
28e5dec8
JH
1818 NV would lose accuracy over a direct conversion from PV to NV. If it
1819 would, cache both conversions, flag similarly.
1820
1821 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1822 correctly because if IV & NV were set NV *always* overruled.
645c22ef
DM
1823 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1824 changes - now IV and NV together means that the two are interchangeable:
28e5dec8 1825 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
d460ef45 1826
645c22ef
DM
1827 The benefit of this is that operations such as pp_add know that if
1828 SvIOK is true for both left and right operands, then integer addition
1829 can be used instead of floating point (for cases where the result won't
1830 overflow). Before, floating point was always used, which could lead to
28e5dec8
JH
1831 loss of precision compared with integer addition.
1832
1833 * making IV and NV equal status should make maths accurate on 64 bit
1834 platforms
1835 * may speed up maths somewhat if pp_add and friends start to use
645c22ef 1836 integers when possible instead of fp. (Hopefully the overhead in
28e5dec8
JH
1837 looking for SvIOK and checking for overflow will not outweigh the
1838 fp to integer speedup)
1839 * will slow down integer operations (callers of SvIV) on "inaccurate"
1840 values, as the change from SvIOK to SvIOKp will cause a call into
1841 sv_2iv each time rather than a macro access direct to the IV slot
1842 * should speed up number->string conversion on integers as IV is
645c22ef 1843 favoured when IV and NV are equally accurate
28e5dec8
JH
1844
1845 ####################################################################
645c22ef
DM
1846 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1847 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1848 On the other hand, SvUOK is true iff UV.
28e5dec8
JH
1849 ####################################################################
1850
645c22ef 1851 Your mileage will vary depending your CPU's relative fp to integer
28e5dec8
JH
1852 performance ratio.
1853*/
1854
1855#ifndef NV_PRESERVES_UV
645c22ef
DM
1856# define IS_NUMBER_UNDERFLOW_IV 1
1857# define IS_NUMBER_UNDERFLOW_UV 2
1858# define IS_NUMBER_IV_AND_UV 2
1859# define IS_NUMBER_OVERFLOW_IV 4
1860# define IS_NUMBER_OVERFLOW_UV 5
1861
1862/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
28e5dec8
JH
1863
1864/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1865STATIC int
5de3775c 1866S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
47031da6
NC
1867# ifdef DEBUGGING
1868 , I32 numtype
1869# endif
1870 )
28e5dec8 1871{
97aff369 1872 dVAR;
3f7c398e 1873 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
1874 if (SvNVX(sv) < (NV)IV_MIN) {
1875 (void)SvIOKp_on(sv);
1876 (void)SvNOK_on(sv);
45977657 1877 SvIV_set(sv, IV_MIN);
28e5dec8
JH
1878 return IS_NUMBER_UNDERFLOW_IV;
1879 }
1880 if (SvNVX(sv) > (NV)UV_MAX) {
1881 (void)SvIOKp_on(sv);
1882 (void)SvNOK_on(sv);
1883 SvIsUV_on(sv);
607fa7f2 1884 SvUV_set(sv, UV_MAX);
28e5dec8
JH
1885 return IS_NUMBER_OVERFLOW_UV;
1886 }
c2988b20
NC
1887 (void)SvIOKp_on(sv);
1888 (void)SvNOK_on(sv);
1889 /* Can't use strtol etc to convert this string. (See truth table in
1890 sv_2iv */
1891 if (SvNVX(sv) <= (UV)IV_MAX) {
45977657 1892 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
1893 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1894 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1895 } else {
1896 /* Integer is imprecise. NOK, IOKp */
1897 }
1898 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1899 }
1900 SvIsUV_on(sv);
607fa7f2 1901 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
1902 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1903 if (SvUVX(sv) == UV_MAX) {
1904 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1905 possibly be preserved by NV. Hence, it must be overflow.
1906 NOK, IOKp */
1907 return IS_NUMBER_OVERFLOW_UV;
1908 }
1909 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1910 } else {
1911 /* Integer is imprecise. NOK, IOKp */
28e5dec8 1912 }
c2988b20 1913 return IS_NUMBER_OVERFLOW_IV;
28e5dec8 1914}
645c22ef
DM
1915#endif /* !NV_PRESERVES_UV*/
1916
af359546 1917STATIC bool
5de3775c 1918S_sv_2iuv_common(pTHX_ SV *const sv) {
97aff369 1919 dVAR;
af359546 1920 if (SvNOKp(sv)) {
28e5dec8
JH
1921 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1922 * without also getting a cached IV/UV from it at the same time
1923 * (ie PV->NV conversion should detect loss of accuracy and cache
af359546
NC
1924 * IV or UV at same time to avoid this. */
1925 /* IV-over-UV optimisation - choose to cache IV if possible */
25da4f38
IZ
1926
1927 if (SvTYPE(sv) == SVt_NV)
1928 sv_upgrade(sv, SVt_PVNV);
1929
28e5dec8
JH
1930 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1931 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1932 certainly cast into the IV range at IV_MAX, whereas the correct
1933 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1934 cases go to UV */
cab190d4
JD
1935#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1936 if (Perl_isnan(SvNVX(sv))) {
1937 SvUV_set(sv, 0);
1938 SvIsUV_on(sv);
fdbe6d7c 1939 return FALSE;
cab190d4 1940 }
cab190d4 1941#endif
28e5dec8 1942 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 1943 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
1944 if (SvNVX(sv) == (NV) SvIVX(sv)
1945#ifndef NV_PRESERVES_UV
1946 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1947 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1948 /* Don't flag it as "accurately an integer" if the number
1949 came from a (by definition imprecise) NV operation, and
1950 we're outside the range of NV integer precision */
1951#endif
1952 ) {
a43d94f2
NC
1953 if (SvNOK(sv))
1954 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1955 else {
1956 /* scalar has trailing garbage, eg "42a" */
1957 }
28e5dec8 1958 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 1959 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
1960 PTR2UV(sv),
1961 SvNVX(sv),
1962 SvIVX(sv)));
1963
1964 } else {
1965 /* IV not precise. No need to convert from PV, as NV
1966 conversion would already have cached IV if it detected
1967 that PV->IV would be better than PV->NV->IV
1968 flags already correct - don't set public IOK. */
1969 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 1970 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
1971 PTR2UV(sv),
1972 SvNVX(sv),
1973 SvIVX(sv)));
1974 }
1975 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1976 but the cast (NV)IV_MIN rounds to a the value less (more
1977 negative) than IV_MIN which happens to be equal to SvNVX ??
1978 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1979 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1980 (NV)UVX == NVX are both true, but the values differ. :-(
1981 Hopefully for 2s complement IV_MIN is something like
1982 0x8000000000000000 which will be exact. NWC */
d460ef45 1983 }
25da4f38 1984 else {
607fa7f2 1985 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
1986 if (
1987 (SvNVX(sv) == (NV) SvUVX(sv))
1988#ifndef NV_PRESERVES_UV
1989 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1990 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1991 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1992 /* Don't flag it as "accurately an integer" if the number
1993 came from a (by definition imprecise) NV operation, and
1994 we're outside the range of NV integer precision */
1995#endif
a43d94f2 1996 && SvNOK(sv)
28e5dec8
JH
1997 )
1998 SvIOK_on(sv);
25da4f38 1999 SvIsUV_on(sv);
1c846c1f 2000 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 2001 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 2002 PTR2UV(sv),
57def98f
JH
2003 SvUVX(sv),
2004 SvUVX(sv)));
25da4f38 2005 }
748a9306
LW
2006 }
2007 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2008 UV value;
504618e9 2009 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
af359546 2010 /* We want to avoid a possible problem when we cache an IV/ a UV which
25da4f38 2011 may be later translated to an NV, and the resulting NV is not
c2988b20
NC
2012 the same as the direct translation of the initial string
2013 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2014 be careful to ensure that the value with the .456 is around if the
2015 NV value is requested in the future).
1c846c1f 2016
af359546 2017 This means that if we cache such an IV/a UV, we need to cache the
25da4f38 2018 NV as well. Moreover, we trade speed for space, and do not
28e5dec8 2019 cache the NV if we are sure it's not needed.
25da4f38 2020 */
16b7a9a4 2021
c2988b20
NC
2022 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2023 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2024 == IS_NUMBER_IN_UV) {
5e045b90 2025 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8
JH
2026 if (SvTYPE(sv) < SVt_PVIV)
2027 sv_upgrade(sv, SVt_PVIV);
f7bbb42a 2028 (void)SvIOK_on(sv);
c2988b20
NC
2029 } else if (SvTYPE(sv) < SVt_PVNV)
2030 sv_upgrade(sv, SVt_PVNV);
28e5dec8 2031
f2524eef 2032 /* If NVs preserve UVs then we only use the UV value if we know that
c2988b20
NC
2033 we aren't going to call atof() below. If NVs don't preserve UVs
2034 then the value returned may have more precision than atof() will
2035 return, even though value isn't perfectly accurate. */
2036 if ((numtype & (IS_NUMBER_IN_UV
2037#ifdef NV_PRESERVES_UV
2038 | IS_NUMBER_NOT_INT
2039#endif
2040 )) == IS_NUMBER_IN_UV) {
2041 /* This won't turn off the public IOK flag if it was set above */
2042 (void)SvIOKp_on(sv);
2043
2044 if (!(numtype & IS_NUMBER_NEG)) {
2045 /* positive */;
2046 if (value <= (UV)IV_MAX) {
45977657 2047 SvIV_set(sv, (IV)value);
c2988b20 2048 } else {
af359546 2049 /* it didn't overflow, and it was positive. */
607fa7f2 2050 SvUV_set(sv, value);
c2988b20
NC
2051 SvIsUV_on(sv);
2052 }
2053 } else {
2054 /* 2s complement assumption */
2055 if (value <= (UV)IV_MIN) {
45977657 2056 SvIV_set(sv, -(IV)value);
c2988b20
NC
2057 } else {
2058 /* Too negative for an IV. This is a double upgrade, but
d1be9408 2059 I'm assuming it will be rare. */
c2988b20
NC
2060 if (SvTYPE(sv) < SVt_PVNV)
2061 sv_upgrade(sv, SVt_PVNV);
2062 SvNOK_on(sv);
2063 SvIOK_off(sv);
2064 SvIOKp_on(sv);
9d6ce603 2065 SvNV_set(sv, -(NV)value);
45977657 2066 SvIV_set(sv, IV_MIN);
c2988b20
NC
2067 }
2068 }
2069 }
2070 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2071 will be in the previous block to set the IV slot, and the next
2072 block to set the NV slot. So no else here. */
2073
2074 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2075 != IS_NUMBER_IN_UV) {
2076 /* It wasn't an (integer that doesn't overflow the UV). */
3f7c398e 2077 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8 2078
c2988b20
NC
2079 if (! numtype && ckWARN(WARN_NUMERIC))
2080 not_a_number(sv);
28e5dec8 2081
65202027 2082#if defined(USE_LONG_DOUBLE)
c2988b20
NC
2083 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2084 PTR2UV(sv), SvNVX(sv)));
65202027 2085#else
1779d84d 2086 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
c2988b20 2087 PTR2UV(sv), SvNVX(sv)));
65202027 2088#endif
28e5dec8 2089
28e5dec8 2090#ifdef NV_PRESERVES_UV
af359546
NC
2091 (void)SvIOKp_on(sv);
2092 (void)SvNOK_on(sv);
2093 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2094 SvIV_set(sv, I_V(SvNVX(sv)));
2095 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2096 SvIOK_on(sv);
2097 } else {
6f207bd3 2098 NOOP; /* Integer is imprecise. NOK, IOKp */
af359546
NC
2099 }
2100 /* UV will not work better than IV */
2101 } else {
2102 if (SvNVX(sv) > (NV)UV_MAX) {
2103 SvIsUV_on(sv);
2104 /* Integer is inaccurate. NOK, IOKp, is UV */
2105 SvUV_set(sv, UV_MAX);
af359546
NC
2106 } else {
2107 SvUV_set(sv, U_V(SvNVX(sv)));
2108 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2109 NV preservse UV so can do correct comparison. */
2110 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2111 SvIOK_on(sv);
af359546 2112 } else {
6f207bd3 2113 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
af359546
NC
2114 }
2115 }
4b0c9573 2116 SvIsUV_on(sv);
af359546 2117 }
28e5dec8 2118#else /* NV_PRESERVES_UV */
c2988b20
NC
2119 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2120 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
af359546 2121 /* The IV/UV slot will have been set from value returned by
c2988b20
NC
2122 grok_number above. The NV slot has just been set using
2123 Atof. */
560b0c46 2124 SvNOK_on(sv);
c2988b20
NC
2125 assert (SvIOKp(sv));
2126 } else {
2127 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2128 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2129 /* Small enough to preserve all bits. */
2130 (void)SvIOKp_on(sv);
2131 SvNOK_on(sv);
45977657 2132 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2133 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2134 SvIOK_on(sv);
2135 /* Assumption: first non-preserved integer is < IV_MAX,
2136 this NV is in the preserved range, therefore: */
2137 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2138 < (UV)IV_MAX)) {
32fdb065 2139 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
2140 }
2141 } else {
2142 /* IN_UV NOT_INT
2143 0 0 already failed to read UV.
2144 0 1 already failed to read UV.
2145 1 0 you won't get here in this case. IV/UV
2146 slot set, public IOK, Atof() unneeded.
2147 1 1 already read UV.
2148 so there's no point in sv_2iuv_non_preserve() attempting
2149 to use atol, strtol, strtoul etc. */
47031da6 2150# ifdef DEBUGGING
40a17c4c 2151 sv_2iuv_non_preserve (sv, numtype);
47031da6
NC
2152# else
2153 sv_2iuv_non_preserve (sv);
2154# endif
c2988b20
NC
2155 }
2156 }
28e5dec8 2157#endif /* NV_PRESERVES_UV */
a43d94f2
NC
2158 /* It might be more code efficient to go through the entire logic above
2159 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2160 gets complex and potentially buggy, so more programmer efficient
2161 to do it this way, by turning off the public flags: */
2162 if (!numtype)
2163 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
25da4f38 2164 }
af359546
NC
2165 }
2166 else {
675c862f 2167 if (isGV_with_GP(sv))
a0933d07 2168 return glob_2number((GV *)sv);
180488f8 2169
af359546
NC
2170 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2171 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2172 report_uninit(sv);
2173 }
25da4f38
IZ
2174 if (SvTYPE(sv) < SVt_IV)
2175 /* Typically the caller expects that sv_any is not NULL now. */
2176 sv_upgrade(sv, SVt_IV);
af359546
NC
2177 /* Return 0 from the caller. */
2178 return TRUE;
2179 }
2180 return FALSE;
2181}
2182
2183/*
2184=for apidoc sv_2iv_flags
2185
2186Return the integer value of an SV, doing any necessary string
2187conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2188Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2189
2190=cut
2191*/
2192
2193IV
5de3775c 2194Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
af359546 2195{
97aff369 2196 dVAR;
af359546 2197 if (!sv)
a0d0e21e 2198 return 0;
cecf5685
NC
2199 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2200 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
50caf62e
NC
2201 cache IVs just in case. In practice it seems that they never
2202 actually anywhere accessible by user Perl code, let alone get used
2203 in anything other than a string context. */
af359546
NC
2204 if (flags & SV_GMAGIC)
2205 mg_get(sv);
2206 if (SvIOKp(sv))
2207 return SvIVX(sv);
2208 if (SvNOKp(sv)) {
2209 return I_V(SvNVX(sv));
2210 }
71c558c3
NC
2211 if (SvPOKp(sv) && SvLEN(sv)) {
2212 UV value;
2213 const int numtype
2214 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2215
2216 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2217 == IS_NUMBER_IN_UV) {
2218 /* It's definitely an integer */
2219 if (numtype & IS_NUMBER_NEG) {
2220 if (value < (UV)IV_MIN)
2221 return -(IV)value;
2222 } else {
2223 if (value < (UV)IV_MAX)
2224 return (IV)value;
2225 }
2226 }
2227 if (!numtype) {
2228 if (ckWARN(WARN_NUMERIC))
2229 not_a_number(sv);
2230 }
2231 return I_V(Atof(SvPVX_const(sv)));
2232 }
1c7ff15e
NC
2233 if (SvROK(sv)) {
2234 goto return_rok;
af359546 2235 }
1c7ff15e
NC
2236 assert(SvTYPE(sv) >= SVt_PVMG);
2237 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
4cb1ec55 2238 } else if (SvTHINKFIRST(sv)) {
af359546 2239 if (SvROK(sv)) {
1c7ff15e 2240 return_rok:
af359546
NC
2241 if (SvAMAGIC(sv)) {
2242 SV * const tmpstr=AMG_CALLun(sv,numer);
2243 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2244 return SvIV(tmpstr);
2245 }
2246 }
2247 return PTR2IV(SvRV(sv));
2248 }
2249 if (SvIsCOW(sv)) {
2250 sv_force_normal_flags(sv, 0);
2251 }
2252 if (SvREADONLY(sv) && !SvOK(sv)) {
2253 if (ckWARN(WARN_UNINITIALIZED))
2254 report_uninit(sv);
2255 return 0;
2256 }
2257 }
2258 if (!SvIOKp(sv)) {
2259 if (S_sv_2iuv_common(aTHX_ sv))
2260 return 0;
79072805 2261 }
1d7c1841
GS
2262 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2263 PTR2UV(sv),SvIVX(sv)));
25da4f38 2264 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW
2265}
2266
645c22ef 2267/*
891f9566 2268=for apidoc sv_2uv_flags
645c22ef
DM
2269
2270Return the unsigned integer value of an SV, doing any necessary string
891f9566
YST
2271conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2272Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
645c22ef
DM
2273
2274=cut
2275*/
2276
ff68c719 2277UV
5de3775c 2278Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
ff68c719 2279{
97aff369 2280 dVAR;
ff68c719
PP
2281 if (!sv)
2282 return 0;
cecf5685
NC
2283 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2284 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
50caf62e 2285 cache IVs just in case. */
891f9566
YST
2286 if (flags & SV_GMAGIC)
2287 mg_get(sv);
ff68c719
PP
2288 if (SvIOKp(sv))
2289 return SvUVX(sv);
2290 if (SvNOKp(sv))
2291 return U_V(SvNVX(sv));
71c558c3
NC
2292 if (SvPOKp(sv) && SvLEN(sv)) {
2293 UV value;
2294 const int numtype
2295 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2296
2297 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2298 == IS_NUMBER_IN_UV) {
2299 /* It's definitely an integer */
2300 if (!(numtype & IS_NUMBER_NEG))
2301 return value;
2302 }
2303 if (!numtype) {
2304 if (ckWARN(WARN_NUMERIC))
2305 not_a_number(sv);
2306 }
2307 return U_V(Atof(SvPVX_const(sv)));
2308 }
1c7ff15e
NC
2309 if (SvROK(sv)) {
2310 goto return_rok;
3fe9a6f1 2311 }
1c7ff15e
NC
2312 assert(SvTYPE(sv) >= SVt_PVMG);
2313 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
4cb1ec55 2314 } else if (SvTHINKFIRST(sv)) {
ff68c719 2315 if (SvROK(sv)) {
1c7ff15e 2316 return_rok:
deb46114
NC
2317 if (SvAMAGIC(sv)) {
2318 SV *const tmpstr = AMG_CALLun(sv,numer);
2319 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2320 return SvUV(tmpstr);
2321 }
2322 }
2323 return PTR2UV(SvRV(sv));
ff68c719 2324 }
765f542d
NC
2325 if (SvIsCOW(sv)) {
2326 sv_force_normal_flags(sv, 0);
8a818333 2327 }
0336b60e 2328 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2329 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2330 report_uninit(sv);
ff68c719
PP
2331 return 0;
2332 }
2333 }
af359546
NC
2334 if (!SvIOKp(sv)) {
2335 if (S_sv_2iuv_common(aTHX_ sv))
2336 return 0;
ff68c719 2337 }
25da4f38 2338
1d7c1841
GS
2339 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2340 PTR2UV(sv),SvUVX(sv)));
25da4f38 2341 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP
2342}
2343
645c22ef
DM
2344/*
2345=for apidoc sv_2nv
2346
2347Return the num value of an SV, doing any necessary string or integer
2348conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2349macros.
2350
2351=cut
2352*/
2353
65202027 2354NV
5de3775c 2355Perl_sv_2nv(pTHX_ register SV *const sv)
79072805 2356{
97aff369 2357 dVAR;
79072805
LW
2358 if (!sv)
2359 return 0.0;
cecf5685
NC
2360 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2361 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
50caf62e 2362 cache IVs just in case. */
463ee0b2
LW
2363 mg_get(sv);
2364 if (SvNOKp(sv))
2365 return SvNVX(sv);
0aa395f8 2366 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
041457d9 2367 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
504618e9 2368 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
a0d0e21e 2369 not_a_number(sv);
3f7c398e 2370 return Atof(SvPVX_const(sv));
a0d0e21e 2371 }
25da4f38 2372 if (SvIOKp(sv)) {
1c846c1f 2373 if (SvIsUV(sv))
65202027 2374 return (NV)SvUVX(sv);
25da4f38 2375 else
65202027 2376 return (NV)SvIVX(sv);
47a72cb8
NC
2377 }
2378 if (SvROK(sv)) {
2379 goto return_rok;
2380 }
2381 assert(SvTYPE(sv) >= SVt_PVMG);
2382 /* This falls through to the report_uninit near the end of the
2383 function. */
2384 } else if (SvTHINKFIRST(sv)) {
a0d0e21e 2385 if (SvROK(sv)) {
47a72cb8 2386 return_rok:
deb46114
NC
2387 if (SvAMAGIC(sv)) {
2388 SV *const tmpstr = AMG_CALLun(sv,numer);
2389 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2390 return SvNV(tmpstr);
2391 }
2392 }
2393 return PTR2NV(SvRV(sv));
a0d0e21e 2394 }
765f542d
NC
2395 if (SvIsCOW(sv)) {
2396 sv_force_normal_flags(sv, 0);
8a818333 2397 }
0336b60e 2398 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 2399 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2400 report_uninit(sv);
ed6116ce
LW
2401 return 0.0;
2402 }
79072805
LW
2403 }
2404 if (SvTYPE(sv) < SVt_NV) {
7e25a7e9
NC
2405 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2406 sv_upgrade(sv, SVt_NV);
906f284f 2407#ifdef USE_LONG_DOUBLE
097ee67d 2408 DEBUG_c({
f93f4e46 2409 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
2410 PerlIO_printf(Perl_debug_log,
2411 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2412 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
2413 RESTORE_NUMERIC_LOCAL();
2414 });
65202027 2415#else
572bbb43 2416 DEBUG_c({
f93f4e46 2417 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 2418 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
1d7c1841 2419 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
2420 RESTORE_NUMERIC_LOCAL();
2421 });
572bbb43 2422#endif
79072805
LW
2423 }
2424 else if (SvTYPE(sv) < SVt_PVNV)
2425 sv_upgrade(sv, SVt_PVNV);
59d8ce62
NC
2426 if (SvNOKp(sv)) {
2427 return SvNVX(sv);
61604483 2428 }
59d8ce62 2429 if (SvIOKp(sv)) {
9d6ce603 2430 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
28e5dec8 2431#ifdef NV_PRESERVES_UV
a43d94f2
NC
2432 if (SvIOK(sv))
2433 SvNOK_on(sv);
2434 else
2435 SvNOKp_on(sv);
28e5dec8
JH
2436#else
2437 /* Only set the public NV OK flag if this NV preserves the IV */
2438 /* Check it's not 0xFFFFFFFFFFFFFFFF */
a43d94f2
NC
2439 if (SvIOK(sv) &&
2440 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
28e5dec8
JH
2441 : (SvIVX(sv) == I_V(SvNVX(sv))))
2442 SvNOK_on(sv);
2443 else
2444 SvNOKp_on(sv);
2445#endif
93a17b20 2446 }
748a9306 2447 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2448 UV value;
3f7c398e 2449 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
041457d9 2450 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
a0d0e21e 2451 not_a_number(sv);
28e5dec8 2452#ifdef NV_PRESERVES_UV
c2988b20
NC
2453 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2454 == IS_NUMBER_IN_UV) {
5e045b90 2455 /* It's definitely an integer */
9d6ce603 2456 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
c2988b20 2457 } else
3f7c398e 2458 SvNV_set(sv, Atof(SvPVX_const(sv)));
a43d94f2
NC
2459 if (numtype)
2460 SvNOK_on(sv);
2461 else
2462 SvNOKp_on(sv);
28e5dec8 2463#else
3f7c398e 2464 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8
JH
2465 /* Only set the public NV OK flag if this NV preserves the value in
2466 the PV at least as well as an IV/UV would.
2467 Not sure how to do this 100% reliably. */
2468 /* if that shift count is out of range then Configure's test is
2469 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2470 UV_BITS */
2471 if (((UV)1 << NV_PRESERVES_UV_BITS) >
c2988b20 2472 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
28e5dec8 2473 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
c2988b20
NC
2474 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2475 /* Can't use strtol etc to convert this string, so don't try.
2476 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2477 SvNOK_on(sv);
2478 } else {
2479 /* value has been set. It may not be precise. */
2480 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2481 /* 2s complement assumption for (UV)IV_MIN */
2482 SvNOK_on(sv); /* Integer is too negative. */
2483 } else {
2484 SvNOKp_on(sv);
2485 SvIOKp_on(sv);
6fa402ec 2486
c2988b20 2487 if (numtype & IS_NUMBER_NEG) {
45977657 2488 SvIV_set(sv, -(IV)value);
c2988b20 2489 } else if (value <= (UV)IV_MAX) {
45977657 2490 SvIV_set(sv, (IV)value);
c2988b20 2491 } else {
607fa7f2 2492 SvUV_set(sv, value);
c2988b20
NC
2493 SvIsUV_on(sv);
2494 }
2495
2496 if (numtype & IS_NUMBER_NOT_INT) {
2497 /* I believe that even if the original PV had decimals,
2498 they are lost beyond the limit of the FP precision.
2499 However, neither is canonical, so both only get p
2500 flags. NWC, 2000/11/25 */
2501 /* Both already have p flags, so do nothing */
2502 } else {
66a1b24b 2503 const NV nv = SvNVX(sv);
c2988b20
NC
2504 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2505 if (SvIVX(sv) == I_V(nv)) {
2506 SvNOK_on(sv);
c2988b20 2507 } else {
c2988b20
NC
2508 /* It had no "." so it must be integer. */
2509 }
00b6aa41 2510 SvIOK_on(sv);
c2988b20
NC
2511 } else {
2512 /* between IV_MAX and NV(UV_MAX).
2513 Could be slightly > UV_MAX */
6fa402ec 2514
c2988b20
NC
2515 if (numtype & IS_NUMBER_NOT_INT) {
2516 /* UV and NV both imprecise. */
2517 } else {
66a1b24b 2518 const UV nv_as_uv = U_V(nv);
c2988b20
NC
2519
2520 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2521 SvNOK_on(sv);
c2988b20 2522 }
00b6aa41 2523 SvIOK_on(sv);
c2988b20
NC
2524 }
2525 }
2526 }
2527 }
2528 }
a43d94f2
NC
2529 /* It might be more code efficient to go through the entire logic above
2530 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2531 gets complex and potentially buggy, so more programmer efficient
2532 to do it this way, by turning off the public flags: */
2533 if (!numtype)
2534 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
28e5dec8 2535#endif /* NV_PRESERVES_UV */
93a17b20 2536 }
79072805 2537 else {
f7877b28 2538 if (isGV_with_GP(sv)) {
19f6321d 2539 glob_2number((GV *)sv);
180488f8
NC
2540 return 0.0;
2541 }
2542
041457d9 2543 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
29489e7c 2544 report_uninit(sv);
7e25a7e9
NC
2545 assert (SvTYPE(sv) >= SVt_NV);
2546 /* Typically the caller expects that sv_any is not NULL now. */
2547 /* XXX Ilya implies that this is a bug in callers that assume this
2548 and ideally should be fixed. */
a0d0e21e 2549 return 0.0;
79072805 2550 }
572bbb43 2551#if defined(USE_LONG_DOUBLE)
097ee67d 2552 DEBUG_c({
f93f4e46 2553 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
2554 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2555 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
2556 RESTORE_NUMERIC_LOCAL();
2557 });
65202027 2558#else
572bbb43 2559 DEBUG_c({
f93f4e46 2560 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 2561 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
1d7c1841 2562 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
2563 RESTORE_NUMERIC_LOCAL();
2564 });
572bbb43 2565#endif
463ee0b2 2566 return SvNVX(sv);
79072805
LW
2567}
2568
800401ee
JH
2569/*
2570=for apidoc sv_2num
2571
2572Return an SV with the numeric value of the source SV, doing any necessary
a196a5fa
JH
2573reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2574access this function.
800401ee
JH
2575
2576=cut
2577*/
2578
2579SV *
5de3775c 2580Perl_sv_2num(pTHX_ register SV *const sv)
800401ee 2581{
b9ee0594
RGS
2582 if (!SvROK(sv))
2583 return sv;
800401ee
JH
2584 if (SvAMAGIC(sv)) {
2585 SV * const tmpsv = AMG_CALLun(sv,numer);
2586 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2587 return sv_2num(tmpsv);
2588 }
2589 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2590}
2591
645c22ef
DM
2592/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2593 * UV as a string towards the end of buf, and return pointers to start and
2594 * end of it.
2595 *
2596 * We assume that buf is at least TYPE_CHARS(UV) long.
2597 */
2598
864dbfa3 2599static char *
5de3775c 2600S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
25da4f38 2601{
25da4f38 2602 char *ptr = buf + TYPE_CHARS(UV);
823a54a3 2603 char * const ebuf = ptr;
25da4f38 2604 int sign;
25da4f38
IZ
2605
2606 if (is_uv)
2607 sign = 0;
2608 else if (iv >= 0) {
2609 uv = iv;
2610 sign = 0;
2611 } else {
2612 uv = -iv;
2613 sign = 1;
2614 }
2615 do {
eb160463 2616 *--ptr = '0' + (char)(uv % 10);
25da4f38
IZ
2617 } while (uv /= 10);
2618 if (sign)
2619 *--ptr = '-';
2620 *peob = ebuf;
2621 return ptr;
2622}
2623
645c22ef
DM
2624/*
2625=for apidoc sv_2pv_flags
2626
ff276b08 2627Returns a pointer to the string value of an SV, and sets *lp to its length.
645c22ef
DM
2628If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2629if necessary.
2630Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2631usually end up here too.
2632
2633=cut
2634*/
2635
8d6d96c1 2636char *
5de3775c 2637Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
8d6d96c1 2638{
97aff369 2639 dVAR;
79072805 2640 register char *s;
79072805 2641
463ee0b2 2642 if (!sv) {
cdb061a3
NC
2643 if (lp)
2644 *lp = 0;
73d840c0 2645 return (char *)"";
463ee0b2 2646 }
8990e307 2647 if (SvGMAGICAL(sv)) {
8d6d96c1
HS
2648 if (flags & SV_GMAGIC)
2649 mg_get(sv);
463ee0b2 2650 if (SvPOKp(sv)) {
cdb061a3
NC
2651 if (lp)
2652 *lp = SvCUR(sv);
10516c54
NC
2653 if (flags & SV_MUTABLE_RETURN)
2654 return SvPVX_mutable(sv);
4d84ee25
NC
2655 if (flags & SV_CONST_RETURN)
2656 return (char *)SvPVX_const(sv);
463ee0b2
LW
2657 return SvPVX(sv);
2658 }
75dfc8ec
NC
2659 if (SvIOKp(sv) || SvNOKp(sv)) {
2660 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
75dfc8ec
NC
2661 STRLEN len;
2662
2663 if (SvIOKp(sv)) {
e80fed9d 2664 len = SvIsUV(sv)
d9fad198
JH
2665 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2666 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
75dfc8ec 2667 } else {
e8ada2d0
NC
2668 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2669 len = strlen(tbuf);
75dfc8ec 2670 }
b5b886f0
NC
2671 assert(!SvROK(sv));
2672 {
75dfc8ec
NC
2673 dVAR;
2674
2675#ifdef FIXNEGATIVEZERO
e8ada2d0
NC
2676 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2677 tbuf[0] = '0';
2678 tbuf[1] = 0;
75dfc8ec
NC
2679 len = 1;
2680 }
2681#endif
2682 SvUPGRADE(sv, SVt_PV);
2683 if (lp)
2684 *lp = len;
2685 s = SvGROW_mutable(sv, len + 1);
2686 SvCUR_set(sv, len);
2687 SvPOKp_on(sv);
10edeb5d 2688 return (char*)memcpy(s, tbuf, len + 1);
75dfc8ec 2689 }
463ee0b2 2690 }
1c7ff15e
NC
2691 if (SvROK(sv)) {
2692 goto return_rok;
2693 }
2694 assert(SvTYPE(sv) >= SVt_PVMG);
2695 /* This falls through to the report_uninit near the end of the
2696 function. */
2697 } else if (SvTHINKFIRST(sv)) {
ed6116ce 2698 if (SvROK(sv)) {
1c7ff15e 2699 return_rok:
deb46114
NC
2700 if (SvAMAGIC(sv)) {
2701 SV *const tmpstr = AMG_CALLun(sv,string);
2702 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2703 /* Unwrap this: */
2704 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2705 */
2706
2707 char *pv;
2708 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2709 if (flags & SV_CONST_RETURN) {
2710 pv = (char *) SvPVX_const(tmpstr);
2711 } else {
2712 pv = (flags & SV_MUTABLE_RETURN)
2713 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2714 }
2715 if (lp)
2716 *lp = SvCUR(tmpstr);
50adf7d2 2717 } else {
deb46114 2718 pv = sv_2pv_flags(tmpstr, lp, flags);
50adf7d2 2719 }
deb46114
NC
2720 if (SvUTF8(tmpstr))
2721 SvUTF8_on(sv);
2722 else
2723 SvUTF8_off(sv);
2724 return pv;
50adf7d2 2725 }
deb46114
NC
2726 }
2727 {
fafee734
NC
2728 STRLEN len;
2729 char *retval;
2730 char *buffer;
d8eae41e
NC
2731 const SV *const referent = (SV*)SvRV(sv);
2732
2733 if (!referent) {
fafee734
NC
2734 len = 7;
2735 retval = buffer = savepvn("NULLREF", len);
5c35adbb 2736 } else if (SvTYPE(referent) == SVt_REGEXP) {
67d2d14d
AB
2737 const REGEXP * const re = (REGEXP *)referent;
2738 I32 seen_evals = 0;
2739
2740 assert(re);
2741
2742 /* If the regex is UTF-8 we want the containing scalar to
2743 have an UTF-8 flag too */
2744 if (RX_UTF8(re))
2745 SvUTF8_on(sv);
2746 else
2747 SvUTF8_off(sv);
2748
2749 if ((seen_evals = RX_SEEN_EVALS(re)))
2750 PL_reginterp_cnt += seen_evals;
2751
2752 if (lp)
2753 *lp = RX_WRAPLEN(re);
2754
2755 return RX_WRAPPED(re);
d8eae41e
NC
2756 } else {
2757 const char *const typestr = sv_reftype(referent, 0);
fafee734
NC
2758 const STRLEN typelen = strlen(typestr);
2759 UV addr = PTR2UV(referent);
2760 const char *stashname = NULL;
2761 STRLEN stashnamelen = 0; /* hush, gcc */
2762 const char *buffer_end;
d8eae41e 2763
d8eae41e 2764 if (SvOBJECT(referent)) {
fafee734
NC
2765 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2766
2767 if (name) {
2768 stashname = HEK_KEY(name);
2769 stashnamelen = HEK_LEN(name);
2770
2771 if (HEK_UTF8(name)) {
2772 SvUTF8_on(sv);
2773 } else {
2774 SvUTF8_off(sv);
2775 }
2776 } else {
2777 stashname = "__ANON__";
2778 stashnamelen = 8;
2779 }
2780 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2781 + 2 * sizeof(UV) + 2 /* )\0 */;
2782 } else {
2783 len = typelen + 3 /* (0x */
2784 + 2 * sizeof(UV) + 2 /* )\0 */;
d8eae41e 2785 }
fafee734
NC
2786
2787 Newx(buffer, len, char);
2788 buffer_end = retval = buffer + len;
2789
2790 /* Working backwards */
2791 *--retval = '\0';
2792 *--retval = ')';
2793 do {
2794 *--retval = PL_hexdigit[addr & 15];
2795 } while (addr >>= 4);
2796 *--retval = 'x';
2797 *--retval = '0';
2798 *--retval = '(';
2799
2800 retval -= typelen;
2801 memcpy(retval, typestr, typelen);
2802
2803 if (stashname) {
2804 *--retval = '=';
2805 retval -= stashnamelen;
2806 memcpy(retval, stashname, stashnamelen);
2807 }
2808 /* retval may not neccesarily have reached the start of the
2809 buffer here. */
2810 assert (retval >= buffer);
2811
2812 len = buffer_end - retval - 1; /* -1 for that \0 */
c080367d 2813 }
042dae7a 2814 if (lp)
fafee734
NC
2815 *lp = len;
2816 SAVEFREEPV(buffer);
2817 return retval;
463ee0b2 2818 }
79072805 2819 }
0336b60e 2820 if (SvREADONLY(sv) && !SvOK(sv)) {
cdb061a3
NC
2821 if (lp)
2822 *lp = 0;
9f621bb0
NC
2823 if (flags & SV_UNDEF_RETURNS_NULL)
2824 return NULL;
2825 if (ckWARN(WARN_UNINITIALIZED))
2826 report_uninit(sv);
73d840c0 2827 return (char *)"";
79072805 2828 }
79072805 2829 }
28e5dec8
JH
2830 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2831 /* I'm assuming that if both IV and NV are equally valid then
2832 converting the IV is going to be more efficient */
e1ec3a88 2833 const U32 isUIOK = SvIsUV(sv);
28e5dec8
JH
2834 char buf[TYPE_CHARS(UV)];
2835 char *ebuf, *ptr;
97a130b8 2836 STRLEN len;
28e5dec8
JH
2837
2838 if (SvTYPE(sv) < SVt_PVIV)
2839 sv_upgrade(sv, SVt_PVIV);
4ea1d550 2840 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
97a130b8 2841 len = ebuf - ptr;
5902b6a9 2842 /* inlined from sv_setpvn */
97a130b8
NC
2843 s = SvGROW_mutable(sv, len + 1);
2844 Move(ptr, s, len, char);
2845 s += len;
28e5dec8 2846 *s = '\0';
28e5dec8
JH
2847 }
2848 else if (SvNOKp(sv)) {
c81271c3 2849 const int olderrno = errno;
79072805
LW
2850 if (SvTYPE(sv) < SVt_PVNV)
2851 sv_upgrade(sv, SVt_PVNV);
1c846c1f 2852 /* The +20 is pure guesswork. Configure test needed. --jhi */
5902b6a9 2853 s = SvGROW_mutable(sv, NV_DIG + 20);
c81271c3 2854 /* some Xenix systems wipe out errno here */
79072805 2855#ifdef apollo
463ee0b2 2856 if (SvNVX(sv) == 0.0)
d1307786 2857 my_strlcpy(s, "0", SvLEN(sv));
79072805
LW
2858 else
2859#endif /*apollo*/
bbce6d69 2860 {
2d4389e4 2861 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2862 }
79072805 2863 errno = olderrno;
a0d0e21e 2864#ifdef FIXNEGATIVEZERO
20773dcd
NC
2865 if (*s == '-' && s[1] == '0' && !s[2]) {
2866 s[0] = '0';
2867 s[1] = 0;
2868 }
a0d0e21e 2869#endif
79072805
LW
2870 while (*s) s++;
2871#ifdef hcx
2872 if (s[-1] == '.')
46fc3d4c 2873 *--s = '\0';
79072805
LW
2874#endif
2875 }
79072805 2876 else {
675c862f 2877 if (isGV_with_GP(sv))
19f6321d 2878 return glob_2pv((GV *)sv, lp);
180488f8 2879
cdb061a3 2880 if (lp)
00b6aa41 2881 *lp = 0;
9f621bb0
NC
2882 if (flags & SV_UNDEF_RETURNS_NULL)
2883 return NULL;
2884 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2885 report_uninit(sv);
25da4f38
IZ
2886 if (SvTYPE(sv) < SVt_PV)
2887 /* Typically the caller expects that sv_any is not NULL now. */
2888 sv_upgrade(sv, SVt_PV);
73d840c0 2889 return (char *)"";
79072805 2890 }
cdb061a3 2891 {
823a54a3 2892 const STRLEN len = s - SvPVX_const(sv);
cdb061a3
NC
2893 if (lp)
2894 *lp = len;
2895 SvCUR_set(sv, len);
2896 }
79072805 2897 SvPOK_on(sv);
1d7c1841 2898 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3f7c398e 2899 PTR2UV(sv),SvPVX_const(sv)));
4d84ee25
NC
2900 if (flags & SV_CONST_RETURN)
2901 return (char *)SvPVX_const(sv);
10516c54
NC
2902 if (flags & SV_MUTABLE_RETURN)
2903 return SvPVX_mutable(sv);
463ee0b2
LW
2904 return SvPVX(sv);
2905}
2906
645c22ef 2907/*
6050d10e
JP
2908=for apidoc sv_copypv
2909
2910Copies a stringified representation of the source SV into the
2911destination SV. Automatically performs any necessary mg_get and
54f0641b 2912coercion of numeric values into strings. Guaranteed to preserve
2575c402 2913UTF8 flag even from overloaded objects. Similar in nature to
54f0641b
NIS
2914sv_2pv[_flags] but operates directly on an SV instead of just the
2915string. Mostly uses sv_2pv_flags to do its work, except when that
6050d10e
JP
2916would lose the UTF-8'ness of the PV.
2917
2918=cut
2919*/
2920
2921void
5de3775c 2922Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
6050d10e 2923{
446eaa42 2924 STRLEN len;
53c1dcc0 2925 const char * const s = SvPV_const(ssv,len);
cb50f42d 2926 sv_setpvn(dsv,s,len);
446eaa42 2927 if (SvUTF8(ssv))
cb50f42d 2928 SvUTF8_on(dsv);
446eaa42 2929 else
cb50f42d 2930 SvUTF8_off(dsv);
6050d10e
JP
2931}
2932
2933/*
645c22ef
DM
2934=for apidoc sv_2pvbyte
2935
2936Return a pointer to the byte-encoded representation of the SV, and set *lp
1e54db1a 2937to its length. May cause the SV to be downgraded from UTF-8 as a
645c22ef
DM
2938side-effect.
2939
2940Usually accessed via the C<SvPVbyte> macro.
2941
2942=cut
2943*/
2944
7340a771 2945char *
5de3775c 2946Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
7340a771 2947{
0875d2fe 2948 sv_utf8_downgrade(sv,0);
97972285 2949 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
7340a771
GS
2950}
2951
645c22ef 2952/*
035cbb0e
RGS
2953=for apidoc sv_2pvutf8
2954
2955Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2956to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
2957
2958Usually accessed via the C<SvPVutf8> macro.
2959
2960=cut
2961*/
645c22ef 2962
7340a771
GS
2963char *
2964Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2965{
035cbb0e
RGS
2966 sv_utf8_upgrade(sv);
2967 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
7340a771 2968}
1c846c1f 2969
7ee2227d 2970
645c22ef
DM
2971/*
2972=for apidoc sv_2bool
2973
2974This function is only called on magical items, and is only used by
8cf8f3d1 2975sv_true() or its macro equivalent.
645c22ef
DM
2976
2977=cut
2978*/
2979
463ee0b2 2980bool
864dbfa3 2981Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2982{
97aff369 2983 dVAR;
5b295bef 2984 SvGETMAGIC(sv);
463ee0b2 2985
a0d0e21e
LW
2986 if (!SvOK(sv))
2987 return 0;
2988 if (SvROK(sv)) {
fabdb6c0
AL
2989 if (SvAMAGIC(sv)) {
2990 SV * const tmpsv = AMG_CALLun(sv,bool_);
2991 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2992 return (bool)SvTRUE(tmpsv);
2993 }
2994 return SvRV(sv) != 0;
a0d0e21e 2995 }
463ee0b2 2996 if (SvPOKp(sv)) {
53c1dcc0
AL
2997 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2998 if (Xpvtmp &&
339049b0 2999 (*sv->sv_u.svu_pv > '0' ||
11343788 3000 Xpvtmp->xpv_cur > 1 ||
339049b0 3001 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
463ee0b2
LW
3002 return 1;
3003 else
3004 return 0;
3005 }
3006 else {
3007 if (SvIOKp(sv))
3008 return SvIVX(sv) != 0;
3009 else {
3010 if (SvNOKp(sv))
3011 return SvNVX(sv) != 0.0;
180488f8 3012 else {
f7877b28 3013 if (isGV_with_GP(sv))
180488f8
NC
3014 return TRUE;
3015 else
3016 return FALSE;
3017 }
463ee0b2
LW
3018 }
3019 }
79072805
LW
3020}
3021
c461cf8f
JH
3022/*
3023=for apidoc sv_utf8_upgrade
3024
78ea37eb 3025Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3026Forces the SV to string form if it is not already.
4411f3b6
NIS
3027Always sets the SvUTF8 flag to avoid future validity checks even
3028if all the bytes have hibit clear.
c461cf8f 3029
13a6c0e0
JH
3030This is not as a general purpose byte encoding to Unicode interface:
3031use the Encode extension for that.
3032
8d6d96c1
HS
3033=for apidoc sv_utf8_upgrade_flags
3034
78ea37eb 3035Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3036Forces the SV to string form if it is not already.
8d6d96c1
HS
3037Always sets the SvUTF8 flag to avoid future validity checks even
3038if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3039will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3040C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3041
13a6c0e0
JH
3042This is not as a general purpose byte encoding to Unicode interface:
3043use the Encode extension for that.
3044
8d6d96c1
HS
3045=cut
3046*/
3047
3048STRLEN
3049Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3050{
97aff369 3051 dVAR;
808c356f
RGS
3052 if (sv == &PL_sv_undef)
3053 return 0;
e0e62c2a
NIS
3054 if (!SvPOK(sv)) {
3055 STRLEN len = 0;
d52b7888
NC
3056 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3057 (void) sv_2pv_flags(sv,&len, flags);
3058 if (SvUTF8(sv))
3059 return len;
3060 } else {
3061 (void) SvPV_force(sv,len);
3062 }
e0e62c2a 3063 }
4411f3b6 3064
f5cee72b 3065 if (SvUTF8(sv)) {
5fec3b1d 3066 return SvCUR(sv);
f5cee72b 3067 }
5fec3b1d 3068
765f542d
NC
3069 if (SvIsCOW(sv)) {
3070 sv_force_normal_flags(sv, 0);
db42d148
NIS
3071 }
3072
88632417 3073 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
799ef3cb 3074 sv_recode_to_utf8(sv, PL_encoding);
9f4817db 3075 else { /* Assume Latin-1/EBCDIC */
c4e7c712
NC
3076 /* This function could be much more efficient if we
3077 * had a FLAG in SVs to signal if there are any hibit
3078 * chars in the PV. Given that there isn't such a flag
3079 * make the loop as fast as possible. */
00b6aa41 3080 const U8 * const s = (U8 *) SvPVX_const(sv);
c4420975 3081 const U8 * const e = (U8 *) SvEND(sv);
93524f2b 3082 const U8 *t = s;
c4e7c712
NC
3083
3084 while (t < e) {
53c1dcc0 3085 const U8 ch = *t++;
00b6aa41
AL
3086 /* Check for hi bit */
3087 if (!NATIVE_IS_INVARIANT(ch)) {
3088 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3089 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3090
3091 SvPV_free(sv); /* No longer using what was there before. */
3092 SvPV_set(sv, (char*)recoded);
3093 SvCUR_set(sv, len - 1);
3094 SvLEN_set(sv, len); /* No longer know the real size. */
c4e7c712 3095 break;
00b6aa41 3096 }
c4e7c712
NC
3097 }
3098 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3099 SvUTF8_on(sv);
560a288e 3100 }
4411f3b6 3101 return SvCUR(sv);
560a288e
GS
3102}
3103
c461cf8f
JH
3104/*
3105=for apidoc sv_utf8_downgrade
3106
78ea37eb
ST
3107Attempts to convert the PV of an SV from characters to bytes.
3108If the PV contains a character beyond byte, this conversion will fail;
3109in this case, either returns false or, if C<fail_ok> is not
c461cf8f
JH
3110true, croaks.
3111
13a6c0e0
JH
3112This is not as a general purpose Unicode to byte encoding interface:
3113use the Encode extension for that.
3114
c461cf8f
JH
3115=cut
3116*/
3117
560a288e
GS
3118bool
3119Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3120{
97aff369 3121 dVAR;
78ea37eb 3122 if (SvPOKp(sv) && SvUTF8(sv)) {
fa301091 3123 if (SvCUR(sv)) {
03cfe0ae 3124 U8 *s;
652088fc 3125 STRLEN len;
fa301091 3126
765f542d
NC
3127 if (SvIsCOW(sv)) {
3128 sv_force_normal_flags(sv, 0);
3129 }
03cfe0ae
NIS
3130 s = (U8 *) SvPV(sv, len);
3131 if (!utf8_to_bytes(s, &len)) {
fa301091
JH
3132 if (fail_ok)
3133 return FALSE;
3134 else {
3135 if (PL_op)
3136 Perl_croak(aTHX_ "Wide character in %s",
53e06cf0 3137 OP_DESC(PL_op));
fa301091
JH
3138 else
3139 Perl_croak(aTHX_ "Wide character");
3140 }
4b3603a4 3141 }
b162af07 3142 SvCUR_set(sv, len);
67e989fb 3143 }
560a288e 3144 }
ffebcc3e 3145 SvUTF8_off(sv);
560a288e
GS
3146 return TRUE;
3147}
3148
c461cf8f
JH
3149/*
3150=for apidoc sv_utf8_encode
3151
78ea37eb
ST
3152Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3153flag off so that it looks like octets again.
c461cf8f
JH
3154
3155=cut
3156*/
3157
560a288e
GS
3158void
3159Perl_sv_utf8_encode(pTHX_ register SV *sv)
3160{
4c94c214
NC
3161 if (SvIsCOW(sv)) {
3162 sv_force_normal_flags(sv, 0);
3163 }
3164 if (SvREADONLY(sv)) {
3165 Perl_croak(aTHX_ PL_no_modify);
3166 }
a5f5288a 3167 (void) sv_utf8_upgrade(sv);
560a288e
GS
3168 SvUTF8_off(sv);
3169}
3170
4411f3b6
NIS
3171/*
3172=for apidoc sv_utf8_decode
3173
78ea37eb
ST
3174If the PV of the SV is an octet sequence in UTF-8
3175and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3176so that it looks like a character. If the PV contains only single-byte
3177characters, the C<SvUTF8> flag stays being off.
3178Scans PV for validity and returns false if the PV is invalid UTF-8.
4411f3b6
NIS
3179
3180=cut
3181*/
3182
560a288e
GS
3183bool
3184Perl_sv_utf8_decode(pTHX_ register SV *sv)
3185{
78ea37eb 3186 if (SvPOKp(sv)) {
93524f2b
NC
3187 const U8 *c;
3188 const U8 *e;
9cbac4c7 3189
645c22ef
DM
3190 /* The octets may have got themselves encoded - get them back as
3191 * bytes
3192 */
3193 if (!sv_utf8_downgrade(sv, TRUE))
560a288e
GS
3194 return FALSE;
3195
3196 /* it is actually just a matter of turning the utf8 flag on, but
3197 * we want to make sure everything inside is valid utf8 first.
3198 */
93524f2b 3199 c = (const U8 *) SvPVX_const(sv);
63cd0674 3200 if (!is_utf8_string(c, SvCUR(sv)+1))
67e989fb 3201 return FALSE;
93524f2b 3202 e = (const U8 *) SvEND(sv);
511c2ff0 3203 while (c < e) {
b64e5050 3204 const U8 ch = *c++;
c4d5f83a 3205 if (!UTF8_IS_INVARIANT(ch)) {
67e989fb
JH
3206 SvUTF8_on(sv);
3207 break;
3208 }
560a288e 3209 }
560a288e
GS
3210 }
3211 return TRUE;
3212}
3213
954c1994
GS
3214/*
3215=for apidoc sv_setsv
3216
645c22ef
DM
3217Copies the contents of the source SV C<ssv> into the destination SV
3218C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3219function if the source SV needs to be reused. Does not handle 'set' magic.
3220Loosely speaking, it performs a copy-by-value, obliterating any previous
3221content of the destination.
3222
3223You probably want to use one of the assortment of wrappers, such as
3224C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3225C<SvSetMagicSV_nosteal>.
3226
8d6d96c1
HS
3227=for apidoc sv_setsv_flags
3228
645c22ef
DM
3229Copies the contents of the source SV C<ssv> into the destination SV
3230C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3231function if the source SV needs to be reused. Does not handle 'set' magic.
3232Loosely speaking, it performs a copy-by-value, obliterating any previous
3233content of the destination.
3234If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
5fcdf167
NC
3235C<ssv> if appropriate, else not. If the C<flags> parameter has the
3236C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3237and C<sv_setsv_nomg> are implemented in terms of this function.
645c22ef
DM
3238
3239You probably want to use one of the assortment of wrappers, such as
3240C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3241C<SvSetMagicSV_nosteal>.
3242
3243This is the primary function for copying scalars, and most other
3244copy-ish functions and macros use this underneath.
8d6d96c1
HS
3245
3246=cut
3247*/
3248
5d0301b7 3249static void
2eb42952 3250S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
5d0301b7 3251{
70cd14a1 3252 I32 mro_changes = 0; /* 1 = method, 2 = isa */
dd69841b 3253
5d0301b7
NC
3254 if (dtype != SVt_PVGV) {
3255 const char * const name = GvNAME(sstr);
3256 const STRLEN len = GvNAMELEN(sstr);
0d092c36 3257 {
f7877b28
NC
3258 if (dtype >= SVt_PV) {
3259 SvPV_free(dstr);
3260 SvPV_set(dstr, 0);
3261 SvLEN_set(dstr, 0);
3262 SvCUR_set(dstr, 0);
3263 }
0d092c36 3264 SvUPGRADE(dstr, SVt_PVGV);
dedf8e73 3265 (void)SvOK_off(dstr);
2e5b91de
NC
3266 /* FIXME - why are we doing this, then turning it off and on again
3267 below? */
3268 isGV_with_GP_on(dstr);
f7877b28 3269 }
5d0301b7
NC
3270 GvSTASH(dstr) = GvSTASH(sstr);
3271 if (GvSTASH(dstr))
3272 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
ae8cc45f 3273 gv_name_set((GV *)dstr, name, len, GV_ADD);
5d0301b7
NC
3274 SvFAKE_on(dstr); /* can coerce to non-glob */
3275 }
3276
3277#ifdef GV_UNIQUE_CHECK
3278 if (GvUNIQUE((GV*)dstr)) {
3279 Perl_croak(aTHX_ PL_no_modify);
3280 }
3281#endif
3282
dd69841b
BB
3283 if(GvGP((GV*)sstr)) {
3284 /* If source has method cache entry, clear it */
3285 if(GvCVGEN(sstr)) {
3286 SvREFCNT_dec(GvCV(sstr));
3287 GvCV(sstr) = NULL;
3288 GvCVGEN(sstr) = 0;
3289 }
3290 /* If source has a real method, then a method is
3291 going to change */
3292 else if(GvCV((GV*)sstr)) {
70cd14a1 3293 mro_changes = 1;
dd69841b
BB
3294 }
3295 }
3296
3297 /* If dest already had a real method, that's a change as well */
70cd14a1
CB
3298 if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
3299 mro_changes = 1;
dd69841b
BB
3300 }
3301
70cd14a1
CB
3302 if(strEQ(GvNAME((GV*)dstr),"ISA"))
3303 mro_changes = 2;
3304
f7877b28 3305 gp_free((GV*)dstr);
2e5b91de 3306 isGV_with_GP_off(dstr);
5d0301b7 3307 (void)SvOK_off(dstr);
2e5b91de 3308 isGV_with_GP_on(dstr);
dedf8e73 3309 GvINTRO_off(dstr); /* one-shot flag */
5d0301b7
NC
3310 GvGP(dstr) = gp_ref(GvGP(sstr));
3311 if (SvTAINTED(sstr))
3312 SvTAINT(dstr);
3313 if (GvIMPORTED(dstr) != GVf_IMPORTED
3314 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3315 {
3316 GvIMPORTED_on(dstr);
3317 }
3318 GvMULTI_on(dstr);
70cd14a1
CB
3319 if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3320 else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
5d0301b7
NC
3321 return;
3322}
3323
b8473700 3324static void
2eb42952 3325S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) {
b8473700
NC
3326 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3327 SV *dref = NULL;
3328 const int intro = GvINTRO(dstr);
2440974c 3329 SV **location;
3386d083 3330 U8 import_flag = 0;
27242d61
NC
3331 const U32 stype = SvTYPE(sref);
3332
b8473700
NC
3333
3334#ifdef GV_UNIQUE_CHECK
3335 if (GvUNIQUE((GV*)dstr)) {
3336 Perl_croak(aTHX_ PL_no_modify);
3337 }
3338#endif
3339
3340 if (intro) {
3341 GvINTRO_off(dstr); /* one-shot flag */
3342 GvLINE(dstr) = CopLINE(PL_curcop);
3343 GvEGV(dstr) = (GV*)dstr;
3344 }
3345 GvMULTI_on(dstr);
27242d61 3346 switch (stype) {
b8473700 3347 case SVt_PVCV:
27242d61
NC
3348 location = (SV **) &GvCV(dstr);
3349 import_flag = GVf_IMPORTED_CV;
3350 goto common;
3351 case SVt_PVHV:
3352 location = (SV **) &GvHV(dstr);
3353 import_flag = GVf_IMPORTED_HV;
3354 goto common;
3355 case SVt_PVAV:
3356 location = (SV **) &GvAV(dstr);
3357 import_flag = GVf_IMPORTED_AV;
3358 goto common;
3359 case SVt_PVIO:
3360 location = (SV **) &GvIOp(dstr);
3361 goto common;
3362 case SVt_PVFM:
3363 location = (SV **) &GvFORM(dstr);
3364 default:
3365 location = &GvSV(dstr);
3366 import_flag = GVf_IMPORTED_SV;
3367 common:
b8473700 3368 if (intro) {
27242d61 3369 if (stype == SVt_PVCV) {
5f2fca8a
BB
3370 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/
3371 if (GvCVGEN(dstr)) {
27242d61
NC
3372 SvREFCNT_dec(GvCV(dstr));
3373 GvCV(dstr) = NULL;
3374 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
27242d61 3375 }
b8473700 3376 }
27242d61 3377 SAVEGENERICSV(*location);
b8473700
NC
3378 }
3379 else
27242d61 3380 dref = *location;
5f2fca8a 3381 if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
27242d61 3382 CV* const cv = (CV*)*location;
b8473700
NC
3383 if (cv) {
3384 if (!GvCVGEN((GV*)dstr) &&
3385 (CvROOT(cv) || CvXSUB(cv)))
3386 {
3387 /* Redefining a sub - warning is mandatory if
3388 it was a const and its value changed. */
3389 if (CvCONST(cv) && CvCONST((CV*)sref)
3390 && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
6f207bd3 3391 NOOP;
b8473700
NC
3392 /* They are 2 constant subroutines generated from
3393 the same constant. This probably means that
3394 they are really the "same" proxy subroutine
3395 instantiated in 2 places. Most likely this is
3396 when a constant is exported twice. Don't warn.
3397 */
3398 }
3399 else if (ckWARN(WARN_REDEFINE)
3400 || (CvCONST(cv)
3401 && (!CvCONST((CV*)sref)
3402 || sv_cmp(cv_const_sv(cv),
3403 cv_const_sv((CV*)sref))))) {
3404 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
10edeb5d
JH
3405 (const char *)
3406 (CvCONST(cv)
3407 ? "Constant subroutine %s::%s redefined"
3408 : "Subroutine %s::%s redefined"),
b8473700
NC
3409 HvNAME_get(GvSTASH((GV*)dstr)),
3410 GvENAME((GV*)dstr));
3411 }
3412 }
3413 if (!intro)
cbf82dd0
NC
3414 cv_ckproto_len(cv, (GV*)dstr,
3415 SvPOK(sref) ? SvPVX_const(sref) : NULL,
3416 SvPOK(sref) ? SvCUR(sref) : 0);
b8473700 3417 }
b8473700
NC
3418 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3419 GvASSUMECV_on(dstr);
dd69841b 3420 if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
b8473700 3421 }
2440974c 3422 *location = sref;
3386d083
NC
3423 if (import_flag && !(GvFLAGS(dstr) & import_flag)
3424 && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3425 GvFLAGS(dstr) |= import_flag;
b8473700
NC
3426 }
3427 break;
3428 }
b37c2d43 3429 SvREFCNT_dec(dref);
b8473700
NC
3430 if (SvTAINTED(sstr))
3431 SvTAINT(dstr);
3432 return;
3433}
3434
8d6d96c1
HS
3435void
3436Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3437{
97aff369 3438 dVAR;
8990e307
LW
3439 register U32 sflags;
3440 register int dtype;
42d0e0b7 3441 register svtype stype;
463ee0b2 3442
79072805
LW
3443 if (sstr == dstr)
3444 return;
29f4f0ab
NC
3445
3446 if (SvIS_FREED(dstr)) {
3447 Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
be2597df 3448 " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
29f4f0ab 3449 }
765f542d 3450 SV_CHECK_THINKFIRST_COW_DROP(dstr);
79072805 3451 if (!sstr)
3280af22 3452 sstr = &PL_sv_undef;
29f4f0ab 3453 if (SvIS_FREED(sstr)) {
6c9570dc
MHM
3454 Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3455 (void*)sstr, (void*)dstr);
29f4f0ab 3456 }
8990e307
LW
3457 stype = SvTYPE(sstr);
3458 dtype = SvTYPE(dstr);
79072805 3459
52944de8 3460 (void)SvAMAGIC_off(dstr);
7a5fa8a2 3461 if ( SvVOK(dstr) )
ece467f9
JP
3462 {
3463 /* need to nuke the magic */
3464 mg_free(dstr);
3465 SvRMAGICAL_off(dstr);
3466 }
9e7bc3e8 3467
463ee0b2 3468 /* There's a lot of redundancy below but we're going for speed here */
79072805 3469
8990e307 3470 switch (stype) {
79072805 3471 case SVt_NULL:
aece5585 3472 undef_sstr:
20408e3c
GS
3473 if (dtype != SVt_PVGV) {
3474 (void)SvOK_off(dstr);
3475 return;
3476 }
3477 break;
463ee0b2 3478 case SVt_IV:
aece5585
GA
3479 if (SvIOK(sstr)) {
3480 switch (dtype) {
3481 case SVt_NULL:
8990e307 3482 sv_upgrade(dstr, SVt_IV);
aece5585
GA
3483 break;
3484 case SVt_NV:
aece5585 3485 case SVt_PV:
a0d0e21e 3486 sv_upgrade(dstr, SVt_PVIV);
aece5585 3487 break;
010be86b
NC
3488 case SVt_PVGV:
3489 goto end_of_first_switch;
aece5585
GA
3490 }
3491 (void)SvIOK_only(dstr);
45977657 3492 SvIV_set(dstr, SvIVX(sstr));
25da4f38
IZ
3493 if (SvIsUV(sstr))
3494 SvIsUV_on(dstr);
37c25af0
NC
3495 /* SvTAINTED can only be true if the SV has taint magic, which in
3496 turn means that the SV type is PVMG (or greater). This is the
3497 case statement for SVt_IV, so this cannot be true (whatever gcov
3498 may say). */
3499 assert(!SvTAINTED(sstr));
aece5585 3500 return;
8990e307 3501 }
4df7f6af
NC
3502 if (!SvROK(sstr))
3503 goto undef_sstr;
3504 if (dtype < SVt_PV && dtype != SVt_IV)
3505 sv_upgrade(dstr, SVt_IV);
3506 break;
aece5585 3507
463ee0b2 3508 case SVt_NV:
aece5585
GA
3509 if (SvNOK(sstr)) {
3510 switch (dtype) {
3511 case SVt_NULL:
3512 case SVt_IV:
8990e307 3513 sv_upgrade(dstr, SVt_NV);
aece5585 3514 break;
aece5585
GA
3515 case SVt_PV:
3516 case SVt_PVIV:
a0d0e21e 3517 sv_upgrade(dstr, SVt_PVNV);
aece5585 3518 break;
010be86b
NC
3519 case SVt_PVGV:
3520 goto end_of_first_switch;
aece5585 3521 }
9d6ce603 3522 SvNV_set(dstr, SvNVX(sstr));
aece5585 3523 (void)SvNOK_only(dstr);
37c25af0
NC
3524 /* SvTAINTED can only be true if the SV has taint magic, which in
3525 turn means that the SV type is PVMG (or greater). This is the
3526 case statement for SVt_NV, so this cannot be true (whatever gcov
3527 may say). */
3528 assert(!SvTAINTED(sstr));
aece5585 3529 return;
8990e307 3530 }
aece5585
GA
3531 goto undef_sstr;
3532
fc36a67e 3533 case SVt_PVFM:
f8c7b90f 3534#ifdef PERL_OLD_COPY_ON_WRITE
d89fc664
NC
3535 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3536 if (dtype < SVt_PVIV)
3537 sv_upgrade(dstr, SVt_PVIV);
3538 break;
3539 }
3540 /* Fall through */
3541#endif
fd44068c 3542 case SVt_REGEXP:
d89fc664 3543 case SVt_PV:
8990e307 3544 if (dtype < SVt_PV)
463ee0b2 3545 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
3546 break;
3547 case SVt_PVIV:
8990e307 3548 if (dtype < SVt_PVIV)
463ee0b2 3549 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW
3550 break;
3551 case SVt_PVNV:
8990e307 3552 if (dtype < SVt_PVNV)
463ee0b2 3553 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 3554 break;
489f7bfe 3555 default:
a3b680e6
AL
3556 {
3557 const char * const type = sv_reftype(sstr,0);
533c011a 3558 if (PL_op)
a3b680e6 3559 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4633a7c4 3560 else
a3b680e6
AL
3561 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3562 }
4633a7c4
LW
3563 break;
3564
cecf5685 3565 /* case SVt_BIND: */
39cb70dc 3566 case SVt_PVLV:
79072805 3567 case SVt_PVGV:
cecf5685 3568 if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
d4c19fe8 3569 glob_assign_glob(dstr, sstr, dtype);
b8c701c1 3570 return;
79072805 3571 }
cecf5685 3572 /* SvVALID means that this PVGV is playing at being an FBM. */
5f66b61c 3573 /*FALLTHROUGH*/
79072805 3574
489f7bfe 3575 case SVt_PVMG:
8d6d96c1 3576 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
973f89ab 3577 mg_get(sstr);
1d9c78c6 3578 if (SvTYPE(sstr) != stype) {
973f89ab 3579 stype = SvTYPE(sstr);
cecf5685 3580 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
d4c19fe8 3581 glob_assign_glob(dstr, sstr, dtype);
b8c701c1
NC
3582 return;
3583 }
973f89ab
CS
3584 }
3585 }
ded42b9f 3586 if (stype == SVt_PVLV)
862a34c6 3587 SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 3588 else
42d0e0b7 3589 SvUPGRADE(dstr, (svtype)stype);
79072805 3590 }
010be86b 3591 end_of_first_switch:
79072805 3592
ff920335
NC
3593 /* dstr may have been upgraded. */
3594 dtype = SvTYPE(dstr);
8990e307
LW
3595 sflags = SvFLAGS(sstr);
3596
ba2fdce6 3597 if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
85324b4d
NC
3598 /* Assigning to a subroutine sets the prototype. */
3599 if (SvOK(sstr)) {
3600 STRLEN len;
3601 const char *const ptr = SvPV_const(sstr, len);
3602
3603 SvGROW(dstr, len + 1);
3604 Copy(ptr, SvPVX(dstr), len + 1, char);
3605 SvCUR_set(dstr, len);
fcddd32e 3606 SvPOK_only(dstr);
ba2fdce6 3607 SvFLAGS(dstr) |= sflags & SVf_UTF8;
85324b4d
NC
3608 } else {
3609 SvOK_off(dstr);
3610 }
ba2fdce6
NC
3611 } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3612 const char * const type = sv_reftype(dstr,0);
3613 if (PL_op)
3614 Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3615 else
3616 Perl_croak(aTHX_ "Cannot copy to %s", type);
85324b4d 3617 } else if (sflags & SVf_ROK) {
cecf5685
NC
3618 if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3619 && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
acaa9288
NC
3620 sstr = SvRV(sstr);
3621 if (sstr == dstr) {
3622 if (GvIMPORTED(dstr) != GVf_IMPORTED
3623 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3624 {
3625 GvIMPORTED_on(dstr);
3626 }
3627 GvMULTI_on(dstr);
3628 return;
3629 }
d4c19fe8 3630 glob_assign_glob(dstr, sstr, dtype);
acaa9288
NC
3631 return;
3632 }
3633
8990e307 3634 if (dtype >= SVt_PV) {
fdc5b023 3635 if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
d4c19fe8 3636 glob_assign_ref(dstr, sstr);
b8c701c1
NC
3637 return;
3638 }
3f7c398e 3639 if (SvPVX_const(dstr)) {
8bd4d4c5 3640 SvPV_free(dstr);
b162af07
SP
3641 SvLEN_set(dstr, 0);
3642 SvCUR_set(dstr, 0);
a0d0e21e 3643 }
8990e307 3644 }
a0d0e21e 3645 (void)SvOK_off(dstr);
b162af07 3646 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
96d4b0ee 3647 SvFLAGS(dstr) |= sflags & SVf_ROK;
dfd48732
NC
3648 assert(!(sflags & SVp_NOK));
3649 assert(!(sflags & SVp_IOK));
3650 assert(!(sflags & SVf_NOK));
3651 assert(!(sflags & SVf_IOK));
ed6116ce 3652 }
cecf5685 3653 else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
c0c44674
NC