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