This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sv_2pv_nolen, sv_2pvbyte_nolen and sv_2pvutf8_nolen can all be replaced
[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
PP
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
PP
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
PP
2377{
2378 if (!sv)
2379 return 0;
2380 if (SvGMAGICAL(sv)) {
891f9566
YST
2381 if (flags & SV_GMAGIC)
2382 mg_get(sv);
ff68c719
PP
2383 if (SvIOKp(sv))
2384 return SvUVX(sv);
2385 if (SvNOKp(sv))
2386 return U_V(SvNVX(sv));
36477c24
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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;
79072805 2956
463ee0b2 2957 if (!sv) {
cdb061a3
NC
2958 if (lp)
2959 *lp = 0;
73d840c0 2960 return (char *)"";
463ee0b2 2961 }
8990e307 2962 if (SvGMAGICAL(sv)) {
8d6d96c1
HS
2963 if (flags & SV_GMAGIC)
2964 mg_get(sv);
463ee0b2 2965 if (SvPOKp(sv)) {
cdb061a3
NC
2966 if (lp)
2967 *lp = SvCUR(sv);
10516c54
NC
2968 if (flags & SV_MUTABLE_RETURN)
2969 return SvPVX_mutable(sv);
4d84ee25
NC
2970 if (flags & SV_CONST_RETURN)
2971 return (char *)SvPVX_const(sv);
463ee0b2
LW
2972 return SvPVX(sv);
2973 }
cf2093f6 2974 if (SvIOKp(sv)) {
1c846c1f 2975 if (SvIsUV(sv))
57def98f 2976 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2977 else
57def98f 2978 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2979 tsv = Nullsv;
a0d0e21e 2980 goto tokensave;
463ee0b2
LW
2981 }
2982 if (SvNOKp(sv)) {
2d4389e4 2983 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2984 tsv = Nullsv;
a0d0e21e 2985 goto tokensave;
463ee0b2 2986 }
16d20bd9 2987 if (!SvROK(sv)) {
d008e5eb 2988 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
041457d9 2989 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
29489e7c 2990 report_uninit(sv);
c6ee37c5 2991 }
cdb061a3
NC
2992 if (lp)
2993 *lp = 0;
73d840c0 2994 return (char *)"";
16d20bd9 2995 }
463ee0b2 2996 }
ed6116ce
LW
2997 if (SvTHINKFIRST(sv)) {
2998 if (SvROK(sv)) {
a0d0e21e 2999 SV* tmpstr;
e1ec3a88 3000 register const char *typestr;
1554e226 3001 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
b4b9a328 3002 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
50adf7d2
NC
3003 /* Unwrap this: */
3004 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3005
3006 char *pv;
3007 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3008 if (flags & SV_CONST_RETURN) {
3009 pv = (char *) SvPVX_const(tmpstr);
3010 } else {
3011 pv = (flags & SV_MUTABLE_RETURN)
3012 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3013 }
3014 if (lp)
3015 *lp = SvCUR(tmpstr);
3016 } else {
3017 pv = sv_2pv_flags(tmpstr, lp, flags);
3018 }
446eaa42
YST
3019 if (SvUTF8(tmpstr))
3020 SvUTF8_on(sv);
3021 else
3022 SvUTF8_off(sv);
3023 return pv;
3024 }
cb50f42d 3025 origsv = sv;
ed6116ce
LW
3026 sv = (SV*)SvRV(sv);
3027 if (!sv)
e1ec3a88 3028 typestr = "NULLREF";
ed6116ce 3029 else {
f9277f47
IZ
3030 MAGIC *mg;
3031
ed6116ce 3032 switch (SvTYPE(sv)) {
f9277f47
IZ
3033 case SVt_PVMG:
3034 if ( ((SvFLAGS(sv) &
1c846c1f 3035 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
faf82a0b 3036 == (SVs_OBJECT|SVs_SMG))
14befaf4 3037 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
e1ec3a88 3038 const regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 3039
2cd61cdb 3040 if (!mg->mg_ptr) {
e1ec3a88 3041 const char *fptr = "msix";
8782bef2
GB
3042 char reflags[6];
3043 char ch;
3044 int left = 0;
3045 int right = 4;
ff385a1b 3046 char need_newline = 0;
eb160463 3047 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
8782bef2 3048
155aba94 3049 while((ch = *fptr++)) {
8782bef2
GB
3050 if(reganch & 1) {
3051 reflags[left++] = ch;
3052 }
3053 else {
3054 reflags[right--] = ch;
3055 }
3056 reganch >>= 1;
3057 }
3058 if(left != 4) {
3059 reflags[left] = '-';
3060 left = 5;
3061 }
3062
3063 mg->mg_len = re->prelen + 4 + left;
ff385a1b
JF
3064 /*
3065 * If /x was used, we have to worry about a regex
3066 * ending with a comment later being embedded
3067 * within another regex. If so, we don't want this
3068 * regex's "commentization" to leak out to the
3069 * right part of the enclosing regex, we must cap
3070 * it with a newline.
3071 *
3072 * So, if /x was used, we scan backwards from the
3073 * end of the regex. If we find a '#' before we
3074 * find a newline, we need to add a newline
3075 * ourself. If we find a '\n' first (or if we
3076 * don't find '#' or '\n'), we don't need to add
3077 * anything. -jfriedl
3078 */
3079 if (PMf_EXTENDED & re->reganch)
3080 {
e1ec3a88 3081 const char *endptr = re->precomp + re->prelen;
ff385a1b
JF
3082 while (endptr >= re->precomp)
3083 {
e1ec3a88 3084 const char c = *(endptr--);
ff385a1b
JF
3085 if (c == '\n')
3086 break; /* don't need another */
3087 if (c == '#') {
3088 /* we end while in a comment, so we
3089 need a newline */
3090 mg->mg_len++; /* save space for it */
3091 need_newline = 1; /* note to add it */
ab01544f 3092 break;
ff385a1b
JF
3093 }
3094 }
3095 }
3096
a02a5408 3097 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
8782bef2
GB
3098 Copy("(?", mg->mg_ptr, 2, char);
3099 Copy(reflags, mg->mg_ptr+2, left, char);
3100 Copy(":", mg->mg_ptr+left+2, 1, char);
3101 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
ff385a1b
JF
3102 if (need_newline)
3103 mg->mg_ptr[mg->mg_len - 2] = '\n';
1bd3ad17
IZ
3104 mg->mg_ptr[mg->mg_len - 1] = ')';
3105 mg->mg_ptr[mg->mg_len] = 0;
3106 }
3280af22 3107 PL_reginterp_cnt += re->program[0].next_off;
cb50f42d
YST
3108
3109 if (re->reganch & ROPT_UTF8)
3110 SvUTF8_on(origsv);
3111 else
3112 SvUTF8_off(origsv);
cdb061a3
NC
3113 if (lp)
3114 *lp = mg->mg_len;
1bd3ad17 3115 return mg->mg_ptr;
f9277f47
IZ
3116 }
3117 /* Fall through */
ed6116ce
LW
3118 case SVt_NULL:
3119 case SVt_IV:
3120 case SVt_NV:
3121 case SVt_RV:
3122 case SVt_PV:
3123 case SVt_PVIV:
3124 case SVt_PVNV:
e1ec3a88
AL
3125 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3126 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
be65207d
DM
3127 /* tied lvalues should appear to be
3128 * scalars for backwards compatitbility */
3129 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3130 ? "SCALAR" : "LVALUE"; break;
e1ec3a88
AL
3131 case SVt_PVAV: typestr = "ARRAY"; break;
3132 case SVt_PVHV: typestr = "HASH"; break;
3133 case SVt_PVCV: typestr = "CODE"; break;
3134 case SVt_PVGV: typestr = "GLOB"; break;
3135 case SVt_PVFM: typestr = "FORMAT"; break;
3136 case SVt_PVIO: typestr = "IO"; break;
3137 default: typestr = "UNKNOWN"; break;
ed6116ce 3138 }
46fc3d4c 3139 tsv = NEWSV(0,0);
a5cb6b62 3140 if (SvOBJECT(sv)) {
bfcb3514 3141 const char *name = HvNAME_get(SvSTASH(sv));
a5cb6b62 3142 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
e1ec3a88 3143 name ? name : "__ANON__" , typestr, PTR2UV(sv));
a5cb6b62 3144 }
ed6116ce 3145 else
e1ec3a88 3146 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
a0d0e21e 3147 goto tokensaveref;
463ee0b2 3148 }
cdb061a3
NC
3149 if (lp)
3150 *lp = strlen(typestr);
73d840c0 3151 return (char *)typestr;
79072805 3152 }
0336b60e 3153 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 3154 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 3155 report_uninit(sv);
cdb061a3
NC
3156 if (lp)
3157 *lp = 0;
73d840c0 3158 return (char *)"";
79072805 3159 }
79072805 3160 }
28e5dec8
JH
3161 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3162 /* I'm assuming that if both IV and NV are equally valid then
3163 converting the IV is going to be more efficient */
e1ec3a88
AL
3164 const U32 isIOK = SvIOK(sv);
3165 const U32 isUIOK = SvIsUV(sv);
28e5dec8
JH
3166 char buf[TYPE_CHARS(UV)];
3167 char *ebuf, *ptr;
3168
3169 if (SvTYPE(sv) < SVt_PVIV)
3170 sv_upgrade(sv, SVt_PVIV);
3171 if (isUIOK)
3172 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3173 else
3174 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
5902b6a9
NC
3175 /* inlined from sv_setpvn */
3176 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
4d84ee25 3177 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
28e5dec8
JH
3178 SvCUR_set(sv, ebuf - ptr);
3179 s = SvEND(sv);
3180 *s = '\0';
3181 if (isIOK)
3182 SvIOK_on(sv);
3183 else
3184 SvIOKp_on(sv);
3185 if (isUIOK)
3186 SvIsUV_on(sv);
3187 }
3188 else if (SvNOKp(sv)) {
79072805
LW
3189 if (SvTYPE(sv) < SVt_PVNV)
3190 sv_upgrade(sv, SVt_PVNV);
1c846c1f 3191 /* The +20 is pure guesswork. Configure test needed. --jhi */
5902b6a9 3192 s = SvGROW_mutable(sv, NV_DIG + 20);
79072805 3193 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 3194#ifdef apollo
463ee0b2 3195 if (SvNVX(sv) == 0.0)
79072805
LW
3196 (void)strcpy(s,"0");
3197 else
3198#endif /*apollo*/
bbce6d69 3199 {
2d4389e4 3200 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 3201 }
79072805 3202 errno = olderrno;
a0d0e21e
LW
3203#ifdef FIXNEGATIVEZERO
3204 if (*s == '-' && s[1] == '0' && !s[2])
3205 strcpy(s,"0");
3206#endif
79072805
LW
3207 while (*s) s++;
3208#ifdef hcx
3209 if (s[-1] == '.')
46fc3d4c 3210 *--s = '\0';
79072805
LW
3211#endif
3212 }
79072805 3213 else {
041457d9 3214 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
29489e7c 3215 report_uninit(sv);
cdb061a3 3216 if (lp)
a0d0e21e 3217 *lp = 0;
25da4f38
IZ
3218 if (SvTYPE(sv) < SVt_PV)
3219 /* Typically the caller expects that sv_any is not NULL now. */
3220 sv_upgrade(sv, SVt_PV);
73d840c0 3221 return (char *)"";
79072805 3222 }
cdb061a3 3223 {
823a54a3 3224 const STRLEN len = s - SvPVX_const(sv);
cdb061a3
NC
3225 if (lp)
3226 *lp = len;
3227 SvCUR_set(sv, len);
3228 }
79072805 3229 SvPOK_on(sv);
1d7c1841 3230 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3f7c398e 3231 PTR2UV(sv),SvPVX_const(sv)));
4d84ee25
NC
3232 if (flags & SV_CONST_RETURN)
3233 return (char *)SvPVX_const(sv);
10516c54
NC
3234 if (flags & SV_MUTABLE_RETURN)
3235 return SvPVX_mutable(sv);
463ee0b2 3236 return SvPVX(sv);
a0d0e21e
LW
3237
3238 tokensave:
3239 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3240 /* Sneaky stuff here */
3241
3242 tokensaveref:
46fc3d4c 3243 if (!tsv)
96827780 3244 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 3245 sv_2mortal(tsv);
cdb061a3
NC
3246 if (lp)
3247 *lp = SvCUR(tsv);
46fc3d4c 3248 return SvPVX(tsv);
a0d0e21e
LW
3249 }
3250 else {
27da23d5 3251 dVAR;
a0d0e21e 3252 STRLEN len;
73d840c0 3253 const char *t;
46fc3d4c
PP
3254
3255 if (tsv) {
3256 sv_2mortal(tsv);
3f7c398e 3257 t = SvPVX_const(tsv);
46fc3d4c
PP
3258 len = SvCUR(tsv);
3259 }
3260 else {
96827780
MB
3261 t = tmpbuf;
3262 len = strlen(tmpbuf);
46fc3d4c 3263 }
a0d0e21e 3264#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
3265 if (len == 2 && t[0] == '-' && t[1] == '0') {
3266 t = "0";
3267 len = 1;
3268 }
a0d0e21e 3269#endif
862a34c6 3270 SvUPGRADE(sv, SVt_PV);
cdb061a3
NC
3271 if (lp)
3272 *lp = len;
5902b6a9 3273 s = SvGROW_mutable(sv, len + 1);
a0d0e21e 3274 SvCUR_set(sv, len);
6bf554b4 3275 SvPOKp_on(sv);
490a0e98 3276 return memcpy(s, t, len + 1);
a0d0e21e 3277 }
463ee0b2
LW
3278}
3279
645c22ef 3280/*
6050d10e
JP
3281=for apidoc sv_copypv
3282
3283Copies a stringified representation of the source SV into the
3284destination SV. Automatically performs any necessary mg_get and
54f0641b 3285coercion of numeric values into strings. Guaranteed to preserve
6050d10e 3286UTF-8 flag even from overloaded objects. Similar in nature to
54f0641b
NIS
3287sv_2pv[_flags] but operates directly on an SV instead of just the
3288string. Mostly uses sv_2pv_flags to do its work, except when that
6050d10e
JP
3289would lose the UTF-8'ness of the PV.
3290
3291=cut
3292*/
3293
3294void
3295Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3296{
446eaa42 3297 STRLEN len;
53c1dcc0 3298 const char * const s = SvPV_const(ssv,len);
cb50f42d 3299 sv_setpvn(dsv,s,len);
446eaa42 3300 if (SvUTF8(ssv))
cb50f42d 3301 SvUTF8_on(dsv);
446eaa42 3302 else
cb50f42d 3303 SvUTF8_off(dsv);
6050d10e
JP
3304}
3305
3306/*
645c22ef
DM
3307=for apidoc sv_2pvbyte
3308
3309Return a pointer to the byte-encoded representation of the SV, and set *lp
1e54db1a 3310to its length. May cause the SV to be downgraded from UTF-8 as a
645c22ef
DM
3311side-effect.
3312
3313Usually accessed via the C<SvPVbyte> macro.
3314
3315=cut
3316*/
3317
7340a771
GS
3318char *
3319Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3320{
0875d2fe 3321 sv_utf8_downgrade(sv,0);
97972285 3322 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
7340a771
GS
3323}
3324
645c22ef 3325/*
7ee2227d
SP
3326 * =for apidoc sv_2pvutf8
3327 *
3328 * Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3329 * to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3330 *
3331 * Usually accessed via the C<SvPVutf8> macro.
3332 *
3333 * =cut
3334 * */
645c22ef 3335
7340a771
GS
3336char *
3337Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3338{
7ee2227d
SP
3339 sv_utf8_upgrade(sv);
3340 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
7340a771 3341}
1c846c1f 3342
7ee2227d 3343
645c22ef
DM
3344/*
3345=for apidoc sv_2bool
3346
3347This function is only called on magical items, and is only used by
8cf8f3d1 3348sv_true() or its macro equivalent.
645c22ef
DM
3349
3350=cut
3351*/
3352
463ee0b2 3353bool
864dbfa3 3354Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 3355{
5b295bef 3356 SvGETMAGIC(sv);
463ee0b2 3357
a0d0e21e
LW
3358 if (!SvOK(sv))
3359 return 0;
3360 if (SvROK(sv)) {
a0d0e21e 3361 SV* tmpsv;
1554e226 3362 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
9e3013b1 3363 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
8a31060d 3364 return (bool)SvTRUE(tmpsv);
a0d0e21e
LW
3365 return SvRV(sv) != 0;
3366 }
463ee0b2 3367 if (SvPOKp(sv)) {
53c1dcc0
AL
3368 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3369 if (Xpvtmp &&
339049b0 3370 (*sv->sv_u.svu_pv > '0' ||
11343788 3371 Xpvtmp->xpv_cur > 1 ||
339049b0 3372 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
463ee0b2
LW
3373 return 1;
3374 else
3375 return 0;
3376 }
3377 else {
3378 if (SvIOKp(sv))
3379 return SvIVX(sv) != 0;
3380 else {
3381 if (SvNOKp(sv))
3382 return SvNVX(sv) != 0.0;
3383 else
3384 return FALSE;
3385 }
3386 }
79072805
LW
3387}
3388
c461cf8f
JH
3389/*
3390=for apidoc sv_utf8_upgrade
3391
78ea37eb 3392Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3393Forces the SV to string form if it is not already.
4411f3b6
NIS
3394Always sets the SvUTF8 flag to avoid future validity checks even
3395if all the bytes have hibit clear.
c461cf8f 3396
13a6c0e0
JH
3397This is not as a general purpose byte encoding to Unicode interface:
3398use the Encode extension for that.
3399
8d6d96c1
HS
3400=for apidoc sv_utf8_upgrade_flags
3401
78ea37eb 3402Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3403Forces the SV to string form if it is not already.
8d6d96c1
HS
3404Always sets the SvUTF8 flag to avoid future validity checks even
3405if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3406will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3407C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3408
13a6c0e0
JH
3409This is not as a general purpose byte encoding to Unicode interface:
3410use the Encode extension for that.
3411
8d6d96c1
HS
3412=cut
3413*/
3414
3415STRLEN
3416Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3417{
808c356f
RGS
3418 if (sv == &PL_sv_undef)
3419 return 0;
e0e62c2a
NIS
3420 if (!SvPOK(sv)) {
3421 STRLEN len = 0;
d52b7888
NC
3422 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3423 (void) sv_2pv_flags(sv,&len, flags);
3424 if (SvUTF8(sv))
3425 return len;
3426 } else {
3427 (void) SvPV_force(sv,len);
3428 }
e0e62c2a 3429 }
4411f3b6 3430
f5cee72b 3431 if (SvUTF8(sv)) {
5fec3b1d 3432 return SvCUR(sv);
f5cee72b 3433 }
5fec3b1d 3434
765f542d
NC
3435 if (SvIsCOW(sv)) {
3436 sv_force_normal_flags(sv, 0);
db42d148
NIS
3437 }
3438
88632417 3439 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
799ef3cb 3440 sv_recode_to_utf8(sv, PL_encoding);
9f4817db 3441 else { /* Assume Latin-1/EBCDIC */
c4e7c712
NC
3442 /* This function could be much more efficient if we
3443 * had a FLAG in SVs to signal if there are any hibit
3444 * chars in the PV. Given that there isn't such a flag
3445 * make the loop as fast as possible. */
93524f2b
NC
3446 const U8 *s = (U8 *) SvPVX_const(sv);
3447 const U8 *e = (U8 *) SvEND(sv);
3448 const U8 *t = s;
c4e7c712
NC
3449 int hibit = 0;
3450
3451 while (t < e) {
53c1dcc0 3452 const U8 ch = *t++;
c4e7c712
NC
3453 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3454 break;
3455 }
3456 if (hibit) {
3457 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
53c1dcc0 3458 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
c4e7c712
NC
3459
3460 SvPV_free(sv); /* No longer using what was there before. */
3461
1e2ebb21 3462 SvPV_set(sv, (char*)recoded);
c4e7c712
NC
3463 SvCUR_set(sv, len - 1);
3464 SvLEN_set(sv, len); /* No longer know the real size. */
3465 }
3466 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3467 SvUTF8_on(sv);
560a288e 3468 }
4411f3b6 3469 return SvCUR(sv);
560a288e
GS
3470}
3471
c461cf8f
JH
3472/*
3473=for apidoc sv_utf8_downgrade
3474
78ea37eb
ST
3475Attempts to convert the PV of an SV from characters to bytes.
3476If the PV contains a character beyond byte, this conversion will fail;
3477in this case, either returns false or, if C<fail_ok> is not
c461cf8f
JH
3478true, croaks.
3479
13a6c0e0
JH
3480This is not as a general purpose Unicode to byte encoding interface:
3481use the Encode extension for that.
3482
c461cf8f
JH
3483=cut
3484*/
3485
560a288e
GS
3486bool
3487Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3488{
78ea37eb 3489 if (SvPOKp(sv) && SvUTF8(sv)) {
fa301091 3490 if (SvCUR(sv)) {
03cfe0ae 3491 U8 *s;
652088fc 3492 STRLEN len;
fa301091 3493
765f542d
NC
3494 if (SvIsCOW(sv)) {
3495 sv_force_normal_flags(sv, 0);
3496 }
03cfe0ae
NIS
3497 s = (U8 *) SvPV(sv, len);
3498 if (!utf8_to_bytes(s, &len)) {
fa301091
JH
3499 if (fail_ok)
3500 return FALSE;
3501 else {
3502 if (PL_op)
3503 Perl_croak(aTHX_ "Wide character in %s",
53e06cf0 3504 OP_DESC(PL_op));
fa301091
JH
3505 else
3506 Perl_croak(aTHX_ "Wide character");
3507 }
4b3603a4 3508 }
b162af07 3509 SvCUR_set(sv, len);
67e989fb 3510 }
560a288e 3511 }
ffebcc3e 3512 SvUTF8_off(sv);
560a288e
GS
3513 return TRUE;
3514}
3515
c461cf8f
JH
3516/*
3517=for apidoc sv_utf8_encode
3518
78ea37eb
ST
3519Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3520flag off so that it looks like octets again.
c461cf8f
JH
3521
3522=cut
3523*/
3524
560a288e
GS
3525void
3526Perl_sv_utf8_encode(pTHX_ register SV *sv)
3527{
4411f3b6 3528 (void) sv_utf8_upgrade(sv);
4c94c214
NC
3529 if (SvIsCOW(sv)) {
3530 sv_force_normal_flags(sv, 0);
3531 }
3532 if (SvREADONLY(sv)) {
3533 Perl_croak(aTHX_ PL_no_modify);
3534 }
560a288e
GS
3535 SvUTF8_off(sv);
3536}
3537
4411f3b6
NIS
3538/*
3539=for apidoc sv_utf8_decode
3540
78ea37eb
ST
3541If the PV of the SV is an octet sequence in UTF-8
3542and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3543so that it looks like a character. If the PV contains only single-byte
3544characters, the C<SvUTF8> flag stays being off.
3545Scans PV for validity and returns false if the PV is invalid UTF-8.
4411f3b6
NIS
3546
3547=cut
3548*/
3549
560a288e
GS
3550bool
3551Perl_sv_utf8_decode(pTHX_ register SV *sv)
3552{
78ea37eb 3553 if (SvPOKp(sv)) {
93524f2b
NC
3554 const U8 *c;
3555 const U8 *e;
9cbac4c7 3556
645c22ef
DM
3557 /* The octets may have got themselves encoded - get them back as
3558 * bytes
3559 */
3560 if (!sv_utf8_downgrade(sv, TRUE))
560a288e
GS
3561 return FALSE;
3562
3563 /* it is actually just a matter of turning the utf8 flag on, but
3564 * we want to make sure everything inside is valid utf8 first.
3565 */
93524f2b 3566 c = (const U8 *) SvPVX_const(sv);
63cd0674 3567 if (!is_utf8_string(c, SvCUR(sv)+1))
67e989fb 3568 return FALSE;
93524f2b 3569 e = (const U8 *) SvEND(sv);
511c2ff0 3570 while (c < e) {
b64e5050 3571 const U8 ch = *c++;
c4d5f83a 3572 if (!UTF8_IS_INVARIANT(ch)) {
67e989fb
JH
3573 SvUTF8_on(sv);
3574 break;
3575 }
560a288e 3576 }
560a288e
GS
3577 }
3578 return TRUE;
3579}
3580
954c1994
GS
3581/*
3582=for apidoc sv_setsv
3583
645c22ef
DM
3584Copies the contents of the source SV C<ssv> into the destination SV
3585C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3586function if the source SV needs to be reused. Does not handle 'set' magic.
3587Loosely speaking, it performs a copy-by-value, obliterating any previous
3588content of the destination.
3589
3590You probably want to use one of the assortment of wrappers, such as
3591C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3592C<SvSetMagicSV_nosteal>.
3593
8d6d96c1
HS
3594=for apidoc sv_setsv_flags
3595
645c22ef
DM
3596Copies the contents of the source SV C<ssv> into the destination SV
3597C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3598function if the source SV needs to be reused. Does not handle 'set' magic.
3599Loosely speaking, it performs a copy-by-value, obliterating any previous
3600content of the destination.
3601If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
5fcdf167
NC
3602C<ssv> if appropriate, else not. If the C<flags> parameter has the
3603C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3604and C<sv_setsv_nomg> are implemented in terms of this function.
645c22ef
DM
3605
3606You probably want to use one of the assortment of wrappers, such as
3607C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3608C<SvSetMagicSV_nosteal>.
3609
3610This is the primary function for copying scalars, and most other
3611copy-ish functions and macros use this underneath.
8d6d96c1
HS
3612
3613=cut
3614*/
3615
3616void
3617Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3618{
8990e307
LW
3619 register U32 sflags;
3620 register int dtype;
3621 register int stype;
463ee0b2 3622
79072805
LW
3623 if (sstr == dstr)
3624 return;
765f542d 3625 SV_CHECK_THINKFIRST_COW_DROP(dstr);
79072805 3626 if (!sstr)
3280af22 3627 sstr = &PL_sv_undef;
8990e307
LW
3628 stype = SvTYPE(sstr);
3629 dtype = SvTYPE(dstr);
79072805 3630
a0d0e21e 3631 SvAMAGIC_off(dstr);
7a5fa8a2 3632 if ( SvVOK(dstr) )
ece467f9
JP
3633 {
3634 /* need to nuke the magic */
3635 mg_free(dstr);
3636 SvRMAGICAL_off(dstr);
3637 }
9e7bc3e8 3638
463ee0b2 3639 /* There's a lot of redundancy below but we're going for speed here */
79072805 3640
8990e307 3641 switch (stype) {
79072805 3642 case SVt_NULL:
aece5585 3643 undef_sstr:
20408e3c
GS
3644 if (dtype != SVt_PVGV) {
3645 (void)SvOK_off(dstr);
3646 return;
3647 }
3648 break;
463ee0b2 3649 case SVt_IV:
aece5585
GA
3650 if (SvIOK(sstr)) {
3651 switch (dtype) {
3652 case SVt_NULL:
8990e307 3653 sv_upgrade(dstr, SVt_IV);
aece5585
GA
3654 break;
3655 case SVt_NV:
8990e307 3656 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
3657 break;
3658 case SVt_RV:
3659 case SVt_PV:
a0d0e21e 3660 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA
3661 break;
3662 }
3663 (void)SvIOK_only(dstr);
45977657 3664 SvIV_set(dstr, SvIVX(sstr));
25da4f38
IZ
3665 if (SvIsUV(sstr))
3666 SvIsUV_on(dstr);
27c9684d
AP
3667 if (SvTAINTED(sstr))
3668 SvTAINT(dstr);
aece5585 3669 return;
8990e307 3670 }
aece5585
GA
3671 goto undef_sstr;
3672
463ee0b2 3673 case SVt_NV:
aece5585
GA
3674 if (SvNOK(sstr)) {
3675 switch (dtype) {
3676 case SVt_NULL:
3677 case SVt_IV:
8990e307 3678 sv_upgrade(dstr, SVt_NV);
aece5585
GA
3679 break;
3680 case SVt_RV:
3681 case SVt_PV:
3682 case SVt_PVIV:
a0d0e21e 3683 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
3684 break;
3685 }
9d6ce603 3686 SvNV_set(dstr, SvNVX(sstr));
aece5585 3687 (void)SvNOK_only(dstr);
27c9684d
AP
3688 if (SvTAINTED(sstr))
3689 SvTAINT(dstr);
aece5585 3690 return;
8990e307 3691 }
aece5585
GA
3692 goto undef_sstr;
3693
ed6116ce 3694 case SVt_RV:
8990e307 3695 if (dtype < SVt_RV)
ed6116ce 3696 sv_upgrade(dstr, SVt_RV);
c07a80fd 3697 else if (dtype == SVt_PVGV &&
23bb1b96 3698 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
c07a80fd 3699 sstr = SvRV(sstr);
a5f75d66 3700 if (sstr == dstr) {
1d7c1841
GS
3701 if (GvIMPORTED(dstr) != GVf_IMPORTED
3702 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3703 {
a5f75d66 3704 GvIMPORTED_on(dstr);
1d7c1841 3705 }
a5f75d66
AD
3706 GvMULTI_on(dstr);
3707 return;
3708 }
c07a80fd
PP
3709 goto glob_assign;
3710 }
ed6116ce 3711 break;
fc36a67e 3712 case SVt_PVFM:
f8c7b90f 3713#ifdef PERL_OLD_COPY_ON_WRITE
d89fc664
NC
3714 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3715 if (dtype < SVt_PVIV)
3716 sv_upgrade(dstr, SVt_PVIV);
3717 break;
3718 }
3719 /* Fall through */
3720#endif
3721 case SVt_PV:
8990e307 3722 if (dtype < SVt_PV)
463ee0b2 3723 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
3724 break;
3725 case SVt_PVIV: