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