e800bd75f666c0cd0d85a39f228588df98c7f74c
[p5sagit/p5-mst-13.2.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, 2007, 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 /* if adding more checks watch out for the following tests:
34  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
35  *   lib/utf8.t lib/Unicode/Collate/t/index.t
36  * --jhi
37  */
38 #   define ASSERT_UTF8_CACHE(cache) \
39     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
40                               assert((cache)[2] <= (cache)[3]); \
41                               assert((cache)[3] <= (cache)[1]);} \
42                               } STMT_END
43 #else
44 #   define ASSERT_UTF8_CACHE(cache) NOOP
45 #endif
46
47 #ifdef PERL_OLD_COPY_ON_WRITE
48 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
49 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
50 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
51    on-write.  */
52 #endif
53
54 /* ============================================================================
55
56 =head1 Allocation and deallocation of SVs.
57
58 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
59 sv, av, hv...) contains type and reference count information, and for
60 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
61 contains fields specific to each type.  Some types store all they need
62 in the head, so don't have a body.
63
64 In all but the most memory-paranoid configuations (ex: PURIFY), heads
65 and bodies are allocated out of arenas, which by default are
66 approximately 4K chunks of memory parcelled up into N heads or bodies.
67 Sv-bodies are allocated by their sv-type, guaranteeing size
68 consistency needed to allocate safely from arrays.
69
70 For SV-heads, the first slot in each arena is reserved, and holds a
71 link to the next arena, some flags, and a note of the number of slots.
72 Snaked through each arena chain is a linked list of free items; when
73 this becomes empty, an extra arena is allocated and divided up into N
74 items which are threaded into the free list.
75
76 SV-bodies are similar, but they use arena-sets by default, which
77 separate the link and info from the arena itself, and reclaim the 1st
78 slot in the arena.  SV-bodies are further described later.
79
80 The following global variables are associated with arenas:
81
82     PL_sv_arenaroot     pointer to list of SV arenas
83     PL_sv_root          pointer to list of free SV structures
84
85     PL_body_arenas      head of linked-list of body arenas
86     PL_body_roots[]     array of pointers to list of free bodies of svtype
87                         arrays are indexed by the svtype needed
88
89 A few special SV heads are not allocated from an arena, but are
90 instead directly created in the interpreter structure, eg PL_sv_undef.
91 The size of arenas can be changed from the default by setting
92 PERL_ARENA_SIZE appropriately at compile time.
93
94 The SV arena serves the secondary purpose of allowing still-live SVs
95 to be located and destroyed during final cleanup.
96
97 At the lowest level, the macros new_SV() and del_SV() grab and free
98 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
99 to return the SV to the free list with error checking.) new_SV() calls
100 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
101 SVs in the free list have their SvTYPE field set to all ones.
102
103 At the time of very final cleanup, sv_free_arenas() is called from
104 perl_destruct() to physically free all the arenas allocated since the
105 start of the interpreter.
106
107 The function visit() scans the SV arenas list, and calls a specified
108 function for each SV it finds which is still live - ie which has an SvTYPE
109 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
110 following functions (specified as [function that calls visit()] / [function
111 called by visit() for each SV]):
112
113     sv_report_used() / do_report_used()
114                         dump all remaining SVs (debugging aid)
115
116     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
117                         Attempt to free all objects pointed to by RVs,
118                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
119                         try to do the same for all objects indirectly
120                         referenced by typeglobs too.  Called once from
121                         perl_destruct(), prior to calling sv_clean_all()
122                         below.
123
124     sv_clean_all() / do_clean_all()
125                         SvREFCNT_dec(sv) each remaining SV, possibly
126                         triggering an sv_free(). It also sets the
127                         SVf_BREAK flag on the SV to indicate that the
128                         refcnt has been artificially lowered, and thus
129                         stopping sv_free() from giving spurious warnings
130                         about SVs which unexpectedly have a refcnt
131                         of zero.  called repeatedly from perl_destruct()
132                         until there are no SVs left.
133
134 =head2 Arena allocator API Summary
135
136 Private API to rest of sv.c
137
138     new_SV(),  del_SV(),
139
140     new_XIV(), del_XIV(),
141     new_XNV(), del_XNV(),
142     etc
143
144 Public API:
145
146     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
147
148 =cut
149
150 ============================================================================ */
151
152 /*
153  * "A time to plant, and a time to uproot what was planted..."
154  */
155
156 void
157 Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size)
158 {
159     dVAR;
160     void *new_chunk;
161     U32 new_chunk_size;
162
163     PERL_ARGS_ASSERT_OFFER_NICE_CHUNK;
164
165     new_chunk = (void *)(chunk);
166     new_chunk_size = (chunk_size);
167     if (new_chunk_size > PL_nice_chunk_size) {
168         Safefree(PL_nice_chunk);
169         PL_nice_chunk = (char *) new_chunk;
170         PL_nice_chunk_size = new_chunk_size;
171     } else {
172         Safefree(chunk);
173     }
174 }
175
176 #ifdef DEBUG_LEAKING_SCALARS
177 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
178 #else
179 #  define FREE_SV_DEBUG_FILE(sv)
180 #endif
181
182 #ifdef PERL_POISON
183 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
184 /* Whilst I'd love to do this, it seems that things like to check on
185    unreferenced scalars
186 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
187 */
188 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
189                                 PoisonNew(&SvREFCNT(sv), 1, U32)
190 #else
191 #  define SvARENA_CHAIN(sv)     SvANY(sv)
192 #  define POSION_SV_HEAD(sv)
193 #endif
194
195 #define plant_SV(p) \
196     STMT_START {                                        \
197         FREE_SV_DEBUG_FILE(p);                          \
198         POSION_SV_HEAD(p);                              \
199         SvARENA_CHAIN(p) = (void *)PL_sv_root;          \
200         SvFLAGS(p) = SVTYPEMASK;                        \
201         PL_sv_root = (p);                               \
202         --PL_sv_count;                                  \
203     } STMT_END
204
205 #define uproot_SV(p) \
206     STMT_START {                                        \
207         (p) = PL_sv_root;                               \
208         PL_sv_root = (SV*)SvARENA_CHAIN(p);             \
209         ++PL_sv_count;                                  \
210     } STMT_END
211
212
213 /* make some more SVs by adding another arena */
214
215 STATIC SV*
216 S_more_sv(pTHX)
217 {
218     dVAR;
219     SV* sv;
220
221     if (PL_nice_chunk) {
222         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
223         PL_nice_chunk = NULL;
224         PL_nice_chunk_size = 0;
225     }
226     else {
227         char *chunk;                /* must use New here to match call to */
228         Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
229         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
230     }
231     uproot_SV(sv);
232     return sv;
233 }
234
235 /* new_SV(): return a new, empty SV head */
236
237 #ifdef DEBUG_LEAKING_SCALARS
238 /* provide a real function for a debugger to play with */
239 STATIC SV*
240 S_new_SV(pTHX)
241 {
242     SV* sv;
243
244     if (PL_sv_root)
245         uproot_SV(sv);
246     else
247         sv = S_more_sv(aTHX);
248     SvANY(sv) = 0;
249     SvREFCNT(sv) = 1;
250     SvFLAGS(sv) = 0;
251     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
252     sv->sv_debug_line = (U16) (PL_parser
253             ?  PL_parser->copline == NOLINE
254                 ?  PL_curcop
255                     ? CopLINE(PL_curcop)
256                     : 0
257                 : PL_parser->copline
258             : 0);
259     sv->sv_debug_inpad = 0;
260     sv->sv_debug_cloned = 0;
261     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
262     
263     return sv;
264 }
265 #  define new_SV(p) (p)=S_new_SV(aTHX)
266
267 #else
268 #  define new_SV(p) \
269     STMT_START {                                        \
270         if (PL_sv_root)                                 \
271             uproot_SV(p);                               \
272         else                                            \
273             (p) = S_more_sv(aTHX);                      \
274         SvANY(p) = 0;                                   \
275         SvREFCNT(p) = 1;                                \
276         SvFLAGS(p) = 0;                                 \
277     } STMT_END
278 #endif
279
280
281 /* del_SV(): return an empty SV head to the free list */
282
283 #ifdef DEBUGGING
284
285 #define del_SV(p) \
286     STMT_START {                                        \
287         if (DEBUG_D_TEST)                               \
288             del_sv(p);                                  \
289         else                                            \
290             plant_SV(p);                                \
291     } STMT_END
292
293 STATIC void
294 S_del_sv(pTHX_ SV *p)
295 {
296     dVAR;
297
298     PERL_ARGS_ASSERT_DEL_SV;
299
300     if (DEBUG_D_TEST) {
301         SV* sva;
302         bool ok = 0;
303         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
304             const SV * const sv = sva + 1;
305             const SV * const svend = &sva[SvREFCNT(sva)];
306             if (p >= sv && p < svend) {
307                 ok = 1;
308                 break;
309             }
310         }
311         if (!ok) {
312             if (ckWARN_d(WARN_INTERNAL))        
313                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
314                             "Attempt to free non-arena SV: 0x%"UVxf
315                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
316             return;
317         }
318     }
319     plant_SV(p);
320 }
321
322 #else /* ! DEBUGGING */
323
324 #define del_SV(p)   plant_SV(p)
325
326 #endif /* DEBUGGING */
327
328
329 /*
330 =head1 SV Manipulation Functions
331
332 =for apidoc sv_add_arena
333
334 Given a chunk of memory, link it to the head of the list of arenas,
335 and split it into a list of free SVs.
336
337 =cut
338 */
339
340 void
341 Perl_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
342 {
343     dVAR;
344     SV* const sva = (SV*)ptr;
345     register SV* sv;
346     register SV* svend;
347
348     PERL_ARGS_ASSERT_SV_ADD_ARENA;
349
350     /* The first SV in an arena isn't an SV. */
351     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
352     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
353     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
354
355     PL_sv_arenaroot = sva;
356     PL_sv_root = sva + 1;
357
358     svend = &sva[SvREFCNT(sva) - 1];
359     sv = sva + 1;
360     while (sv < svend) {
361         SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
362 #ifdef DEBUGGING
363         SvREFCNT(sv) = 0;
364 #endif
365         /* Must always set typemask because it's always checked in on cleanup
366            when the arenas are walked looking for objects.  */
367         SvFLAGS(sv) = SVTYPEMASK;
368         sv++;
369     }
370     SvARENA_CHAIN(sv) = 0;
371 #ifdef DEBUGGING
372     SvREFCNT(sv) = 0;
373 #endif
374     SvFLAGS(sv) = SVTYPEMASK;
375 }
376
377 /* visit(): call the named function for each non-free SV in the arenas
378  * whose flags field matches the flags/mask args. */
379
380 STATIC I32
381 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
382 {
383     dVAR;
384     SV* sva;
385     I32 visited = 0;
386
387     PERL_ARGS_ASSERT_VISIT;
388
389     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
390         register const SV * const svend = &sva[SvREFCNT(sva)];
391         register SV* sv;
392         for (sv = sva + 1; sv < svend; ++sv) {
393             if (SvTYPE(sv) != SVTYPEMASK
394                     && (sv->sv_flags & mask) == flags
395                     && SvREFCNT(sv))
396             {
397                 (FCALL)(aTHX_ sv);
398                 ++visited;
399             }
400         }
401     }
402     return visited;
403 }
404
405 #ifdef DEBUGGING
406
407 /* called by sv_report_used() for each live SV */
408
409 static void
410 do_report_used(pTHX_ SV *const sv)
411 {
412     if (SvTYPE(sv) != SVTYPEMASK) {
413         PerlIO_printf(Perl_debug_log, "****\n");
414         sv_dump(sv);
415     }
416 }
417 #endif
418
419 /*
420 =for apidoc sv_report_used
421
422 Dump the contents of all SVs not yet freed. (Debugging aid).
423
424 =cut
425 */
426
427 void
428 Perl_sv_report_used(pTHX)
429 {
430 #ifdef DEBUGGING
431     visit(do_report_used, 0, 0);
432 #else
433     PERL_UNUSED_CONTEXT;
434 #endif
435 }
436
437 /* called by sv_clean_objs() for each live SV */
438
439 static void
440 do_clean_objs(pTHX_ SV *const ref)
441 {
442     dVAR;
443     assert (SvROK(ref));
444     {
445         SV * const target = SvRV(ref);
446         if (SvOBJECT(target)) {
447             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
448             if (SvWEAKREF(ref)) {
449                 sv_del_backref(target, ref);
450                 SvWEAKREF_off(ref);
451                 SvRV_set(ref, NULL);
452             } else {
453                 SvROK_off(ref);
454                 SvRV_set(ref, NULL);
455                 SvREFCNT_dec(target);
456             }
457         }
458     }
459
460     /* XXX Might want to check arrays, etc. */
461 }
462
463 /* called by sv_clean_objs() for each live SV */
464
465 #ifndef DISABLE_DESTRUCTOR_KLUDGE
466 static void
467 do_clean_named_objs(pTHX_ SV *const sv)
468 {
469     dVAR;
470     assert(SvTYPE(sv) == SVt_PVGV);
471     assert(isGV_with_GP(sv));
472     if (GvGP(sv)) {
473         if ((
474 #ifdef PERL_DONT_CREATE_GVSV
475              GvSV(sv) &&
476 #endif
477              SvOBJECT(GvSV(sv))) ||
478              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
479              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
480              /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */
481              (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) ||
482              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
483         {
484             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
485             SvFLAGS(sv) |= SVf_BREAK;
486             SvREFCNT_dec(sv);
487         }
488     }
489 }
490 #endif
491
492 /*
493 =for apidoc sv_clean_objs
494
495 Attempt to destroy all objects not yet freed
496
497 =cut
498 */
499
500 void
501 Perl_sv_clean_objs(pTHX)
502 {
503     dVAR;
504     PL_in_clean_objs = TRUE;
505     visit(do_clean_objs, SVf_ROK, SVf_ROK);
506 #ifndef DISABLE_DESTRUCTOR_KLUDGE
507     /* some barnacles may yet remain, clinging to typeglobs */
508     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
509 #endif
510     PL_in_clean_objs = FALSE;
511 }
512
513 /* called by sv_clean_all() for each live SV */
514
515 static void
516 do_clean_all(pTHX_ SV *const sv)
517 {
518     dVAR;
519     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
520     SvFLAGS(sv) |= SVf_BREAK;
521     SvREFCNT_dec(sv);
522 }
523
524 /*
525 =for apidoc sv_clean_all
526
527 Decrement the refcnt of each remaining SV, possibly triggering a
528 cleanup. This function may have to be called multiple times to free
529 SVs which are in complex self-referential hierarchies.
530
531 =cut
532 */
533
534 I32
535 Perl_sv_clean_all(pTHX)
536 {
537     dVAR;
538     I32 cleaned;
539     PL_in_clean_all = TRUE;
540     cleaned = visit(do_clean_all, 0,0);
541     PL_in_clean_all = FALSE;
542     return cleaned;
543 }
544
545 /*
546   ARENASETS: a meta-arena implementation which separates arena-info
547   into struct arena_set, which contains an array of struct
548   arena_descs, each holding info for a single arena.  By separating
549   the meta-info from the arena, we recover the 1st slot, formerly
550   borrowed for list management.  The arena_set is about the size of an
551   arena, avoiding the needless malloc overhead of a naive linked-list.
552
553   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
554   memory in the last arena-set (1/2 on average).  In trade, we get
555   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
556   smaller types).  The recovery of the wasted space allows use of
557   small arenas for large, rare body types, by changing array* fields
558   in body_details_by_type[] below.
559 */
560 struct arena_desc {
561     char       *arena;          /* the raw storage, allocated aligned */
562     size_t      size;           /* its size ~4k typ */
563     U32         misc;           /* type, and in future other things. */
564 };
565
566 struct arena_set;
567
568 /* Get the maximum number of elements in set[] such that struct arena_set
569    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
570    therefore likely to be 1 aligned memory page.  */
571
572 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
573                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
574
575 struct arena_set {
576     struct arena_set* next;
577     unsigned int   set_size;    /* ie ARENAS_PER_SET */
578     unsigned int   curr;        /* index of next available arena-desc */
579     struct arena_desc set[ARENAS_PER_SET];
580 };
581
582 /*
583 =for apidoc sv_free_arenas
584
585 Deallocate the memory used by all arenas. Note that all the individual SV
586 heads and bodies within the arenas must already have been freed.
587
588 =cut
589 */
590 void
591 Perl_sv_free_arenas(pTHX)
592 {
593     dVAR;
594     SV* sva;
595     SV* svanext;
596     unsigned int i;
597
598     /* Free arenas here, but be careful about fake ones.  (We assume
599        contiguity of the fake ones with the corresponding real ones.) */
600
601     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
602         svanext = (SV*) SvANY(sva);
603         while (svanext && SvFAKE(svanext))
604             svanext = (SV*) SvANY(svanext);
605
606         if (!SvFAKE(sva))
607             Safefree(sva);
608     }
609
610     {
611         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
612
613         while (aroot) {
614             struct arena_set *current = aroot;
615             i = aroot->curr;
616             while (i--) {
617                 assert(aroot->set[i].arena);
618                 Safefree(aroot->set[i].arena);
619             }
620             aroot = aroot->next;
621             Safefree(current);
622         }
623     }
624     PL_body_arenas = 0;
625
626     i = PERL_ARENA_ROOTS_SIZE;
627     while (i--)
628         PL_body_roots[i] = 0;
629
630     Safefree(PL_nice_chunk);
631     PL_nice_chunk = NULL;
632     PL_nice_chunk_size = 0;
633     PL_sv_arenaroot = 0;
634     PL_sv_root = 0;
635 }
636
637 /*
638   Here are mid-level routines that manage the allocation of bodies out
639   of the various arenas.  There are 5 kinds of arenas:
640
641   1. SV-head arenas, which are discussed and handled above
642   2. regular body arenas
643   3. arenas for reduced-size bodies
644   4. Hash-Entry arenas
645   5. pte arenas (thread related)
646
647   Arena types 2 & 3 are chained by body-type off an array of
648   arena-root pointers, which is indexed by svtype.  Some of the
649   larger/less used body types are malloced singly, since a large
650   unused block of them is wasteful.  Also, several svtypes dont have
651   bodies; the data fits into the sv-head itself.  The arena-root
652   pointer thus has a few unused root-pointers (which may be hijacked
653   later for arena types 4,5)
654
655   3 differs from 2 as an optimization; some body types have several
656   unused fields in the front of the structure (which are kept in-place
657   for consistency).  These bodies can be allocated in smaller chunks,
658   because the leading fields arent accessed.  Pointers to such bodies
659   are decremented to point at the unused 'ghost' memory, knowing that
660   the pointers are used with offsets to the real memory.
661
662   HE, HEK arenas are managed separately, with separate code, but may
663   be merge-able later..
664
665   PTE arenas are not sv-bodies, but they share these mid-level
666   mechanics, so are considered here.  The new mid-level mechanics rely
667   on the sv_type of the body being allocated, so we just reserve one
668   of the unused body-slots for PTEs, then use it in those (2) PTE
669   contexts below (line ~10k)
670 */
671
672 /* get_arena(size): this creates custom-sized arenas
673    TBD: export properly for hv.c: S_more_he().
674 */
675 void*
676 Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc)
677 {
678     dVAR;
679     struct arena_desc* adesc;
680     struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
681     unsigned int curr;
682
683     /* shouldnt need this
684     if (!arena_size)    arena_size = PERL_ARENA_SIZE;
685     */
686
687     /* may need new arena-set to hold new arena */
688     if (!aroot || aroot->curr >= aroot->set_size) {
689         struct arena_set *newroot;
690         Newxz(newroot, 1, struct arena_set);
691         newroot->set_size = ARENAS_PER_SET;
692         newroot->next = aroot;
693         aroot = newroot;
694         PL_body_arenas = (void *) newroot;
695         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
696     }
697
698     /* ok, now have arena-set with at least 1 empty/available arena-desc */
699     curr = aroot->curr++;
700     adesc = &(aroot->set[curr]);
701     assert(!adesc->arena);
702     
703     Newx(adesc->arena, arena_size, char);
704     adesc->size = arena_size;
705     adesc->misc = misc;
706     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
707                           curr, (void*)adesc->arena, (UV)arena_size));
708
709     return adesc->arena;
710 }
711
712
713 /* return a thing to the free list */
714
715 #define del_body(thing, root)                   \
716     STMT_START {                                \
717         void ** const thing_copy = (void **)thing;\
718         *thing_copy = *root;                    \
719         *root = (void*)thing_copy;              \
720     } STMT_END
721
722 /* 
723
724 =head1 SV-Body Allocation
725
726 Allocation of SV-bodies is similar to SV-heads, differing as follows;
727 the allocation mechanism is used for many body types, so is somewhat
728 more complicated, it uses arena-sets, and has no need for still-live
729 SV detection.
730
731 At the outermost level, (new|del)_X*V macros return bodies of the
732 appropriate type.  These macros call either (new|del)_body_type or
733 (new|del)_body_allocated macro pairs, depending on specifics of the
734 type.  Most body types use the former pair, the latter pair is used to
735 allocate body types with "ghost fields".
736
737 "ghost fields" are fields that are unused in certain types, and
738 consequently dont need to actually exist.  They are declared because
739 they're part of a "base type", which allows use of functions as
740 methods.  The simplest examples are AVs and HVs, 2 aggregate types
741 which don't use the fields which support SCALAR semantics.
742
743 For these types, the arenas are carved up into *_allocated size
744 chunks, we thus avoid wasted memory for those unaccessed members.
745 When bodies are allocated, we adjust the pointer back in memory by the
746 size of the bit not allocated, so it's as if we allocated the full
747 structure.  (But things will all go boom if you write to the part that
748 is "not there", because you'll be overwriting the last members of the
749 preceding structure in memory.)
750
751 We calculate the correction using the STRUCT_OFFSET macro. For
752 example, if xpv_allocated is the same structure as XPV then the two
753 OFFSETs sum to zero, and the pointer is unchanged. If the allocated
754 structure is smaller (no initial NV actually allocated) then the net
755 effect is to subtract the size of the NV from the pointer, to return a
756 new pointer as if an initial NV were actually allocated.
757
758 This is the same trick as was used for NV and IV bodies. Ironically it
759 doesn't need to be used for NV bodies any more, because NV is now at
760 the start of the structure. IV bodies don't need it either, because
761 they are no longer allocated.
762
763 In turn, the new_body_* allocators call S_new_body(), which invokes
764 new_body_inline macro, which takes a lock, and takes a body off the
765 linked list at PL_body_roots[sv_type], calling S_more_bodies() if
766 necessary to refresh an empty list.  Then the lock is released, and
767 the body is returned.
768
769 S_more_bodies calls get_arena(), and carves it up into an array of N
770 bodies, which it strings into a linked list.  It looks up arena-size
771 and body-size from the body_details table described below, thus
772 supporting the multiple body-types.
773
774 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
775 the (new|del)_X*V macros are mapped directly to malloc/free.
776
777 */
778
779 /* 
780
781 For each sv-type, struct body_details bodies_by_type[] carries
782 parameters which control these aspects of SV handling:
783
784 Arena_size determines whether arenas are used for this body type, and if
785 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
786 zero, forcing individual mallocs and frees.
787
788 Body_size determines how big a body is, and therefore how many fit into
789 each arena.  Offset carries the body-pointer adjustment needed for
790 *_allocated body types, and is used in *_allocated macros.
791
792 But its main purpose is to parameterize info needed in
793 Perl_sv_upgrade().  The info here dramatically simplifies the function
794 vs the implementation in 5.8.7, making it table-driven.  All fields
795 are used for this, except for arena_size.
796
797 For the sv-types that have no bodies, arenas are not used, so those
798 PL_body_roots[sv_type] are unused, and can be overloaded.  In
799 something of a special case, SVt_NULL is borrowed for HE arenas;
800 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
801 bodies_by_type[SVt_NULL] slot is not used, as the table is not
802 available in hv.c.
803
804 PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless,
805 they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can
806 just use the same allocation semantics.  At first, PTEs were also
807 overloaded to a non-body sv-type, but this yielded hard-to-find malloc
808 bugs, so was simplified by claiming a new slot.  This choice has no
809 consequence at this time.
810
811 */
812
813 struct body_details {
814     U8 body_size;       /* Size to allocate  */
815     U8 copy;            /* Size of structure to copy (may be shorter)  */
816     U8 offset;
817     unsigned int type : 4;          /* We have space for a sanity check.  */
818     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
819     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
820     unsigned int arena : 1;         /* Allocated from an arena */
821     size_t arena_size;              /* Size of arena to allocate */
822 };
823
824 #define HADNV FALSE
825 #define NONV TRUE
826
827
828 #ifdef PURIFY
829 /* With -DPURFIY we allocate everything directly, and don't use arenas.
830    This seems a rather elegant way to simplify some of the code below.  */
831 #define HASARENA FALSE
832 #else
833 #define HASARENA TRUE
834 #endif
835 #define NOARENA FALSE
836
837 /* Size the arenas to exactly fit a given number of bodies.  A count
838    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
839    simplifying the default.  If count > 0, the arena is sized to fit
840    only that many bodies, allowing arenas to be used for large, rare
841    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
842    limited by PERL_ARENA_SIZE, so we can safely oversize the
843    declarations.
844  */
845 #define FIT_ARENA0(body_size)                           \
846     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
847 #define FIT_ARENAn(count,body_size)                     \
848     ( count * body_size <= PERL_ARENA_SIZE)             \
849     ? count * body_size                                 \
850     : FIT_ARENA0 (body_size)
851 #define FIT_ARENA(count,body_size)                      \
852     count                                               \
853     ? FIT_ARENAn (count, body_size)                     \
854     : FIT_ARENA0 (body_size)
855
856 /* A macro to work out the offset needed to subtract from a pointer to (say)
857
858 typedef struct {
859     STRLEN      xpv_cur;
860     STRLEN      xpv_len;
861 } xpv_allocated;
862
863 to make its members accessible via a pointer to (say)
864
865 struct xpv {
866     NV          xnv_nv;
867     STRLEN      xpv_cur;
868     STRLEN      xpv_len;
869 };
870
871 */
872
873 #define relative_STRUCT_OFFSET(longer, shorter, member) \
874     (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
875
876 /* Calculate the length to copy. Specifically work out the length less any
877    final padding the compiler needed to add.  See the comment in sv_upgrade
878    for why copying the padding proved to be a bug.  */
879
880 #define copy_length(type, last_member) \
881         STRUCT_OFFSET(type, last_member) \
882         + sizeof (((type*)SvANY((SV*)0))->last_member)
883
884 static const struct body_details bodies_by_type[] = {
885     { sizeof(HE), 0, 0, SVt_NULL,
886       FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) },
887
888     /* The bind placeholder pretends to be an RV for now.
889        Also it's marked as "can't upgrade" to stop anyone using it before it's
890        implemented.  */
891     { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 },
892
893     /* IVs are in the head, so the allocation size is 0.
894        However, the slot is overloaded for PTEs.  */
895     { sizeof(struct ptr_tbl_ent), /* This is used for PTEs.  */
896       sizeof(IV), /* This is used to copy out the IV body.  */
897       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
898       NOARENA /* IVS don't need an arena  */,
899       /* But PTEs need to know the size of their arena  */
900       FIT_ARENA(0, sizeof(struct ptr_tbl_ent))
901     },
902
903     /* 8 bytes on most ILP32 with IEEE doubles */
904     { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA,
905       FIT_ARENA(0, sizeof(NV)) },
906
907     /* 8 bytes on most ILP32 with IEEE doubles */
908     { sizeof(xpv_allocated),
909       copy_length(XPV, xpv_len)
910       - relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
911       + relative_STRUCT_OFFSET(xpv_allocated, XPV, xpv_cur),
912       SVt_PV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpv_allocated)) },
913
914     /* 12 */
915     { sizeof(xpviv_allocated),
916       copy_length(XPVIV, xiv_u)
917       - relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
918       + relative_STRUCT_OFFSET(xpviv_allocated, XPVIV, xpv_cur),
919       SVt_PVIV, FALSE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpviv_allocated)) },
920
921     /* 20 */
922     { sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, SVt_PVNV, FALSE, HADNV,
923       HASARENA, FIT_ARENA(0, sizeof(XPVNV)) },
924
925     /* 28 */
926     { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
927       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
928
929     /* something big */
930     { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated),
931       + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur),
932       SVt_REGEXP, FALSE, NONV, HASARENA,
933       FIT_ARENA(0, sizeof(struct regexp_allocated))
934     },
935
936     /* 48 */
937     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
938       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
939     
940     /* 64 */
941     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
942       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
943
944     { sizeof(xpvav_allocated),
945       copy_length(XPVAV, xmg_stash)
946       - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
947       + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill),
948       SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) },
949
950     { sizeof(xpvhv_allocated),
951       copy_length(XPVHV, xmg_stash)
952       - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
953       + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill),
954       SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) },
955
956     /* 56 */
957     { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated),
958       + relative_STRUCT_OFFSET(xpvcv_allocated, XPVCV, xpv_cur),
959       SVt_PVCV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvcv_allocated)) },
960
961     { sizeof(xpvfm_allocated), sizeof(xpvfm_allocated),
962       + relative_STRUCT_OFFSET(xpvfm_allocated, XPVFM, xpv_cur),
963       SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) },
964
965     /* XPVIO is 84 bytes, fits 48x */
966     { sizeof(xpvio_allocated), sizeof(xpvio_allocated),
967       + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur),
968       SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) },
969 };
970
971 #define new_body_type(sv_type)          \
972     (void *)((char *)S_new_body(aTHX_ sv_type))
973
974 #define del_body_type(p, sv_type)       \
975     del_body(p, &PL_body_roots[sv_type])
976
977
978 #define new_body_allocated(sv_type)             \
979     (void *)((char *)S_new_body(aTHX_ sv_type)  \
980              - bodies_by_type[sv_type].offset)
981
982 #define del_body_allocated(p, sv_type)          \
983     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
984
985
986 #define my_safemalloc(s)        (void*)safemalloc(s)
987 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
988 #define my_safefree(p)  safefree((char*)p)
989
990 #ifdef PURIFY
991
992 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
993 #define del_XNV(p)      my_safefree(p)
994
995 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
996 #define del_XPVNV(p)    my_safefree(p)
997
998 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
999 #define del_XPVAV(p)    my_safefree(p)
1000
1001 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
1002 #define del_XPVHV(p)    my_safefree(p)
1003
1004 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
1005 #define del_XPVMG(p)    my_safefree(p)
1006
1007 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
1008 #define del_XPVGV(p)    my_safefree(p)
1009
1010 #else /* !PURIFY */
1011
1012 #define new_XNV()       new_body_type(SVt_NV)
1013 #define del_XNV(p)      del_body_type(p, SVt_NV)
1014
1015 #define new_XPVNV()     new_body_type(SVt_PVNV)
1016 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
1017
1018 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
1019 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
1020
1021 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
1022 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
1023
1024 #define new_XPVMG()     new_body_type(SVt_PVMG)
1025 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
1026
1027 #define new_XPVGV()     new_body_type(SVt_PVGV)
1028 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
1029
1030 #endif /* PURIFY */
1031
1032 /* no arena for you! */
1033
1034 #define new_NOARENA(details) \
1035         my_safemalloc((details)->body_size + (details)->offset)
1036 #define new_NOARENAZ(details) \
1037         my_safecalloc((details)->body_size + (details)->offset)
1038
1039 STATIC void *
1040 S_more_bodies (pTHX_ const svtype sv_type)
1041 {
1042     dVAR;
1043     void ** const root = &PL_body_roots[sv_type];
1044     const struct body_details * const bdp = &bodies_by_type[sv_type];
1045     const size_t body_size = bdp->body_size;
1046     char *start;
1047     const char *end;
1048     const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
1049 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1050     static bool done_sanity_check;
1051
1052     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1053      * variables like done_sanity_check. */
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     assert(bdp->arena_size);
1065
1066     start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
1067
1068     end = start + arena_size - 2 * body_size;
1069
1070     /* computed count doesnt reflect the 1st slot reservation */
1071 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1072     DEBUG_m(PerlIO_printf(Perl_debug_log,
1073                           "arena %p end %p arena-size %d (from %d) type %d "
1074                           "size %d ct %d\n",
1075                           (void*)start, (void*)end, (int)arena_size,
1076                           (int)bdp->arena_size, sv_type, (int)body_size,
1077                           (int)arena_size / (int)body_size));
1078 #else
1079     DEBUG_m(PerlIO_printf(Perl_debug_log,
1080                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1081                           (void*)start, (void*)end,
1082                           (int)bdp->arena_size, sv_type, (int)body_size,
1083                           (int)bdp->arena_size / (int)body_size));
1084 #endif
1085     *root = (void *)start;
1086
1087     while (start <= end) {
1088         char * const next = start + body_size;
1089         *(void**) start = (void *)next;
1090         start = next;
1091     }
1092     *(void **)start = 0;
1093
1094     return *root;
1095 }
1096
1097 /* grab a new thing from the free list, allocating more if necessary.
1098    The inline version is used for speed in hot routines, and the
1099    function using it serves the rest (unless PURIFY).
1100 */
1101 #define new_body_inline(xpv, sv_type) \
1102     STMT_START { \
1103         void ** const r3wt = &PL_body_roots[sv_type]; \
1104         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1105           ? *((void **)(r3wt)) : more_bodies(sv_type)); \
1106         *(r3wt) = *(void**)(xpv); \
1107     } STMT_END
1108
1109 #ifndef PURIFY
1110
1111 STATIC void *
1112 S_new_body(pTHX_ const svtype sv_type)
1113 {
1114     dVAR;
1115     void *xpv;
1116     new_body_inline(xpv, sv_type);
1117     return xpv;
1118 }
1119
1120 #endif
1121
1122 static const struct body_details fake_rv =
1123     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1124
1125 /*
1126 =for apidoc sv_upgrade
1127
1128 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1129 SV, then copies across as much information as possible from the old body.
1130 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1131
1132 =cut
1133 */
1134
1135 void
1136 Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
1137 {
1138     dVAR;
1139     void*       old_body;
1140     void*       new_body;
1141     const svtype old_type = SvTYPE(sv);
1142     const struct body_details *new_type_details;
1143     const struct body_details *old_type_details
1144         = bodies_by_type + old_type;
1145     SV *referant = NULL;
1146
1147     PERL_ARGS_ASSERT_SV_UPGRADE;
1148
1149     if (new_type != SVt_PV && SvIsCOW(sv)) {
1150         sv_force_normal_flags(sv, 0);
1151     }
1152
1153     if (old_type == new_type)
1154         return;
1155
1156     old_body = SvANY(sv);
1157
1158     /* Copying structures onto other structures that have been neatly zeroed
1159        has a subtle gotcha. Consider XPVMG
1160
1161        +------+------+------+------+------+-------+-------+
1162        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1163        +------+------+------+------+------+-------+-------+
1164        0      4      8     12     16     20      24      28
1165
1166        where NVs are aligned to 8 bytes, so that sizeof that structure is
1167        actually 32 bytes long, with 4 bytes of padding at the end:
1168
1169        +------+------+------+------+------+-------+-------+------+
1170        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1171        +------+------+------+------+------+-------+-------+------+
1172        0      4      8     12     16     20      24      28     32
1173
1174        so what happens if you allocate memory for this structure:
1175
1176        +------+------+------+------+------+-------+-------+------+------+...
1177        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1178        +------+------+------+------+------+-------+-------+------+------+...
1179        0      4      8     12     16     20      24      28     32     36
1180
1181        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1182        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1183        started out as zero once, but it's quite possible that it isn't. So now,
1184        rather than a nicely zeroed GP, you have it pointing somewhere random.
1185        Bugs ensue.
1186
1187        (In fact, GP ends up pointing at a previous GP structure, because the
1188        principle cause of the padding in XPVMG getting garbage is a copy of
1189        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1190        this happens to be moot because XPVGV has been re-ordered, with GP
1191        no longer after STASH)
1192
1193        So we are careful and work out the size of used parts of all the
1194        structures.  */
1195
1196     switch (old_type) {
1197     case SVt_NULL:
1198         break;
1199     case SVt_IV:
1200         if (SvROK(sv)) {
1201             referant = SvRV(sv);
1202             old_type_details = &fake_rv;
1203             if (new_type == SVt_NV)
1204                 new_type = SVt_PVNV;
1205         } else {
1206             if (new_type < SVt_PVIV) {
1207                 new_type = (new_type == SVt_NV)
1208                     ? SVt_PVNV : SVt_PVIV;
1209             }
1210         }
1211         break;
1212     case SVt_NV:
1213         if (new_type < SVt_PVNV) {
1214             new_type = SVt_PVNV;
1215         }
1216         break;
1217     case SVt_PV:
1218         assert(new_type > SVt_PV);
1219         assert(SVt_IV < SVt_PV);
1220         assert(SVt_NV < SVt_PV);
1221         break;
1222     case SVt_PVIV:
1223         break;
1224     case SVt_PVNV:
1225         break;
1226     case SVt_PVMG:
1227         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1228            there's no way that it can be safely upgraded, because perl.c
1229            expects to Safefree(SvANY(PL_mess_sv))  */
1230         assert(sv != PL_mess_sv);
1231         /* This flag bit is used to mean other things in other scalar types.
1232            Given that it only has meaning inside the pad, it shouldn't be set
1233            on anything that can get upgraded.  */
1234         assert(!SvPAD_TYPED(sv));
1235         break;
1236     default:
1237         if (old_type_details->cant_upgrade)
1238             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1239                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1240     }
1241
1242     if (old_type > new_type)
1243         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1244                 (int)old_type, (int)new_type);
1245
1246     new_type_details = bodies_by_type + new_type;
1247
1248     SvFLAGS(sv) &= ~SVTYPEMASK;
1249     SvFLAGS(sv) |= new_type;
1250
1251     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1252        the return statements above will have triggered.  */
1253     assert (new_type != SVt_NULL);
1254     switch (new_type) {
1255     case SVt_IV:
1256         assert(old_type == SVt_NULL);
1257         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1258         SvIV_set(sv, 0);
1259         return;
1260     case SVt_NV:
1261         assert(old_type == SVt_NULL);
1262         SvANY(sv) = new_XNV();
1263         SvNV_set(sv, 0);
1264         return;
1265     case SVt_PVHV:
1266     case SVt_PVAV:
1267         assert(new_type_details->body_size);
1268
1269 #ifndef PURIFY  
1270         assert(new_type_details->arena);
1271         assert(new_type_details->arena_size);
1272         /* This points to the start of the allocated area.  */
1273         new_body_inline(new_body, new_type);
1274         Zero(new_body, new_type_details->body_size, char);
1275         new_body = ((char *)new_body) - new_type_details->offset;
1276 #else
1277         /* We always allocated the full length item with PURIFY. To do this
1278            we fake things so that arena is false for all 16 types..  */
1279         new_body = new_NOARENAZ(new_type_details);
1280 #endif
1281         SvANY(sv) = new_body;
1282         if (new_type == SVt_PVAV) {
1283             AvMAX(sv)   = -1;
1284             AvFILLp(sv) = -1;
1285             AvREAL_only(sv);
1286             if (old_type_details->body_size) {
1287                 AvALLOC(sv) = 0;
1288             } else {
1289                 /* It will have been zeroed when the new body was allocated.
1290                    Lets not write to it, in case it confuses a write-back
1291                    cache.  */
1292             }
1293         } else {
1294             assert(!SvOK(sv));
1295             SvOK_off(sv);
1296 #ifndef NODEFAULT_SHAREKEYS
1297             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1298 #endif
1299             HvMAX(sv) = 7; /* (start with 8 buckets) */
1300             if (old_type_details->body_size) {
1301                 HvFILL(sv) = 0;
1302             } else {
1303                 /* It will have been zeroed when the new body was allocated.
1304                    Lets not write to it, in case it confuses a write-back
1305                    cache.  */
1306             }
1307         }
1308
1309         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1310            The target created by newSVrv also is, and it can have magic.
1311            However, it never has SvPVX set.
1312         */
1313         if (old_type == SVt_IV) {
1314             assert(!SvROK(sv));
1315         } else if (old_type >= SVt_PV) {
1316             assert(SvPVX_const(sv) == 0);
1317         }
1318
1319         if (old_type >= SVt_PVMG) {
1320             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1321             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1322         } else {
1323             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1324         }
1325         break;
1326
1327
1328     case SVt_PVIV:
1329         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1330            no route from NV to PVIV, NOK can never be true  */
1331         assert(!SvNOKp(sv));
1332         assert(!SvNOK(sv));
1333     case SVt_PVIO:
1334     case SVt_PVFM:
1335     case SVt_PVGV:
1336     case SVt_PVCV:
1337     case SVt_PVLV:
1338     case SVt_REGEXP:
1339     case SVt_PVMG:
1340     case SVt_PVNV:
1341     case SVt_PV:
1342
1343         assert(new_type_details->body_size);
1344         /* We always allocated the full length item with PURIFY. To do this
1345            we fake things so that arena is false for all 16 types..  */
1346         if(new_type_details->arena) {
1347             /* This points to the start of the allocated area.  */
1348             new_body_inline(new_body, new_type);
1349             Zero(new_body, new_type_details->body_size, char);
1350             new_body = ((char *)new_body) - new_type_details->offset;
1351         } else {
1352             new_body = new_NOARENAZ(new_type_details);
1353         }
1354         SvANY(sv) = new_body;
1355
1356         if (old_type_details->copy) {
1357             /* There is now the potential for an upgrade from something without
1358                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1359             int offset = old_type_details->offset;
1360             int length = old_type_details->copy;
1361
1362             if (new_type_details->offset > old_type_details->offset) {
1363                 const int difference
1364                     = new_type_details->offset - old_type_details->offset;
1365                 offset += difference;
1366                 length -= difference;
1367             }
1368             assert (length >= 0);
1369                 
1370             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1371                  char);
1372         }
1373
1374 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1375         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1376          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1377          * NV slot, but the new one does, then we need to initialise the
1378          * freshly created NV slot with whatever the correct bit pattern is
1379          * for 0.0  */
1380         if (old_type_details->zero_nv && !new_type_details->zero_nv
1381             && !isGV_with_GP(sv))
1382             SvNV_set(sv, 0);
1383 #endif
1384
1385         if (new_type == SVt_PVIO)
1386             IoPAGE_LEN(sv) = 60;
1387         if (old_type < SVt_PV) {
1388             /* referant will be NULL unless the old type was SVt_IV emulating
1389                SVt_RV */
1390             sv->sv_u.svu_rv = referant;
1391         }
1392         break;
1393     default:
1394         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1395                    (unsigned long)new_type);
1396     }
1397
1398     if (old_type_details->arena) {
1399         /* If there was an old body, then we need to free it.
1400            Note that there is an assumption that all bodies of types that
1401            can be upgraded came from arenas. Only the more complex non-
1402            upgradable types are allowed to be directly malloc()ed.  */
1403 #ifdef PURIFY
1404         my_safefree(old_body);
1405 #else
1406         del_body((void*)((char*)old_body + old_type_details->offset),
1407                  &PL_body_roots[old_type]);
1408 #endif
1409     }
1410 }
1411
1412 /*
1413 =for apidoc sv_backoff
1414
1415 Remove any string offset. You should normally use the C<SvOOK_off> macro
1416 wrapper instead.
1417
1418 =cut
1419 */
1420
1421 int
1422 Perl_sv_backoff(pTHX_ register SV *const sv)
1423 {
1424     STRLEN delta;
1425     const char * const s = SvPVX_const(sv);
1426
1427     PERL_ARGS_ASSERT_SV_BACKOFF;
1428     PERL_UNUSED_CONTEXT;
1429
1430     assert(SvOOK(sv));
1431     assert(SvTYPE(sv) != SVt_PVHV);
1432     assert(SvTYPE(sv) != SVt_PVAV);
1433
1434     SvOOK_offset(sv, delta);
1435     
1436     SvLEN_set(sv, SvLEN(sv) + delta);
1437     SvPV_set(sv, SvPVX(sv) - delta);
1438     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1439     SvFLAGS(sv) &= ~SVf_OOK;
1440     return 0;
1441 }
1442
1443 /*
1444 =for apidoc sv_grow
1445
1446 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1447 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1448 Use the C<SvGROW> wrapper instead.
1449
1450 =cut
1451 */
1452
1453 char *
1454 Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen)
1455 {
1456     register char *s;
1457
1458     PERL_ARGS_ASSERT_SV_GROW;
1459
1460     if (PL_madskills && newlen >= 0x100000) {
1461         PerlIO_printf(Perl_debug_log,
1462                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1463     }
1464 #ifdef HAS_64K_LIMIT
1465     if (newlen >= 0x10000) {
1466         PerlIO_printf(Perl_debug_log,
1467                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1468         my_exit(1);
1469     }
1470 #endif /* HAS_64K_LIMIT */
1471     if (SvROK(sv))
1472         sv_unref(sv);
1473     if (SvTYPE(sv) < SVt_PV) {
1474         sv_upgrade(sv, SVt_PV);
1475         s = SvPVX_mutable(sv);
1476     }
1477     else if (SvOOK(sv)) {       /* pv is offset? */
1478         sv_backoff(sv);
1479         s = SvPVX_mutable(sv);
1480         if (newlen > SvLEN(sv))
1481             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1482 #ifdef HAS_64K_LIMIT
1483         if (newlen >= 0x10000)
1484             newlen = 0xFFFF;
1485 #endif
1486     }
1487     else
1488         s = SvPVX_mutable(sv);
1489
1490     if (newlen > SvLEN(sv)) {           /* need more room? */
1491 #ifndef MYMALLOC
1492         newlen = PERL_STRLEN_ROUNDUP(newlen);
1493 #endif
1494         if (SvLEN(sv) && s) {
1495             s = (char*)saferealloc(s, newlen);
1496         }
1497         else {
1498             s = (char*)safemalloc(newlen);
1499             if (SvPVX_const(sv) && SvCUR(sv)) {
1500                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1501             }
1502         }
1503         SvPV_set(sv, s);
1504 #ifdef Perl_safesysmalloc_size
1505         /* Do this here, do it once, do it right, and then we will never get
1506            called back into sv_grow() unless there really is some growing
1507            needed.  */
1508         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1509 #else
1510         SvLEN_set(sv, newlen);
1511 #endif
1512     }
1513     return s;
1514 }
1515
1516 /*
1517 =for apidoc sv_setiv
1518
1519 Copies an integer into the given SV, upgrading first if necessary.
1520 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1521
1522 =cut
1523 */
1524
1525 void
1526 Perl_sv_setiv(pTHX_ register SV *const sv, const IV i)
1527 {
1528     dVAR;
1529
1530     PERL_ARGS_ASSERT_SV_SETIV;
1531
1532     SV_CHECK_THINKFIRST_COW_DROP(sv);
1533     switch (SvTYPE(sv)) {
1534     case SVt_NULL:
1535     case SVt_NV:
1536         sv_upgrade(sv, SVt_IV);
1537         break;
1538     case SVt_PV:
1539         sv_upgrade(sv, SVt_PVIV);
1540         break;
1541
1542     case SVt_PVGV:
1543     case SVt_PVAV:
1544     case SVt_PVHV:
1545     case SVt_PVCV:
1546     case SVt_PVFM:
1547     case SVt_PVIO:
1548         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1549                    OP_DESC(PL_op));
1550     default: NOOP;
1551     }
1552     (void)SvIOK_only(sv);                       /* validate number */
1553     SvIV_set(sv, i);
1554     SvTAINT(sv);
1555 }
1556
1557 /*
1558 =for apidoc sv_setiv_mg
1559
1560 Like C<sv_setiv>, but also handles 'set' magic.
1561
1562 =cut
1563 */
1564
1565 void
1566 Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i)
1567 {
1568     PERL_ARGS_ASSERT_SV_SETIV_MG;
1569
1570     sv_setiv(sv,i);
1571     SvSETMAGIC(sv);
1572 }
1573
1574 /*
1575 =for apidoc sv_setuv
1576
1577 Copies an unsigned integer into the given SV, upgrading first if necessary.
1578 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1579
1580 =cut
1581 */
1582
1583 void
1584 Perl_sv_setuv(pTHX_ register SV *const sv, const UV u)
1585 {
1586     PERL_ARGS_ASSERT_SV_SETUV;
1587
1588     /* With these two if statements:
1589        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1590
1591        without
1592        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1593
1594        If you wish to remove them, please benchmark to see what the effect is
1595     */
1596     if (u <= (UV)IV_MAX) {
1597        sv_setiv(sv, (IV)u);
1598        return;
1599     }
1600     sv_setiv(sv, 0);
1601     SvIsUV_on(sv);
1602     SvUV_set(sv, u);
1603 }
1604
1605 /*
1606 =for apidoc sv_setuv_mg
1607
1608 Like C<sv_setuv>, but also handles 'set' magic.
1609
1610 =cut
1611 */
1612
1613 void
1614 Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u)
1615 {
1616     PERL_ARGS_ASSERT_SV_SETUV_MG;
1617
1618     sv_setuv(sv,u);
1619     SvSETMAGIC(sv);
1620 }
1621
1622 /*
1623 =for apidoc sv_setnv
1624
1625 Copies a double into the given SV, upgrading first if necessary.
1626 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1627
1628 =cut
1629 */
1630
1631 void
1632 Perl_sv_setnv(pTHX_ register SV *const sv, const NV num)
1633 {
1634     dVAR;
1635
1636     PERL_ARGS_ASSERT_SV_SETNV;
1637
1638     SV_CHECK_THINKFIRST_COW_DROP(sv);
1639     switch (SvTYPE(sv)) {
1640     case SVt_NULL:
1641     case SVt_IV:
1642         sv_upgrade(sv, SVt_NV);
1643         break;
1644     case SVt_PV:
1645     case SVt_PVIV:
1646         sv_upgrade(sv, SVt_PVNV);
1647         break;
1648
1649     case SVt_PVGV:
1650     case SVt_PVAV:
1651     case SVt_PVHV:
1652     case SVt_PVCV:
1653     case SVt_PVFM:
1654     case SVt_PVIO:
1655         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1656                    OP_NAME(PL_op));
1657     default: NOOP;
1658     }
1659     SvNV_set(sv, num);
1660     (void)SvNOK_only(sv);                       /* validate number */
1661     SvTAINT(sv);
1662 }
1663
1664 /*
1665 =for apidoc sv_setnv_mg
1666
1667 Like C<sv_setnv>, but also handles 'set' magic.
1668
1669 =cut
1670 */
1671
1672 void
1673 Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num)
1674 {
1675     PERL_ARGS_ASSERT_SV_SETNV_MG;
1676
1677     sv_setnv(sv,num);
1678     SvSETMAGIC(sv);
1679 }
1680
1681 /* Print an "isn't numeric" warning, using a cleaned-up,
1682  * printable version of the offending string
1683  */
1684
1685 STATIC void
1686 S_not_a_number(pTHX_ SV *const sv)
1687 {
1688      dVAR;
1689      SV *dsv;
1690      char tmpbuf[64];
1691      const char *pv;
1692
1693      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1694
1695      if (DO_UTF8(sv)) {
1696           dsv = newSVpvs_flags("", SVs_TEMP);
1697           pv = sv_uni_display(dsv, sv, 10, 0);
1698      } else {
1699           char *d = tmpbuf;
1700           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1701           /* each *s can expand to 4 chars + "...\0",
1702              i.e. need room for 8 chars */
1703         
1704           const char *s = SvPVX_const(sv);
1705           const char * const end = s + SvCUR(sv);
1706           for ( ; s < end && d < limit; s++ ) {
1707                int ch = *s & 0xFF;
1708                if (ch & 128 && !isPRINT_LC(ch)) {
1709                     *d++ = 'M';
1710                     *d++ = '-';
1711                     ch &= 127;
1712                }
1713                if (ch == '\n') {
1714                     *d++ = '\\';
1715                     *d++ = 'n';
1716                }
1717                else if (ch == '\r') {
1718                     *d++ = '\\';
1719                     *d++ = 'r';
1720                }
1721                else if (ch == '\f') {
1722                     *d++ = '\\';
1723                     *d++ = 'f';
1724                }
1725                else if (ch == '\\') {
1726                     *d++ = '\\';
1727                     *d++ = '\\';
1728                }
1729                else if (ch == '\0') {
1730                     *d++ = '\\';
1731                     *d++ = '0';
1732                }
1733                else if (isPRINT_LC(ch))
1734                     *d++ = ch;
1735                else {
1736                     *d++ = '^';
1737                     *d++ = toCTRL(ch);
1738                }
1739           }
1740           if (s < end) {
1741                *d++ = '.';
1742                *d++ = '.';
1743                *d++ = '.';
1744           }
1745           *d = '\0';
1746           pv = tmpbuf;
1747     }
1748
1749     if (PL_op)
1750         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1751                     "Argument \"%s\" isn't numeric in %s", pv,
1752                     OP_DESC(PL_op));
1753     else
1754         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1755                     "Argument \"%s\" isn't numeric", pv);
1756 }
1757
1758 /*
1759 =for apidoc looks_like_number
1760
1761 Test if the content of an SV looks like a number (or is a number).
1762 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1763 non-numeric warning), even if your atof() doesn't grok them.
1764
1765 =cut
1766 */
1767
1768 I32
1769 Perl_looks_like_number(pTHX_ SV *const sv)
1770 {
1771     register const char *sbegin;
1772     STRLEN len;
1773
1774     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1775
1776     if (SvPOK(sv)) {
1777         sbegin = SvPVX_const(sv);
1778         len = SvCUR(sv);
1779     }
1780     else if (SvPOKp(sv))
1781         sbegin = SvPV_const(sv, len);
1782     else
1783         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1784     return grok_number(sbegin, len, NULL);
1785 }
1786
1787 STATIC bool
1788 S_glob_2number(pTHX_ GV * const gv)
1789 {
1790     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1791     SV *const buffer = sv_newmortal();
1792
1793     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1794
1795     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1796        is on.  */
1797     SvFAKE_off(gv);
1798     gv_efullname3(buffer, gv, "*");
1799     SvFLAGS(gv) |= wasfake;
1800
1801     /* We know that all GVs stringify to something that is not-a-number,
1802         so no need to test that.  */
1803     if (ckWARN(WARN_NUMERIC))
1804         not_a_number(buffer);
1805     /* We just want something true to return, so that S_sv_2iuv_common
1806         can tail call us and return true.  */
1807     return TRUE;
1808 }
1809
1810 STATIC char *
1811 S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
1812 {
1813     const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
1814     SV *const buffer = sv_newmortal();
1815
1816     PERL_ARGS_ASSERT_GLOB_2PV;
1817
1818     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1819        is on.  */
1820     SvFAKE_off(gv);
1821     gv_efullname3(buffer, gv, "*");
1822     SvFLAGS(gv) |= wasfake;
1823
1824     assert(SvPOK(buffer));
1825     if (len) {
1826         *len = SvCUR(buffer);
1827     }
1828     return SvPVX(buffer);
1829 }
1830
1831 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1832    until proven guilty, assume that things are not that bad... */
1833
1834 /*
1835    NV_PRESERVES_UV:
1836
1837    As 64 bit platforms often have an NV that doesn't preserve all bits of
1838    an IV (an assumption perl has been based on to date) it becomes necessary
1839    to remove the assumption that the NV always carries enough precision to
1840    recreate the IV whenever needed, and that the NV is the canonical form.
1841    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1842    precision as a side effect of conversion (which would lead to insanity
1843    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1844    1) to distinguish between IV/UV/NV slots that have cached a valid
1845       conversion where precision was lost and IV/UV/NV slots that have a
1846       valid conversion which has lost no precision
1847    2) to ensure that if a numeric conversion to one form is requested that
1848       would lose precision, the precise conversion (or differently
1849       imprecise conversion) is also performed and cached, to prevent
1850       requests for different numeric formats on the same SV causing
1851       lossy conversion chains. (lossless conversion chains are perfectly
1852       acceptable (still))
1853
1854
1855    flags are used:
1856    SvIOKp is true if the IV slot contains a valid value
1857    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1858    SvNOKp is true if the NV slot contains a valid value
1859    SvNOK  is true only if the NV value is accurate
1860
1861    so
1862    while converting from PV to NV, check to see if converting that NV to an
1863    IV(or UV) would lose accuracy over a direct conversion from PV to
1864    IV(or UV). If it would, cache both conversions, return NV, but mark
1865    SV as IOK NOKp (ie not NOK).
1866
1867    While converting from PV to IV, check to see if converting that IV to an
1868    NV would lose accuracy over a direct conversion from PV to NV. If it
1869    would, cache both conversions, flag similarly.
1870
1871    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1872    correctly because if IV & NV were set NV *always* overruled.
1873    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1874    changes - now IV and NV together means that the two are interchangeable:
1875    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1876
1877    The benefit of this is that operations such as pp_add know that if
1878    SvIOK is true for both left and right operands, then integer addition
1879    can be used instead of floating point (for cases where the result won't
1880    overflow). Before, floating point was always used, which could lead to
1881    loss of precision compared with integer addition.
1882
1883    * making IV and NV equal status should make maths accurate on 64 bit
1884      platforms
1885    * may speed up maths somewhat if pp_add and friends start to use
1886      integers when possible instead of fp. (Hopefully the overhead in
1887      looking for SvIOK and checking for overflow will not outweigh the
1888      fp to integer speedup)
1889    * will slow down integer operations (callers of SvIV) on "inaccurate"
1890      values, as the change from SvIOK to SvIOKp will cause a call into
1891      sv_2iv each time rather than a macro access direct to the IV slot
1892    * should speed up number->string conversion on integers as IV is
1893      favoured when IV and NV are equally accurate
1894
1895    ####################################################################
1896    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1897    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1898    On the other hand, SvUOK is true iff UV.
1899    ####################################################################
1900
1901    Your mileage will vary depending your CPU's relative fp to integer
1902    performance ratio.
1903 */
1904
1905 #ifndef NV_PRESERVES_UV
1906 #  define IS_NUMBER_UNDERFLOW_IV 1
1907 #  define IS_NUMBER_UNDERFLOW_UV 2
1908 #  define IS_NUMBER_IV_AND_UV    2
1909 #  define IS_NUMBER_OVERFLOW_IV  4
1910 #  define IS_NUMBER_OVERFLOW_UV  5
1911
1912 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1913
1914 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1915 STATIC int
1916 S_sv_2iuv_non_preserve(pTHX_ register SV *const sv
1917 #  ifdef DEBUGGING
1918                        , I32 numtype
1919 #  endif
1920                        )
1921 {
1922     dVAR;
1923
1924     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
1925
1926     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));
1927     if (SvNVX(sv) < (NV)IV_MIN) {
1928         (void)SvIOKp_on(sv);
1929         (void)SvNOK_on(sv);
1930         SvIV_set(sv, IV_MIN);
1931         return IS_NUMBER_UNDERFLOW_IV;
1932     }
1933     if (SvNVX(sv) > (NV)UV_MAX) {
1934         (void)SvIOKp_on(sv);
1935         (void)SvNOK_on(sv);
1936         SvIsUV_on(sv);
1937         SvUV_set(sv, UV_MAX);
1938         return IS_NUMBER_OVERFLOW_UV;
1939     }
1940     (void)SvIOKp_on(sv);
1941     (void)SvNOK_on(sv);
1942     /* Can't use strtol etc to convert this string.  (See truth table in
1943        sv_2iv  */
1944     if (SvNVX(sv) <= (UV)IV_MAX) {
1945         SvIV_set(sv, I_V(SvNVX(sv)));
1946         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1947             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1948         } else {
1949             /* Integer is imprecise. NOK, IOKp */
1950         }
1951         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1952     }
1953     SvIsUV_on(sv);
1954     SvUV_set(sv, U_V(SvNVX(sv)));
1955     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1956         if (SvUVX(sv) == UV_MAX) {
1957             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1958                possibly be preserved by NV. Hence, it must be overflow.
1959                NOK, IOKp */
1960             return IS_NUMBER_OVERFLOW_UV;
1961         }
1962         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1963     } else {
1964         /* Integer is imprecise. NOK, IOKp */
1965     }
1966     return IS_NUMBER_OVERFLOW_IV;
1967 }
1968 #endif /* !NV_PRESERVES_UV*/
1969
1970 STATIC bool
1971 S_sv_2iuv_common(pTHX_ SV *const sv)
1972 {
1973     dVAR;
1974
1975     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
1976
1977     if (SvNOKp(sv)) {
1978         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1979          * without also getting a cached IV/UV from it at the same time
1980          * (ie PV->NV conversion should detect loss of accuracy and cache
1981          * IV or UV at same time to avoid this. */
1982         /* IV-over-UV optimisation - choose to cache IV if possible */
1983
1984         if (SvTYPE(sv) == SVt_NV)
1985             sv_upgrade(sv, SVt_PVNV);
1986
1987         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1988         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1989            certainly cast into the IV range at IV_MAX, whereas the correct
1990            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1991            cases go to UV */
1992 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
1993         if (Perl_isnan(SvNVX(sv))) {
1994             SvUV_set(sv, 0);
1995             SvIsUV_on(sv);
1996             return FALSE;
1997         }
1998 #endif
1999         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2000             SvIV_set(sv, I_V(SvNVX(sv)));
2001             if (SvNVX(sv) == (NV) SvIVX(sv)
2002 #ifndef NV_PRESERVES_UV
2003                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2004                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2005                 /* Don't flag it as "accurately an integer" if the number
2006                    came from a (by definition imprecise) NV operation, and
2007                    we're outside the range of NV integer precision */
2008 #endif
2009                 ) {
2010                 if (SvNOK(sv))
2011                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2012                 else {
2013                     /* scalar has trailing garbage, eg "42a" */
2014                 }
2015                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2016                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2017                                       PTR2UV(sv),
2018                                       SvNVX(sv),
2019                                       SvIVX(sv)));
2020
2021             } else {
2022                 /* IV not precise.  No need to convert from PV, as NV
2023                    conversion would already have cached IV if it detected
2024                    that PV->IV would be better than PV->NV->IV
2025                    flags already correct - don't set public IOK.  */
2026                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2027                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2028                                       PTR2UV(sv),
2029                                       SvNVX(sv),
2030                                       SvIVX(sv)));
2031             }
2032             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2033                but the cast (NV)IV_MIN rounds to a the value less (more
2034                negative) than IV_MIN which happens to be equal to SvNVX ??
2035                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2036                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2037                (NV)UVX == NVX are both true, but the values differ. :-(
2038                Hopefully for 2s complement IV_MIN is something like
2039                0x8000000000000000 which will be exact. NWC */
2040         }
2041         else {
2042             SvUV_set(sv, U_V(SvNVX(sv)));
2043             if (
2044                 (SvNVX(sv) == (NV) SvUVX(sv))
2045 #ifndef  NV_PRESERVES_UV
2046                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2047                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2048                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2049                 /* Don't flag it as "accurately an integer" if the number
2050                    came from a (by definition imprecise) NV operation, and
2051                    we're outside the range of NV integer precision */
2052 #endif
2053                 && SvNOK(sv)
2054                 )
2055                 SvIOK_on(sv);
2056             SvIsUV_on(sv);
2057             DEBUG_c(PerlIO_printf(Perl_debug_log,
2058                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2059                                   PTR2UV(sv),
2060                                   SvUVX(sv),
2061                                   SvUVX(sv)));
2062         }
2063     }
2064     else if (SvPOKp(sv) && SvLEN(sv)) {
2065         UV value;
2066         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2067         /* We want to avoid a possible problem when we cache an IV/ a UV which
2068            may be later translated to an NV, and the resulting NV is not
2069            the same as the direct translation of the initial string
2070            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2071            be careful to ensure that the value with the .456 is around if the
2072            NV value is requested in the future).
2073         
2074            This means that if we cache such an IV/a UV, we need to cache the
2075            NV as well.  Moreover, we trade speed for space, and do not
2076            cache the NV if we are sure it's not needed.
2077          */
2078
2079         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2080         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2081              == IS_NUMBER_IN_UV) {
2082             /* It's definitely an integer, only upgrade to PVIV */
2083             if (SvTYPE(sv) < SVt_PVIV)
2084                 sv_upgrade(sv, SVt_PVIV);
2085             (void)SvIOK_on(sv);
2086         } else if (SvTYPE(sv) < SVt_PVNV)
2087             sv_upgrade(sv, SVt_PVNV);
2088
2089         /* If NVs preserve UVs then we only use the UV value if we know that
2090            we aren't going to call atof() below. If NVs don't preserve UVs
2091            then the value returned may have more precision than atof() will
2092            return, even though value isn't perfectly accurate.  */
2093         if ((numtype & (IS_NUMBER_IN_UV
2094 #ifdef NV_PRESERVES_UV
2095                         | IS_NUMBER_NOT_INT
2096 #endif
2097             )) == IS_NUMBER_IN_UV) {
2098             /* This won't turn off the public IOK flag if it was set above  */
2099             (void)SvIOKp_on(sv);
2100
2101             if (!(numtype & IS_NUMBER_NEG)) {
2102                 /* positive */;
2103                 if (value <= (UV)IV_MAX) {
2104                     SvIV_set(sv, (IV)value);
2105                 } else {
2106                     /* it didn't overflow, and it was positive. */
2107                     SvUV_set(sv, value);
2108                     SvIsUV_on(sv);
2109                 }
2110             } else {
2111                 /* 2s complement assumption  */
2112                 if (value <= (UV)IV_MIN) {
2113                     SvIV_set(sv, -(IV)value);
2114                 } else {
2115                     /* Too negative for an IV.  This is a double upgrade, but
2116                        I'm assuming it will be rare.  */
2117                     if (SvTYPE(sv) < SVt_PVNV)
2118                         sv_upgrade(sv, SVt_PVNV);
2119                     SvNOK_on(sv);
2120                     SvIOK_off(sv);
2121                     SvIOKp_on(sv);
2122                     SvNV_set(sv, -(NV)value);
2123                     SvIV_set(sv, IV_MIN);
2124                 }
2125             }
2126         }
2127         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2128            will be in the previous block to set the IV slot, and the next
2129            block to set the NV slot.  So no else here.  */
2130         
2131         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2132             != IS_NUMBER_IN_UV) {
2133             /* It wasn't an (integer that doesn't overflow the UV). */
2134             SvNV_set(sv, Atof(SvPVX_const(sv)));
2135
2136             if (! numtype && ckWARN(WARN_NUMERIC))
2137                 not_a_number(sv);
2138
2139 #if defined(USE_LONG_DOUBLE)
2140             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2141                                   PTR2UV(sv), SvNVX(sv)));
2142 #else
2143             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2144                                   PTR2UV(sv), SvNVX(sv)));
2145 #endif
2146
2147 #ifdef NV_PRESERVES_UV
2148             (void)SvIOKp_on(sv);
2149             (void)SvNOK_on(sv);
2150             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2151                 SvIV_set(sv, I_V(SvNVX(sv)));
2152                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2153                     SvIOK_on(sv);
2154                 } else {
2155                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2156                 }
2157                 /* UV will not work better than IV */
2158             } else {
2159                 if (SvNVX(sv) > (NV)UV_MAX) {
2160                     SvIsUV_on(sv);
2161                     /* Integer is inaccurate. NOK, IOKp, is UV */
2162                     SvUV_set(sv, UV_MAX);
2163                 } else {
2164                     SvUV_set(sv, U_V(SvNVX(sv)));
2165                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2166                        NV preservse UV so can do correct comparison.  */
2167                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2168                         SvIOK_on(sv);
2169                     } else {
2170                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2171                     }
2172                 }
2173                 SvIsUV_on(sv);
2174             }
2175 #else /* NV_PRESERVES_UV */
2176             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2177                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2178                 /* The IV/UV slot will have been set from value returned by
2179                    grok_number above.  The NV slot has just been set using
2180                    Atof.  */
2181                 SvNOK_on(sv);
2182                 assert (SvIOKp(sv));
2183             } else {
2184                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2185                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2186                     /* Small enough to preserve all bits. */
2187                     (void)SvIOKp_on(sv);
2188                     SvNOK_on(sv);
2189                     SvIV_set(sv, I_V(SvNVX(sv)));
2190                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2191                         SvIOK_on(sv);
2192                     /* Assumption: first non-preserved integer is < IV_MAX,
2193                        this NV is in the preserved range, therefore: */
2194                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2195                           < (UV)IV_MAX)) {
2196                         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);
2197                     }
2198                 } else {
2199                     /* IN_UV NOT_INT
2200                          0      0       already failed to read UV.
2201                          0      1       already failed to read UV.
2202                          1      0       you won't get here in this case. IV/UV
2203                                         slot set, public IOK, Atof() unneeded.
2204                          1      1       already read UV.
2205                        so there's no point in sv_2iuv_non_preserve() attempting
2206                        to use atol, strtol, strtoul etc.  */
2207 #  ifdef DEBUGGING
2208                     sv_2iuv_non_preserve (sv, numtype);
2209 #  else
2210                     sv_2iuv_non_preserve (sv);
2211 #  endif
2212                 }
2213             }
2214 #endif /* NV_PRESERVES_UV */
2215         /* It might be more code efficient to go through the entire logic above
2216            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2217            gets complex and potentially buggy, so more programmer efficient
2218            to do it this way, by turning off the public flags:  */
2219         if (!numtype)
2220             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2221         }
2222     }
2223     else  {
2224         if (isGV_with_GP(sv))
2225             return glob_2number((GV *)sv);
2226
2227         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2228             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2229                 report_uninit(sv);
2230         }
2231         if (SvTYPE(sv) < SVt_IV)
2232             /* Typically the caller expects that sv_any is not NULL now.  */
2233             sv_upgrade(sv, SVt_IV);
2234         /* Return 0 from the caller.  */
2235         return TRUE;
2236     }
2237     return FALSE;
2238 }
2239
2240 /*
2241 =for apidoc sv_2iv_flags
2242
2243 Return the integer value of an SV, doing any necessary string
2244 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2245 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2246
2247 =cut
2248 */
2249
2250 IV
2251 Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
2252 {
2253     dVAR;
2254     if (!sv)
2255         return 0;
2256     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2257         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2258            cache IVs just in case. In practice it seems that they never
2259            actually anywhere accessible by user Perl code, let alone get used
2260            in anything other than a string context.  */
2261         if (flags & SV_GMAGIC)
2262             mg_get(sv);
2263         if (SvIOKp(sv))
2264             return SvIVX(sv);
2265         if (SvNOKp(sv)) {
2266             return I_V(SvNVX(sv));
2267         }
2268         if (SvPOKp(sv) && SvLEN(sv)) {
2269             UV value;
2270             const int numtype
2271                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2272
2273             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2274                 == IS_NUMBER_IN_UV) {
2275                 /* It's definitely an integer */
2276                 if (numtype & IS_NUMBER_NEG) {
2277                     if (value < (UV)IV_MIN)
2278                         return -(IV)value;
2279                 } else {
2280                     if (value < (UV)IV_MAX)
2281                         return (IV)value;
2282                 }
2283             }
2284             if (!numtype) {
2285                 if (ckWARN(WARN_NUMERIC))
2286                     not_a_number(sv);
2287             }
2288             return I_V(Atof(SvPVX_const(sv)));
2289         }
2290         if (SvROK(sv)) {
2291             goto return_rok;
2292         }
2293         assert(SvTYPE(sv) >= SVt_PVMG);
2294         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2295     } else if (SvTHINKFIRST(sv)) {
2296         if (SvROK(sv)) {
2297         return_rok:
2298             if (SvAMAGIC(sv)) {
2299                 SV * const tmpstr=AMG_CALLun(sv,numer);
2300                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2301                     return SvIV(tmpstr);
2302                 }
2303             }
2304             return PTR2IV(SvRV(sv));
2305         }
2306         if (SvIsCOW(sv)) {
2307             sv_force_normal_flags(sv, 0);
2308         }
2309         if (SvREADONLY(sv) && !SvOK(sv)) {
2310             if (ckWARN(WARN_UNINITIALIZED))
2311                 report_uninit(sv);
2312             return 0;
2313         }
2314     }
2315     if (!SvIOKp(sv)) {
2316         if (S_sv_2iuv_common(aTHX_ sv))
2317             return 0;
2318     }
2319     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2320         PTR2UV(sv),SvIVX(sv)));
2321     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2322 }
2323
2324 /*
2325 =for apidoc sv_2uv_flags
2326
2327 Return the unsigned integer value of an SV, doing any necessary string
2328 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2329 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2330
2331 =cut
2332 */
2333
2334 UV
2335 Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
2336 {
2337     dVAR;
2338     if (!sv)
2339         return 0;
2340     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2341         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2342            cache IVs just in case.  */
2343         if (flags & SV_GMAGIC)
2344             mg_get(sv);
2345         if (SvIOKp(sv))
2346             return SvUVX(sv);
2347         if (SvNOKp(sv))
2348             return U_V(SvNVX(sv));
2349         if (SvPOKp(sv) && SvLEN(sv)) {
2350             UV value;
2351             const int numtype
2352                 = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2353
2354             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2355                 == IS_NUMBER_IN_UV) {
2356                 /* It's definitely an integer */
2357                 if (!(numtype & IS_NUMBER_NEG))
2358                     return value;
2359             }
2360             if (!numtype) {
2361                 if (ckWARN(WARN_NUMERIC))
2362                     not_a_number(sv);
2363             }
2364             return U_V(Atof(SvPVX_const(sv)));
2365         }
2366         if (SvROK(sv)) {
2367             goto return_rok;
2368         }
2369         assert(SvTYPE(sv) >= SVt_PVMG);
2370         /* This falls through to the report_uninit inside S_sv_2iuv_common.  */
2371     } else if (SvTHINKFIRST(sv)) {
2372         if (SvROK(sv)) {
2373         return_rok:
2374             if (SvAMAGIC(sv)) {
2375                 SV *const tmpstr = AMG_CALLun(sv,numer);
2376                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2377                     return SvUV(tmpstr);
2378                 }
2379             }
2380             return PTR2UV(SvRV(sv));
2381         }
2382         if (SvIsCOW(sv)) {
2383             sv_force_normal_flags(sv, 0);
2384         }
2385         if (SvREADONLY(sv) && !SvOK(sv)) {
2386             if (ckWARN(WARN_UNINITIALIZED))
2387                 report_uninit(sv);
2388             return 0;
2389         }
2390     }
2391     if (!SvIOKp(sv)) {
2392         if (S_sv_2iuv_common(aTHX_ sv))
2393             return 0;
2394     }
2395
2396     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2397                           PTR2UV(sv),SvUVX(sv)));
2398     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2399 }
2400
2401 /*
2402 =for apidoc sv_2nv
2403
2404 Return the num value of an SV, doing any necessary string or integer
2405 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2406 macros.
2407
2408 =cut
2409 */
2410
2411 NV
2412 Perl_sv_2nv(pTHX_ register SV *const sv)
2413 {
2414     dVAR;
2415     if (!sv)
2416         return 0.0;
2417     if (SvGMAGICAL(sv) || (SvTYPE(sv) == SVt_PVGV && SvVALID(sv))) {
2418         /* FBMs use the same flag bit as SVf_IVisUV, so must let them
2419            cache IVs just in case.  */
2420         mg_get(sv);
2421         if (SvNOKp(sv))
2422             return SvNVX(sv);
2423         if ((SvPOKp(sv) && SvLEN(sv)) && !SvIOKp(sv)) {
2424             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2425                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2426                 not_a_number(sv);
2427             return Atof(SvPVX_const(sv));
2428         }
2429         if (SvIOKp(sv)) {
2430             if (SvIsUV(sv))
2431                 return (NV)SvUVX(sv);
2432             else
2433                 return (NV)SvIVX(sv);
2434         }
2435         if (SvROK(sv)) {
2436             goto return_rok;
2437         }
2438         assert(SvTYPE(sv) >= SVt_PVMG);
2439         /* This falls through to the report_uninit near the end of the
2440            function. */
2441     } else if (SvTHINKFIRST(sv)) {
2442         if (SvROK(sv)) {
2443         return_rok:
2444             if (SvAMAGIC(sv)) {
2445                 SV *const tmpstr = AMG_CALLun(sv,numer);
2446                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2447                     return SvNV(tmpstr);
2448                 }
2449             }
2450             return PTR2NV(SvRV(sv));
2451         }
2452         if (SvIsCOW(sv)) {
2453             sv_force_normal_flags(sv, 0);
2454         }
2455         if (SvREADONLY(sv) && !SvOK(sv)) {
2456             if (ckWARN(WARN_UNINITIALIZED))
2457                 report_uninit(sv);
2458             return 0.0;
2459         }
2460     }
2461     if (SvTYPE(sv) < SVt_NV) {
2462         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2463         sv_upgrade(sv, SVt_NV);
2464 #ifdef USE_LONG_DOUBLE
2465         DEBUG_c({
2466             STORE_NUMERIC_LOCAL_SET_STANDARD();
2467             PerlIO_printf(Perl_debug_log,
2468                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2469                           PTR2UV(sv), SvNVX(sv));
2470             RESTORE_NUMERIC_LOCAL();
2471         });
2472 #else
2473         DEBUG_c({
2474             STORE_NUMERIC_LOCAL_SET_STANDARD();
2475             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2476                           PTR2UV(sv), SvNVX(sv));
2477             RESTORE_NUMERIC_LOCAL();
2478         });
2479 #endif
2480     }
2481     else if (SvTYPE(sv) < SVt_PVNV)
2482         sv_upgrade(sv, SVt_PVNV);
2483     if (SvNOKp(sv)) {
2484         return SvNVX(sv);
2485     }
2486     if (SvIOKp(sv)) {
2487         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2488 #ifdef NV_PRESERVES_UV
2489         if (SvIOK(sv))
2490             SvNOK_on(sv);
2491         else
2492             SvNOKp_on(sv);
2493 #else
2494         /* Only set the public NV OK flag if this NV preserves the IV  */
2495         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2496         if (SvIOK(sv) &&
2497             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2498                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2499             SvNOK_on(sv);
2500         else
2501             SvNOKp_on(sv);
2502 #endif
2503     }
2504     else if (SvPOKp(sv) && SvLEN(sv)) {
2505         UV value;
2506         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2507         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2508             not_a_number(sv);
2509 #ifdef NV_PRESERVES_UV
2510         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2511             == IS_NUMBER_IN_UV) {
2512             /* It's definitely an integer */
2513             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2514         } else
2515             SvNV_set(sv, Atof(SvPVX_const(sv)));
2516         if (numtype)
2517             SvNOK_on(sv);
2518         else
2519             SvNOKp_on(sv);
2520 #else
2521         SvNV_set(sv, Atof(SvPVX_const(sv)));
2522         /* Only set the public NV OK flag if this NV preserves the value in
2523            the PV at least as well as an IV/UV would.
2524            Not sure how to do this 100% reliably. */
2525         /* if that shift count is out of range then Configure's test is
2526            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2527            UV_BITS */
2528         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2529             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2530             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2531         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2532             /* Can't use strtol etc to convert this string, so don't try.
2533                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2534             SvNOK_on(sv);
2535         } else {
2536             /* value has been set.  It may not be precise.  */
2537             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2538                 /* 2s complement assumption for (UV)IV_MIN  */
2539                 SvNOK_on(sv); /* Integer is too negative.  */
2540             } else {
2541                 SvNOKp_on(sv);
2542                 SvIOKp_on(sv);
2543
2544                 if (numtype & IS_NUMBER_NEG) {
2545                     SvIV_set(sv, -(IV)value);
2546                 } else if (value <= (UV)IV_MAX) {
2547                     SvIV_set(sv, (IV)value);
2548                 } else {
2549                     SvUV_set(sv, value);
2550                     SvIsUV_on(sv);
2551                 }
2552
2553                 if (numtype & IS_NUMBER_NOT_INT) {
2554                     /* I believe that even if the original PV had decimals,
2555                        they are lost beyond the limit of the FP precision.
2556                        However, neither is canonical, so both only get p
2557                        flags.  NWC, 2000/11/25 */
2558                     /* Both already have p flags, so do nothing */
2559                 } else {
2560                     const NV nv = SvNVX(sv);
2561                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2562                         if (SvIVX(sv) == I_V(nv)) {
2563                             SvNOK_on(sv);
2564                         } else {
2565                             /* It had no "." so it must be integer.  */
2566                         }
2567                         SvIOK_on(sv);
2568                     } else {
2569                         /* between IV_MAX and NV(UV_MAX).
2570                            Could be slightly > UV_MAX */
2571
2572                         if (numtype & IS_NUMBER_NOT_INT) {
2573                             /* UV and NV both imprecise.  */
2574                         } else {
2575                             const UV nv_as_uv = U_V(nv);
2576
2577                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2578                                 SvNOK_on(sv);
2579                             }
2580                             SvIOK_on(sv);
2581                         }
2582                     }
2583                 }
2584             }
2585         }
2586         /* It might be more code efficient to go through the entire logic above
2587            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2588            gets complex and potentially buggy, so more programmer efficient
2589            to do it this way, by turning off the public flags:  */
2590         if (!numtype)
2591             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2592 #endif /* NV_PRESERVES_UV */
2593     }
2594     else  {
2595         if (isGV_with_GP(sv)) {
2596             glob_2number((GV *)sv);
2597             return 0.0;
2598         }
2599
2600         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2601             report_uninit(sv);
2602         assert (SvTYPE(sv) >= SVt_NV);
2603         /* Typically the caller expects that sv_any is not NULL now.  */
2604         /* XXX Ilya implies that this is a bug in callers that assume this
2605            and ideally should be fixed.  */
2606         return 0.0;
2607     }
2608 #if defined(USE_LONG_DOUBLE)
2609     DEBUG_c({
2610         STORE_NUMERIC_LOCAL_SET_STANDARD();
2611         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2612                       PTR2UV(sv), SvNVX(sv));
2613         RESTORE_NUMERIC_LOCAL();
2614     });
2615 #else
2616     DEBUG_c({
2617         STORE_NUMERIC_LOCAL_SET_STANDARD();
2618         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2619                       PTR2UV(sv), SvNVX(sv));
2620         RESTORE_NUMERIC_LOCAL();
2621     });
2622 #endif
2623     return SvNVX(sv);
2624 }
2625
2626 /*
2627 =for apidoc sv_2num
2628
2629 Return an SV with the numeric value of the source SV, doing any necessary
2630 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2631 access this function.
2632
2633 =cut
2634 */
2635
2636 SV *
2637 Perl_sv_2num(pTHX_ register SV *const sv)
2638 {
2639     PERL_ARGS_ASSERT_SV_2NUM;
2640
2641     if (!SvROK(sv))
2642         return sv;
2643     if (SvAMAGIC(sv)) {
2644         SV * const tmpsv = AMG_CALLun(sv,numer);
2645         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2646             return sv_2num(tmpsv);
2647     }
2648     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2649 }
2650
2651 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2652  * UV as a string towards the end of buf, and return pointers to start and
2653  * end of it.
2654  *
2655  * We assume that buf is at least TYPE_CHARS(UV) long.
2656  */
2657
2658 static char *
2659 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2660 {
2661     char *ptr = buf + TYPE_CHARS(UV);
2662     char * const ebuf = ptr;
2663     int sign;
2664
2665     PERL_ARGS_ASSERT_UIV_2BUF;
2666
2667     if (is_uv)
2668         sign = 0;
2669     else if (iv >= 0) {
2670         uv = iv;
2671         sign = 0;
2672     } else {
2673         uv = -iv;
2674         sign = 1;
2675     }
2676     do {
2677         *--ptr = '0' + (char)(uv % 10);
2678     } while (uv /= 10);
2679     if (sign)
2680         *--ptr = '-';
2681     *peob = ebuf;
2682     return ptr;
2683 }
2684
2685 /*
2686 =for apidoc sv_2pv_flags
2687
2688 Returns a pointer to the string value of an SV, and sets *lp to its length.
2689 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2690 if necessary.
2691 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2692 usually end up here too.
2693
2694 =cut
2695 */
2696
2697 char *
2698 Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags)
2699 {
2700     dVAR;
2701     register char *s;
2702
2703     if (!sv) {
2704         if (lp)
2705             *lp = 0;
2706         return (char *)"";
2707     }
2708     if (SvGMAGICAL(sv)) {
2709         if (flags & SV_GMAGIC)
2710             mg_get(sv);
2711         if (SvPOKp(sv)) {
2712             if (lp)
2713                 *lp = SvCUR(sv);
2714             if (flags & SV_MUTABLE_RETURN)
2715                 return SvPVX_mutable(sv);
2716             if (flags & SV_CONST_RETURN)
2717                 return (char *)SvPVX_const(sv);
2718             return SvPVX(sv);
2719         }
2720         if (SvIOKp(sv) || SvNOKp(sv)) {
2721             char tbuf[64];  /* Must fit sprintf/Gconvert of longest IV/NV */
2722             STRLEN len;
2723
2724             if (SvIOKp(sv)) {
2725                 len = SvIsUV(sv)
2726                     ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
2727                     : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
2728             } else {
2729                 Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
2730                 len = strlen(tbuf);
2731             }
2732             assert(!SvROK(sv));
2733             {
2734                 dVAR;
2735
2736 #ifdef FIXNEGATIVEZERO
2737                 if (len == 2 && tbuf[0] == '-' && tbuf[1] == '0') {
2738                     tbuf[0] = '0';
2739                     tbuf[1] = 0;
2740                     len = 1;
2741                 }
2742 #endif
2743                 SvUPGRADE(sv, SVt_PV);
2744                 if (lp)
2745                     *lp = len;
2746                 s = SvGROW_mutable(sv, len + 1);
2747                 SvCUR_set(sv, len);
2748                 SvPOKp_on(sv);
2749                 return (char*)memcpy(s, tbuf, len + 1);
2750             }
2751         }
2752         if (SvROK(sv)) {
2753             goto return_rok;
2754         }
2755         assert(SvTYPE(sv) >= SVt_PVMG);
2756         /* This falls through to the report_uninit near the end of the
2757            function. */
2758     } else if (SvTHINKFIRST(sv)) {
2759         if (SvROK(sv)) {
2760         return_rok:
2761             if (SvAMAGIC(sv)) {
2762                 SV *const tmpstr = AMG_CALLun(sv,string);
2763                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2764                     /* Unwrap this:  */
2765                     /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2766                      */
2767
2768                     char *pv;
2769                     if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2770                         if (flags & SV_CONST_RETURN) {
2771                             pv = (char *) SvPVX_const(tmpstr);
2772                         } else {
2773                             pv = (flags & SV_MUTABLE_RETURN)
2774                                 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2775                         }
2776                         if (lp)
2777                             *lp = SvCUR(tmpstr);
2778                     } else {
2779                         pv = sv_2pv_flags(tmpstr, lp, flags);
2780                     }
2781                     if (SvUTF8(tmpstr))
2782                         SvUTF8_on(sv);
2783                     else
2784                         SvUTF8_off(sv);
2785                     return pv;
2786                 }
2787             }
2788             {
2789                 STRLEN len;
2790                 char *retval;
2791                 char *buffer;
2792                 const SV *const referent = (SV*)SvRV(sv);
2793
2794                 if (!referent) {
2795                     len = 7;
2796                     retval = buffer = savepvn("NULLREF", len);
2797                 } else if (SvTYPE(referent) == SVt_REGEXP) {
2798                     const REGEXP * const re = (REGEXP *)referent;
2799                     I32 seen_evals = 0;
2800
2801                     assert(re);
2802                         
2803                     /* If the regex is UTF-8 we want the containing scalar to
2804                        have an UTF-8 flag too */
2805                     if (RX_UTF8(re))
2806                         SvUTF8_on(sv);
2807                     else
2808                         SvUTF8_off(sv); 
2809
2810                     if ((seen_evals = RX_SEEN_EVALS(re)))
2811                         PL_reginterp_cnt += seen_evals;
2812
2813                     if (lp)
2814                         *lp = RX_WRAPLEN(re);
2815  
2816                     return RX_WRAPPED(re);
2817                 } else {
2818                     const char *const typestr = sv_reftype(referent, 0);
2819                     const STRLEN typelen = strlen(typestr);
2820                     UV addr = PTR2UV(referent);
2821                     const char *stashname = NULL;
2822                     STRLEN stashnamelen = 0; /* hush, gcc */
2823                     const char *buffer_end;
2824
2825                     if (SvOBJECT(referent)) {
2826                         const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2827
2828                         if (name) {
2829                             stashname = HEK_KEY(name);
2830                             stashnamelen = HEK_LEN(name);
2831
2832                             if (HEK_UTF8(name)) {
2833                                 SvUTF8_on(sv);
2834                             } else {
2835                                 SvUTF8_off(sv);
2836                             }
2837                         } else {
2838                             stashname = "__ANON__";
2839                             stashnamelen = 8;
2840                         }
2841                         len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2842                             + 2 * sizeof(UV) + 2 /* )\0 */;
2843                     } else {
2844                         len = typelen + 3 /* (0x */
2845                             + 2 * sizeof(UV) + 2 /* )\0 */;
2846                     }
2847
2848                     Newx(buffer, len, char);
2849                     buffer_end = retval = buffer + len;
2850
2851                     /* Working backwards  */
2852                     *--retval = '\0';
2853                     *--retval = ')';
2854                     do {
2855                         *--retval = PL_hexdigit[addr & 15];
2856                     } while (addr >>= 4);
2857                     *--retval = 'x';
2858                     *--retval = '0';
2859                     *--retval = '(';
2860
2861                     retval -= typelen;
2862                     memcpy(retval, typestr, typelen);
2863
2864                     if (stashname) {
2865                         *--retval = '=';
2866                         retval -= stashnamelen;
2867                         memcpy(retval, stashname, stashnamelen);
2868                     }
2869                     /* retval may not neccesarily have reached the start of the
2870                        buffer here.  */
2871                     assert (retval >= buffer);
2872
2873                     len = buffer_end - retval - 1; /* -1 for that \0  */
2874                 }
2875                 if (lp)
2876                     *lp = len;
2877                 SAVEFREEPV(buffer);
2878                 return retval;
2879             }
2880         }
2881         if (SvREADONLY(sv) && !SvOK(sv)) {
2882             if (lp)
2883                 *lp = 0;
2884             if (flags & SV_UNDEF_RETURNS_NULL)
2885                 return NULL;
2886             if (ckWARN(WARN_UNINITIALIZED))
2887                 report_uninit(sv);
2888             return (char *)"";
2889         }
2890     }
2891     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2892         /* I'm assuming that if both IV and NV are equally valid then
2893            converting the IV is going to be more efficient */
2894         const U32 isUIOK = SvIsUV(sv);
2895         char buf[TYPE_CHARS(UV)];
2896         char *ebuf, *ptr;
2897         STRLEN len;
2898
2899         if (SvTYPE(sv) < SVt_PVIV)
2900             sv_upgrade(sv, SVt_PVIV);
2901         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2902         len = ebuf - ptr;
2903         /* inlined from sv_setpvn */
2904         s = SvGROW_mutable(sv, len + 1);
2905         Move(ptr, s, len, char);
2906         s += len;
2907         *s = '\0';
2908     }
2909     else if (SvNOKp(sv)) {
2910         const int olderrno = errno;
2911         if (SvTYPE(sv) < SVt_PVNV)
2912             sv_upgrade(sv, SVt_PVNV);
2913         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2914         s = SvGROW_mutable(sv, NV_DIG + 20);
2915         /* some Xenix systems wipe out errno here */
2916 #ifdef apollo
2917         if (SvNVX(sv) == 0.0)
2918             my_strlcpy(s, "0", SvLEN(sv));
2919         else
2920 #endif /*apollo*/
2921         {
2922             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2923         }
2924         errno = olderrno;
2925 #ifdef FIXNEGATIVEZERO
2926         if (*s == '-' && s[1] == '0' && !s[2]) {
2927             s[0] = '0';
2928             s[1] = 0;
2929         }
2930 #endif
2931         while (*s) s++;
2932 #ifdef hcx
2933         if (s[-1] == '.')
2934             *--s = '\0';
2935 #endif
2936     }
2937     else {
2938         if (isGV_with_GP(sv))
2939             return glob_2pv((GV *)sv, lp);
2940
2941         if (lp)
2942             *lp = 0;
2943         if (flags & SV_UNDEF_RETURNS_NULL)
2944             return NULL;
2945         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2946             report_uninit(sv);
2947         if (SvTYPE(sv) < SVt_PV)
2948             /* Typically the caller expects that sv_any is not NULL now.  */
2949             sv_upgrade(sv, SVt_PV);
2950         return (char *)"";
2951     }
2952     {
2953         const STRLEN len = s - SvPVX_const(sv);
2954         if (lp) 
2955             *lp = len;
2956         SvCUR_set(sv, len);
2957     }
2958     SvPOK_on(sv);
2959     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2960                           PTR2UV(sv),SvPVX_const(sv)));
2961     if (flags & SV_CONST_RETURN)
2962         return (char *)SvPVX_const(sv);
2963     if (flags & SV_MUTABLE_RETURN)
2964         return SvPVX_mutable(sv);
2965     return SvPVX(sv);
2966 }
2967
2968 /*
2969 =for apidoc sv_copypv
2970
2971 Copies a stringified representation of the source SV into the
2972 destination SV.  Automatically performs any necessary mg_get and
2973 coercion of numeric values into strings.  Guaranteed to preserve
2974 UTF8 flag even from overloaded objects.  Similar in nature to
2975 sv_2pv[_flags] but operates directly on an SV instead of just the
2976 string.  Mostly uses sv_2pv_flags to do its work, except when that
2977 would lose the UTF-8'ness of the PV.
2978
2979 =cut
2980 */
2981
2982 void
2983 Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
2984 {
2985     STRLEN len;
2986     const char * const s = SvPV_const(ssv,len);
2987
2988     PERL_ARGS_ASSERT_SV_COPYPV;
2989
2990     sv_setpvn(dsv,s,len);
2991     if (SvUTF8(ssv))
2992         SvUTF8_on(dsv);
2993     else
2994         SvUTF8_off(dsv);
2995 }
2996
2997 /*
2998 =for apidoc sv_2pvbyte
2999
3000 Return a pointer to the byte-encoded representation of the SV, and set *lp
3001 to its length.  May cause the SV to be downgraded from UTF-8 as a
3002 side-effect.
3003
3004 Usually accessed via the C<SvPVbyte> macro.
3005
3006 =cut
3007 */
3008
3009 char *
3010 Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp)
3011 {
3012     PERL_ARGS_ASSERT_SV_2PVBYTE;
3013
3014     sv_utf8_downgrade(sv,0);
3015     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3016 }
3017
3018 /*
3019 =for apidoc sv_2pvutf8
3020
3021 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3022 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3023
3024 Usually accessed via the C<SvPVutf8> macro.
3025
3026 =cut
3027 */
3028
3029 char *
3030 Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
3031 {
3032     PERL_ARGS_ASSERT_SV_2PVUTF8;
3033
3034     sv_utf8_upgrade(sv);
3035     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3036 }
3037
3038
3039 /*
3040 =for apidoc sv_2bool
3041
3042 This function is only called on magical items, and is only used by
3043 sv_true() or its macro equivalent.
3044
3045 =cut
3046 */
3047
3048 bool
3049 Perl_sv_2bool(pTHX_ register SV *const sv)
3050 {
3051     dVAR;
3052
3053     PERL_ARGS_ASSERT_SV_2BOOL;
3054
3055     SvGETMAGIC(sv);
3056
3057     if (!SvOK(sv))
3058         return 0;
3059     if (SvROK(sv)) {
3060         if (SvAMAGIC(sv)) {
3061             SV * const tmpsv = AMG_CALLun(sv,bool_);
3062             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3063                 return (bool)SvTRUE(tmpsv);
3064         }
3065         return SvRV(sv) != 0;
3066     }
3067     if (SvPOKp(sv)) {
3068         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3069         if (Xpvtmp &&
3070                 (*sv->sv_u.svu_pv > '0' ||
3071                 Xpvtmp->xpv_cur > 1 ||
3072                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3073             return 1;
3074         else
3075             return 0;
3076     }
3077     else {
3078         if (SvIOKp(sv))
3079             return SvIVX(sv) != 0;
3080         else {
3081             if (SvNOKp(sv))
3082                 return SvNVX(sv) != 0.0;
3083             else {
3084                 if (isGV_with_GP(sv))
3085                     return TRUE;
3086                 else
3087                     return FALSE;
3088             }
3089         }
3090     }
3091 }
3092
3093 /*
3094 =for apidoc sv_utf8_upgrade
3095
3096 Converts the PV of an SV to its UTF-8-encoded form.
3097 Forces the SV to string form if it is not already.
3098 Always sets the SvUTF8 flag to avoid future validity checks even
3099 if all the bytes have hibit clear.
3100
3101 This is not as a general purpose byte encoding to Unicode interface:
3102 use the Encode extension for that.
3103
3104 =for apidoc sv_utf8_upgrade_flags
3105
3106 Converts the PV of an SV to its UTF-8-encoded form.
3107 Forces the SV to string form if it is not already.
3108 Always sets the SvUTF8 flag to avoid future validity checks even
3109 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3110 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3111 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3112
3113 This is not as a general purpose byte encoding to Unicode interface:
3114 use the Encode extension for that.
3115
3116 =cut
3117 */
3118
3119 STRLEN
3120 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags)
3121 {
3122     dVAR;
3123
3124     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS;
3125
3126     if (sv == &PL_sv_undef)
3127         return 0;
3128     if (!SvPOK(sv)) {
3129         STRLEN len = 0;
3130         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3131             (void) sv_2pv_flags(sv,&len, flags);
3132             if (SvUTF8(sv))
3133                 return len;
3134         } else {
3135             (void) SvPV_force(sv,len);
3136         }
3137     }
3138
3139     if (SvUTF8(sv)) {
3140         return SvCUR(sv);
3141     }
3142
3143     if (SvIsCOW(sv)) {
3144         sv_force_normal_flags(sv, 0);
3145     }
3146
3147     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3148         sv_recode_to_utf8(sv, PL_encoding);
3149     else { /* Assume Latin-1/EBCDIC */
3150         /* This function could be much more efficient if we
3151          * had a FLAG in SVs to signal if there are any hibit
3152          * chars in the PV.  Given that there isn't such a flag
3153          * make the loop as fast as possible. */
3154         const U8 * const s = (U8 *) SvPVX_const(sv);
3155         const U8 * const e = (U8 *) SvEND(sv);
3156         const U8 *t = s;
3157         
3158         while (t < e) {
3159             const U8 ch = *t++;
3160             /* Check for hi bit */
3161             if (!NATIVE_IS_INVARIANT(ch)) {
3162                 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3163                 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3164
3165                 SvPV_free(sv); /* No longer using what was there before. */
3166                 SvPV_set(sv, (char*)recoded);
3167                 SvCUR_set(sv, len - 1);
3168                 SvLEN_set(sv, len); /* No longer know the real size. */
3169                 break;
3170             }
3171         }
3172         /* Mark as UTF-8 even if no hibit - saves scanning loop */
3173         SvUTF8_on(sv);
3174     }
3175     return SvCUR(sv);
3176 }
3177
3178 /*
3179 =for apidoc sv_utf8_downgrade
3180
3181 Attempts to convert the PV of an SV from characters to bytes.
3182 If the PV contains a character beyond byte, this conversion will fail;
3183 in this case, either returns false or, if C<fail_ok> is not
3184 true, croaks.
3185
3186 This is not as a general purpose Unicode to byte encoding interface:
3187 use the Encode extension for that.
3188
3189 =cut
3190 */
3191
3192 bool
3193 Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok)
3194 {
3195     dVAR;
3196
3197     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3198
3199     if (SvPOKp(sv) && SvUTF8(sv)) {
3200         if (SvCUR(sv)) {
3201             U8 *s;
3202             STRLEN len;
3203
3204             if (SvIsCOW(sv)) {
3205                 sv_force_normal_flags(sv, 0);
3206             }
3207             s = (U8 *) SvPV(sv, len);
3208             if (!utf8_to_bytes(s, &len)) {
3209                 if (fail_ok)
3210                     return FALSE;
3211                 else {
3212                     if (PL_op)
3213                         Perl_croak(aTHX_ "Wide character in %s",
3214                                    OP_DESC(PL_op));
3215                     else
3216                         Perl_croak(aTHX_ "Wide character");
3217                 }
3218             }
3219             SvCUR_set(sv, len);
3220         }
3221     }
3222     SvUTF8_off(sv);
3223     return TRUE;
3224 }
3225
3226 /*
3227 =for apidoc sv_utf8_encode
3228
3229 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3230 flag off so that it looks like octets again.
3231
3232 =cut
3233 */
3234
3235 void
3236 Perl_sv_utf8_encode(pTHX_ register SV *const sv)
3237 {
3238     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3239
3240     if (SvIsCOW(sv)) {
3241         sv_force_normal_flags(sv, 0);
3242     }
3243     if (SvREADONLY(sv)) {
3244         Perl_croak(aTHX_ PL_no_modify);
3245     }
3246     (void) sv_utf8_upgrade(sv);
3247     SvUTF8_off(sv);
3248 }
3249
3250 /*
3251 =for apidoc sv_utf8_decode
3252
3253 If the PV of the SV is an octet sequence in UTF-8
3254 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3255 so that it looks like a character. If the PV contains only single-byte
3256 characters, the C<SvUTF8> flag stays being off.
3257 Scans PV for validity and returns false if the PV is invalid UTF-8.
3258
3259 =cut
3260 */
3261
3262 bool
3263 Perl_sv_utf8_decode(pTHX_ register SV *const sv)
3264 {
3265     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3266
3267     if (SvPOKp(sv)) {
3268         const U8 *c;
3269         const U8 *e;
3270
3271         /* The octets may have got themselves encoded - get them back as
3272          * bytes
3273          */
3274         if (!sv_utf8_downgrade(sv, TRUE))
3275             return FALSE;
3276
3277         /* it is actually just a matter of turning the utf8 flag on, but
3278          * we want to make sure everything inside is valid utf8 first.
3279          */
3280         c = (const U8 *) SvPVX_const(sv);
3281         if (!is_utf8_string(c, SvCUR(sv)+1))
3282             return FALSE;
3283         e = (const U8 *) SvEND(sv);
3284         while (c < e) {
3285             const U8 ch = *c++;
3286             if (!UTF8_IS_INVARIANT(ch)) {
3287                 SvUTF8_on(sv);
3288                 break;
3289             }
3290         }
3291     }
3292     return TRUE;
3293 }
3294
3295 /*
3296 =for apidoc sv_setsv
3297
3298 Copies the contents of the source SV C<ssv> into the destination SV
3299 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3300 function if the source SV needs to be reused. Does not handle 'set' magic.
3301 Loosely speaking, it performs a copy-by-value, obliterating any previous
3302 content of the destination.
3303
3304 You probably want to use one of the assortment of wrappers, such as
3305 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3306 C<SvSetMagicSV_nosteal>.
3307
3308 =for apidoc sv_setsv_flags
3309
3310 Copies the contents of the source SV C<ssv> into the destination SV
3311 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3312 function if the source SV needs to be reused. Does not handle 'set' magic.
3313 Loosely speaking, it performs a copy-by-value, obliterating any previous
3314 content of the destination.
3315 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3316 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3317 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3318 and C<sv_setsv_nomg> are implemented in terms of this function.
3319
3320 You probably want to use one of the assortment of wrappers, such as
3321 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3322 C<SvSetMagicSV_nosteal>.
3323
3324 This is the primary function for copying scalars, and most other
3325 copy-ish functions and macros use this underneath.
3326
3327 =cut
3328 */
3329
3330 static void
3331 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3332 {
3333     I32 mro_changes = 0; /* 1 = method, 2 = isa */
3334
3335     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3336
3337     if (dtype != SVt_PVGV) {
3338         const char * const name = GvNAME(sstr);
3339         const STRLEN len = GvNAMELEN(sstr);
3340         {
3341             if (dtype >= SVt_PV) {
3342                 SvPV_free(dstr);
3343                 SvPV_set(dstr, 0);
3344                 SvLEN_set(dstr, 0);
3345                 SvCUR_set(dstr, 0);
3346             }
3347             SvUPGRADE(dstr, SVt_PVGV);
3348             (void)SvOK_off(dstr);
3349             /* FIXME - why are we doing this, then turning it off and on again
3350                below?  */
3351             isGV_with_GP_on(dstr);
3352         }
3353         GvSTASH(dstr) = GvSTASH(sstr);
3354         if (GvSTASH(dstr))
3355             Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3356         gv_name_set((GV *)dstr, name, len, GV_ADD);
3357         SvFAKE_on(dstr);        /* can coerce to non-glob */
3358     }
3359
3360 #ifdef GV_UNIQUE_CHECK
3361     if (GvUNIQUE((GV*)dstr)) {
3362         Perl_croak(aTHX_ PL_no_modify);
3363     }
3364 #endif
3365
3366     if(GvGP((GV*)sstr)) {
3367         /* If source has method cache entry, clear it */
3368         if(GvCVGEN(sstr)) {
3369             SvREFCNT_dec(GvCV(sstr));
3370             GvCV(sstr) = NULL;
3371             GvCVGEN(sstr) = 0;
3372         }
3373         /* If source has a real method, then a method is
3374            going to change */
3375         else if(GvCV((GV*)sstr)) {
3376             mro_changes = 1;
3377         }
3378     }
3379
3380     /* If dest already had a real method, that's a change as well */
3381     if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
3382         mro_changes = 1;
3383     }
3384
3385     if(strEQ(GvNAME((GV*)dstr),"ISA"))
3386         mro_changes = 2;
3387
3388     gp_free((GV*)dstr);
3389     isGV_with_GP_off(dstr);
3390     (void)SvOK_off(dstr);
3391     isGV_with_GP_on(dstr);
3392     GvINTRO_off(dstr);          /* one-shot flag */
3393     GvGP(dstr) = gp_ref(GvGP(sstr));
3394     if (SvTAINTED(sstr))
3395         SvTAINT(dstr);
3396     if (GvIMPORTED(dstr) != GVf_IMPORTED
3397         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3398         {
3399             GvIMPORTED_on(dstr);
3400         }
3401     GvMULTI_on(dstr);
3402     if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
3403     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3404     return;
3405 }
3406
3407 static void
3408 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3409 {
3410     SV * const sref = SvREFCNT_inc(SvRV(sstr));
3411     SV *dref = NULL;
3412     const int intro = GvINTRO(dstr);
3413     SV **location;
3414     U8 import_flag = 0;
3415     const U32 stype = SvTYPE(sref);
3416
3417     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3418
3419 #ifdef GV_UNIQUE_CHECK
3420     if (GvUNIQUE((GV*)dstr)) {
3421         Perl_croak(aTHX_ PL_no_modify);
3422     }
3423 #endif
3424
3425     if (intro) {
3426         GvINTRO_off(dstr);      /* one-shot flag */
3427         GvLINE(dstr) = CopLINE(PL_curcop);
3428         GvEGV(dstr) = (GV*)dstr;
3429     }
3430     GvMULTI_on(dstr);
3431     switch (stype) {
3432     case SVt_PVCV:
3433         location = (SV **) &GvCV(dstr);
3434         import_flag = GVf_IMPORTED_CV;
3435         goto common;
3436     case SVt_PVHV:
3437         location = (SV **) &GvHV(dstr);
3438         import_flag = GVf_IMPORTED_HV;
3439         goto common;
3440     case SVt_PVAV:
3441         location = (SV **) &GvAV(dstr);
3442         import_flag = GVf_IMPORTED_AV;
3443         goto common;
3444     case SVt_PVIO:
3445         location = (SV **) &GvIOp(dstr);
3446         goto common;
3447     case SVt_PVFM:
3448         location = (SV **) &GvFORM(dstr);
3449     default:
3450         location = &GvSV(dstr);
3451         import_flag = GVf_IMPORTED_SV;
3452     common:
3453         if (intro) {
3454             if (stype == SVt_PVCV) {
3455                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/
3456                 if (GvCVGEN(dstr)) {
3457                     SvREFCNT_dec(GvCV(dstr));
3458                     GvCV(dstr) = NULL;
3459                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3460                 }
3461             }
3462             SAVEGENERICSV(*location);
3463         }
3464         else
3465             dref = *location;
3466         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3467             CV* const cv = (CV*)*location;
3468             if (cv) {
3469                 if (!GvCVGEN((GV*)dstr) &&
3470                     (CvROOT(cv) || CvXSUB(cv)))
3471                     {
3472                         /* Redefining a sub - warning is mandatory if
3473                            it was a const and its value changed. */
3474                         if (CvCONST(cv) && CvCONST((CV*)sref)
3475                             && cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
3476                             NOOP;
3477                             /* They are 2 constant subroutines generated from
3478                                the same constant. This probably means that
3479                                they are really the "same" proxy subroutine
3480                                instantiated in 2 places. Most likely this is
3481                                when a constant is exported twice.  Don't warn.
3482                             */
3483                         }
3484                         else if (ckWARN(WARN_REDEFINE)
3485                                  || (CvCONST(cv)
3486                                      && (!CvCONST((CV*)sref)
3487                                          || sv_cmp(cv_const_sv(cv),
3488                                                    cv_const_sv((CV*)sref))))) {
3489                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3490                                         (const char *)
3491                                         (CvCONST(cv)
3492                                          ? "Constant subroutine %s::%s redefined"
3493                                          : "Subroutine %s::%s redefined"),
3494                                         HvNAME_get(GvSTASH((GV*)dstr)),
3495                                         GvENAME((GV*)dstr));
3496                         }
3497                     }
3498                 if (!intro)
3499                     cv_ckproto_len(cv, (GV*)dstr,
3500                                    SvPOK(sref) ? SvPVX_const(sref) : NULL,
3501                                    SvPOK(sref) ? SvCUR(sref) : 0);
3502             }
3503             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3504             GvASSUMECV_on(dstr);
3505             if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3506         }
3507         *location = sref;
3508         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3509             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3510             GvFLAGS(dstr) |= import_flag;
3511         }
3512         break;
3513     }
3514     SvREFCNT_dec(dref);
3515     if (SvTAINTED(sstr))
3516         SvTAINT(dstr);
3517     return;
3518 }
3519
3520 void
3521 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
3522 {
3523     dVAR;
3524     register U32 sflags;
3525     register int dtype;
3526     register svtype stype;
3527
3528     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
3529
3530     if (sstr == dstr)
3531         return;
3532
3533     if (SvIS_FREED(dstr)) {
3534         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
3535                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
3536     }
3537     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3538     if (!sstr)
3539         sstr = &PL_sv_undef;
3540     if (SvIS_FREED(sstr)) {
3541         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
3542                    (void*)sstr, (void*)dstr);
3543     }
3544     stype = SvTYPE(sstr);
3545     dtype = SvTYPE(dstr);
3546
3547     (void)SvAMAGIC_off(dstr);
3548     if ( SvVOK(dstr) )
3549     {
3550         /* need to nuke the magic */
3551         mg_free(dstr);
3552         SvRMAGICAL_off(dstr);
3553     }
3554
3555     /* There's a lot of redundancy below but we're going for speed here */
3556
3557     switch (stype) {
3558     case SVt_NULL:
3559       undef_sstr:
3560         if (dtype != SVt_PVGV) {
3561             (void)SvOK_off(dstr);
3562             return;
3563         }
3564         break;
3565     case SVt_IV:
3566         if (SvIOK(sstr)) {
3567             switch (dtype) {
3568             case SVt_NULL:
3569                 sv_upgrade(dstr, SVt_IV);
3570                 break;
3571             case SVt_NV:
3572             case SVt_PV:
3573                 sv_upgrade(dstr, SVt_PVIV);
3574                 break;
3575             case SVt_PVGV:
3576                 goto end_of_first_switch;
3577             }
3578             (void)SvIOK_only(dstr);
3579             SvIV_set(dstr,  SvIVX(sstr));
3580             if (SvIsUV(sstr))
3581                 SvIsUV_on(dstr);
3582             /* SvTAINTED can only be true if the SV has taint magic, which in
3583                turn means that the SV type is PVMG (or greater). This is the
3584                case statement for SVt_IV, so this cannot be true (whatever gcov
3585                may say).  */
3586             assert(!SvTAINTED(sstr));
3587             return;
3588         }
3589         if (!SvROK(sstr))
3590             goto undef_sstr;
3591         if (dtype < SVt_PV && dtype != SVt_IV)
3592             sv_upgrade(dstr, SVt_IV);
3593         break;
3594
3595     case SVt_NV:
3596         if (SvNOK(sstr)) {
3597             switch (dtype) {
3598             case SVt_NULL:
3599             case SVt_IV:
3600                 sv_upgrade(dstr, SVt_NV);
3601                 break;
3602             case SVt_PV:
3603             case SVt_PVIV:
3604                 sv_upgrade(dstr, SVt_PVNV);
3605                 break;
3606             case SVt_PVGV:
3607                 goto end_of_first_switch;
3608             }
3609             SvNV_set(dstr, SvNVX(sstr));
3610             (void)SvNOK_only(dstr);
3611             /* SvTAINTED can only be true if the SV has taint magic, which in
3612                turn means that the SV type is PVMG (or greater). This is the
3613                case statement for SVt_NV, so this cannot be true (whatever gcov
3614                may say).  */
3615             assert(!SvTAINTED(sstr));
3616             return;
3617         }
3618         goto undef_sstr;
3619
3620     case SVt_PVFM:
3621 #ifdef PERL_OLD_COPY_ON_WRITE
3622         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3623             if (dtype < SVt_PVIV)
3624                 sv_upgrade(dstr, SVt_PVIV);
3625             break;
3626         }
3627         /* Fall through */
3628 #endif
3629     case SVt_REGEXP:
3630     case SVt_PV:
3631         if (dtype < SVt_PV)
3632             sv_upgrade(dstr, SVt_PV);
3633         break;
3634     case SVt_PVIV:
3635         if (dtype < SVt_PVIV)
3636             sv_upgrade(dstr, SVt_PVIV);
3637         break;
3638     case SVt_PVNV:
3639         if (dtype < SVt_PVNV)
3640             sv_upgrade(dstr, SVt_PVNV);
3641         break;
3642     default:
3643         {
3644         const char * const type = sv_reftype(sstr,0);
3645         if (PL_op)
3646             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3647         else
3648             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3649         }
3650         break;
3651
3652         /* case SVt_BIND: */
3653     case SVt_PVLV:
3654     case SVt_PVGV:
3655         if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
3656             glob_assign_glob(dstr, sstr, dtype);
3657             return;
3658         }
3659         /* SvVALID means that this PVGV is playing at being an FBM.  */
3660         /*FALLTHROUGH*/
3661
3662     case SVt_PVMG:
3663         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3664             mg_get(sstr);
3665             if (SvTYPE(sstr) != stype) {
3666                 stype = SvTYPE(sstr);
3667                 if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
3668                     glob_assign_glob(dstr, sstr, dtype);
3669                     return;
3670                 }
3671             }
3672         }
3673         if (stype == SVt_PVLV)
3674             SvUPGRADE(dstr, SVt_PVNV);
3675         else
3676             SvUPGRADE(dstr, (svtype)stype);
3677     }
3678  end_of_first_switch:
3679
3680     /* dstr may have been upgraded.  */
3681     dtype = SvTYPE(dstr);
3682     sflags = SvFLAGS(sstr);
3683
3684     if (dtype == SVt_PVCV || dtype == SVt_PVFM) {
3685         /* Assigning to a subroutine sets the prototype.  */
3686         if (SvOK(sstr)) {
3687             STRLEN len;
3688             const char *const ptr = SvPV_const(sstr, len);
3689
3690             SvGROW(dstr, len + 1);
3691             Copy(ptr, SvPVX(dstr), len + 1, char);
3692             SvCUR_set(dstr, len);
3693             SvPOK_only(dstr);
3694             SvFLAGS(dstr) |= sflags & SVf_UTF8;
3695         } else {
3696             SvOK_off(dstr);
3697         }
3698     } else if (dtype == SVt_PVAV || dtype == SVt_PVHV) {
3699         const char * const type = sv_reftype(dstr,0);
3700         if (PL_op)
3701             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_NAME(PL_op));
3702         else
3703             Perl_croak(aTHX_ "Cannot copy to %s", type);
3704     } else if (sflags & SVf_ROK) {
3705         if (isGV_with_GP(dstr) && dtype == SVt_PVGV
3706             && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3707             sstr = SvRV(sstr);
3708             if (sstr == dstr) {
3709                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3710                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3711                 {
3712                     GvIMPORTED_on(dstr);
3713                 }
3714                 GvMULTI_on(dstr);
3715                 return;
3716             }
3717             glob_assign_glob(dstr, sstr, dtype);
3718             return;
3719         }
3720
3721         if (dtype >= SVt_PV) {
3722             if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3723                 glob_assign_ref(dstr, sstr);
3724                 return;
3725             }
3726             if (SvPVX_const(dstr)) {
3727                 SvPV_free(dstr);
3728                 SvLEN_set(dstr, 0);
3729                 SvCUR_set(dstr, 0);
3730             }
3731         }
3732         (void)SvOK_off(dstr);
3733         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3734         SvFLAGS(dstr) |= sflags & SVf_ROK;
3735         assert(!(sflags & SVp_NOK));
3736         assert(!(sflags & SVp_IOK));
3737         assert(!(sflags & SVf_NOK));
3738         assert(!(sflags & SVf_IOK));
3739     }
3740     else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
3741         if (!(sflags & SVf_OK)) {
3742             if (ckWARN(WARN_MISC))
3743                 Perl_warner(aTHX_ packWARN(WARN_MISC),
3744                             "Undefined value assigned to typeglob");
3745         }
3746         else {
3747             GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV);
3748             if (dstr != (SV*)gv) {
3749                 if (GvGP(dstr))
3750                     gp_free((GV*)dstr);
3751                 GvGP(dstr) = gp_ref(GvGP(gv));
3752             }
3753         }
3754     }
3755     else if (sflags & SVp_POK) {
3756         bool isSwipe = 0;
3757
3758         /*
3759          * Check to see if we can just swipe the string.  If so, it's a
3760          * possible small lose on short strings, but a big win on long ones.
3761          * It might even be a win on short strings if SvPVX_const(dstr)
3762          * has to be allocated and SvPVX_const(sstr) has to be freed.
3763          * Likewise if we can set up COW rather than doing an actual copy, we
3764          * drop to the else clause, as the swipe code and the COW setup code
3765          * have much in common.
3766          */
3767
3768         /* Whichever path we take through the next code, we want this true,
3769            and doing it now facilitates the COW check.  */
3770         (void)SvPOK_only(dstr);
3771
3772         if (
3773             /* If we're already COW then this clause is not true, and if COW
3774                is allowed then we drop down to the else and make dest COW 
3775                with us.  If caller hasn't said that we're allowed to COW
3776                shared hash keys then we don't do the COW setup, even if the
3777                source scalar is a shared hash key scalar.  */
3778             (((flags & SV_COW_SHARED_HASH_KEYS)
3779                ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY)
3780                : 1 /* If making a COW copy is forbidden then the behaviour we
3781                        desire is as if the source SV isn't actually already
3782                        COW, even if it is.  So we act as if the source flags
3783                        are not COW, rather than actually testing them.  */
3784               )
3785 #ifndef PERL_OLD_COPY_ON_WRITE
3786              /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
3787                 when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
3788                 Conceptually PERL_OLD_COPY_ON_WRITE being defined should
3789                 override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
3790                 but in turn, it's somewhat dead code, never expected to go
3791                 live, but more kept as a placeholder on how to do it better
3792                 in a newer implementation.  */
3793              /* If we are COW and dstr is a suitable target then we drop down
3794                 into the else and make dest a COW of us.  */
3795              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3796 #endif
3797              )
3798             &&
3799             !(isSwipe =
3800                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3801                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3802                  (!(flags & SV_NOSTEAL)) &&
3803                                         /* and we're allowed to steal temps */
3804                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3805                  SvLEN(sstr)    &&        /* and really is a string */
3806                                 /* and won't be needed again, potentially */
3807               !(PL_op && PL_op->op_type == OP_AASSIGN))
3808 #ifdef PERL_OLD_COPY_ON_WRITE
3809             && ((flags & SV_COW_SHARED_HASH_KEYS)
3810                 ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3811                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3812                      && SvTYPE(sstr) >= SVt_PVIV))
3813                 : 1)
3814 #endif
3815             ) {
3816             /* Failed the swipe test, and it's not a shared hash key either.
3817                Have to copy the string.  */
3818             STRLEN len = SvCUR(sstr);
3819             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3820             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3821             SvCUR_set(dstr, len);
3822             *SvEND(dstr) = '\0';
3823         } else {
3824             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3825                be true in here.  */
3826             /* Either it's a shared hash key, or it's suitable for
3827                copy-on-write or we can swipe the string.  */
3828             if (DEBUG_C_TEST) {
3829                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3830                 sv_dump(sstr);
3831                 sv_dump(dstr);
3832             }
3833 #ifdef PERL_OLD_COPY_ON_WRITE
3834             if (!isSwipe) {
3835                 /* I believe I should acquire a global SV mutex if
3836                    it's a COW sv (not a shared hash key) to stop
3837                    it going un copy-on-write.
3838                    If the source SV has gone un copy on write between up there
3839                    and down here, then (assert() that) it is of the correct
3840                    form to make it copy on write again */
3841                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3842                     != (SVf_FAKE | SVf_READONLY)) {
3843                     SvREADONLY_on(sstr);
3844                     SvFAKE_on(sstr);
3845                     /* Make the source SV into a loop of 1.
3846                        (about to become 2) */
3847                     SV_COW_NEXT_SV_SET(sstr, sstr);
3848                 }
3849             }
3850 #endif
3851             /* Initial code is common.  */
3852             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
3853                 SvPV_free(dstr);
3854             }
3855
3856             if (!isSwipe) {
3857                 /* making another shared SV.  */
3858                 STRLEN cur = SvCUR(sstr);
3859                 STRLEN len = SvLEN(sstr);
3860 #ifdef PERL_OLD_COPY_ON_WRITE
3861                 if (len) {
3862                     assert (SvTYPE(dstr) >= SVt_PVIV);
3863                     /* SvIsCOW_normal */
3864                     /* splice us in between source and next-after-source.  */
3865                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3866                     SV_COW_NEXT_SV_SET(sstr, dstr);
3867                     SvPV_set(dstr, SvPVX_mutable(sstr));
3868                 } else
3869 #endif
3870                 {
3871                     /* SvIsCOW_shared_hash */
3872                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3873                                           "Copy on write: Sharing hash\n"));
3874
3875                     assert (SvTYPE(dstr) >= SVt_PV);
3876                     SvPV_set(dstr,
3877                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3878                 }
3879                 SvLEN_set(dstr, len);
3880                 SvCUR_set(dstr, cur);
3881                 SvREADONLY_on(dstr);
3882                 SvFAKE_on(dstr);
3883                 /* Relesase a global SV mutex.  */
3884             }
3885             else
3886                 {       /* Passes the swipe test.  */
3887                 SvPV_set(dstr, SvPVX_mutable(sstr));
3888                 SvLEN_set(dstr, SvLEN(sstr));
3889                 SvCUR_set(dstr, SvCUR(sstr));
3890
3891                 SvTEMP_off(dstr);
3892                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3893                 SvPV_set(sstr, NULL);
3894                 SvLEN_set(sstr, 0);
3895                 SvCUR_set(sstr, 0);
3896                 SvTEMP_off(sstr);
3897             }
3898         }
3899         if (sflags & SVp_NOK) {
3900             SvNV_set(dstr, SvNVX(sstr));
3901         }
3902         if (sflags & SVp_IOK) {
3903             SvIV_set(dstr, SvIVX(sstr));
3904             /* Must do this otherwise some other overloaded use of 0x80000000
3905                gets confused. I guess SVpbm_VALID */
3906             if (sflags & SVf_IVisUV)
3907                 SvIsUV_on(dstr);
3908         }
3909         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
3910         {
3911             const MAGIC * const smg = SvVSTRING_mg(sstr);
3912             if (smg) {
3913                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3914                          smg->mg_ptr, smg->mg_len);
3915                 SvRMAGICAL_on(dstr);
3916             }
3917         }
3918     }
3919     else if (sflags & (SVp_IOK|SVp_NOK)) {
3920         (void)SvOK_off(dstr);
3921         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
3922         if (sflags & SVp_IOK) {
3923             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3924             SvIV_set(dstr, SvIVX(sstr));
3925         }
3926         if (sflags & SVp_NOK) {
3927             SvNV_set(dstr, SvNVX(sstr));
3928         }
3929     }
3930     else {
3931         if (isGV_with_GP(sstr)) {
3932             /* This stringification rule for globs is spread in 3 places.
3933                This feels bad. FIXME.  */
3934             const U32 wasfake = sflags & SVf_FAKE;
3935
3936             /* FAKE globs can get coerced, so need to turn this off
3937                temporarily if it is on.  */
3938             SvFAKE_off(sstr);
3939             gv_efullname3(dstr, (GV *)sstr, "*");
3940             SvFLAGS(sstr) |= wasfake;
3941         }
3942         else
3943             (void)SvOK_off(dstr);
3944     }
3945     if (SvTAINTED(sstr))
3946         SvTAINT(dstr);
3947 }
3948
3949 /*
3950 =for apidoc sv_setsv_mg
3951
3952 Like C<sv_setsv>, but also handles 'set' magic.
3953
3954 =cut
3955 */
3956
3957 void
3958 Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr)
3959 {
3960     PERL_ARGS_ASSERT_SV_SETSV_MG;
3961
3962     sv_setsv(dstr,sstr);
3963     SvSETMAGIC(dstr);
3964 }
3965
3966 #ifdef PERL_OLD_COPY_ON_WRITE
3967 SV *
3968 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3969 {
3970     STRLEN cur = SvCUR(sstr);
3971     STRLEN len = SvLEN(sstr);
3972     register char *new_pv;
3973
3974     PERL_ARGS_ASSERT_SV_SETSV_COW;
3975
3976     if (DEBUG_C_TEST) {
3977         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3978                       (void*)sstr, (void*)dstr);
3979         sv_dump(sstr);
3980         if (dstr)
3981                     sv_dump(dstr);
3982     }
3983
3984     if (dstr) {
3985         if (SvTHINKFIRST(dstr))
3986             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3987         else if (SvPVX_const(dstr))
3988             Safefree(SvPVX_const(dstr));
3989     }
3990     else
3991         new_SV(dstr);
3992     SvUPGRADE(dstr, SVt_PVIV);
3993
3994     assert (SvPOK(sstr));
3995     assert (SvPOKp(sstr));
3996     assert (!SvIOK(sstr));
3997     assert (!SvIOKp(sstr));
3998     assert (!SvNOK(sstr));
3999     assert (!SvNOKp(sstr));
4000
4001     if (SvIsCOW(sstr)) {
4002
4003         if (SvLEN(sstr) == 0) {
4004             /* source is a COW shared hash key.  */
4005             DEBUG_C(PerlIO_printf(Perl_debug_log,
4006                                   "Fast copy on write: Sharing hash\n"));
4007             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4008             goto common_exit;
4009         }
4010         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4011     } else {
4012         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4013         SvUPGRADE(sstr, SVt_PVIV);
4014         SvREADONLY_on(sstr);
4015         SvFAKE_on(sstr);
4016         DEBUG_C(PerlIO_printf(Perl_debug_log,
4017                               "Fast copy on write: Converting sstr to COW\n"));
4018         SV_COW_NEXT_SV_SET(dstr, sstr);
4019     }
4020     SV_COW_NEXT_SV_SET(sstr, dstr);
4021     new_pv = SvPVX_mutable(sstr);
4022
4023   common_exit:
4024     SvPV_set(dstr, new_pv);
4025     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4026     if (SvUTF8(sstr))
4027         SvUTF8_on(dstr);
4028     SvLEN_set(dstr, len);
4029     SvCUR_set(dstr, cur);
4030     if (DEBUG_C_TEST) {
4031         sv_dump(dstr);
4032     }
4033     return dstr;
4034 }
4035 #endif
4036
4037 /*
4038 =for apidoc sv_setpvn
4039
4040 Copies a string into an SV.  The C<len> parameter indicates the number of
4041 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4042 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4043
4044 =cut
4045 */
4046
4047 void
4048 Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4049 {
4050     dVAR;
4051     register char *dptr;
4052
4053     PERL_ARGS_ASSERT_SV_SETPVN;
4054
4055     SV_CHECK_THINKFIRST_COW_DROP(sv);
4056     if (!ptr) {
4057         (void)SvOK_off(sv);
4058         return;
4059     }
4060     else {
4061         /* len is STRLEN which is unsigned, need to copy to signed */
4062         const IV iv = len;
4063         if (iv < 0)
4064             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4065     }
4066     SvUPGRADE(sv, SVt_PV);
4067
4068     dptr = SvGROW(sv, len + 1);
4069     Move(ptr,dptr,len,char);
4070     dptr[len] = '\0';
4071     SvCUR_set(sv, len);
4072     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4073     SvTAINT(sv);
4074 }
4075
4076 /*
4077 =for apidoc sv_setpvn_mg
4078
4079 Like C<sv_setpvn>, but also handles 'set' magic.
4080
4081 =cut
4082 */
4083
4084 void
4085 Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len)
4086 {
4087     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4088
4089     sv_setpvn(sv,ptr,len);
4090     SvSETMAGIC(sv);
4091 }
4092
4093 /*
4094 =for apidoc sv_setpv
4095
4096 Copies a string into an SV.  The string must be null-terminated.  Does not
4097 handle 'set' magic.  See C<sv_setpv_mg>.
4098
4099 =cut
4100 */
4101
4102 void
4103 Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr)
4104 {
4105     dVAR;
4106     register STRLEN len;
4107
4108     PERL_ARGS_ASSERT_SV_SETPV;
4109
4110     SV_CHECK_THINKFIRST_COW_DROP(sv);
4111     if (!ptr) {
4112         (void)SvOK_off(sv);
4113         return;
4114     }
4115     len = strlen(ptr);
4116     SvUPGRADE(sv, SVt_PV);
4117
4118     SvGROW(sv, len + 1);
4119     Move(ptr,SvPVX(sv),len+1,char);
4120     SvCUR_set(sv, len);
4121     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4122     SvTAINT(sv);
4123 }
4124
4125 /*
4126 =for apidoc sv_setpv_mg
4127
4128 Like C<sv_setpv>, but also handles 'set' magic.
4129
4130 =cut
4131 */
4132
4133 void
4134 Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4135 {
4136     PERL_ARGS_ASSERT_SV_SETPV_MG;
4137
4138     sv_setpv(sv,ptr);
4139     SvSETMAGIC(sv);
4140 }
4141
4142 /*
4143 =for apidoc sv_usepvn_flags
4144
4145 Tells an SV to use C<ptr> to find its string value.  Normally the
4146 string is stored inside the SV but sv_usepvn allows the SV to use an
4147 outside string.  The C<ptr> should point to memory that was allocated
4148 by C<malloc>.  The string length, C<len>, must be supplied.  By default
4149 this function will realloc (i.e. move) the memory pointed to by C<ptr>,
4150 so that pointer should not be freed or used by the programmer after
4151 giving it to sv_usepvn, and neither should any pointers from "behind"
4152 that pointer (e.g. ptr + 1) be used.
4153
4154 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
4155 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
4156 will be skipped. (i.e. the buffer is actually at least 1 byte longer than
4157 C<len>, and already meets the requirements for storing in C<SvPVX>)
4158
4159 =cut
4160 */
4161
4162 void
4163 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4164 {
4165     dVAR;
4166     STRLEN allocate;
4167
4168     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4169
4170     SV_CHECK_THINKFIRST_COW_DROP(sv);
4171     SvUPGRADE(sv, SVt_PV);
4172     if (!ptr) {
4173         (void)SvOK_off(sv);
4174         if (flags & SV_SMAGIC)
4175             SvSETMAGIC(sv);
4176         return;
4177     }
4178     if (SvPVX_const(sv))
4179         SvPV_free(sv);
4180
4181 #ifdef DEBUGGING
4182     if (flags & SV_HAS_TRAILING_NUL)
4183         assert(ptr[len] == '\0');
4184 #endif
4185
4186     allocate = (flags & SV_HAS_TRAILING_NUL)
4187         ? len + 1 :
4188 #ifdef Perl_safesysmalloc_size
4189         len + 1;
4190 #else 
4191         PERL_STRLEN_ROUNDUP(len + 1);
4192 #endif
4193     if (flags & SV_HAS_TRAILING_NUL) {
4194         /* It's long enough - do nothing.
4195            Specfically Perl_newCONSTSUB is relying on this.  */
4196     } else {
4197 #ifdef DEBUGGING
4198         /* Force a move to shake out bugs in callers.  */
4199         char *new_ptr = (char*)safemalloc(allocate);
4200         Copy(ptr, new_ptr, len, char);
4201         PoisonFree(ptr,len,char);
4202         Safefree(ptr);
4203         ptr = new_ptr;
4204 #else
4205         ptr = (char*) saferealloc (ptr, allocate);
4206 #endif
4207     }
4208 #ifdef Perl_safesysmalloc_size
4209     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4210 #else
4211     SvLEN_set(sv, allocate);
4212 #endif
4213     SvCUR_set(sv, len);
4214     SvPV_set(sv, ptr);
4215     if (!(flags & SV_HAS_TRAILING_NUL)) {
4216         ptr[len] = '\0';
4217     }
4218     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4219     SvTAINT(sv);
4220     if (flags & SV_SMAGIC)
4221         SvSETMAGIC(sv);
4222 }
4223
4224 #ifdef PERL_OLD_COPY_ON_WRITE
4225 /* Need to do this *after* making the SV normal, as we need the buffer
4226    pointer to remain valid until after we've copied it.  If we let go too early,
4227    another thread could invalidate it by unsharing last of the same hash key
4228    (which it can do by means other than releasing copy-on-write Svs)
4229    or by changing the other copy-on-write SVs in the loop.  */
4230 STATIC void
4231 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
4232 {
4233     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4234
4235     { /* this SV was SvIsCOW_normal(sv) */
4236          /* we need to find the SV pointing to us.  */
4237         SV *current = SV_COW_NEXT_SV(after);
4238
4239         if (current == sv) {
4240             /* The SV we point to points back to us (there were only two of us
4241                in the loop.)
4242                Hence other SV is no longer copy on write either.  */
4243             SvFAKE_off(after);
4244             SvREADONLY_off(after);
4245         } else {
4246             /* We need to follow the pointers around the loop.  */
4247             SV *next;
4248             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4249                 assert (next);
4250                 current = next;
4251                  /* don't loop forever if the structure is bust, and we have
4252                     a pointer into a closed loop.  */
4253                 assert (current != after);
4254                 assert (SvPVX_const(current) == pvx);
4255             }
4256             /* Make the SV before us point to the SV after us.  */
4257             SV_COW_NEXT_SV_SET(current, after);
4258         }
4259     }
4260 }
4261 #endif
4262 /*
4263 =for apidoc sv_force_normal_flags
4264
4265 Undo various types of fakery on an SV: if the PV is a shared string, make
4266 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4267 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4268 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4269 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4270 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4271 set to some other value.) In addition, the C<flags> parameter gets passed to
4272 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4273 with flags set to 0.
4274
4275 =cut
4276 */
4277
4278 void
4279 Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
4280 {
4281     dVAR;
4282
4283     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
4284
4285 #ifdef PERL_OLD_COPY_ON_WRITE
4286     if (SvREADONLY(sv)) {
4287         /* At this point I believe I should acquire a global SV mutex.  */
4288         if (SvFAKE(sv)) {
4289             const char * const pvx = SvPVX_const(sv);
4290             const STRLEN len = SvLEN(sv);
4291             const STRLEN cur = SvCUR(sv);
4292             /* next COW sv in the loop.  If len is 0 then this is a shared-hash
4293                key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
4294                we'll fail an assertion.  */
4295             SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
4296
4297             if (DEBUG_C_TEST) {
4298                 PerlIO_printf(Perl_debug_log,
4299                               "Copy on write: Force normal %ld\n",
4300                               (long) flags);
4301                 sv_dump(sv);
4302             }
4303             SvFAKE_off(sv);
4304             SvREADONLY_off(sv);
4305             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
4306             SvPV_set(sv, NULL);
4307             SvLEN_set(sv, 0);
4308             if (flags & SV_COW_DROP_PV) {
4309                 /* OK, so we don't need to copy our buffer.  */
4310                 SvPOK_off(sv);
4311             } else {
4312                 SvGROW(sv, cur + 1);
4313                 Move(pvx,SvPVX(sv),cur,char);
4314                 SvCUR_set(sv, cur);
4315                 *SvEND(sv) = '\0';
4316             }
4317             if (len) {
4318                 sv_release_COW(sv, pvx, next);
4319             } else {
4320                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4321             }
4322             if (DEBUG_C_TEST) {
4323                 sv_dump(sv);
4324             }
4325         }
4326         else if (IN_PERL_RUNTIME)
4327             Perl_croak(aTHX_ PL_no_modify);
4328         /* At this point I believe that I can drop the global SV mutex.  */
4329     }
4330 #else
4331     if (SvREADONLY(sv)) {
4332         if (SvFAKE(sv)) {
4333             const char * const pvx = SvPVX_const(sv);
4334             const STRLEN len = SvCUR(sv);
4335             SvFAKE_off(sv);
4336             SvREADONLY_off(sv);
4337             SvPV_set(sv, NULL);
4338             SvLEN_set(sv, 0);
4339             SvGROW(sv, len + 1);
4340             Move(pvx,SvPVX(sv),len,char);
4341             *SvEND(sv) = '\0';
4342             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4343         }
4344         else if (IN_PERL_RUNTIME)
4345             Perl_croak(aTHX_ PL_no_modify);
4346     }
4347 #endif
4348     if (SvROK(sv))
4349         sv_unref_flags(sv, flags);
4350     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4351         sv_unglob(sv);
4352 }
4353
4354 /*
4355 =for apidoc sv_chop
4356
4357 Efficient removal of characters from the beginning of the string buffer.
4358 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4359 the string buffer.  The C<ptr> becomes the first character of the adjusted
4360 string. Uses the "OOK hack".
4361 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4362 refer to the same chunk of data.
4363
4364 =cut
4365 */
4366
4367 void
4368 Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr)
4369 {
4370     STRLEN delta;
4371     STRLEN old_delta;
4372     U8 *p;
4373 #ifdef DEBUGGING
4374     const U8 *real_start;
4375 #endif
4376
4377     PERL_ARGS_ASSERT_SV_CHOP;
4378
4379     if (!ptr || !SvPOKp(sv))
4380         return;
4381     delta = ptr - SvPVX_const(sv);
4382     if (!delta) {
4383         /* Nothing to do.  */
4384         return;
4385     }
4386     assert(ptr > SvPVX_const(sv));
4387     SV_CHECK_THINKFIRST(sv);
4388
4389     if (!SvOOK(sv)) {
4390         if (!SvLEN(sv)) { /* make copy of shared string */
4391             const char *pvx = SvPVX_const(sv);
4392             const STRLEN len = SvCUR(sv);
4393             SvGROW(sv, len + 1);
4394             Move(pvx,SvPVX(sv),len,char);
4395             *SvEND(sv) = '\0';
4396         }
4397         SvFLAGS(sv) |= SVf_OOK;
4398         old_delta = 0;
4399     } else {
4400         SvOOK_offset(sv, old_delta);
4401     }
4402     SvLEN_set(sv, SvLEN(sv) - delta);
4403     SvCUR_set(sv, SvCUR(sv) - delta);
4404     SvPV_set(sv, SvPVX(sv) + delta);
4405
4406     p = (U8 *)SvPVX_const(sv);
4407
4408     delta += old_delta;
4409
4410 #ifdef DEBUGGING
4411     real_start = p - delta;
4412 #endif
4413
4414     assert(delta);
4415     if (delta < 0x100) {
4416         *--p = (U8) delta;
4417     } else {
4418         *--p = 0;
4419         p -= sizeof(STRLEN);
4420         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
4421     }
4422
4423 #ifdef DEBUGGING
4424     /* Fill the preceding buffer with sentinals to verify that no-one is
4425        using it.  */
4426     while (p > real_start) {
4427         --p;
4428         *p = (U8)PTR2UV(p);
4429     }
4430 #endif
4431 }
4432
4433 /*
4434 =for apidoc sv_catpvn
4435
4436 Concatenates the string onto the end of the string which is in the SV.  The
4437 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4438 status set, then the bytes appended should be valid UTF-8.
4439 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4440
4441 =for apidoc sv_catpvn_flags
4442
4443 Concatenates the string onto the end of the string which is in the SV.  The
4444 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4445 status set, then the bytes appended should be valid UTF-8.
4446 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4447 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4448 in terms of this function.
4449
4450 =cut
4451 */
4452
4453 void
4454 Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags)
4455 {
4456     dVAR;
4457     STRLEN dlen;
4458     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
4459
4460     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
4461
4462     SvGROW(dsv, dlen + slen + 1);
4463     if (sstr == dstr)
4464         sstr = SvPVX_const(dsv);
4465     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4466     SvCUR_set(dsv, SvCUR(dsv) + slen);
4467     *SvEND(dsv) = '\0';
4468     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4469     SvTAINT(dsv);
4470     if (flags & SV_SMAGIC)
4471         SvSETMAGIC(dsv);
4472 }
4473
4474 /*
4475 =for apidoc sv_catsv
4476
4477 Concatenates the string from SV C<ssv> onto the end of the string in
4478 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4479 not 'set' magic.  See C<sv_catsv_mg>.
4480
4481 =for apidoc sv_catsv_flags
4482
4483 Concatenates the string from SV C<ssv> onto the end of the string in
4484 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4485 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4486 and C<sv_catsv_nomg> are implemented in terms of this function.
4487
4488 =cut */
4489
4490 void
4491 Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
4492 {
4493     dVAR;
4494  
4495     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
4496
4497    if (ssv) {
4498         STRLEN slen;
4499         const char *spv = SvPV_const(ssv, slen);
4500         if (spv) {
4501             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4502                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4503                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4504                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4505                 dsv->sv_flags doesn't have that bit set.
4506                 Andy Dougherty  12 Oct 2001
4507             */
4508             const I32 sutf8 = DO_UTF8(ssv);
4509             I32 dutf8;
4510
4511             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4512                 mg_get(dsv);
4513             dutf8 = DO_UTF8(dsv);
4514
4515             if (dutf8 != sutf8) {
4516                 if (dutf8) {
4517                     /* Not modifying source SV, so taking a temporary copy. */
4518                     SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP);
4519
4520                     sv_utf8_upgrade(csv);
4521                     spv = SvPV_const(csv, slen);
4522                 }
4523                 else
4524                     sv_utf8_upgrade_nomg(dsv);
4525             }
4526             sv_catpvn_nomg(dsv, spv, slen);
4527         }
4528     }
4529     if (flags & SV_SMAGIC)
4530         SvSETMAGIC(dsv);
4531 }
4532
4533 /*
4534 =for apidoc sv_catpv
4535
4536 Concatenates the string onto the end of the string which is in the SV.
4537 If the SV has the UTF-8 status set, then the bytes appended should be
4538 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4539
4540 =cut */
4541
4542 void
4543 Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr)
4544 {
4545     dVAR;
4546     register STRLEN len;
4547     STRLEN tlen;
4548     char *junk;
4549
4550     PERL_ARGS_ASSERT_SV_CATPV;
4551
4552     if (!ptr)
4553         return;
4554     junk = SvPV_force(sv, tlen);
4555     len = strlen(ptr);
4556     SvGROW(sv, tlen + len + 1);
4557     if (ptr == junk)
4558         ptr = SvPVX_const(sv);
4559     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4560     SvCUR_set(sv, SvCUR(sv) + len);
4561     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4562     SvTAINT(sv);
4563 }
4564
4565 /*
4566 =for apidoc sv_catpv_mg
4567
4568 Like C<sv_catpv>, but also handles 'set' magic.
4569
4570 =cut
4571 */
4572
4573 void
4574 Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr)
4575 {
4576     PERL_ARGS_ASSERT_SV_CATPV_MG;
4577
4578     sv_catpv(sv,ptr);
4579     SvSETMAGIC(sv);
4580 }
4581
4582 /*
4583 =for apidoc newSV
4584
4585 Creates a new SV.  A non-zero C<len> parameter indicates the number of
4586 bytes of preallocated string space the SV should have.  An extra byte for a
4587 trailing NUL is also reserved.  (SvPOK is not set for the SV even if string
4588 space is allocated.)  The reference count for the new SV is set to 1.
4589
4590 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
4591 parameter, I<x>, a debug aid which allowed callers to identify themselves.
4592 This aid has been superseded by a new build option, PERL_MEM_LOG (see
4593 L<perlhack/PERL_MEM_LOG>).  The older API is still there for use in XS
4594 modules supporting older perls.
4595
4596 =cut
4597 */
4598
4599 SV *
4600 Perl_newSV(pTHX_ const STRLEN len)
4601 {
4602     dVAR;
4603     register SV *sv;
4604
4605     new_SV(sv);
4606     if (len) {
4607         sv_upgrade(sv, SVt_PV);
4608         SvGROW(sv, len + 1);
4609     }
4610     return sv;
4611 }
4612 /*
4613 =for apidoc sv_magicext
4614
4615 Adds magic to an SV, upgrading it if necessary. Applies the
4616 supplied vtable and returns a pointer to the magic added.
4617
4618 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4619 In particular, you can add magic to SvREADONLY SVs, and add more than
4620 one instance of the same 'how'.
4621
4622 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4623 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4624 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4625 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4626
4627 (This is now used as a subroutine by C<sv_magic>.)
4628
4629 =cut
4630 */
4631 MAGIC * 
4632 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
4633                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
4634 {
4635     dVAR;
4636     MAGIC* mg;
4637
4638     PERL_ARGS_ASSERT_SV_MAGICEXT;
4639
4640     SvUPGRADE(sv, SVt_PVMG);
4641     Newxz(mg, 1, MAGIC);
4642     mg->mg_moremagic = SvMAGIC(sv);
4643     SvMAGIC_set(sv, mg);
4644
4645     /* Sometimes a magic contains a reference loop, where the sv and
4646        object refer to each other.  To prevent a reference loop that
4647        would prevent such objects being freed, we look for such loops
4648        and if we find one we avoid incrementing the object refcount.
4649
4650        Note we cannot do this to avoid self-tie loops as intervening RV must
4651        have its REFCNT incremented to keep it in existence.
4652
4653     */
4654     if (!obj || obj == sv ||
4655         how == PERL_MAGIC_arylen ||
4656         how == PERL_MAGIC_symtab ||
4657         (SvTYPE(obj) == SVt_PVGV &&
4658             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4659             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4660             GvFORM(obj) == (CV*)sv)))
4661     {
4662         mg->mg_obj = obj;
4663     }
4664     else {
4665         mg->mg_obj = SvREFCNT_inc_simple(obj);
4666         mg->mg_flags |= MGf_REFCOUNTED;
4667     }
4668
4669     /* Normal self-ties simply pass a null object, and instead of
4670        using mg_obj directly, use the SvTIED_obj macro to produce a
4671        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4672        with an RV obj pointing to the glob containing the PVIO.  In
4673        this case, to avoid a reference loop, we need to weaken the
4674        reference.
4675     */
4676
4677     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4678         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4679     {
4680       sv_rvweaken(obj);
4681     }
4682
4683     mg->mg_type = how;
4684     mg->mg_len = namlen;
4685     if (name) {
4686         if (namlen > 0)
4687             mg->mg_ptr = savepvn(name, namlen);
4688         else if (namlen == HEf_SVKEY)
4689             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name);
4690         else
4691             mg->mg_ptr = (char *) name;
4692     }
4693     mg->mg_virtual = (MGVTBL *) vtable;
4694
4695     mg_magical(sv);
4696     if (SvGMAGICAL(sv))
4697         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4698     return mg;
4699 }
4700
4701 /*
4702 =for apidoc sv_magic
4703
4704 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4705 then adds a new magic item of type C<how> to the head of the magic list.
4706
4707 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4708 handling of the C<name> and C<namlen> arguments.
4709
4710 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4711 to add more than one instance of the same 'how'.
4712
4713 =cut
4714 */
4715
4716 void
4717 Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, 
4718              const char *const name, const I32 namlen)
4719 {
4720     dVAR;
4721     const MGVTBL *vtable;
4722     MAGIC* mg;
4723
4724     PERL_ARGS_ASSERT_SV_MAGIC;
4725
4726 #ifdef PERL_OLD_COPY_ON_WRITE
4727     if (SvIsCOW(sv))
4728         sv_force_normal_flags(sv, 0);
4729 #endif
4730     if (SvREADONLY(sv)) {
4731         if (
4732             /* its okay to attach magic to shared strings; the subsequent
4733              * upgrade to PVMG will unshare the string */
4734             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4735
4736             && IN_PERL_RUNTIME
4737             && how != PERL_MAGIC_regex_global
4738             && how != PERL_MAGIC_bm
4739             && how != PERL_MAGIC_fm
4740             && how != PERL_MAGIC_sv
4741             && how != PERL_MAGIC_backref
4742            )
4743         {
4744             Perl_croak(aTHX_ PL_no_modify);
4745         }
4746     }
4747     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4748         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4749             /* sv_magic() refuses to add a magic of the same 'how' as an
4750                existing one
4751              */
4752             if (how == PERL_MAGIC_taint) {
4753                 mg->mg_len |= 1;
4754                 /* Any scalar which already had taint magic on which someone
4755                    (erroneously?) did SvIOK_on() or similar will now be
4756                    incorrectly sporting public "OK" flags.  */
4757                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4758             }
4759             return;
4760         }
4761     }
4762
4763     switch (how) {
4764     case PERL_MAGIC_sv:
4765         vtable = &PL_vtbl_sv;
4766         break;
4767     case PERL_MAGIC_overload:
4768         vtable = &PL_vtbl_amagic;
4769         break;
4770     case PERL_MAGIC_overload_elem:
4771         vtable = &PL_vtbl_amagicelem;
4772         break;
4773     case PERL_MAGIC_overload_table:
4774         vtable = &PL_vtbl_ovrld;
4775         break;
4776     case PERL_MAGIC_bm:
4777         vtable = &PL_vtbl_bm;
4778         break;
4779     case PERL_MAGIC_regdata:
4780         vtable = &PL_vtbl_regdata;
4781         break;
4782     case PERL_MAGIC_regdatum:
4783         vtable = &PL_vtbl_regdatum;
4784         break;
4785     case PERL_MAGIC_env:
4786         vtable = &PL_vtbl_env;
4787         break;
4788     case PERL_MAGIC_fm:
4789         vtable = &PL_vtbl_fm;
4790         break;
4791     case PERL_MAGIC_envelem:
4792         vtable = &PL_vtbl_envelem;
4793         break;
4794     case PERL_MAGIC_regex_global:
4795         vtable = &PL_vtbl_mglob;
4796         break;
4797     case PERL_MAGIC_isa:
4798         vtable = &PL_vtbl_isa;
4799         break;
4800     case PERL_MAGIC_isaelem:
4801         vtable = &PL_vtbl_isaelem;
4802         break;
4803     case PERL_MAGIC_nkeys:
4804         vtable = &PL_vtbl_nkeys;
4805         break;
4806     case PERL_MAGIC_dbfile:
4807         vtable = NULL;
4808         break;
4809     case PERL_MAGIC_dbline:
4810         vtable = &PL_vtbl_dbline;
4811         break;
4812 #ifdef USE_LOCALE_COLLATE
4813     case PERL_MAGIC_collxfrm:
4814         vtable = &PL_vtbl_collxfrm;
4815         break;
4816 #endif /* USE_LOCALE_COLLATE */
4817     case PERL_MAGIC_tied:
4818         vtable = &PL_vtbl_pack;
4819         break;
4820     case PERL_MAGIC_tiedelem:
4821     case PERL_MAGIC_tiedscalar:
4822         vtable = &PL_vtbl_packelem;
4823         break;
4824     case PERL_MAGIC_qr:
4825         vtable = &PL_vtbl_regexp;
4826         break;
4827     case PERL_MAGIC_hints:
4828         /* As this vtable is all NULL, we can reuse it.  */
4829     case PERL_MAGIC_sig:
4830         vtable = &PL_vtbl_sig;
4831         break;
4832     case PERL_MAGIC_sigelem:
4833         vtable = &PL_vtbl_sigelem;
4834         break;
4835     case PERL_MAGIC_taint:
4836         vtable = &PL_vtbl_taint;
4837         break;
4838     case PERL_MAGIC_uvar:
4839         vtable = &PL_vtbl_uvar;
4840         break;
4841     case PERL_MAGIC_vec:
4842         vtable = &PL_vtbl_vec;
4843         break;
4844     case PERL_MAGIC_arylen_p:
4845     case PERL_MAGIC_rhash:
4846     case PERL_MAGIC_symtab:
4847     case PERL_MAGIC_vstring:
4848         vtable = NULL;
4849         break;
4850     case PERL_MAGIC_utf8:
4851         vtable = &PL_vtbl_utf8;
4852         break;
4853     case PERL_MAGIC_substr:
4854         vtable = &PL_vtbl_substr;
4855         break;
4856     case PERL_MAGIC_defelem:
4857         vtable = &PL_vtbl_defelem;
4858         break;
4859     case PERL_MAGIC_arylen:
4860         vtable = &PL_vtbl_arylen;
4861         break;
4862     case PERL_MAGIC_pos:
4863         vtable = &PL_vtbl_pos;
4864         break;
4865     case PERL_MAGIC_backref:
4866         vtable = &PL_vtbl_backref;
4867         break;
4868     case PERL_MAGIC_hintselem:
4869         vtable = &PL_vtbl_hintselem;
4870         break;
4871     case PERL_MAGIC_ext:
4872         /* Reserved for use by extensions not perl internals.           */
4873         /* Useful for attaching extension internal data to perl vars.   */
4874         /* Note that multiple extensions may clash if magical scalars   */
4875         /* etc holding private data from one are passed to another.     */
4876         vtable = NULL;
4877         break;
4878     default:
4879         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4880     }
4881
4882     /* Rest of work is done else where */
4883     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4884
4885     switch (how) {
4886     case PERL_MAGIC_taint:
4887         mg->mg_len = 1;
4888         break;
4889     case PERL_MAGIC_ext:
4890     case PERL_MAGIC_dbfile:
4891         SvRMAGICAL_on(sv);
4892         break;
4893     }
4894 }
4895
4896 /*
4897 =for apidoc sv_unmagic
4898
4899 Removes all magic of type C<type> from an SV.
4900
4901 =cut
4902 */
4903
4904 int
4905 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
4906 {
4907     MAGIC* mg;
4908     MAGIC** mgp;
4909
4910     PERL_ARGS_ASSERT_SV_UNMAGIC;
4911
4912     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4913         return 0;
4914     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
4915     for (mg = *mgp; mg; mg = *mgp) {
4916         if (mg->mg_type == type) {
4917             const MGVTBL* const vtbl = mg->mg_virtual;
4918             *mgp = mg->mg_moremagic;
4919             if (vtbl && vtbl->svt_free)
4920                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4921             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4922                 if (mg->mg_len > 0)
4923                     Safefree(mg->mg_ptr);
4924                 else if (mg->mg_len == HEf_SVKEY)
4925                     SvREFCNT_dec((SV*)mg->mg_ptr);
4926                 else if (mg->mg_type == PERL_MAGIC_utf8)
4927                     Safefree(mg->mg_ptr);
4928             }
4929             if (mg->mg_flags & MGf_REFCOUNTED)
4930                 SvREFCNT_dec(mg->mg_obj);
4931             Safefree(mg);
4932         }
4933         else
4934             mgp = &mg->mg_moremagic;
4935     }
4936     if (!SvMAGIC(sv)) {
4937         SvMAGICAL_off(sv);
4938         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4939         SvMAGIC_set(sv, NULL);
4940     }
4941
4942     return 0;
4943 }
4944
4945 /*
4946 =for apidoc sv_rvweaken
4947
4948 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4949 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4950 push a back-reference to this RV onto the array of backreferences
4951 associated with that magic. If the RV is magical, set magic will be
4952 called after the RV is cleared.
4953
4954 =cut
4955 */
4956
4957 SV *
4958 Perl_sv_rvweaken(pTHX_ SV *const sv)
4959 {
4960     SV *tsv;
4961
4962     PERL_ARGS_ASSERT_SV_RVWEAKEN;
4963
4964     if (!SvOK(sv))  /* let undefs pass */
4965         return sv;
4966     if (!SvROK(sv))
4967         Perl_croak(aTHX_ "Can't weaken a nonreference");
4968     else if (SvWEAKREF(sv)) {
4969         if (ckWARN(WARN_MISC))
4970             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4971         return sv;
4972     }
4973     tsv = SvRV(sv);
4974     Perl_sv_add_backref(aTHX_ tsv, sv);
4975     SvWEAKREF_on(sv);
4976     SvREFCNT_dec(tsv);
4977     return sv;
4978 }
4979
4980 /* Give tsv backref magic if it hasn't already got it, then push a
4981  * back-reference to sv onto the array associated with the backref magic.
4982  */
4983
4984 void
4985 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
4986 {
4987     dVAR;
4988     AV *av;
4989
4990     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
4991
4992     if (SvTYPE(tsv) == SVt_PVHV) {
4993         AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
4994
4995         av = *avp;
4996         if (!av) {
4997             /* There is no AV in the offical place - try a fixup.  */
4998             MAGIC *const mg = mg_find(tsv, PERL_MAGIC_backref);
4999
5000             if (mg) {
5001                 /* Aha. They've got it stowed in magic.  Bring it back.  */
5002                 av = (AV*)mg->mg_obj;
5003                 /* Stop mg_free decreasing the refernce count.  */
5004                 mg->mg_obj = NULL;
5005                 /* Stop mg_free even calling the destructor, given that
5006                    there's no AV to free up.  */
5007                 mg->mg_virtual = 0;
5008                 sv_unmagic(tsv, PERL_MAGIC_backref);
5009             } else {
5010                 av = newAV();
5011                 AvREAL_off(av);
5012                 SvREFCNT_inc_simple_void(av);
5013             }
5014             *avp = av;
5015         }
5016     } else {
5017         const MAGIC *const mg
5018             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5019         if (mg)
5020             av = (AV*)mg->mg_obj;
5021         else {
5022             av = newAV();
5023             AvREAL_off(av);
5024             sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5025             /* av now has a refcnt of 2, which avoids it getting freed
5026              * before us during global cleanup. The extra ref is removed
5027              * by magic_killbackrefs() when tsv is being freed */
5028         }
5029     }
5030     if (AvFILLp(av) >= AvMAX(av)) {
5031         av_extend(av, AvFILLp(av)+1);
5032     }
5033     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5034 }
5035
5036 /* delete a back-reference to ourselves from the backref magic associated
5037  * with the SV we point to.
5038  */
5039
5040 STATIC void
5041 S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5042 {
5043     dVAR;
5044     AV *av = NULL;
5045     SV **svp;
5046     I32 i;
5047
5048     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5049
5050     if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) {
5051         av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv);
5052         /* We mustn't attempt to "fix up" the hash here by moving the
5053            backreference array back to the hv_aux structure, as that is stored
5054            in the main HvARRAY(), and hfreentries assumes that no-one
5055            reallocates HvARRAY() while it is running.  */
5056     }
5057     if (!av) {
5058         const MAGIC *const mg
5059             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5060         if (mg)
5061             av = (AV *)mg->mg_obj;
5062     }
5063     if (!av) {
5064         if (PL_in_clean_all)
5065             return;
5066         Perl_croak(aTHX_ "panic: del_backref");
5067     }
5068
5069     if (SvIS_FREED(av))
5070         return;
5071
5072     svp = AvARRAY(av);
5073     /* We shouldn't be in here more than once, but for paranoia reasons lets
5074        not assume this.  */
5075     for (i = AvFILLp(av); i >= 0; i--) {
5076         if (svp[i] == sv) {
5077             const SSize_t fill = AvFILLp(av);
5078             if (i != fill) {
5079                 /* We weren't the last entry.
5080                    An unordered list has this property that you can take the
5081                    last element off the end to fill the hole, and it's still
5082                    an unordered list :-)
5083                 */
5084                 svp[i] = svp[fill];
5085             }
5086             svp[fill] = NULL;
5087             AvFILLp(av) = fill - 1;
5088         }
5089     }
5090 }
5091
5092 int
5093 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5094 {
5095     SV **svp = AvARRAY(av);
5096
5097     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5098     PERL_UNUSED_ARG(sv);
5099
5100     /* Not sure why the av can get freed ahead of its sv, but somehow it does
5101        in ext/B/t/bytecode.t test 15 (involving print <DATA>)  */
5102     if (svp && !SvIS_FREED(av)) {
5103         SV *const *const last = svp + AvFILLp(av);
5104
5105         while (svp <= last) {
5106             if (*svp) {
5107                 SV *const referrer = *svp;
5108                 if (SvWEAKREF(referrer)) {
5109                     /* XXX Should we check that it hasn't changed? */
5110                     SvRV_set(referrer, 0);
5111                     SvOK_off(referrer);
5112                     SvWEAKREF_off(referrer);
5113                     SvSETMAGIC(referrer);
5114                 } else if (SvTYPE(referrer) == SVt_PVGV ||
5115                            SvTYPE(referrer) == SVt_PVLV) {
5116                     /* You lookin' at me?  */
5117                     assert(GvSTASH(referrer));
5118                     assert(GvSTASH(referrer) == (HV*)sv);
5119                     GvSTASH(referrer) = 0;
5120                 } else {
5121                     Perl_croak(aTHX_
5122                                "panic: magic_killbackrefs (flags=%"UVxf")",
5123                                (UV)SvFLAGS(referrer));
5124                 }
5125
5126                 *svp = NULL;
5127             }
5128             svp++;
5129         }
5130     }
5131     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
5132     return 0;
5133 }
5134
5135 /*
5136 =for apidoc sv_insert
5137
5138 Inserts a string at the specified offset/length within the SV. Similar to
5139 the Perl substr() function.
5140
5141 =cut
5142 */
5143
5144 void
5145 Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, 
5146               const char *const little, const STRLEN littlelen)
5147 {
5148     dVAR;
5149     register char *big;
5150     register char *mid;
5151     register char *midend;
5152     register char *bigend;
5153     register I32 i;
5154     STRLEN curlen;
5155
5156     PERL_ARGS_ASSERT_SV_INSERT;
5157
5158     if (!bigstr)
5159         Perl_croak(aTHX_ "Can't modify non-existent substring");
5160     SvPV_force(bigstr, curlen);
5161     (void)SvPOK_only_UTF8(bigstr);
5162     if (offset + len > curlen) {
5163         SvGROW(bigstr, offset+len+1);
5164         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5165         SvCUR_set(bigstr, offset+len);
5166     }
5167
5168     SvTAINT(bigstr);
5169     i = littlelen - len;
5170     if (i > 0) {                        /* string might grow */
5171         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5172         mid = big + offset + len;
5173         midend = bigend = big + SvCUR(bigstr);
5174         bigend += i;
5175         *bigend = '\0';
5176         while (midend > mid)            /* shove everything down */
5177             *--bigend = *--midend;
5178         Move(little,big+offset,littlelen,char);
5179         SvCUR_set(bigstr, SvCUR(bigstr) + i);
5180         SvSETMAGIC(bigstr);
5181         return;
5182     }
5183     else if (i == 0) {
5184         Move(little,SvPVX(bigstr)+offset,len,char);
5185         SvSETMAGIC(bigstr);
5186         return;
5187     }
5188
5189     big = SvPVX(bigstr);
5190     mid = big + offset;
5191     midend = mid + len;
5192     bigend = big + SvCUR(bigstr);
5193
5194     if (midend > bigend)
5195         Perl_croak(aTHX_ "panic: sv_insert");
5196
5197     if (mid - big > bigend - midend) {  /* faster to shorten from end */
5198         if (littlelen) {
5199             Move(little, mid, littlelen,char);
5200             mid += littlelen;
5201         }
5202         i = bigend - midend;
5203         if (i > 0) {
5204             Move(midend, mid, i,char);
5205             mid += i;
5206         }
5207         *mid = '\0';
5208         SvCUR_set(bigstr, mid - big);
5209     }
5210     else if ((i = mid - big)) { /* faster from front */
5211         midend -= littlelen;
5212         mid = midend;
5213         Move(big, midend - i, i, char);
5214         sv_chop(bigstr,midend-i);
5215         if (littlelen)
5216             Move(little, mid, littlelen,char);
5217     }
5218     else if (littlelen) {
5219         midend -= littlelen;
5220         sv_chop(bigstr,midend);
5221         Move(little,midend,littlelen,char);
5222     }
5223     else {
5224         sv_chop(bigstr,midend);
5225     }
5226     SvSETMAGIC(bigstr);
5227 }
5228
5229 /*
5230 =for apidoc sv_replace
5231
5232 Make the first argument a copy of the second, then delete the original.
5233 The target SV physically takes over ownership of the body of the source SV
5234 and inherits its flags; however, the target keeps any magic it owns,
5235 and any magic in the source is discarded.
5236 Note that this is a rather specialist SV copying operation; most of the
5237 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5238
5239 =cut
5240 */
5241
5242 void
5243 Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv)
5244 {
5245     dVAR;
5246     const U32 refcnt = SvREFCNT(sv);
5247
5248     PERL_ARGS_ASSERT_SV_REPLACE;
5249
5250     SV_CHECK_THINKFIRST_COW_DROP(sv);
5251     if (SvREFCNT(nsv) != 1) {
5252         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5253                    UVuf " != 1)", (UV) SvREFCNT(nsv));
5254     }
5255     if (SvMAGICAL(sv)) {
5256         if (SvMAGICAL(nsv))
5257             mg_free(nsv);
5258         else
5259             sv_upgrade(nsv, SVt_PVMG);
5260         SvMAGIC_set(nsv, SvMAGIC(sv));
5261         SvFLAGS(nsv) |= SvMAGICAL(sv);
5262         SvMAGICAL_off(sv);
5263         SvMAGIC_set(sv, NULL);
5264     }
5265     SvREFCNT(sv) = 0;
5266     sv_clear(sv);
5267     assert(!SvREFCNT(sv));
5268 #ifdef DEBUG_LEAKING_SCALARS
5269     sv->sv_flags  = nsv->sv_flags;
5270     sv->sv_any    = nsv->sv_any;
5271     sv->sv_refcnt = nsv->sv_refcnt;
5272     sv->sv_u      = nsv->sv_u;
5273 #else
5274     StructCopy(nsv,sv,SV);
5275 #endif
5276     if(SvTYPE(sv) == SVt_IV) {
5277         SvANY(sv)
5278             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5279     }
5280         
5281
5282 #ifdef PERL_OLD_COPY_ON_WRITE
5283     if (SvIsCOW_normal(nsv)) {
5284         /* We need to follow the pointers around the loop to make the
5285            previous SV point to sv, rather than nsv.  */
5286         SV *next;
5287         SV *current = nsv;
5288         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5289             assert(next);
5290             current = next;
5291             assert(SvPVX_const(current) == SvPVX_const(nsv));
5292         }
5293         /* Make the SV before us point to the SV after us.  */
5294         if (DEBUG_C_TEST) {
5295             PerlIO_printf(Perl_debug_log, "previous is\n");
5296             sv_dump(current);
5297             PerlIO_printf(Perl_debug_log,
5298                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5299                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
5300         }
5301         SV_COW_NEXT_SV_SET(current, sv);
5302     }
5303 #endif
5304     SvREFCNT(sv) = refcnt;
5305     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
5306     SvREFCNT(nsv) = 0;
5307     del_SV(nsv);
5308 }
5309
5310 /*
5311 =for apidoc sv_clear
5312
5313 Clear an SV: call any destructors, free up any memory used by the body,
5314 and free the body itself. The SV's head is I<not> freed, although
5315 its type is set to all 1's so that it won't inadvertently be assumed
5316 to be live during global destruction etc.
5317 This function should only be called when REFCNT is zero. Most of the time
5318 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5319 instead.
5320
5321 =cut
5322 */
5323
5324 void
5325 Perl_sv_clear(pTHX_ register SV *const sv)
5326 {
5327     dVAR;
5328     const U32 type = SvTYPE(sv);
5329     const struct body_details *const sv_type_details
5330         = bodies_by_type + type;
5331     HV *stash;
5332
5333     PERL_ARGS_ASSERT_SV_CLEAR;
5334     assert(SvREFCNT(sv) == 0);
5335     assert(SvTYPE(sv) != SVTYPEMASK);
5336
5337     if (type <= SVt_IV) {
5338         /* See the comment in sv.h about the collusion between this early
5339            return and the overloading of the NULL and IV slots in the size
5340            table.  */
5341         if (SvROK(sv)) {
5342             SV * const target = SvRV(sv);
5343             if (SvWEAKREF(sv))
5344                 sv_del_backref(target, sv);
5345             else
5346                 SvREFCNT_dec(target);
5347         }
5348         SvFLAGS(sv) &= SVf_BREAK;
5349         SvFLAGS(sv) |= SVTYPEMASK;
5350         return;
5351     }
5352
5353     if (SvOBJECT(sv)) {
5354         if (PL_defstash &&      /* Still have a symbol table? */
5355             SvDESTROYABLE(sv))
5356         {
5357             dSP;
5358             HV* stash;
5359             do {        
5360                 CV* destructor;
5361                 stash = SvSTASH(sv);
5362                 destructor = StashHANDLER(stash,DESTROY);
5363                 if (destructor) {
5364                     SV* const tmpref = newRV(sv);
5365                     SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5366                     ENTER;
5367                     PUSHSTACKi(PERLSI_DESTROY);
5368                     EXTEND(SP, 2);
5369                     PUSHMARK(SP);
5370                     PUSHs(tmpref);
5371                     PUTBACK;
5372                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5373                 
5374                 
5375                     POPSTACK;
5376                     SPAGAIN;
5377                     LEAVE;
5378                     if(SvREFCNT(tmpref) < 2) {
5379                         /* tmpref is not kept alive! */
5380                         SvREFCNT(sv)--;
5381                         SvRV_set(tmpref, NULL);
5382                         SvROK_off(tmpref);
5383                     }
5384                     SvREFCNT_dec(tmpref);
5385                 }
5386             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5387
5388
5389             if (SvREFCNT(sv)) {
5390                 if (PL_in_clean_objs)
5391                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5392                           HvNAME_get(stash));
5393                 /* DESTROY gave object new lease on life */
5394                 return;
5395             }
5396         }
5397
5398         if (SvOBJECT(sv)) {
5399             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
5400             SvOBJECT_off(sv);   /* Curse the object. */
5401             if (type != SVt_PVIO)
5402                 --PL_sv_objcount;       /* XXX Might want something more general */
5403         }
5404     }
5405     if (type >= SVt_PVMG) {
5406         if (type == SVt_PVMG && SvPAD_OUR(sv)) {
5407             SvREFCNT_dec(SvOURSTASH(sv));
5408         } else if (SvMAGIC(sv))
5409             mg_free(sv);
5410         if (type == SVt_PVMG && SvPAD_TYPED(sv))
5411             SvREFCNT_dec(SvSTASH(sv));
5412     }
5413     switch (type) {
5414         /* case SVt_BIND: */
5415     case SVt_PVIO:
5416         if (IoIFP(sv) &&
5417             IoIFP(sv) != PerlIO_stdin() &&
5418             IoIFP(sv) != PerlIO_stdout() &&
5419             IoIFP(sv) != PerlIO_stderr())
5420         {
5421             io_close((IO*)sv, FALSE);
5422         }
5423         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5424             PerlDir_close(IoDIRP(sv));
5425         IoDIRP(sv) = (DIR*)NULL;
5426         Safefree(IoTOP_NAME(sv));
5427         Safefree(IoFMT_NAME(sv));
5428         Safefree(IoBOTTOM_NAME(sv));
5429         goto freescalar;
5430     case SVt_REGEXP:
5431         /* FIXME for plugins */
5432         pregfree2((REGEXP*) sv);
5433         goto freescalar;
5434     case SVt_PVCV:
5435     case SVt_PVFM:
5436         cv_undef((CV*)sv);
5437         goto freescalar;
5438     case SVt_PVHV:
5439         Perl_hv_kill_backrefs(aTHX_ (HV*)sv);
5440         hv_undef((HV*)sv);
5441         break;
5442     case SVt_PVAV:
5443         if (PL_comppad == (AV*)sv) {
5444             PL_comppad = NULL;
5445             PL_curpad = NULL;
5446         }
5447         av_undef((AV*)sv);
5448         break;
5449     case SVt_PVLV:
5450         if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5451             SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5452             HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5453             PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5454         }
5455         else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5456             SvREFCNT_dec(LvTARG(sv));
5457     case SVt_PVGV:
5458         if (isGV_with_GP(sv)) {
5459             if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
5460                 mro_method_changed_in(stash);
5461             gp_free((GV*)sv);
5462             if (GvNAME_HEK(sv))
5463                 unshare_hek(GvNAME_HEK(sv));
5464             /* If we're in a stash, we don't own a reference to it. However it does
5465                have a back reference to us, which needs to be cleared.  */
5466             if (!SvVALID(sv) && (stash = GvSTASH(sv)))
5467                     sv_del_backref((SV*)stash, sv);
5468         }
5469         /* FIXME. There are probably more unreferenced pointers to SVs in the
5470            interpreter struct that we should check and tidy in a similar
5471            fashion to this:  */
5472         if ((GV*)sv == PL_last_in_gv)
5473             PL_last_in_gv = NULL;
5474     case SVt_PVMG:
5475     case SVt_PVNV:
5476     case SVt_PVIV:
5477     case SVt_PV:
5478       freescalar:
5479         /* Don't bother with SvOOK_off(sv); as we're only going to free it.  */
5480         if (SvOOK(sv)) {
5481             STRLEN offset;
5482             SvOOK_offset(sv, offset);
5483             SvPV_set(sv, SvPVX_mutable(sv) - offset);
5484             /* Don't even bother with turning off the OOK flag.  */
5485         }
5486         if (SvROK(sv)) {
5487             SV * const target = SvRV(sv);
5488             if (SvWEAKREF(sv))
5489                 sv_del_backref(target, sv);
5490             else
5491                 SvREFCNT_dec(target);
5492         }
5493 #ifdef PERL_OLD_COPY_ON_WRITE
5494         else if (SvPVX_const(sv)) {
5495             if (SvIsCOW(sv)) {
5496                 /* I believe I need to grab the global SV mutex here and
5497                    then recheck the COW status.  */
5498                 if (DEBUG_C_TEST) {
5499                     PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5500                     sv_dump(sv);
5501                 }
5502                 if (SvLEN(sv)) {
5503                     sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
5504                 } else {
5505                     unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5506                 }
5507
5508                 /* And drop it here.  */
5509                 SvFAKE_off(sv);
5510             } else if (SvLEN(sv)) {
5511                 Safefree(SvPVX_const(sv));
5512             }
5513         }
5514 #else
5515         else if (SvPVX_const(sv) && SvLEN(sv))
5516             Safefree(SvPVX_mutable(sv));
5517         else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5518             unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5519             SvFAKE_off(sv);
5520         }
5521 #endif
5522         break;
5523     case SVt_NV:
5524         break;
5525     }
5526
5527     SvFLAGS(sv) &= SVf_BREAK;
5528     SvFLAGS(sv) |= SVTYPEMASK;
5529
5530     if (sv_type_details->arena) {
5531         del_body(((char *)SvANY(sv) + sv_type_details->offset),
5532                  &PL_body_roots[type]);
5533     }
5534     else if (sv_type_details->body_size) {
5535         my_safefree(SvANY(sv));
5536     }
5537 }
5538
5539 /*
5540 =for apidoc sv_newref
5541
5542 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5543 instead.
5544
5545 =cut
5546 */
5547
5548 SV *
5549 Perl_sv_newref(pTHX_ SV *const sv)
5550 {
5551     PERL_UNUSED_CONTEXT;
5552     if (sv)
5553         (SvREFCNT(sv))++;
5554     return sv;
5555 }
5556
5557 /*
5558 =for apidoc sv_free
5559
5560 Decrement an SV's reference count, and if it drops to zero, call
5561 C<sv_clear> to invoke destructors and free up any memory used by
5562 the body; finally, deallocate the SV's head itself.
5563 Normally called via a wrapper macro C<SvREFCNT_dec>.
5564
5565 =cut
5566 */
5567
5568 void
5569 Perl_sv_free(pTHX_ SV *const sv)
5570 {
5571     dVAR;
5572     if (!sv)
5573         return;
5574     if (SvREFCNT(sv) == 0) {
5575         if (SvFLAGS(sv) & SVf_BREAK)
5576             /* this SV's refcnt has been artificially decremented to
5577              * trigger cleanup */
5578             return;
5579         if (PL_in_clean_all) /* All is fair */
5580             return;
5581         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5582             /* make sure SvREFCNT(sv)==0 happens very seldom */
5583             SvREFCNT(sv) = (~(U32)0)/2;
5584             return;
5585         }
5586         if (ckWARN_d(WARN_INTERNAL)) {
5587 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5588             Perl_dump_sv_child(aTHX_ sv);
5589 #else
5590   #ifdef DEBUG_LEAKING_SCALARS
5591             sv_dump(sv);
5592   #endif
5593 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5594             if (PL_warnhook == PERL_WARNHOOK_FATAL
5595                 || ckDEAD(packWARN(WARN_INTERNAL))) {
5596                 /* Don't let Perl_warner cause us to escape our fate:  */
5597                 abort();
5598             }
5599 #endif
5600             /* This may not return:  */
5601             Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5602                         "Attempt to free unreferenced scalar: SV 0x%"UVxf
5603                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5604 #endif
5605         }
5606 #ifdef DEBUG_LEAKING_SCALARS_ABORT
5607         abort();
5608 #endif
5609         return;
5610     }
5611     if (--(SvREFCNT(sv)) > 0)
5612         return;
5613     Perl_sv_free2(aTHX_ sv);
5614 }
5615
5616 void
5617 Perl_sv_free2(pTHX_ SV *const sv)
5618 {
5619     dVAR;
5620
5621     PERL_ARGS_ASSERT_SV_FREE2;
5622
5623 #ifdef DEBUGGING
5624     if (SvTEMP(sv)) {
5625         if (ckWARN_d(WARN_DEBUGGING))
5626             Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5627                         "Attempt to free temp prematurely: SV 0x%"UVxf
5628                         pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5629         return;
5630     }
5631 #endif
5632     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5633         /* make sure SvREFCNT(sv)==0 happens very seldom */
5634         SvREFCNT(sv) = (~(U32)0)/2;
5635         return;
5636     }
5637     sv_clear(sv);
5638     if (! SvREFCNT(sv))
5639         del_SV(sv);
5640 }
5641
5642 /*
5643 =for apidoc sv_len
5644
5645 Returns the length of the string in the SV. Handles magic and type
5646 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5647
5648 =cut
5649 */
5650
5651 STRLEN
5652 Perl_sv_len(pTHX_ register SV *const sv)
5653 {
5654     STRLEN len;
5655
5656     if (!sv)
5657         return 0;
5658
5659     if (SvGMAGICAL(sv))
5660         len = mg_length(sv);
5661     else
5662         (void)SvPV_const(sv, len);
5663     return len;
5664 }
5665
5666 /*
5667 =for apidoc sv_len_utf8
5668
5669 Returns the number of characters in the string in an SV, counting wide
5670 UTF-8 bytes as a single character. Handles magic and type coercion.
5671
5672 =cut
5673 */
5674
5675 /*
5676  * The length is cached in PERL_UTF8_magic, in the mg_len field.  Also the
5677  * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
5678  * (Note that the mg_len is not the length of the mg_ptr field.
5679  * This allows the cache to store the character length of the string without
5680  * needing to malloc() extra storage to attach to the mg_ptr.)
5681  *
5682  */
5683
5684 STRLEN
5685 Perl_sv_len_utf8(pTHX_ register SV *const sv)
5686 {
5687     if (!sv)
5688         return 0;
5689
5690     if (SvGMAGICAL(sv))
5691         return mg_length(sv);
5692     else
5693     {
5694         STRLEN len;
5695         const U8 *s = (U8*)SvPV_const(sv, len);
5696
5697         if (PL_utf8cache) {
5698             STRLEN ulen;
5699             MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
5700
5701             if (mg && mg->mg_len != -1) {
5702                 ulen = mg->mg_len;
5703                 if (PL_utf8cache < 0) {
5704                     const STRLEN real = Perl_utf8_length(aTHX_ s, s + len);
5705                     if (real != ulen) {
5706                         /* Need to turn the assertions off otherwise we may
5707                            recurse infinitely while printing error messages.
5708                         */
5709                         SAVEI8(PL_utf8cache);
5710                         PL_utf8cache = 0;
5711                         Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
5712                                    " real %"UVuf" for %"SVf,
5713                                    (UV) ulen, (UV) real, SVfARG(sv));
5714                     }
5715                 }
5716             }
5717             else {
5718                 ulen = Perl_utf8_length(aTHX_ s, s + len);
5719                 if (!SvREADONLY(sv)) {
5720                     if (!mg) {
5721                         mg = sv_magicext(sv, 0, PERL_MAGIC_utf8,
5722                                          &PL_vtbl_utf8, 0, 0);
5723                     }
5724                     assert(mg);
5725                     mg->mg_len = ulen;
5726                 }
5727             }
5728             return ulen;
5729         }
5730         return Perl_utf8_length(aTHX_ s, s + len);
5731     }
5732 }
5733
5734 /* Walk forwards to find the byte corresponding to the passed in UTF-8
5735    offset.  */
5736 static STRLEN
5737 S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
5738                       STRLEN uoffset)
5739 {
5740     const U8 *s = start;
5741
5742     PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS;
5743
5744     while (s < send && uoffset--)
5745         s += UTF8SKIP(s);
5746     if (s > send) {
5747         /* This is the existing behaviour. Possibly it should be a croak, as
5748            it's actually a bounds error  */
5749         s = send;
5750     }
5751     return s - start;
5752 }
5753
5754 /* Given the length of the string in both bytes and UTF-8 characters, decide
5755    whether to walk forwards or backwards to find the byte corresponding to
5756    the passed in UTF-8 offset.  */
5757 static STRLEN
5758 S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
5759                       const STRLEN uoffset, const STRLEN uend)
5760 {
5761     STRLEN backw = uend - uoffset;
5762
5763     PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY;
5764
5765     if (uoffset < 2 * backw) {
5766         /* The assumption is that going forwards is twice the speed of going
5767            forward (that's where the 2 * backw comes from).
5768            (The real figure of course depends on the UTF-8 data.)  */
5769         return sv_pos_u2b_forwards(start, send, uoffset);
5770     }
5771
5772     while (backw--) {
5773         send--;
5774         while (UTF8_IS_CONTINUATION(*send))
5775             send--;
5776     }
5777     return send - start;
5778 }
5779
5780 /* For the string representation of the given scalar, find the byte
5781    corresponding to the passed in UTF-8 offset.  uoffset0 and boffset0
5782    give another position in the string, *before* the sought offset, which
5783    (which is always true, as 0, 0 is a valid pair of positions), which should
5784    help reduce the amount of linear searching.
5785    If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
5786    will be used to reduce the amount of linear searching. The cache will be
5787    created if necessary, and the found value offered to it for update.  */
5788 static STRLEN
5789 S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start,
5790                     const U8 *const send, const STRLEN uoffset,
5791                     STRLEN uoffset0, STRLEN boffset0)
5792 {
5793     STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy.  */
5794     bool found = FALSE;
5795
5796     PERL_ARGS_ASSERT_SV_POS_U2B_CACHED;
5797
5798     assert (uoffset >= uoffset0);
5799
5800     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
5801         && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
5802         if ((*mgp)->mg_ptr) {
5803             STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
5804             if (cache[0] == uoffset) {
5805                 /* An exact match. */
5806                 return cache[1];
5807             }
5808             if (cache[2] == uoffset) {
5809                 /* An exact match. */
5810                 return cache[3];
5811             }
5812
5813             if (cache[0] < uoffset) {
5814                 /* The cache already knows part of the way.   */
5815                 if (cache[0] > uoffset0) {
5816                     /* The cache knows more than the passed in pair  */
5817                     uoffset0 = cache[0];
5818                     boffset0 = cache[1];
5819                 }
5820                 if ((*mgp)->mg_len != -1) {
5821                     /* And we know the end too.  */
5822                     boffset = boffset0
5823                         + sv_pos_u2b_midway(start + boffset0, send,
5824                                               uoffset - uoffset0,
5825                                               (*mgp)->mg_len - uoffset0);
5826                 } else {
5827                     boffset = boffset0
5828                         + sv_pos_u2b_forwards(start + boffset0,
5829                                                 send, uoffset - uoffset0);
5830                 }
5831             }
5832             else if (cache[2] < uoffset) {
5833                 /* We're between the two cache entries.  */
5834                 if (cache[2] > uoffset0) {
5835                     /* and the cache knows more than the passed in pair  */
5836                     uoffset0 = cache[2];
5837                     boffset0 = cache[3];
5838                 }
5839
5840                 boffset = boffset0
5841                     + sv_pos_u2b_midway(start + boffset0,
5842                                           start + cache[1],
5843                                           uoffset - uoffset0,
5844                                           cache[0] - uoffset0);
5845             } else {
5846                 boffset = boffset0
5847                     + sv_pos_u2b_midway(start + boffset0,
5848                                           start + cache[3],
5849                                           uoffset - uoffset0,
5850                                           cache[2] - uoffset0);
5851             }
5852             found = TRUE;
5853         }
5854         else if ((*mgp)->mg_len != -1) {
5855             /* If we can take advantage of a passed in offset, do so.  */
5856             /* In fact, offset0 is either 0, or less than offset, so don't
5857                need to worry about the other possibility.  */
5858             boffset = boffset0
5859                 + sv_pos_u2b_midway(start + boffset0, send,
5860                                       uoffset - uoffset0,
5861                                       (*mgp)->mg_len - uoffset0);
5862             found = TRUE;
5863         }
5864     }
5865
5866     if (!found || PL_utf8cache < 0) {
5867         const STRLEN real_boffset
5868             = boffset0 + sv_pos_u2b_forwards(start + boffset0,
5869                                                send, uoffset - uoffset0);
5870
5871         if (found && PL_utf8cache < 0) {
5872             if (real_boffset != boffset) {
5873                 /* Need to turn the assertions off otherwise we may recurse
5874                    infinitely while printing error messages.  */
5875                 SAVEI8(PL_utf8cache);
5876                 PL_utf8cache = 0;
5877                 Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
5878                            " real %"UVuf" for %"SVf,
5879                            (UV) boffset, (UV) real_boffset, SVfARG(sv));
5880             }
5881         }
5882         boffset = real_boffset;
5883     }
5884
5885     if (PL_utf8cache)
5886         utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start);
5887     return boffset;
5888 }
5889
5890
5891 /*
5892 =for apidoc sv_pos_u2b
5893
5894 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5895 the start of the string, to a count of the equivalent number of bytes; if
5896 lenp is non-zero, it does the same to lenp, but this time starting from
5897 the offset, rather than from the start of the string. Handles magic and
5898 type coercion.
5899
5900 =cut
5901 */
5902
5903 /*
5904  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5905  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5906  * byte offsets.  See also the comments of S_utf8_mg_pos_cache_update().
5907  *
5908  */
5909
5910 void
5911 Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp)
5912 {
5913     const U8 *start;
5914     STRLEN len;
5915
5916     PERL_ARGS_ASSERT_SV_POS_U2B;
5917
5918     if (!sv)
5919         return;
5920
5921     start = (U8*)SvPV_const(sv, len);
5922     if (len) {
5923         STRLEN uoffset = (STRLEN) *offsetp;
5924         const U8 * const send = start + len;
5925         MAGIC *mg = NULL;
5926         const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
5927                                              uoffset, 0, 0);
5928
5929         *offsetp = (I32) boffset;
5930
5931         if (lenp) {
5932             /* Convert the relative offset to absolute.  */
5933             const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
5934             const STRLEN boffset2
5935                 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
5936                                       uoffset, boffset) - boffset;
5937
5938             *lenp = boffset2;
5939         }
5940     }
5941     else {
5942          *offsetp = 0;
5943          if (lenp)
5944               *lenp = 0;
5945     }
5946
5947     return;
5948 }
5949
5950 /* Create and update the UTF8 magic offset cache, with the proffered utf8/
5951    byte length pairing. The (byte) length of the total SV is passed in too,
5952    as blen, because for some (more esoteric) SVs, the call to SvPV_const()
5953    may not have updated SvCUR, so we can't rely on reading it directly.
5954
5955    The proffered utf8/byte length pairing isn't used if the cache already has
5956    two pairs, and swapping either for the proffered pair would increase the
5957    RMS of the intervals between known byte offsets.
5958
5959    The cache itself consists of 4 STRLEN values
5960    0: larger UTF-8 offset
5961    1: corresponding byte offset
5962    2: smaller UTF-8 offset
5963    3: corresponding byte offset
5964
5965    Unused cache pairs have the value 0, 0.
5966    Keeping the cache "backwards" means that the invariant of
5967    cache[0] >= cache[2] is maintained even with empty slots, which means that
5968    the code that uses it doesn't need to worry if only 1 entry has actually
5969    been set to non-zero.  It also makes the "position beyond the end of the
5970    cache" logic much simpler, as the first slot is always the one to start
5971    from.   
5972 */
5973 static void
5974 S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte,
5975                            const STRLEN utf8, const STRLEN blen)
5976 {
5977     STRLEN *cache;
5978
5979     PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE;
5980
5981     if (SvREADONLY(sv))
5982         return;
5983
5984     if (!*mgp) {
5985         *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0,
5986                            0);
5987         (*mgp)->mg_len = -1;
5988     }
5989     assert(*mgp);
5990
5991     if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) {
5992         Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5993         (*mgp)->mg_ptr = (char *) cache;
5994     }
5995     assert(cache);
5996
5997     if (PL_utf8cache < 0) {
5998         const U8 *start = (const U8 *) SvPVX_const(sv);
5999         const STRLEN realutf8 = utf8_length(start, start + byte);
6000
6001         if (realutf8 != utf8) {
6002             /* Need to turn the assertions off otherwise we may recurse
6003                infinitely while printing error messages.  */
6004             SAVEI8(PL_utf8cache);
6005             PL_utf8cache = 0;
6006             Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
6007                        " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, SVfARG(sv));
6008         }
6009     }
6010
6011     /* Cache is held with the later position first, to simplify the code
6012        that deals with unbounded ends.  */
6013        
6014     ASSERT_UTF8_CACHE(cache);
6015     if (cache[1] == 0) {
6016         /* Cache is totally empty  */
6017         cache[0] = utf8;
6018         cache[1] = byte;
6019     } else if (cache[3] == 0) {
6020         if (byte > cache[1]) {
6021             /* New one is larger, so goes first.  */
6022             cache[2] = cache[0];
6023             cache[3] = cache[1];
6024             cache[0] = utf8;
6025             cache[1] = byte;
6026         } else {
6027             cache[2] = utf8;
6028             cache[3] = byte;
6029         }
6030     } else {
6031 #define THREEWAY_SQUARE(a,b,c,d) \
6032             ((float)((d) - (c))) * ((float)((d) - (c))) \
6033             + ((float)((c) - (b))) * ((float)((c) - (b))) \
6034                + ((float)((b) - (a))) * ((float)((b) - (a)))
6035
6036         /* Cache has 2 slots in use, and we know three potential pairs.
6037            Keep the two that give the lowest RMS distance. Do the
6038            calcualation in bytes simply because we always know the byte
6039            length.  squareroot has the same ordering as the positive value,
6040            so don't bother with the actual square root.  */
6041         const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
6042         if (byte > cache[1]) {
6043             /* New position is after the existing pair of pairs.  */
6044             const float keep_earlier
6045                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6046             const float keep_later
6047                 = THREEWAY_SQUARE(0, cache[1], byte, blen);
6048
6049             if (keep_later < keep_earlier) {
6050                 if (keep_later < existing) {
6051                     cache[2] = cache[0];
6052                     cache[3] = cache[1];
6053                     cache[0] = utf8;
6054                     cache[1] = byte;
6055                 }
6056             }
6057             else {
6058                 if (keep_earlier < existing) {
6059                     cache[0] = utf8;
6060                     cache[1] = byte;
6061                 }
6062             }
6063         }
6064         else if (byte > cache[3]) {
6065             /* New position is between the existing pair of pairs.  */
6066             const float keep_earlier
6067                 = THREEWAY_SQUARE(0, cache[3], byte, blen);
6068             const float keep_later
6069                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6070
6071             if (keep_later < keep_earlier) {
6072                 if (keep_later < existing) {
6073                     cache[2] = utf8;
6074                     cache[3] = byte;
6075                 }
6076             }
6077             else {
6078                 if (keep_earlier < existing) {
6079                     cache[0] = utf8;
6080                     cache[1] = byte;
6081                 }
6082             }
6083         }
6084         else {
6085             /* New position is before the existing pair of pairs.  */
6086             const float keep_earlier
6087                 = THREEWAY_SQUARE(0, byte, cache[3], blen);
6088             const float keep_later
6089                 = THREEWAY_SQUARE(0, byte, cache[1], blen);
6090
6091             if (keep_later < keep_earlier) {
6092                 if (keep_later < existing) {
6093                     cache[2] = utf8;
6094                     cache[3] = byte;
6095                 }
6096             }
6097             else {
6098                 if (keep_earlier < existing) {
6099                     cache[0] = cache[2];
6100                     cache[1] = cache[3];
6101                     cache[2] = utf8;
6102                     cache[3] = byte;
6103                 }
6104             }
6105         }
6106     }
6107     ASSERT_UTF8_CACHE(cache);
6108 }
6109
6110 /* We already know all of the way, now we may be able to walk back.  The same
6111    assumption is made as in S_sv_pos_u2b_midway(), namely that walking
6112    backward is half the speed of walking forward. */
6113 static STRLEN
6114 S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target,
6115                     const U8 *end, STRLEN endu)
6116 {
6117     const STRLEN forw = target - s;
6118     STRLEN backw = end - target;
6119
6120     PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY;
6121
6122     if (forw < 2 * backw) {
6123         return utf8_length(s, target);
6124     }
6125
6126     while (end > target) {
6127         end--;
6128         while (UTF8_IS_CONTINUATION(*end)) {
6129             end--;
6130         }
6131         endu--;
6132     }
6133     return endu;
6134 }
6135
6136 /*
6137 =for apidoc sv_pos_b2u
6138
6139 Converts the value pointed to by offsetp from a count of bytes from the
6140 start of the string, to a count of the equivalent number of UTF-8 chars.
6141 Handles magic and type coercion.
6142
6143 =cut
6144 */
6145
6146 /*
6147  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
6148  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
6149  * byte offsets.
6150  *
6151  */
6152 void
6153 Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp)
6154 {
6155     const U8* s;
6156     const STRLEN byte = *offsetp;
6157     STRLEN len = 0; /* Actually always set, but let's keep gcc happy.  */
6158     STRLEN blen;
6159     MAGIC* mg = NULL;
6160     const U8* send;
6161     bool found = FALSE;
6162
6163     PERL_ARGS_ASSERT_SV_POS_B2U;
6164
6165     if (!sv)
6166         return;
6167
6168     s = (const U8*)SvPV_const(sv, blen);
6169
6170     if (blen < byte)
6171         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
6172
6173     send = s + byte;
6174
6175     if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
6176         && (mg = mg_find(sv, PERL_MAGIC_utf8))) {
6177         if (mg->mg_ptr) {
6178             STRLEN * const cache = (STRLEN *) mg->mg_ptr;
6179             if (cache[1] == byte) {
6180                 /* An exact match. */
6181                 *offsetp = cache[0];
6182                 return;
6183             }
6184             if (cache[3] == byte) {
6185                 /* An exact match. */
6186                 *offsetp = cache[2];
6187                 return;
6188             }
6189
6190             if (cache[1] < byte) {
6191                 /* We already know part of the way. */
6192                 if (mg->mg_len != -1) {
6193                     /* Actually, we know the end too.  */
6194                     len = cache[0]
6195                         + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
6196                                               s + blen, mg->mg_len - cache[0]);
6197                 } else {
6198                     len = cache[0] + utf8_length(s + cache[1], send);
6199                 }
6200             }
6201             else if (cache[3] < byte) {
6202                 /* We're between the two cached pairs, so we do the calculation
6203                    offset by the byte/utf-8 positions for the earlier pair,
6204                    then add the utf-8 characters from the string start to
6205                    there.  */
6206                 len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
6207                                           s + cache[1], cache[0] - cache[2])
6208                     + cache[2];
6209
6210             }
6211             else { /* cache[3] > byte */
6212                 len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
6213                                           cache[2]);
6214
6215             }
6216             ASSERT_UTF8_CACHE(cache);
6217             found = TRUE;
6218         } else if (mg->mg_len != -1) {
6219             len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
6220             found = TRUE;
6221         }
6222     }
6223     if (!found || PL_utf8cache < 0) {
6224         const STRLEN real_len = utf8_length(s, send);
6225
6226         if (found && PL_utf8cache < 0) {
6227             if (len != real_len) {
6228                 /* Need to turn the assertions off otherwise we may recurse
6229                    infinitely while printing error messages.  */
6230                 SAVEI8(PL_utf8cache);
6231                 PL_utf8cache = 0;
6232                 Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
6233                            " real %"UVuf" for %"SVf,
6234                            (UV) len, (UV) real_len, SVfARG(sv));
6235             }
6236         }
6237         len = real_len;
6238     }
6239     *offsetp = len;
6240
6241     if (PL_utf8cache)
6242         utf8_mg_pos_cache_update(sv, &mg, byte, len, blen);
6243 }
6244
6245 /*
6246 =for apidoc sv_eq
6247
6248 Returns a boolean indicating whether the strings in the two SVs are
6249 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6250 coerce its args to strings if necessary.
6251
6252 =cut
6253 */
6254
6255 I32
6256 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6257 {
6258     dVAR;
6259     const char *pv1;
6260     STRLEN cur1;
6261     const char *pv2;
6262     STRLEN cur2;
6263     I32  eq     = 0;
6264     char *tpv   = NULL;
6265     SV* svrecode = NULL;
6266
6267     if (!sv1) {
6268         pv1 = "";
6269         cur1 = 0;
6270     }
6271     else {
6272         /* if pv1 and pv2 are the same, second SvPV_const call may
6273          * invalidate pv1, so we may need to make a copy */
6274         if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
6275             pv1 = SvPV_const(sv1, cur1);
6276             sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
6277         }
6278         pv1 = SvPV_const(sv1, cur1);
6279     }
6280
6281     if (!sv2){
6282         pv2 = "";
6283         cur2 = 0;
6284     }
6285     else
6286         pv2 = SvPV_const(sv2, cur2);
6287
6288     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6289         /* Differing utf8ness.
6290          * Do not UTF8size the comparands as a side-effect. */
6291          if (PL_encoding) {
6292               if (SvUTF8(sv1)) {
6293                    svrecode = newSVpvn(pv2, cur2);
6294                    sv_recode_to_utf8(svrecode, PL_encoding);
6295                    pv2 = SvPV_const(svrecode, cur2);
6296               }
6297               else {
6298                    svrecode = newSVpvn(pv1, cur1);
6299                    sv_recode_to_utf8(svrecode, PL_encoding);
6300                    pv1 = SvPV_const(svrecode, cur1);
6301               }
6302               /* Now both are in UTF-8. */
6303               if (cur1 != cur2) {
6304                    SvREFCNT_dec(svrecode);
6305                    return FALSE;
6306               }
6307          }
6308          else {
6309               bool is_utf8 = TRUE;
6310
6311               if (SvUTF8(sv1)) {
6312                    /* sv1 is the UTF-8 one,
6313                     * if is equal it must be downgrade-able */
6314                    char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6315                                                      &cur1, &is_utf8);
6316                    if (pv != pv1)
6317                         pv1 = tpv = pv;
6318               }
6319               else {
6320                    /* sv2 is the UTF-8 one,
6321                     * if is equal it must be downgrade-able */
6322                    char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6323                                                       &cur2, &is_utf8);
6324                    if (pv != pv2)
6325                         pv2 = tpv = pv;
6326               }
6327               if (is_utf8) {
6328                    /* Downgrade not possible - cannot be eq */
6329                    assert (tpv == 0);
6330                    return FALSE;
6331               }
6332          }
6333     }
6334
6335     if (cur1 == cur2)
6336         eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6337         
6338     SvREFCNT_dec(svrecode);
6339     if (tpv)
6340         Safefree(tpv);
6341
6342     return eq;
6343 }
6344
6345 /*
6346 =for apidoc sv_cmp
6347
6348 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
6349 string in C<sv1> is less than, equal to, or greater than the string in
6350 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6351 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
6352
6353 =cut
6354 */
6355
6356 I32
6357 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
6358 {
6359     dVAR;
6360     STRLEN cur1, cur2;
6361     const char *pv1, *pv2;
6362     char *tpv = NULL;
6363     I32  cmp;
6364     SV *svrecode = NULL;
6365
6366     if (!sv1) {
6367         pv1 = "";
6368         cur1 = 0;
6369     }
6370     else
6371         pv1 = SvPV_const(sv1, cur1);
6372
6373     if (!sv2) {
6374         pv2 = "";
6375         cur2 = 0;
6376     }
6377     else
6378         pv2 = SvPV_const(sv2, cur2);
6379
6380     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6381         /* Differing utf8ness.
6382          * Do not UTF8size the comparands as a side-effect. */
6383         if (SvUTF8(sv1)) {
6384             if (PL_encoding) {
6385                  svrecode = newSVpvn(pv2, cur2);
6386                  sv_recode_to_utf8(svrecode, PL_encoding);
6387                  pv2 = SvPV_const(svrecode, cur2);
6388             }
6389             else {
6390                  pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6391             }
6392         }
6393         else {
6394             if (PL_encoding) {
6395                  svrecode = newSVpvn(pv1, cur1);
6396                  sv_recode_to_utf8(svrecode, PL_encoding);
6397                  pv1 = SvPV_const(svrecode, cur1);
6398             }
6399             else {
6400                  pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6401             }
6402         }
6403     }
6404
6405     if (!cur1) {
6406         cmp = cur2 ? -1 : 0;
6407     } else if (!cur2) {
6408         cmp = 1;
6409     } else {
6410         const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6411
6412         if (retval) {
6413             cmp = retval < 0 ? -1 : 1;
6414         } else if (cur1 == cur2) {
6415             cmp = 0;
6416         } else {
6417             cmp = cur1 < cur2 ? -1 : 1;
6418         }
6419     }
6420
6421     SvREFCNT_dec(svrecode);
6422     if (tpv)
6423         Safefree(tpv);
6424
6425     return cmp;
6426 }
6427
6428 /*
6429 =for apidoc sv_cmp_locale
6430
6431 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6432 'use bytes' aware, handles get magic, and will coerce its args to strings
6433 if necessary.  See also C<sv_cmp>.
6434
6435 =cut
6436 */
6437
6438 I32
6439 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
6440 {
6441     dVAR;
6442 #ifdef USE_LOCALE_COLLATE
6443
6444     char *pv1, *pv2;
6445     STRLEN len1, len2;
6446     I32 retval;
6447
6448     if (PL_collation_standard)
6449         goto raw_compare;
6450
6451     len1 = 0;
6452     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6453     len2 = 0;
6454     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6455
6456     if (!pv1 || !len1) {
6457         if (pv2 && len2)
6458             return -1;
6459         else
6460             goto raw_compare;
6461     }
6462     else {
6463         if (!pv2 || !len2)
6464             return 1;
6465     }
6466
6467     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6468
6469     if (retval)
6470         return retval < 0 ? -1 : 1;
6471
6472     /*
6473      * When the result of collation is equality, that doesn't mean
6474      * that there are no differences -- some locales exclude some
6475      * characters from consideration.  So to avoid false equalities,
6476      * we use the raw string as a tiebreaker.
6477      */
6478
6479   raw_compare:
6480     /*FALLTHROUGH*/
6481
6482 #endif /* USE_LOCALE_COLLATE */
6483
6484     return sv_cmp(sv1, sv2);
6485 }
6486
6487
6488 #ifdef USE_LOCALE_COLLATE
6489
6490 /*
6491 =for apidoc sv_collxfrm
6492
6493 Add Collate Transform magic to an SV if it doesn't already have it.
6494
6495 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6496 scalar data of the variable, but transformed to such a format that a normal
6497 memory comparison can be used to compare the data according to the locale
6498 settings.
6499
6500 =cut
6501 */
6502
6503 char *
6504 Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
6505 {
6506     dVAR;
6507     MAGIC *mg;
6508
6509     PERL_ARGS_ASSERT_SV_COLLXFRM;
6510
6511     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6512     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6513         const char *s;
6514         char *xf;
6515         STRLEN len, xlen;
6516
6517         if (mg)
6518             Safefree(mg->mg_ptr);
6519         s = SvPV_const(sv, len);
6520         if ((xf = mem_collxfrm(s, len, &xlen))) {
6521             if (! mg) {
6522 #ifdef PERL_OLD_COPY_ON_WRITE
6523                 if (SvIsCOW(sv))
6524                     sv_force_normal_flags(sv, 0);
6525 #endif
6526                 mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
6527                                  0, 0);
6528                 assert(mg);
6529             }
6530             mg->mg_ptr = xf;
6531             mg->mg_len = xlen;
6532         }
6533         else {
6534             if (mg) {
6535                 mg->mg_ptr = NULL;
6536                 mg->mg_len = -1;
6537             }
6538         }
6539     }
6540     if (mg && mg->mg_ptr) {
6541         *nxp = mg->mg_len;
6542         return mg->mg_ptr + sizeof(PL_collation_ix);
6543     }
6544     else {
6545         *nxp = 0;
6546         return NULL;
6547     }
6548 }
6549
6550 #endif /* USE_LOCALE_COLLATE */
6551
6552 /*
6553 =for apidoc sv_gets
6554
6555 Get a line from the filehandle and store it into the SV, optionally
6556 appending to the currently-stored string.
6557
6558 =cut
6559 */
6560
6561 char *
6562 Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append)
6563 {
6564     dVAR;
6565     const char *rsptr;
6566     STRLEN rslen;
6567     register STDCHAR rslast;
6568     register STDCHAR *bp;
6569     register I32 cnt;
6570     I32 i = 0;
6571     I32 rspara = 0;
6572
6573     PERL_ARGS_ASSERT_SV_GETS;
6574
6575     if (SvTHINKFIRST(sv))
6576         sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6577     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6578        from <>.
6579        However, perlbench says it's slower, because the existing swipe code
6580        is faster than copy on write.
6581        Swings and roundabouts.  */
6582     SvUPGRADE(sv, SVt_PV);
6583
6584     SvSCREAM_off(sv);
6585
6586     if (append) {
6587         if (PerlIO_isutf8(fp)) {
6588             if (!SvUTF8(sv)) {
6589                 sv_utf8_upgrade_nomg(sv);
6590                 sv_pos_u2b(sv,&append,0);
6591             }
6592         } else if (SvUTF8(sv)) {
6593             SV * const tsv = newSV(0);
6594             sv_gets(tsv, fp, 0);
6595             sv_utf8_upgrade_nomg(tsv);
6596             SvCUR_set(sv,append);
6597             sv_catsv(sv,tsv);
6598             sv_free(tsv);
6599             goto return_string_or_null;
6600         }
6601     }
6602
6603     SvPOK_only(sv);
6604     if (PerlIO_isutf8(fp))
6605         SvUTF8_on(sv);
6606
6607     if (IN_PERL_COMPILETIME) {
6608         /* we always read code in line mode */
6609         rsptr = "\n";
6610         rslen = 1;
6611     }
6612     else if (RsSNARF(PL_rs)) {
6613         /* If it is a regular disk file use size from stat() as estimate
6614            of amount we are going to read -- may result in mallocing
6615            more memory than we really need if the layers below reduce
6616            the size we read (e.g. CRLF or a gzip layer).
6617          */
6618         Stat_t st;
6619         if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6620             const Off_t offset = PerlIO_tell(fp);
6621             if (offset != (Off_t) -1 && st.st_size + append > offset) {
6622                 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6623             }
6624         }
6625         rsptr = NULL;
6626         rslen = 0;
6627     }
6628     else if (RsRECORD(PL_rs)) {
6629       I32 bytesread;
6630       char *buffer;
6631       U32 recsize;
6632
6633       /* Grab the size of the record we're getting */
6634       recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
6635       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6636       /* Go yank in */
6637 #ifdef VMS
6638       /* VMS wants read instead of fread, because fread doesn't respect */
6639       /* RMS record boundaries. This is not necessarily a good thing to be */
6640       /* doing, but we've got no other real choice - except avoid stdio
6641          as implementation - perhaps write a :vms layer ?
6642        */
6643       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6644 #else
6645       bytesread = PerlIO_read(fp, buffer, recsize);
6646 #endif
6647       if (bytesread < 0)
6648           bytesread = 0;
6649       SvCUR_set(sv, bytesread += append);
6650       buffer[bytesread] = '\0';
6651       goto return_string_or_null;
6652     }
6653     else if (RsPARA(PL_rs)) {
6654         rsptr = "\n\n";
6655         rslen = 2;
6656         rspara = 1;
6657     }
6658     else {
6659         /* Get $/ i.e. PL_rs into same encoding as stream wants */
6660         if (PerlIO_isutf8(fp)) {
6661             rsptr = SvPVutf8(PL_rs, rslen);
6662         }
6663         else {
6664             if (SvUTF8(PL_rs)) {
6665                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6666                     Perl_croak(aTHX_ "Wide character in $/");
6667                 }
6668             }
6669             rsptr = SvPV_const(PL_rs, rslen);
6670         }
6671     }
6672
6673     rslast = rslen ? rsptr[rslen - 1] : '\0';
6674
6675     if (rspara) {               /* have to do this both before and after */
6676         do {                    /* to make sure file boundaries work right */
6677             if (PerlIO_eof(fp))
6678                 return 0;
6679             i = PerlIO_getc(fp);
6680             if (i != '\n') {
6681                 if (i == -1)
6682                     return 0;
6683                 PerlIO_ungetc(fp,i);
6684                 break;
6685             }
6686         } while (i != EOF);
6687     }
6688
6689     /* See if we know enough about I/O mechanism to cheat it ! */
6690
6691     /* This used to be #ifdef test - it is made run-time test for ease
6692        of abstracting out stdio interface. One call should be cheap
6693        enough here - and may even be a macro allowing compile
6694        time optimization.
6695      */
6696
6697     if (PerlIO_fast_gets(fp)) {
6698
6699     /*
6700      * We're going to steal some values from the stdio struct
6701      * and put EVERYTHING in the innermost loop into registers.
6702      */
6703     register STDCHAR *ptr;
6704     STRLEN bpx;
6705     I32 shortbuffered;
6706
6707 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6708     /* An ungetc()d char is handled separately from the regular
6709      * buffer, so we getc() it back out and stuff it in the buffer.
6710      */
6711     i = PerlIO_getc(fp);
6712     if (i == EOF) return 0;
6713     *(--((*fp)->_ptr)) = (unsigned char) i;
6714     (*fp)->_cnt++;
6715 #endif
6716
6717     /* Here is some breathtakingly efficient cheating */
6718
6719     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
6720     /* make sure we have the room */
6721     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6722         /* Not room for all of it
6723            if we are looking for a separator and room for some
6724          */
6725         if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6726             /* just process what we have room for */
6727             shortbuffered = cnt - SvLEN(sv) + append + 1;
6728             cnt -= shortbuffered;
6729         }
6730         else {
6731             shortbuffered = 0;
6732             /* remember that cnt can be negative */
6733             SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6734         }
6735     }
6736     else
6737         shortbuffered = 0;
6738     bp = (STDCHAR*)SvPVX_const(sv) + append;  /* move these two too to registers */
6739     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6740     DEBUG_P(PerlIO_printf(Perl_debug_log,
6741         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6742     DEBUG_P(PerlIO_printf(Perl_debug_log,
6743         "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6744                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6745                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6746     for (;;) {
6747       screamer:
6748         if (cnt > 0) {
6749             if (rslen) {
6750                 while (cnt > 0) {                    /* this     |  eat */
6751                     cnt--;
6752                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
6753                         goto thats_all_folks;        /* screams  |  sed :-) */
6754                 }
6755             }
6756             else {
6757                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
6758                 bp += cnt;                           /* screams  |  dust */
6759                 ptr += cnt;                          /* louder   |  sed :-) */
6760                 cnt = 0;
6761             }
6762         }
6763         
6764         if (shortbuffered) {            /* oh well, must extend */
6765             cnt = shortbuffered;
6766             shortbuffered = 0;
6767             bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6768             SvCUR_set(sv, bpx);
6769             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6770             bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6771             continue;
6772         }
6773
6774         DEBUG_P(PerlIO_printf(Perl_debug_log,
6775                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6776                               PTR2UV(ptr),(long)cnt));
6777         PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6778 #if 0
6779         DEBUG_P(PerlIO_printf(Perl_debug_log,
6780             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6781             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6782             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6783 #endif
6784         /* This used to call 'filbuf' in stdio form, but as that behaves like
6785            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6786            another abstraction.  */
6787         i   = PerlIO_getc(fp);          /* get more characters */
6788 #if 0
6789         DEBUG_P(PerlIO_printf(Perl_debug_log,
6790             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6791             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6792             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6793 #endif
6794         cnt = PerlIO_get_cnt(fp);
6795         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
6796         DEBUG_P(PerlIO_printf(Perl_debug_log,
6797             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6798
6799         if (i == EOF)                   /* all done for ever? */
6800             goto thats_really_all_folks;
6801
6802         bpx = bp - (STDCHAR*)SvPVX_const(sv);   /* box up before relocation */
6803         SvCUR_set(sv, bpx);
6804         SvGROW(sv, bpx + cnt + 2);
6805         bp = (STDCHAR*)SvPVX_const(sv) + bpx;   /* unbox after relocation */
6806
6807         *bp++ = (STDCHAR)i;             /* store character from PerlIO_getc */
6808
6809         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
6810             goto thats_all_folks;
6811     }
6812
6813 thats_all_folks:
6814     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6815           memNE((char*)bp - rslen, rsptr, rslen))
6816         goto screamer;                          /* go back to the fray */
6817 thats_really_all_folks:
6818     if (shortbuffered)
6819         cnt += shortbuffered;
6820         DEBUG_P(PerlIO_printf(Perl_debug_log,
6821             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6822     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);  /* put these back or we're in trouble */
6823     DEBUG_P(PerlIO_printf(Perl_debug_log,
6824         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6825         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6826         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6827     *bp = '\0';
6828     SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv));      /* set length */
6829     DEBUG_P(PerlIO_printf(Perl_debug_log,
6830         "Screamer: done, len=%ld, string=|%.*s|\n",
6831         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6832     }
6833    else
6834     {
6835        /*The big, slow, and stupid way. */
6836 #ifdef USE_HEAP_INSTEAD_OF_STACK        /* Even slower way. */
6837         STDCHAR *buf = NULL;
6838         Newx(buf, 8192, STDCHAR);
6839         assert(buf);
6840 #else
6841         STDCHAR buf[8192];
6842 #endif
6843
6844 screamer2:
6845         if (rslen) {
6846             register const STDCHAR * const bpe = buf + sizeof(buf);
6847             bp = buf;
6848             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6849                 ; /* keep reading */
6850             cnt = bp - buf;
6851         }
6852         else {
6853             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6854             /* Accomodate broken VAXC compiler, which applies U8 cast to
6855              * both args of ?: operator, causing EOF to change into 255
6856              */
6857             if (cnt > 0)
6858                  i = (U8)buf[cnt - 1];
6859             else
6860                  i = EOF;
6861         }
6862
6863         if (cnt < 0)
6864             cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
6865         if (append)
6866              sv_catpvn(sv, (char *) buf, cnt);
6867         else
6868              sv_setpvn(sv, (char *) buf, cnt);
6869
6870         if (i != EOF &&                 /* joy */
6871             (!rslen ||
6872              SvCUR(sv) < rslen ||
6873              memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6874         {
6875             append = -1;
6876             /*
6877              * If we're reading from a TTY and we get a short read,
6878              * indicating that the user hit his EOF character, we need
6879              * to notice it now, because if we try to read from the TTY
6880              * again, the EOF condition will disappear.
6881              *
6882              * The comparison of cnt to sizeof(buf) is an optimization
6883              * that prevents unnecessary calls to feof().
6884              *
6885              * - jik 9/25/96
6886              */
6887             if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
6888                 goto screamer2;
6889         }
6890
6891 #ifdef USE_HEAP_INSTEAD_OF_STACK
6892         Safefree(buf);
6893 #endif
6894     }
6895
6896     if (rspara) {               /* have to do this both before and after */
6897         while (i != EOF) {      /* to make sure file boundaries work right */
6898             i = PerlIO_getc(fp);
6899             if (i != '\n') {
6900                 PerlIO_ungetc(fp,i);
6901                 break;
6902             }
6903         }
6904     }
6905
6906 return_string_or_null:
6907     return (SvCUR(sv) - append) ? SvPVX(sv) : NULL;
6908 }
6909
6910 /*
6911 =for apidoc sv_inc
6912
6913 Auto-increment of the value in the SV, doing string to numeric conversion
6914 if necessary. Handles 'get' magic.
6915
6916 =cut
6917 */
6918
6919 void
6920 Perl_sv_inc(pTHX_ register SV *const sv)
6921 {
6922     dVAR;
6923     register char *d;
6924     int flags;
6925
6926     if (!sv)
6927         return;
6928     SvGETMAGIC(sv);
6929     if (SvTHINKFIRST(sv)) {
6930         if (SvIsCOW(sv))
6931             sv_force_normal_flags(sv, 0);
6932         if (SvREADONLY(sv)) {
6933             if (IN_PERL_RUNTIME)
6934                 Perl_croak(aTHX_ PL_no_modify);
6935         }
6936         if (SvROK(sv)) {
6937             IV i;
6938             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6939                 return;
6940             i = PTR2IV(SvRV(sv));
6941             sv_unref(sv);
6942             sv_setiv(sv, i);
6943         }
6944     }
6945     flags = SvFLAGS(sv);
6946     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6947         /* It's (privately or publicly) a float, but not tested as an
6948            integer, so test it to see. */
6949         (void) SvIV(sv);
6950         flags = SvFLAGS(sv);
6951     }
6952     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6953         /* It's publicly an integer, or privately an integer-not-float */
6954 #ifdef PERL_PRESERVE_IVUV
6955       oops_its_int:
6956 #endif
6957         if (SvIsUV(sv)) {
6958             if (SvUVX(sv) == UV_MAX)
6959                 sv_setnv(sv, UV_MAX_P1);
6960             else
6961                 (void)SvIOK_only_UV(sv);
6962                 SvUV_set(sv, SvUVX(sv) + 1);
6963         } else {
6964             if (SvIVX(sv) == IV_MAX)
6965                 sv_setuv(sv, (UV)IV_MAX + 1);
6966             else {
6967                 (void)SvIOK_only(sv);
6968                 SvIV_set(sv, SvIVX(sv) + 1);
6969             }   
6970         }
6971         return;
6972     }
6973     if (flags & SVp_NOK) {
6974         const NV was = SvNVX(sv);
6975         if (NV_OVERFLOWS_INTEGERS_AT &&
6976             was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
6977             Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
6978                         "Lost precision when incrementing %" NVff " by 1",
6979                         was);
6980         }
6981         (void)SvNOK_only(sv);
6982         SvNV_set(sv, was + 1.0);
6983         return;
6984     }
6985
6986     if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6987         if ((flags & SVTYPEMASK) < SVt_PVIV)
6988             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6989         (void)SvIOK_only(sv);
6990         SvIV_set(sv, 1);
6991         return;
6992     }
6993     d = SvPVX(sv);
6994     while (isALPHA(*d)) d++;
6995     while (isDIGIT(*d)) d++;
6996     if (*d) {
6997 #ifdef PERL_PRESERVE_IVUV
6998         /* Got to punt this as an integer if needs be, but we don't issue
6999            warnings. Probably ought to make the sv_iv_please() that does
7000            the conversion if possible, and silently.  */
7001         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7002         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7003             /* Need to try really hard to see if it's an integer.
7004                9.22337203685478e+18 is an integer.
7005                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7006                so $a="9.22337203685478e+18"; $a+0; $a++
7007                needs to be the same as $a="9.22337203685478e+18"; $a++
7008                or we go insane. */
7009         
7010             (void) sv_2iv(sv);
7011             if (SvIOK(sv))
7012                 goto oops_its_int;
7013
7014             /* sv_2iv *should* have made this an NV */
7015             if (flags & SVp_NOK) {
7016                 (void)SvNOK_only(sv);
7017                 SvNV_set(sv, SvNVX(sv) + 1.0);
7018                 return;
7019             }
7020             /* I don't think we can get here. Maybe I should assert this
7021                And if we do get here I suspect that sv_setnv will croak. NWC
7022                Fall through. */
7023 #if defined(USE_LONG_DOUBLE)
7024             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
7025                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7026 #else
7027             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7028                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7029 #endif
7030         }
7031 #endif /* PERL_PRESERVE_IVUV */
7032         sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
7033         return;
7034     }
7035     d--;
7036     while (d >= SvPVX_const(sv)) {
7037         if (isDIGIT(*d)) {
7038             if (++*d <= '9')
7039                 return;
7040             *(d--) = '0';
7041         }
7042         else {
7043 #ifdef EBCDIC
7044             /* MKS: The original code here died if letters weren't consecutive.
7045              * at least it didn't have to worry about non-C locales.  The
7046              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
7047              * arranged in order (although not consecutively) and that only
7048              * [A-Za-z] are accepted by isALPHA in the C locale.
7049              */
7050             if (*d != 'z' && *d != 'Z') {
7051                 do { ++*d; } while (!isALPHA(*d));
7052                 return;
7053             }
7054             *(d--) -= 'z' - 'a';
7055 #else
7056             ++*d;
7057             if (isALPHA(*d))
7058                 return;
7059             *(d--) -= 'z' - 'a' + 1;
7060 #endif
7061         }
7062     }
7063     /* oh,oh, the number grew */
7064     SvGROW(sv, SvCUR(sv) + 2);
7065     SvCUR_set(sv, SvCUR(sv) + 1);
7066     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
7067         *d = d[-1];
7068     if (isDIGIT(d[1]))
7069         *d = '1';
7070     else
7071         *d = d[1];
7072 }
7073
7074 /*
7075 =for apidoc sv_dec
7076
7077 Auto-decrement of the value in the SV, doing string to numeric conversion
7078 if necessary. Handles 'get' magic.
7079
7080 =cut
7081 */
7082
7083 void
7084 Perl_sv_dec(pTHX_ register SV *const sv)
7085 {
7086     dVAR;
7087     int flags;
7088
7089     if (!sv)
7090         return;
7091     SvGETMAGIC(sv);
7092     if (SvTHINKFIRST(sv)) {
7093         if (SvIsCOW(sv))
7094             sv_force_normal_flags(sv, 0);
7095         if (SvREADONLY(sv)) {
7096             if (IN_PERL_RUNTIME)
7097                 Perl_croak(aTHX_ PL_no_modify);
7098         }
7099         if (SvROK(sv)) {
7100             IV i;
7101             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
7102                 return;
7103             i = PTR2IV(SvRV(sv));
7104             sv_unref(sv);
7105             sv_setiv(sv, i);
7106         }
7107     }
7108     /* Unlike sv_inc we don't have to worry about string-never-numbers
7109        and keeping them magic. But we mustn't warn on punting */
7110     flags = SvFLAGS(sv);
7111     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
7112         /* It's publicly an integer, or privately an integer-not-float */
7113 #ifdef PERL_PRESERVE_IVUV
7114       oops_its_int:
7115 #endif
7116         if (SvIsUV(sv)) {
7117             if (SvUVX(sv) == 0) {
7118                 (void)SvIOK_only(sv);
7119                 SvIV_set(sv, -1);
7120             }
7121             else {
7122                 (void)SvIOK_only_UV(sv);
7123                 SvUV_set(sv, SvUVX(sv) - 1);
7124             }   
7125         } else {
7126             if (SvIVX(sv) == IV_MIN) {
7127                 sv_setnv(sv, (NV)IV_MIN);
7128                 goto oops_its_num;
7129             }
7130             else {
7131                 (void)SvIOK_only(sv);
7132                 SvIV_set(sv, SvIVX(sv) - 1);
7133             }   
7134         }
7135         return;
7136     }
7137     if (flags & SVp_NOK) {
7138     oops_its_num:
7139         {
7140             const NV was = SvNVX(sv);
7141             if (NV_OVERFLOWS_INTEGERS_AT &&
7142                 was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) {
7143                 Perl_warner(aTHX_ packWARN(WARN_IMPRECISION),
7144                             "Lost precision when decrementing %" NVff " by 1",
7145                             was);
7146             }
7147             (void)SvNOK_only(sv);
7148             SvNV_set(sv, was - 1.0);
7149             return;
7150         }
7151     }
7152     if (!(flags & SVp_POK)) {
7153         if ((flags & SVTYPEMASK) < SVt_PVIV)
7154             sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
7155         SvIV_set(sv, -1);
7156         (void)SvIOK_only(sv);
7157         return;
7158     }
7159 #ifdef PERL_PRESERVE_IVUV
7160     {
7161         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
7162         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
7163             /* Need to try really hard to see if it's an integer.
7164                9.22337203685478e+18 is an integer.
7165                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
7166                so $a="9.22337203685478e+18"; $a+0; $a--
7167                needs to be the same as $a="9.22337203685478e+18"; $a--
7168                or we go insane. */
7169         
7170             (void) sv_2iv(sv);
7171             if (SvIOK(sv))
7172                 goto oops_its_int;
7173
7174             /* sv_2iv *should* have made this an NV */
7175             if (flags & SVp_NOK) {
7176                 (void)SvNOK_only(sv);
7177                 SvNV_set(sv, SvNVX(sv) - 1.0);
7178                 return;
7179             }
7180             /* I don't think we can get here. Maybe I should assert this
7181                And if we do get here I suspect that sv_setnv will croak. NWC
7182                Fall through. */
7183 #if defined(USE_LONG_DOUBLE)
7184             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
7185                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7186 #else
7187             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
7188                                   SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
7189 #endif
7190         }
7191     }
7192 #endif /* PERL_PRESERVE_IVUV */
7193     sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0);   /* punt */
7194 }
7195
7196 /*
7197 =for apidoc sv_mortalcopy
7198
7199 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
7200 The new SV is marked as mortal. It will be destroyed "soon", either by an
7201 explicit call to FREETMPS, or by an implicit call at places such as
7202 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
7203
7204 =cut
7205 */
7206
7207 /* Make a string that will exist for the duration of the expression
7208  * evaluation.  Actually, it may have to last longer than that, but
7209  * hopefully we won't free it until it has been assigned to a
7210  * permanent location. */
7211
7212 SV *
7213 Perl_sv_mortalcopy(pTHX_ SV *const oldstr)
7214 {
7215     dVAR;
7216     register SV *sv;
7217
7218     new_SV(sv);
7219     sv_setsv(sv,oldstr);
7220     EXTEND_MORTAL(1);
7221     PL_tmps_stack[++PL_tmps_ix] = sv;
7222     SvTEMP_on(sv);
7223     return sv;
7224 }
7225
7226 /*
7227 =for apidoc sv_newmortal
7228
7229 Creates a new null SV which is mortal.  The reference count of the SV is
7230 set to 1. It will be destroyed "soon", either by an explicit call to
7231 FREETMPS, or by an implicit call at places such as statement boundaries.
7232 See also C<sv_mortalcopy> and C<sv_2mortal>.
7233
7234 =cut
7235 */
7236
7237 SV *
7238 Perl_sv_newmortal(pTHX)
7239 {
7240     dVAR;
7241     register SV *sv;
7242
7243     new_SV(sv);
7244     SvFLAGS(sv) = SVs_TEMP;
7245     EXTEND_MORTAL(1);
7246     PL_tmps_stack[++PL_tmps_ix] = sv;
7247     return sv;
7248 }
7249
7250
7251 /*
7252 =for apidoc newSVpvn_flags
7253
7254 Creates a new SV and copies a string into it.  The reference count for the
7255 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7256 string.  You are responsible for ensuring that the source string is at least
7257 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7258 Currently the only flag bits accepted are C<SVf_UTF8> and C<SVs_TEMP>.
7259 If C<SVs_TEMP> is set, then C<sv2mortal()> is called on the result before
7260 returning. If C<SVf_UTF8> is set, then it will be set on the new SV.
7261 C<newSVpvn_utf8()> is a convenience wrapper for this function, defined as
7262
7263     #define newSVpvn_utf8(s, len, u)                    \
7264         newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
7265
7266 =cut
7267 */
7268
7269 SV *
7270 Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
7271 {
7272     dVAR;
7273     register SV *sv;
7274
7275     /* All the flags we don't support must be zero.
7276        And we're new code so I'm going to assert this from the start.  */
7277     assert(!(flags & ~(SVf_UTF8|SVs_TEMP)));
7278     new_SV(sv);
7279     sv_setpvn(sv,s,len);
7280     SvFLAGS(sv) |= (flags & SVf_UTF8);
7281     return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
7282 }
7283
7284 /*
7285 =for apidoc sv_2mortal
7286
7287 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
7288 by an explicit call to FREETMPS, or by an implicit call at places such as
7289 statement boundaries.  SvTEMP() is turned on which means that the SV's
7290 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
7291 and C<sv_mortalcopy>.
7292
7293 =cut
7294 */
7295
7296 SV *
7297 Perl_sv_2mortal(pTHX_ register SV *const sv)
7298 {
7299     dVAR;
7300     if (!sv)
7301         return NULL;
7302     if (SvREADONLY(sv) && SvIMMORTAL(sv))
7303         return sv;
7304     EXTEND_MORTAL(1);
7305     PL_tmps_stack[++PL_tmps_ix] = sv;
7306     SvTEMP_on(sv);
7307     return sv;
7308 }
7309
7310 /*
7311 =for apidoc newSVpv
7312
7313 Creates a new SV and copies a string into it.  The reference count for the
7314 SV is set to 1.  If C<len> is zero, Perl will compute the length using
7315 strlen().  For efficiency, consider using C<newSVpvn> instead.
7316
7317 =cut
7318 */
7319
7320 SV *
7321 Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
7322 {
7323     dVAR;
7324     register SV *sv;
7325
7326     new_SV(sv);
7327     sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
7328     return sv;
7329 }
7330
7331 /*
7332 =for apidoc newSVpvn
7333
7334 Creates a new SV and copies a string into it.  The reference count for the
7335 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
7336 string.  You are responsible for ensuring that the source string is at least
7337 C<len> bytes long.  If the C<s> argument is NULL the new SV will be undefined.
7338
7339 =cut
7340 */
7341
7342 SV *
7343 Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len)
7344 {
7345     dVAR;
7346     register SV *sv;
7347
7348     new_SV(sv);
7349     sv_setpvn(sv,s,len);
7350     return sv;
7351 }
7352
7353 /*
7354 =for apidoc newSVhek
7355
7356 Creates a new SV from the hash key structure.  It will generate scalars that
7357 point to the shared string table where possible. Returns a new (undefined)
7358 SV if the hek is NULL.
7359
7360 =cut
7361 */
7362
7363 SV *
7364 Perl_newSVhek(pTHX_ const HEK *const hek)
7365 {
7366     dVAR;
7367     if (!hek) {
7368         SV *sv;
7369
7370         new_SV(sv);
7371         return sv;
7372     }
7373
7374     if (HEK_LEN(hek) == HEf_SVKEY) {
7375         return newSVsv(*(SV**)HEK_KEY(hek));
7376     } else {
7377         const int flags = HEK_FLAGS(hek);
7378         if (flags & HVhek_WASUTF8) {
7379             /* Trouble :-)
7380                Andreas would like keys he put in as utf8 to come back as utf8
7381             */
7382             STRLEN utf8_len = HEK_LEN(hek);
7383             const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7384             SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7385
7386             SvUTF8_on (sv);
7387             Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7388             return sv;
7389         } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
7390             /* We don't have a pointer to the hv, so we have to replicate the
7391                flag into every HEK. This hv is using custom a hasing
7392                algorithm. Hence we can't return a shared string scalar, as
7393                that would contain the (wrong) hash value, and might get passed
7394                into an hv routine with a regular hash.
7395                Similarly, a hash that isn't using shared hash keys has to have
7396                the flag in every key so that we know not to try to call
7397                share_hek_kek on it.  */
7398
7399             SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7400             if (HEK_UTF8(hek))
7401                 SvUTF8_on (sv);
7402             return sv;
7403         }
7404         /* This will be overwhelminly the most common case.  */
7405         {
7406             /* Inline most of newSVpvn_share(), because share_hek_hek() is far
7407                more efficient than sharepvn().  */
7408             SV *sv;
7409
7410             new_SV(sv);
7411             sv_upgrade(sv, SVt_PV);
7412             SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
7413             SvCUR_set(sv, HEK_LEN(hek));
7414             SvLEN_set(sv, 0);
7415             SvREADONLY_on(sv);
7416             SvFAKE_on(sv);
7417             SvPOK_on(sv);
7418             if (HEK_UTF8(hek))
7419                 SvUTF8_on(sv);
7420             return sv;
7421         }
7422     }
7423 }
7424
7425 /*
7426 =for apidoc newSVpvn_share
7427
7428 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7429 table. If the string does not already exist in the table, it is created
7430 first.  Turns on READONLY and FAKE. If the C<hash> parameter is non-zero, that
7431 value is used; otherwise the hash is computed. The string's hash can be later
7432 be retrieved from the SV with the C<SvSHARED_HASH()> macro. The idea here is
7433 that as the string table is used for shared hash keys these strings will have
7434 SvPVX_const == HeKEY and hash lookup will avoid string compare.
7435
7436 =cut
7437 */
7438
7439 SV *
7440 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7441 {
7442     dVAR;
7443     register SV *sv;
7444     bool is_utf8 = FALSE;
7445     const char *const orig_src = src;
7446
7447     if (len < 0) {
7448         STRLEN tmplen = -len;
7449         is_utf8 = TRUE;
7450         /* See the note in hv.c:hv_fetch() --jhi */
7451         src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7452         len = tmplen;
7453     }
7454     if (!hash)
7455         PERL_HASH(hash, src, len);
7456     new_SV(sv);
7457     sv_upgrade(sv, SVt_PV);
7458     SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7459     SvCUR_set(sv, len);
7460     SvLEN_set(sv, 0);
7461     SvREADONLY_on(sv);
7462     SvFAKE_on(sv);
7463     SvPOK_on(sv);
7464     if (is_utf8)
7465         SvUTF8_on(sv);
7466     if (src != orig_src)
7467         Safefree(src);
7468     return sv;
7469 }
7470
7471
7472 #if defined(PERL_IMPLICIT_CONTEXT)
7473
7474 /* pTHX_ magic can't cope with varargs, so this is a no-context
7475  * version of the main function, (which may itself be aliased to us).
7476  * Don't access this version directly.
7477  */
7478
7479 SV *
7480 Perl_newSVpvf_nocontext(const char *const pat, ...)
7481 {
7482     dTHX;
7483     register SV *sv;
7484     va_list args;
7485
7486     PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT;
7487
7488     va_start(args, pat);
7489     sv = vnewSVpvf(pat, &args);
7490     va_end(args);
7491     return sv;
7492 }
7493 #endif
7494
7495 /*
7496 =for apidoc newSVpvf
7497
7498 Creates a new SV and initializes it with the string formatted like
7499 C<sprintf>.
7500
7501 =cut
7502 */
7503
7504 SV *
7505 Perl_newSVpvf(pTHX_ const char *const pat, ...)
7506 {
7507     register SV *sv;
7508     va_list args;
7509
7510     PERL_ARGS_ASSERT_NEWSVPVF;
7511
7512     va_start(args, pat);
7513     sv = vnewSVpvf(pat, &args);
7514     va_end(args);
7515     return sv;
7516 }
7517
7518 /* backend for newSVpvf() and newSVpvf_nocontext() */
7519
7520 SV *
7521 Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
7522 {
7523     dVAR;
7524     register SV *sv;
7525
7526     PERL_ARGS_ASSERT_VNEWSVPVF;
7527
7528     new_SV(sv);
7529     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
7530     return sv;
7531 }
7532
7533 /*
7534 =for apidoc newSVnv
7535
7536 Creates a new SV and copies a floating point value into it.
7537 The reference count for the SV is set to 1.
7538
7539 =cut
7540 */
7541
7542 SV *
7543 Perl_newSVnv(pTHX_ const NV n)
7544 {
7545     dVAR;
7546     register SV *sv;
7547
7548     new_SV(sv);
7549     sv_setnv(sv,n);
7550     return sv;
7551 }
7552
7553 /*
7554 =for apidoc newSViv
7555
7556 Creates a new SV and copies an integer into it.  The reference count for the
7557 SV is set to 1.
7558
7559 =cut
7560 */
7561
7562 SV *
7563 Perl_newSViv(pTHX_ const IV i)
7564 {
7565     dVAR;
7566     register SV *sv;
7567
7568     new_SV(sv);
7569     sv_setiv(sv,i);
7570     return sv;
7571 }
7572
7573 /*
7574 =for apidoc newSVuv
7575
7576 Creates a new SV and copies an unsigned integer into it.
7577 The reference count for the SV is set to 1.
7578
7579 =cut
7580 */
7581
7582 SV *
7583 Perl_newSVuv(pTHX_ const UV u)
7584 {
7585     dVAR;
7586     register SV *sv;
7587
7588     new_SV(sv);
7589     sv_setuv(sv,u);
7590     return sv;
7591 }
7592
7593 /*
7594 =for apidoc newSV_type
7595
7596 Creates a new SV, of the type specified.  The reference count for the new SV
7597 is set to 1.
7598
7599 =cut
7600 */
7601
7602 SV *
7603 Perl_newSV_type(pTHX_ const svtype type)
7604 {
7605     register SV *sv;
7606
7607     new_SV(sv);
7608     sv_upgrade(sv, type);
7609     return sv;
7610 }
7611
7612 /*
7613 =for apidoc newRV_noinc
7614
7615 Creates an RV wrapper for an SV.  The reference count for the original
7616 SV is B<not> incremented.
7617
7618 =cut
7619 */
7620
7621 SV *
7622 Perl_newRV_noinc(pTHX_ SV *const tmpRef)
7623 {
7624     dVAR;
7625     register SV *sv = newSV_type(SVt_IV);
7626
7627     PERL_ARGS_ASSERT_NEWRV_NOINC;
7628
7629     SvTEMP_off(tmpRef);
7630     SvRV_set(sv, tmpRef);
7631     SvROK_on(sv);
7632     return sv;
7633 }
7634
7635 /* newRV_inc is the official function name to use now.
7636  * newRV_inc is in fact #defined to newRV in sv.h
7637  */
7638
7639 SV *
7640 Perl_newRV(pTHX_ SV *const sv)
7641 {
7642     dVAR;
7643
7644     PERL_ARGS_ASSERT_NEWRV;
7645
7646     return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
7647 }
7648
7649 /*
7650 =for apidoc newSVsv
7651
7652 Creates a new SV which is an exact duplicate of the original SV.
7653 (Uses C<sv_setsv>).
7654
7655 =cut
7656 */
7657
7658 SV *
7659 Perl_newSVsv(pTHX_ register SV *const old)
7660 {
7661     dVAR;
7662     register SV *sv;
7663
7664     if (!old)
7665         return NULL;
7666     if (SvTYPE(old) == SVTYPEMASK) {
7667         if (ckWARN_d(WARN_INTERNAL))
7668             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7669         return NULL;
7670     }
7671     new_SV(sv);
7672     /* SV_GMAGIC is the default for sv_setv()
7673        SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7674        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
7675     sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7676     return sv;
7677 }
7678
7679 /*
7680 =for apidoc sv_reset
7681
7682 Underlying implementation for the C<reset> Perl function.
7683 Note that the perl-level function is vaguely deprecated.
7684
7685 =cut
7686 */
7687
7688 void
7689 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
7690 {
7691     dVAR;
7692     char todo[PERL_UCHAR_MAX+1];
7693
7694     PERL_ARGS_ASSERT_SV_RESET;
7695
7696     if (!stash)
7697         return;
7698
7699     if (!*s) {          /* reset ?? searches */
7700         MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7701         if (mg) {
7702             const U32 count = mg->mg_len / sizeof(PMOP**);
7703             PMOP **pmp = (PMOP**) mg->mg_ptr;
7704             PMOP *const *const end = pmp + count;
7705
7706             while (pmp < end) {
7707 #ifdef USE_ITHREADS
7708                 SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]);
7709 #else
7710                 (*pmp)->op_pmflags &= ~PMf_USED;
7711 #endif
7712                 ++pmp;
7713             }
7714         }
7715         return;
7716     }
7717
7718     /* reset variables */
7719
7720     if (!HvARRAY(stash))
7721         return;
7722
7723     Zero(todo, 256, char);
7724     while (*s) {
7725         I32 max;
7726         I32 i = (unsigned char)*s;
7727         if (s[1] == '-') {
7728             s += 2;
7729         }
7730         max = (unsigned char)*s++;
7731         for ( ; i <= max; i++) {
7732             todo[i] = 1;
7733         }
7734         for (i = 0; i <= (I32) HvMAX(stash); i++) {
7735             HE *entry;
7736             for (entry = HvARRAY(stash)[i];
7737                  entry;
7738                  entry = HeNEXT(entry))
7739             {
7740                 register GV *gv;
7741                 register SV *sv;
7742
7743                 if (!todo[(U8)*HeKEY(entry)])
7744                     continue;
7745                 gv = (GV*)HeVAL(entry);
7746                 sv = GvSV(gv);
7747                 if (sv) {
7748                     if (SvTHINKFIRST(sv)) {
7749                         if (!SvREADONLY(sv) && SvROK(sv))
7750                             sv_unref(sv);
7751                         /* XXX Is this continue a bug? Why should THINKFIRST
7752                            exempt us from resetting arrays and hashes?  */
7753                         continue;
7754                     }
7755                     SvOK_off(sv);
7756                     if (SvTYPE(sv) >= SVt_PV) {
7757                         SvCUR_set(sv, 0);
7758                         if (SvPVX_const(sv) != NULL)
7759                             *SvPVX(sv) = '\0';
7760                         SvTAINT(sv);
7761                     }
7762                 }
7763                 if (GvAV(gv)) {
7764                     av_clear(GvAV(gv));
7765                 }
7766                 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7767 #if defined(VMS)
7768                     Perl_die(aTHX_ "Can't reset %%ENV on this system");
7769 #else /* ! VMS */
7770                     hv_clear(GvHV(gv));
7771 #  if defined(USE_ENVIRON_ARRAY)
7772                     if (gv == PL_envgv)
7773                         my_clearenv();
7774 #  endif /* USE_ENVIRON_ARRAY */
7775 #endif /* VMS */
7776                 }
7777             }
7778         }
7779     }
7780 }
7781
7782 /*
7783 =for apidoc sv_2io
7784
7785 Using various gambits, try to get an IO from an SV: the IO slot if its a
7786 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7787 named after the PV if we're a string.
7788
7789 =cut
7790 */
7791
7792 IO*
7793 Perl_sv_2io(pTHX_ SV *const sv)
7794 {
7795     IO* io;
7796     GV* gv;
7797
7798     PERL_ARGS_ASSERT_SV_2IO;
7799
7800     switch (SvTYPE(sv)) {
7801     case SVt_PVIO:
7802         io = (IO*)sv;
7803         break;
7804     case SVt_PVGV:
7805         gv = (GV*)sv;
7806         io = GvIO(gv);
7807         if (!io)
7808             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7809         break;
7810     default:
7811         if (!SvOK(sv))
7812             Perl_croak(aTHX_ PL_no_usym, "filehandle");
7813         if (SvROK(sv))
7814             return sv_2io(SvRV(sv));
7815         gv = gv_fetchsv(sv, 0, SVt_PVIO);
7816         if (gv)
7817             io = GvIO(gv);
7818         else
7819             io = 0;
7820         if (!io)
7821             Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(sv));
7822         break;
7823     }
7824     return io;
7825 }
7826
7827 /*
7828 =for apidoc sv_2cv
7829
7830 Using various gambits, try to get a CV from an SV; in addition, try if
7831 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7832 The flags in C<lref> are passed to sv_fetchsv.
7833
7834 =cut
7835 */
7836
7837 CV *
7838 Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
7839 {
7840     dVAR;
7841     GV *gv = NULL;
7842     CV *cv = NULL;
7843
7844     PERL_ARGS_ASSERT_SV_2CV;
7845
7846     if (!sv) {
7847         *st = NULL;
7848         *gvp = NULL;
7849         return NULL;
7850     }
7851     switch (SvTYPE(sv)) {
7852     case SVt_PVCV:
7853         *st = CvSTASH(sv);
7854         *gvp = NULL;
7855         return (CV*)sv;
7856     case SVt_PVHV:
7857     case SVt_PVAV:
7858         *st = NULL;
7859         *gvp = NULL;
7860         return NULL;
7861     case SVt_PVGV:
7862         gv = (GV*)sv;
7863         *gvp = gv;
7864         *st = GvESTASH(gv);
7865         goto fix_gv;
7866
7867     default:
7868         SvGETMAGIC(sv);
7869         if (SvROK(sv)) {
7870             SV * const *sp = &sv;       /* Used in tryAMAGICunDEREF macro. */
7871             tryAMAGICunDEREF(to_cv);
7872
7873             sv = SvRV(sv);
7874             if (SvTYPE(sv) == SVt_PVCV) {
7875                 cv = (CV*)sv;
7876                 *gvp = NULL;
7877                 *st = CvSTASH(cv);
7878                 return cv;
7879             }
7880             else if(isGV(sv))
7881                 gv = (GV*)sv;
7882             else
7883                 Perl_croak(aTHX_ "Not a subroutine reference");
7884         }
7885         else if (isGV(sv))
7886             gv = (GV*)sv;
7887         else
7888             gv = gv_fetchsv(sv, lref, SVt_PVCV);
7889         *gvp = gv;
7890         if (!gv) {
7891             *st = NULL;
7892             return NULL;
7893         }
7894         /* Some flags to gv_fetchsv mean don't really create the GV  */
7895         if (SvTYPE(gv) != SVt_PVGV) {
7896             *st = NULL;
7897             return NULL;
7898         }
7899         *st = GvESTASH(gv);
7900     fix_gv:
7901         if (lref && !GvCVu(gv)) {
7902             SV *tmpsv;
7903             ENTER;
7904             tmpsv = newSV(0);
7905             gv_efullname3(tmpsv, gv, NULL);
7906             /* XXX this is probably not what they think they're getting.
7907              * It has the same effect as "sub name;", i.e. just a forward
7908              * declaration! */
7909             newSUB(start_subparse(FALSE, 0),
7910                    newSVOP(OP_CONST, 0, tmpsv),
7911                    NULL, NULL);
7912             LEAVE;
7913             if (!GvCVu(gv))
7914                 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7915                            SVfARG(SvOK(sv) ? sv : &PL_sv_no));
7916         }
7917         return GvCVu(gv);
7918     }
7919 }
7920
7921 /*
7922 =for apidoc sv_true
7923
7924 Returns true if the SV has a true value by Perl's rules.
7925 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7926 instead use an in-line version.
7927
7928 =cut
7929 */
7930
7931 I32
7932 Perl_sv_true(pTHX_ register SV *const sv)
7933 {
7934     if (!sv)
7935         return 0;
7936     if (SvPOK(sv)) {
7937         register const XPV* const tXpv = (XPV*)SvANY(sv);
7938         if (tXpv &&
7939                 (tXpv->xpv_cur > 1 ||
7940                 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7941             return 1;
7942         else
7943             return 0;
7944     }
7945     else {
7946         if (SvIOK(sv))
7947             return SvIVX(sv) != 0;
7948         else {
7949             if (SvNOK(sv))
7950                 return SvNVX(sv) != 0.0;
7951             else
7952                 return sv_2bool(sv);
7953         }
7954     }
7955 }
7956
7957 /*
7958 =for apidoc sv_pvn_force
7959
7960 Get a sensible string out of the SV somehow.
7961 A private implementation of the C<SvPV_force> macro for compilers which
7962 can't cope with complex macro expressions. Always use the macro instead.
7963
7964 =for apidoc sv_pvn_force_flags
7965
7966 Get a sensible string out of the SV somehow.
7967 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7968 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7969 implemented in terms of this function.
7970 You normally want to use the various wrapper macros instead: see
7971 C<SvPV_force> and C<SvPV_force_nomg>
7972
7973 =cut
7974 */
7975
7976 char *
7977 Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
7978 {
7979     dVAR;
7980
7981     PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
7982
7983     if (SvTHINKFIRST(sv) && !SvROK(sv))
7984         sv_force_normal_flags(sv, 0);
7985
7986     if (SvPOK(sv)) {
7987         if (lp)
7988             *lp = SvCUR(sv);
7989     }
7990     else {
7991         char *s;
7992         STRLEN len;
7993  
7994         if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7995             const char * const ref = sv_reftype(sv,0);
7996             if (PL_op)
7997                 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7998                            ref, OP_NAME(PL_op));
7999             else
8000                 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
8001         }
8002         if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
8003             || isGV_with_GP(sv))
8004             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
8005                 OP_NAME(PL_op));
8006         s = sv_2pv_flags(sv, &len, flags);
8007         if (lp)
8008             *lp = len;
8009
8010         if (s != SvPVX_const(sv)) {     /* Almost, but not quite, sv_setpvn() */
8011             if (SvROK(sv))
8012                 sv_unref(sv);
8013             SvUPGRADE(sv, SVt_PV);              /* Never FALSE */
8014             SvGROW(sv, len + 1);
8015             Move(s,SvPVX(sv),len,char);
8016             SvCUR_set(sv, len);
8017             SvPVX(sv)[len] = '\0';
8018         }
8019         if (!SvPOK(sv)) {
8020             SvPOK_on(sv);               /* validate pointer */
8021             SvTAINT(sv);
8022             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
8023                                   PTR2UV(sv),SvPVX_const(sv)));
8024         }
8025     }
8026     return SvPVX_mutable(sv);
8027 }
8028
8029 /*
8030 =for apidoc sv_pvbyten_force
8031
8032 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
8033
8034 =cut
8035 */
8036
8037 char *
8038 Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp)
8039 {
8040     PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE;
8041
8042     sv_pvn_force(sv,lp);
8043     sv_utf8_downgrade(sv,0);
8044     *lp = SvCUR(sv);
8045     return SvPVX(sv);
8046 }
8047
8048 /*
8049 =for apidoc sv_pvutf8n_force
8050
8051 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
8052
8053 =cut
8054 */
8055
8056 char *
8057 Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
8058 {
8059     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
8060
8061     sv_pvn_force(sv,lp);
8062     sv_utf8_upgrade(sv);
8063     *lp = SvCUR(sv);
8064     return SvPVX(sv);
8065 }
8066
8067 /*
8068 =for apidoc sv_reftype
8069
8070 Returns a string describing what the SV is a reference to.
8071
8072 =cut
8073 */
8074
8075 const char *
8076 Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
8077 {
8078     PERL_ARGS_ASSERT_SV_REFTYPE;
8079
8080     /* The fact that I don't need to downcast to char * everywhere, only in ?:
8081        inside return suggests a const propagation bug in g++.  */
8082     if (ob && SvOBJECT(sv)) {
8083         char * const name = HvNAME_get(SvSTASH(sv));
8084         return name ? name : (char *) "__ANON__";
8085     }
8086     else {
8087         switch (SvTYPE(sv)) {
8088         case SVt_NULL:
8089         case SVt_IV:
8090         case SVt_NV:
8091         case SVt_PV:
8092         case SVt_PVIV:
8093         case SVt_PVNV:
8094         case SVt_PVMG:
8095                                 if (SvVOK(sv))
8096                                     return "VSTRING";
8097                                 if (SvROK(sv))
8098                                     return "REF";
8099                                 else
8100                                     return "SCALAR";
8101
8102         case SVt_PVLV:          return (char *)  (SvROK(sv) ? "REF"
8103                                 /* tied lvalues should appear to be
8104                                  * scalars for backwards compatitbility */
8105                                 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
8106                                     ? "SCALAR" : "LVALUE");
8107         case SVt_PVAV:          return "ARRAY";
8108         case SVt_PVHV:          return "HASH";
8109         case SVt_PVCV:          return "CODE";
8110         case SVt_PVGV:          return "GLOB";
8111         case SVt_PVFM:          return "FORMAT";
8112         case SVt_PVIO:          return "IO";
8113         case SVt_BIND:          return "BIND";
8114         case SVt_REGEXP:        return "REGEXP"; 
8115         default:                return "UNKNOWN";
8116         }
8117     }
8118 }
8119
8120 /*
8121 =for apidoc sv_isobject
8122
8123 Returns a boolean indicating whether the SV is an RV pointing to a blessed
8124 object.  If the SV is not an RV, or if the object is not blessed, then this
8125 will return false.
8126
8127 =cut
8128 */
8129
8130 int
8131 Perl_sv_isobject(pTHX_ SV *sv)
8132 {
8133     if (!sv)
8134         return 0;
8135     SvGETMAGIC(sv);
8136     if (!SvROK(sv))
8137         return 0;
8138     sv = (SV*)SvRV(sv);
8139     if (!SvOBJECT(sv))
8140         return 0;
8141     return 1;
8142 }
8143
8144 /*
8145 =for apidoc sv_isa
8146
8147 Returns a boolean indicating whether the SV is blessed into the specified
8148 class.  This does not check for subtypes; use C<sv_derived_from> to verify
8149 an inheritance relationship.
8150
8151 =cut
8152 */
8153
8154 int
8155 Perl_sv_isa(pTHX_ SV *sv, const char *const name)
8156 {
8157     const char *hvname;
8158
8159     PERL_ARGS_ASSERT_SV_ISA;
8160
8161     if (!sv)
8162         return 0;
8163     SvGETMAGIC(sv);
8164     if (!SvROK(sv))
8165         return 0;
8166     sv = (SV*)SvRV(sv);
8167     if (!SvOBJECT(sv))
8168         return 0;
8169     hvname = HvNAME_get(SvSTASH(sv));
8170     if (!hvname)
8171         return 0;
8172
8173     return strEQ(hvname, name);
8174 }
8175
8176 /*
8177 =for apidoc newSVrv
8178
8179 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
8180 it will be upgraded to one.  If C<classname> is non-null then the new SV will
8181 be blessed in the specified package.  The new SV is returned and its
8182 reference count is 1.
8183
8184 =cut
8185 */
8186
8187 SV*
8188 Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
8189 {
8190     dVAR;
8191     SV *sv;
8192
8193     PERL_ARGS_ASSERT_NEWSVRV;
8194
8195     new_SV(sv);
8196
8197     SV_CHECK_THINKFIRST_COW_DROP(rv);
8198     (void)SvAMAGIC_off(rv);
8199
8200     if (SvTYPE(rv) >= SVt_PVMG) {
8201         const U32 refcnt = SvREFCNT(rv);
8202         SvREFCNT(rv) = 0;
8203         sv_clear(rv);
8204         SvFLAGS(rv) = 0;
8205         SvREFCNT(rv) = refcnt;
8206
8207         sv_upgrade(rv, SVt_IV);
8208     } else if (SvROK(rv)) {
8209         SvREFCNT_dec(SvRV(rv));
8210     } else {
8211         prepare_SV_for_RV(rv);
8212     }
8213
8214     SvOK_off(rv);
8215     SvRV_set(rv, sv);
8216     SvROK_on(rv);
8217
8218     if (classname) {
8219         HV* const stash = gv_stashpv(classname, GV_ADD);
8220         (void)sv_bless(rv, stash);
8221     }
8222     return sv;
8223 }
8224
8225 /*
8226 =for apidoc sv_setref_pv
8227
8228 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
8229 argument will be upgraded to an RV.  That RV will be modified to point to
8230 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
8231 into the SV.  The C<classname> argument indicates the package for the
8232 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8233 will have a reference count of 1, and the RV will be returned.
8234
8235 Do not use with other Perl types such as HV, AV, SV, CV, because those
8236 objects will become corrupted by the pointer copy process.
8237
8238 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
8239
8240 =cut
8241 */
8242
8243 SV*
8244 Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
8245 {
8246     dVAR;
8247
8248     PERL_ARGS_ASSERT_SV_SETREF_PV;
8249
8250     if (!pv) {
8251         sv_setsv(rv, &PL_sv_undef);
8252         SvSETMAGIC(rv);
8253     }
8254     else
8255         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8256     return rv;
8257 }
8258
8259 /*
8260 =for apidoc sv_setref_iv
8261
8262 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
8263 argument will be upgraded to an RV.  That RV will be modified to point to
8264 the new SV.  The C<classname> argument indicates the package for the
8265 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8266 will have a reference count of 1, and the RV will be returned.
8267
8268 =cut
8269 */
8270
8271 SV*
8272 Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv)
8273 {
8274     PERL_ARGS_ASSERT_SV_SETREF_IV;
8275
8276     sv_setiv(newSVrv(rv,classname), iv);
8277     return rv;
8278 }
8279
8280 /*
8281 =for apidoc sv_setref_uv
8282
8283 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
8284 argument will be upgraded to an RV.  That RV will be modified to point to
8285 the new SV.  The C<classname> argument indicates the package for the
8286 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8287 will have a reference count of 1, and the RV will be returned.
8288
8289 =cut
8290 */
8291
8292 SV*
8293 Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv)
8294 {
8295     PERL_ARGS_ASSERT_SV_SETREF_UV;
8296
8297     sv_setuv(newSVrv(rv,classname), uv);
8298     return rv;
8299 }
8300
8301 /*
8302 =for apidoc sv_setref_nv
8303
8304 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
8305 argument will be upgraded to an RV.  That RV will be modified to point to
8306 the new SV.  The C<classname> argument indicates the package for the
8307 blessing.  Set C<classname> to C<NULL> to avoid the blessing.  The new SV
8308 will have a reference count of 1, and the RV will be returned.
8309
8310 =cut
8311 */
8312
8313 SV*
8314 Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv)
8315 {
8316     PERL_ARGS_ASSERT_SV_SETREF_NV;
8317
8318     sv_setnv(newSVrv(rv,classname), nv);
8319     return rv;
8320 }
8321
8322 /*
8323 =for apidoc sv_setref_pvn
8324
8325 Copies a string into a new SV, optionally blessing the SV.  The length of the
8326 string must be specified with C<n>.  The C<rv> argument will be upgraded to
8327 an RV.  That RV will be modified to point to the new SV.  The C<classname>
8328 argument indicates the package for the blessing.  Set C<classname> to
8329 C<NULL> to avoid the blessing.  The new SV will have a reference count
8330 of 1, and the RV will be returned.
8331
8332 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8333
8334 =cut
8335 */
8336
8337 SV*
8338 Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname,
8339                    const char *const pv, const STRLEN n)
8340 {
8341     PERL_ARGS_ASSERT_SV_SETREF_PVN;
8342
8343     sv_setpvn(newSVrv(rv,classname), pv, n);
8344     return rv;
8345 }
8346
8347 /*
8348 =for apidoc sv_bless
8349
8350 Blesses an SV into a specified package.  The SV must be an RV.  The package
8351 must be designated by its stash (see C<gv_stashpv()>).  The reference count
8352 of the SV is unaffected.
8353
8354 =cut
8355 */
8356
8357 SV*
8358 Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
8359 {
8360     dVAR;
8361     SV *tmpRef;
8362
8363     PERL_ARGS_ASSERT_SV_BLESS;
8364
8365     if (!SvROK(sv))
8366         Perl_croak(aTHX_ "Can't bless non-reference value");
8367     tmpRef = SvRV(sv);
8368     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8369         if (SvIsCOW(tmpRef))
8370             sv_force_normal_flags(tmpRef, 0);
8371         if (SvREADONLY(tmpRef))
8372             Perl_croak(aTHX_ PL_no_modify);
8373         if (SvOBJECT(tmpRef)) {
8374             if (SvTYPE(tmpRef) != SVt_PVIO)
8375                 --PL_sv_objcount;
8376             SvREFCNT_dec(SvSTASH(tmpRef));
8377         }
8378     }
8379     SvOBJECT_on(tmpRef);
8380     if (SvTYPE(tmpRef) != SVt_PVIO)
8381         ++PL_sv_objcount;
8382     SvUPGRADE(tmpRef, SVt_PVMG);
8383     SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash));
8384
8385     if (Gv_AMG(stash))
8386         SvAMAGIC_on(sv);
8387     else
8388         (void)SvAMAGIC_off(sv);
8389
8390     if(SvSMAGICAL(tmpRef))
8391         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8392             mg_set(tmpRef);
8393
8394
8395
8396     return sv;
8397 }
8398
8399 /* Downgrades a PVGV to a PVMG.
8400  */
8401
8402 STATIC void
8403 S_sv_unglob(pTHX_ SV *const sv)
8404 {
8405     dVAR;
8406     void *xpvmg;
8407     HV *stash;
8408     SV * const temp = sv_newmortal();
8409
8410     PERL_ARGS_ASSERT_SV_UNGLOB;
8411
8412     assert(SvTYPE(sv) == SVt_PVGV);
8413     SvFAKE_off(sv);
8414     gv_efullname3(temp, (GV *) sv, "*");
8415
8416     if (GvGP(sv)) {
8417         if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash))
8418             mro_method_changed_in(stash);
8419         gp_free((GV*)sv);
8420     }
8421     if (GvSTASH(sv)) {
8422         sv_del_backref((SV*)GvSTASH(sv), sv);
8423         GvSTASH(sv) = NULL;
8424     }
8425     GvMULTI_off(sv);
8426     if (GvNAME_HEK(sv)) {
8427         unshare_hek(GvNAME_HEK(sv));
8428     }
8429     isGV_with_GP_off(sv);
8430
8431     /* need to keep SvANY(sv) in the right arena */
8432     xpvmg = new_XPVMG();
8433     StructCopy(SvANY(sv), xpvmg, XPVMG);
8434     del_XPVGV(SvANY(sv));
8435     SvANY(sv) = xpvmg;
8436
8437     SvFLAGS(sv) &= ~SVTYPEMASK;
8438     SvFLAGS(sv) |= SVt_PVMG;
8439
8440     /* Intentionally not calling any local SET magic, as this isn't so much a
8441        set operation as merely an internal storage change.  */
8442     sv_setsv_flags(sv, temp, 0);
8443 }
8444
8445 /*
8446 =for apidoc sv_unref_flags
8447
8448 Unsets the RV status of the SV, and decrements the reference count of
8449 whatever was being referenced by the RV.  This can almost be thought of
8450 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
8451 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8452 (otherwise the decrementing is conditional on the reference count being
8453 different from one or the reference being a readonly SV).
8454 See C<SvROK_off>.
8455
8456 =cut
8457 */
8458
8459 void
8460 Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags)
8461 {
8462     SV* const target = SvRV(ref);
8463
8464     PERL_ARGS_ASSERT_SV_UNREF_FLAGS;
8465
8466     if (SvWEAKREF(ref)) {
8467         sv_del_backref(target, ref);
8468         SvWEAKREF_off(ref);
8469         SvRV_set(ref, NULL);
8470         return;
8471     }
8472     SvRV_set(ref, NULL);
8473     SvROK_off(ref);
8474     /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8475        assigned to as BEGIN {$a = \"Foo"} will fail.  */
8476     if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8477         SvREFCNT_dec(target);
8478     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8479         sv_2mortal(target);     /* Schedule for freeing later */
8480 }
8481
8482 /*
8483 =for apidoc sv_untaint
8484
8485 Untaint an SV. Use C<SvTAINTED_off> instead.
8486 =cut
8487 */
8488
8489 void
8490 Perl_sv_untaint(pTHX_ SV *const sv)
8491 {
8492     PERL_ARGS_ASSERT_SV_UNTAINT;
8493
8494     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8495         MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8496         if (mg)
8497             mg->mg_len &= ~1;
8498     }
8499 }
8500
8501 /*
8502 =for apidoc sv_tainted
8503
8504 Test an SV for taintedness. Use C<SvTAINTED> instead.
8505 =cut
8506 */
8507
8508 bool
8509 Perl_sv_tainted(pTHX_ SV *const sv)
8510 {
8511     PERL_ARGS_ASSERT_SV_TAINTED;
8512
8513     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8514         const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8515         if (mg && (mg->mg_len & 1) )
8516             return TRUE;
8517     }
8518     return FALSE;
8519 }
8520
8521 /*
8522 =for apidoc sv_setpviv
8523
8524 Copies an integer into the given SV, also updating its string value.
8525 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8526
8527 =cut
8528 */
8529
8530 void
8531 Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv)
8532 {
8533     char buf[TYPE_CHARS(UV)];
8534     char *ebuf;
8535     char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8536
8537     PERL_ARGS_ASSERT_SV_SETPVIV;
8538
8539     sv_setpvn(sv, ptr, ebuf - ptr);
8540 }
8541
8542 /*
8543 =for apidoc sv_setpviv_mg
8544
8545 Like C<sv_setpviv>, but also handles 'set' magic.
8546
8547 =cut
8548 */
8549
8550 void
8551 Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv)
8552 {
8553     PERL_ARGS_ASSERT_SV_SETPVIV_MG;
8554
8555     sv_setpviv(sv, iv);
8556     SvSETMAGIC(sv);
8557 }
8558
8559 #if defined(PERL_IMPLICIT_CONTEXT)
8560
8561 /* pTHX_ magic can't cope with varargs, so this is a no-context
8562  * version of the main function, (which may itself be aliased to us).
8563  * Don't access this version directly.
8564  */
8565
8566 void
8567 Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...)
8568 {
8569     dTHX;
8570     va_list args;
8571
8572     PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT;
8573
8574     va_start(args, pat);
8575     sv_vsetpvf(sv, pat, &args);
8576     va_end(args);
8577 }
8578
8579 /* pTHX_ magic can't cope with varargs, so this is a no-context
8580  * version of the main function, (which may itself be aliased to us).
8581  * Don't access this version directly.
8582  */
8583
8584 void
8585 Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8586 {
8587     dTHX;
8588     va_list args;
8589
8590     PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT;
8591
8592     va_start(args, pat);
8593     sv_vsetpvf_mg(sv, pat, &args);
8594     va_end(args);
8595 }
8596 #endif
8597
8598 /*
8599 =for apidoc sv_setpvf
8600
8601 Works like C<sv_catpvf> but copies the text into the SV instead of
8602 appending it.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8603
8604 =cut
8605 */
8606
8607 void
8608 Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...)
8609 {
8610     va_list args;
8611
8612     PERL_ARGS_ASSERT_SV_SETPVF;
8613
8614     va_start(args, pat);
8615     sv_vsetpvf(sv, pat, &args);
8616     va_end(args);
8617 }
8618
8619 /*
8620 =for apidoc sv_vsetpvf
8621
8622 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8623 appending it.  Does not handle 'set' magic.  See C<sv_vsetpvf_mg>.
8624
8625 Usually used via its frontend C<sv_setpvf>.
8626
8627 =cut
8628 */
8629
8630 void
8631 Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8632 {
8633     PERL_ARGS_ASSERT_SV_VSETPVF;
8634
8635     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8636 }
8637
8638 /*
8639 =for apidoc sv_setpvf_mg
8640
8641 Like C<sv_setpvf>, but also handles 'set' magic.
8642
8643 =cut
8644 */
8645
8646 void
8647 Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8648 {
8649     va_list args;
8650
8651     PERL_ARGS_ASSERT_SV_SETPVF_MG;
8652
8653     va_start(args, pat);
8654     sv_vsetpvf_mg(sv, pat, &args);
8655     va_end(args);
8656 }
8657
8658 /*
8659 =for apidoc sv_vsetpvf_mg
8660
8661 Like C<sv_vsetpvf>, but also handles 'set' magic.
8662
8663 Usually used via its frontend C<sv_setpvf_mg>.
8664
8665 =cut
8666 */
8667
8668 void
8669 Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8670 {
8671     PERL_ARGS_ASSERT_SV_VSETPVF_MG;
8672
8673     sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8674     SvSETMAGIC(sv);
8675 }
8676
8677 #if defined(PERL_IMPLICIT_CONTEXT)
8678
8679 /* pTHX_ magic can't cope with varargs, so this is a no-context
8680  * version of the main function, (which may itself be aliased to us).
8681  * Don't access this version directly.
8682  */
8683
8684 void
8685 Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...)
8686 {
8687     dTHX;
8688     va_list args;
8689
8690     PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
8691
8692     va_start(args, pat);
8693     sv_vcatpvf(sv, pat, &args);
8694     va_end(args);
8695 }
8696
8697 /* pTHX_ magic can't cope with varargs, so this is a no-context
8698  * version of the main function, (which may itself be aliased to us).
8699  * Don't access this version directly.
8700  */
8701
8702 void
8703 Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...)
8704 {
8705     dTHX;
8706     va_list args;
8707
8708     PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
8709
8710     va_start(args, pat);
8711     sv_vcatpvf_mg(sv, pat, &args);
8712     va_end(args);
8713 }
8714 #endif
8715
8716 /*
8717 =for apidoc sv_catpvf
8718
8719 Processes its arguments like C<sprintf> and appends the formatted
8720 output to an SV.  If the appended data contains "wide" characters
8721 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8722 and characters >255 formatted with %c), the original SV might get
8723 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.  See
8724 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8725 valid UTF-8; if the original SV was bytes, the pattern should be too.
8726
8727 =cut */
8728
8729 void
8730 Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...)
8731 {
8732     va_list args;
8733
8734     PERL_ARGS_ASSERT_SV_CATPVF;
8735
8736     va_start(args, pat);
8737     sv_vcatpvf(sv, pat, &args);
8738     va_end(args);
8739 }
8740
8741 /*
8742 =for apidoc sv_vcatpvf
8743
8744 Processes its arguments like C<vsprintf> and appends the formatted output
8745 to an SV.  Does not handle 'set' magic.  See C<sv_vcatpvf_mg>.
8746
8747 Usually used via its frontend C<sv_catpvf>.
8748
8749 =cut
8750 */
8751
8752 void
8753 Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8754 {
8755     PERL_ARGS_ASSERT_SV_VCATPVF;
8756
8757     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8758 }
8759
8760 /*
8761 =for apidoc sv_catpvf_mg
8762
8763 Like C<sv_catpvf>, but also handles 'set' magic.
8764
8765 =cut
8766 */
8767
8768 void
8769 Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...)
8770 {
8771     va_list args;
8772
8773     PERL_ARGS_ASSERT_SV_CATPVF_MG;
8774
8775     va_start(args, pat);
8776     sv_vcatpvf_mg(sv, pat, &args);
8777     va_end(args);
8778 }
8779
8780 /*
8781 =for apidoc sv_vcatpvf_mg
8782
8783 Like C<sv_vcatpvf>, but also handles 'set' magic.
8784
8785 Usually used via its frontend C<sv_catpvf_mg>.
8786
8787 =cut
8788 */
8789
8790 void
8791 Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args)
8792 {
8793     PERL_ARGS_ASSERT_SV_VCATPVF_MG;
8794
8795     sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
8796     SvSETMAGIC(sv);
8797 }
8798
8799 /*
8800 =for apidoc sv_vsetpvfn
8801
8802 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8803 appending it.
8804
8805 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8806
8807 =cut
8808 */
8809
8810 void
8811 Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
8812                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
8813 {
8814     PERL_ARGS_ASSERT_SV_VSETPVFN;
8815
8816     sv_setpvn(sv, "", 0);
8817     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8818 }
8819
8820 STATIC I32
8821 S_expect_number(pTHX_ char **const pattern)
8822 {
8823     dVAR;
8824     I32 var = 0;
8825
8826     PERL_ARGS_ASSERT_EXPECT_NUMBER;
8827
8828     switch (**pattern) {
8829     case '1': case '2': case '3':
8830     case '4': case '5': case '6':
8831     case '7': case '8': case '9':
8832         var = *(*pattern)++ - '0';
8833         while (isDIGIT(**pattern)) {
8834             const I32 tmp = var * 10 + (*(*pattern)++ - '0');
8835             if (tmp < var)
8836                 Perl_croak(aTHX_ "Integer overflow in format string for %s", (PL_op ? OP_NAME(PL_op) : "sv_vcatpvfn"));
8837             var = tmp;
8838         }
8839     }
8840     return var;
8841 }
8842
8843 STATIC char *
8844 S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
8845 {
8846     const int neg = nv < 0;
8847     UV uv;
8848
8849     PERL_ARGS_ASSERT_F0CONVERT;
8850
8851     if (neg)
8852         nv = -nv;
8853     if (nv < UV_MAX) {
8854         char *p = endbuf;
8855         nv += 0.5;
8856         uv = (UV)nv;
8857         if (uv & 1 && uv == nv)
8858             uv--;                       /* Round to even */
8859         do {
8860             const unsigned dig = uv % 10;
8861             *--p = '0' + dig;
8862         } while (uv /= 10);
8863         if (neg)
8864             *--p = '-';
8865         *len = endbuf - p;
8866         return p;
8867     }
8868     return NULL;
8869 }
8870
8871
8872 /*
8873 =for apidoc sv_vcatpvfn
8874
8875 Processes its arguments like C<vsprintf> and appends the formatted output
8876 to an SV.  Uses an array of SVs if the C style variable argument list is
8877 missing (NULL).  When running with taint checks enabled, indicates via
8878 C<maybe_tainted> if results are untrustworthy (often due to the use of
8879 locales).
8880
8881 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8882
8883 =cut
8884 */
8885
8886
8887 #define VECTORIZE_ARGS  vecsv = va_arg(*args, SV*);\
8888                         vecstr = (U8*)SvPV_const(vecsv,veclen);\
8889                         vec_utf8 = DO_UTF8(vecsv);
8890
8891 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8892
8893 void
8894 Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
8895                  va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
8896 {
8897     dVAR;
8898     char *p;
8899     char *q;
8900     const char *patend;
8901     STRLEN origlen;
8902     I32 svix = 0;
8903     static const char nullstr[] = "(null)";
8904     SV *argsv = NULL;
8905     bool has_utf8 = DO_UTF8(sv);    /* has the result utf8? */
8906     const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8907     SV *nsv = NULL;
8908     /* Times 4: a decimal digit takes more than 3 binary digits.
8909      * NV_DIG: mantissa takes than many decimal digits.
8910      * Plus 32: Playing safe. */
8911     char ebuf[IV_DIG * 4 + NV_DIG + 32];
8912     /* large enough for "%#.#f" --chip */
8913     /* what about long double NVs? --jhi */
8914
8915     PERL_ARGS_ASSERT_SV_VCATPVFN;
8916     PERL_UNUSED_ARG(maybe_tainted);
8917
8918     /* no matter what, this is a string now */
8919     (void)SvPV_force(sv, origlen);
8920
8921     /* special-case "", "%s", and "%-p" (SVf - see below) */
8922     if (patlen == 0)
8923         return;
8924     if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8925         if (args) {
8926             const char * const s = va_arg(*args, char*);
8927             sv_catpv(sv, s ? s : nullstr);
8928         }
8929         else if (svix < svmax) {
8930             sv_catsv(sv, *svargs);
8931         }
8932         return;
8933     }
8934     if (args && patlen == 3 && pat[0] == '%' &&
8935                 pat[1] == '-' && pat[2] == 'p') {
8936         argsv = (SV*)va_arg(*args, void*);
8937         sv_catsv(sv, argsv);
8938         return;
8939     }
8940
8941 #ifndef USE_LONG_DOUBLE
8942     /* special-case "%.<number>[gf]" */
8943     if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8944          && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8945         unsigned digits = 0;
8946         const char *pp;
8947
8948         pp = pat + 2;
8949         while (*pp >= '0' && *pp <= '9')
8950             digits = 10 * digits + (*pp++ - '0');
8951         if (pp - pat == (int)patlen - 1) {
8952             NV nv;
8953
8954             if (svix < svmax)
8955                 nv = SvNV(*svargs);
8956             else
8957                 return;
8958             if (*pp == 'g') {
8959                 /* Add check for digits != 0 because it seems that some
8960                    gconverts are buggy in this case, and we don't yet have
8961                    a Configure test for this.  */
8962                 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8963                      /* 0, point, slack */
8964                     Gconvert(nv, (int)digits, 0, ebuf);
8965                     sv_catpv(sv, ebuf);
8966                     if (*ebuf)  /* May return an empty string for digits==0 */
8967                         return;
8968                 }
8969             } else if (!digits) {
8970                 STRLEN l;
8971
8972                 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8973                     sv_catpvn(sv, p, l);
8974                     return;
8975                 }
8976             }
8977         }
8978     }
8979 #endif /* !USE_LONG_DOUBLE */
8980
8981     if (!args && svix < svmax && DO_UTF8(*svargs))
8982         has_utf8 = TRUE;
8983
8984     patend = (char*)pat + patlen;
8985     for (p = (char*)pat; p < patend; p = q) {
8986         bool alt = FALSE;
8987         bool left = FALSE;
8988         bool vectorize = FALSE;
8989         bool vectorarg = FALSE;
8990         bool vec_utf8 = FALSE;
8991         char fill = ' ';
8992         char plus = 0;
8993         char intsize = 0;
8994         STRLEN width = 0;
8995         STRLEN zeros = 0;
8996         bool has_precis = FALSE;
8997         STRLEN precis = 0;
8998         const I32 osvix = svix;
8999         bool is_utf8 = FALSE;  /* is this item utf8?   */
9000 #ifdef HAS_LDBL_SPRINTF_BUG
9001         /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9002            with sfio - Allen <allens@cpan.org> */
9003         bool fix_ldbl_sprintf_bug = FALSE;
9004 #endif
9005
9006         char esignbuf[4];
9007         U8 utf8buf[UTF8_MAXBYTES+1];
9008         STRLEN esignlen = 0;
9009
9010         const char *eptr = NULL;
9011         STRLEN elen = 0;
9012         SV *vecsv = NULL;
9013         const U8 *vecstr = NULL;
9014         STRLEN veclen = 0;
9015         char c = 0;
9016         int i;
9017         unsigned base = 0;
9018         IV iv = 0;
9019         UV uv = 0;
9020         /* we need a long double target in case HAS_LONG_DOUBLE but
9021            not USE_LONG_DOUBLE
9022         */
9023 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
9024         long double nv;
9025 #else
9026         NV nv;
9027 #endif
9028         STRLEN have;
9029         STRLEN need;
9030         STRLEN gap;
9031         const char *dotstr = ".";
9032         STRLEN dotstrlen = 1;
9033         I32 efix = 0; /* explicit format parameter index */
9034         I32 ewix = 0; /* explicit width index */
9035         I32 epix = 0; /* explicit precision index */
9036         I32 evix = 0; /* explicit vector index */
9037         bool asterisk = FALSE;
9038
9039         /* echo everything up to the next format specification */
9040         for (q = p; q < patend && *q != '%'; ++q) ;
9041         if (q > p) {
9042             if (has_utf8 && !pat_utf8)
9043                 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
9044             else
9045                 sv_catpvn(sv, p, q - p);
9046             p = q;
9047         }
9048         if (q++ >= patend)
9049             break;
9050
9051 /*
9052     We allow format specification elements in this order:
9053         \d+\$              explicit format parameter index
9054         [-+ 0#]+           flags
9055         v|\*(\d+\$)?v      vector with optional (optionally specified) arg
9056         0                  flag (as above): repeated to allow "v02"     
9057         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
9058         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
9059         [hlqLV]            size
9060     [%bcdefginopsuxDFOUX] format (mandatory)
9061 */
9062
9063         if (args) {
9064 /*  
9065         As of perl5.9.3, printf format checking is on by default.
9066         Internally, perl uses %p formats to provide an escape to
9067         some extended formatting.  This block deals with those
9068         extensions: if it does not match, (char*)q is reset and
9069         the normal format processing code is used.
9070
9071         Currently defined extensions are:
9072                 %p              include pointer address (standard)      
9073                 %-p     (SVf)   include an SV (previously %_)
9074                 %-<num>p        include an SV with precision <num>      
9075                 %<num>p         reserved for future extensions
9076
9077         Robin Barker 2005-07-14
9078
9079                 %1p     (VDf)   removed.  RMB 2007-10-19
9080 */
9081             char* r = q; 
9082             bool sv = FALSE;    
9083             STRLEN n = 0;
9084             if (*q == '-')
9085                 sv = *q++;
9086             n = expect_number(&q);
9087             if (*q++ == 'p') {
9088                 if (sv) {                       /* SVf */
9089                     if (n) {
9090                         precis = n;
9091                         has_precis = TRUE;
9092                     }
9093                     argsv = (SV*)va_arg(*args, void*);
9094                     eptr = SvPV_const(argsv, elen);
9095                     if (DO_UTF8(argsv))
9096                         is_utf8 = TRUE;
9097                     goto string;
9098                 }
9099                 else if (n) {
9100                     if (ckWARN_d(WARN_INTERNAL))
9101                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9102                         "internal %%<num>p might conflict with future printf extensions");
9103                 }
9104             }
9105             q = r; 
9106         }
9107
9108         if ( (width = expect_number(&q)) ) {
9109             if (*q == '$') {
9110                 ++q;
9111                 efix = width;
9112             } else {
9113                 goto gotwidth;
9114             }
9115         }
9116
9117         /* FLAGS */
9118
9119         while (*q) {
9120             switch (*q) {
9121             case ' ':
9122             case '+':
9123                 if (plus == '+' && *q == ' ') /* '+' over ' ' */
9124                     q++;
9125                 else
9126                     plus = *q++;
9127                 continue;
9128
9129             case '-':
9130                 left = TRUE;
9131                 q++;
9132                 continue;
9133
9134             case '0':
9135                 fill = *q++;
9136                 continue;
9137
9138             case '#':
9139                 alt = TRUE;
9140                 q++;
9141                 continue;
9142
9143             default:
9144                 break;
9145             }
9146             break;
9147         }
9148
9149       tryasterisk:
9150         if (*q == '*') {
9151             q++;
9152             if ( (ewix = expect_number(&q)) )
9153                 if (*q++ != '$')
9154                     goto unknown;
9155             asterisk = TRUE;
9156         }
9157         if (*q == 'v') {
9158             q++;
9159             if (vectorize)
9160                 goto unknown;
9161             if ((vectorarg = asterisk)) {
9162                 evix = ewix;
9163                 ewix = 0;
9164                 asterisk = FALSE;
9165             }
9166             vectorize = TRUE;
9167             goto tryasterisk;
9168         }
9169
9170         if (!asterisk)
9171         {
9172             if( *q == '0' )
9173                 fill = *q++;
9174             width = expect_number(&q);
9175         }
9176
9177         if (vectorize) {
9178             if (vectorarg) {
9179                 if (args)
9180                     vecsv = va_arg(*args, SV*);
9181                 else if (evix) {
9182                     vecsv = (evix > 0 && evix <= svmax)
9183                         ? svargs[evix-1] : &PL_sv_undef;
9184                 } else {
9185                     vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
9186                 }
9187                 dotstr = SvPV_const(vecsv, dotstrlen);
9188                 /* Keep the DO_UTF8 test *after* the SvPV call, else things go
9189                    bad with tied or overloaded values that return UTF8.  */
9190                 if (DO_UTF8(vecsv))
9191                     is_utf8 = TRUE;
9192                 else if (has_utf8) {
9193                     vecsv = sv_mortalcopy(vecsv);
9194                     sv_utf8_upgrade(vecsv);
9195                     dotstr = SvPV_const(vecsv, dotstrlen);
9196                     is_utf8 = TRUE;
9197                 }                   
9198             }
9199             if (args) {
9200                 VECTORIZE_ARGS
9201             }
9202             else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
9203                 vecsv = svargs[efix ? efix-1 : svix++];
9204                 vecstr = (U8*)SvPV_const(vecsv,veclen);
9205                 vec_utf8 = DO_UTF8(vecsv);
9206
9207                 /* if this is a version object, we need to convert
9208                  * back into v-string notation and then let the
9209                  * vectorize happen normally
9210                  */
9211                 if (sv_derived_from(vecsv, "version")) {
9212                     char *version = savesvpv(vecsv);
9213                     if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) {
9214                         Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
9215                         "vector argument not supported with alpha versions");
9216                         goto unknown;
9217                     }
9218                     vecsv = sv_newmortal();
9219                     scan_vstring(version, version + veclen, vecsv);
9220                     vecstr = (U8*)SvPV_const(vecsv, veclen);
9221                     vec_utf8 = DO_UTF8(vecsv);
9222                     Safefree(version);
9223                 }
9224             }
9225             else {
9226                 vecstr = (U8*)"";
9227                 veclen = 0;
9228             }
9229         }
9230
9231         if (asterisk) {
9232             if (args)
9233                 i = va_arg(*args, int);
9234             else
9235                 i = (ewix ? ewix <= svmax : svix < svmax) ?
9236                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9237             left |= (i < 0);
9238             width = (i < 0) ? -i : i;
9239         }
9240       gotwidth:
9241
9242         /* PRECISION */
9243
9244         if (*q == '.') {
9245             q++;
9246             if (*q == '*') {
9247                 q++;
9248                 if ( ((epix = expect_number(&q))) && (*q++ != '$') )
9249                     goto unknown;
9250                 /* XXX: todo, support specified precision parameter */
9251                 if (epix)
9252                     goto unknown;
9253                 if (args)
9254                     i = va_arg(*args, int);
9255                 else
9256                     i = (ewix ? ewix <= svmax : svix < svmax)
9257                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
9258                 precis = i;
9259                 has_precis = !(i < 0);
9260             }
9261             else {
9262                 precis = 0;
9263                 while (isDIGIT(*q))
9264                     precis = precis * 10 + (*q++ - '0');
9265                 has_precis = TRUE;
9266             }
9267         }
9268
9269         /* SIZE */
9270
9271         switch (*q) {
9272 #ifdef WIN32
9273         case 'I':                       /* Ix, I32x, and I64x */
9274 #  ifdef WIN64
9275             if (q[1] == '6' && q[2] == '4') {
9276                 q += 3;
9277                 intsize = 'q';
9278                 break;
9279             }
9280 #  endif
9281             if (q[1] == '3' && q[2] == '2') {
9282                 q += 3;
9283                 break;
9284             }
9285 #  ifdef WIN64
9286             intsize = 'q';
9287 #  endif
9288             q++;
9289             break;
9290 #endif
9291 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9292         case 'L':                       /* Ld */
9293             /*FALLTHROUGH*/
9294 #ifdef HAS_QUAD
9295         case 'q':                       /* qd */
9296 #endif
9297             intsize = 'q';
9298             q++;
9299             break;
9300 #endif
9301         case 'l':
9302 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
9303             if (*(q + 1) == 'l') {      /* lld, llf */
9304                 intsize = 'q';
9305                 q += 2;
9306                 break;
9307              }
9308 #endif
9309             /*FALLTHROUGH*/
9310         case 'h':
9311             /*FALLTHROUGH*/
9312         case 'V':
9313             intsize = *q++;
9314             break;
9315         }
9316
9317         /* CONVERSION */
9318
9319         if (*q == '%') {
9320             eptr = q++;
9321             elen = 1;
9322             if (vectorize) {
9323                 c = '%';
9324                 goto unknown;
9325             }
9326             goto string;
9327         }
9328
9329         if (!vectorize && !args) {
9330             if (efix) {
9331                 const I32 i = efix-1;
9332                 argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
9333             } else {
9334                 argsv = (svix >= 0 && svix < svmax)
9335                     ? svargs[svix++] : &PL_sv_undef;
9336             }
9337         }
9338
9339         switch (c = *q++) {
9340
9341             /* STRINGS */
9342
9343         case 'c':
9344             if (vectorize)
9345                 goto unknown;
9346             uv = (args) ? va_arg(*args, int) : SvIV(argsv);
9347             if ((uv > 255 ||
9348                  (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
9349                 && !IN_BYTES) {
9350                 eptr = (char*)utf8buf;
9351                 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
9352                 is_utf8 = TRUE;
9353             }
9354             else {
9355                 c = (char)uv;
9356                 eptr = &c;
9357                 elen = 1;
9358             }
9359             goto string;
9360
9361         case 's':
9362             if (vectorize)
9363                 goto unknown;
9364             if (args) {
9365                 eptr = va_arg(*args, char*);
9366                 if (eptr)
9367 #ifdef MACOS_TRADITIONAL
9368                   /* On MacOS, %#s format is used for Pascal strings */
9369                   if (alt)
9370                     elen = *eptr++;
9371                   else
9372 #endif
9373                     elen = strlen(eptr);
9374                 else {
9375                     eptr = (char *)nullstr;
9376                     elen = sizeof nullstr - 1;
9377                 }
9378             }
9379             else {
9380                 eptr = SvPV_const(argsv, elen);
9381                 if (DO_UTF8(argsv)) {
9382                     I32 old_precis = precis;
9383                     if (has_precis && precis < elen) {
9384                         I32 p = precis;
9385                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
9386                         precis = p;
9387                     }
9388                     if (width) { /* fudge width (can't fudge elen) */
9389                         if (has_precis && precis < elen)
9390                             width += precis - old_precis;
9391                         else
9392                             width += elen - sv_len_utf8(argsv);
9393                     }
9394                     is_utf8 = TRUE;
9395                 }
9396             }
9397
9398         string:
9399             if (has_precis && elen > precis)
9400                 elen = precis;
9401             break;
9402
9403             /* INTEGERS */
9404
9405         case 'p':
9406             if (alt || vectorize)
9407                 goto unknown;
9408             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
9409             base = 16;
9410             goto integer;
9411
9412         case 'D':
9413 #ifdef IV_IS_QUAD
9414             intsize = 'q';
9415 #else
9416             intsize = 'l';
9417 #endif
9418             /*FALLTHROUGH*/
9419         case 'd':
9420         case 'i':
9421 #if vdNUMBER
9422         format_vd:
9423 #endif
9424             if (vectorize) {
9425                 STRLEN ulen;
9426                 if (!veclen)
9427                     continue;
9428                 if (vec_utf8)
9429                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9430                                         UTF8_ALLOW_ANYUV);
9431                 else {
9432                     uv = *vecstr;
9433                     ulen = 1;
9434                 }
9435                 vecstr += ulen;
9436                 veclen -= ulen;
9437                 if (plus)
9438                      esignbuf[esignlen++] = plus;
9439             }
9440             else if (args) {
9441                 switch (intsize) {
9442                 case 'h':       iv = (short)va_arg(*args, int); break;
9443                 case 'l':       iv = va_arg(*args, long); break;
9444                 case 'V':       iv = va_arg(*args, IV); break;
9445                 default:        iv = va_arg(*args, int); break;
9446 #ifdef HAS_QUAD
9447                 case 'q':       iv = va_arg(*args, Quad_t); break;
9448 #endif
9449                 }
9450             }
9451             else {
9452                 IV tiv = SvIV(argsv); /* work around GCC bug #13488 */
9453                 switch (intsize) {
9454                 case 'h':       iv = (short)tiv; break;
9455                 case 'l':       iv = (long)tiv; break;
9456                 case 'V':
9457                 default:        iv = tiv; break;
9458 #ifdef HAS_QUAD
9459                 case 'q':       iv = (Quad_t)tiv; break;
9460 #endif
9461                 }
9462             }
9463             if ( !vectorize )   /* we already set uv above */
9464             {
9465                 if (iv >= 0) {
9466                     uv = iv;
9467                     if (plus)
9468                         esignbuf[esignlen++] = plus;
9469                 }
9470                 else {
9471                     uv = -iv;
9472                     esignbuf[esignlen++] = '-';
9473                 }
9474             }
9475             base = 10;
9476             goto integer;
9477
9478         case 'U':
9479 #ifdef IV_IS_QUAD
9480             intsize = 'q';
9481 #else
9482             intsize = 'l';
9483 #endif
9484             /*FALLTHROUGH*/
9485         case 'u':
9486             base = 10;
9487             goto uns_integer;
9488
9489         case 'B':
9490         case 'b':
9491             base = 2;
9492             goto uns_integer;
9493
9494         case 'O':
9495 #ifdef IV_IS_QUAD
9496             intsize = 'q';
9497 #else
9498             intsize = 'l';
9499 #endif
9500             /*FALLTHROUGH*/
9501         case 'o':
9502             base = 8;
9503             goto uns_integer;
9504
9505         case 'X':
9506         case 'x':
9507             base = 16;
9508
9509         uns_integer:
9510             if (vectorize) {
9511                 STRLEN ulen;
9512         vector:
9513                 if (!veclen)
9514                     continue;
9515                 if (vec_utf8)
9516                     uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9517                                         UTF8_ALLOW_ANYUV);
9518                 else {
9519                     uv = *vecstr;
9520                     ulen = 1;
9521                 }
9522                 vecstr += ulen;
9523                 veclen -= ulen;
9524             }
9525             else if (args) {
9526                 switch (intsize) {
9527                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
9528                 case 'l':  uv = va_arg(*args, unsigned long); break;
9529                 case 'V':  uv = va_arg(*args, UV); break;
9530                 default:   uv = va_arg(*args, unsigned); break;
9531 #ifdef HAS_QUAD
9532                 case 'q':  uv = va_arg(*args, Uquad_t); break;
9533 #endif
9534                 }
9535             }
9536             else {
9537                 UV tuv = SvUV(argsv); /* work around GCC bug #13488 */
9538                 switch (intsize) {
9539                 case 'h':       uv = (unsigned short)tuv; break;
9540                 case 'l':       uv = (unsigned long)tuv; break;
9541                 case 'V':
9542                 default:        uv = tuv; break;
9543 #ifdef HAS_QUAD
9544                 case 'q':       uv = (Uquad_t)tuv; break;
9545 #endif
9546                 }
9547             }
9548
9549         integer:
9550             {
9551                 char *ptr = ebuf + sizeof ebuf;
9552                 bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
9553                 zeros = 0;
9554
9555                 switch (base) {
9556                     unsigned dig;
9557                 case 16:
9558                     p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
9559                     do {
9560                         dig = uv & 15;
9561                         *--ptr = p[dig];
9562                     } while (uv >>= 4);
9563                     if (tempalt) {
9564                         esignbuf[esignlen++] = '0';
9565                         esignbuf[esignlen++] = c;  /* 'x' or 'X' */
9566                     }
9567                     break;
9568                 case 8:
9569                     do {
9570                         dig = uv & 7;
9571                         *--ptr = '0' + dig;
9572                     } while (uv >>= 3);
9573                     if (alt && *ptr != '0')
9574                         *--ptr = '0';
9575                     break;
9576                 case 2:
9577                     do {
9578                         dig = uv & 1;
9579                         *--ptr = '0' + dig;
9580                     } while (uv >>= 1);
9581                     if (tempalt) {
9582                         esignbuf[esignlen++] = '0';
9583                         esignbuf[esignlen++] = c;
9584                     }
9585                     break;
9586                 default:                /* it had better be ten or less */
9587                     do {
9588                         dig = uv % base;
9589                         *--ptr = '0' + dig;
9590                     } while (uv /= base);
9591                     break;
9592                 }
9593                 elen = (ebuf + sizeof ebuf) - ptr;
9594                 eptr = ptr;
9595                 if (has_precis) {
9596                     if (precis > elen)
9597                         zeros = precis - elen;
9598                     else if (precis == 0 && elen == 1 && *eptr == '0'
9599                              && !(base == 8 && alt)) /* "%#.0o" prints "0" */
9600                         elen = 0;
9601
9602                 /* a precision nullifies the 0 flag. */
9603                     if (fill == '0')
9604                         fill = ' ';
9605                 }
9606             }
9607             break;
9608
9609             /* FLOATING POINT */
9610
9611         case 'F':
9612             c = 'f';            /* maybe %F isn't supported here */
9613             /*FALLTHROUGH*/
9614         case 'e': case 'E':
9615         case 'f':
9616         case 'g': case 'G':
9617             if (vectorize)
9618                 goto unknown;
9619
9620             /* This is evil, but floating point is even more evil */
9621
9622             /* for SV-style calling, we can only get NV
9623                for C-style calling, we assume %f is double;
9624                for simplicity we allow any of %Lf, %llf, %qf for long double
9625             */
9626             switch (intsize) {
9627             case 'V':
9628 #if defined(USE_LONG_DOUBLE)
9629                 intsize = 'q';
9630 #endif
9631                 break;
9632 /* [perl #20339] - we should accept and ignore %lf rather than die */
9633             case 'l':
9634                 /*FALLTHROUGH*/
9635             default:
9636 #if defined(USE_LONG_DOUBLE)
9637                 intsize = args ? 0 : 'q';
9638 #endif
9639                 break;
9640             case 'q':
9641 #if defined(HAS_LONG_DOUBLE)
9642                 break;
9643 #else
9644                 /*FALLTHROUGH*/
9645 #endif
9646             case 'h':
9647                 goto unknown;
9648             }
9649
9650             /* now we need (long double) if intsize == 'q', else (double) */
9651             nv = (args) ?
9652 #if LONG_DOUBLESIZE > DOUBLESIZE
9653                 intsize == 'q' ?
9654                     va_arg(*args, long double) :
9655                     va_arg(*args, double)
9656 #else
9657                     va_arg(*args, double)
9658 #endif
9659                 : SvNV(argsv);
9660
9661             need = 0;
9662             /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
9663                else. frexp() has some unspecified behaviour for those three */
9664             if (c != 'e' && c != 'E' && (nv * 0) == 0) {
9665                 i = PERL_INT_MIN;
9666                 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9667                    will cast our (long double) to (double) */
9668                 (void)Perl_frexp(nv, &i);
9669                 if (i == PERL_INT_MIN)
9670                     Perl_die(aTHX_ "panic: frexp");
9671                 if (i > 0)
9672                     need = BIT_DIGITS(i);
9673             }
9674             need += has_precis ? precis : 6; /* known default */
9675
9676             if (need < width)
9677                 need = width;
9678
9679 #ifdef HAS_LDBL_SPRINTF_BUG
9680             /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9681                with sfio - Allen <allens@cpan.org> */
9682
9683 #  ifdef DBL_MAX
9684 #    define MY_DBL_MAX DBL_MAX
9685 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9686 #    if DOUBLESIZE >= 8
9687 #      define MY_DBL_MAX 1.7976931348623157E+308L
9688 #    else
9689 #      define MY_DBL_MAX 3.40282347E+38L
9690 #    endif
9691 #  endif
9692
9693 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9694 #    define MY_DBL_MAX_BUG 1L
9695 #  else
9696 #    define MY_DBL_MAX_BUG MY_DBL_MAX
9697 #  endif
9698
9699 #  ifdef DBL_MIN
9700 #    define MY_DBL_MIN DBL_MIN
9701 #  else  /* XXX guessing! -Allen */
9702 #    if DOUBLESIZE >= 8
9703 #      define MY_DBL_MIN 2.2250738585072014E-308L
9704 #    else
9705 #      define MY_DBL_MIN 1.17549435E-38L
9706 #    endif
9707 #  endif
9708
9709             if ((intsize == 'q') && (c == 'f') &&
9710                 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9711                 (need < DBL_DIG)) {
9712                 /* it's going to be short enough that
9713                  * long double precision is not needed */
9714
9715                 if ((nv <= 0L) && (nv >= -0L))
9716                     fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9717                 else {
9718                     /* would use Perl_fp_class as a double-check but not
9719                      * functional on IRIX - see perl.h comments */
9720
9721                     if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9722                         /* It's within the range that a double can represent */
9723 #if defined(DBL_MAX) && !defined(DBL_MIN)
9724                         if ((nv >= ((long double)1/DBL_MAX)) ||
9725                             (nv <= (-(long double)1/DBL_MAX)))
9726 #endif
9727                         fix_ldbl_sprintf_bug = TRUE;
9728                     }
9729                 }
9730                 if (fix_ldbl_sprintf_bug == TRUE) {
9731                     double temp;
9732
9733                     intsize = 0;
9734                     temp = (double)nv;
9735                     nv = (NV)temp;
9736                 }
9737             }
9738
9739 #  undef MY_DBL_MAX
9740 #  undef MY_DBL_MAX_BUG
9741 #  undef MY_DBL_MIN
9742
9743 #endif /* HAS_LDBL_SPRINTF_BUG */
9744
9745             need += 20; /* fudge factor */
9746             if (PL_efloatsize < need) {
9747                 Safefree(PL_efloatbuf);
9748                 PL_efloatsize = need + 20; /* more fudge */
9749                 Newx(PL_efloatbuf, PL_efloatsize, char);
9750                 PL_efloatbuf[0] = '\0';
9751             }
9752
9753             if ( !(width || left || plus || alt) && fill != '0'
9754                  && has_precis && intsize != 'q' ) {    /* Shortcuts */
9755                 /* See earlier comment about buggy Gconvert when digits,
9756                    aka precis is 0  */
9757                 if ( c == 'g' && precis) {
9758                     Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9759                     /* May return an empty string for digits==0 */
9760                     if (*PL_efloatbuf) {
9761                         elen = strlen(PL_efloatbuf);
9762                         goto float_converted;
9763                     }
9764                 } else if ( c == 'f' && !precis) {
9765                     if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9766                         break;
9767                 }
9768             }
9769             {
9770                 char *ptr = ebuf + sizeof ebuf;
9771                 *--ptr = '\0';
9772                 *--ptr = c;
9773                 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9774 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9775                 if (intsize == 'q') {
9776                     /* Copy the one or more characters in a long double
9777                      * format before the 'base' ([efgEFG]) character to
9778                      * the format string. */
9779                     static char const prifldbl[] = PERL_PRIfldbl;
9780                     char const *p = prifldbl + sizeof(prifldbl) - 3;
9781                     while (p >= prifldbl) { *--ptr = *p--; }
9782                 }
9783 #endif
9784                 if (has_precis) {
9785                     base = precis;
9786                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
9787                     *--ptr = '.';
9788                 }
9789                 if (width) {
9790                     base = width;
9791                     do { *--ptr = '0' + (base % 10); } while (base /= 10);
9792                 }
9793                 if (fill == '0')
9794                     *--ptr = fill;
9795                 if (left)
9796                     *--ptr = '-';
9797                 if (plus)
9798                     *--ptr = plus;
9799                 if (alt)
9800                     *--ptr = '#';
9801                 *--ptr = '%';
9802
9803                 /* No taint.  Otherwise we are in the strange situation
9804                  * where printf() taints but print($float) doesn't.
9805                  * --jhi */
9806 #if defined(HAS_LONG_DOUBLE)
9807                 elen = ((intsize == 'q')
9808                         ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
9809                         : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
9810 #else
9811                 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9812 #endif
9813             }
9814         float_converted:
9815             eptr = PL_efloatbuf;
9816             break;
9817
9818             /* SPECIAL */
9819
9820         case 'n':
9821             if (vectorize)
9822                 goto unknown;
9823             i = SvCUR(sv) - origlen;
9824             if (args) {
9825                 switch (intsize) {
9826                 case 'h':       *(va_arg(*args, short*)) = i; break;
9827                 default:        *(va_arg(*args, int*)) = i; break;
9828                 case 'l':       *(va_arg(*args, long*)) = i; break;
9829                 case 'V':       *(va_arg(*args, IV*)) = i; break;
9830 #ifdef HAS_QUAD
9831                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
9832 #endif
9833                 }
9834             }
9835             else
9836                 sv_setuv_mg(argsv, (UV)i);
9837             continue;   /* not "break" */
9838
9839             /* UNKNOWN */
9840
9841         default:
9842       unknown:
9843             if (!args
9844                 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9845                 && ckWARN(WARN_PRINTF))
9846             {
9847                 SV * const msg = sv_newmortal();
9848                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9849                           (PL_op->op_type == OP_PRTF) ? "" : "s");
9850                 if (c) {
9851                     if (isPRINT(c))
9852                         Perl_sv_catpvf(aTHX_ msg,
9853                                        "\"%%%c\"", c & 0xFF);
9854                     else
9855                         Perl_sv_catpvf(aTHX_ msg,
9856                                        "\"%%\\%03"UVof"\"",
9857                                        (UV)c & 0xFF);
9858                 } else
9859                     sv_catpvs(msg, "end of string");
9860                 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
9861             }
9862
9863             /* output mangled stuff ... */
9864             if (c == '\0')
9865                 --q;
9866             eptr = p;
9867             elen = q - p;
9868
9869             /* ... right here, because formatting flags should not apply */
9870             SvGROW(sv, SvCUR(sv) + elen + 1);
9871             p = SvEND(sv);
9872             Copy(eptr, p, elen, char);
9873             p += elen;
9874             *p = '\0';
9875             SvCUR_set(sv, p - SvPVX_const(sv));
9876             svix = osvix;
9877             continue;   /* not "break" */
9878         }
9879
9880         if (is_utf8 != has_utf8) {
9881             if (is_utf8) {
9882                 if (SvCUR(sv))
9883                     sv_utf8_upgrade(sv);
9884             }
9885             else {
9886                 const STRLEN old_elen = elen;
9887                 SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP);
9888                 sv_utf8_upgrade(nsv);
9889                 eptr = SvPVX_const(nsv);
9890                 elen = SvCUR(nsv);
9891
9892                 if (width) { /* fudge width (can't fudge elen) */
9893                     width += elen - old_elen;
9894                 }
9895                 is_utf8 = TRUE;
9896             }
9897         }
9898
9899         have = esignlen + zeros + elen;
9900         if (have < zeros)
9901             Perl_croak_nocontext(PL_memory_wrap);
9902
9903         need = (have > width ? have : width);
9904         gap = need - have;
9905
9906         if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
9907             Perl_croak_nocontext(PL_memory_wrap);
9908         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9909         p = SvEND(sv);
9910         if (esignlen && fill == '0') {
9911             int i;
9912             for (i = 0; i < (int)esignlen; i++)
9913                 *p++ = esignbuf[i];
9914         }
9915         if (gap && !left) {
9916             memset(p, fill, gap);
9917             p += gap;
9918         }
9919         if (esignlen && fill != '0') {
9920             int i;
9921             for (i = 0; i < (int)esignlen; i++)
9922                 *p++ = esignbuf[i];
9923         }
9924         if (zeros) {
9925             int i;
9926             for (i = zeros; i; i--)
9927                 *p++ = '0';
9928         }
9929         if (elen) {
9930             Copy(eptr, p, elen, char);
9931             p += elen;
9932         }
9933         if (gap && left) {
9934             memset(p, ' ', gap);
9935             p += gap;
9936         }
9937         if (vectorize) {
9938             if (veclen) {
9939                 Copy(dotstr, p, dotstrlen, char);
9940                 p += dotstrlen;
9941             }
9942             else
9943                 vectorize = FALSE;              /* done iterating over vecstr */
9944         }
9945         if (is_utf8)
9946             has_utf8 = TRUE;
9947         if (has_utf8)
9948             SvUTF8_on(sv);
9949         *p = '\0';
9950         SvCUR_set(sv, p - SvPVX_const(sv));
9951         if (vectorize) {
9952             esignlen = 0;
9953             goto vector;
9954         }
9955     }
9956 }
9957
9958 /* =========================================================================
9959
9960 =head1 Cloning an interpreter
9961
9962 All the macros and functions in this section are for the private use of
9963 the main function, perl_clone().
9964
9965 The foo_dup() functions make an exact copy of an existing foo thingy.
9966 During the course of a cloning, a hash table is used to map old addresses
9967 to new addresses. The table is created and manipulated with the
9968 ptr_table_* functions.
9969
9970 =cut
9971
9972 ============================================================================*/
9973
9974
9975 #if defined(USE_ITHREADS)
9976
9977 /* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
9978 #ifndef GpREFCNT_inc
9979 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9980 #endif
9981
9982
9983 /* Certain cases in Perl_ss_dup have been merged, by relying on the fact
9984    that currently av_dup, gv_dup and hv_dup are the same as sv_dup.
9985    If this changes, please unmerge ss_dup.  */
9986 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9987 #define sv_dup_inc_NN(s,t)      SvREFCNT_inc_NN(sv_dup(s,t))
9988 #define av_dup(s,t)     (AV*)sv_dup((SV*)s,t)
9989 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9990 #define hv_dup(s,t)     (HV*)sv_dup((SV*)s,t)
9991 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9992 #define cv_dup(s,t)     (CV*)sv_dup((SV*)s,t)
9993 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9994 #define io_dup(s,t)     (IO*)sv_dup((SV*)s,t)
9995 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9996 #define gv_dup(s,t)     (GV*)sv_dup((SV*)s,t)
9997 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9998 #define SAVEPV(p)       ((p) ? savepv(p) : NULL)
9999 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
10000
10001 /* clone a parser */
10002
10003 yy_parser *
10004 Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
10005 {
10006     yy_parser *parser;
10007
10008     PERL_ARGS_ASSERT_PARSER_DUP;
10009
10010     if (!proto)
10011         return NULL;
10012
10013     /* look for it in the table first */
10014     parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto);
10015     if (parser)
10016         return parser;
10017
10018     /* create anew and remember what it is */
10019     Newxz(parser, 1, yy_parser);
10020     ptr_table_store(PL_ptr_table, proto, parser);
10021
10022     parser->yyerrstatus = 0;
10023     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
10024
10025     /* XXX these not yet duped */
10026     parser->old_parser = NULL;
10027     parser->stack = NULL;
10028     parser->ps = NULL;
10029     parser->stack_size = 0;
10030     /* XXX parser->stack->state = 0; */
10031
10032     /* XXX eventually, just Copy() most of the parser struct ? */
10033
10034     parser->lex_brackets = proto->lex_brackets;
10035     parser->lex_casemods = proto->lex_casemods;
10036     parser->lex_brackstack = savepvn(proto->lex_brackstack,
10037                     (proto->lex_brackets < 120 ? 120 : proto->lex_brackets));
10038     parser->lex_casestack = savepvn(proto->lex_casestack,
10039                     (proto->lex_casemods < 12 ? 12 : proto->lex_casemods));
10040     parser->lex_defer   = proto->lex_defer;
10041     parser->lex_dojoin  = proto->lex_dojoin;
10042     parser->lex_expect  = proto->lex_expect;
10043     parser->lex_formbrack = proto->lex_formbrack;
10044     parser->lex_inpat   = proto->lex_inpat;
10045     parser->lex_inwhat  = proto->lex_inwhat;
10046     parser->lex_op      = proto->lex_op;
10047     parser->lex_repl    = sv_dup_inc(proto->lex_repl, param);
10048     parser->lex_starts  = proto->lex_starts;
10049     parser->lex_stuff   = sv_dup_inc(proto->lex_stuff, param);
10050     parser->multi_close = proto->multi_close;
10051     parser->multi_open  = proto->multi_open;
10052     parser->multi_start = proto->multi_start;
10053     parser->multi_end   = proto->multi_end;
10054     parser->pending_ident = proto->pending_ident;
10055     parser->preambled   = proto->preambled;
10056     parser->sublex_info = proto->sublex_info; /* XXX not quite right */
10057     parser->linestr     = sv_dup_inc(proto->linestr, param);
10058     parser->expect      = proto->expect;
10059     parser->copline     = proto->copline;
10060     parser->last_lop_op = proto->last_lop_op;
10061     parser->lex_state   = proto->lex_state;
10062     parser->rsfp        = fp_dup(proto->rsfp, '<', param);
10063     /* rsfp_filters entries have fake IoDIRP() */
10064     parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param);
10065     parser->in_my       = proto->in_my;
10066     parser->in_my_stash = hv_dup(proto->in_my_stash, param);
10067     parser->error_count = proto->error_count;
10068
10069
10070     parser->linestr     = sv_dup_inc(proto->linestr, param);
10071
10072     {
10073         char * const ols = SvPVX(proto->linestr);
10074         char * const ls  = SvPVX(parser->linestr);
10075
10076         parser->bufptr      = ls + (proto->bufptr >= ols ?
10077                                     proto->bufptr -  ols : 0);
10078         parser->oldbufptr   = ls + (proto->oldbufptr >= ols ?
10079                                     proto->oldbufptr -  ols : 0);
10080         parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ?
10081                                     proto->oldoldbufptr -  ols : 0);
10082         parser->linestart   = ls + (proto->linestart >= ols ?
10083                                     proto->linestart -  ols : 0);
10084         parser->last_uni    = ls + (proto->last_uni >= ols ?
10085                                     proto->last_uni -  ols : 0);
10086         parser->last_lop    = ls + (proto->last_lop >= ols ?
10087                                     proto->last_lop -  ols : 0);
10088
10089         parser->bufend      = ls + SvCUR(parser->linestr);
10090     }
10091
10092     Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
10093
10094
10095 #ifdef PERL_MAD
10096     parser->endwhite    = proto->endwhite;
10097     parser->faketokens  = proto->faketokens;
10098     parser->lasttoke    = proto->lasttoke;
10099     parser->nextwhite   = proto->nextwhite;
10100     parser->realtokenstart = proto->realtokenstart;
10101     parser->skipwhite   = proto->skipwhite;
10102     parser->thisclose   = proto->thisclose;
10103     parser->thismad     = proto->thismad;
10104     parser->thisopen    = proto->thisopen;
10105     parser->thisstuff   = proto->thisstuff;
10106     parser->thistoken   = proto->thistoken;
10107     parser->thiswhite   = proto->thiswhite;
10108
10109     Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
10110     parser->curforce    = proto->curforce;
10111 #else
10112     Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
10113     Copy(proto->nexttype, parser->nexttype, 5,  I32);
10114     parser->nexttoke    = proto->nexttoke;
10115 #endif
10116     return parser;
10117 }
10118
10119
10120 /* duplicate a file handle */
10121
10122 PerlIO *
10123 Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param)
10124 {
10125     PerlIO *ret;
10126
10127     PERL_ARGS_ASSERT_FP_DUP;
10128     PERL_UNUSED_ARG(type);
10129
10130     if (!fp)
10131         return (PerlIO*)NULL;
10132
10133     /* look for it in the table first */
10134     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
10135     if (ret)
10136         return ret;
10137
10138     /* create anew and remember what it is */
10139     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
10140     ptr_table_store(PL_ptr_table, fp, ret);
10141     return ret;
10142 }
10143
10144 /* duplicate a directory handle */
10145
10146 DIR *
10147 Perl_dirp_dup(pTHX_ DIR *const dp)
10148 {
10149     PERL_UNUSED_CONTEXT;
10150     if (!dp)
10151         return (DIR*)NULL;
10152     /* XXX TODO */
10153     return dp;
10154 }
10155
10156 /* duplicate a typeglob */
10157
10158 GP *
10159 Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param)
10160 {
10161     GP *ret;
10162
10163     PERL_ARGS_ASSERT_GP_DUP;
10164
10165     if (!gp)
10166         return (GP*)NULL;
10167     /* look for it in the table first */
10168     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
10169     if (ret)
10170         return ret;
10171
10172     /* create anew and remember what it is */
10173     Newxz(ret, 1, GP);
10174     ptr_table_store(PL_ptr_table, gp, ret);
10175
10176     /* clone */
10177     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
10178     ret->gp_sv          = sv_dup_inc(gp->gp_sv, param);
10179     ret->gp_io          = io_dup_inc(gp->gp_io, param);
10180     ret->gp_form        = cv_dup_inc(gp->gp_form, param);
10181     ret->gp_av          = av_dup_inc(gp->gp_av, param);
10182     ret->gp_hv          = hv_dup_inc(gp->gp_hv, param);
10183     ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
10184     ret->gp_cv          = cv_dup_inc(gp->gp_cv, param);
10185     ret->gp_cvgen       = gp->gp_cvgen;
10186     ret->gp_line        = gp->gp_line;
10187     ret->gp_file_hek    = hek_dup(gp->gp_file_hek, param);
10188     return ret;
10189 }
10190
10191 /* duplicate a chain of magic */
10192
10193 MAGIC *
10194 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param)
10195 {
10196     MAGIC *mgprev = (MAGIC*)NULL;
10197     MAGIC *mgret;
10198
10199     PERL_ARGS_ASSERT_MG_DUP;
10200
10201     if (!mg)
10202         return (MAGIC*)NULL;
10203     /* look for it in the table first */
10204     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
10205     if (mgret)
10206         return mgret;
10207
10208     for (; mg; mg = mg->mg_moremagic) {
10209         MAGIC *nmg;
10210         Newxz(nmg, 1, MAGIC);
10211         if (mgprev)
10212             mgprev->mg_moremagic = nmg;
10213         else
10214             mgret = nmg;
10215         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
10216         nmg->mg_private = mg->mg_private;
10217         nmg->mg_type    = mg->mg_type;
10218         nmg->mg_flags   = mg->mg_flags;
10219         /* FIXME for plugins
10220         if (mg->mg_type == PERL_MAGIC_qr) {
10221             nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
10222         }
10223         else
10224         */
10225         if(mg->mg_type == PERL_MAGIC_backref) {
10226             /* The backref AV has its reference count deliberately bumped by
10227                1.  */
10228             nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
10229         }
10230         else {
10231             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
10232                               ? sv_dup_inc(mg->mg_obj, param)
10233                               : sv_dup(mg->mg_obj, param);
10234         }
10235         nmg->mg_len     = mg->mg_len;
10236         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
10237         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
10238             if (mg->mg_len > 0) {
10239                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
10240                 if (mg->mg_type == PERL_MAGIC_overload_table &&
10241                         AMT_AMAGIC((AMT*)mg->mg_ptr))
10242                 {
10243                     const AMT * const amtp = (AMT*)mg->mg_ptr;
10244                     AMT * const namtp = (AMT*)nmg->mg_ptr;
10245                     I32 i;
10246                     for (i = 1; i < NofAMmeth; i++) {
10247                         namtp->table[i] = cv_dup_inc(amtp->table[i], param);
10248                     }
10249                 }
10250             }
10251             else if (mg->mg_len == HEf_SVKEY)
10252                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
10253         }
10254         if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
10255             CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
10256         }
10257         mgprev = nmg;
10258     }
10259     return mgret;
10260 }
10261
10262 #endif /* USE_ITHREADS */
10263
10264 /* create a new pointer-mapping table */
10265
10266 PTR_TBL_t *
10267 Perl_ptr_table_new(pTHX)
10268 {
10269     PTR_TBL_t *tbl;
10270     PERL_UNUSED_CONTEXT;
10271
10272     Newxz(tbl, 1, PTR_TBL_t);
10273     tbl->tbl_max        = 511;
10274     tbl->tbl_items      = 0;
10275     Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
10276     return tbl;
10277 }
10278
10279 #define PTR_TABLE_HASH(ptr) \
10280   ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17)))
10281
10282 /* 
10283    we use the PTE_SVSLOT 'reservation' made above, both here (in the
10284    following define) and at call to new_body_inline made below in 
10285    Perl_ptr_table_store()
10286  */
10287
10288 #define del_pte(p)     del_body_type(p, PTE_SVSLOT)
10289
10290 /* map an existing pointer using a table */
10291
10292 STATIC PTR_TBL_ENT_t *
10293 S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv)
10294 {
10295     PTR_TBL_ENT_t *tblent;
10296     const UV hash = PTR_TABLE_HASH(sv);
10297
10298     PERL_ARGS_ASSERT_PTR_TABLE_FIND;
10299
10300     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
10301     for (; tblent; tblent = tblent->next) {
10302         if (tblent->oldval == sv)
10303             return tblent;
10304     }
10305     return NULL;
10306 }
10307
10308 void *
10309 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv)
10310 {
10311     PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
10312
10313     PERL_ARGS_ASSERT_PTR_TABLE_FETCH;
10314     PERL_UNUSED_CONTEXT;
10315
10316     return tblent ? tblent->newval : NULL;
10317 }
10318
10319 /* add a new entry to a pointer-mapping table */
10320
10321 void
10322 Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
10323 {
10324     PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv);
10325
10326     PERL_ARGS_ASSERT_PTR_TABLE_STORE;
10327     PERL_UNUSED_CONTEXT;
10328
10329     if (tblent) {
10330         tblent->newval = newsv;
10331     } else {
10332         const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max;
10333
10334         new_body_inline(tblent, PTE_SVSLOT);
10335
10336         tblent->oldval = oldsv;
10337         tblent->newval = newsv;
10338         tblent->next = tbl->tbl_ary[entry];
10339         tbl->tbl_ary[entry] = tblent;
10340         tbl->tbl_items++;
10341         if (tblent->next && tbl->tbl_items > tbl->tbl_max)
10342             ptr_table_split(tbl);
10343     }
10344 }
10345
10346 /* double the hash bucket size of an existing ptr table */
10347
10348 void
10349 Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl)
10350 {
10351     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
10352     const UV oldsize = tbl->tbl_max + 1;
10353     UV newsize = oldsize * 2;
10354     UV i;
10355
10356     PERL_ARGS_ASSERT_PTR_TABLE_SPLIT;
10357     PERL_UNUSED_CONTEXT;
10358
10359     Renew(ary, newsize, PTR_TBL_ENT_t*);
10360     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
10361     tbl->tbl_max = --newsize;
10362     tbl->tbl_ary = ary;
10363     for (i=0; i < oldsize; i++, ary++) {
10364         PTR_TBL_ENT_t **curentp, **entp, *ent;
10365         if (!*ary)
10366             continue;
10367         curentp = ary + oldsize;
10368         for (entp = ary, ent = *ary; ent; ent = *entp) {
10369             if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
10370                 *entp = ent->next;
10371                 ent->next = *curentp;
10372                 *curentp = ent;
10373                 continue;
10374             }
10375             else
10376                 entp = &ent->next;
10377         }
10378     }
10379 }
10380
10381 /* remove all the entries from a ptr table */
10382
10383 void
10384 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
10385 {
10386     if (tbl && tbl->tbl_items) {
10387         register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary;
10388         UV riter = tbl->tbl_max;
10389
10390         do {
10391             PTR_TBL_ENT_t *entry = array[riter];
10392
10393             while (entry) {
10394                 PTR_TBL_ENT_t * const oentry = entry;
10395                 entry = entry->next;
10396                 del_pte(oentry);
10397             }
10398         } while (riter--);
10399
10400         tbl->tbl_items = 0;
10401     }
10402 }
10403
10404 /* clear and free a ptr table */
10405
10406 void
10407 Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl)
10408 {
10409     if (!tbl) {
10410         return;
10411     }
10412     ptr_table_clear(tbl);
10413     Safefree(tbl->tbl_ary);
10414     Safefree(tbl);
10415 }
10416
10417 #if defined(USE_ITHREADS)
10418
10419 void
10420 Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param)
10421 {
10422     PERL_ARGS_ASSERT_RVPV_DUP;
10423
10424     if (SvROK(sstr)) {
10425         SvRV_set(dstr, SvWEAKREF(sstr)
10426                        ? sv_dup(SvRV(sstr), param)
10427                        : sv_dup_inc(SvRV(sstr), param));
10428
10429     }
10430     else if (SvPVX_const(sstr)) {
10431         /* Has something there */
10432         if (SvLEN(sstr)) {
10433             /* Normal PV - clone whole allocated space */
10434             SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
10435             if (SvREADONLY(sstr) && SvFAKE(sstr)) {
10436                 /* Not that normal - actually sstr is copy on write.
10437                    But we are a true, independant SV, so:  */
10438                 SvREADONLY_off(dstr);
10439                 SvFAKE_off(dstr);
10440             }
10441         }
10442         else {
10443             /* Special case - not normally malloced for some reason */
10444             if (isGV_with_GP(sstr)) {
10445                 /* Don't need to do anything here.  */
10446             }
10447             else if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
10448                 /* A "shared" PV - clone it as "shared" PV */
10449                 SvPV_set(dstr,
10450                          HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
10451                                          param)));
10452             }
10453             else {
10454                 /* Some other special case - random pointer */
10455                 SvPV_set(dstr, SvPVX(sstr));            
10456             }
10457         }
10458     }
10459     else {
10460         /* Copy the NULL */
10461         SvPV_set(dstr, NULL);
10462     }
10463 }
10464
10465 /* duplicate an SV of any type (including AV, HV etc) */
10466
10467 SV *
10468 Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
10469 {
10470     dVAR;
10471     SV *dstr;
10472
10473     PERL_ARGS_ASSERT_SV_DUP;
10474
10475     if (!sstr)
10476         return NULL;
10477     if (SvTYPE(sstr) == SVTYPEMASK) {
10478 #ifdef DEBUG_LEAKING_SCALARS_ABORT
10479         abort();
10480 #endif
10481         return NULL;
10482     }
10483     /* look for it in the table first */
10484     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
10485     if (dstr)
10486         return dstr;
10487
10488     if(param->flags & CLONEf_JOIN_IN) {
10489         /** We are joining here so we don't want do clone
10490             something that is bad **/
10491         if (SvTYPE(sstr) == SVt_PVHV) {
10492             const HEK * const hvname = HvNAME_HEK(sstr);
10493             if (hvname)
10494                 /** don't clone stashes if they already exist **/
10495                 return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0);
10496         }
10497     }
10498
10499     /* create anew and remember what it is */
10500     new_SV(dstr);
10501
10502 #ifdef DEBUG_LEAKING_SCALARS
10503     dstr->sv_debug_optype = sstr->sv_debug_optype;
10504     dstr->sv_debug_line = sstr->sv_debug_line;
10505     dstr->sv_debug_inpad = sstr->sv_debug_inpad;
10506     dstr->sv_debug_cloned = 1;
10507     dstr->sv_debug_file = savepv(sstr->sv_debug_file);
10508 #endif
10509
10510     ptr_table_store(PL_ptr_table, sstr, dstr);
10511
10512     /* clone */
10513     SvFLAGS(dstr)       = SvFLAGS(sstr);
10514     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
10515     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
10516
10517 #ifdef DEBUGGING
10518     if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
10519         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10520                       (void*)PL_watch_pvx, SvPVX_const(sstr));
10521 #endif
10522
10523     /* don't clone objects whose class has asked us not to */
10524     if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
10525         SvFLAGS(dstr) = 0;
10526         return dstr;
10527     }
10528
10529     switch (SvTYPE(sstr)) {
10530     case SVt_NULL:
10531         SvANY(dstr)     = NULL;
10532         break;
10533     case SVt_IV:
10534         SvANY(dstr)     = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
10535         if(SvROK(sstr)) {
10536             Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10537         } else {
10538             SvIV_set(dstr, SvIVX(sstr));
10539         }
10540         break;
10541     case SVt_NV:
10542         SvANY(dstr)     = new_XNV();
10543         SvNV_set(dstr, SvNVX(sstr));
10544         break;
10545         /* case SVt_BIND: */
10546     default:
10547         {
10548             /* These are all the types that need complex bodies allocating.  */
10549             void *new_body;
10550             const svtype sv_type = SvTYPE(sstr);
10551             const struct body_details *const sv_type_details
10552                 = bodies_by_type + sv_type;
10553
10554             switch (sv_type) {
10555             default:
10556                 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10557                 break;
10558
10559             case SVt_PVGV:
10560                 if (GvUNIQUE((GV*)sstr)) {
10561                     NOOP;   /* Do sharing here, and fall through */
10562                 }
10563             case SVt_PVIO:
10564             case SVt_PVFM:
10565             case SVt_PVHV:
10566             case SVt_PVAV:
10567             case SVt_PVCV:
10568             case SVt_PVLV:
10569             case SVt_REGEXP:
10570             case SVt_PVMG:
10571             case SVt_PVNV:
10572             case SVt_PVIV:
10573             case SVt_PV:
10574                 assert(sv_type_details->body_size);
10575                 if (sv_type_details->arena) {
10576                     new_body_inline(new_body, sv_type);
10577                     new_body
10578                         = (void*)((char*)new_body - sv_type_details->offset);
10579                 } else {
10580                     new_body = new_NOARENA(sv_type_details);
10581                 }
10582             }
10583             assert(new_body);
10584             SvANY(dstr) = new_body;
10585
10586 #ifndef PURIFY
10587             Copy(((char*)SvANY(sstr)) + sv_type_details->offset,
10588                  ((char*)SvANY(dstr)) + sv_type_details->offset,
10589                  sv_type_details->copy, char);
10590 #else
10591             Copy(((char*)SvANY(sstr)),
10592                  ((char*)SvANY(dstr)),
10593                  sv_type_details->body_size + sv_type_details->offset, char);
10594 #endif
10595
10596             if (sv_type != SVt_PVAV && sv_type != SVt_PVHV
10597                 && !isGV_with_GP(dstr))
10598                 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10599
10600             /* The Copy above means that all the source (unduplicated) pointers
10601                are now in the destination.  We can check the flags and the
10602                pointers in either, but it's possible that there's less cache
10603                missing by always going for the destination.
10604                FIXME - instrument and check that assumption  */
10605             if (sv_type >= SVt_PVMG) {
10606                 if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
10607                     SvOURSTASH_set(dstr, hv_dup_inc(SvOURSTASH(dstr), param));
10608                 } else if (SvMAGIC(dstr))
10609                     SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10610                 if (SvSTASH(dstr))
10611                     SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10612             }
10613
10614             /* The cast silences a GCC warning about unhandled types.  */
10615             switch ((int)sv_type) {
10616             case SVt_PV:
10617                 break;
10618             case SVt_PVIV:
10619                 break;
10620             case SVt_PVNV:
10621                 break;
10622             case SVt_PVMG:
10623                 break;
10624             case SVt_REGEXP:
10625                 /* FIXME for plugins */
10626                 re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param);
10627                 break;
10628             case SVt_PVLV:
10629                 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10630                 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10631                     LvTARG(dstr) = dstr;
10632                 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10633                     LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10634                 else
10635                     LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10636             case SVt_PVGV:
10637                 if(isGV_with_GP(sstr)) {
10638                     if (GvNAME_HEK(dstr))
10639                         GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param);
10640                     /* Don't call sv_add_backref here as it's going to be
10641                        created as part of the magic cloning of the symbol
10642                        table.  */
10643                     /* Danger Will Robinson - GvGP(dstr) isn't initialised
10644                        at the point of this comment.  */
10645                     GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10646                     GvGP(dstr)  = gp_dup(GvGP(sstr), param);
10647                     (void)GpREFCNT_inc(GvGP(dstr));
10648                 } else
10649                     Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10650                 break;
10651             case SVt_PVIO:
10652                 IoIFP(dstr)     = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10653                 if (IoOFP(dstr) == IoIFP(sstr))
10654                     IoOFP(dstr) = IoIFP(dstr);
10655                 else
10656                     IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10657                 /* PL_parser->rsfp_filters entries have fake IoDIRP() */
10658                 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10659                     /* I have no idea why fake dirp (rsfps)
10660                        should be treated differently but otherwise
10661                        we end up with leaks -- sky*/
10662                     IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(dstr), param);
10663                     IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(dstr), param);
10664                     IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10665                 } else {
10666                     IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(dstr), param);
10667                     IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(dstr), param);
10668                     IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(dstr), param);
10669                     if (IoDIRP(dstr)) {
10670                         IoDIRP(dstr)    = dirp_dup(IoDIRP(dstr));
10671                     } else {
10672                         NOOP;
10673                         /* IoDIRP(dstr) is already a copy of IoDIRP(sstr)  */
10674                     }
10675                 }
10676                 IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(dstr));
10677                 IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(dstr));
10678                 IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(dstr));
10679                 break;
10680             case SVt_PVAV:
10681                 if (AvARRAY((AV*)sstr)) {
10682                     SV **dst_ary, **src_ary;
10683                     SSize_t items = AvFILLp((AV*)sstr) + 1;
10684
10685                     src_ary = AvARRAY((AV*)sstr);
10686                     Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10687                     ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10688                     AvARRAY((AV*)dstr) = dst_ary;
10689                     AvALLOC((AV*)dstr) = dst_ary;
10690                     if (AvREAL((AV*)sstr)) {
10691                         while (items-- > 0)
10692                             *dst_ary++ = sv_dup_inc(*src_ary++, param);
10693                     }
10694                     else {
10695                         while (items-- > 0)
10696                             *dst_ary++ = sv_dup(*src_ary++, param);
10697                     }
10698                     items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10699                     while (items-- > 0) {
10700                         *dst_ary++ = &PL_sv_undef;
10701                     }
10702                 }
10703                 else {
10704                     AvARRAY((AV*)dstr)  = NULL;
10705                     AvALLOC((AV*)dstr)  = (SV**)NULL;
10706                 }
10707                 break;
10708             case SVt_PVHV:
10709                 if (HvARRAY((HV*)sstr)) {
10710                     STRLEN i = 0;
10711                     const bool sharekeys = !!HvSHAREKEYS(sstr);
10712                     XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10713                     XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10714                     char *darray;
10715                     Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10716                         + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10717                         char);
10718                     HvARRAY(dstr) = (HE**)darray;
10719                     while (i <= sxhv->xhv_max) {
10720                         const HE * const source = HvARRAY(sstr)[i];
10721                         HvARRAY(dstr)[i] = source
10722                             ? he_dup(source, sharekeys, param) : 0;
10723                         ++i;
10724                     }
10725                     if (SvOOK(sstr)) {
10726                         HEK *hvname;
10727                         const struct xpvhv_aux * const saux = HvAUX(sstr);
10728                         struct xpvhv_aux * const daux = HvAUX(dstr);
10729                         /* This flag isn't copied.  */
10730                         /* SvOOK_on(hv) attacks the IV flags.  */
10731                         SvFLAGS(dstr) |= SVf_OOK;
10732
10733                         hvname = saux->xhv_name;
10734                         daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
10735
10736                         daux->xhv_riter = saux->xhv_riter;
10737                         daux->xhv_eiter = saux->xhv_eiter
10738                             ? he_dup(saux->xhv_eiter,
10739                                         (bool)!!HvSHAREKEYS(sstr), param) : 0;
10740                         daux->xhv_backreferences =
10741                             saux->xhv_backreferences
10742                                 ? (AV*) SvREFCNT_inc(
10743                                         sv_dup((SV*)saux->xhv_backreferences, param))
10744                                 : 0;
10745
10746                         daux->xhv_mro_meta = saux->xhv_mro_meta
10747                             ? mro_meta_dup(saux->xhv_mro_meta, param)
10748                             : 0;
10749
10750                         /* Record stashes for possible cloning in Perl_clone(). */
10751                         if (hvname)
10752                             av_push(param->stashes, dstr);
10753                     }
10754                 }
10755                 else
10756                     HvARRAY((HV*)dstr) = NULL;
10757                 break;
10758             case SVt_PVCV:
10759                 if (!(param->flags & CLONEf_COPY_STACKS)) {
10760                     CvDEPTH(dstr) = 0;
10761                 }
10762             case SVt_PVFM:
10763                 /* NOTE: not refcounted */
10764                 CvSTASH(dstr)   = hv_dup(CvSTASH(dstr), param);
10765                 OP_REFCNT_LOCK;
10766                 if (!CvISXSUB(dstr))
10767                     CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10768                 OP_REFCNT_UNLOCK;
10769                 if (CvCONST(dstr) && CvISXSUB(dstr)) {
10770                     CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10771                         SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10772                         sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10773                 }
10774                 /* don't dup if copying back - CvGV isn't refcounted, so the
10775                  * duped GV may never be freed. A bit of a hack! DAPM */
10776                 CvGV(dstr)      = (param->flags & CLONEf_JOIN_IN) ?
10777                     NULL : gv_dup(CvGV(dstr), param) ;
10778                 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10779                 CvOUTSIDE(dstr) =
10780                     CvWEAKOUTSIDE(sstr)
10781                     ? cv_dup(    CvOUTSIDE(dstr), param)
10782                     : cv_dup_inc(CvOUTSIDE(dstr), param);
10783                 if (!CvISXSUB(dstr))
10784                     CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10785                 break;
10786             }
10787         }
10788     }
10789
10790     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10791         ++PL_sv_objcount;
10792
10793     return dstr;
10794  }
10795
10796 /* duplicate a context */
10797
10798 PERL_CONTEXT *
10799 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10800 {
10801     PERL_CONTEXT *ncxs;
10802
10803     PERL_ARGS_ASSERT_CX_DUP;
10804
10805     if (!cxs)
10806         return (PERL_CONTEXT*)NULL;
10807
10808     /* look for it in the table first */
10809     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10810     if (ncxs)
10811         return ncxs;
10812
10813     /* create anew and remember what it is */
10814     Newx(ncxs, max + 1, PERL_CONTEXT);
10815     ptr_table_store(PL_ptr_table, cxs, ncxs);
10816     Copy(cxs, ncxs, max + 1, PERL_CONTEXT);
10817
10818     while (ix >= 0) {
10819         PERL_CONTEXT * const ncx = &ncxs[ix];
10820         if (CxTYPE(ncx) == CXt_SUBST) {
10821             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10822         }
10823         else {
10824             switch (CxTYPE(ncx)) {
10825             case CXt_SUB:
10826                 ncx->blk_sub.cv         = (ncx->blk_sub.olddepth == 0
10827                                            ? cv_dup_inc(ncx->blk_sub.cv, param)
10828                                            : cv_dup(ncx->blk_sub.cv,param));
10829                 ncx->blk_sub.argarray   = (CxHASARGS(ncx)
10830                                            ? av_dup_inc(ncx->blk_sub.argarray,
10831                                                         param)
10832                                            : NULL);
10833                 ncx->blk_sub.savearray  = av_dup_inc(ncx->blk_sub.savearray,
10834                                                      param);
10835                 ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
10836                                            ncx->blk_sub.oldcomppad);
10837                 break;
10838             case CXt_EVAL:
10839                 ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
10840                                                       param);
10841                 ncx->blk_eval.cur_text  = sv_dup(ncx->blk_eval.cur_text, param);
10842                 break;
10843             case CXt_LOOP_LAZYSV:
10844                 ncx->blk_loop.state_u.lazysv.end
10845                     = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
10846                 /* We are taking advantage of av_dup_inc and sv_dup_inc
10847                    actually being the same function, and order equivalance of
10848                    the two unions.
10849                    We can assert the later [but only at run time :-(]  */
10850                 assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
10851                         (void *) &ncx->blk_loop.state_u.lazysv.cur);
10852             case CXt_LOOP_FOR:
10853                 ncx->blk_loop.state_u.ary.ary
10854                     = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
10855             case CXt_LOOP_LAZYIV:
10856             case CXt_LOOP_PLAIN:
10857                 if (CxPADLOOP(ncx)) {
10858                     ncx->blk_loop.oldcomppad
10859                         = (PAD*)ptr_table_fetch(PL_ptr_table,
10860                                                 ncx->blk_loop.oldcomppad);
10861                 } else {
10862                     ncx->blk_loop.oldcomppad
10863                         = (PAD*)gv_dup((GV*)ncx->blk_loop.oldcomppad, param);
10864                 }
10865                 break;
10866             case CXt_FORMAT:
10867                 ncx->blk_format.cv      = cv_dup(ncx->blk_format.cv, param);
10868                 ncx->blk_format.gv      = gv_dup(ncx->blk_format.gv, param);
10869                 ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
10870                                                      param);
10871                 break;
10872             case CXt_BLOCK:
10873             case CXt_NULL:
10874                 break;
10875             }
10876         }
10877         --ix;
10878     }
10879     return ncxs;
10880 }
10881
10882 /* duplicate a stack info structure */
10883
10884 PERL_SI *
10885 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10886 {
10887     PERL_SI *nsi;
10888
10889     PERL_ARGS_ASSERT_SI_DUP;
10890
10891     if (!si)
10892         return (PERL_SI*)NULL;
10893
10894     /* look for it in the table first */
10895     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10896     if (nsi)
10897         return nsi;
10898
10899     /* create anew and remember what it is */
10900     Newxz(nsi, 1, PERL_SI);
10901     ptr_table_store(PL_ptr_table, si, nsi);
10902
10903     nsi->si_stack       = av_dup_inc(si->si_stack, param);
10904     nsi->si_cxix        = si->si_cxix;
10905     nsi->si_cxmax       = si->si_cxmax;
10906     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10907     nsi->si_type        = si->si_type;
10908     nsi->si_prev        = si_dup(si->si_prev, param);
10909     nsi->si_next        = si_dup(si->si_next, param);
10910     nsi->si_markoff     = si->si_markoff;
10911
10912     return nsi;
10913 }
10914
10915 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
10916 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
10917 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
10918 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
10919 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
10920 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
10921 #define POPBOOL(ss,ix)  ((ss)[--(ix)].any_bool)
10922 #define TOPBOOL(ss,ix)  ((ss)[ix].any_bool)
10923 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
10924 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
10925 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
10926 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
10927 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10928 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10929
10930 /* XXXXX todo */
10931 #define pv_dup_inc(p)   SAVEPV(p)
10932 #define pv_dup(p)       SAVEPV(p)
10933 #define svp_dup_inc(p,pp)       any_dup(p,pp)
10934
10935 /* map any object to the new equivent - either something in the
10936  * ptr table, or something in the interpreter structure
10937  */
10938
10939 void *
10940 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10941 {
10942     void *ret;
10943
10944     PERL_ARGS_ASSERT_ANY_DUP;
10945
10946     if (!v)
10947         return (void*)NULL;
10948
10949     /* look for it in the table first */
10950     ret = ptr_table_fetch(PL_ptr_table, v);
10951     if (ret)
10952         return ret;
10953
10954     /* see if it is part of the interpreter structure */
10955     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10956         ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10957     else {
10958         ret = v;
10959     }
10960
10961     return ret;
10962 }
10963
10964 /* duplicate the save stack */
10965
10966 ANY *
10967 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10968 {
10969     dVAR;
10970     ANY * const ss      = proto_perl->Isavestack;
10971     const I32 max       = proto_perl->Isavestack_max;
10972     I32 ix              = proto_perl->Isavestack_ix;
10973     ANY *nss;
10974     SV *sv;
10975     GV *gv;
10976     AV *av;
10977     HV *hv;
10978     void* ptr;
10979     int intval;
10980     long longval;
10981     GP *gp;
10982     IV iv;
10983     I32 i;
10984     char *c = NULL;
10985     void (*dptr) (void*);
10986     void (*dxptr) (pTHX_ void*);
10987
10988     PERL_ARGS_ASSERT_SS_DUP;
10989
10990     Newxz(nss, max, ANY);
10991
10992     while (ix > 0) {
10993         const I32 type = POPINT(ss,ix);
10994         TOPINT(nss,ix) = type;
10995         switch (type) {
10996         case SAVEt_HELEM:               /* hash element */
10997             sv = (SV*)POPPTR(ss,ix);
10998             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10999             /* fall through */
11000         case SAVEt_ITEM:                        /* normal string */
11001         case SAVEt_SV:                          /* scalar reference */
11002             sv = (SV*)POPPTR(ss,ix);
11003             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11004             /* fall through */
11005         case SAVEt_FREESV:
11006         case SAVEt_MORTALIZESV:
11007             sv = (SV*)POPPTR(ss,ix);
11008             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11009             break;
11010         case SAVEt_SHARED_PVREF:                /* char* in shared space */
11011             c = (char*)POPPTR(ss,ix);
11012             TOPPTR(nss,ix) = savesharedpv(c);
11013             ptr = POPPTR(ss,ix);
11014             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11015             break;
11016         case SAVEt_GENERIC_SVREF:               /* generic sv */
11017         case SAVEt_SVREF:                       /* scalar reference */
11018             sv = (SV*)POPPTR(ss,ix);
11019             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11020             ptr = POPPTR(ss,ix);
11021             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
11022             break;
11023         case SAVEt_HV:                          /* hash reference */
11024         case SAVEt_AV:                          /* array reference */
11025             sv = (SV*) POPPTR(ss,ix);
11026             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11027             /* fall through */
11028         case SAVEt_COMPPAD:
11029         case SAVEt_NSTAB:
11030             sv = (SV*) POPPTR(ss,ix);
11031             TOPPTR(nss,ix) = sv_dup(sv, param);
11032             break;
11033         case SAVEt_INT:                         /* int reference */
11034             ptr = POPPTR(ss,ix);
11035             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11036             intval = (int)POPINT(ss,ix);
11037             TOPINT(nss,ix) = intval;
11038             break;
11039         case SAVEt_LONG:                        /* long reference */
11040             ptr = POPPTR(ss,ix);
11041             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11042             /* fall through */
11043         case SAVEt_CLEARSV:
11044             longval = (long)POPLONG(ss,ix);
11045             TOPLONG(nss,ix) = longval;
11046             break;
11047         case SAVEt_I32:                         /* I32 reference */
11048         case SAVEt_I16:                         /* I16 reference */
11049         case SAVEt_I8:                          /* I8 reference */
11050         case SAVEt_COP_ARYBASE:                 /* call CopARYBASE_set */
11051             ptr = POPPTR(ss,ix);
11052             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11053             i = POPINT(ss,ix);
11054             TOPINT(nss,ix) = i;
11055             break;
11056         case SAVEt_IV:                          /* IV reference */
11057             ptr = POPPTR(ss,ix);
11058             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11059             iv = POPIV(ss,ix);
11060             TOPIV(nss,ix) = iv;
11061             break;
11062         case SAVEt_HPTR:                        /* HV* reference */
11063         case SAVEt_APTR:                        /* AV* reference */
11064         case SAVEt_SPTR:                        /* SV* reference */
11065             ptr = POPPTR(ss,ix);
11066             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11067             sv = (SV*)POPPTR(ss,ix);
11068             TOPPTR(nss,ix) = sv_dup(sv, param);
11069             break;
11070         case SAVEt_VPTR:                        /* random* reference */
11071             ptr = POPPTR(ss,ix);
11072             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11073             ptr = POPPTR(ss,ix);
11074             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11075             break;
11076         case SAVEt_GENERIC_PVREF:               /* generic char* */
11077         case SAVEt_PPTR:                        /* char* reference */
11078             ptr = POPPTR(ss,ix);
11079             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11080             c = (char*)POPPTR(ss,ix);
11081             TOPPTR(nss,ix) = pv_dup(c);
11082             break;
11083         case SAVEt_GP:                          /* scalar reference */
11084             gp = (GP*)POPPTR(ss,ix);
11085             TOPPTR(nss,ix) = gp = gp_dup(gp, param);
11086             (void)GpREFCNT_inc(gp);
11087             gv = (GV*)POPPTR(ss,ix);
11088             TOPPTR(nss,ix) = gv_dup_inc(gv, param);
11089             break;
11090         case SAVEt_FREEOP:
11091             ptr = POPPTR(ss,ix);
11092             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
11093                 /* these are assumed to be refcounted properly */
11094                 OP *o;
11095                 switch (((OP*)ptr)->op_type) {
11096                 case OP_LEAVESUB:
11097                 case OP_LEAVESUBLV:
11098                 case OP_LEAVEEVAL:
11099                 case OP_LEAVE:
11100                 case OP_SCOPE:
11101                 case OP_LEAVEWRITE:
11102                     TOPPTR(nss,ix) = ptr;
11103                     o = (OP*)ptr;
11104                     OP_REFCNT_LOCK;
11105                     (void) OpREFCNT_inc(o);
11106                     OP_REFCNT_UNLOCK;
11107                     break;
11108                 default:
11109                     TOPPTR(nss,ix) = NULL;
11110                     break;
11111                 }
11112             }
11113             else
11114                 TOPPTR(nss,ix) = NULL;
11115             break;
11116         case SAVEt_FREEPV:
11117             c = (char*)POPPTR(ss,ix);
11118             TOPPTR(nss,ix) = pv_dup_inc(c);
11119             break;
11120         case SAVEt_DELETE:
11121             hv = (HV*)POPPTR(ss,ix);
11122             TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11123             c = (char*)POPPTR(ss,ix);
11124             TOPPTR(nss,ix) = pv_dup_inc(c);
11125             /* fall through */
11126         case SAVEt_STACK_POS:           /* Position on Perl stack */
11127             i = POPINT(ss,ix);
11128             TOPINT(nss,ix) = i;
11129             break;
11130         case SAVEt_DESTRUCTOR:
11131             ptr = POPPTR(ss,ix);
11132             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11133             dptr = POPDPTR(ss,ix);
11134             TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
11135                                         any_dup(FPTR2DPTR(void *, dptr),
11136                                                 proto_perl));
11137             break;
11138         case SAVEt_DESTRUCTOR_X:
11139             ptr = POPPTR(ss,ix);
11140             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
11141             dxptr = POPDXPTR(ss,ix);
11142             TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
11143                                          any_dup(FPTR2DPTR(void *, dxptr),
11144                                                  proto_perl));
11145             break;
11146         case SAVEt_REGCONTEXT:
11147         case SAVEt_ALLOC:
11148             i = POPINT(ss,ix);
11149             TOPINT(nss,ix) = i;
11150             ix -= i;
11151             break;
11152         case SAVEt_AELEM:               /* array element */
11153             sv = (SV*)POPPTR(ss,ix);
11154             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11155             i = POPINT(ss,ix);
11156             TOPINT(nss,ix) = i;
11157             av = (AV*)POPPTR(ss,ix);
11158             TOPPTR(nss,ix) = av_dup_inc(av, param);
11159             break;
11160         case SAVEt_OP:
11161             ptr = POPPTR(ss,ix);
11162             TOPPTR(nss,ix) = ptr;
11163             break;
11164         case SAVEt_HINTS:
11165             i = POPINT(ss,ix);
11166             TOPINT(nss,ix) = i;
11167             ptr = POPPTR(ss,ix);
11168             if (ptr) {
11169                 HINTS_REFCNT_LOCK;
11170                 ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
11171                 HINTS_REFCNT_UNLOCK;
11172             }
11173             TOPPTR(nss,ix) = ptr;
11174             if (i & HINT_LOCALIZE_HH) {
11175                 hv = (HV*)POPPTR(ss,ix);
11176                 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
11177             }
11178             break;
11179         case SAVEt_PADSV_AND_MORTALIZE:
11180             longval = (long)POPLONG(ss,ix);
11181             TOPLONG(nss,ix) = longval;
11182             ptr = POPPTR(ss,ix);
11183             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11184             sv = (SV*)POPPTR(ss,ix);
11185             TOPPTR(nss,ix) = sv_dup_inc(sv, param);
11186             break;
11187         case SAVEt_BOOL:
11188             ptr = POPPTR(ss,ix);
11189             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
11190             longval = (long)POPBOOL(ss,ix);
11191             TOPBOOL(nss,ix) = (bool)longval;
11192             break;
11193         case SAVEt_SET_SVFLAGS:
11194             i = POPINT(ss,ix);
11195             TOPINT(nss,ix) = i;
11196             i = POPINT(ss,ix);
11197             TOPINT(nss,ix) = i;
11198             sv = (SV*)POPPTR(ss,ix);
11199             TOPPTR(nss,ix) = sv_dup(sv, param);
11200             break;
11201         case SAVEt_RE_STATE:
11202             {
11203                 const struct re_save_state *const old_state
11204                     = (struct re_save_state *)
11205                     (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11206                 struct re_save_state *const new_state
11207                     = (struct re_save_state *)
11208                     (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
11209
11210                 Copy(old_state, new_state, 1, struct re_save_state);
11211                 ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11212
11213                 new_state->re_state_bostr
11214                     = pv_dup(old_state->re_state_bostr);
11215                 new_state->re_state_reginput
11216                     = pv_dup(old_state->re_state_reginput);
11217                 new_state->re_state_regeol
11218                     = pv_dup(old_state->re_state_regeol);
11219                 new_state->re_state_regoffs
11220                     = (regexp_paren_pair*)
11221                         any_dup(old_state->re_state_regoffs, proto_perl);
11222                 new_state->re_state_reglastparen
11223                     = (U32*) any_dup(old_state->re_state_reglastparen, 
11224                               proto_perl);
11225                 new_state->re_state_reglastcloseparen
11226                     = (U32*)any_dup(old_state->re_state_reglastcloseparen,
11227                               proto_perl);
11228                 /* XXX This just has to be broken. The old save_re_context
11229                    code did SAVEGENERICPV(PL_reg_start_tmp);
11230                    PL_reg_start_tmp is char **.
11231                    Look above to what the dup code does for
11232                    SAVEt_GENERIC_PVREF
11233                    It can never have worked.
11234                    So this is merely a faithful copy of the exiting bug:  */
11235                 new_state->re_state_reg_start_tmp
11236                     = (char **) pv_dup((char *)
11237                                       old_state->re_state_reg_start_tmp);
11238                 /* I assume that it only ever "worked" because no-one called
11239                    (pseudo)fork while the regexp engine had re-entered itself.
11240                 */
11241 #ifdef PERL_OLD_COPY_ON_WRITE
11242                 new_state->re_state_nrs
11243                     = sv_dup(old_state->re_state_nrs, param);
11244 #endif
11245                 new_state->re_state_reg_magic
11246                     = (MAGIC*) any_dup(old_state->re_state_reg_magic, 
11247                                proto_perl);
11248                 new_state->re_state_reg_oldcurpm
11249                     = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm, 
11250                               proto_perl);
11251                 new_state->re_state_reg_curpm
11252                     = (PMOP*)  any_dup(old_state->re_state_reg_curpm, 
11253                                proto_perl);
11254                 new_state->re_state_reg_oldsaved
11255                     = pv_dup(old_state->re_state_reg_oldsaved);
11256                 new_state->re_state_reg_poscache
11257                     = pv_dup(old_state->re_state_reg_poscache);
11258                 new_state->re_state_reg_starttry
11259                     = pv_dup(old_state->re_state_reg_starttry);
11260                 break;
11261             }
11262         case SAVEt_COMPILE_WARNINGS:
11263             ptr = POPPTR(ss,ix);
11264             TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
11265             break;
11266         case SAVEt_PARSER:
11267             ptr = POPPTR(ss,ix);
11268             TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param);
11269             break;
11270         default:
11271             Perl_croak(aTHX_
11272                        "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
11273         }
11274     }
11275
11276     return nss;
11277 }
11278
11279
11280 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
11281  * flag to the result. This is done for each stash before cloning starts,
11282  * so we know which stashes want their objects cloned */
11283
11284 static void
11285 do_mark_cloneable_stash(pTHX_ SV *const sv)
11286 {
11287     const HEK * const hvname = HvNAME_HEK((HV*)sv);
11288     if (hvname) {
11289         GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
11290         SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
11291         if (cloner && GvCV(cloner)) {
11292             dSP;
11293             UV status;
11294
11295             ENTER;
11296             SAVETMPS;
11297             PUSHMARK(SP);
11298             mXPUSHs(newSVhek(hvname));
11299             PUTBACK;
11300             call_sv((SV*)GvCV(cloner), G_SCALAR);
11301             SPAGAIN;
11302             status = POPu;
11303             PUTBACK;
11304             FREETMPS;
11305             LEAVE;
11306             if (status)
11307                 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
11308         }
11309     }
11310 }
11311
11312
11313
11314 /*
11315 =for apidoc perl_clone
11316
11317 Create and return a new interpreter by cloning the current one.
11318
11319 perl_clone takes these flags as parameters:
11320
11321 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
11322 without it we only clone the data and zero the stacks,
11323 with it we copy the stacks and the new perl interpreter is
11324 ready to run at the exact same point as the previous one.
11325 The pseudo-fork code uses COPY_STACKS while the
11326 threads->create doesn't.
11327
11328 CLONEf_KEEP_PTR_TABLE
11329 perl_clone keeps a ptr_table with the pointer of the old
11330 variable as a key and the new variable as a value,
11331 this allows it to check if something has been cloned and not
11332 clone it again but rather just use the value and increase the
11333 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
11334 the ptr_table using the function
11335 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
11336 reason to keep it around is if you want to dup some of your own
11337 variable who are outside the graph perl scans, example of this
11338 code is in threads.xs create
11339
11340 CLONEf_CLONE_HOST
11341 This is a win32 thing, it is ignored on unix, it tells perls
11342 win32host code (which is c++) to clone itself, this is needed on
11343 win32 if you want to run two threads at the same time,
11344 if you just want to do some stuff in a separate perl interpreter
11345 and then throw it away and return to the original one,
11346 you don't need to do anything.
11347
11348 =cut
11349 */
11350
11351 /* XXX the above needs expanding by someone who actually understands it ! */
11352 EXTERN_C PerlInterpreter *
11353 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
11354
11355 PerlInterpreter *
11356 perl_clone(PerlInterpreter *proto_perl, UV flags)
11357 {
11358    dVAR;
11359 #ifdef PERL_IMPLICIT_SYS
11360
11361     PERL_ARGS_ASSERT_PERL_CLONE;
11362
11363    /* perlhost.h so we need to call into it
11364    to clone the host, CPerlHost should have a c interface, sky */
11365
11366    if (flags & CLONEf_CLONE_HOST) {
11367        return perl_clone_host(proto_perl,flags);
11368    }
11369    return perl_clone_using(proto_perl, flags,
11370                             proto_perl->IMem,
11371                             proto_perl->IMemShared,
11372                             proto_perl->IMemParse,
11373                             proto_perl->IEnv,
11374                             proto_perl->IStdIO,
11375                             proto_perl->ILIO,
11376                             proto_perl->IDir,
11377                             proto_perl->ISock,
11378                             proto_perl->IProc);
11379 }
11380
11381 PerlInterpreter *
11382 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
11383                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
11384                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
11385                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
11386                  struct IPerlDir* ipD, struct IPerlSock* ipS,
11387                  struct IPerlProc* ipP)
11388 {
11389     /* XXX many of the string copies here can be optimized if they're
11390      * constants; they need to be allocated as common memory and just
11391      * their pointers copied. */
11392
11393     IV i;
11394     CLONE_PARAMS clone_params;
11395     CLONE_PARAMS* const param = &clone_params;
11396
11397     PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
11398
11399     PERL_ARGS_ASSERT_PERL_CLONE_USING;
11400
11401     /* for each stash, determine whether its objects should be cloned */
11402     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11403     PERL_SET_THX(my_perl);
11404
11405 #  ifdef DEBUGGING
11406     PoisonNew(my_perl, 1, PerlInterpreter);
11407     PL_op = NULL;
11408     PL_curcop = NULL;
11409     PL_markstack = 0;
11410     PL_scopestack = 0;
11411     PL_savestack = 0;
11412     PL_savestack_ix = 0;
11413     PL_savestack_max = -1;
11414     PL_sig_pending = 0;
11415     PL_parser = NULL;
11416     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11417 #  else /* !DEBUGGING */
11418     Zero(my_perl, 1, PerlInterpreter);
11419 #  endif        /* DEBUGGING */
11420
11421     /* host pointers */
11422     PL_Mem              = ipM;
11423     PL_MemShared        = ipMS;
11424     PL_MemParse         = ipMP;
11425     PL_Env              = ipE;
11426     PL_StdIO            = ipStd;
11427     PL_LIO              = ipLIO;
11428     PL_Dir              = ipD;
11429     PL_Sock             = ipS;
11430     PL_Proc             = ipP;
11431 #else           /* !PERL_IMPLICIT_SYS */
11432     IV i;
11433     CLONE_PARAMS clone_params;
11434     CLONE_PARAMS* param = &clone_params;
11435     PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
11436
11437     PERL_ARGS_ASSERT_PERL_CLONE;
11438
11439     /* for each stash, determine whether its objects should be cloned */
11440     S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
11441     PERL_SET_THX(my_perl);
11442
11443 #    ifdef DEBUGGING
11444     PoisonNew(my_perl, 1, PerlInterpreter);
11445     PL_op = NULL;
11446     PL_curcop = NULL;
11447     PL_markstack = 0;
11448     PL_scopestack = 0;
11449     PL_savestack = 0;
11450     PL_savestack_ix = 0;
11451     PL_savestack_max = -1;
11452     PL_sig_pending = 0;
11453     PL_parser = NULL;
11454     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
11455 #    else       /* !DEBUGGING */
11456     Zero(my_perl, 1, PerlInterpreter);
11457 #    endif      /* DEBUGGING */
11458 #endif          /* PERL_IMPLICIT_SYS */
11459     param->flags = flags;
11460     param->proto_perl = proto_perl;
11461
11462     INIT_TRACK_MEMPOOL(my_perl->Imemory_debug_header, my_perl);
11463
11464     PL_body_arenas = NULL;
11465     Zero(&PL_body_roots, 1, PL_body_roots);
11466     
11467     PL_nice_chunk       = NULL;
11468     PL_nice_chunk_size  = 0;
11469     PL_sv_count         = 0;
11470     PL_sv_objcount      = 0;
11471     PL_sv_root          = NULL;
11472     PL_sv_arenaroot     = NULL;
11473
11474     PL_debug            = proto_perl->Idebug;
11475
11476     PL_hash_seed        = proto_perl->Ihash_seed;
11477     PL_rehash_seed      = proto_perl->Irehash_seed;
11478
11479 #ifdef USE_REENTRANT_API
11480     /* XXX: things like -Dm will segfault here in perlio, but doing
11481      *  PERL_SET_CONTEXT(proto_perl);
11482      * breaks too many other things
11483      */
11484     Perl_reentrant_init(aTHX);
11485 #endif
11486
11487     /* create SV map for pointer relocation */
11488     PL_ptr_table = ptr_table_new();
11489
11490     /* initialize these special pointers as early as possible */
11491     SvANY(&PL_sv_undef)         = NULL;
11492     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
11493     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
11494     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
11495
11496     SvANY(&PL_sv_no)            = new_XPVNV();
11497     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
11498     SvFLAGS(&PL_sv_no)          = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11499                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11500     SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
11501     SvCUR_set(&PL_sv_no, 0);
11502     SvLEN_set(&PL_sv_no, 1);
11503     SvIV_set(&PL_sv_no, 0);
11504     SvNV_set(&PL_sv_no, 0);
11505     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
11506
11507     SvANY(&PL_sv_yes)           = new_XPVNV();
11508     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
11509     SvFLAGS(&PL_sv_yes)         = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
11510                                   |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
11511     SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
11512     SvCUR_set(&PL_sv_yes, 1);
11513     SvLEN_set(&PL_sv_yes, 2);
11514     SvIV_set(&PL_sv_yes, 1);
11515     SvNV_set(&PL_sv_yes, 1);
11516     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
11517
11518     /* create (a non-shared!) shared string table */
11519     PL_strtab           = newHV();
11520     HvSHAREKEYS_off(PL_strtab);
11521     hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
11522     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
11523
11524     PL_compiling = proto_perl->Icompiling;
11525
11526     /* These two PVs will be free'd special way so must set them same way op.c does */
11527     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
11528     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
11529
11530     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
11531     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
11532
11533     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
11534     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
11535     if (PL_compiling.cop_hints_hash) {
11536         HINTS_REFCNT_LOCK;
11537         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
11538         HINTS_REFCNT_UNLOCK;
11539     }
11540     PL_curcop           = (COP*)any_dup(proto_perl->Icurcop, proto_perl);
11541 #ifdef PERL_DEBUG_READONLY_OPS
11542     PL_slabs = NULL;
11543     PL_slab_count = 0;
11544 #endif
11545
11546     /* pseudo environmental stuff */
11547     PL_origargc         = proto_perl->Iorigargc;
11548     PL_origargv         = proto_perl->Iorigargv;
11549
11550     param->stashes      = newAV();  /* Setup array of objects to call clone on */
11551
11552     /* Set tainting stuff before PerlIO_debug can possibly get called */
11553     PL_tainting         = proto_perl->Itainting;
11554     PL_taint_warn       = proto_perl->Itaint_warn;
11555
11556 #ifdef PERLIO_LAYERS
11557     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
11558     PerlIO_clone(aTHX_ proto_perl, param);
11559 #endif
11560
11561     PL_envgv            = gv_dup(proto_perl->Ienvgv, param);
11562     PL_incgv            = gv_dup(proto_perl->Iincgv, param);
11563     PL_hintgv           = gv_dup(proto_perl->Ihintgv, param);
11564     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
11565     PL_diehook          = sv_dup_inc(proto_perl->Idiehook, param);
11566     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook, param);
11567
11568     /* switches */
11569     PL_minus_c          = proto_perl->Iminus_c;
11570     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel, param);
11571     PL_localpatches     = proto_perl->Ilocalpatches;
11572     PL_splitstr         = proto_perl->Isplitstr;
11573     PL_minus_n          = proto_perl->Iminus_n;
11574     PL_minus_p          = proto_perl->Iminus_p;
11575     PL_minus_l          = proto_perl->Iminus_l;
11576     PL_minus_a          = proto_perl->Iminus_a;
11577     PL_minus_E          = proto_perl->Iminus_E;
11578     PL_minus_F          = proto_perl->Iminus_F;
11579     PL_doswitches       = proto_perl->Idoswitches;
11580     PL_dowarn           = proto_perl->Idowarn;
11581     PL_doextract        = proto_perl->Idoextract;
11582     PL_sawampersand     = proto_perl->Isawampersand;
11583     PL_unsafe           = proto_perl->Iunsafe;
11584     PL_inplace          = SAVEPV(proto_perl->Iinplace);
11585     PL_e_script         = sv_dup_inc(proto_perl->Ie_script, param);
11586     PL_perldb           = proto_perl->Iperldb;
11587     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
11588     PL_exit_flags       = proto_perl->Iexit_flags;
11589
11590     /* magical thingies */
11591     /* XXX time(&PL_basetime) when asked for? */
11592     PL_basetime         = proto_perl->Ibasetime;
11593     PL_formfeed         = sv_dup(proto_perl->Iformfeed, param);
11594
11595     PL_maxsysfd         = proto_perl->Imaxsysfd;
11596     PL_statusvalue      = proto_perl->Istatusvalue;
11597 #ifdef VMS
11598     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
11599 #else
11600     PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
11601 #endif
11602     PL_encoding         = sv_dup(proto_perl->Iencoding, param);
11603
11604     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);        /* For regex debugging. */
11605     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);        /* ext/re needs these */
11606     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);        /* even without DEBUGGING. */
11607
11608    
11609     /* RE engine related */
11610     Zero(&PL_reg_state, 1, struct re_save_state);
11611     PL_reginterp_cnt    = 0;
11612     PL_regmatch_slab    = NULL;
11613     
11614     /* Clone the regex array */
11615     /* ORANGE FIXME for plugins, probably in the SV dup code.
11616        newSViv(PTR2IV(CALLREGDUPE(
11617        INT2PTR(REGEXP *, SvIVX(regex)), param))))
11618     */
11619     PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param);
11620     PL_regex_pad = AvARRAY(PL_regex_padav);
11621
11622     /* shortcuts to various I/O objects */
11623     PL_stdingv          = gv_dup(proto_perl->Istdingv, param);
11624     PL_stderrgv         = gv_dup(proto_perl->Istderrgv, param);
11625     PL_defgv            = gv_dup(proto_perl->Idefgv, param);
11626     PL_argvgv           = gv_dup(proto_perl->Iargvgv, param);
11627     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv, param);
11628     PL_argvout_stack    = av_dup_inc(proto_perl->Iargvout_stack, param);
11629
11630     /* shortcuts to regexp stuff */
11631     PL_replgv           = gv_dup(proto_perl->Ireplgv, param);
11632
11633     /* shortcuts to misc objects */
11634     PL_errgv            = gv_dup(proto_perl->Ierrgv, param);
11635
11636     /* shortcuts to debugging objects */
11637     PL_DBgv             = gv_dup(proto_perl->IDBgv, param);
11638     PL_DBline           = gv_dup(proto_perl->IDBline, param);
11639     PL_DBsub            = gv_dup(proto_perl->IDBsub, param);
11640     PL_DBsingle         = sv_dup(proto_perl->IDBsingle, param);
11641     PL_DBtrace          = sv_dup(proto_perl->IDBtrace, param);
11642     PL_DBsignal         = sv_dup(proto_perl->IDBsignal, param);
11643     PL_dbargs           = av_dup(proto_perl->Idbargs, param);
11644
11645     /* symbol tables */
11646     PL_defstash         = hv_dup_inc(proto_perl->Idefstash, param);
11647     PL_curstash         = hv_dup(proto_perl->Icurstash, param);
11648     PL_debstash         = hv_dup(proto_perl->Idebstash, param);
11649     PL_globalstash      = hv_dup(proto_perl->Iglobalstash, param);
11650     PL_curstname        = sv_dup_inc(proto_perl->Icurstname, param);
11651
11652     PL_beginav          = av_dup_inc(proto_perl->Ibeginav, param);
11653     PL_beginav_save     = av_dup_inc(proto_perl->Ibeginav_save, param);
11654     PL_checkav_save     = av_dup_inc(proto_perl->Icheckav_save, param);
11655     PL_unitcheckav      = av_dup_inc(proto_perl->Iunitcheckav, param);
11656     PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param);
11657     PL_endav            = av_dup_inc(proto_perl->Iendav, param);
11658     PL_checkav          = av_dup_inc(proto_perl->Icheckav, param);
11659     PL_initav           = av_dup_inc(proto_perl->Iinitav, param);
11660
11661     PL_sub_generation   = proto_perl->Isub_generation;
11662     PL_isarev           = hv_dup_inc(proto_perl->Iisarev, param);
11663
11664     /* funky return mechanisms */
11665     PL_forkprocess      = proto_perl->Iforkprocess;
11666
11667     /* subprocess state */
11668     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid, param);
11669
11670     /* internal state */
11671     PL_maxo             = proto_perl->Imaxo;
11672     if (proto_perl->Iop_mask)
11673         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11674     else
11675         PL_op_mask      = NULL;
11676     /* PL_asserting        = proto_perl->Iasserting; */
11677
11678     /* current interpreter roots */
11679     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv, param);
11680     OP_REFCNT_LOCK;
11681     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
11682     OP_REFCNT_UNLOCK;
11683     PL_main_start       = proto_perl->Imain_start;
11684     PL_eval_root        = proto_perl->Ieval_root;
11685     PL_eval_start       = proto_perl->Ieval_start;
11686
11687     /* runtime control stuff */
11688     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11689
11690     PL_filemode         = proto_perl->Ifilemode;
11691     PL_lastfd           = proto_perl->Ilastfd;
11692     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
11693     PL_Argv             = NULL;
11694     PL_Cmd              = NULL;
11695     PL_gensym           = proto_perl->Igensym;
11696     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav, param);
11697     PL_laststatval      = proto_perl->Ilaststatval;
11698     PL_laststype        = proto_perl->Ilaststype;
11699     PL_mess_sv          = NULL;
11700
11701     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv, param);
11702
11703     /* interpreter atexit processing */
11704     PL_exitlistlen      = proto_perl->Iexitlistlen;
11705     if (PL_exitlistlen) {
11706         Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11707         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11708     }
11709     else
11710         PL_exitlist     = (PerlExitListEntry*)NULL;
11711
11712     PL_my_cxt_size = proto_perl->Imy_cxt_size;
11713     if (PL_my_cxt_size) {
11714         Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
11715         Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *);
11716 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11717         Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
11718         Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *);
11719 #endif
11720     }
11721     else {
11722         PL_my_cxt_list  = (void**)NULL;
11723 #ifdef PERL_GLOBAL_STRUCT_PRIVATE
11724         PL_my_cxt_keys  = (const char**)NULL;
11725 #endif
11726     }
11727     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal, param);
11728     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
11729     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11730
11731     PL_profiledata      = NULL;
11732
11733     PL_compcv                   = cv_dup(proto_perl->Icompcv, param);
11734
11735     PAD_CLONE_VARS(proto_perl, param);
11736
11737 #ifdef HAVE_INTERP_INTERN
11738     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11739 #endif
11740
11741     /* more statics moved here */
11742     PL_generation       = proto_perl->Igeneration;
11743     PL_DBcv             = cv_dup(proto_perl->IDBcv, param);
11744
11745     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
11746     PL_in_clean_all     = proto_perl->Iin_clean_all;
11747
11748     PL_uid              = proto_perl->Iuid;
11749     PL_euid             = proto_perl->Ieuid;
11750     PL_gid              = proto_perl->Igid;
11751     PL_egid             = proto_perl->Iegid;
11752     PL_nomemok          = proto_perl->Inomemok;
11753     PL_an               = proto_perl->Ian;
11754     PL_evalseq          = proto_perl->Ievalseq;
11755     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
11756     PL_origalen         = proto_perl->Iorigalen;
11757 #ifdef PERL_USES_PL_PIDSTATUS
11758     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
11759 #endif
11760     PL_osname           = SAVEPV(proto_perl->Iosname);
11761     PL_sighandlerp      = proto_perl->Isighandlerp;
11762
11763     PL_runops           = proto_perl->Irunops;
11764
11765     PL_parser           = parser_dup(proto_perl->Iparser, param);
11766
11767     PL_subline          = proto_perl->Isubline;
11768     PL_subname          = sv_dup_inc(proto_perl->Isubname, param);
11769
11770 #ifdef FCRYPT
11771     PL_cryptseen        = proto_perl->Icryptseen;
11772 #endif
11773
11774     PL_hints            = proto_perl->Ihints;
11775
11776     PL_amagic_generation        = proto_perl->Iamagic_generation;
11777
11778 #ifdef USE_LOCALE_COLLATE
11779     PL_collation_ix     = proto_perl->Icollation_ix;
11780     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
11781     PL_collation_standard       = proto_perl->Icollation_standard;
11782     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
11783     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
11784 #endif /* USE_LOCALE_COLLATE */
11785
11786 #ifdef USE_LOCALE_NUMERIC
11787     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
11788     PL_numeric_standard = proto_perl->Inumeric_standard;
11789     PL_numeric_local    = proto_perl->Inumeric_local;
11790     PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11791 #endif /* !USE_LOCALE_NUMERIC */
11792
11793     /* utf8 character classes */
11794     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11795     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11796     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11797     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11798     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space, param);
11799     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11800     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph, param);
11801     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit, param);
11802     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper, param);
11803     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower, param);
11804     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print, param);
11805     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct, param);
11806     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11807     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark, param);
11808     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11809     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11810     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11811     PL_utf8_tofold      = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11812     PL_utf8_idstart     = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11813     PL_utf8_idcont      = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11814
11815     /* Did the locale setup indicate UTF-8? */
11816     PL_utf8locale       = proto_perl->Iutf8locale;
11817     /* Unicode features (see perlrun/-C) */
11818     PL_unicode          = proto_perl->Iunicode;
11819
11820     /* Pre-5.8 signals control */
11821     PL_signals          = proto_perl->Isignals;
11822
11823     /* times() ticks per second */
11824     PL_clocktick        = proto_perl->Iclocktick;
11825
11826     /* Recursion stopper for PerlIO_find_layer */
11827     PL_in_load_module   = proto_perl->Iin_load_module;
11828
11829     /* sort() routine */
11830     PL_sort_RealCmp     = proto_perl->Isort_RealCmp;
11831
11832     /* Not really needed/useful since the reenrant_retint is "volatile",
11833      * but do it for consistency's sake. */
11834     PL_reentrant_retint = proto_perl->Ireentrant_retint;
11835
11836     /* Hooks to shared SVs and locks. */
11837     PL_sharehook        = proto_perl->Isharehook;
11838     PL_lockhook         = proto_perl->Ilockhook;
11839     PL_unlockhook       = proto_perl->Iunlockhook;
11840     PL_threadhook       = proto_perl->Ithreadhook;
11841     PL_destroyhook      = proto_perl->Idestroyhook;
11842
11843 #ifdef THREADS_HAVE_PIDS
11844     PL_ppid             = proto_perl->Ippid;
11845 #endif
11846
11847     /* swatch cache */
11848     PL_last_swash_hv    = NULL; /* reinits on demand */
11849     PL_last_swash_klen  = 0;
11850     PL_last_swash_key[0]= '\0';
11851     PL_last_swash_tmps  = (U8*)NULL;
11852     PL_last_swash_slen  = 0;
11853
11854     PL_glob_index       = proto_perl->Iglob_index;
11855     PL_srand_called     = proto_perl->Isrand_called;
11856     PL_bitcount         = NULL; /* reinits on demand */
11857
11858     if (proto_perl->Ipsig_pend) {
11859         Newxz(PL_psig_pend, SIG_SIZE, int);
11860     }
11861     else {
11862         PL_psig_pend    = (int*)NULL;
11863     }
11864
11865     if (proto_perl->Ipsig_ptr) {
11866         Newxz(PL_psig_ptr,  SIG_SIZE, SV*);
11867         Newxz(PL_psig_name, SIG_SIZE, SV*);
11868         for (i = 1; i < SIG_SIZE; i++) {
11869             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11870             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11871         }
11872     }
11873     else {
11874         PL_psig_ptr     = (SV**)NULL;
11875         PL_psig_name    = (SV**)NULL;
11876     }
11877
11878     /* intrpvar.h stuff */
11879
11880     if (flags & CLONEf_COPY_STACKS) {
11881         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11882         PL_tmps_ix              = proto_perl->Itmps_ix;
11883         PL_tmps_max             = proto_perl->Itmps_max;
11884         PL_tmps_floor           = proto_perl->Itmps_floor;
11885         Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11886         i = 0;
11887         while (i <= PL_tmps_ix) {
11888             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Itmps_stack[i], param);
11889             ++i;
11890         }
11891
11892         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11893         i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
11894         Newxz(PL_markstack, i, I32);
11895         PL_markstack_max        = PL_markstack + (proto_perl->Imarkstack_max
11896                                                   - proto_perl->Imarkstack);
11897         PL_markstack_ptr        = PL_markstack + (proto_perl->Imarkstack_ptr
11898                                                   - proto_perl->Imarkstack);
11899         Copy(proto_perl->Imarkstack, PL_markstack,
11900              PL_markstack_ptr - PL_markstack + 1, I32);
11901
11902         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11903          * NOTE: unlike the others! */
11904         PL_scopestack_ix        = proto_perl->Iscopestack_ix;
11905         PL_scopestack_max       = proto_perl->Iscopestack_max;
11906         Newxz(PL_scopestack, PL_scopestack_max, I32);
11907         Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
11908
11909         /* NOTE: si_dup() looks at PL_markstack */
11910         PL_curstackinfo         = si_dup(proto_perl->Icurstackinfo, param);
11911
11912         /* PL_curstack          = PL_curstackinfo->si_stack; */
11913         PL_curstack             = av_dup(proto_perl->Icurstack, param);
11914         PL_mainstack            = av_dup(proto_perl->Imainstack, param);
11915
11916         /* next PUSHs() etc. set *(PL_stack_sp+1) */
11917         PL_stack_base           = AvARRAY(PL_curstack);
11918         PL_stack_sp             = PL_stack_base + (proto_perl->Istack_sp
11919                                                    - proto_perl->Istack_base);
11920         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
11921
11922         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11923          * NOTE: unlike the others! */
11924         PL_savestack_ix         = proto_perl->Isavestack_ix;
11925         PL_savestack_max        = proto_perl->Isavestack_max;
11926         /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11927         PL_savestack            = ss_dup(proto_perl, param);
11928     }
11929     else {
11930         init_stacks();
11931         ENTER;                  /* perl_destruct() wants to LEAVE; */
11932
11933         /* although we're not duplicating the tmps stack, we should still
11934          * add entries for any SVs on the tmps stack that got cloned by a
11935          * non-refcount means (eg a temp in @_); otherwise they will be
11936          * orphaned
11937          */
11938         for (i = 0; i<= proto_perl->Itmps_ix; i++) {
11939             SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table,
11940                     proto_perl->Itmps_stack[i]);
11941             if (nsv && !SvREFCNT(nsv)) {
11942                 EXTEND_MORTAL(1);
11943                 PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv);
11944             }
11945         }
11946     }
11947
11948     PL_start_env        = proto_perl->Istart_env;       /* XXXXXX */
11949     PL_top_env          = &PL_start_env;
11950
11951     PL_op               = proto_perl->Iop;
11952
11953     PL_Sv               = NULL;
11954     PL_Xpv              = (XPV*)NULL;
11955     my_perl->Ina        = proto_perl->Ina;
11956
11957     PL_statbuf          = proto_perl->Istatbuf;
11958     PL_statcache        = proto_perl->Istatcache;
11959     PL_statgv           = gv_dup(proto_perl->Istatgv, param);
11960     PL_statname         = sv_dup_inc(proto_perl->Istatname, param);
11961 #ifdef HAS_TIMES
11962     PL_timesbuf         = proto_perl->Itimesbuf;
11963 #endif
11964
11965     PL_tainted          = proto_perl->Itainted;
11966     PL_curpm            = proto_perl->Icurpm;   /* XXX No PMOP ref count */
11967     PL_rs               = sv_dup_inc(proto_perl->Irs, param);
11968     PL_last_in_gv       = gv_dup(proto_perl->Ilast_in_gv, param);
11969     PL_ofs_sv           = sv_dup_inc(proto_perl->Iofs_sv, param);
11970     PL_defoutgv         = gv_dup_inc(proto_perl->Idefoutgv, param);
11971     PL_chopset          = proto_perl->Ichopset; /* XXX never deallocated */
11972     PL_toptarget        = sv_dup_inc(proto_perl->Itoptarget, param);
11973     PL_bodytarget       = sv_dup_inc(proto_perl->Ibodytarget, param);
11974     PL_formtarget       = sv_dup(proto_perl->Iformtarget, param);
11975
11976     PL_restartop        = proto_perl->Irestartop;
11977     PL_in_eval          = proto_perl->Iin_eval;
11978     PL_delaymagic       = proto_perl->Idelaymagic;
11979     PL_dirty            = proto_perl->Idirty;
11980     PL_localizing       = proto_perl->Ilocalizing;
11981
11982     PL_errors           = sv_dup_inc(proto_perl->Ierrors, param);
11983     PL_hv_fetch_ent_mh  = NULL;
11984     PL_modcount         = proto_perl->Imodcount;
11985     PL_lastgotoprobe    = NULL;
11986     PL_dumpindent       = proto_perl->Idumpindent;
11987
11988     PL_sortcop          = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
11989     PL_sortstash        = hv_dup(proto_perl->Isortstash, param);
11990     PL_firstgv          = gv_dup(proto_perl->Ifirstgv, param);
11991     PL_secondgv         = gv_dup(proto_perl->Isecondgv, param);
11992     PL_efloatbuf        = NULL;         /* reinits on demand */
11993     PL_efloatsize       = 0;                    /* reinits on demand */
11994
11995     /* regex stuff */
11996
11997     PL_screamfirst      = NULL;
11998     PL_screamnext       = NULL;
11999     PL_maxscream        = -1;                   /* reinits on demand */
12000     PL_lastscream       = NULL;
12001
12002
12003     PL_regdummy         = proto_perl->Iregdummy;
12004     PL_colorset         = 0;            /* reinits PL_colors[] */
12005     /*PL_colors[6]      = {0,0,0,0,0,0};*/
12006
12007
12008
12009     /* Pluggable optimizer */
12010     PL_peepp            = proto_perl->Ipeepp;
12011
12012     PL_stashcache       = newHV();
12013
12014     PL_watchaddr        = (char **) ptr_table_fetch(PL_ptr_table,
12015                                             proto_perl->Iwatchaddr);
12016     PL_watchok          = PL_watchaddr ? * PL_watchaddr : NULL;
12017     if (PL_debug && PL_watchaddr) {
12018         PerlIO_printf(Perl_debug_log,
12019           "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
12020           PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
12021           PTR2UV(PL_watchok));
12022     }
12023
12024     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
12025         ptr_table_free(PL_ptr_table);
12026         PL_ptr_table = NULL;
12027     }
12028
12029     /* Call the ->CLONE method, if it exists, for each of the stashes
12030        identified by sv_dup() above.
12031     */
12032     while(av_len(param->stashes) != -1) {
12033         HV* const stash = (HV*) av_shift(param->stashes);
12034         GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
12035         if (cloner && GvCV(cloner)) {
12036             dSP;
12037             ENTER;
12038             SAVETMPS;
12039             PUSHMARK(SP);
12040             mXPUSHs(newSVhek(HvNAME_HEK(stash)));
12041             PUTBACK;
12042             call_sv((SV*)GvCV(cloner), G_DISCARD);
12043             FREETMPS;
12044             LEAVE;
12045         }
12046     }
12047
12048     SvREFCNT_dec(param->stashes);
12049
12050     /* orphaned? eg threads->new inside BEGIN or use */
12051     if (PL_compcv && ! SvREFCNT(PL_compcv)) {
12052         SvREFCNT_inc_simple_void(PL_compcv);
12053         SAVEFREESV(PL_compcv);
12054     }
12055
12056     return my_perl;
12057 }
12058
12059 #endif /* USE_ITHREADS */
12060
12061 /*
12062 =head1 Unicode Support
12063
12064 =for apidoc sv_recode_to_utf8
12065
12066 The encoding is assumed to be an Encode object, on entry the PV
12067 of the sv is assumed to be octets in that encoding, and the sv
12068 will be converted into Unicode (and UTF-8).
12069
12070 If the sv already is UTF-8 (or if it is not POK), or if the encoding
12071 is not a reference, nothing is done to the sv.  If the encoding is not
12072 an C<Encode::XS> Encoding object, bad things will happen.
12073 (See F<lib/encoding.pm> and L<Encode>).
12074
12075 The PV of the sv is returned.
12076
12077 =cut */
12078
12079 char *
12080 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
12081 {
12082     dVAR;
12083
12084     PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
12085
12086     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
12087         SV *uni;
12088         STRLEN len;
12089         const char *s;
12090         dSP;
12091         ENTER;
12092         SAVETMPS;
12093         save_re_context();
12094         PUSHMARK(sp);
12095         EXTEND(SP, 3);
12096         XPUSHs(encoding);
12097         XPUSHs(sv);
12098 /*
12099   NI-S 2002/07/09
12100   Passing sv_yes is wrong - it needs to be or'ed set of constants
12101   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
12102   remove converted chars from source.
12103
12104   Both will default the value - let them.
12105
12106         XPUSHs(&PL_sv_yes);
12107 */
12108         PUTBACK;
12109         call_method("decode", G_SCALAR);
12110         SPAGAIN;
12111         uni = POPs;
12112         PUTBACK;
12113         s = SvPV_const(uni, len);
12114         if (s != SvPVX_const(sv)) {
12115             SvGROW(sv, len + 1);
12116             Move(s, SvPVX(sv), len + 1, char);
12117             SvCUR_set(sv, len);
12118         }
12119         FREETMPS;
12120         LEAVE;
12121         SvUTF8_on(sv);
12122         return SvPVX(sv);
12123     }
12124     return SvPOKp(sv) ? SvPVX(sv) : NULL;
12125 }
12126
12127 /*
12128 =for apidoc sv_cat_decode
12129
12130 The encoding is assumed to be an Encode object, the PV of the ssv is
12131 assumed to be octets in that encoding and decoding the input starts
12132 from the position which (PV + *offset) pointed to.  The dsv will be
12133 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
12134 when the string tstr appears in decoding output or the input ends on
12135 the PV of the ssv. The value which the offset points will be modified
12136 to the last input position on the ssv.
12137
12138 Returns TRUE if the terminator was found, else returns FALSE.
12139
12140 =cut */
12141
12142 bool
12143 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
12144                    SV *ssv, int *offset, char *tstr, int tlen)
12145 {
12146     dVAR;
12147     bool ret = FALSE;
12148
12149     PERL_ARGS_ASSERT_SV_CAT_DECODE;
12150
12151     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
12152         SV *offsv;
12153         dSP;
12154         ENTER;
12155         SAVETMPS;
12156         save_re_context();
12157         PUSHMARK(sp);
12158         EXTEND(SP, 6);
12159         XPUSHs(encoding);
12160         XPUSHs(dsv);
12161         XPUSHs(ssv);
12162         offsv = newSViv(*offset);
12163         mXPUSHs(offsv);
12164         mXPUSHp(tstr, tlen);
12165         PUTBACK;
12166         call_method("cat_decode", G_SCALAR);
12167         SPAGAIN;
12168         ret = SvTRUE(TOPs);
12169         *offset = SvIV(offsv);
12170         PUTBACK;
12171         FREETMPS;
12172         LEAVE;
12173     }
12174     else
12175         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
12176     return ret;
12177
12178 }
12179
12180 /* ---------------------------------------------------------------------
12181  *
12182  * support functions for report_uninit()
12183  */
12184
12185 /* the maxiumum size of array or hash where we will scan looking
12186  * for the undefined element that triggered the warning */
12187
12188 #define FUV_MAX_SEARCH_SIZE 1000
12189
12190 /* Look for an entry in the hash whose value has the same SV as val;
12191  * If so, return a mortal copy of the key. */
12192
12193 STATIC SV*
12194 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
12195 {
12196     dVAR;
12197     register HE **array;
12198     I32 i;
12199
12200     PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT;
12201
12202     if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
12203                         (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
12204         return NULL;
12205
12206     array = HvARRAY(hv);
12207
12208     for (i=HvMAX(hv); i>0; i--) {
12209         register HE *entry;
12210         for (entry = array[i]; entry; entry = HeNEXT(entry)) {
12211             if (HeVAL(entry) != val)
12212                 continue;
12213             if (    HeVAL(entry) == &PL_sv_undef ||
12214                     HeVAL(entry) == &PL_sv_placeholder)
12215                 continue;
12216             if (!HeKEY(entry))
12217                 return NULL;
12218             if (HeKLEN(entry) == HEf_SVKEY)
12219                 return sv_mortalcopy(HeKEY_sv(entry));
12220             return sv_2mortal(newSVhek(HeKEY_hek(entry)));
12221         }
12222     }
12223     return NULL;
12224 }
12225
12226 /* Look for an entry in the array whose value has the same SV as val;
12227  * If so, return the index, otherwise return -1. */
12228
12229 STATIC I32
12230 S_find_array_subscript(pTHX_ AV *av, SV* val)
12231 {
12232     dVAR;
12233
12234     PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
12235
12236     if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
12237                         (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
12238         return -1;
12239
12240     if (val != &PL_sv_undef) {
12241         SV ** const svp = AvARRAY(av);
12242         I32 i;
12243
12244         for (i=AvFILLp(av); i>=0; i--)
12245             if (svp[i] == val)
12246                 return i;
12247     }
12248     return -1;
12249 }
12250
12251 /* S_varname(): return the name of a variable, optionally with a subscript.
12252  * If gv is non-zero, use the name of that global, along with gvtype (one
12253  * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
12254  * targ.  Depending on the value of the subscript_type flag, return:
12255  */
12256
12257 #define FUV_SUBSCRIPT_NONE      1       /* "@foo"          */
12258 #define FUV_SUBSCRIPT_ARRAY     2       /* "$foo[aindex]"  */
12259 #define FUV_SUBSCRIPT_HASH      3       /* "$foo{keyname}" */
12260 #define FUV_SUBSCRIPT_WITHIN    4       /* "within @foo"   */
12261
12262 STATIC SV*
12263 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
12264         SV* keyname, I32 aindex, int subscript_type)
12265 {
12266
12267     SV * const name = sv_newmortal();
12268     if (gv) {
12269         char buffer[2];
12270         buffer[0] = gvtype;
12271         buffer[1] = 0;
12272
12273         /* as gv_fullname4(), but add literal '^' for $^FOO names  */
12274
12275         gv_fullname4(name, gv, buffer, 0);
12276
12277         if ((unsigned int)SvPVX(name)[1] <= 26) {
12278             buffer[0] = '^';
12279             buffer[1] = SvPVX(name)[1] + 'A' - 1;
12280
12281             /* Swap the 1 unprintable control character for the 2 byte pretty
12282                version - ie substr($name, 1, 1) = $buffer; */
12283             sv_insert(name, 1, 1, buffer, 2);
12284         }
12285     }
12286     else {
12287         CV * const cv = find_runcv(NULL);
12288         SV *sv;
12289         AV *av;
12290
12291         if (!cv || !CvPADLIST(cv))
12292             return NULL;
12293         av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
12294         sv = *av_fetch(av, targ, FALSE);
12295         sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
12296     }
12297
12298     if (subscript_type == FUV_SUBSCRIPT_HASH) {
12299         SV * const sv = newSV(0);
12300         *SvPVX(name) = '$';
12301         Perl_sv_catpvf(aTHX_ name, "{%s}",
12302             pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
12303         SvREFCNT_dec(sv);
12304     }
12305     else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
12306         *SvPVX(name) = '$';
12307         Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
12308     }
12309     else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
12310         Perl_sv_insert(aTHX_ name, 0, 0,  STR_WITH_LEN("within "));
12311
12312     return name;
12313 }
12314
12315
12316 /*
12317 =for apidoc find_uninit_var
12318
12319 Find the name of the undefined variable (if any) that caused the operator o
12320 to issue a "Use of uninitialized value" warning.
12321 If match is true, only return a name if it's value matches uninit_sv.
12322 So roughly speaking, if a unary operator (such as OP_COS) generates a
12323 warning, then following the direct child of the op may yield an
12324 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
12325 other hand, with OP_ADD there are two branches to follow, so we only print
12326 the variable name if we get an exact match.
12327
12328 The name is returned as a mortal SV.
12329
12330 Assumes that PL_op is the op that originally triggered the error, and that
12331 PL_comppad/PL_curpad points to the currently executing pad.
12332
12333 =cut
12334 */
12335
12336 STATIC SV *
12337 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
12338 {
12339     dVAR;
12340     SV *sv;
12341     AV *av;
12342     GV *gv;
12343     OP *o, *o2, *kid;
12344
12345     if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
12346                             uninit_sv == &PL_sv_placeholder)))
12347         return NULL;
12348
12349     switch (obase->op_type) {
12350
12351     case OP_RV2AV:
12352     case OP_RV2HV:
12353     case OP_PADAV:
12354     case OP_PADHV:
12355       {
12356         const bool pad  = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
12357         const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
12358         I32 index = 0;
12359         SV *keysv = NULL;
12360         int subscript_type = FUV_SUBSCRIPT_WITHIN;
12361
12362         if (pad) { /* @lex, %lex */
12363             sv = PAD_SVl(obase->op_targ);
12364             gv = NULL;
12365         }
12366         else {
12367             if (cUNOPx(obase)->op_first->op_type == OP_GV) {
12368             /* @global, %global */
12369                 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
12370                 if (!gv)
12371                     break;
12372                 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
12373             }
12374             else /* @{expr}, %{expr} */
12375                 return find_uninit_var(cUNOPx(obase)->op_first,
12376                                                     uninit_sv, match);
12377         }
12378
12379         /* attempt to find a match within the aggregate */
12380         if (hash) {
12381             keysv = find_hash_subscript((HV*)sv, uninit_sv);
12382             if (keysv)
12383                 subscript_type = FUV_SUBSCRIPT_HASH;
12384         }
12385         else {
12386             index = find_array_subscript((AV*)sv, uninit_sv);
12387             if (index >= 0)
12388                 subscript_type = FUV_SUBSCRIPT_ARRAY;
12389         }
12390
12391         if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
12392             break;
12393
12394         return varname(gv, hash ? '%' : '@', obase->op_targ,
12395                                     keysv, index, subscript_type);
12396       }
12397
12398     case OP_PADSV:
12399         if (match && PAD_SVl(obase->op_targ) != uninit_sv)
12400             break;
12401         return varname(NULL, '$', obase->op_targ,
12402                                     NULL, 0, FUV_SUBSCRIPT_NONE);
12403
12404     case OP_GVSV:
12405         gv = cGVOPx_gv(obase);
12406         if (!gv || (match && GvSV(gv) != uninit_sv))
12407             break;
12408         return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
12409
12410     case OP_AELEMFAST:
12411         if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
12412             if (match) {
12413                 SV **svp;
12414                 av = (AV*)PAD_SV(obase->op_targ);
12415                 if (!av || SvRMAGICAL(av))
12416                     break;
12417                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12418                 if (!svp || *svp != uninit_sv)
12419                     break;
12420             }
12421             return varname(NULL, '$', obase->op_targ,
12422                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12423         }
12424         else {
12425             gv = cGVOPx_gv(obase);
12426             if (!gv)
12427                 break;
12428             if (match) {
12429                 SV **svp;
12430                 av = GvAV(gv);
12431                 if (!av || SvRMAGICAL(av))
12432                     break;
12433                 svp = av_fetch(av, (I32)obase->op_private, FALSE);
12434                 if (!svp || *svp != uninit_sv)
12435                     break;
12436             }
12437             return varname(gv, '$', 0,
12438                     NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
12439         }
12440         break;
12441
12442     case OP_EXISTS:
12443         o = cUNOPx(obase)->op_first;
12444         if (!o || o->op_type != OP_NULL ||
12445                 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
12446             break;
12447         return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
12448
12449     case OP_AELEM:
12450     case OP_HELEM:
12451         if (PL_op == obase)
12452             /* $a[uninit_expr] or $h{uninit_expr} */
12453             return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
12454
12455         gv = NULL;
12456         o = cBINOPx(obase)->op_first;
12457         kid = cBINOPx(obase)->op_last;
12458
12459         /* get the av or hv, and optionally the gv */
12460         sv = NULL;
12461         if  (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
12462             sv = PAD_SV(o->op_targ);
12463         }
12464         else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
12465                 && cUNOPo->op_first->op_type == OP_GV)
12466         {
12467             gv = cGVOPx_gv(cUNOPo->op_first);
12468             if (!gv)
12469                 break;
12470             sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
12471         }
12472         if (!sv)
12473             break;
12474
12475         if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
12476             /* index is constant */
12477             if (match) {
12478                 if (SvMAGICAL(sv))
12479                     break;
12480                 if (obase->op_type == OP_HELEM) {
12481                     HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
12482                     if (!he || HeVAL(he) != uninit_sv)
12483                         break;
12484                 }
12485                 else {
12486                     SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
12487                     if (!svp || *svp != uninit_sv)
12488                         break;
12489                 }
12490             }
12491             if (obase->op_type == OP_HELEM)
12492                 return varname(gv, '%', o->op_targ,
12493                             cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
12494             else
12495                 return varname(gv, '@', o->op_targ, NULL,
12496                             SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
12497         }
12498         else  {
12499             /* index is an expression;
12500              * attempt to find a match within the aggregate */
12501             if (obase->op_type == OP_HELEM) {
12502                 SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv);
12503                 if (keysv)
12504                     return varname(gv, '%', o->op_targ,
12505                                                 keysv, 0, FUV_SUBSCRIPT_HASH);
12506             }
12507             else {
12508                 const I32 index = find_array_subscript((AV*)sv, uninit_sv);
12509                 if (index >= 0)
12510                     return varname(gv, '@', o->op_targ,
12511                                         NULL, index, FUV_SUBSCRIPT_ARRAY);
12512             }
12513             if (match)
12514                 break;
12515             return varname(gv,
12516                 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
12517                 ? '@' : '%',
12518                 o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
12519         }
12520         break;
12521
12522     case OP_AASSIGN:
12523         /* only examine RHS */
12524         return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
12525
12526     case OP_OPEN:
12527         o = cUNOPx(obase)->op_first;
12528         if (o->op_type == OP_PUSHMARK)
12529             o = o->op_sibling;
12530
12531         if (!o->op_sibling) {
12532             /* one-arg version of open is highly magical */
12533
12534             if (o->op_type == OP_GV) { /* open FOO; */
12535                 gv = cGVOPx_gv(o);
12536                 if (match && GvSV(gv) != uninit_sv)
12537                     break;
12538                 return varname(gv, '$', 0,
12539                             NULL, 0, FUV_SUBSCRIPT_NONE);
12540             }
12541             /* other possibilities not handled are:
12542              * open $x; or open my $x;  should return '${*$x}'
12543              * open expr;               should return '$'.expr ideally
12544              */
12545              break;
12546         }
12547         goto do_op;
12548
12549     /* ops where $_ may be an implicit arg */
12550     case OP_TRANS:
12551     case OP_SUBST:
12552     case OP_MATCH:
12553         if ( !(obase->op_flags & OPf_STACKED)) {
12554             if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
12555                                  ? PAD_SVl(obase->op_targ)
12556                                  : DEFSV))
12557             {
12558                 sv = sv_newmortal();
12559                 sv_setpvn(sv, "$_", 2);
12560                 return sv;
12561             }
12562         }
12563         goto do_op;
12564
12565     case OP_PRTF:
12566     case OP_PRINT:
12567     case OP_SAY:
12568         /* skip filehandle as it can't produce 'undef' warning  */
12569         o = cUNOPx(obase)->op_first;
12570         if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
12571             o = o->op_sibling->op_sibling;
12572         goto do_op2;
12573
12574
12575     case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
12576     case OP_RV2SV:
12577     case OP_CUSTOM:
12578         match = 1; /* XS or custom code could trigger random warnings */
12579         goto do_op;
12580
12581     case OP_ENTERSUB:
12582     case OP_GOTO:
12583         /* XXX tmp hack: these two may call an XS sub, and currently
12584           XS subs don't have a SUB entry on the context stack, so CV and
12585           pad determination goes wrong, and BAD things happen. So, just
12586           don't try to determine the value under those circumstances.
12587           Need a better fix at dome point. DAPM 11/2007 */
12588         break;
12589
12590     case OP_POS:
12591         /* def-ness of rval pos() is independent of the def-ness of its arg */
12592         if ( !(obase->op_flags & OPf_MOD))
12593             break;
12594
12595     case OP_SCHOMP:
12596     case OP_CHOMP:
12597         if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
12598             return newSVpvs_flags("${$/}", SVs_TEMP);
12599         /*FALLTHROUGH*/
12600
12601     default:
12602     do_op:
12603         if (!(obase->op_flags & OPf_KIDS))
12604             break;
12605         o = cUNOPx(obase)->op_first;
12606         
12607     do_op2:
12608         if (!o)
12609             break;
12610
12611         /* if all except one arg are constant, or have no side-effects,
12612          * or are optimized away, then it's unambiguous */
12613         o2 = NULL;
12614         for (kid=o; kid; kid = kid->op_sibling) {
12615             if (kid) {
12616                 const OPCODE type = kid->op_type;
12617                 if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
12618                   || (type == OP_NULL  && ! (kid->op_flags & OPf_KIDS))
12619                   || (type == OP_PUSHMARK)
12620                 )
12621                 continue;
12622             }
12623             if (o2) { /* more than one found */
12624                 o2 = NULL;
12625                 break;
12626             }
12627             o2 = kid;
12628         }
12629         if (o2)
12630             return find_uninit_var(o2, uninit_sv, match);
12631
12632         /* scan all args */
12633         while (o) {
12634             sv = find_uninit_var(o, uninit_sv, 1);
12635             if (sv)
12636                 return sv;
12637             o = o->op_sibling;
12638         }
12639         break;
12640     }
12641     return NULL;
12642 }
12643
12644
12645 /*
12646 =for apidoc report_uninit
12647
12648 Print appropriate "Use of uninitialized variable" warning
12649
12650 =cut
12651 */
12652
12653 void
12654 Perl_report_uninit(pTHX_ SV* uninit_sv)
12655 {
12656     dVAR;
12657     if (PL_op) {
12658         SV* varname = NULL;
12659         if (uninit_sv) {
12660             varname = find_uninit_var(PL_op, uninit_sv,0);
12661             if (varname)
12662                 sv_insert(varname, 0, 0, " ", 1);
12663         }
12664         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12665                 varname ? SvPV_nolen_const(varname) : "",
12666                 " in ", OP_DESC(PL_op));
12667     }
12668     else
12669         Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
12670                     "", "", "");
12671 }
12672
12673 /*
12674  * Local variables:
12675  * c-indentation-style: bsd
12676  * c-basic-offset: 4
12677  * indent-tabs-mode: t
12678  * End:
12679  *
12680  * ex: set ts=8 sts=4 sw=4 noet:
12681  */