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