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