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