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