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