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