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