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