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