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