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