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