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