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