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