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