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