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