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