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