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