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