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