This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
14a5fab6d435273a310521314d21d422523ae96f
[perl5.git] / sv.c
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
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  *
9  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
10  *
11  *
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.
18  */
19
20 #include "EXTERN.h"
21 #define PERL_IN_SV_C
22 #include "perl.h"
23 #include "regcomp.h"
24
25 #define FCALL *f
26
27 #ifdef __Lynx__
28 /* Missing proto on LynxOS */
29   char *gconvert(double, int, int,  char *);
30 #endif
31
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
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
54    on-write.  */
55 #endif
56
57 /* ============================================================================
58
59 =head1 Allocation and deallocation of SVs.
60
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
65
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
71
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena.  In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots.  Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
78
79 The 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
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
87
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
91
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
96
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
99
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
105
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
112
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
116
117 Manipulation of any of the PL_*root pointers is protected by enclosing
118 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
119 if threads are enabled.
120
121 The function visit() scans the SV arenas list, and calls a specified
122 function for each SV it finds which is still live - ie which has an SvTYPE
123 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
124 following functions (specified as [function that calls visit()] / [function
125 called 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
148 =head2 Arena allocator API Summary
149
150 Private 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
158 Public API:
159
160     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
161
162
163 =cut
164
165 ============================================================================ */
166
167
168
169 /*
170  * "A time to plant, and a time to uproot what was planted..."
171  */
172
173 /*
174  * nice_chunk and nice_chunk size need to be set
175  * and queried under the protection of sv_mutex
176  */
177 void
178 Perl_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 }
194
195 #ifdef DEBUG_LEAKING_SCALARS
196 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
197 #else
198 #  define FREE_SV_DEBUG_FILE(sv)
199 #endif
200
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
214 #define plant_SV(p) \
215     STMT_START {                                        \
216         FREE_SV_DEBUG_FILE(p);                          \
217         POSION_SV_HEAD(p);                              \
218         SvARENA_CHAIN(p) = (void *)PL_sv_root;          \
219         SvFLAGS(p) = SVTYPEMASK;                        \
220         PL_sv_root = (p);                               \
221         --PL_sv_count;                                  \
222     } STMT_END
223
224 /* sv_mutex must be held while calling uproot_SV() */
225 #define uproot_SV(p) \
226     STMT_START {                                        \
227         (p) = PL_sv_root;                               \
228         PL_sv_root = (SV*)SvARENA_CHAIN(p);                     \
229         ++PL_sv_count;                                  \
230     } STMT_END
231
232
233 /* make some more SVs by adding another arena */
234
235 /* sv_mutex must be held while calling more_sv() */
236 STATIC SV*
237 S_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 */
248         Newx(chunk,PERL_ARENA_SIZE,char);   /* Safefree() in sv_free_arenas()     */
249         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
250     }
251     uproot_SV(sv);
252     return sv;
253 }
254
255 /* new_SV(): return a new, empty SV head */
256
257 #ifdef DEBUG_LEAKING_SCALARS
258 /* provide a real function for a debugger to play with */
259 STATIC SV*
260 S_new_SV(pTHX)
261 {
262     SV* sv;
263
264     LOCK_SV_MUTEX;
265     if (PL_sv_root)
266         uproot_SV(sv);
267     else
268         sv = S_more_sv(aTHX);
269     UNLOCK_SV_MUTEX;
270     SvANY(sv) = 0;
271     SvREFCNT(sv) = 1;
272     SvFLAGS(sv) = 0;
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;
278     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
279     
280     return sv;
281 }
282 #  define new_SV(p) (p)=S_new_SV(aTHX)
283
284 #else
285 #  define new_SV(p) \
286     STMT_START {                                        \
287         LOCK_SV_MUTEX;                                  \
288         if (PL_sv_root)                                 \
289             uproot_SV(p);                               \
290         else                                            \
291             (p) = S_more_sv(aTHX);                      \
292         UNLOCK_SV_MUTEX;                                \
293         SvANY(p) = 0;                                   \
294         SvREFCNT(p) = 1;                                \
295         SvFLAGS(p) = 0;                                 \
296     } STMT_END
297 #endif
298
299
300 /* del_SV(): return an empty SV head to the free list */
301
302 #ifdef DEBUGGING
303
304 #define del_SV(p) \
305     STMT_START {                                        \
306         LOCK_SV_MUTEX;                                  \
307         if (DEBUG_D_TEST)                               \
308             del_sv(p);                                  \
309         else                                            \
310             plant_SV(p);                                \
311         UNLOCK_SV_MUTEX;                                \
312     } STMT_END
313
314 STATIC void
315 S_del_sv(pTHX_ SV *p)
316 {
317     if (DEBUG_D_TEST) {
318         SV* sva;
319         bool ok = 0;
320         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
321             const SV * const sv = sva + 1;
322             const SV * const svend = &sva[SvREFCNT(sva)];
323             if (p >= sv && p < svend) {
324                 ok = 1;
325                 break;
326             }
327         }
328         if (!ok) {
329             if (ckWARN_d(WARN_INTERNAL))        
330                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
331                             "Attempt to free non-arena SV: 0x%"UVxf
332                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
333             return;
334         }
335     }
336     plant_SV(p);
337 }
338
339 #else /* ! DEBUGGING */
340
341 #define del_SV(p)   plant_SV(p)
342
343 #endif /* DEBUGGING */
344
345
346 /*
347 =head1 SV Manipulation Functions
348
349 =for apidoc sv_add_arena
350
351 Given a chunk of memory, link it to the head of the list of arenas,
352 and split it into a list of free SVs.
353
354 =cut
355 */
356
357 void
358 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
359 {
360     SV* sva = (SV*)ptr;
361     register SV* sv;
362     register SV* svend;
363
364     /* The first SV in an arena isn't an SV. */
365     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
366     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
367     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
368
369     PL_sv_arenaroot = sva;
370     PL_sv_root = sva + 1;
371
372     svend = &sva[SvREFCNT(sva) - 1];
373     sv = sva + 1;
374     while (sv < svend) {
375         SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
376 #ifdef DEBUGGING
377         SvREFCNT(sv) = 0;
378 #endif
379         /* Must always set typemask because it's awlays checked in on cleanup
380            when the arenas are walked looking for objects.  */
381         SvFLAGS(sv) = SVTYPEMASK;
382         sv++;
383     }
384     SvARENA_CHAIN(sv) = 0;
385 #ifdef DEBUGGING
386     SvREFCNT(sv) = 0;
387 #endif
388     SvFLAGS(sv) = SVTYPEMASK;
389 }
390
391 /* visit(): call the named function for each non-free SV in the arenas
392  * whose flags field matches the flags/mask args. */
393
394 STATIC I32
395 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
396 {
397     SV* sva;
398     I32 visited = 0;
399
400     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
401         register const SV * const svend = &sva[SvREFCNT(sva)];
402         register SV* sv;
403         for (sv = sva + 1; sv < svend; ++sv) {
404             if (SvTYPE(sv) != SVTYPEMASK
405                     && (sv->sv_flags & mask) == flags
406                     && SvREFCNT(sv))
407             {
408                 (FCALL)(aTHX_ sv);
409                 ++visited;
410             }
411         }
412     }
413     return visited;
414 }
415
416 #ifdef DEBUGGING
417
418 /* called by sv_report_used() for each live SV */
419
420 static void
421 do_report_used(pTHX_ SV *sv)
422 {
423     if (SvTYPE(sv) != SVTYPEMASK) {
424         PerlIO_printf(Perl_debug_log, "****\n");
425         sv_dump(sv);
426     }
427 }
428 #endif
429
430 /*
431 =for apidoc sv_report_used
432
433 Dump the contents of all SVs not yet freed. (Debugging aid).
434
435 =cut
436 */
437
438 void
439 Perl_sv_report_used(pTHX)
440 {
441 #ifdef DEBUGGING
442     visit(do_report_used, 0, 0);
443 #endif
444 }
445
446 /* called by sv_clean_objs() for each live SV */
447
448 static void
449 do_clean_objs(pTHX_ SV *ref)
450 {
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             }
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
473 static void
474 do_clean_named_objs(pTHX_ SV *sv)
475 {
476     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
477         if ((
478 #ifdef PERL_DONT_CREATE_GVSV
479              GvSV(sv) &&
480 #endif
481              SvOBJECT(GvSV(sv))) ||
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)));
488             SvFLAGS(sv) |= SVf_BREAK;
489             SvREFCNT_dec(sv);
490         }
491     }
492 }
493 #endif
494
495 /*
496 =for apidoc sv_clean_objs
497
498 Attempt to destroy all objects not yet freed
499
500 =cut
501 */
502
503 void
504 Perl_sv_clean_objs(pTHX)
505 {
506     PL_in_clean_objs = TRUE;
507     visit(do_clean_objs, SVf_ROK, SVf_ROK);
508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
509     /* some barnacles may yet remain, clinging to typeglobs */
510     visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
511 #endif
512     PL_in_clean_objs = FALSE;
513 }
514
515 /* called by sv_clean_all() for each live SV */
516
517 static void
518 do_clean_all(pTHX_ SV *sv)
519 {
520     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
521     SvFLAGS(sv) |= SVf_BREAK;
522     if (PL_comppad == (AV*)sv) {
523         PL_comppad = Nullav;
524         PL_curpad = Null(SV**);
525     }
526     SvREFCNT_dec(sv);
527 }
528
529 /*
530 =for apidoc sv_clean_all
531
532 Decrement the refcnt of each remaining SV, possibly triggering a
533 cleanup. This function may have to be called multiple times to free
534 SVs which are in complex self-referential hierarchies.
535
536 =cut
537 */
538
539 I32
540 Perl_sv_clean_all(pTHX)
541 {
542     I32 cleaned;
543     PL_in_clean_all = TRUE;
544     cleaned = visit(do_clean_all, 0,0);
545     PL_in_clean_all = FALSE;
546     return cleaned;
547 }
548
549 static void 
550 S_free_arena(pTHX_ void **root) {
551     while (root) {
552         void ** const next = *(void **)root;
553         Safefree(root);
554         root = next;
555     }
556 }
557     
558 /*
559 =for apidoc sv_free_arenas
560
561 Deallocate the memory used by all arenas. Note that all the individual SV
562 heads and bodies within the arenas must already have been freed.
563
564 =cut
565 */
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
573 void
574 Perl_sv_free_arenas(pTHX)
575 {
576     SV* sva;
577     SV* svanext;
578     int i;
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
583     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
584         svanext = (SV*) SvANY(sva);
585         while (svanext && SvFAKE(svanext))
586             svanext = (SV*) SvANY(svanext);
587
588         if (!SvFAKE(sva))
589             Safefree(sva);
590     }
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
598     Safefree(PL_nice_chunk);
599     PL_nice_chunk = Nullch;
600     PL_nice_chunk_size = 0;
601     PL_sv_arenaroot = 0;
602     PL_sv_root = 0;
603 }
604
605 /*
606   Here are mid-level routines that manage the allocation of bodies out
607   of the various arenas.  There are 5 kinds of arenas:
608
609   1. SV-head arenas, which are discussed and handled above
610   2. regular body arenas
611   3. arenas for reduced-size bodies
612   4. Hash-Entry arenas
613   5. pte arenas (thread related)
614
615   Arena types 2 & 3 are chained by body-type off an array of
616   arena-root pointers, which is indexed by svtype.  Some of the
617   larger/less used body types are malloced singly, since a large
618   unused block of them is wasteful.  Also, several svtypes dont have
619   bodies; the data fits into the sv-head itself.  The arena-root
620   pointer thus has a few unused root-pointers (which may be hijacked
621   later for arena types 4,5)
622
623   3 differs from 2 as an optimization; some body types have several
624   unused fields in the front of the structure (which are kept in-place
625   for consistency).  These bodies can be allocated in smaller chunks,
626   because the leading fields arent accessed.  Pointers to such bodies
627   are decremented to point at the unused 'ghost' memory, knowing that
628   the pointers are used with offsets to the real memory.
629
630   HE, HEK arenas are managed separately, with separate code, but may
631   be merge-able later..
632
633   PTE arenas are not sv-bodies, but they share these mid-level
634   mechanics, so are considered here.  The new mid-level mechanics rely
635   on the sv_type of the body being allocated, so we just reserve one
636   of the unused body-slots for PTEs, then use it in those (2) PTE
637   contexts below (line ~10k)
638 */
639
640 STATIC void *
641 S_more_bodies (pTHX_ size_t size, svtype sv_type)
642 {
643     void **arena_root   = &PL_body_arenaroots[sv_type];
644     void **root         = &PL_body_roots[sv_type];
645     char *start;
646     const char *end;
647     const size_t count = PERL_ARENA_SIZE / size;
648
649     Newx(start, count*size, char);
650     *((void **) start) = *arena_root;
651     *arena_root = (void *)start;
652
653     end = start + (count-1) * size;
654
655     /* The initial slot is used to link the arenas together, so it isn't to be
656        linked into the list of ready-to-use bodies.  */
657
658     start += size;
659
660     *root = (void *)start;
661
662     while (start < end) {
663         char * const next = start + size;
664         *(void**) start = (void *)next;
665         start = next;
666     }
667     *(void **)start = 0;
668
669     return *root;
670 }
671
672 /* grab a new thing from the free list, allocating more if necessary */
673
674 /* 1st, the inline version  */
675
676 #define new_body_inline(xpv, size, sv_type) \
677     STMT_START { \
678         void **r3wt = &PL_body_roots[sv_type]; \
679         LOCK_SV_MUTEX; \
680         xpv = *((void **)(r3wt)) \
681           ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
682         *(r3wt) = *(void**)(xpv); \
683         UNLOCK_SV_MUTEX; \
684     } STMT_END
685
686 /* now use the inline version in the proper function */
687
688 #ifndef PURIFY
689
690 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
691    compilers issue warnings.  */
692
693 STATIC void *
694 S_new_body(pTHX_ size_t size, svtype sv_type)
695 {
696     void *xpv;
697     new_body_inline(xpv, size, sv_type);
698     return xpv;
699 }
700
701 #endif
702
703 /* return a thing to the free list */
704
705 #define del_body(thing, root)                   \
706     STMT_START {                                \
707         void **thing_copy = (void **)thing;     \
708         LOCK_SV_MUTEX;                          \
709         *thing_copy = *root;                    \
710         *root = (void*)thing_copy;              \
711         UNLOCK_SV_MUTEX;                        \
712     } STMT_END
713
714 /* 
715    Revisiting type 3 arenas, there are 4 body-types which have some
716    members that are never accessed.  They are XPV, XPVIV, XPVAV,
717    XPVHV, which have corresponding types: xpv_allocated,
718    xpviv_allocated, xpvav_allocated, xpvhv_allocated,
719
720    For these types, the arenas are carved up into *_allocated size
721    chunks, we thus avoid wasted memory for those unaccessed members.
722    When bodies are allocated, we adjust the pointer back in memory by
723    the size of the bit not allocated, so it's as if we allocated the
724    full structure.  (But things will all go boom if you write to the
725    part that is "not there", because you'll be overwriting the last
726    members of the preceding structure in memory.)
727
728    We calculate the correction using the STRUCT_OFFSET macro. For example, if
729    xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
730    and the pointer is unchanged. If the allocated structure is smaller (no
731    initial NV actually allocated) then the net effect is to subtract the size
732    of the NV from the pointer, to return a new pointer as if an initial NV were
733    actually allocated.
734
735    This is the same trick as was used for NV and IV bodies. Ironically it
736    doesn't need to be used for NV bodies any more, because NV is now at the
737    start of the structure. IV bodies don't need it either, because they are
738    no longer allocated.  */
739
740 /* The following 2 arrays hide the above details in a pair of
741    lookup-tables, allowing us to be body-type agnostic.
742
743    size maps svtype to its body's allocated size.
744    offset maps svtype to the body-pointer adjustment needed
745
746    NB: elements in latter are 0 or <0, and are added during
747    allocation, and subtracted during deallocation.  It may be clearer
748    to invert the values, and call it shrinkage_by_svtype.
749 */
750
751 struct body_details {
752     size_t size;        /* Size to allocate  */
753     size_t copy;        /* Size of structure to copy (may be shorter)  */
754     size_t offset;
755     bool cant_upgrade;  /* Can upgrade this type */
756     bool zero_nv;       /* zero the NV when upgrading from this */
757     bool arena;         /* Allocated from an arena */
758 };
759
760 #define HADNV FALSE
761 #define NONV TRUE
762
763 #ifdef PURIFY
764 /* With -DPURFIY we allocate everything directly, and don't use arenas.
765    This seems a rather elegant way to simplify some of the code below.  */
766 #define HASARENA FALSE
767 #else
768 #define HASARENA TRUE
769 #endif
770 #define NOARENA FALSE
771
772 /* A macro to work out the offset needed to subtract from a pointer to (say)
773
774 typedef struct {
775     STRLEN      xpv_cur;
776     STRLEN      xpv_len;
777 } xpv_allocated;
778
779 to make its members accessible via a pointer to (say)
780
781 struct xpv {
782     NV          xnv_nv;
783     STRLEN      xpv_cur;
784     STRLEN      xpv_len;
785 };
786
787 */
788
789 #define relative_STRUCT_OFFSET(longer, shorter, member) \
790     (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
791
792 /* Calculate the length to copy. Specifically work out the length less any
793    final padding the compiler needed to add.  See the comment in sv_upgrade
794    for why copying the padding proved to be a bug.  */
795
796 #define copy_length(type, last_member) \
797         STRUCT_OFFSET(type, last_member) \
798         + sizeof (((type*)SvANY((SV*)0))->last_member)
799
800 static const struct body_details bodies_by_type[] = {
801     {0, 0, 0, FALSE, NONV, NOARENA},
802     /* IVs are in the head, so the allocation size is 0  */
803     {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
804     /* 8 bytes on most ILP32 with IEEE doubles */
805     {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
806     /* RVs are in the head now */
807     /* However, this slot is overloaded and used by the pte  */
808     {0, 0, 0, FALSE, NONV, NOARENA},
809     /* 8 bytes on most ILP32 with IEEE doubles */
810     {sizeof(xpv_allocated),
811      copy_length(XPV, xpv_len)
812      + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
813      - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
814      FALSE, NONV, HASARENA},
815     /* 12 */
816     {sizeof(xpviv_allocated),
817      copy_length(XPVIV, xiv_u)
818      + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
819      - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
820      FALSE, NONV, HASARENA},
821     /* 20 */
822     {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
823     /* 28 */
824     {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
825     /* 36 */
826     {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
827     /* 48 */
828     {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
829     /* 64 */
830     {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
831     /* 20 */
832     {sizeof(xpvav_allocated),
833      copy_length(XPVAV, xmg_stash)
834      + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
835      - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
836      TRUE, HADNV, HASARENA},
837     /* 20 */
838     {sizeof(xpvhv_allocated),
839      copy_length(XPVHV, xmg_stash)
840      + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
841      - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
842      TRUE, HADNV, HASARENA},
843     /* 76 */
844     {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
845     /* 80 */
846     {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
847     /* 84 */
848     {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
849 };
850
851 #define new_body_type(sv_type)                  \
852     (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
853              - bodies_by_type[sv_type].offset)
854
855 #define del_body_type(p, sv_type)       \
856     del_body(p, &PL_body_roots[sv_type])
857
858
859 #define new_body_allocated(sv_type)             \
860     (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
861              - bodies_by_type[sv_type].offset)
862
863 #define del_body_allocated(p, sv_type)          \
864     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
865
866
867 #define my_safemalloc(s)        (void*)safemalloc(s)
868 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
869 #define my_safefree(p)  safefree((char*)p)
870
871 #ifdef PURIFY
872
873 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
874 #define del_XNV(p)      my_safefree(p)
875
876 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
877 #define del_XPVNV(p)    my_safefree(p)
878
879 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
880 #define del_XPVAV(p)    my_safefree(p)
881
882 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
883 #define del_XPVHV(p)    my_safefree(p)
884
885 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
886 #define del_XPVMG(p)    my_safefree(p)
887
888 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
889 #define del_XPVGV(p)    my_safefree(p)
890
891 #else /* !PURIFY */
892
893 #define new_XNV()       new_body_type(SVt_NV)
894 #define del_XNV(p)      del_body_type(p, SVt_NV)
895
896 #define new_XPVNV()     new_body_type(SVt_PVNV)
897 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
898
899 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
900 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
901
902 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
903 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
904
905 #define new_XPVMG()     new_body_type(SVt_PVMG)
906 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
907
908 #define new_XPVGV()     new_body_type(SVt_PVGV)
909 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
910
911 #endif /* PURIFY */
912
913 /* no arena for you! */
914
915 #define new_NOARENA(details) \
916         my_safemalloc((details)->size + (details)->offset)
917 #define new_NOARENAZ(details) \
918         my_safecalloc((details)->size + (details)->offset)
919
920 /*
921 =for apidoc sv_upgrade
922
923 Upgrade an SV to a more complex form.  Generally adds a new body type to the
924 SV, then copies across as much information as possible from the old body.
925 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
926
927 =cut
928 */
929
930 void
931 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
932 {
933     void*       old_body;
934     void*       new_body;
935     const U32   old_type = SvTYPE(sv);
936     const struct body_details *const old_type_details
937         = bodies_by_type + old_type;
938     const struct body_details *new_type_details = bodies_by_type + new_type;
939
940     if (new_type != SVt_PV && SvIsCOW(sv)) {
941         sv_force_normal_flags(sv, 0);
942     }
943
944     if (old_type == new_type)
945         return;
946
947     if (old_type > new_type)
948         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
949                 (int)old_type, (int)new_type);
950
951
952     old_body = SvANY(sv);
953
954     /* Copying structures onto other structures that have been neatly zeroed
955        has a subtle gotcha. Consider XPVMG
956
957        +------+------+------+------+------+-------+-------+
958        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
959        +------+------+------+------+------+-------+-------+
960        0      4      8     12     16     20      24      28
961
962        where NVs are aligned to 8 bytes, so that sizeof that structure is
963        actually 32 bytes long, with 4 bytes of padding at the end:
964
965        +------+------+------+------+------+-------+-------+------+
966        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
967        +------+------+------+------+------+-------+-------+------+
968        0      4      8     12     16     20      24      28     32
969
970        so what happens if you allocate memory for this structure:
971
972        +------+------+------+------+------+-------+-------+------+------+...
973        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
974        +------+------+------+------+------+-------+-------+------+------+...
975        0      4      8     12     16     20      24      28     32     36
976
977        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
978        expect, because you copy the area marked ??? onto GP. Now, ??? may have
979        started out as zero once, but it's quite possible that it isn't. So now,
980        rather than a nicely zeroed GP, you have it pointing somewhere random.
981        Bugs ensue.
982
983        (In fact, GP ends up pointing at a previous GP structure, because the
984        principle cause of the padding in XPVMG getting garbage is a copy of
985        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
986
987        So we are careful and work out the size of used parts of all the
988        structures.  */
989
990     switch (old_type) {
991     case SVt_NULL:
992         break;
993     case SVt_IV:
994         if (new_type < SVt_PVIV) {
995             new_type = (new_type == SVt_NV)
996                 ? SVt_PVNV : SVt_PVIV;
997             new_type_details = bodies_by_type + new_type;
998         }
999         break;
1000     case SVt_NV:
1001         if (new_type < SVt_PVNV) {
1002             new_type = SVt_PVNV;
1003             new_type_details = bodies_by_type + new_type;
1004         }
1005         break;
1006     case SVt_RV:
1007         break;
1008     case SVt_PV:
1009         assert(new_type > SVt_PV);
1010         assert(SVt_IV < SVt_PV);
1011         assert(SVt_NV < SVt_PV);
1012         break;
1013     case SVt_PVIV:
1014         break;
1015     case SVt_PVNV:
1016         break;
1017     case SVt_PVMG:
1018         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1019            there's no way that it can be safely upgraded, because perl.c
1020            expects to Safefree(SvANY(PL_mess_sv))  */
1021         assert(sv != PL_mess_sv);
1022         /* This flag bit is used to mean other things in other scalar types.
1023            Given that it only has meaning inside the pad, it shouldn't be set
1024            on anything that can get upgraded.  */
1025         assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1026         break;
1027     default:
1028         if (old_type_details->cant_upgrade)
1029             Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1030     }
1031
1032     SvFLAGS(sv) &= ~SVTYPEMASK;
1033     SvFLAGS(sv) |= new_type;
1034
1035     switch (new_type) {
1036     case SVt_NULL:
1037         Perl_croak(aTHX_ "Can't upgrade to undef");
1038     case SVt_IV:
1039         assert(old_type == SVt_NULL);
1040         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1041         SvIV_set(sv, 0);
1042         return;
1043     case SVt_NV:
1044         assert(old_type == SVt_NULL);
1045         SvANY(sv) = new_XNV();
1046         SvNV_set(sv, 0);
1047         return;
1048     case SVt_RV:
1049         assert(old_type == SVt_NULL);
1050         SvANY(sv) = &sv->sv_u.svu_rv;
1051         SvRV_set(sv, 0);
1052         return;
1053     case SVt_PVHV:
1054         SvANY(sv) = new_XPVHV();
1055         HvFILL(sv)      = 0;
1056         HvMAX(sv)       = 0;
1057         HvTOTALKEYS(sv) = 0;
1058
1059         goto hv_av_common;
1060
1061     case SVt_PVAV:
1062         SvANY(sv) = new_XPVAV();
1063         AvMAX(sv)       = -1;
1064         AvFILLp(sv)     = -1;
1065         AvALLOC(sv)     = 0;
1066         AvREAL_only(sv);
1067
1068     hv_av_common:
1069         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1070            The target created by newSVrv also is, and it can have magic.
1071            However, it never has SvPVX set.
1072         */
1073         if (old_type >= SVt_RV) {
1074             assert(SvPVX_const(sv) == 0);
1075         }
1076
1077         /* Could put this in the else clause below, as PVMG must have SvPVX
1078            0 already (the assertion above)  */
1079         SvPV_set(sv, (char*)0);
1080
1081         if (old_type >= SVt_PVMG) {
1082             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1083             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1084         } else {
1085             SvMAGIC_set(sv, 0);
1086             SvSTASH_set(sv, 0);
1087         }
1088         break;
1089
1090
1091     case SVt_PVIV:
1092         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1093            no route from NV to PVIV, NOK can never be true  */
1094         assert(!SvNOKp(sv));
1095         assert(!SvNOK(sv));
1096     case SVt_PVIO:
1097     case SVt_PVFM:
1098     case SVt_PVBM:
1099     case SVt_PVGV:
1100     case SVt_PVCV:
1101     case SVt_PVLV:
1102     case SVt_PVMG:
1103     case SVt_PVNV:
1104     case SVt_PV:
1105
1106         assert(new_type_details->size);
1107         /* We always allocated the full length item with PURIFY. To do this
1108            we fake things so that arena is false for all 16 types..  */
1109         if(new_type_details->arena) {
1110             /* This points to the start of the allocated area.  */
1111             new_body_inline(new_body, new_type_details->size, new_type);
1112             Zero(new_body, new_type_details->size, char);
1113             new_body = ((char *)new_body) - new_type_details->offset;
1114         } else {
1115             new_body = new_NOARENAZ(new_type_details);
1116         }
1117         SvANY(sv) = new_body;
1118
1119         if (old_type_details->copy) {
1120             Copy((char *)old_body + old_type_details->offset,
1121                  (char *)new_body + old_type_details->offset,
1122                  old_type_details->copy, char);
1123         }
1124
1125 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1126     /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1127        0.0 for us.  */
1128         if (old_type_details->zero_nv)
1129             SvNV_set(sv, 0);
1130 #endif
1131
1132         if (new_type == SVt_PVIO)
1133             IoPAGE_LEN(sv)      = 60;
1134         if (old_type < SVt_RV)
1135             SvPV_set(sv, 0);
1136         break;
1137     default:
1138         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
1139     }
1140
1141     if (old_type_details->size) {
1142         /* If the old body had an allocated size, then we need to free it.  */
1143 #ifdef PURIFY
1144         my_safefree(old_body);
1145 #else
1146         del_body((void*)((char*)old_body + old_type_details->offset),
1147                  &PL_body_roots[old_type]);
1148 #endif
1149     }
1150 }
1151
1152 /*
1153 =for apidoc sv_backoff
1154
1155 Remove any string offset. You should normally use the C<SvOOK_off> macro
1156 wrapper instead.
1157
1158 =cut
1159 */
1160
1161 int
1162 Perl_sv_backoff(pTHX_ register SV *sv)
1163 {
1164     assert(SvOOK(sv));
1165     assert(SvTYPE(sv) != SVt_PVHV);
1166     assert(SvTYPE(sv) != SVt_PVAV);
1167     if (SvIVX(sv)) {
1168         const char * const s = SvPVX_const(sv);
1169         SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1170         SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1171         SvIV_set(sv, 0);
1172         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1173     }
1174     SvFLAGS(sv) &= ~SVf_OOK;
1175     return 0;
1176 }
1177
1178 /*
1179 =for apidoc sv_grow
1180
1181 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1182 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1183 Use the C<SvGROW> wrapper instead.
1184
1185 =cut
1186 */
1187
1188 char *
1189 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1190 {
1191     register char *s;
1192
1193 #ifdef HAS_64K_LIMIT
1194     if (newlen >= 0x10000) {
1195         PerlIO_printf(Perl_debug_log,
1196                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1197         my_exit(1);
1198     }
1199 #endif /* HAS_64K_LIMIT */
1200     if (SvROK(sv))
1201         sv_unref(sv);
1202     if (SvTYPE(sv) < SVt_PV) {
1203         sv_upgrade(sv, SVt_PV);
1204         s = SvPVX_mutable(sv);
1205     }
1206     else if (SvOOK(sv)) {       /* pv is offset? */
1207         sv_backoff(sv);
1208         s = SvPVX_mutable(sv);
1209         if (newlen > SvLEN(sv))
1210             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1211 #ifdef HAS_64K_LIMIT
1212         if (newlen >= 0x10000)
1213             newlen = 0xFFFF;
1214 #endif
1215     }
1216     else
1217         s = SvPVX_mutable(sv);
1218
1219     if (newlen > SvLEN(sv)) {           /* need more room? */
1220         newlen = PERL_STRLEN_ROUNDUP(newlen);
1221         if (SvLEN(sv) && s) {
1222 #ifdef MYMALLOC
1223             const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1224             if (newlen <= l) {
1225                 SvLEN_set(sv, l);
1226                 return s;
1227             } else
1228 #endif
1229             s = saferealloc(s, newlen);
1230         }
1231         else {
1232             s = safemalloc(newlen);
1233             if (SvPVX_const(sv) && SvCUR(sv)) {
1234                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1235             }
1236         }
1237         SvPV_set(sv, s);
1238         SvLEN_set(sv, newlen);
1239     }
1240     return s;
1241 }
1242
1243 /*
1244 =for apidoc sv_setiv
1245
1246 Copies an integer into the given SV, upgrading first if necessary.
1247 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1248
1249 =cut
1250 */
1251
1252 void
1253 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1254 {
1255     SV_CHECK_THINKFIRST_COW_DROP(sv);
1256     switch (SvTYPE(sv)) {
1257     case SVt_NULL:
1258         sv_upgrade(sv, SVt_IV);
1259         break;
1260     case SVt_NV:
1261         sv_upgrade(sv, SVt_PVNV);
1262         break;
1263     case SVt_RV:
1264     case SVt_PV:
1265         sv_upgrade(sv, SVt_PVIV);
1266         break;
1267
1268     case SVt_PVGV:
1269     case SVt_PVAV:
1270     case SVt_PVHV:
1271     case SVt_PVCV:
1272     case SVt_PVFM:
1273     case SVt_PVIO:
1274         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1275                    OP_DESC(PL_op));
1276     }
1277     (void)SvIOK_only(sv);                       /* validate number */
1278     SvIV_set(sv, i);
1279     SvTAINT(sv);
1280 }
1281
1282 /*
1283 =for apidoc sv_setiv_mg
1284
1285 Like C<sv_setiv>, but also handles 'set' magic.
1286
1287 =cut
1288 */
1289
1290 void
1291 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1292 {
1293     sv_setiv(sv,i);
1294     SvSETMAGIC(sv);
1295 }
1296
1297 /*
1298 =for apidoc sv_setuv
1299
1300 Copies an unsigned integer into the given SV, upgrading first if necessary.
1301 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1302
1303 =cut
1304 */
1305
1306 void
1307 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1308 {
1309     /* With these two if statements:
1310        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1311
1312        without
1313        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1314
1315        If you wish to remove them, please benchmark to see what the effect is
1316     */
1317     if (u <= (UV)IV_MAX) {
1318        sv_setiv(sv, (IV)u);
1319        return;
1320     }
1321     sv_setiv(sv, 0);
1322     SvIsUV_on(sv);
1323     SvUV_set(sv, u);
1324 }
1325
1326 /*
1327 =for apidoc sv_setuv_mg
1328
1329 Like C<sv_setuv>, but also handles 'set' magic.
1330
1331 =cut
1332 */
1333
1334 void
1335 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1336 {
1337     sv_setiv(sv, 0);
1338     SvIsUV_on(sv);
1339     sv_setuv(sv,u);
1340     SvSETMAGIC(sv);
1341 }
1342
1343 /*
1344 =for apidoc sv_setnv
1345
1346 Copies a double into the given SV, upgrading first if necessary.
1347 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1348
1349 =cut
1350 */
1351
1352 void
1353 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1354 {
1355     SV_CHECK_THINKFIRST_COW_DROP(sv);
1356     switch (SvTYPE(sv)) {
1357     case SVt_NULL:
1358     case SVt_IV:
1359         sv_upgrade(sv, SVt_NV);
1360         break;
1361     case SVt_RV:
1362     case SVt_PV:
1363     case SVt_PVIV:
1364         sv_upgrade(sv, SVt_PVNV);
1365         break;
1366
1367     case SVt_PVGV:
1368     case SVt_PVAV:
1369     case SVt_PVHV:
1370     case SVt_PVCV:
1371     case SVt_PVFM:
1372     case SVt_PVIO:
1373         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1374                    OP_NAME(PL_op));
1375     }
1376     SvNV_set(sv, num);
1377     (void)SvNOK_only(sv);                       /* validate number */
1378     SvTAINT(sv);
1379 }
1380
1381 /*
1382 =for apidoc sv_setnv_mg
1383
1384 Like C<sv_setnv>, but also handles 'set' magic.
1385
1386 =cut
1387 */
1388
1389 void
1390 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1391 {
1392     sv_setnv(sv,num);
1393     SvSETMAGIC(sv);
1394 }
1395
1396 /* Print an "isn't numeric" warning, using a cleaned-up,
1397  * printable version of the offending string
1398  */
1399
1400 STATIC void
1401 S_not_a_number(pTHX_ SV *sv)
1402 {
1403      SV *dsv;
1404      char tmpbuf[64];
1405      const char *pv;
1406
1407      if (DO_UTF8(sv)) {
1408           dsv = sv_2mortal(newSVpvn("", 0));
1409           pv = sv_uni_display(dsv, sv, 10, 0);
1410      } else {
1411           char *d = tmpbuf;
1412           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1413           /* each *s can expand to 4 chars + "...\0",
1414              i.e. need room for 8 chars */
1415         
1416           const char *s, *end;
1417           for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1418                s++) {
1419                int ch = *s & 0xFF;
1420                if (ch & 128 && !isPRINT_LC(ch)) {
1421                     *d++ = 'M';
1422                     *d++ = '-';
1423                     ch &= 127;
1424                }
1425                if (ch == '\n') {
1426                     *d++ = '\\';
1427                     *d++ = 'n';
1428                }
1429                else if (ch == '\r') {
1430                     *d++ = '\\';
1431                     *d++ = 'r';
1432                }
1433                else if (ch == '\f') {
1434                     *d++ = '\\';
1435                     *d++ = 'f';
1436                }
1437                else if (ch == '\\') {
1438                     *d++ = '\\';
1439                     *d++ = '\\';
1440                }
1441                else if (ch == '\0') {
1442                     *d++ = '\\';
1443                     *d++ = '0';
1444                }
1445                else if (isPRINT_LC(ch))
1446                     *d++ = ch;
1447                else {
1448                     *d++ = '^';
1449                     *d++ = toCTRL(ch);
1450                }
1451           }
1452           if (s < end) {
1453                *d++ = '.';
1454                *d++ = '.';
1455                *d++ = '.';
1456           }
1457           *d = '\0';
1458           pv = tmpbuf;
1459     }
1460
1461     if (PL_op)
1462         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1463                     "Argument \"%s\" isn't numeric in %s", pv,
1464                     OP_DESC(PL_op));
1465     else
1466         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1467                     "Argument \"%s\" isn't numeric", pv);
1468 }
1469
1470 /*
1471 =for apidoc looks_like_number
1472
1473 Test if the content of an SV looks like a number (or is a number).
1474 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1475 non-numeric warning), even if your atof() doesn't grok them.
1476
1477 =cut
1478 */
1479
1480 I32
1481 Perl_looks_like_number(pTHX_ SV *sv)
1482 {
1483     register const char *sbegin;
1484     STRLEN len;
1485
1486     if (SvPOK(sv)) {
1487         sbegin = SvPVX_const(sv);
1488         len = SvCUR(sv);
1489     }
1490     else if (SvPOKp(sv))
1491         sbegin = SvPV_const(sv, len);
1492     else
1493         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1494     return grok_number(sbegin, len, NULL);
1495 }
1496
1497 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1498    until proven guilty, assume that things are not that bad... */
1499
1500 /*
1501    NV_PRESERVES_UV:
1502
1503    As 64 bit platforms often have an NV that doesn't preserve all bits of
1504    an IV (an assumption perl has been based on to date) it becomes necessary
1505    to remove the assumption that the NV always carries enough precision to
1506    recreate the IV whenever needed, and that the NV is the canonical form.
1507    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1508    precision as a side effect of conversion (which would lead to insanity
1509    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1510    1) to distinguish between IV/UV/NV slots that have cached a valid
1511       conversion where precision was lost and IV/UV/NV slots that have a
1512       valid conversion which has lost no precision
1513    2) to ensure that if a numeric conversion to one form is requested that
1514       would lose precision, the precise conversion (or differently
1515       imprecise conversion) is also performed and cached, to prevent
1516       requests for different numeric formats on the same SV causing
1517       lossy conversion chains. (lossless conversion chains are perfectly
1518       acceptable (still))
1519
1520
1521    flags are used:
1522    SvIOKp is true if the IV slot contains a valid value
1523    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1524    SvNOKp is true if the NV slot contains a valid value
1525    SvNOK  is true only if the NV value is accurate
1526
1527    so
1528    while converting from PV to NV, check to see if converting that NV to an
1529    IV(or UV) would lose accuracy over a direct conversion from PV to
1530    IV(or UV). If it would, cache both conversions, return NV, but mark
1531    SV as IOK NOKp (ie not NOK).
1532
1533    While converting from PV to IV, check to see if converting that IV to an
1534    NV would lose accuracy over a direct conversion from PV to NV. If it
1535    would, cache both conversions, flag similarly.
1536
1537    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1538    correctly because if IV & NV were set NV *always* overruled.
1539    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1540    changes - now IV and NV together means that the two are interchangeable:
1541    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1542
1543    The benefit of this is that operations such as pp_add know that if
1544    SvIOK is true for both left and right operands, then integer addition
1545    can be used instead of floating point (for cases where the result won't
1546    overflow). Before, floating point was always used, which could lead to
1547    loss of precision compared with integer addition.
1548
1549    * making IV and NV equal status should make maths accurate on 64 bit
1550      platforms
1551    * may speed up maths somewhat if pp_add and friends start to use
1552      integers when possible instead of fp. (Hopefully the overhead in
1553      looking for SvIOK and checking for overflow will not outweigh the
1554      fp to integer speedup)
1555    * will slow down integer operations (callers of SvIV) on "inaccurate"
1556      values, as the change from SvIOK to SvIOKp will cause a call into
1557      sv_2iv each time rather than a macro access direct to the IV slot
1558    * should speed up number->string conversion on integers as IV is
1559      favoured when IV and NV are equally accurate
1560
1561    ####################################################################
1562    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1563    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1564    On the other hand, SvUOK is true iff UV.
1565    ####################################################################
1566
1567    Your mileage will vary depending your CPU's relative fp to integer
1568    performance ratio.
1569 */
1570
1571 #ifndef NV_PRESERVES_UV
1572 #  define IS_NUMBER_UNDERFLOW_IV 1
1573 #  define IS_NUMBER_UNDERFLOW_UV 2
1574 #  define IS_NUMBER_IV_AND_UV    2
1575 #  define IS_NUMBER_OVERFLOW_IV  4
1576 #  define IS_NUMBER_OVERFLOW_UV  5
1577
1578 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1579
1580 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1581 STATIC int
1582 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1583 {
1584     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));
1585     if (SvNVX(sv) < (NV)IV_MIN) {
1586         (void)SvIOKp_on(sv);
1587         (void)SvNOK_on(sv);
1588         SvIV_set(sv, IV_MIN);
1589         return IS_NUMBER_UNDERFLOW_IV;
1590     }
1591     if (SvNVX(sv) > (NV)UV_MAX) {
1592         (void)SvIOKp_on(sv);
1593         (void)SvNOK_on(sv);
1594         SvIsUV_on(sv);
1595         SvUV_set(sv, UV_MAX);
1596         return IS_NUMBER_OVERFLOW_UV;
1597     }
1598     (void)SvIOKp_on(sv);
1599     (void)SvNOK_on(sv);
1600     /* Can't use strtol etc to convert this string.  (See truth table in
1601        sv_2iv  */
1602     if (SvNVX(sv) <= (UV)IV_MAX) {
1603         SvIV_set(sv, I_V(SvNVX(sv)));
1604         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1605             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1606         } else {
1607             /* Integer is imprecise. NOK, IOKp */
1608         }
1609         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1610     }
1611     SvIsUV_on(sv);
1612     SvUV_set(sv, U_V(SvNVX(sv)));
1613     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1614         if (SvUVX(sv) == UV_MAX) {
1615             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1616                possibly be preserved by NV. Hence, it must be overflow.
1617                NOK, IOKp */
1618             return IS_NUMBER_OVERFLOW_UV;
1619         }
1620         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1621     } else {
1622         /* Integer is imprecise. NOK, IOKp */
1623     }
1624     return IS_NUMBER_OVERFLOW_IV;
1625 }
1626 #endif /* !NV_PRESERVES_UV*/
1627
1628 /*
1629 =for apidoc sv_2iv_flags
1630
1631 Return the integer value of an SV, doing any necessary string
1632 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
1633 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1634
1635 =cut
1636 */
1637
1638 IV
1639 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
1640 {
1641     if (!sv)
1642         return 0;
1643     if (SvGMAGICAL(sv)) {
1644         if (flags & SV_GMAGIC)
1645             mg_get(sv);
1646         if (SvIOKp(sv))
1647             return SvIVX(sv);
1648         if (SvNOKp(sv)) {
1649             return I_V(SvNVX(sv));
1650         }
1651         if (SvPOKp(sv) && SvLEN(sv))
1652             return asIV(sv);
1653         if (!SvROK(sv)) {
1654             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1655                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1656                     report_uninit(sv);
1657             }
1658             return 0;
1659         }
1660     }
1661     if (SvTHINKFIRST(sv)) {
1662         if (SvROK(sv)) {
1663             if (SvAMAGIC(sv)) {
1664                 SV * const tmpstr=AMG_CALLun(sv,numer);
1665                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
1666                     return SvIV(tmpstr);
1667                 }
1668             }
1669             return PTR2IV(SvRV(sv));
1670         }
1671         if (SvIsCOW(sv)) {
1672             sv_force_normal_flags(sv, 0);
1673         }
1674         if (SvREADONLY(sv) && !SvOK(sv)) {
1675             if (ckWARN(WARN_UNINITIALIZED))
1676                 report_uninit(sv);
1677             return 0;
1678         }
1679     }
1680     if (SvIOKp(sv)) {
1681         if (SvIsUV(sv)) {
1682             return (IV)(SvUVX(sv));
1683         }
1684         else {
1685             return SvIVX(sv);
1686         }
1687     }
1688     if (SvNOKp(sv)) {
1689         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1690          * without also getting a cached IV/UV from it at the same time
1691          * (ie PV->NV conversion should detect loss of accuracy and cache
1692          * IV or UV at same time to avoid this.  NWC */
1693
1694         if (SvTYPE(sv) == SVt_NV)
1695             sv_upgrade(sv, SVt_PVNV);
1696
1697         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1698         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1699            certainly cast into the IV range at IV_MAX, whereas the correct
1700            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1701            cases go to UV */
1702         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1703             SvIV_set(sv, I_V(SvNVX(sv)));
1704             if (SvNVX(sv) == (NV) SvIVX(sv)
1705 #ifndef NV_PRESERVES_UV
1706                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1707                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1708                 /* Don't flag it as "accurately an integer" if the number
1709                    came from a (by definition imprecise) NV operation, and
1710                    we're outside the range of NV integer precision */
1711 #endif
1712                 ) {
1713                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1714                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1715                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1716                                       PTR2UV(sv),
1717                                       SvNVX(sv),
1718                                       SvIVX(sv)));
1719
1720             } else {
1721                 /* IV not precise.  No need to convert from PV, as NV
1722                    conversion would already have cached IV if it detected
1723                    that PV->IV would be better than PV->NV->IV
1724                    flags already correct - don't set public IOK.  */
1725                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1726                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1727                                       PTR2UV(sv),
1728                                       SvNVX(sv),
1729                                       SvIVX(sv)));
1730             }
1731             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1732                but the cast (NV)IV_MIN rounds to a the value less (more
1733                negative) than IV_MIN which happens to be equal to SvNVX ??
1734                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1735                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1736                (NV)UVX == NVX are both true, but the values differ. :-(
1737                Hopefully for 2s complement IV_MIN is something like
1738                0x8000000000000000 which will be exact. NWC */
1739         }
1740         else {
1741             SvUV_set(sv, U_V(SvNVX(sv)));
1742             if (
1743                 (SvNVX(sv) == (NV) SvUVX(sv))
1744 #ifndef  NV_PRESERVES_UV
1745                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1746                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1747                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1748                 /* Don't flag it as "accurately an integer" if the number
1749                    came from a (by definition imprecise) NV operation, and
1750                    we're outside the range of NV integer precision */
1751 #endif
1752                 )
1753                 SvIOK_on(sv);
1754             SvIsUV_on(sv);
1755           ret_iv_max:
1756             DEBUG_c(PerlIO_printf(Perl_debug_log,
1757                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1758                                   PTR2UV(sv),
1759                                   SvUVX(sv),
1760                                   SvUVX(sv)));
1761             return (IV)SvUVX(sv);
1762         }
1763     }
1764     else if (SvPOKp(sv) && SvLEN(sv)) {
1765         UV value;
1766         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1767         /* We want to avoid a possible problem when we cache an IV which
1768            may be later translated to an NV, and the resulting NV is not
1769            the same as the direct translation of the initial string
1770            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1771            be careful to ensure that the value with the .456 is around if the
1772            NV value is requested in the future).
1773         
1774            This means that if we cache such an IV, we need to cache the
1775            NV as well.  Moreover, we trade speed for space, and do not
1776            cache the NV if we are sure it's not needed.
1777          */
1778
1779         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
1780         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1781              == IS_NUMBER_IN_UV) {
1782             /* It's definitely an integer, only upgrade to PVIV */
1783             if (SvTYPE(sv) < SVt_PVIV)
1784                 sv_upgrade(sv, SVt_PVIV);
1785             (void)SvIOK_on(sv);
1786         } else if (SvTYPE(sv) < SVt_PVNV)
1787             sv_upgrade(sv, SVt_PVNV);
1788
1789         /* If NV preserves UV then we only use the UV value if we know that
1790            we aren't going to call atof() below. If NVs don't preserve UVs
1791            then the value returned may have more precision than atof() will
1792            return, even though value isn't perfectly accurate.  */
1793         if ((numtype & (IS_NUMBER_IN_UV
1794 #ifdef NV_PRESERVES_UV
1795                         | IS_NUMBER_NOT_INT
1796 #endif
1797             )) == IS_NUMBER_IN_UV) {
1798             /* This won't turn off the public IOK flag if it was set above  */
1799             (void)SvIOKp_on(sv);
1800
1801             if (!(numtype & IS_NUMBER_NEG)) {
1802                 /* positive */;
1803                 if (value <= (UV)IV_MAX) {
1804                     SvIV_set(sv, (IV)value);
1805                 } else {
1806                     SvUV_set(sv, value);
1807                     SvIsUV_on(sv);
1808                 }
1809             } else {
1810                 /* 2s complement assumption  */
1811                 if (value <= (UV)IV_MIN) {
1812                     SvIV_set(sv, -(IV)value);
1813                 } else {
1814                     /* Too negative for an IV.  This is a double upgrade, but
1815                        I'm assuming it will be rare.  */
1816                     if (SvTYPE(sv) < SVt_PVNV)
1817                         sv_upgrade(sv, SVt_PVNV);
1818                     SvNOK_on(sv);
1819                     SvIOK_off(sv);
1820                     SvIOKp_on(sv);
1821                     SvNV_set(sv, -(NV)value);
1822                     SvIV_set(sv, IV_MIN);
1823                 }
1824             }
1825         }
1826         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1827            will be in the previous block to set the IV slot, and the next
1828            block to set the NV slot.  So no else here.  */
1829         
1830         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1831             != IS_NUMBER_IN_UV) {
1832             /* It wasn't an (integer that doesn't overflow the UV). */
1833             SvNV_set(sv, Atof(SvPVX_const(sv)));
1834
1835             if (! numtype && ckWARN(WARN_NUMERIC))
1836                 not_a_number(sv);
1837
1838 #if defined(USE_LONG_DOUBLE)
1839             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1840                                   PTR2UV(sv), SvNVX(sv)));
1841 #else
1842             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
1843                                   PTR2UV(sv), SvNVX(sv)));
1844 #endif
1845
1846
1847 #ifdef NV_PRESERVES_UV
1848             (void)SvIOKp_on(sv);
1849             (void)SvNOK_on(sv);
1850             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1851                 SvIV_set(sv, I_V(SvNVX(sv)));
1852                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1853                     SvIOK_on(sv);
1854                 } else {
1855                     /* Integer is imprecise. NOK, IOKp */
1856                 }
1857                 /* UV will not work better than IV */
1858             } else {
1859                 if (SvNVX(sv) > (NV)UV_MAX) {
1860                     SvIsUV_on(sv);
1861                     /* Integer is inaccurate. NOK, IOKp, is UV */
1862                     SvUV_set(sv, UV_MAX);
1863                     SvIsUV_on(sv);
1864                 } else {
1865                     SvUV_set(sv, U_V(SvNVX(sv)));
1866                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1867                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1868                         SvIOK_on(sv);
1869                         SvIsUV_on(sv);
1870                     } else {
1871                         /* Integer is imprecise. NOK, IOKp, is UV */
1872                         SvIsUV_on(sv);
1873                     }
1874                 }
1875                 goto ret_iv_max;
1876             }
1877 #else /* NV_PRESERVES_UV */
1878             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1879                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1880                 /* The IV slot will have been set from value returned by
1881                    grok_number above.  The NV slot has just been set using
1882                    Atof.  */
1883                 SvNOK_on(sv);
1884                 assert (SvIOKp(sv));
1885             } else {
1886                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1887                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1888                     /* Small enough to preserve all bits. */
1889                     (void)SvIOKp_on(sv);
1890                     SvNOK_on(sv);
1891                     SvIV_set(sv, I_V(SvNVX(sv)));
1892                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
1893                         SvIOK_on(sv);
1894                     /* Assumption: first non-preserved integer is < IV_MAX,
1895                        this NV is in the preserved range, therefore: */
1896                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1897                           < (UV)IV_MAX)) {
1898                         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);
1899                     }
1900                 } else {
1901                     /* IN_UV NOT_INT
1902                          0      0       already failed to read UV.
1903                          0      1       already failed to read UV.
1904                          1      0       you won't get here in this case. IV/UV
1905                                         slot set, public IOK, Atof() unneeded.
1906                          1      1       already read UV.
1907                        so there's no point in sv_2iuv_non_preserve() attempting
1908                        to use atol, strtol, strtoul etc.  */
1909                     if (sv_2iuv_non_preserve (sv, numtype)
1910                         >= IS_NUMBER_OVERFLOW_IV)
1911                     goto ret_iv_max;
1912                 }
1913             }
1914 #endif /* NV_PRESERVES_UV */
1915         }
1916     } else  {
1917         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
1918             report_uninit(sv);
1919         if (SvTYPE(sv) < SVt_IV)
1920             /* Typically the caller expects that sv_any is not NULL now.  */
1921             sv_upgrade(sv, SVt_IV);
1922         return 0;
1923     }
1924     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1925         PTR2UV(sv),SvIVX(sv)));
1926     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1927 }
1928
1929 /*
1930 =for apidoc sv_2uv_flags
1931
1932 Return the unsigned integer value of an SV, doing any necessary string
1933 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
1934 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
1935
1936 =cut
1937 */
1938
1939 UV
1940 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
1941 {
1942     if (!sv)
1943         return 0;
1944     if (SvGMAGICAL(sv)) {
1945         if (flags & SV_GMAGIC)
1946             mg_get(sv);
1947         if (SvIOKp(sv))
1948             return SvUVX(sv);
1949         if (SvNOKp(sv))
1950             return U_V(SvNVX(sv));
1951         if (SvPOKp(sv) && SvLEN(sv))
1952             return asUV(sv);
1953         if (!SvROK(sv)) {
1954             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1955                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1956                     report_uninit(sv);
1957             }
1958             return 0;
1959         }
1960     }
1961     if (SvTHINKFIRST(sv)) {
1962         if (SvROK(sv)) {
1963           SV* tmpstr;
1964           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1965                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
1966               return SvUV(tmpstr);
1967           return PTR2UV(SvRV(sv));
1968         }
1969         if (SvIsCOW(sv)) {
1970             sv_force_normal_flags(sv, 0);
1971         }
1972         if (SvREADONLY(sv) && !SvOK(sv)) {
1973             if (ckWARN(WARN_UNINITIALIZED))
1974                 report_uninit(sv);
1975             return 0;
1976         }
1977     }
1978     if (SvIOKp(sv)) {
1979         if (SvIsUV(sv)) {
1980             return SvUVX(sv);
1981         }
1982         else {
1983             return (UV)SvIVX(sv);
1984         }
1985     }
1986     if (SvNOKp(sv)) {
1987         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1988          * without also getting a cached IV/UV from it at the same time
1989          * (ie PV->NV conversion should detect loss of accuracy and cache
1990          * IV or UV at same time to avoid this. */
1991         /* IV-over-UV optimisation - choose to cache IV if possible */
1992
1993         if (SvTYPE(sv) == SVt_NV)
1994             sv_upgrade(sv, SVt_PVNV);
1995
1996         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1997         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1998             SvIV_set(sv, I_V(SvNVX(sv)));
1999             if (SvNVX(sv) == (NV) SvIVX(sv)
2000 #ifndef NV_PRESERVES_UV
2001                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2002                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2003                 /* Don't flag it as "accurately an integer" if the number
2004                    came from a (by definition imprecise) NV operation, and
2005                    we're outside the range of NV integer precision */
2006 #endif
2007                 ) {
2008                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2009                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2010                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2011                                       PTR2UV(sv),
2012                                       SvNVX(sv),
2013                                       SvIVX(sv)));
2014
2015             } else {
2016                 /* IV not precise.  No need to convert from PV, as NV
2017                    conversion would already have cached IV if it detected
2018                    that PV->IV would be better than PV->NV->IV
2019                    flags already correct - don't set public IOK.  */
2020                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2021                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2022                                       PTR2UV(sv),
2023                                       SvNVX(sv),
2024                                       SvIVX(sv)));
2025             }
2026             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2027                but the cast (NV)IV_MIN rounds to a the value less (more
2028                negative) than IV_MIN which happens to be equal to SvNVX ??
2029                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2030                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2031                (NV)UVX == NVX are both true, but the values differ. :-(
2032                Hopefully for 2s complement IV_MIN is something like
2033                0x8000000000000000 which will be exact. NWC */
2034         }
2035         else {
2036             SvUV_set(sv, U_V(SvNVX(sv)));
2037             if (
2038                 (SvNVX(sv) == (NV) SvUVX(sv))
2039 #ifndef  NV_PRESERVES_UV
2040                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2041                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2042                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2043                 /* Don't flag it as "accurately an integer" if the number
2044                    came from a (by definition imprecise) NV operation, and
2045                    we're outside the range of NV integer precision */
2046 #endif
2047                 )
2048                 SvIOK_on(sv);
2049             SvIsUV_on(sv);
2050             DEBUG_c(PerlIO_printf(Perl_debug_log,
2051                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2052                                   PTR2UV(sv),
2053                                   SvUVX(sv),
2054                                   SvUVX(sv)));
2055         }
2056     }
2057     else if (SvPOKp(sv) && SvLEN(sv)) {
2058         UV value;
2059         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2060
2061         /* We want to avoid a possible problem when we cache a UV which
2062            may be later translated to an NV, and the resulting NV is not
2063            the translation of the initial data.
2064         
2065            This means that if we cache such a UV, we need to cache the
2066            NV as well.  Moreover, we trade speed for space, and do not
2067            cache the NV if not needed.
2068          */
2069
2070         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2071         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2072              == IS_NUMBER_IN_UV) {
2073             /* It's definitely an integer, only upgrade to PVIV */
2074             if (SvTYPE(sv) < SVt_PVIV)
2075                 sv_upgrade(sv, SVt_PVIV);
2076             (void)SvIOK_on(sv);
2077         } else if (SvTYPE(sv) < SVt_PVNV)
2078             sv_upgrade(sv, SVt_PVNV);
2079
2080         /* If NV preserves UV then we only use the UV value if we know that
2081            we aren't going to call atof() below. If NVs don't preserve UVs
2082            then the value returned may have more precision than atof() will
2083            return, even though it isn't accurate.  */
2084         if ((numtype & (IS_NUMBER_IN_UV
2085 #ifdef NV_PRESERVES_UV
2086                         | IS_NUMBER_NOT_INT
2087 #endif
2088             )) == IS_NUMBER_IN_UV) {
2089             /* This won't turn off the public IOK flag if it was set above  */
2090             (void)SvIOKp_on(sv);
2091
2092             if (!(numtype & IS_NUMBER_NEG)) {
2093                 /* positive */;
2094                 if (value <= (UV)IV_MAX) {
2095                     SvIV_set(sv, (IV)value);
2096                 } else {
2097                     /* it didn't overflow, and it was positive. */
2098                     SvUV_set(sv, value);
2099                     SvIsUV_on(sv);
2100                 }
2101             } else {
2102                 /* 2s complement assumption  */
2103                 if (value <= (UV)IV_MIN) {
2104                     SvIV_set(sv, -(IV)value);
2105                 } else {
2106                     /* Too negative for an IV.  This is a double upgrade, but
2107                        I'm assuming it will be rare.  */
2108                     if (SvTYPE(sv) < SVt_PVNV)
2109                         sv_upgrade(sv, SVt_PVNV);
2110                     SvNOK_on(sv);
2111                     SvIOK_off(sv);
2112                     SvIOKp_on(sv);
2113                     SvNV_set(sv, -(NV)value);
2114                     SvIV_set(sv, IV_MIN);
2115                 }
2116             }
2117         }
2118         
2119         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2120             != IS_NUMBER_IN_UV) {
2121             /* It wasn't an integer, or it overflowed the UV. */
2122             SvNV_set(sv, Atof(SvPVX_const(sv)));
2123
2124             if (! numtype && ckWARN(WARN_NUMERIC))
2125                     not_a_number(sv);
2126
2127 #if defined(USE_LONG_DOUBLE)
2128             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2129                                   PTR2UV(sv), SvNVX(sv)));
2130 #else
2131             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2132                                   PTR2UV(sv), SvNVX(sv)));
2133 #endif
2134
2135 #ifdef NV_PRESERVES_UV
2136             (void)SvIOKp_on(sv);
2137             (void)SvNOK_on(sv);
2138             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2139                 SvIV_set(sv, I_V(SvNVX(sv)));
2140                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2141                     SvIOK_on(sv);
2142                 } else {
2143                     /* Integer is imprecise. NOK, IOKp */
2144                 }
2145                 /* UV will not work better than IV */
2146             } else {
2147                 if (SvNVX(sv) > (NV)UV_MAX) {
2148                     SvIsUV_on(sv);
2149                     /* Integer is inaccurate. NOK, IOKp, is UV */
2150                     SvUV_set(sv, UV_MAX);
2151                     SvIsUV_on(sv);
2152                 } else {
2153                     SvUV_set(sv, U_V(SvNVX(sv)));
2154                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2155                        NV preservse UV so can do correct comparison.  */
2156                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2157                         SvIOK_on(sv);
2158                         SvIsUV_on(sv);
2159                     } else {
2160                         /* Integer is imprecise. NOK, IOKp, is UV */
2161                         SvIsUV_on(sv);
2162                     }
2163                 }
2164             }
2165 #else /* NV_PRESERVES_UV */
2166             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2167                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2168                 /* The UV slot will have been set from value returned by
2169                    grok_number above.  The NV slot has just been set using
2170                    Atof.  */
2171                 SvNOK_on(sv);
2172                 assert (SvIOKp(sv));
2173             } else {
2174                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2175                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2176                     /* Small enough to preserve all bits. */
2177                     (void)SvIOKp_on(sv);
2178                     SvNOK_on(sv);
2179                     SvIV_set(sv, I_V(SvNVX(sv)));
2180                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2181                         SvIOK_on(sv);
2182                     /* Assumption: first non-preserved integer is < IV_MAX,
2183                        this NV is in the preserved range, therefore: */
2184                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2185                           < (UV)IV_MAX)) {
2186                         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);
2187                     }
2188                 } else
2189                     sv_2iuv_non_preserve (sv, numtype);
2190             }
2191 #endif /* NV_PRESERVES_UV */
2192         }
2193     }
2194     else  {
2195         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2196             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2197                 report_uninit(sv);
2198         }
2199         if (SvTYPE(sv) < SVt_IV)
2200             /* Typically the caller expects that sv_any is not NULL now.  */
2201             sv_upgrade(sv, SVt_IV);
2202         return 0;
2203     }
2204
2205     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2206                           PTR2UV(sv),SvUVX(sv)));
2207     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2208 }
2209
2210 /*
2211 =for apidoc sv_2nv
2212
2213 Return the num value of an SV, doing any necessary string or integer
2214 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2215 macros.
2216
2217 =cut
2218 */
2219
2220 NV
2221 Perl_sv_2nv(pTHX_ register SV *sv)
2222 {
2223     if (!sv)
2224         return 0.0;
2225     if (SvGMAGICAL(sv)) {
2226         mg_get(sv);
2227         if (SvNOKp(sv))
2228             return SvNVX(sv);
2229         if (SvPOKp(sv) && SvLEN(sv)) {
2230             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2231                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2232                 not_a_number(sv);
2233             return Atof(SvPVX_const(sv));
2234         }
2235         if (SvIOKp(sv)) {
2236             if (SvIsUV(sv))
2237                 return (NV)SvUVX(sv);
2238             else
2239                 return (NV)SvIVX(sv);
2240         }       
2241         if (!SvROK(sv)) {
2242             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2243                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2244                     report_uninit(sv);
2245             }
2246             return (NV)0;
2247         }
2248     }
2249     if (SvTHINKFIRST(sv)) {
2250         if (SvROK(sv)) {
2251           SV* tmpstr;
2252           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2253                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2254               return SvNV(tmpstr);
2255           return PTR2NV(SvRV(sv));
2256         }
2257         if (SvIsCOW(sv)) {
2258             sv_force_normal_flags(sv, 0);
2259         }
2260         if (SvREADONLY(sv) && !SvOK(sv)) {
2261             if (ckWARN(WARN_UNINITIALIZED))
2262                 report_uninit(sv);
2263             return 0.0;
2264         }
2265     }
2266     if (SvTYPE(sv) < SVt_NV) {
2267         if (SvTYPE(sv) == SVt_IV)
2268             sv_upgrade(sv, SVt_PVNV);
2269         else
2270             sv_upgrade(sv, SVt_NV);
2271 #ifdef USE_LONG_DOUBLE
2272         DEBUG_c({
2273             STORE_NUMERIC_LOCAL_SET_STANDARD();
2274             PerlIO_printf(Perl_debug_log,
2275                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2276                           PTR2UV(sv), SvNVX(sv));
2277             RESTORE_NUMERIC_LOCAL();
2278         });
2279 #else
2280         DEBUG_c({
2281             STORE_NUMERIC_LOCAL_SET_STANDARD();
2282             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2283                           PTR2UV(sv), SvNVX(sv));
2284             RESTORE_NUMERIC_LOCAL();
2285         });
2286 #endif
2287     }
2288     else if (SvTYPE(sv) < SVt_PVNV)
2289         sv_upgrade(sv, SVt_PVNV);
2290     if (SvNOKp(sv)) {
2291         return SvNVX(sv);
2292     }
2293     if (SvIOKp(sv)) {
2294         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2295 #ifdef NV_PRESERVES_UV
2296         SvNOK_on(sv);
2297 #else
2298         /* Only set the public NV OK flag if this NV preserves the IV  */
2299         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2300         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2301                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2302             SvNOK_on(sv);
2303         else
2304             SvNOKp_on(sv);
2305 #endif
2306     }
2307     else if (SvPOKp(sv) && SvLEN(sv)) {
2308         UV value;
2309         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2310         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2311             not_a_number(sv);
2312 #ifdef NV_PRESERVES_UV
2313         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2314             == IS_NUMBER_IN_UV) {
2315             /* It's definitely an integer */
2316             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2317         } else
2318             SvNV_set(sv, Atof(SvPVX_const(sv)));
2319         SvNOK_on(sv);
2320 #else
2321         SvNV_set(sv, Atof(SvPVX_const(sv)));
2322         /* Only set the public NV OK flag if this NV preserves the value in
2323            the PV at least as well as an IV/UV would.
2324            Not sure how to do this 100% reliably. */
2325         /* if that shift count is out of range then Configure's test is
2326            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2327            UV_BITS */
2328         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2329             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2330             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2331         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2332             /* Can't use strtol etc to convert this string, so don't try.
2333                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2334             SvNOK_on(sv);
2335         } else {
2336             /* value has been set.  It may not be precise.  */
2337             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2338                 /* 2s complement assumption for (UV)IV_MIN  */
2339                 SvNOK_on(sv); /* Integer is too negative.  */
2340             } else {
2341                 SvNOKp_on(sv);
2342                 SvIOKp_on(sv);
2343
2344                 if (numtype & IS_NUMBER_NEG) {
2345                     SvIV_set(sv, -(IV)value);
2346                 } else if (value <= (UV)IV_MAX) {
2347                     SvIV_set(sv, (IV)value);
2348                 } else {
2349                     SvUV_set(sv, value);
2350                     SvIsUV_on(sv);
2351                 }
2352
2353                 if (numtype & IS_NUMBER_NOT_INT) {
2354                     /* I believe that even if the original PV had decimals,
2355                        they are lost beyond the limit of the FP precision.
2356                        However, neither is canonical, so both only get p
2357                        flags.  NWC, 2000/11/25 */
2358                     /* Both already have p flags, so do nothing */
2359                 } else {
2360                     const NV nv = SvNVX(sv);
2361                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2362                         if (SvIVX(sv) == I_V(nv)) {
2363                             SvNOK_on(sv);
2364                             SvIOK_on(sv);
2365                         } else {
2366                             SvIOK_on(sv);
2367                             /* It had no "." so it must be integer.  */
2368                         }
2369                     } else {
2370                         /* between IV_MAX and NV(UV_MAX).
2371                            Could be slightly > UV_MAX */
2372
2373                         if (numtype & IS_NUMBER_NOT_INT) {
2374                             /* UV and NV both imprecise.  */
2375                         } else {
2376                             const UV nv_as_uv = U_V(nv);
2377
2378                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2379                                 SvNOK_on(sv);
2380                                 SvIOK_on(sv);
2381                             } else {
2382                                 SvIOK_on(sv);
2383                             }
2384                         }
2385                     }
2386                 }
2387             }
2388         }
2389 #endif /* NV_PRESERVES_UV */
2390     }
2391     else  {
2392         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2393             report_uninit(sv);
2394         if (SvTYPE(sv) < SVt_NV)
2395             /* Typically the caller expects that sv_any is not NULL now.  */
2396             /* XXX Ilya implies that this is a bug in callers that assume this
2397                and ideally should be fixed.  */
2398             sv_upgrade(sv, SVt_NV);
2399         return 0.0;
2400     }
2401 #if defined(USE_LONG_DOUBLE)
2402     DEBUG_c({
2403         STORE_NUMERIC_LOCAL_SET_STANDARD();
2404         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2405                       PTR2UV(sv), SvNVX(sv));
2406         RESTORE_NUMERIC_LOCAL();
2407     });
2408 #else
2409     DEBUG_c({
2410         STORE_NUMERIC_LOCAL_SET_STANDARD();
2411         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2412                       PTR2UV(sv), SvNVX(sv));
2413         RESTORE_NUMERIC_LOCAL();
2414     });
2415 #endif
2416     return SvNVX(sv);
2417 }
2418
2419 /* asIV(): extract an integer from the string value of an SV.
2420  * Caller must validate PVX  */
2421
2422 STATIC IV
2423 S_asIV(pTHX_ SV *sv)
2424 {
2425     UV value;
2426     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2427
2428     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2429         == IS_NUMBER_IN_UV) {
2430         /* It's definitely an integer */
2431         if (numtype & IS_NUMBER_NEG) {
2432             if (value < (UV)IV_MIN)
2433                 return -(IV)value;
2434         } else {
2435             if (value < (UV)IV_MAX)
2436                 return (IV)value;
2437         }
2438     }
2439     if (!numtype) {
2440         if (ckWARN(WARN_NUMERIC))
2441             not_a_number(sv);
2442     }
2443     return I_V(Atof(SvPVX_const(sv)));
2444 }
2445
2446 /* asUV(): extract an unsigned integer from the string value of an SV
2447  * Caller must validate PVX  */
2448
2449 STATIC UV
2450 S_asUV(pTHX_ SV *sv)
2451 {
2452     UV value;
2453     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2454
2455     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2456         == IS_NUMBER_IN_UV) {
2457         /* It's definitely an integer */
2458         if (!(numtype & IS_NUMBER_NEG))
2459             return value;
2460     }
2461     if (!numtype) {
2462         if (ckWARN(WARN_NUMERIC))
2463             not_a_number(sv);
2464     }
2465     return U_V(Atof(SvPVX_const(sv)));
2466 }
2467
2468 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2469  * UV as a string towards the end of buf, and return pointers to start and
2470  * end of it.
2471  *
2472  * We assume that buf is at least TYPE_CHARS(UV) long.
2473  */
2474
2475 static char *
2476 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2477 {
2478     char *ptr = buf + TYPE_CHARS(UV);
2479     char * const ebuf = ptr;
2480     int sign;
2481
2482     if (is_uv)
2483         sign = 0;
2484     else if (iv >= 0) {
2485         uv = iv;
2486         sign = 0;
2487     } else {
2488         uv = -iv;
2489         sign = 1;
2490     }
2491     do {
2492         *--ptr = '0' + (char)(uv % 10);
2493     } while (uv /= 10);
2494     if (sign)
2495         *--ptr = '-';
2496     *peob = ebuf;
2497     return ptr;
2498 }
2499
2500 /*
2501 =for apidoc sv_2pv_flags
2502
2503 Returns a pointer to the string value of an SV, and sets *lp to its length.
2504 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2505 if necessary.
2506 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2507 usually end up here too.
2508
2509 =cut
2510 */
2511
2512 char *
2513 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2514 {
2515     register char *s;
2516     int olderrno;
2517     SV *tsv, *origsv;
2518     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2519     char *tmpbuf = tbuf;
2520     STRLEN len = 0;     /* Hush gcc. len is always initialised before use.  */
2521
2522     if (!sv) {
2523         if (lp)
2524             *lp = 0;
2525         return (char *)"";
2526     }
2527     if (SvGMAGICAL(sv)) {
2528         if (flags & SV_GMAGIC)
2529             mg_get(sv);
2530         if (SvPOKp(sv)) {
2531             if (lp)
2532                 *lp = SvCUR(sv);
2533             if (flags & SV_MUTABLE_RETURN)
2534                 return SvPVX_mutable(sv);
2535             if (flags & SV_CONST_RETURN)
2536                 return (char *)SvPVX_const(sv);
2537             return SvPVX(sv);
2538         }
2539         if (SvIOKp(sv)) {
2540             len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
2541                 : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2542             tsv = Nullsv;
2543             goto tokensave_has_len;
2544         }
2545         if (SvNOKp(sv)) {
2546             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2547             tsv = Nullsv;
2548             goto tokensave;
2549         }
2550         if (!SvROK(sv)) {
2551             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2552                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2553                     report_uninit(sv);
2554             }
2555             if (lp)
2556                 *lp = 0;
2557             return (char *)"";
2558         }
2559     }
2560     if (SvTHINKFIRST(sv)) {
2561         if (SvROK(sv)) {
2562             SV* tmpstr;
2563             register const char *typestr;
2564             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2565                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2566                 /* Unwrap this:  */
2567                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
2568
2569                 char *pv;
2570                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2571                     if (flags & SV_CONST_RETURN) {
2572                         pv = (char *) SvPVX_const(tmpstr);
2573                     } else {
2574                         pv = (flags & SV_MUTABLE_RETURN)
2575                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2576                     }
2577                     if (lp)
2578                         *lp = SvCUR(tmpstr);
2579                 } else {
2580                     pv = sv_2pv_flags(tmpstr, lp, flags);
2581                 }
2582                 if (SvUTF8(tmpstr))
2583                     SvUTF8_on(sv);
2584                 else
2585                     SvUTF8_off(sv);
2586                 return pv;
2587             }
2588             origsv = sv;
2589             sv = (SV*)SvRV(sv);
2590             if (!sv)
2591                 typestr = "NULLREF";
2592             else {
2593                 MAGIC *mg;
2594                 
2595                 switch (SvTYPE(sv)) {
2596                 case SVt_PVMG:
2597                     if ( ((SvFLAGS(sv) &
2598                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2599                           == (SVs_OBJECT|SVs_SMG))
2600                          && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2601                         const regexp *re = (regexp *)mg->mg_obj;
2602
2603                         if (!mg->mg_ptr) {
2604                             const char *fptr = "msix";
2605                             char reflags[6];
2606                             char ch;
2607                             int left = 0;
2608                             int right = 4;
2609                             char need_newline = 0;
2610                             U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2611
2612                             while((ch = *fptr++)) {
2613                                 if(reganch & 1) {
2614                                     reflags[left++] = ch;
2615                                 }
2616                                 else {
2617                                     reflags[right--] = ch;
2618                                 }
2619                                 reganch >>= 1;
2620                             }
2621                             if(left != 4) {
2622                                 reflags[left] = '-';
2623                                 left = 5;
2624                             }
2625
2626                             mg->mg_len = re->prelen + 4 + left;
2627                             /*
2628                              * If /x was used, we have to worry about a regex
2629                              * ending with a comment later being embedded
2630                              * within another regex. If so, we don't want this
2631                              * regex's "commentization" to leak out to the
2632                              * right part of the enclosing regex, we must cap
2633                              * it with a newline.
2634                              *
2635                              * So, if /x was used, we scan backwards from the
2636                              * end of the regex. If we find a '#' before we
2637                              * find a newline, we need to add a newline
2638                              * ourself. If we find a '\n' first (or if we
2639                              * don't find '#' or '\n'), we don't need to add
2640                              * anything.  -jfriedl
2641                              */
2642                             if (PMf_EXTENDED & re->reganch)
2643                             {
2644                                 const char *endptr = re->precomp + re->prelen;
2645                                 while (endptr >= re->precomp)
2646                                 {
2647                                     const char c = *(endptr--);
2648                                     if (c == '\n')
2649                                         break; /* don't need another */
2650                                     if (c == '#') {
2651                                         /* we end while in a comment, so we
2652                                            need a newline */
2653                                         mg->mg_len++; /* save space for it */
2654                                         need_newline = 1; /* note to add it */
2655                                         break;
2656                                     }
2657                                 }
2658                             }
2659
2660                             Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2661                             Copy("(?", mg->mg_ptr, 2, char);
2662                             Copy(reflags, mg->mg_ptr+2, left, char);
2663                             Copy(":", mg->mg_ptr+left+2, 1, char);
2664                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2665                             if (need_newline)
2666                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
2667                             mg->mg_ptr[mg->mg_len - 1] = ')';
2668                             mg->mg_ptr[mg->mg_len] = 0;
2669                         }
2670                         PL_reginterp_cnt += re->program[0].next_off;
2671
2672                         if (re->reganch & ROPT_UTF8)
2673                             SvUTF8_on(origsv);
2674                         else
2675                             SvUTF8_off(origsv);
2676                         if (lp)
2677                             *lp = mg->mg_len;
2678                         return mg->mg_ptr;
2679                     }
2680                                         /* Fall through */
2681                 case SVt_NULL:
2682                 case SVt_IV:
2683                 case SVt_NV:
2684                 case SVt_RV:
2685                 case SVt_PV:
2686                 case SVt_PVIV:
2687                 case SVt_PVNV:
2688                 case SVt_PVBM:  typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
2689                 case SVt_PVLV:  typestr = SvROK(sv) ? "REF"
2690                                 /* tied lvalues should appear to be
2691                                  * scalars for backwards compatitbility */
2692                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
2693                                     ? "SCALAR" : "LVALUE";      break;
2694                 case SVt_PVAV:  typestr = "ARRAY";      break;
2695                 case SVt_PVHV:  typestr = "HASH";       break;
2696                 case SVt_PVCV:  typestr = "CODE";       break;
2697                 case SVt_PVGV:  typestr = "GLOB";       break;
2698                 case SVt_PVFM:  typestr = "FORMAT";     break;
2699                 case SVt_PVIO:  typestr = "IO";         break;
2700                 default:        typestr = "UNKNOWN";    break;
2701                 }
2702                 tsv = NEWSV(0,0);
2703                 if (SvOBJECT(sv)) {
2704                     const char * const name = HvNAME_get(SvSTASH(sv));
2705                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2706                                    name ? name : "__ANON__" , typestr, PTR2UV(sv));
2707                 }
2708                 else
2709                     Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
2710                 goto tokensaveref;
2711             }
2712             if (lp)
2713                 *lp = strlen(typestr);
2714             return (char *)typestr;
2715         }
2716         if (SvREADONLY(sv) && !SvOK(sv)) {
2717             if (ckWARN(WARN_UNINITIALIZED))
2718                 report_uninit(sv);
2719             if (lp)
2720                 *lp = 0;
2721             return (char *)"";
2722         }
2723     }
2724     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2725         /* I'm assuming that if both IV and NV are equally valid then
2726            converting the IV is going to be more efficient */
2727         const U32 isIOK = SvIOK(sv);
2728         const U32 isUIOK = SvIsUV(sv);
2729         char buf[TYPE_CHARS(UV)];
2730         char *ebuf, *ptr;
2731
2732         if (SvTYPE(sv) < SVt_PVIV)
2733             sv_upgrade(sv, SVt_PVIV);
2734         if (isUIOK)
2735             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2736         else
2737             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2738         /* inlined from sv_setpvn */
2739         SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2740         Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2741         SvCUR_set(sv, ebuf - ptr);
2742         s = SvEND(sv);
2743         *s = '\0';
2744         if (isIOK)
2745             SvIOK_on(sv);
2746         else
2747             SvIOKp_on(sv);
2748         if (isUIOK)
2749             SvIsUV_on(sv);
2750     }
2751     else if (SvNOKp(sv)) {
2752         if (SvTYPE(sv) < SVt_PVNV)
2753             sv_upgrade(sv, SVt_PVNV);
2754         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2755         s = SvGROW_mutable(sv, NV_DIG + 20);
2756         olderrno = errno;       /* some Xenix systems wipe out errno here */
2757 #ifdef apollo
2758         if (SvNVX(sv) == 0.0)
2759             (void)strcpy(s,"0");
2760         else
2761 #endif /*apollo*/
2762         {
2763             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2764         }
2765         errno = olderrno;
2766 #ifdef FIXNEGATIVEZERO
2767         if (*s == '-' && s[1] == '0' && !s[2])
2768             strcpy(s,"0");
2769 #endif
2770         while (*s) s++;
2771 #ifdef hcx
2772         if (s[-1] == '.')
2773             *--s = '\0';
2774 #endif
2775     }
2776     else {
2777         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2778             report_uninit(sv);
2779         if (lp)
2780         *lp = 0;
2781         if (SvTYPE(sv) < SVt_PV)
2782             /* Typically the caller expects that sv_any is not NULL now.  */
2783             sv_upgrade(sv, SVt_PV);
2784         return (char *)"";
2785     }
2786     {
2787         const STRLEN len = s - SvPVX_const(sv);
2788         if (lp) 
2789             *lp = len;
2790         SvCUR_set(sv, len);
2791     }
2792     SvPOK_on(sv);
2793     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2794                           PTR2UV(sv),SvPVX_const(sv)));
2795     if (flags & SV_CONST_RETURN)
2796         return (char *)SvPVX_const(sv);
2797     if (flags & SV_MUTABLE_RETURN)
2798         return SvPVX_mutable(sv);
2799     return SvPVX(sv);
2800
2801   tokensave:
2802     len = strlen(tmpbuf);
2803  tokensave_has_len:
2804     assert (!tsv);
2805     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2806         /* Sneaky stuff here */
2807
2808       tokensaveref:
2809         if (!tsv)
2810             tsv = newSVpvn(tmpbuf, len);
2811         sv_2mortal(tsv);
2812         if (lp)
2813             *lp = SvCUR(tsv);
2814         return SvPVX(tsv);
2815     }
2816     else {
2817         dVAR;
2818
2819 #ifdef FIXNEGATIVEZERO
2820         if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
2821             tmpbuf[0] = '0';
2822             tmpbuf[1] = 0;
2823             len = 1;
2824         }
2825 #endif
2826         SvUPGRADE(sv, SVt_PV);
2827         if (lp)
2828             *lp = len;
2829         s = SvGROW_mutable(sv, len + 1);
2830         SvCUR_set(sv, len);
2831         SvPOKp_on(sv);
2832         return memcpy(s, tmpbuf, len + 1);
2833     }
2834 }
2835
2836 /*
2837 =for apidoc sv_copypv
2838
2839 Copies a stringified representation of the source SV into the
2840 destination SV.  Automatically performs any necessary mg_get and
2841 coercion of numeric values into strings.  Guaranteed to preserve
2842 UTF-8 flag even from overloaded objects.  Similar in nature to
2843 sv_2pv[_flags] but operates directly on an SV instead of just the
2844 string.  Mostly uses sv_2pv_flags to do its work, except when that
2845 would lose the UTF-8'ness of the PV.
2846
2847 =cut
2848 */
2849
2850 void
2851 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2852 {
2853     STRLEN len;
2854     const char * const s = SvPV_const(ssv,len);
2855     sv_setpvn(dsv,s,len);
2856     if (SvUTF8(ssv))
2857         SvUTF8_on(dsv);
2858     else
2859         SvUTF8_off(dsv);
2860 }
2861
2862 /*
2863 =for apidoc sv_2pvbyte
2864
2865 Return a pointer to the byte-encoded representation of the SV, and set *lp
2866 to its length.  May cause the SV to be downgraded from UTF-8 as a
2867 side-effect.
2868
2869 Usually accessed via the C<SvPVbyte> macro.
2870
2871 =cut
2872 */
2873
2874 char *
2875 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2876 {
2877     sv_utf8_downgrade(sv,0);
2878     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2879 }
2880
2881 /*
2882 =for apidoc sv_2pvutf8
2883
2884 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2885 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
2886
2887 Usually accessed via the C<SvPVutf8> macro.
2888
2889 =cut
2890 */
2891
2892 char *
2893 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2894 {
2895     sv_utf8_upgrade(sv);
2896     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2897 }
2898
2899
2900 /*
2901 =for apidoc sv_2bool
2902
2903 This function is only called on magical items, and is only used by
2904 sv_true() or its macro equivalent.
2905
2906 =cut
2907 */
2908
2909 bool
2910 Perl_sv_2bool(pTHX_ register SV *sv)
2911 {
2912     SvGETMAGIC(sv);
2913
2914     if (!SvOK(sv))
2915         return 0;
2916     if (SvROK(sv)) {
2917         SV* tmpsv;
2918         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2919                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2920             return (bool)SvTRUE(tmpsv);
2921       return SvRV(sv) != 0;
2922     }
2923     if (SvPOKp(sv)) {
2924         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2925         if (Xpvtmp &&
2926                 (*sv->sv_u.svu_pv > '0' ||
2927                 Xpvtmp->xpv_cur > 1 ||
2928                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2929             return 1;
2930         else
2931             return 0;
2932     }
2933     else {
2934         if (SvIOKp(sv))
2935             return SvIVX(sv) != 0;
2936         else {
2937             if (SvNOKp(sv))
2938                 return SvNVX(sv) != 0.0;
2939             else
2940                 return FALSE;
2941         }
2942     }
2943 }
2944
2945 /*
2946 =for apidoc sv_utf8_upgrade
2947
2948 Converts the PV of an SV to its UTF-8-encoded form.
2949 Forces the SV to string form if it is not already.
2950 Always sets the SvUTF8 flag to avoid future validity checks even
2951 if all the bytes have hibit clear.
2952
2953 This is not as a general purpose byte encoding to Unicode interface:
2954 use the Encode extension for that.
2955
2956 =for apidoc sv_utf8_upgrade_flags
2957
2958 Converts the PV of an SV to its UTF-8-encoded form.
2959 Forces the SV to string form if it is not already.
2960 Always sets the SvUTF8 flag to avoid future validity checks even
2961 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2962 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2963 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2964
2965 This is not as a general purpose byte encoding to Unicode interface:
2966 use the Encode extension for that.
2967
2968 =cut
2969 */
2970
2971 STRLEN
2972 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2973 {
2974     if (sv == &PL_sv_undef)
2975         return 0;
2976     if (!SvPOK(sv)) {
2977         STRLEN len = 0;
2978         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2979             (void) sv_2pv_flags(sv,&len, flags);
2980             if (SvUTF8(sv))
2981                 return len;
2982         } else {
2983             (void) SvPV_force(sv,len);
2984         }
2985     }
2986
2987     if (SvUTF8(sv)) {
2988         return SvCUR(sv);
2989     }
2990
2991     if (SvIsCOW(sv)) {
2992         sv_force_normal_flags(sv, 0);
2993     }
2994
2995     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2996         sv_recode_to_utf8(sv, PL_encoding);
2997     else { /* Assume Latin-1/EBCDIC */
2998         /* This function could be much more efficient if we
2999          * had a FLAG in SVs to signal if there are any hibit
3000          * chars in the PV.  Given that there isn't such a flag
3001          * make the loop as fast as possible. */
3002         const U8 *s = (U8 *) SvPVX_const(sv);
3003         const U8 * const e = (U8 *) SvEND(sv);
3004         const U8 *t = s;
3005         int hibit = 0;
3006         
3007         while (t < e) {
3008             const U8 ch = *t++;
3009             if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3010                 break;
3011         }
3012         if (hibit) {
3013             STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3014             U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3015
3016             SvPV_free(sv); /* No longer using what was there before. */
3017
3018             SvPV_set(sv, (char*)recoded);
3019             SvCUR_set(sv, len - 1);
3020             SvLEN_set(sv, len); /* No longer know the real size. */
3021         }
3022         /* Mark as UTF-8 even if no hibit - saves scanning loop */
3023         SvUTF8_on(sv);
3024     }
3025     return SvCUR(sv);
3026 }
3027
3028 /*
3029 =for apidoc sv_utf8_downgrade
3030
3031 Attempts to convert the PV of an SV from characters to bytes.
3032 If the PV contains a character beyond byte, this conversion will fail;
3033 in this case, either returns false or, if C<fail_ok> is not
3034 true, croaks.
3035
3036 This is not as a general purpose Unicode to byte encoding interface:
3037 use the Encode extension for that.
3038
3039 =cut
3040 */
3041
3042 bool
3043 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3044 {
3045     if (SvPOKp(sv) && SvUTF8(sv)) {
3046         if (SvCUR(sv)) {
3047             U8 *s;
3048             STRLEN len;
3049
3050             if (SvIsCOW(sv)) {
3051                 sv_force_normal_flags(sv, 0);
3052             }
3053             s = (U8 *) SvPV(sv, len);
3054             if (!utf8_to_bytes(s, &len)) {
3055                 if (fail_ok)
3056                     return FALSE;
3057                 else {
3058                     if (PL_op)
3059                         Perl_croak(aTHX_ "Wide character in %s",
3060                                    OP_DESC(PL_op));
3061                     else
3062                         Perl_croak(aTHX_ "Wide character");
3063                 }
3064             }
3065             SvCUR_set(sv, len);
3066         }
3067     }
3068     SvUTF8_off(sv);
3069     return TRUE;
3070 }
3071
3072 /*
3073 =for apidoc sv_utf8_encode
3074
3075 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3076 flag off so that it looks like octets again.
3077
3078 =cut
3079 */
3080
3081 void
3082 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3083 {
3084     (void) sv_utf8_upgrade(sv);
3085     if (SvIsCOW(sv)) {
3086         sv_force_normal_flags(sv, 0);
3087     }
3088     if (SvREADONLY(sv)) {
3089         Perl_croak(aTHX_ PL_no_modify);
3090     }
3091     SvUTF8_off(sv);
3092 }
3093
3094 /*
3095 =for apidoc sv_utf8_decode
3096
3097 If the PV of the SV is an octet sequence in UTF-8
3098 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3099 so that it looks like a character. If the PV contains only single-byte
3100 characters, the C<SvUTF8> flag stays being off.
3101 Scans PV for validity and returns false if the PV is invalid UTF-8.
3102
3103 =cut
3104 */
3105
3106 bool
3107 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3108 {
3109     if (SvPOKp(sv)) {
3110         const U8 *c;
3111         const U8 *e;
3112
3113         /* The octets may have got themselves encoded - get them back as
3114          * bytes
3115          */
3116         if (!sv_utf8_downgrade(sv, TRUE))
3117             return FALSE;
3118
3119         /* it is actually just a matter of turning the utf8 flag on, but
3120          * we want to make sure everything inside is valid utf8 first.
3121          */
3122         c = (const U8 *) SvPVX_const(sv);
3123         if (!is_utf8_string(c, SvCUR(sv)+1))
3124             return FALSE;
3125         e = (const U8 *) SvEND(sv);
3126         while (c < e) {
3127             const U8 ch = *c++;
3128             if (!UTF8_IS_INVARIANT(ch)) {
3129                 SvUTF8_on(sv);
3130                 break;
3131             }
3132         }
3133     }
3134     return TRUE;
3135 }
3136
3137 /*
3138 =for apidoc sv_setsv
3139
3140 Copies the contents of the source SV C<ssv> into the destination SV
3141 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3142 function if the source SV needs to be reused. Does not handle 'set' magic.
3143 Loosely speaking, it performs a copy-by-value, obliterating any previous
3144 content of the destination.
3145
3146 You probably want to use one of the assortment of wrappers, such as
3147 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3148 C<SvSetMagicSV_nosteal>.
3149
3150 =for apidoc sv_setsv_flags
3151
3152 Copies the contents of the source SV C<ssv> into the destination SV
3153 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3154 function if the source SV needs to be reused. Does not handle 'set' magic.
3155 Loosely speaking, it performs a copy-by-value, obliterating any previous
3156 content of the destination.
3157 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3158 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3159 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3160 and C<sv_setsv_nomg> are implemented in terms of this function.
3161
3162 You probably want to use one of the assortment of wrappers, such as
3163 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3164 C<SvSetMagicSV_nosteal>.
3165
3166 This is the primary function for copying scalars, and most other
3167 copy-ish functions and macros use this underneath.
3168
3169 =cut
3170 */
3171
3172 void
3173 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3174 {
3175     register U32 sflags;
3176     register int dtype;
3177     register int stype;
3178
3179     if (sstr == dstr)
3180         return;
3181     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3182     if (!sstr)
3183         sstr = &PL_sv_undef;
3184     stype = SvTYPE(sstr);
3185     dtype = SvTYPE(dstr);
3186
3187     SvAMAGIC_off(dstr);
3188     if ( SvVOK(dstr) )
3189     {
3190         /* need to nuke the magic */
3191         mg_free(dstr);
3192         SvRMAGICAL_off(dstr);
3193     }
3194
3195     /* There's a lot of redundancy below but we're going for speed here */
3196
3197     switch (stype) {
3198     case SVt_NULL:
3199       undef_sstr:
3200         if (dtype != SVt_PVGV) {
3201             (void)SvOK_off(dstr);
3202             return;
3203         }
3204         break;
3205     case SVt_IV:
3206         if (SvIOK(sstr)) {
3207             switch (dtype) {
3208             case SVt_NULL:
3209                 sv_upgrade(dstr, SVt_IV);
3210                 break;
3211             case SVt_NV:
3212                 sv_upgrade(dstr, SVt_PVNV);
3213                 break;
3214             case SVt_RV:
3215             case SVt_PV:
3216                 sv_upgrade(dstr, SVt_PVIV);
3217                 break;
3218             }
3219             (void)SvIOK_only(dstr);
3220             SvIV_set(dstr,  SvIVX(sstr));
3221             if (SvIsUV(sstr))
3222                 SvIsUV_on(dstr);
3223             if (SvTAINTED(sstr))
3224                 SvTAINT(dstr);
3225             return;
3226         }
3227         goto undef_sstr;
3228
3229     case SVt_NV:
3230         if (SvNOK(sstr)) {
3231             switch (dtype) {
3232             case SVt_NULL:
3233             case SVt_IV:
3234                 sv_upgrade(dstr, SVt_NV);
3235                 break;
3236             case SVt_RV:
3237             case SVt_PV:
3238             case SVt_PVIV:
3239                 sv_upgrade(dstr, SVt_PVNV);
3240                 break;
3241             }
3242             SvNV_set(dstr, SvNVX(sstr));
3243             (void)SvNOK_only(dstr);
3244             if (SvTAINTED(sstr))
3245                 SvTAINT(dstr);
3246             return;
3247         }
3248         goto undef_sstr;
3249
3250     case SVt_RV:
3251         if (dtype < SVt_RV)
3252             sv_upgrade(dstr, SVt_RV);
3253         else if (dtype == SVt_PVGV &&
3254                  SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3255             sstr = SvRV(sstr);
3256             if (sstr == dstr) {
3257                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3258                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3259                 {
3260                     GvIMPORTED_on(dstr);
3261                 }
3262                 GvMULTI_on(dstr);
3263                 return;
3264             }
3265             goto glob_assign;
3266         }
3267         break;
3268     case SVt_PVFM:
3269 #ifdef PERL_OLD_COPY_ON_WRITE
3270         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3271             if (dtype < SVt_PVIV)
3272                 sv_upgrade(dstr, SVt_PVIV);
3273             break;
3274         }
3275         /* Fall through */
3276 #endif
3277     case SVt_PV:
3278         if (dtype < SVt_PV)
3279             sv_upgrade(dstr, SVt_PV);
3280         break;
3281     case SVt_PVIV:
3282         if (dtype < SVt_PVIV)
3283             sv_upgrade(dstr, SVt_PVIV);
3284         break;
3285     case SVt_PVNV:
3286         if (dtype < SVt_PVNV)
3287             sv_upgrade(dstr, SVt_PVNV);
3288         break;
3289     case SVt_PVAV:
3290     case SVt_PVHV:
3291     case SVt_PVCV:
3292     case SVt_PVIO:
3293         {
3294         const char * const type = sv_reftype(sstr,0);
3295         if (PL_op)
3296             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3297         else
3298             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3299         }
3300         break;
3301
3302     case SVt_PVGV:
3303         if (dtype <= SVt_PVGV) {
3304   glob_assign:
3305             if (dtype != SVt_PVGV) {
3306                 const char * const name = GvNAME(sstr);
3307                 const STRLEN len = GvNAMELEN(sstr);
3308                 /* don't upgrade SVt_PVLV: it can hold a glob */
3309                 if (dtype != SVt_PVLV)
3310                     sv_upgrade(dstr, SVt_PVGV);
3311                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3312                 GvSTASH(dstr) = GvSTASH(sstr);
3313                 if (GvSTASH(dstr))
3314                     Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3315                 GvNAME(dstr) = savepvn(name, len);
3316                 GvNAMELEN(dstr) = len;
3317                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3318             }
3319
3320 #ifdef GV_UNIQUE_CHECK
3321                 if (GvUNIQUE((GV*)dstr)) {
3322                     Perl_croak(aTHX_ PL_no_modify);
3323                 }
3324 #endif
3325
3326             (void)SvOK_off(dstr);
3327             GvINTRO_off(dstr);          /* one-shot flag */
3328             gp_free((GV*)dstr);
3329             GvGP(dstr) = gp_ref(GvGP(sstr));
3330             if (SvTAINTED(sstr))
3331                 SvTAINT(dstr);
3332             if (GvIMPORTED(dstr) != GVf_IMPORTED
3333                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3334             {
3335                 GvIMPORTED_on(dstr);
3336             }
3337             GvMULTI_on(dstr);
3338             return;
3339         }
3340         /* FALL THROUGH */
3341
3342     default:
3343         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3344             mg_get(sstr);
3345             if ((int)SvTYPE(sstr) != stype) {
3346                 stype = SvTYPE(sstr);
3347                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3348                     goto glob_assign;
3349             }
3350         }
3351         if (stype == SVt_PVLV)
3352             SvUPGRADE(dstr, SVt_PVNV);
3353         else
3354             SvUPGRADE(dstr, (U32)stype);
3355     }
3356
3357     sflags = SvFLAGS(sstr);
3358
3359     if (sflags & SVf_ROK) {
3360         if (dtype >= SVt_PV) {
3361             if (dtype == SVt_PVGV) {
3362                 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3363                 SV *dref = 0;
3364                 const int intro = GvINTRO(dstr);
3365
3366 #ifdef GV_UNIQUE_CHECK
3367                 if (GvUNIQUE((GV*)dstr)) {
3368                     Perl_croak(aTHX_ PL_no_modify);
3369                 }
3370 #endif
3371
3372                 if (intro) {
3373                     GvINTRO_off(dstr);  /* one-shot flag */
3374                     GvLINE(dstr) = CopLINE(PL_curcop);
3375                     GvEGV(dstr) = (GV*)dstr;
3376                 }
3377                 GvMULTI_on(dstr);
3378                 switch (SvTYPE(sref)) {
3379                 case SVt_PVAV:
3380                     if (intro)
3381                         SAVEGENERICSV(GvAV(dstr));
3382                     else
3383                         dref = (SV*)GvAV(dstr);
3384                     GvAV(dstr) = (AV*)sref;
3385                     if (!GvIMPORTED_AV(dstr)
3386                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3387                     {
3388                         GvIMPORTED_AV_on(dstr);
3389                     }
3390                     break;
3391                 case SVt_PVHV:
3392                     if (intro)
3393                         SAVEGENERICSV(GvHV(dstr));
3394                     else
3395                         dref = (SV*)GvHV(dstr);
3396                     GvHV(dstr) = (HV*)sref;
3397                     if (!GvIMPORTED_HV(dstr)
3398                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3399                     {
3400                         GvIMPORTED_HV_on(dstr);
3401                     }
3402                     break;
3403                 case SVt_PVCV:
3404                     if (intro) {
3405                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3406                             SvREFCNT_dec(GvCV(dstr));
3407                             GvCV(dstr) = Nullcv;
3408                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3409                             PL_sub_generation++;
3410                         }
3411                         SAVEGENERICSV(GvCV(dstr));
3412                     }
3413                     else
3414                         dref = (SV*)GvCV(dstr);
3415                     if (GvCV(dstr) != (CV*)sref) {
3416                         CV* const cv = GvCV(dstr);
3417                         if (cv) {
3418                             if (!GvCVGEN((GV*)dstr) &&
3419                                 (CvROOT(cv) || CvXSUB(cv)))
3420                             {
3421                                 /* Redefining a sub - warning is mandatory if
3422                                    it was a const and its value changed. */
3423                                 if (ckWARN(WARN_REDEFINE)
3424                                     || (CvCONST(cv)
3425                                         && (!CvCONST((CV*)sref)
3426                                             || sv_cmp(cv_const_sv(cv),
3427                                                       cv_const_sv((CV*)sref)))))
3428                                 {
3429                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3430                                         CvCONST(cv)
3431                                         ? "Constant subroutine %s::%s redefined"
3432                                         : "Subroutine %s::%s redefined",
3433                                         HvNAME_get(GvSTASH((GV*)dstr)),
3434                                         GvENAME((GV*)dstr));
3435                                 }
3436                             }
3437                             if (!intro)
3438                                 cv_ckproto(cv, (GV*)dstr,
3439                                            SvPOK(sref)
3440                                            ? SvPVX_const(sref) : Nullch);
3441                         }
3442                         GvCV(dstr) = (CV*)sref;
3443                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3444                         GvASSUMECV_on(dstr);
3445                         PL_sub_generation++;
3446                     }
3447                     if (!GvIMPORTED_CV(dstr)
3448                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3449                     {
3450                         GvIMPORTED_CV_on(dstr);
3451                     }
3452                     break;
3453                 case SVt_PVIO:
3454                     if (intro)
3455                         SAVEGENERICSV(GvIOp(dstr));
3456                     else
3457                         dref = (SV*)GvIOp(dstr);
3458                     GvIOp(dstr) = (IO*)sref;
3459                     break;
3460                 case SVt_PVFM:
3461                     if (intro)
3462                         SAVEGENERICSV(GvFORM(dstr));
3463                     else
3464                         dref = (SV*)GvFORM(dstr);
3465                     GvFORM(dstr) = (CV*)sref;
3466                     break;
3467                 default:
3468                     if (intro)
3469                         SAVEGENERICSV(GvSV(dstr));
3470                     else
3471                         dref = (SV*)GvSV(dstr);
3472                     GvSV(dstr) = sref;
3473                     if (!GvIMPORTED_SV(dstr)
3474                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3475                     {
3476                         GvIMPORTED_SV_on(dstr);
3477                     }
3478                     break;
3479                 }
3480                 if (dref)
3481                     SvREFCNT_dec(dref);
3482                 if (SvTAINTED(sstr))
3483                     SvTAINT(dstr);
3484                 return;
3485             }
3486             if (SvPVX_const(dstr)) {
3487                 SvPV_free(dstr);
3488                 SvLEN_set(dstr, 0);
3489                 SvCUR_set(dstr, 0);
3490             }
3491         }
3492         (void)SvOK_off(dstr);
3493         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3494         SvROK_on(dstr);
3495         if (sflags & SVp_NOK) {
3496             SvNOKp_on(dstr);
3497             /* Only set the public OK flag if the source has public OK.  */
3498             if (sflags & SVf_NOK)
3499                 SvFLAGS(dstr) |= SVf_NOK;
3500             SvNV_set(dstr, SvNVX(sstr));
3501         }
3502         if (sflags & SVp_IOK) {
3503             (void)SvIOKp_on(dstr);
3504             if (sflags & SVf_IOK)
3505                 SvFLAGS(dstr) |= SVf_IOK;
3506             if (sflags & SVf_IVisUV)
3507                 SvIsUV_on(dstr);
3508             SvIV_set(dstr, SvIVX(sstr));
3509         }
3510         if (SvAMAGIC(sstr)) {
3511             SvAMAGIC_on(dstr);
3512         }
3513     }
3514     else if (sflags & SVp_POK) {
3515         bool isSwipe = 0;
3516
3517         /*
3518          * Check to see if we can just swipe the string.  If so, it's a
3519          * possible small lose on short strings, but a big win on long ones.
3520          * It might even be a win on short strings if SvPVX_const(dstr)
3521          * has to be allocated and SvPVX_const(sstr) has to be freed.
3522          */
3523
3524         /* Whichever path we take through the next code, we want this true,
3525            and doing it now facilitates the COW check.  */
3526         (void)SvPOK_only(dstr);
3527
3528         if (
3529             /* We're not already COW  */
3530             ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3531 #ifndef PERL_OLD_COPY_ON_WRITE
3532              /* or we are, but dstr isn't a suitable target.  */
3533              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3534 #endif
3535              )
3536             &&
3537             !(isSwipe =
3538                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3539                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3540                  (!(flags & SV_NOSTEAL)) &&
3541                                         /* and we're allowed to steal temps */
3542                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3543                  SvLEN(sstr)    &&        /* and really is a string */
3544                                 /* and won't be needed again, potentially */
3545               !(PL_op && PL_op->op_type == OP_AASSIGN))
3546 #ifdef PERL_OLD_COPY_ON_WRITE
3547             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3548                  && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3549                  && SvTYPE(sstr) >= SVt_PVIV)
3550 #endif
3551             ) {
3552             /* Failed the swipe test, and it's not a shared hash key either.
3553                Have to copy the string.  */
3554             STRLEN len = SvCUR(sstr);
3555             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3556             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3557             SvCUR_set(dstr, len);
3558             *SvEND(dstr) = '\0';
3559         } else {
3560             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3561                be true in here.  */
3562             /* Either it's a shared hash key, or it's suitable for
3563                copy-on-write or we can swipe the string.  */
3564             if (DEBUG_C_TEST) {
3565                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3566                 sv_dump(sstr);
3567                 sv_dump(dstr);
3568             }
3569 #ifdef PERL_OLD_COPY_ON_WRITE
3570             if (!isSwipe) {
3571                 /* I believe I should acquire a global SV mutex if
3572                    it's a COW sv (not a shared hash key) to stop
3573                    it going un copy-on-write.
3574                    If the source SV has gone un copy on write between up there
3575                    and down here, then (assert() that) it is of the correct
3576                    form to make it copy on write again */
3577                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3578                     != (SVf_FAKE | SVf_READONLY)) {
3579                     SvREADONLY_on(sstr);
3580                     SvFAKE_on(sstr);
3581                     /* Make the source SV into a loop of 1.
3582                        (about to become 2) */
3583                     SV_COW_NEXT_SV_SET(sstr, sstr);
3584                 }
3585             }
3586 #endif
3587             /* Initial code is common.  */
3588             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
3589                 SvPV_free(dstr);
3590             }
3591
3592             if (!isSwipe) {
3593                 /* making another shared SV.  */
3594                 STRLEN cur = SvCUR(sstr);
3595                 STRLEN len = SvLEN(sstr);
3596 #ifdef PERL_OLD_COPY_ON_WRITE
3597                 if (len) {
3598                     assert (SvTYPE(dstr) >= SVt_PVIV);
3599                     /* SvIsCOW_normal */
3600                     /* splice us in between source and next-after-source.  */
3601                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3602                     SV_COW_NEXT_SV_SET(sstr, dstr);
3603                     SvPV_set(dstr, SvPVX_mutable(sstr));
3604                 } else
3605 #endif
3606                 {
3607                     /* SvIsCOW_shared_hash */
3608                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3609                                           "Copy on write: Sharing hash\n"));
3610
3611                     assert (SvTYPE(dstr) >= SVt_PV);
3612                     SvPV_set(dstr,
3613                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3614                 }
3615                 SvLEN_set(dstr, len);
3616                 SvCUR_set(dstr, cur);
3617                 SvREADONLY_on(dstr);
3618                 SvFAKE_on(dstr);
3619                 /* Relesase a global SV mutex.  */
3620             }
3621             else
3622                 {       /* Passes the swipe test.  */
3623                 SvPV_set(dstr, SvPVX_mutable(sstr));
3624                 SvLEN_set(dstr, SvLEN(sstr));
3625                 SvCUR_set(dstr, SvCUR(sstr));
3626
3627                 SvTEMP_off(dstr);
3628                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3629                 SvPV_set(sstr, Nullch);
3630                 SvLEN_set(sstr, 0);
3631                 SvCUR_set(sstr, 0);
3632                 SvTEMP_off(sstr);
3633             }
3634         }
3635         if (sflags & SVf_UTF8)
3636             SvUTF8_on(dstr);
3637         if (sflags & SVp_NOK) {
3638             SvNOKp_on(dstr);
3639             if (sflags & SVf_NOK)
3640                 SvFLAGS(dstr) |= SVf_NOK;
3641             SvNV_set(dstr, SvNVX(sstr));
3642         }
3643         if (sflags & SVp_IOK) {
3644             (void)SvIOKp_on(dstr);
3645             if (sflags & SVf_IOK)
3646                 SvFLAGS(dstr) |= SVf_IOK;
3647             if (sflags & SVf_IVisUV)
3648                 SvIsUV_on(dstr);
3649             SvIV_set(dstr, SvIVX(sstr));
3650         }
3651         if (SvVOK(sstr)) {
3652             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
3653             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3654                         smg->mg_ptr, smg->mg_len);
3655             SvRMAGICAL_on(dstr);
3656         }
3657     }
3658     else if (sflags & SVp_IOK) {
3659         if (sflags & SVf_IOK)
3660             (void)SvIOK_only(dstr);
3661         else {
3662             (void)SvOK_off(dstr);
3663             (void)SvIOKp_on(dstr);
3664         }
3665         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3666         if (sflags & SVf_IVisUV)
3667             SvIsUV_on(dstr);
3668         SvIV_set(dstr, SvIVX(sstr));
3669         if (sflags & SVp_NOK) {
3670             if (sflags & SVf_NOK)
3671                 (void)SvNOK_on(dstr);
3672             else
3673                 (void)SvNOKp_on(dstr);
3674             SvNV_set(dstr, SvNVX(sstr));
3675         }
3676     }
3677     else if (sflags & SVp_NOK) {
3678         if (sflags & SVf_NOK)
3679             (void)SvNOK_only(dstr);
3680         else {
3681             (void)SvOK_off(dstr);
3682             SvNOKp_on(dstr);
3683         }
3684         SvNV_set(dstr, SvNVX(sstr));
3685     }
3686     else {
3687         if (dtype == SVt_PVGV) {
3688             if (ckWARN(WARN_MISC))
3689                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3690         }
3691         else
3692             (void)SvOK_off(dstr);
3693     }
3694     if (SvTAINTED(sstr))
3695         SvTAINT(dstr);
3696 }
3697
3698 /*
3699 =for apidoc sv_setsv_mg
3700
3701 Like C<sv_setsv>, but also handles 'set' magic.
3702
3703 =cut
3704 */
3705
3706 void
3707 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3708 {
3709     sv_setsv(dstr,sstr);
3710     SvSETMAGIC(dstr);
3711 }
3712
3713 #ifdef PERL_OLD_COPY_ON_WRITE
3714 SV *
3715 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3716 {
3717     STRLEN cur = SvCUR(sstr);
3718     STRLEN len = SvLEN(sstr);
3719     register char *new_pv;
3720
3721     if (DEBUG_C_TEST) {
3722         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3723                       sstr, dstr);
3724         sv_dump(sstr);
3725         if (dstr)
3726                     sv_dump(dstr);
3727     }
3728
3729     if (dstr) {
3730         if (SvTHINKFIRST(dstr))
3731             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3732         else if (SvPVX_const(dstr))
3733             Safefree(SvPVX_const(dstr));
3734     }
3735     else
3736         new_SV(dstr);
3737     SvUPGRADE(dstr, SVt_PVIV);
3738
3739     assert (SvPOK(sstr));
3740     assert (SvPOKp(sstr));
3741     assert (!SvIOK(sstr));
3742     assert (!SvIOKp(sstr));
3743     assert (!SvNOK(sstr));
3744     assert (!SvNOKp(sstr));
3745
3746     if (SvIsCOW(sstr)) {
3747
3748         if (SvLEN(sstr) == 0) {
3749             /* source is a COW shared hash key.  */
3750             DEBUG_C(PerlIO_printf(Perl_debug_log,
3751                                   "Fast copy on write: Sharing hash\n"));
3752             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3753             goto common_exit;
3754         }
3755         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3756     } else {
3757         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3758         SvUPGRADE(sstr, SVt_PVIV);
3759         SvREADONLY_on(sstr);
3760         SvFAKE_on(sstr);
3761         DEBUG_C(PerlIO_printf(Perl_debug_log,
3762                               "Fast copy on write: Converting sstr to COW\n"));
3763         SV_COW_NEXT_SV_SET(dstr, sstr);
3764     }
3765     SV_COW_NEXT_SV_SET(sstr, dstr);
3766     new_pv = SvPVX_mutable(sstr);
3767
3768   common_exit:
3769     SvPV_set(dstr, new_pv);
3770     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3771     if (SvUTF8(sstr))
3772         SvUTF8_on(dstr);
3773     SvLEN_set(dstr, len);
3774     SvCUR_set(dstr, cur);
3775     if (DEBUG_C_TEST) {
3776         sv_dump(dstr);
3777     }
3778     return dstr;
3779 }
3780 #endif
3781
3782 /*
3783 =for apidoc sv_setpvn
3784
3785 Copies a string into an SV.  The C<len> parameter indicates the number of
3786 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
3787 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3788
3789 =cut
3790 */
3791
3792 void
3793 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3794 {
3795     register char *dptr;
3796
3797     SV_CHECK_THINKFIRST_COW_DROP(sv);
3798     if (!ptr) {
3799         (void)SvOK_off(sv);
3800         return;
3801     }
3802     else {
3803         /* len is STRLEN which is unsigned, need to copy to signed */
3804         const IV iv = len;
3805         if (iv < 0)
3806             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3807     }
3808     SvUPGRADE(sv, SVt_PV);
3809
3810     dptr = SvGROW(sv, len + 1);
3811     Move(ptr,dptr,len,char);
3812     dptr[len] = '\0';
3813     SvCUR_set(sv, len);
3814     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3815     SvTAINT(sv);
3816 }
3817
3818 /*
3819 =for apidoc sv_setpvn_mg
3820
3821 Like C<sv_setpvn>, but also handles 'set' magic.
3822
3823 =cut
3824 */
3825
3826 void
3827 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3828 {
3829     sv_setpvn(sv,ptr,len);
3830     SvSETMAGIC(sv);
3831 }
3832
3833 /*
3834 =for apidoc sv_setpv
3835
3836 Copies a string into an SV.  The string must be null-terminated.  Does not
3837 handle 'set' magic.  See C<sv_setpv_mg>.
3838
3839 =cut
3840 */
3841
3842 void
3843 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3844 {
3845     register STRLEN len;
3846
3847     SV_CHECK_THINKFIRST_COW_DROP(sv);
3848     if (!ptr) {
3849         (void)SvOK_off(sv);
3850         return;
3851     }
3852     len = strlen(ptr);
3853     SvUPGRADE(sv, SVt_PV);
3854
3855     SvGROW(sv, len + 1);
3856     Move(ptr,SvPVX(sv),len+1,char);
3857     SvCUR_set(sv, len);
3858     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3859     SvTAINT(sv);
3860 }
3861
3862 /*
3863 =for apidoc sv_setpv_mg
3864
3865 Like C<sv_setpv>, but also handles 'set' magic.
3866
3867 =cut
3868 */
3869
3870 void
3871 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3872 {
3873     sv_setpv(sv,ptr);
3874     SvSETMAGIC(sv);
3875 }
3876
3877 /*
3878 =for apidoc sv_usepvn
3879
3880 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3881 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3882 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3883 string length, C<len>, must be supplied.  This function will realloc the
3884 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3885 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3886 See C<sv_usepvn_mg>.
3887
3888 =cut
3889 */
3890
3891 void
3892 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3893 {
3894     STRLEN allocate;
3895     SV_CHECK_THINKFIRST_COW_DROP(sv);
3896     SvUPGRADE(sv, SVt_PV);
3897     if (!ptr) {
3898         (void)SvOK_off(sv);
3899         return;
3900     }
3901     if (SvPVX_const(sv))
3902         SvPV_free(sv);
3903
3904     allocate = PERL_STRLEN_ROUNDUP(len + 1);
3905     ptr = saferealloc (ptr, allocate);
3906     SvPV_set(sv, ptr);
3907     SvCUR_set(sv, len);
3908     SvLEN_set(sv, allocate);
3909     *SvEND(sv) = '\0';
3910     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3911     SvTAINT(sv);
3912 }
3913
3914 /*
3915 =for apidoc sv_usepvn_mg
3916
3917 Like C<sv_usepvn>, but also handles 'set' magic.
3918
3919 =cut
3920 */
3921
3922 void
3923 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3924 {
3925     sv_usepvn(sv,ptr,len);
3926     SvSETMAGIC(sv);
3927 }
3928
3929 #ifdef PERL_OLD_COPY_ON_WRITE
3930 /* Need to do this *after* making the SV normal, as we need the buffer
3931    pointer to remain valid until after we've copied it.  If we let go too early,
3932    another thread could invalidate it by unsharing last of the same hash key
3933    (which it can do by means other than releasing copy-on-write Svs)
3934    or by changing the other copy-on-write SVs in the loop.  */
3935 STATIC void
3936 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3937 {
3938     if (len) { /* this SV was SvIsCOW_normal(sv) */
3939          /* we need to find the SV pointing to us.  */
3940         SV * const current = SV_COW_NEXT_SV(after);
3941
3942         if (current == sv) {
3943             /* The SV we point to points back to us (there were only two of us
3944                in the loop.)
3945                Hence other SV is no longer copy on write either.  */
3946             SvFAKE_off(after);
3947             SvREADONLY_off(after);
3948         } else {
3949             /* We need to follow the pointers around the loop.  */
3950             SV *next;
3951             while ((next = SV_COW_NEXT_SV(current)) != sv) {
3952                 assert (next);
3953                 current = next;
3954                  /* don't loop forever if the structure is bust, and we have
3955                     a pointer into a closed loop.  */
3956                 assert (current != after);
3957                 assert (SvPVX_const(current) == pvx);
3958             }
3959             /* Make the SV before us point to the SV after us.  */
3960             SV_COW_NEXT_SV_SET(current, after);
3961         }
3962     } else {
3963         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3964     }
3965 }
3966
3967 int
3968 Perl_sv_release_IVX(pTHX_ register SV *sv)
3969 {
3970     if (SvIsCOW(sv))
3971         sv_force_normal_flags(sv, 0);
3972     SvOOK_off(sv);
3973     return 0;
3974 }
3975 #endif
3976 /*
3977 =for apidoc sv_force_normal_flags
3978
3979 Undo various types of fakery on an SV: if the PV is a shared string, make
3980 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3981 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3982 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3983 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3984 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3985 set to some other value.) In addition, the C<flags> parameter gets passed to
3986 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3987 with flags set to 0.
3988
3989 =cut
3990 */
3991
3992 void
3993 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3994 {
3995 #ifdef PERL_OLD_COPY_ON_WRITE
3996     if (SvREADONLY(sv)) {
3997         /* At this point I believe I should acquire a global SV mutex.  */
3998         if (SvFAKE(sv)) {
3999             const char * const pvx = SvPVX_const(sv);
4000             const STRLEN len = SvLEN(sv);
4001             const STRLEN cur = SvCUR(sv);
4002             SV * const next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
4003             if (DEBUG_C_TEST) {
4004                 PerlIO_printf(Perl_debug_log,
4005                               "Copy on write: Force normal %ld\n",
4006                               (long) flags);
4007                 sv_dump(sv);
4008             }
4009             SvFAKE_off(sv);
4010             SvREADONLY_off(sv);
4011             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4012             SvPV_set(sv, (char*)0);
4013             SvLEN_set(sv, 0);
4014             if (flags & SV_COW_DROP_PV) {
4015                 /* OK, so we don't need to copy our buffer.  */
4016                 SvPOK_off(sv);
4017             } else {
4018                 SvGROW(sv, cur + 1);
4019                 Move(pvx,SvPVX(sv),cur,char);
4020                 SvCUR_set(sv, cur);
4021                 *SvEND(sv) = '\0';
4022             }
4023             sv_release_COW(sv, pvx, len, next);
4024             if (DEBUG_C_TEST) {
4025                 sv_dump(sv);
4026             }
4027         }
4028         else if (IN_PERL_RUNTIME)
4029             Perl_croak(aTHX_ PL_no_modify);
4030         /* At this point I believe that I can drop the global SV mutex.  */
4031     }
4032 #else
4033     if (SvREADONLY(sv)) {
4034         if (SvFAKE(sv)) {
4035             const char * const pvx = SvPVX_const(sv);
4036             const STRLEN len = SvCUR(sv);
4037             SvFAKE_off(sv);
4038             SvREADONLY_off(sv);
4039             SvPV_set(sv, Nullch);
4040             SvLEN_set(sv, 0);
4041             SvGROW(sv, len + 1);
4042             Move(pvx,SvPVX(sv),len,char);
4043             *SvEND(sv) = '\0';
4044             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4045         }
4046         else if (IN_PERL_RUNTIME)
4047             Perl_croak(aTHX_ PL_no_modify);
4048     }
4049 #endif
4050     if (SvROK(sv))
4051         sv_unref_flags(sv, flags);
4052     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4053         sv_unglob(sv);
4054 }
4055
4056 /*
4057 =for apidoc sv_chop
4058
4059 Efficient removal of characters from the beginning of the string buffer.
4060 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4061 the string buffer.  The C<ptr> becomes the first character of the adjusted
4062 string. Uses the "OOK hack".
4063 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4064 refer to the same chunk of data.
4065
4066 =cut
4067 */
4068
4069 void
4070 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4071 {
4072     register STRLEN delta;
4073     if (!ptr || !SvPOKp(sv))
4074         return;
4075     delta = ptr - SvPVX_const(sv);
4076     SV_CHECK_THINKFIRST(sv);
4077     if (SvTYPE(sv) < SVt_PVIV)
4078         sv_upgrade(sv,SVt_PVIV);
4079
4080     if (!SvOOK(sv)) {
4081         if (!SvLEN(sv)) { /* make copy of shared string */
4082             const char *pvx = SvPVX_const(sv);
4083             const STRLEN len = SvCUR(sv);
4084             SvGROW(sv, len + 1);
4085             Move(pvx,SvPVX(sv),len,char);
4086             *SvEND(sv) = '\0';
4087         }
4088         SvIV_set(sv, 0);
4089         /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4090            and we do that anyway inside the SvNIOK_off
4091         */
4092         SvFLAGS(sv) |= SVf_OOK;
4093     }
4094     SvNIOK_off(sv);
4095     SvLEN_set(sv, SvLEN(sv) - delta);
4096     SvCUR_set(sv, SvCUR(sv) - delta);
4097     SvPV_set(sv, SvPVX(sv) + delta);
4098     SvIV_set(sv, SvIVX(sv) + delta);
4099 }
4100
4101 /*
4102 =for apidoc sv_catpvn
4103
4104 Concatenates the string onto the end of the string which is in the SV.  The
4105 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4106 status set, then the bytes appended should be valid UTF-8.
4107 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4108
4109 =for apidoc sv_catpvn_flags
4110
4111 Concatenates the string onto the end of the string which is in the SV.  The
4112 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4113 status set, then the bytes appended should be valid UTF-8.
4114 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4115 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4116 in terms of this function.
4117
4118 =cut
4119 */
4120
4121 void
4122 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4123 {
4124     STRLEN dlen;
4125     const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4126
4127     SvGROW(dsv, dlen + slen + 1);
4128     if (sstr == dstr)
4129         sstr = SvPVX_const(dsv);
4130     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4131     SvCUR_set(dsv, SvCUR(dsv) + slen);
4132     *SvEND(dsv) = '\0';
4133     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4134     SvTAINT(dsv);
4135     if (flags & SV_SMAGIC)
4136         SvSETMAGIC(dsv);
4137 }
4138
4139 /*
4140 =for apidoc sv_catsv
4141
4142 Concatenates the string from SV C<ssv> onto the end of the string in
4143 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4144 not 'set' magic.  See C<sv_catsv_mg>.
4145
4146 =for apidoc sv_catsv_flags
4147
4148 Concatenates the string from SV C<ssv> onto the end of the string in
4149 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4150 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4151 and C<sv_catsv_nomg> are implemented in terms of this function.
4152
4153 =cut */
4154
4155 void
4156 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4157 {
4158     const char *spv;
4159     STRLEN slen;
4160     if (ssv) {
4161         if ((spv = SvPV_const(ssv, slen))) {
4162             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4163                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4164                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4165                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4166                 dsv->sv_flags doesn't have that bit set.
4167                 Andy Dougherty  12 Oct 2001
4168             */
4169             const I32 sutf8 = DO_UTF8(ssv);
4170             I32 dutf8;
4171
4172             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4173                 mg_get(dsv);
4174             dutf8 = DO_UTF8(dsv);
4175
4176             if (dutf8 != sutf8) {
4177                 if (dutf8) {
4178                     /* Not modifying source SV, so taking a temporary copy. */
4179                     SV* csv = sv_2mortal(newSVpvn(spv, slen));
4180
4181                     sv_utf8_upgrade(csv);
4182                     spv = SvPV_const(csv, slen);
4183                 }
4184                 else
4185                     sv_utf8_upgrade_nomg(dsv);
4186             }
4187             sv_catpvn_nomg(dsv, spv, slen);
4188         }
4189     }
4190     if (flags & SV_SMAGIC)
4191         SvSETMAGIC(dsv);
4192 }
4193
4194 /*
4195 =for apidoc sv_catpv
4196
4197 Concatenates the string onto the end of the string which is in the SV.
4198 If the SV has the UTF-8 status set, then the bytes appended should be
4199 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4200
4201 =cut */
4202
4203 void
4204 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4205 {
4206     register STRLEN len;
4207     STRLEN tlen;
4208     char *junk;
4209
4210     if (!ptr)
4211         return;
4212     junk = SvPV_force(sv, tlen);
4213     len = strlen(ptr);
4214     SvGROW(sv, tlen + len + 1);
4215     if (ptr == junk)
4216         ptr = SvPVX_const(sv);
4217     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4218     SvCUR_set(sv, SvCUR(sv) + len);
4219     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4220     SvTAINT(sv);
4221 }
4222
4223 /*
4224 =for apidoc sv_catpv_mg
4225
4226 Like C<sv_catpv>, but also handles 'set' magic.
4227
4228 =cut
4229 */
4230
4231 void
4232 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4233 {
4234     sv_catpv(sv,ptr);
4235     SvSETMAGIC(sv);
4236 }
4237
4238 /*
4239 =for apidoc newSV
4240
4241 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4242 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4243 macro.
4244
4245 =cut
4246 */
4247
4248 SV *
4249 Perl_newSV(pTHX_ STRLEN len)
4250 {
4251     register SV *sv;
4252
4253     new_SV(sv);
4254     if (len) {
4255         sv_upgrade(sv, SVt_PV);
4256         SvGROW(sv, len + 1);
4257     }
4258     return sv;
4259 }
4260 /*
4261 =for apidoc sv_magicext
4262
4263 Adds magic to an SV, upgrading it if necessary. Applies the
4264 supplied vtable and returns a pointer to the magic added.
4265
4266 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4267 In particular, you can add magic to SvREADONLY SVs, and add more than
4268 one instance of the same 'how'.
4269
4270 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4271 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4272 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4273 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4274
4275 (This is now used as a subroutine by C<sv_magic>.)
4276
4277 =cut
4278 */
4279 MAGIC * 
4280 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4281                  const char* name, I32 namlen)
4282 {
4283     MAGIC* mg;
4284
4285     if (SvTYPE(sv) < SVt_PVMG) {
4286         SvUPGRADE(sv, SVt_PVMG);
4287     }
4288     Newxz(mg, 1, MAGIC);
4289     mg->mg_moremagic = SvMAGIC(sv);
4290     SvMAGIC_set(sv, mg);
4291
4292     /* Sometimes a magic contains a reference loop, where the sv and
4293        object refer to each other.  To prevent a reference loop that
4294        would prevent such objects being freed, we look for such loops
4295        and if we find one we avoid incrementing the object refcount.
4296
4297        Note we cannot do this to avoid self-tie loops as intervening RV must
4298        have its REFCNT incremented to keep it in existence.
4299
4300     */
4301     if (!obj || obj == sv ||
4302         how == PERL_MAGIC_arylen ||
4303         how == PERL_MAGIC_qr ||
4304         how == PERL_MAGIC_symtab ||
4305         (SvTYPE(obj) == SVt_PVGV &&
4306             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4307             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4308             GvFORM(obj) == (CV*)sv)))
4309     {
4310         mg->mg_obj = obj;
4311     }
4312     else {
4313         mg->mg_obj = SvREFCNT_inc(obj);
4314         mg->mg_flags |= MGf_REFCOUNTED;
4315     }
4316
4317     /* Normal self-ties simply pass a null object, and instead of
4318        using mg_obj directly, use the SvTIED_obj macro to produce a
4319        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4320        with an RV obj pointing to the glob containing the PVIO.  In
4321        this case, to avoid a reference loop, we need to weaken the
4322        reference.
4323     */
4324
4325     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4326         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4327     {
4328       sv_rvweaken(obj);
4329     }
4330
4331     mg->mg_type = how;
4332     mg->mg_len = namlen;
4333     if (name) {
4334         if (namlen > 0)
4335             mg->mg_ptr = savepvn(name, namlen);
4336         else if (namlen == HEf_SVKEY)
4337             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4338         else
4339             mg->mg_ptr = (char *) name;
4340     }
4341     mg->mg_virtual = vtable;
4342
4343     mg_magical(sv);
4344     if (SvGMAGICAL(sv))
4345         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4346     return mg;
4347 }
4348
4349 /*
4350 =for apidoc sv_magic
4351
4352 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4353 then adds a new magic item of type C<how> to the head of the magic list.
4354
4355 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4356 handling of the C<name> and C<namlen> arguments.
4357
4358 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4359 to add more than one instance of the same 'how'.
4360
4361 =cut
4362 */
4363
4364 void
4365 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4366 {
4367     const MGVTBL *vtable;
4368     MAGIC* mg;
4369
4370 #ifdef PERL_OLD_COPY_ON_WRITE
4371     if (SvIsCOW(sv))
4372         sv_force_normal_flags(sv, 0);
4373 #endif
4374     if (SvREADONLY(sv)) {
4375         if (
4376             /* its okay to attach magic to shared strings; the subsequent
4377              * upgrade to PVMG will unshare the string */
4378             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4379
4380             && IN_PERL_RUNTIME
4381             && how != PERL_MAGIC_regex_global
4382             && how != PERL_MAGIC_bm
4383             && how != PERL_MAGIC_fm
4384             && how != PERL_MAGIC_sv
4385             && how != PERL_MAGIC_backref
4386            )
4387         {
4388             Perl_croak(aTHX_ PL_no_modify);
4389         }
4390     }
4391     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4392         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4393             /* sv_magic() refuses to add a magic of the same 'how' as an
4394                existing one
4395              */
4396             if (how == PERL_MAGIC_taint)
4397                 mg->mg_len |= 1;
4398             return;
4399         }
4400     }
4401
4402     switch (how) {
4403     case PERL_MAGIC_sv:
4404         vtable = &PL_vtbl_sv;
4405         break;
4406     case PERL_MAGIC_overload:
4407         vtable = &PL_vtbl_amagic;
4408         break;
4409     case PERL_MAGIC_overload_elem:
4410         vtable = &PL_vtbl_amagicelem;
4411         break;
4412     case PERL_MAGIC_overload_table:
4413         vtable = &PL_vtbl_ovrld;
4414         break;
4415     case PERL_MAGIC_bm:
4416         vtable = &PL_vtbl_bm;
4417         break;
4418     case PERL_MAGIC_regdata:
4419         vtable = &PL_vtbl_regdata;
4420         break;
4421     case PERL_MAGIC_regdatum:
4422         vtable = &PL_vtbl_regdatum;
4423         break;
4424     case PERL_MAGIC_env:
4425         vtable = &PL_vtbl_env;
4426         break;
4427     case PERL_MAGIC_fm:
4428         vtable = &PL_vtbl_fm;
4429         break;
4430     case PERL_MAGIC_envelem:
4431         vtable = &PL_vtbl_envelem;
4432         break;
4433     case PERL_MAGIC_regex_global:
4434         vtable = &PL_vtbl_mglob;
4435         break;
4436     case PERL_MAGIC_isa:
4437         vtable = &PL_vtbl_isa;
4438         break;
4439     case PERL_MAGIC_isaelem:
4440         vtable = &PL_vtbl_isaelem;
4441         break;
4442     case PERL_MAGIC_nkeys:
4443         vtable = &PL_vtbl_nkeys;
4444         break;
4445     case PERL_MAGIC_dbfile:
4446         vtable = NULL;
4447         break;
4448     case PERL_MAGIC_dbline:
4449         vtable = &PL_vtbl_dbline;
4450         break;
4451 #ifdef USE_LOCALE_COLLATE
4452     case PERL_MAGIC_collxfrm:
4453         vtable = &PL_vtbl_collxfrm;
4454         break;
4455 #endif /* USE_LOCALE_COLLATE */
4456     case PERL_MAGIC_tied:
4457         vtable = &PL_vtbl_pack;
4458         break;
4459     case PERL_MAGIC_tiedelem:
4460     case PERL_MAGIC_tiedscalar:
4461         vtable = &PL_vtbl_packelem;
4462         break;
4463     case PERL_MAGIC_qr:
4464         vtable = &PL_vtbl_regexp;
4465         break;
4466     case PERL_MAGIC_sig:
4467         vtable = &PL_vtbl_sig;
4468         break;
4469     case PERL_MAGIC_sigelem:
4470         vtable = &PL_vtbl_sigelem;
4471         break;
4472     case PERL_MAGIC_taint:
4473         vtable = &PL_vtbl_taint;
4474         break;
4475     case PERL_MAGIC_uvar:
4476         vtable = &PL_vtbl_uvar;
4477         break;
4478     case PERL_MAGIC_vec:
4479         vtable = &PL_vtbl_vec;
4480         break;
4481     case PERL_MAGIC_arylen_p:
4482     case PERL_MAGIC_rhash:
4483     case PERL_MAGIC_symtab:
4484     case PERL_MAGIC_vstring:
4485         vtable = NULL;
4486         break;
4487     case PERL_MAGIC_utf8:
4488         vtable = &PL_vtbl_utf8;
4489         break;
4490     case PERL_MAGIC_substr:
4491         vtable = &PL_vtbl_substr;
4492         break;
4493     case PERL_MAGIC_defelem:
4494         vtable = &PL_vtbl_defelem;
4495         break;
4496     case PERL_MAGIC_glob:
4497         vtable = &PL_vtbl_glob;
4498         break;
4499     case PERL_MAGIC_arylen:
4500         vtable = &PL_vtbl_arylen;
4501         break;
4502     case PERL_MAGIC_pos:
4503         vtable = &PL_vtbl_pos;
4504         break;
4505     case PERL_MAGIC_backref:
4506         vtable = &PL_vtbl_backref;
4507         break;
4508     case PERL_MAGIC_ext:
4509         /* Reserved for use by extensions not perl internals.           */
4510         /* Useful for attaching extension internal data to perl vars.   */
4511         /* Note that multiple extensions may clash if magical scalars   */
4512         /* etc holding private data from one are passed to another.     */
4513         vtable = NULL;
4514         break;
4515     default:
4516         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4517     }
4518
4519     /* Rest of work is done else where */
4520     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4521
4522     switch (how) {
4523     case PERL_MAGIC_taint:
4524         mg->mg_len = 1;
4525         break;
4526     case PERL_MAGIC_ext:
4527     case PERL_MAGIC_dbfile:
4528         SvRMAGICAL_on(sv);
4529         break;
4530     }
4531 }
4532
4533 /*
4534 =for apidoc sv_unmagic
4535
4536 Removes all magic of type C<type> from an SV.
4537
4538 =cut
4539 */
4540
4541 int
4542 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4543 {
4544     MAGIC* mg;
4545     MAGIC** mgp;
4546     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4547         return 0;
4548     mgp = &SvMAGIC(sv);
4549     for (mg = *mgp; mg; mg = *mgp) {
4550         if (mg->mg_type == type) {
4551             const MGVTBL* const vtbl = mg->mg_virtual;
4552             *mgp = mg->mg_moremagic;
4553             if (vtbl && vtbl->svt_free)
4554                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4555             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4556                 if (mg->mg_len > 0)
4557                     Safefree(mg->mg_ptr);
4558                 else if (mg->mg_len == HEf_SVKEY)
4559                     SvREFCNT_dec((SV*)mg->mg_ptr);
4560                 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4561                     Safefree(mg->mg_ptr);
4562             }
4563             if (mg->mg_flags & MGf_REFCOUNTED)
4564                 SvREFCNT_dec(mg->mg_obj);
4565             Safefree(mg);
4566         }
4567         else
4568             mgp = &mg->mg_moremagic;
4569     }
4570     if (!SvMAGIC(sv)) {
4571         SvMAGICAL_off(sv);
4572        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4573     }
4574
4575     return 0;
4576 }
4577
4578 /*
4579 =for apidoc sv_rvweaken
4580
4581 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4582 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4583 push a back-reference to this RV onto the array of backreferences
4584 associated with that magic.
4585
4586 =cut
4587 */
4588
4589 SV *
4590 Perl_sv_rvweaken(pTHX_ SV *sv)
4591 {
4592     SV *tsv;
4593     if (!SvOK(sv))  /* let undefs pass */
4594         return sv;
4595     if (!SvROK(sv))
4596         Perl_croak(aTHX_ "Can't weaken a nonreference");
4597     else if (SvWEAKREF(sv)) {
4598         if (ckWARN(WARN_MISC))
4599             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4600         return sv;
4601     }
4602     tsv = SvRV(sv);
4603     Perl_sv_add_backref(aTHX_ tsv, sv);
4604     SvWEAKREF_on(sv);
4605     SvREFCNT_dec(tsv);
4606     return sv;
4607 }
4608
4609 /* Give tsv backref magic if it hasn't already got it, then push a
4610  * back-reference to sv onto the array associated with the backref magic.
4611  */
4612
4613 void
4614 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4615 {
4616     AV *av;
4617     MAGIC *mg;
4618     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4619         av = (AV*)mg->mg_obj;
4620     else {
4621         av = newAV();
4622         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4623         /* av now has a refcnt of 2, which avoids it getting freed
4624          * before us during global cleanup. The extra ref is removed
4625          * by magic_killbackrefs() when tsv is being freed */
4626     }
4627     if (AvFILLp(av) >= AvMAX(av)) {
4628         av_extend(av, AvFILLp(av)+1);
4629     }
4630     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4631 }
4632
4633 /* delete a back-reference to ourselves from the backref magic associated
4634  * with the SV we point to.
4635  */
4636
4637 STATIC void
4638 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4639 {
4640     AV *av;
4641     SV **svp;
4642     I32 i;
4643     MAGIC *mg = NULL;
4644     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
4645         if (PL_in_clean_all)
4646             return;
4647     }
4648     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4649         Perl_croak(aTHX_ "panic: del_backref");
4650     av = (AV *)mg->mg_obj;
4651     svp = AvARRAY(av);
4652     /* We shouldn't be in here more than once, but for paranoia reasons lets
4653        not assume this.  */
4654     for (i = AvFILLp(av); i >= 0; i--) {
4655         if (svp[i] == sv) {
4656             const SSize_t fill = AvFILLp(av);
4657             if (i != fill) {
4658                 /* We weren't the last entry.
4659                    An unordered list has this property that you can take the
4660                    last element off the end to fill the hole, and it's still
4661                    an unordered list :-)
4662                 */
4663                 svp[i] = svp[fill];
4664             }
4665             svp[fill] = Nullsv;
4666             AvFILLp(av) = fill - 1;
4667         }
4668     }
4669 }
4670
4671 /*