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