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