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