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