This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Really fix change 24527
[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 = "???";
bfcb3514 757 else if (!(p=HvNAME_get(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();
bfcb3514 1973 ((XPVHV*) SvANY(sv))->xhv_aux = 0;
463ee0b2
LW
1974 HvFILL(sv) = 0;
1975 HvMAX(sv) = 0;
8aacddc1 1976 HvTOTALKEYS(sv) = 0;
bd4b1eb5
NC
1977
1978 /* Fall through... */
1979 if (0) {
1980 case SVt_PVAV:
1981 SvANY(sv) = new_XPVAV();
1982 AvMAX(sv) = -1;
1983 AvFILLp(sv) = -1;
1984 AvALLOC(sv) = 0;
1985 AvARYLEN(sv)= 0;
11ca45c0 1986 AvREAL_only(sv);
bd4b1eb5
NC
1987 SvIV_set(sv, 0);
1988 SvNV_set(sv, 0.0);
1989 }
1990 /* to here. */
c2bfdfaf
NC
1991 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1992 assert(!pv);
8bd4d4c5
NC
1993 /* FIXME. Should be able to remove all this if()... if the above
1994 assertion is genuinely always true. */
1995 if(SvOOK(sv)) {
1996 pv -= iv;
1997 SvFLAGS(sv) &= ~SVf_OOK;
1998 }
1999 Safefree(pv);
bd4b1eb5 2000 SvPV_set(sv, (char*)0);
b162af07
SP
2001 SvMAGIC_set(sv, magic);
2002 SvSTASH_set(sv, stash);
79072805 2003 break;
bd4b1eb5
NC
2004
2005 case SVt_PVIO:
2006 SvANY(sv) = new_XPVIO();
2007 Zero(SvANY(sv), 1, XPVIO);
2008 IoPAGE_LEN(sv) = 60;
2009 goto set_magic_common;
2010 case SVt_PVFM:
2011 SvANY(sv) = new_XPVFM();
2012 Zero(SvANY(sv), 1, XPVFM);
2013 goto set_magic_common;
2014 case SVt_PVBM:
2015 SvANY(sv) = new_XPVBM();
2016 BmRARE(sv) = 0;
2017 BmUSEFUL(sv) = 0;
2018 BmPREVIOUS(sv) = 0;
2019 goto set_magic_common;
2020 case SVt_PVGV:
2021 SvANY(sv) = new_XPVGV();
2022 GvGP(sv) = 0;
2023 GvNAME(sv) = 0;
2024 GvNAMELEN(sv) = 0;
2025 GvSTASH(sv) = 0;
2026 GvFLAGS(sv) = 0;
2027 goto set_magic_common;
79072805
LW
2028 case SVt_PVCV:
2029 SvANY(sv) = new_XPVCV();
748a9306 2030 Zero(SvANY(sv), 1, XPVCV);
bd4b1eb5
NC
2031 goto set_magic_common;
2032 case SVt_PVLV:
2033 SvANY(sv) = new_XPVLV();
2034 LvTARGOFF(sv) = 0;
2035 LvTARGLEN(sv) = 0;
2036 LvTARG(sv) = 0;
2037 LvTYPE(sv) = 0;
93a17b20 2038 GvGP(sv) = 0;
79072805
LW
2039 GvNAME(sv) = 0;
2040 GvNAMELEN(sv) = 0;
2041 GvSTASH(sv) = 0;
a5f75d66 2042 GvFLAGS(sv) = 0;
bd4b1eb5
NC
2043 /* Fall through. */
2044 if (0) {
2045 case SVt_PVMG:
2046 SvANY(sv) = new_XPVMG();
2047 }
2048 set_magic_common:
b162af07
SP
2049 SvMAGIC_set(sv, magic);
2050 SvSTASH_set(sv, stash);
bd4b1eb5
NC
2051 /* Fall through. */
2052 if (0) {
2053 case SVt_PVNV:
2054 SvANY(sv) = new_XPVNV();
2055 }
9d6ce603 2056 SvNV_set(sv, nv);
bd4b1eb5
NC
2057 /* Fall through. */
2058 if (0) {
2059 case SVt_PVIV:
2060 SvANY(sv) = new_XPVIV();
2061 if (SvNIOK(sv))
2062 (void)SvIOK_on(sv);
2063 SvNOK_off(sv);
2064 }
2065 SvIV_set(sv, iv);
2066 /* Fall through. */
2067 if (0) {
2068 case SVt_PV:
2069 SvANY(sv) = new_XPV();
2070 }
f880fe2f 2071 SvPV_set(sv, pv);
b162af07
SP
2072 SvCUR_set(sv, cur);
2073 SvLEN_set(sv, len);
8990e307
LW
2074 break;
2075 }
79072805
LW
2076 return TRUE;
2077}
2078
645c22ef
DM
2079/*
2080=for apidoc sv_backoff
2081
2082Remove any string offset. You should normally use the C<SvOOK_off> macro
2083wrapper instead.
2084
2085=cut
2086*/
2087
79072805 2088int
864dbfa3 2089Perl_sv_backoff(pTHX_ register SV *sv)
79072805
LW
2090{
2091 assert(SvOOK(sv));
463ee0b2
LW
2092 if (SvIVX(sv)) {
2093 char *s = SvPVX(sv);
b162af07 2094 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
f880fe2f 2095 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
79072805 2096 SvIV_set(sv, 0);
463ee0b2 2097 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW
2098 }
2099 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 2100 return 0;
79072805
LW
2101}
2102
954c1994
GS
2103/*
2104=for apidoc sv_grow
2105
645c22ef
DM
2106Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2107upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2108Use the C<SvGROW> wrapper instead.
954c1994
GS
2109
2110=cut
2111*/
2112
79072805 2113char *
864dbfa3 2114Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
79072805
LW
2115{
2116 register char *s;
2117
55497cff 2118#ifdef HAS_64K_LIMIT
79072805 2119 if (newlen >= 0x10000) {
1d7c1841
GS
2120 PerlIO_printf(Perl_debug_log,
2121 "Allocation too large: %"UVxf"\n", (UV)newlen);
79072805
LW
2122 my_exit(1);
2123 }
55497cff 2124#endif /* HAS_64K_LIMIT */
a0d0e21e
LW
2125 if (SvROK(sv))
2126 sv_unref(sv);
79072805
LW
2127 if (SvTYPE(sv) < SVt_PV) {
2128 sv_upgrade(sv, SVt_PV);
463ee0b2 2129 s = SvPVX(sv);
79072805
LW
2130 }
2131 else if (SvOOK(sv)) { /* pv is offset? */
2132 sv_backoff(sv);
463ee0b2 2133 s = SvPVX(sv);
79072805
LW
2134 if (newlen > SvLEN(sv))
2135 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
c6f8c383
GA
2136#ifdef HAS_64K_LIMIT
2137 if (newlen >= 0x10000)
2138 newlen = 0xFFFF;
2139#endif
79072805 2140 }
bc44a8a2 2141 else
463ee0b2 2142 s = SvPVX(sv);
54f0641b 2143
79072805 2144 if (newlen > SvLEN(sv)) { /* need more room? */
8d6dde3e 2145 if (SvLEN(sv) && s) {
7bab3ede 2146#ifdef MYMALLOC
a3b680e6 2147 const STRLEN l = malloced_size((void*)SvPVX(sv));
8d6dde3e
IZ
2148 if (newlen <= l) {
2149 SvLEN_set(sv, l);
2150 return s;
2151 } else
c70c8a0a 2152#endif
79072805 2153 Renew(s,newlen,char);
8d6dde3e 2154 }
bfed75c6 2155 else {
4e83176d 2156 New(703, s, newlen, char);
40565179 2157 if (SvPVX(sv) && SvCUR(sv)) {
54f0641b 2158 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
40565179 2159 }
4e83176d 2160 }
79072805 2161 SvPV_set(sv, s);
e1ec3a88 2162 SvLEN_set(sv, newlen);
79072805
LW
2163 }
2164 return s;
2165}
2166
954c1994
GS
2167/*
2168=for apidoc sv_setiv
2169
645c22ef
DM
2170Copies an integer into the given SV, upgrading first if necessary.
2171Does not handle 'set' magic. See also C<sv_setiv_mg>.
954c1994
GS
2172
2173=cut
2174*/
2175
79072805 2176void
864dbfa3 2177Perl_sv_setiv(pTHX_ register SV *sv, IV i)
79072805 2178{
765f542d 2179 SV_CHECK_THINKFIRST_COW_DROP(sv);
463ee0b2
LW
2180 switch (SvTYPE(sv)) {
2181 case SVt_NULL:
79072805 2182 sv_upgrade(sv, SVt_IV);
463ee0b2
LW
2183 break;
2184 case SVt_NV:
2185 sv_upgrade(sv, SVt_PVNV);
2186 break;
ed6116ce 2187 case SVt_RV:
463ee0b2 2188 case SVt_PV:
79072805 2189 sv_upgrade(sv, SVt_PVIV);
463ee0b2 2190 break;
a0d0e21e
LW
2191
2192 case SVt_PVGV:
a0d0e21e
LW
2193 case SVt_PVAV:
2194 case SVt_PVHV:
2195 case SVt_PVCV:
2196 case SVt_PVFM:
2197 case SVt_PVIO:
411caa50 2198 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
53e06cf0 2199 OP_DESC(PL_op));
463ee0b2 2200 }
a0d0e21e 2201 (void)SvIOK_only(sv); /* validate number */
45977657 2202 SvIV_set(sv, i);
463ee0b2 2203 SvTAINT(sv);
79072805
LW
2204}
2205
954c1994
GS
2206/*
2207=for apidoc sv_setiv_mg
2208
2209Like C<sv_setiv>, but also handles 'set' magic.
2210
2211=cut
2212*/
2213
79072805 2214void
864dbfa3 2215Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
ef50df4b
GS
2216{
2217 sv_setiv(sv,i);
2218 SvSETMAGIC(sv);
2219}
2220
954c1994
GS
2221/*
2222=for apidoc sv_setuv
2223
645c22ef
DM
2224Copies an unsigned integer into the given SV, upgrading first if necessary.
2225Does not handle 'set' magic. See also C<sv_setuv_mg>.
954c1994
GS
2226
2227=cut
2228*/
2229
ef50df4b 2230void
864dbfa3 2231Perl_sv_setuv(pTHX_ register SV *sv, UV u)
55497cff 2232{
55ada374
NC
2233 /* With these two if statements:
2234 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 2235
55ada374
NC
2236 without
2237 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 2238
55ada374
NC
2239 If you wish to remove them, please benchmark to see what the effect is
2240 */
28e5dec8
JH
2241 if (u <= (UV)IV_MAX) {
2242 sv_setiv(sv, (IV)u);
2243 return;
2244 }
25da4f38
IZ
2245 sv_setiv(sv, 0);
2246 SvIsUV_on(sv);
607fa7f2 2247 SvUV_set(sv, u);
55497cff
PP
2248}
2249
954c1994
GS
2250/*
2251=for apidoc sv_setuv_mg
2252
2253Like C<sv_setuv>, but also handles 'set' magic.
2254
2255=cut
2256*/
2257
55497cff 2258void
864dbfa3 2259Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b 2260{
55ada374
NC
2261 /* With these two if statements:
2262 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 2263
55ada374
NC
2264 without
2265 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 2266
55ada374
NC
2267 If you wish to remove them, please benchmark to see what the effect is
2268 */
28e5dec8
JH
2269 if (u <= (UV)IV_MAX) {
2270 sv_setiv(sv, (IV)u);
2271 } else {
2272 sv_setiv(sv, 0);
2273 SvIsUV_on(sv);
2274 sv_setuv(sv,u);
2275 }
ef50df4b
GS
2276 SvSETMAGIC(sv);
2277}
2278
954c1994
GS
2279/*
2280=for apidoc sv_setnv
2281
645c22ef
DM
2282Copies a double into the given SV, upgrading first if necessary.
2283Does not handle 'set' magic. See also C<sv_setnv_mg>.
954c1994
GS
2284
2285=cut
2286*/
2287
ef50df4b 2288void
65202027 2289Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 2290{
765f542d 2291 SV_CHECK_THINKFIRST_COW_DROP(sv);
a0d0e21e
LW
2292 switch (SvTYPE(sv)) {
2293 case SVt_NULL:
2294 case SVt_IV:
79072805 2295 sv_upgrade(sv, SVt_NV);
a0d0e21e 2296 break;
a0d0e21e
LW
2297 case SVt_RV:
2298 case SVt_PV:
2299 case SVt_PVIV:
79072805 2300 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 2301 break;
827b7e14 2302
a0d0e21e 2303 case SVt_PVGV:
a0d0e21e
LW
2304 case SVt_PVAV:
2305 case SVt_PVHV:
2306 case SVt_PVCV:
2307 case SVt_PVFM:
2308 case SVt_PVIO:
411caa50 2309 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
53e06cf0 2310 OP_NAME(PL_op));
79072805 2311 }
9d6ce603 2312 SvNV_set(sv, num);
a0d0e21e 2313 (void)SvNOK_only(sv); /* validate number */
463ee0b2 2314 SvTAINT(sv);
79072805
LW
2315}
2316
954c1994
GS
2317/*
2318=for apidoc sv_setnv_mg
2319
2320Like C<sv_setnv>, but also handles 'set' magic.
2321
2322=cut
2323*/
2324
ef50df4b 2325void
65202027 2326Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS
2327{
2328 sv_setnv(sv,num);
2329 SvSETMAGIC(sv);
2330}
2331
645c22ef
DM
2332/* Print an "isn't numeric" warning, using a cleaned-up,
2333 * printable version of the offending string
2334 */
2335
76e3520e 2336STATIC void
cea2e8a9 2337S_not_a_number(pTHX_ SV *sv)
a0d0e21e 2338{
94463019
JH
2339 SV *dsv;
2340 char tmpbuf[64];
2341 char *pv;
2342
2343 if (DO_UTF8(sv)) {
2344 dsv = sv_2mortal(newSVpv("", 0));
2345 pv = sv_uni_display(dsv, sv, 10, 0);
2346 } else {
2347 char *d = tmpbuf;
2348 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2349 /* each *s can expand to 4 chars + "...\0",
2350 i.e. need room for 8 chars */
ecdeb87c 2351
94463019
JH
2352 char *s, *end;
2353 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2354 int ch = *s & 0xFF;
2355 if (ch & 128 && !isPRINT_LC(ch)) {
2356 *d++ = 'M';
2357 *d++ = '-';
2358 ch &= 127;
2359 }
2360 if (ch == '\n') {
2361 *d++ = '\\';
2362 *d++ = 'n';
2363 }
2364 else if (ch == '\r') {
2365 *d++ = '\\';
2366 *d++ = 'r';
2367 }
2368 else if (ch == '\f') {
2369 *d++ = '\\';
2370 *d++ = 'f';
2371 }
2372 else if (ch == '\\') {
2373 *d++ = '\\';
2374 *d++ = '\\';
2375 }
2376 else if (ch == '\0') {
2377 *d++ = '\\';
2378 *d++ = '0';
2379 }
2380 else if (isPRINT_LC(ch))
2381 *d++ = ch;
2382 else {
2383 *d++ = '^';
2384 *d++ = toCTRL(ch);
2385 }
2386 }
2387 if (s < end) {
2388 *d++ = '.';
2389 *d++ = '.';
2390 *d++ = '.';
2391 }
2392 *d = '\0';
2393 pv = tmpbuf;
a0d0e21e 2394 }
a0d0e21e 2395
533c011a 2396 if (PL_op)
9014280d 2397 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019
JH
2398 "Argument \"%s\" isn't numeric in %s", pv,
2399 OP_DESC(PL_op));
a0d0e21e 2400 else
9014280d 2401 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019 2402 "Argument \"%s\" isn't numeric", pv);
a0d0e21e
LW
2403}
2404
c2988b20
NC
2405/*
2406=for apidoc looks_like_number
2407
645c22ef
DM
2408Test if the content of an SV looks like a number (or is a number).
2409C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2410non-numeric warning), even if your atof() doesn't grok them.
c2988b20
NC
2411
2412=cut
2413*/
2414
2415I32
2416Perl_looks_like_number(pTHX_ SV *sv)
2417{
a3b680e6 2418 register const char *sbegin;
c2988b20
NC
2419 STRLEN len;
2420
2421 if (SvPOK(sv)) {
2422 sbegin = SvPVX(sv);
2423 len = SvCUR(sv);
2424 }
2425 else if (SvPOKp(sv))
2426 sbegin = SvPV(sv, len);
2427 else
e0ab1c0e 2428 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
c2988b20
NC
2429 return grok_number(sbegin, len, NULL);
2430}
25da4f38
IZ
2431
2432/* Actually, ISO C leaves conversion of UV to IV undefined, but
2433 until proven guilty, assume that things are not that bad... */
2434
645c22ef
DM
2435/*
2436 NV_PRESERVES_UV:
2437
2438 As 64 bit platforms often have an NV that doesn't preserve all bits of
28e5dec8
JH
2439 an IV (an assumption perl has been based on to date) it becomes necessary
2440 to remove the assumption that the NV always carries enough precision to
2441 recreate the IV whenever needed, and that the NV is the canonical form.
2442 Instead, IV/UV and NV need to be given equal rights. So as to not lose
645c22ef 2443 precision as a side effect of conversion (which would lead to insanity
28e5dec8
JH
2444 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2445 1) to distinguish between IV/UV/NV slots that have cached a valid
2446 conversion where precision was lost and IV/UV/NV slots that have a
2447 valid conversion which has lost no precision
645c22ef 2448 2) to ensure that if a numeric conversion to one form is requested that
28e5dec8
JH
2449 would lose precision, the precise conversion (or differently
2450 imprecise conversion) is also performed and cached, to prevent
2451 requests for different numeric formats on the same SV causing
2452 lossy conversion chains. (lossless conversion chains are perfectly
2453 acceptable (still))
2454
2455
2456 flags are used:
2457 SvIOKp is true if the IV slot contains a valid value
2458 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2459 SvNOKp is true if the NV slot contains a valid value
2460 SvNOK is true only if the NV value is accurate
2461
2462 so
645c22ef 2463 while converting from PV to NV, check to see if converting that NV to an
28e5dec8
JH
2464 IV(or UV) would lose accuracy over a direct conversion from PV to
2465 IV(or UV). If it would, cache both conversions, return NV, but mark
2466 SV as IOK NOKp (ie not NOK).
2467
645c22ef 2468 While converting from PV to IV, check to see if converting that IV to an
28e5dec8
JH
2469 NV would lose accuracy over a direct conversion from PV to NV. If it
2470 would, cache both conversions, flag similarly.
2471
2472 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2473 correctly because if IV & NV were set NV *always* overruled.
645c22ef
DM
2474 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2475 changes - now IV and NV together means that the two are interchangeable:
28e5dec8 2476 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
d460ef45 2477
645c22ef
DM
2478 The benefit of this is that operations such as pp_add know that if
2479 SvIOK is true for both left and right operands, then integer addition
2480 can be used instead of floating point (for cases where the result won't
2481 overflow). Before, floating point was always used, which could lead to
28e5dec8
JH
2482 loss of precision compared with integer addition.
2483
2484 * making IV and NV equal status should make maths accurate on 64 bit
2485 platforms
2486 * may speed up maths somewhat if pp_add and friends start to use
645c22ef 2487 integers when possible instead of fp. (Hopefully the overhead in
28e5dec8
JH
2488 looking for SvIOK and checking for overflow will not outweigh the
2489 fp to integer speedup)
2490 * will slow down integer operations (callers of SvIV) on "inaccurate"
2491 values, as the change from SvIOK to SvIOKp will cause a call into
2492 sv_2iv each time rather than a macro access direct to the IV slot
2493 * should speed up number->string conversion on integers as IV is
645c22ef 2494 favoured when IV and NV are equally accurate
28e5dec8
JH
2495
2496 ####################################################################
645c22ef
DM
2497 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2498 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2499 On the other hand, SvUOK is true iff UV.
28e5dec8
JH
2500 ####################################################################
2501
645c22ef 2502 Your mileage will vary depending your CPU's relative fp to integer
28e5dec8
JH
2503 performance ratio.
2504*/
2505
2506#ifndef NV_PRESERVES_UV
645c22ef
DM
2507# define IS_NUMBER_UNDERFLOW_IV 1
2508# define IS_NUMBER_UNDERFLOW_UV 2
2509# define IS_NUMBER_IV_AND_UV 2
2510# define IS_NUMBER_OVERFLOW_IV 4
2511# define IS_NUMBER_OVERFLOW_UV 5
2512
2513/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
28e5dec8
JH
2514
2515/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2516STATIC int
645c22ef 2517S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
28e5dec8 2518{
1779d84d 2519 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
2520 if (SvNVX(sv) < (NV)IV_MIN) {
2521 (void)SvIOKp_on(sv);
2522 (void)SvNOK_on(sv);
45977657 2523 SvIV_set(sv, IV_MIN);
28e5dec8
JH
2524 return IS_NUMBER_UNDERFLOW_IV;
2525 }
2526 if (SvNVX(sv) > (NV)UV_MAX) {
2527 (void)SvIOKp_on(sv);
2528 (void)SvNOK_on(sv);
2529 SvIsUV_on(sv);
607fa7f2 2530 SvUV_set(sv, UV_MAX);
28e5dec8
JH
2531 return IS_NUMBER_OVERFLOW_UV;
2532 }
c2988b20
NC
2533 (void)SvIOKp_on(sv);
2534 (void)SvNOK_on(sv);
2535 /* Can't use strtol etc to convert this string. (See truth table in
2536 sv_2iv */
2537 if (SvNVX(sv) <= (UV)IV_MAX) {
45977657 2538 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2539 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2540 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2541 } else {
2542 /* Integer is imprecise. NOK, IOKp */
2543 }
2544 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2545 }
2546 SvIsUV_on(sv);
607fa7f2 2547 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2548 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2549 if (SvUVX(sv) == UV_MAX) {
2550 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2551 possibly be preserved by NV. Hence, it must be overflow.
2552 NOK, IOKp */
2553 return IS_NUMBER_OVERFLOW_UV;
2554 }
2555 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2556 } else {
2557 /* Integer is imprecise. NOK, IOKp */
28e5dec8 2558 }
c2988b20 2559 return IS_NUMBER_OVERFLOW_IV;
28e5dec8 2560}
645c22ef
DM
2561#endif /* !NV_PRESERVES_UV*/
2562
891f9566
YST
2563/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2564 * this function provided for binary compatibility only
2565 */
2566
2567IV
2568Perl_sv_2iv(pTHX_ register SV *sv)
2569{
2570 return sv_2iv_flags(sv, SV_GMAGIC);
2571}
2572
645c22ef 2573/*
891f9566 2574=for apidoc sv_2iv_flags
645c22ef 2575
891f9566
YST
2576Return the integer value of an SV, doing any necessary string
2577conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2578Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
645c22ef
DM
2579
2580=cut
2581*/
28e5dec8 2582
a0d0e21e 2583IV
891f9566 2584Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
79072805
LW
2585{
2586 if (!sv)
2587 return 0;
8990e307 2588 if (SvGMAGICAL(sv)) {
891f9566
YST
2589 if (flags & SV_GMAGIC)
2590 mg_get(sv);
463ee0b2
LW
2591 if (SvIOKp(sv))
2592 return SvIVX(sv);
748a9306 2593 if (SvNOKp(sv)) {
25da4f38 2594 return I_V(SvNVX(sv));
748a9306 2595 }
36477c24
PP
2596 if (SvPOKp(sv) && SvLEN(sv))
2597 return asIV(sv);
3fe9a6f1 2598 if (!SvROK(sv)) {
d008e5eb 2599 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2600 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2601 report_uninit(sv);
c6ee37c5 2602 }
36477c24 2603 return 0;
3fe9a6f1 2604 }
463ee0b2 2605 }
ed6116ce 2606 if (SvTHINKFIRST(sv)) {
a0d0e21e 2607 if (SvROK(sv)) {
a0d0e21e 2608 SV* tmpstr;
1554e226 2609 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2610 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2611 return SvIV(tmpstr);
56431972 2612 return PTR2IV(SvRV(sv));
a0d0e21e 2613 }
765f542d
NC
2614 if (SvIsCOW(sv)) {
2615 sv_force_normal_flags(sv, 0);
47deb5e7 2616 }
0336b60e 2617 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2618 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2619 report_uninit(sv);
ed6116ce
LW
2620 return 0;
2621 }
79072805 2622 }
25da4f38
IZ
2623 if (SvIOKp(sv)) {
2624 if (SvIsUV(sv)) {
2625 return (IV)(SvUVX(sv));
2626 }
2627 else {
2628 return SvIVX(sv);
2629 }
463ee0b2 2630 }
748a9306 2631 if (SvNOKp(sv)) {
28e5dec8
JH
2632 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2633 * without also getting a cached IV/UV from it at the same time
2634 * (ie PV->NV conversion should detect loss of accuracy and cache
2635 * IV or UV at same time to avoid this. NWC */
25da4f38
IZ
2636
2637 if (SvTYPE(sv) == SVt_NV)
2638 sv_upgrade(sv, SVt_PVNV);
2639
28e5dec8
JH
2640 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2641 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2642 certainly cast into the IV range at IV_MAX, whereas the correct
2643 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2644 cases go to UV */
2645 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2646 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
2647 if (SvNVX(sv) == (NV) SvIVX(sv)
2648#ifndef NV_PRESERVES_UV
2649 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2650 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2651 /* Don't flag it as "accurately an integer" if the number
2652 came from a (by definition imprecise) NV operation, and
2653 we're outside the range of NV integer precision */
2654#endif
2655 ) {
2656 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2657 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2658 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2659 PTR2UV(sv),
2660 SvNVX(sv),
2661 SvIVX(sv)));
2662
2663 } else {
2664 /* IV not precise. No need to convert from PV, as NV
2665 conversion would already have cached IV if it detected
2666 that PV->IV would be better than PV->NV->IV
2667 flags already correct - don't set public IOK. */
2668 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2669 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2670 PTR2UV(sv),
2671 SvNVX(sv),
2672 SvIVX(sv)));
2673 }
2674 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2675 but the cast (NV)IV_MIN rounds to a the value less (more
2676 negative) than IV_MIN which happens to be equal to SvNVX ??
2677 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2678 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2679 (NV)UVX == NVX are both true, but the values differ. :-(
2680 Hopefully for 2s complement IV_MIN is something like
2681 0x8000000000000000 which will be exact. NWC */
d460ef45 2682 }
25da4f38 2683 else {
607fa7f2 2684 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2685 if (
2686 (SvNVX(sv) == (NV) SvUVX(sv))
2687#ifndef NV_PRESERVES_UV
2688 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2689 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2690 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2691 /* Don't flag it as "accurately an integer" if the number
2692 came from a (by definition imprecise) NV operation, and
2693 we're outside the range of NV integer precision */
2694#endif
2695 )
2696 SvIOK_on(sv);
25da4f38
IZ
2697 SvIsUV_on(sv);
2698 ret_iv_max:
1c846c1f 2699 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 2700 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 2701 PTR2UV(sv),
57def98f
JH
2702 SvUVX(sv),
2703 SvUVX(sv)));
25da4f38
IZ
2704 return (IV)SvUVX(sv);
2705 }
748a9306
LW
2706 }
2707 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2708 UV value;
f54cb97a 2709 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
25da4f38
IZ
2710 /* We want to avoid a possible problem when we cache an IV which
2711 may be later translated to an NV, and the resulting NV is not
c2988b20
NC
2712 the same as the direct translation of the initial string
2713 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2714 be careful to ensure that the value with the .456 is around if the
2715 NV value is requested in the future).
1c846c1f 2716
25da4f38
IZ
2717 This means that if we cache such an IV, we need to cache the
2718 NV as well. Moreover, we trade speed for space, and do not
28e5dec8 2719 cache the NV if we are sure it's not needed.
25da4f38 2720 */
16b7a9a4 2721
c2988b20
NC
2722 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2723 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2724 == IS_NUMBER_IN_UV) {
5e045b90 2725 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8
JH
2726 if (SvTYPE(sv) < SVt_PVIV)
2727 sv_upgrade(sv, SVt_PVIV);
f7bbb42a 2728 (void)SvIOK_on(sv);
c2988b20
NC
2729 } else if (SvTYPE(sv) < SVt_PVNV)
2730 sv_upgrade(sv, SVt_PVNV);
28e5dec8 2731
c2988b20
NC
2732 /* If NV preserves UV then we only use the UV value if we know that
2733 we aren't going to call atof() below. If NVs don't preserve UVs
2734 then the value returned may have more precision than atof() will
2735 return, even though value isn't perfectly accurate. */
2736 if ((numtype & (IS_NUMBER_IN_UV
2737#ifdef NV_PRESERVES_UV
2738 | IS_NUMBER_NOT_INT
2739#endif
2740 )) == IS_NUMBER_IN_UV) {
2741 /* This won't turn off the public IOK flag if it was set above */
2742 (void)SvIOKp_on(sv);
2743
2744 if (!(numtype & IS_NUMBER_NEG)) {
2745 /* positive */;
2746 if (value <= (UV)IV_MAX) {
45977657 2747 SvIV_set(sv, (IV)value);
c2988b20 2748 } else {
607fa7f2 2749 SvUV_set(sv, value);
c2988b20
NC
2750 SvIsUV_on(sv);
2751 }
2752 } else {
2753 /* 2s complement assumption */
2754 if (value <= (UV)IV_MIN) {
45977657 2755 SvIV_set(sv, -(IV)value);
c2988b20
NC
2756 } else {
2757 /* Too negative for an IV. This is a double upgrade, but
d1be9408 2758 I'm assuming it will be rare. */
c2988b20
NC
2759 if (SvTYPE(sv) < SVt_PVNV)
2760 sv_upgrade(sv, SVt_PVNV);
2761 SvNOK_on(sv);
2762 SvIOK_off(sv);
2763 SvIOKp_on(sv);
9d6ce603 2764 SvNV_set(sv, -(NV)value);
45977657 2765 SvIV_set(sv, IV_MIN);
c2988b20
NC
2766 }
2767 }
2768 }
2769 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2770 will be in the previous block to set the IV slot, and the next
2771 block to set the NV slot. So no else here. */
2772
2773 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2774 != IS_NUMBER_IN_UV) {
2775 /* It wasn't an (integer that doesn't overflow the UV). */
9d6ce603 2776 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8 2777
c2988b20
NC
2778 if (! numtype && ckWARN(WARN_NUMERIC))
2779 not_a_number(sv);
28e5dec8 2780
65202027 2781#if defined(USE_LONG_DOUBLE)
c2988b20
NC
2782 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2783 PTR2UV(sv), SvNVX(sv)));
65202027 2784#else
1779d84d 2785 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
c2988b20 2786 PTR2UV(sv), SvNVX(sv)));
65202027 2787#endif
28e5dec8
JH
2788
2789
2790#ifdef NV_PRESERVES_UV
c2988b20
NC
2791 (void)SvIOKp_on(sv);
2792 (void)SvNOK_on(sv);
2793 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2794 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2795 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2796 SvIOK_on(sv);
28e5dec8 2797 } else {
c2988b20
NC
2798 /* Integer is imprecise. NOK, IOKp */
2799 }
2800 /* UV will not work better than IV */
2801 } else {
2802 if (SvNVX(sv) > (NV)UV_MAX) {
2803 SvIsUV_on(sv);
2804 /* Integer is inaccurate. NOK, IOKp, is UV */
607fa7f2 2805 SvUV_set(sv, UV_MAX);
c2988b20
NC
2806 SvIsUV_on(sv);
2807 } else {
607fa7f2 2808 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2809 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2810 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2811 SvIOK_on(sv);
28e5dec8
JH
2812 SvIsUV_on(sv);
2813 } else {
c2988b20
NC
2814 /* Integer is imprecise. NOK, IOKp, is UV */
2815 SvIsUV_on(sv);
28e5dec8 2816 }
28e5dec8 2817 }
c2988b20
NC
2818 goto ret_iv_max;
2819 }
28e5dec8 2820#else /* NV_PRESERVES_UV */
c2988b20
NC
2821 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2822 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2823 /* The IV slot will have been set from value returned by
2824 grok_number above. The NV slot has just been set using
2825 Atof. */
560b0c46 2826 SvNOK_on(sv);
c2988b20
NC
2827 assert (SvIOKp(sv));
2828 } else {
2829 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2830 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2831 /* Small enough to preserve all bits. */
2832 (void)SvIOKp_on(sv);
2833 SvNOK_on(sv);
45977657 2834 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2835 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2836 SvIOK_on(sv);
2837 /* Assumption: first non-preserved integer is < IV_MAX,
2838 this NV is in the preserved range, therefore: */
2839 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2840 < (UV)IV_MAX)) {
32fdb065 2841 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
2842 }
2843 } else {
2844 /* IN_UV NOT_INT
2845 0 0 already failed to read UV.
2846 0 1 already failed to read UV.
2847 1 0 you won't get here in this case. IV/UV
2848 slot set, public IOK, Atof() unneeded.
2849 1 1 already read UV.
2850 so there's no point in sv_2iuv_non_preserve() attempting
2851 to use atol, strtol, strtoul etc. */
2852 if (sv_2iuv_non_preserve (sv, numtype)
2853 >= IS_NUMBER_OVERFLOW_IV)
2854 goto ret_iv_max;
2855 }
2856 }
28e5dec8 2857#endif /* NV_PRESERVES_UV */
25da4f38 2858 }
28e5dec8 2859 } else {
599cee73 2860 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 2861 report_uninit(sv);
25da4f38
IZ
2862 if (SvTYPE(sv) < SVt_IV)
2863 /* Typically the caller expects that sv_any is not NULL now. */
2864 sv_upgrade(sv, SVt_IV);
a0d0e21e 2865 return 0;
79072805 2866 }
1d7c1841
GS
2867 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2868 PTR2UV(sv),SvIVX(sv)));
25da4f38 2869 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW
2870}
2871
891f9566
YST
2872/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2873 * this function provided for binary compatibility only
2874 */
2875
2876UV
2877Perl_sv_2uv(pTHX_ register SV *sv)
2878{
2879 return sv_2uv_flags(sv, SV_GMAGIC);
2880}
2881
645c22ef 2882/*
891f9566 2883=for apidoc sv_2uv_flags
645c22ef
DM
2884
2885Return the unsigned integer value of an SV, doing any necessary string
891f9566
YST
2886conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2887Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
645c22ef
DM
2888
2889=cut
2890*/
2891
ff68c719 2892UV
891f9566 2893Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
ff68c719
PP
2894{
2895 if (!sv)
2896 return 0;
2897 if (SvGMAGICAL(sv)) {
891f9566
YST
2898 if (flags & SV_GMAGIC)
2899 mg_get(sv);
ff68c719
PP
2900 if (SvIOKp(sv))
2901 return SvUVX(sv);
2902 if (SvNOKp(sv))
2903 return U_V(SvNVX(sv));
36477c24
PP
2904 if (SvPOKp(sv) && SvLEN(sv))
2905 return asUV(sv);
3fe9a6f1 2906 if (!SvROK(sv)) {
d008e5eb 2907 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2908 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2909 report_uninit(sv);
c6ee37c5 2910 }
36477c24 2911 return 0;
3fe9a6f1 2912 }
ff68c719
PP
2913 }
2914 if (SvTHINKFIRST(sv)) {
2915 if (SvROK(sv)) {
ff68c719 2916 SV* tmpstr;
1554e226 2917 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2918 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2919 return SvUV(tmpstr);
56431972 2920 return PTR2UV(SvRV(sv));
ff68c719 2921 }
765f542d
NC
2922 if (SvIsCOW(sv)) {
2923 sv_force_normal_flags(sv, 0);
8a818333 2924 }
0336b60e 2925 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2926 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2927 report_uninit(sv);
ff68c719
PP
2928 return 0;
2929 }
2930 }
25da4f38
IZ
2931 if (SvIOKp(sv)) {
2932 if (SvIsUV(sv)) {
2933 return SvUVX(sv);
2934 }
2935 else {
2936 return (UV)SvIVX(sv);
2937 }
ff68c719
PP
2938 }
2939 if (SvNOKp(sv)) {
28e5dec8
JH
2940 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2941 * without also getting a cached IV/UV from it at the same time
2942 * (ie PV->NV conversion should detect loss of accuracy and cache
2943 * IV or UV at same time to avoid this. */
2944 /* IV-over-UV optimisation - choose to cache IV if possible */
2945
25da4f38
IZ
2946 if (SvTYPE(sv) == SVt_NV)
2947 sv_upgrade(sv, SVt_PVNV);
28e5dec8
JH
2948
2949 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2950 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2951 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
2952 if (SvNVX(sv) == (NV) SvIVX(sv)
2953#ifndef NV_PRESERVES_UV
2954 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2955 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2956 /* Don't flag it as "accurately an integer" if the number
2957 came from a (by definition imprecise) NV operation, and
2958 we're outside the range of NV integer precision */
2959#endif
2960 ) {
2961 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2962 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2963 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2964 PTR2UV(sv),
2965 SvNVX(sv),
2966 SvIVX(sv)));
2967
2968 } else {
2969 /* IV not precise. No need to convert from PV, as NV
2970 conversion would already have cached IV if it detected
2971 that PV->IV would be better than PV->NV->IV
2972 flags already correct - don't set public IOK. */
2973 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2974 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2975 PTR2UV(sv),
2976 SvNVX(sv),
2977 SvIVX(sv)));
2978 }
2979 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2980 but the cast (NV)IV_MIN rounds to a the value less (more
2981 negative) than IV_MIN which happens to be equal to SvNVX ??
2982 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2983 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2984 (NV)UVX == NVX are both true, but the values differ. :-(
2985 Hopefully for 2s complement IV_MIN is something like
2986 0x8000000000000000 which will be exact. NWC */
d460ef45 2987 }
28e5dec8 2988 else {
607fa7f2 2989 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2990 if (
2991 (SvNVX(sv) == (NV) SvUVX(sv))
2992#ifndef NV_PRESERVES_UV
2993 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2994 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2995 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2996 /* Don't flag it as "accurately an integer" if the number
2997 came from a (by definition imprecise) NV operation, and
2998 we're outside the range of NV integer precision */
2999#endif
3000 )
3001 SvIOK_on(sv);
3002 SvIsUV_on(sv);
1c846c1f 3003 DEBUG_c(PerlIO_printf(Perl_debug_log,
28e5dec8 3004 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
57def98f 3005 PTR2UV(sv),
28e5dec8
JH
3006 SvUVX(sv),
3007 SvUVX(sv)));
25da4f38 3008 }
ff68c719
PP
3009 }
3010 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 3011 UV value;
f54cb97a 3012 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
25da4f38
IZ
3013
3014 /* We want to avoid a possible problem when we cache a UV which
3015 may be later translated to an NV, and the resulting NV is not
3016 the translation of the initial data.
1c846c1f 3017
25da4f38
IZ
3018 This means that if we cache such a UV, we need to cache the
3019 NV as well. Moreover, we trade speed for space, and do not
3020 cache the NV if not needed.
3021 */
16b7a9a4 3022
c2988b20
NC
3023 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3024 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3025 == IS_NUMBER_IN_UV) {
5e045b90 3026 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8 3027 if (SvTYPE(sv) < SVt_PVIV)
f7bbb42a
JH
3028 sv_upgrade(sv, SVt_PVIV);
3029 (void)SvIOK_on(sv);
c2988b20
NC
3030 } else if (SvTYPE(sv) < SVt_PVNV)
3031 sv_upgrade(sv, SVt_PVNV);
d460ef45 3032
c2988b20
NC
3033 /* If NV preserves UV then we only use the UV value if we know that
3034 we aren't going to call atof() below. If NVs don't preserve UVs
3035 then the value returned may have more precision than atof() will
3036 return, even though it isn't accurate. */
3037 if ((numtype & (IS_NUMBER_IN_UV
3038#ifdef NV_PRESERVES_UV
3039 | IS_NUMBER_NOT_INT
3040#endif
3041 )) == IS_NUMBER_IN_UV) {
3042 /* This won't turn off the public IOK flag if it was set above */
3043 (void)SvIOKp_on(sv);
3044
3045 if (!(numtype & IS_NUMBER_NEG)) {
3046 /* positive */;
3047 if (value <= (UV)IV_MAX) {
45977657 3048 SvIV_set(sv, (IV)value);
28e5dec8
JH
3049 } else {
3050 /* it didn't overflow, and it was positive. */
607fa7f2 3051 SvUV_set(sv, value);
28e5dec8
JH
3052 SvIsUV_on(sv);
3053 }
c2988b20
NC
3054 } else {
3055 /* 2s complement assumption */
3056 if (value <= (UV)IV_MIN) {
45977657 3057 SvIV_set(sv, -(IV)value);
c2988b20
NC
3058 } else {
3059 /* Too negative for an IV. This is a double upgrade, but
d1be9408 3060 I'm assuming it will be rare. */
c2988b20
NC
3061 if (SvTYPE(sv) < SVt_PVNV)
3062 sv_upgrade(sv, SVt_PVNV);
3063 SvNOK_on(sv);
3064 SvIOK_off(sv);
3065 SvIOKp_on(sv);
9d6ce603 3066 SvNV_set(sv, -(NV)value);
45977657 3067 SvIV_set(sv, IV_MIN);
c2988b20
NC
3068 }
3069 }
3070 }
3071
3072 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3073 != IS_NUMBER_IN_UV) {
3074 /* It wasn't an integer, or it overflowed the UV. */
9d6ce603 3075 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8 3076
c2988b20 3077 if (! numtype && ckWARN(WARN_NUMERIC))
28e5dec8
JH
3078 not_a_number(sv);
3079
3080#if defined(USE_LONG_DOUBLE)
c2988b20
NC
3081 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3082 PTR2UV(sv), SvNVX(sv)));
28e5dec8 3083#else
1779d84d 3084 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
c2988b20 3085 PTR2UV(sv), SvNVX(sv)));
28e5dec8
JH
3086#endif
3087
3088#ifdef NV_PRESERVES_UV
c2988b20
NC
3089 (void)SvIOKp_on(sv);
3090 (void)SvNOK_on(sv);
3091 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 3092 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
3093 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3094 SvIOK_on(sv);
3095 } else {
3096 /* Integer is imprecise. NOK, IOKp */
3097 }
3098 /* UV will not work better than IV */
3099 } else {
3100 if (SvNVX(sv) > (NV)UV_MAX) {
3101 SvIsUV_on(sv);
3102 /* Integer is inaccurate. NOK, IOKp, is UV */
607fa7f2 3103 SvUV_set(sv, UV_MAX);
c2988b20
NC
3104 SvIsUV_on(sv);
3105 } else {
607fa7f2 3106 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
3107 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3108 NV preservse UV so can do correct comparison. */
3109 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3110 SvIOK_on(sv);
3111 SvIsUV_on(sv);
3112 } else {
3113 /* Integer is imprecise. NOK, IOKp, is UV */
3114 SvIsUV_on(sv);
3115 }
3116 }
3117 }
28e5dec8 3118#else /* NV_PRESERVES_UV */
c2988b20
NC
3119 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3120 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3121 /* The UV slot will have been set from value returned by
3122 grok_number above. The NV slot has just been set using
3123 Atof. */
560b0c46 3124 SvNOK_on(sv);
c2988b20
NC
3125 assert (SvIOKp(sv));
3126 } else {
3127 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3128 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3129 /* Small enough to preserve all bits. */
3130 (void)SvIOKp_on(sv);
3131 SvNOK_on(sv);
45977657 3132 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
3133 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3134 SvIOK_on(sv);
3135 /* Assumption: first non-preserved integer is < IV_MAX,
3136 this NV is in the preserved range, therefore: */
3137 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3138 < (UV)IV_MAX)) {
32fdb065 3139 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
3140 }
3141 } else
3142 sv_2iuv_non_preserve (sv, numtype);
3143 }
28e5dec8 3144#endif /* NV_PRESERVES_UV */
f7bbb42a 3145 }
ff68c719
PP
3146 }
3147 else {
d008e5eb 3148 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3149 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3150 report_uninit(sv);
c6ee37c5 3151 }
25da4f38
IZ
3152 if (SvTYPE(sv) < SVt_IV)
3153 /* Typically the caller expects that sv_any is not NULL now. */
3154 sv_upgrade(sv, SVt_IV);
ff68c719
PP
3155 return 0;
3156 }
25da4f38 3157
1d7c1841
GS
3158 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3159 PTR2UV(sv),SvUVX(sv)));
25da4f38 3160 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP
3161}
3162
645c22ef
DM
3163/*
3164=for apidoc sv_2nv
3165
3166Return the num value of an SV, doing any necessary string or integer
3167conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3168macros.
3169
3170=cut
3171*/
3172
65202027 3173NV
864dbfa3 3174Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW
3175{
3176 if (!sv)
3177 return 0.0;
8990e307 3178 if (SvGMAGICAL(sv)) {
463ee0b2
LW
3179 mg_get(sv);
3180 if (SvNOKp(sv))
3181 return SvNVX(sv);
a0d0e21e 3182 if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20
NC
3183 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3184 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
a0d0e21e 3185 not_a_number(sv);
097ee67d 3186 return Atof(SvPVX(sv));
a0d0e21e 3187 }
25da4f38 3188 if (SvIOKp(sv)) {
1c846c1f 3189 if (SvIsUV(sv))
65202027 3190 return (NV)SvUVX(sv);
25da4f38 3191 else
65202027 3192 return (NV)SvIVX(sv);
25da4f38 3193 }
16d20bd9 3194 if (!SvROK(sv)) {
d008e5eb 3195 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3196 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3197 report_uninit(sv);
c6ee37c5 3198 }
16d20bd9
AD
3199 return 0;
3200 }
463ee0b2 3201 }
ed6116ce 3202 if (SvTHINKFIRST(sv)) {
a0d0e21e 3203 if (SvROK(sv)) {
a0d0e21e 3204 SV* tmpstr;
1554e226 3205 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 3206 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 3207 return SvNV(tmpstr);
56431972 3208 return PTR2NV(SvRV(sv));
a0d0e21e 3209 }
765f542d
NC
3210 if (SvIsCOW(sv)) {
3211 sv_force_normal_flags(sv, 0);
8a818333 3212 }
0336b60e 3213 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 3214 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 3215 report_uninit(sv);
ed6116ce
LW
3216 return 0.0;
3217 }
79072805
LW
3218 }
3219 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW
3220 if (SvTYPE(sv) == SVt_IV)
3221 sv_upgrade(sv, SVt_PVNV);
3222 else
3223 sv_upgrade(sv, SVt_NV);
906f284f 3224#ifdef USE_LONG_DOUBLE
097ee67d 3225 DEBUG_c({
f93f4e46 3226 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
3227 PerlIO_printf(Perl_debug_log,
3228 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3229 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
3230 RESTORE_NUMERIC_LOCAL();
3231 });
65202027 3232#else
572bbb43 3233 DEBUG_c({
f93f4e46 3234 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 3235 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
1d7c1841 3236 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
3237 RESTORE_NUMERIC_LOCAL();
3238 });
572bbb43 3239#endif
79072805
LW
3240 }
3241 else if (SvTYPE(sv) < SVt_PVNV)
3242 sv_upgrade(sv, SVt_PVNV);
59d8ce62
NC
3243 if (SvNOKp(sv)) {
3244 return SvNVX(sv);
61604483 3245 }
59d8ce62 3246 if (SvIOKp(sv)) {
9d6ce603 3247 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
28e5dec8
JH
3248#ifdef NV_PRESERVES_UV
3249 SvNOK_on(sv);
3250#else
3251 /* Only set the public NV OK flag if this NV preserves the IV */
3252 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3253 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3254 : (SvIVX(sv) == I_V(SvNVX(sv))))
3255 SvNOK_on(sv);
3256 else
3257 SvNOKp_on(sv);
3258#endif
93a17b20 3259 }
748a9306 3260 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 3261 UV value;
f54cb97a 3262 const int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
c2988b20 3263 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
a0d0e21e 3264 not_a_number(sv);
28e5dec8 3265#ifdef NV_PRESERVES_UV
c2988b20
NC
3266 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3267 == IS_NUMBER_IN_UV) {
5e045b90 3268 /* It's definitely an integer */
9d6ce603 3269 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
c2988b20 3270 } else
9d6ce603 3271 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8
JH
3272 SvNOK_on(sv);
3273#else
9d6ce603 3274 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8
JH
3275 /* Only set the public NV OK flag if this NV preserves the value in
3276 the PV at least as well as an IV/UV would.
3277 Not sure how to do this 100% reliably. */
3278 /* if that shift count is out of range then Configure's test is
3279 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3280 UV_BITS */
3281 if (((UV)1 << NV_PRESERVES_UV_BITS) >
c2988b20 3282 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
28e5dec8 3283 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
c2988b20
NC
3284 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3285 /* Can't use strtol etc to convert this string, so don't try.
3286 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3287 SvNOK_on(sv);
3288 } else {
3289 /* value has been set. It may not be precise. */
3290 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3291 /* 2s complement assumption for (UV)IV_MIN */
3292 SvNOK_on(sv); /* Integer is too negative. */
3293 } else {
3294 SvNOKp_on(sv);
3295 SvIOKp_on(sv);
6fa402ec 3296
c2988b20 3297 if (numtype & IS_NUMBER_NEG) {
45977657 3298 SvIV_set(sv, -(IV)value);
c2988b20 3299 } else if (value <= (UV)IV_MAX) {
45977657 3300 SvIV_set(sv, (IV)value);
c2988b20 3301 } else {
607fa7f2 3302 SvUV_set(sv, value);
c2988b20
NC
3303 SvIsUV_on(sv);
3304 }
3305
3306 if (numtype & IS_NUMBER_NOT_INT) {
3307 /* I believe that even if the original PV had decimals,
3308 they are lost beyond the limit of the FP precision.
3309 However, neither is canonical, so both only get p
3310 flags. NWC, 2000/11/25 */
3311 /* Both already have p flags, so do nothing */
3312 } else {
3313 NV nv = SvNVX(sv);
3314 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3315 if (SvIVX(sv) == I_V(nv)) {
3316 SvNOK_on(sv);
3317 SvIOK_on(sv);
3318 } else {
3319 SvIOK_on(sv);
3320 /* It had no "." so it must be integer. */
3321 }
3322 } else {
3323 /* between IV_MAX and NV(UV_MAX).
3324 Could be slightly > UV_MAX */
6fa402ec 3325
c2988b20
NC
3326 if (numtype & IS_NUMBER_NOT_INT) {
3327 /* UV and NV both imprecise. */
3328 } else {
3329 UV nv_as_uv = U_V(nv);
3330
3331 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3332 SvNOK_on(sv);
3333 SvIOK_on(sv);
3334 } else {
3335 SvIOK_on(sv);
3336 }
3337 }
3338 }
3339 }
3340 }
3341 }
28e5dec8 3342#endif /* NV_PRESERVES_UV */
93a17b20 3343 }
79072805 3344 else {
599cee73 3345 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 3346 report_uninit(sv);
25da4f38
IZ
3347 if (SvTYPE(sv) < SVt_NV)
3348 /* Typically the caller expects that sv_any is not NULL now. */
28e5dec8
JH
3349 /* XXX Ilya implies that this is a bug in callers that assume this
3350 and ideally should be fixed. */
25da4f38 3351 sv_upgrade(sv, SVt_NV);
a0d0e21e 3352 return 0.0;
79072805 3353 }
572bbb43 3354#if defined(USE_LONG_DOUBLE)
097ee67d 3355 DEBUG_c({
f93f4e46 3356 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
3357 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3358 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
3359 RESTORE_NUMERIC_LOCAL();
3360 });
65202027 3361#else
572bbb43 3362 DEBUG_c({
f93f4e46 3363 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 3364 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
1d7c1841 3365 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
3366 RESTORE_NUMERIC_LOCAL();
3367 });
572bbb43 3368#endif
463ee0b2 3369 return SvNVX(sv);
79072805
LW
3370}
3371
645c22ef
DM
3372/* asIV(): extract an integer from the string value of an SV.
3373 * Caller must validate PVX */
3374
76e3520e 3375STATIC IV
cea2e8a9 3376S_asIV(pTHX_ SV *sv)
36477c24 3377{
c2988b20
NC
3378 UV value;
3379 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3380
3381 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3382 == IS_NUMBER_IN_UV) {
645c22ef 3383 /* It's definitely an integer */
c2988b20
NC
3384 if (numtype & IS_NUMBER_NEG) {
3385 if (value < (UV)IV_MIN)
3386 return -(IV)value;
3387 } else {
3388 if (value < (UV)IV_MAX)
3389 return (IV)value;
3390 }
3391 }
d008e5eb 3392 if (!numtype) {
d008e5eb
GS
3393 if (ckWARN(WARN_NUMERIC))
3394 not_a_number(sv);
3395 }
c2988b20 3396 return I_V(Atof(SvPVX(sv)));
36477c24
PP
3397}
3398
645c22ef
DM
3399/* asUV(): extract an unsigned integer from the string value of an SV
3400 * Caller must validate PVX */
3401
76e3520e 3402STATIC UV
cea2e8a9 3403S_asUV(pTHX_ SV *sv)
36477c24 3404{
c2988b20
NC
3405 UV value;
3406 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
36477c24 3407
c2988b20
NC
3408 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3409 == IS_NUMBER_IN_UV) {
645c22ef 3410 /* It's definitely an integer */
6fa402ec 3411 if (!(numtype & IS_NUMBER_NEG))
c2988b20
NC
3412 return value;
3413 }
d008e5eb 3414 if (!numtype) {
d008e5eb
GS
3415 if (ckWARN(WARN_NUMERIC))
3416 not_a_number(sv);
3417 }
097ee67d 3418 return U_V(Atof(SvPVX(sv)));
36477c24
PP
3419}
3420
645c22ef
DM
3421/*
3422=for apidoc sv_2pv_nolen
3423
3424Like C<sv_2pv()>, but doesn't return the length too. You should usually
3425use the macro wrapper C<SvPV_nolen(sv)> instead.
3426=cut
3427*/
3428
79072805 3429char *
864dbfa3 3430Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD
3431{
3432 STRLEN n_a;
3433 return sv_2pv(sv, &n_a);
3434}
3435
645c22ef
DM
3436/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3437 * UV as a string towards the end of buf, and return pointers to start and
3438 * end of it.
3439 *
3440 * We assume that buf is at least TYPE_CHARS(UV) long.
3441 */
3442
864dbfa3 3443static char *
25da4f38
IZ
3444uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3445{
25da4f38
IZ
3446 char *ptr = buf + TYPE_CHARS(UV);
3447 char *ebuf = ptr;
3448 int sign;
25da4f38
IZ
3449
3450 if (is_uv)
3451 sign = 0;
3452 else if (iv >= 0) {
3453 uv = iv;
3454 sign = 0;
3455 } else {
3456 uv = -iv;
3457 sign = 1;
3458 }
3459 do {
eb160463 3460 *--ptr = '0' + (char)(uv % 10);
25da4f38
IZ
3461 } while (uv /= 10);
3462 if (sign)
3463 *--ptr = '-';
3464 *peob = ebuf;
3465 return ptr;
3466}
3467
09540bc3
JH
3468/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3469 * this function provided for binary compatibility only
3470 */
3471
3472char *
3473Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3474{
3475 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3476}
3477
645c22ef
DM
3478/*
3479=for apidoc sv_2pv_flags
3480
ff276b08 3481Returns a pointer to the string value of an SV, and sets *lp to its length.
645c22ef
DM
3482If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3483if necessary.
3484Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3485usually end up here too.
3486
3487=cut
3488*/
3489
8d6d96c1
HS
3490char *
3491Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3492{
79072805
LW
3493 register char *s;
3494 int olderrno;
cb50f42d 3495 SV *tsv, *origsv;
25da4f38
IZ
3496 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3497 char *tmpbuf = tbuf;
79072805 3498
463ee0b2
LW
3499 if (!sv) {
3500 *lp = 0;
73d840c0 3501 return (char *)"";
463ee0b2 3502 }
8990e307 3503 if (SvGMAGICAL(sv)) {
8d6d96c1
HS
3504 if (flags & SV_GMAGIC)
3505 mg_get(sv);
463ee0b2
LW
3506 if (SvPOKp(sv)) {
3507 *lp = SvCUR(sv);
3508 return SvPVX(sv);
3509 }
cf2093f6 3510 if (SvIOKp(sv)) {
1c846c1f 3511 if (SvIsUV(sv))
57def98f 3512 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 3513 else
57def98f 3514 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 3515 tsv = Nullsv;
a0d0e21e 3516 goto tokensave;
463ee0b2
LW
3517 }
3518 if (SvNOKp(sv)) {
2d4389e4 3519 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 3520 tsv = Nullsv;
a0d0e21e 3521 goto tokensave;
463ee0b2 3522 }
16d20bd9 3523 if (!SvROK(sv)) {
d008e5eb 3524 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3525 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3526 report_uninit(sv);
c6ee37c5 3527 }
16d20bd9 3528 *lp = 0;
73d840c0 3529 return (char *)"";
16d20bd9 3530 }
463ee0b2 3531 }
ed6116ce
LW
3532 if (SvTHINKFIRST(sv)) {
3533 if (SvROK(sv)) {
a0d0e21e 3534 SV* tmpstr;
e1ec3a88 3535 register const char *typestr;
1554e226 3536 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
b4b9a328 3537 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
446eaa42
YST
3538 char *pv = SvPV(tmpstr, *lp);
3539 if (SvUTF8(tmpstr))
3540 SvUTF8_on(sv);
3541 else
3542 SvUTF8_off(sv);
3543 return pv;
3544 }
cb50f42d 3545 origsv = sv;
ed6116ce
LW
3546 sv = (SV*)SvRV(sv);
3547 if (!sv)
e1ec3a88 3548 typestr = "NULLREF";
ed6116ce 3549 else {
f9277f47
IZ
3550 MAGIC *mg;
3551
ed6116ce 3552 switch (SvTYPE(sv)) {
f9277f47
IZ
3553 case SVt_PVMG:
3554 if ( ((SvFLAGS(sv) &
1c846c1f 3555 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
faf82a0b 3556 == (SVs_OBJECT|SVs_SMG))
14befaf4 3557 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
e1ec3a88 3558 const regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 3559
2cd61cdb 3560 if (!mg->mg_ptr) {
e1ec3a88 3561 const char *fptr = "msix";
8782bef2
GB
3562 char reflags[6];
3563 char ch;
3564 int left = 0;
3565 int right = 4;
ff385a1b 3566 char need_newline = 0;
eb160463 3567 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
8782bef2 3568
155aba94 3569 while((ch = *fptr++)) {
8782bef2
GB
3570 if(reganch & 1) {
3571 reflags[left++] = ch;
3572 }
3573 else {
3574 reflags[right--] = ch;
3575 }
3576 reganch >>= 1;
3577 }
3578 if(left != 4) {
3579 reflags[left] = '-';
3580 left = 5;
3581 }
3582
3583 mg->mg_len = re->prelen + 4 + left;
ff385a1b
JF
3584 /*
3585 * If /x was used, we have to worry about a regex
3586 * ending with a comment later being embedded
3587 * within another regex. If so, we don't want this
3588 * regex's "commentization" to leak out to the
3589 * right part of the enclosing regex, we must cap
3590 * it with a newline.
3591 *
3592 * So, if /x was used, we scan backwards from the
3593 * end of the regex. If we find a '#' before we
3594 * find a newline, we need to add a newline
3595 * ourself. If we find a '\n' first (or if we
3596 * don't find '#' or '\n'), we don't need to add
3597 * anything. -jfriedl
3598 */
3599 if (PMf_EXTENDED & re->reganch)
3600 {
e1ec3a88 3601 const char *endptr = re->precomp + re->prelen;
ff385a1b
JF
3602 while (endptr >= re->precomp)
3603 {
e1ec3a88 3604 const char c = *(endptr--);
ff385a1b
JF
3605 if (c == '\n')
3606 break; /* don't need another */
3607 if (c == '#') {
3608 /* we end while in a comment, so we
3609 need a newline */
3610 mg->mg_len++; /* save space for it */
3611 need_newline = 1; /* note to add it */
ab01544f 3612 break;
ff385a1b
JF
3613 }
3614 }
3615 }
3616
8782bef2
GB
3617 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3618 Copy("(?", mg->mg_ptr, 2, char);
3619 Copy(reflags, mg->mg_ptr+2, left, char);
3620 Copy(":", mg->mg_ptr+left+2, 1, char);
3621 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
ff385a1b
JF
3622 if (need_newline)
3623 mg->mg_ptr[mg->mg_len - 2] = '\n';
1bd3ad17
IZ
3624 mg->mg_ptr[mg->mg_len - 1] = ')';
3625 mg->mg_ptr[mg->mg_len] = 0;
3626 }
3280af22 3627 PL_reginterp_cnt += re->program[0].next_off;
cb50f42d
YST
3628
3629 if (re->reganch & ROPT_UTF8)
3630 SvUTF8_on(origsv);
3631 else
3632 SvUTF8_off(origsv);
1bd3ad17
IZ
3633 *lp = mg->mg_len;
3634 return mg->mg_ptr;
f9277f47
IZ
3635 }
3636 /* Fall through */
ed6116ce
LW
3637 case SVt_NULL:
3638 case SVt_IV:
3639 case SVt_NV:
3640 case SVt_RV:
3641 case SVt_PV:
3642 case SVt_PVIV:
3643 case SVt_PVNV:
e1ec3a88
AL
3644 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3645 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
be65207d
DM
3646 /* tied lvalues should appear to be
3647 * scalars for backwards compatitbility */
3648 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3649 ? "SCALAR" : "LVALUE"; break;
e1ec3a88
AL
3650 case SVt_PVAV: typestr = "ARRAY"; break;
3651 case SVt_PVHV: typestr = "HASH"; break;
3652 case SVt_PVCV: typestr = "CODE"; break;
3653 case SVt_PVGV: typestr = "GLOB"; break;
3654 case SVt_PVFM: typestr = "FORMAT"; break;
3655 case SVt_PVIO: typestr = "IO"; break;
3656 default: typestr = "UNKNOWN"; break;
ed6116ce 3657 }
46fc3d4c 3658 tsv = NEWSV(0,0);
a5cb6b62 3659 if (SvOBJECT(sv)) {
bfcb3514 3660 const char *name = HvNAME_get(SvSTASH(sv));
a5cb6b62 3661 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
e1ec3a88 3662 name ? name : "__ANON__" , typestr, PTR2UV(sv));
a5cb6b62 3663 }
ed6116ce 3664 else
e1ec3a88 3665 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
a0d0e21e 3666 goto tokensaveref;
463ee0b2 3667 }
e1ec3a88 3668 *lp = strlen(typestr);
73d840c0 3669 return (char *)typestr;
79072805 3670 }
0336b60e 3671 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 3672 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 3673 report_uninit(sv);
ed6116ce 3674 *lp = 0;
73d840c0 3675 return (char *)"";
79072805 3676 }
79072805 3677 }
28e5dec8
JH
3678 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3679 /* I'm assuming that if both IV and NV are equally valid then
3680 converting the IV is going to be more efficient */
e1ec3a88
AL
3681 const U32 isIOK = SvIOK(sv);
3682 const U32 isUIOK = SvIsUV(sv);
28e5dec8
JH
3683 char buf[TYPE_CHARS(UV)];
3684 char *ebuf, *ptr;
3685
3686 if (SvTYPE(sv) < SVt_PVIV)
3687 sv_upgrade(sv, SVt_PVIV);
3688 if (isUIOK)
3689 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3690 else
3691 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
eb160463 3692 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
28e5dec8
JH
3693 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3694 SvCUR_set(sv, ebuf - ptr);
3695 s = SvEND(sv);
3696 *s = '\0';
3697 if (isIOK)
3698 SvIOK_on(sv);
3699 else
3700 SvIOKp_on(sv);
3701 if (isUIOK)
3702 SvIsUV_on(sv);
3703 }
3704 else if (SvNOKp(sv)) {
79072805
LW
3705 if (SvTYPE(sv) < SVt_PVNV)
3706 sv_upgrade(sv, SVt_PVNV);
1c846c1f 3707 /* The +20 is pure guesswork. Configure test needed. --jhi */
59155cc0 3708 SvGROW(sv, NV_DIG + 20);
463ee0b2 3709 s = SvPVX(sv);
79072805 3710 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 3711#ifdef apollo
463ee0b2 3712 if (SvNVX(sv) == 0.0)
79072805
LW
3713 (void)strcpy(s,"0");
3714 else
3715#endif /*apollo*/
bbce6d69 3716 {
2d4389e4 3717 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 3718 }
79072805 3719 errno = olderrno;
a0d0e21e
LW
3720#ifdef FIXNEGATIVEZERO
3721 if (*s == '-' && s[1] == '0' && !s[2])
3722 strcpy(s,"0");
3723#endif
79072805
LW
3724 while (*s) s++;
3725#ifdef hcx
3726 if (s[-1] == '.')
46fc3d4c 3727 *--s = '\0';
79072805
LW
3728#endif
3729 }
79072805 3730 else {
0336b60e
IZ
3731 if (ckWARN(WARN_UNINITIALIZED)
3732 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 3733 report_uninit(sv);
a0d0e21e 3734 *lp = 0;
25da4f38
IZ
3735 if (SvTYPE(sv) < SVt_PV)
3736 /* Typically the caller expects that sv_any is not NULL now. */
3737 sv_upgrade(sv, SVt_PV);
73d840c0 3738 return (char *)"";
79072805 3739 }
463ee0b2
LW
3740 *lp = s - SvPVX(sv);
3741 SvCUR_set(sv, *lp);
79072805 3742 SvPOK_on(sv);
1d7c1841
GS
3743 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3744 PTR2UV(sv),SvPVX(sv)));
463ee0b2 3745 return SvPVX(sv);
a0d0e21e
LW
3746
3747 tokensave:
3748 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3749 /* Sneaky stuff here */
3750
3751 tokensaveref:
46fc3d4c 3752 if (!tsv)
96827780 3753 tsv = newSVpv(tmpbuf, 0);
46fc3d4c
PP
3754 sv_2mortal(tsv);
3755 *lp = SvCUR(tsv);
3756 return SvPVX(tsv);
a0d0e21e
LW
3757 }
3758 else {
27da23d5 3759 dVAR;
a0d0e21e 3760 STRLEN len;
73d840c0 3761 const char *t;
46fc3d4c
PP
3762
3763 if (tsv) {
3764 sv_2mortal(tsv);
3765 t = SvPVX(tsv);
3766 len = SvCUR(tsv);
3767 }
3768 else {
96827780
MB
3769 t = tmpbuf;
3770 len = strlen(tmpbuf);
46fc3d4c 3771 }
a0d0e21e 3772#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
3773 if (len == 2 && t[0] == '-' && t[1] == '0') {
3774 t = "0";
3775 len = 1;
3776 }
a0d0e21e
LW
3777#endif
3778 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 3779 *lp = len;
a0d0e21e
LW
3780 s = SvGROW(sv, len + 1);
3781 SvCUR_set(sv, len);
6bf554b4 3782 SvPOKp_on(sv);
e90e2364 3783 return strcpy(s, t);
a0d0e21e 3784 }
463ee0b2
LW
3785}
3786
645c22ef 3787/*
6050d10e
JP
3788=for apidoc sv_copypv
3789
3790Copies a stringified representation of the source SV into the
3791destination SV. Automatically performs any necessary mg_get and
54f0641b 3792coercion of numeric values into strings. Guaranteed to preserve
6050d10e 3793UTF-8 flag even from overloaded objects. Similar in nature to
54f0641b
NIS
3794sv_2pv[_flags] but operates directly on an SV instead of just the
3795string. Mostly uses sv_2pv_flags to do its work, except when that
6050d10e
JP
3796would lose the UTF-8'ness of the PV.
3797
3798=cut
3799*/
3800
3801void
3802Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3803{
446eaa42
YST
3804 STRLEN len;
3805 char *s;
3806 s = SvPV(ssv,len);
cb50f42d 3807 sv_setpvn(dsv,s,len);
446eaa42 3808 if (SvUTF8(ssv))
cb50f42d 3809 SvUTF8_on(dsv);
446eaa42 3810 else
cb50f42d 3811 SvUTF8_off(dsv);
6050d10e
JP
3812}
3813
3814/*
645c22ef
DM
3815=for apidoc sv_2pvbyte_nolen
3816
3817Return a pointer to the byte-encoded representation of the SV.
1e54db1a 3818May cause the SV to be downgraded from UTF-8 as a side-effect.
645c22ef
DM
3819
3820Usually accessed via the C<SvPVbyte_nolen> macro.
3821
3822=cut
3823*/
3824
7340a771
GS
3825char *
3826Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3827{
560a288e
GS
3828 STRLEN n_a;
3829 return sv_2pvbyte(sv, &n_a);
7340a771
GS
3830}
3831
645c22ef
DM
3832/*
3833=for apidoc sv_2pvbyte
3834
3835Return a pointer to the byte-encoded representation of the SV, and set *lp
1e54db1a 3836to its length. May cause the SV to be downgraded from UTF-8 as a
645c22ef
DM
3837side-effect.
3838
3839Usually accessed via the C<SvPVbyte> macro.
3840
3841=cut
3842*/
3843
7340a771
GS
3844char *
3845Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3846{
0875d2fe
NIS
3847 sv_utf8_downgrade(sv,0);
3848 return SvPV(sv,*lp);
7340a771
GS
3849}
3850
645c22ef
DM
3851/*
3852=for apidoc sv_2pvutf8_nolen
3853
1e54db1a
JH
3854Return a pointer to the UTF-8-encoded representation of the SV.
3855May cause the SV to be upgraded to UTF-8 as a side-effect.
645c22ef
DM
3856
3857Usually accessed via the C<SvPVutf8_nolen> macro.
3858
3859=cut
3860*/
3861
7340a771
GS
3862char *
3863Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3864{
560a288e
GS
3865 STRLEN n_a;
3866 return sv_2pvutf8(sv, &n_a);
7340a771
GS
3867}
3868
645c22ef
DM
3869/*
3870=for apidoc sv_2pvutf8
3871
1e54db1a
JH
3872Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3873to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
645c22ef
DM
3874
3875Usually accessed via the C<SvPVutf8> macro.
3876
3877=cut
3878*/
3879
7340a771
GS
3880char *
3881Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3882{
560a288e 3883 sv_utf8_upgrade(sv);
7d59b7e4 3884 return SvPV(sv,*lp);
7340a771 3885}
1c846c1f 3886
645c22ef
DM
3887/*
3888=for apidoc sv_2bool
3889
3890This function is only called on magical items, and is only used by
8cf8f3d1 3891sv_true() or its macro equivalent.
645c22ef
DM
3892
3893=cut
3894*/
3895
463ee0b2 3896bool
864dbfa3 3897Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 3898{
8990e307 3899 if (SvGMAGICAL(sv))
463ee0b2
LW
3900 mg_get(sv);
3901
a0d0e21e
LW
3902 if (!SvOK(sv))
3903 return 0;
3904 if (SvROK(sv)) {
a0d0e21e 3905