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