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