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