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