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