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