This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix compiling with -DPURIFY
[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
de042e1d 1128STATIC void *
e3bbdc67 1129S_more_bodies (pTHX_ void **arena_root, void **root, size_t size)
cac9b346 1130{
e3bbdc67
NC
1131 char *start;
1132 const char *end;
1133 size_t count = PERL_ARENA_SIZE/size;
1134 New(0, start, count*size, char);
1135 *((void **) start) = *arena_root;
1136 *arena_root = (void *)start;
cac9b346 1137
e3bbdc67 1138 end = start + (count-1) * size;
cac9b346 1139
e3bbdc67
NC
1140 /* The initial slot is used to link the arenas together, so it isn't to be
1141 linked into the list of ready-to-use bodies. */
cac9b346 1142
e3bbdc67 1143 start += size;
cac9b346 1144
e3bbdc67 1145 *root = (void *)start;
cac9b346 1146
e3bbdc67
NC
1147 while (start < end) {
1148 char *next = start + size;
1149 *(void**) start = (void *)next;
1150 start = next;
cac9b346 1151 }
e3bbdc67 1152 *(void **)start = 0;
de042e1d
NC
1153
1154 return *root;
cac9b346
NC
1155}
1156
aeb18a1e 1157/* grab a new thing from the free list, allocating more if necessary */
645c22ef 1158
aeb18a1e
NC
1159STATIC void *
1160S_new_body(pTHX_ void **arena_root, void **root, size_t size, size_t offset)
932e9ff9 1161{
aeb18a1e 1162 void *xpv;
932e9ff9 1163 LOCK_SV_MUTEX;
aeb18a1e
NC
1164 xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size);
1165 *root = *(void**)xpv;
932e9ff9 1166 UNLOCK_SV_MUTEX;
aeb18a1e 1167 return (void*)((char*)xpv - offset);
932e9ff9
VB
1168}
1169
aeb18a1e 1170/* return a thing to the free list */
645c22ef 1171
932e9ff9 1172STATIC void
aeb18a1e 1173S_del_body(pTHX_ void *thing, void **root, size_t offset)
932e9ff9 1174{
aeb18a1e 1175 void **real_thing = (void**)((char *)thing + offset);
932e9ff9 1176 LOCK_SV_MUTEX;
aeb18a1e
NC
1177 *real_thing = *root;
1178 *root = (void*)real_thing;
932e9ff9
VB
1179 UNLOCK_SV_MUTEX;
1180}
1181
aeb18a1e
NC
1182/* Conventionally we simply malloc() a big block of memory, then divide it
1183 up into lots of the thing that we're allocating.
645c22ef 1184
aeb18a1e
NC
1185 This macro will expand to call to S_new_body. So for XPVBM (with ithreads),
1186 it would become
932e9ff9 1187
aeb18a1e
NC
1188 S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot),
1189 (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0)
1190*/
645c22ef 1191
aeb18a1e
NC
1192#define new_body(TYPE,lctype) \
1193 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1194 (void**)&PL_ ## lctype ## _root, \
1195 sizeof(TYPE), \
1196 0)
1197
1198/* But for some types, we cheat. The type starts with some members that are
1199 never accessed. So we allocate the substructure, starting at the first used
1200 member, then adjust the pointer back in memory by the size of the bit not
1201 allocated, so it's as if we allocated the full structure.
1202 (But things will all go boom if you write to the part that is "not there",
1203 because you'll be overwriting the last members of the preceding structure
1204 in memory.)
1205
1206 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1207 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1208 and the pointer is unchanged. If the allocated structure is smaller (no
1209 initial NV actually allocated) then the net effect is to subtract the size
1210 of the NV from the pointer, to return a new pointer as if an initial NV were
1211 actually allocated.
1212
1213 This is the same trick as was used for NV and IV bodies. Ironically it
1214 doesn't need to be used for NV bodies any more, because NV is now at the
1215 start of the structure. IV bodies don't need it either, because they are
1216 no longer allocated. */
1217
1218#define new_body_allocated(TYPE,lctype,member) \
1219 S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \
1220 (void**)&PL_ ## lctype ## _root, \
1221 sizeof(lctype ## _allocated), \
1222 STRUCT_OFFSET(TYPE, member) \
1223 - STRUCT_OFFSET(lctype ## _allocated, member))
1224
1225
1226#define del_body(p,TYPE,lctype) \
1227 S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, 0)
1228
1229#define del_body_allocated(p,TYPE,lctype,member) \
1230 S_del_body(aTHX_ (void*)p, (void**)&PL_ ## lctype ## _root, \
1231 STRUCT_OFFSET(TYPE, member) \
1232 - STRUCT_OFFSET(lctype ## _allocated, member))
932e9ff9 1233
7bab3ede
MB
1234#define my_safemalloc(s) (void*)safemalloc(s)
1235#define my_safefree(p) safefree((char*)p)
463ee0b2 1236
d33b2eba 1237#ifdef PURIFY
463ee0b2 1238
d33b2eba
GS
1239#define new_XNV() my_safemalloc(sizeof(XPVNV))
1240#define del_XNV(p) my_safefree(p)
463ee0b2 1241
d33b2eba
GS
1242#define new_XPV() my_safemalloc(sizeof(XPV))
1243#define del_XPV(p) my_safefree(p)
9b94d1dd 1244
d33b2eba
GS
1245#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1246#define del_XPVIV(p) my_safefree(p)
932e9ff9 1247
d33b2eba
GS
1248#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1249#define del_XPVNV(p) my_safefree(p)
932e9ff9 1250
d33b2eba
GS
1251#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1252#define del_XPVCV(p) my_safefree(p)
932e9ff9 1253
d33b2eba
GS
1254#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1255#define del_XPVAV(p) my_safefree(p)
1256
1257#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1258#define del_XPVHV(p) my_safefree(p)
1c846c1f 1259
d33b2eba
GS
1260#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1261#define del_XPVMG(p) my_safefree(p)
1262
727879eb
NC
1263#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1264#define del_XPVGV(p) my_safefree(p)
1265
d33b2eba
GS
1266#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1267#define del_XPVLV(p) my_safefree(p)
1268
1269#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1270#define del_XPVBM(p) my_safefree(p)
1271
1272#else /* !PURIFY */
1273
aeb18a1e
NC
1274#define new_XNV() new_body(NV, xnv)
1275#define del_XNV(p) del_body(p, NV, xnv)
9b94d1dd 1276
aeb18a1e
NC
1277#define new_XPV() new_body_allocated(XPV, xpv, xpv_cur)
1278#define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur)
d33b2eba 1279
aeb18a1e
NC
1280#define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur)
1281#define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur)
d33b2eba 1282
aeb18a1e
NC
1283#define new_XPVNV() new_body(XPVNV, xpvnv)
1284#define del_XPVNV(p) del_body(p, XPVNV, xpvnv)
d33b2eba 1285
aeb18a1e
NC
1286#define new_XPVCV() new_body(XPVCV, xpvcv)
1287#define del_XPVCV(p) del_body(p, XPVCV, xpvcv)
d33b2eba 1288
aeb18a1e
NC
1289#define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill)
1290#define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill)
d33b2eba 1291
aeb18a1e
NC
1292#define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill)
1293#define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill)
1c846c1f 1294
aeb18a1e
NC
1295#define new_XPVMG() new_body(XPVMG, xpvmg)
1296#define del_XPVMG(p) del_body(p, XPVMG, xpvmg)
d33b2eba 1297
aeb18a1e
NC
1298#define new_XPVGV() new_body(XPVGV, xpvgv)
1299#define del_XPVGV(p) del_body(p, XPVGV, xpvgv)
727879eb 1300
aeb18a1e
NC
1301#define new_XPVLV() new_body(XPVLV, xpvlv)
1302#define del_XPVLV(p) del_body(p, XPVLV, xpvlv)
d33b2eba 1303
aeb18a1e
NC
1304#define new_XPVBM() new_body(XPVBM, xpvbm)
1305#define del_XPVBM(p) del_body(p, XPVBM, xpvbm)
d33b2eba
GS
1306
1307#endif /* PURIFY */
9b94d1dd 1308
d33b2eba
GS
1309#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1310#define del_XPVFM(p) my_safefree(p)
1c846c1f 1311
d33b2eba
GS
1312#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1313#define del_XPVIO(p) my_safefree(p)
8990e307 1314
954c1994
GS
1315/*
1316=for apidoc sv_upgrade
1317
ff276b08 1318Upgrade an SV to a more complex form. Generally adds a new body type to the
645c22ef 1319SV, then copies across as much information as possible from the old body.
ff276b08 1320You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
954c1994
GS
1321
1322=cut
1323*/
1324
63f97190 1325void
864dbfa3 1326Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
79072805 1327{
e763e3dc 1328
d2e56290
NC
1329 char* pv;
1330 U32 cur;
1331 U32 len;
1332 IV iv;
1333 NV nv;
1334 MAGIC* magic;
1335 HV* stash;
9a085840 1336 void** old_body_arena;
878cc751 1337 size_t old_body_offset;
4cbc76b1 1338 size_t old_body_length; /* Well, the length to copy. */
878cc751 1339 void* old_body;
4cbc76b1
NC
1340 bool zero_nv = TRUE;
1341#ifdef DEBUGGING
1342 U32 old_type = SvTYPE(sv);
1343#endif
79072805 1344
765f542d
NC
1345 if (mt != SVt_PV && SvIsCOW(sv)) {
1346 sv_force_normal_flags(sv, 0);
f130fd45
NIS
1347 }
1348
79072805 1349 if (SvTYPE(sv) == mt)
63f97190 1350 return;
79072805 1351
f5282e15 1352 if (SvTYPE(sv) > mt)
921edb34
RGS
1353 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1354 (int)SvTYPE(sv), (int)mt);
f5282e15 1355
d2e56290
NC
1356 pv = NULL;
1357 cur = 0;
1358 len = 0;
1359 iv = 0;
1360 nv = 0.0;
1361 magic = NULL;
1362 stash = Nullhv;
1363
878cc751
NC
1364 old_body = SvANY(sv);
1365 old_body_arena = 0;
1366 old_body_offset = 0;
4cbc76b1 1367 old_body_length = 0;
878cc751 1368
79072805
LW
1369 switch (SvTYPE(sv)) {
1370 case SVt_NULL:
79072805 1371 break;
79072805 1372 case SVt_IV:
463ee0b2 1373 iv = SvIVX(sv);
ed6116ce 1374 if (mt == SVt_NV)
463ee0b2 1375 mt = SVt_PVNV;
ed6116ce
LW
1376 else if (mt < SVt_PVIV)
1377 mt = SVt_PVIV;
4cbc76b1
NC
1378 old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv);
1379 old_body_length = sizeof(IV);
79072805
LW
1380 break;
1381 case SVt_NV:
463ee0b2 1382 nv = SvNVX(sv);
9a085840 1383 old_body_arena = (void **) &PL_xnv_root;
4cbc76b1
NC
1384 old_body_length = sizeof(NV);
1385 zero_nv = FALSE;
878cc751 1386
ed6116ce 1387 if (mt < SVt_PVNV)
79072805
LW
1388 mt = SVt_PVNV;
1389 break;
ed6116ce
LW
1390 case SVt_RV:
1391 pv = (char*)SvRV(sv);
ed6116ce 1392 break;
79072805 1393 case SVt_PV:
4d84ee25 1394 pv = SvPVX_mutable(sv);
79072805
LW
1395 cur = SvCUR(sv);
1396 len = SvLEN(sv);
9a085840 1397 old_body_arena = (void **) &PL_xpv_root;
878cc751
NC
1398 old_body_offset = STRUCT_OFFSET(XPV, xpv_cur)
1399 - STRUCT_OFFSET(xpv_allocated, xpv_cur);
4cbc76b1 1400 old_body_length = sizeof(XPV) - old_body_offset;
748a9306
LW
1401 if (mt <= SVt_IV)
1402 mt = SVt_PVIV;
1403 else if (mt == SVt_NV)
1404 mt = SVt_PVNV;
79072805
LW
1405 break;
1406 case SVt_PVIV:
4d84ee25 1407 pv = SvPVX_mutable(sv);
79072805
LW
1408 cur = SvCUR(sv);
1409 len = SvLEN(sv);
463ee0b2 1410 iv = SvIVX(sv);
9a085840 1411 old_body_arena = (void **) &PL_xpviv_root;
878cc751
NC
1412 old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur)
1413 - STRUCT_OFFSET(xpviv_allocated, xpv_cur);
4cbc76b1 1414 old_body_length = sizeof(XPVIV) - old_body_offset;
79072805
LW
1415 break;
1416 case SVt_PVNV:
4d84ee25 1417 pv = SvPVX_mutable(sv);
79072805
LW
1418 cur = SvCUR(sv);
1419 len = SvLEN(sv);
463ee0b2
LW
1420 iv = SvIVX(sv);
1421 nv = SvNVX(sv);
9a085840 1422 old_body_arena = (void **) &PL_xpvnv_root;
4cbc76b1
NC
1423 old_body_length = sizeof(XPVNV);
1424 zero_nv = FALSE;
79072805
LW
1425 break;
1426 case SVt_PVMG:
0ec50a73
NC
1427 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1428 there's no way that it can be safely upgraded, because perl.c
1429 expects to Safefree(SvANY(PL_mess_sv)) */
1430 assert(sv != PL_mess_sv);
bce8f412
NC
1431 /* This flag bit is used to mean other things in other scalar types.
1432 Given that it only has meaning inside the pad, it shouldn't be set
1433 on anything that can get upgraded. */
1434 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
4d84ee25 1435 pv = SvPVX_mutable(sv);
79072805
LW
1436 cur = SvCUR(sv);
1437 len = SvLEN(sv);
463ee0b2
LW
1438 iv = SvIVX(sv);
1439 nv = SvNVX(sv);
79072805
LW
1440 magic = SvMAGIC(sv);
1441 stash = SvSTASH(sv);
9a085840 1442 old_body_arena = (void **) &PL_xpvmg_root;
4cbc76b1
NC
1443 old_body_length = sizeof(XPVMG);
1444 zero_nv = FALSE;
79072805
LW
1445 break;
1446 default:
cea2e8a9 1447 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
79072805
LW
1448 }
1449
ffb05e06
NC
1450 SvFLAGS(sv) &= ~SVTYPEMASK;
1451 SvFLAGS(sv) |= mt;
1452
79072805
LW
1453 switch (mt) {
1454 case SVt_NULL:
cea2e8a9 1455 Perl_croak(aTHX_ "Can't upgrade to undef");
79072805 1456 case SVt_IV:
4cbc76b1 1457 assert(old_type == SVt_NULL);
339049b0 1458 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
45977657 1459 SvIV_set(sv, iv);
79072805
LW
1460 break;
1461 case SVt_NV:
4cbc76b1 1462 assert(old_type == SVt_NULL);
79072805 1463 SvANY(sv) = new_XNV();
9d6ce603 1464 SvNV_set(sv, nv);
79072805 1465 break;
ed6116ce 1466 case SVt_RV:
4cbc76b1 1467 assert(old_type == SVt_NULL);
339049b0 1468 SvANY(sv) = &sv->sv_u.svu_rv;
b162af07 1469 SvRV_set(sv, (SV*)pv);
ed6116ce 1470 break;
79072805
LW
1471 case SVt_PVHV:
1472 SvANY(sv) = new_XPVHV();
463ee0b2
LW
1473 HvFILL(sv) = 0;
1474 HvMAX(sv) = 0;
8aacddc1 1475 HvTOTALKEYS(sv) = 0;
bd4b1eb5
NC
1476
1477 /* Fall through... */
1478 if (0) {
1479 case SVt_PVAV:
1480 SvANY(sv) = new_XPVAV();
1481 AvMAX(sv) = -1;
1482 AvFILLp(sv) = -1;
1483 AvALLOC(sv) = 0;
11ca45c0 1484 AvREAL_only(sv);
bd4b1eb5
NC
1485 }
1486 /* to here. */
c2bfdfaf
NC
1487 /* XXX? Only SVt_NULL is ever upgraded to AV or HV? */
1488 assert(!pv);
8bd4d4c5
NC
1489 /* FIXME. Should be able to remove all this if()... if the above
1490 assertion is genuinely always true. */
1491 if(SvOOK(sv)) {
1492 pv -= iv;
1493 SvFLAGS(sv) &= ~SVf_OOK;
1494 }
1495 Safefree(pv);
bd4b1eb5 1496 SvPV_set(sv, (char*)0);
b162af07
SP
1497 SvMAGIC_set(sv, magic);
1498 SvSTASH_set(sv, stash);
79072805 1499 break;
bd4b1eb5
NC
1500
1501 case SVt_PVIO:
1502 SvANY(sv) = new_XPVIO();
1503 Zero(SvANY(sv), 1, XPVIO);
1504 IoPAGE_LEN(sv) = 60;
1505 goto set_magic_common;
1506 case SVt_PVFM:
1507 SvANY(sv) = new_XPVFM();
1508 Zero(SvANY(sv), 1, XPVFM);
1509 goto set_magic_common;
1510 case SVt_PVBM:
1511 SvANY(sv) = new_XPVBM();
1512 BmRARE(sv) = 0;
1513 BmUSEFUL(sv) = 0;
1514 BmPREVIOUS(sv) = 0;
1515 goto set_magic_common;
1516 case SVt_PVGV:
1517 SvANY(sv) = new_XPVGV();
1518 GvGP(sv) = 0;
1519 GvNAME(sv) = 0;
1520 GvNAMELEN(sv) = 0;
1521 GvSTASH(sv) = 0;
1522 GvFLAGS(sv) = 0;
1523 goto set_magic_common;
79072805
LW
1524 case SVt_PVCV:
1525 SvANY(sv) = new_XPVCV();
748a9306 1526 Zero(SvANY(sv), 1, XPVCV);
bd4b1eb5
NC
1527 goto set_magic_common;
1528 case SVt_PVLV:
1529 SvANY(sv) = new_XPVLV();
1530 LvTARGOFF(sv) = 0;
1531 LvTARGLEN(sv) = 0;
1532 LvTARG(sv) = 0;
1533 LvTYPE(sv) = 0;
93a17b20 1534 GvGP(sv) = 0;
79072805
LW
1535 GvNAME(sv) = 0;
1536 GvNAMELEN(sv) = 0;
1537 GvSTASH(sv) = 0;
a5f75d66 1538 GvFLAGS(sv) = 0;
bd4b1eb5
NC
1539 /* Fall through. */
1540 if (0) {
1541 case SVt_PVMG:
1542 SvANY(sv) = new_XPVMG();
1543 }
1544 set_magic_common:
b162af07
SP
1545 SvMAGIC_set(sv, magic);
1546 SvSTASH_set(sv, stash);
bd4b1eb5
NC
1547 /* Fall through. */
1548 if (0) {
1549 case SVt_PVNV:
1550 SvANY(sv) = new_XPVNV();
1551 }
9d6ce603 1552 SvNV_set(sv, nv);
bd4b1eb5
NC
1553 /* Fall through. */
1554 if (0) {
1555 case SVt_PVIV:
1556 SvANY(sv) = new_XPVIV();
1557 if (SvNIOK(sv))
1558 (void)SvIOK_on(sv);
1559 SvNOK_off(sv);
1560 }
1561 SvIV_set(sv, iv);
1562 /* Fall through. */
1563 if (0) {
1564 case SVt_PV:
1565 SvANY(sv) = new_XPV();
1566 }
f880fe2f 1567 SvPV_set(sv, pv);
b162af07
SP
1568 SvCUR_set(sv, cur);
1569 SvLEN_set(sv, len);
8990e307
LW
1570 break;
1571 }
878cc751
NC
1572
1573
1574 if (old_body_arena) {
1575#ifdef PURIFY
ee6954bb 1576 my_safefree(old_body);
878cc751
NC
1577#else
1578 S_del_body(aTHX_ old_body, old_body_arena, old_body_offset);
1579#endif
ee6954bb 1580 }
79072805
LW
1581}
1582
645c22ef
DM
1583/*
1584=for apidoc sv_backoff
1585
1586Remove any string offset. You should normally use the C<SvOOK_off> macro
1587wrapper instead.
1588
1589=cut
1590*/
1591
79072805 1592int
864dbfa3 1593Perl_sv_backoff(pTHX_ register SV *sv)
79072805
LW
1594{
1595 assert(SvOOK(sv));
b79f7545
NC
1596 assert(SvTYPE(sv) != SVt_PVHV);
1597 assert(SvTYPE(sv) != SVt_PVAV);
463ee0b2 1598 if (SvIVX(sv)) {
3f7c398e 1599 const char *s = SvPVX_const(sv);
b162af07 1600 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
f880fe2f 1601 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
79072805 1602 SvIV_set(sv, 0);
463ee0b2 1603 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW
1604 }
1605 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 1606 return 0;
79072805
LW
1607}
1608
954c1994
GS
1609/*
1610=for apidoc sv_grow
1611
645c22ef
DM
1612Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1613upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1614Use the C<SvGROW> wrapper instead.
954c1994
GS
1615
1616=cut
1617*/
1618
79072805 1619char *
864dbfa3 1620Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
79072805
LW
1621{
1622 register char *s;
1623
55497cff 1624#ifdef HAS_64K_LIMIT
79072805 1625 if (newlen >= 0x10000) {
1d7c1841
GS
1626 PerlIO_printf(Perl_debug_log,
1627 "Allocation too large: %"UVxf"\n", (UV)newlen);
79072805
LW
1628 my_exit(1);
1629 }
55497cff 1630#endif /* HAS_64K_LIMIT */
a0d0e21e
LW
1631 if (SvROK(sv))
1632 sv_unref(sv);
79072805
LW
1633 if (SvTYPE(sv) < SVt_PV) {
1634 sv_upgrade(sv, SVt_PV);
93524f2b 1635 s = SvPVX_mutable(sv);
79072805
LW
1636 }
1637 else if (SvOOK(sv)) { /* pv is offset? */
1638 sv_backoff(sv);
93524f2b 1639 s = SvPVX_mutable(sv);
79072805
LW
1640 if (newlen > SvLEN(sv))
1641 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
c6f8c383
GA
1642#ifdef HAS_64K_LIMIT
1643 if (newlen >= 0x10000)
1644 newlen = 0xFFFF;
1645#endif
79072805 1646 }
bc44a8a2 1647 else
4d84ee25 1648 s = SvPVX_mutable(sv);
54f0641b 1649
79072805 1650 if (newlen > SvLEN(sv)) { /* need more room? */
7a9b70e9 1651 newlen = PERL_STRLEN_ROUNDUP(newlen);
8d6dde3e 1652 if (SvLEN(sv) && s) {
7bab3ede 1653#ifdef MYMALLOC
93524f2b 1654 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
8d6dde3e
IZ
1655 if (newlen <= l) {
1656 SvLEN_set(sv, l);
1657 return s;
1658 } else
c70c8a0a 1659#endif
1936d2a7 1660 s = saferealloc(s, newlen);
8d6dde3e 1661 }
bfed75c6 1662 else {
1936d2a7 1663 s = safemalloc(newlen);
3f7c398e
SP
1664 if (SvPVX_const(sv) && SvCUR(sv)) {
1665 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
40565179 1666 }
4e83176d 1667 }
79072805 1668 SvPV_set(sv, s);
e1ec3a88 1669 SvLEN_set(sv, newlen);
79072805
LW
1670 }
1671 return s;
1672}
1673
954c1994
GS
1674/*
1675=for apidoc sv_setiv
1676
645c22ef
DM
1677Copies an integer into the given SV, upgrading first if necessary.
1678Does not handle 'set' magic. See also C<sv_setiv_mg>.
954c1994
GS
1679
1680=cut
1681*/
1682
79072805 1683void
864dbfa3 1684Perl_sv_setiv(pTHX_ register SV *sv, IV i)
79072805 1685{
765f542d 1686 SV_CHECK_THINKFIRST_COW_DROP(sv);
463ee0b2
LW
1687 switch (SvTYPE(sv)) {
1688 case SVt_NULL:
79072805 1689 sv_upgrade(sv, SVt_IV);
463ee0b2
LW
1690 break;
1691 case SVt_NV:
1692 sv_upgrade(sv, SVt_PVNV);
1693 break;
ed6116ce 1694 case SVt_RV:
463ee0b2 1695 case SVt_PV:
79072805 1696 sv_upgrade(sv, SVt_PVIV);
463ee0b2 1697 break;
a0d0e21e
LW
1698
1699 case SVt_PVGV:
a0d0e21e
LW
1700 case SVt_PVAV:
1701 case SVt_PVHV:
1702 case SVt_PVCV:
1703 case SVt_PVFM:
1704 case SVt_PVIO:
411caa50 1705 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
53e06cf0 1706 OP_DESC(PL_op));
463ee0b2 1707 }
a0d0e21e 1708 (void)SvIOK_only(sv); /* validate number */
45977657 1709 SvIV_set(sv, i);
463ee0b2 1710 SvTAINT(sv);
79072805
LW
1711}
1712
954c1994
GS
1713/*
1714=for apidoc sv_setiv_mg
1715
1716Like C<sv_setiv>, but also handles 'set' magic.
1717
1718=cut
1719*/
1720
79072805 1721void
864dbfa3 1722Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
ef50df4b
GS
1723{
1724 sv_setiv(sv,i);
1725 SvSETMAGIC(sv);
1726}
1727
954c1994
GS
1728/*
1729=for apidoc sv_setuv
1730
645c22ef
DM
1731Copies an unsigned integer into the given SV, upgrading first if necessary.
1732Does not handle 'set' magic. See also C<sv_setuv_mg>.
954c1994
GS
1733
1734=cut
1735*/
1736
ef50df4b 1737void
864dbfa3 1738Perl_sv_setuv(pTHX_ register SV *sv, UV u)
55497cff 1739{
55ada374
NC
1740 /* With these two if statements:
1741 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 1742
55ada374
NC
1743 without
1744 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 1745
55ada374
NC
1746 If you wish to remove them, please benchmark to see what the effect is
1747 */
28e5dec8
JH
1748 if (u <= (UV)IV_MAX) {
1749 sv_setiv(sv, (IV)u);
1750 return;
1751 }
25da4f38
IZ
1752 sv_setiv(sv, 0);
1753 SvIsUV_on(sv);
607fa7f2 1754 SvUV_set(sv, u);
55497cff
PP
1755}
1756
954c1994
GS
1757/*
1758=for apidoc sv_setuv_mg
1759
1760Like C<sv_setuv>, but also handles 'set' magic.
1761
1762=cut
1763*/
1764
55497cff 1765void
864dbfa3 1766Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b 1767{
55ada374
NC
1768 /* With these two if statements:
1769 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 1770
55ada374
NC
1771 without
1772 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 1773
55ada374
NC
1774 If you wish to remove them, please benchmark to see what the effect is
1775 */
28e5dec8
JH
1776 if (u <= (UV)IV_MAX) {
1777 sv_setiv(sv, (IV)u);
1778 } else {
1779 sv_setiv(sv, 0);
1780 SvIsUV_on(sv);
1781 sv_setuv(sv,u);
1782 }
ef50df4b
GS
1783 SvSETMAGIC(sv);
1784}
1785
954c1994
GS
1786/*
1787=for apidoc sv_setnv
1788
645c22ef
DM
1789Copies a double into the given SV, upgrading first if necessary.
1790Does not handle 'set' magic. See also C<sv_setnv_mg>.
954c1994
GS
1791
1792=cut
1793*/
1794
ef50df4b 1795void
65202027 1796Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 1797{
765f542d 1798 SV_CHECK_THINKFIRST_COW_DROP(sv);
a0d0e21e
LW
1799 switch (SvTYPE(sv)) {
1800 case SVt_NULL:
1801 case SVt_IV:
79072805 1802 sv_upgrade(sv, SVt_NV);
a0d0e21e 1803 break;
a0d0e21e
LW
1804 case SVt_RV:
1805 case SVt_PV:
1806 case SVt_PVIV:
79072805 1807 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 1808 break;
827b7e14 1809
a0d0e21e 1810 case SVt_PVGV:
a0d0e21e
LW
1811 case SVt_PVAV:
1812 case SVt_PVHV:
1813 case SVt_PVCV:
1814 case SVt_PVFM:
1815 case SVt_PVIO:
411caa50 1816 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
53e06cf0 1817 OP_NAME(PL_op));
79072805 1818 }
9d6ce603 1819 SvNV_set(sv, num);
a0d0e21e 1820 (void)SvNOK_only(sv); /* validate number */
463ee0b2 1821 SvTAINT(sv);
79072805
LW
1822}
1823
954c1994
GS
1824/*
1825=for apidoc sv_setnv_mg
1826
1827Like C<sv_setnv>, but also handles 'set' magic.
1828
1829=cut
1830*/
1831
ef50df4b 1832void
65202027 1833Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS
1834{
1835 sv_setnv(sv,num);
1836 SvSETMAGIC(sv);
1837}
1838
645c22ef
DM
1839/* Print an "isn't numeric" warning, using a cleaned-up,
1840 * printable version of the offending string
1841 */
1842
76e3520e 1843STATIC void
cea2e8a9 1844S_not_a_number(pTHX_ SV *sv)
a0d0e21e 1845{
94463019
JH
1846 SV *dsv;
1847 char tmpbuf[64];
1848 char *pv;
1849
1850 if (DO_UTF8(sv)) {
1851 dsv = sv_2mortal(newSVpv("", 0));
1852 pv = sv_uni_display(dsv, sv, 10, 0);
1853 } else {
1854 char *d = tmpbuf;
1855 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1856 /* each *s can expand to 4 chars + "...\0",
1857 i.e. need room for 8 chars */
ecdeb87c 1858
e62f0680
NC
1859 const char *s, *end;
1860 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1861 s++) {
94463019
JH
1862 int ch = *s & 0xFF;
1863 if (ch & 128 && !isPRINT_LC(ch)) {
1864 *d++ = 'M';
1865 *d++ = '-';
1866 ch &= 127;
1867 }
1868 if (ch == '\n') {
1869 *d++ = '\\';
1870 *d++ = 'n';
1871 }
1872 else if (ch == '\r') {
1873 *d++ = '\\';
1874 *d++ = 'r';
1875 }
1876 else if (ch == '\f') {
1877 *d++ = '\\';
1878 *d++ = 'f';
1879 }
1880 else if (ch == '\\') {
1881 *d++ = '\\';
1882 *d++ = '\\';
1883 }
1884 else if (ch == '\0') {
1885 *d++ = '\\';
1886 *d++ = '0';
1887 }
1888 else if (isPRINT_LC(ch))
1889 *d++ = ch;
1890 else {
1891 *d++ = '^';
1892 *d++ = toCTRL(ch);
1893 }
1894 }
1895 if (s < end) {
1896 *d++ = '.';
1897 *d++ = '.';
1898 *d++ = '.';
1899 }
1900 *d = '\0';
1901 pv = tmpbuf;
a0d0e21e 1902 }
a0d0e21e 1903
533c011a 1904 if (PL_op)
9014280d 1905 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019
JH
1906 "Argument \"%s\" isn't numeric in %s", pv,
1907 OP_DESC(PL_op));
a0d0e21e 1908 else
9014280d 1909 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019 1910 "Argument \"%s\" isn't numeric", pv);
a0d0e21e
LW
1911}
1912
c2988b20
NC
1913/*
1914=for apidoc looks_like_number
1915
645c22ef
DM
1916Test if the content of an SV looks like a number (or is a number).
1917C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1918non-numeric warning), even if your atof() doesn't grok them.
c2988b20
NC
1919
1920=cut
1921*/
1922
1923I32
1924Perl_looks_like_number(pTHX_ SV *sv)
1925{
a3b680e6 1926 register const char *sbegin;
c2988b20
NC
1927 STRLEN len;
1928
1929 if (SvPOK(sv)) {
3f7c398e 1930 sbegin = SvPVX_const(sv);
c2988b20
NC
1931 len = SvCUR(sv);
1932 }
1933 else if (SvPOKp(sv))
83003860 1934 sbegin = SvPV_const(sv, len);
c2988b20 1935 else
e0ab1c0e 1936 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
c2988b20
NC
1937 return grok_number(sbegin, len, NULL);
1938}
25da4f38
IZ
1939
1940/* Actually, ISO C leaves conversion of UV to IV undefined, but
1941 until proven guilty, assume that things are not that bad... */
1942
645c22ef
DM
1943/*
1944 NV_PRESERVES_UV:
1945
1946 As 64 bit platforms often have an NV that doesn't preserve all bits of
28e5dec8
JH
1947 an IV (an assumption perl has been based on to date) it becomes necessary
1948 to remove the assumption that the NV always carries enough precision to
1949 recreate the IV whenever needed, and that the NV is the canonical form.
1950 Instead, IV/UV and NV need to be given equal rights. So as to not lose
645c22ef 1951 precision as a side effect of conversion (which would lead to insanity
28e5dec8
JH
1952 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1953 1) to distinguish between IV/UV/NV slots that have cached a valid
1954 conversion where precision was lost and IV/UV/NV slots that have a
1955 valid conversion which has lost no precision
645c22ef 1956 2) to ensure that if a numeric conversion to one form is requested that
28e5dec8
JH
1957 would lose precision, the precise conversion (or differently
1958 imprecise conversion) is also performed and cached, to prevent
1959 requests for different numeric formats on the same SV causing
1960 lossy conversion chains. (lossless conversion chains are perfectly
1961 acceptable (still))
1962
1963
1964 flags are used:
1965 SvIOKp is true if the IV slot contains a valid value
1966 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1967 SvNOKp is true if the NV slot contains a valid value
1968 SvNOK is true only if the NV value is accurate
1969
1970 so
645c22ef 1971 while converting from PV to NV, check to see if converting that NV to an
28e5dec8
JH
1972 IV(or UV) would lose accuracy over a direct conversion from PV to
1973 IV(or UV). If it would, cache both conversions, return NV, but mark
1974 SV as IOK NOKp (ie not NOK).
1975
645c22ef 1976 While converting from PV to IV, check to see if converting that IV to an
28e5dec8
JH
1977 NV would lose accuracy over a direct conversion from PV to NV. If it
1978 would, cache both conversions, flag similarly.
1979
1980 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1981 correctly because if IV & NV were set NV *always* overruled.
645c22ef
DM
1982 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1983 changes - now IV and NV together means that the two are interchangeable:
28e5dec8 1984 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
d460ef45 1985
645c22ef
DM
1986 The benefit of this is that operations such as pp_add know that if
1987 SvIOK is true for both left and right operands, then integer addition
1988 can be used instead of floating point (for cases where the result won't
1989 overflow). Before, floating point was always used, which could lead to
28e5dec8
JH
1990 loss of precision compared with integer addition.
1991
1992 * making IV and NV equal status should make maths accurate on 64 bit
1993 platforms
1994 * may speed up maths somewhat if pp_add and friends start to use
645c22ef 1995 integers when possible instead of fp. (Hopefully the overhead in
28e5dec8
JH
1996 looking for SvIOK and checking for overflow will not outweigh the
1997 fp to integer speedup)
1998 * will slow down integer operations (callers of SvIV) on "inaccurate"
1999 values, as the change from SvIOK to SvIOKp will cause a call into
2000 sv_2iv each time rather than a macro access direct to the IV slot
2001 * should speed up number->string conversion on integers as IV is
645c22ef 2002 favoured when IV and NV are equally accurate
28e5dec8
JH
2003
2004 ####################################################################
645c22ef
DM
2005 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2006 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2007 On the other hand, SvUOK is true iff UV.
28e5dec8
JH
2008 ####################################################################
2009
645c22ef 2010 Your mileage will vary depending your CPU's relative fp to integer
28e5dec8
JH
2011 performance ratio.
2012*/
2013
2014#ifndef NV_PRESERVES_UV
645c22ef
DM
2015# define IS_NUMBER_UNDERFLOW_IV 1
2016# define IS_NUMBER_UNDERFLOW_UV 2
2017# define IS_NUMBER_IV_AND_UV 2
2018# define IS_NUMBER_OVERFLOW_IV 4
2019# define IS_NUMBER_OVERFLOW_UV 5
2020
2021/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
28e5dec8
JH
2022
2023/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2024STATIC int
645c22ef 2025S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
28e5dec8 2026{
3f7c398e 2027 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
2028 if (SvNVX(sv) < (NV)IV_MIN) {
2029 (void)SvIOKp_on(sv);
2030 (void)SvNOK_on(sv);
45977657 2031 SvIV_set(sv, IV_MIN);
28e5dec8
JH
2032 return IS_NUMBER_UNDERFLOW_IV;
2033 }
2034 if (SvNVX(sv) > (NV)UV_MAX) {
2035 (void)SvIOKp_on(sv);
2036 (void)SvNOK_on(sv);
2037 SvIsUV_on(sv);
607fa7f2 2038 SvUV_set(sv, UV_MAX);
28e5dec8
JH
2039 return IS_NUMBER_OVERFLOW_UV;
2040 }
c2988b20
NC
2041 (void)SvIOKp_on(sv);
2042 (void)SvNOK_on(sv);
2043 /* Can't use strtol etc to convert this string. (See truth table in
2044 sv_2iv */
2045 if (SvNVX(sv) <= (UV)IV_MAX) {
45977657 2046 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2047 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2048 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2049 } else {
2050 /* Integer is imprecise. NOK, IOKp */
2051 }
2052 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2053 }
2054 SvIsUV_on(sv);
607fa7f2 2055 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2056 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2057 if (SvUVX(sv) == UV_MAX) {
2058 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2059 possibly be preserved by NV. Hence, it must be overflow.
2060 NOK, IOKp */
2061 return IS_NUMBER_OVERFLOW_UV;
2062 }
2063 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2064 } else {
2065 /* Integer is imprecise. NOK, IOKp */
28e5dec8 2066 }
c2988b20 2067 return IS_NUMBER_OVERFLOW_IV;
28e5dec8 2068}
645c22ef
DM
2069#endif /* !NV_PRESERVES_UV*/
2070
891f9566
YST
2071/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2072 * this function provided for binary compatibility only
2073 */
2074
2075IV
2076Perl_sv_2iv(pTHX_ register SV *sv)
2077{
2078 return sv_2iv_flags(sv, SV_GMAGIC);
2079}
2080
645c22ef 2081/*
891f9566 2082=for apidoc sv_2iv_flags
645c22ef 2083
891f9566
YST
2084Return the integer value of an SV, doing any necessary string
2085conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2086Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
645c22ef
DM
2087
2088=cut
2089*/
28e5dec8 2090
a0d0e21e 2091IV
891f9566 2092Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
79072805
LW
2093{
2094 if (!sv)
2095 return 0;
8990e307 2096 if (SvGMAGICAL(sv)) {
891f9566
YST
2097 if (flags & SV_GMAGIC)
2098 mg_get(sv);
463ee0b2
LW
2099 if (SvIOKp(sv))
2100 return SvIVX(sv);
748a9306 2101 if (SvNOKp(sv)) {
25da4f38 2102 return I_V(SvNVX(sv));
748a9306 2103 }
36477c24
PP
2104 if (SvPOKp(sv) && SvLEN(sv))
2105 return asIV(sv);
3fe9a6f1 2106 if (!SvROK(sv)) {
d008e5eb 2107 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2108 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2109 report_uninit(sv);
c6ee37c5 2110 }
36477c24 2111 return 0;
3fe9a6f1 2112 }
463ee0b2 2113 }
ed6116ce 2114 if (SvTHINKFIRST(sv)) {
a0d0e21e 2115 if (SvROK(sv)) {
a0d0e21e 2116 SV* tmpstr;
1554e226 2117 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2118 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2119 return SvIV(tmpstr);
56431972 2120 return PTR2IV(SvRV(sv));
a0d0e21e 2121 }
765f542d
NC
2122 if (SvIsCOW(sv)) {
2123 sv_force_normal_flags(sv, 0);
47deb5e7 2124 }
0336b60e 2125 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2126 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2127 report_uninit(sv);
ed6116ce
LW
2128 return 0;
2129 }
79072805 2130 }
25da4f38
IZ
2131 if (SvIOKp(sv)) {
2132 if (SvIsUV(sv)) {
2133 return (IV)(SvUVX(sv));
2134 }
2135 else {
2136 return SvIVX(sv);
2137 }
463ee0b2 2138 }
748a9306 2139 if (SvNOKp(sv)) {
28e5dec8
JH
2140 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2141 * without also getting a cached IV/UV from it at the same time
2142 * (ie PV->NV conversion should detect loss of accuracy and cache
2143 * IV or UV at same time to avoid this. NWC */
25da4f38
IZ
2144
2145 if (SvTYPE(sv) == SVt_NV)
2146 sv_upgrade(sv, SVt_PVNV);
2147
28e5dec8
JH
2148 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2149 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2150 certainly cast into the IV range at IV_MAX, whereas the correct
2151 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2152 cases go to UV */
2153 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2154 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
2155 if (SvNVX(sv) == (NV) SvIVX(sv)
2156#ifndef NV_PRESERVES_UV
2157 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2158 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2159 /* Don't flag it as "accurately an integer" if the number
2160 came from a (by definition imprecise) NV operation, and
2161 we're outside the range of NV integer precision */
2162#endif
2163 ) {
2164 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2165 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2166 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2167 PTR2UV(sv),
2168 SvNVX(sv),
2169 SvIVX(sv)));
2170
2171 } else {
2172 /* IV not precise. No need to convert from PV, as NV
2173 conversion would already have cached IV if it detected
2174 that PV->IV would be better than PV->NV->IV
2175 flags already correct - don't set public IOK. */
2176 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2177 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2178 PTR2UV(sv),
2179 SvNVX(sv),
2180 SvIVX(sv)));
2181 }
2182 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2183 but the cast (NV)IV_MIN rounds to a the value less (more
2184 negative) than IV_MIN which happens to be equal to SvNVX ??
2185 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2186 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2187 (NV)UVX == NVX are both true, but the values differ. :-(
2188 Hopefully for 2s complement IV_MIN is something like
2189 0x8000000000000000 which will be exact. NWC */
d460ef45 2190 }
25da4f38 2191 else {
607fa7f2 2192 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2193 if (
2194 (SvNVX(sv) == (NV) SvUVX(sv))
2195#ifndef NV_PRESERVES_UV
2196 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2197 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2198 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2199 /* Don't flag it as "accurately an integer" if the number
2200 came from a (by definition imprecise) NV operation, and
2201 we're outside the range of NV integer precision */
2202#endif
2203 )
2204 SvIOK_on(sv);
25da4f38
IZ
2205 SvIsUV_on(sv);
2206 ret_iv_max:
1c846c1f 2207 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 2208 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 2209 PTR2UV(sv),
57def98f
JH
2210 SvUVX(sv),
2211 SvUVX(sv)));
25da4f38
IZ
2212 return (IV)SvUVX(sv);
2213 }
748a9306
LW
2214 }
2215 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2216 UV value;
504618e9 2217 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
25da4f38
IZ
2218 /* We want to avoid a possible problem when we cache an IV which
2219 may be later translated to an NV, and the resulting NV is not
c2988b20
NC
2220 the same as the direct translation of the initial string
2221 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2222 be careful to ensure that the value with the .456 is around if the
2223 NV value is requested in the future).
1c846c1f 2224
25da4f38
IZ
2225 This means that if we cache such an IV, we need to cache the
2226 NV as well. Moreover, we trade speed for space, and do not
28e5dec8 2227 cache the NV if we are sure it's not needed.
25da4f38 2228 */
16b7a9a4 2229
c2988b20
NC
2230 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2231 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2232 == IS_NUMBER_IN_UV) {
5e045b90 2233 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8
JH
2234 if (SvTYPE(sv) < SVt_PVIV)
2235 sv_upgrade(sv, SVt_PVIV);
f7bbb42a 2236 (void)SvIOK_on(sv);
c2988b20
NC
2237 } else if (SvTYPE(sv) < SVt_PVNV)
2238 sv_upgrade(sv, SVt_PVNV);
28e5dec8 2239
c2988b20
NC
2240 /* If NV preserves UV then we only use the UV value if we know that
2241 we aren't going to call atof() below. If NVs don't preserve UVs
2242 then the value returned may have more precision than atof() will
2243 return, even though value isn't perfectly accurate. */
2244 if ((numtype & (IS_NUMBER_IN_UV
2245#ifdef NV_PRESERVES_UV
2246 | IS_NUMBER_NOT_INT
2247#endif
2248 )) == IS_NUMBER_IN_UV) {
2249 /* This won't turn off the public IOK flag if it was set above */
2250 (void)SvIOKp_on(sv);
2251
2252 if (!(numtype & IS_NUMBER_NEG)) {
2253 /* positive */;
2254 if (value <= (UV)IV_MAX) {
45977657 2255 SvIV_set(sv, (IV)value);
c2988b20 2256 } else {
607fa7f2 2257 SvUV_set(sv, value);
c2988b20
NC
2258 SvIsUV_on(sv);
2259 }
2260 } else {
2261 /* 2s complement assumption */
2262 if (value <= (UV)IV_MIN) {
45977657 2263 SvIV_set(sv, -(IV)value);
c2988b20
NC
2264 } else {
2265 /* Too negative for an IV. This is a double upgrade, but
d1be9408 2266 I'm assuming it will be rare. */
c2988b20
NC
2267 if (SvTYPE(sv) < SVt_PVNV)
2268 sv_upgrade(sv, SVt_PVNV);
2269 SvNOK_on(sv);
2270 SvIOK_off(sv);
2271 SvIOKp_on(sv);
9d6ce603 2272 SvNV_set(sv, -(NV)value);
45977657 2273 SvIV_set(sv, IV_MIN);
c2988b20
NC
2274 }
2275 }
2276 }
2277 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2278 will be in the previous block to set the IV slot, and the next
2279 block to set the NV slot. So no else here. */
2280
2281 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2282 != IS_NUMBER_IN_UV) {
2283 /* It wasn't an (integer that doesn't overflow the UV). */
3f7c398e 2284 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8 2285
c2988b20
NC
2286 if (! numtype && ckWARN(WARN_NUMERIC))
2287 not_a_number(sv);
28e5dec8 2288
65202027 2289#if defined(USE_LONG_DOUBLE)
c2988b20
NC
2290 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2291 PTR2UV(sv), SvNVX(sv)));
65202027 2292#else
1779d84d 2293 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
c2988b20 2294 PTR2UV(sv), SvNVX(sv)));
65202027 2295#endif
28e5dec8
JH
2296
2297
2298#ifdef NV_PRESERVES_UV
c2988b20
NC
2299 (void)SvIOKp_on(sv);
2300 (void)SvNOK_on(sv);
2301 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2302 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2303 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2304 SvIOK_on(sv);
28e5dec8 2305 } else {
c2988b20
NC
2306 /* Integer is imprecise. NOK, IOKp */
2307 }
2308 /* UV will not work better than IV */
2309 } else {
2310 if (SvNVX(sv) > (NV)UV_MAX) {
2311 SvIsUV_on(sv);
2312 /* Integer is inaccurate. NOK, IOKp, is UV */
607fa7f2 2313 SvUV_set(sv, UV_MAX);
c2988b20
NC
2314 SvIsUV_on(sv);
2315 } else {
607fa7f2 2316 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2317 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2318 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2319 SvIOK_on(sv);
28e5dec8
JH
2320 SvIsUV_on(sv);
2321 } else {
c2988b20
NC
2322 /* Integer is imprecise. NOK, IOKp, is UV */
2323 SvIsUV_on(sv);
28e5dec8 2324 }
28e5dec8 2325 }
c2988b20
NC
2326 goto ret_iv_max;
2327 }
28e5dec8 2328#else /* NV_PRESERVES_UV */
c2988b20
NC
2329 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2330 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2331 /* The IV slot will have been set from value returned by
2332 grok_number above. The NV slot has just been set using
2333 Atof. */
560b0c46 2334 SvNOK_on(sv);
c2988b20
NC
2335 assert (SvIOKp(sv));
2336 } else {
2337 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2338 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2339 /* Small enough to preserve all bits. */
2340 (void)SvIOKp_on(sv);
2341 SvNOK_on(sv);
45977657 2342 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2343 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2344 SvIOK_on(sv);
2345 /* Assumption: first non-preserved integer is < IV_MAX,
2346 this NV is in the preserved range, therefore: */
2347 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2348 < (UV)IV_MAX)) {
32fdb065 2349 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
2350 }
2351 } else {
2352 /* IN_UV NOT_INT
2353 0 0 already failed to read UV.
2354 0 1 already failed to read UV.
2355 1 0 you won't get here in this case. IV/UV
2356 slot set, public IOK, Atof() unneeded.
2357 1 1 already read UV.
2358 so there's no point in sv_2iuv_non_preserve() attempting
2359 to use atol, strtol, strtoul etc. */
2360 if (sv_2iuv_non_preserve (sv, numtype)
2361 >= IS_NUMBER_OVERFLOW_IV)
2362 goto ret_iv_max;
2363 }
2364 }
28e5dec8 2365#endif /* NV_PRESERVES_UV */
25da4f38 2366 }
28e5dec8 2367 } else {
599cee73 2368 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 2369 report_uninit(sv);
25da4f38
IZ
2370 if (SvTYPE(sv) < SVt_IV)
2371 /* Typically the caller expects that sv_any is not NULL now. */
2372 sv_upgrade(sv, SVt_IV);
a0d0e21e 2373 return 0;
79072805 2374 }
1d7c1841
GS
2375 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2376 PTR2UV(sv),SvIVX(sv)));
25da4f38 2377 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW
2378}
2379
891f9566
YST
2380/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2381 * this function provided for binary compatibility only
2382 */
2383
2384UV
2385Perl_sv_2uv(pTHX_ register SV *sv)
2386{
2387 return sv_2uv_flags(sv, SV_GMAGIC);
2388}
2389
645c22ef 2390/*
891f9566 2391=for apidoc sv_2uv_flags
645c22ef
DM
2392
2393Return the unsigned integer value of an SV, doing any necessary string
891f9566
YST
2394conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2395Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
645c22ef
DM
2396
2397=cut
2398*/
2399
ff68c719 2400UV
891f9566 2401Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
ff68c719
PP
2402{
2403 if (!sv)
2404 return 0;
2405 if (SvGMAGICAL(sv)) {
891f9566
YST
2406 if (flags & SV_GMAGIC)
2407 mg_get(sv);
ff68c719
PP
2408 if (SvIOKp(sv))
2409 return SvUVX(sv);
2410 if (SvNOKp(sv))
2411 return U_V(SvNVX(sv));
36477c24
PP
2412 if (SvPOKp(sv) && SvLEN(sv))
2413 return asUV(sv);
3fe9a6f1 2414 if (!SvROK(sv)) {
d008e5eb 2415 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2416 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2417 report_uninit(sv);
c6ee37c5 2418 }
36477c24 2419 return 0;
3fe9a6f1 2420 }
ff68c719
PP
2421 }
2422 if (SvTHINKFIRST(sv)) {
2423 if (SvROK(sv)) {
ff68c719 2424 SV* tmpstr;
1554e226 2425 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2426 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2427 return SvUV(tmpstr);
56431972 2428 return PTR2UV(SvRV(sv));
ff68c719 2429 }
765f542d
NC
2430 if (SvIsCOW(sv)) {
2431 sv_force_normal_flags(sv, 0);
8a818333 2432 }
0336b60e 2433 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2434 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2435 report_uninit(sv);
ff68c719
PP
2436 return 0;
2437 }
2438 }
25da4f38
IZ
2439 if (SvIOKp(sv)) {
2440 if (SvIsUV(sv)) {
2441 return SvUVX(sv);
2442 }
2443 else {
2444 return (UV)SvIVX(sv);
2445 }
ff68c719
PP
2446 }
2447 if (SvNOKp(sv)) {
28e5dec8
JH
2448 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2449 * without also getting a cached IV/UV from it at the same time
2450 * (ie PV->NV conversion should detect loss of accuracy and cache
2451 * IV or UV at same time to avoid this. */
2452 /* IV-over-UV optimisation - choose to cache IV if possible */
2453
25da4f38
IZ
2454 if (SvTYPE(sv) == SVt_NV)
2455 sv_upgrade(sv, SVt_PVNV);
28e5dec8
JH
2456
2457 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2458 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2459 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
2460 if (SvNVX(sv) == (NV) SvIVX(sv)
2461#ifndef NV_PRESERVES_UV
2462 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2463 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2464 /* Don't flag it as "accurately an integer" if the number
2465 came from a (by definition imprecise) NV operation, and
2466 we're outside the range of NV integer precision */
2467#endif
2468 ) {
2469 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2470 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2471 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2472 PTR2UV(sv),
2473 SvNVX(sv),
2474 SvIVX(sv)));
2475
2476 } else {
2477 /* IV not precise. No need to convert from PV, as NV
2478 conversion would already have cached IV if it detected
2479 that PV->IV would be better than PV->NV->IV
2480 flags already correct - don't set public IOK. */
2481 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2482 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2483 PTR2UV(sv),
2484 SvNVX(sv),
2485 SvIVX(sv)));
2486 }
2487 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2488 but the cast (NV)IV_MIN rounds to a the value less (more
2489 negative) than IV_MIN which happens to be equal to SvNVX ??
2490 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2491 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2492 (NV)UVX == NVX are both true, but the values differ. :-(
2493 Hopefully for 2s complement IV_MIN is something like
2494 0x8000000000000000 which will be exact. NWC */
d460ef45 2495 }
28e5dec8 2496 else {
607fa7f2 2497 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2498 if (
2499 (SvNVX(sv) == (NV) SvUVX(sv))
2500#ifndef NV_PRESERVES_UV
2501 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2502 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2503 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2504 /* Don't flag it as "accurately an integer" if the number
2505 came from a (by definition imprecise) NV operation, and
2506 we're outside the range of NV integer precision */
2507#endif
2508 )
2509 SvIOK_on(sv);
2510 SvIsUV_on(sv);
1c846c1f 2511 DEBUG_c(PerlIO_printf(Perl_debug_log,
28e5dec8 2512 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
57def98f 2513 PTR2UV(sv),
28e5dec8
JH
2514 SvUVX(sv),
2515 SvUVX(sv)));
25da4f38 2516 }
ff68c719
PP
2517 }
2518 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2519 UV value;
504618e9 2520 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
25da4f38
IZ
2521
2522 /* We want to avoid a possible problem when we cache a UV which
2523 may be later translated to an NV, and the resulting NV is not
2524 the translation of the initial data.
1c846c1f 2525
25da4f38
IZ
2526 This means that if we cache such a UV, we need to cache the
2527 NV as well. Moreover, we trade speed for space, and do not
2528 cache the NV if not needed.
2529 */
16b7a9a4 2530
c2988b20
NC
2531 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2532 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2533 == IS_NUMBER_IN_UV) {
5e045b90 2534 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8 2535 if (SvTYPE(sv) < SVt_PVIV)
f7bbb42a
JH
2536 sv_upgrade(sv, SVt_PVIV);
2537 (void)SvIOK_on(sv);
c2988b20
NC
2538 } else if (SvTYPE(sv) < SVt_PVNV)
2539 sv_upgrade(sv, SVt_PVNV);
d460ef45 2540
c2988b20
NC
2541 /* If NV preserves UV then we only use the UV value if we know that
2542 we aren't going to call atof() below. If NVs don't preserve UVs
2543 then the value returned may have more precision than atof() will
2544 return, even though it isn't accurate. */
2545 if ((numtype & (IS_NUMBER_IN_UV
2546#ifdef NV_PRESERVES_UV
2547 | IS_NUMBER_NOT_INT
2548#endif
2549 )) == IS_NUMBER_IN_UV) {
2550 /* This won't turn off the public IOK flag if it was set above */
2551 (void)SvIOKp_on(sv);
2552
2553 if (!(numtype & IS_NUMBER_NEG)) {
2554 /* positive */;
2555 if (value <= (UV)IV_MAX) {
45977657 2556 SvIV_set(sv, (IV)value);
28e5dec8
JH
2557 } else {
2558 /* it didn't overflow, and it was positive. */
607fa7f2 2559 SvUV_set(sv, value);
28e5dec8
JH
2560 SvIsUV_on(sv);
2561 }
c2988b20
NC
2562 } else {
2563 /* 2s complement assumption */
2564 if (value <= (UV)IV_MIN) {
45977657 2565 SvIV_set(sv, -(IV)value);
c2988b20
NC
2566 } else {
2567 /* Too negative for an IV. This is a double upgrade, but
d1be9408 2568 I'm assuming it will be rare. */
c2988b20
NC
2569 if (SvTYPE(sv) < SVt_PVNV)
2570 sv_upgrade(sv, SVt_PVNV);
2571 SvNOK_on(sv);
2572 SvIOK_off(sv);
2573 SvIOKp_on(sv);
9d6ce603 2574 SvNV_set(sv, -(NV)value);
45977657 2575 SvIV_set(sv, IV_MIN);
c2988b20
NC
2576 }
2577 }
2578 }
2579
2580 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2581 != IS_NUMBER_IN_UV) {
2582 /* It wasn't an integer, or it overflowed the UV. */
3f7c398e 2583 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8 2584
c2988b20 2585 if (! numtype && ckWARN(WARN_NUMERIC))
28e5dec8
JH
2586 not_a_number(sv);
2587
2588#if defined(USE_LONG_DOUBLE)
c2988b20
NC
2589 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2590 PTR2UV(sv), SvNVX(sv)));
28e5dec8 2591#else
1779d84d 2592 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
c2988b20 2593 PTR2UV(sv), SvNVX(sv)));
28e5dec8
JH
2594#endif
2595
2596#ifdef NV_PRESERVES_UV
c2988b20
NC
2597 (void)SvIOKp_on(sv);
2598 (void)SvNOK_on(sv);
2599 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2600 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2601 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2602 SvIOK_on(sv);
2603 } else {
2604 /* Integer is imprecise. NOK, IOKp */
2605 }
2606 /* UV will not work better than IV */
2607 } else {
2608 if (SvNVX(sv) > (NV)UV_MAX) {
2609 SvIsUV_on(sv);
2610 /* Integer is inaccurate. NOK, IOKp, is UV */
607fa7f2 2611 SvUV_set(sv, UV_MAX);
c2988b20
NC
2612 SvIsUV_on(sv);
2613 } else {
607fa7f2 2614 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2615 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2616 NV preservse UV so can do correct comparison. */
2617 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2618 SvIOK_on(sv);
2619 SvIsUV_on(sv);
2620 } else {
2621 /* Integer is imprecise. NOK, IOKp, is UV */
2622 SvIsUV_on(sv);
2623 }
2624 }
2625 }
28e5dec8 2626#else /* NV_PRESERVES_UV */
c2988b20
NC
2627 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2628 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2629 /* The UV slot will have been set from value returned by
2630 grok_number above. The NV slot has just been set using
2631 Atof. */
560b0c46 2632 SvNOK_on(sv);
c2988b20
NC
2633 assert (SvIOKp(sv));
2634 } else {
2635 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2636 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2637 /* Small enough to preserve all bits. */
2638 (void)SvIOKp_on(sv);
2639 SvNOK_on(sv);
45977657 2640 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2641 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2642 SvIOK_on(sv);
2643 /* Assumption: first non-preserved integer is < IV_MAX,
2644 this NV is in the preserved range, therefore: */
2645 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2646 < (UV)IV_MAX)) {
32fdb065 2647 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
2648 }
2649 } else
2650 sv_2iuv_non_preserve (sv, numtype);
2651 }
28e5dec8 2652#endif /* NV_PRESERVES_UV */
f7bbb42a 2653 }
ff68c719
PP
2654 }
2655 else {
d008e5eb 2656 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2657 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2658 report_uninit(sv);
c6ee37c5 2659 }
25da4f38
IZ
2660 if (SvTYPE(sv) < SVt_IV)
2661 /* Typically the caller expects that sv_any is not NULL now. */
2662 sv_upgrade(sv, SVt_IV);
ff68c719
PP
2663 return 0;
2664 }
25da4f38 2665
1d7c1841
GS
2666 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2667 PTR2UV(sv),SvUVX(sv)));
25da4f38 2668 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP
2669}
2670
645c22ef
DM
2671/*
2672=for apidoc sv_2nv
2673
2674Return the num value of an SV, doing any necessary string or integer
2675conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2676macros.
2677
2678=cut
2679*/
2680
65202027 2681NV
864dbfa3 2682Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW
2683{
2684 if (!sv)
2685 return 0.0;
8990e307 2686 if (SvGMAGICAL(sv)) {
463ee0b2
LW
2687 mg_get(sv);
2688 if (SvNOKp(sv))
2689 return SvNVX(sv);
a0d0e21e 2690 if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2691 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
504618e9 2692 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
a0d0e21e 2693 not_a_number(sv);
3f7c398e 2694 return Atof(SvPVX_const(sv));
a0d0e21e 2695 }
25da4f38 2696 if (SvIOKp(sv)) {
1c846c1f 2697 if (SvIsUV(sv))
65202027 2698 return (NV)SvUVX(sv);
25da4f38 2699 else
65202027 2700 return (NV)SvIVX(sv);
25da4f38 2701 }
16d20bd9 2702 if (!SvROK(sv)) {
d008e5eb 2703 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2704 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2705 report_uninit(sv);
c6ee37c5 2706 }
66a1b24b 2707 return (NV)0;
16d20bd9 2708 }
463ee0b2 2709 }
ed6116ce 2710 if (SvTHINKFIRST(sv)) {
a0d0e21e 2711 if (SvROK(sv)) {
a0d0e21e 2712 SV* tmpstr;
1554e226 2713 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2714 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2715 return SvNV(tmpstr);
56431972 2716 return PTR2NV(SvRV(sv));
a0d0e21e 2717 }
765f542d
NC
2718 if (SvIsCOW(sv)) {
2719 sv_force_normal_flags(sv, 0);
8a818333 2720 }
0336b60e 2721 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 2722 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2723 report_uninit(sv);
ed6116ce
LW
2724 return 0.0;
2725 }
79072805
LW
2726 }
2727 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW
2728 if (SvTYPE(sv) == SVt_IV)
2729 sv_upgrade(sv, SVt_PVNV);
2730 else
2731 sv_upgrade(sv, SVt_NV);
906f284f 2732#ifdef USE_LONG_DOUBLE
097ee67d 2733 DEBUG_c({
f93f4e46 2734 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
2735 PerlIO_printf(Perl_debug_log,
2736 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2737 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
2738 RESTORE_NUMERIC_LOCAL();
2739 });
65202027 2740#else
572bbb43 2741 DEBUG_c({
f93f4e46 2742 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 2743 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
1d7c1841 2744 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
2745 RESTORE_NUMERIC_LOCAL();
2746 });
572bbb43 2747#endif
79072805
LW
2748 }
2749 else if (SvTYPE(sv) < SVt_PVNV)
2750 sv_upgrade(sv, SVt_PVNV);
59d8ce62
NC
2751 if (SvNOKp(sv)) {
2752 return SvNVX(sv);
61604483 2753 }
59d8ce62 2754 if (SvIOKp(sv)) {
9d6ce603 2755 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
28e5dec8
JH
2756#ifdef NV_PRESERVES_UV
2757 SvNOK_on(sv);
2758#else
2759 /* Only set the public NV OK flag if this NV preserves the IV */
2760 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2761 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2762 : (SvIVX(sv) == I_V(SvNVX(sv))))
2763 SvNOK_on(sv);
2764 else
2765 SvNOKp_on(sv);
2766#endif
93a17b20 2767 }
748a9306 2768 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2769 UV value;
3f7c398e 2770 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
c2988b20 2771 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
a0d0e21e 2772 not_a_number(sv);
28e5dec8 2773#ifdef NV_PRESERVES_UV
c2988b20
NC
2774 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2775 == IS_NUMBER_IN_UV) {
5e045b90 2776 /* It's definitely an integer */
9d6ce603 2777 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
c2988b20 2778 } else
3f7c398e 2779 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8
JH
2780 SvNOK_on(sv);
2781#else
3f7c398e 2782 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8
JH
2783 /* Only set the public NV OK flag if this NV preserves the value in
2784 the PV at least as well as an IV/UV would.
2785 Not sure how to do this 100% reliably. */
2786 /* if that shift count is out of range then Configure's test is
2787 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2788 UV_BITS */
2789 if (((UV)1 << NV_PRESERVES_UV_BITS) >
c2988b20 2790 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
28e5dec8 2791 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
c2988b20
NC
2792 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2793 /* Can't use strtol etc to convert this string, so don't try.
2794 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2795 SvNOK_on(sv);
2796 } else {
2797 /* value has been set. It may not be precise. */
2798 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2799 /* 2s complement assumption for (UV)IV_MIN */
2800 SvNOK_on(sv); /* Integer is too negative. */
2801 } else {
2802 SvNOKp_on(sv);
2803 SvIOKp_on(sv);
6fa402ec 2804
c2988b20 2805 if (numtype & IS_NUMBER_NEG) {
45977657 2806 SvIV_set(sv, -(IV)value);
c2988b20 2807 } else if (value <= (UV)IV_MAX) {
45977657 2808 SvIV_set(sv, (IV)value);
c2988b20 2809 } else {
607fa7f2 2810 SvUV_set(sv, value);
c2988b20
NC
2811 SvIsUV_on(sv);
2812 }
2813
2814 if (numtype & IS_NUMBER_NOT_INT) {
2815 /* I believe that even if the original PV had decimals,
2816 they are lost beyond the limit of the FP precision.
2817 However, neither is canonical, so both only get p
2818 flags. NWC, 2000/11/25 */
2819 /* Both already have p flags, so do nothing */
2820 } else {
66a1b24b 2821 const NV nv = SvNVX(sv);
c2988b20
NC
2822 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2823 if (SvIVX(sv) == I_V(nv)) {
2824 SvNOK_on(sv);
2825 SvIOK_on(sv);
2826 } else {
2827 SvIOK_on(sv);
2828 /* It had no "." so it must be integer. */
2829 }
2830 } else {
2831 /* between IV_MAX and NV(UV_MAX).
2832 Could be slightly > UV_MAX */
6fa402ec 2833
c2988b20
NC
2834 if (numtype & IS_NUMBER_NOT_INT) {
2835 /* UV and NV both imprecise. */
2836 } else {
66a1b24b 2837 const UV nv_as_uv = U_V(nv);
c2988b20
NC
2838
2839 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2840 SvNOK_on(sv);
2841 SvIOK_on(sv);
2842 } else {
2843 SvIOK_on(sv);
2844 }
2845 }
2846 }
2847 }
2848 }
2849 }
28e5dec8 2850#endif /* NV_PRESERVES_UV */
93a17b20 2851 }
79072805 2852 else {
599cee73 2853 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 2854 report_uninit(sv);
25da4f38
IZ
2855 if (SvTYPE(sv) < SVt_NV)
2856 /* Typically the caller expects that sv_any is not NULL now. */
28e5dec8
JH
2857 /* XXX Ilya implies that this is a bug in callers that assume this
2858 and ideally should be fixed. */
25da4f38 2859 sv_upgrade(sv, SVt_NV);
a0d0e21e 2860 return 0.0;
79072805 2861 }
572bbb43 2862#if defined(USE_LONG_DOUBLE)
097ee67d 2863 DEBUG_c({
f93f4e46 2864 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
2865 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2866 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
2867 RESTORE_NUMERIC_LOCAL();
2868 });
65202027 2869#else
572bbb43 2870 DEBUG_c({
f93f4e46 2871 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 2872 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
1d7c1841 2873 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
2874 RESTORE_NUMERIC_LOCAL();
2875 });
572bbb43 2876#endif
463ee0b2 2877 return SvNVX(sv);
79072805
LW
2878}
2879
645c22ef
DM
2880/* asIV(): extract an integer from the string value of an SV.
2881 * Caller must validate PVX */
2882
76e3520e 2883STATIC IV
cea2e8a9 2884S_asIV(pTHX_ SV *sv)
36477c24 2885{
c2988b20 2886 UV value;
66a1b24b 2887 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
c2988b20
NC
2888
2889 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2890 == IS_NUMBER_IN_UV) {
645c22ef 2891 /* It's definitely an integer */
c2988b20
NC
2892 if (numtype & IS_NUMBER_NEG) {
2893 if (value < (UV)IV_MIN)
2894 return -(IV)value;
2895 } else {
2896 if (value < (UV)IV_MAX)
2897 return (IV)value;
2898 }
2899 }
d008e5eb 2900 if (!numtype) {
d008e5eb
GS
2901 if (ckWARN(WARN_NUMERIC))
2902 not_a_number(sv);
2903 }
3f7c398e 2904 return I_V(Atof(SvPVX_const(sv)));
36477c24
PP
2905}
2906
645c22ef
DM
2907/* asUV(): extract an unsigned integer from the string value of an SV
2908 * Caller must validate PVX */
2909
76e3520e 2910STATIC UV
cea2e8a9 2911S_asUV(pTHX_ SV *sv)
36477c24 2912{
c2988b20 2913 UV value;
504618e9 2914 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
36477c24 2915
c2988b20
NC
2916 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2917 == IS_NUMBER_IN_UV) {
645c22ef 2918 /* It's definitely an integer */
6fa402ec 2919 if (!(numtype & IS_NUMBER_NEG))
c2988b20
NC
2920 return value;
2921 }
d008e5eb 2922 if (!numtype) {
d008e5eb
GS
2923 if (ckWARN(WARN_NUMERIC))
2924 not_a_number(sv);
2925 }
3f7c398e 2926 return U_V(Atof(SvPVX_const(sv)));
36477c24
PP
2927}
2928
645c22ef
DM
2929/*
2930=for apidoc sv_2pv_nolen
2931
2932Like C<sv_2pv()>, but doesn't return the length too. You should usually
2933use the macro wrapper C<SvPV_nolen(sv)> instead.
2934=cut
2935*/
2936
79072805 2937char *
864dbfa3 2938Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d 2939{
dafda6d1 2940 return sv_2pv(sv, 0);
1fa8b10d
JD
2941}
2942
645c22ef
DM
2943/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2944 * UV as a string towards the end of buf, and return pointers to start and
2945 * end of it.
2946 *
2947 * We assume that buf is at least TYPE_CHARS(UV) long.
2948 */
2949
864dbfa3 2950static char *
25da4f38
IZ
2951uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2952{
25da4f38
IZ
2953 char *ptr = buf + TYPE_CHARS(UV);
2954 char *ebuf = ptr;
2955 int sign;
25da4f38
IZ
2956
2957 if (is_uv)
2958 sign = 0;
2959 else if (iv >= 0) {
2960 uv = iv;
2961 sign = 0;
2962 } else {
2963 uv = -iv;
2964 sign = 1;
2965 }
2966 do {
eb160463 2967 *--ptr = '0' + (char)(uv % 10);
25da4f38
IZ
2968 } while (uv /= 10);
2969 if (sign)
2970 *--ptr = '-';
2971 *peob = ebuf;
2972 return ptr;
2973}
2974
09540bc3
JH
2975/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2976 * this function provided for binary compatibility only
2977 */
2978
2979char *
2980Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2981{
2982 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2983}
2984
645c22ef
DM
2985/*
2986=for apidoc sv_2pv_flags
2987
ff276b08 2988Returns a pointer to the string value of an SV, and sets *lp to its length.
645c22ef
DM
2989If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2990if necessary.
2991Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2992usually end up here too.
2993
2994=cut
2995*/
2996
8d6d96c1
HS
2997char *
2998Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2999{
79072805
LW
3000 register char *s;
3001 int olderrno;
cb50f42d 3002 SV *tsv, *origsv;
25da4f38
IZ
3003 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3004 char *tmpbuf = tbuf;
79072805 3005
463ee0b2 3006 if (!sv) {
cdb061a3
NC
3007 if (lp)
3008 *lp = 0;
73d840c0 3009 return (char *)"";
463ee0b2 3010 }
8990e307 3011 if (SvGMAGICAL(sv)) {
8d6d96c1
HS
3012 if (flags & SV_GMAGIC)
3013 mg_get(sv);
463ee0b2 3014 if (SvPOKp(sv)) {
cdb061a3
NC
3015 if (lp)
3016 *lp = SvCUR(sv);
10516c54
NC
3017 if (flags & SV_MUTABLE_RETURN)
3018 return SvPVX_mutable(sv);
4d84ee25
NC
3019 if (flags & SV_CONST_RETURN)
3020 return (char *)SvPVX_const(sv);
463ee0b2
LW
3021 return SvPVX(sv);
3022 }
cf2093f6 3023 if (SvIOKp(sv)) {
1c846c1f 3024 if (SvIsUV(sv))
57def98f 3025 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 3026 else
57def98f 3027 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 3028 tsv = Nullsv;
a0d0e21e 3029 goto tokensave;
463ee0b2
LW
3030 }
3031 if (SvNOKp(sv)) {
2d4389e4 3032 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 3033 tsv = Nullsv;
a0d0e21e 3034 goto tokensave;
463ee0b2 3035 }
16d20bd9 3036 if (!SvROK(sv)) {
d008e5eb 3037 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3038 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3039 report_uninit(sv);
c6ee37c5 3040 }
cdb061a3
NC
3041 if (lp)
3042 *lp = 0;
73d840c0 3043 return (char *)"";
16d20bd9 3044 }
463ee0b2 3045 }
ed6116ce
LW
3046 if (SvTHINKFIRST(sv)) {
3047 if (SvROK(sv)) {
a0d0e21e 3048 SV* tmpstr;
e1ec3a88 3049 register const char *typestr;
1554e226 3050 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
b4b9a328 3051 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
50adf7d2
NC
3052 /* Unwrap this: */
3053 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3054
3055 char *pv;
3056 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3057 if (flags & SV_CONST_RETURN) {
3058 pv = (char *) SvPVX_const(tmpstr);
3059 } else {
3060 pv = (flags & SV_MUTABLE_RETURN)
3061 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3062 }
3063 if (lp)
3064 *lp = SvCUR(tmpstr);
3065 } else {
3066 pv = sv_2pv_flags(tmpstr, lp, flags);
3067 }
446eaa42
YST
3068 if (SvUTF8(tmpstr))
3069 SvUTF8_on(sv);
3070 else
3071 SvUTF8_off(sv);
3072 return pv;
3073 }
cb50f42d 3074 origsv = sv;
ed6116ce
LW
3075 sv = (SV*)SvRV(sv);
3076 if (!sv)
e1ec3a88 3077 typestr = "NULLREF";
ed6116ce 3078 else {
f9277f47
IZ
3079 MAGIC *mg;
3080
ed6116ce 3081 switch (SvTYPE(sv)) {
f9277f47
IZ
3082 case SVt_PVMG:
3083 if ( ((SvFLAGS(sv) &
1c846c1f 3084 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
faf82a0b 3085 == (SVs_OBJECT|SVs_SMG))
14befaf4 3086 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
e1ec3a88 3087 const regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 3088
2cd61cdb 3089 if (!mg->mg_ptr) {
e1ec3a88 3090 const char *fptr = "msix";
8782bef2
GB
3091 char reflags[6];
3092 char ch;
3093 int left = 0;
3094 int right = 4;
ff385a1b 3095 char need_newline = 0;
eb160463 3096 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
8782bef2 3097
155aba94 3098 while((ch = *fptr++)) {
8782bef2
GB
3099 if(reganch & 1) {
3100 reflags[left++] = ch;
3101 }
3102 else {
3103 reflags[right--] = ch;
3104 }
3105 reganch >>= 1;
3106 }
3107 if(left != 4) {
3108 reflags[left] = '-';
3109 left = 5;
3110 }
3111
3112 mg->mg_len = re->prelen + 4 + left;
ff385a1b
JF
3113 /*
3114 * If /x was used, we have to worry about a regex
3115 * ending with a comment later being embedded
3116 * within another regex. If so, we don't want this
3117 * regex's "commentization" to leak out to the
3118 * right part of the enclosing regex, we must cap
3119 * it with a newline.
3120 *
3121 * So, if /x was used, we scan backwards from the
3122 * end of the regex. If we find a '#' before we
3123 * find a newline, we need to add a newline
3124 * ourself. If we find a '\n' first (or if we
3125 * don't find '#' or '\n'), we don't need to add
3126 * anything. -jfriedl
3127 */
3128 if (PMf_EXTENDED & re->reganch)
3129 {
e1ec3a88 3130 const char *endptr = re->precomp + re->prelen;
ff385a1b
JF
3131 while (endptr >= re->precomp)
3132 {
e1ec3a88 3133 const char c = *(endptr--);
ff385a1b
JF
3134 if (c == '\n')
3135 break; /* don't need another */
3136 if (c == '#') {
3137 /* we end while in a comment, so we
3138 need a newline */
3139 mg->mg_len++; /* save space for it */
3140 need_newline = 1; /* note to add it */
ab01544f 3141 break;
ff385a1b
JF
3142 }
3143 }
3144 }
3145
8782bef2
GB
3146 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3147 Copy("(?", mg->mg_ptr, 2, char);
3148 Copy(reflags, mg->mg_ptr+2, left, char);
3149 Copy(":", mg->mg_ptr+left+2, 1, char);
3150 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
ff385a1b
JF
3151 if (need_newline)
3152 mg->mg_ptr[mg->mg_len - 2] = '\n';
1bd3ad17
IZ
3153 mg->mg_ptr[mg->mg_len - 1] = ')';
3154 mg->mg_ptr[mg->mg_len] = 0;
3155 }
3280af22 3156 PL_reginterp_cnt += re->program[0].next_off;
cb50f42d
YST
3157
3158 if (re->reganch & ROPT_UTF8)
3159 SvUTF8_on(origsv);
3160 else
3161 SvUTF8_off(origsv);
cdb061a3
NC
3162 if (lp)
3163 *lp = mg->mg_len;
1bd3ad17 3164 return mg->mg_ptr;
f9277f47
IZ
3165 }
3166 /* Fall through */
ed6116ce
LW
3167 case SVt_NULL:
3168 case SVt_IV:
3169 case SVt_NV:
3170 case SVt_RV:
3171 case SVt_PV:
3172 case SVt_PVIV:
3173 case SVt_PVNV:
e1ec3a88
AL
3174 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3175 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
be65207d
DM
3176 /* tied lvalues should appear to be
3177 * scalars for backwards compatitbility */
3178 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3179 ? "SCALAR" : "LVALUE"; break;
e1ec3a88
AL
3180 case SVt_PVAV: typestr = "ARRAY"; break;
3181 case SVt_PVHV: typestr = "HASH"; break;
3182 case SVt_PVCV: typestr = "CODE"; break;
3183 case SVt_PVGV: typestr = "GLOB"; break;
3184 case SVt_PVFM: typestr = "FORMAT"; break;
3185 case SVt_PVIO: typestr = "IO"; break;
3186 default: typestr = "UNKNOWN"; break;
ed6116ce 3187 }
46fc3d4c 3188 tsv = NEWSV(0,0);
a5cb6b62 3189 if (SvOBJECT(sv)) {
bfcb3514 3190 const char *name = HvNAME_get(SvSTASH(sv));
a5cb6b62 3191 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
e1ec3a88 3192 name ? name : "__ANON__" , typestr, PTR2UV(sv));
a5cb6b62 3193 }
ed6116ce 3194 else
e1ec3a88 3195 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
a0d0e21e 3196 goto tokensaveref;
463ee0b2 3197 }
cdb061a3
NC
3198 if (lp)
3199 *lp = strlen(typestr);
73d840c0 3200 return (char *)typestr;
79072805 3201 }
0336b60e 3202 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 3203 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 3204 report_uninit(sv);
cdb061a3
NC
3205 if (lp)
3206 *lp = 0;
73d840c0 3207 return (char *)"";
79072805 3208 }
79072805 3209 }
28e5dec8
JH
3210 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3211 /* I'm assuming that if both IV and NV are equally valid then
3212 converting the IV is going to be more efficient */
e1ec3a88
AL
3213 const U32 isIOK = SvIOK(sv);
3214 const U32 isUIOK = SvIsUV(sv);
28e5dec8
JH
3215 char buf[TYPE_CHARS(UV)];
3216 char *ebuf, *ptr;
3217
3218 if (SvTYPE(sv) < SVt_PVIV)
3219 sv_upgrade(sv, SVt_PVIV);
3220 if (isUIOK)
3221 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3222 else
3223 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
5902b6a9
NC
3224 /* inlined from sv_setpvn */
3225 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
4d84ee25 3226 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
28e5dec8
JH
3227 SvCUR_set(sv, ebuf - ptr);
3228 s = SvEND(sv);
3229 *s = '\0';
3230 if (isIOK)
3231 SvIOK_on(sv);
3232 else
3233 SvIOKp_on(sv);
3234 if (isUIOK)
3235 SvIsUV_on(sv);
3236 }
3237 else if (SvNOKp(sv)) {
79072805
LW
3238 if (SvTYPE(sv) < SVt_PVNV)
3239 sv_upgrade(sv, SVt_PVNV);
1c846c1f 3240 /* The +20 is pure guesswork. Configure test needed. --jhi */
5902b6a9 3241 s = SvGROW_mutable(sv, NV_DIG + 20);
79072805 3242 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 3243#ifdef apollo
463ee0b2 3244 if (SvNVX(sv) == 0.0)
79072805
LW
3245 (void)strcpy(s,"0");
3246 else
3247#endif /*apollo*/
bbce6d69 3248 {
2d4389e4 3249 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 3250 }
79072805 3251 errno = olderrno;
a0d0e21e
LW
3252#ifdef FIXNEGATIVEZERO
3253 if (*s == '-' && s[1] == '0' && !s[2])
3254 strcpy(s,"0");
3255#endif
79072805
LW
3256 while (*s) s++;
3257#ifdef hcx
3258 if (s[-1] == '.')
46fc3d4c 3259 *--s = '\0';
79072805
LW
3260#endif
3261 }
79072805 3262 else {
0336b60e
IZ
3263 if (ckWARN(WARN_UNINITIALIZED)
3264 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 3265 report_uninit(sv);
cdb061a3 3266 if (lp)
a0d0e21e 3267 *lp = 0;
25da4f38
IZ
3268 if (SvTYPE(sv) < SVt_PV)
3269 /* Typically the caller expects that sv_any is not NULL now. */
3270 sv_upgrade(sv, SVt_PV);
73d840c0 3271 return (char *)"";
79072805 3272 }
cdb061a3
NC
3273 {
3274 STRLEN len = s - SvPVX_const(sv);
3275 if (lp)
3276 *lp = len;
3277 SvCUR_set(sv, len);
3278 }
79072805 3279 SvPOK_on(sv);
1d7c1841 3280 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3f7c398e 3281 PTR2UV(sv),SvPVX_const(sv)));
4d84ee25
NC
3282 if (flags & SV_CONST_RETURN)
3283 return (char *)SvPVX_const(sv);
10516c54
NC
3284 if (flags & SV_MUTABLE_RETURN)
3285 return SvPVX_mutable(sv);
463ee0b2 3286 return SvPVX(sv);
a0d0e21e
LW
3287
3288 tokensave:
3289 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3290 /* Sneaky stuff here */
3291
3292 tokensaveref:
46fc3d4c 3293 if (!tsv)
96827780 3294 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 3295 sv_2mortal(tsv);
cdb061a3
NC
3296 if (lp)
3297 *lp = SvCUR(tsv);
46fc3d4c 3298 return SvPVX(tsv);
a0d0e21e
LW
3299 }
3300 else {
27da23d5 3301 dVAR;
a0d0e21e 3302 STRLEN len;
73d840c0 3303 const char *t;
46fc3d4c
PP
3304
3305 if (tsv) {
3306 sv_2mortal(tsv);
3f7c398e 3307 t = SvPVX_const(tsv);
46fc3d4c
PP
3308 len = SvCUR(tsv);
3309 }
3310 else {
96827780
MB
3311 t = tmpbuf;
3312 len = strlen(tmpbuf);
46fc3d4c 3313 }
a0d0e21e 3314#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
3315 if (len == 2 && t[0] == '-' && t[1] == '0') {
3316 t = "0";
3317 len = 1;
3318 }
a0d0e21e 3319#endif
862a34c6 3320 SvUPGRADE(sv, SVt_PV);
cdb061a3
NC
3321 if (lp)
3322 *lp = len;
5902b6a9 3323 s = SvGROW_mutable(sv, len + 1);
a0d0e21e 3324 SvCUR_set(sv, len);
6bf554b4 3325 SvPOKp_on(sv);
e90e2364 3326 return strcpy(s, t);
a0d0e21e 3327 }
463ee0b2
LW
3328}
3329
645c22ef 3330/*
6050d10e
JP
3331=for apidoc sv_copypv
3332
3333Copies a stringified representation of the source SV into the
3334destination SV. Automatically performs any necessary mg_get and
54f0641b 3335coercion of numeric values into strings. Guaranteed to preserve
6050d10e 3336UTF-8 flag even from overloaded objects. Similar in nature to
54f0641b
NIS
3337sv_2pv[_flags] but operates directly on an SV instead of just the
3338string. Mostly uses sv_2pv_flags to do its work, except when that
6050d10e
JP
3339would lose the UTF-8'ness of the PV.
3340
3341=cut
3342*/
3343
3344void
3345Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3346{
446eaa42 3347 STRLEN len;
4d84ee25
NC
3348 const char *s;
3349 s = SvPV_const(ssv,len);
cb50f42d 3350 sv_setpvn(dsv,s,len);
446eaa42 3351 if (SvUTF8(ssv))
cb50f42d 3352 SvUTF8_on(dsv);
446eaa42 3353 else
cb50f42d 3354 SvUTF8_off(dsv);
6050d10e
JP
3355}
3356
3357/*
645c22ef
DM
3358=for apidoc sv_2pvbyte_nolen
3359
3360Return a pointer to the byte-encoded representation of the SV.
1e54db1a 3361May cause the SV to be downgraded from UTF-8 as a side-effect.
645c22ef
DM
3362
3363Usually accessed via the C<SvPVbyte_nolen> macro.
3364
3365=cut
3366*/
3367
7340a771
GS
3368char *
3369Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3370{
dafda6d1 3371 return sv_2pvbyte(sv, 0);
7340a771
GS
3372}
3373
645c22ef
DM
3374/*
3375=for apidoc sv_2pvbyte
3376
3377Return a pointer to the byte-encoded representation of the SV, and set *lp
1e54db1a 3378to its length. May cause the SV to be downgraded from UTF-8 as a
645c22ef
DM
3379side-effect.
3380
3381Usually accessed via the C<SvPVbyte> macro.
3382
3383=cut
3384*/
3385
7340a771
GS
3386char *
3387Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3388{
0875d2fe 3389 sv_utf8_downgrade(sv,0);
97972285 3390 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
7340a771
GS
3391}
3392
645c22ef
DM
3393/*
3394=for apidoc sv_2pvutf8_nolen
3395
1e54db1a
JH
3396Return a pointer to the UTF-8-encoded representation of the SV.
3397May cause the SV to be upgraded to UTF-8 as a side-effect.
645c22ef
DM
3398
3399Usually accessed via the C<SvPVutf8_nolen> macro.
3400
3401=cut
3402*/
3403
7340a771
GS
3404char *
3405Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3406{
dafda6d1 3407 return sv_2pvutf8(sv, 0);
7340a771
GS
3408}
3409
645c22ef
DM
3410/*
3411=for apidoc sv_2pvutf8
3412
1e54db1a
JH
3413Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3414to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
645c22ef
DM
3415
3416Usually accessed via the C<SvPVutf8> macro.
3417
3418=cut
3419*/
3420
7340a771
GS
3421char *
3422Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3423{
560a288e 3424 sv_utf8_upgrade(sv);
7d59b7e4 3425 return SvPV(sv,*lp);
7340a771 3426}
1c846c1f 3427
645c22ef
DM
3428/*
3429=for apidoc sv_2bool
3430
3431This function is only called on magical items, and is only used by
8cf8f3d1 3432sv_true() or its macro equivalent.
645c22ef
DM
3433
3434=cut
3435*/
3436
463ee0b2 3437bool
864dbfa3 3438Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 3439{
8990e307 3440 if (SvGMAGICAL(sv))
463ee0b2
LW
3441 mg_get(sv);
3442
a0d0e21e
LW
3443 if (!SvOK(sv))
3444 return 0;
3445 if (SvROK(sv)) {
a0d0e21e 3446 SV* tmpsv;
1554e226 3447 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
9e3013b1 3448 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
8a31060d 3449 return (bool)SvTRUE(tmpsv);
a0d0e21e
LW
3450 return SvRV(sv) != 0;
3451 }
463ee0b2 3452 if (SvPOKp(sv)) {
11343788
MB
3453 register XPV* Xpvtmp;
3454 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
339049b0 3455 (*sv->sv_u.svu_pv > '0' ||
11343788 3456 Xpvtmp->xpv_cur > 1 ||
339049b0 3457 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
463ee0b2
LW
3458 return 1;
3459 else
3460 return 0;
3461 }
3462 else {
3463 if (SvIOKp(sv))
3464 return SvIVX(sv) != 0;
3465 else {
3466 if (SvNOKp(sv))
3467 return SvNVX(sv) != 0.0;
3468 else
3469 return FALSE;
3470 }
3471 }
79072805
LW
3472}
3473
09540bc3
JH
3474/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3475 * this function provided for binary compatibility only
3476 */
3477
3478
3479STRLEN
3480Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3481{
3482 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3483}
3484
c461cf8f
JH
3485/*
3486=for apidoc sv_utf8_upgrade
3487
78ea37eb 3488Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3489Forces the SV to string form if it is not already.
4411f3b6
NIS
3490Always sets the SvUTF8 flag to avoid future validity checks even
3491if all the bytes have hibit clear.
c461cf8f 3492
13a6c0e0
JH
3493This is not as a general purpose byte encoding to Unicode interface:
3494use the Encode extension for that.
3495
8d6d96c1
HS
3496=for apidoc sv_utf8_upgrade_flags
3497
78ea37eb 3498Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3499Forces the SV to string form if it is not already.
8d6d96c1
HS
3500Always sets the SvUTF8 flag to avoid future validity checks even
3501if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3502will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3503C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3504
13a6c0e0
JH
3505This is not as a general purpose byte encoding to Unicode interface:
3506use the Encode extension for that.
3507
8d6d96c1
HS
3508=cut
3509*/
3510
3511STRLEN
3512Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3513{
808c356f
RGS
3514 if (sv == &PL_sv_undef)
3515 return 0;
e0e62c2a
NIS
3516 if (!SvPOK(sv)) {
3517 STRLEN len = 0;
d52b7888
NC
3518 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3519 (void) sv_2pv_flags(sv,&len, flags);
3520 if (SvUTF8(sv))
3521 return len;
3522 } else {
3523 (void) SvPV_force(sv,len);
3524 }
e0e62c2a 3525 }
4411f3b6 3526
f5cee72b 3527 if (SvUTF8(sv)) {
5fec3b1d 3528 return SvCUR(sv);
f5cee72b 3529 }
5fec3b1d 3530
765f542d
NC
3531 if (SvIsCOW(sv)) {
3532 sv_force_normal_flags(sv, 0);
db42d148
NIS
3533 }
3534
88632417 3535 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
799ef3cb 3536 sv_recode_to_utf8(sv, PL_encoding);
9f4817db 3537 else { /* Assume Latin-1/EBCDIC */
c4e7c712
NC
3538 /* This function could be much more efficient if we
3539 * had a FLAG in SVs to signal if there are any hibit
3540 * chars in the PV. Given that there isn't such a flag
3541 * make the loop as fast as possible. */
93524f2b
NC
3542 const U8 *s = (U8 *) SvPVX_const(sv);
3543 const U8 *e = (U8 *) SvEND(sv);
3544 const U8 *t = s;
c4e7c712
NC
3545 int hibit = 0;
3546
3547 while (t < e) {
3548 U8 ch = *t++;
3549 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3550 break;
3551 }
3552 if (hibit) {
3553 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
1e2ebb21 3554 U8 *recoded = bytes_to_utf8((U8*)s, &len);
c4e7c712
NC
3555
3556 SvPV_free(sv); /* No longer using what was there before. */
3557
1e2ebb21 3558 SvPV_set(sv, (char*)recoded);
c4e7c712
NC
3559 SvCUR_set(sv, len - 1);
3560 SvLEN_set(sv, len); /* No longer know the real size. */
3561 }
3562 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3563 SvUTF8_on(sv);
560a288e 3564 }
4411f3b6 3565 return SvCUR(sv);
560a288e
GS
3566}
3567
c461cf8f
JH
3568/*
3569=for apidoc sv_utf8_downgrade
3570
78ea37eb
ST
3571Attempts to convert the PV of an SV from characters to bytes.
3572If the PV contains a character beyond byte, this conversion will fail;
3573in this case, either returns false or, if C<fail_ok> is not
c461cf8f
JH
3574true, croaks.
3575
13a6c0e0
JH
3576This is not as a general purpose Unicode to byte encoding interface:
3577use the Encode extension for that.
3578
c461cf8f
JH
3579=cut
3580*/
3581
560a288e
GS
3582bool
3583Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3584{
78ea37eb 3585 if (SvPOKp(sv) && SvUTF8(sv)) {
fa301091 3586 if (SvCUR(sv)) {
03cfe0ae 3587 U8 *s;
652088fc 3588 STRLEN len;
fa301091 3589
765f542d
NC
3590 if (SvIsCOW(sv)) {
3591 sv_force_normal_flags(sv, 0);
3592 }
03cfe0ae
NIS
3593 s = (U8 *) SvPV(sv, len);
3594 if (!utf8_to_bytes(s, &len)) {
fa301091
JH
3595 if (fail_ok)
3596 return FALSE;
3597 else {
3598 if (PL_op)
3599 Perl_croak(aTHX_ "Wide character in %s",
53e06cf0 3600 OP_DESC(PL_op));
fa301091
JH
3601 else
3602 Perl_croak(aTHX_ "Wide character");
3603 }
4b3603a4 3604 }
b162af07 3605 SvCUR_set(sv, len);
67e989fb 3606 }
560a288e 3607 }
ffebcc3e 3608 SvUTF8_off(sv);
560a288e
GS
3609 return TRUE;
3610}
3611
c461cf8f
JH
3612/*
3613=for apidoc sv_utf8_encode
3614
78ea37eb
ST
3615Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3616flag off so that it looks like octets again.
c461cf8f
JH
3617
3618=cut
3619*/
3620
560a288e
GS
3621void
3622Perl_sv_utf8_encode(pTHX_ register SV *sv)
3623{
4411f3b6 3624 (void) sv_utf8_upgrade(sv);
4c94c214
NC
3625 if (SvIsCOW(sv)) {
3626 sv_force_normal_flags(sv, 0);
3627 }
3628 if (SvREADONLY(sv)) {
3629 Perl_croak(aTHX_ PL_no_modify);
3630 }
560a288e
GS
3631 SvUTF8_off(sv);
3632}
3633
4411f3b6
NIS
3634/*
3635=for apidoc sv_utf8_decode
3636
78ea37eb
ST
3637If the PV of the SV is an octet sequence in UTF-8
3638and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3639so that it looks like a character. If the PV contains only single-byte
3640characters, the C<SvUTF8> flag stays being off.
3641Scans PV for validity and returns false if the PV is invalid UTF-8.
4411f3b6
NIS
3642
3643=cut
3644*/
3645
560a288e
GS
3646bool
3647Perl_sv_utf8_decode(pTHX_ register SV *sv)
3648{
78ea37eb 3649 if (SvPOKp(sv)) {
93524f2b
NC
3650 const U8 *c;
3651 const U8 *e;
9cbac4c7 3652
645c22ef
DM
3653 /* The octets may have got themselves encoded - get them back as
3654 * bytes
3655 */
3656 if (!sv_utf8_downgrade(sv, TRUE))
560a288e
GS
3657 return FALSE;
3658
3659 /* it is actually just a matter of turning the utf8 flag on, but
3660 * we want to make sure everything inside is valid utf8 first.
3661 */
93524f2b 3662 c = (const U8 *) SvPVX_const(sv);
63cd0674 3663 if (!is_utf8_string(c, SvCUR(sv)+1))
67e989fb 3664 return FALSE;
93524f2b 3665 e = (const U8 *) SvEND(sv);
511c2ff0 3666 while (c < e) {
c4d5f83a
NIS
3667 U8 ch = *c++;
3668 if (!UTF8_IS_INVARIANT(ch)) {
67e989fb
JH
3669 SvUTF8_on(sv);
3670 break;
3671 }
560a288e 3672 }
560a288e
GS
3673 }
3674 return TRUE;
3675}
3676
09540bc3
JH
3677/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3678 * this function provided for binary compatibility only
3679 */
3680
3681void
3682Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3683{
3684 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3685}
3686
954c1994
GS
3687/*
3688=for apidoc sv_setsv
3689
645c22ef
DM
3690Copies the contents of the source SV C<ssv> into the destination SV
3691C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3692function if the source SV needs to be reused. Does not handle 'set' magic.
3693Loosely speaking, it performs a copy-by-value, obliterating any previous
3694content of the destination.
3695
3696You probably want to use one of the assortment of wrappers, such as
3697C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3698C<SvSetMagicSV_nosteal>.
3699
8d6d96c1
HS
3700=for apidoc sv_setsv_flags
3701
645c22ef
DM
3702Copies the contents of the source SV C<ssv> into the destination SV
3703C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3704function if the source SV needs to be reused. Does not handle 'set' magic.
3705Loosely speaking, it performs a copy-by-value, obliterating any previous
3706content of the destination.
3707If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
5fcdf167
NC
3708C<ssv> if appropriate, else not. If the C<flags> parameter has the
3709C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3710and C<sv_setsv_nomg> are implemented in terms of this function.
645c22ef
DM
3711
3712You probably want to use one of the assortment of wrappers, such as
3713C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3714C<SvSetMagicSV_nosteal>.
3715
3716This is the primary function for copying scalars, and most other
3717copy-ish functions and macros use this underneath.
8d6d96c1
HS
3718
3719=cut
3720*/
3721
3722void
3723Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3724{
8990e307
LW
3725 register U32 sflags;
3726 register int dtype;
3727 register int stype;
463ee0b2 3728
79072805
LW
3729 if (sstr == dstr)
3730 return;
765f542d 3731 SV_CHECK_THINKFIRST_COW_DROP(dstr);
79072805 3732 if (!sstr)
3280af22 3733 sstr = &PL_sv_undef;
8990e307
LW
3734 stype = SvTYPE(sstr);
3735 dtype = SvTYPE(dstr);
79072805 3736
a0d0e21e 3737 SvAMAGIC_off(dstr);
7a5fa8a2 3738 if ( SvVOK(dstr) )
ece467f9
JP
3739 {
3740 /* need to nuke the magic */
3741 mg_free(dstr);
3742 SvRMAGICAL_off(dstr);
3743 }
9e7bc3e8 3744
463ee0b2 3745 /* There's a lot of redundancy below but we're going for speed here */
79072805 3746
8990e307 3747 switch (stype) {
79072805 3748 case SVt_NULL:
aece5585 3749 undef_sstr:
20408e3c
GS
3750 if (dtype != SVt_PVGV) {
3751 (void)SvOK_off(dstr);
3752 return;
3753 }
3754 break;
463ee0b2 3755 case SVt_IV:
aece5585
GA
3756 if (SvIOK(sstr)) {
3757 switch (dtype) {
3758 case SVt_NULL:
8990e307 3759 sv_upgrade(dstr, SVt_IV);
aece5585
GA
3760 break;
3761 case SVt_NV:
8990e307 3762 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
3763 break;
3764 case SVt_RV:
3765 case SVt_PV:
a0d0e21e 3766 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA
3767 break;
3768 }