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