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