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