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