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