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