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