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