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