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