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