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