This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restore SvEND_set
[perl5.git] / sv.c
CommitLineData
a0d0e21e 1/* sv.c
79072805 2 *
4bb101f2 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
241d1a3b 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
79072805
LW
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
a0d0e21e 9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
645c22ef
DM
10 *
11 *
5e045b90
AMS
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
17 * in the pp*.c files.
79072805
LW
18 */
19
20#include "EXTERN.h"
864dbfa3 21#define PERL_IN_SV_C
79072805 22#include "perl.h"
d2f185dc 23#include "regcomp.h"
79072805 24
51371543 25#define FCALL *f
2c5424a7 26
2f8ed50e
OS
27#ifdef __Lynx__
28/* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
30#endif
31
e23c8137
JH
32#ifdef PERL_UTF8_CACHE_ASSERT
33/* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
42 * --jhi
43 */
44#define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
46#else
47#define ASSERT_UTF8_CACHE(cache) NOOP
48#endif
49
765f542d
NC
50#ifdef PERL_COPY_ON_WRITE
51#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
607fa7f2 52#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
b5ccf5f2 53/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
765f542d 54 on-write. */
765f542d 55#endif
645c22ef
DM
56
57/* ============================================================================
58
59=head1 Allocation and deallocation of SVs.
60
5e045b90
AMS
61An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62av, hv...) contains type and reference count information, as well as a
63pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64specific to each type.
65
66Normally, this allocation is done using arenas, which are approximately
671K chunks of memory parcelled up into N heads or bodies. The first slot
68in each arena is reserved, and is used to hold a link to the next arena.
69In the case of heads, the unused first slot also contains some flags and
70a note of the number of slots. Snaked through each arena chain is a
71linked list of free items; when this becomes empty, an extra arena is
72allocated and divided up into N items which are threaded into the free
73list.
645c22ef
DM
74
75The following global variables are associated with arenas:
76
77 PL_sv_arenaroot pointer to list of SV arenas
78 PL_sv_root pointer to list of free SV structures
79
80 PL_foo_arenaroot pointer to list of foo arenas,
81 PL_foo_root pointer to list of free foo bodies
82 ... for foo in xiv, xnv, xrv, xpv etc.
83
84Note that some of the larger and more rarely used body types (eg xpvio)
85are not allocated using arenas, but are instead just malloc()/free()ed as
86required. Also, if PURIFY is defined, arenas are abandoned altogether,
87with all items individually malloc()ed. In addition, a few SV heads are
88not allocated from an arena, but are instead directly created as static
89or auto variables, eg PL_sv_undef.
90
91The SV arena serves the secondary purpose of allowing still-live SVs
92to be located and destroyed during final cleanup.
93
94At the lowest level, the macros new_SV() and del_SV() grab and free
95an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
96to return the SV to the free list with error checking.) new_SV() calls
97more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
98SVs in the free list have their SvTYPE field set to all ones.
99
100Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
101that allocate and return individual body types. Normally these are mapped
ff276b08
RG
102to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
103instead mapped directly to malloc()/free() if PURIFY is defined. The
645c22ef
DM
104new/del functions remove from, or add to, the appropriate PL_foo_root
105list, and call more_xiv() etc to add a new arena if the list is empty.
106
ff276b08 107At the time of very final cleanup, sv_free_arenas() is called from
645c22ef
DM
108perl_destruct() to physically free all the arenas allocated since the
109start of the interpreter. Note that this also clears PL_he_arenaroot,
110which is otherwise dealt with in hv.c.
111
112Manipulation of any of the PL_*root pointers is protected by enclosing
113LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
114if threads are enabled.
115
116The function visit() scans the SV arenas list, and calls a specified
117function for each SV it finds which is still live - ie which has an SvTYPE
118other than all 1's, and a non-zero SvREFCNT. visit() is used by the
119following functions (specified as [function that calls visit()] / [function
120called by visit() for each SV]):
121
122 sv_report_used() / do_report_used()
123 dump all remaining SVs (debugging aid)
124
125 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
126 Attempt to free all objects pointed to by RVs,
127 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
128 try to do the same for all objects indirectly
129 referenced by typeglobs too. Called once from
130 perl_destruct(), prior to calling sv_clean_all()
131 below.
132
133 sv_clean_all() / do_clean_all()
134 SvREFCNT_dec(sv) each remaining SV, possibly
135 triggering an sv_free(). It also sets the
136 SVf_BREAK flag on the SV to indicate that the
137 refcnt has been artificially lowered, and thus
138 stopping sv_free() from giving spurious warnings
139 about SVs which unexpectedly have a refcnt
140 of zero. called repeatedly from perl_destruct()
141 until there are no SVs left.
142
143=head2 Summary
144
145Private API to rest of sv.c
146
147 new_SV(), del_SV(),
148
149 new_XIV(), del_XIV(),
150 new_XNV(), del_XNV(),
151 etc
152
153Public API:
154
8cf8f3d1 155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
645c22ef
DM
156
157
158=cut
159
160============================================================================ */
161
162
51371543 163
4561caa4
CS
164/*
165 * "A time to plant, and a time to uproot what was planted..."
166 */
167
fd0854ff
DM
168#ifdef DEBUG_LEAKING_SCALARS
169# ifdef NETWARE
170# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file)
171# else
172# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file)
173# endif
174#else
175# define FREE_SV_DEBUG_FILE(sv)
176#endif
177
053fc874
GS
178#define plant_SV(p) \
179 STMT_START { \
fd0854ff 180 FREE_SV_DEBUG_FILE(p); \
053fc874
GS
181 SvANY(p) = (void *)PL_sv_root; \
182 SvFLAGS(p) = SVTYPEMASK; \
183 PL_sv_root = (p); \
184 --PL_sv_count; \
185 } STMT_END
a0d0e21e 186
fba3b22e 187/* sv_mutex must be held while calling uproot_SV() */
053fc874
GS
188#define uproot_SV(p) \
189 STMT_START { \
190 (p) = PL_sv_root; \
191 PL_sv_root = (SV*)SvANY(p); \
192 ++PL_sv_count; \
193 } STMT_END
194
645c22ef
DM
195
196/* new_SV(): return a new, empty SV head */
197
eba0f806
DM
198#ifdef DEBUG_LEAKING_SCALARS
199/* provide a real function for a debugger to play with */
200STATIC SV*
201S_new_SV(pTHX)
202{
203 SV* sv;
204
205 LOCK_SV_MUTEX;
206 if (PL_sv_root)
207 uproot_SV(sv);
208 else
209 sv = more_sv();
210 UNLOCK_SV_MUTEX;
211 SvANY(sv) = 0;
212 SvREFCNT(sv) = 1;
213 SvFLAGS(sv) = 0;
fd0854ff
DM
214 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
215 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
216 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
217 sv->sv_debug_inpad = 0;
218 sv->sv_debug_cloned = 0;
219# ifdef NETWARE
220 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
221# else
222 sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
223# endif
224
eba0f806
DM
225 return sv;
226}
227# define new_SV(p) (p)=S_new_SV(aTHX)
228
229#else
230# define new_SV(p) \
053fc874
GS
231 STMT_START { \
232 LOCK_SV_MUTEX; \
233 if (PL_sv_root) \
234 uproot_SV(p); \
235 else \
236 (p) = more_sv(); \
237 UNLOCK_SV_MUTEX; \
238 SvANY(p) = 0; \
239 SvREFCNT(p) = 1; \
240 SvFLAGS(p) = 0; \
241 } STMT_END
eba0f806 242#endif
463ee0b2 243
645c22ef
DM
244
245/* del_SV(): return an empty SV head to the free list */
246
a0d0e21e 247#ifdef DEBUGGING
4561caa4 248
053fc874
GS
249#define del_SV(p) \
250 STMT_START { \
251 LOCK_SV_MUTEX; \
aea4f609 252 if (DEBUG_D_TEST) \
053fc874
GS
253 del_sv(p); \
254 else \
255 plant_SV(p); \
256 UNLOCK_SV_MUTEX; \
257 } STMT_END
a0d0e21e 258
76e3520e 259STATIC void
cea2e8a9 260S_del_sv(pTHX_ SV *p)
463ee0b2 261{
aea4f609 262 if (DEBUG_D_TEST) {
4633a7c4 263 SV* sva;
a0d0e21e
LW
264 SV* sv;
265 SV* svend;
266 int ok = 0;
3280af22 267 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
4633a7c4
LW
268 sv = sva + 1;
269 svend = &sva[SvREFCNT(sva)];
a0d0e21e
LW
270 if (p >= sv && p < svend)
271 ok = 1;
272 }
273 if (!ok) {
0453d815 274 if (ckWARN_d(WARN_INTERNAL))
9014280d 275 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
472d47bc
SB
276 "Attempt to free non-arena SV: 0x%"UVxf
277 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
a0d0e21e
LW
278 return;
279 }
280 }
4561caa4 281 plant_SV(p);
463ee0b2 282}
a0d0e21e 283
4561caa4
CS
284#else /* ! DEBUGGING */
285
286#define del_SV(p) plant_SV(p)
287
288#endif /* DEBUGGING */
463ee0b2 289
645c22ef
DM
290
291/*
ccfc67b7
JH
292=head1 SV Manipulation Functions
293
645c22ef
DM
294=for apidoc sv_add_arena
295
296Given a chunk of memory, link it to the head of the list of arenas,
297and split it into a list of free SVs.
298
299=cut
300*/
301
4633a7c4 302void
864dbfa3 303Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
463ee0b2 304{
4633a7c4 305 SV* sva = (SV*)ptr;
463ee0b2
LW
306 register SV* sv;
307 register SV* svend;
4633a7c4
LW
308
309 /* The first SV in an arena isn't an SV. */
3280af22 310 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
4633a7c4
LW
311 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
312 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
313
3280af22
NIS
314 PL_sv_arenaroot = sva;
315 PL_sv_root = sva + 1;
4633a7c4
LW
316
317 svend = &sva[SvREFCNT(sva) - 1];
318 sv = sva + 1;
463ee0b2 319 while (sv < svend) {
a0d0e21e 320 SvANY(sv) = (void *)(SV*)(sv + 1);
978b032e 321 SvREFCNT(sv) = 0;
8990e307 322 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW
323 sv++;
324 }
325 SvANY(sv) = 0;
4633a7c4
LW
326 SvFLAGS(sv) = SVTYPEMASK;
327}
328
645c22ef
DM
329/* make some more SVs by adding another arena */
330
fba3b22e 331/* sv_mutex must be held while calling more_sv() */
76e3520e 332STATIC SV*
cea2e8a9 333S_more_sv(pTHX)
4633a7c4 334{
4561caa4
CS
335 register SV* sv;
336
3280af22
NIS
337 if (PL_nice_chunk) {
338 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
339 PL_nice_chunk = Nullch;
30ad99e7 340 PL_nice_chunk_size = 0;
c07a80fd 341 }
1edc1566
PP
342 else {
343 char *chunk; /* must use New here to match call to */
344 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
345 sv_add_arena(chunk, 1008, 0);
346 }
4561caa4
CS
347 uproot_SV(sv);
348 return sv;
463ee0b2
LW
349}
350
055972dc
DM
351/* visit(): call the named function for each non-free SV in the arenas
352 * whose flags field matches the flags/mask args. */
645c22ef 353
5226ed68 354STATIC I32
055972dc 355S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
8990e307 356{
4633a7c4 357 SV* sva;
8990e307
LW
358 SV* sv;
359 register SV* svend;
5226ed68 360 I32 visited = 0;
8990e307 361
3280af22 362 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
4633a7c4 363 svend = &sva[SvREFCNT(sva)];
4561caa4 364 for (sv = sva + 1; sv < svend; ++sv) {
055972dc
DM
365 if (SvTYPE(sv) != SVTYPEMASK
366 && (sv->sv_flags & mask) == flags
367 && SvREFCNT(sv))
368 {
acfe0abc 369 (FCALL)(aTHX_ sv);
5226ed68
JH
370 ++visited;
371 }
8990e307
LW
372 }
373 }
5226ed68 374 return visited;
8990e307
LW
375}
376
758a08c3
JH
377#ifdef DEBUGGING
378
645c22ef
DM
379/* called by sv_report_used() for each live SV */
380
381static void
acfe0abc 382do_report_used(pTHX_ SV *sv)
645c22ef
DM
383{
384 if (SvTYPE(sv) != SVTYPEMASK) {
385 PerlIO_printf(Perl_debug_log, "****\n");
386 sv_dump(sv);
387 }
388}
758a08c3 389#endif
645c22ef
DM
390
391/*
392=for apidoc sv_report_used
393
394Dump the contents of all SVs not yet freed. (Debugging aid).
395
396=cut
397*/
398
8990e307 399void
864dbfa3 400Perl_sv_report_used(pTHX)
4561caa4 401{
ff270d3a 402#ifdef DEBUGGING
055972dc 403 visit(do_report_used, 0, 0);
ff270d3a 404#endif
4561caa4
CS
405}
406
645c22ef
DM
407/* called by sv_clean_objs() for each live SV */
408
409static void
acfe0abc 410do_clean_objs(pTHX_ SV *sv)
645c22ef
DM
411{
412 SV* rv;
413
414 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
415 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
416 if (SvWEAKREF(sv)) {
417 sv_del_backref(sv);
418 SvWEAKREF_off(sv);
b162af07 419 SvRV_set(sv, NULL);
645c22ef
DM
420 } else {
421 SvROK_off(sv);
b162af07 422 SvRV_set(sv, NULL);
645c22ef
DM
423 SvREFCNT_dec(rv);
424 }
425 }
426
427 /* XXX Might want to check arrays, etc. */
428}
429
430/* called by sv_clean_objs() for each live SV */
431
432#ifndef DISABLE_DESTRUCTOR_KLUDGE
433static void
acfe0abc 434do_clean_named_objs(pTHX_ SV *sv)
645c22ef
DM
435{
436 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
437 if ( SvOBJECT(GvSV(sv)) ||
438 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
439 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
440 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
441 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
442 {
443 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
ec5f3c78 444 SvFLAGS(sv) |= SVf_BREAK;
645c22ef
DM
445 SvREFCNT_dec(sv);
446 }
447 }
448}
449#endif
450
451/*
452=for apidoc sv_clean_objs
453
454Attempt to destroy all objects not yet freed
455
456=cut
457*/
458
4561caa4 459void
864dbfa3 460Perl_sv_clean_objs(pTHX)
4561caa4 461{
3280af22 462 PL_in_clean_objs = TRUE;
055972dc 463 visit(do_clean_objs, SVf_ROK, SVf_ROK);
4561caa4 464#ifndef DISABLE_DESTRUCTOR_KLUDGE
2d0f3c12 465 /* some barnacles may yet remain, clinging to typeglobs */
055972dc 466 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
4561caa4 467#endif
3280af22 468 PL_in_clean_objs = FALSE;
4561caa4
CS
469}
470
645c22ef
DM
471/* called by sv_clean_all() for each live SV */
472
473static void
acfe0abc 474do_clean_all(pTHX_ SV *sv)
645c22ef
DM
475{
476 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
477 SvFLAGS(sv) |= SVf_BREAK;
0e705b3b
DM
478 if (PL_comppad == (AV*)sv) {
479 PL_comppad = Nullav;
480 PL_curpad = Null(SV**);
481 }
645c22ef
DM
482 SvREFCNT_dec(sv);
483}
484
485/*
486=for apidoc sv_clean_all
487
488Decrement the refcnt of each remaining SV, possibly triggering a
489cleanup. This function may have to be called multiple times to free
ff276b08 490SVs which are in complex self-referential hierarchies.
645c22ef
DM
491
492=cut
493*/
494
5226ed68 495I32
864dbfa3 496Perl_sv_clean_all(pTHX)
8990e307 497{
5226ed68 498 I32 cleaned;
3280af22 499 PL_in_clean_all = TRUE;
055972dc 500 cleaned = visit(do_clean_all, 0,0);
3280af22 501 PL_in_clean_all = FALSE;
5226ed68 502 return cleaned;
8990e307 503}
463ee0b2 504
645c22ef
DM
505/*
506=for apidoc sv_free_arenas
507
508Deallocate the memory used by all arenas. Note that all the individual SV
509heads and bodies within the arenas must already have been freed.
510
511=cut
512*/
513
4633a7c4 514void
864dbfa3 515Perl_sv_free_arenas(pTHX)
4633a7c4
LW
516{
517 SV* sva;
518 SV* svanext;
612f20c3 519 XPV *arena, *arenanext;
4633a7c4
LW
520
521 /* Free arenas here, but be careful about fake ones. (We assume
522 contiguity of the fake ones with the corresponding real ones.) */
523
3280af22 524 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
4633a7c4
LW
525 svanext = (SV*) SvANY(sva);
526 while (svanext && SvFAKE(svanext))
527 svanext = (SV*) SvANY(svanext);
528
529 if (!SvFAKE(sva))
1edc1566 530 Safefree((void *)sva);
4633a7c4 531 }
5f05dabc 532
612f20c3
GS
533 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
535 Safefree(arena);
536 }
537 PL_xiv_arenaroot = 0;
bf9cdc68 538 PL_xiv_root = 0;
612f20c3
GS
539
540 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
541 arenanext = (XPV*)arena->xpv_pv;
542 Safefree(arena);
543 }
544 PL_xnv_arenaroot = 0;
bf9cdc68 545 PL_xnv_root = 0;
612f20c3
GS
546
547 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
548 arenanext = (XPV*)arena->xpv_pv;
549 Safefree(arena);
550 }
551 PL_xrv_arenaroot = 0;
bf9cdc68 552 PL_xrv_root = 0;
612f20c3
GS
553
554 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
555 arenanext = (XPV*)arena->xpv_pv;
556 Safefree(arena);
557 }
558 PL_xpv_arenaroot = 0;
bf9cdc68 559 PL_xpv_root = 0;
612f20c3
GS
560
561 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
562 arenanext = (XPV*)arena->xpv_pv;
563 Safefree(arena);
564 }
565 PL_xpviv_arenaroot = 0;
bf9cdc68 566 PL_xpviv_root = 0;
612f20c3
GS
567
568 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
569 arenanext = (XPV*)arena->xpv_pv;
570 Safefree(arena);
571 }
572 PL_xpvnv_arenaroot = 0;
bf9cdc68 573 PL_xpvnv_root = 0;
612f20c3
GS
574
575 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
576 arenanext = (XPV*)arena->xpv_pv;
577 Safefree(arena);
578 }
579 PL_xpvcv_arenaroot = 0;
bf9cdc68 580 PL_xpvcv_root = 0;
612f20c3
GS
581
582 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
583 arenanext = (XPV*)arena->xpv_pv;
584 Safefree(arena);
585 }
586 PL_xpvav_arenaroot = 0;
bf9cdc68 587 PL_xpvav_root = 0;
612f20c3
GS
588
589 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
590 arenanext = (XPV*)arena->xpv_pv;
591 Safefree(arena);
592 }
593 PL_xpvhv_arenaroot = 0;
bf9cdc68 594 PL_xpvhv_root = 0;
612f20c3
GS
595
596 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
597 arenanext = (XPV*)arena->xpv_pv;
598 Safefree(arena);
599 }
600 PL_xpvmg_arenaroot = 0;
bf9cdc68 601 PL_xpvmg_root = 0;
612f20c3
GS
602
603 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
604 arenanext = (XPV*)arena->xpv_pv;
605 Safefree(arena);
606 }
607 PL_xpvlv_arenaroot = 0;
bf9cdc68 608 PL_xpvlv_root = 0;
612f20c3
GS
609
610 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
611 arenanext = (XPV*)arena->xpv_pv;
612 Safefree(arena);
613 }
614 PL_xpvbm_arenaroot = 0;
bf9cdc68 615 PL_xpvbm_root = 0;
612f20c3
GS
616
617 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
618 arenanext = (XPV*)arena->xpv_pv;
619 Safefree(arena);
620 }
621 PL_he_arenaroot = 0;
bf9cdc68 622 PL_he_root = 0;
612f20c3 623
3280af22
NIS
624 if (PL_nice_chunk)
625 Safefree(PL_nice_chunk);
626 PL_nice_chunk = Nullch;
627 PL_nice_chunk_size = 0;
628 PL_sv_arenaroot = 0;
629 PL_sv_root = 0;
4633a7c4
LW
630}
631
29489e7c
DM
632/* ---------------------------------------------------------------------
633 *
634 * support functions for report_uninit()
635 */
636
637/* the maxiumum size of array or hash where we will scan looking
638 * for the undefined element that triggered the warning */
639
640#define FUV_MAX_SEARCH_SIZE 1000
641
642/* Look for an entry in the hash whose value has the same SV as val;
643 * If so, return a mortal copy of the key. */
644
645STATIC SV*
646S_find_hash_subscript(pTHX_ HV *hv, SV* val)
647{
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
c04a4dfe
JH
1780 char* pv = NULL;
1781 U32 cur = 0;
1782 U32 len = 0;
1783 IV iv = 0;
1784 NV nv = 0.0;
1785 MAGIC* magic = NULL;
1786 HV* stash = Nullhv;
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
79072805
LW
1798 switch (SvTYPE(sv)) {
1799 case SVt_NULL:
1800 pv = 0;
1801 cur = 0;
1802 len = 0;
1803 iv = 0;
1804 nv = 0.0;
1805 magic = 0;
1806 stash = 0;
1807 break;
79072805
LW
1808 case SVt_IV:
1809 pv = 0;
1810 cur = 0;
1811 len = 0;
463ee0b2 1812 iv = SvIVX(sv);
65202027 1813 nv = (NV)SvIVX(sv);
79072805
LW
1814 del_XIV(SvANY(sv));
1815 magic = 0;
1816 stash = 0;
ed6116ce 1817 if (mt == SVt_NV)
463ee0b2 1818 mt = SVt_PVNV;
ed6116ce
LW
1819 else if (mt < SVt_PVIV)
1820 mt = SVt_PVIV;
79072805
LW
1821 break;
1822 case SVt_NV:
1823 pv = 0;
1824 cur = 0;
1825 len = 0;
463ee0b2 1826 nv = SvNVX(sv);
1bd302c3 1827 iv = I_V(nv);
79072805
LW
1828 magic = 0;
1829 stash = 0;
1830 del_XNV(SvANY(sv));
1831 SvANY(sv) = 0;
ed6116ce 1832 if (mt < SVt_PVNV)
79072805
LW
1833 mt = SVt_PVNV;
1834 break;
ed6116ce
LW
1835 case SVt_RV:
1836 pv = (char*)SvRV(sv);
1837 cur = 0;
1838 len = 0;
56431972
RB
1839 iv = PTR2IV(pv);
1840 nv = PTR2NV(pv);
ed6116ce
LW
1841 del_XRV(SvANY(sv));
1842 magic = 0;
1843 stash = 0;
1844 break;
79072805 1845 case SVt_PV:
463ee0b2 1846 pv = SvPVX(sv);
79072805
LW
1847 cur = SvCUR(sv);
1848 len = SvLEN(sv);
1849 iv = 0;
1850 nv = 0.0;
1851 magic = 0;
1852 stash = 0;
1853 del_XPV(SvANY(sv));
748a9306
LW
1854 if (mt <= SVt_IV)
1855 mt = SVt_PVIV;
1856 else if (mt == SVt_NV)
1857 mt = SVt_PVNV;
79072805
LW
1858 break;
1859 case SVt_PVIV:
463ee0b2 1860 pv = SvPVX(sv);
79072805
LW
1861 cur = SvCUR(sv);
1862 len = SvLEN(sv);
463ee0b2 1863 iv = SvIVX(sv);
79072805
LW
1864 nv = 0.0;
1865 magic = 0;
1866 stash = 0;
1867 del_XPVIV(SvANY(sv));
1868 break;
1869 case SVt_PVNV:
463ee0b2 1870 pv = SvPVX(sv);
79072805
LW
1871 cur = SvCUR(sv);
1872 len = SvLEN(sv);
463ee0b2
LW
1873 iv = SvIVX(sv);
1874 nv = SvNVX(sv);
79072805
LW
1875 magic = 0;
1876 stash = 0;
1877 del_XPVNV(SvANY(sv));
1878 break;
1879 case SVt_PVMG:
463ee0b2 1880 pv = SvPVX(sv);
79072805
LW
1881 cur = SvCUR(sv);
1882 len = SvLEN(sv);
463ee0b2
LW
1883 iv = SvIVX(sv);
1884 nv = SvNVX(sv);
79072805
LW
1885 magic = SvMAGIC(sv);
1886 stash = SvSTASH(sv);
1887 del_XPVMG(SvANY(sv));
1888 break;
1889 default:
cea2e8a9 1890 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
79072805
LW
1891 }
1892
ffb05e06
NC
1893 SvFLAGS(sv) &= ~SVTYPEMASK;
1894 SvFLAGS(sv) |= mt;
1895
79072805
LW
1896 switch (mt) {
1897 case SVt_NULL:
cea2e8a9 1898 Perl_croak(aTHX_ "Can't upgrade to undef");
79072805
LW
1899 case SVt_IV:
1900 SvANY(sv) = new_XIV();
45977657 1901 SvIV_set(sv, iv);
79072805
LW
1902 break;
1903 case SVt_NV:
1904 SvANY(sv) = new_XNV();
9d6ce603 1905 SvNV_set(sv, nv);
79072805 1906 break;
ed6116ce
LW
1907 case SVt_RV:
1908 SvANY(sv) = new_XRV();
b162af07 1909 SvRV_set(sv, (SV*)pv);
ed6116ce 1910 break;
79072805
LW
1911 case SVt_PV:
1912 SvANY(sv) = new_XPV();
f880fe2f 1913 SvPV_set(sv, pv);
b162af07
SP
1914 SvCUR_set(sv, cur);
1915 SvLEN_set(sv, len);
79072805
LW
1916 break;
1917 case SVt_PVIV:
1918 SvANY(sv) = new_XPVIV();
f880fe2f 1919 SvPV_set(sv, pv);
b162af07
SP
1920 SvCUR_set(sv, cur);
1921 SvLEN_set(sv, len);
45977657 1922 SvIV_set(sv, iv);
79072805 1923 if (SvNIOK(sv))
a0d0e21e 1924 (void)SvIOK_on(sv);
79072805
LW
1925 SvNOK_off(sv);
1926 break;
1927 case SVt_PVNV:
1928 SvANY(sv) = new_XPVNV();
f880fe2f 1929 SvPV_set(sv, pv);
b162af07
SP
1930 SvCUR_set(sv, cur);
1931 SvLEN_set(sv, len);
45977657 1932 SvIV_set(sv, iv);
9d6ce603 1933 SvNV_set(sv, nv);
79072805
LW
1934 break;
1935 case SVt_PVMG:
1936 SvANY(sv) = new_XPVMG();
f880fe2f 1937 SvPV_set(sv, pv);
b162af07
SP
1938 SvCUR_set(sv, cur);
1939 SvLEN_set(sv, len);
45977657 1940 SvIV_set(sv, iv);
9d6ce603 1941 SvNV_set(sv, nv);
b162af07
SP
1942 SvMAGIC_set(sv, magic);
1943 SvSTASH_set(sv, stash);
79072805
LW
1944 break;
1945 case SVt_PVLV:
1946 SvANY(sv) = new_XPVLV();
f880fe2f 1947 SvPV_set(sv, pv);
b162af07
SP
1948 SvCUR_set(sv, cur);
1949 SvLEN_set(sv, len);
45977657 1950 SvIV_set(sv, iv);
9d6ce603 1951 SvNV_set(sv, nv);
b162af07
SP
1952 SvMAGIC_set(sv, magic);
1953 SvSTASH_set(sv, stash);
79072805
LW
1954 LvTARGOFF(sv) = 0;
1955 LvTARGLEN(sv) = 0;
1956 LvTARG(sv) = 0;
1957 LvTYPE(sv) = 0;
b76195c2
DM
1958 GvGP(sv) = 0;
1959 GvNAME(sv) = 0;
1960 GvNAMELEN(sv) = 0;
1961 GvSTASH(sv) = 0;
1962 GvFLAGS(sv) = 0;
79072805
LW
1963 break;
1964 case SVt_PVAV:
1965 SvANY(sv) = new_XPVAV();
463ee0b2
LW
1966 if (pv)
1967 Safefree(pv);
f880fe2f 1968 SvPV_set(sv, (char*)0);
d1bf51dd 1969 AvMAX(sv) = -1;
93965878 1970 AvFILLp(sv) = -1;
45977657 1971 SvIV_set(sv, 0);
9d6ce603 1972 SvNV_set(sv, 0.0);
b162af07
SP
1973 SvMAGIC_set(sv, magic);
1974 SvSTASH_set(sv, stash);
463ee0b2 1975 AvALLOC(sv) = 0;
79072805 1976 AvARYLEN(sv) = 0;
e763e3dc 1977 AvFLAGS(sv) = AVf_REAL;
79072805
LW
1978 break;
1979 case SVt_PVHV:
1980 SvANY(sv) = new_XPVHV();
463ee0b2
LW
1981 if (pv)
1982 Safefree(pv);
f880fe2f 1983 SvPV_set(sv, (char*)0);
463ee0b2
LW
1984 HvFILL(sv) = 0;
1985 HvMAX(sv) = 0;
8aacddc1
NIS
1986 HvTOTALKEYS(sv) = 0;
1987 HvPLACEHOLDERS(sv) = 0;
b162af07
SP
1988 SvMAGIC_set(sv, magic);
1989 SvSTASH_set(sv, stash);
79072805
LW
1990 HvRITER(sv) = 0;
1991 HvEITER(sv) = 0;
1992 HvPMROOT(sv) = 0;
1993 HvNAME(sv) = 0;
79072805
LW
1994 break;
1995 case SVt_PVCV:
1996 SvANY(sv) = new_XPVCV();
748a9306 1997 Zero(SvANY(sv), 1, XPVCV);
f880fe2f 1998 SvPV_set(sv, pv);
b162af07
SP
1999 SvCUR_set(sv, cur);
2000 SvLEN_set(sv, len);
45977657 2001 SvIV_set(sv, iv);
9d6ce603 2002 SvNV_set(sv, nv);
b162af07
SP
2003 SvMAGIC_set(sv, magic);
2004 SvSTASH_set(sv, stash);
79072805
LW
2005 break;
2006 case SVt_PVGV:
2007 SvANY(sv) = new_XPVGV();
f880fe2f 2008 SvPV_set(sv, pv);
b162af07
SP
2009 SvCUR_set(sv, cur);
2010 SvLEN_set(sv, len);
45977657 2011 SvIV_set(sv, iv);
9d6ce603 2012 SvNV_set(sv, nv);
b162af07
SP
2013 SvMAGIC_set(sv, magic);
2014 SvSTASH_set(sv, stash);
93a17b20 2015 GvGP(sv) = 0;
79072805
LW
2016 GvNAME(sv) = 0;
2017 GvNAMELEN(sv) = 0;
2018 GvSTASH(sv) = 0;
a5f75d66 2019 GvFLAGS(sv) = 0;
79072805
LW
2020 break;
2021 case SVt_PVBM:
2022 SvANY(sv) = new_XPVBM();
f880fe2f 2023 SvPV_set(sv, pv);
b162af07
SP
2024 SvCUR_set(sv, cur);
2025 SvLEN_set(sv, len);
45977657 2026 SvIV_set(sv, iv);
9d6ce603 2027 SvNV_set(sv, nv);
b162af07
SP
2028 SvMAGIC_set(sv, magic);
2029 SvSTASH_set(sv, stash);
79072805
LW
2030 BmRARE(sv) = 0;
2031 BmUSEFUL(sv) = 0;
2032 BmPREVIOUS(sv) = 0;
2033 break;
2034 case SVt_PVFM:
2035 SvANY(sv) = new_XPVFM();
748a9306 2036 Zero(SvANY(sv), 1, XPVFM);
f880fe2f 2037 SvPV_set(sv, pv);
b162af07
SP
2038 SvCUR_set(sv, cur);
2039 SvLEN_set(sv, len);
45977657 2040 SvIV_set(sv, iv);
9d6ce603 2041 SvNV_set(sv, nv);
b162af07
SP
2042 SvMAGIC_set(sv, magic);
2043 SvSTASH_set(sv, stash);
79072805 2044 break;
8990e307
LW
2045 case SVt_PVIO:
2046 SvANY(sv) = new_XPVIO();
748a9306 2047 Zero(SvANY(sv), 1, XPVIO);
f880fe2f 2048 SvPV_set(sv, pv);
b162af07
SP
2049 SvCUR_set(sv, cur);
2050 SvLEN_set(sv, len);
45977657 2051 SvIV_set(sv, iv);
9d6ce603 2052 SvNV_set(sv, nv);
b162af07
SP
2053 SvMAGIC_set(sv, magic);
2054 SvSTASH_set(sv, stash);
85e6fe83 2055 IoPAGE_LEN(sv) = 60;
8990e307
LW
2056 break;
2057 }
79072805
LW
2058 return TRUE;
2059}
2060
645c22ef
DM
2061/*
2062=for apidoc sv_backoff
2063
2064Remove any string offset. You should normally use the C<SvOOK_off> macro
2065wrapper instead.
2066
2067=cut
2068*/
2069
79072805 2070int
864dbfa3 2071Perl_sv_backoff(pTHX_ register SV *sv)
79072805
LW
2072{
2073 assert(SvOOK(sv));
463ee0b2
LW
2074 if (SvIVX(sv)) {
2075 char *s = SvPVX(sv);
b162af07 2076 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
f880fe2f 2077 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
79072805 2078 SvIV_set(sv, 0);
463ee0b2 2079 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW
2080 }
2081 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 2082 return 0;
79072805
LW
2083}
2084
954c1994
GS
2085/*
2086=for apidoc sv_grow
2087
645c22ef
DM
2088Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
2089upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
2090Use the C<SvGROW> wrapper instead.
954c1994
GS
2091
2092=cut
2093*/
2094
79072805 2095char *
864dbfa3 2096Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
79072805
LW
2097{
2098 register char *s;
2099
55497cff 2100#ifdef HAS_64K_LIMIT
79072805 2101 if (newlen >= 0x10000) {
1d7c1841
GS
2102 PerlIO_printf(Perl_debug_log,
2103 "Allocation too large: %"UVxf"\n", (UV)newlen);
79072805
LW
2104 my_exit(1);
2105 }
55497cff 2106#endif /* HAS_64K_LIMIT */
a0d0e21e
LW
2107 if (SvROK(sv))
2108 sv_unref(sv);
79072805
LW
2109 if (SvTYPE(sv) < SVt_PV) {
2110 sv_upgrade(sv, SVt_PV);
463ee0b2 2111 s = SvPVX(sv);
79072805
LW
2112 }
2113 else if (SvOOK(sv)) { /* pv is offset? */
2114 sv_backoff(sv);
463ee0b2 2115 s = SvPVX(sv);
79072805
LW
2116 if (newlen > SvLEN(sv))
2117 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
c6f8c383
GA
2118#ifdef HAS_64K_LIMIT
2119 if (newlen >= 0x10000)
2120 newlen = 0xFFFF;
2121#endif
79072805 2122 }
bc44a8a2 2123 else
463ee0b2 2124 s = SvPVX(sv);
54f0641b 2125
79072805 2126 if (newlen > SvLEN(sv)) { /* need more room? */
8d6dde3e 2127 if (SvLEN(sv) && s) {
7bab3ede 2128#ifdef MYMALLOC
8d6dde3e
IZ
2129 STRLEN l = malloced_size((void*)SvPVX(sv));
2130 if (newlen <= l) {
2131 SvLEN_set(sv, l);
2132 return s;
2133 } else
c70c8a0a 2134#endif
79072805 2135 Renew(s,newlen,char);
8d6dde3e 2136 }
bfed75c6 2137 else {
4e83176d 2138 New(703, s, newlen, char);
40565179 2139 if (SvPVX(sv) && SvCUR(sv)) {
54f0641b 2140 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
40565179 2141 }
4e83176d 2142 }
79072805 2143 SvPV_set(sv, s);
e1ec3a88 2144 SvLEN_set(sv, newlen);
79072805
LW
2145 }
2146 return s;
2147}
2148
954c1994
GS
2149/*
2150=for apidoc sv_setiv
2151
645c22ef
DM
2152Copies an integer into the given SV, upgrading first if necessary.
2153Does not handle 'set' magic. See also C<sv_setiv_mg>.
954c1994
GS
2154
2155=cut
2156*/
2157
79072805 2158void
864dbfa3 2159Perl_sv_setiv(pTHX_ register SV *sv, IV i)
79072805 2160{
765f542d 2161 SV_CHECK_THINKFIRST_COW_DROP(sv);
463ee0b2
LW
2162 switch (SvTYPE(sv)) {
2163 case SVt_NULL:
79072805 2164 sv_upgrade(sv, SVt_IV);
463ee0b2
LW
2165 break;
2166 case SVt_NV:
2167 sv_upgrade(sv, SVt_PVNV);
2168 break;
ed6116ce 2169 case SVt_RV:
463ee0b2 2170 case SVt_PV:
79072805 2171 sv_upgrade(sv, SVt_PVIV);
463ee0b2 2172 break;
a0d0e21e
LW
2173
2174 case SVt_PVGV:
a0d0e21e
LW
2175 case SVt_PVAV:
2176 case SVt_PVHV:
2177 case SVt_PVCV:
2178 case SVt_PVFM:
2179 case SVt_PVIO:
411caa50 2180 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
53e06cf0 2181 OP_DESC(PL_op));
463ee0b2 2182 }
a0d0e21e 2183 (void)SvIOK_only(sv); /* validate number */
45977657 2184 SvIV_set(sv, i);
463ee0b2 2185 SvTAINT(sv);
79072805
LW
2186}
2187
954c1994
GS
2188/*
2189=for apidoc sv_setiv_mg
2190
2191Like C<sv_setiv>, but also handles 'set' magic.
2192
2193=cut
2194*/
2195
79072805 2196void
864dbfa3 2197Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
ef50df4b
GS
2198{
2199 sv_setiv(sv,i);
2200 SvSETMAGIC(sv);
2201}
2202
954c1994
GS
2203/*
2204=for apidoc sv_setuv
2205
645c22ef
DM
2206Copies an unsigned integer into the given SV, upgrading first if necessary.
2207Does not handle 'set' magic. See also C<sv_setuv_mg>.
954c1994
GS
2208
2209=cut
2210*/
2211
ef50df4b 2212void
864dbfa3 2213Perl_sv_setuv(pTHX_ register SV *sv, UV u)
55497cff 2214{
55ada374
NC
2215 /* With these two if statements:
2216 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 2217
55ada374
NC
2218 without
2219 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 2220
55ada374
NC
2221 If you wish to remove them, please benchmark to see what the effect is
2222 */
28e5dec8
JH
2223 if (u <= (UV)IV_MAX) {
2224 sv_setiv(sv, (IV)u);
2225 return;
2226 }
25da4f38
IZ
2227 sv_setiv(sv, 0);
2228 SvIsUV_on(sv);
607fa7f2 2229 SvUV_set(sv, u);
55497cff
PP
2230}
2231
954c1994
GS
2232/*
2233=for apidoc sv_setuv_mg
2234
2235Like C<sv_setuv>, but also handles 'set' magic.
2236
2237=cut
2238*/
2239
55497cff 2240void
864dbfa3 2241Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b 2242{
55ada374
NC
2243 /* With these two if statements:
2244 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 2245
55ada374
NC
2246 without
2247 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 2248
55ada374
NC
2249 If you wish to remove them, please benchmark to see what the effect is
2250 */
28e5dec8
JH
2251 if (u <= (UV)IV_MAX) {
2252 sv_setiv(sv, (IV)u);
2253 } else {
2254 sv_setiv(sv, 0);
2255 SvIsUV_on(sv);
2256 sv_setuv(sv,u);
2257 }
ef50df4b
GS
2258 SvSETMAGIC(sv);
2259}
2260
954c1994
GS
2261/*
2262=for apidoc sv_setnv
2263
645c22ef
DM
2264Copies a double into the given SV, upgrading first if necessary.
2265Does not handle 'set' magic. See also C<sv_setnv_mg>.
954c1994
GS
2266
2267=cut
2268*/
2269
ef50df4b 2270void
65202027 2271Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 2272{
765f542d 2273 SV_CHECK_THINKFIRST_COW_DROP(sv);
a0d0e21e
LW
2274 switch (SvTYPE(sv)) {
2275 case SVt_NULL:
2276 case SVt_IV:
79072805 2277 sv_upgrade(sv, SVt_NV);
a0d0e21e 2278 break;
a0d0e21e
LW
2279 case SVt_RV:
2280 case SVt_PV:
2281 case SVt_PVIV:
79072805 2282 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 2283 break;
827b7e14 2284
a0d0e21e 2285 case SVt_PVGV:
a0d0e21e
LW
2286 case SVt_PVAV:
2287 case SVt_PVHV:
2288 case SVt_PVCV:
2289 case SVt_PVFM:
2290 case SVt_PVIO:
411caa50 2291 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
53e06cf0 2292 OP_NAME(PL_op));
79072805 2293 }
9d6ce603 2294 SvNV_set(sv, num);
a0d0e21e 2295 (void)SvNOK_only(sv); /* validate number */
463ee0b2 2296 SvTAINT(sv);
79072805
LW
2297}
2298
954c1994
GS
2299/*
2300=for apidoc sv_setnv_mg
2301
2302Like C<sv_setnv>, but also handles 'set' magic.
2303
2304=cut
2305*/
2306
ef50df4b 2307void
65202027 2308Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS
2309{
2310 sv_setnv(sv,num);
2311 SvSETMAGIC(sv);
2312}
2313
645c22ef
DM
2314/* Print an "isn't numeric" warning, using a cleaned-up,
2315 * printable version of the offending string
2316 */
2317
76e3520e 2318STATIC void
cea2e8a9 2319S_not_a_number(pTHX_ SV *sv)
a0d0e21e 2320{
94463019
JH
2321 SV *dsv;
2322 char tmpbuf[64];
2323 char *pv;
2324
2325 if (DO_UTF8(sv)) {
2326 dsv = sv_2mortal(newSVpv("", 0));
2327 pv = sv_uni_display(dsv, sv, 10, 0);
2328 } else {
2329 char *d = tmpbuf;
2330 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
2331 /* each *s can expand to 4 chars + "...\0",
2332 i.e. need room for 8 chars */
ecdeb87c 2333
94463019
JH
2334 char *s, *end;
2335 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
2336 int ch = *s & 0xFF;
2337 if (ch & 128 && !isPRINT_LC(ch)) {
2338 *d++ = 'M';
2339 *d++ = '-';
2340 ch &= 127;
2341 }
2342 if (ch == '\n') {
2343 *d++ = '\\';
2344 *d++ = 'n';
2345 }
2346 else if (ch == '\r') {
2347 *d++ = '\\';
2348 *d++ = 'r';
2349 }
2350 else if (ch == '\f') {
2351 *d++ = '\\';
2352 *d++ = 'f';
2353 }
2354 else if (ch == '\\') {
2355 *d++ = '\\';
2356 *d++ = '\\';
2357 }
2358 else if (ch == '\0') {
2359 *d++ = '\\';
2360 *d++ = '0';
2361 }
2362 else if (isPRINT_LC(ch))
2363 *d++ = ch;
2364 else {
2365 *d++ = '^';
2366 *d++ = toCTRL(ch);
2367 }
2368 }
2369 if (s < end) {
2370 *d++ = '.';
2371 *d++ = '.';
2372 *d++ = '.';
2373 }
2374 *d = '\0';
2375 pv = tmpbuf;
a0d0e21e 2376 }
a0d0e21e 2377
533c011a 2378 if (PL_op)
9014280d 2379 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019
JH
2380 "Argument \"%s\" isn't numeric in %s", pv,
2381 OP_DESC(PL_op));
a0d0e21e 2382 else
9014280d 2383 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019 2384 "Argument \"%s\" isn't numeric", pv);
a0d0e21e
LW
2385}
2386
c2988b20
NC
2387/*
2388=for apidoc looks_like_number
2389
645c22ef
DM
2390Test if the content of an SV looks like a number (or is a number).
2391C<Inf> and C<Infinity> are treated as numbers (so will not issue a
2392non-numeric warning), even if your atof() doesn't grok them.
c2988b20
NC
2393
2394=cut
2395*/
2396
2397I32
2398Perl_looks_like_number(pTHX_ SV *sv)
2399{
2400 register char *sbegin;
2401 STRLEN len;
2402
2403 if (SvPOK(sv)) {
2404 sbegin = SvPVX(sv);
2405 len = SvCUR(sv);
2406 }
2407 else if (SvPOKp(sv))
2408 sbegin = SvPV(sv, len);
2409 else
e0ab1c0e 2410 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
c2988b20
NC
2411 return grok_number(sbegin, len, NULL);
2412}
25da4f38
IZ
2413
2414/* Actually, ISO C leaves conversion of UV to IV undefined, but
2415 until proven guilty, assume that things are not that bad... */
2416
645c22ef
DM
2417/*
2418 NV_PRESERVES_UV:
2419
2420 As 64 bit platforms often have an NV that doesn't preserve all bits of
28e5dec8
JH
2421 an IV (an assumption perl has been based on to date) it becomes necessary
2422 to remove the assumption that the NV always carries enough precision to
2423 recreate the IV whenever needed, and that the NV is the canonical form.
2424 Instead, IV/UV and NV need to be given equal rights. So as to not lose
645c22ef 2425 precision as a side effect of conversion (which would lead to insanity
28e5dec8
JH
2426 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
2427 1) to distinguish between IV/UV/NV slots that have cached a valid
2428 conversion where precision was lost and IV/UV/NV slots that have a
2429 valid conversion which has lost no precision
645c22ef 2430 2) to ensure that if a numeric conversion to one form is requested that
28e5dec8
JH
2431 would lose precision, the precise conversion (or differently
2432 imprecise conversion) is also performed and cached, to prevent
2433 requests for different numeric formats on the same SV causing
2434 lossy conversion chains. (lossless conversion chains are perfectly
2435 acceptable (still))
2436
2437
2438 flags are used:
2439 SvIOKp is true if the IV slot contains a valid value
2440 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
2441 SvNOKp is true if the NV slot contains a valid value
2442 SvNOK is true only if the NV value is accurate
2443
2444 so
645c22ef 2445 while converting from PV to NV, check to see if converting that NV to an
28e5dec8
JH
2446 IV(or UV) would lose accuracy over a direct conversion from PV to
2447 IV(or UV). If it would, cache both conversions, return NV, but mark
2448 SV as IOK NOKp (ie not NOK).
2449
645c22ef 2450 While converting from PV to IV, check to see if converting that IV to an
28e5dec8
JH
2451 NV would lose accuracy over a direct conversion from PV to NV. If it
2452 would, cache both conversions, flag similarly.
2453
2454 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
2455 correctly because if IV & NV were set NV *always* overruled.
645c22ef
DM
2456 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
2457 changes - now IV and NV together means that the two are interchangeable:
28e5dec8 2458 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
d460ef45 2459
645c22ef
DM
2460 The benefit of this is that operations such as pp_add know that if
2461 SvIOK is true for both left and right operands, then integer addition
2462 can be used instead of floating point (for cases where the result won't
2463 overflow). Before, floating point was always used, which could lead to
28e5dec8
JH
2464 loss of precision compared with integer addition.
2465
2466 * making IV and NV equal status should make maths accurate on 64 bit
2467 platforms
2468 * may speed up maths somewhat if pp_add and friends start to use
645c22ef 2469 integers when possible instead of fp. (Hopefully the overhead in
28e5dec8
JH
2470 looking for SvIOK and checking for overflow will not outweigh the
2471 fp to integer speedup)
2472 * will slow down integer operations (callers of SvIV) on "inaccurate"
2473 values, as the change from SvIOK to SvIOKp will cause a call into
2474 sv_2iv each time rather than a macro access direct to the IV slot
2475 * should speed up number->string conversion on integers as IV is
645c22ef 2476 favoured when IV and NV are equally accurate
28e5dec8
JH
2477
2478 ####################################################################
645c22ef
DM
2479 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2480 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2481 On the other hand, SvUOK is true iff UV.
28e5dec8
JH
2482 ####################################################################
2483
645c22ef 2484 Your mileage will vary depending your CPU's relative fp to integer
28e5dec8
JH
2485 performance ratio.
2486*/
2487
2488#ifndef NV_PRESERVES_UV
645c22ef
DM
2489# define IS_NUMBER_UNDERFLOW_IV 1
2490# define IS_NUMBER_UNDERFLOW_UV 2
2491# define IS_NUMBER_IV_AND_UV 2
2492# define IS_NUMBER_OVERFLOW_IV 4
2493# define IS_NUMBER_OVERFLOW_UV 5
2494
2495/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
28e5dec8
JH
2496
2497/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2498STATIC int
645c22ef 2499S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
28e5dec8 2500{
1779d84d 2501 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
2502 if (SvNVX(sv) < (NV)IV_MIN) {
2503 (void)SvIOKp_on(sv);
2504 (void)SvNOK_on(sv);
45977657 2505 SvIV_set(sv, IV_MIN);
28e5dec8
JH
2506 return IS_NUMBER_UNDERFLOW_IV;
2507 }
2508 if (SvNVX(sv) > (NV)UV_MAX) {
2509 (void)SvIOKp_on(sv);
2510 (void)SvNOK_on(sv);
2511 SvIsUV_on(sv);
607fa7f2 2512 SvUV_set(sv, UV_MAX);
28e5dec8
JH
2513 return IS_NUMBER_OVERFLOW_UV;
2514 }
c2988b20
NC
2515 (void)SvIOKp_on(sv);
2516 (void)SvNOK_on(sv);
2517 /* Can't use strtol etc to convert this string. (See truth table in
2518 sv_2iv */
2519 if (SvNVX(sv) <= (UV)IV_MAX) {
45977657 2520 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2521 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2522 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2523 } else {
2524 /* Integer is imprecise. NOK, IOKp */
2525 }
2526 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2527 }
2528 SvIsUV_on(sv);
607fa7f2 2529 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2530 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2531 if (SvUVX(sv) == UV_MAX) {
2532 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2533 possibly be preserved by NV. Hence, it must be overflow.
2534 NOK, IOKp */
2535 return IS_NUMBER_OVERFLOW_UV;
2536 }
2537 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2538 } else {
2539 /* Integer is imprecise. NOK, IOKp */
28e5dec8 2540 }
c2988b20 2541 return IS_NUMBER_OVERFLOW_IV;
28e5dec8 2542}
645c22ef
DM
2543#endif /* !NV_PRESERVES_UV*/
2544
891f9566
YST
2545/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
2546 * this function provided for binary compatibility only
2547 */
2548
2549IV
2550Perl_sv_2iv(pTHX_ register SV *sv)
2551{
2552 return sv_2iv_flags(sv, SV_GMAGIC);
2553}
2554
645c22ef 2555/*
891f9566 2556=for apidoc sv_2iv_flags
645c22ef 2557
891f9566
YST
2558Return the integer value of an SV, doing any necessary string
2559conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2560Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
645c22ef
DM
2561
2562=cut
2563*/
28e5dec8 2564
a0d0e21e 2565IV
891f9566 2566Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
79072805
LW
2567{
2568 if (!sv)
2569 return 0;
8990e307 2570 if (SvGMAGICAL(sv)) {
891f9566
YST
2571 if (flags & SV_GMAGIC)
2572 mg_get(sv);
463ee0b2
LW
2573 if (SvIOKp(sv))
2574 return SvIVX(sv);
748a9306 2575 if (SvNOKp(sv)) {
25da4f38 2576 return I_V(SvNVX(sv));
748a9306 2577 }
36477c24
PP
2578 if (SvPOKp(sv) && SvLEN(sv))
2579 return asIV(sv);
3fe9a6f1 2580 if (!SvROK(sv)) {
d008e5eb 2581 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2582 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2583 report_uninit(sv);
c6ee37c5 2584 }
36477c24 2585 return 0;
3fe9a6f1 2586 }
463ee0b2 2587 }
ed6116ce 2588 if (SvTHINKFIRST(sv)) {
a0d0e21e 2589 if (SvROK(sv)) {
a0d0e21e 2590 SV* tmpstr;
1554e226 2591 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2592 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2593 return SvIV(tmpstr);
56431972 2594 return PTR2IV(SvRV(sv));
a0d0e21e 2595 }
765f542d
NC
2596 if (SvIsCOW(sv)) {
2597 sv_force_normal_flags(sv, 0);
47deb5e7 2598 }
0336b60e 2599 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2600 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2601 report_uninit(sv);
ed6116ce
LW
2602 return 0;
2603 }
79072805 2604 }
25da4f38
IZ
2605 if (SvIOKp(sv)) {
2606 if (SvIsUV(sv)) {
2607 return (IV)(SvUVX(sv));
2608 }
2609 else {
2610 return SvIVX(sv);
2611 }
463ee0b2 2612 }
748a9306 2613 if (SvNOKp(sv)) {
28e5dec8
JH
2614 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2615 * without also getting a cached IV/UV from it at the same time
2616 * (ie PV->NV conversion should detect loss of accuracy and cache
2617 * IV or UV at same time to avoid this. NWC */
25da4f38
IZ
2618
2619 if (SvTYPE(sv) == SVt_NV)
2620 sv_upgrade(sv, SVt_PVNV);
2621
28e5dec8
JH
2622 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2623 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2624 certainly cast into the IV range at IV_MAX, whereas the correct
2625 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2626 cases go to UV */
2627 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2628 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
2629 if (SvNVX(sv) == (NV) SvIVX(sv)
2630#ifndef NV_PRESERVES_UV
2631 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2632 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2633 /* Don't flag it as "accurately an integer" if the number
2634 came from a (by definition imprecise) NV operation, and
2635 we're outside the range of NV integer precision */
2636#endif
2637 ) {
2638 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2639 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2640 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2641 PTR2UV(sv),
2642 SvNVX(sv),
2643 SvIVX(sv)));
2644
2645 } else {
2646 /* IV not precise. No need to convert from PV, as NV
2647 conversion would already have cached IV if it detected
2648 that PV->IV would be better than PV->NV->IV
2649 flags already correct - don't set public IOK. */
2650 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2651 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2652 PTR2UV(sv),
2653 SvNVX(sv),
2654 SvIVX(sv)));
2655 }
2656 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2657 but the cast (NV)IV_MIN rounds to a the value less (more
2658 negative) than IV_MIN which happens to be equal to SvNVX ??
2659 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2660 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2661 (NV)UVX == NVX are both true, but the values differ. :-(
2662 Hopefully for 2s complement IV_MIN is something like
2663 0x8000000000000000 which will be exact. NWC */
d460ef45 2664 }
25da4f38 2665 else {
607fa7f2 2666 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2667 if (
2668 (SvNVX(sv) == (NV) SvUVX(sv))
2669#ifndef NV_PRESERVES_UV
2670 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2671 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2672 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2673 /* Don't flag it as "accurately an integer" if the number
2674 came from a (by definition imprecise) NV operation, and
2675 we're outside the range of NV integer precision */
2676#endif
2677 )
2678 SvIOK_on(sv);
25da4f38
IZ
2679 SvIsUV_on(sv);
2680 ret_iv_max:
1c846c1f 2681 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 2682 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 2683 PTR2UV(sv),
57def98f
JH
2684 SvUVX(sv),
2685 SvUVX(sv)));
25da4f38
IZ
2686 return (IV)SvUVX(sv);
2687 }
748a9306
LW
2688 }
2689 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20
NC
2690 UV value;
2691 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
25da4f38
IZ
2692 /* We want to avoid a possible problem when we cache an IV which
2693 may be later translated to an NV, and the resulting NV is not
c2988b20
NC
2694 the same as the direct translation of the initial string
2695 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2696 be careful to ensure that the value with the .456 is around if the
2697 NV value is requested in the future).
1c846c1f 2698
25da4f38
IZ
2699 This means that if we cache such an IV, we need to cache the
2700 NV as well. Moreover, we trade speed for space, and do not
28e5dec8 2701 cache the NV if we are sure it's not needed.
25da4f38 2702 */
16b7a9a4 2703
c2988b20
NC
2704 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2705 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2706 == IS_NUMBER_IN_UV) {
5e045b90 2707 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8
JH
2708 if (SvTYPE(sv) < SVt_PVIV)
2709 sv_upgrade(sv, SVt_PVIV);
f7bbb42a 2710 (void)SvIOK_on(sv);
c2988b20
NC
2711 } else if (SvTYPE(sv) < SVt_PVNV)
2712 sv_upgrade(sv, SVt_PVNV);
28e5dec8 2713
c2988b20
NC
2714 /* If NV preserves UV then we only use the UV value if we know that
2715 we aren't going to call atof() below. If NVs don't preserve UVs
2716 then the value returned may have more precision than atof() will
2717 return, even though value isn't perfectly accurate. */
2718 if ((numtype & (IS_NUMBER_IN_UV
2719#ifdef NV_PRESERVES_UV
2720 | IS_NUMBER_NOT_INT
2721#endif
2722 )) == IS_NUMBER_IN_UV) {
2723 /* This won't turn off the public IOK flag if it was set above */
2724 (void)SvIOKp_on(sv);
2725
2726 if (!(numtype & IS_NUMBER_NEG)) {
2727 /* positive */;
2728 if (value <= (UV)IV_MAX) {
45977657 2729 SvIV_set(sv, (IV)value);
c2988b20 2730 } else {
607fa7f2 2731 SvUV_set(sv, value);
c2988b20
NC
2732 SvIsUV_on(sv);
2733 }
2734 } else {
2735 /* 2s complement assumption */
2736 if (value <= (UV)IV_MIN) {
45977657 2737 SvIV_set(sv, -(IV)value);
c2988b20
NC
2738 } else {
2739 /* Too negative for an IV. This is a double upgrade, but
d1be9408 2740 I'm assuming it will be rare. */
c2988b20
NC
2741 if (SvTYPE(sv) < SVt_PVNV)
2742 sv_upgrade(sv, SVt_PVNV);
2743 SvNOK_on(sv);
2744 SvIOK_off(sv);
2745 SvIOKp_on(sv);
9d6ce603 2746 SvNV_set(sv, -(NV)value);
45977657 2747 SvIV_set(sv, IV_MIN);
c2988b20
NC
2748 }
2749 }
2750 }
2751 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2752 will be in the previous block to set the IV slot, and the next
2753 block to set the NV slot. So no else here. */
2754
2755 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2756 != IS_NUMBER_IN_UV) {
2757 /* It wasn't an (integer that doesn't overflow the UV). */
9d6ce603 2758 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8 2759
c2988b20
NC
2760 if (! numtype && ckWARN(WARN_NUMERIC))
2761 not_a_number(sv);
28e5dec8 2762
65202027 2763#if defined(USE_LONG_DOUBLE)
c2988b20
NC
2764 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2765 PTR2UV(sv), SvNVX(sv)));
65202027 2766#else
1779d84d 2767 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
c2988b20 2768 PTR2UV(sv), SvNVX(sv)));
65202027 2769#endif
28e5dec8
JH
2770
2771
2772#ifdef NV_PRESERVES_UV
c2988b20
NC
2773 (void)SvIOKp_on(sv);
2774 (void)SvNOK_on(sv);
2775 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2776 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2777 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2778 SvIOK_on(sv);
28e5dec8 2779 } else {
c2988b20
NC
2780 /* Integer is imprecise. NOK, IOKp */
2781 }
2782 /* UV will not work better than IV */
2783 } else {
2784 if (SvNVX(sv) > (NV)UV_MAX) {
2785 SvIsUV_on(sv);
2786 /* Integer is inaccurate. NOK, IOKp, is UV */
607fa7f2 2787 SvUV_set(sv, UV_MAX);
c2988b20
NC
2788 SvIsUV_on(sv);
2789 } else {
607fa7f2 2790 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
2791 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2792 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2793 SvIOK_on(sv);
28e5dec8
JH
2794 SvIsUV_on(sv);
2795 } else {
c2988b20
NC
2796 /* Integer is imprecise. NOK, IOKp, is UV */
2797 SvIsUV_on(sv);
28e5dec8 2798 }
28e5dec8 2799 }
c2988b20
NC
2800 goto ret_iv_max;
2801 }
28e5dec8 2802#else /* NV_PRESERVES_UV */
c2988b20
NC
2803 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2804 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2805 /* The IV slot will have been set from value returned by
2806 grok_number above. The NV slot has just been set using
2807 Atof. */
560b0c46 2808 SvNOK_on(sv);
c2988b20
NC
2809 assert (SvIOKp(sv));
2810 } else {
2811 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2812 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2813 /* Small enough to preserve all bits. */
2814 (void)SvIOKp_on(sv);
2815 SvNOK_on(sv);
45977657 2816 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2817 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2818 SvIOK_on(sv);
2819 /* Assumption: first non-preserved integer is < IV_MAX,
2820 this NV is in the preserved range, therefore: */
2821 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2822 < (UV)IV_MAX)) {
32fdb065 2823 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
2824 }
2825 } else {
2826 /* IN_UV NOT_INT
2827 0 0 already failed to read UV.
2828 0 1 already failed to read UV.
2829 1 0 you won't get here in this case. IV/UV
2830 slot set, public IOK, Atof() unneeded.
2831 1 1 already read UV.
2832 so there's no point in sv_2iuv_non_preserve() attempting
2833 to use atol, strtol, strtoul etc. */
2834 if (sv_2iuv_non_preserve (sv, numtype)
2835 >= IS_NUMBER_OVERFLOW_IV)
2836 goto ret_iv_max;
2837 }
2838 }
28e5dec8 2839#endif /* NV_PRESERVES_UV */
25da4f38 2840 }
28e5dec8 2841 } else {
599cee73 2842 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 2843 report_uninit(sv);
25da4f38
IZ
2844 if (SvTYPE(sv) < SVt_IV)
2845 /* Typically the caller expects that sv_any is not NULL now. */
2846 sv_upgrade(sv, SVt_IV);
a0d0e21e 2847 return 0;
79072805 2848 }
1d7c1841
GS
2849 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2850 PTR2UV(sv),SvIVX(sv)));
25da4f38 2851 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW
2852}
2853
891f9566
YST
2854/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
2855 * this function provided for binary compatibility only
2856 */
2857
2858UV
2859Perl_sv_2uv(pTHX_ register SV *sv)
2860{
2861 return sv_2uv_flags(sv, SV_GMAGIC);
2862}
2863
645c22ef 2864/*
891f9566 2865=for apidoc sv_2uv_flags
645c22ef
DM
2866
2867Return the unsigned integer value of an SV, doing any necessary string
891f9566
YST
2868conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2869Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
645c22ef
DM
2870
2871=cut
2872*/
2873
ff68c719 2874UV
891f9566 2875Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
ff68c719
PP
2876{
2877 if (!sv)
2878 return 0;
2879 if (SvGMAGICAL(sv)) {
891f9566
YST
2880 if (flags & SV_GMAGIC)
2881 mg_get(sv);
ff68c719
PP
2882 if (SvIOKp(sv))
2883 return SvUVX(sv);
2884 if (SvNOKp(sv))
2885 return U_V(SvNVX(sv));
36477c24
PP
2886 if (SvPOKp(sv) && SvLEN(sv))
2887 return asUV(sv);
3fe9a6f1 2888 if (!SvROK(sv)) {
d008e5eb 2889 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2890 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 2891 report_uninit(sv);
c6ee37c5 2892 }
36477c24 2893 return 0;
3fe9a6f1 2894 }
ff68c719
PP
2895 }
2896 if (SvTHINKFIRST(sv)) {
2897 if (SvROK(sv)) {
ff68c719 2898 SV* tmpstr;
1554e226 2899 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 2900 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2901 return SvUV(tmpstr);
56431972 2902 return PTR2UV(SvRV(sv));
ff68c719 2903 }
765f542d
NC
2904 if (SvIsCOW(sv)) {
2905 sv_force_normal_flags(sv, 0);
8a818333 2906 }
0336b60e 2907 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2908 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2909 report_uninit(sv);
ff68c719
PP
2910 return 0;
2911 }
2912 }
25da4f38
IZ
2913 if (SvIOKp(sv)) {
2914 if (SvIsUV(sv)) {
2915 return SvUVX(sv);
2916 }
2917 else {
2918 return (UV)SvIVX(sv);
2919 }
ff68c719
PP
2920 }
2921 if (SvNOKp(sv)) {
28e5dec8
JH
2922 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2923 * without also getting a cached IV/UV from it at the same time
2924 * (ie PV->NV conversion should detect loss of accuracy and cache
2925 * IV or UV at same time to avoid this. */
2926 /* IV-over-UV optimisation - choose to cache IV if possible */
2927
25da4f38
IZ
2928 if (SvTYPE(sv) == SVt_NV)
2929 sv_upgrade(sv, SVt_PVNV);
28e5dec8
JH
2930
2931 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2932 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 2933 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
2934 if (SvNVX(sv) == (NV) SvIVX(sv)
2935#ifndef NV_PRESERVES_UV
2936 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2937 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2938 /* Don't flag it as "accurately an integer" if the number
2939 came from a (by definition imprecise) NV operation, and
2940 we're outside the range of NV integer precision */
2941#endif
2942 ) {
2943 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2944 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2945 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2946 PTR2UV(sv),
2947 SvNVX(sv),
2948 SvIVX(sv)));
2949
2950 } else {
2951 /* IV not precise. No need to convert from PV, as NV
2952 conversion would already have cached IV if it detected
2953 that PV->IV would be better than PV->NV->IV
2954 flags already correct - don't set public IOK. */
2955 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2956 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2957 PTR2UV(sv),
2958 SvNVX(sv),
2959 SvIVX(sv)));
2960 }
2961 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2962 but the cast (NV)IV_MIN rounds to a the value less (more
2963 negative) than IV_MIN which happens to be equal to SvNVX ??
2964 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2965 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2966 (NV)UVX == NVX are both true, but the values differ. :-(
2967 Hopefully for 2s complement IV_MIN is something like
2968 0x8000000000000000 which will be exact. NWC */
d460ef45 2969 }
28e5dec8 2970 else {
607fa7f2 2971 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2972 if (
2973 (SvNVX(sv) == (NV) SvUVX(sv))
2974#ifndef NV_PRESERVES_UV
2975 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2976 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2977 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2978 /* Don't flag it as "accurately an integer" if the number
2979 came from a (by definition imprecise) NV operation, and
2980 we're outside the range of NV integer precision */
2981#endif
2982 )
2983 SvIOK_on(sv);
2984 SvIsUV_on(sv);
1c846c1f 2985 DEBUG_c(PerlIO_printf(Perl_debug_log,
28e5dec8 2986 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
57def98f 2987 PTR2UV(sv),
28e5dec8
JH
2988 SvUVX(sv),
2989 SvUVX(sv)));
25da4f38 2990 }
ff68c719
PP
2991 }
2992 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20
NC
2993 UV value;
2994 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
25da4f38
IZ
2995
2996 /* We want to avoid a possible problem when we cache a UV which
2997 may be later translated to an NV, and the resulting NV is not
2998 the translation of the initial data.
1c846c1f 2999
25da4f38
IZ
3000 This means that if we cache such a UV, we need to cache the
3001 NV as well. Moreover, we trade speed for space, and do not
3002 cache the NV if not needed.
3003 */
16b7a9a4 3004
c2988b20
NC
3005 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
3006 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3007 == IS_NUMBER_IN_UV) {
5e045b90 3008 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8 3009 if (SvTYPE(sv) < SVt_PVIV)
f7bbb42a
JH
3010 sv_upgrade(sv, SVt_PVIV);
3011 (void)SvIOK_on(sv);
c2988b20
NC
3012 } else if (SvTYPE(sv) < SVt_PVNV)
3013 sv_upgrade(sv, SVt_PVNV);
d460ef45 3014
c2988b20
NC
3015 /* If NV preserves UV then we only use the UV value if we know that
3016 we aren't going to call atof() below. If NVs don't preserve UVs
3017 then the value returned may have more precision than atof() will
3018 return, even though it isn't accurate. */
3019 if ((numtype & (IS_NUMBER_IN_UV
3020#ifdef NV_PRESERVES_UV
3021 | IS_NUMBER_NOT_INT
3022#endif
3023 )) == IS_NUMBER_IN_UV) {
3024 /* This won't turn off the public IOK flag if it was set above */
3025 (void)SvIOKp_on(sv);
3026
3027 if (!(numtype & IS_NUMBER_NEG)) {
3028 /* positive */;
3029 if (value <= (UV)IV_MAX) {
45977657 3030 SvIV_set(sv, (IV)value);
28e5dec8
JH
3031 } else {
3032 /* it didn't overflow, and it was positive. */
607fa7f2 3033 SvUV_set(sv, value);
28e5dec8
JH
3034 SvIsUV_on(sv);
3035 }
c2988b20
NC
3036 } else {
3037 /* 2s complement assumption */
3038 if (value <= (UV)IV_MIN) {
45977657 3039 SvIV_set(sv, -(IV)value);
c2988b20
NC
3040 } else {
3041 /* Too negative for an IV. This is a double upgrade, but
d1be9408 3042 I'm assuming it will be rare. */
c2988b20
NC
3043 if (SvTYPE(sv) < SVt_PVNV)
3044 sv_upgrade(sv, SVt_PVNV);
3045 SvNOK_on(sv);
3046 SvIOK_off(sv);
3047 SvIOKp_on(sv);
9d6ce603 3048 SvNV_set(sv, -(NV)value);
45977657 3049 SvIV_set(sv, IV_MIN);
c2988b20
NC
3050 }
3051 }
3052 }
3053
3054 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3055 != IS_NUMBER_IN_UV) {
3056 /* It wasn't an integer, or it overflowed the UV. */
9d6ce603 3057 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8 3058
c2988b20 3059 if (! numtype && ckWARN(WARN_NUMERIC))
28e5dec8
JH
3060 not_a_number(sv);
3061
3062#if defined(USE_LONG_DOUBLE)
c2988b20
NC
3063 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
3064 PTR2UV(sv), SvNVX(sv)));
28e5dec8 3065#else
1779d84d 3066 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
c2988b20 3067 PTR2UV(sv), SvNVX(sv)));
28e5dec8
JH
3068#endif
3069
3070#ifdef NV_PRESERVES_UV
c2988b20
NC
3071 (void)SvIOKp_on(sv);
3072 (void)SvNOK_on(sv);
3073 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 3074 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
3075 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
3076 SvIOK_on(sv);
3077 } else {
3078 /* Integer is imprecise. NOK, IOKp */
3079 }
3080 /* UV will not work better than IV */
3081 } else {
3082 if (SvNVX(sv) > (NV)UV_MAX) {
3083 SvIsUV_on(sv);
3084 /* Integer is inaccurate. NOK, IOKp, is UV */
607fa7f2 3085 SvUV_set(sv, UV_MAX);
c2988b20
NC
3086 SvIsUV_on(sv);
3087 } else {
607fa7f2 3088 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
3089 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
3090 NV preservse UV so can do correct comparison. */
3091 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
3092 SvIOK_on(sv);
3093 SvIsUV_on(sv);
3094 } else {
3095 /* Integer is imprecise. NOK, IOKp, is UV */
3096 SvIsUV_on(sv);
3097 }
3098 }
3099 }
28e5dec8 3100#else /* NV_PRESERVES_UV */
c2988b20
NC
3101 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3102 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
3103 /* The UV slot will have been set from value returned by
3104 grok_number above. The NV slot has just been set using
3105 Atof. */
560b0c46 3106 SvNOK_on(sv);
c2988b20
NC
3107 assert (SvIOKp(sv));
3108 } else {
3109 if (((UV)1 << NV_PRESERVES_UV_BITS) >
3110 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
3111 /* Small enough to preserve all bits. */
3112 (void)SvIOKp_on(sv);
3113 SvNOK_on(sv);
45977657 3114 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
3115 if ((NV)(SvIVX(sv)) == SvNVX(sv))
3116 SvIOK_on(sv);
3117 /* Assumption: first non-preserved integer is < IV_MAX,
3118 this NV is in the preserved range, therefore: */
3119 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
3120 < (UV)IV_MAX)) {
32fdb065 3121 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
3122 }
3123 } else
3124 sv_2iuv_non_preserve (sv, numtype);
3125 }
28e5dec8 3126#endif /* NV_PRESERVES_UV */
f7bbb42a 3127 }
ff68c719
PP
3128 }
3129 else {
d008e5eb 3130 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3131 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3132 report_uninit(sv);
c6ee37c5 3133 }
25da4f38
IZ
3134 if (SvTYPE(sv) < SVt_IV)
3135 /* Typically the caller expects that sv_any is not NULL now. */
3136 sv_upgrade(sv, SVt_IV);
ff68c719
PP
3137 return 0;
3138 }
25da4f38 3139
1d7c1841
GS
3140 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
3141 PTR2UV(sv),SvUVX(sv)));
25da4f38 3142 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP
3143}
3144
645c22ef
DM
3145/*
3146=for apidoc sv_2nv
3147
3148Return the num value of an SV, doing any necessary string or integer
3149conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
3150macros.
3151
3152=cut
3153*/
3154
65202027 3155NV
864dbfa3 3156Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW
3157{
3158 if (!sv)
3159 return 0.0;
8990e307 3160 if (SvGMAGICAL(sv)) {
463ee0b2
LW
3161 mg_get(sv);
3162 if (SvNOKp(sv))
3163 return SvNVX(sv);
a0d0e21e 3164 if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20
NC
3165 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
3166 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
a0d0e21e 3167 not_a_number(sv);
097ee67d 3168 return Atof(SvPVX(sv));
a0d0e21e 3169 }
25da4f38 3170 if (SvIOKp(sv)) {
1c846c1f 3171 if (SvIsUV(sv))
65202027 3172 return (NV)SvUVX(sv);
25da4f38 3173 else
65202027 3174 return (NV)SvIVX(sv);
25da4f38 3175 }
16d20bd9 3176 if (!SvROK(sv)) {
d008e5eb 3177 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3178 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3179 report_uninit(sv);
c6ee37c5 3180 }
16d20bd9
AD
3181 return 0;
3182 }
463ee0b2 3183 }
ed6116ce 3184 if (SvTHINKFIRST(sv)) {
a0d0e21e 3185 if (SvROK(sv)) {
a0d0e21e 3186 SV* tmpstr;
1554e226 3187 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
b4b9a328 3188 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 3189 return SvNV(tmpstr);
56431972 3190 return PTR2NV(SvRV(sv));
a0d0e21e 3191 }
765f542d
NC
3192 if (SvIsCOW(sv)) {
3193 sv_force_normal_flags(sv, 0);
8a818333 3194 }
0336b60e 3195 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 3196 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 3197 report_uninit(sv);
ed6116ce
LW
3198 return 0.0;
3199 }
79072805
LW
3200 }
3201 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW
3202 if (SvTYPE(sv) == SVt_IV)
3203 sv_upgrade(sv, SVt_PVNV);
3204 else
3205 sv_upgrade(sv, SVt_NV);
906f284f 3206#ifdef USE_LONG_DOUBLE
097ee67d 3207 DEBUG_c({
f93f4e46 3208 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
3209 PerlIO_printf(Perl_debug_log,
3210 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
3211 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
3212 RESTORE_NUMERIC_LOCAL();
3213 });
65202027 3214#else
572bbb43 3215 DEBUG_c({
f93f4e46 3216 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 3217 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
1d7c1841 3218 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
3219 RESTORE_NUMERIC_LOCAL();
3220 });
572bbb43 3221#endif
79072805
LW
3222 }
3223 else if (SvTYPE(sv) < SVt_PVNV)
3224 sv_upgrade(sv, SVt_PVNV);
59d8ce62
NC
3225 if (SvNOKp(sv)) {
3226 return SvNVX(sv);
61604483 3227 }
59d8ce62 3228 if (SvIOKp(sv)) {
9d6ce603 3229 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
28e5dec8
JH
3230#ifdef NV_PRESERVES_UV
3231 SvNOK_on(sv);
3232#else
3233 /* Only set the public NV OK flag if this NV preserves the IV */
3234 /* Check it's not 0xFFFFFFFFFFFFFFFF */
3235 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
3236 : (SvIVX(sv) == I_V(SvNVX(sv))))
3237 SvNOK_on(sv);
3238 else
3239 SvNOKp_on(sv);
3240#endif
93a17b20 3241 }
748a9306 3242 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20
NC
3243 UV value;
3244 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3245 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
a0d0e21e 3246 not_a_number(sv);
28e5dec8 3247#ifdef NV_PRESERVES_UV
c2988b20
NC
3248 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3249 == IS_NUMBER_IN_UV) {
5e045b90 3250 /* It's definitely an integer */
9d6ce603 3251 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
c2988b20 3252 } else
9d6ce603 3253 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8
JH
3254 SvNOK_on(sv);
3255#else
9d6ce603 3256 SvNV_set(sv, Atof(SvPVX(sv)));
28e5dec8
JH
3257 /* Only set the public NV OK flag if this NV preserves the value in
3258 the PV at least as well as an IV/UV would.
3259 Not sure how to do this 100% reliably. */
3260 /* if that shift count is out of range then Configure's test is
3261 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
3262 UV_BITS */
3263 if (((UV)1 << NV_PRESERVES_UV_BITS) >
c2988b20 3264 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
28e5dec8 3265 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
c2988b20
NC
3266 } else if (!(numtype & IS_NUMBER_IN_UV)) {
3267 /* Can't use strtol etc to convert this string, so don't try.
3268 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
3269 SvNOK_on(sv);
3270 } else {
3271 /* value has been set. It may not be precise. */
3272 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
3273 /* 2s complement assumption for (UV)IV_MIN */
3274 SvNOK_on(sv); /* Integer is too negative. */
3275 } else {
3276 SvNOKp_on(sv);
3277 SvIOKp_on(sv);
6fa402ec 3278
c2988b20 3279 if (numtype & IS_NUMBER_NEG) {
45977657 3280 SvIV_set(sv, -(IV)value);
c2988b20 3281 } else if (value <= (UV)IV_MAX) {
45977657 3282 SvIV_set(sv, (IV)value);
c2988b20 3283 } else {
607fa7f2 3284 SvUV_set(sv, value);
c2988b20
NC
3285 SvIsUV_on(sv);
3286 }
3287
3288 if (numtype & IS_NUMBER_NOT_INT) {
3289 /* I believe that even if the original PV had decimals,
3290 they are lost beyond the limit of the FP precision.
3291 However, neither is canonical, so both only get p
3292 flags. NWC, 2000/11/25 */
3293 /* Both already have p flags, so do nothing */
3294 } else {
3295 NV nv = SvNVX(sv);
3296 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
3297 if (SvIVX(sv) == I_V(nv)) {
3298 SvNOK_on(sv);
3299 SvIOK_on(sv);
3300 } else {
3301 SvIOK_on(sv);
3302 /* It had no "." so it must be integer. */
3303 }
3304 } else {
3305 /* between IV_MAX and NV(UV_MAX).
3306 Could be slightly > UV_MAX */
6fa402ec 3307
c2988b20
NC
3308 if (numtype & IS_NUMBER_NOT_INT) {
3309 /* UV and NV both imprecise. */
3310 } else {
3311 UV nv_as_uv = U_V(nv);
3312
3313 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
3314 SvNOK_on(sv);
3315 SvIOK_on(sv);
3316 } else {
3317 SvIOK_on(sv);
3318 }
3319 }
3320 }
3321 }
3322 }
3323 }
28e5dec8 3324#endif /* NV_PRESERVES_UV */
93a17b20 3325 }
79072805 3326 else {
599cee73 3327 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 3328 report_uninit(sv);
25da4f38
IZ
3329 if (SvTYPE(sv) < SVt_NV)
3330 /* Typically the caller expects that sv_any is not NULL now. */
28e5dec8
JH
3331 /* XXX Ilya implies that this is a bug in callers that assume this
3332 and ideally should be fixed. */
25da4f38 3333 sv_upgrade(sv, SVt_NV);
a0d0e21e 3334 return 0.0;
79072805 3335 }
572bbb43 3336#if defined(USE_LONG_DOUBLE)
097ee67d 3337 DEBUG_c({
f93f4e46 3338 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
3339 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
3340 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
3341 RESTORE_NUMERIC_LOCAL();
3342 });
65202027 3343#else
572bbb43 3344 DEBUG_c({
f93f4e46 3345 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 3346 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
1d7c1841 3347 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
3348 RESTORE_NUMERIC_LOCAL();
3349 });
572bbb43 3350#endif
463ee0b2 3351 return SvNVX(sv);
79072805
LW
3352}
3353
645c22ef
DM
3354/* asIV(): extract an integer from the string value of an SV.
3355 * Caller must validate PVX */
3356
76e3520e 3357STATIC IV
cea2e8a9 3358S_asIV(pTHX_ SV *sv)
36477c24 3359{
c2988b20
NC
3360 UV value;
3361 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
3362
3363 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3364 == IS_NUMBER_IN_UV) {
645c22ef 3365 /* It's definitely an integer */
c2988b20
NC
3366 if (numtype & IS_NUMBER_NEG) {
3367 if (value < (UV)IV_MIN)
3368 return -(IV)value;
3369 } else {
3370 if (value < (UV)IV_MAX)
3371 return (IV)value;
3372 }
3373 }
d008e5eb 3374 if (!numtype) {
d008e5eb
GS
3375 if (ckWARN(WARN_NUMERIC))
3376 not_a_number(sv);
3377 }
c2988b20 3378 return I_V(Atof(SvPVX(sv)));
36477c24
PP
3379}
3380
645c22ef
DM
3381/* asUV(): extract an unsigned integer from the string value of an SV
3382 * Caller must validate PVX */
3383
76e3520e 3384STATIC UV
cea2e8a9 3385S_asUV(pTHX_ SV *sv)
36477c24 3386{
c2988b20
NC
3387 UV value;
3388 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
36477c24 3389
c2988b20
NC
3390 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
3391 == IS_NUMBER_IN_UV) {
645c22ef 3392 /* It's definitely an integer */
6fa402ec 3393 if (!(numtype & IS_NUMBER_NEG))
c2988b20
NC
3394 return value;
3395 }
d008e5eb 3396 if (!numtype) {
d008e5eb
GS
3397 if (ckWARN(WARN_NUMERIC))
3398 not_a_number(sv);
3399 }
097ee67d 3400 return U_V(Atof(SvPVX(sv)));
36477c24
PP
3401}
3402
645c22ef
DM
3403/*
3404=for apidoc sv_2pv_nolen
3405
3406Like C<sv_2pv()>, but doesn't return the length too. You should usually
3407use the macro wrapper C<SvPV_nolen(sv)> instead.
3408=cut
3409*/
3410
79072805 3411char *
864dbfa3 3412Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD
3413{
3414 STRLEN n_a;
3415 return sv_2pv(sv, &n_a);
3416}
3417
645c22ef
DM
3418/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
3419 * UV as a string towards the end of buf, and return pointers to start and
3420 * end of it.
3421 *
3422 * We assume that buf is at least TYPE_CHARS(UV) long.
3423 */
3424
864dbfa3 3425static char *
25da4f38
IZ
3426uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
3427{
25da4f38
IZ
3428 char *ptr = buf + TYPE_CHARS(UV);
3429 char *ebuf = ptr;
3430 int sign;
25da4f38
IZ
3431
3432 if (is_uv)
3433 sign = 0;
3434 else if (iv >= 0) {
3435 uv = iv;
3436 sign = 0;
3437 } else {
3438 uv = -iv;
3439 sign = 1;
3440 }
3441 do {
eb160463 3442 *--ptr = '0' + (char)(uv % 10);
25da4f38
IZ
3443 } while (uv /= 10);
3444 if (sign)
3445 *--ptr = '-';
3446 *peob = ebuf;
3447 return ptr;
3448}
3449
09540bc3
JH
3450/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
3451 * this function provided for binary compatibility only
3452 */
3453
3454char *
3455Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
3456{
3457 return sv_2pv_flags(sv, lp, SV_GMAGIC);
3458}
3459
645c22ef
DM
3460/*
3461=for apidoc sv_2pv_flags
3462
ff276b08 3463Returns a pointer to the string value of an SV, and sets *lp to its length.
645c22ef
DM
3464If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
3465if necessary.
3466Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
3467usually end up here too.
3468
3469=cut
3470*/
3471
8d6d96c1
HS
3472char *
3473Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
3474{
79072805
LW
3475 register char *s;
3476 int olderrno;
cb50f42d 3477 SV *tsv, *origsv;
25da4f38
IZ
3478 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
3479 char *tmpbuf = tbuf;
79072805 3480
463ee0b2
LW
3481 if (!sv) {
3482 *lp = 0;
73d840c0 3483 return (char *)"";
463ee0b2 3484 }
8990e307 3485 if (SvGMAGICAL(sv)) {
8d6d96c1
HS
3486 if (flags & SV_GMAGIC)
3487 mg_get(sv);
463ee0b2
LW
3488 if (SvPOKp(sv)) {
3489 *lp = SvCUR(sv);
3490 return SvPVX(sv);
3491 }
cf2093f6 3492 if (SvIOKp(sv)) {
1c846c1f 3493 if (SvIsUV(sv))
57def98f 3494 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 3495 else
57def98f 3496 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 3497 tsv = Nullsv;
a0d0e21e 3498 goto tokensave;
463ee0b2
LW
3499 }
3500 if (SvNOKp(sv)) {
2d4389e4 3501 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 3502 tsv = Nullsv;
a0d0e21e 3503 goto tokensave;
463ee0b2 3504 }
16d20bd9 3505 if (!SvROK(sv)) {
d008e5eb 3506 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 3507 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
29489e7c 3508 report_uninit(sv);
c6ee37c5 3509 }
16d20bd9 3510 *lp = 0;
73d840c0 3511 return (char *)"";
16d20bd9 3512 }
463ee0b2 3513 }
ed6116ce
LW
3514 if (SvTHINKFIRST(sv)) {
3515 if (SvROK(sv)) {
a0d0e21e 3516 SV* tmpstr;
e1ec3a88 3517 register const char *typestr;
1554e226 3518 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
b4b9a328 3519 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
446eaa42
YST
3520 char *pv = SvPV(tmpstr, *lp);
3521 if (SvUTF8(tmpstr))
3522 SvUTF8_on(sv);
3523 else
3524 SvUTF8_off(sv);
3525 return pv;
3526 }
cb50f42d 3527 origsv = sv;
ed6116ce
LW
3528 sv = (SV*)SvRV(sv);
3529 if (!sv)
e1ec3a88 3530 typestr = "NULLREF";
ed6116ce 3531 else {
f9277f47
IZ
3532 MAGIC *mg;
3533
ed6116ce 3534 switch (SvTYPE(sv)) {
f9277f47
IZ
3535 case SVt_PVMG:
3536 if ( ((SvFLAGS(sv) &
1c846c1f 3537 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
faf82a0b 3538 == (SVs_OBJECT|SVs_SMG))
14befaf4 3539 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
e1ec3a88 3540 const regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 3541
2cd61cdb 3542 if (!mg->mg_ptr) {
e1ec3a88 3543 const char *fptr = "msix";
8782bef2
GB
3544 char reflags[6];
3545 char ch;
3546 int left = 0;
3547 int right = 4;
ff385a1b 3548 char need_newline = 0;
eb160463 3549 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
8782bef2 3550
155aba94 3551 while((ch = *fptr++)) {
8782bef2
GB
3552 if(reganch & 1) {
3553 reflags[left++] = ch;
3554 }
3555 else {
3556 reflags[right--] = ch;
3557 }
3558 reganch >>= 1;
3559 }
3560 if(left != 4) {
3561 reflags[left] = '-';
3562 left = 5;
3563 }
3564
3565 mg->mg_len = re->prelen + 4 + left;
ff385a1b
JF
3566 /*
3567 * If /x was used, we have to worry about a regex
3568 * ending with a comment later being embedded
3569 * within another regex. If so, we don't want this
3570 * regex's "commentization" to leak out to the
3571 * right part of the enclosing regex, we must cap
3572 * it with a newline.
3573 *
3574 * So, if /x was used, we scan backwards from the
3575 * end of the regex. If we find a '#' before we
3576 * find a newline, we need to add a newline
3577 * ourself. If we find a '\n' first (or if we
3578 * don't find '#' or '\n'), we don't need to add
3579 * anything. -jfriedl
3580 */
3581 if (PMf_EXTENDED & re->reganch)
3582 {
e1ec3a88 3583 const char *endptr = re->precomp + re->prelen;
ff385a1b
JF
3584 while (endptr >= re->precomp)
3585 {
e1ec3a88 3586 const char c = *(endptr--);
ff385a1b
JF
3587 if (c == '\n')
3588 break; /* don't need another */
3589 if (c == '#') {
3590 /* we end while in a comment, so we
3591 need a newline */
3592 mg->mg_len++; /* save space for it */
3593 need_newline = 1; /* note to add it */
ab01544f 3594 break;
ff385a1b
JF
3595 }
3596 }
3597 }
3598
8782bef2
GB
3599 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3600 Copy("(?", mg->mg_ptr, 2, char);
3601 Copy(reflags, mg->mg_ptr+2, left, char);
3602 Copy(":", mg->mg_ptr+left+2, 1, char);
3603 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
ff385a1b
JF
3604 if (need_newline)
3605 mg->mg_ptr[mg->mg_len - 2] = '\n';
1bd3ad17
IZ
3606 mg->mg_ptr[mg->mg_len - 1] = ')';
3607 mg->mg_ptr[mg->mg_len] = 0;
3608 }
3280af22 3609 PL_reginterp_cnt += re->program[0].next_off;
cb50f42d
YST
3610
3611 if (re->reganch & ROPT_UTF8)
3612 SvUTF8_on(origsv);
3613 else
3614 SvUTF8_off(origsv);
1bd3ad17
IZ
3615 *lp = mg->mg_len;
3616 return mg->mg_ptr;
f9277f47
IZ
3617 }
3618 /* Fall through */
ed6116ce
LW
3619 case SVt_NULL:
3620 case SVt_IV:
3621 case SVt_NV:
3622 case SVt_RV:
3623 case SVt_PV:
3624 case SVt_PVIV:
3625 case SVt_PVNV:
e1ec3a88
AL
3626 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3627 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
be65207d
DM
3628 /* tied lvalues should appear to be
3629 * scalars for backwards compatitbility */
3630 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3631 ? "SCALAR" : "LVALUE"; break;
e1ec3a88
AL
3632 case SVt_PVAV: typestr = "ARRAY"; break;
3633 case SVt_PVHV: typestr = "HASH"; break;
3634 case SVt_PVCV: typestr = "CODE"; break;
3635 case SVt_PVGV: typestr = "GLOB"; break;
3636 case SVt_PVFM: typestr = "FORMAT"; break;
3637 case SVt_PVIO: typestr = "IO"; break;
3638 default: typestr = "UNKNOWN"; break;
ed6116ce 3639 }
46fc3d4c 3640 tsv = NEWSV(0,0);
a5cb6b62
NC
3641 if (SvOBJECT(sv)) {
3642 const char *name = HvNAME(SvSTASH(sv));
3643 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
e1ec3a88 3644 name ? name : "__ANON__" , typestr, PTR2UV(sv));
a5cb6b62 3645 }
ed6116ce 3646 else
e1ec3a88 3647 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
a0d0e21e 3648 goto tokensaveref;
463ee0b2 3649 }
e1ec3a88 3650 *lp = strlen(typestr);
73d840c0 3651 return (char *)typestr;
79072805 3652 }
0336b60e 3653 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 3654 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 3655 report_uninit(sv);
ed6116ce 3656 *lp = 0;
73d840c0 3657 return (char *)"";
79072805 3658 }
79072805 3659 }
28e5dec8
JH
3660 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3661 /* I'm assuming that if both IV and NV are equally valid then
3662 converting the IV is going to be more efficient */
e1ec3a88
AL
3663 const U32 isIOK = SvIOK(sv);
3664 const U32 isUIOK = SvIsUV(sv);
28e5dec8
JH
3665 char buf[TYPE_CHARS(UV)];
3666 char *ebuf, *ptr;
3667
3668 if (SvTYPE(sv) < SVt_PVIV)
3669 sv_upgrade(sv, SVt_PVIV);
3670 if (isUIOK)
3671 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3672 else
3673 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
eb160463 3674 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
28e5dec8
JH
3675 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3676 SvCUR_set(sv, ebuf - ptr);
3677 s = SvEND(sv);
3678 *s = '\0';
3679 if (isIOK)
3680 SvIOK_on(sv);
3681 else
3682 SvIOKp_on(sv);
3683 if (isUIOK)
3684 SvIsUV_on(sv);
3685 }
3686 else if (SvNOKp(sv)) {
79072805
LW
3687 if (SvTYPE(sv) < SVt_PVNV)
3688 sv_upgrade(sv, SVt_PVNV);
1c846c1f 3689 /* The +20 is pure guesswork. Configure test needed. --jhi */
59155cc0 3690 SvGROW(sv, NV_DIG + 20);
463ee0b2 3691 s = SvPVX(sv);
79072805 3692 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 3693#ifdef apollo
463ee0b2 3694 if (SvNVX(sv) == 0.0)
79072805
LW
3695 (void)strcpy(s,"0");
3696 else
3697#endif /*apollo*/
bbce6d69 3698 {
2d4389e4 3699 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 3700 }
79072805 3701 errno = olderrno;
a0d0e21e
LW
3702#ifdef FIXNEGATIVEZERO
3703 if (*s == '-' && s[1] == '0' && !s[2])
3704 strcpy(s,"0");
3705#endif
79072805
LW
3706 while (*s) s++;
3707#ifdef hcx
3708 if (s[-1] == '.')
46fc3d4c 3709 *--s = '\0';
79072805
LW
3710#endif
3711 }
79072805 3712 else {
0336b60e
IZ
3713 if (ckWARN(WARN_UNINITIALIZED)
3714 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
29489e7c 3715 report_uninit(sv);
a0d0e21e 3716 *lp = 0;
25da4f38
IZ
3717 if (SvTYPE(sv) < SVt_PV)
3718 /* Typically the caller expects that sv_any is not NULL now. */
3719 sv_upgrade(sv, SVt_PV);
73d840c0 3720 return (char *)"";
79072805 3721 }
463ee0b2
LW
3722 *lp = s - SvPVX(sv);
3723 SvCUR_set(sv, *lp);
79072805 3724 SvPOK_on(sv);
1d7c1841
GS
3725 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3726 PTR2UV(sv),SvPVX(sv)));
463ee0b2 3727 return SvPVX(sv);
a0d0e21e
LW
3728
3729 tokensave:
3730 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3731 /* Sneaky stuff here */
3732
3733 tokensaveref:
46fc3d4c 3734 if (!tsv)
96827780 3735 tsv = newSVpv(tmpbuf, 0);
46fc3d4c
PP
3736 sv_2mortal(tsv);
3737 *lp = SvCUR(tsv);
3738 return SvPVX(tsv);
a0d0e21e
LW
3739 }
3740 else {
3741 STRLEN len;
73d840c0 3742 const char *t;
46fc3d4c
PP
3743
3744 if (tsv) {
3745 sv_2mortal(tsv);
3746 t = SvPVX(tsv);
3747 len = SvCUR(tsv);
3748 }
3749 else {
96827780
MB
3750 t = tmpbuf;
3751 len = strlen(tmpbuf);
46fc3d4c 3752 }
a0d0e21e 3753#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
3754 if (len == 2 && t[0] == '-' && t[1] == '0') {
3755 t = "0";
3756 len = 1;
3757 }
a0d0e21e
LW
3758#endif
3759 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 3760 *lp = len;
a0d0e21e
LW
3761 s = SvGROW(sv, len + 1);
3762 SvCUR_set(sv, len);
6bf554b4 3763 SvPOKp_on(sv);
e90e2364 3764 return strcpy(s, t);
a0d0e21e 3765 }
463ee0b2
LW
3766}
3767
645c22ef 3768/*
6050d10e
JP
3769=for apidoc sv_copypv
3770
3771Copies a stringified representation of the source SV into the
3772destination SV. Automatically performs any necessary mg_get and
54f0641b 3773coercion of numeric values into strings. Guaranteed to preserve
6050d10e 3774UTF-8 flag even from overloaded objects. Similar in nature to
54f0641b
NIS
3775sv_2pv[_flags] but operates directly on an SV instead of just the
3776string. Mostly uses sv_2pv_flags to do its work, except when that
6050d10e
JP
3777would lose the UTF-8'ness of the PV.
3778
3779=cut
3780*/
3781
3782void
3783Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3784{
446eaa42
YST
3785 STRLEN len;
3786 char *s;
3787 s = SvPV(ssv,len);
cb50f42d 3788 sv_setpvn(dsv,s,len);
446eaa42 3789 if (SvUTF8(ssv))
cb50f42d 3790 SvUTF8_on(dsv);
446eaa42 3791 else
cb50f42d 3792 SvUTF8_off(dsv);
6050d10e
JP
3793}
3794
3795/*
645c22ef
DM
3796=for apidoc sv_2pvbyte_nolen
3797
3798Return a pointer to the byte-encoded representation of the SV.
1e54db1a 3799May cause the SV to be downgraded from UTF-8 as a side-effect.
645c22ef
DM
3800
3801Usually accessed via the C<SvPVbyte_nolen> macro.
3802
3803=cut
3804*/
3805
7340a771
GS
3806char *
3807Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3808{
560a288e
GS
3809 STRLEN n_a;
3810 return sv_2pvbyte(sv, &n_a);
7340a771
GS
3811}
3812
645c22ef
DM
3813/*
3814=for apidoc sv_2pvbyte
3815
3816Return a pointer to the byte-encoded representation of the SV, and set *lp
1e54db1a 3817to its length. May cause the SV to be downgraded from UTF-8 as a
645c22ef
DM
3818side-effect.
3819
3820Usually accessed via the C<SvPVbyte> macro.
3821
3822=cut
3823*/
3824
7340a771
GS
3825char *
3826Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3827{
0875d2fe
NIS
3828 sv_utf8_downgrade(sv,0);
3829 return SvPV(sv,*lp);
7340a771
GS
3830}
3831
645c22ef
DM
3832/*
3833=for apidoc sv_2pvutf8_nolen
3834
1e54db1a
JH
3835Return a pointer to the UTF-8-encoded representation of the SV.
3836May cause the SV to be upgraded to UTF-8 as a side-effect.
645c22ef
DM
3837
3838Usually accessed via the C<SvPVutf8_nolen> macro.
3839
3840=cut
3841*/
3842
7340a771
GS
3843char *
3844Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3845{
560a288e
GS
3846 STRLEN n_a;
3847 return sv_2pvutf8(sv, &n_a);
7340a771
GS
3848}
3849
645c22ef
DM
3850/*
3851=for apidoc sv_2pvutf8
3852
1e54db1a
JH
3853Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3854to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
645c22ef
DM
3855
3856Usually accessed via the C<SvPVutf8> macro.
3857
3858=cut
3859*/
3860