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