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