This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove goto glob_assign;
[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
5d0301b7
NC
2928static void
2929S_glob_assign(pTHX_ SV *dstr, SV *sstr, const int dtype)
2930{
2931 if (dtype != SVt_PVGV) {
2932 const char * const name = GvNAME(sstr);
2933 const STRLEN len = GvNAMELEN(sstr);
2934 /* don't upgrade SVt_PVLV: it can hold a glob */
2935 if (dtype != SVt_PVLV)
2936 sv_upgrade(dstr, SVt_PVGV);
2937 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
2938 GvSTASH(dstr) = GvSTASH(sstr);
2939 if (GvSTASH(dstr))
2940 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
2941 GvNAME(dstr) = savepvn(name, len);
2942 GvNAMELEN(dstr) = len;
2943 SvFAKE_on(dstr); /* can coerce to non-glob */
2944 }
2945
2946#ifdef GV_UNIQUE_CHECK
2947 if (GvUNIQUE((GV*)dstr)) {
2948 Perl_croak(aTHX_ PL_no_modify);
2949 }
2950#endif
2951
2952 (void)SvOK_off(dstr);
2953 GvINTRO_off(dstr); /* one-shot flag */
2954 gp_free((GV*)dstr);
2955 GvGP(dstr) = gp_ref(GvGP(sstr));
2956 if (SvTAINTED(sstr))
2957 SvTAINT(dstr);
2958 if (GvIMPORTED(dstr) != GVf_IMPORTED
2959 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2960 {
2961 GvIMPORTED_on(dstr);
2962 }
2963 GvMULTI_on(dstr);
2964 return;
2965}
2966
8d6d96c1
HS
2967void
2968Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
2969{
97aff369 2970 dVAR;
8990e307
LW
2971 register U32 sflags;
2972 register int dtype;
2973 register int stype;
463ee0b2 2974
79072805
LW
2975 if (sstr == dstr)
2976 return;
765f542d 2977 SV_CHECK_THINKFIRST_COW_DROP(dstr);
79072805 2978 if (!sstr)
3280af22 2979 sstr = &PL_sv_undef;
8990e307
LW
2980 stype = SvTYPE(sstr);
2981 dtype = SvTYPE(dstr);
79072805 2982
a0d0e21e 2983 SvAMAGIC_off(dstr);
7a5fa8a2 2984 if ( SvVOK(dstr) )
ece467f9
JP
2985 {
2986 /* need to nuke the magic */
2987 mg_free(dstr);
2988 SvRMAGICAL_off(dstr);
2989 }
9e7bc3e8 2990
463ee0b2 2991 /* There's a lot of redundancy below but we're going for speed here */
79072805 2992
8990e307 2993 switch (stype) {
79072805 2994 case SVt_NULL:
aece5585 2995 undef_sstr:
20408e3c
GS
2996 if (dtype != SVt_PVGV) {
2997 (void)SvOK_off(dstr);
2998 return;
2999 }
3000 break;
463ee0b2 3001 case SVt_IV:
aece5585
GA
3002 if (SvIOK(sstr)) {
3003 switch (dtype) {
3004 case SVt_NULL:
8990e307 3005 sv_upgrade(dstr, SVt_IV);
aece5585
GA
3006 break;
3007 case SVt_NV:
8990e307 3008 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
3009 break;
3010 case SVt_RV:
3011 case SVt_PV:
a0d0e21e 3012 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA
3013 break;
3014 }
3015 (void)SvIOK_only(dstr);
45977657 3016 SvIV_set(dstr, SvIVX(sstr));
25da4f38
IZ
3017 if (SvIsUV(sstr))
3018 SvIsUV_on(dstr);
27c9684d
AP
3019 if (SvTAINTED(sstr))
3020 SvTAINT(dstr);
aece5585 3021 return;
8990e307 3022 }
aece5585
GA
3023 goto undef_sstr;
3024
463ee0b2 3025 case SVt_NV:
aece5585
GA
3026 if (SvNOK(sstr)) {
3027 switch (dtype) {
3028 case SVt_NULL:
3029 case SVt_IV:
8990e307 3030 sv_upgrade(dstr, SVt_NV);
aece5585
GA
3031 break;
3032 case SVt_RV:
3033 case SVt_PV:
3034 case SVt_PVIV:
a0d0e21e 3035 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
3036 break;
3037 }
9d6ce603 3038 SvNV_set(dstr, SvNVX(sstr));
aece5585 3039 (void)SvNOK_only(dstr);
27c9684d
AP
3040 if (SvTAINTED(sstr))
3041 SvTAINT(dstr);
aece5585 3042 return;
8990e307 3043 }
aece5585
GA
3044 goto undef_sstr;
3045
ed6116ce 3046 case SVt_RV:
8990e307 3047 if (dtype < SVt_RV)
ed6116ce 3048 sv_upgrade(dstr, SVt_RV);
c07a80fd 3049 else if (dtype == SVt_PVGV &&
23bb1b96 3050 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
c07a80fd 3051 sstr = SvRV(sstr);
a5f75d66 3052 if (sstr == dstr) {
1d7c1841
GS
3053 if (GvIMPORTED(dstr) != GVf_IMPORTED
3054 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3055 {
a5f75d66 3056 GvIMPORTED_on(dstr);
1d7c1841 3057 }
a5f75d66
AD
3058 GvMULTI_on(dstr);
3059 return;
3060 }
c36d06f3 3061 return S_glob_assign(aTHX_ dstr, sstr, dtype);
c07a80fd 3062 }
ed6116ce 3063 break;
fc36a67e 3064 case SVt_PVFM:
f8c7b90f 3065#ifdef PERL_OLD_COPY_ON_WRITE
d89fc664
NC
3066 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3067 if (dtype < SVt_PVIV)
3068 sv_upgrade(dstr, SVt_PVIV);
3069 break;
3070 }
3071 /* Fall through */
3072#endif
3073 case SVt_PV:
8990e307 3074 if (dtype < SVt_PV)
463ee0b2 3075 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
3076 break;
3077 case SVt_PVIV:
8990e307 3078 if (dtype < SVt_PVIV)
463ee0b2 3079 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW
3080 break;
3081 case SVt_PVNV:
8990e307 3082 if (dtype < SVt_PVNV)
463ee0b2 3083 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 3084 break;
4633a7c4
LW
3085 case SVt_PVAV:
3086 case SVt_PVHV:
3087 case SVt_PVCV:
4633a7c4 3088 case SVt_PVIO:
a3b680e6
AL
3089 {
3090 const char * const type = sv_reftype(sstr,0);
533c011a 3091 if (PL_op)
a3b680e6 3092 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
4633a7c4 3093 else
a3b680e6
AL
3094 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3095 }
4633a7c4
LW
3096 break;
3097
79072805 3098 case SVt_PVGV:
8990e307 3099 if (dtype <= SVt_PVGV) {
5d0301b7 3100 return S_glob_assign(aTHX_ dstr, sstr, dtype);
79072805
LW
3101 }
3102 /* FALL THROUGH */
3103
3104 default:
8d6d96c1 3105 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
973f89ab 3106 mg_get(sstr);
eb160463 3107 if ((int)SvTYPE(sstr) != stype) {
973f89ab
CS
3108 stype = SvTYPE(sstr);
3109 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
c36d06f3 3110 return S_glob_assign(aTHX_ dstr, sstr, dtype);
973f89ab
CS
3111 }
3112 }
ded42b9f 3113 if (stype == SVt_PVLV)
862a34c6 3114 SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 3115 else
862a34c6 3116 SvUPGRADE(dstr, (U32)stype);
79072805
LW
3117 }
3118
8990e307
LW
3119 sflags = SvFLAGS(sstr);
3120
3121 if (sflags & SVf_ROK) {
3122 if (dtype >= SVt_PV) {
3123 if (dtype == SVt_PVGV) {
823a54a3 3124 SV * const sref = SvREFCNT_inc(SvRV(sstr));
cbbf8932 3125 SV *dref = NULL;
a3b680e6 3126 const int intro = GvINTRO(dstr);
a0d0e21e 3127
7fb37951
AMS
3128#ifdef GV_UNIQUE_CHECK
3129 if (GvUNIQUE((GV*)dstr)) {
5bd07a3d
DM
3130 Perl_croak(aTHX_ PL_no_modify);
3131 }
3132#endif
3133
a0d0e21e 3134 if (intro) {
a5f75d66 3135 GvINTRO_off(dstr); /* one-shot flag */
1d7c1841 3136 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 3137 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 3138 }
a5f75d66 3139 GvMULTI_on(dstr);
8990e307
LW
3140 switch (SvTYPE(sref)) {
3141 case SVt_PVAV:
a0d0e21e 3142 if (intro)
890ed176 3143 SAVEGENERICSV(GvAV(dstr));
a0d0e21e
LW
3144 else
3145 dref = (SV*)GvAV(dstr);
8990e307 3146 GvAV(dstr) = (AV*)sref;
39bac7f7 3147 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS
3148 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3149 {
a5f75d66 3150 GvIMPORTED_AV_on(dstr);
1d7c1841 3151 }
8990e307
LW
3152 break;
3153 case SVt_PVHV:
a0d0e21e 3154 if (intro)
890ed176 3155 SAVEGENERICSV(GvHV(dstr));
a0d0e21e
LW
3156 else
3157 dref = (SV*)GvHV(dstr);
8990e307 3158 GvHV(dstr) = (HV*)sref;
39bac7f7 3159 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS
3160 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3161 {
a5f75d66 3162 GvIMPORTED_HV_on(dstr);
1d7c1841 3163 }
8990e307
LW
3164 break;
3165 case SVt_PVCV:
8ebc5c01
PP
3166 if (intro) {
3167 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3168 SvREFCNT_dec(GvCV(dstr));
3169 GvCV(dstr) = Nullcv;
68dc0745 3170 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 3171 PL_sub_generation++;
8ebc5c01 3172 }
890ed176 3173 SAVEGENERICSV(GvCV(dstr));
8ebc5c01 3174 }
68dc0745
PP
3175 else
3176 dref = (SV*)GvCV(dstr);
3177 if (GvCV(dstr) != (CV*)sref) {
823a54a3 3178 CV* const cv = GvCV(dstr);
4633a7c4 3179 if (cv) {
68dc0745
PP
3180 if (!GvCVGEN((GV*)dstr) &&
3181 (CvROOT(cv) || CvXSUB(cv)))
3182 {
beab0874
JT
3183 /* Redefining a sub - warning is mandatory if
3184 it was a const and its value changed. */
2111d928
NC
3185 if (CvCONST(cv) && CvCONST((CV*)sref)
3186 && cv_const_sv(cv)
3187 == cv_const_sv((CV*)sref)) {
3188 /* They are 2 constant subroutines
3189 generated from the same constant.
3190 This probably means that they are
3191 really the "same" proxy subroutine
3192 instantiated in 2 places. Most likely
3193 this is when a constant is exported
3194 twice. Don't warn. */
3195 }
3196 else if (ckWARN(WARN_REDEFINE)
beab0874
JT
3197 || (CvCONST(cv)
3198 && (!CvCONST((CV*)sref)
3199 || sv_cmp(cv_const_sv(cv),
3200 cv_const_sv((CV*)sref)))))
3201 {
9014280d 3202 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
beab0874 3203 CvCONST(cv)
910764e6
RGS
3204 ? "Constant subroutine %s::%s redefined"
3205 : "Subroutine %s::%s redefined",
bfcb3514 3206 HvNAME_get(GvSTASH((GV*)dstr)),
beab0874
JT
3207 GvENAME((GV*)dstr));
3208 }
9607fc9c 3209 }
fb24441d
RGS
3210 if (!intro)
3211 cv_ckproto(cv, (GV*)dstr,
93524f2b
NC
3212 SvPOK(sref)
3213 ? SvPVX_const(sref) : Nullch);
4633a7c4 3214 }
a5f75d66 3215 GvCV(dstr) = (CV*)sref;
7a4c00b4 3216 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 3217 GvASSUMECV_on(dstr);
3280af22 3218 PL_sub_generation++;
a5f75d66 3219 }
39bac7f7 3220 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS
3221 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3222 {
a5f75d66 3223 GvIMPORTED_CV_on(dstr);
1d7c1841 3224 }
8990e307 3225 break;
91bba347
LW
3226 case SVt_PVIO:
3227 if (intro)
890ed176 3228 SAVEGENERICSV(GvIOp(dstr));
91bba347
LW
3229 else
3230 dref = (SV*)GvIOp(dstr);
3231 GvIOp(dstr) = (IO*)sref;
3232 break;
f4d13ee9
JH
3233 case SVt_PVFM:
3234 if (intro)
890ed176 3235 SAVEGENERICSV(GvFORM(dstr));
f4d13ee9
JH
3236 else
3237 dref = (SV*)GvFORM(dstr);
3238 GvFORM(dstr) = (CV*)sref;
3239 break;
8990e307 3240 default:
a0d0e21e 3241 if (intro)
890ed176 3242 SAVEGENERICSV(GvSV(dstr));
a0d0e21e
LW
3243 else
3244 dref = (SV*)GvSV(dstr);
8990e307 3245 GvSV(dstr) = sref;
39bac7f7 3246 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS
3247 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3248 {
a5f75d66 3249 GvIMPORTED_SV_on(dstr);
1d7c1841 3250 }
8990e307
LW
3251 break;
3252 }
3253 if (dref)
3254 SvREFCNT_dec(dref);
27c9684d
AP
3255 if (SvTAINTED(sstr))
3256 SvTAINT(dstr);
8990e307
LW
3257 return;
3258 }
3f7c398e 3259 if (SvPVX_const(dstr)) {
8bd4d4c5 3260 SvPV_free(dstr);
b162af07
SP
3261 SvLEN_set(dstr, 0);
3262 SvCUR_set(dstr, 0);
a0d0e21e 3263 }
8990e307 3264 }
a0d0e21e 3265 (void)SvOK_off(dstr);
b162af07 3266 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
ed6116ce 3267 SvROK_on(dstr);
8990e307 3268 if (sflags & SVp_NOK) {
3332b3c1
JH
3269 SvNOKp_on(dstr);
3270 /* Only set the public OK flag if the source has public OK. */
3271 if (sflags & SVf_NOK)
3272 SvFLAGS(dstr) |= SVf_NOK;
9d6ce603 3273 SvNV_set(dstr, SvNVX(sstr));
ed6116ce 3274 }
8990e307 3275 if (sflags & SVp_IOK) {
3332b3c1
JH
3276 (void)SvIOKp_on(dstr);
3277 if (sflags & SVf_IOK)
3278 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3279 if (sflags & SVf_IVisUV)
25da4f38 3280 SvIsUV_on(dstr);
45977657 3281 SvIV_set(dstr, SvIVX(sstr));
ed6116ce 3282 }
a0d0e21e
LW
3283 if (SvAMAGIC(sstr)) {
3284 SvAMAGIC_on(dstr);
3285 }
ed6116ce 3286 }
8990e307 3287 else if (sflags & SVp_POK) {
765f542d 3288 bool isSwipe = 0;
79072805
LW
3289
3290 /*
3291 * Check to see if we can just swipe the string. If so, it's a
3292 * possible small lose on short strings, but a big win on long ones.
3f7c398e
SP
3293 * It might even be a win on short strings if SvPVX_const(dstr)
3294 * has to be allocated and SvPVX_const(sstr) has to be freed.
79072805
LW
3295 */
3296
120fac95
NC
3297 /* Whichever path we take through the next code, we want this true,
3298 and doing it now facilitates the COW check. */
3299 (void)SvPOK_only(dstr);
3300
765f542d 3301 if (
b8f9541a
NC
3302 /* We're not already COW */
3303 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
f8c7b90f 3304#ifndef PERL_OLD_COPY_ON_WRITE
b8f9541a
NC
3305 /* or we are, but dstr isn't a suitable target. */
3306 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3307#endif
3308 )
765f542d 3309 &&
765f542d
NC
3310 !(isSwipe =
3311 (sflags & SVs_TEMP) && /* slated for free anyway? */
3312 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
5fcdf167
NC
3313 (!(flags & SV_NOSTEAL)) &&
3314 /* and we're allowed to steal temps */
765f542d
NC
3315 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3316 SvLEN(sstr) && /* and really is a string */
645c22ef 3317 /* and won't be needed again, potentially */
765f542d 3318 !(PL_op && PL_op->op_type == OP_AASSIGN))
f8c7b90f 3319#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 3320 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
120fac95 3321 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
765f542d
NC
3322 && SvTYPE(sstr) >= SVt_PVIV)
3323#endif
3324 ) {
3325 /* Failed the swipe test, and it's not a shared hash key either.
3326 Have to copy the string. */
3327 STRLEN len = SvCUR(sstr);
3328 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3f7c398e 3329 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
765f542d
NC
3330 SvCUR_set(dstr, len);
3331 *SvEND(dstr) = '\0';
765f542d 3332 } else {
f8c7b90f 3333 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
765f542d 3334 be true in here. */
765f542d
NC
3335 /* Either it's a shared hash key, or it's suitable for
3336 copy-on-write or we can swipe the string. */
46187eeb 3337 if (DEBUG_C_TEST) {
ed252734 3338 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
e419cbc5
NC
3339 sv_dump(sstr);
3340 sv_dump(dstr);
46187eeb 3341 }
f8c7b90f 3342#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
3343 if (!isSwipe) {
3344 /* I believe I should acquire a global SV mutex if
3345 it's a COW sv (not a shared hash key) to stop
3346 it going un copy-on-write.
3347 If the source SV has gone un copy on write between up there
3348 and down here, then (assert() that) it is of the correct
3349 form to make it copy on write again */
3350 if ((sflags & (SVf_FAKE | SVf_READONLY))
3351 != (SVf_FAKE | SVf_READONLY)) {
3352 SvREADONLY_on(sstr);
3353 SvFAKE_on(sstr);
3354 /* Make the source SV into a loop of 1.
3355 (about to become 2) */
a29f6d03 3356 SV_COW_NEXT_SV_SET(sstr, sstr);
765f542d
NC
3357 }
3358 }
3359#endif
3360 /* Initial code is common. */
94010e71
NC
3361 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
3362 SvPV_free(dstr);
79072805 3363 }
765f542d 3364
765f542d
NC
3365 if (!isSwipe) {
3366 /* making another shared SV. */
3367 STRLEN cur = SvCUR(sstr);
3368 STRLEN len = SvLEN(sstr);
f8c7b90f 3369#ifdef PERL_OLD_COPY_ON_WRITE
765f542d 3370 if (len) {
b8f9541a 3371 assert (SvTYPE(dstr) >= SVt_PVIV);
765f542d
NC
3372 /* SvIsCOW_normal */
3373 /* splice us in between source and next-after-source. */
a29f6d03
NC
3374 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3375 SV_COW_NEXT_SV_SET(sstr, dstr);
940132f3 3376 SvPV_set(dstr, SvPVX_mutable(sstr));
a604c751
NC
3377 } else
3378#endif
3379 {
765f542d 3380 /* SvIsCOW_shared_hash */
46187eeb
NC
3381 DEBUG_C(PerlIO_printf(Perl_debug_log,
3382 "Copy on write: Sharing hash\n"));
b8f9541a 3383
bdd68bc3 3384 assert (SvTYPE(dstr) >= SVt_PV);
765f542d 3385 SvPV_set(dstr,
d1db91c6 3386 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
bdd68bc3 3387 }
87a1ef3d
SP
3388 SvLEN_set(dstr, len);
3389 SvCUR_set(dstr, cur);
765f542d
NC
3390 SvREADONLY_on(dstr);
3391 SvFAKE_on(dstr);
3392 /* Relesase a global SV mutex. */
3393 }
3394 else
765f542d 3395 { /* Passes the swipe test. */
78d1e721 3396 SvPV_set(dstr, SvPVX_mutable(sstr));
765f542d
NC
3397 SvLEN_set(dstr, SvLEN(sstr));
3398 SvCUR_set(dstr, SvCUR(sstr));
3399
3400 SvTEMP_off(dstr);
3401 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
6136c704 3402 SvPV_set(sstr, NULL);
765f542d
NC
3403 SvLEN_set(sstr, 0);
3404 SvCUR_set(sstr, 0);
3405 SvTEMP_off(sstr);
3406 }
3407 }
9aa983d2 3408 if (sflags & SVf_UTF8)
a7cb1f99 3409 SvUTF8_on(dstr);
8990e307 3410 if (sflags & SVp_NOK) {
3332b3c1
JH
3411 SvNOKp_on(dstr);
3412 if (sflags & SVf_NOK)
3413 SvFLAGS(dstr) |= SVf_NOK;
9d6ce603 3414 SvNV_set(dstr, SvNVX(sstr));
79072805 3415 }
8990e307 3416 if (sflags & SVp_IOK) {
3332b3c1
JH
3417 (void)SvIOKp_on(dstr);
3418 if (sflags & SVf_IOK)
3419 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3420 if (sflags & SVf_IVisUV)
25da4f38 3421 SvIsUV_on(dstr);
45977657 3422 SvIV_set(dstr, SvIVX(sstr));
79072805 3423 }
92f0c265 3424 if (SvVOK(sstr)) {
00b6aa41 3425 const MAGIC * const smg = mg_find(sstr,PERL_MAGIC_vstring);
ece467f9
JP
3426 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3427 smg->mg_ptr, smg->mg_len);
439cb1c4 3428 SvRMAGICAL_on(dstr);
7a5fa8a2 3429 }
79072805 3430 }
8990e307 3431 else if (sflags & SVp_IOK) {
3332b3c1
JH
3432 if (sflags & SVf_IOK)
3433 (void)SvIOK_only(dstr);
3434 else {
9cbac4c7
DM
3435 (void)SvOK_off(dstr);
3436 (void)SvIOKp_on(dstr);
3332b3c1
JH
3437 }
3438 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2b1c7e3e 3439 if (sflags & SVf_IVisUV)
25da4f38 3440 SvIsUV_on(dstr);
45977657 3441 SvIV_set(dstr, SvIVX(sstr));
3332b3c1
JH
3442 if (sflags & SVp_NOK) {
3443 if (sflags & SVf_NOK)
3444 (void)SvNOK_on(dstr);
3445 else
3446 (void)SvNOKp_on(dstr);
9d6ce603 3447 SvNV_set(dstr, SvNVX(sstr));
3332b3c1
JH
3448 }
3449 }
3450 else if (sflags & SVp_NOK) {
3451 if (sflags & SVf_NOK)
3452 (void)SvNOK_only(dstr);
3453 else {
9cbac4c7 3454 (void)SvOK_off(dstr);
3332b3c1
JH
3455 SvNOKp_on(dstr);
3456 }
9d6ce603 3457 SvNV_set(dstr, SvNVX(sstr));
79072805
LW
3458 }
3459 else {
20408e3c 3460 if (dtype == SVt_PVGV) {
e476b1b5 3461 if (ckWARN(WARN_MISC))
9014280d 3462 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
20408e3c
GS
3463 }
3464 else
3465 (void)SvOK_off(dstr);
a0d0e21e 3466 }
27c9684d
AP
3467 if (SvTAINTED(sstr))
3468 SvTAINT(dstr);
79072805
LW
3469}
3470
954c1994
GS
3471/*
3472=for apidoc sv_setsv_mg
3473
3474Like C<sv_setsv>, but also handles 'set' magic.
3475
3476=cut
3477*/
3478
79072805 3479void
864dbfa3 3480Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS
3481{
3482 sv_setsv(dstr,sstr);
3483 SvSETMAGIC(dstr);
3484}
3485
f8c7b90f 3486#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
3487SV *
3488Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3489{
3490 STRLEN cur = SvCUR(sstr);
3491 STRLEN len = SvLEN(sstr);
3492 register char *new_pv;
3493
3494 if (DEBUG_C_TEST) {
3495 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3496 sstr, dstr);
3497 sv_dump(sstr);
3498 if (dstr)
3499 sv_dump(dstr);
3500 }
3501
3502 if (dstr) {
3503 if (SvTHINKFIRST(dstr))
3504 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3f7c398e
SP
3505 else if (SvPVX_const(dstr))
3506 Safefree(SvPVX_const(dstr));
ed252734
NC
3507 }
3508 else
3509 new_SV(dstr);
862a34c6 3510 SvUPGRADE(dstr, SVt_PVIV);
ed252734
NC
3511
3512 assert (SvPOK(sstr));
3513 assert (SvPOKp(sstr));
3514 assert (!SvIOK(sstr));
3515 assert (!SvIOKp(sstr));
3516 assert (!SvNOK(sstr));
3517 assert (!SvNOKp(sstr));
3518
3519 if (SvIsCOW(sstr)) {
3520
3521 if (SvLEN(sstr) == 0) {
3522 /* source is a COW shared hash key. */
ed252734
NC
3523 DEBUG_C(PerlIO_printf(Perl_debug_log,
3524 "Fast copy on write: Sharing hash\n"));
d1db91c6 3525 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
ed252734
NC
3526 goto common_exit;
3527 }
3528 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3529 } else {
3530 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
862a34c6 3531 SvUPGRADE(sstr, SVt_PVIV);
ed252734
NC
3532 SvREADONLY_on(sstr);
3533 SvFAKE_on(sstr);
3534 DEBUG_C(PerlIO_printf(Perl_debug_log,
3535 "Fast copy on write: Converting sstr to COW\n"));
3536 SV_COW_NEXT_SV_SET(dstr, sstr);
3537 }
3538 SV_COW_NEXT_SV_SET(sstr, dstr);
940132f3 3539 new_pv = SvPVX_mutable(sstr);
ed252734
NC
3540
3541 common_exit:
3542 SvPV_set(dstr, new_pv);
3543 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3544 if (SvUTF8(sstr))
3545 SvUTF8_on(dstr);
87a1ef3d
SP
3546 SvLEN_set(dstr, len);
3547 SvCUR_set(dstr, cur);
ed252734
NC
3548 if (DEBUG_C_TEST) {
3549 sv_dump(dstr);
3550 }
3551 return dstr;
3552}
3553#endif
3554
954c1994
GS
3555/*
3556=for apidoc sv_setpvn
3557
3558Copies a string into an SV. The C<len> parameter indicates the number of
9e09f5f2
MHM
3559bytes to be copied. If the C<ptr> argument is NULL the SV will become
3560undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
954c1994
GS
3561
3562=cut
3563*/
3564
ef50df4b 3565void
864dbfa3 3566Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3567{
97aff369 3568 dVAR;
c6f8c383 3569 register char *dptr;
22c522df 3570
765f542d 3571 SV_CHECK_THINKFIRST_COW_DROP(sv);
463ee0b2 3572 if (!ptr) {
a0d0e21e 3573 (void)SvOK_off(sv);
463ee0b2
LW
3574 return;
3575 }
22c522df
JH
3576 else {
3577 /* len is STRLEN which is unsigned, need to copy to signed */
a3b680e6 3578 const IV iv = len;
9c5ffd7c
JH
3579 if (iv < 0)
3580 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
22c522df 3581 }
862a34c6 3582 SvUPGRADE(sv, SVt_PV);
c6f8c383 3583
5902b6a9 3584 dptr = SvGROW(sv, len + 1);
c6f8c383
GA
3585 Move(ptr,dptr,len,char);
3586 dptr[len] = '\0';
79072805 3587 SvCUR_set(sv, len);
1aa99e6b 3588 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3589 SvTAINT(sv);
79072805
LW
3590}
3591
954c1994
GS
3592/*
3593=for apidoc sv_setpvn_mg
3594
3595Like C<sv_setpvn>, but also handles 'set' magic.
3596
3597=cut
3598*/
3599
79072805 3600void
864dbfa3 3601Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS
3602{
3603 sv_setpvn(sv,ptr,len);
3604 SvSETMAGIC(sv);
3605}
3606
954c1994
GS
3607/*
3608=for apidoc sv_setpv
3609
3610Copies a string into an SV. The string must be null-terminated. Does not
3611handle 'set' magic. See C<sv_setpv_mg>.
3612
3613=cut
3614*/
3615
ef50df4b 3616void
864dbfa3 3617Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805 3618{
97aff369 3619 dVAR;
79072805
LW
3620 register STRLEN len;
3621
765f542d 3622 SV_CHECK_THINKFIRST_COW_DROP(sv);
463ee0b2 3623 if (!ptr) {
a0d0e21e 3624 (void)SvOK_off(sv);
463ee0b2
LW
3625 return;
3626 }
79072805 3627 len = strlen(ptr);
862a34c6 3628 SvUPGRADE(sv, SVt_PV);
c6f8c383 3629
79072805 3630 SvGROW(sv, len + 1);
463ee0b2 3631 Move(ptr,SvPVX(sv),len+1,char);
79072805 3632 SvCUR_set(sv, len);
1aa99e6b 3633 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2
LW
3634 SvTAINT(sv);
3635}
3636
954c1994
GS
3637/*
3638=for apidoc sv_setpv_mg
3639
3640Like C<sv_setpv>, but also handles 'set' magic.
3641
3642=cut
3643*/
3644
463ee0b2 3645void
864dbfa3 3646Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS
3647{
3648 sv_setpv(sv,ptr);
3649 SvSETMAGIC(sv);
3650}
3651
954c1994
GS
3652/*
3653=for apidoc sv_usepvn
3654
3655Tells an SV to use C<ptr> to find its string value. Normally the string is
1c846c1f 3656stored inside the SV but sv_usepvn allows the SV to use an outside string.
954c1994
GS
3657The C<ptr> should point to memory that was allocated by C<malloc>. The
3658string length, C<len>, must be supplied. This function will realloc the
3659memory pointed to by C<ptr>, so that pointer should not be freed or used by
3660the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3661See C<sv_usepvn_mg>.
3662
3663=cut
3664*/
3665
ef50df4b 3666void
864dbfa3 3667Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 3668{
97aff369 3669 dVAR;
1936d2a7 3670 STRLEN allocate;
765f542d 3671 SV_CHECK_THINKFIRST_COW_DROP(sv);
862a34c6 3672 SvUPGRADE(sv, SVt_PV);
463ee0b2 3673 if (!ptr) {
a0d0e21e 3674 (void)SvOK_off(sv);
463ee0b2
LW
3675 return;
3676 }
3f7c398e 3677 if (SvPVX_const(sv))
8bd4d4c5 3678 SvPV_free(sv);
1936d2a7
NC
3679
3680 allocate = PERL_STRLEN_ROUNDUP(len + 1);
7a9b70e9 3681 ptr = saferealloc (ptr, allocate);
f880fe2f 3682 SvPV_set(sv, ptr);
463ee0b2 3683 SvCUR_set(sv, len);
1936d2a7 3684 SvLEN_set(sv, allocate);
463ee0b2 3685 *SvEND(sv) = '\0';
1aa99e6b 3686 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3687 SvTAINT(sv);
79072805
LW
3688}
3689
954c1994
GS
3690/*
3691=for apidoc sv_usepvn_mg
3692
3693Like C<sv_usepvn>, but also handles 'set' magic.
3694
3695=cut
3696*/
3697
ef50df4b 3698void
864dbfa3 3699Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 3700{
51c1089b 3701 sv_usepvn(sv,ptr,len);
ef50df4b
GS
3702 SvSETMAGIC(sv);
3703}
3704
f8c7b90f 3705#ifdef PERL_OLD_COPY_ON_WRITE
765f542d
NC
3706/* Need to do this *after* making the SV normal, as we need the buffer
3707 pointer to remain valid until after we've copied it. If we let go too early,
3708 another thread could invalidate it by unsharing last of the same hash key
3709 (which it can do by means other than releasing copy-on-write Svs)
3710 or by changing the other copy-on-write SVs in the loop. */
3711STATIC void
bdd68bc3 3712S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
765f542d
NC
3713{
3714 if (len) { /* this SV was SvIsCOW_normal(sv) */
3715 /* we need to find the SV pointing to us. */