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