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