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