This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The early return for SvIOKp(sv) in sv_2[iu]v_flags is actually code
[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* const 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     }
1682     else if (SvNOKp(sv)) {
1683         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1684          * without also getting a cached IV/UV from it at the same time
1685          * (ie PV->NV conversion should detect loss of accuracy and cache
1686          * IV or UV at same time to avoid this.  NWC */
1687
1688         if (SvTYPE(sv) == SVt_NV)
1689             sv_upgrade(sv, SVt_PVNV);
1690
1691         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1692         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1693            certainly cast into the IV range at IV_MAX, whereas the correct
1694            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1695            cases go to UV */
1696         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1697             SvIV_set(sv, I_V(SvNVX(sv)));
1698             if (SvNVX(sv) == (NV) SvIVX(sv)
1699 #ifndef NV_PRESERVES_UV
1700                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1701                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1702                 /* Don't flag it as "accurately an integer" if the number
1703                    came from a (by definition imprecise) NV operation, and
1704                    we're outside the range of NV integer precision */
1705 #endif
1706                 ) {
1707                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1708                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1709                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1710                                       PTR2UV(sv),
1711                                       SvNVX(sv),
1712                                       SvIVX(sv)));
1713
1714             } else {
1715                 /* IV not precise.  No need to convert from PV, as NV
1716                    conversion would already have cached IV if it detected
1717                    that PV->IV would be better than PV->NV->IV
1718                    flags already correct - don't set public IOK.  */
1719                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1720                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1721                                       PTR2UV(sv),
1722                                       SvNVX(sv),
1723                                       SvIVX(sv)));
1724             }
1725             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1726                but the cast (NV)IV_MIN rounds to a the value less (more
1727                negative) than IV_MIN which happens to be equal to SvNVX ??
1728                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1729                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1730                (NV)UVX == NVX are both true, but the values differ. :-(
1731                Hopefully for 2s complement IV_MIN is something like
1732                0x8000000000000000 which will be exact. NWC */
1733         }
1734         else {
1735             SvUV_set(sv, U_V(SvNVX(sv)));
1736             if (
1737                 (SvNVX(sv) == (NV) SvUVX(sv))
1738 #ifndef  NV_PRESERVES_UV
1739                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1740                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1741                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1742                 /* Don't flag it as "accurately an integer" if the number
1743                    came from a (by definition imprecise) NV operation, and
1744                    we're outside the range of NV integer precision */
1745 #endif
1746                 )
1747                 SvIOK_on(sv);
1748             SvIsUV_on(sv);
1749             DEBUG_c(PerlIO_printf(Perl_debug_log,
1750                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1751                                   PTR2UV(sv),
1752                                   SvUVX(sv),
1753                                   SvUVX(sv)));
1754         }
1755     }
1756     else if (SvPOKp(sv) && SvLEN(sv)) {
1757         UV value;
1758         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1759         /* We want to avoid a possible problem when we cache an IV which
1760            may be later translated to an NV, and the resulting NV is not
1761            the same as the direct translation of the initial string
1762            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1763            be careful to ensure that the value with the .456 is around if the
1764            NV value is requested in the future).
1765         
1766            This means that if we cache such an IV, we need to cache the
1767            NV as well.  Moreover, we trade speed for space, and do not
1768            cache the NV if we are sure it's not needed.
1769          */
1770
1771         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
1772         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1773              == IS_NUMBER_IN_UV) {
1774             /* It's definitely an integer, only upgrade to PVIV */
1775             if (SvTYPE(sv) < SVt_PVIV)
1776                 sv_upgrade(sv, SVt_PVIV);
1777             (void)SvIOK_on(sv);
1778         } else if (SvTYPE(sv) < SVt_PVNV)
1779             sv_upgrade(sv, SVt_PVNV);
1780
1781         /* If NV preserves UV then we only use the UV value if we know that
1782            we aren't going to call atof() below. If NVs don't preserve UVs
1783            then the value returned may have more precision than atof() will
1784            return, even though value isn't perfectly accurate.  */
1785         if ((numtype & (IS_NUMBER_IN_UV
1786 #ifdef NV_PRESERVES_UV
1787                         | IS_NUMBER_NOT_INT
1788 #endif
1789             )) == IS_NUMBER_IN_UV) {
1790             /* This won't turn off the public IOK flag if it was set above  */
1791             (void)SvIOKp_on(sv);
1792
1793             if (!(numtype & IS_NUMBER_NEG)) {
1794                 /* positive */;
1795                 if (value <= (UV)IV_MAX) {
1796                     SvIV_set(sv, (IV)value);
1797                 } else {
1798                     SvUV_set(sv, value);
1799                     SvIsUV_on(sv);
1800                 }
1801             } else {
1802                 /* 2s complement assumption  */
1803                 if (value <= (UV)IV_MIN) {
1804                     SvIV_set(sv, -(IV)value);
1805                 } else {
1806                     /* Too negative for an IV.  This is a double upgrade, but
1807                        I'm assuming it will be rare.  */
1808                     if (SvTYPE(sv) < SVt_PVNV)
1809                         sv_upgrade(sv, SVt_PVNV);
1810                     SvNOK_on(sv);
1811                     SvIOK_off(sv);
1812                     SvIOKp_on(sv);
1813                     SvNV_set(sv, -(NV)value);
1814                     SvIV_set(sv, IV_MIN);
1815                 }
1816             }
1817         }
1818         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1819            will be in the previous block to set the IV slot, and the next
1820            block to set the NV slot.  So no else here.  */
1821         
1822         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1823             != IS_NUMBER_IN_UV) {
1824             /* It wasn't an (integer that doesn't overflow the UV). */
1825             SvNV_set(sv, Atof(SvPVX_const(sv)));
1826
1827             if (! numtype && ckWARN(WARN_NUMERIC))
1828                 not_a_number(sv);
1829
1830 #if defined(USE_LONG_DOUBLE)
1831             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1832                                   PTR2UV(sv), SvNVX(sv)));
1833 #else
1834             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
1835                                   PTR2UV(sv), SvNVX(sv)));
1836 #endif
1837
1838
1839 #ifdef NV_PRESERVES_UV
1840             (void)SvIOKp_on(sv);
1841             (void)SvNOK_on(sv);
1842             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1843                 SvIV_set(sv, I_V(SvNVX(sv)));
1844                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1845                     SvIOK_on(sv);
1846                 } else {
1847                     /* Integer is imprecise. NOK, IOKp */
1848                 }
1849                 /* UV will not work better than IV */
1850             } else {
1851                 if (SvNVX(sv) > (NV)UV_MAX) {
1852                     SvIsUV_on(sv);
1853                     /* Integer is inaccurate. NOK, IOKp, is UV */
1854                     SvUV_set(sv, UV_MAX);
1855                     SvIsUV_on(sv);
1856                 } else {
1857                     SvUV_set(sv, U_V(SvNVX(sv)));
1858                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1859                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1860                         SvIOK_on(sv);
1861                         SvIsUV_on(sv);
1862                     } else {
1863                         /* Integer is imprecise. NOK, IOKp, is UV */
1864                         SvIsUV_on(sv);
1865                     }
1866                 }
1867             }
1868 #else /* NV_PRESERVES_UV */
1869             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1870                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1871                 /* The IV slot will have been set from value returned by
1872                    grok_number above.  The NV slot has just been set using
1873                    Atof.  */
1874                 SvNOK_on(sv);
1875                 assert (SvIOKp(sv));
1876             } else {
1877                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1878                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1879                     /* Small enough to preserve all bits. */
1880                     (void)SvIOKp_on(sv);
1881                     SvNOK_on(sv);
1882                     SvIV_set(sv, I_V(SvNVX(sv)));
1883                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
1884                         SvIOK_on(sv);
1885                     /* Assumption: first non-preserved integer is < IV_MAX,
1886                        this NV is in the preserved range, therefore: */
1887                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1888                           < (UV)IV_MAX)) {
1889                         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);
1890                     }
1891                 } else {
1892                     /* IN_UV NOT_INT
1893                          0      0       already failed to read UV.
1894                          0      1       already failed to read UV.
1895                          1      0       you won't get here in this case. IV/UV
1896                                         slot set, public IOK, Atof() unneeded.
1897                          1      1       already read UV.
1898                        so there's no point in sv_2iuv_non_preserve() attempting
1899                        to use atol, strtol, strtoul etc.  */
1900                     sv_2iuv_non_preserve (sv, numtype);
1901                 }
1902             }
1903 #endif /* NV_PRESERVES_UV */
1904         }
1905     } else  {
1906         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
1907             report_uninit(sv);
1908         if (SvTYPE(sv) < SVt_IV)
1909             /* Typically the caller expects that sv_any is not NULL now.  */
1910             sv_upgrade(sv, SVt_IV);
1911         return 0;
1912     }
1913     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1914         PTR2UV(sv),SvIVX(sv)));
1915     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1916 }
1917
1918 /*
1919 =for apidoc sv_2uv_flags
1920
1921 Return the unsigned integer value of an SV, doing any necessary string
1922 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
1923 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
1924
1925 =cut
1926 */
1927
1928 UV
1929 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
1930 {
1931     if (!sv)
1932         return 0;
1933     if (SvGMAGICAL(sv)) {
1934         if (flags & SV_GMAGIC)
1935             mg_get(sv);
1936         if (SvIOKp(sv))
1937             return SvUVX(sv);
1938         if (SvNOKp(sv))
1939             return U_V(SvNVX(sv));
1940         if (SvPOKp(sv) && SvLEN(sv))
1941             return asUV(sv);
1942         if (!SvROK(sv)) {
1943             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1944                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1945                     report_uninit(sv);
1946             }
1947             return 0;
1948         }
1949     }
1950     if (SvTHINKFIRST(sv)) {
1951         if (SvROK(sv)) {
1952           SV* tmpstr;
1953           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1954                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
1955               return SvUV(tmpstr);
1956           return PTR2UV(SvRV(sv));
1957         }
1958         if (SvIsCOW(sv)) {
1959             sv_force_normal_flags(sv, 0);
1960         }
1961         if (SvREADONLY(sv) && !SvOK(sv)) {
1962             if (ckWARN(WARN_UNINITIALIZED))
1963                 report_uninit(sv);
1964             return 0;
1965         }
1966     }
1967     if (SvIOKp(sv)) {
1968     }
1969     else if (SvNOKp(sv)) {
1970         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1971          * without also getting a cached IV/UV from it at the same time
1972          * (ie PV->NV conversion should detect loss of accuracy and cache
1973          * IV or UV at same time to avoid this. */
1974         /* IV-over-UV optimisation - choose to cache IV if possible */
1975
1976         if (SvTYPE(sv) == SVt_NV)
1977             sv_upgrade(sv, SVt_PVNV);
1978
1979         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1980         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1981             SvIV_set(sv, I_V(SvNVX(sv)));
1982             if (SvNVX(sv) == (NV) SvIVX(sv)
1983 #ifndef NV_PRESERVES_UV
1984                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1985                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1986                 /* Don't flag it as "accurately an integer" if the number
1987                    came from a (by definition imprecise) NV operation, and
1988                    we're outside the range of NV integer precision */
1989 #endif
1990                 ) {
1991                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1992                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1993                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
1994                                       PTR2UV(sv),
1995                                       SvNVX(sv),
1996                                       SvIVX(sv)));
1997
1998             } else {
1999                 /* IV not precise.  No need to convert from PV, as NV
2000                    conversion would already have cached IV if it detected
2001                    that PV->IV would be better than PV->NV->IV
2002                    flags already correct - don't set public IOK.  */
2003                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2004                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2005                                       PTR2UV(sv),
2006                                       SvNVX(sv),
2007                                       SvIVX(sv)));
2008             }
2009             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2010                but the cast (NV)IV_MIN rounds to a the value less (more
2011                negative) than IV_MIN which happens to be equal to SvNVX ??
2012                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2013                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2014                (NV)UVX == NVX are both true, but the values differ. :-(
2015                Hopefully for 2s complement IV_MIN is something like
2016                0x8000000000000000 which will be exact. NWC */
2017         }
2018         else {
2019             SvUV_set(sv, U_V(SvNVX(sv)));
2020             if (
2021                 (SvNVX(sv) == (NV) SvUVX(sv))
2022 #ifndef  NV_PRESERVES_UV
2023                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2024                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2025                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2026                 /* Don't flag it as "accurately an integer" if the number
2027                    came from a (by definition imprecise) NV operation, and
2028                    we're outside the range of NV integer precision */
2029 #endif
2030                 )
2031                 SvIOK_on(sv);
2032             SvIsUV_on(sv);
2033             DEBUG_c(PerlIO_printf(Perl_debug_log,
2034                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2035                                   PTR2UV(sv),
2036                                   SvUVX(sv),
2037                                   SvUVX(sv)));
2038         }
2039     }
2040     else if (SvPOKp(sv) && SvLEN(sv)) {
2041         UV value;
2042         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2043
2044         /* We want to avoid a possible problem when we cache a UV which
2045            may be later translated to an NV, and the resulting NV is not
2046            the translation of the initial data.
2047         
2048            This means that if we cache such a UV, we need to cache the
2049            NV as well.  Moreover, we trade speed for space, and do not
2050            cache the NV if not needed.
2051          */
2052
2053         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2054         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2055              == IS_NUMBER_IN_UV) {
2056             /* It's definitely an integer, only upgrade to PVIV */
2057             if (SvTYPE(sv) < SVt_PVIV)
2058                 sv_upgrade(sv, SVt_PVIV);
2059             (void)SvIOK_on(sv);
2060         } else if (SvTYPE(sv) < SVt_PVNV)
2061             sv_upgrade(sv, SVt_PVNV);
2062
2063         /* If NV preserves UV then we only use the UV value if we know that
2064            we aren't going to call atof() below. If NVs don't preserve UVs
2065            then the value returned may have more precision than atof() will
2066            return, even though it isn't accurate.  */
2067         if ((numtype & (IS_NUMBER_IN_UV
2068 #ifdef NV_PRESERVES_UV
2069                         | IS_NUMBER_NOT_INT
2070 #endif
2071             )) == IS_NUMBER_IN_UV) {
2072             /* This won't turn off the public IOK flag if it was set above  */
2073             (void)SvIOKp_on(sv);
2074
2075             if (!(numtype & IS_NUMBER_NEG)) {
2076                 /* positive */;
2077                 if (value <= (UV)IV_MAX) {
2078                     SvIV_set(sv, (IV)value);
2079                 } else {
2080                     /* it didn't overflow, and it was positive. */
2081                     SvUV_set(sv, value);
2082                     SvIsUV_on(sv);
2083                 }
2084             } else {
2085                 /* 2s complement assumption  */
2086                 if (value <= (UV)IV_MIN) {
2087                     SvIV_set(sv, -(IV)value);
2088                 } else {
2089                     /* Too negative for an IV.  This is a double upgrade, but
2090                        I'm assuming it will be rare.  */
2091                     if (SvTYPE(sv) < SVt_PVNV)
2092                         sv_upgrade(sv, SVt_PVNV);
2093                     SvNOK_on(sv);
2094                     SvIOK_off(sv);
2095                     SvIOKp_on(sv);
2096                     SvNV_set(sv, -(NV)value);
2097                     SvIV_set(sv, IV_MIN);
2098                 }
2099             }
2100         }
2101         
2102         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2103             != IS_NUMBER_IN_UV) {
2104             /* It wasn't an integer, or it overflowed the UV. */
2105             SvNV_set(sv, Atof(SvPVX_const(sv)));
2106
2107             if (! numtype && ckWARN(WARN_NUMERIC))
2108                     not_a_number(sv);
2109
2110 #if defined(USE_LONG_DOUBLE)
2111             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2112                                   PTR2UV(sv), SvNVX(sv)));
2113 #else
2114             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2115                                   PTR2UV(sv), SvNVX(sv)));
2116 #endif
2117
2118 #ifdef NV_PRESERVES_UV
2119             (void)SvIOKp_on(sv);
2120             (void)SvNOK_on(sv);
2121             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2122                 SvIV_set(sv, I_V(SvNVX(sv)));
2123                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2124                     SvIOK_on(sv);
2125                 } else {
2126                     /* Integer is imprecise. NOK, IOKp */
2127                 }
2128                 /* UV will not work better than IV */
2129             } else {
2130                 if (SvNVX(sv) > (NV)UV_MAX) {
2131                     SvIsUV_on(sv);
2132                     /* Integer is inaccurate. NOK, IOKp, is UV */
2133                     SvUV_set(sv, UV_MAX);
2134                     SvIsUV_on(sv);
2135                 } else {
2136                     SvUV_set(sv, U_V(SvNVX(sv)));
2137                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2138                        NV preservse UV so can do correct comparison.  */
2139                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2140                         SvIOK_on(sv);
2141                         SvIsUV_on(sv);
2142                     } else {
2143                         /* Integer is imprecise. NOK, IOKp, is UV */
2144                         SvIsUV_on(sv);
2145                     }
2146                 }
2147             }
2148 #else /* NV_PRESERVES_UV */
2149             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2150                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2151                 /* The UV slot will have been set from value returned by
2152                    grok_number above.  The NV slot has just been set using
2153                    Atof.  */
2154                 SvNOK_on(sv);
2155                 assert (SvIOKp(sv));
2156             } else {
2157                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2158                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2159                     /* Small enough to preserve all bits. */
2160                     (void)SvIOKp_on(sv);
2161                     SvNOK_on(sv);
2162                     SvIV_set(sv, I_V(SvNVX(sv)));
2163                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2164                         SvIOK_on(sv);
2165                     /* Assumption: first non-preserved integer is < IV_MAX,
2166                        this NV is in the preserved range, therefore: */
2167                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2168                           < (UV)IV_MAX)) {
2169                         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);
2170                     }
2171                 } else
2172                     sv_2iuv_non_preserve (sv, numtype);
2173             }
2174 #endif /* NV_PRESERVES_UV */
2175         }
2176     }
2177     else  {
2178         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2179             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2180                 report_uninit(sv);
2181         }
2182         if (SvTYPE(sv) < SVt_IV)
2183             /* Typically the caller expects that sv_any is not NULL now.  */
2184             sv_upgrade(sv, SVt_IV);
2185         return 0;
2186     }
2187
2188     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2189                           PTR2UV(sv),SvUVX(sv)));
2190     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2191 }
2192
2193 /*
2194 =for apidoc sv_2nv
2195
2196 Return the num value of an SV, doing any necessary string or integer
2197 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2198 macros.
2199
2200 =cut
2201 */
2202
2203 NV
2204 Perl_sv_2nv(pTHX_ register SV *sv)
2205 {
2206     if (!sv)
2207         return 0.0;
2208     if (SvGMAGICAL(sv)) {
2209         mg_get(sv);
2210         if (SvNOKp(sv))
2211             return SvNVX(sv);
2212         if (SvPOKp(sv) && SvLEN(sv)) {
2213             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2214                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2215                 not_a_number(sv);
2216             return Atof(SvPVX_const(sv));
2217         }
2218         if (SvIOKp(sv)) {
2219             if (SvIsUV(sv))
2220                 return (NV)SvUVX(sv);
2221             else
2222                 return (NV)SvIVX(sv);
2223         }       
2224         if (!SvROK(sv)) {
2225             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2226                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2227                     report_uninit(sv);
2228             }
2229             return (NV)0;
2230         }
2231     }
2232     if (SvTHINKFIRST(sv)) {
2233         if (SvROK(sv)) {
2234           SV* tmpstr;
2235           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2236                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2237               return SvNV(tmpstr);
2238           return PTR2NV(SvRV(sv));
2239         }
2240         if (SvIsCOW(sv)) {
2241             sv_force_normal_flags(sv, 0);
2242         }
2243         if (SvREADONLY(sv) && !SvOK(sv)) {
2244             if (ckWARN(WARN_UNINITIALIZED))
2245                 report_uninit(sv);
2246             return 0.0;
2247         }
2248     }
2249     if (SvTYPE(sv) < SVt_NV) {
2250         if (SvTYPE(sv) == SVt_IV)
2251             sv_upgrade(sv, SVt_PVNV);
2252         else
2253             sv_upgrade(sv, SVt_NV);
2254 #ifdef USE_LONG_DOUBLE
2255         DEBUG_c({
2256             STORE_NUMERIC_LOCAL_SET_STANDARD();
2257             PerlIO_printf(Perl_debug_log,
2258                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2259                           PTR2UV(sv), SvNVX(sv));
2260             RESTORE_NUMERIC_LOCAL();
2261         });
2262 #else
2263         DEBUG_c({
2264             STORE_NUMERIC_LOCAL_SET_STANDARD();
2265             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2266                           PTR2UV(sv), SvNVX(sv));
2267             RESTORE_NUMERIC_LOCAL();
2268         });
2269 #endif
2270     }
2271     else if (SvTYPE(sv) < SVt_PVNV)
2272         sv_upgrade(sv, SVt_PVNV);
2273     if (SvNOKp(sv)) {
2274         return SvNVX(sv);
2275     }
2276     if (SvIOKp(sv)) {
2277         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2278 #ifdef NV_PRESERVES_UV
2279         SvNOK_on(sv);
2280 #else
2281         /* Only set the public NV OK flag if this NV preserves the IV  */
2282         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2283         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2284                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2285             SvNOK_on(sv);
2286         else
2287             SvNOKp_on(sv);
2288 #endif
2289     }
2290     else if (SvPOKp(sv) && SvLEN(sv)) {
2291         UV value;
2292         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2293         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2294             not_a_number(sv);
2295 #ifdef NV_PRESERVES_UV
2296         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2297             == IS_NUMBER_IN_UV) {
2298             /* It's definitely an integer */
2299             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2300         } else
2301             SvNV_set(sv, Atof(SvPVX_const(sv)));
2302         SvNOK_on(sv);
2303 #else
2304         SvNV_set(sv, Atof(SvPVX_const(sv)));
2305         /* Only set the public NV OK flag if this NV preserves the value in
2306            the PV at least as well as an IV/UV would.
2307            Not sure how to do this 100% reliably. */
2308         /* if that shift count is out of range then Configure's test is
2309            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2310            UV_BITS */
2311         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2312             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2313             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2314         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2315             /* Can't use strtol etc to convert this string, so don't try.
2316                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2317             SvNOK_on(sv);
2318         } else {
2319             /* value has been set.  It may not be precise.  */
2320             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2321                 /* 2s complement assumption for (UV)IV_MIN  */
2322                 SvNOK_on(sv); /* Integer is too negative.  */
2323             } else {
2324                 SvNOKp_on(sv);
2325                 SvIOKp_on(sv);
2326
2327                 if (numtype & IS_NUMBER_NEG) {
2328                     SvIV_set(sv, -(IV)value);
2329                 } else if (value <= (UV)IV_MAX) {
2330                     SvIV_set(sv, (IV)value);
2331                 } else {
2332                     SvUV_set(sv, value);
2333                     SvIsUV_on(sv);
2334                 }
2335
2336                 if (numtype & IS_NUMBER_NOT_INT) {
2337                     /* I believe that even if the original PV had decimals,
2338                        they are lost beyond the limit of the FP precision.
2339                        However, neither is canonical, so both only get p
2340                        flags.  NWC, 2000/11/25 */
2341                     /* Both already have p flags, so do nothing */
2342                 } else {
2343                     const NV nv = SvNVX(sv);
2344                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2345                         if (SvIVX(sv) == I_V(nv)) {
2346                             SvNOK_on(sv);
2347                             SvIOK_on(sv);
2348                         } else {
2349                             SvIOK_on(sv);
2350                             /* It had no "." so it must be integer.  */
2351                         }
2352                     } else {
2353                         /* between IV_MAX and NV(UV_MAX).
2354                            Could be slightly > UV_MAX */
2355
2356                         if (numtype & IS_NUMBER_NOT_INT) {
2357                             /* UV and NV both imprecise.  */
2358                         } else {
2359                             const UV nv_as_uv = U_V(nv);
2360
2361                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2362                                 SvNOK_on(sv);
2363                                 SvIOK_on(sv);
2364                             } else {
2365                                 SvIOK_on(sv);
2366                             }
2367                         }
2368                     }
2369                 }
2370             }
2371         }
2372 #endif /* NV_PRESERVES_UV */
2373     }
2374     else  {
2375         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2376             report_uninit(sv);
2377         if (SvTYPE(sv) < SVt_NV)
2378             /* Typically the caller expects that sv_any is not NULL now.  */
2379             /* XXX Ilya implies that this is a bug in callers that assume this
2380                and ideally should be fixed.  */
2381             sv_upgrade(sv, SVt_NV);
2382         return 0.0;
2383     }
2384 #if defined(USE_LONG_DOUBLE)
2385     DEBUG_c({
2386         STORE_NUMERIC_LOCAL_SET_STANDARD();
2387         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2388                       PTR2UV(sv), SvNVX(sv));
2389         RESTORE_NUMERIC_LOCAL();
2390     });
2391 #else
2392     DEBUG_c({
2393         STORE_NUMERIC_LOCAL_SET_STANDARD();
2394         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2395                       PTR2UV(sv), SvNVX(sv));
2396         RESTORE_NUMERIC_LOCAL();
2397     });
2398 #endif
2399     return SvNVX(sv);
2400 }
2401
2402 /* asIV(): extract an integer from the string value of an SV.
2403  * Caller must validate PVX  */
2404
2405 STATIC IV
2406 S_asIV(pTHX_ SV *sv)
2407 {
2408     UV value;
2409     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2410
2411     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2412         == IS_NUMBER_IN_UV) {
2413         /* It's definitely an integer */
2414         if (numtype & IS_NUMBER_NEG) {
2415             if (value < (UV)IV_MIN)
2416                 return -(IV)value;
2417         } else {
2418             if (value < (UV)IV_MAX)
2419                 return (IV)value;
2420         }
2421     }
2422     if (!numtype) {
2423         if (ckWARN(WARN_NUMERIC))
2424             not_a_number(sv);
2425     }
2426     return I_V(Atof(SvPVX_const(sv)));
2427 }
2428
2429 /* asUV(): extract an unsigned integer from the string value of an SV
2430  * Caller must validate PVX  */
2431
2432 STATIC UV
2433 S_asUV(pTHX_ SV *sv)
2434 {
2435     UV value;
2436     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2437
2438     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2439         == IS_NUMBER_IN_UV) {
2440         /* It's definitely an integer */
2441         if (!(numtype & IS_NUMBER_NEG))
2442             return value;
2443     }
2444     if (!numtype) {
2445         if (ckWARN(WARN_NUMERIC))
2446             not_a_number(sv);
2447     }
2448     return U_V(Atof(SvPVX_const(sv)));
2449 }
2450
2451 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2452  * UV as a string towards the end of buf, and return pointers to start and
2453  * end of it.
2454  *
2455  * We assume that buf is at least TYPE_CHARS(UV) long.
2456  */
2457
2458 static char *
2459 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2460 {
2461     char *ptr = buf + TYPE_CHARS(UV);
2462     char * const ebuf = ptr;
2463     int sign;
2464
2465     if (is_uv)
2466         sign = 0;
2467     else if (iv >= 0) {
2468         uv = iv;
2469         sign = 0;
2470     } else {
2471         uv = -iv;
2472         sign = 1;
2473     }
2474     do {
2475         *--ptr = '0' + (char)(uv % 10);
2476     } while (uv /= 10);
2477     if (sign)
2478         *--ptr = '-';
2479     *peob = ebuf;
2480     return ptr;
2481 }
2482
2483 /*
2484 =for apidoc sv_2pv_flags
2485
2486 Returns a pointer to the string value of an SV, and sets *lp to its length.
2487 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2488 if necessary.
2489 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2490 usually end up here too.
2491
2492 =cut
2493 */
2494
2495 char *
2496 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2497 {
2498     register char *s;
2499     int olderrno;
2500
2501     if (!sv) {
2502         if (lp)
2503             *lp = 0;
2504         return (char *)"";
2505     }
2506     if (SvGMAGICAL(sv)) {
2507         if (flags & SV_GMAGIC)
2508             mg_get(sv);
2509         if (SvPOKp(sv)) {
2510             if (lp)
2511                 *lp = SvCUR(sv);
2512             if (flags & SV_MUTABLE_RETURN)
2513                 return SvPVX_mutable(sv);
2514             if (flags & SV_CONST_RETURN)
2515                 return (char *)SvPVX_const(sv);
2516             return SvPVX(sv);
2517         }
2518         if (SvIOKp(sv) || SvNOKp(sv)) {
2519             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2520             STRLEN len;
2521
2522             if (SvIOKp(sv)) {
2523                 len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
2524                     : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
2525             } else {
2526                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2527                 len = strlen(tbuf);
2528             }
2529             if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2530                 /* Sneaky stuff here */
2531                 SV *tsv = newSVpvn(tbuf, len);
2532
2533                 sv_2mortal(tsv);
2534                 if (lp)
2535                     *lp = SvCUR(tsv);
2536                 return SvPVX(tsv);
2537             }
2538             else {
2539                 dVAR;
2540
2541 #ifdef FIXNEGATIVEZERO
2542                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2543                     tbuf[0] = '0';
2544                     tbuf[1] = 0;
2545                     len = 1;
2546                 }
2547 #endif
2548                 SvUPGRADE(sv, SVt_PV);
2549                 if (lp)
2550                     *lp = len;
2551                 s = SvGROW_mutable(sv, len + 1);
2552                 SvCUR_set(sv, len);
2553                 SvPOKp_on(sv);
2554                 return memcpy(s, tbuf, len + 1);
2555             }
2556         }
2557         if (!SvROK(sv)) {
2558             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2559                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2560                     report_uninit(sv);
2561             }
2562             if (lp)
2563                 *lp = 0;
2564             return (char *)"";
2565         }
2566     }
2567     if (SvTHINKFIRST(sv)) {
2568         if (SvROK(sv)) {
2569             SV* tmpstr;
2570
2571             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2572                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2573                 /* Unwrap this:  */
2574                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
2575
2576                 char *pv;
2577                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2578                     if (flags & SV_CONST_RETURN) {
2579                         pv = (char *) SvPVX_const(tmpstr);
2580                     } else {
2581                         pv = (flags & SV_MUTABLE_RETURN)
2582                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2583                     }
2584                     if (lp)
2585                         *lp = SvCUR(tmpstr);
2586                 } else {
2587                     pv = sv_2pv_flags(tmpstr, lp, flags);
2588                 }
2589                 if (SvUTF8(tmpstr))
2590                     SvUTF8_on(sv);
2591                 else
2592                     SvUTF8_off(sv);
2593                 return pv;
2594             } else {
2595                 SV *tsv;
2596                 MAGIC *mg;
2597                 const SV *const referent = (SV*)SvRV(sv);
2598
2599                 if (!referent) {
2600                     tsv = sv_2mortal(newSVpvn("NULLREF", 7));
2601                 } else if (SvTYPE(referent) == SVt_PVMG
2602                            && ((SvFLAGS(referent) &
2603                                 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2604                                == (SVs_OBJECT|SVs_SMG))
2605                            && (mg = mg_find(referent, PERL_MAGIC_qr))) {
2606                     const regexp *re = (regexp *)mg->mg_obj;
2607
2608                     if (!mg->mg_ptr) {
2609                         const char *fptr = "msix";
2610                         char reflags[6];
2611                         char ch;
2612                         int left = 0;
2613                         int right = 4;
2614                         char need_newline = 0;
2615                         U16 reganch =
2616                             (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2617
2618                         while((ch = *fptr++)) {
2619                             if(reganch & 1) {
2620                                 reflags[left++] = ch;
2621                             }
2622                             else {
2623                                 reflags[right--] = ch;
2624                             }
2625                             reganch >>= 1;
2626                         }
2627                         if(left != 4) {
2628                             reflags[left] = '-';
2629                             left = 5;
2630                         }
2631
2632                         mg->mg_len = re->prelen + 4 + left;
2633                         /*
2634                          * If /x was used, we have to worry about a regex
2635                          * ending with a comment later being embedded
2636                          * within another regex. If so, we don't want this
2637                          * regex's "commentization" to leak out to the
2638                          * right part of the enclosing regex, we must cap
2639                          * it with a newline.
2640                          *
2641                          * So, if /x was used, we scan backwards from the
2642                          * end of the regex. If we find a '#' before we
2643                          * find a newline, we need to add a newline
2644                          * ourself. If we find a '\n' first (or if we
2645                          * don't find '#' or '\n'), we don't need to add
2646                          * anything.  -jfriedl
2647                          */
2648                         if (PMf_EXTENDED & re->reganch) {
2649                             const char *endptr = re->precomp + re->prelen;
2650                             while (endptr >= re->precomp) {
2651                                 const char c = *(endptr--);
2652                                 if (c == '\n')
2653                                     break; /* don't need another */
2654                                 if (c == '#') {
2655                                     /* we end while in a comment, so we
2656                                        need a newline */
2657                                     mg->mg_len++; /* save space for it */
2658                                     need_newline = 1; /* note to add it */
2659                                     break;
2660                                 }
2661                             }
2662                         }
2663
2664                         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2665                         mg->mg_ptr[0] = '(';
2666                         mg->mg_ptr[1] = '?';
2667                         Copy(reflags, mg->mg_ptr+2, left, char);
2668                         *(mg->mg_ptr+left+2) = ':';
2669                         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2670                         if (need_newline)
2671                             mg->mg_ptr[mg->mg_len - 2] = '\n';
2672                         mg->mg_ptr[mg->mg_len - 1] = ')';
2673                         mg->mg_ptr[mg->mg_len] = 0;
2674                     }
2675                     PL_reginterp_cnt += re->program[0].next_off;
2676
2677                     if (re->reganch & ROPT_UTF8)
2678                         SvUTF8_on(sv);
2679                     else
2680                         SvUTF8_off(sv);
2681                     if (lp)
2682                         *lp = mg->mg_len;
2683                     return mg->mg_ptr;
2684                 } else {
2685                     const char *const typestr = sv_reftype(referent, 0);
2686
2687                     tsv = sv_newmortal();
2688                     if (SvOBJECT(referent)) {
2689                         const char *const name = HvNAME_get(SvSTASH(referent));
2690                         Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2691                                        name ? name : "__ANON__" , typestr,
2692                                        PTR2UV(referent));
2693                     }
2694                     else
2695                         Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
2696                                        PTR2UV(referent));
2697                 }
2698                 if (lp)
2699                     *lp = SvCUR(tsv);
2700                 return SvPVX(tsv);
2701             }
2702         }
2703         if (SvREADONLY(sv) && !SvOK(sv)) {
2704             if (ckWARN(WARN_UNINITIALIZED))
2705                 report_uninit(sv);
2706             if (lp)
2707                 *lp = 0;
2708             return (char *)"";
2709         }
2710     }
2711     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2712         /* I'm assuming that if both IV and NV are equally valid then
2713            converting the IV is going to be more efficient */
2714         const U32 isIOK = SvIOK(sv);
2715         const U32 isUIOK = SvIsUV(sv);
2716         char buf[TYPE_CHARS(UV)];
2717         char *ebuf, *ptr;
2718
2719         if (SvTYPE(sv) < SVt_PVIV)
2720             sv_upgrade(sv, SVt_PVIV);
2721         if (isUIOK)
2722             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2723         else
2724             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2725         /* inlined from sv_setpvn */
2726         SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2727         Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2728         SvCUR_set(sv, ebuf - ptr);
2729         s = SvEND(sv);
2730         *s = '\0';
2731         if (isIOK)
2732             SvIOK_on(sv);
2733         else
2734             SvIOKp_on(sv);
2735         if (isUIOK)
2736             SvIsUV_on(sv);
2737     }
2738     else if (SvNOKp(sv)) {
2739         if (SvTYPE(sv) < SVt_PVNV)
2740             sv_upgrade(sv, SVt_PVNV);
2741         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2742         s = SvGROW_mutable(sv, NV_DIG + 20);
2743         olderrno = errno;       /* some Xenix systems wipe out errno here */
2744 #ifdef apollo
2745         if (SvNVX(sv) == 0.0)
2746             (void)strcpy(s,"0");
2747         else
2748 #endif /*apollo*/
2749         {
2750             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2751         }
2752         errno = olderrno;
2753 #ifdef FIXNEGATIVEZERO
2754         if (*s == '-' && s[1] == '0' && !s[2])
2755             strcpy(s,"0");
2756 #endif
2757         while (*s) s++;
2758 #ifdef hcx
2759         if (s[-1] == '.')
2760             *--s = '\0';
2761 #endif
2762     }
2763     else {
2764         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2765             report_uninit(sv);
2766         if (lp)
2767         *lp = 0;
2768         if (SvTYPE(sv) < SVt_PV)
2769             /* Typically the caller expects that sv_any is not NULL now.  */
2770             sv_upgrade(sv, SVt_PV);
2771         return (char *)"";
2772     }
2773     {
2774         const STRLEN len = s - SvPVX_const(sv);
2775         if (lp) 
2776             *lp = len;
2777         SvCUR_set(sv, len);
2778     }
2779     SvPOK_on(sv);
2780     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2781                           PTR2UV(sv),SvPVX_const(sv)));
2782     if (flags & SV_CONST_RETURN)
2783         return (char *)SvPVX_const(sv);
2784     if (flags & SV_MUTABLE_RETURN)
2785         return SvPVX_mutable(sv);
2786     return SvPVX(sv);
2787 }
2788
2789 /*
2790 =for apidoc sv_copypv
2791
2792 Copies a stringified representation of the source SV into the
2793 destination SV.  Automatically performs any necessary mg_get and
2794 coercion of numeric values into strings.  Guaranteed to preserve
2795 UTF-8 flag even from overloaded objects.  Similar in nature to
2796 sv_2pv[_flags] but operates directly on an SV instead of just the
2797 string.  Mostly uses sv_2pv_flags to do its work, except when that
2798 would lose the UTF-8'ness of the PV.
2799
2800 =cut
2801 */
2802
2803 void
2804 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2805 {
2806     STRLEN len;
2807     const char * const s = SvPV_const(ssv,len);
2808     sv_setpvn(dsv,s,len);
2809     if (SvUTF8(ssv))
2810         SvUTF8_on(dsv);
2811     else
2812         SvUTF8_off(dsv);
2813 }
2814
2815 /*
2816 =for apidoc sv_2pvbyte
2817
2818 Return a pointer to the byte-encoded representation of the SV, and set *lp
2819 to its length.  May cause the SV to be downgraded from UTF-8 as a
2820 side-effect.
2821
2822 Usually accessed via the C<SvPVbyte> macro.
2823
2824 =cut
2825 */
2826
2827 char *
2828 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2829 {
2830     sv_utf8_downgrade(sv,0);
2831     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2832 }
2833
2834 /*
2835 =for apidoc sv_2pvutf8
2836
2837 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2838 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
2839
2840 Usually accessed via the C<SvPVutf8> macro.
2841
2842 =cut
2843 */
2844
2845 char *
2846 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2847 {
2848     sv_utf8_upgrade(sv);
2849     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2850 }
2851
2852
2853 /*
2854 =for apidoc sv_2bool
2855
2856 This function is only called on magical items, and is only used by
2857 sv_true() or its macro equivalent.
2858
2859 =cut
2860 */
2861
2862 bool
2863 Perl_sv_2bool(pTHX_ register SV *sv)
2864 {
2865     SvGETMAGIC(sv);
2866
2867     if (!SvOK(sv))
2868         return 0;
2869     if (SvROK(sv)) {
2870         SV* tmpsv;
2871         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2872                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2873             return (bool)SvTRUE(tmpsv);
2874       return SvRV(sv) != 0;
2875     }
2876     if (SvPOKp(sv)) {
2877         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2878         if (Xpvtmp &&
2879                 (*sv->sv_u.svu_pv > '0' ||
2880                 Xpvtmp->xpv_cur > 1 ||
2881                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2882             return 1;
2883         else
2884             return 0;
2885     }
2886     else {
2887         if (SvIOKp(sv))
2888             return SvIVX(sv) != 0;
2889         else {
2890             if (SvNOKp(sv))
2891                 return SvNVX(sv) != 0.0;
2892             else
2893                 return FALSE;
2894         }
2895     }
2896 }
2897
2898 /*
2899 =for apidoc sv_utf8_upgrade
2900
2901 Converts the PV of an SV to its UTF-8-encoded form.
2902 Forces the SV to string form if it is not already.
2903 Always sets the SvUTF8 flag to avoid future validity checks even
2904 if all the bytes have hibit clear.
2905
2906 This is not as a general purpose byte encoding to Unicode interface:
2907 use the Encode extension for that.
2908
2909 =for apidoc sv_utf8_upgrade_flags
2910
2911 Converts the PV of an SV to its UTF-8-encoded form.
2912 Forces the SV to string form if it is not already.
2913 Always sets the SvUTF8 flag to avoid future validity checks even
2914 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2915 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2916 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2917
2918 This is not as a general purpose byte encoding to Unicode interface:
2919 use the Encode extension for that.
2920
2921 =cut
2922 */
2923
2924 STRLEN
2925 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2926 {
2927     if (sv == &PL_sv_undef)
2928         return 0;
2929     if (!SvPOK(sv)) {
2930         STRLEN len = 0;
2931         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2932             (void) sv_2pv_flags(sv,&len, flags);
2933             if (SvUTF8(sv))
2934                 return len;
2935         } else {
2936             (void) SvPV_force(sv,len);
2937         }
2938     }
2939
2940     if (SvUTF8(sv)) {
2941         return SvCUR(sv);
2942     }
2943
2944     if (SvIsCOW(sv)) {
2945         sv_force_normal_flags(sv, 0);
2946     }
2947
2948     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2949         sv_recode_to_utf8(sv, PL_encoding);
2950     else { /* Assume Latin-1/EBCDIC */
2951         /* This function could be much more efficient if we
2952          * had a FLAG in SVs to signal if there are any hibit
2953          * chars in the PV.  Given that there isn't such a flag
2954          * make the loop as fast as possible. */
2955         const U8 *s = (U8 *) SvPVX_const(sv);
2956         const U8 * const e = (U8 *) SvEND(sv);
2957         const U8 *t = s;
2958         int hibit = 0;
2959         
2960         while (t < e) {
2961             const U8 ch = *t++;
2962             if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2963                 break;
2964         }
2965         if (hibit) {
2966             STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2967             U8 * const recoded = bytes_to_utf8((U8*)s, &len);
2968
2969             SvPV_free(sv); /* No longer using what was there before. */
2970
2971             SvPV_set(sv, (char*)recoded);
2972             SvCUR_set(sv, len - 1);
2973             SvLEN_set(sv, len); /* No longer know the real size. */
2974         }
2975         /* Mark as UTF-8 even if no hibit - saves scanning loop */
2976         SvUTF8_on(sv);
2977     }
2978     return SvCUR(sv);
2979 }
2980
2981 /*
2982 =for apidoc sv_utf8_downgrade
2983
2984 Attempts to convert the PV of an SV from characters to bytes.
2985 If the PV contains a character beyond byte, this conversion will fail;
2986 in this case, either returns false or, if C<fail_ok> is not
2987 true, croaks.
2988
2989 This is not as a general purpose Unicode to byte encoding interface:
2990 use the Encode extension for that.
2991
2992 =cut
2993 */
2994
2995 bool
2996 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2997 {
2998     if (SvPOKp(sv) && SvUTF8(sv)) {
2999         if (SvCUR(sv)) {
3000             U8 *s;
3001             STRLEN len;
3002
3003             if (SvIsCOW(sv)) {
3004                 sv_force_normal_flags(sv, 0);
3005             }
3006             s = (U8 *) SvPV(sv, len);
3007             if (!utf8_to_bytes(s, &len)) {
3008                 if (fail_ok)
3009                     return FALSE;
3010                 else {
3011                     if (PL_op)
3012                         Perl_croak(aTHX_ "Wide character in %s",
3013                                    OP_DESC(PL_op));
3014                     else
3015                         Perl_croak(aTHX_ "Wide character");
3016                 }
3017             }
3018             SvCUR_set(sv, len);
3019         }
3020     }
3021     SvUTF8_off(sv);
3022     return TRUE;
3023 }
3024
3025 /*
3026 =for apidoc sv_utf8_encode
3027
3028 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3029 flag off so that it looks like octets again.
3030
3031 =cut
3032 */
3033
3034 void
3035 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3036 {
3037     (void) sv_utf8_upgrade(sv);
3038     if (SvIsCOW(sv)) {
3039         sv_force_normal_flags(sv, 0);
3040     }
3041     if (SvREADONLY(sv)) {
3042         Perl_croak(aTHX_ PL_no_modify);
3043     }
3044     SvUTF8_off(sv);
3045 }
3046
3047 /*
3048 =for apidoc sv_utf8_decode
3049
3050 If the PV of the SV is an octet sequence in UTF-8
3051 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3052 so that it looks like a character. If the PV contains only single-byte
3053 characters, the C<SvUTF8> flag stays being off.
3054 Scans PV for validity and returns false if the PV is invalid UTF-8.
3055
3056 =cut
3057 */
3058
3059 bool
3060 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3061 {
3062     if (SvPOKp(sv)) {
3063         const U8 *c;
3064         const U8 *e;
3065
3066         /* The octets may have got themselves encoded - get them back as
3067          * bytes
3068          */
3069         if (!sv_utf8_downgrade(sv, TRUE))
3070             return FALSE;
3071
3072         /* it is actually just a matter of turning the utf8 flag on, but
3073          * we want to make sure everything inside is valid utf8 first.
3074          */
3075         c = (const U8 *) SvPVX_const(sv);
3076         if (!is_utf8_string(c, SvCUR(sv)+1))
3077             return FALSE;
3078         e = (const U8 *) SvEND(sv);
3079         while (c < e) {
3080             const U8 ch = *c++;
3081             if (!UTF8_IS_INVARIANT(ch)) {
3082                 SvUTF8_on(sv);
3083                 break;
3084             }
3085         }
3086     }
3087     return TRUE;
3088 }
3089
3090 /*
3091 =for apidoc sv_setsv
3092
3093 Copies the contents of the source SV C<ssv> into the destination SV
3094 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3095 function if the source SV needs to be reused. Does not handle 'set' magic.
3096 Loosely speaking, it performs a copy-by-value, obliterating any previous
3097 content of the destination.
3098
3099 You probably want to use one of the assortment of wrappers, such as
3100 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3101 C<SvSetMagicSV_nosteal>.
3102
3103 =for apidoc sv_setsv_flags
3104
3105 Copies the contents of the source SV C<ssv> into the destination SV
3106 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3107 function if the source SV needs to be reused. Does not handle 'set' magic.
3108 Loosely speaking, it performs a copy-by-value, obliterating any previous
3109 content of the destination.
3110 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3111 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3112 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3113 and C<sv_setsv_nomg> are implemented in terms of this function.
3114
3115 You probably want to use one of the assortment of wrappers, such as
3116 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3117 C<SvSetMagicSV_nosteal>.
3118
3119 This is the primary function for copying scalars, and most other
3120 copy-ish functions and macros use this underneath.
3121
3122 =cut
3123 */
3124
3125 void
3126 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3127 {
3128     register U32 sflags;
3129     register int dtype;
3130     register int stype;
3131
3132     if (sstr == dstr)
3133         return;
3134     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3135     if (!sstr)
3136         sstr = &PL_sv_undef;
3137     stype = SvTYPE(sstr);
3138     dtype = SvTYPE(dstr);
3139
3140     SvAMAGIC_off(dstr);
3141     if ( SvVOK(dstr) )
3142     {
3143         /* need to nuke the magic */
3144         mg_free(dstr);
3145         SvRMAGICAL_off(dstr);
3146     }
3147
3148     /* There's a lot of redundancy below but we're going for speed here */
3149
3150     switch (stype) {
3151     case SVt_NULL:
3152       undef_sstr:
3153         if (dtype != SVt_PVGV) {
3154             (void)SvOK_off(dstr);
3155             return;
3156         }
3157         break;
3158     case SVt_IV:
3159         if (SvIOK(sstr)) {
3160             switch (dtype) {
3161             case SVt_NULL:
3162                 sv_upgrade(dstr, SVt_IV);
3163                 break;
3164             case SVt_NV:
3165                 sv_upgrade(dstr, SVt_PVNV);
3166                 break;
3167             case SVt_RV:
3168             case SVt_PV:
3169                 sv_upgrade(dstr, SVt_PVIV);
3170                 break;
3171             }
3172             (void)SvIOK_only(dstr);
3173             SvIV_set(dstr,  SvIVX(sstr));
3174             if (SvIsUV(sstr))
3175                 SvIsUV_on(dstr);
3176             if (SvTAINTED(sstr))
3177                 SvTAINT(dstr);
3178             return;
3179         }
3180         goto undef_sstr;
3181
3182     case SVt_NV:
3183         if (SvNOK(sstr)) {
3184             switch (dtype) {
3185             case SVt_NULL:
3186             case SVt_IV:
3187                 sv_upgrade(dstr, SVt_NV);
3188                 break;
3189             case SVt_RV:
3190             case SVt_PV:
3191             case SVt_PVIV:
3192                 sv_upgrade(dstr, SVt_PVNV);
3193                 break;
3194             }
3195             SvNV_set(dstr, SvNVX(sstr));
3196             (void)SvNOK_only(dstr);
3197             if (SvTAINTED(sstr))
3198                 SvTAINT(dstr);
3199             return;
3200         }
3201         goto undef_sstr;
3202
3203     case SVt_RV:
3204         if (dtype < SVt_RV)
3205             sv_upgrade(dstr, SVt_RV);
3206         else if (dtype == SVt_PVGV &&
3207                  SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3208             sstr = SvRV(sstr);
3209             if (sstr == dstr) {
3210                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3211                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3212                 {
3213                     GvIMPORTED_on(dstr);
3214                 }
3215                 GvMULTI_on(dstr);
3216                 return;
3217             }
3218             goto glob_assign;
3219         }
3220         break;
3221     case SVt_PVFM:
3222 #ifdef PERL_OLD_COPY_ON_WRITE
3223         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3224             if (dtype < SVt_PVIV)
3225                 sv_upgrade(dstr, SVt_PVIV);
3226             break;
3227         }
3228         /* Fall through */
3229 #endif
3230     case SVt_PV:
3231         if (dtype < SVt_PV)
3232             sv_upgrade(dstr, SVt_PV);
3233         break;
3234     case SVt_PVIV:
3235         if (dtype < SVt_PVIV)
3236             sv_upgrade(dstr, SVt_PVIV);
3237         break;
3238     case SVt_PVNV:
3239         if (dtype < SVt_PVNV)
3240             sv_upgrade(dstr, SVt_PVNV);
3241         break;
3242     case SVt_PVAV:
3243     case SVt_PVHV:
3244     case SVt_PVCV:
3245     case SVt_PVIO:
3246         {
3247         const char * const type = sv_reftype(sstr,0);
3248         if (PL_op)
3249             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3250         else
3251             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3252         }
3253         break;
3254
3255     case SVt_PVGV:
3256         if (dtype <= SVt_PVGV) {
3257   glob_assign:
3258             if (dtype != SVt_PVGV) {
3259                 const char * const name = GvNAME(sstr);
3260                 const STRLEN len = GvNAMELEN(sstr);
3261                 /* don't upgrade SVt_PVLV: it can hold a glob */
3262                 if (dtype != SVt_PVLV)
3263                     sv_upgrade(dstr, SVt_PVGV);
3264                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3265                 GvSTASH(dstr) = GvSTASH(sstr);
3266                 if (GvSTASH(dstr))
3267                     Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3268                 GvNAME(dstr) = savepvn(name, len);
3269                 GvNAMELEN(dstr) = len;
3270                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3271             }
3272
3273 #ifdef GV_UNIQUE_CHECK
3274                 if (GvUNIQUE((GV*)dstr)) {
3275                     Perl_croak(aTHX_ PL_no_modify);
3276                 }
3277 #endif
3278
3279             (void)SvOK_off(dstr);
3280             GvINTRO_off(dstr);          /* one-shot flag */
3281             gp_free((GV*)dstr);
3282             GvGP(dstr) = gp_ref(GvGP(sstr));
3283             if (SvTAINTED(sstr))
3284                 SvTAINT(dstr);
3285             if (GvIMPORTED(dstr) != GVf_IMPORTED
3286                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3287             {
3288                 GvIMPORTED_on(dstr);
3289             }
3290             GvMULTI_on(dstr);
3291             return;
3292         }
3293         /* FALL THROUGH */
3294
3295     default:
3296         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3297             mg_get(sstr);
3298             if ((int)SvTYPE(sstr) != stype) {
3299                 stype = SvTYPE(sstr);
3300                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3301                     goto glob_assign;
3302             }
3303         }
3304         if (stype == SVt_PVLV)
3305             SvUPGRADE(dstr, SVt_PVNV);
3306         else
3307             SvUPGRADE(dstr, (U32)stype);
3308     }
3309
3310     sflags = SvFLAGS(sstr);
3311
3312     if (sflags & SVf_ROK) {
3313         if (dtype >= SVt_PV) {
3314             if (dtype == SVt_PVGV) {
3315                 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3316                 SV *dref = 0;
3317                 const int intro = GvINTRO(dstr);
3318
3319 #ifdef GV_UNIQUE_CHECK
3320                 if (GvUNIQUE((GV*)dstr)) {
3321                     Perl_croak(aTHX_ PL_no_modify);
3322                 }
3323 #endif
3324
3325                 if (intro) {
3326                     GvINTRO_off(dstr);  /* one-shot flag */
3327                     GvLINE(dstr) = CopLINE(PL_curcop);
3328                     GvEGV(dstr) = (GV*)dstr;
3329                 }
3330                 GvMULTI_on(dstr);
3331                 switch (SvTYPE(sref)) {
3332                 case SVt_PVAV:
3333                     if (intro)
3334                         SAVEGENERICSV(GvAV(dstr));
3335                     else
3336                         dref = (SV*)GvAV(dstr);
3337                     GvAV(dstr) = (AV*)sref;
3338                     if (!GvIMPORTED_AV(dstr)
3339                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3340                     {
3341                         GvIMPORTED_AV_on(dstr);
3342                     }
3343                     break;
3344                 case SVt_PVHV:
3345                     if (intro)
3346                         SAVEGENERICSV(GvHV(dstr));
3347                     else
3348                         dref = (SV*)GvHV(dstr);
3349                     GvHV(dstr) = (HV*)sref;
3350                     if (!GvIMPORTED_HV(dstr)
3351                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3352                     {
3353                         GvIMPORTED_HV_on(dstr);
3354                     }
3355                     break;
3356                 case SVt_PVCV:
3357                     if (intro) {
3358                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3359                             SvREFCNT_dec(GvCV(dstr));
3360                             GvCV(dstr) = Nullcv;
3361                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3362                             PL_sub_generation++;
3363                         }
3364                         SAVEGENERICSV(GvCV(dstr));
3365                     }
3366                     else
3367                         dref = (SV*)GvCV(dstr);
3368                     if (GvCV(dstr) != (CV*)sref) {
3369                         CV* const cv = GvCV(dstr);
3370                         if (cv) {
3371                             if (!GvCVGEN((GV*)dstr) &&
3372                                 (CvROOT(cv) || CvXSUB(cv)))
3373                             {
3374                                 /* Redefining a sub - warning is mandatory if
3375                                    it was a const and its value changed. */
3376                                 if (ckWARN(WARN_REDEFINE)
3377                                     || (CvCONST(cv)
3378                                         && (!CvCONST((CV*)sref)
3379                                             || sv_cmp(cv_const_sv(cv),
3380                                                       cv_const_sv((CV*)sref)))))
3381                                 {
3382                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3383                                         CvCONST(cv)
3384                                         ? "Constant subroutine %s::%s redefined"
3385                                         : "Subroutine %s::%s redefined",
3386                                         HvNAME_get(GvSTASH((GV*)dstr)),
3387                                         GvENAME((GV*)dstr));
3388                                 }
3389                             }
3390                             if (!intro)
3391                                 cv_ckproto(cv, (GV*)dstr,
3392                                            SvPOK(sref)
3393                                            ? SvPVX_const(sref) : Nullch);
3394                         }
3395                         GvCV(dstr) = (CV*)sref;
3396                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3397                         GvASSUMECV_on(dstr);
3398                         PL_sub_generation++;
3399                     }
3400                     if (!GvIMPORTED_CV(dstr)
3401                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3402                     {
3403                         GvIMPORTED_CV_on(dstr);
3404                     }
3405                     break;
3406                 case SVt_PVIO:
3407                     if (intro)
3408                         SAVEGENERICSV(GvIOp(dstr));
3409                     else
3410                         dref = (SV*)GvIOp(dstr);
3411                     GvIOp(dstr) = (IO*)sref;
3412                     break;
3413                 case SVt_PVFM:
3414                     if (intro)
3415                         SAVEGENERICSV(GvFORM(dstr));
3416                     else
3417                         dref = (SV*)GvFORM(dstr);
3418                     GvFORM(dstr) = (CV*)sref;
3419                     break;
3420                 default:
3421                     if (intro)
3422                         SAVEGENERICSV(GvSV(dstr));
3423                     else
3424                         dref = (SV*)GvSV(dstr);
3425                     GvSV(dstr) = sref;
3426                     if (!GvIMPORTED_SV(dstr)
3427                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3428                     {
3429                         GvIMPORTED_SV_on(dstr);
3430                     }
3431                     break;
3432                 }
3433                 if (dref)
3434                     SvREFCNT_dec(dref);
3435                 if (SvTAINTED(sstr))
3436                     SvTAINT(dstr);
3437                 return;
3438             }
3439             if (SvPVX_const(dstr)) {
3440                 SvPV_free(dstr);
3441                 SvLEN_set(dstr, 0);
3442                 SvCUR_set(dstr, 0);
3443             }
3444         }
3445         (void)SvOK_off(dstr);
3446         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3447         SvROK_on(dstr);
3448         if (sflags & SVp_NOK) {
3449             SvNOKp_on(dstr);
3450             /* Only set the public OK flag if the source has public OK.  */
3451             if (sflags & SVf_NOK)
3452                 SvFLAGS(dstr) |= SVf_NOK;
3453             SvNV_set(dstr, SvNVX(sstr));
3454         }
3455         if (sflags & SVp_IOK) {
3456             (void)SvIOKp_on(dstr);
3457             if (sflags & SVf_IOK)
3458                 SvFLAGS(dstr) |= SVf_IOK;
3459             if (sflags & SVf_IVisUV)
3460                 SvIsUV_on(dstr);
3461             SvIV_set(dstr, SvIVX(sstr));
3462         }
3463         if (SvAMAGIC(sstr)) {
3464             SvAMAGIC_on(dstr);
3465         }
3466     }
3467     else if (sflags & SVp_POK) {
3468         bool isSwipe = 0;
3469
3470         /*
3471          * Check to see if we can just swipe the string.  If so, it's a
3472          * possible small lose on short strings, but a big win on long ones.
3473          * It might even be a win on short strings if SvPVX_const(dstr)
3474          * has to be allocated and SvPVX_const(sstr) has to be freed.
3475          */
3476
3477         /* Whichever path we take through the next code, we want this true,
3478            and doing it now facilitates the COW check.  */
3479         (void)SvPOK_only(dstr);
3480
3481         if (
3482             /* We're not already COW  */
3483             ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3484 #ifndef PERL_OLD_COPY_ON_WRITE
3485              /* or we are, but dstr isn't a suitable target.  */
3486              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3487 #endif
3488              )
3489             &&
3490             !(isSwipe =
3491                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3492                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3493                  (!(flags & SV_NOSTEAL)) &&
3494                                         /* and we're allowed to steal temps */
3495                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3496                  SvLEN(sstr)    &&        /* and really is a string */
3497                                 /* and won't be needed again, potentially */
3498               !(PL_op && PL_op->op_type == OP_AASSIGN))
3499 #ifdef PERL_OLD_COPY_ON_WRITE
3500             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3501                  && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3502                  && SvTYPE(sstr) >= SVt_PVIV)
3503 #endif
3504             ) {
3505             /* Failed the swipe test, and it's not a shared hash key either.
3506                Have to copy the string.  */
3507             STRLEN len = SvCUR(sstr);
3508             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3509             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3510             SvCUR_set(dstr, len);
3511             *SvEND(dstr) = '\0';
3512         } else {
3513             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3514                be true in here.  */
3515             /* Either it's a shared hash key, or it's suitable for
3516                copy-on-write or we can swipe the string.  */
3517             if (DEBUG_C_TEST) {
3518                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3519                 sv_dump(sstr);
3520                 sv_dump(dstr);
3521             }
3522 #ifdef PERL_OLD_COPY_ON_WRITE
3523             if (!isSwipe) {
3524                 /* I believe I should acquire a global SV mutex if
3525                    it's a COW sv (not a shared hash key) to stop
3526                    it going un copy-on-write.
3527                    If the source SV has gone un copy on write between up there
3528                    and down here, then (assert() that) it is of the correct
3529                    form to make it copy on write again */
3530                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3531                     != (SVf_FAKE | SVf_READONLY)) {
3532                     SvREADONLY_on(sstr);
3533                     SvFAKE_on(sstr);
3534                     /* Make the source SV into a loop of 1.
3535                        (about to become 2) */
3536                     SV_COW_NEXT_SV_SET(sstr, sstr);
3537                 }
3538             }
3539 #endif
3540             /* Initial code is common.  */
3541             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
3542                 SvPV_free(dstr);
3543             }
3544
3545             if (!isSwipe) {
3546                 /* making another shared SV.  */
3547                 STRLEN cur = SvCUR(sstr);
3548                 STRLEN len = SvLEN(sstr);
3549 #ifdef PERL_OLD_COPY_ON_WRITE
3550                 if (len) {
3551                     assert (SvTYPE(dstr) >= SVt_PVIV);
3552                     /* SvIsCOW_normal */
3553                     /* splice us in between source and next-after-source.  */
3554                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3555                     SV_COW_NEXT_SV_SET(sstr, dstr);
3556                     SvPV_set(dstr, SvPVX_mutable(sstr));
3557                 } else
3558 #endif
3559                 {
3560                     /* SvIsCOW_shared_hash */
3561                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3562                                           "Copy on write: Sharing hash\n"));
3563
3564                     assert (SvTYPE(dstr) >= SVt_PV);
3565                     SvPV_set(dstr,
3566                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3567                 }
3568                 SvLEN_set(dstr, len);
3569                 SvCUR_set(dstr, cur);
3570                 SvREADONLY_on(dstr);
3571                 SvFAKE_on(dstr);
3572                 /* Relesase a global SV mutex.  */
3573             }
3574             else
3575                 {       /* Passes the swipe test.  */
3576                 SvPV_set(dstr, SvPVX_mutable(sstr));
3577                 SvLEN_set(dstr, SvLEN(sstr));
3578                 SvCUR_set(dstr, SvCUR(sstr));
3579
3580                 SvTEMP_off(dstr);
3581                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3582                 SvPV_set(sstr, Nullch);
3583                 SvLEN_set(sstr, 0);
3584                 SvCUR_set(sstr, 0);
3585                 SvTEMP_off(sstr);
3586             }
3587         }
3588         if (sflags & SVf_UTF8)
3589             SvUTF8_on(dstr);
3590         if (sflags & SVp_NOK) {
3591             SvNOKp_on(dstr);
3592             if (sflags & SVf_NOK)
3593                 SvFLAGS(dstr) |= SVf_NOK;
3594             SvNV_set(dstr, SvNVX(sstr));
3595         }
3596         if (sflags & SVp_IOK) {
3597             (void)SvIOKp_on(dstr);
3598             if (sflags & SVf_IOK)
3599                 SvFLAGS(dstr) |= SVf_IOK;
3600             if (sflags & SVf_IVisUV)
3601                 SvIsUV_on(dstr);
3602             SvIV_set(dstr, SvIVX(sstr));
3603         }
3604         if (SvVOK(sstr)) {
3605             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
3606             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3607                         smg->mg_ptr, smg->mg_len);
3608             SvRMAGICAL_on(dstr);
3609         }
3610     }
3611     else if (sflags & SVp_IOK) {
3612         if (sflags & SVf_IOK)
3613             (void)SvIOK_only(dstr);
3614         else {
3615             (void)SvOK_off(dstr);
3616             (void)SvIOKp_on(dstr);
3617         }
3618         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3619         if (sflags & SVf_IVisUV)
3620             SvIsUV_on(dstr);
3621         SvIV_set(dstr, SvIVX(sstr));
3622         if (sflags & SVp_NOK) {
3623             if (sflags & SVf_NOK)
3624                 (void)SvNOK_on(dstr);
3625             else
3626                 (void)SvNOKp_on(dstr);
3627             SvNV_set(dstr, SvNVX(sstr));
3628         }
3629     }
3630     else if (sflags & SVp_NOK) {
3631         if (sflags & SVf_NOK)
3632             (void)SvNOK_only(dstr);
3633         else {
3634             (void)SvOK_off(dstr);
3635             SvNOKp_on(dstr);
3636         }
3637         SvNV_set(dstr, SvNVX(sstr));
3638     }
3639     else {
3640         if (dtype == SVt_PVGV) {
3641             if (ckWARN(WARN_MISC))
3642                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3643         }
3644         else
3645             (void)SvOK_off(dstr);
3646     }
3647     if (SvTAINTED(sstr))
3648         SvTAINT(dstr);
3649 }
3650
3651 /*
3652 =for apidoc sv_setsv_mg
3653
3654 Like C<sv_setsv>, but also handles 'set' magic.
3655
3656 =cut
3657 */
3658
3659 void
3660 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3661 {
3662     sv_setsv(dstr,sstr);
3663     SvSETMAGIC(dstr);
3664 }
3665
3666 #ifdef PERL_OLD_COPY_ON_WRITE
3667 SV *
3668 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3669 {
3670     STRLEN cur = SvCUR(sstr);
3671     STRLEN len = SvLEN(sstr);
3672     register char *new_pv;
3673
3674     if (DEBUG_C_TEST) {
3675         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3676                       sstr, dstr);
3677         sv_dump(sstr);
3678         if (dstr)
3679                     sv_dump(dstr);
3680     }
3681
3682     if (dstr) {
3683         if (SvTHINKFIRST(dstr))
3684             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3685         else if (SvPVX_const(dstr))
3686             Safefree(SvPVX_const(dstr));
3687     }
3688     else
3689         new_SV(dstr);
3690     SvUPGRADE(dstr, SVt_PVIV);
3691
3692     assert (SvPOK(sstr));
3693     assert (SvPOKp(sstr));
3694     assert (!SvIOK(sstr));
3695     assert (!SvIOKp(sstr));
3696     assert (!SvNOK(sstr));
3697     assert (!SvNOKp(sstr));
3698
3699     if (SvIsCOW(sstr)) {
3700
3701         if (SvLEN(sstr) == 0) {
3702             /* source is a COW shared hash key.  */
3703             DEBUG_C(PerlIO_printf(Perl_debug_log,
3704                                   "Fast copy on write: Sharing hash\n"));
3705             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3706             goto common_exit;
3707         }
3708         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3709     } else {
3710         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3711         SvUPGRADE(sstr, SVt_PVIV);
3712         SvREADONLY_on(sstr);
3713         SvFAKE_on(sstr);
3714         DEBUG_C(PerlIO_printf(Perl_debug_log,
3715                               "Fast copy on write: Converting sstr to COW\n"));
3716         SV_COW_NEXT_SV_SET(dstr, sstr);
3717     }
3718     SV_COW_NEXT_SV_SET(sstr, dstr);
3719     new_pv = SvPVX_mutable(sstr);
3720
3721   common_exit:
3722     SvPV_set(dstr, new_pv);
3723     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3724     if (SvUTF8(sstr))
3725         SvUTF8_on(dstr);
3726     SvLEN_set(dstr, len);
3727     SvCUR_set(dstr, cur);
3728     if (DEBUG_C_TEST) {
3729         sv_dump(dstr);
3730     }
3731     return dstr;
3732 }
3733 #endif
3734
3735 /*
3736 =for apidoc sv_setpvn
3737
3738 Copies a string into an SV.  The C<len> parameter indicates the number of
3739 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
3740 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3741
3742 =cut
3743 */
3744
3745 void
3746 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3747 {
3748     register char *dptr;
3749
3750     SV_CHECK_THINKFIRST_COW_DROP(sv);
3751     if (!ptr) {
3752         (void)SvOK_off(sv);
3753         return;
3754     }
3755     else {
3756         /* len is STRLEN which is unsigned, need to copy to signed */
3757         const IV iv = len;
3758         if (iv < 0)
3759             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3760     }
3761     SvUPGRADE(sv, SVt_PV);
3762
3763     dptr = SvGROW(sv, len + 1);
3764     Move(ptr,dptr,len,char);
3765     dptr[len] = '\0';
3766     SvCUR_set(sv, len);
3767     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3768     SvTAINT(sv);
3769 }
3770
3771 /*
3772 =for apidoc sv_setpvn_mg
3773
3774 Like C<sv_setpvn>, but also handles 'set' magic.
3775
3776 =cut
3777 */
3778
3779 void
3780 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3781 {
3782     sv_setpvn(sv,ptr,len);
3783     SvSETMAGIC(sv);
3784 }
3785
3786 /*
3787 =for apidoc sv_setpv
3788
3789 Copies a string into an SV.  The string must be null-terminated.  Does not
3790 handle 'set' magic.  See C<sv_setpv_mg>.
3791
3792 =cut
3793 */
3794
3795 void
3796 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3797 {
3798     register STRLEN len;
3799
3800     SV_CHECK_THINKFIRST_COW_DROP(sv);
3801     if (!ptr) {
3802         (void)SvOK_off(sv);
3803         return;
3804     }
3805     len = strlen(ptr);
3806     SvUPGRADE(sv, SVt_PV);
3807
3808     SvGROW(sv, len + 1);
3809     Move(ptr,SvPVX(sv),len+1,char);
3810     SvCUR_set(sv, len);
3811     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3812     SvTAINT(sv);
3813 }
3814
3815 /*
3816 =for apidoc sv_setpv_mg
3817
3818 Like C<sv_setpv>, but also handles 'set' magic.
3819
3820 =cut
3821 */
3822
3823 void
3824 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3825 {
3826     sv_setpv(sv,ptr);
3827     SvSETMAGIC(sv);
3828 }
3829
3830 /*
3831 =for apidoc sv_usepvn
3832
3833 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3834 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3835 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3836 string length, C<len>, must be supplied.  This function will realloc the
3837 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3838 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3839 See C<sv_usepvn_mg>.
3840
3841 =cut
3842 */
3843
3844 void
3845 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3846 {
3847     STRLEN allocate;
3848     SV_CHECK_THINKFIRST_COW_DROP(sv);
3849     SvUPGRADE(sv, SVt_PV);
3850     if (!ptr) {
3851         (void)SvOK_off(sv);
3852         return;
3853     }
3854     if (SvPVX_const(sv))
3855         SvPV_free(sv);
3856
3857     allocate = PERL_STRLEN_ROUNDUP(len + 1);
3858     ptr = saferealloc (ptr, allocate);
3859     SvPV_set(sv, ptr);
3860     SvCUR_set(sv, len);
3861     SvLEN_set(sv, allocate);
3862     *SvEND(sv) = '\0';
3863     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3864     SvTAINT(sv);
3865 }
3866
3867 /*
3868 =for apidoc sv_usepvn_mg
3869
3870 Like C<sv_usepvn>, but also handles 'set' magic.
3871
3872 =cut
3873 */
3874
3875 void
3876 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3877 {
3878     sv_usepvn(sv,ptr,len);
3879     SvSETMAGIC(sv);
3880 }
3881
3882 #ifdef PERL_OLD_COPY_ON_WRITE
3883 /* Need to do this *after* making the SV normal, as we need the buffer
3884    pointer to remain valid until after we've copied it.  If we let go too early,
3885    another thread could invalidate it by unsharing last of the same hash key
3886    (which it can do by means other than releasing copy-on-write Svs)
3887    or by changing the other copy-on-write SVs in the loop.  */
3888 STATIC void
3889 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3890 {
3891     if (len) { /* this SV was SvIsCOW_normal(sv) */
3892          /* we need to find the SV pointing to us.  */
3893         SV * const current = SV_COW_NEXT_SV(after);
3894
3895         if (current == sv) {
3896             /* The SV we point to points back to us (there were only two of us
3897                in the loop.)
3898                Hence other SV is no longer copy on write either.  */
3899             SvFAKE_off(after);
3900             SvREADONLY_off(after);
3901         } else {
3902             /* We need to follow the pointers around the loop.  */
3903             SV *next;
3904             while ((next = SV_COW_NEXT_SV(current)) != sv) {
3905                 assert (next);
3906                 current = next;
3907                  /* don't loop forever if the structure is bust, and we have
3908                     a pointer into a closed loop.  */
3909                 assert (current != after);
3910                 assert (SvPVX_const(current) == pvx);
3911             }
3912             /* Make the SV before us point to the SV after us.  */
3913             SV_COW_NEXT_SV_SET(current, after);
3914         }
3915     } else {
3916         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3917     }
3918 }
3919
3920 int
3921 Perl_sv_release_IVX(pTHX_ register SV *sv)
3922 {
3923     if (SvIsCOW(sv))
3924         sv_force_normal_flags(sv, 0);
3925     SvOOK_off(sv);
3926     return 0;
3927 }
3928 #endif
3929 /*
3930 =for apidoc sv_force_normal_flags
3931
3932 Undo various types of fakery on an SV: if the PV is a shared string, make
3933 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3934 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3935 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3936 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3937 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3938 set to some other value.) In addition, the C<flags> parameter gets passed to
3939 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3940 with flags set to 0.
3941
3942 =cut
3943 */
3944
3945 void
3946 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3947 {
3948 #ifdef PERL_OLD_COPY_ON_WRITE
3949     if (SvREADONLY(sv)) {
3950         /* At this point I believe I should acquire a global SV mutex.  */
3951         if (SvFAKE(sv)) {
3952             const char * const pvx = SvPVX_const(sv);
3953             const STRLEN len = SvLEN(sv);
3954             const STRLEN cur = SvCUR(sv);
3955             SV * const next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
3956             if (DEBUG_C_TEST) {
3957                 PerlIO_printf(Perl_debug_log,
3958                               "Copy on write: Force normal %ld\n",
3959                               (long) flags);
3960                 sv_dump(sv);
3961             }
3962             SvFAKE_off(sv);
3963             SvREADONLY_off(sv);
3964             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
3965             SvPV_set(sv, (char*)0);
3966             SvLEN_set(sv, 0);
3967             if (flags & SV_COW_DROP_PV) {
3968                 /* OK, so we don't need to copy our buffer.  */
3969                 SvPOK_off(sv);
3970             } else {
3971                 SvGROW(sv, cur + 1);
3972                 Move(pvx,SvPVX(sv),cur,char);
3973                 SvCUR_set(sv, cur);
3974                 *SvEND(sv) = '\0';
3975             }
3976             sv_release_COW(sv, pvx, len, next);
3977             if (DEBUG_C_TEST) {
3978                 sv_dump(sv);
3979             }
3980         }
3981         else if (IN_PERL_RUNTIME)
3982             Perl_croak(aTHX_ PL_no_modify);
3983         /* At this point I believe that I can drop the global SV mutex.  */
3984     }
3985 #else
3986     if (SvREADONLY(sv)) {
3987         if (SvFAKE(sv)) {
3988             const char * const pvx = SvPVX_const(sv);
3989             const STRLEN len = SvCUR(sv);
3990             SvFAKE_off(sv);
3991             SvREADONLY_off(sv);
3992             SvPV_set(sv, Nullch);
3993             SvLEN_set(sv, 0);
3994             SvGROW(sv, len + 1);
3995             Move(pvx,SvPVX(sv),len,char);
3996             *SvEND(sv) = '\0';
3997             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3998         }
3999         else if (IN_PERL_RUNTIME)
4000             Perl_croak(aTHX_ PL_no_modify);
4001     }
4002 #endif
4003     if (SvROK(sv))
4004         sv_unref_flags(sv, flags);
4005     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4006         sv_unglob(sv);
4007 }
4008
4009 /*
4010 =for apidoc sv_chop
4011
4012 Efficient removal of characters from the beginning of the string buffer.
4013 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4014 the string buffer.  The C<ptr> becomes the first character of the adjusted
4015 string. Uses the "OOK hack".
4016 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4017 refer to the same chunk of data.
4018
4019 =cut
4020 */
4021
4022 void
4023 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4024 {
4025     register STRLEN delta;
4026     if (!ptr || !SvPOKp(sv))
4027         return;
4028     delta = ptr - SvPVX_const(sv);
4029     SV_CHECK_THINKFIRST(sv);
4030     if (SvTYPE(sv) < SVt_PVIV)
4031         sv_upgrade(sv,SVt_PVIV);
4032
4033     if (!SvOOK(sv)) {
4034         if (!SvLEN(sv)) { /* make copy of shared string */
4035             const char *pvx = SvPVX_const(sv);
4036             const STRLEN len = SvCUR(sv);
4037             SvGROW(sv, len + 1);
4038             Move(pvx,SvPVX(sv),len,char);
4039             *SvEND(sv) = '\0';
4040         }
4041         SvIV_set(sv, 0);
4042         /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4043            and we do that anyway inside the SvNIOK_off
4044         */
4045         SvFLAGS(sv) |= SVf_OOK;
4046     }
4047     SvNIOK_off(sv);
4048     SvLEN_set(sv, SvLEN(sv) - delta);
4049     SvCUR_set(sv, SvCUR(sv) - delta);
4050     SvPV_set(sv, SvPVX(sv) + delta);
4051     SvIV_set(sv, SvIVX(sv) + delta);
4052 }
4053
4054 /*
4055 =for apidoc sv_catpvn
4056
4057 Concatenates the string onto the end of the string which is in the SV.  The
4058 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4059 status set, then the bytes appended should be valid UTF-8.
4060 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4061
4062 =for apidoc sv_catpvn_flags
4063
4064 Concatenates the string onto the end of the string which is in the SV.  The
4065 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4066 status set, then the bytes appended should be valid UTF-8.
4067 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4068 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4069 in terms of this function.
4070
4071 =cut
4072 */
4073
4074 void
4075 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4076 {
4077     STRLEN dlen;
4078     const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4079
4080     SvGROW(dsv, dlen + slen + 1);
4081     if (sstr == dstr)
4082         sstr = SvPVX_const(dsv);
4083     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4084     SvCUR_set(dsv, SvCUR(dsv) + slen);
4085     *SvEND(dsv) = '\0';
4086     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4087     SvTAINT(dsv);
4088     if (flags & SV_SMAGIC)
4089         SvSETMAGIC(dsv);
4090 }
4091
4092 /*
4093 =for apidoc sv_catsv
4094
4095 Concatenates the string from SV C<ssv> onto the end of the string in
4096 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4097 not 'set' magic.  See C<sv_catsv_mg>.
4098
4099 =for apidoc sv_catsv_flags
4100
4101 Concatenates the string from SV C<ssv> onto the end of the string in
4102 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4103 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4104 and C<sv_catsv_nomg> are implemented in terms of this function.
4105
4106 =cut */
4107
4108 void
4109 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4110 {
4111     const char *spv;
4112     STRLEN slen;
4113     if (ssv) {
4114         if ((spv = SvPV_const(ssv, slen))) {
4115             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4116                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4117                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4118                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4119                 dsv->sv_flags doesn't have that bit set.
4120                 Andy Dougherty  12 Oct 2001
4121             */
4122             const I32 sutf8 = DO_UTF8(ssv);
4123             I32 dutf8;
4124
4125             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4126                 mg_get(dsv);
4127             dutf8 = DO_UTF8(dsv);
4128
4129             if (dutf8 != sutf8) {
4130                 if (dutf8) {
4131                     /* Not modifying source SV, so taking a temporary copy. */
4132                     SV* csv = sv_2mortal(newSVpvn(spv, slen));
4133
4134                     sv_utf8_upgrade(csv);
4135                     spv = SvPV_const(csv, slen);
4136                 }
4137                 else
4138                     sv_utf8_upgrade_nomg(dsv);
4139             }
4140             sv_catpvn_nomg(dsv, spv, slen);
4141         }
4142     }
4143     if (flags & SV_SMAGIC)
4144         SvSETMAGIC(dsv);
4145 }
4146
4147 /*
4148 =for apidoc sv_catpv
4149
4150 Concatenates the string onto the end of the string which is in the SV.
4151 If the SV has the UTF-8 status set, then the bytes appended should be
4152 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4153
4154 =cut */
4155
4156 void
4157 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4158 {
4159     register STRLEN len;
4160     STRLEN tlen;
4161     char *junk;
4162
4163     if (!ptr)
4164         return;
4165     junk = SvPV_force(sv, tlen);
4166     len = strlen(ptr);
4167     SvGROW(sv, tlen + len + 1);
4168     if (ptr == junk)
4169         ptr = SvPVX_const(sv);
4170     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4171     SvCUR_set(sv, SvCUR(sv) + len);
4172     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4173     SvTAINT(sv);
4174 }
4175
4176 /*
4177 =for apidoc sv_catpv_mg
4178
4179 Like C<sv_catpv>, but also handles 'set' magic.
4180
4181 =cut
4182 */
4183
4184 void
4185 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4186 {
4187     sv_catpv(sv,ptr);
4188     SvSETMAGIC(sv);
4189 }
4190
4191 /*
4192 =for apidoc newSV
4193
4194 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4195 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4196 macro.
4197
4198 =cut
4199 */
4200
4201 SV *
4202 Perl_newSV(pTHX_ STRLEN len)
4203 {
4204     register SV *sv;
4205
4206     new_SV(sv);
4207     if (len) {
4208         sv_upgrade(sv, SVt_PV);
4209         SvGROW(sv, len + 1);
4210     }
4211     return sv;
4212 }
4213 /*
4214 =for apidoc sv_magicext
4215
4216 Adds magic to an SV, upgrading it if necessary. Applies the
4217 supplied vtable and returns a pointer to the magic added.
4218
4219 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4220 In particular, you can add magic to SvREADONLY SVs, and add more than
4221 one instance of the same 'how'.
4222
4223 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4224 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4225 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4226 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4227
4228 (This is now used as a subroutine by C<sv_magic>.)
4229
4230 =cut
4231 */
4232 MAGIC * 
4233 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4234                  const char* name, I32 namlen)
4235 {
4236     MAGIC* mg;
4237
4238     if (SvTYPE(sv) < SVt_PVMG) {
4239         SvUPGRADE(sv, SVt_PVMG);
4240     }
4241     Newxz(mg, 1, MAGIC);
4242     mg->mg_moremagic = SvMAGIC(sv);
4243     SvMAGIC_set(sv, mg);
4244
4245     /* Sometimes a magic contains a reference loop, where the sv and
4246        object refer to each other.  To prevent a reference loop that
4247        would prevent such objects being freed, we look for such loops
4248        and if we find one we avoid incrementing the object refcount.
4249
4250        Note we cannot do this to avoid self-tie loops as intervening RV must
4251        have its REFCNT incremented to keep it in existence.
4252
4253     */
4254     if (!obj || obj == sv ||
4255         how == PERL_MAGIC_arylen ||
4256         how == PERL_MAGIC_qr ||
4257         how == PERL_MAGIC_symtab ||
4258         (SvTYPE(obj) == SVt_PVGV &&
4259             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4260             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4261             GvFORM(obj) == (CV*)sv)))
4262     {
4263         mg->mg_obj = obj;
4264     }
4265     else {
4266         mg->mg_obj = SvREFCNT_inc(obj);
4267         mg->mg_flags |= MGf_REFCOUNTED;
4268     }
4269
4270     /* Normal self-ties simply pass a null object, and instead of
4271        using mg_obj directly, use the SvTIED_obj macro to produce a
4272        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4273        with an RV obj pointing to the glob containing the PVIO.  In
4274        this case, to avoid a reference loop, we need to weaken the
4275        reference.
4276     */
4277
4278     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4279         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4280     {
4281       sv_rvweaken(obj);
4282     }
4283
4284     mg->mg_type = how;
4285     mg->mg_len = namlen;
4286     if (name) {
4287         if (namlen > 0)
4288             mg->mg_ptr = savepvn(name, namlen);
4289         else if (namlen == HEf_SVKEY)
4290             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4291         else
4292             mg->mg_ptr = (char *) name;
4293     }
4294     mg->mg_virtual = vtable;
4295
4296     mg_magical(sv);
4297     if (SvGMAGICAL(sv))
4298         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4299     return mg;
4300 }
4301
4302 /*
4303 =for apidoc sv_magic
4304
4305 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4306 then adds a new magic item of type C<how> to the head of the magic list.
4307
4308 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4309 handling of the C<name> and C<namlen> arguments.
4310
4311 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4312 to add more than one instance of the same 'how'.
4313
4314 =cut
4315 */
4316
4317 void
4318 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4319 {
4320     const MGVTBL *vtable;
4321     MAGIC* mg;
4322
4323 #ifdef PERL_OLD_COPY_ON_WRITE
4324     if (SvIsCOW(sv))
4325         sv_force_normal_flags(sv, 0);
4326 #endif
4327     if (SvREADONLY(sv)) {
4328         if (
4329             /* its okay to attach magic to shared strings; the subsequent
4330              * upgrade to PVMG will unshare the string */
4331             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4332
4333             && IN_PERL_RUNTIME
4334             && how != PERL_MAGIC_regex_global
4335             && how != PERL_MAGIC_bm
4336             && how != PERL_MAGIC_fm
4337             && how != PERL_MAGIC_sv
4338             && how != PERL_MAGIC_backref
4339            )
4340         {
4341             Perl_croak(aTHX_ PL_no_modify);
4342         }
4343     }
4344     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4345         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4346             /* sv_magic() refuses to add a magic of the same 'how' as an
4347                existing one
4348              */
4349             if (how == PERL_MAGIC_taint)
4350                 mg->mg_len |= 1;
4351             return;
4352         }
4353     }
4354
4355     switch (how) {
4356     case PERL_MAGIC_sv:
4357         vtable = &PL_vtbl_sv;
4358         break;
4359     case PERL_MAGIC_overload:
4360         vtable = &PL_vtbl_amagic;
4361         break;
4362     case PERL_MAGIC_overload_elem:
4363         vtable = &PL_vtbl_amagicelem;
4364         break;
4365     case PERL_MAGIC_overload_table:
4366         vtable = &PL_vtbl_ovrld;
4367         break;
4368     case PERL_MAGIC_bm:
4369         vtable = &PL_vtbl_bm;
4370         break;
4371     case PERL_MAGIC_regdata:
4372         vtable = &PL_vtbl_regdata;
4373         break;
4374     case PERL_MAGIC_regdatum:
4375         vtable = &PL_vtbl_regdatum;
4376         break;
4377     case PERL_MAGIC_env:
4378         vtable = &PL_vtbl_env;
4379         break;
4380     case PERL_MAGIC_fm:
4381         vtable = &PL_vtbl_fm;
4382         break;
4383     case PERL_MAGIC_envelem:
4384         vtable = &PL_vtbl_envelem;
4385         break;
4386     case PERL_MAGIC_regex_global:
4387         vtable = &PL_vtbl_mglob;
4388         break;
4389     case PERL_MAGIC_isa:
4390         vtable = &PL_vtbl_isa;
4391         break;
4392     case PERL_MAGIC_isaelem:
4393         vtable = &PL_vtbl_isaelem;
4394         break;
4395     case PERL_MAGIC_nkeys:
4396         vtable = &PL_vtbl_nkeys;
4397         break;
4398     case PERL_MAGIC_dbfile:
4399         vtable = NULL;
4400         break;
4401     case PERL_MAGIC_dbline:
4402         vtable = &PL_vtbl_dbline;
4403         break;
4404 #ifdef USE_LOCALE_COLLATE
4405     case PERL_MAGIC_collxfrm:
4406         vtable = &PL_vtbl_collxfrm;
4407         break;
4408 #endif /* USE_LOCALE_COLLATE */
4409     case PERL_MAGIC_tied:
4410         vtable = &PL_vtbl_pack;
4411         break;
4412     case PERL_MAGIC_tiedelem:
4413     case PERL_MAGIC_tiedscalar:
4414         vtable = &PL_vtbl_packelem;
4415         break;
4416     case PERL_MAGIC_qr:
4417         vtable = &PL_vtbl_regexp;
4418         break;
4419     case PERL_MAGIC_sig:
4420         vtable = &PL_vtbl_sig;
4421         break;
4422     case PERL_MAGIC_sigelem:
4423         vtable = &PL_vtbl_sigelem;
4424         break;
4425     case PERL_MAGIC_taint:
4426         vtable = &PL_vtbl_taint;
4427         break;
4428     case PERL_MAGIC_uvar:
4429         vtable = &PL_vtbl_uvar;
4430         break;
4431     case PERL_MAGIC_vec:
4432         vtable = &PL_vtbl_vec;
4433         break;
4434     case PERL_MAGIC_arylen_p:
4435     case PERL_MAGIC_rhash:
4436     case PERL_MAGIC_symtab:
4437     case PERL_MAGIC_vstring:
4438         vtable = NULL;
4439         break;
4440     case PERL_MAGIC_utf8:
4441         vtable = &PL_vtbl_utf8;
4442         break;
4443     case PERL_MAGIC_substr:
4444         vtable = &PL_vtbl_substr;
4445         break;
4446     case PERL_MAGIC_defelem:
4447         vtable = &PL_vtbl_defelem;
4448         break;
4449     case PERL_MAGIC_glob:
4450         vtable = &PL_vtbl_glob;
4451         break;
4452     case PERL_MAGIC_arylen:
4453         vtable = &PL_vtbl_arylen;
4454         break;
4455     case PERL_MAGIC_pos:
4456         vtable = &PL_vtbl_pos;
4457         break;
4458     case PERL_MAGIC_backref:
4459         vtable = &PL_vtbl_backref;
4460         break;
4461     case PERL_MAGIC_ext:
4462         /* Reserved for use by extensions not perl internals.           */
4463         /* Useful for attaching extension internal data to perl vars.   */
4464         /* Note that multiple extensions may clash if magical scalars   */
4465         /* etc holding private data from one are passed to another.     */
4466         vtable = NULL;
4467         break;
4468     default:
4469         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4470     }
4471
4472     /* Rest of work is done else where */
4473     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4474
4475     switch (how) {
4476     case PERL_MAGIC_taint:
4477         mg->mg_len = 1;
4478         break;
4479     case PERL_MAGIC_ext:
4480     case PERL_MAGIC_dbfile:
4481         SvRMAGICAL_on(sv);
4482         break;
4483     }
4484 }
4485
4486 /*
4487 =for apidoc sv_unmagic
4488
4489 Removes all magic of type C<type> from an SV.
4490
4491 =cut
4492 */
4493
4494 int
4495 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4496 {
4497     MAGIC* mg;
4498     MAGIC** mgp;
4499     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4500         return 0;
4501     mgp = &SvMAGIC(sv);
4502     for (mg = *mgp; mg; mg = *mgp) {
4503         if (mg->mg_type == type) {
4504             const MGVTBL* const vtbl = mg->mg_virtual;
4505             *mgp = mg->mg_moremagic;
4506             if (vtbl && vtbl->svt_free)
4507                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4508             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4509                 if (mg->mg_len > 0)
4510                     Safefree(mg->mg_ptr);
4511                 else if (mg->mg_len == HEf_SVKEY)
4512                     SvREFCNT_dec((SV*)mg->mg_ptr);
4513                 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4514                     Safefree(mg->mg_ptr);
4515             }
4516             if (mg->mg_flags & MGf_REFCOUNTED)
4517                 SvREFCNT_dec(mg->mg_obj);
4518             Safefree(mg);
4519         }
4520         else
4521             mgp = &mg->mg_moremagic;
4522     }
4523     if (!SvMAGIC(sv)) {
4524         SvMAGICAL_off(sv);
4525        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4526     }
4527
4528     return 0;
4529 }
4530
4531 /*
4532 =for apidoc sv_rvweaken
4533
4534 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4535 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4536 push a back-reference to this RV onto the array of backreferences
4537 associated with that magic.
4538
4539 =cut
4540 */
4541
4542 SV *
4543 Perl_sv_rvweaken(pTHX_ SV *sv)
4544 {
4545     SV *tsv;
4546     if (!SvOK(sv))  /* let undefs pass */
4547         return sv;
4548     if (!SvROK(sv))
4549         Perl_croak(aTHX_ "Can't weaken a nonreference");
4550     else if (SvWEAKREF(sv)) {
4551         if (ckWARN(WARN_MISC))
4552             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4553         return sv;
4554     }
4555     tsv = SvRV(sv);
4556     Perl_sv_add_backref(aTHX_ tsv, sv);
4557     SvWEAKREF_on(sv);
4558     SvREFCNT_dec(tsv);
4559     return sv;
4560 }
4561
4562 /* Give tsv backref magic if it hasn't already got it, then push a
4563  * back-reference to sv onto the array associated with the backref magic.
4564  */
4565
4566 void
4567 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4568 {
4569     AV *av;
4570     MAGIC *mg;
4571     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4572         av = (AV*)mg->mg_obj;
4573     else {
4574         av = newAV();
4575         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4576         /* av now has a refcnt of 2, which avoids it getting freed
4577          * before us during global cleanup. The extra ref is removed
4578          * by magic_killbackrefs() when tsv is being freed */
4579     }
4580     if (AvFILLp(av) >= AvMAX(av)) {
4581         av_extend(av, AvFILLp(av)+1);
4582     }
4583     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4584 }
4585
4586 /* delete a back-reference to ourselves from the backref magic associated
4587  * with the SV we point to.
4588  */
4589
4590 STATIC void
4591 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4592 {
4593     AV *av;
4594     SV **svp;
4595     I32 i;
4596     MAGIC *mg = NULL;
4597     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
4598         if (PL_in_clean_all)
4599             return;
4600     }
4601     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4602         Perl_croak(aTHX_ "panic: del_backref");
4603     av = (AV *)mg->mg_obj;
4604     svp = AvARRAY(av);
4605     /* We shouldn't be in here more than once, but for paranoia reasons lets
4606        not assume this.  */
4607     for (i = AvFILLp(av); i >= 0; i--) {
4608         if (svp[i] == sv) {
4609             const SSize_t fill = AvFILLp(av);
4610             if (i != fill) {
4611                 /* We weren't the last entry.
4612                    An unordered list has this property that you can take the
4613                    last element off the end to fill the hole, and it's still
4614                    an unordered list :-)
4615                 */
4616                 svp[i] = svp[fill];
4617             }
4618             svp[fill] = Nullsv;
4619             AvFILLp(av) = fill - 1;
4620         }
4621     }
4622 }
4623
4624 /*
4625 =for apidoc sv_insert
4626
4627 Inserts a string at the specified offset/length within the SV. Similar to
4628 the Perl substr() function.
4629
4630 =cut
4631 */
4632
4633 void
4634 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4635 {
4636     register char *big;
4637     register char *mid;
4638     register char *midend;
4639     register char *bigend;
4640     register I32 i;
4641     STRLEN curlen;
4642
4643
4644     if (!bigstr)
4645         Perl_croak(aTHX_ "Can't modify non-existent substring");
4646     SvPV_force(bigstr, curlen);
4647     (void)SvPOK_only_UTF8(bigstr);
4648     if (offset + len > curlen) {
4649         SvGROW(bigstr, offset+len+1);
4650         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4651         SvCUR_set(bigstr, offset+len);
4652     }
4653
4654     SvTAINT(bigstr);
4655     i = littlelen - len;
4656     if (i > 0) {                        /* string might grow */
4657         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4658         mid = big + offset + len;
4659         midend = bigend = big + SvCUR(bigstr);
4660         bigend += i;
4661         *bigend = '\0';
4662         while (midend > mid)            /* shove everything down */
4663             *--bigend = *--midend;
4664         Move(little,big+offset,littlelen,char);
4665         SvCUR_set(bigstr, SvCUR(bigstr) + i);
4666         SvSETMAGIC(bigstr);
4667         return;
4668     }
4669     else if (i == 0) {
4670         Move(little,SvPVX(bigstr)+offset,len,char);
4671         SvSETMAGIC(bigstr);
4672         return;
4673     }
4674
4675     big = SvPVX(bigstr);
4676     mid = big + offset;
4677     midend = mid + len;
4678     bigend = big + SvCUR(bigstr);
4679
4680     if (midend > bigend)
4681         Perl_croak(aTHX_ "panic: sv_insert");
4682
4683     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4684         if (littlelen) {
4685             Move(little, mid, littlelen,char);
4686             mid += littlelen;
4687         }
4688         i = bigend - midend;
4689         if (i > 0) {
4690             Move(midend, mid, i,char);
4691             mid += i;
4692         }
4693         *mid = '\0';
4694         SvCUR_set(bigstr, mid - big);
4695     }
4696     else if ((i = mid - big)) { /* faster from front */
4697         midend -= littlelen;
4698         mid = midend;
4699         sv_chop(bigstr,midend-i);
4700         big += i;
4701         while (i--)
4702             *--midend = *--big;
4703         if (littlelen)