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