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