This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #72090] unitialized variable name wrong with no strict refs
[perl5.git] / sv.c
CommitLineData
a0d0e21e 1/* sv.c
79072805 2 *
1129b882 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
83706693
RGS
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
5 * and others
79072805
LW
6 *
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
9 *
4ac71550
TC
10 */
11
12/*
13 * 'I wonder what the Entish is for "yes" and "no",' he thought.
14 * --Pippin
15 *
16 * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
17 */
18
19/*
645c22ef
DM
20 *
21 *
5e045b90
AMS
22 * This file contains the code that creates, manipulates and destroys
23 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24 * structure of an SV, so their creation and destruction is handled
25 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26 * level functions (eg. substr, split, join) for each of the types are
27 * in the pp*.c files.
79072805
LW
28 */
29
30#include "EXTERN.h"
864dbfa3 31#define PERL_IN_SV_C
79072805 32#include "perl.h"
d2f185dc 33#include "regcomp.h"
79072805 34
51371543 35#define FCALL *f
2c5424a7 36
2f8ed50e
OS
37#ifdef __Lynx__
38/* Missing proto on LynxOS */
39 char *gconvert(double, int, int, char *);
40#endif
41
e23c8137 42#ifdef PERL_UTF8_CACHE_ASSERT
ab455f60 43/* if adding more checks watch out for the following tests:
e23c8137
JH
44 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
45 * lib/utf8.t lib/Unicode/Collate/t/index.t
46 * --jhi
47 */
6f207bd3 48# define ASSERT_UTF8_CACHE(cache) \
ab455f60
NC
49 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
50 assert((cache)[2] <= (cache)[3]); \
51 assert((cache)[3] <= (cache)[1]);} \
52 } STMT_END
e23c8137 53#else
6f207bd3 54# define ASSERT_UTF8_CACHE(cache) NOOP
e23c8137
JH
55#endif
56
f8c7b90f 57#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 58#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
607fa7f2 59#define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
b5ccf5f2 60/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
765f542d 61 on-write. */
765f542d 62#endif
645c22ef
DM
63
64/* ============================================================================
65
66=head1 Allocation and deallocation of SVs.
67
d2a0f284
JC
68An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
69sv, av, hv...) contains type and reference count information, and for
70many types, a pointer to the body (struct xrv, xpv, xpviv...), which
71contains fields specific to each type. Some types store all they need
72in the head, so don't have a body.
73
74In all but the most memory-paranoid configuations (ex: PURIFY), heads
75and bodies are allocated out of arenas, which by default are
76approximately 4K chunks of memory parcelled up into N heads or bodies.
93e68bfb
JC
77Sv-bodies are allocated by their sv-type, guaranteeing size
78consistency needed to allocate safely from arrays.
79
d2a0f284
JC
80For SV-heads, the first slot in each arena is reserved, and holds a
81link to the next arena, some flags, and a note of the number of slots.
82Snaked through each arena chain is a linked list of free items; when
83this becomes empty, an extra arena is allocated and divided up into N
84items which are threaded into the free list.
85
86SV-bodies are similar, but they use arena-sets by default, which
87separate the link and info from the arena itself, and reclaim the 1st
88slot in the arena. SV-bodies are further described later.
645c22ef
DM
89
90The following global variables are associated with arenas:
91
92 PL_sv_arenaroot pointer to list of SV arenas
93 PL_sv_root pointer to list of free SV structures
94
d2a0f284
JC
95 PL_body_arenas head of linked-list of body arenas
96 PL_body_roots[] array of pointers to list of free bodies of svtype
97 arrays are indexed by the svtype needed
93e68bfb 98
d2a0f284
JC
99A few special SV heads are not allocated from an arena, but are
100instead directly created in the interpreter structure, eg PL_sv_undef.
93e68bfb
JC
101The size of arenas can be changed from the default by setting
102PERL_ARENA_SIZE appropriately at compile time.
645c22ef
DM
103
104The SV arena serves the secondary purpose of allowing still-live SVs
105to be located and destroyed during final cleanup.
106
107At the lowest level, the macros new_SV() and del_SV() grab and free
108an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
109to return the SV to the free list with error checking.) new_SV() calls
110more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
111SVs in the free list have their SvTYPE field set to all ones.
112
ff276b08 113At the time of very final cleanup, sv_free_arenas() is called from
645c22ef 114perl_destruct() to physically free all the arenas allocated since the
6a93a7e5 115start of the interpreter.
645c22ef 116
645c22ef
DM
117The function visit() scans the SV arenas list, and calls a specified
118function for each SV it finds which is still live - ie which has an SvTYPE
119other than all 1's, and a non-zero SvREFCNT. visit() is used by the
120following functions (specified as [function that calls visit()] / [function
121called by visit() for each SV]):
122
123 sv_report_used() / do_report_used()
f2524eef 124 dump all remaining SVs (debugging aid)
645c22ef 125
e4487e9b
DM
126 sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
127 do_clean_named_io_objs()
645c22ef 128 Attempt to free all objects pointed to by RVs,
c3b19b5c 129 and try to do the same for all objects indirectly
645c22ef
DM
130 referenced by typeglobs too. Called once from
131 perl_destruct(), prior to calling sv_clean_all()
132 below.
133
134 sv_clean_all() / do_clean_all()
135 SvREFCNT_dec(sv) each remaining SV, possibly
136 triggering an sv_free(). It also sets the
137 SVf_BREAK flag on the SV to indicate that the
138 refcnt has been artificially lowered, and thus
139 stopping sv_free() from giving spurious warnings
140 about SVs which unexpectedly have a refcnt
141 of zero. called repeatedly from perl_destruct()
142 until there are no SVs left.
143
93e68bfb 144=head2 Arena allocator API Summary
645c22ef
DM
145
146Private API to rest of sv.c
147
148 new_SV(), del_SV(),
149
df0f0429 150 new_XPVNV(), del_XPVGV(),
645c22ef
DM
151 etc
152
153Public API:
154
8cf8f3d1 155 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
645c22ef 156
645c22ef
DM
157=cut
158
3e8320cc 159 * ========================================================================= */
645c22ef 160
4561caa4
CS
161/*
162 * "A time to plant, and a time to uproot what was planted..."
163 */
164
d7a2c63c
MHM
165#ifdef PERL_MEM_LOG
166# define MEM_LOG_NEW_SV(sv, file, line, func) \
167 Perl_mem_log_new_sv(sv, file, line, func)
168# define MEM_LOG_DEL_SV(sv, file, line, func) \
169 Perl_mem_log_del_sv(sv, file, line, func)
170#else
171# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP
172# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP
173#endif
174
fd0854ff 175#ifdef DEBUG_LEAKING_SCALARS
22162ca8 176# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
d7a2c63c
MHM
177# define DEBUG_SV_SERIAL(sv) \
178 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
179 PTR2UV(sv), (long)(sv)->sv_debug_serial))
fd0854ff
DM
180#else
181# define FREE_SV_DEBUG_FILE(sv)
d7a2c63c 182# define DEBUG_SV_SERIAL(sv) NOOP
fd0854ff
DM
183#endif
184
48614a46
NC
185#ifdef PERL_POISON
186# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
daba3364 187# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val))
48614a46
NC
188/* Whilst I'd love to do this, it seems that things like to check on
189 unreferenced scalars
7e337ee0 190# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
48614a46 191*/
7e337ee0
JH
192# define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
193 PoisonNew(&SvREFCNT(sv), 1, U32)
48614a46
NC
194#else
195# define SvARENA_CHAIN(sv) SvANY(sv)
3eef1deb 196# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val)
48614a46
NC
197# define POSION_SV_HEAD(sv)
198#endif
199
990198f0
DM
200/* Mark an SV head as unused, and add to free list.
201 *
202 * If SVf_BREAK is set, skip adding it to the free list, as this SV had
203 * its refcount artificially decremented during global destruction, so
204 * there may be dangling pointers to it. The last thing we want in that
205 * case is for it to be reused. */
206
053fc874
GS
207#define plant_SV(p) \
208 STMT_START { \
990198f0 209 const U32 old_flags = SvFLAGS(p); \
d7a2c63c
MHM
210 MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \
211 DEBUG_SV_SERIAL(p); \
fd0854ff 212 FREE_SV_DEBUG_FILE(p); \
48614a46 213 POSION_SV_HEAD(p); \
053fc874 214 SvFLAGS(p) = SVTYPEMASK; \
990198f0 215 if (!(old_flags & SVf_BREAK)) { \
3eef1deb 216 SvARENA_CHAIN_SET(p, PL_sv_root); \
990198f0
DM
217 PL_sv_root = (p); \
218 } \
053fc874
GS
219 --PL_sv_count; \
220 } STMT_END
a0d0e21e 221
053fc874
GS
222#define uproot_SV(p) \
223 STMT_START { \
224 (p) = PL_sv_root; \
daba3364 225 PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \
053fc874
GS
226 ++PL_sv_count; \
227 } STMT_END
228
645c22ef 229
cac9b346
NC
230/* make some more SVs by adding another arena */
231
cac9b346
NC
232STATIC SV*
233S_more_sv(pTHX)
234{
97aff369 235 dVAR;
cac9b346 236 SV* sv;
9a87bd09
NC
237 char *chunk; /* must use New here to match call to */
238 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
239 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
cac9b346
NC
240 uproot_SV(sv);
241 return sv;
242}
243
645c22ef
DM
244/* new_SV(): return a new, empty SV head */
245
eba0f806
DM
246#ifdef DEBUG_LEAKING_SCALARS
247/* provide a real function for a debugger to play with */
248STATIC SV*
d7a2c63c 249S_new_SV(pTHX_ const char *file, int line, const char *func)
eba0f806
DM
250{
251 SV* sv;
252
eba0f806
DM
253 if (PL_sv_root)
254 uproot_SV(sv);
255 else
cac9b346 256 sv = S_more_sv(aTHX);
eba0f806
DM
257 SvANY(sv) = 0;
258 SvREFCNT(sv) = 1;
259 SvFLAGS(sv) = 0;
fd0854ff 260 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
e385c3bf
DM
261 sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
262 ? PL_parser->copline
263 : PL_curcop
f24aceb1
DM
264 ? CopLINE(PL_curcop)
265 : 0
e385c3bf 266 );
fd0854ff 267 sv->sv_debug_inpad = 0;
cd676548 268 sv->sv_debug_parent = NULL;
fd0854ff 269 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
d7a2c63c
MHM
270
271 sv->sv_debug_serial = PL_sv_serial++;
272
273 MEM_LOG_NEW_SV(sv, file, line, func);
274 DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
275 PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
276
eba0f806
DM
277 return sv;
278}
d7a2c63c 279# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
eba0f806
DM
280
281#else
282# define new_SV(p) \
053fc874 283 STMT_START { \
053fc874
GS
284 if (PL_sv_root) \
285 uproot_SV(p); \
286 else \
cac9b346 287 (p) = S_more_sv(aTHX); \
053fc874
GS
288 SvANY(p) = 0; \
289 SvREFCNT(p) = 1; \
290 SvFLAGS(p) = 0; \
d7a2c63c 291 MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \
053fc874 292 } STMT_END
eba0f806 293#endif
463ee0b2 294
645c22ef
DM
295
296/* del_SV(): return an empty SV head to the free list */
297
a0d0e21e 298#ifdef DEBUGGING
4561caa4 299
053fc874
GS
300#define del_SV(p) \
301 STMT_START { \
aea4f609 302 if (DEBUG_D_TEST) \
053fc874
GS
303 del_sv(p); \
304 else \
305 plant_SV(p); \
053fc874 306 } STMT_END
a0d0e21e 307
76e3520e 308STATIC void
cea2e8a9 309S_del_sv(pTHX_ SV *p)
463ee0b2 310{
97aff369 311 dVAR;
7918f24d
NC
312
313 PERL_ARGS_ASSERT_DEL_SV;
314
aea4f609 315 if (DEBUG_D_TEST) {
4633a7c4 316 SV* sva;
a3b680e6 317 bool ok = 0;
daba3364 318 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
53c1dcc0
AL
319 const SV * const sv = sva + 1;
320 const SV * const svend = &sva[SvREFCNT(sva)];
c0ff570e 321 if (p >= sv && p < svend) {
a0d0e21e 322 ok = 1;
c0ff570e
NC
323 break;
324 }
a0d0e21e
LW
325 }
326 if (!ok) {
9b387841
NC
327 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
328 "Attempt to free non-arena SV: 0x%"UVxf
329 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
a0d0e21e
LW
330 return;
331 }
332 }
4561caa4 333 plant_SV(p);
463ee0b2 334}
a0d0e21e 335
4561caa4
CS
336#else /* ! DEBUGGING */
337
338#define del_SV(p) plant_SV(p)
339
340#endif /* DEBUGGING */
463ee0b2 341
645c22ef
DM
342
343/*
ccfc67b7
JH
344=head1 SV Manipulation Functions
345
645c22ef
DM
346=for apidoc sv_add_arena
347
348Given a chunk of memory, link it to the head of the list of arenas,
349and split it into a list of free SVs.
350
351=cut
352*/
353
d2bd4e7f
NC
354static void
355S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
463ee0b2 356{
97aff369 357 dVAR;
daba3364 358 SV *const sva = MUTABLE_SV(ptr);
463ee0b2
LW
359 register SV* sv;
360 register SV* svend;
4633a7c4 361
7918f24d
NC
362 PERL_ARGS_ASSERT_SV_ADD_ARENA;
363
4633a7c4 364 /* The first SV in an arena isn't an SV. */
3280af22 365 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
4633a7c4
LW
366 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
367 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
368
3280af22
NIS
369 PL_sv_arenaroot = sva;
370 PL_sv_root = sva + 1;
4633a7c4
LW
371
372 svend = &sva[SvREFCNT(sva) - 1];
373 sv = sva + 1;
463ee0b2 374 while (sv < svend) {
3eef1deb 375 SvARENA_CHAIN_SET(sv, (sv + 1));
03e36789 376#ifdef DEBUGGING
978b032e 377 SvREFCNT(sv) = 0;
03e36789 378#endif
4b69cbe3 379 /* Must always set typemask because it's always checked in on cleanup
03e36789 380 when the arenas are walked looking for objects. */
8990e307 381 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW
382 sv++;
383 }
3eef1deb 384 SvARENA_CHAIN_SET(sv, 0);
03e36789
NC
385#ifdef DEBUGGING
386 SvREFCNT(sv) = 0;
387#endif
4633a7c4
LW
388 SvFLAGS(sv) = SVTYPEMASK;
389}
390
055972dc
DM
391/* visit(): call the named function for each non-free SV in the arenas
392 * whose flags field matches the flags/mask args. */
645c22ef 393
5226ed68 394STATIC I32
de37a194 395S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
8990e307 396{
97aff369 397 dVAR;
4633a7c4 398 SV* sva;
5226ed68 399 I32 visited = 0;
8990e307 400
7918f24d
NC
401 PERL_ARGS_ASSERT_VISIT;
402
daba3364 403 for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
53c1dcc0 404 register const SV * const svend = &sva[SvREFCNT(sva)];
a3b680e6 405 register SV* sv;
4561caa4 406 for (sv = sva + 1; sv < svend; ++sv) {
055972dc
DM
407 if (SvTYPE(sv) != SVTYPEMASK
408 && (sv->sv_flags & mask) == flags
409 && SvREFCNT(sv))
410 {
acfe0abc 411 (FCALL)(aTHX_ sv);
5226ed68
JH
412 ++visited;
413 }
8990e307
LW
414 }
415 }
5226ed68 416 return visited;
8990e307
LW
417}
418
758a08c3
JH
419#ifdef DEBUGGING
420
645c22ef
DM
421/* called by sv_report_used() for each live SV */
422
423static void
5fa45a31 424do_report_used(pTHX_ SV *const sv)
645c22ef
DM
425{
426 if (SvTYPE(sv) != SVTYPEMASK) {
427 PerlIO_printf(Perl_debug_log, "****\n");
428 sv_dump(sv);
429 }
430}
758a08c3 431#endif
645c22ef
DM
432
433/*
434=for apidoc sv_report_used
435
436Dump the contents of all SVs not yet freed. (Debugging aid).
437
438=cut
439*/
440
8990e307 441void
864dbfa3 442Perl_sv_report_used(pTHX)
4561caa4 443{
ff270d3a 444#ifdef DEBUGGING
055972dc 445 visit(do_report_used, 0, 0);
96a5add6
AL
446#else
447 PERL_UNUSED_CONTEXT;
ff270d3a 448#endif
4561caa4
CS
449}
450
645c22ef
DM
451/* called by sv_clean_objs() for each live SV */
452
453static void
de37a194 454do_clean_objs(pTHX_ SV *const ref)
645c22ef 455{
97aff369 456 dVAR;
ea724faa
NC
457 assert (SvROK(ref));
458 {
823a54a3
AL
459 SV * const target = SvRV(ref);
460 if (SvOBJECT(target)) {
461 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
462 if (SvWEAKREF(ref)) {
463 sv_del_backref(target, ref);
464 SvWEAKREF_off(ref);
465 SvRV_set(ref, NULL);
466 } else {
467 SvROK_off(ref);
468 SvRV_set(ref, NULL);
469 SvREFCNT_dec(target);
470 }
645c22ef
DM
471 }
472 }
473
474 /* XXX Might want to check arrays, etc. */
475}
476
645c22ef 477
e4487e9b
DM
478/* clear any slots in a GV which hold objects - except IO;
479 * called by sv_clean_objs() for each live GV */
480
645c22ef 481static void
f30de749 482do_clean_named_objs(pTHX_ SV *const sv)
645c22ef 483{
97aff369 484 dVAR;
57ef47cc 485 SV *obj;
ea724faa 486 assert(SvTYPE(sv) == SVt_PVGV);
d011219a 487 assert(isGV_with_GP(sv));
57ef47cc
DM
488 if (!GvGP(sv))
489 return;
490
491 /* freeing GP entries may indirectly free the current GV;
492 * hold onto it while we mess with the GP slots */
493 SvREFCNT_inc(sv);
494
495 if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
496 DEBUG_D((PerlIO_printf(Perl_debug_log,
497 "Cleaning named glob SV object:\n "), sv_dump(obj)));
498 GvSV(sv) = NULL;
499 SvREFCNT_dec(obj);
500 }
501 if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
502 DEBUG_D((PerlIO_printf(Perl_debug_log,
503 "Cleaning named glob AV object:\n "), sv_dump(obj)));
504 GvAV(sv) = NULL;
505 SvREFCNT_dec(obj);
506 }
507 if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
508 DEBUG_D((PerlIO_printf(Perl_debug_log,
509 "Cleaning named glob HV object:\n "), sv_dump(obj)));
510 GvHV(sv) = NULL;
511 SvREFCNT_dec(obj);
512 }
513 if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
514 DEBUG_D((PerlIO_printf(Perl_debug_log,
515 "Cleaning named glob CV object:\n "), sv_dump(obj)));
516 GvCV(sv) = NULL;
517 SvREFCNT_dec(obj);
518 }
e4487e9b
DM
519 SvREFCNT_dec(sv); /* undo the inc above */
520}
521
68b590d9 522/* clear any IO slots in a GV which hold objects (except stderr, defout);
e4487e9b
DM
523 * called by sv_clean_objs() for each live GV */
524
525static void
526do_clean_named_io_objs(pTHX_ SV *const sv)
527{
528 dVAR;
529 SV *obj;
530 assert(SvTYPE(sv) == SVt_PVGV);
531 assert(isGV_with_GP(sv));
68b590d9 532 if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
e4487e9b
DM
533 return;
534
535 SvREFCNT_inc(sv);
57ef47cc
DM
536 if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
537 DEBUG_D((PerlIO_printf(Perl_debug_log,
538 "Cleaning named glob IO object:\n "), sv_dump(obj)));
539 GvIOp(sv) = NULL;
540 SvREFCNT_dec(obj);
645c22ef 541 }
57ef47cc 542 SvREFCNT_dec(sv); /* undo the inc above */
645c22ef 543}
645c22ef
DM
544
545/*
546=for apidoc sv_clean_objs
547
548Attempt to destroy all objects not yet freed
549
550=cut
551*/
552
4561caa4 553void
864dbfa3 554Perl_sv_clean_objs(pTHX)
4561caa4 555{
97aff369 556 dVAR;
68b590d9 557 GV *olddef, *olderr;
3280af22 558 PL_in_clean_objs = TRUE;
055972dc 559 visit(do_clean_objs, SVf_ROK, SVf_ROK);
e4487e9b
DM
560 /* Some barnacles may yet remain, clinging to typeglobs.
561 * Run the non-IO destructors first: they may want to output
562 * error messages, close files etc */
d011219a 563 visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
e4487e9b 564 visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
68b590d9
DM
565 olddef = PL_defoutgv;
566 PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
567 if (olddef && isGV_with_GP(olddef))
568 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
569 olderr = PL_stderrgv;
570 PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
571 if (olderr && isGV_with_GP(olderr))
572 do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
573 SvREFCNT_dec(olddef);
3280af22 574 PL_in_clean_objs = FALSE;
4561caa4
CS
575}
576
645c22ef
DM
577/* called by sv_clean_all() for each live SV */
578
579static void
de37a194 580do_clean_all(pTHX_ SV *const sv)
645c22ef 581{
97aff369 582 dVAR;
daba3364 583 if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
cddfcddc 584 /* don't clean pid table and strtab */
d17ea597 585 return;
cddfcddc 586 }
645c22ef
DM
587 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
588 SvFLAGS(sv) |= SVf_BREAK;
589 SvREFCNT_dec(sv);
590}
591
592/*
593=for apidoc sv_clean_all
594
595Decrement the refcnt of each remaining SV, possibly triggering a
596cleanup. This function may have to be called multiple times to free
ff276b08 597SVs which are in complex self-referential hierarchies.
645c22ef
DM
598
599=cut
600*/
601
5226ed68 602I32
864dbfa3 603Perl_sv_clean_all(pTHX)
8990e307 604{
97aff369 605 dVAR;
5226ed68 606 I32 cleaned;
3280af22 607 PL_in_clean_all = TRUE;
055972dc 608 cleaned = visit(do_clean_all, 0,0);
5226ed68 609 return cleaned;
8990e307 610}
463ee0b2 611
5e258f8c
JC
612/*
613 ARENASETS: a meta-arena implementation which separates arena-info
614 into struct arena_set, which contains an array of struct
615 arena_descs, each holding info for a single arena. By separating
616 the meta-info from the arena, we recover the 1st slot, formerly
617 borrowed for list management. The arena_set is about the size of an
39244528 618 arena, avoiding the needless malloc overhead of a naive linked-list.
5e258f8c
JC
619
620 The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
621 memory in the last arena-set (1/2 on average). In trade, we get
622 back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
d2a0f284 623 smaller types). The recovery of the wasted space allows use of
e15dad31
JC
624 small arenas for large, rare body types, by changing array* fields
625 in body_details_by_type[] below.
5e258f8c 626*/
5e258f8c 627struct arena_desc {
398c677b
NC
628 char *arena; /* the raw storage, allocated aligned */
629 size_t size; /* its size ~4k typ */
e5973ed5 630 svtype utype; /* bodytype stored in arena */
5e258f8c
JC
631};
632
e6148039
NC
633struct arena_set;
634
635/* Get the maximum number of elements in set[] such that struct arena_set
e15dad31 636 will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
e6148039
NC
637 therefore likely to be 1 aligned memory page. */
638
639#define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
640 - 2 * sizeof(int)) / sizeof (struct arena_desc))
5e258f8c
JC
641
642struct arena_set {
643 struct arena_set* next;
0a848332
NC
644 unsigned int set_size; /* ie ARENAS_PER_SET */
645 unsigned int curr; /* index of next available arena-desc */
5e258f8c
JC
646 struct arena_desc set[ARENAS_PER_SET];
647};
648
645c22ef
DM
649/*
650=for apidoc sv_free_arenas
651
652Deallocate the memory used by all arenas. Note that all the individual SV
653heads and bodies within the arenas must already have been freed.
654
655=cut
656*/
4633a7c4 657void
864dbfa3 658Perl_sv_free_arenas(pTHX)
4633a7c4 659{
97aff369 660 dVAR;
4633a7c4
LW
661 SV* sva;
662 SV* svanext;
0a848332 663 unsigned int i;
4633a7c4
LW
664
665 /* Free arenas here, but be careful about fake ones. (We assume
666 contiguity of the fake ones with the corresponding real ones.) */
667
3280af22 668 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
daba3364 669 svanext = MUTABLE_SV(SvANY(sva));
4633a7c4 670 while (svanext && SvFAKE(svanext))
daba3364 671 svanext = MUTABLE_SV(SvANY(svanext));
4633a7c4
LW
672
673 if (!SvFAKE(sva))
1df70142 674 Safefree(sva);
4633a7c4 675 }
93e68bfb 676
5e258f8c 677 {
0a848332
NC
678 struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
679
680 while (aroot) {
681 struct arena_set *current = aroot;
682 i = aroot->curr;
683 while (i--) {
5e258f8c
JC
684 assert(aroot->set[i].arena);
685 Safefree(aroot->set[i].arena);
686 }
0a848332
NC
687 aroot = aroot->next;
688 Safefree(current);
5e258f8c
JC
689 }
690 }
dc8220bf 691 PL_body_arenas = 0;
fdda85ca 692
0a848332
NC
693 i = PERL_ARENA_ROOTS_SIZE;
694 while (i--)
93e68bfb 695 PL_body_roots[i] = 0;
93e68bfb 696
3280af22
NIS
697 PL_sv_arenaroot = 0;
698 PL_sv_root = 0;
4633a7c4
LW
699}
700
bd81e77b
NC
701/*
702 Here are mid-level routines that manage the allocation of bodies out
703 of the various arenas. There are 5 kinds of arenas:
29489e7c 704
bd81e77b
NC
705 1. SV-head arenas, which are discussed and handled above
706 2. regular body arenas
707 3. arenas for reduced-size bodies
708 4. Hash-Entry arenas
29489e7c 709
bd81e77b
NC
710 Arena types 2 & 3 are chained by body-type off an array of
711 arena-root pointers, which is indexed by svtype. Some of the
712 larger/less used body types are malloced singly, since a large
713 unused block of them is wasteful. Also, several svtypes dont have
714 bodies; the data fits into the sv-head itself. The arena-root
715 pointer thus has a few unused root-pointers (which may be hijacked
716 later for arena types 4,5)
29489e7c 717
bd81e77b
NC
718 3 differs from 2 as an optimization; some body types have several
719 unused fields in the front of the structure (which are kept in-place
720 for consistency). These bodies can be allocated in smaller chunks,
721 because the leading fields arent accessed. Pointers to such bodies
722 are decremented to point at the unused 'ghost' memory, knowing that
723 the pointers are used with offsets to the real memory.
29489e7c 724
d2a0f284
JC
725
726=head1 SV-Body Allocation
727
728Allocation of SV-bodies is similar to SV-heads, differing as follows;
729the allocation mechanism is used for many body types, so is somewhat
730more complicated, it uses arena-sets, and has no need for still-live
731SV detection.
732
733At the outermost level, (new|del)_X*V macros return bodies of the
734appropriate type. These macros call either (new|del)_body_type or
735(new|del)_body_allocated macro pairs, depending on specifics of the
736type. Most body types use the former pair, the latter pair is used to
737allocate body types with "ghost fields".
738
739"ghost fields" are fields that are unused in certain types, and
69ba284b 740consequently don't need to actually exist. They are declared because
d2a0f284
JC
741they're part of a "base type", which allows use of functions as
742methods. The simplest examples are AVs and HVs, 2 aggregate types
743which don't use the fields which support SCALAR semantics.
744
69ba284b 745For these types, the arenas are carved up into appropriately sized
d2a0f284
JC
746chunks, we thus avoid wasted memory for those unaccessed members.
747When bodies are allocated, we adjust the pointer back in memory by the
69ba284b 748size of the part not allocated, so it's as if we allocated the full
d2a0f284
JC
749structure. (But things will all go boom if you write to the part that
750is "not there", because you'll be overwriting the last members of the
751preceding structure in memory.)
752
69ba284b
NC
753We calculate the correction using the STRUCT_OFFSET macro on the first
754member present. If the allocated structure is smaller (no initial NV
755actually allocated) then the net effect is to subtract the size of the NV
756from the pointer, to return a new pointer as if an initial NV were actually
757allocated. (We were using structures named *_allocated for this, but
758this turned out to be a subtle bug, because a structure without an NV
759could have a lower alignment constraint, but the compiler is allowed to
760optimised accesses based on the alignment constraint of the actual pointer
761to the full structure, for example, using a single 64 bit load instruction
762because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
d2a0f284
JC
763
764This is the same trick as was used for NV and IV bodies. Ironically it
765doesn't need to be used for NV bodies any more, because NV is now at
766the start of the structure. IV bodies don't need it either, because
767they are no longer allocated.
768
769In turn, the new_body_* allocators call S_new_body(), which invokes
770new_body_inline macro, which takes a lock, and takes a body off the
1e30fcd5 771linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
d2a0f284
JC
772necessary to refresh an empty list. Then the lock is released, and
773the body is returned.
774
99816f8d 775Perl_more_bodies allocates a new arena, and carves it up into an array of N
d2a0f284
JC
776bodies, which it strings into a linked list. It looks up arena-size
777and body-size from the body_details table described below, thus
778supporting the multiple body-types.
779
780If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
781the (new|del)_X*V macros are mapped directly to malloc/free.
782
d2a0f284
JC
783For each sv-type, struct body_details bodies_by_type[] carries
784parameters which control these aspects of SV handling:
785
786Arena_size determines whether arenas are used for this body type, and if
787so, how big they are. PURIFY or PERL_ARENA_SIZE=0 set this field to
788zero, forcing individual mallocs and frees.
789
790Body_size determines how big a body is, and therefore how many fit into
791each arena. Offset carries the body-pointer adjustment needed for
69ba284b 792"ghost fields", and is used in *_allocated macros.
d2a0f284
JC
793
794But its main purpose is to parameterize info needed in
795Perl_sv_upgrade(). The info here dramatically simplifies the function
69ba284b 796vs the implementation in 5.8.8, making it table-driven. All fields
d2a0f284
JC
797are used for this, except for arena_size.
798
799For the sv-types that have no bodies, arenas are not used, so those
800PL_body_roots[sv_type] are unused, and can be overloaded. In
801something of a special case, SVt_NULL is borrowed for HE arenas;
c6f8b1d0 802PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
d2a0f284 803bodies_by_type[SVt_NULL] slot is not used, as the table is not
c6f8b1d0 804available in hv.c.
d2a0f284 805
29489e7c
DM
806*/
807
bd81e77b 808struct body_details {
0fb58b32 809 U8 body_size; /* Size to allocate */
10666ae3 810 U8 copy; /* Size of structure to copy (may be shorter) */
0fb58b32 811 U8 offset;
10666ae3
NC
812 unsigned int type : 4; /* We have space for a sanity check. */
813 unsigned int cant_upgrade : 1; /* Cannot upgrade this type */
814 unsigned int zero_nv : 1; /* zero the NV when upgrading from this */
815 unsigned int arena : 1; /* Allocated from an arena */
816 size_t arena_size; /* Size of arena to allocate */
bd81e77b 817};
29489e7c 818
bd81e77b
NC
819#define HADNV FALSE
820#define NONV TRUE
29489e7c 821
d2a0f284 822
bd81e77b
NC
823#ifdef PURIFY
824/* With -DPURFIY we allocate everything directly, and don't use arenas.
825 This seems a rather elegant way to simplify some of the code below. */
826#define HASARENA FALSE
827#else
828#define HASARENA TRUE
829#endif
830#define NOARENA FALSE
29489e7c 831
d2a0f284
JC
832/* Size the arenas to exactly fit a given number of bodies. A count
833 of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
834 simplifying the default. If count > 0, the arena is sized to fit
835 only that many bodies, allowing arenas to be used for large, rare
836 bodies (XPVFM, XPVIO) without undue waste. The arena size is
837 limited by PERL_ARENA_SIZE, so we can safely oversize the
838 declarations.
839 */
95db5f15
MB
840#define FIT_ARENA0(body_size) \
841 ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
842#define FIT_ARENAn(count,body_size) \
843 ( count * body_size <= PERL_ARENA_SIZE) \
844 ? count * body_size \
845 : FIT_ARENA0 (body_size)
846#define FIT_ARENA(count,body_size) \
847 count \
848 ? FIT_ARENAn (count, body_size) \
849 : FIT_ARENA0 (body_size)
d2a0f284 850
bd81e77b
NC
851/* Calculate the length to copy. Specifically work out the length less any
852 final padding the compiler needed to add. See the comment in sv_upgrade
853 for why copying the padding proved to be a bug. */
29489e7c 854
bd81e77b
NC
855#define copy_length(type, last_member) \
856 STRUCT_OFFSET(type, last_member) \
daba3364 857 + sizeof (((type*)SvANY((const SV *)0))->last_member)
29489e7c 858
bd81e77b 859static const struct body_details bodies_by_type[] = {
829cd18a
NC
860 /* HEs use this offset for their arena. */
861 { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
d2a0f284 862
1cb9cd50 863 /* The bind placeholder pretends to be an RV for now.
c6f8b1d0 864 Also it's marked as "can't upgrade" to stop anyone using it before it's
1cb9cd50
NC
865 implemented. */
866 { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
867
db93c0c4
NC
868 /* IVs are in the head, so the allocation size is 0. */
869 { 0,
d2a0f284 870 sizeof(IV), /* This is used to copy out the IV body. */
10666ae3 871 STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
db93c0c4 872 NOARENA /* IVS don't need an arena */, 0
d2a0f284
JC
873 },
874
bd81e77b 875 /* 8 bytes on most ILP32 with IEEE doubles */
6e128786
NC
876 { sizeof(NV), sizeof(NV),
877 STRUCT_OFFSET(XPVNV, xnv_u),
878 SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
d2a0f284 879
bd81e77b 880 /* 8 bytes on most ILP32 with IEEE doubles */
bc337e5c 881 { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
889d28b2
NC
882 copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
883 + STRUCT_OFFSET(XPV, xpv_cur),
69ba284b 884 SVt_PV, FALSE, NONV, HASARENA,
889d28b2 885 FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
d2a0f284 886
bd81e77b 887 /* 12 */
bc337e5c 888 { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
889d28b2
NC
889 copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
890 + STRUCT_OFFSET(XPV, xpv_cur),
891 SVt_PVIV, FALSE, NONV, HASARENA,
892 FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
d2a0f284 893
889d28b2 894 /* 20 */
bc337e5c 895 { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
889d28b2
NC
896 copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
897 + STRUCT_OFFSET(XPV, xpv_cur),
898 SVt_PVNV, FALSE, HADNV, HASARENA,
899 FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
d2a0f284 900
bd81e77b 901 /* 28 */
6e128786 902 { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
d2a0f284 903 HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
4df7f6af 904
288b8c02 905 /* something big */
601dfd0a
NC
906 { sizeof(regexp),
907 sizeof(regexp),
908 0,
08e44740 909 SVt_REGEXP, FALSE, NONV, HASARENA,
eaeb1e7f 910 FIT_ARENA(0, sizeof(regexp))
5c35adbb 911 },
4df7f6af 912
bd81e77b 913 /* 48 */
10666ae3 914 { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
d2a0f284
JC
915 HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
916
bd81e77b 917 /* 64 */
10666ae3 918 { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
d2a0f284
JC
919 HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
920
601dfd0a 921 { sizeof(XPVAV),
4f7003f5 922 copy_length(XPVAV, xav_alloc),
601dfd0a 923 0,
69ba284b 924 SVt_PVAV, TRUE, NONV, HASARENA,
601dfd0a 925 FIT_ARENA(0, sizeof(XPVAV)) },
d2a0f284 926
601dfd0a 927 { sizeof(XPVHV),
359164a0 928 copy_length(XPVHV, xhv_max),
601dfd0a 929 0,
69ba284b 930 SVt_PVHV, TRUE, NONV, HASARENA,
601dfd0a 931 FIT_ARENA(0, sizeof(XPVHV)) },
d2a0f284 932
c84c4652 933 /* 56 */
601dfd0a
NC
934 { sizeof(XPVCV),
935 sizeof(XPVCV),
936 0,
69ba284b 937 SVt_PVCV, TRUE, NONV, HASARENA,
601dfd0a 938 FIT_ARENA(0, sizeof(XPVCV)) },
69ba284b 939
601dfd0a
NC
940 { sizeof(XPVFM),
941 sizeof(XPVFM),
942 0,
69ba284b 943 SVt_PVFM, TRUE, NONV, NOARENA,
601dfd0a 944 FIT_ARENA(20, sizeof(XPVFM)) },
d2a0f284
JC
945
946 /* XPVIO is 84 bytes, fits 48x */
601dfd0a
NC
947 { sizeof(XPVIO),
948 sizeof(XPVIO),
949 0,
b6f60916 950 SVt_PVIO, TRUE, NONV, HASARENA,
601dfd0a 951 FIT_ARENA(24, sizeof(XPVIO)) },
bd81e77b 952};
29489e7c 953
bd81e77b 954#define new_body_allocated(sv_type) \
d2a0f284 955 (void *)((char *)S_new_body(aTHX_ sv_type) \
bd81e77b 956 - bodies_by_type[sv_type].offset)
29489e7c 957
26359cfa
NC
958/* return a thing to the free list */
959
960#define del_body(thing, root) \
961 STMT_START { \
962 void ** const thing_copy = (void **)thing; \
963 *thing_copy = *root; \
964 *root = (void*)thing_copy; \
965 } STMT_END
29489e7c 966
bd81e77b 967#ifdef PURIFY
29489e7c 968
beeec492
NC
969#define new_XNV() safemalloc(sizeof(XPVNV))
970#define new_XPVNV() safemalloc(sizeof(XPVNV))
971#define new_XPVMG() safemalloc(sizeof(XPVMG))
29489e7c 972
beeec492 973#define del_XPVGV(p) safefree(p)
29489e7c 974
bd81e77b 975#else /* !PURIFY */
29489e7c 976
65ac1738 977#define new_XNV() new_body_allocated(SVt_NV)
65ac1738 978#define new_XPVNV() new_body_allocated(SVt_PVNV)
65ac1738 979#define new_XPVMG() new_body_allocated(SVt_PVMG)
645c22ef 980
26359cfa
NC
981#define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \
982 &PL_body_roots[SVt_PVGV])
1d7c1841 983
bd81e77b 984#endif /* PURIFY */
93e68bfb 985
bd81e77b 986/* no arena for you! */
93e68bfb 987
bd81e77b 988#define new_NOARENA(details) \
beeec492 989 safemalloc((details)->body_size + (details)->offset)
bd81e77b 990#define new_NOARENAZ(details) \
beeec492 991 safecalloc((details)->body_size + (details)->offset, 1)
d2a0f284 992
1e30fcd5
NC
993void *
994Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
995 const size_t arena_size)
d2a0f284
JC
996{
997 dVAR;
998 void ** const root = &PL_body_roots[sv_type];
99816f8d
NC
999 struct arena_desc *adesc;
1000 struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1001 unsigned int curr;
d2a0f284
JC
1002 char *start;
1003 const char *end;
02982131 1004 const size_t good_arena_size = Perl_malloc_good_size(arena_size);
0b2d3faa 1005#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
23e9d66c
NC
1006 static bool done_sanity_check;
1007
0b2d3faa
JH
1008 /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1009 * variables like done_sanity_check. */
10666ae3 1010 if (!done_sanity_check) {
ea471437 1011 unsigned int i = SVt_LAST;
10666ae3
NC
1012
1013 done_sanity_check = TRUE;
1014
1015 while (i--)
1016 assert (bodies_by_type[i].type == i);
1017 }
1018#endif
1019
02982131 1020 assert(arena_size);
23e9d66c 1021
99816f8d
NC
1022 /* may need new arena-set to hold new arena */
1023 if (!aroot || aroot->curr >= aroot->set_size) {
1024 struct arena_set *newroot;
1025 Newxz(newroot, 1, struct arena_set);
1026 newroot->set_size = ARENAS_PER_SET;
1027 newroot->next = aroot;
1028 aroot = newroot;
1029 PL_body_arenas = (void *) newroot;
1030 DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1031 }
1032
1033 /* ok, now have arena-set with at least 1 empty/available arena-desc */
1034 curr = aroot->curr++;
1035 adesc = &(aroot->set[curr]);
1036 assert(!adesc->arena);
1037
1038 Newx(adesc->arena, good_arena_size, char);
1039 adesc->size = good_arena_size;
1040 adesc->utype = sv_type;
1041 DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
1042 curr, (void*)adesc->arena, (UV)good_arena_size));
1043
1044 start = (char *) adesc->arena;
d2a0f284 1045
29657bb6
NC
1046 /* Get the address of the byte after the end of the last body we can fit.
1047 Remember, this is integer division: */
02982131 1048 end = start + good_arena_size / body_size * body_size;
d2a0f284 1049
d2a0f284 1050 /* computed count doesnt reflect the 1st slot reservation */
d8fca402
NC
1051#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1052 DEBUG_m(PerlIO_printf(Perl_debug_log,
1053 "arena %p end %p arena-size %d (from %d) type %d "
1054 "size %d ct %d\n",
02982131
NC
1055 (void*)start, (void*)end, (int)good_arena_size,
1056 (int)arena_size, sv_type, (int)body_size,
1057 (int)good_arena_size / (int)body_size));
d8fca402 1058#else
d2a0f284
JC
1059 DEBUG_m(PerlIO_printf(Perl_debug_log,
1060 "arena %p end %p arena-size %d type %d size %d ct %d\n",
6c9570dc 1061 (void*)start, (void*)end,
02982131
NC
1062 (int)arena_size, sv_type, (int)body_size,
1063 (int)good_arena_size / (int)body_size));
d8fca402 1064#endif
d2a0f284
JC
1065 *root = (void *)start;
1066
29657bb6
NC
1067 while (1) {
1068 /* Where the next body would start: */
d2a0f284 1069 char * const next = start + body_size;
29657bb6
NC
1070
1071 if (next >= end) {
1072 /* This is the last body: */
1073 assert(next == end);
1074
1075 *(void **)start = 0;
1076 return *root;
1077 }
1078
d2a0f284
JC
1079 *(void**) start = (void *)next;
1080 start = next;
1081 }
d2a0f284
JC
1082}
1083
1084/* grab a new thing from the free list, allocating more if necessary.
1085 The inline version is used for speed in hot routines, and the
1086 function using it serves the rest (unless PURIFY).
1087*/
1088#define new_body_inline(xpv, sv_type) \
1089 STMT_START { \
1090 void ** const r3wt = &PL_body_roots[sv_type]; \
11b79775 1091 xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
1e30fcd5 1092 ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
02982131
NC
1093 bodies_by_type[sv_type].body_size,\
1094 bodies_by_type[sv_type].arena_size)); \
d2a0f284 1095 *(r3wt) = *(void**)(xpv); \
d2a0f284
JC
1096 } STMT_END
1097
1098#ifndef PURIFY
1099
1100STATIC void *
de37a194 1101S_new_body(pTHX_ const svtype sv_type)
d2a0f284
JC
1102{
1103 dVAR;
1104 void *xpv;
1105 new_body_inline(xpv, sv_type);
1106 return xpv;
1107}
1108
1109#endif
93e68bfb 1110
238b27b3
NC
1111static const struct body_details fake_rv =
1112 { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1113
bd81e77b
NC
1114/*
1115=for apidoc sv_upgrade
93e68bfb 1116
bd81e77b
NC
1117Upgrade an SV to a more complex form. Generally adds a new body type to the
1118SV, then copies across as much information as possible from the old body.
1119You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
93e68bfb 1120
bd81e77b 1121=cut
93e68bfb 1122*/
93e68bfb 1123
bd81e77b 1124void
aad570aa 1125Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
cac9b346 1126{
97aff369 1127 dVAR;
bd81e77b
NC
1128 void* old_body;
1129 void* new_body;
42d0e0b7 1130 const svtype old_type = SvTYPE(sv);
d2a0f284 1131 const struct body_details *new_type_details;
238b27b3 1132 const struct body_details *old_type_details
bd81e77b 1133 = bodies_by_type + old_type;
4df7f6af 1134 SV *referant = NULL;
cac9b346 1135
7918f24d
NC
1136 PERL_ARGS_ASSERT_SV_UPGRADE;
1137
1776cbe8
NC
1138 if (old_type == new_type)
1139 return;
1140
1141 /* This clause was purposefully added ahead of the early return above to
1142 the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1143 inference by Nick I-S that it would fix other troublesome cases. See
1144 changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1145
1146 Given that shared hash key scalars are no longer PVIV, but PV, there is
1147 no longer need to unshare so as to free up the IVX slot for its proper
1148 purpose. So it's safe to move the early return earlier. */
1149
bd81e77b
NC
1150 if (new_type != SVt_PV && SvIsCOW(sv)) {
1151 sv_force_normal_flags(sv, 0);
1152 }
cac9b346 1153
bd81e77b 1154 old_body = SvANY(sv);
de042e1d 1155
bd81e77b
NC
1156 /* Copying structures onto other structures that have been neatly zeroed
1157 has a subtle gotcha. Consider XPVMG
cac9b346 1158
bd81e77b
NC
1159 +------+------+------+------+------+-------+-------+
1160 | NV | CUR | LEN | IV | MAGIC | STASH |
1161 +------+------+------+------+------+-------+-------+
1162 0 4 8 12 16 20 24 28
645c22ef 1163
bd81e77b
NC
1164 where NVs are aligned to 8 bytes, so that sizeof that structure is
1165 actually 32 bytes long, with 4 bytes of padding at the end:
08742458 1166
bd81e77b
NC
1167 +------+------+------+------+------+-------+-------+------+
1168 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1169 +------+------+------+------+------+-------+-------+------+
1170 0 4 8 12 16 20 24 28 32
08742458 1171
bd81e77b 1172 so what happens if you allocate memory for this structure:
30f9da9e 1173
bd81e77b
NC
1174 +------+------+------+------+------+-------+-------+------+------+...
1175 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1176 +------+------+------+------+------+-------+-------+------+------+...
1177 0 4 8 12 16 20 24 28 32 36
bfc44f79 1178
bd81e77b
NC
1179 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1180 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1181 started out as zero once, but it's quite possible that it isn't. So now,
1182 rather than a nicely zeroed GP, you have it pointing somewhere random.
1183 Bugs ensue.
bfc44f79 1184
bd81e77b
NC
1185 (In fact, GP ends up pointing at a previous GP structure, because the
1186 principle cause of the padding in XPVMG getting garbage is a copy of
6c9e42f7
NC
1187 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1188 this happens to be moot because XPVGV has been re-ordered, with GP
1189 no longer after STASH)
30f9da9e 1190
bd81e77b
NC
1191 So we are careful and work out the size of used parts of all the
1192 structures. */
bfc44f79 1193
bd81e77b
NC
1194 switch (old_type) {
1195 case SVt_NULL:
1196 break;
1197 case SVt_IV:
4df7f6af
NC
1198 if (SvROK(sv)) {
1199 referant = SvRV(sv);
238b27b3
NC
1200 old_type_details = &fake_rv;
1201 if (new_type == SVt_NV)
1202 new_type = SVt_PVNV;
4df7f6af
NC
1203 } else {
1204 if (new_type < SVt_PVIV) {
1205 new_type = (new_type == SVt_NV)
1206 ? SVt_PVNV : SVt_PVIV;
1207 }
bd81e77b
NC
1208 }
1209 break;
1210 case SVt_NV:
1211 if (new_type < SVt_PVNV) {
1212 new_type = SVt_PVNV;
bd81e77b
NC
1213 }
1214 break;
bd81e77b
NC
1215 case SVt_PV:
1216 assert(new_type > SVt_PV);
1217 assert(SVt_IV < SVt_PV);
1218 assert(SVt_NV < SVt_PV);
1219 break;
1220 case SVt_PVIV:
1221 break;
1222 case SVt_PVNV:
1223 break;
1224 case SVt_PVMG:
1225 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1226 there's no way that it can be safely upgraded, because perl.c
1227 expects to Safefree(SvANY(PL_mess_sv)) */
1228 assert(sv != PL_mess_sv);
1229 /* This flag bit is used to mean other things in other scalar types.
1230 Given that it only has meaning inside the pad, it shouldn't be set
1231 on anything that can get upgraded. */
00b1698f 1232 assert(!SvPAD_TYPED(sv));
bd81e77b
NC
1233 break;
1234 default:
1235 if (old_type_details->cant_upgrade)
c81225bc
NC
1236 Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1237 sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
bd81e77b 1238 }
3376de98
NC
1239
1240 if (old_type > new_type)
1241 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1242 (int)old_type, (int)new_type);
1243
2fa1109b 1244 new_type_details = bodies_by_type + new_type;
645c22ef 1245
bd81e77b
NC
1246 SvFLAGS(sv) &= ~SVTYPEMASK;
1247 SvFLAGS(sv) |= new_type;
932e9ff9 1248
ab4416c0
NC
1249 /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1250 the return statements above will have triggered. */
1251 assert (new_type != SVt_NULL);
bd81e77b 1252 switch (new_type) {
bd81e77b
NC
1253 case SVt_IV:
1254 assert(old_type == SVt_NULL);
1255 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1256 SvIV_set(sv, 0);
1257 return;
1258 case SVt_NV:
1259 assert(old_type == SVt_NULL);
1260 SvANY(sv) = new_XNV();
1261 SvNV_set(sv, 0);
1262 return;
bd81e77b 1263 case SVt_PVHV:
bd81e77b 1264 case SVt_PVAV:
d2a0f284 1265 assert(new_type_details->body_size);
c1ae03ae
NC
1266
1267#ifndef PURIFY
1268 assert(new_type_details->arena);
d2a0f284 1269 assert(new_type_details->arena_size);
c1ae03ae 1270 /* This points to the start of the allocated area. */
d2a0f284
JC
1271 new_body_inline(new_body, new_type);
1272 Zero(new_body, new_type_details->body_size, char);
c1ae03ae
NC
1273 new_body = ((char *)new_body) - new_type_details->offset;
1274#else
1275 /* We always allocated the full length item with PURIFY. To do this
1276 we fake things so that arena is false for all 16 types.. */
1277 new_body = new_NOARENAZ(new_type_details);
1278#endif
1279 SvANY(sv) = new_body;
1280 if (new_type == SVt_PVAV) {
1281 AvMAX(sv) = -1;
1282 AvFILLp(sv) = -1;
1283 AvREAL_only(sv);
64484faa 1284 if (old_type_details->body_size) {
ac572bf4
NC
1285 AvALLOC(sv) = 0;
1286 } else {
1287 /* It will have been zeroed when the new body was allocated.
1288 Lets not write to it, in case it confuses a write-back
1289 cache. */
1290 }
78ac7dd9
NC
1291 } else {
1292 assert(!SvOK(sv));
1293 SvOK_off(sv);
1294#ifndef NODEFAULT_SHAREKEYS
1295 HvSHAREKEYS_on(sv); /* key-sharing on by default */
1296#endif
1297 HvMAX(sv) = 7; /* (start with 8 buckets) */
c1ae03ae 1298 }
aeb18a1e 1299
bd81e77b
NC
1300 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1301 The target created by newSVrv also is, and it can have magic.
1302 However, it never has SvPVX set.
1303 */
4df7f6af
NC
1304 if (old_type == SVt_IV) {
1305 assert(!SvROK(sv));
1306 } else if (old_type >= SVt_PV) {
bd81e77b
NC
1307 assert(SvPVX_const(sv) == 0);
1308 }
aeb18a1e 1309
bd81e77b 1310 if (old_type >= SVt_PVMG) {
e736a858 1311 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
bd81e77b 1312 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
797c7171
NC
1313 } else {
1314 sv->sv_u.svu_array = NULL; /* or svu_hash */
bd81e77b
NC
1315 }
1316 break;
93e68bfb 1317
93e68bfb 1318
b9ad13ac
NC
1319 case SVt_REGEXP:
1320 /* This ensures that SvTHINKFIRST(sv) is true, and hence that
1321 sv_force_normal_flags(sv) is called. */
1322 SvFAKE_on(sv);
bd81e77b
NC
1323 case SVt_PVIV:
1324 /* XXX Is this still needed? Was it ever needed? Surely as there is
1325 no route from NV to PVIV, NOK can never be true */
1326 assert(!SvNOKp(sv));
1327 assert(!SvNOK(sv));
1328 case SVt_PVIO:
1329 case SVt_PVFM:
bd81e77b
NC
1330 case SVt_PVGV:
1331 case SVt_PVCV:
1332 case SVt_PVLV:
1333 case SVt_PVMG:
1334 case SVt_PVNV:
1335 case SVt_PV:
93e68bfb 1336
d2a0f284 1337 assert(new_type_details->body_size);
bd81e77b
NC
1338 /* We always allocated the full length item with PURIFY. To do this
1339 we fake things so that arena is false for all 16 types.. */
1340 if(new_type_details->arena) {
1341 /* This points to the start of the allocated area. */
d2a0f284
JC
1342 new_body_inline(new_body, new_type);
1343 Zero(new_body, new_type_details->body_size, char);
bd81e77b
NC
1344 new_body = ((char *)new_body) - new_type_details->offset;
1345 } else {
1346 new_body = new_NOARENAZ(new_type_details);
1347 }
1348 SvANY(sv) = new_body;
5e2fc214 1349
bd81e77b 1350 if (old_type_details->copy) {
f9ba3d20
NC
1351 /* There is now the potential for an upgrade from something without
1352 an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */
1353 int offset = old_type_details->offset;
1354 int length = old_type_details->copy;
1355
1356 if (new_type_details->offset > old_type_details->offset) {
d4c19fe8 1357 const int difference
f9ba3d20
NC
1358 = new_type_details->offset - old_type_details->offset;
1359 offset += difference;
1360 length -= difference;
1361 }
1362 assert (length >= 0);
1363
1364 Copy((char *)old_body + offset, (char *)new_body + offset, length,
1365 char);
bd81e77b
NC
1366 }
1367
1368#ifndef NV_ZERO_IS_ALLBITS_ZERO
f2524eef 1369 /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
e5ce394c
NC
1370 * correct 0.0 for us. Otherwise, if the old body didn't have an
1371 * NV slot, but the new one does, then we need to initialise the
1372 * freshly created NV slot with whatever the correct bit pattern is
1373 * for 0.0 */
e22a937e
NC
1374 if (old_type_details->zero_nv && !new_type_details->zero_nv
1375 && !isGV_with_GP(sv))
bd81e77b 1376 SvNV_set(sv, 0);
82048762 1377#endif
5e2fc214 1378
85dca89a
NC
1379 if (new_type == SVt_PVIO) {
1380 IO * const io = MUTABLE_IO(sv);
d963bf01 1381 GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
85dca89a
NC
1382
1383 SvOBJECT_on(io);
1384 /* Clear the stashcache because a new IO could overrule a package
1385 name */
1386 hv_clear(PL_stashcache);
1387
85dca89a 1388 SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
f2524eef 1389 IoPAGE_LEN(sv) = 60;
85dca89a 1390 }
4df7f6af
NC
1391 if (old_type < SVt_PV) {
1392 /* referant will be NULL unless the old type was SVt_IV emulating
1393 SVt_RV */
1394 sv->sv_u.svu_rv = referant;
1395 }
bd81e77b
NC
1396 break;
1397 default:
afd78fd5
JH
1398 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1399 (unsigned long)new_type);
bd81e77b 1400 }
73171d91 1401
db93c0c4 1402 if (old_type > SVt_IV) {
bd81e77b 1403#ifdef PURIFY
beeec492 1404 safefree(old_body);
bd81e77b 1405#else
bc786448
GG
1406 /* Note that there is an assumption that all bodies of types that
1407 can be upgraded came from arenas. Only the more complex non-
1408 upgradable types are allowed to be directly malloc()ed. */
1409 assert(old_type_details->arena);
bd81e77b
NC
1410 del_body((void*)((char*)old_body + old_type_details->offset),
1411 &PL_body_roots[old_type]);
1412#endif
1413 }
1414}
73171d91 1415
bd81e77b
NC
1416/*
1417=for apidoc sv_backoff
73171d91 1418
bd81e77b
NC
1419Remove any string offset. You should normally use the C<SvOOK_off> macro
1420wrapper instead.
73171d91 1421
bd81e77b 1422=cut
73171d91
NC
1423*/
1424
bd81e77b 1425int
aad570aa 1426Perl_sv_backoff(pTHX_ register SV *const sv)
bd81e77b 1427{
69240efd 1428 STRLEN delta;
7a4bba22 1429 const char * const s = SvPVX_const(sv);
7918f24d
NC
1430
1431 PERL_ARGS_ASSERT_SV_BACKOFF;
96a5add6 1432 PERL_UNUSED_CONTEXT;
7918f24d 1433
bd81e77b
NC
1434 assert(SvOOK(sv));
1435 assert(SvTYPE(sv) != SVt_PVHV);
1436 assert(SvTYPE(sv) != SVt_PVAV);
7a4bba22 1437
69240efd
NC
1438 SvOOK_offset(sv, delta);
1439
7a4bba22
NC
1440 SvLEN_set(sv, SvLEN(sv) + delta);
1441 SvPV_set(sv, SvPVX(sv) - delta);
1442 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
bd81e77b
NC
1443 SvFLAGS(sv) &= ~SVf_OOK;
1444 return 0;
1445}
73171d91 1446
bd81e77b
NC
1447/*
1448=for apidoc sv_grow
73171d91 1449
bd81e77b
NC
1450Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1451upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1452Use the C<SvGROW> wrapper instead.
93e68bfb 1453
bd81e77b
NC
1454=cut
1455*/
93e68bfb 1456
bd81e77b 1457char *
aad570aa 1458Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
bd81e77b
NC
1459{
1460 register char *s;
93e68bfb 1461
7918f24d
NC
1462 PERL_ARGS_ASSERT_SV_GROW;
1463
5db06880
NC
1464 if (PL_madskills && newlen >= 0x100000) {
1465 PerlIO_printf(Perl_debug_log,
1466 "Allocation too large: %"UVxf"\n", (UV)newlen);
1467 }
bd81e77b
NC
1468#ifdef HAS_64K_LIMIT
1469 if (newlen >= 0x10000) {
1470 PerlIO_printf(Perl_debug_log,
1471 "Allocation too large: %"UVxf"\n", (UV)newlen);
1472 my_exit(1);
1473 }
1474#endif /* HAS_64K_LIMIT */
1475 if (SvROK(sv))
1476 sv_unref(sv);
1477 if (SvTYPE(sv) < SVt_PV) {
1478 sv_upgrade(sv, SVt_PV);
1479 s = SvPVX_mutable(sv);
1480 }
1481 else if (SvOOK(sv)) { /* pv is offset? */
1482 sv_backoff(sv);
1483 s = SvPVX_mutable(sv);
1484 if (newlen > SvLEN(sv))
1485 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1486#ifdef HAS_64K_LIMIT
1487 if (newlen >= 0x10000)
1488 newlen = 0xFFFF;
1489#endif
1490 }
1491 else
1492 s = SvPVX_mutable(sv);
aeb18a1e 1493
bd81e77b 1494 if (newlen > SvLEN(sv)) { /* need more room? */
f1200559
WH
1495 STRLEN minlen = SvCUR(sv);
1496 minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1497 if (newlen < minlen)
1498 newlen = minlen;
aedff202 1499#ifndef Perl_safesysmalloc_size
bd81e77b 1500 newlen = PERL_STRLEN_ROUNDUP(newlen);
bd81e77b 1501#endif
98653f18 1502 if (SvLEN(sv) && s) {
10edeb5d 1503 s = (char*)saferealloc(s, newlen);
bd81e77b
NC
1504 }
1505 else {
10edeb5d 1506 s = (char*)safemalloc(newlen);
bd81e77b
NC
1507 if (SvPVX_const(sv) && SvCUR(sv)) {
1508 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1509 }
1510 }
1511 SvPV_set(sv, s);
ca7c1a29 1512#ifdef Perl_safesysmalloc_size
98653f18
NC
1513 /* Do this here, do it once, do it right, and then we will never get
1514 called back into sv_grow() unless there really is some growing
1515 needed. */
ca7c1a29 1516 SvLEN_set(sv, Perl_safesysmalloc_size(s));
98653f18 1517#else
bd81e77b 1518 SvLEN_set(sv, newlen);
98653f18 1519#endif
bd81e77b
NC
1520 }
1521 return s;
1522}
aeb18a1e 1523
bd81e77b
NC
1524/*
1525=for apidoc sv_setiv
932e9ff9 1526
bd81e77b
NC
1527Copies an integer into the given SV, upgrading first if necessary.
1528Does not handle 'set' magic. See also C<sv_setiv_mg>.
463ee0b2 1529
bd81e77b
NC
1530=cut
1531*/
463ee0b2 1532
bd81e77b 1533void
aad570aa 1534Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
bd81e77b 1535{
97aff369 1536 dVAR;
7918f24d
NC
1537
1538 PERL_ARGS_ASSERT_SV_SETIV;
1539
bd81e77b
NC
1540 SV_CHECK_THINKFIRST_COW_DROP(sv);
1541 switch (SvTYPE(sv)) {
1542 case SVt_NULL:
bd81e77b 1543 case SVt_NV:
3376de98 1544 sv_upgrade(sv, SVt_IV);
bd81e77b 1545 break;
bd81e77b
NC
1546 case SVt_PV:
1547 sv_upgrade(sv, SVt_PVIV);
1548 break;
463ee0b2 1549
bd81e77b 1550 case SVt_PVGV:
6e592b3a
BM
1551 if (!isGV_with_GP(sv))
1552 break;
bd81e77b
NC
1553 case SVt_PVAV:
1554 case SVt_PVHV:
1555 case SVt_PVCV:
1556 case SVt_PVFM:
1557 case SVt_PVIO:
1558 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1559 OP_DESC(PL_op));
42d0e0b7 1560 default: NOOP;
bd81e77b
NC
1561 }
1562 (void)SvIOK_only(sv); /* validate number */
1563 SvIV_set(sv, i);
1564 SvTAINT(sv);
1565}
932e9ff9 1566
bd81e77b
NC
1567/*
1568=for apidoc sv_setiv_mg
d33b2eba 1569
bd81e77b 1570Like C<sv_setiv>, but also handles 'set' magic.
1c846c1f 1571
bd81e77b
NC
1572=cut
1573*/
d33b2eba 1574
bd81e77b 1575void
aad570aa 1576Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
bd81e77b 1577{
7918f24d
NC
1578 PERL_ARGS_ASSERT_SV_SETIV_MG;
1579
bd81e77b
NC
1580 sv_setiv(sv,i);
1581 SvSETMAGIC(sv);
1582}
727879eb 1583
bd81e77b
NC
1584/*
1585=for apidoc sv_setuv
d33b2eba 1586
bd81e77b
NC
1587Copies an unsigned integer into the given SV, upgrading first if necessary.
1588Does not handle 'set' magic. See also C<sv_setuv_mg>.
9b94d1dd 1589
bd81e77b
NC
1590=cut
1591*/
d33b2eba 1592
bd81e77b 1593void
aad570aa 1594Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
bd81e77b 1595{
7918f24d
NC
1596 PERL_ARGS_ASSERT_SV_SETUV;
1597
bd81e77b
NC
1598 /* With these two if statements:
1599 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d33b2eba 1600
bd81e77b
NC
1601 without
1602 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1c846c1f 1603
bd81e77b
NC
1604 If you wish to remove them, please benchmark to see what the effect is
1605 */
1606 if (u <= (UV)IV_MAX) {
1607 sv_setiv(sv, (IV)u);
1608 return;
1609 }
1610 sv_setiv(sv, 0);
1611 SvIsUV_on(sv);
1612 SvUV_set(sv, u);
1613}
d33b2eba 1614
bd81e77b
NC
1615/*
1616=for apidoc sv_setuv_mg
727879eb 1617
bd81e77b 1618Like C<sv_setuv>, but also handles 'set' magic.
9b94d1dd 1619
bd81e77b
NC
1620=cut
1621*/
5e2fc214 1622
bd81e77b 1623void
aad570aa 1624Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
bd81e77b 1625{
7918f24d
NC
1626 PERL_ARGS_ASSERT_SV_SETUV_MG;
1627
bd81e77b
NC
1628 sv_setuv(sv,u);
1629 SvSETMAGIC(sv);
1630}
5e2fc214 1631
954c1994 1632/*
bd81e77b 1633=for apidoc sv_setnv
954c1994 1634
bd81e77b
NC
1635Copies a double into the given SV, upgrading first if necessary.
1636Does not handle 'set' magic. See also C<sv_setnv_mg>.
954c1994
GS
1637
1638=cut
1639*/
1640
63f97190 1641void
aad570aa 1642Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
79072805 1643{
97aff369 1644 dVAR;
7918f24d
NC
1645
1646 PERL_ARGS_ASSERT_SV_SETNV;
1647
bd81e77b
NC
1648 SV_CHECK_THINKFIRST_COW_DROP(sv);
1649 switch (SvTYPE(sv)) {
79072805 1650 case SVt_NULL:
79072805 1651 case SVt_IV:
bd81e77b 1652 sv_upgrade(sv, SVt_NV);
79072805
LW
1653 break;
1654 case SVt_PV:
79072805 1655 case SVt_PVIV:
bd81e77b 1656 sv_upgrade(sv, SVt_PVNV);
79072805 1657 break;
bd4b1eb5 1658
bd4b1eb5 1659 case SVt_PVGV:
6e592b3a
BM
1660 if (!isGV_with_GP(sv))
1661 break;
bd81e77b
NC
1662 case SVt_PVAV:
1663 case SVt_PVHV:
79072805 1664 case SVt_PVCV:
bd81e77b
NC
1665 case SVt_PVFM:
1666 case SVt_PVIO:
1667 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
94bbb3f4 1668 OP_DESC(PL_op));
42d0e0b7 1669 default: NOOP;
2068cd4d 1670 }
bd81e77b
NC
1671 SvNV_set(sv, num);
1672 (void)SvNOK_only(sv); /* validate number */
1673 SvTAINT(sv);
79072805
LW
1674}
1675
645c22ef 1676/*
bd81e77b 1677=for apidoc sv_setnv_mg
645c22ef 1678
bd81e77b 1679Like C<sv_setnv>, but also handles 'set' magic.
645c22ef
DM
1680
1681=cut
1682*/
1683
bd81e77b 1684void
aad570aa 1685Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
79072805 1686{
7918f24d
NC
1687 PERL_ARGS_ASSERT_SV_SETNV_MG;
1688
bd81e77b
NC
1689 sv_setnv(sv,num);
1690 SvSETMAGIC(sv);
79072805
LW
1691}
1692
bd81e77b
NC
1693/* Print an "isn't numeric" warning, using a cleaned-up,
1694 * printable version of the offending string
1695 */
954c1994 1696
bd81e77b 1697STATIC void
aad570aa 1698S_not_a_number(pTHX_ SV *const sv)
79072805 1699{
97aff369 1700 dVAR;
bd81e77b
NC
1701 SV *dsv;
1702 char tmpbuf[64];
1703 const char *pv;
94463019 1704
7918f24d
NC
1705 PERL_ARGS_ASSERT_NOT_A_NUMBER;
1706
94463019 1707 if (DO_UTF8(sv)) {
84bafc02 1708 dsv = newSVpvs_flags("", SVs_TEMP);
94463019
JH
1709 pv = sv_uni_display(dsv, sv, 10, 0);
1710 } else {
1711 char *d = tmpbuf;
551405c4 1712 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
94463019
JH
1713 /* each *s can expand to 4 chars + "...\0",
1714 i.e. need room for 8 chars */
ecdeb87c 1715
00b6aa41
AL
1716 const char *s = SvPVX_const(sv);
1717 const char * const end = s + SvCUR(sv);
1718 for ( ; s < end && d < limit; s++ ) {
94463019
JH
1719 int ch = *s & 0xFF;
1720 if (ch & 128 && !isPRINT_LC(ch)) {
1721 *d++ = 'M';
1722 *d++ = '-';
1723 ch &= 127;
1724 }
1725 if (ch == '\n') {
1726 *d++ = '\\';
1727 *d++ = 'n';
1728 }
1729 else if (ch == '\r') {
1730 *d++ = '\\';
1731 *d++ = 'r';
1732 }
1733 else if (ch == '\f') {
1734 *d++ = '\\';
1735 *d++ = 'f';
1736 }
1737 else if (ch == '\\') {
1738 *d++ = '\\';
1739 *d++ = '\\';
1740 }
1741 else if (ch == '\0') {
1742 *d++ = '\\';
1743 *d++ = '0';
1744 }
1745 else if (isPRINT_LC(ch))
1746 *d++ = ch;
1747 else {
1748 *d++ = '^';
1749 *d++ = toCTRL(ch);
1750 }
1751 }
1752 if (s < end) {
1753 *d++ = '.';
1754 *d++ = '.';
1755 *d++ = '.';
1756 }
1757 *d = '\0';
1758 pv = tmpbuf;
a0d0e21e 1759 }
a0d0e21e 1760
533c011a 1761 if (PL_op)
9014280d 1762 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019
JH
1763 "Argument \"%s\" isn't numeric in %s", pv,
1764 OP_DESC(PL_op));
a0d0e21e 1765 else
9014280d 1766 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
94463019 1767 "Argument \"%s\" isn't numeric", pv);
a0d0e21e
LW
1768}
1769
c2988b20
NC
1770/*
1771=for apidoc looks_like_number
1772
645c22ef
DM
1773Test if the content of an SV looks like a number (or is a number).
1774C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1775non-numeric warning), even if your atof() doesn't grok them.
c2988b20
NC
1776
1777=cut
1778*/
1779
1780I32
aad570aa 1781Perl_looks_like_number(pTHX_ SV *const sv)
c2988b20 1782{
a3b680e6 1783 register const char *sbegin;
c2988b20
NC
1784 STRLEN len;
1785
7918f24d
NC
1786 PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1787
c2988b20 1788 if (SvPOK(sv)) {
3f7c398e 1789 sbegin = SvPVX_const(sv);
c2988b20
NC
1790 len = SvCUR(sv);
1791 }
1792 else if (SvPOKp(sv))
83003860 1793 sbegin = SvPV_const(sv, len);
c2988b20 1794 else
e0ab1c0e 1795 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
c2988b20
NC
1796 return grok_number(sbegin, len, NULL);
1797}
25da4f38 1798
19f6321d
NC
1799STATIC bool
1800S_glob_2number(pTHX_ GV * const gv)
180488f8
NC
1801{
1802 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1803 SV *const buffer = sv_newmortal();
1804
7918f24d
NC
1805 PERL_ARGS_ASSERT_GLOB_2NUMBER;
1806
180488f8
NC
1807 /* FAKE globs can get coerced, so need to turn this off temporarily if it
1808 is on. */
1809 SvFAKE_off(gv);
1810 gv_efullname3(buffer, gv, "*");
1811 SvFLAGS(gv) |= wasfake;
1812
675c862f
AL
1813 /* We know that all GVs stringify to something that is not-a-number,
1814 so no need to test that. */
1815 if (ckWARN(WARN_NUMERIC))
1816 not_a_number(buffer);
1817 /* We just want something true to return, so that S_sv_2iuv_common
1818 can tail call us and return true. */
19f6321d 1819 return TRUE;
675c862f
AL
1820}
1821
25da4f38
IZ
1822/* Actually, ISO C leaves conversion of UV to IV undefined, but
1823 until proven guilty, assume that things are not that bad... */
1824
645c22ef
DM
1825/*
1826 NV_PRESERVES_UV:
1827
1828 As 64 bit platforms often have an NV that doesn't preserve all bits of
28e5dec8
JH
1829 an IV (an assumption perl has been based on to date) it becomes necessary
1830 to remove the assumption that the NV always carries enough precision to
1831 recreate the IV whenever needed, and that the NV is the canonical form.
1832 Instead, IV/UV and NV need to be given equal rights. So as to not lose
645c22ef 1833 precision as a side effect of conversion (which would lead to insanity
28e5dec8
JH
1834 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1835 1) to distinguish between IV/UV/NV slots that have cached a valid
1836 conversion where precision was lost and IV/UV/NV slots that have a
1837 valid conversion which has lost no precision
645c22ef 1838 2) to ensure that if a numeric conversion to one form is requested that
28e5dec8
JH
1839 would lose precision, the precise conversion (or differently
1840 imprecise conversion) is also performed and cached, to prevent
1841 requests for different numeric formats on the same SV causing
1842 lossy conversion chains. (lossless conversion chains are perfectly
1843 acceptable (still))
1844
1845
1846 flags are used:
1847 SvIOKp is true if the IV slot contains a valid value
1848 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1849 SvNOKp is true if the NV slot contains a valid value
1850 SvNOK is true only if the NV value is accurate
1851
1852 so
645c22ef 1853 while converting from PV to NV, check to see if converting that NV to an
28e5dec8
JH
1854 IV(or UV) would lose accuracy over a direct conversion from PV to
1855 IV(or UV). If it would, cache both conversions, return NV, but mark
1856 SV as IOK NOKp (ie not NOK).
1857
645c22ef 1858 While converting from PV to IV, check to see if converting that IV to an
28e5dec8
JH
1859 NV would lose accuracy over a direct conversion from PV to NV. If it
1860 would, cache both conversions, flag similarly.
1861
1862 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1863 correctly because if IV & NV were set NV *always* overruled.
645c22ef
DM
1864 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1865 changes - now IV and NV together means that the two are interchangeable:
28e5dec8 1866 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
d460ef45 1867
645c22ef
DM
1868 The benefit of this is that operations such as pp_add know that if
1869 SvIOK is true for both left and right operands, then integer addition
1870 can be used instead of floating point (for cases where the result won't
1871 overflow). Before, floating point was always used, which could lead to
28e5dec8
JH
1872 loss of precision compared with integer addition.
1873
1874 * making IV and NV equal status should make maths accurate on 64 bit
1875 platforms
1876 * may speed up maths somewhat if pp_add and friends start to use
645c22ef 1877 integers when possible instead of fp. (Hopefully the overhead in
28e5dec8
JH
1878 looking for SvIOK and checking for overflow will not outweigh the
1879 fp to integer speedup)
1880 * will slow down integer operations (callers of SvIV) on "inaccurate"
1881 values, as the change from SvIOK to SvIOKp will cause a call into
1882 sv_2iv each time rather than a macro access direct to the IV slot
1883 * should speed up number->string conversion on integers as IV is
645c22ef 1884 favoured when IV and NV are equally accurate
28e5dec8
JH
1885
1886 ####################################################################
645c22ef
DM
1887 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1888 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1889 On the other hand, SvUOK is true iff UV.
28e5dec8
JH
1890 ####################################################################
1891
645c22ef 1892 Your mileage will vary depending your CPU's relative fp to integer
28e5dec8
JH
1893 performance ratio.
1894*/
1895
1896#ifndef NV_PRESERVES_UV
645c22ef
DM
1897# define IS_NUMBER_UNDERFLOW_IV 1
1898# define IS_NUMBER_UNDERFLOW_UV 2
1899# define IS_NUMBER_IV_AND_UV 2
1900# define IS_NUMBER_OVERFLOW_IV 4
1901# define IS_NUMBER_OVERFLOW_UV 5
1902
1903/* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
28e5dec8
JH
1904
1905/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1906STATIC int
5de3775c 1907S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
47031da6
NC
1908# ifdef DEBUGGING
1909 , I32 numtype
1910# endif
1911 )
28e5dec8 1912{
97aff369 1913 dVAR;
7918f24d
NC
1914
1915 PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1916
3f7c398e 1917 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
1918 if (SvNVX(sv) < (NV)IV_MIN) {
1919 (void)SvIOKp_on(sv);
1920 (void)SvNOK_on(sv);
45977657 1921 SvIV_set(sv, IV_MIN);
28e5dec8
JH
1922 return IS_NUMBER_UNDERFLOW_IV;
1923 }
1924 if (SvNVX(sv) > (NV)UV_MAX) {
1925 (void)SvIOKp_on(sv);
1926 (void)SvNOK_on(sv);
1927 SvIsUV_on(sv);
607fa7f2 1928 SvUV_set(sv, UV_MAX);
28e5dec8
JH
1929 return IS_NUMBER_OVERFLOW_UV;
1930 }
c2988b20
NC
1931 (void)SvIOKp_on(sv);
1932 (void)SvNOK_on(sv);
1933 /* Can't use strtol etc to convert this string. (See truth table in
1934 sv_2iv */
1935 if (SvNVX(sv) <= (UV)IV_MAX) {
45977657 1936 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
1937 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1938 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1939 } else {
1940 /* Integer is imprecise. NOK, IOKp */
1941 }
1942 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1943 }
1944 SvIsUV_on(sv);
607fa7f2 1945 SvUV_set(sv, U_V(SvNVX(sv)));
c2988b20
NC
1946 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1947 if (SvUVX(sv) == UV_MAX) {
1948 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1949 possibly be preserved by NV. Hence, it must be overflow.
1950 NOK, IOKp */
1951 return IS_NUMBER_OVERFLOW_UV;
1952 }
1953 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1954 } else {
1955 /* Integer is imprecise. NOK, IOKp */
28e5dec8 1956 }
c2988b20 1957 return IS_NUMBER_OVERFLOW_IV;
28e5dec8 1958}
645c22ef
DM
1959#endif /* !NV_PRESERVES_UV*/
1960
af359546 1961STATIC bool
7918f24d
NC
1962S_sv_2iuv_common(pTHX_ SV *const sv)
1963{
97aff369 1964 dVAR;
7918f24d
NC
1965
1966 PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1967
af359546 1968 if (SvNOKp(sv)) {
28e5dec8
JH
1969 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1970 * without also getting a cached IV/UV from it at the same time
1971 * (ie PV->NV conversion should detect loss of accuracy and cache
af359546
NC
1972 * IV or UV at same time to avoid this. */
1973 /* IV-over-UV optimisation - choose to cache IV if possible */
25da4f38
IZ
1974
1975 if (SvTYPE(sv) == SVt_NV)
1976 sv_upgrade(sv, SVt_PVNV);
1977
28e5dec8
JH
1978 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1979 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1980 certainly cast into the IV range at IV_MAX, whereas the correct
1981 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1982 cases go to UV */
cab190d4
JD
1983#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1984 if (Perl_isnan(SvNVX(sv))) {
1985 SvUV_set(sv, 0);
1986 SvIsUV_on(sv);
fdbe6d7c 1987 return FALSE;
cab190d4 1988 }
cab190d4 1989#endif
28e5dec8 1990 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
45977657 1991 SvIV_set(sv, I_V(SvNVX(sv)));
28e5dec8
JH
1992 if (SvNVX(sv) == (NV) SvIVX(sv)
1993#ifndef NV_PRESERVES_UV
1994 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1995 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1996 /* Don't flag it as "accurately an integer" if the number
1997 came from a (by definition imprecise) NV operation, and
1998 we're outside the range of NV integer precision */
1999#endif
2000 ) {
a43d94f2
NC
2001 if (SvNOK(sv))
2002 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2003 else {
2004 /* scalar has trailing garbage, eg "42a" */
2005 }
28e5dec8 2006 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2007 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
28e5dec8
JH
2008 PTR2UV(sv),
2009 SvNVX(sv),
2010 SvIVX(sv)));
2011
2012 } else {
2013 /* IV not precise. No need to convert from PV, as NV
2014 conversion would already have cached IV if it detected
2015 that PV->IV would be better than PV->NV->IV
2016 flags already correct - don't set public IOK. */
2017 DEBUG_c(PerlIO_printf(Perl_debug_log,
7234c960 2018 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
28e5dec8
JH
2019 PTR2UV(sv),
2020 SvNVX(sv),
2021 SvIVX(sv)));
2022 }
2023 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2024 but the cast (NV)IV_MIN rounds to a the value less (more
2025 negative) than IV_MIN which happens to be equal to SvNVX ??
2026 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2027 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2028 (NV)UVX == NVX are both true, but the values differ. :-(
2029 Hopefully for 2s complement IV_MIN is something like
2030 0x8000000000000000 which will be exact. NWC */
d460ef45 2031 }
25da4f38 2032 else {
607fa7f2 2033 SvUV_set(sv, U_V(SvNVX(sv)));
28e5dec8
JH
2034 if (
2035 (SvNVX(sv) == (NV) SvUVX(sv))
2036#ifndef NV_PRESERVES_UV
2037 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2038 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2039 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2040 /* Don't flag it as "accurately an integer" if the number
2041 came from a (by definition imprecise) NV operation, and
2042 we're outside the range of NV integer precision */
2043#endif
a43d94f2 2044 && SvNOK(sv)
28e5dec8
JH
2045 )
2046 SvIOK_on(sv);
25da4f38 2047 SvIsUV_on(sv);
1c846c1f 2048 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 2049 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 2050 PTR2UV(sv),
57def98f
JH
2051 SvUVX(sv),
2052 SvUVX(sv)));
25da4f38 2053 }
748a9306
LW
2054 }
2055 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2056 UV value;
504618e9 2057 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
af359546 2058 /* We want to avoid a possible problem when we cache an IV/ a UV which
25da4f38 2059 may be later translated to an NV, and the resulting NV is not
c2988b20
NC
2060 the same as the direct translation of the initial string
2061 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2062 be careful to ensure that the value with the .456 is around if the
2063 NV value is requested in the future).
1c846c1f 2064
af359546 2065 This means that if we cache such an IV/a UV, we need to cache the
25da4f38 2066 NV as well. Moreover, we trade speed for space, and do not
28e5dec8 2067 cache the NV if we are sure it's not needed.
25da4f38 2068 */
16b7a9a4 2069
c2988b20
NC
2070 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2071 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2072 == IS_NUMBER_IN_UV) {
5e045b90 2073 /* It's definitely an integer, only upgrade to PVIV */
28e5dec8
JH
2074 if (SvTYPE(sv) < SVt_PVIV)
2075 sv_upgrade(sv, SVt_PVIV);
f7bbb42a 2076 (void)SvIOK_on(sv);
c2988b20
NC
2077 } else if (SvTYPE(sv) < SVt_PVNV)
2078 sv_upgrade(sv, SVt_PVNV);
28e5dec8 2079
f2524eef 2080 /* If NVs preserve UVs then we only use the UV value if we know that
c2988b20
NC
2081 we aren't going to call atof() below. If NVs don't preserve UVs
2082 then the value returned may have more precision than atof() will
2083 return, even though value isn't perfectly accurate. */
2084 if ((numtype & (IS_NUMBER_IN_UV
2085#ifdef NV_PRESERVES_UV
2086 | IS_NUMBER_NOT_INT
2087#endif
2088 )) == IS_NUMBER_IN_UV) {
2089 /* This won't turn off the public IOK flag if it was set above */
2090 (void)SvIOKp_on(sv);
2091
2092 if (!(numtype & IS_NUMBER_NEG)) {
2093 /* positive */;
2094 if (value <= (UV)IV_MAX) {
45977657 2095 SvIV_set(sv, (IV)value);
c2988b20 2096 } else {
af359546 2097 /* it didn't overflow, and it was positive. */
607fa7f2 2098 SvUV_set(sv, value);
c2988b20
NC
2099 SvIsUV_on(sv);
2100 }
2101 } else {
2102 /* 2s complement assumption */
2103 if (value <= (UV)IV_MIN) {
45977657 2104 SvIV_set(sv, -(IV)value);
c2988b20
NC
2105 } else {
2106 /* Too negative for an IV. This is a double upgrade, but
d1be9408 2107 I'm assuming it will be rare. */
c2988b20
NC
2108 if (SvTYPE(sv) < SVt_PVNV)
2109 sv_upgrade(sv, SVt_PVNV);
2110 SvNOK_on(sv);
2111 SvIOK_off(sv);
2112 SvIOKp_on(sv);
9d6ce603 2113 SvNV_set(sv, -(NV)value);
45977657 2114 SvIV_set(sv, IV_MIN);
c2988b20
NC
2115 }
2116 }
2117 }
2118 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2119 will be in the previous block to set the IV slot, and the next
2120 block to set the NV slot. So no else here. */
2121
2122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123 != IS_NUMBER_IN_UV) {
2124 /* It wasn't an (integer that doesn't overflow the UV). */
3f7c398e 2125 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8 2126
c2988b20
NC
2127 if (! numtype && ckWARN(WARN_NUMERIC))
2128 not_a_number(sv);
28e5dec8 2129
65202027 2130#if defined(USE_LONG_DOUBLE)
c2988b20
NC
2131 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2132 PTR2UV(sv), SvNVX(sv)));
65202027 2133#else
1779d84d 2134 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
c2988b20 2135 PTR2UV(sv), SvNVX(sv)));
65202027 2136#endif
28e5dec8 2137
28e5dec8 2138#ifdef NV_PRESERVES_UV
af359546
NC
2139 (void)SvIOKp_on(sv);
2140 (void)SvNOK_on(sv);
2141 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2142 SvIV_set(sv, I_V(SvNVX(sv)));
2143 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2144 SvIOK_on(sv);
2145 } else {
6f207bd3 2146 NOOP; /* Integer is imprecise. NOK, IOKp */
af359546
NC
2147 }
2148 /* UV will not work better than IV */
2149 } else {
2150 if (SvNVX(sv) > (NV)UV_MAX) {
2151 SvIsUV_on(sv);
2152 /* Integer is inaccurate. NOK, IOKp, is UV */
2153 SvUV_set(sv, UV_MAX);
af359546
NC
2154 } else {
2155 SvUV_set(sv, U_V(SvNVX(sv)));
2156 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2157 NV preservse UV so can do correct comparison. */
2158 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2159 SvIOK_on(sv);
af359546 2160 } else {
6f207bd3 2161 NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
af359546
NC
2162 }
2163 }
4b0c9573 2164 SvIsUV_on(sv);
af359546 2165 }
28e5dec8 2166#else /* NV_PRESERVES_UV */
c2988b20
NC
2167 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2168 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
af359546 2169 /* The IV/UV slot will have been set from value returned by
c2988b20
NC
2170 grok_number above. The NV slot has just been set using
2171 Atof. */
560b0c46 2172 SvNOK_on(sv);
c2988b20
NC
2173 assert (SvIOKp(sv));
2174 } else {
2175 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2176 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2177 /* Small enough to preserve all bits. */
2178 (void)SvIOKp_on(sv);
2179 SvNOK_on(sv);
45977657 2180 SvIV_set(sv, I_V(SvNVX(sv)));
c2988b20
NC
2181 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2182 SvIOK_on(sv);
2183 /* Assumption: first non-preserved integer is < IV_MAX,
2184 this NV is in the preserved range, therefore: */
2185 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2186 < (UV)IV_MAX)) {
32fdb065 2187 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
2188 }
2189 } else {
2190 /* IN_UV NOT_INT
2191 0 0 already failed to read UV.
2192 0 1 already failed to read UV.
2193 1 0 you won't get here in this case. IV/UV
2194 slot set, public IOK, Atof() unneeded.
2195 1 1 already read UV.
2196 so there's no point in sv_2iuv_non_preserve() attempting
2197 to use atol, strtol, strtoul etc. */
47031da6 2198# ifdef DEBUGGING
40a17c4c 2199 sv_2iuv_non_preserve (sv, numtype);
47031da6
NC
2200# else
2201 sv_2iuv_non_preserve (sv);
2202# endif
c2988b20
NC
2203 }
2204 }
28e5dec8 2205#endif /* NV_PRESERVES_UV */
a43d94f2
NC
2206 /* It might be more code efficient to go through the entire logic above
2207 and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2208 gets complex and potentially buggy, so more programmer efficient
2209 to do it this way, by turning off the public flags: */
2210 if (!numtype)
2211 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
25da4f38 2212 }
af359546
NC
2213 }
2214 else {
675c862f 2215 if (isGV_with_GP(sv))
159b6efe 2216 return glob_2number(MUTABLE_GV(sv));
180488f8 2217
af359546
NC
2218 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2219 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2220 report_uninit(sv);
2221 }
25da4f38
IZ
2222 if (SvTYPE(sv) < SVt_IV)
2223 /* Typically the caller expects that sv_any is not NULL now. */
2224 sv_upgrade(sv, SVt_IV);
af359546
NC
2225 /* Return 0 from the caller. */
2226 return TRUE;
2227 }
2228 return FALSE;
2229}
2230
2231/*
2232=for apidoc sv_2iv_flags
2233
2234Return the integer value of an SV, doing any necessary string
2235conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2236Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2237
2238=cut
2239*/
2240
2241IV
5de3775c 2242Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
af359546 2243{
97aff369 2244 dVAR;
af359546 2245 if (!sv)
a0d0e21e 2246 return 0;
cecf5685
NC
2247 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2248 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
50caf62e
NC
2249 cache IVs just in case. In practice it seems that they never
2250 actually anywhere accessible by user Perl code, let alone get used
2251 in anything other than a string context. */
af359546
NC
2252 if (flags & SV_GMAGIC)
2253 mg_get(sv);
2254 if (SvIOKp(sv))
2255 return SvIVX(sv);
2256 if (SvNOKp(sv)) {
2257 return I_V(SvNVX(sv));
2258 }
71c558c3
NC
2259 if (SvPOKp(sv) && SvLEN(sv)) {
2260 UV value;
2261 const int numtype
2262 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2263
2264 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2265 == IS_NUMBER_IN_UV) {
2266 /* It's definitely an integer */
2267 if (numtype & IS_NUMBER_NEG) {
2268 if (value < (UV)IV_MIN)
2269 return -(IV)value;
2270 } else {
2271 if (value < (UV)IV_MAX)
2272 return (IV)value;
2273 }
2274 }
2275 if (!numtype) {
2276 if (ckWARN(WARN_NUMERIC))
2277 not_a_number(sv);
2278 }
2279 return I_V(Atof(SvPVX_const(sv)));
2280 }
1c7ff15e
NC
2281 if (SvROK(sv)) {
2282 goto return_rok;
af359546 2283 }
1c7ff15e
NC
2284 assert(SvTYPE(sv) >= SVt_PVMG);
2285 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
4cb1ec55 2286 } else if (SvTHINKFIRST(sv)) {
af359546 2287 if (SvROK(sv)) {
1c7ff15e 2288 return_rok:
af359546 2289 if (SvAMAGIC(sv)) {
aee036bb
DM
2290 SV * tmpstr;
2291 if (flags & SV_SKIP_OVERLOAD)
2292 return 0;
2293 tmpstr=AMG_CALLun(sv,numer);
af359546
NC
2294 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2295 return SvIV(tmpstr);
2296 }
2297 }
2298 return PTR2IV(SvRV(sv));
2299 }
2300 if (SvIsCOW(sv)) {
2301 sv_force_normal_flags(sv, 0);
2302 }
2303 if (SvREADONLY(sv) && !SvOK(sv)) {
2304 if (ckWARN(WARN_UNINITIALIZED))
2305 report_uninit(sv);
2306 return 0;
2307 }
2308 }
2309 if (!SvIOKp(sv)) {
2310 if (S_sv_2iuv_common(aTHX_ sv))
2311 return 0;
79072805 2312 }
1d7c1841
GS
2313 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2314 PTR2UV(sv),SvIVX(sv)));
25da4f38 2315 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW
2316}
2317
645c22ef 2318/*
891f9566 2319=for apidoc sv_2uv_flags
645c22ef
DM
2320
2321Return the unsigned integer value of an SV, doing any necessary string
891f9566
YST
2322conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2323Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
645c22ef
DM
2324
2325=cut
2326*/
2327
ff68c719 2328UV
5de3775c 2329Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
ff68c719 2330{
97aff369 2331 dVAR;
ff68c719
PP
2332 if (!sv)
2333 return 0;
cecf5685
NC
2334 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2335 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
50caf62e 2336 cache IVs just in case. */
891f9566
YST
2337 if (flags & SV_GMAGIC)
2338 mg_get(sv);
ff68c719
PP
2339 if (SvIOKp(sv))
2340 return SvUVX(sv);
2341 if (SvNOKp(sv))
2342 return U_V(SvNVX(sv));
71c558c3
NC
2343 if (SvPOKp(sv) && SvLEN(sv)) {
2344 UV value;
2345 const int numtype
2346 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2347
2348 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2349 == IS_NUMBER_IN_UV) {
2350 /* It's definitely an integer */
2351 if (!(numtype & IS_NUMBER_NEG))
2352 return value;
2353 }
2354 if (!numtype) {
2355 if (ckWARN(WARN_NUMERIC))
2356 not_a_number(sv);
2357 }
2358 return U_V(Atof(SvPVX_const(sv)));
2359 }
1c7ff15e
NC
2360 if (SvROK(sv)) {
2361 goto return_rok;
3fe9a6f1 2362 }
1c7ff15e
NC
2363 assert(SvTYPE(sv) >= SVt_PVMG);
2364 /* This falls through to the report_uninit inside S_sv_2iuv_common. */
4cb1ec55 2365 } else if (SvTHINKFIRST(sv)) {
ff68c719 2366 if (SvROK(sv)) {
1c7ff15e 2367 return_rok:
deb46114 2368 if (SvAMAGIC(sv)) {
aee036bb
DM
2369 SV *tmpstr;
2370 if (flags & SV_SKIP_OVERLOAD)
2371 return 0;
2372 tmpstr = AMG_CALLun(sv,numer);
deb46114
NC
2373 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2374 return SvUV(tmpstr);
2375 }
2376 }
2377 return PTR2UV(SvRV(sv));
ff68c719 2378 }
765f542d
NC
2379 if (SvIsCOW(sv)) {
2380 sv_force_normal_flags(sv, 0);
8a818333 2381 }
0336b60e 2382 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2383 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2384 report_uninit(sv);
ff68c719
PP
2385 return 0;
2386 }
2387 }
af359546
NC
2388 if (!SvIOKp(sv)) {
2389 if (S_sv_2iuv_common(aTHX_ sv))
2390 return 0;
ff68c719 2391 }
25da4f38 2392
1d7c1841
GS
2393 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2394 PTR2UV(sv),SvUVX(sv)));
25da4f38 2395 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP
2396}
2397
645c22ef 2398/*
196007d1 2399=for apidoc sv_2nv_flags
645c22ef
DM
2400
2401Return the num value of an SV, doing any necessary string or integer
39d5de13
DM
2402conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2403Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
645c22ef
DM
2404
2405=cut
2406*/
2407
65202027 2408NV
39d5de13 2409Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags)
79072805 2410{
97aff369 2411 dVAR;
79072805
LW
2412 if (!sv)
2413 return 0.0;
cecf5685
NC
2414 if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2415 /* FBMs use the same flag bit as SVf_IVisUV, so must let them
50caf62e 2416 cache IVs just in case. */
39d5de13
DM
2417 if (flags & SV_GMAGIC)
2418 mg_get(sv);
463ee0b2
LW
2419 if (SvNOKp(sv))
2420 return SvNVX(sv);
0aa395f8 2421 if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
041457d9 2422 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
504618e9 2423 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
a0d0e21e 2424 not_a_number(sv);
3f7c398e 2425 return Atof(SvPVX_const(sv));
a0d0e21e 2426 }
25da4f38 2427 if (SvIOKp(sv)) {
1c846c1f 2428 if (SvIsUV(sv))
65202027 2429 return (NV)SvUVX(sv);
25da4f38 2430 else
65202027 2431 return (NV)SvIVX(sv);
47a72cb8
NC
2432 }
2433 if (SvROK(sv)) {
2434 goto return_rok;
2435 }
2436 assert(SvTYPE(sv) >= SVt_PVMG);
2437 /* This falls through to the report_uninit near the end of the
2438 function. */
2439 } else if (SvTHINKFIRST(sv)) {
a0d0e21e 2440 if (SvROK(sv)) {
47a72cb8 2441 return_rok:
deb46114 2442 if (SvAMAGIC(sv)) {
aee036bb
DM
2443 SV *tmpstr;
2444 if (flags & SV_SKIP_OVERLOAD)
2445 return 0;
2446 tmpstr = AMG_CALLun(sv,numer);
deb46114
NC
2447 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2448 return SvNV(tmpstr);
2449 }
2450 }
2451 return PTR2NV(SvRV(sv));
a0d0e21e 2452 }
765f542d
NC
2453 if (SvIsCOW(sv)) {
2454 sv_force_normal_flags(sv, 0);
8a818333 2455 }
0336b60e 2456 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 2457 if (ckWARN(WARN_UNINITIALIZED))
29489e7c 2458 report_uninit(sv);
ed6116ce
LW
2459 return 0.0;
2460 }
79072805
LW
2461 }
2462 if (SvTYPE(sv) < SVt_NV) {
7e25a7e9
NC
2463 /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
2464 sv_upgrade(sv, SVt_NV);
906f284f 2465#ifdef USE_LONG_DOUBLE
097ee67d 2466 DEBUG_c({
f93f4e46 2467 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
2468 PerlIO_printf(Perl_debug_log,
2469 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2470 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
2471 RESTORE_NUMERIC_LOCAL();
2472 });
65202027 2473#else
572bbb43 2474 DEBUG_c({
f93f4e46 2475 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 2476 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
1d7c1841 2477 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
2478 RESTORE_NUMERIC_LOCAL();
2479 });
572bbb43 2480#endif
79072805
LW
2481 }
2482 else if (SvTYPE(sv) < SVt_PVNV)
2483 sv_upgrade(sv, SVt_PVNV);
59d8ce62
NC
2484 if (SvNOKp(sv)) {
2485 return SvNVX(sv);
61604483 2486 }
59d8ce62 2487 if (SvIOKp(sv)) {
9d6ce603 2488 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
28e5dec8 2489#ifdef NV_PRESERVES_UV
a43d94f2
NC
2490 if (SvIOK(sv))
2491 SvNOK_on(sv);
2492 else
2493 SvNOKp_on(sv);
28e5dec8
JH
2494#else
2495 /* Only set the public NV OK flag if this NV preserves the IV */
2496 /* Check it's not 0xFFFFFFFFFFFFFFFF */
a43d94f2
NC
2497 if (SvIOK(sv) &&
2498 SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
28e5dec8
JH
2499 : (SvIVX(sv) == I_V(SvNVX(sv))))
2500 SvNOK_on(sv);
2501 else
2502 SvNOKp_on(sv);
2503#endif
93a17b20 2504 }
748a9306 2505 else if (SvPOKp(sv) && SvLEN(sv)) {
c2988b20 2506 UV value;
3f7c398e 2507 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
041457d9 2508 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
a0d0e21e 2509 not_a_number(sv);
28e5dec8 2510#ifdef NV_PRESERVES_UV
c2988b20
NC
2511 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2512 == IS_NUMBER_IN_UV) {
5e045b90 2513 /* It's definitely an integer */
9d6ce603 2514 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
c2988b20 2515 } else
3f7c398e 2516 SvNV_set(sv, Atof(SvPVX_const(sv)));
a43d94f2
NC
2517 if (numtype)
2518 SvNOK_on(sv);
2519 else
2520 SvNOKp_on(sv);
28e5dec8 2521#else
3f7c398e 2522 SvNV_set(sv, Atof(SvPVX_const(sv)));
28e5dec8
JH
2523 /* Only set the public NV OK flag if this NV preserves the value in
2524 the PV at least as well as an IV/UV would.
2525 Not sure how to do this 100% reliably. */
2526 /* if that shift count is out of range then Configure's test is
2527 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2528 UV_BITS */
2529 if (((UV)1 << NV_PRESERVES_UV_BITS) >
c2988b20 2530 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
28e5dec8 2531 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
c2988b20
NC
2532 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2533 /* Can't use strtol etc to convert this string, so don't try.
2534 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2535 SvNOK_on(sv);
2536 } else {
2537 /* value has been set. It may not be precise. */
2538 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2539 /* 2s complement assumption for (UV)IV_MIN */
2540 SvNOK_on(sv); /* Integer is too negative. */
2541 } else {
2542 SvNOKp_on(sv);
2543 SvIOKp_on(sv);
6fa402ec 2544
c2988b20 2545 if (numtype & IS_NUMBER_NEG) {
45977657 2546 SvIV_set(sv, -(IV)value);
c2988b20 2547 } else if (value <= (UV)IV_MAX) {
45977657 2548 SvIV_set(sv, (IV)value);
c2988b20 2549 } else {
607fa7f2 2550 SvUV_set(sv, value);
c2988b20
NC
2551 SvIsUV_on(sv);
2552 }
2553
2554 if (numtype & IS_NUMBER_NOT_INT) {
2555 /* I believe that even if the original PV had decimals,
2556 they are lost beyond the limit of the FP precision.
2557 However, neither is canonical, so both only get p
2558 flags. NWC, 2000/11/25 */
2559 /* Both already have p flags, so do nothing */
2560 } else {
66a1b24b 2561 const NV nv = SvNVX(sv);
c2988b20
NC
2562 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2563 if (SvIVX(sv) == I_V(nv)) {
2564 SvNOK_on(sv);
c2988b20 2565 } else {
c2988b20
NC
2566 /* It had no "." so it must be integer. */
2567 }
00b6aa41 2568 SvIOK_on(sv);
c2988b20
NC
2569 } else {
2570 /* between IV_MAX and NV(UV_MAX).
2571 Could be slightly > UV_MAX */
6fa402ec 2572
c2988b20
NC
2573 if (numtype & IS_NUMBER_NOT_INT) {
2574 /* UV and NV both imprecise. */
2575 } else {
66a1b24b 2576 const UV nv_as_uv = U_V(nv);
c2988b20
NC
2577
2578 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2579 SvNOK_on(sv);
c2988b20 2580 }
00b6aa41 2581 SvIOK_on(sv);
c2988b20
NC
2582 }
2583 }
2584 }
2585 }
2586 }
a43d94f2
NC
2587 /* It might be more code efficient to go through the entire logic above
2588 and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2589 gets complex and potentially buggy, so more programmer efficient
2590 to do it this way, by turning off the public flags: */
2591 if (!numtype)
2592 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
28e5dec8 2593#endif /* NV_PRESERVES_UV */
93a17b20 2594 }
79072805 2595 else {
f7877b28 2596 if (isGV_with_GP(sv)) {
159b6efe 2597 glob_2number(MUTABLE_GV(sv));
180488f8
NC
2598 return 0.0;
2599 }
2600
041457d9 2601 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
29489e7c 2602 report_uninit(sv);
7e25a7e9
NC
2603 assert (SvTYPE(sv) >= SVt_NV);
2604 /* Typically the caller expects that sv_any is not NULL now. */
2605 /* XXX Ilya implies that this is a bug in callers that assume this
2606 and ideally should be fixed. */
a0d0e21e 2607 return 0.0;
79072805 2608 }
572bbb43 2609#if defined(USE_LONG_DOUBLE)
097ee67d 2610 DEBUG_c({
f93f4e46 2611 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS
2612 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2613 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
2614 RESTORE_NUMERIC_LOCAL();
2615 });
65202027 2616#else
572bbb43 2617 DEBUG_c({
f93f4e46 2618 STORE_NUMERIC_LOCAL_SET_STANDARD();
1779d84d 2619 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
1d7c1841 2620 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
2621 RESTORE_NUMERIC_LOCAL();
2622 });
572bbb43 2623#endif
463ee0b2 2624 return SvNVX(sv);
79072805
LW
2625}
2626
800401ee
JH
2627/*
2628=for apidoc sv_2num
2629
2630Return an SV with the numeric value of the source SV, doing any necessary
a196a5fa
JH
2631reference or overload conversion. You must use the C<SvNUM(sv)> macro to
2632access this function.
800401ee
JH
2633
2634=cut
2635*/
2636
2637SV *
5de3775c 2638Perl_sv_2num(pTHX_ register SV *const sv)
800401ee 2639{
7918f24d
NC
2640 PERL_ARGS_ASSERT_SV_2NUM;
2641
b9ee0594
RGS
2642 if (!SvROK(sv))
2643 return sv;
800401ee
JH
2644 if (SvAMAGIC(sv)) {
2645 SV * const tmpsv = AMG_CALLun(sv,numer);
a02ec77a 2646 TAINT_IF(tmpsv && SvTAINTED(tmpsv));
800401ee
JH
2647 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2648 return sv_2num(tmpsv);
2649 }
2650 return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2651}
2652
645c22ef
DM
2653/* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2654 * UV as a string towards the end of buf, and return pointers to start and
2655 * end of it.
2656 *
2657 * We assume that buf is at least TYPE_CHARS(UV) long.
2658 */
2659
864dbfa3 2660static char *
5de3775c 2661S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
25da4f38 2662{
25da4f38 2663 char *ptr = buf + TYPE_CHARS(UV);
823a54a3 2664 char * const ebuf = ptr;
25da4f38 2665 int sign;
25da4f38 2666
7918f24d
NC
2667 PERL_ARGS_ASSERT_UIV_2BUF;
2668
25da4f38
IZ
2669 if (is_uv)
2670 sign = 0;
2671 else if (iv >= 0) {
2672 uv = iv;
2673 sign = 0;
2674 } else {
2675 uv = -iv;
2676 sign = 1;
2677 }
2678 do {
eb160463 2679 *--ptr = '0' + (char)(uv % 10);
25da4f38
IZ
2680 } while (uv /= 10);
2681 if (sign)
2682 *--ptr = '-';
2683 *peob = ebuf;
2684 return ptr;
2685}
2686
645c22ef
DM
2687/*
2688=for apidoc sv_2pv_flags
2689
ff276b08 2690Returns a pointer to the string value of an SV, and sets *lp to its length.
645c22ef
DM
2691If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2692if necessary.
2693Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2694usually end up here too.
2695
2696=cut
2697*/
2698
8d6d96c1 2699char *
5de3775c 2700Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
8d6d96c1 2701{
97aff369 2702 dVAR;
79072805 2703 register char *s;
79072805 2704
463ee0b2 2705 if (!sv) {
cdb061a3
NC
2706 if (lp)
2707 *lp = 0;
73d840c0 2708 return (char *)"";
463ee0b2 2709 }
8990e307 2710 if (SvGMAGICAL(sv)) {
8d6d96c1
HS
2711 if (flags & SV_GMAGIC)
2712 mg_get(sv);
463ee0b2 2713 if (SvPOKp(sv)) {
cdb061a3
NC
2714 if (lp)
2715 *lp = SvCUR(sv);
10516c54
NC
2716 if (flags & SV_MUTABLE_RETURN)
2717 return SvPVX_mutable(sv);
4d84ee25
NC
2718 if (flags & SV_CONST_RETURN)
2719 return (char *)SvPVX_const(sv);
463ee0b2
LW
2720 return SvPVX(sv);
2721 }
75dfc8ec
NC
2722 if (SvIOKp(sv) || SvNOKp(sv)) {
2723 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
75dfc8ec
NC
2724 STRLEN len;
2725
2726 if (SvIOKp(sv)) {
e80fed9d 2727 len = SvIsUV(sv)
d9fad198
JH
2728 ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2729 : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
29912d93
NC
2730 } else if(SvNVX(sv) == 0.0) {
2731 tbuf[0] = '0';
2732 tbuf[1] = 0;
2733 len = 1;
75dfc8ec 2734 } else {
e8ada2d0
NC
2735 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2736 len = strlen(tbuf);
75dfc8ec 2737 }
b5b886f0
NC
2738 assert(!SvROK(sv));
2739 {
75dfc8ec
NC
2740 dVAR;
2741
75dfc8ec
NC
2742 SvUPGRADE(sv, SVt_PV);
2743 if (lp)
2744 *lp = len;
2745 s = SvGROW_mutable(sv, len + 1);
2746 SvCUR_set(sv, len);
2747 SvPOKp_on(sv);
10edeb5d 2748 return (char*)memcpy(s, tbuf, len + 1);
75dfc8ec 2749 }
463ee0b2 2750 }
1c7ff15e
NC
2751 if (SvROK(sv)) {
2752 goto return_rok;
2753 }
2754 assert(SvTYPE(sv) >= SVt_PVMG);
2755 /* This falls through to the report_uninit near the end of the
2756 function. */
2757 } else if (SvTHINKFIRST(sv)) {
ed6116ce 2758 if (SvROK(sv)) {
1c7ff15e 2759 return_rok:
deb46114 2760 if (SvAMAGIC(sv)) {
aee036bb
DM
2761 SV *tmpstr;
2762 if (flags & SV_SKIP_OVERLOAD)
2763 return NULL;
2764 tmpstr = AMG_CALLun(sv,string);
a02ec77a 2765 TAINT_IF(tmpstr && SvTAINTED(tmpstr));
deb46114
NC
2766 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2767 /* Unwrap this: */
2768 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2769 */
2770
2771 char *pv;
2772 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2773 if (flags & SV_CONST_RETURN) {
2774 pv = (char *) SvPVX_const(tmpstr);
2775 } else {
2776 pv = (flags & SV_MUTABLE_RETURN)
2777 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2778 }
2779 if (lp)
2780 *lp = SvCUR(tmpstr);
50adf7d2 2781 } else {
deb46114 2782 pv = sv_2pv_flags(tmpstr, lp, flags);
50adf7d2 2783 }
deb46114
NC
2784 if (SvUTF8(tmpstr))
2785 SvUTF8_on(sv);
2786 else
2787 SvUTF8_off(sv);
2788 return pv;
50adf7d2 2789 }
deb46114
NC
2790 }
2791 {
fafee734
NC
2792 STRLEN len;
2793 char *retval;
2794 char *buffer;
d2c6dc5e 2795 SV *const referent = SvRV(sv);
d8eae41e
NC
2796
2797 if (!referent) {
fafee734
NC
2798 len = 7;
2799 retval = buffer = savepvn("NULLREF", len);
5c35adbb 2800 } else if (SvTYPE(referent) == SVt_REGEXP) {
d2c6dc5e 2801 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
67d2d14d
AB
2802 I32 seen_evals = 0;
2803
2804 assert(re);
2805
2806 /* If the regex is UTF-8 we want the containing scalar to
2807 have an UTF-8 flag too */
2808 if (RX_UTF8(re))
2809 SvUTF8_on(sv);
2810 else
2811 SvUTF8_off(sv);
2812
2813 if ((seen_evals = RX_SEEN_EVALS(re)))
2814 PL_reginterp_cnt += seen_evals;
2815
2816 if (lp)
2817 *lp = RX_WRAPLEN(re);
2818
2819 return RX_WRAPPED(re);
d8eae41e
NC
2820 } else {
2821 const char *const typestr = sv_reftype(referent, 0);
fafee734
NC
2822 const STRLEN typelen = strlen(typestr);
2823 UV addr = PTR2UV(referent);
2824 const char *stashname = NULL;
2825 STRLEN stashnamelen = 0; /* hush, gcc */
2826 const char *buffer_end;
d8eae41e 2827
d8eae41e 2828 if (SvOBJECT(referent)) {
fafee734
NC
2829 const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2830
2831 if (name) {
2832 stashname = HEK_KEY(name);
2833 stashnamelen = HEK_LEN(name);
2834
2835 if (HEK_UTF8(name)) {
2836 SvUTF8_on(sv);
2837 } else {
2838 SvUTF8_off(sv);
2839 }
2840 } else {
2841 stashname = "__ANON__";
2842 stashnamelen = 8;
2843 }
2844 len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2845 + 2 * sizeof(UV) + 2 /* )\0 */;
2846 } else {
2847 len = typelen + 3 /* (0x */
2848 + 2 * sizeof(UV) + 2 /* )\0 */;
d8eae41e 2849 }
fafee734
NC
2850
2851 Newx(buffer, len, char);
2852 buffer_end = retval = buffer + len;
2853
2854 /* Working backwards */
2855 *--retval = '\0';
2856 *--retval = ')';
2857 do {
2858 *--retval = PL_hexdigit[addr & 15];
2859 } while (addr >>= 4);
2860 *--retval = 'x';
2861 *--retval = '0';
2862 *--retval = '(';
2863
2864 retval -= typelen;
2865 memcpy(retval, typestr, typelen);
2866
2867 if (stashname) {
2868 *--retval = '=';
2869 retval -= stashnamelen;
2870 memcpy(retval, stashname, stashnamelen);
2871 }
2872 /* retval may not neccesarily have reached the start of the
2873 buffer here. */
2874 assert (retval >= buffer);
2875
2876 len = buffer_end - retval - 1; /* -1 for that \0 */
c080367d 2877 }
042dae7a 2878 if (lp)
fafee734
NC
2879 *lp = len;
2880 SAVEFREEPV(buffer);
2881 return retval;
463ee0b2 2882 }
79072805 2883 }
0336b60e 2884 if (SvREADONLY(sv) && !SvOK(sv)) {
cdb061a3
NC
2885 if (lp)
2886 *lp = 0;
9f621bb0
NC
2887 if (flags & SV_UNDEF_RETURNS_NULL)
2888 return NULL;
2889 if (ckWARN(WARN_UNINITIALIZED))
2890 report_uninit(sv);
73d840c0 2891 return (char *)"";
79072805 2892 }
79072805 2893 }
28e5dec8
JH
2894 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2895 /* I'm assuming that if both IV and NV are equally valid then
2896 converting the IV is going to be more efficient */
e1ec3a88 2897 const U32 isUIOK = SvIsUV(sv);
28e5dec8
JH
2898 char buf[TYPE_CHARS(UV)];
2899 char *ebuf, *ptr;
97a130b8 2900 STRLEN len;
28e5dec8
JH
2901
2902 if (SvTYPE(sv) < SVt_PVIV)
2903 sv_upgrade(sv, SVt_PVIV);
4ea1d550 2904 ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
97a130b8 2905 len = ebuf - ptr;
5902b6a9 2906 /* inlined from sv_setpvn */
97a130b8
NC
2907 s = SvGROW_mutable(sv, len + 1);
2908 Move(ptr, s, len, char);
2909 s += len;
28e5dec8 2910 *s = '\0';
28e5dec8
JH
2911 }
2912 else if (SvNOKp(sv)) {
79072805
LW
2913 if (SvTYPE(sv) < SVt_PVNV)
2914 sv_upgrade(sv, SVt_PVNV);
29912d93
NC
2915 if (SvNVX(sv) == 0.0) {
2916 s = SvGROW_mutable(sv, 2);
2917 *s++ = '0';
2918 *s = '\0';
2919 } else {
2920 dSAVE_ERRNO;
2921 /* The +20 is pure guesswork. Configure test needed. --jhi */
2922 s = SvGROW_mutable(sv, NV_DIG + 20);
2923 /* some Xenix systems wipe out errno here */
2d4389e4 2924 Gconvert(SvNVX(sv), NV_DIG, 0, s);
29912d93
NC
2925 RESTORE_ERRNO;
2926 while (*s) s++;
bbce6d69 2927 }
79072805
LW
2928#ifdef hcx
2929 if (s[-1] == '.')
46fc3d4c 2930 *--s = '\0';
79072805
LW
2931#endif
2932 }
79072805 2933 else {
8d1c3e26
NC
2934 if (isGV_with_GP(sv)) {
2935 GV *const gv = MUTABLE_GV(sv);
2936 const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
2937 SV *const buffer = sv_newmortal();
2938
2939 /* FAKE globs can get coerced, so need to turn this off temporarily
2940 if it is on. */
2941 SvFAKE_off(gv);
2942 gv_efullname3(buffer, gv, "*");
2943 SvFLAGS(gv) |= wasfake;
2944
1809c940
DM
2945 if (SvPOK(buffer)) {
2946 if (lp) {
2947 *lp = SvCUR(buffer);
2948 }
2949 return SvPVX(buffer);
2950 }
2951 else {
2952 if (lp)
2953 *lp = 0;
2954 return (char *)"";
8d1c3e26 2955 }
8d1c3e26 2956 }
180488f8 2957
cdb061a3 2958 if (lp)
00b6aa41 2959 *lp = 0;
9f621bb0
NC
2960 if (flags & SV_UNDEF_RETURNS_NULL)
2961 return NULL;
2962 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2963 report_uninit(sv);
25da4f38
IZ
2964 if (SvTYPE(sv) < SVt_PV)
2965 /* Typically the caller expects that sv_any is not NULL now. */
2966 sv_upgrade(sv, SVt_PV);
73d840c0 2967 return (char *)"";
79072805 2968 }
cdb061a3 2969 {
823a54a3 2970 const STRLEN len = s - SvPVX_const(sv);
cdb061a3
NC
2971 if (lp)
2972 *lp = len;
2973 SvCUR_set(sv, len);
2974 }
79072805 2975 SvPOK_on(sv);
1d7c1841 2976 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3f7c398e 2977 PTR2UV(sv),SvPVX_const(sv)));
4d84ee25
NC
2978 if (flags & SV_CONST_RETURN)
2979 return (char *)SvPVX_const(sv);
10516c54
NC
2980 if (flags & SV_MUTABLE_RETURN)
2981 return SvPVX_mutable(sv);
463ee0b2
LW
2982 return SvPVX(sv);
2983}
2984
645c22ef 2985/*
6050d10e
JP
2986=for apidoc sv_copypv
2987
2988Copies a stringified representation of the source SV into the
2989destination SV. Automatically performs any necessary mg_get and
54f0641b 2990coercion of numeric values into strings. Guaranteed to preserve
2575c402 2991UTF8 flag even from overloaded objects. Similar in nature to
54f0641b
NIS
2992sv_2pv[_flags] but operates directly on an SV instead of just the
2993string. Mostly uses sv_2pv_flags to do its work, except when that
6050d10e
JP
2994would lose the UTF-8'ness of the PV.
2995
2996=cut
2997*/
2998
2999void
5de3775c 3000Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
6050d10e 3001{
446eaa42 3002 STRLEN len;
53c1dcc0 3003 const char * const s = SvPV_const(ssv,len);
7918f24d
NC
3004
3005 PERL_ARGS_ASSERT_SV_COPYPV;
3006
cb50f42d 3007 sv_setpvn(dsv,s,len);
446eaa42 3008 if (SvUTF8(ssv))
cb50f42d 3009 SvUTF8_on(dsv);
446eaa42 3010 else
cb50f42d 3011 SvUTF8_off(dsv);
6050d10e
JP
3012}
3013
3014/*
645c22ef
DM
3015=for apidoc sv_2pvbyte
3016
3017Return a pointer to the byte-encoded representation of the SV, and set *lp
1e54db1a 3018to its length. May cause the SV to be downgraded from UTF-8 as a
645c22ef
DM
3019side-effect.
3020
3021Usually accessed via the C<SvPVbyte> macro.
3022
3023=cut
3024*/
3025
7340a771 3026char *
5de3775c 3027Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
7340a771 3028{
7918f24d
NC
3029 PERL_ARGS_ASSERT_SV_2PVBYTE;
3030
71eb6d8c 3031 SvGETMAGIC(sv);
0875d2fe 3032 sv_utf8_downgrade(sv,0);
71eb6d8c 3033 return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
7340a771
GS
3034}
3035
645c22ef 3036/*
035cbb0e
RGS
3037=for apidoc sv_2pvutf8
3038
3039Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3040to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3041
3042Usually accessed via the C<SvPVutf8> macro.
3043
3044=cut
3045*/
645c22ef 3046
7340a771 3047char *
7bc54cea 3048Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
7340a771 3049{
7918f24d
NC
3050 PERL_ARGS_ASSERT_SV_2PVUTF8;
3051
035cbb0e
RGS
3052 sv_utf8_upgrade(sv);
3053 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
7340a771 3054}
1c846c1f 3055
7ee2227d 3056
645c22ef
DM
3057/*
3058=for apidoc sv_2bool
3059
06c841cf
FC
3060This macro is only used by sv_true() or its macro equivalent, and only if
3061the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3062It calls sv_2bool_flags with the SV_GMAGIC flag.
3063
3064=for apidoc sv_2bool_flags
3065
3066This function is only used by sv_true() and friends, and only if
3067the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
3068contain SV_GMAGIC, then it does an mg_get() first.
3069
645c22ef
DM
3070
3071=cut
3072*/
3073
463ee0b2 3074bool
06c841cf 3075Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
463ee0b2 3076{
97aff369 3077 dVAR;
7918f24d 3078
06c841cf 3079 PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
7918f24d 3080
06c841cf 3081 if(flags & SV_GMAGIC) SvGETMAGIC(sv);
463ee0b2 3082
a0d0e21e
LW
3083 if (!SvOK(sv))
3084 return 0;
3085 if (SvROK(sv)) {
fabdb6c0
AL
3086 if (SvAMAGIC(sv)) {
3087 SV * const tmpsv = AMG_CALLun(sv,bool_);
3088 if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
f2338a2e 3089 return cBOOL(SvTRUE(tmpsv));
fabdb6c0
AL
3090 }
3091 return SvRV(sv) != 0;
a0d0e21e 3092 }
463ee0b2 3093 if (SvPOKp(sv)) {
53c1dcc0
AL
3094 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3095 if (Xpvtmp &&
339049b0 3096 (*sv->sv_u.svu_pv > '0' ||
11343788 3097 Xpvtmp->xpv_cur > 1 ||
339049b0 3098 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
463ee0b2
LW
3099 return 1;
3100 else
3101 return 0;
3102 }
3103 else {
3104 if (SvIOKp(sv))
3105 return SvIVX(sv) != 0;
3106 else {
3107 if (SvNOKp(sv))
3108 return SvNVX(sv) != 0.0;
180488f8 3109 else {
f7877b28 3110 if (isGV_with_GP(sv))
180488f8
NC
3111 return TRUE;
3112 else
3113 return FALSE;
3114 }
463ee0b2
LW
3115 }
3116 }
79072805
LW
3117}
3118
c461cf8f
JH
3119/*
3120=for apidoc sv_utf8_upgrade
3121
78ea37eb 3122Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3123Forces the SV to string form if it is not already.
2bbc8d55 3124Will C<mg_get> on C<sv> if appropriate.
4411f3b6 3125Always sets the SvUTF8 flag to avoid future validity checks even
2bbc8d55
SP
3126if the whole string is the same in UTF-8 as not.
3127Returns the number of bytes in the converted string
c461cf8f 3128
13a6c0e0
JH
3129This is not as a general purpose byte encoding to Unicode interface:
3130use the Encode extension for that.
3131
fe749c9a
KW
3132=for apidoc sv_utf8_upgrade_nomg
3133
3134Like sv_utf8_upgrade, but doesn't do magic on C<sv>
3135
8d6d96c1
HS
3136=for apidoc sv_utf8_upgrade_flags
3137
78ea37eb 3138Converts the PV of an SV to its UTF-8-encoded form.
645c22ef 3139Forces the SV to string form if it is not already.
8d6d96c1 3140Always sets the SvUTF8 flag to avoid future validity checks even
2bbc8d55
SP
3141if all the bytes are invariant in UTF-8. If C<flags> has C<SV_GMAGIC> bit set,
3142will C<mg_get> on C<sv> if appropriate, else not.
3143Returns the number of bytes in the converted string
3144C<sv_utf8_upgrade> and
8d6d96c1
HS
3145C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3146
13a6c0e0
JH
3147This is not as a general purpose byte encoding to Unicode interface:
3148use the Encode extension for that.
3149
8d6d96c1 3150=cut
b3ab6785
KW
3151
3152The grow version is currently not externally documented. It adds a parameter,
3153extra, which is the number of unused bytes the string of 'sv' is guaranteed to
3154have free after it upon return. This allows the caller to reserve extra space
3155that it intends to fill, to avoid extra grows.
3156
3157Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
3158which can be used to tell this function to not first check to see if there are
3159any characters that are different in UTF-8 (variant characters) which would
3160force it to allocate a new string to sv, but to assume there are. Typically
3161this flag is used by a routine that has already parsed the string to find that
3162there are such characters, and passes this information on so that the work
3163doesn't have to be repeated.
3164
3165(One might think that the calling routine could pass in the position of the
3166first such variant, so it wouldn't have to be found again. But that is not the
3167case, because typically when the caller is likely to use this flag, it won't be
3168calling this routine unless it finds something that won't fit into a byte.
3169Otherwise it tries to not upgrade and just use bytes. But some things that
3170do fit into a byte are variants in utf8, and the caller may not have been
3171keeping track of these.)
3172
3173If the routine itself changes the string, it adds a trailing NUL. Such a NUL
3174isn't guaranteed due to having other routines do the work in some input cases,
3175or if the input is already flagged as being in utf8.
3176
3177The speed of this could perhaps be improved for many cases if someone wanted to
3178write a fast function that counts the number of variant characters in a string,
3179especially if it could return the position of the first one.
3180
8d6d96c1
HS
3181*/
3182
3183STRLEN
b3ab6785 3184Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra)
8d6d96c1 3185{
97aff369 3186 dVAR;
7918f24d 3187
b3ab6785 3188 PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
7918f24d 3189
808c356f
RGS
3190 if (sv == &PL_sv_undef)
3191 return 0;
e0e62c2a
NIS
3192 if (!SvPOK(sv)) {
3193 STRLEN len = 0;
d52b7888
NC
3194 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3195 (void) sv_2pv_flags(sv,&len, flags);
b3ab6785
KW
3196 if (SvUTF8(sv)) {
3197 if (extra) SvGROW(sv, SvCUR(sv) + extra);
d52b7888 3198 return len;
b3ab6785 3199 }
d52b7888
NC
3200 } else {
3201 (void) SvPV_force(sv,len);
3202 }
e0e62c2a 3203 }
4411f3b6 3204
f5cee72b 3205 if (SvUTF8(sv)) {
b3ab6785 3206 if (extra) SvGROW(sv, SvCUR(sv) + extra);
5fec3b1d 3207 return SvCUR(sv);
f5cee72b 3208 }
5fec3b1d 3209
765f542d
NC
3210 if (SvIsCOW(sv)) {
3211 sv_force_normal_flags(sv, 0);
db42d148
NIS
3212 }
3213
b3ab6785 3214 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
799ef3cb 3215 sv_recode_to_utf8(sv, PL_encoding);
b3ab6785
KW
3216 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3217 return SvCUR(sv);
3218 }
3219
4e93345f
KW
3220 if (SvCUR(sv) == 0) {
3221 if (extra) SvGROW(sv, extra);
3222 } else { /* Assume Latin-1/EBCDIC */
c4e7c712 3223 /* This function could be much more efficient if we
2bbc8d55 3224 * had a FLAG in SVs to signal if there are any variant
c4e7c712 3225 * chars in the PV. Given that there isn't such a flag
b3ab6785
KW
3226 * make the loop as fast as possible (although there are certainly ways
3227 * to speed this up, eg. through vectorization) */
3228 U8 * s = (U8 *) SvPVX_const(sv);
3229 U8 * e = (U8 *) SvEND(sv);
3230 U8 *t = s;
3231 STRLEN two_byte_count = 0;
c4e7c712 3232
b3ab6785
KW
3233 if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3234
3235 /* See if really will need to convert to utf8. We mustn't rely on our
3236 * incoming SV being well formed and having a trailing '\0', as certain
3237 * code in pp_formline can send us partially built SVs. */
3238
c4e7c712 3239 while (t < e) {
53c1dcc0 3240 const U8 ch = *t++;
b3ab6785
KW
3241 if (NATIVE_IS_INVARIANT(ch)) continue;
3242
3243 t--; /* t already incremented; re-point to first variant */
3244 two_byte_count = 1;
3245 goto must_be_utf8;
c4e7c712 3246 }
b3ab6785
KW
3247
3248 /* utf8 conversion not needed because all are invariants. Mark as
3249 * UTF-8 even if no variant - saves scanning loop */
c4e7c712 3250 SvUTF8_on(sv);
b3ab6785
KW
3251 return SvCUR(sv);
3252
3253must_be_utf8:
3254
3255 /* Here, the string should be converted to utf8, either because of an
3256 * input flag (two_byte_count = 0), or because a character that
3257 * requires 2 bytes was found (two_byte_count = 1). t points either to
3258 * the beginning of the string (if we didn't examine anything), or to
3259 * the first variant. In either case, everything from s to t - 1 will
3260 * occupy only 1 byte each on output.
3261 *
3262 * There are two main ways to convert. One is to create a new string
3263 * and go through the input starting from the beginning, appending each
3264 * converted value onto the new string as we go along. It's probably
3265 * best to allocate enough space in the string for the worst possible
3266 * case rather than possibly running out of space and having to
3267 * reallocate and then copy what we've done so far. Since everything
3268 * from s to t - 1 is invariant, the destination can be initialized
3269 * with these using a fast memory copy
3270 *
3271 * The other way is to figure out exactly how big the string should be
3272 * by parsing the entire input. Then you don't have to make it big
3273 * enough to handle the worst possible case, and more importantly, if
3274 * the string you already have is large enough, you don't have to
3275 * allocate a new string, you can copy the last character in the input
3276 * string to the final position(s) that will be occupied by the
3277 * converted string and go backwards, stopping at t, since everything
3278 * before that is invariant.
3279 *
3280 * There are advantages and disadvantages to each method.
3281 *
3282 * In the first method, we can allocate a new string, do the memory
3283 * copy from the s to t - 1, and then proceed through the rest of the
3284 * string byte-by-byte.
3285 *
3286 * In the second method, we proceed through the rest of the input
3287 * string just calculating how big the converted string will be. Then
3288 * there are two cases:
3289 * 1) if the string has enough extra space to handle the converted
3290 * value. We go backwards through the string, converting until we
3291 * get to the position we are at now, and then stop. If this
3292 * position is far enough along in the string, this method is
3293 * faster than the other method. If the memory copy were the same
3294 * speed as the byte-by-byte loop, that position would be about
3295 * half-way, as at the half-way mark, parsing to the end and back
3296 * is one complete string's parse, the same amount as starting
3297 * over and going all the way through. Actually, it would be
3298 * somewhat less than half-way, as it's faster to just count bytes
3299 * than to also copy, and we don't have the overhead of allocating
3300 * a new string, changing the scalar to use it, and freeing the
3301 * existing one. But if the memory copy is fast, the break-even
3302 * point is somewhere after half way. The counting loop could be
3303 * sped up by vectorization, etc, to move the break-even point
3304 * further towards the beginning.
3305 * 2) if the string doesn't have enough space to handle the converted
3306 * value. A new string will have to be allocated, and one might
3307 * as well, given that, start from the beginning doing the first
3308 * method. We've spent extra time parsing the string and in
3309 * exchange all we've gotten is that we know precisely how big to
3310 * make the new one. Perl is more optimized for time than space,
3311 * so this case is a loser.
3312 * So what I've decided to do is not use the 2nd method unless it is
3313 * guaranteed that a new string won't have to be allocated, assuming
3314 * the worst case. I also decided not to put any more conditions on it
3315 * than this, for now. It seems likely that, since the worst case is
3316 * twice as big as the unknown portion of the string (plus 1), we won't
3317 * be guaranteed enough space, causing us to go to the first method,
3318 * unless the string is short, or the first variant character is near
3319 * the end of it. In either of these cases, it seems best to use the
3320 * 2nd method. The only circumstance I can think of where this would
3321 * be really slower is if the string had once had much more data in it
3322 * than it does now, but there is still a substantial amount in it */
3323
3324 {
3325 STRLEN invariant_head = t - s;
3326 STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3327 if (SvLEN(sv) < size) {
3328
3329 /* Here, have decided to allocate a new string */
3330
3331 U8 *dst;
3332 U8 *d;
3333
3334 Newx(dst, size, U8);
3335
3336 /* If no known invariants at the beginning of the input string,
3337 * set so starts from there. Otherwise, can use memory copy to
3338 * get up to where we are now, and then start from here */
3339
3340 if (invariant_head <= 0) {
3341 d = dst;
3342 } else {
3343 Copy(s, dst, invariant_head, char);
3344 d = dst + invariant_head;
3345 }
3346
3347 while (t < e) {
3348 const UV uv = NATIVE8_TO_UNI(*t++);
3349 if (UNI_IS_INVARIANT(uv))
3350 *d++ = (U8)UNI_TO_NATIVE(uv);
3351 else {
3352 *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
3353 *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
3354 }
3355 }
3356 *d = '\0';
3357 SvPV_free(sv); /* No longer using pre-existing string */
3358 SvPV_set(sv, (char*)dst);
3359 SvCUR_set(sv, d - dst);
3360 SvLEN_set(sv, size);
3361 } else {
3362
3363 /* Here, have decided to get the exact size of the string.
3364 * Currently this happens only when we know that there is
3365 * guaranteed enough space to fit the converted string, so
3366 * don't have to worry about growing. If two_byte_count is 0,
3367 * then t points to the first byte of the string which hasn't
3368 * been examined yet. Otherwise two_byte_count is 1, and t
3369 * points to the first byte in the string that will expand to
3370 * two. Depending on this, start examining at t or 1 after t.
3371 * */
3372
3373 U8 *d = t + two_byte_count;
3374
3375
3376 /* Count up the remaining bytes that expand to two */
3377
3378 while (d < e) {
3379 const U8 chr = *d++;
3380 if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
3381 }
3382
3383 /* The string will expand by just the number of bytes that
3384 * occupy two positions. But we are one afterwards because of
3385 * the increment just above. This is the place to put the
3386 * trailing NUL, and to set the length before we decrement */
3387
3388 d += two_byte_count;
3389 SvCUR_set(sv, d - s);
3390 *d-- = '\0';
3391
3392
3393 /* Having decremented d, it points to the position to put the
3394 * very last byte of the expanded string. Go backwards through
3395 * the string, copying and expanding as we go, stopping when we
3396 * get to the part that is invariant the rest of the way down */
3397
3398 e--;
3399 while (e >= t) {
3400 const U8 ch = NATIVE8_TO_UNI(*e--);
3401 if (UNI_IS_INVARIANT(ch)) {
3402 *d-- = UNI_TO_NATIVE(ch);
3403 } else {
3404 *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
3405 *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
3406 }
3407 }
3408 }
3409 }
560a288e 3410 }
b3ab6785
KW
3411
3412 /* Mark as UTF-8 even if no variant - saves scanning loop */
3413 SvUTF8_on(sv);
4411f3b6 3414 return SvCUR(sv);
560a288e
GS
3415}
3416
c461cf8f
JH
3417/*
3418=for apidoc sv_utf8_downgrade
3419
78ea37eb 3420Attempts to convert the PV of an SV from characters to bytes.
2bbc8d55
SP
3421If the PV contains a character that cannot fit
3422in a byte, this conversion will fail;
78ea37eb 3423in this case, either returns false or, if C<fail_ok> is not
c461cf8f
JH
3424true, croaks.
3425
13a6c0e0
JH
3426This is not as a general purpose Unicode to byte encoding interface:
3427use the Encode extension for that.
3428
c461cf8f
JH
3429=cut
3430*/
3431
560a288e 3432bool
7bc54cea 3433Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
560a288e 3434{
97aff369 3435 dVAR;
7918f24d
NC
3436
3437 PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3438
78ea37eb 3439 if (SvPOKp(sv) && SvUTF8(sv)) {
fa301091 3440 if (SvCUR(sv)) {
03cfe0ae 3441 U8 *s;
652088fc 3442 STRLEN len;
fa301091 3443
765f542d
NC
3444 if (SvIsCOW(sv)) {
3445 sv_force_normal_flags(sv, 0);
3446 }
03cfe0ae
NIS
3447 s = (U8 *) SvPV(sv, len);
3448 if (!utf8_to_bytes(s, &len)) {
fa301091
JH
3449 if (fail_ok)
3450 return FALSE;
3451 else {
3452 if (PL_op)
3453 Perl_croak(aTHX_ "Wide character in %s",
53e06cf0 3454 OP_DESC(PL_op));
fa301091
JH
3455 else
3456 Perl_croak(aTHX_ "Wide character");
3457 }
4b3603a4 3458 }
b162af07 3459 SvCUR_set(sv, len);
67e989fb 3460 }
560a288e 3461 }
ffebcc3e 3462 SvUTF8_off(sv);
560a288e
GS
3463 return TRUE;
3464}
3465
c461cf8f
JH
3466/*
3467=for apidoc sv_utf8_encode
3468
78ea37eb
ST
3469Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3470flag off so that it looks like octets again.
c461cf8f
JH
3471
3472=cut
3473*/
3474
560a288e 3475void
7bc54cea 3476Perl_sv_utf8_encode(pTHX_ register SV *const sv)
560a288e 3477{
7918f24d
NC
3478 PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3479
4c94c214
NC
3480 if (SvIsCOW(sv)) {
3481 sv_force_normal_flags(sv, 0);
3482 }
3483 if (SvREADONLY(sv)) {
6ad8f254 3484 Perl_croak_no_modify(aTHX);
4c94c214 3485 }
a5f5288a 3486 (void) sv_utf8_upgrade(sv);
560a288e
GS
3487 SvUTF8_off(sv);
3488}
3489
4411f3b6
NIS
3490/*
3491=for apidoc sv_utf8_decode
3492
78ea37eb
ST
3493If the PV of the SV is an octet sequence in UTF-8
3494and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3495so that it looks like a character. If the PV contains only single-byte
3496characters, the C<SvUTF8> flag stays being off.
3497Scans PV for validity and returns false if the PV is invalid UTF-8.
4411f3b6
NIS
3498
3499=cut
3500*/
3501
560a288e 3502bool
7bc54cea 3503Perl_sv_utf8_decode(pTHX_ register SV *const sv)
560a288e 3504{
7918f24d
NC
3505 PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3506
78ea37eb 3507 if (SvPOKp(sv)) {
93524f2b
NC
3508 const U8 *c;
3509 const U8 *e;
9cbac4c7 3510
645c22ef
DM
3511 /* The octets may have got themselves encoded - get them back as
3512 * bytes
3513 */
3514 if (!sv_utf8_downgrade(sv, TRUE))
560a288e
GS
3515 return FALSE;
3516
3517 /* it is actually just a matter of turning the utf8 flag on, but
3518 * we want to make sure everything inside is valid utf8 first.
3519 */
93524f2b 3520 c = (const U8 *) SvPVX_const(sv);
63cd0674 3521 if (!is_utf8_string(c, SvCUR(sv)+1))
67e989fb 3522 return FALSE;
93524f2b 3523 e = (const U8 *) SvEND(sv);
511c2ff0 3524 while (c < e) {
b64e5050 3525 const U8 ch = *c++;
c4d5f83a 3526 if (!UTF8_IS_INVARIANT(ch)) {
67e989fb
JH
3527 SvUTF8_on(sv);
3528 break;
3529 }
560a288e 3530 }
560a288e
GS
3531 }
3532 return TRUE;
3533}
3534
954c1994
GS
3535/*
3536=for apidoc sv_setsv
3537
645c22ef
DM
3538Copies the contents of the source SV C<ssv> into the destination SV
3539C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3540function if the source SV needs to be reused. Does not handle 'set' magic.
3541Loosely speaking, it performs a copy-by-value, obliterating any previous
3542content of the destination.
3543
3544You probably want to use one of the assortment of wrappers, such as
3545C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3546C<SvSetMagicSV_nosteal>.
3547
8d6d96c1
HS
3548=for apidoc sv_setsv_flags
3549
645c22ef
DM
3550Copies the contents of the source SV C<ssv> into the destination SV
3551C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3552function if the source SV needs to be reused. Does not handle 'set' magic.
3553Loosely speaking, it performs a copy-by-value, obliterating any previous
3554content of the destination.
3555If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
5fcdf167
NC
3556C<ssv> if appropriate, else not. If the C<flags> parameter has the
3557C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3558and C<sv_setsv_nomg> are implemented in terms of this function.
645c22ef
DM
3559
3560You probably want to use one of the assortment of wrappers, such as
3561C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3562C<SvSetMagicSV_nosteal>.
3563
3564This is the primary function for copying scalars, and most other
3565copy-ish functions and macros use this underneath.
8d6d96c1
HS
3566
3567=cut
3568*/
3569
5d0301b7 3570static void
7bc54cea 3571S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
5d0301b7 3572{
c8bbf675 3573 I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3e6edce2 3574 HV *old_stash = NULL;
dd69841b 3575
7918f24d
NC
3576 PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3577
bec4f4b4 3578 if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
5d0301b7
NC
3579 const char * const name = GvNAME(sstr);
3580 const STRLEN len = GvNAMELEN(sstr);
0d092c36 3581 {
f7877b28
NC
3582 if (dtype >= SVt_PV) {
3583 SvPV_free(dstr);
3584 SvPV_set(dstr, 0);
3585 SvLEN_set(dstr, 0);
3586 SvCUR_set(dstr, 0);
3587 }
0d092c36 3588 SvUPGRADE(dstr, SVt_PVGV);
dedf8e73 3589 (void)SvOK_off(dstr);
2e5b91de
NC
3590 /* FIXME - why are we doing this, then turning it off and on again
3591 below? */
3592 isGV_with_GP_on(dstr);
f7877b28 3593 }
5d0301b7
NC
3594 GvSTASH(dstr) = GvSTASH(sstr);
3595 if (GvSTASH(dstr))
daba3364 3596 Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
159b6efe 3597 gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD);
5d0301b7
NC
3598 SvFAKE_on(dstr); /* can coerce to non-glob */
3599 }
3600
159b6efe 3601 if(GvGP(MUTABLE_GV(sstr))) {
dd69841b
BB
3602 /* If source has method cache entry, clear it */
3603 if(GvCVGEN(sstr)) {
3604 SvREFCNT_dec(GvCV(sstr));
3605 GvCV(sstr) = NULL;
3606 GvCVGEN(sstr) = 0;
3607 }
3608 /* If source has a real method, then a method is
3609 going to change */
00169e2c
FC
3610 else if(
3611 GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3612 ) {
70cd14a1 3613 mro_changes = 1;
dd69841b
BB
3614 }
3615 }
3616
3617 /* If dest already had a real method, that's a change as well */
00169e2c
FC
3618 if(
3619 !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3620 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3621 ) {
70cd14a1 3622 mro_changes = 1;
dd69841b
BB
3623 }
3624
c8bbf675
FC
3625 /* We don’t need to check the name of the destination if it was not a
3626 glob to begin with. */
3627 if(dtype == SVt_PVGV) {
3628 const char * const name = GvNAME((const GV *)dstr);
00169e2c
FC
3629 if(
3630 strEQ(name,"ISA")
3631 /* The stash may have been detached from the symbol table, so
3632 check its name. */
3633 && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
6624142a 3634 && GvAV((const GV *)sstr)
00169e2c 3635 )
c8bbf675
FC
3636 mro_changes = 2;
3637 else {
3638 const STRLEN len = GvNAMELEN(dstr);
3639 if (len > 1 && name[len-2] == ':' && name[len-1] == ':') {
3640 mro_changes = 3;
3641
3642 /* Set aside the old stash, so we can reset isa caches on
3643 its subclasses. */
bf01568a
FC
3644 if((old_stash = GvHV(dstr)))
3645 /* Make sure we do not lose it early. */
3646 SvREFCNT_inc_simple_void_NN(
3647 sv_2mortal((SV *)old_stash)
3648 );
c8bbf675
FC
3649 }
3650 }
3651 }
70cd14a1 3652
159b6efe 3653 gp_free(MUTABLE_GV(dstr));
2e5b91de 3654 isGV_with_GP_off(dstr);
5d0301b7 3655 (void)SvOK_off(dstr);
2e5b91de 3656 isGV_with_GP_on(dstr);
dedf8e73 3657 GvINTRO_off(dstr); /* one-shot flag */
5d0301b7
NC
3658 GvGP(dstr) = gp_ref(GvGP(sstr));
3659 if (SvTAINTED(sstr))
3660 SvTAINT(dstr);
3661 if (GvIMPORTED(dstr) != GVf_IMPORTED
3662 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3663 {
3664 GvIMPORTED_on(dstr);
3665 }