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