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