Vladimir Marek is now a perl author
[perl.git] / sv.c
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall
5  *    and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'I wonder what the Entish is for "yes" and "no",' he thought.
14  *                                                      --Pippin
15  *
16  *     [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"]
17  */
18
19 /*
20  *
21  *
22  * This file contains the code that creates, manipulates and destroys
23  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
24  * structure of an SV, so their creation and destruction is handled
25  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
26  * level functions (eg. substr, split, join) for each of the types are
27  * in the pp*.c files.
28  */
29
30 #include "EXTERN.h"
31 #define PERL_IN_SV_C
32 #include "perl.h"
33 #include "regcomp.h"
34 #ifdef __VMS
35 # include <rms.h>
36 #endif
37
38 #ifndef HAS_C99
39 # if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS)
40 #  define HAS_C99 1
41 # endif
42 #endif
43 #ifdef HAS_C99
44 # include <stdint.h>
45 #endif
46
47 #ifdef __Lynx__
48 /* Missing proto on LynxOS */
49   char *gconvert(double, int, int,  char *);
50 #endif
51
52 #ifdef PERL_NEW_COPY_ON_WRITE
53 #   ifndef SV_COW_THRESHOLD
54 #    define SV_COW_THRESHOLD                    0   /* COW iff len > K */
55 #   endif
56 #   ifndef SV_COWBUF_THRESHOLD
57 #    define SV_COWBUF_THRESHOLD                 1250 /* COW iff len > K */
58 #   endif
59 #   ifndef SV_COW_MAX_WASTE_THRESHOLD
60 #    define SV_COW_MAX_WASTE_THRESHOLD          80   /* COW iff (len - cur) < K */
61 #   endif
62 #   ifndef SV_COWBUF_WASTE_THRESHOLD
63 #    define SV_COWBUF_WASTE_THRESHOLD           80   /* COW iff (len - cur) < K */
64 #   endif
65 #   ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
66 #    define SV_COW_MAX_WASTE_FACTOR_THRESHOLD   2    /* COW iff len < (cur * K) */
67 #   endif
68 #   ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
69 #    define SV_COWBUF_WASTE_FACTOR_THRESHOLD    2    /* COW iff len < (cur * K) */
70 #   endif
71 #endif
72 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
73    hold is 0. */
74 #if SV_COW_THRESHOLD
75 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
76 #else
77 # define GE_COW_THRESHOLD(cur) 1
78 #endif
79 #if SV_COWBUF_THRESHOLD
80 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
81 #else
82 # define GE_COWBUF_THRESHOLD(cur) 1
83 #endif
84 #if SV_COW_MAX_WASTE_THRESHOLD
85 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
86 #else
87 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
88 #endif
89 #if SV_COWBUF_WASTE_THRESHOLD
90 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
91 #else
92 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
93 #endif
94 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
95 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
96 #else
97 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
98 #endif
99 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
100 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
101 #else
102 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
103 #endif
104
105 #define CHECK_COW_THRESHOLD(cur,len) (\
106     GE_COW_THRESHOLD((cur)) && \
107     GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
108     GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
109 )
110 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
111     GE_COWBUF_THRESHOLD((cur)) && \
112     GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
113     GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
114 )
115 /* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
116  * has a mandatory return value, even though that value is just the same
117  * as the buf arg */
118
119 #ifdef PERL_UTF8_CACHE_ASSERT
120 /* if adding more checks watch out for the following tests:
121  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
122  *   lib/utf8.t lib/Unicode/Collate/t/index.t
123  * --jhi
124  */
125 #   define ASSERT_UTF8_CACHE(cache) \
126     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
127                               assert((cache)[2] <= (cache)[3]); \
128                               assert((cache)[3] <= (cache)[1]);} \
129                               } STMT_END
130 #else
131 #   define ASSERT_UTF8_CACHE(cache) NOOP
132 #endif
133
134 #ifdef PERL_OLD_COPY_ON_WRITE
135 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
136 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
137 #endif
138
139 /* ============================================================================
140
141 =head1 Allocation and deallocation of SVs.
142 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
143 sv, av, hv...) contains type and reference count information, and for
144 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
145 contains fields specific to each type.  Some types store all they need
146 in the head, so don't have a body.
147
148 In all but the most memory-paranoid configurations (ex: PURIFY), heads
149 and bodies are allocated out of arenas, which by default are
150 approximately 4K chunks of memory parcelled up into N heads or bodies.
151 Sv-bodies are allocated by their sv-type, guaranteeing size
152 consistency needed to allocate safely from arrays.
153
154 For SV-heads, the first slot in each arena is reserved, and holds a
155 link to the next arena, some flags, and a note of the number of slots.
156 Snaked through each arena chain is a linked list of free items; when
157 this becomes empty, an extra arena is allocated and divided up into N
158 items which are threaded into the free list.
159
160 SV-bodies are similar, but they use arena-sets by default, which
161 separate the link and info from the arena itself, and reclaim the 1st
162 slot in the arena.  SV-bodies are further described later.
163
164 The following global variables are associated with arenas:
165
166  PL_sv_arenaroot     pointer to list of SV arenas
167  PL_sv_root          pointer to list of free SV structures
168
169  PL_body_arenas      head of linked-list of body arenas
170  PL_body_roots[]     array of pointers to list of free bodies of svtype
171                      arrays are indexed by the svtype needed
172
173 A few special SV heads are not allocated from an arena, but are
174 instead directly created in the interpreter structure, eg PL_sv_undef.
175 The size of arenas can be changed from the default by setting
176 PERL_ARENA_SIZE appropriately at compile time.
177
178 The SV arena serves the secondary purpose of allowing still-live SVs
179 to be located and destroyed during final cleanup.
180
181 At the lowest level, the macros new_SV() and del_SV() grab and free
182 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
183 to return the SV to the free list with error checking.) new_SV() calls
184 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
185 SVs in the free list have their SvTYPE field set to all ones.
186
187 At the time of very final cleanup, sv_free_arenas() is called from
188 perl_destruct() to physically free all the arenas allocated since the
189 start of the interpreter.
190
191 The function visit() scans the SV arenas list, and calls a specified
192 function for each SV it finds which is still live - ie which has an SvTYPE
193 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
194 following functions (specified as [function that calls visit()] / [function
195 called by visit() for each SV]):
196
197     sv_report_used() / do_report_used()
198                         dump all remaining SVs (debugging aid)
199
200     sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
201                       do_clean_named_io_objs(),do_curse()
202                         Attempt to free all objects pointed to by RVs,
203                         try to do the same for all objects indir-
204                         ectly referenced by typeglobs too, and
205                         then do a final sweep, cursing any
206                         objects that remain.  Called once from
207                         perl_destruct(), prior to calling sv_clean_all()
208                         below.
209
210     sv_clean_all() / do_clean_all()
211                         SvREFCNT_dec(sv) each remaining SV, possibly
212                         triggering an sv_free(). It also sets the
213                         SVf_BREAK flag on the SV to indicate that the
214                         refcnt has been artificially lowered, and thus
215                         stopping sv_free() from giving spurious warnings
216                         about SVs which unexpectedly have a refcnt
217                         of zero.  called repeatedly from perl_destruct()
218                         until there are no SVs left.
219
220 =head2 Arena allocator API Summary
221
222 Private API to rest of sv.c
223
224     new_SV(),  del_SV(),
225
226     new_XPVNV(), del_XPVGV(),
227     etc
228
229 Public API:
230
231     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
232
233 =cut
234
235  * ========================================================================= */
236
237 /*
238  * "A time to plant, and a time to uproot what was planted..."
239  */
240
241 #ifdef PERL_MEM_LOG
242 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
243             Perl_mem_log_new_sv(sv, file, line, func)
244 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
245             Perl_mem_log_del_sv(sv, file, line, func)
246 #else
247 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
248 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
249 #endif
250
251 #ifdef DEBUG_LEAKING_SCALARS
252 #  define FREE_SV_DEBUG_FILE(sv) STMT_START { \
253         if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
254     } STMT_END
255 #  define DEBUG_SV_SERIAL(sv)                                               \
256     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
257             PTR2UV(sv), (long)(sv)->sv_debug_serial))
258 #else
259 #  define FREE_SV_DEBUG_FILE(sv)
260 #  define DEBUG_SV_SERIAL(sv)   NOOP
261 #endif
262
263 #ifdef PERL_POISON
264 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
265 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
266 /* Whilst I'd love to do this, it seems that things like to check on
267    unreferenced scalars
268 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
269 */
270 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
271                                 PoisonNew(&SvREFCNT(sv), 1, U32)
272 #else
273 #  define SvARENA_CHAIN(sv)     SvANY(sv)
274 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
275 #  define POSION_SV_HEAD(sv)
276 #endif
277
278 /* Mark an SV head as unused, and add to free list.
279  *
280  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
281  * its refcount artificially decremented during global destruction, so
282  * there may be dangling pointers to it. The last thing we want in that
283  * case is for it to be reused. */
284
285 #define plant_SV(p) \
286     STMT_START {                                        \
287         const U32 old_flags = SvFLAGS(p);                       \
288         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
289         DEBUG_SV_SERIAL(p);                             \
290         FREE_SV_DEBUG_FILE(p);                          \
291         POSION_SV_HEAD(p);                              \
292         SvFLAGS(p) = SVTYPEMASK;                        \
293         if (!(old_flags & SVf_BREAK)) {         \
294             SvARENA_CHAIN_SET(p, PL_sv_root);   \
295             PL_sv_root = (p);                           \
296         }                                               \
297         --PL_sv_count;                                  \
298     } STMT_END
299
300 #define uproot_SV(p) \
301     STMT_START {                                        \
302         (p) = PL_sv_root;                               \
303         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
304         ++PL_sv_count;                                  \
305     } STMT_END
306
307
308 /* make some more SVs by adding another arena */
309
310 STATIC SV*
311 S_more_sv(pTHX)
312 {
313     SV* sv;
314     char *chunk;                /* must use New here to match call to */
315     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
316     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
317     uproot_SV(sv);
318     return sv;
319 }
320
321 /* new_SV(): return a new, empty SV head */
322
323 #ifdef DEBUG_LEAKING_SCALARS
324 /* provide a real function for a debugger to play with */
325 STATIC SV*
326 S_new_SV(pTHX_ const char *file, int line, const char *func)
327 {
328     SV* sv;
329
330     if (PL_sv_root)
331         uproot_SV(sv);
332     else
333         sv = S_more_sv(aTHX);
334     SvANY(sv) = 0;
335     SvREFCNT(sv) = 1;
336     SvFLAGS(sv) = 0;
337     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
338     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
339                 ? PL_parser->copline
340                 :  PL_curcop
341                     ? CopLINE(PL_curcop)
342                     : 0
343             );
344     sv->sv_debug_inpad = 0;
345     sv->sv_debug_parent = NULL;
346     sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
347
348     sv->sv_debug_serial = PL_sv_serial++;
349
350     MEM_LOG_NEW_SV(sv, file, line, func);
351     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
352             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
353
354     return sv;
355 }
356 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
357
358 #else
359 #  define new_SV(p) \
360     STMT_START {                                        \
361         if (PL_sv_root)                                 \
362             uproot_SV(p);                               \
363         else                                            \
364             (p) = S_more_sv(aTHX);                      \
365         SvANY(p) = 0;                                   \
366         SvREFCNT(p) = 1;                                \
367         SvFLAGS(p) = 0;                                 \
368         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
369     } STMT_END
370 #endif
371
372
373 /* del_SV(): return an empty SV head to the free list */
374
375 #ifdef DEBUGGING
376
377 #define del_SV(p) \
378     STMT_START {                                        \
379         if (DEBUG_D_TEST)                               \
380             del_sv(p);                                  \
381         else                                            \
382             plant_SV(p);                                \
383     } STMT_END
384
385 STATIC void
386 S_del_sv(pTHX_ SV *p)
387 {
388     dVAR;
389
390     PERL_ARGS_ASSERT_DEL_SV;
391
392     if (DEBUG_D_TEST) {
393         SV* sva;
394         bool ok = 0;
395         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
396             const SV * const sv = sva + 1;
397             const SV * const svend = &sva[SvREFCNT(sva)];
398             if (p >= sv && p < svend) {
399                 ok = 1;
400                 break;
401             }
402         }
403         if (!ok) {
404             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
405                              "Attempt to free non-arena SV: 0x%"UVxf
406                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
407             return;
408         }
409     }
410     plant_SV(p);
411 }
412
413 #else /* ! DEBUGGING */
414
415 #define del_SV(p)   plant_SV(p)
416
417 #endif /* DEBUGGING */
418
419
420 /*
421 =head1 SV Manipulation Functions
422
423 =for apidoc sv_add_arena
424
425 Given a chunk of memory, link it to the head of the list of arenas,
426 and split it into a list of free SVs.
427
428 =cut
429 */
430
431 static void
432 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
433 {
434     SV *const sva = MUTABLE_SV(ptr);
435     SV* sv;
436     SV* svend;
437
438     PERL_ARGS_ASSERT_SV_ADD_ARENA;
439
440     /* The first SV in an arena isn't an SV. */
441     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
442     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
443     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
444
445     PL_sv_arenaroot = sva;
446     PL_sv_root = sva + 1;
447
448     svend = &sva[SvREFCNT(sva) - 1];
449     sv = sva + 1;
450     while (sv < svend) {
451         SvARENA_CHAIN_SET(sv, (sv + 1));
452 #ifdef DEBUGGING
453         SvREFCNT(sv) = 0;
454 #endif
455         /* Must always set typemask because it's always checked in on cleanup
456            when the arenas are walked looking for objects.  */
457         SvFLAGS(sv) = SVTYPEMASK;
458         sv++;
459     }
460     SvARENA_CHAIN_SET(sv, 0);
461 #ifdef DEBUGGING
462     SvREFCNT(sv) = 0;
463 #endif
464     SvFLAGS(sv) = SVTYPEMASK;
465 }
466
467 /* visit(): call the named function for each non-free SV in the arenas
468  * whose flags field matches the flags/mask args. */
469
470 STATIC I32
471 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
472 {
473     SV* sva;
474     I32 visited = 0;
475
476     PERL_ARGS_ASSERT_VISIT;
477
478     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
479         const SV * const svend = &sva[SvREFCNT(sva)];
480         SV* sv;
481         for (sv = sva + 1; sv < svend; ++sv) {
482             if (SvTYPE(sv) != (svtype)SVTYPEMASK
483                     && (sv->sv_flags & mask) == flags
484                     && SvREFCNT(sv))
485             {
486                 (*f)(aTHX_ sv);
487                 ++visited;
488             }
489         }
490     }
491     return visited;
492 }
493
494 #ifdef DEBUGGING
495
496 /* called by sv_report_used() for each live SV */
497
498 static void
499 do_report_used(pTHX_ SV *const sv)
500 {
501     if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
502         PerlIO_printf(Perl_debug_log, "****\n");
503         sv_dump(sv);
504     }
505 }
506 #endif
507
508 /*
509 =for apidoc sv_report_used
510
511 Dump the contents of all SVs not yet freed (debugging aid).
512
513 =cut
514 */
515
516 void
517 Perl_sv_report_used(pTHX)
518 {
519 #ifdef DEBUGGING
520     visit(do_report_used, 0, 0);
521 #else
522     PERL_UNUSED_CONTEXT;
523 #endif
524 }
525
526 /* called by sv_clean_objs() for each live SV */
527
528 static void
529 do_clean_objs(pTHX_ SV *const ref)
530 {
531     assert (SvROK(ref));
532     {
533         SV * const target = SvRV(ref);
534         if (SvOBJECT(target)) {
535             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
536             if (SvWEAKREF(ref)) {
537                 sv_del_backref(target, ref);
538                 SvWEAKREF_off(ref);
539                 SvRV_set(ref, NULL);
540             } else {
541                 SvROK_off(ref);
542                 SvRV_set(ref, NULL);
543                 SvREFCNT_dec_NN(target);
544             }
545         }
546     }
547 }
548
549
550 /* clear any slots in a GV which hold objects - except IO;
551  * called by sv_clean_objs() for each live GV */
552
553 static void
554 do_clean_named_objs(pTHX_ SV *const sv)
555 {
556     SV *obj;
557     assert(SvTYPE(sv) == SVt_PVGV);
558     assert(isGV_with_GP(sv));
559     if (!GvGP(sv))
560         return;
561
562     /* freeing GP entries may indirectly free the current GV;
563      * hold onto it while we mess with the GP slots */
564     SvREFCNT_inc(sv);
565
566     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
567         DEBUG_D((PerlIO_printf(Perl_debug_log,
568                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
569         GvSV(sv) = NULL;
570         SvREFCNT_dec_NN(obj);
571     }
572     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
573         DEBUG_D((PerlIO_printf(Perl_debug_log,
574                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
575         GvAV(sv) = NULL;
576         SvREFCNT_dec_NN(obj);
577     }
578     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
579         DEBUG_D((PerlIO_printf(Perl_debug_log,
580                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
581         GvHV(sv) = NULL;
582         SvREFCNT_dec_NN(obj);
583     }
584     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
585         DEBUG_D((PerlIO_printf(Perl_debug_log,
586                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
587         GvCV_set(sv, NULL);
588         SvREFCNT_dec_NN(obj);
589     }
590     SvREFCNT_dec_NN(sv); /* undo the inc above */
591 }
592
593 /* clear any IO slots in a GV which hold objects (except stderr, defout);
594  * called by sv_clean_objs() for each live GV */
595
596 static void
597 do_clean_named_io_objs(pTHX_ SV *const sv)
598 {
599     SV *obj;
600     assert(SvTYPE(sv) == SVt_PVGV);
601     assert(isGV_with_GP(sv));
602     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
603         return;
604
605     SvREFCNT_inc(sv);
606     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
607         DEBUG_D((PerlIO_printf(Perl_debug_log,
608                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
609         GvIOp(sv) = NULL;
610         SvREFCNT_dec_NN(obj);
611     }
612     SvREFCNT_dec_NN(sv); /* undo the inc above */
613 }
614
615 /* Void wrapper to pass to visit() */
616 static void
617 do_curse(pTHX_ SV * const sv) {
618     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
619      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
620         return;
621     (void)curse(sv, 0);
622 }
623
624 /*
625 =for apidoc sv_clean_objs
626
627 Attempt to destroy all objects not yet freed.
628
629 =cut
630 */
631
632 void
633 Perl_sv_clean_objs(pTHX)
634 {
635     GV *olddef, *olderr;
636     PL_in_clean_objs = TRUE;
637     visit(do_clean_objs, SVf_ROK, SVf_ROK);
638     /* Some barnacles may yet remain, clinging to typeglobs.
639      * Run the non-IO destructors first: they may want to output
640      * error messages, close files etc */
641     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
642     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
643     /* And if there are some very tenacious barnacles clinging to arrays,
644        closures, or what have you.... */
645     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
646     olddef = PL_defoutgv;
647     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
648     if (olddef && isGV_with_GP(olddef))
649         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
650     olderr = PL_stderrgv;
651     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
652     if (olderr && isGV_with_GP(olderr))
653         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
654     SvREFCNT_dec(olddef);
655     PL_in_clean_objs = FALSE;
656 }
657
658 /* called by sv_clean_all() for each live SV */
659
660 static void
661 do_clean_all(pTHX_ SV *const sv)
662 {
663     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
664         /* don't clean pid table and strtab */
665         return;
666     }
667     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
668     SvFLAGS(sv) |= SVf_BREAK;
669     SvREFCNT_dec_NN(sv);
670 }
671
672 /*
673 =for apidoc sv_clean_all
674
675 Decrement the refcnt of each remaining SV, possibly triggering a
676 cleanup.  This function may have to be called multiple times to free
677 SVs which are in complex self-referential hierarchies.
678
679 =cut
680 */
681
682 I32
683 Perl_sv_clean_all(pTHX)
684 {
685     I32 cleaned;
686     PL_in_clean_all = TRUE;
687     cleaned = visit(do_clean_all, 0,0);
688     return cleaned;
689 }
690
691 /*
692   ARENASETS: a meta-arena implementation which separates arena-info
693   into struct arena_set, which contains an array of struct
694   arena_descs, each holding info for a single arena.  By separating
695   the meta-info from the arena, we recover the 1st slot, formerly
696   borrowed for list management.  The arena_set is about the size of an
697   arena, avoiding the needless malloc overhead of a naive linked-list.
698
699   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
700   memory in the last arena-set (1/2 on average).  In trade, we get
701   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
702   smaller types).  The recovery of the wasted space allows use of
703   small arenas for large, rare body types, by changing array* fields
704   in body_details_by_type[] below.
705 */
706 struct arena_desc {
707     char       *arena;          /* the raw storage, allocated aligned */
708     size_t      size;           /* its size ~4k typ */
709     svtype      utype;          /* bodytype stored in arena */
710 };
711
712 struct arena_set;
713
714 /* Get the maximum number of elements in set[] such that struct arena_set
715    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
716    therefore likely to be 1 aligned memory page.  */
717
718 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
719                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
720
721 struct arena_set {
722     struct arena_set* next;
723     unsigned int   set_size;    /* ie ARENAS_PER_SET */
724     unsigned int   curr;        /* index of next available arena-desc */
725     struct arena_desc set[ARENAS_PER_SET];
726 };
727
728 /*
729 =for apidoc sv_free_arenas
730
731 Deallocate the memory used by all arenas.  Note that all the individual SV
732 heads and bodies within the arenas must already have been freed.
733
734 =cut
735
736 */
737 void
738 Perl_sv_free_arenas(pTHX)
739 {
740     SV* sva;
741     SV* svanext;
742     unsigned int i;
743
744     /* Free arenas here, but be careful about fake ones.  (We assume
745        contiguity of the fake ones with the corresponding real ones.) */
746
747     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
748         svanext = MUTABLE_SV(SvANY(sva));
749         while (svanext && SvFAKE(svanext))
750             svanext = MUTABLE_SV(SvANY(svanext));
751
752         if (!SvFAKE(sva))
753             Safefree(sva);
754     }
755
756     {
757         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
758
759         while (aroot) {
760             struct arena_set *current = aroot;
761             i = aroot->curr;
762             while (i--) {
763                 assert(aroot->set[i].arena);
764                 Safefree(aroot->set[i].arena);
765             }
766             aroot = aroot->next;
767             Safefree(current);
768         }
769     }
770     PL_body_arenas = 0;
771
772     i = PERL_ARENA_ROOTS_SIZE;
773     while (i--)
774         PL_body_roots[i] = 0;
775
776     PL_sv_arenaroot = 0;
777     PL_sv_root = 0;
778 }
779
780 /*
781   Here are mid-level routines that manage the allocation of bodies out
782   of the various arenas.  There are 5 kinds of arenas:
783
784   1. SV-head arenas, which are discussed and handled above
785   2. regular body arenas
786   3. arenas for reduced-size bodies
787   4. Hash-Entry arenas
788
789   Arena types 2 & 3 are chained by body-type off an array of
790   arena-root pointers, which is indexed by svtype.  Some of the
791   larger/less used body types are malloced singly, since a large
792   unused block of them is wasteful.  Also, several svtypes dont have
793   bodies; the data fits into the sv-head itself.  The arena-root
794   pointer thus has a few unused root-pointers (which may be hijacked
795   later for arena types 4,5)
796
797   3 differs from 2 as an optimization; some body types have several
798   unused fields in the front of the structure (which are kept in-place
799   for consistency).  These bodies can be allocated in smaller chunks,
800   because the leading fields arent accessed.  Pointers to such bodies
801   are decremented to point at the unused 'ghost' memory, knowing that
802   the pointers are used with offsets to the real memory.
803
804
805 =head1 SV-Body Allocation
806
807 =cut
808
809 Allocation of SV-bodies is similar to SV-heads, differing as follows;
810 the allocation mechanism is used for many body types, so is somewhat
811 more complicated, it uses arena-sets, and has no need for still-live
812 SV detection.
813
814 At the outermost level, (new|del)_X*V macros return bodies of the
815 appropriate type.  These macros call either (new|del)_body_type or
816 (new|del)_body_allocated macro pairs, depending on specifics of the
817 type.  Most body types use the former pair, the latter pair is used to
818 allocate body types with "ghost fields".
819
820 "ghost fields" are fields that are unused in certain types, and
821 consequently don't need to actually exist.  They are declared because
822 they're part of a "base type", which allows use of functions as
823 methods.  The simplest examples are AVs and HVs, 2 aggregate types
824 which don't use the fields which support SCALAR semantics.
825
826 For these types, the arenas are carved up into appropriately sized
827 chunks, we thus avoid wasted memory for those unaccessed members.
828 When bodies are allocated, we adjust the pointer back in memory by the
829 size of the part not allocated, so it's as if we allocated the full
830 structure.  (But things will all go boom if you write to the part that
831 is "not there", because you'll be overwriting the last members of the
832 preceding structure in memory.)
833
834 We calculate the correction using the STRUCT_OFFSET macro on the first
835 member present.  If the allocated structure is smaller (no initial NV
836 actually allocated) then the net effect is to subtract the size of the NV
837 from the pointer, to return a new pointer as if an initial NV were actually
838 allocated.  (We were using structures named *_allocated for this, but
839 this turned out to be a subtle bug, because a structure without an NV
840 could have a lower alignment constraint, but the compiler is allowed to
841 optimised accesses based on the alignment constraint of the actual pointer
842 to the full structure, for example, using a single 64 bit load instruction
843 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
844
845 This is the same trick as was used for NV and IV bodies.  Ironically it
846 doesn't need to be used for NV bodies any more, because NV is now at
847 the start of the structure.  IV bodies don't need it either, because
848 they are no longer allocated.
849
850 In turn, the new_body_* allocators call S_new_body(), which invokes
851 new_body_inline macro, which takes a lock, and takes a body off the
852 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
853 necessary to refresh an empty list.  Then the lock is released, and
854 the body is returned.
855
856 Perl_more_bodies allocates a new arena, and carves it up into an array of N
857 bodies, which it strings into a linked list.  It looks up arena-size
858 and body-size from the body_details table described below, thus
859 supporting the multiple body-types.
860
861 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
862 the (new|del)_X*V macros are mapped directly to malloc/free.
863
864 For each sv-type, struct body_details bodies_by_type[] carries
865 parameters which control these aspects of SV handling:
866
867 Arena_size determines whether arenas are used for this body type, and if
868 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
869 zero, forcing individual mallocs and frees.
870
871 Body_size determines how big a body is, and therefore how many fit into
872 each arena.  Offset carries the body-pointer adjustment needed for
873 "ghost fields", and is used in *_allocated macros.
874
875 But its main purpose is to parameterize info needed in
876 Perl_sv_upgrade().  The info here dramatically simplifies the function
877 vs the implementation in 5.8.8, making it table-driven.  All fields
878 are used for this, except for arena_size.
879
880 For the sv-types that have no bodies, arenas are not used, so those
881 PL_body_roots[sv_type] are unused, and can be overloaded.  In
882 something of a special case, SVt_NULL is borrowed for HE arenas;
883 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
884 bodies_by_type[SVt_NULL] slot is not used, as the table is not
885 available in hv.c.
886
887 */
888
889 struct body_details {
890     U8 body_size;       /* Size to allocate  */
891     U8 copy;            /* Size of structure to copy (may be shorter)  */
892     U8 offset;
893     unsigned int type : 4;          /* We have space for a sanity check.  */
894     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
895     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
896     unsigned int arena : 1;         /* Allocated from an arena */
897     size_t arena_size;              /* Size of arena to allocate */
898 };
899
900 #define HADNV FALSE
901 #define NONV TRUE
902
903
904 #ifdef PURIFY
905 /* With -DPURFIY we allocate everything directly, and don't use arenas.
906    This seems a rather elegant way to simplify some of the code below.  */
907 #define HASARENA FALSE
908 #else
909 #define HASARENA TRUE
910 #endif
911 #define NOARENA FALSE
912
913 /* Size the arenas to exactly fit a given number of bodies.  A count
914    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
915    simplifying the default.  If count > 0, the arena is sized to fit
916    only that many bodies, allowing arenas to be used for large, rare
917    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
918    limited by PERL_ARENA_SIZE, so we can safely oversize the
919    declarations.
920  */
921 #define FIT_ARENA0(body_size)                           \
922     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
923 #define FIT_ARENAn(count,body_size)                     \
924     ( count * body_size <= PERL_ARENA_SIZE)             \
925     ? count * body_size                                 \
926     : FIT_ARENA0 (body_size)
927 #define FIT_ARENA(count,body_size)                      \
928     count                                               \
929     ? FIT_ARENAn (count, body_size)                     \
930     : FIT_ARENA0 (body_size)
931
932 /* Calculate the length to copy. Specifically work out the length less any
933    final padding the compiler needed to add.  See the comment in sv_upgrade
934    for why copying the padding proved to be a bug.  */
935
936 #define copy_length(type, last_member) \
937         STRUCT_OFFSET(type, last_member) \
938         + sizeof (((type*)SvANY((const SV *)0))->last_member)
939
940 static const struct body_details bodies_by_type[] = {
941     /* HEs use this offset for their arena.  */
942     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
943
944     /* IVs are in the head, so the allocation size is 0.  */
945     { 0,
946       sizeof(IV), /* This is used to copy out the IV body.  */
947       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
948       NOARENA /* IVS don't need an arena  */, 0
949     },
950
951     { sizeof(NV), sizeof(NV),
952       STRUCT_OFFSET(XPVNV, xnv_u),
953       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
954
955     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
956       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
957       + STRUCT_OFFSET(XPV, xpv_cur),
958       SVt_PV, FALSE, NONV, HASARENA,
959       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
960
961     { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
962       copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
963       + STRUCT_OFFSET(XPV, xpv_cur),
964       SVt_INVLIST, TRUE, NONV, HASARENA,
965       FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
966
967     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
968       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
969       + STRUCT_OFFSET(XPV, xpv_cur),
970       SVt_PVIV, FALSE, NONV, HASARENA,
971       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
972
973     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
974       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
975       + STRUCT_OFFSET(XPV, xpv_cur),
976       SVt_PVNV, FALSE, HADNV, HASARENA,
977       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
978
979     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
980       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
981
982     { sizeof(regexp),
983       sizeof(regexp),
984       0,
985       SVt_REGEXP, TRUE, NONV, HASARENA,
986       FIT_ARENA(0, sizeof(regexp))
987     },
988
989     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
990       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
991     
992     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
993       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
994
995     { sizeof(XPVAV),
996       copy_length(XPVAV, xav_alloc),
997       0,
998       SVt_PVAV, TRUE, NONV, HASARENA,
999       FIT_ARENA(0, sizeof(XPVAV)) },
1000
1001     { sizeof(XPVHV),
1002       copy_length(XPVHV, xhv_max),
1003       0,
1004       SVt_PVHV, TRUE, NONV, HASARENA,
1005       FIT_ARENA(0, sizeof(XPVHV)) },
1006
1007     { sizeof(XPVCV),
1008       sizeof(XPVCV),
1009       0,
1010       SVt_PVCV, TRUE, NONV, HASARENA,
1011       FIT_ARENA(0, sizeof(XPVCV)) },
1012
1013     { sizeof(XPVFM),
1014       sizeof(XPVFM),
1015       0,
1016       SVt_PVFM, TRUE, NONV, NOARENA,
1017       FIT_ARENA(20, sizeof(XPVFM)) },
1018
1019     { sizeof(XPVIO),
1020       sizeof(XPVIO),
1021       0,
1022       SVt_PVIO, TRUE, NONV, HASARENA,
1023       FIT_ARENA(24, sizeof(XPVIO)) },
1024 };
1025
1026 #define new_body_allocated(sv_type)             \
1027     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1028              - bodies_by_type[sv_type].offset)
1029
1030 /* return a thing to the free list */
1031
1032 #define del_body(thing, root)                           \
1033     STMT_START {                                        \
1034         void ** const thing_copy = (void **)thing;      \
1035         *thing_copy = *root;                            \
1036         *root = (void*)thing_copy;                      \
1037     } STMT_END
1038
1039 #ifdef PURIFY
1040
1041 #define new_XNV()       safemalloc(sizeof(XPVNV))
1042 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
1043 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
1044
1045 #define del_XPVGV(p)    safefree(p)
1046
1047 #else /* !PURIFY */
1048
1049 #define new_XNV()       new_body_allocated(SVt_NV)
1050 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1051 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1052
1053 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
1054                                  &PL_body_roots[SVt_PVGV])
1055
1056 #endif /* PURIFY */
1057
1058 /* no arena for you! */
1059
1060 #define new_NOARENA(details) \
1061         safemalloc((details)->body_size + (details)->offset)
1062 #define new_NOARENAZ(details) \
1063         safecalloc((details)->body_size + (details)->offset, 1)
1064
1065 void *
1066 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1067                   const size_t arena_size)
1068 {
1069     void ** const root = &PL_body_roots[sv_type];
1070     struct arena_desc *adesc;
1071     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1072     unsigned int curr;
1073     char *start;
1074     const char *end;
1075     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1076 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1077     dVAR;
1078 #endif
1079 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1080     static bool done_sanity_check;
1081
1082     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1083      * variables like done_sanity_check. */
1084     if (!done_sanity_check) {
1085         unsigned int i = SVt_LAST;
1086
1087         done_sanity_check = TRUE;
1088
1089         while (i--)
1090             assert (bodies_by_type[i].type == i);
1091     }
1092 #endif
1093
1094     assert(arena_size);
1095
1096     /* may need new arena-set to hold new arena */
1097     if (!aroot || aroot->curr >= aroot->set_size) {
1098         struct arena_set *newroot;
1099         Newxz(newroot, 1, struct arena_set);
1100         newroot->set_size = ARENAS_PER_SET;
1101         newroot->next = aroot;
1102         aroot = newroot;
1103         PL_body_arenas = (void *) newroot;
1104         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1105     }
1106
1107     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1108     curr = aroot->curr++;
1109     adesc = &(aroot->set[curr]);
1110     assert(!adesc->arena);
1111     
1112     Newx(adesc->arena, good_arena_size, char);
1113     adesc->size = good_arena_size;
1114     adesc->utype = sv_type;
1115     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
1116                           curr, (void*)adesc->arena, (UV)good_arena_size));
1117
1118     start = (char *) adesc->arena;
1119
1120     /* Get the address of the byte after the end of the last body we can fit.
1121        Remember, this is integer division:  */
1122     end = start + good_arena_size / body_size * body_size;
1123
1124     /* computed count doesn't reflect the 1st slot reservation */
1125 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1126     DEBUG_m(PerlIO_printf(Perl_debug_log,
1127                           "arena %p end %p arena-size %d (from %d) type %d "
1128                           "size %d ct %d\n",
1129                           (void*)start, (void*)end, (int)good_arena_size,
1130                           (int)arena_size, sv_type, (int)body_size,
1131                           (int)good_arena_size / (int)body_size));
1132 #else
1133     DEBUG_m(PerlIO_printf(Perl_debug_log,
1134                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1135                           (void*)start, (void*)end,
1136                           (int)arena_size, sv_type, (int)body_size,
1137                           (int)good_arena_size / (int)body_size));
1138 #endif
1139     *root = (void *)start;
1140
1141     while (1) {
1142         /* Where the next body would start:  */
1143         char * const next = start + body_size;
1144
1145         if (next >= end) {
1146             /* This is the last body:  */
1147             assert(next == end);
1148
1149             *(void **)start = 0;
1150             return *root;
1151         }
1152
1153         *(void**) start = (void *)next;
1154         start = next;
1155     }
1156 }
1157
1158 /* grab a new thing from the free list, allocating more if necessary.
1159    The inline version is used for speed in hot routines, and the
1160    function using it serves the rest (unless PURIFY).
1161 */
1162 #define new_body_inline(xpv, sv_type) \
1163     STMT_START { \
1164         void ** const r3wt = &PL_body_roots[sv_type]; \
1165         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1166           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1167                                              bodies_by_type[sv_type].body_size,\
1168                                              bodies_by_type[sv_type].arena_size)); \
1169         *(r3wt) = *(void**)(xpv); \
1170     } STMT_END
1171
1172 #ifndef PURIFY
1173
1174 STATIC void *
1175 S_new_body(pTHX_ const svtype sv_type)
1176 {
1177     void *xpv;
1178     new_body_inline(xpv, sv_type);
1179     return xpv;
1180 }
1181
1182 #endif
1183
1184 static const struct body_details fake_rv =
1185     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1186
1187 /*
1188 =for apidoc sv_upgrade
1189
1190 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1191 SV, then copies across as much information as possible from the old body.
1192 It croaks if the SV is already in a more complex form than requested.  You
1193 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1194 before calling C<sv_upgrade>, and hence does not croak.  See also
1195 C<svtype>.
1196
1197 =cut
1198 */
1199
1200 void
1201 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1202 {
1203     void*       old_body;
1204     void*       new_body;
1205     const svtype old_type = SvTYPE(sv);
1206     const struct body_details *new_type_details;
1207     const struct body_details *old_type_details
1208         = bodies_by_type + old_type;
1209     SV *referant = NULL;
1210
1211     PERL_ARGS_ASSERT_SV_UPGRADE;
1212
1213     if (old_type == new_type)
1214         return;
1215
1216     /* This clause was purposefully added ahead of the early return above to
1217        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1218        inference by Nick I-S that it would fix other troublesome cases. See
1219        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1220
1221        Given that shared hash key scalars are no longer PVIV, but PV, there is
1222        no longer need to unshare so as to free up the IVX slot for its proper
1223        purpose. So it's safe to move the early return earlier.  */
1224
1225     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1226         sv_force_normal_flags(sv, 0);
1227     }
1228
1229     old_body = SvANY(sv);
1230
1231     /* Copying structures onto other structures that have been neatly zeroed
1232        has a subtle gotcha. Consider XPVMG
1233
1234        +------+------+------+------+------+-------+-------+
1235        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1236        +------+------+------+------+------+-------+-------+
1237        0      4      8     12     16     20      24      28
1238
1239        where NVs are aligned to 8 bytes, so that sizeof that structure is
1240        actually 32 bytes long, with 4 bytes of padding at the end:
1241
1242        +------+------+------+------+------+-------+-------+------+
1243        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1244        +------+------+------+------+------+-------+-------+------+
1245        0      4      8     12     16     20      24      28     32
1246
1247        so what happens if you allocate memory for this structure:
1248
1249        +------+------+------+------+------+-------+-------+------+------+...
1250        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1251        +------+------+------+------+------+-------+-------+------+------+...
1252        0      4      8     12     16     20      24      28     32     36
1253
1254        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1255        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1256        started out as zero once, but it's quite possible that it isn't. So now,
1257        rather than a nicely zeroed GP, you have it pointing somewhere random.
1258        Bugs ensue.
1259
1260        (In fact, GP ends up pointing at a previous GP structure, because the
1261        principle cause of the padding in XPVMG getting garbage is a copy of
1262        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1263        this happens to be moot because XPVGV has been re-ordered, with GP
1264        no longer after STASH)
1265
1266        So we are careful and work out the size of used parts of all the
1267        structures.  */
1268
1269     switch (old_type) {
1270     case SVt_NULL:
1271         break;
1272     case SVt_IV:
1273         if (SvROK(sv)) {
1274             referant = SvRV(sv);
1275             old_type_details = &fake_rv;
1276             if (new_type == SVt_NV)
1277                 new_type = SVt_PVNV;
1278         } else {
1279             if (new_type < SVt_PVIV) {
1280                 new_type = (new_type == SVt_NV)
1281                     ? SVt_PVNV : SVt_PVIV;
1282             }
1283         }
1284         break;
1285     case SVt_NV:
1286         if (new_type < SVt_PVNV) {
1287             new_type = SVt_PVNV;
1288         }
1289         break;
1290     case SVt_PV:
1291         assert(new_type > SVt_PV);
1292         assert(SVt_IV < SVt_PV);
1293         assert(SVt_NV < SVt_PV);
1294         break;
1295     case SVt_PVIV:
1296         break;
1297     case SVt_PVNV:
1298         break;
1299     case SVt_PVMG:
1300         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1301            there's no way that it can be safely upgraded, because perl.c
1302            expects to Safefree(SvANY(PL_mess_sv))  */
1303         assert(sv != PL_mess_sv);
1304         /* This flag bit is used to mean other things in other scalar types.
1305            Given that it only has meaning inside the pad, it shouldn't be set
1306            on anything that can get upgraded.  */
1307         assert(!SvPAD_TYPED(sv));
1308         break;
1309     default:
1310         if (UNLIKELY(old_type_details->cant_upgrade))
1311             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1312                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1313     }
1314
1315     if (UNLIKELY(old_type > new_type))
1316         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1317                 (int)old_type, (int)new_type);
1318
1319     new_type_details = bodies_by_type + new_type;
1320
1321     SvFLAGS(sv) &= ~SVTYPEMASK;
1322     SvFLAGS(sv) |= new_type;
1323
1324     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1325        the return statements above will have triggered.  */
1326     assert (new_type != SVt_NULL);
1327     switch (new_type) {
1328     case SVt_IV:
1329         assert(old_type == SVt_NULL);
1330         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1331         SvIV_set(sv, 0);
1332         return;
1333     case SVt_NV:
1334         assert(old_type == SVt_NULL);
1335         SvANY(sv) = new_XNV();
1336         SvNV_set(sv, 0);
1337         return;
1338     case SVt_PVHV:
1339     case SVt_PVAV:
1340         assert(new_type_details->body_size);
1341
1342 #ifndef PURIFY  
1343         assert(new_type_details->arena);
1344         assert(new_type_details->arena_size);
1345         /* This points to the start of the allocated area.  */
1346         new_body_inline(new_body, new_type);
1347         Zero(new_body, new_type_details->body_size, char);
1348         new_body = ((char *)new_body) - new_type_details->offset;
1349 #else
1350         /* We always allocated the full length item with PURIFY. To do this
1351            we fake things so that arena is false for all 16 types..  */
1352         new_body = new_NOARENAZ(new_type_details);
1353 #endif
1354         SvANY(sv) = new_body;
1355         if (new_type == SVt_PVAV) {
1356             AvMAX(sv)   = -1;
1357             AvFILLp(sv) = -1;
1358             AvREAL_only(sv);
1359             if (old_type_details->body_size) {
1360                 AvALLOC(sv) = 0;
1361             } else {
1362                 /* It will have been zeroed when the new body was allocated.
1363                    Lets not write to it, in case it confuses a write-back
1364                    cache.  */
1365             }
1366         } else {
1367             assert(!SvOK(sv));
1368             SvOK_off(sv);
1369 #ifndef NODEFAULT_SHAREKEYS
1370             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1371 #endif
1372             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1373             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1374         }
1375
1376         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1377            The target created by newSVrv also is, and it can have magic.
1378            However, it never has SvPVX set.
1379         */
1380         if (old_type == SVt_IV) {
1381             assert(!SvROK(sv));
1382         } else if (old_type >= SVt_PV) {
1383             assert(SvPVX_const(sv) == 0);
1384         }
1385
1386         if (old_type >= SVt_PVMG) {
1387             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1388             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1389         } else {
1390             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1391         }
1392         break;
1393
1394     case SVt_PVIV:
1395         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1396            no route from NV to PVIV, NOK can never be true  */
1397         assert(!SvNOKp(sv));
1398         assert(!SvNOK(sv));
1399     case SVt_PVIO:
1400     case SVt_PVFM:
1401     case SVt_PVGV:
1402     case SVt_PVCV:
1403     case SVt_PVLV:
1404     case SVt_INVLIST:
1405     case SVt_REGEXP:
1406     case SVt_PVMG:
1407     case SVt_PVNV:
1408     case SVt_PV:
1409
1410         assert(new_type_details->body_size);
1411         /* We always allocated the full length item with PURIFY. To do this
1412            we fake things so that arena is false for all 16 types..  */
1413         if(new_type_details->arena) {
1414             /* This points to the start of the allocated area.  */
1415             new_body_inline(new_body, new_type);
1416             Zero(new_body, new_type_details->body_size, char);
1417             new_body = ((char *)new_body) - new_type_details->offset;
1418         } else {
1419             new_body = new_NOARENAZ(new_type_details);
1420         }
1421         SvANY(sv) = new_body;
1422
1423         if (old_type_details->copy) {
1424             /* There is now the potential for an upgrade from something without
1425                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1426             int offset = old_type_details->offset;
1427             int length = old_type_details->copy;
1428
1429             if (new_type_details->offset > old_type_details->offset) {
1430                 const int difference
1431                     = new_type_details->offset - old_type_details->offset;
1432                 offset += difference;
1433                 length -= difference;
1434             }
1435             assert (length >= 0);
1436                 
1437             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1438                  char);
1439         }
1440
1441 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1442         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1443          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1444          * NV slot, but the new one does, then we need to initialise the
1445          * freshly created NV slot with whatever the correct bit pattern is
1446          * for 0.0  */
1447         if (old_type_details->zero_nv && !new_type_details->zero_nv
1448             && !isGV_with_GP(sv))
1449             SvNV_set(sv, 0);
1450 #endif
1451
1452         if (UNLIKELY(new_type == SVt_PVIO)) {
1453             IO * const io = MUTABLE_IO(sv);
1454             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1455
1456             SvOBJECT_on(io);
1457             /* Clear the stashcache because a new IO could overrule a package
1458                name */
1459             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1460             hv_clear(PL_stashcache);
1461
1462             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1463             IoPAGE_LEN(sv) = 60;
1464         }
1465         if (UNLIKELY(new_type == SVt_REGEXP))
1466             sv->sv_u.svu_rx = (regexp *)new_body;
1467         else if (old_type < SVt_PV) {
1468             /* referant will be NULL unless the old type was SVt_IV emulating
1469                SVt_RV */
1470             sv->sv_u.svu_rv = referant;
1471         }
1472         break;
1473     default:
1474         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1475                    (unsigned long)new_type);
1476     }
1477
1478     if (old_type > SVt_IV) {
1479 #ifdef PURIFY
1480         safefree(old_body);
1481 #else
1482         /* Note that there is an assumption that all bodies of types that
1483            can be upgraded came from arenas. Only the more complex non-
1484            upgradable types are allowed to be directly malloc()ed.  */
1485         assert(old_type_details->arena);
1486         del_body((void*)((char*)old_body + old_type_details->offset),
1487                  &PL_body_roots[old_type]);
1488 #endif
1489     }
1490 }
1491
1492 /*
1493 =for apidoc sv_backoff
1494
1495 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1496 wrapper instead.
1497
1498 =cut
1499 */
1500
1501 int
1502 Perl_sv_backoff(SV *const sv)
1503 {
1504     STRLEN delta;
1505     const char * const s = SvPVX_const(sv);
1506
1507     PERL_ARGS_ASSERT_SV_BACKOFF;
1508
1509     assert(SvOOK(sv));
1510     assert(SvTYPE(sv) != SVt_PVHV);
1511     assert(SvTYPE(sv) != SVt_PVAV);
1512
1513     SvOOK_offset(sv, delta);
1514     
1515     SvLEN_set(sv, SvLEN(sv) + delta);
1516     SvPV_set(sv, SvPVX(sv) - delta);
1517     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1518     SvFLAGS(sv) &= ~SVf_OOK;
1519     return 0;
1520 }
1521
1522 /*
1523 =for apidoc sv_grow
1524
1525 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1526 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1527 Use the C<SvGROW> wrapper instead.
1528
1529 =cut
1530 */
1531
1532 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1533
1534 char *
1535 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1536 {
1537     char *s;
1538
1539     PERL_ARGS_ASSERT_SV_GROW;
1540
1541     if (SvROK(sv))
1542         sv_unref(sv);
1543     if (SvTYPE(sv) < SVt_PV) {
1544         sv_upgrade(sv, SVt_PV);
1545         s = SvPVX_mutable(sv);
1546     }
1547     else if (SvOOK(sv)) {       /* pv is offset? */
1548         sv_backoff(sv);
1549         s = SvPVX_mutable(sv);
1550         if (newlen > SvLEN(sv))
1551             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1552     }
1553     else
1554     {
1555         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1556         s = SvPVX_mutable(sv);
1557     }
1558
1559 #ifdef PERL_NEW_COPY_ON_WRITE
1560     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1561      * to store the COW count. So in general, allocate one more byte than
1562      * asked for, to make it likely this byte is always spare: and thus
1563      * make more strings COW-able.
1564      * If the new size is a big power of two, don't bother: we assume the
1565      * caller wanted a nice 2^N sized block and will be annoyed at getting
1566      * 2^N+1 */
1567     if (newlen & 0xff)
1568         newlen++;
1569 #endif
1570
1571 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1572 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1573 #endif
1574
1575     if (newlen > SvLEN(sv)) {           /* need more room? */
1576         STRLEN minlen = SvCUR(sv);
1577         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1578         if (newlen < minlen)
1579             newlen = minlen;
1580 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1581
1582         /* Don't round up on the first allocation, as odds are pretty good that
1583          * the initial request is accurate as to what is really needed */
1584         if (SvLEN(sv)) {
1585             newlen = PERL_STRLEN_ROUNDUP(newlen);
1586         }
1587 #endif
1588         if (SvLEN(sv) && s) {
1589             s = (char*)saferealloc(s, newlen);
1590         }
1591         else {
1592             s = (char*)safemalloc(newlen);
1593             if (SvPVX_const(sv) && SvCUR(sv)) {
1594                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1595             }
1596         }
1597         SvPV_set(sv, s);
1598 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1599         /* Do this here, do it once, do it right, and then we will never get
1600            called back into sv_grow() unless there really is some growing
1601            needed.  */
1602         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1603 #else
1604         SvLEN_set(sv, newlen);
1605 #endif
1606     }
1607     return s;
1608 }
1609
1610 /*
1611 =for apidoc sv_setiv
1612
1613 Copies an integer into the given SV, upgrading first if necessary.
1614 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1615
1616 =cut
1617 */
1618
1619 void
1620 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1621 {
1622     PERL_ARGS_ASSERT_SV_SETIV;
1623
1624     SV_CHECK_THINKFIRST_COW_DROP(sv);
1625     switch (SvTYPE(sv)) {
1626     case SVt_NULL:
1627     case SVt_NV:
1628         sv_upgrade(sv, SVt_IV);
1629         break;
1630     case SVt_PV:
1631         sv_upgrade(sv, SVt_PVIV);
1632         break;
1633
1634     case SVt_PVGV:
1635         if (!isGV_with_GP(sv))
1636             break;
1637     case SVt_PVAV:
1638     case SVt_PVHV:
1639     case SVt_PVCV:
1640     case SVt_PVFM:
1641     case SVt_PVIO:
1642         /* diag_listed_as: Can't coerce %s to %s in %s */
1643         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1644                    OP_DESC(PL_op));
1645     default: NOOP;
1646     }
1647     (void)SvIOK_only(sv);                       /* validate number */
1648     SvIV_set(sv, i);
1649     SvTAINT(sv);
1650 }
1651
1652 /*
1653 =for apidoc sv_setiv_mg
1654
1655 Like C<sv_setiv>, but also handles 'set' magic.
1656
1657 =cut
1658 */
1659
1660 void
1661 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1662 {
1663     PERL_ARGS_ASSERT_SV_SETIV_MG;
1664
1665     sv_setiv(sv,i);
1666     SvSETMAGIC(sv);
1667 }
1668
1669 /*
1670 =for apidoc sv_setuv
1671
1672 Copies an unsigned integer into the given SV, upgrading first if necessary.
1673 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1674
1675 =cut
1676 */
1677
1678 void
1679 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1680 {
1681     PERL_ARGS_ASSERT_SV_SETUV;
1682
1683     /* With the if statement to ensure that integers are stored as IVs whenever
1684        possible:
1685        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1686
1687        without
1688        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1689
1690        If you wish to remove the following if statement, so that this routine
1691        (and its callers) always return UVs, please benchmark to see what the
1692        effect is. Modern CPUs may be different. Or may not :-)
1693     */
1694     if (u <= (UV)IV_MAX) {
1695        sv_setiv(sv, (IV)u);
1696        return;
1697     }
1698     sv_setiv(sv, 0);
1699     SvIsUV_on(sv);
1700     SvUV_set(sv, u);
1701 }
1702
1703 /*
1704 =for apidoc sv_setuv_mg
1705
1706 Like C<sv_setuv>, but also handles 'set' magic.
1707
1708 =cut
1709 */
1710
1711 void
1712 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1713 {
1714     PERL_ARGS_ASSERT_SV_SETUV_MG;
1715
1716     sv_setuv(sv,u);
1717     SvSETMAGIC(sv);
1718 }
1719
1720 /*
1721 =for apidoc sv_setnv
1722
1723 Copies a double into the given SV, upgrading first if necessary.
1724 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1725
1726 =cut
1727 */
1728
1729 void
1730 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1731 {
1732     PERL_ARGS_ASSERT_SV_SETNV;
1733
1734     SV_CHECK_THINKFIRST_COW_DROP(sv);
1735     switch (SvTYPE(sv)) {
1736     case SVt_NULL:
1737     case SVt_IV:
1738         sv_upgrade(sv, SVt_NV);
1739         break;
1740     case SVt_PV:
1741     case SVt_PVIV:
1742         sv_upgrade(sv, SVt_PVNV);
1743         break;
1744
1745     case SVt_PVGV:
1746         if (!isGV_with_GP(sv))
1747             break;
1748     case SVt_PVAV:
1749     case SVt_PVHV:
1750     case SVt_PVCV:
1751     case SVt_PVFM:
1752     case SVt_PVIO:
1753         /* diag_listed_as: Can't coerce %s to %s in %s */
1754         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1755                    OP_DESC(PL_op));
1756     default: NOOP;
1757     }
1758     SvNV_set(sv, num);
1759     (void)SvNOK_only(sv);                       /* validate number */
1760     SvTAINT(sv);
1761 }
1762
1763 /*
1764 =for apidoc sv_setnv_mg
1765
1766 Like C<sv_setnv>, but also handles 'set' magic.
1767
1768 =cut
1769 */
1770
1771 void
1772 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1773 {
1774     PERL_ARGS_ASSERT_SV_SETNV_MG;
1775
1776     sv_setnv(sv,num);
1777     SvSETMAGIC(sv);
1778 }
1779
1780 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1781  * not incrementable warning display.
1782  * Originally part of S_not_a_number().
1783  * The return value may be != tmpbuf.
1784  */
1785
1786 STATIC const char *
1787 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1788     const char *pv;
1789
1790      PERL_ARGS_ASSERT_SV_DISPLAY;
1791
1792      if (DO_UTF8(sv)) {
1793           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1794           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1795      } else {
1796           char *d = tmpbuf;
1797           const char * const limit = tmpbuf + tmpbuf_size - 8;
1798           /* each *s can expand to 4 chars + "...\0",
1799              i.e. need room for 8 chars */
1800         
1801           const char *s = SvPVX_const(sv);
1802           const char * const end = s + SvCUR(sv);
1803           for ( ; s < end && d < limit; s++ ) {
1804                int ch = *s & 0xFF;
1805                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1806                     *d++ = 'M';
1807                     *d++ = '-';
1808
1809                     /* Map to ASCII "equivalent" of Latin1 */
1810                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1811                }
1812                if (ch == '\n') {
1813                     *d++ = '\\';
1814                     *d++ = 'n';
1815                }
1816                else if (ch == '\r') {
1817                     *d++ = '\\';
1818                     *d++ = 'r';
1819                }
1820                else if (ch == '\f') {
1821                     *d++ = '\\';
1822                     *d++ = 'f';
1823                }
1824                else if (ch == '\\') {
1825                     *d++ = '\\';
1826                     *d++ = '\\';
1827                }
1828                else if (ch == '\0') {
1829                     *d++ = '\\';
1830                     *d++ = '0';
1831                }
1832                else if (isPRINT_LC(ch))
1833                     *d++ = ch;
1834                else {
1835                     *d++ = '^';
1836                     *d++ = toCTRL(ch);
1837                }
1838           }
1839           if (s < end) {
1840                *d++ = '.';
1841                *d++ = '.';
1842                *d++ = '.';
1843           }
1844           *d = '\0';
1845           pv = tmpbuf;
1846     }
1847
1848     return pv;
1849 }
1850
1851 /* Print an "isn't numeric" warning, using a cleaned-up,
1852  * printable version of the offending string
1853  */
1854
1855 STATIC void
1856 S_not_a_number(pTHX_ SV *const sv)
1857 {
1858      dVAR;
1859      char tmpbuf[64];
1860      const char *pv;
1861
1862      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1863
1864      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1865
1866     if (PL_op)
1867         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1868                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1869                     "Argument \"%s\" isn't numeric in %s", pv,
1870                     OP_DESC(PL_op));
1871     else
1872         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1873                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1874                     "Argument \"%s\" isn't numeric", pv);
1875 }
1876
1877 STATIC void
1878 S_not_incrementable(pTHX_ SV *const sv) {
1879      dVAR;
1880      char tmpbuf[64];
1881      const char *pv;
1882
1883      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1884
1885      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1886
1887      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1888                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1889 }
1890
1891 /*
1892 =for apidoc looks_like_number
1893
1894 Test if the content of an SV looks like a number (or is a number).
1895 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1896 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1897 ignored.
1898
1899 =cut
1900 */
1901
1902 I32
1903 Perl_looks_like_number(pTHX_ SV *const sv)
1904 {
1905     const char *sbegin;
1906     STRLEN len;
1907
1908     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1909
1910     if (SvPOK(sv) || SvPOKp(sv)) {
1911         sbegin = SvPV_nomg_const(sv, len);
1912     }
1913     else
1914         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1915     return grok_number(sbegin, len, NULL);
1916 }
1917
1918 STATIC bool
1919 S_glob_2number(pTHX_ GV * const gv)
1920 {
1921     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1922
1923     /* We know that all GVs stringify to something that is not-a-number,
1924         so no need to test that.  */
1925     if (ckWARN(WARN_NUMERIC))
1926     {
1927         SV *const buffer = sv_newmortal();
1928         gv_efullname3(buffer, gv, "*");
1929         not_a_number(buffer);
1930     }
1931     /* We just want something true to return, so that S_sv_2iuv_common
1932         can tail call us and return true.  */
1933     return TRUE;
1934 }
1935
1936 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1937    until proven guilty, assume that things are not that bad... */
1938
1939 /*
1940    NV_PRESERVES_UV:
1941
1942    As 64 bit platforms often have an NV that doesn't preserve all bits of
1943    an IV (an assumption perl has been based on to date) it becomes necessary
1944    to remove the assumption that the NV always carries enough precision to
1945    recreate the IV whenever needed, and that the NV is the canonical form.
1946    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1947    precision as a side effect of conversion (which would lead to insanity
1948    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1949    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1950       where precision was lost, and IV/UV/NV slots that have a valid conversion
1951       which has lost no precision
1952    2) to ensure that if a numeric conversion to one form is requested that
1953       would lose precision, the precise conversion (or differently
1954       imprecise conversion) is also performed and cached, to prevent
1955       requests for different numeric formats on the same SV causing
1956       lossy conversion chains. (lossless conversion chains are perfectly
1957       acceptable (still))
1958
1959
1960    flags are used:
1961    SvIOKp is true if the IV slot contains a valid value
1962    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1963    SvNOKp is true if the NV slot contains a valid value
1964    SvNOK  is true only if the NV value is accurate
1965
1966    so
1967    while converting from PV to NV, check to see if converting that NV to an
1968    IV(or UV) would lose accuracy over a direct conversion from PV to
1969    IV(or UV). If it would, cache both conversions, return NV, but mark
1970    SV as IOK NOKp (ie not NOK).
1971
1972    While converting from PV to IV, check to see if converting that IV to an
1973    NV would lose accuracy over a direct conversion from PV to NV. If it
1974    would, cache both conversions, flag similarly.
1975
1976    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1977    correctly because if IV & NV were set NV *always* overruled.
1978    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1979    changes - now IV and NV together means that the two are interchangeable:
1980    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1981
1982    The benefit of this is that operations such as pp_add know that if
1983    SvIOK is true for both left and right operands, then integer addition
1984    can be used instead of floating point (for cases where the result won't
1985    overflow). Before, floating point was always used, which could lead to
1986    loss of precision compared with integer addition.
1987
1988    * making IV and NV equal status should make maths accurate on 64 bit
1989      platforms
1990    * may speed up maths somewhat if pp_add and friends start to use
1991      integers when possible instead of fp. (Hopefully the overhead in
1992      looking for SvIOK and checking for overflow will not outweigh the
1993      fp to integer speedup)
1994    * will slow down integer operations (callers of SvIV) on "inaccurate"
1995      values, as the change from SvIOK to SvIOKp will cause a call into
1996      sv_2iv each time rather than a macro access direct to the IV slot
1997    * should speed up number->string conversion on integers as IV is
1998      favoured when IV and NV are equally accurate
1999
2000    ####################################################################
2001    You had better be using SvIOK_notUV if you want an IV for arithmetic:
2002    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2003    On the other hand, SvUOK is true iff UV.
2004    ####################################################################
2005
2006    Your mileage will vary depending your CPU's relative fp to integer
2007    performance ratio.
2008 */
2009
2010 #ifndef NV_PRESERVES_UV
2011 #  define IS_NUMBER_UNDERFLOW_IV 1
2012 #  define IS_NUMBER_UNDERFLOW_UV 2
2013 #  define IS_NUMBER_IV_AND_UV    2
2014 #  define IS_NUMBER_OVERFLOW_IV  4
2015 #  define IS_NUMBER_OVERFLOW_UV  5
2016
2017 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2018
2019 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2020 STATIC int
2021 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2022 #  ifdef DEBUGGING
2023                        , I32 numtype
2024 #  endif
2025                        )
2026 {
2027     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2028     PERL_UNUSED_CONTEXT;
2029
2030     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));
2031     if (SvNVX(sv) < (NV)IV_MIN) {
2032         (void)SvIOKp_on(sv);
2033         (void)SvNOK_on(sv);
2034         SvIV_set(sv, IV_MIN);
2035         return IS_NUMBER_UNDERFLOW_IV;
2036     }
2037     if (SvNVX(sv) > (NV)UV_MAX) {
2038         (void)SvIOKp_on(sv);
2039         (void)SvNOK_on(sv);
2040         SvIsUV_on(sv);
2041         SvUV_set(sv, UV_MAX);
2042         return IS_NUMBER_OVERFLOW_UV;
2043     }
2044     (void)SvIOKp_on(sv);
2045     (void)SvNOK_on(sv);
2046     /* Can't use strtol etc to convert this string.  (See truth table in
2047        sv_2iv  */
2048     if (SvNVX(sv) <= (UV)IV_MAX) {
2049         SvIV_set(sv, I_V(SvNVX(sv)));
2050         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2051             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2052         } else {
2053             /* Integer is imprecise. NOK, IOKp */
2054         }
2055         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2056     }
2057     SvIsUV_on(sv);
2058     SvUV_set(sv, U_V(SvNVX(sv)));
2059     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2060         if (SvUVX(sv) == UV_MAX) {
2061             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2062                possibly be preserved by NV. Hence, it must be overflow.
2063                NOK, IOKp */
2064             return IS_NUMBER_OVERFLOW_UV;
2065         }
2066         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2067     } else {
2068         /* Integer is imprecise. NOK, IOKp */
2069     }
2070     return IS_NUMBER_OVERFLOW_IV;
2071 }
2072 #endif /* !NV_PRESERVES_UV*/
2073
2074 STATIC bool
2075 S_sv_2iuv_common(pTHX_ SV *const sv)
2076 {
2077     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2078
2079     if (SvNOKp(sv)) {
2080         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2081          * without also getting a cached IV/UV from it at the same time
2082          * (ie PV->NV conversion should detect loss of accuracy and cache
2083          * IV or UV at same time to avoid this. */
2084         /* IV-over-UV optimisation - choose to cache IV if possible */
2085
2086         if (SvTYPE(sv) == SVt_NV)
2087             sv_upgrade(sv, SVt_PVNV);
2088
2089         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2090         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2091            certainly cast into the IV range at IV_MAX, whereas the correct
2092            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2093            cases go to UV */
2094 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2095         if (Perl_isnan(SvNVX(sv))) {
2096             SvUV_set(sv, 0);
2097             SvIsUV_on(sv);
2098             return FALSE;
2099         }
2100 #endif
2101         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2102             SvIV_set(sv, I_V(SvNVX(sv)));
2103             if (SvNVX(sv) == (NV) SvIVX(sv)
2104 #ifndef NV_PRESERVES_UV
2105                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2106                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2107                 /* Don't flag it as "accurately an integer" if the number
2108                    came from a (by definition imprecise) NV operation, and
2109                    we're outside the range of NV integer precision */
2110 #endif
2111                 ) {
2112                 if (SvNOK(sv))
2113                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2114                 else {
2115                     /* scalar has trailing garbage, eg "42a" */
2116                 }
2117                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2118                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2119                                       PTR2UV(sv),
2120                                       SvNVX(sv),
2121                                       SvIVX(sv)));
2122
2123             } else {
2124                 /* IV not precise.  No need to convert from PV, as NV
2125                    conversion would already have cached IV if it detected
2126                    that PV->IV would be better than PV->NV->IV
2127                    flags already correct - don't set public IOK.  */
2128                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2129                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2130                                       PTR2UV(sv),
2131                                       SvNVX(sv),
2132                                       SvIVX(sv)));
2133             }
2134             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2135                but the cast (NV)IV_MIN rounds to a the value less (more
2136                negative) than IV_MIN which happens to be equal to SvNVX ??
2137                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2138                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2139                (NV)UVX == NVX are both true, but the values differ. :-(
2140                Hopefully for 2s complement IV_MIN is something like
2141                0x8000000000000000 which will be exact. NWC */
2142         }
2143         else {
2144             SvUV_set(sv, U_V(SvNVX(sv)));
2145             if (
2146                 (SvNVX(sv) == (NV) SvUVX(sv))
2147 #ifndef  NV_PRESERVES_UV
2148                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2149                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2150                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2151                 /* Don't flag it as "accurately an integer" if the number
2152                    came from a (by definition imprecise) NV operation, and
2153                    we're outside the range of NV integer precision */
2154 #endif
2155                 && SvNOK(sv)
2156                 )
2157                 SvIOK_on(sv);
2158             SvIsUV_on(sv);
2159             DEBUG_c(PerlIO_printf(Perl_debug_log,
2160                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2161                                   PTR2UV(sv),
2162                                   SvUVX(sv),
2163                                   SvUVX(sv)));
2164         }
2165     }
2166     else if (SvPOKp(sv)) {
2167         UV value;
2168         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2169         /* We want to avoid a possible problem when we cache an IV/ a UV which
2170            may be later translated to an NV, and the resulting NV is not
2171            the same as the direct translation of the initial string
2172            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2173            be careful to ensure that the value with the .456 is around if the
2174            NV value is requested in the future).
2175         
2176            This means that if we cache such an IV/a UV, we need to cache the
2177            NV as well.  Moreover, we trade speed for space, and do not
2178            cache the NV if we are sure it's not needed.
2179          */
2180
2181         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2182         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2183              == IS_NUMBER_IN_UV) {
2184             /* It's definitely an integer, only upgrade to PVIV */
2185             if (SvTYPE(sv) < SVt_PVIV)
2186                 sv_upgrade(sv, SVt_PVIV);
2187             (void)SvIOK_on(sv);
2188         } else if (SvTYPE(sv) < SVt_PVNV)
2189             sv_upgrade(sv, SVt_PVNV);
2190
2191         /* If NVs preserve UVs then we only use the UV value if we know that
2192            we aren't going to call atof() below. If NVs don't preserve UVs
2193            then the value returned may have more precision than atof() will
2194            return, even though value isn't perfectly accurate.  */
2195         if ((numtype & (IS_NUMBER_IN_UV
2196 #ifdef NV_PRESERVES_UV
2197                         | IS_NUMBER_NOT_INT
2198 #endif
2199             )) == IS_NUMBER_IN_UV) {
2200             /* This won't turn off the public IOK flag if it was set above  */
2201             (void)SvIOKp_on(sv);
2202
2203             if (!(numtype & IS_NUMBER_NEG)) {
2204                 /* positive */;
2205                 if (value <= (UV)IV_MAX) {
2206                     SvIV_set(sv, (IV)value);
2207                 } else {
2208                     /* it didn't overflow, and it was positive. */
2209                     SvUV_set(sv, value);
2210                     SvIsUV_on(sv);
2211                 }
2212             } else {
2213                 /* 2s complement assumption  */
2214                 if (value <= (UV)IV_MIN) {
2215                     SvIV_set(sv, -(IV)value);
2216                 } else {
2217                     /* Too negative for an IV.  This is a double upgrade, but
2218                        I'm assuming it will be rare.  */
2219                     if (SvTYPE(sv) < SVt_PVNV)
2220                         sv_upgrade(sv, SVt_PVNV);
2221                     SvNOK_on(sv);
2222                     SvIOK_off(sv);
2223                     SvIOKp_on(sv);
2224                     SvNV_set(sv, -(NV)value);
2225                     SvIV_set(sv, IV_MIN);
2226                 }
2227             }
2228         }
2229         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2230            will be in the previous block to set the IV slot, and the next
2231            block to set the NV slot.  So no else here.  */
2232         
2233         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2234             != IS_NUMBER_IN_UV) {
2235             /* It wasn't an (integer that doesn't overflow the UV). */
2236             SvNV_set(sv, Atof(SvPVX_const(sv)));
2237
2238             if (! numtype && ckWARN(WARN_NUMERIC))
2239                 not_a_number(sv);
2240
2241 #if defined(USE_LONG_DOUBLE)
2242             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2243                                   PTR2UV(sv), SvNVX(sv)));
2244 #else
2245             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2246                                   PTR2UV(sv), SvNVX(sv)));
2247 #endif
2248
2249 #ifdef NV_PRESERVES_UV
2250             (void)SvIOKp_on(sv);
2251             (void)SvNOK_on(sv);
2252             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2253                 SvIV_set(sv, I_V(SvNVX(sv)));
2254                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2255                     SvIOK_on(sv);
2256                 } else {
2257                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2258                 }
2259                 /* UV will not work better than IV */
2260             } else {
2261                 if (SvNVX(sv) > (NV)UV_MAX) {
2262                     SvIsUV_on(sv);
2263                     /* Integer is inaccurate. NOK, IOKp, is UV */
2264                     SvUV_set(sv, UV_MAX);
2265                 } else {
2266                     SvUV_set(sv, U_V(SvNVX(sv)));
2267                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2268                        NV preservse UV so can do correct comparison.  */
2269                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2270                         SvIOK_on(sv);
2271                     } else {
2272                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2273                     }
2274                 }
2275                 SvIsUV_on(sv);
2276             }
2277 #else /* NV_PRESERVES_UV */
2278             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2279                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2280                 /* The IV/UV slot will have been set from value returned by
2281                    grok_number above.  The NV slot has just been set using
2282                    Atof.  */
2283                 SvNOK_on(sv);
2284                 assert (SvIOKp(sv));
2285             } else {
2286                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2287                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2288                     /* Small enough to preserve all bits. */
2289                     (void)SvIOKp_on(sv);
2290                     SvNOK_on(sv);
2291                     SvIV_set(sv, I_V(SvNVX(sv)));
2292                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2293                         SvIOK_on(sv);
2294                     /* Assumption: first non-preserved integer is < IV_MAX,
2295                        this NV is in the preserved range, therefore: */
2296                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2297                           < (UV)IV_MAX)) {
2298                         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);
2299                     }
2300                 } else {
2301                     /* IN_UV NOT_INT
2302                          0      0       already failed to read UV.
2303                          0      1       already failed to read UV.
2304                          1      0       you won't get here in this case. IV/UV
2305                                         slot set, public IOK, Atof() unneeded.
2306                          1      1       already read UV.
2307                        so there's no point in sv_2iuv_non_preserve() attempting
2308                        to use atol, strtol, strtoul etc.  */
2309 #  ifdef DEBUGGING
2310                     sv_2iuv_non_preserve (sv, numtype);
2311 #  else
2312                     sv_2iuv_non_preserve (sv);
2313 #  endif
2314                 }
2315             }
2316 #endif /* NV_PRESERVES_UV */
2317         /* It might be more code efficient to go through the entire logic above
2318            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2319            gets complex and potentially buggy, so more programmer efficient
2320            to do it this way, by turning off the public flags:  */
2321         if (!numtype)
2322             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2323         }
2324     }
2325     else  {
2326         if (isGV_with_GP(sv))
2327             return glob_2number(MUTABLE_GV(sv));
2328
2329         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2330                 report_uninit(sv);
2331         if (SvTYPE(sv) < SVt_IV)
2332             /* Typically the caller expects that sv_any is not NULL now.  */
2333             sv_upgrade(sv, SVt_IV);
2334         /* Return 0 from the caller.  */
2335         return TRUE;
2336     }
2337     return FALSE;
2338 }
2339
2340 /*
2341 =for apidoc sv_2iv_flags
2342
2343 Return the integer value of an SV, doing any necessary string
2344 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2345 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2346
2347 =cut
2348 */
2349
2350 IV
2351 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2352 {
2353     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2354
2355     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2356          && SvTYPE(sv) != SVt_PVFM);
2357
2358     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2359         mg_get(sv);
2360
2361     if (SvROK(sv)) {
2362         if (SvAMAGIC(sv)) {
2363             SV * tmpstr;
2364             if (flags & SV_SKIP_OVERLOAD)
2365                 return 0;
2366             tmpstr = AMG_CALLunary(sv, numer_amg);
2367             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2368                 return SvIV(tmpstr);
2369             }
2370         }
2371         return PTR2IV(SvRV(sv));
2372     }
2373
2374     if (SvVALID(sv) || isREGEXP(sv)) {
2375         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2376            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2377            In practice they are extremely unlikely to actually get anywhere
2378            accessible by user Perl code - the only way that I'm aware of is when
2379            a constant subroutine which is used as the second argument to index.
2380
2381            Regexps have no SvIVX and SvNVX fields.
2382         */
2383         assert(isREGEXP(sv) || SvPOKp(sv));
2384         {
2385             UV value;
2386             const char * const ptr =
2387                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2388             const int numtype
2389                 = grok_number(ptr, SvCUR(sv), &value);
2390
2391             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2392                 == IS_NUMBER_IN_UV) {
2393                 /* It's definitely an integer */
2394                 if (numtype & IS_NUMBER_NEG) {
2395                     if (value < (UV)IV_MIN)
2396                         return -(IV)value;
2397                 } else {
2398                     if (value < (UV)IV_MAX)
2399                         return (IV)value;
2400                 }
2401             }
2402             if (!numtype) {
2403                 if (ckWARN(WARN_NUMERIC))
2404                     not_a_number(sv);
2405             }
2406             return I_V(Atof(ptr));
2407         }
2408     }
2409
2410     if (SvTHINKFIRST(sv)) {
2411 #ifdef PERL_OLD_COPY_ON_WRITE
2412         if (SvIsCOW(sv)) {
2413             sv_force_normal_flags(sv, 0);
2414         }
2415 #endif
2416         if (SvREADONLY(sv) && !SvOK(sv)) {
2417             if (ckWARN(WARN_UNINITIALIZED))
2418                 report_uninit(sv);
2419             return 0;
2420         }
2421     }
2422
2423     if (!SvIOKp(sv)) {
2424         if (S_sv_2iuv_common(aTHX_ sv))
2425             return 0;
2426     }
2427
2428     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2429         PTR2UV(sv),SvIVX(sv)));
2430     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2431 }
2432
2433 /*
2434 =for apidoc sv_2uv_flags
2435
2436 Return the unsigned integer value of an SV, doing any necessary string
2437 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2438 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2439
2440 =cut
2441 */
2442
2443 UV
2444 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2445 {
2446     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2447
2448     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2449         mg_get(sv);
2450
2451     if (SvROK(sv)) {
2452         if (SvAMAGIC(sv)) {
2453             SV *tmpstr;
2454             if (flags & SV_SKIP_OVERLOAD)
2455                 return 0;
2456             tmpstr = AMG_CALLunary(sv, numer_amg);
2457             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2458                 return SvUV(tmpstr);
2459             }
2460         }
2461         return PTR2UV(SvRV(sv));
2462     }
2463
2464     if (SvVALID(sv) || isREGEXP(sv)) {
2465         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2466            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2467            Regexps have no SvIVX and SvNVX fields. */
2468         assert(isREGEXP(sv) || SvPOKp(sv));
2469         {
2470             UV value;
2471             const char * const ptr =
2472                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2473             const int numtype
2474                 = grok_number(ptr, SvCUR(sv), &value);
2475
2476             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2477                 == IS_NUMBER_IN_UV) {
2478                 /* It's definitely an integer */
2479                 if (!(numtype & IS_NUMBER_NEG))
2480                     return value;
2481             }
2482             if (!numtype) {
2483                 if (ckWARN(WARN_NUMERIC))
2484                     not_a_number(sv);
2485             }
2486             return U_V(Atof(ptr));
2487         }
2488     }
2489
2490     if (SvTHINKFIRST(sv)) {
2491 #ifdef PERL_OLD_COPY_ON_WRITE
2492         if (SvIsCOW(sv)) {
2493             sv_force_normal_flags(sv, 0);
2494         }
2495 #endif
2496         if (SvREADONLY(sv) && !SvOK(sv)) {
2497             if (ckWARN(WARN_UNINITIALIZED))
2498                 report_uninit(sv);
2499             return 0;
2500         }
2501     }
2502
2503     if (!SvIOKp(sv)) {
2504         if (S_sv_2iuv_common(aTHX_ sv))
2505             return 0;
2506     }
2507
2508     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2509                           PTR2UV(sv),SvUVX(sv)));
2510     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2511 }
2512
2513 /*
2514 =for apidoc sv_2nv_flags
2515
2516 Return the num value of an SV, doing any necessary string or integer
2517 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2518 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2519
2520 =cut
2521 */
2522
2523 NV
2524 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2525 {
2526     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2527
2528     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2529          && SvTYPE(sv) != SVt_PVFM);
2530     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2531         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2532            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2533            Regexps have no SvIVX and SvNVX fields.  */
2534         const char *ptr;
2535         if (flags & SV_GMAGIC)
2536             mg_get(sv);
2537         if (SvNOKp(sv))
2538             return SvNVX(sv);
2539         if (SvPOKp(sv) && !SvIOKp(sv)) {
2540             ptr = SvPVX_const(sv);
2541           grokpv:
2542             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2543                 !grok_number(ptr, SvCUR(sv), NULL))
2544                 not_a_number(sv);
2545             return Atof(ptr);
2546         }
2547         if (SvIOKp(sv)) {
2548             if (SvIsUV(sv))
2549                 return (NV)SvUVX(sv);
2550             else
2551                 return (NV)SvIVX(sv);
2552         }
2553         if (SvROK(sv)) {
2554             goto return_rok;
2555         }
2556         if (isREGEXP(sv)) {
2557             ptr = RX_WRAPPED((REGEXP *)sv);
2558             goto grokpv;
2559         }
2560         assert(SvTYPE(sv) >= SVt_PVMG);
2561         /* This falls through to the report_uninit near the end of the
2562            function. */
2563     } else if (SvTHINKFIRST(sv)) {
2564         if (SvROK(sv)) {
2565         return_rok:
2566             if (SvAMAGIC(sv)) {
2567                 SV *tmpstr;
2568                 if (flags & SV_SKIP_OVERLOAD)
2569                     return 0;
2570                 tmpstr = AMG_CALLunary(sv, numer_amg);
2571                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2572                     return SvNV(tmpstr);
2573                 }
2574             }
2575             return PTR2NV(SvRV(sv));
2576         }
2577 #ifdef PERL_OLD_COPY_ON_WRITE
2578         if (SvIsCOW(sv)) {
2579             sv_force_normal_flags(sv, 0);
2580         }
2581 #endif
2582         if (SvREADONLY(sv) && !SvOK(sv)) {
2583             if (ckWARN(WARN_UNINITIALIZED))
2584                 report_uninit(sv);
2585             return 0.0;
2586         }
2587     }
2588     if (SvTYPE(sv) < SVt_NV) {
2589         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2590         sv_upgrade(sv, SVt_NV);
2591 #ifdef USE_LONG_DOUBLE
2592         DEBUG_c({
2593             STORE_NUMERIC_LOCAL_SET_STANDARD();
2594             PerlIO_printf(Perl_debug_log,
2595                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2596                           PTR2UV(sv), SvNVX(sv));
2597             RESTORE_NUMERIC_LOCAL();
2598         });
2599 #else
2600         DEBUG_c({
2601             STORE_NUMERIC_LOCAL_SET_STANDARD();
2602             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2603                           PTR2UV(sv), SvNVX(sv));
2604             RESTORE_NUMERIC_LOCAL();
2605         });
2606 #endif
2607     }
2608     else if (SvTYPE(sv) < SVt_PVNV)
2609         sv_upgrade(sv, SVt_PVNV);
2610     if (SvNOKp(sv)) {
2611         return SvNVX(sv);
2612     }
2613     if (SvIOKp(sv)) {
2614         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2615 #ifdef NV_PRESERVES_UV
2616         if (SvIOK(sv))
2617             SvNOK_on(sv);
2618         else
2619             SvNOKp_on(sv);
2620 #else
2621         /* Only set the public NV OK flag if this NV preserves the IV  */
2622         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2623         if (SvIOK(sv) &&
2624             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2625                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2626             SvNOK_on(sv);
2627         else
2628             SvNOKp_on(sv);
2629 #endif
2630     }
2631     else if (SvPOKp(sv)) {
2632         UV value;
2633         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2634         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2635             not_a_number(sv);
2636 #ifdef NV_PRESERVES_UV
2637         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2638             == IS_NUMBER_IN_UV) {
2639             /* It's definitely an integer */
2640             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2641         } else
2642             SvNV_set(sv, Atof(SvPVX_const(sv)));
2643         if (numtype)
2644             SvNOK_on(sv);
2645         else
2646             SvNOKp_on(sv);
2647 #else
2648         SvNV_set(sv, Atof(SvPVX_const(sv)));
2649         /* Only set the public NV OK flag if this NV preserves the value in
2650            the PV at least as well as an IV/UV would.
2651            Not sure how to do this 100% reliably. */
2652         /* if that shift count is out of range then Configure's test is
2653            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2654            UV_BITS */
2655         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2656             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2657             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2658         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2659             /* Can't use strtol etc to convert this string, so don't try.
2660                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2661             SvNOK_on(sv);
2662         } else {
2663             /* value has been set.  It may not be precise.  */
2664             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2665                 /* 2s complement assumption for (UV)IV_MIN  */
2666                 SvNOK_on(sv); /* Integer is too negative.  */
2667             } else {
2668                 SvNOKp_on(sv);
2669                 SvIOKp_on(sv);
2670
2671                 if (numtype & IS_NUMBER_NEG) {
2672                     SvIV_set(sv, -(IV)value);
2673                 } else if (value <= (UV)IV_MAX) {
2674                     SvIV_set(sv, (IV)value);
2675                 } else {
2676                     SvUV_set(sv, value);
2677                     SvIsUV_on(sv);
2678                 }
2679
2680                 if (numtype & IS_NUMBER_NOT_INT) {
2681                     /* I believe that even if the original PV had decimals,
2682                        they are lost beyond the limit of the FP precision.
2683                        However, neither is canonical, so both only get p
2684                        flags.  NWC, 2000/11/25 */
2685                     /* Both already have p flags, so do nothing */
2686                 } else {
2687                     const NV nv = SvNVX(sv);
2688                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2689                         if (SvIVX(sv) == I_V(nv)) {
2690                             SvNOK_on(sv);
2691                         } else {
2692                             /* It had no "." so it must be integer.  */
2693                         }
2694                         SvIOK_on(sv);
2695                     } else {
2696                         /* between IV_MAX and NV(UV_MAX).
2697                            Could be slightly > UV_MAX */
2698
2699                         if (numtype & IS_NUMBER_NOT_INT) {
2700                             /* UV and NV both imprecise.  */
2701                         } else {
2702                             const UV nv_as_uv = U_V(nv);
2703
2704                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2705                                 SvNOK_on(sv);
2706                             }
2707                             SvIOK_on(sv);
2708                         }
2709                     }
2710                 }
2711             }
2712         }
2713         /* It might be more code efficient to go through the entire logic above
2714            and conditionally set with SvNOKp_on() rather than SvNOK(), but it
2715            gets complex and potentially buggy, so more programmer efficient
2716            to do it this way, by turning off the public flags:  */
2717         if (!numtype)
2718             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2719 #endif /* NV_PRESERVES_UV */
2720     }
2721     else  {
2722         if (isGV_with_GP(sv)) {
2723             glob_2number(MUTABLE_GV(sv));
2724             return 0.0;
2725         }
2726
2727         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2728             report_uninit(sv);
2729         assert (SvTYPE(sv) >= SVt_NV);
2730         /* Typically the caller expects that sv_any is not NULL now.  */
2731         /* XXX Ilya implies that this is a bug in callers that assume this
2732            and ideally should be fixed.  */
2733         return 0.0;
2734     }
2735 #if defined(USE_LONG_DOUBLE)
2736     DEBUG_c({
2737         STORE_NUMERIC_LOCAL_SET_STANDARD();
2738         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2739                       PTR2UV(sv), SvNVX(sv));
2740         RESTORE_NUMERIC_LOCAL();
2741     });
2742 #else
2743     DEBUG_c({
2744         STORE_NUMERIC_LOCAL_SET_STANDARD();
2745         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2746                       PTR2UV(sv), SvNVX(sv));
2747         RESTORE_NUMERIC_LOCAL();
2748     });
2749 #endif
2750     return SvNVX(sv);
2751 }
2752
2753 /*
2754 =for apidoc sv_2num
2755
2756 Return an SV with the numeric value of the source SV, doing any necessary
2757 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2758 access this function.
2759
2760 =cut
2761 */
2762
2763 SV *
2764 Perl_sv_2num(pTHX_ SV *const sv)
2765 {
2766     PERL_ARGS_ASSERT_SV_2NUM;
2767
2768     if (!SvROK(sv))
2769         return sv;
2770     if (SvAMAGIC(sv)) {
2771         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2772         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2773         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2774             return sv_2num(tmpsv);
2775     }
2776     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2777 }
2778
2779 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2780  * UV as a string towards the end of buf, and return pointers to start and
2781  * end of it.
2782  *
2783  * We assume that buf is at least TYPE_CHARS(UV) long.
2784  */
2785
2786 static char *
2787 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2788 {
2789     char *ptr = buf + TYPE_CHARS(UV);
2790     char * const ebuf = ptr;
2791     int sign;
2792
2793     PERL_ARGS_ASSERT_UIV_2BUF;
2794
2795     if (is_uv)
2796         sign = 0;
2797     else if (iv >= 0) {
2798         uv = iv;
2799         sign = 0;
2800     } else {
2801         uv = -iv;
2802         sign = 1;
2803     }
2804     do {
2805         *--ptr = '0' + (char)(uv % 10);
2806     } while (uv /= 10);
2807     if (sign)
2808         *--ptr = '-';
2809     *peob = ebuf;
2810     return ptr;
2811 }
2812
2813 /*
2814 =for apidoc sv_2pv_flags
2815
2816 Returns a pointer to the string value of an SV, and sets *lp to its length.
2817 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2818 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2819 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2820
2821 =cut
2822 */
2823
2824 char *
2825 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2826 {
2827     char *s;
2828
2829     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2830
2831     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2832          && SvTYPE(sv) != SVt_PVFM);
2833     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2834         mg_get(sv);
2835     if (SvROK(sv)) {
2836         if (SvAMAGIC(sv)) {
2837             SV *tmpstr;
2838             if (flags & SV_SKIP_OVERLOAD)
2839                 return NULL;
2840             tmpstr = AMG_CALLunary(sv, string_amg);
2841             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2842             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2843                 /* Unwrap this:  */
2844                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2845                  */
2846
2847                 char *pv;
2848                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2849                     if (flags & SV_CONST_RETURN) {
2850                         pv = (char *) SvPVX_const(tmpstr);
2851                     } else {
2852                         pv = (flags & SV_MUTABLE_RETURN)
2853                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2854                     }
2855                     if (lp)
2856                         *lp = SvCUR(tmpstr);
2857                 } else {
2858                     pv = sv_2pv_flags(tmpstr, lp, flags);
2859                 }
2860                 if (SvUTF8(tmpstr))
2861                     SvUTF8_on(sv);
2862                 else
2863                     SvUTF8_off(sv);
2864                 return pv;
2865             }
2866         }
2867         {
2868             STRLEN len;
2869             char *retval;
2870             char *buffer;
2871             SV *const referent = SvRV(sv);
2872
2873             if (!referent) {
2874                 len = 7;
2875                 retval = buffer = savepvn("NULLREF", len);
2876             } else if (SvTYPE(referent) == SVt_REGEXP &&
2877                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2878                         amagic_is_enabled(string_amg))) {
2879                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2880
2881                 assert(re);
2882                         
2883                 /* If the regex is UTF-8 we want the containing scalar to
2884                    have an UTF-8 flag too */
2885                 if (RX_UTF8(re))
2886                     SvUTF8_on(sv);
2887                 else
2888                     SvUTF8_off(sv);     
2889
2890                 if (lp)
2891                     *lp = RX_WRAPLEN(re);
2892  
2893                 return RX_WRAPPED(re);
2894             } else {
2895                 const char *const typestr = sv_reftype(referent, 0);
2896                 const STRLEN typelen = strlen(typestr);
2897                 UV addr = PTR2UV(referent);
2898                 const char *stashname = NULL;
2899                 STRLEN stashnamelen = 0; /* hush, gcc */
2900                 const char *buffer_end;
2901
2902                 if (SvOBJECT(referent)) {
2903                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2904
2905                     if (name) {
2906                         stashname = HEK_KEY(name);
2907                         stashnamelen = HEK_LEN(name);
2908
2909                         if (HEK_UTF8(name)) {
2910                             SvUTF8_on(sv);
2911                         } else {
2912                             SvUTF8_off(sv);
2913                         }
2914                     } else {
2915                         stashname = "__ANON__";
2916                         stashnamelen = 8;
2917                     }
2918                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2919                         + 2 * sizeof(UV) + 2 /* )\0 */;
2920                 } else {
2921                     len = typelen + 3 /* (0x */
2922                         + 2 * sizeof(UV) + 2 /* )\0 */;
2923                 }
2924
2925                 Newx(buffer, len, char);
2926                 buffer_end = retval = buffer + len;
2927
2928                 /* Working backwards  */
2929                 *--retval = '\0';
2930                 *--retval = ')';
2931                 do {
2932                     *--retval = PL_hexdigit[addr & 15];
2933                 } while (addr >>= 4);
2934                 *--retval = 'x';
2935                 *--retval = '0';
2936                 *--retval = '(';
2937
2938                 retval -= typelen;
2939                 memcpy(retval, typestr, typelen);
2940
2941                 if (stashname) {
2942                     *--retval = '=';
2943                     retval -= stashnamelen;
2944                     memcpy(retval, stashname, stashnamelen);
2945                 }
2946                 /* retval may not necessarily have reached the start of the
2947                    buffer here.  */
2948                 assert (retval >= buffer);
2949
2950                 len = buffer_end - retval - 1; /* -1 for that \0  */
2951             }
2952             if (lp)
2953                 *lp = len;
2954             SAVEFREEPV(buffer);
2955             return retval;
2956         }
2957     }
2958
2959     if (SvPOKp(sv)) {
2960         if (lp)
2961             *lp = SvCUR(sv);
2962         if (flags & SV_MUTABLE_RETURN)
2963             return SvPVX_mutable(sv);
2964         if (flags & SV_CONST_RETURN)
2965             return (char *)SvPVX_const(sv);
2966         return SvPVX(sv);
2967     }
2968
2969     if (SvIOK(sv)) {
2970         /* I'm assuming that if both IV and NV are equally valid then
2971            converting the IV is going to be more efficient */
2972         const U32 isUIOK = SvIsUV(sv);
2973         char buf[TYPE_CHARS(UV)];
2974         char *ebuf, *ptr;
2975         STRLEN len;
2976
2977         if (SvTYPE(sv) < SVt_PVIV)
2978             sv_upgrade(sv, SVt_PVIV);
2979         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
2980         len = ebuf - ptr;
2981         /* inlined from sv_setpvn */
2982         s = SvGROW_mutable(sv, len + 1);
2983         Move(ptr, s, len, char);
2984         s += len;
2985         *s = '\0';
2986         SvPOK_on(sv);
2987     }
2988     else if (SvNOK(sv)) {
2989         if (SvTYPE(sv) < SVt_PVNV)
2990             sv_upgrade(sv, SVt_PVNV);
2991         if (SvNVX(sv) == 0.0) {
2992             s = SvGROW_mutable(sv, 2);
2993             *s++ = '0';
2994             *s = '\0';
2995         } else {
2996             dSAVE_ERRNO;
2997             /* The +20 is pure guesswork.  Configure test needed. --jhi */
2998             s = SvGROW_mutable(sv, NV_DIG + 20);
2999             /* some Xenix systems wipe out errno here */
3000
3001 #ifndef USE_LOCALE_NUMERIC
3002             PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3003             SvPOK_on(sv);
3004 #else
3005             {
3006                 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3007                 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3008
3009                 /* If the radix character is UTF-8, and actually is in the
3010                  * output, turn on the UTF-8 flag for the scalar */
3011                 if (PL_numeric_local
3012                     && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
3013                     && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3014                 {
3015                     SvUTF8_on(sv);
3016                 }
3017                 RESTORE_LC_NUMERIC();
3018             }
3019
3020             /* We don't call SvPOK_on(), because it may come to pass that the
3021              * locale changes so that the stringification we just did is no
3022              * longer correct.  We will have to re-stringify every time it is
3023              * needed */
3024 #endif
3025             RESTORE_ERRNO;
3026             while (*s) s++;
3027         }
3028     }
3029     else if (isGV_with_GP(sv)) {
3030         GV *const gv = MUTABLE_GV(sv);
3031         SV *const buffer = sv_newmortal();
3032
3033         gv_efullname3(buffer, gv, "*");
3034
3035         assert(SvPOK(buffer));
3036         if (SvUTF8(buffer))
3037             SvUTF8_on(sv);
3038         if (lp)
3039             *lp = SvCUR(buffer);
3040         return SvPVX(buffer);
3041     }
3042     else if (isREGEXP(sv)) {
3043         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3044         return RX_WRAPPED((REGEXP *)sv);
3045     }
3046     else {
3047         if (lp)
3048             *lp = 0;
3049         if (flags & SV_UNDEF_RETURNS_NULL)
3050             return NULL;
3051         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3052             report_uninit(sv);
3053         /* Typically the caller expects that sv_any is not NULL now.  */
3054         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3055             sv_upgrade(sv, SVt_PV);
3056         return (char *)"";
3057     }
3058
3059     {
3060         const STRLEN len = s - SvPVX_const(sv);
3061         if (lp) 
3062             *lp = len;
3063         SvCUR_set(sv, len);
3064     }
3065     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3066                           PTR2UV(sv),SvPVX_const(sv)));
3067     if (flags & SV_CONST_RETURN)
3068         return (char *)SvPVX_const(sv);
3069     if (flags & SV_MUTABLE_RETURN)
3070         return SvPVX_mutable(sv);
3071     return SvPVX(sv);
3072 }
3073
3074 /*
3075 =for apidoc sv_copypv
3076
3077 Copies a stringified representation of the source SV into the
3078 destination SV.  Automatically performs any necessary mg_get and
3079 coercion of numeric values into strings.  Guaranteed to preserve
3080 UTF8 flag even from overloaded objects.  Similar in nature to
3081 sv_2pv[_flags] but operates directly on an SV instead of just the
3082 string.  Mostly uses sv_2pv_flags to do its work, except when that
3083 would lose the UTF-8'ness of the PV.
3084
3085 =for apidoc sv_copypv_nomg
3086
3087 Like sv_copypv, but doesn't invoke get magic first.
3088
3089 =for apidoc sv_copypv_flags
3090
3091 Implementation of sv_copypv and sv_copypv_nomg.  Calls get magic iff flags
3092 include SV_GMAGIC.
3093
3094 =cut
3095 */
3096
3097 void
3098 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3099 {
3100     PERL_ARGS_ASSERT_SV_COPYPV;
3101
3102     sv_copypv_flags(dsv, ssv, 0);
3103 }
3104
3105 void
3106 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3107 {
3108     STRLEN len;
3109     const char *s;
3110
3111     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3112
3113     if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
3114         mg_get(ssv);
3115     s = SvPV_nomg_const(ssv,len);
3116     sv_setpvn(dsv,s,len);
3117     if (SvUTF8(ssv))
3118         SvUTF8_on(dsv);
3119     else
3120         SvUTF8_off(dsv);
3121 }
3122
3123 /*
3124 =for apidoc sv_2pvbyte
3125
3126 Return a pointer to the byte-encoded representation of the SV, and set *lp
3127 to its length.  May cause the SV to be downgraded from UTF-8 as a
3128 side-effect.
3129
3130 Usually accessed via the C<SvPVbyte> macro.
3131
3132 =cut
3133 */
3134
3135 char *
3136 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3137 {
3138     PERL_ARGS_ASSERT_SV_2PVBYTE;
3139
3140     SvGETMAGIC(sv);
3141     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3142      || isGV_with_GP(sv) || SvROK(sv)) {
3143         SV *sv2 = sv_newmortal();
3144         sv_copypv_nomg(sv2,sv);
3145         sv = sv2;
3146     }
3147     sv_utf8_downgrade(sv,0);
3148     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3149 }
3150
3151 /*
3152 =for apidoc sv_2pvutf8
3153
3154 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3155 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3156
3157 Usually accessed via the C<SvPVutf8> macro.
3158
3159 =cut
3160 */
3161
3162 char *
3163 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3164 {
3165     PERL_ARGS_ASSERT_SV_2PVUTF8;
3166
3167     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3168      || isGV_with_GP(sv) || SvROK(sv))
3169         sv = sv_mortalcopy(sv);
3170     else
3171         SvGETMAGIC(sv);
3172     sv_utf8_upgrade_nomg(sv);
3173     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3174 }
3175
3176
3177 /*
3178 =for apidoc sv_2bool
3179
3180 This macro is only used by sv_true() or its macro equivalent, and only if
3181 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3182 It calls sv_2bool_flags with the SV_GMAGIC flag.
3183
3184 =for apidoc sv_2bool_flags
3185
3186 This function is only used by sv_true() and friends,  and only if
3187 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3188 contain SV_GMAGIC, then it does an mg_get() first.
3189
3190
3191 =cut
3192 */
3193
3194 bool
3195 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3196 {
3197     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3198
3199     restart:
3200     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3201
3202     if (!SvOK(sv))
3203         return 0;
3204     if (SvROK(sv)) {
3205         if (SvAMAGIC(sv)) {
3206             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3207             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3208                 bool svb;
3209                 sv = tmpsv;
3210                 if(SvGMAGICAL(sv)) {
3211                     flags = SV_GMAGIC;
3212                     goto restart; /* call sv_2bool */
3213                 }
3214                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3215                 else if(!SvOK(sv)) {
3216                     svb = 0;
3217                 }
3218                 else if(SvPOK(sv)) {
3219                     svb = SvPVXtrue(sv);
3220                 }
3221                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3222                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3223                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3224                 }
3225                 else {
3226                     flags = 0;
3227                     goto restart; /* call sv_2bool_nomg */
3228                 }
3229                 return cBOOL(svb);
3230             }
3231         }
3232         return SvRV(sv) != 0;
3233     }
3234     if (isREGEXP(sv))
3235         return
3236           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3237     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3238 }
3239
3240 /*
3241 =for apidoc sv_utf8_upgrade
3242
3243 Converts the PV of an SV to its UTF-8-encoded form.
3244 Forces the SV to string form if it is not already.
3245 Will C<mg_get> on C<sv> if appropriate.
3246 Always sets the SvUTF8 flag to avoid future validity checks even
3247 if the whole string is the same in UTF-8 as not.
3248 Returns the number of bytes in the converted string
3249
3250 This is not a general purpose byte encoding to Unicode interface:
3251 use the Encode extension for that.
3252
3253 =for apidoc sv_utf8_upgrade_nomg
3254
3255 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3256
3257 =for apidoc sv_utf8_upgrade_flags
3258
3259 Converts the PV of an SV to its UTF-8-encoded form.
3260 Forces the SV to string form if it is not already.
3261 Always sets the SvUTF8 flag to avoid future validity checks even
3262 if all the bytes are invariant in UTF-8.
3263 If C<flags> has C<SV_GMAGIC> bit set,
3264 will C<mg_get> on C<sv> if appropriate, else not.
3265
3266 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3267 will expand when converted to UTF-8, and skips the extra work of checking for
3268 that.  Typically this flag is used by a routine that has already parsed the
3269 string and found such characters, and passes this information on so that the
3270 work doesn't have to be repeated.
3271
3272 Returns the number of bytes in the converted string.
3273
3274 This is not a general purpose byte encoding to Unicode interface:
3275 use the Encode extension for that.
3276
3277 =for apidoc sv_utf8_upgrade_flags_grow
3278
3279 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3280 the number of unused bytes the string of 'sv' is guaranteed to have free after
3281 it upon return.  This allows the caller to reserve extra space that it intends
3282 to fill, to avoid extra grows.
3283
3284 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3285 are implemented in terms of this function.
3286
3287 Returns the number of bytes in the converted string (not including the spares).
3288
3289 =cut
3290
3291 (One might think that the calling routine could pass in the position of the
3292 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3293 have to be found again.  But that is not the case, because typically when the
3294 caller is likely to use this flag, it won't be calling this routine unless it
3295 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3296 and just use bytes.  But some things that do fit into a byte are variants in
3297 utf8, and the caller may not have been keeping track of these.)
3298
3299 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3300 C<NUL> isn't guaranteed due to having other routines do the work in some input
3301 cases, or if the input is already flagged as being in utf8.
3302
3303 The speed of this could perhaps be improved for many cases if someone wanted to
3304 write a fast function that counts the number of variant characters in a string,
3305 especially if it could return the position of the first one.
3306
3307 */
3308
3309 STRLEN
3310 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3311 {
3312     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3313
3314     if (sv == &PL_sv_undef)
3315         return 0;
3316     if (!SvPOK_nog(sv)) {
3317         STRLEN len = 0;
3318         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3319             (void) sv_2pv_flags(sv,&len, flags);
3320             if (SvUTF8(sv)) {
3321                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3322                 return len;
3323             }
3324         } else {
3325             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3326         }
3327     }
3328
3329     if (SvUTF8(sv)) {
3330         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3331         return SvCUR(sv);
3332     }
3333
3334     if (SvIsCOW(sv)) {
3335         S_sv_uncow(aTHX_ sv, 0);
3336     }
3337
3338     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3339         sv_recode_to_utf8(sv, PL_encoding);
3340         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3341         return SvCUR(sv);
3342     }
3343
3344     if (SvCUR(sv) == 0) {
3345         if (extra) SvGROW(sv, extra);
3346     } else { /* Assume Latin-1/EBCDIC */
3347         /* This function could be much more efficient if we
3348          * had a FLAG in SVs to signal if there are any variant
3349          * chars in the PV.  Given that there isn't such a flag
3350          * make the loop as fast as possible (although there are certainly ways
3351          * to speed this up, eg. through vectorization) */
3352         U8 * s = (U8 *) SvPVX_const(sv);
3353         U8 * e = (U8 *) SvEND(sv);
3354         U8 *t = s;
3355         STRLEN two_byte_count = 0;
3356         
3357         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3358
3359         /* See if really will need to convert to utf8.  We mustn't rely on our
3360          * incoming SV being well formed and having a trailing '\0', as certain
3361          * code in pp_formline can send us partially built SVs. */
3362
3363         while (t < e) {
3364             const U8 ch = *t++;
3365             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3366
3367             t--;    /* t already incremented; re-point to first variant */
3368             two_byte_count = 1;
3369             goto must_be_utf8;
3370         }
3371
3372         /* utf8 conversion not needed because all are invariants.  Mark as
3373          * UTF-8 even if no variant - saves scanning loop */
3374         SvUTF8_on(sv);
3375         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3376         return SvCUR(sv);
3377
3378 must_be_utf8:
3379
3380         /* Here, the string should be converted to utf8, either because of an
3381          * input flag (two_byte_count = 0), or because a character that
3382          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3383          * the beginning of the string (if we didn't examine anything), or to
3384          * the first variant.  In either case, everything from s to t - 1 will
3385          * occupy only 1 byte each on output.
3386          *
3387          * There are two main ways to convert.  One is to create a new string
3388          * and go through the input starting from the beginning, appending each
3389          * converted value onto the new string as we go along.  It's probably
3390          * best to allocate enough space in the string for the worst possible
3391          * case rather than possibly running out of space and having to
3392          * reallocate and then copy what we've done so far.  Since everything
3393          * from s to t - 1 is invariant, the destination can be initialized
3394          * with these using a fast memory copy
3395          *
3396          * The other way is to figure out exactly how big the string should be
3397          * by parsing the entire input.  Then you don't have to make it big
3398          * enough to handle the worst possible case, and more importantly, if
3399          * the string you already have is large enough, you don't have to
3400          * allocate a new string, you can copy the last character in the input
3401          * string to the final position(s) that will be occupied by the
3402          * converted string and go backwards, stopping at t, since everything
3403          * before that is invariant.
3404          *
3405          * There are advantages and disadvantages to each method.
3406          *
3407          * In the first method, we can allocate a new string, do the memory
3408          * copy from the s to t - 1, and then proceed through the rest of the
3409          * string byte-by-byte.
3410          *
3411          * In the second method, we proceed through the rest of the input
3412          * string just calculating how big the converted string will be.  Then
3413          * there are two cases:
3414          *  1)  if the string has enough extra space to handle the converted
3415          *      value.  We go backwards through the string, converting until we
3416          *      get to the position we are at now, and then stop.  If this
3417          *      position is far enough along in the string, this method is
3418          *      faster than the other method.  If the memory copy were the same
3419          *      speed as the byte-by-byte loop, that position would be about
3420          *      half-way, as at the half-way mark, parsing to the end and back
3421          *      is one complete string's parse, the same amount as starting
3422          *      over and going all the way through.  Actually, it would be
3423          *      somewhat less than half-way, as it's faster to just count bytes
3424          *      than to also copy, and we don't have the overhead of allocating
3425          *      a new string, changing the scalar to use it, and freeing the
3426          *      existing one.  But if the memory copy is fast, the break-even
3427          *      point is somewhere after half way.  The counting loop could be
3428          *      sped up by vectorization, etc, to move the break-even point
3429          *      further towards the beginning.
3430          *  2)  if the string doesn't have enough space to handle the converted
3431          *      value.  A new string will have to be allocated, and one might
3432          *      as well, given that, start from the beginning doing the first
3433          *      method.  We've spent extra time parsing the string and in
3434          *      exchange all we've gotten is that we know precisely how big to
3435          *      make the new one.  Perl is more optimized for time than space,
3436          *      so this case is a loser.
3437          * So what I've decided to do is not use the 2nd method unless it is
3438          * guaranteed that a new string won't have to be allocated, assuming
3439          * the worst case.  I also decided not to put any more conditions on it
3440          * than this, for now.  It seems likely that, since the worst case is
3441          * twice as big as the unknown portion of the string (plus 1), we won't
3442          * be guaranteed enough space, causing us to go to the first method,
3443          * unless the string is short, or the first variant character is near
3444          * the end of it.  In either of these cases, it seems best to use the
3445          * 2nd method.  The only circumstance I can think of where this would
3446          * be really slower is if the string had once had much more data in it
3447          * than it does now, but there is still a substantial amount in it  */
3448
3449         {
3450             STRLEN invariant_head = t - s;
3451             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3452             if (SvLEN(sv) < size) {
3453
3454                 /* Here, have decided to allocate a new string */
3455
3456                 U8 *dst;
3457                 U8 *d;
3458
3459                 Newx(dst, size, U8);
3460
3461                 /* If no known invariants at the beginning of the input string,
3462                  * set so starts from there.  Otherwise, can use memory copy to
3463                  * get up to where we are now, and then start from here */
3464
3465                 if (invariant_head <= 0) {
3466                     d = dst;
3467                 } else {
3468                     Copy(s, dst, invariant_head, char);
3469                     d = dst + invariant_head;
3470                 }
3471
3472                 while (t < e) {
3473                     append_utf8_from_native_byte(*t, &d);
3474                     t++;
3475                 }
3476                 *d = '\0';
3477                 SvPV_free(sv); /* No longer using pre-existing string */
3478                 SvPV_set(sv, (char*)dst);
3479                 SvCUR_set(sv, d - dst);
3480                 SvLEN_set(sv, size);
3481             } else {
3482
3483                 /* Here, have decided to get the exact size of the string.
3484                  * Currently this happens only when we know that there is
3485                  * guaranteed enough space to fit the converted string, so
3486                  * don't have to worry about growing.  If two_byte_count is 0,
3487                  * then t points to the first byte of the string which hasn't
3488                  * been examined yet.  Otherwise two_byte_count is 1, and t
3489                  * points to the first byte in the string that will expand to
3490                  * two.  Depending on this, start examining at t or 1 after t.
3491                  * */
3492
3493                 U8 *d = t + two_byte_count;
3494
3495
3496                 /* Count up the remaining bytes that expand to two */
3497
3498                 while (d < e) {
3499                     const U8 chr = *d++;
3500                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3501                 }
3502
3503                 /* The string will expand by just the number of bytes that
3504                  * occupy two positions.  But we are one afterwards because of
3505                  * the increment just above.  This is the place to put the
3506                  * trailing NUL, and to set the length before we decrement */
3507
3508                 d += two_byte_count;
3509                 SvCUR_set(sv, d - s);
3510                 *d-- = '\0';
3511
3512
3513                 /* Having decremented d, it points to the position to put the
3514                  * very last byte of the expanded string.  Go backwards through
3515                  * the string, copying and expanding as we go, stopping when we
3516                  * get to the part that is invariant the rest of the way down */
3517
3518                 e--;
3519                 while (e >= t) {
3520                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3521                         *d-- = *e;
3522                     } else {
3523                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3524                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3525                     }
3526                     e--;
3527                 }
3528             }
3529
3530             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3531                 /* Update pos. We do it at the end rather than during
3532                  * the upgrade, to avoid slowing down the common case
3533                  * (upgrade without pos).
3534                  * pos can be stored as either bytes or characters.  Since
3535                  * this was previously a byte string we can just turn off
3536                  * the bytes flag. */
3537                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3538                 if (mg) {
3539                     mg->mg_flags &= ~MGf_BYTES;
3540                 }
3541                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3542                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3543             }
3544         }
3545     }
3546
3547     /* Mark as UTF-8 even if no variant - saves scanning loop */
3548     SvUTF8_on(sv);
3549     return SvCUR(sv);
3550 }
3551
3552 /*
3553 =for apidoc sv_utf8_downgrade
3554
3555 Attempts to convert the PV of an SV from characters to bytes.
3556 If the PV contains a character that cannot fit
3557 in a byte, this conversion will fail;
3558 in this case, either returns false or, if C<fail_ok> is not
3559 true, croaks.
3560
3561 This is not a general purpose Unicode to byte encoding interface:
3562 use the Encode extension for that.
3563
3564 =cut
3565 */
3566
3567 bool
3568 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3569 {
3570     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3571
3572     if (SvPOKp(sv) && SvUTF8(sv)) {
3573         if (SvCUR(sv)) {
3574             U8 *s;
3575             STRLEN len;
3576             int mg_flags = SV_GMAGIC;
3577
3578             if (SvIsCOW(sv)) {
3579                 S_sv_uncow(aTHX_ sv, 0);
3580             }
3581             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3582                 /* update pos */
3583                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3584                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3585                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3586                                                 SV_GMAGIC|SV_CONST_RETURN);
3587                         mg_flags = 0; /* sv_pos_b2u does get magic */
3588                 }
3589                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3590                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3591
3592             }
3593             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3594
3595             if (!utf8_to_bytes(s, &len)) {
3596                 if (fail_ok)
3597                     return FALSE;
3598                 else {
3599                     if (PL_op)
3600                         Perl_croak(aTHX_ "Wide character in %s",
3601                                    OP_DESC(PL_op));
3602                     else
3603                         Perl_croak(aTHX_ "Wide character");
3604                 }
3605             }
3606             SvCUR_set(sv, len);
3607         }
3608     }
3609     SvUTF8_off(sv);
3610     return TRUE;
3611 }
3612
3613 /*
3614 =for apidoc sv_utf8_encode
3615
3616 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3617 flag off so that it looks like octets again.
3618
3619 =cut
3620 */
3621
3622 void
3623 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3624 {
3625     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3626
3627     if (SvREADONLY(sv)) {
3628         sv_force_normal_flags(sv, 0);
3629     }
3630     (void) sv_utf8_upgrade(sv);
3631     SvUTF8_off(sv);
3632 }
3633
3634 /*
3635 =for apidoc sv_utf8_decode
3636
3637 If the PV of the SV is an octet sequence in UTF-8
3638 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3639 so that it looks like a character.  If the PV contains only single-byte
3640 characters, the C<SvUTF8> flag stays off.
3641 Scans PV for validity and returns false if the PV is invalid UTF-8.
3642
3643 =cut
3644 */
3645
3646 bool
3647 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3648 {
3649     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3650
3651     if (SvPOKp(sv)) {
3652         const U8 *start, *c;
3653         const U8 *e;
3654
3655         /* The octets may have got themselves encoded - get them back as
3656          * bytes
3657          */
3658         if (!sv_utf8_downgrade(sv, TRUE))
3659             return FALSE;
3660
3661         /* it is actually just a matter of turning the utf8 flag on, but
3662          * we want to make sure everything inside is valid utf8 first.
3663          */
3664         c = start = (const U8 *) SvPVX_const(sv);
3665         if (!is_utf8_string(c, SvCUR(sv)))
3666             return FALSE;
3667         e = (const U8 *) SvEND(sv);
3668         while (c < e) {
3669             const U8 ch = *c++;
3670             if (!UTF8_IS_INVARIANT(ch)) {
3671                 SvUTF8_on(sv);
3672                 break;
3673             }
3674         }
3675         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3676             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3677                    after this, clearing pos.  Does anything on CPAN
3678                    need this? */
3679             /* adjust pos to the start of a UTF8 char sequence */
3680             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3681             if (mg) {
3682                 I32 pos = mg->mg_len;
3683                 if (pos > 0) {
3684                     for (c = start + pos; c > start; c--) {
3685                         if (UTF8_IS_START(*c))
3686                             break;
3687                     }
3688                     mg->mg_len  = c - start;
3689                 }
3690             }
3691             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3692                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3693         }
3694     }
3695     return TRUE;
3696 }
3697
3698 /*
3699 =for apidoc sv_setsv
3700
3701 Copies the contents of the source SV C<ssv> into the destination SV
3702 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3703 function if the source SV needs to be reused.  Does not handle 'set' magic on
3704 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3705 performs a copy-by-value, obliterating any previous content of the
3706 destination.
3707
3708 You probably want to use one of the assortment of wrappers, such as
3709 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3710 C<SvSetMagicSV_nosteal>.
3711
3712 =for apidoc sv_setsv_flags
3713
3714 Copies the contents of the source SV C<ssv> into the destination SV
3715 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3716 function if the source SV needs to be reused.  Does not handle 'set' magic.
3717 Loosely speaking, it performs a copy-by-value, obliterating any previous
3718 content of the destination.
3719 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3720 C<ssv> if appropriate, else not.  If the C<flags>
3721 parameter has the C<SV_NOSTEAL> bit set then the
3722 buffers of temps will not be stolen.  <sv_setsv>
3723 and C<sv_setsv_nomg> are implemented in terms of this function.
3724
3725 You probably want to use one of the assortment of wrappers, such as
3726 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3727 C<SvSetMagicSV_nosteal>.
3728
3729 This is the primary function for copying scalars, and most other
3730 copy-ish functions and macros use this underneath.
3731
3732 =cut
3733 */
3734
3735 static void
3736 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3737 {
3738     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3739     HV *old_stash = NULL;
3740
3741     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3742
3743     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3744         const char * const name = GvNAME(sstr);
3745         const STRLEN len = GvNAMELEN(sstr);
3746         {
3747             if (dtype >= SVt_PV) {
3748                 SvPV_free(dstr);
3749                 SvPV_set(dstr, 0);
3750                 SvLEN_set(dstr, 0);
3751                 SvCUR_set(dstr, 0);
3752             }
3753             SvUPGRADE(dstr, SVt_PVGV);
3754             (void)SvOK_off(dstr);
3755             isGV_with_GP_on(dstr);
3756         }
3757         GvSTASH(dstr) = GvSTASH(sstr);
3758         if (GvSTASH(dstr))
3759             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3760         gv_name_set(MUTABLE_GV(dstr), name, len,
3761                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3762         SvFAKE_on(dstr);        /* can coerce to non-glob */
3763     }
3764
3765     if(GvGP(MUTABLE_GV(sstr))) {
3766         /* If source has method cache entry, clear it */
3767         if(GvCVGEN(sstr)) {
3768             SvREFCNT_dec(GvCV(sstr));
3769             GvCV_set(sstr, NULL);
3770             GvCVGEN(sstr) = 0;
3771         }
3772         /* If source has a real method, then a method is
3773            going to change */
3774         else if(
3775          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3776         ) {
3777             mro_changes = 1;
3778         }
3779     }
3780
3781     /* If dest already had a real method, that's a change as well */
3782     if(
3783         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3784      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3785     ) {
3786         mro_changes = 1;
3787     }
3788
3789     /* We don't need to check the name of the destination if it was not a
3790        glob to begin with. */
3791     if(dtype == SVt_PVGV) {
3792         const char * const name = GvNAME((const GV *)dstr);
3793         if(
3794             strEQ(name,"ISA")
3795          /* The stash may have been detached from the symbol table, so
3796             check its name. */
3797          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3798         )
3799             mro_changes = 2;
3800         else {
3801             const STRLEN len = GvNAMELEN(dstr);
3802             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3803              || (len == 1 && name[0] == ':')) {
3804                 mro_changes = 3;
3805
3806                 /* Set aside the old stash, so we can reset isa caches on
3807                    its subclasses. */
3808                 if((old_stash = GvHV(dstr)))
3809                     /* Make sure we do not lose it early. */
3810                     SvREFCNT_inc_simple_void_NN(
3811                      sv_2mortal((SV *)old_stash)
3812                     );
3813             }
3814         }
3815
3816         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3817     }
3818
3819     gp_free(MUTABLE_GV(dstr));
3820     GvINTRO_off(dstr);          /* one-shot flag */
3821     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3822     if (SvTAINTED(sstr))
3823         SvTAINT(dstr);
3824     if (GvIMPORTED(dstr) != GVf_IMPORTED
3825         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3826         {
3827             GvIMPORTED_on(dstr);
3828         }
3829     GvMULTI_on(dstr);
3830     if(mro_changes == 2) {
3831       if (GvAV((const GV *)sstr)) {
3832         MAGIC *mg;
3833         SV * const sref = (SV *)GvAV((const GV *)dstr);
3834         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3835             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3836                 AV * const ary = newAV();
3837                 av_push(ary, mg->mg_obj); /* takes the refcount */
3838                 mg->mg_obj = (SV *)ary;
3839             }
3840             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3841         }
3842         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3843       }
3844       mro_isa_changed_in(GvSTASH(dstr));
3845     }
3846     else if(mro_changes == 3) {
3847         HV * const stash = GvHV(dstr);
3848         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3849             mro_package_moved(
3850                 stash, old_stash,
3851                 (GV *)dstr, 0
3852             );
3853     }
3854     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3855     if (GvIO(dstr) && dtype == SVt_PVGV) {
3856         DEBUG_o(Perl_deb(aTHX_
3857                         "glob_assign_glob clearing PL_stashcache\n"));
3858         /* It's a cache. It will rebuild itself quite happily.
3859            It's a lot of effort to work out exactly which key (or keys)
3860            might be invalidated by the creation of the this file handle.
3861          */
3862         hv_clear(PL_stashcache);
3863     }
3864     return;
3865 }
3866
3867 static void
3868 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3869 {
3870     SV * const sref = SvRV(sstr);
3871     SV *dref;
3872     const int intro = GvINTRO(dstr);
3873     SV **location;
3874     U8 import_flag = 0;
3875     const U32 stype = SvTYPE(sref);
3876
3877     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3878
3879     if (intro) {
3880         GvINTRO_off(dstr);      /* one-shot flag */
3881         GvLINE(dstr) = CopLINE(PL_curcop);
3882         GvEGV(dstr) = MUTABLE_GV(dstr);
3883     }
3884     GvMULTI_on(dstr);
3885     switch (stype) {
3886     case SVt_PVCV:
3887         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3888         import_flag = GVf_IMPORTED_CV;
3889         goto common;
3890     case SVt_PVHV:
3891         location = (SV **) &GvHV(dstr);
3892         import_flag = GVf_IMPORTED_HV;
3893         goto common;
3894     case SVt_PVAV:
3895         location = (SV **) &GvAV(dstr);
3896         import_flag = GVf_IMPORTED_AV;
3897         goto common;
3898     case SVt_PVIO:
3899         location = (SV **) &GvIOp(dstr);
3900         goto common;
3901     case SVt_PVFM:
3902         location = (SV **) &GvFORM(dstr);
3903         goto common;
3904     default:
3905         location = &GvSV(dstr);
3906         import_flag = GVf_IMPORTED_SV;
3907     common:
3908         if (intro) {
3909             if (stype == SVt_PVCV) {
3910                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3911                 if (GvCVGEN(dstr)) {
3912                     SvREFCNT_dec(GvCV(dstr));
3913                     GvCV_set(dstr, NULL);
3914                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3915                 }
3916             }
3917             /* SAVEt_GVSLOT takes more room on the savestack and has more
3918                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
3919                leave_scope needs access to the GV so it can reset method
3920                caches.  We must use SAVEt_GVSLOT whenever the type is
3921                SVt_PVCV, even if the stash is anonymous, as the stash may
3922                gain a name somehow before leave_scope. */
3923             if (stype == SVt_PVCV) {
3924                 /* There is no save_pushptrptrptr.  Creating it for this
3925                    one call site would be overkill.  So inline the ss add
3926                    routines here. */
3927                 dSS_ADD;
3928                 SS_ADD_PTR(dstr);
3929                 SS_ADD_PTR(location);
3930                 SS_ADD_PTR(SvREFCNT_inc(*location));
3931                 SS_ADD_UV(SAVEt_GVSLOT);
3932                 SS_ADD_END(4);
3933             }
3934             else SAVEGENERICSV(*location);
3935         }
3936         dref = *location;
3937         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3938             CV* const cv = MUTABLE_CV(*location);
3939             if (cv) {
3940                 if (!GvCVGEN((const GV *)dstr) &&
3941                     (CvROOT(cv) || CvXSUB(cv)) &&
3942                     /* redundant check that avoids creating the extra SV
3943                        most of the time: */
3944                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3945                     {
3946                         SV * const new_const_sv =
3947                             CvCONST((const CV *)sref)
3948                                  ? cv_const_sv((const CV *)sref)
3949                                  : NULL;
3950                         report_redefined_cv(
3951                            sv_2mortal(Perl_newSVpvf(aTHX_
3952                                 "%"HEKf"::%"HEKf,
3953                                 HEKfARG(
3954                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
3955                                 ),
3956                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
3957                            )),
3958                            cv,
3959                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
3960                         );
3961                     }
3962                 if (!intro)
3963                     cv_ckproto_len_flags(cv, (const GV *)dstr,
3964                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
3965                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
3966                                    SvPOK(sref) ? SvUTF8(sref) : 0);
3967             }
3968             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3969             GvASSUMECV_on(dstr);
3970             if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
3971         }
3972         *location = SvREFCNT_inc_simple_NN(sref);
3973         if (import_flag && !(GvFLAGS(dstr) & import_flag)
3974             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
3975             GvFLAGS(dstr) |= import_flag;
3976         }
3977         if (stype == SVt_PVHV) {
3978             const char * const name = GvNAME((GV*)dstr);
3979             const STRLEN len = GvNAMELEN(dstr);
3980             if (
3981                 (
3982                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
3983                 || (len == 1 && name[0] == ':')
3984                 )
3985              && (!dref || HvENAME_get(dref))
3986             ) {
3987                 mro_package_moved(
3988                     (HV *)sref, (HV *)dref,
3989                     (GV *)dstr, 0
3990                 );
3991             }
3992         }
3993         else if (
3994             stype == SVt_PVAV && sref != dref
3995          && strEQ(GvNAME((GV*)dstr), "ISA")
3996          /* The stash may have been detached from the symbol table, so
3997             check its name before doing anything. */
3998          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3999         ) {
4000             MAGIC *mg;
4001             MAGIC * const omg = dref && SvSMAGICAL(dref)
4002                                  ? mg_find(dref, PERL_MAGIC_isa)
4003                                  : NULL;
4004             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4005                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4006                     AV * const ary = newAV();
4007                     av_push(ary, mg->mg_obj); /* takes the refcount */
4008                     mg->mg_obj = (SV *)ary;
4009                 }
4010                 if (omg) {
4011                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4012                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4013                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4014                         while (items--)
4015                             av_push(
4016                              (AV *)mg->mg_obj,
4017                              SvREFCNT_inc_simple_NN(*svp++)
4018                             );
4019                     }
4020                     else
4021                         av_push(
4022                          (AV *)mg->mg_obj,
4023                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4024                         );
4025                 }
4026                 else
4027                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4028             }
4029             else
4030             {
4031                 sv_magic(
4032                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4033                 );
4034                 mg = mg_find(sref, PERL_MAGIC_isa);
4035             }
4036             /* Since the *ISA assignment could have affected more than
4037                one stash, don't call mro_isa_changed_in directly, but let
4038                magic_clearisa do it for us, as it already has the logic for
4039                dealing with globs vs arrays of globs. */
4040             assert(mg);
4041             Perl_magic_clearisa(aTHX_ NULL, mg);
4042         }
4043         else if (stype == SVt_PVIO) {
4044             DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4045             /* It's a cache. It will rebuild itself quite happily.
4046                It's a lot of effort to work out exactly which key (or keys)
4047                might be invalidated by the creation of the this file handle.
4048             */
4049             hv_clear(PL_stashcache);
4050         }
4051         break;
4052     }
4053     if (!intro) SvREFCNT_dec(dref);
4054     if (SvTAINTED(sstr))
4055         SvTAINT(dstr);
4056     return;
4057 }
4058
4059
4060
4061
4062 #ifdef PERL_DEBUG_READONLY_COW
4063 # include <sys/mman.h>
4064
4065 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4066 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4067 # endif
4068
4069 void
4070 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4071 {
4072     struct perl_memory_debug_header * const header =
4073         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4074     const MEM_SIZE len = header->size;
4075     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4076 # ifdef PERL_TRACK_MEMPOOL
4077     if (!header->readonly) header->readonly = 1;
4078 # endif
4079     if (mprotect(header, len, PROT_READ))
4080         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4081                          header, len, errno);
4082 }
4083
4084 static void
4085 S_sv_buf_to_rw(pTHX_ SV *sv)
4086 {
4087     struct perl_memory_debug_header * const header =
4088         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4089     const MEM_SIZE len = header->size;
4090     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4091     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4092         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4093                          header, len, errno);
4094 # ifdef PERL_TRACK_MEMPOOL
4095     header->readonly = 0;
4096 # endif
4097 }
4098
4099 #else
4100 # define sv_buf_to_ro(sv)       NOOP
4101 # define sv_buf_to_rw(sv)       NOOP
4102 #endif
4103
4104 void
4105 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4106 {
4107     U32 sflags;
4108     int dtype;
4109     svtype stype;
4110
4111     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4112
4113     if (sstr == dstr)
4114         return;
4115
4116     if (SvIS_FREED(dstr)) {
4117         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4118                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4119     }
4120     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4121     if (!sstr)
4122         sstr = &PL_sv_undef;
4123     if (SvIS_FREED(sstr)) {
4124         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4125                    (void*)sstr, (void*)dstr);
4126     }
4127     stype = SvTYPE(sstr);
4128     dtype = SvTYPE(dstr);
4129
4130     /* There's a lot of redundancy below but we're going for speed here */
4131
4132     switch (stype) {
4133     case SVt_NULL:
4134       undef_sstr:
4135         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4136             (void)SvOK_off(dstr);
4137             return;
4138         }
4139         break;
4140     case SVt_IV:
4141         if (SvIOK(sstr)) {
4142             switch (dtype) {
4143             case SVt_NULL:
4144                 sv_upgrade(dstr, SVt_IV);
4145                 break;
4146             case SVt_NV:
4147             case SVt_PV:
4148                 sv_upgrade(dstr, SVt_PVIV);
4149                 break;
4150             case SVt_PVGV:
4151             case SVt_PVLV:
4152                 goto end_of_first_switch;
4153             }
4154             (void)SvIOK_only(dstr);
4155             SvIV_set(dstr,  SvIVX(sstr));
4156             if (SvIsUV(sstr))
4157                 SvIsUV_on(dstr);
4158             /* SvTAINTED can only be true if the SV has taint magic, which in
4159                turn means that the SV type is PVMG (or greater). This is the
4160                case statement for SVt_IV, so this cannot be true (whatever gcov
4161                may say).  */
4162             assert(!SvTAINTED(sstr));
4163             return;
4164         }
4165         if (!SvROK(sstr))
4166             goto undef_sstr;
4167         if (dtype < SVt_PV && dtype != SVt_IV)
4168             sv_upgrade(dstr, SVt_IV);
4169         break;
4170
4171     case SVt_NV:
4172         if (SvNOK(sstr)) {
4173             switch (dtype) {
4174             case SVt_NULL:
4175             case SVt_IV:
4176                 sv_upgrade(dstr, SVt_NV);
4177                 break;
4178             case SVt_PV:
4179             case SVt_PVIV:
4180                 sv_upgrade(dstr, SVt_PVNV);
4181                 break;
4182             case SVt_PVGV:
4183             case SVt_PVLV:
4184                 goto end_of_first_switch;
4185             }
4186             SvNV_set(dstr, SvNVX(sstr));
4187             (void)SvNOK_only(dstr);
4188             /* SvTAINTED can only be true if the SV has taint magic, which in
4189                turn means that the SV type is PVMG (or greater). This is the
4190                case statement for SVt_NV, so this cannot be true (whatever gcov
4191                may say).  */
4192             assert(!SvTAINTED(sstr));
4193             return;
4194         }
4195         goto undef_sstr;
4196
4197     case SVt_PV:
4198         if (dtype < SVt_PV)
4199             sv_upgrade(dstr, SVt_PV);
4200         break;
4201     case SVt_PVIV:
4202         if (dtype < SVt_PVIV)
4203             sv_upgrade(dstr, SVt_PVIV);
4204         break;
4205     case SVt_PVNV:
4206         if (dtype < SVt_PVNV)
4207             sv_upgrade(dstr, SVt_PVNV);
4208         break;
4209     default:
4210         {
4211         const char * const type = sv_reftype(sstr,0);
4212         if (PL_op)
4213             /* diag_listed_as: Bizarre copy of %s */
4214             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4215         else
4216             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4217         }
4218         NOT_REACHED; /* NOTREACHED */
4219
4220     case SVt_REGEXP:
4221       upgregexp:
4222         if (dtype < SVt_REGEXP)
4223         {
4224             if (dtype >= SVt_PV) {
4225                 SvPV_free(dstr);
4226                 SvPV_set(dstr, 0);
4227                 SvLEN_set(dstr, 0);
4228                 SvCUR_set(dstr, 0);
4229             }
4230             sv_upgrade(dstr, SVt_REGEXP);
4231         }
4232         break;
4233
4234         case SVt_INVLIST:
4235     case SVt_PVLV:
4236     case SVt_PVGV:
4237     case SVt_PVMG:
4238         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4239             mg_get(sstr);
4240             if (SvTYPE(sstr) != stype)
4241                 stype = SvTYPE(sstr);
4242         }
4243         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4244                     glob_assign_glob(dstr, sstr, dtype);
4245                     return;
4246         }
4247         if (stype == SVt_PVLV)
4248         {
4249             if (isREGEXP(sstr)) goto upgregexp;
4250             SvUPGRADE(dstr, SVt_PVNV);
4251         }
4252         else
4253             SvUPGRADE(dstr, (svtype)stype);
4254     }
4255  end_of_first_switch:
4256
4257     /* dstr may have been upgraded.  */
4258     dtype = SvTYPE(dstr);
4259     sflags = SvFLAGS(sstr);
4260
4261     if (dtype == SVt_PVCV) {
4262         /* Assigning to a subroutine sets the prototype.  */
4263         if (SvOK(sstr)) {
4264             STRLEN len;
4265             const char *const ptr = SvPV_const(sstr, len);
4266
4267             SvGROW(dstr, len + 1);
4268             Copy(ptr, SvPVX(dstr), len + 1, char);
4269             SvCUR_set(dstr, len);
4270             SvPOK_only(dstr);
4271             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4272             CvAUTOLOAD_off(dstr);
4273         } else {
4274             SvOK_off(dstr);
4275         }
4276     }
4277     else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4278         const char * const type = sv_reftype(dstr,0);
4279         if (PL_op)
4280             /* diag_listed_as: Cannot copy to %s */
4281             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4282         else
4283             Perl_croak(aTHX_ "Cannot copy to %s", type);
4284     } else if (sflags & SVf_ROK) {
4285         if (isGV_with_GP(dstr)
4286             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4287             sstr = SvRV(sstr);
4288             if (sstr == dstr) {
4289                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4290                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4291                 {
4292                     GvIMPORTED_on(dstr);
4293                 }
4294                 GvMULTI_on(dstr);
4295                 return;
4296             }
4297             glob_assign_glob(dstr, sstr, dtype);
4298             return;
4299         }
4300
4301         if (dtype >= SVt_PV) {
4302             if (isGV_with_GP(dstr)) {
4303                 glob_assign_ref(dstr, sstr);
4304                 return;
4305             }
4306             if (SvPVX_const(dstr)) {
4307                 SvPV_free(dstr);
4308                 SvLEN_set(dstr, 0);
4309                 SvCUR_set(dstr, 0);
4310             }
4311         }
4312         (void)SvOK_off(dstr);
4313         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4314         SvFLAGS(dstr) |= sflags & SVf_ROK;
4315         assert(!(sflags & SVp_NOK));
4316         assert(!(sflags & SVp_IOK));
4317         assert(!(sflags & SVf_NOK));
4318         assert(!(sflags & SVf_IOK));
4319     }
4320     else if (isGV_with_GP(dstr)) {
4321         if (!(sflags & SVf_OK)) {
4322             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4323                            "Undefined value assigned to typeglob");
4324         }
4325         else {
4326             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4327             if (dstr != (const SV *)gv) {
4328                 const char * const name = GvNAME((const GV *)dstr);
4329                 const STRLEN len = GvNAMELEN(dstr);
4330                 HV *old_stash = NULL;
4331                 bool reset_isa = FALSE;
4332                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4333                  || (len == 1 && name[0] == ':')) {
4334                     /* Set aside the old stash, so we can reset isa caches
4335                        on its subclasses. */
4336                     if((old_stash = GvHV(dstr))) {
4337                         /* Make sure we do not lose it early. */
4338                         SvREFCNT_inc_simple_void_NN(
4339                          sv_2mortal((SV *)old_stash)
4340                         );
4341                     }
4342                     reset_isa = TRUE;
4343                 }
4344
4345                 if (GvGP(dstr)) {
4346                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4347                     gp_free(MUTABLE_GV(dstr));
4348                 }
4349                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4350
4351                 if (reset_isa) {
4352                     HV * const stash = GvHV(dstr);
4353                     if(
4354                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4355                     )
4356                         mro_package_moved(
4357                          stash, old_stash,
4358                          (GV *)dstr, 0
4359                         );
4360                 }
4361             }
4362         }
4363     }
4364     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4365           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4366         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4367     }
4368     else if (sflags & SVp_POK) {
4369         const STRLEN cur = SvCUR(sstr);
4370         const STRLEN len = SvLEN(sstr);
4371
4372         /*
4373          * We have three basic ways to copy the string:
4374          *
4375          *  1. Swipe
4376          *  2. Copy-on-write
4377          *  3. Actual copy
4378          * 
4379          * Which we choose is based on various factors.  The following
4380          * things are listed in order of speed, fastest to slowest:
4381          *  - Swipe
4382          *  - Copying a short string
4383          *  - Copy-on-write bookkeeping
4384          *  - malloc
4385          *  - Copying a long string
4386          * 
4387          * We swipe the string (steal the string buffer) if the SV on the
4388          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4389          * big win on long strings.  It should be a win on short strings if
4390          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4391          * slow things down, as SvPVX_const(sstr) would have been freed
4392          * soon anyway.
4393          * 
4394          * We also steal the buffer from a PADTMP (operator target) if it
4395          * is ‘long enough’.  For short strings, a swipe does not help
4396          * here, as it causes more malloc calls the next time the target
4397          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4398          * be allocated it is still not worth swiping PADTMPs for short
4399          * strings, as the savings here are small.
4400          * 
4401          * If the rhs is already flagged as a copy-on-write string and COW
4402          * is possible here, we use copy-on-write and make both SVs share
4403          * the string buffer.
4404          * 
4405          * If the rhs is not flagged as copy-on-write, then we see whether
4406          * it is worth upgrading it to such.  If the lhs already has a buf-
4407          * fer big enough and the string is short, we skip it and fall back
4408          * to method 3, since memcpy is faster for short strings than the
4409          * later bookkeeping overhead that copy-on-write entails.
4410          * 
4411          * If there is no buffer on the left, or the buffer is too small,
4412          * then we use copy-on-write.
4413          */
4414
4415         /* Whichever path we take through the next code, we want this true,
4416            and doing it now facilitates the COW check.  */
4417         (void)SvPOK_only(dstr);
4418
4419         if (
4420                  (              /* Either ... */
4421                                 /* slated for free anyway (and not COW)? */
4422                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4423                                 /* or a swipable TARG */
4424                  || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
4425                        == SVs_PADTMP
4426                                 /* whose buffer is worth stealing */
4427                      && CHECK_COWBUF_THRESHOLD(cur,len)
4428                     )
4429                  ) &&
4430                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4431                  (!(flags & SV_NOSTEAL)) &&
4432                                         /* and we're allowed to steal temps */
4433                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4434                  len)             /* and really is a string */
4435         {       /* Passes the swipe test.  */
4436             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4437                 SvPV_free(dstr);
4438             SvPV_set(dstr, SvPVX_mutable(sstr));
4439             SvLEN_set(dstr, SvLEN(sstr));
4440             SvCUR_set(dstr, SvCUR(sstr));
4441
4442             SvTEMP_off(dstr);
4443             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4444             SvPV_set(sstr, NULL);
4445             SvLEN_set(sstr, 0);
4446             SvCUR_set(sstr, 0);
4447             SvTEMP_off(sstr);
4448         }
4449         else if (flags & SV_COW_SHARED_HASH_KEYS
4450               &&
4451 #ifdef PERL_OLD_COPY_ON_WRITE
4452                  (  sflags & SVf_IsCOW
4453                  || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4454                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4455                      && SvTYPE(sstr) >= SVt_PVIV && len
4456                     )
4457                  )
4458 #elif defined(PERL_NEW_COPY_ON_WRITE)
4459                  (sflags & SVf_IsCOW
4460                    ? (!len ||
4461                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4462                           /* If this is a regular (non-hek) COW, only so
4463                              many COW "copies" are possible. */
4464                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4465                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4466                      && !(SvFLAGS(dstr) & SVf_BREAK)
4467                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4468                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4469                     ))
4470 #else
4471                  sflags & SVf_IsCOW
4472               && !(SvFLAGS(dstr) & SVf_BREAK)
4473 #endif
4474             ) {
4475             /* Either it's a shared hash key, or it's suitable for
4476                copy-on-write.  */
4477             if (DEBUG_C_TEST) {
4478                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4479                 sv_dump(sstr);
4480                 sv_dump(dstr);
4481             }
4482 #ifdef PERL_ANY_COW
4483             if (!(sflags & SVf_IsCOW)) {
4484                     SvIsCOW_on(sstr);
4485 # ifdef PERL_OLD_COPY_ON_WRITE
4486                     /* Make the source SV into a loop of 1.
4487                        (about to become 2) */
4488                     SV_COW_NEXT_SV_SET(sstr, sstr);
4489 # else
4490                     CowREFCNT(sstr) = 0;
4491 # endif
4492             }
4493 #endif
4494             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4495                 SvPV_free(dstr);
4496             }
4497
4498 #ifdef PERL_ANY_COW
4499             if (len) {
4500 # ifdef PERL_OLD_COPY_ON_WRITE
4501                     assert (SvTYPE(dstr) >= SVt_PVIV);
4502                     /* SvIsCOW_normal */
4503                     /* splice us in between source and next-after-source.  */
4504                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4505                     SV_COW_NEXT_SV_SET(sstr, dstr);
4506 # else
4507                     if (sflags & SVf_IsCOW) {
4508                         sv_buf_to_rw(sstr);
4509                     }
4510                     CowREFCNT(sstr)++;
4511 # endif
4512                     SvPV_set(dstr, SvPVX_mutable(sstr));
4513                     sv_buf_to_ro(sstr);
4514             } else
4515 #endif
4516             {
4517                     /* SvIsCOW_shared_hash */
4518                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4519                                           "Copy on write: Sharing hash\n"));
4520
4521                     assert (SvTYPE(dstr) >= SVt_PV);
4522                     SvPV_set(dstr,
4523                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4524             }
4525             SvLEN_set(dstr, len);
4526             SvCUR_set(dstr, cur);
4527             SvIsCOW_on(dstr);
4528         } else {
4529             /* Failed the swipe test, and we cannot do copy-on-write either.
4530                Have to copy the string.  */
4531             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4532             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4533             SvCUR_set(dstr, cur);
4534             *SvEND(dstr) = '\0';
4535         }
4536         if (sflags & SVp_NOK) {
4537             SvNV_set(dstr, SvNVX(sstr));
4538         }
4539         if (sflags & SVp_IOK) {
4540             SvIV_set(dstr, SvIVX(sstr));
4541             /* Must do this otherwise some other overloaded use of 0x80000000
4542                gets confused. I guess SVpbm_VALID */
4543             if (sflags & SVf_IVisUV)
4544                 SvIsUV_on(dstr);
4545         }
4546         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4547         {
4548             const MAGIC * const smg = SvVSTRING_mg(sstr);
4549             if (smg) {
4550                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4551                          smg->mg_ptr, smg->mg_len);
4552                 SvRMAGICAL_on(dstr);
4553             }
4554         }
4555     }
4556     else if (sflags & (SVp_IOK|SVp_NOK)) {
4557         (void)SvOK_off(dstr);
4558         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);
4559         if (sflags & SVp_IOK) {
4560             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4561             SvIV_set(dstr, SvIVX(sstr));
4562         }
4563         if (sflags & SVp_NOK) {
4564             SvNV_set(dstr, SvNVX(sstr));
4565         }
4566     }
4567     else {
4568         if (isGV_with_GP(sstr)) {
4569             gv_efullname3(dstr, MUTABLE_GV(sstr), "*");
4570         }
4571         else
4572             (void)SvOK_off(dstr);
4573     }
4574     if (SvTAINTED(sstr))
4575         SvTAINT(dstr);
4576 }
4577
4578 /*
4579 =for apidoc sv_setsv_mg
4580
4581 Like C<sv_setsv>, but also handles 'set' magic.
4582
4583 =cut
4584 */
4585
4586 void
4587 Perl_sv_setsv_mg(pTHX_ SV *const dstr, SV *const sstr)
4588 {
4589     PERL_ARGS_ASSERT_SV_SETSV_MG;
4590
4591     sv_setsv(dstr,sstr);
4592     SvSETMAGIC(dstr);
4593 }
4594
4595 #ifdef PERL_ANY_COW
4596 # ifdef PERL_OLD_COPY_ON_WRITE
4597 #  define SVt_COW SVt_PVIV
4598 # else
4599 #  define SVt_COW SVt_PV
4600 # endif
4601 SV *
4602 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4603 {
4604     STRLEN cur = SvCUR(sstr);
4605     STRLEN len = SvLEN(sstr);
4606     char *new_pv;
4607 #if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
4608     const bool already = cBOOL(SvIsCOW(sstr));
4609 #endif
4610
4611     PERL_ARGS_ASSERT_SV_SETSV_COW;
4612
4613     if (DEBUG_C_TEST) {
4614         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4615                       (void*)sstr, (void*)dstr);
4616         sv_dump(sstr);
4617         if (dstr)
4618                     sv_dump(dstr);
4619     }
4620
4621     if (dstr) {
4622         if (SvTHINKFIRST(dstr))
4623             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4624         else if (SvPVX_const(dstr))
4625             Safefree(SvPVX_mutable(dstr));
4626     }
4627     else
4628         new_SV(dstr);
4629     SvUPGRADE(dstr, SVt_COW);
4630
4631     assert (SvPOK(sstr));
4632     assert (SvPOKp(sstr));
4633 # ifdef PERL_OLD_COPY_ON_WRITE
4634     assert (!SvIOK(sstr));
4635     assert (!SvIOKp(sstr));
4636     assert (!SvNOK(sstr));
4637     assert (!SvNOKp(sstr));
4638 # endif
4639
4640     if (SvIsCOW(sstr)) {
4641
4642         if (SvLEN(sstr) == 0) {
4643             /* source is a COW shared hash key.  */
4644             DEBUG_C(PerlIO_printf(Perl_debug_log,
4645                                   "Fast copy on write: Sharing hash\n"));
4646             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4647             goto common_exit;
4648         }
4649 # ifdef PERL_OLD_COPY_ON_WRITE
4650         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4651 # else
4652         assert(SvCUR(sstr)+1 < SvLEN(sstr));
4653         assert(CowREFCNT(sstr) < SV_COW_REFCNT_MAX);
4654 # endif
4655     } else {
4656         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4657         SvUPGRADE(sstr, SVt_COW);
4658         SvIsCOW_on(sstr);
4659         DEBUG_C(PerlIO_printf(Perl_debug_log,
4660                               "Fast copy on write: Converting sstr to COW\n"));
4661 # ifdef PERL_OLD_COPY_ON_WRITE
4662         SV_COW_NEXT_SV_SET(dstr, sstr);
4663 # else
4664         CowREFCNT(sstr) = 0;    
4665 # endif
4666     }
4667 # ifdef PERL_OLD_COPY_ON_WRITE
4668     SV_COW_NEXT_SV_SET(sstr, dstr);
4669 # else
4670 #  ifdef PERL_DEBUG_READONLY_COW
4671     if (already) sv_buf_to_rw(sstr);
4672 #  endif
4673     CowREFCNT(sstr)++;  
4674 # endif
4675     new_pv = SvPVX_mutable(sstr);
4676     sv_buf_to_ro(sstr);
4677
4678   common_exit:
4679     SvPV_set(dstr, new_pv);
4680     SvFLAGS(dstr) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW);
4681     if (SvUTF8(sstr))
4682         SvUTF8_on(dstr);
4683     SvLEN_set(dstr, len);
4684     SvCUR_set(dstr, cur);
4685     if (DEBUG_C_TEST) {
4686         sv_dump(dstr);
4687     }
4688     return dstr;
4689 }
4690 #endif
4691
4692 /*
4693 =for apidoc sv_setpvn
4694
4695 Copies a string (possibly containing embedded C<NUL> characters) into an SV.
4696 The C<len> parameter indicates the number of
4697 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
4698 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4699
4700 =cut
4701 */
4702
4703 void
4704 Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4705 {
4706     char *dptr;
4707
4708     PERL_ARGS_ASSERT_SV_SETPVN;
4709
4710     SV_CHECK_THINKFIRST_COW_DROP(sv);
4711     if (!ptr) {
4712         (void)SvOK_off(sv);
4713         return;
4714     }
4715     else {
4716         /* len is STRLEN which is unsigned, need to copy to signed */
4717         const IV iv = len;
4718         if (iv < 0)
4719             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %"
4720                        IVdf, iv);
4721     }
4722     SvUPGRADE(sv, SVt_PV);
4723
4724     dptr = SvGROW(sv, len + 1);
4725     Move(ptr,dptr,len,char);
4726     dptr[len] = '\0';
4727     SvCUR_set(sv, len);
4728     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4729     SvTAINT(sv);
4730     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4731 }
4732
4733 /*
4734 =for apidoc sv_setpvn_mg
4735
4736 Like C<sv_setpvn>, but also handles 'set' magic.
4737
4738 =cut
4739 */
4740
4741 void
4742 Perl_sv_setpvn_mg(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
4743 {
4744     PERL_ARGS_ASSERT_SV_SETPVN_MG;
4745
4746     sv_setpvn(sv,ptr,len);
4747     SvSETMAGIC(sv);
4748 }
4749
4750 /*
4751 =for apidoc sv_setpv
4752
4753 Copies a string into an SV.  The string must be terminated with a C<NUL>
4754 character.
4755 Does not handle 'set' magic.  See C<sv_setpv_mg>.
4756
4757 =cut
4758 */
4759
4760 void
4761 Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
4762 {
4763     STRLEN len;
4764
4765     PERL_ARGS_ASSERT_SV_SETPV;
4766
4767     SV_CHECK_THINKFIRST_COW_DROP(sv);
4768     if (!ptr) {
4769         (void)SvOK_off(sv);
4770         return;
4771     }
4772     len = strlen(ptr);
4773     SvUPGRADE(sv, SVt_PV);
4774
4775     SvGROW(sv, len + 1);
4776     Move(ptr,SvPVX(sv),len+1,char);
4777     SvCUR_set(sv, len);
4778     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4779     SvTAINT(sv);
4780     if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
4781 }
4782
4783 /*
4784 =for apidoc sv_setpv_mg
4785
4786 Like C<sv_setpv>, but also handles 'set' magic.
4787
4788 =cut
4789 */
4790
4791 void
4792 Perl_sv_setpv_mg(pTHX_ SV *const sv, const char *const ptr)
4793 {
4794     PERL_ARGS_ASSERT_SV_SETPV_MG;
4795
4796     sv_setpv(sv,ptr);
4797     SvSETMAGIC(sv);
4798 }
4799
4800 void
4801 Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
4802 {
4803     PERL_ARGS_ASSERT_SV_SETHEK;
4804
4805     if (!hek) {
4806         return;
4807     }
4808
4809     if (HEK_LEN(hek) == HEf_SVKEY) {
4810         sv_setsv(sv, *(SV**)HEK_KEY(hek));
4811         return;
4812     } else {
4813         const int flags = HEK_FLAGS(hek);
4814         if (flags & HVhek_WASUTF8) {
4815             STRLEN utf8_len = HEK_LEN(hek);
4816             char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len);
4817             sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL);
4818             SvUTF8_on(sv);
4819             return;
4820         } else if (flags & HVhek_UNSHARED) {
4821             sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek));
4822             if (HEK_UTF8(hek))
4823                 SvUTF8_on(sv);
4824             else SvUTF8_off(sv);
4825             return;
4826         }
4827         {
4828             SV_CHECK_THINKFIRST_COW_DROP(sv);
4829             SvUPGRADE(sv, SVt_PV);
4830             SvPV_free(sv);
4831             SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek)));
4832             SvCUR_set(sv, HEK_LEN(hek));
4833             SvLEN_set(sv, 0);
4834             SvIsCOW_on(sv);
4835             SvPOK_on(sv);
4836             if (HEK_UTF8(hek))
4837                 SvUTF8_on(sv);
4838             else SvUTF8_off(sv);
4839             return;
4840         }
4841     }
4842 }
4843
4844
4845 /*
4846 =for apidoc sv_usepvn_flags
4847
4848 Tells an SV to use C<ptr> to find its string value.  Normally the
4849 string is stored inside the SV, but sv_usepvn allows the SV to use an
4850 outside string.  The C<ptr> should point to memory that was allocated
4851 by L<Newx|perlclib/Memory Management and String Handling>. It must be
4852 the start of a Newx-ed block of memory, and not a pointer to the
4853 middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
4854 and not be from a non-Newx memory allocator like C<malloc>. The
4855 string length, C<len>, must be supplied.  By default this function
4856 will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
4857 so that pointer should not be freed or used by the programmer after
4858 giving it to sv_usepvn, and neither should any pointers from "behind"
4859 that pointer (e.g. ptr + 1) be used.
4860
4861 If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC.  If C<flags> &
4862 SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
4863 will be skipped (i.e. the buffer is actually at least 1 byte longer than
4864 C<len>, and already meets the requirements for storing in C<SvPVX>).
4865
4866 =cut
4867 */
4868
4869 void
4870 Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
4871 {
4872     STRLEN allocate;
4873
4874     PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
4875
4876     SV_CHECK_THINKFIRST_COW_DROP(sv);
4877     SvUPGRADE(sv, SVt_PV);
4878     if (!ptr) {
4879         (void)SvOK_off(sv);
4880         if (flags & SV_SMAGIC)
4881             SvSETMAGIC(sv);
4882         return;
4883     }
4884     if (SvPVX_const(sv))
4885         SvPV_free(sv);
4886
4887 #ifdef DEBUGGING
4888     if (flags & SV_HAS_TRAILING_NUL)
4889         assert(ptr[len] == '\0');
4890 #endif
4891
4892     allocate = (flags & SV_HAS_TRAILING_NUL)
4893         ? len + 1 :
4894 #ifdef Perl_safesysmalloc_size
4895         len + 1;
4896 #else 
4897         PERL_STRLEN_ROUNDUP(len + 1);
4898 #endif
4899     if (flags & SV_HAS_TRAILING_NUL) {
4900         /* It's long enough - do nothing.
4901            Specifically Perl_newCONSTSUB is relying on this.  */
4902     } else {
4903 #ifdef DEBUGGING
4904         /* Force a move to shake out bugs in callers.  */
4905         char *new_ptr = (char*)safemalloc(allocate);
4906         Copy(ptr, new_ptr, len, char);
4907         PoisonFree(ptr,len,char);
4908         Safefree(ptr);
4909         ptr = new_ptr;
4910 #else
4911         ptr = (char*) saferealloc (ptr, allocate);
4912 #endif
4913     }
4914 #ifdef Perl_safesysmalloc_size
4915     SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
4916 #else
4917     SvLEN_set(sv, allocate);
4918 #endif
4919     SvCUR_set(sv, len);
4920     SvPV_set(sv, ptr);
4921     if (!(flags & SV_HAS_TRAILING_NUL)) {
4922         ptr[len] = '\0';
4923     }
4924     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4925     SvTAINT(sv);
4926     if (flags & SV_SMAGIC)
4927         SvSETMAGIC(sv);
4928 }
4929
4930 #ifdef PERL_OLD_COPY_ON_WRITE
4931 /* Need to do this *after* making the SV normal, as we need the buffer
4932    pointer to remain valid until after we've copied it.  If we let go too early,
4933    another thread could invalidate it by unsharing last of the same hash key
4934    (which it can do by means other than releasing copy-on-write Svs)
4935    or by changing the other copy-on-write SVs in the loop.  */
4936 STATIC void
4937 S_sv_release_COW(pTHX_ SV *sv, const char *pvx, SV *after)
4938 {
4939     PERL_ARGS_ASSERT_SV_RELEASE_COW;
4940
4941     { /* this SV was SvIsCOW_normal(sv) */
4942          /* we need to find the SV pointing to us.  */
4943         SV *current = SV_COW_NEXT_SV(after);
4944
4945         if (current == sv) {
4946             /* The SV we point to points back to us (there were only two of us
4947                in the loop.)
4948                Hence other SV is no longer copy on write either.  */
4949             SvIsCOW_off(after);
4950             sv_buf_to_rw(after);
4951         } else {
4952             /* We need to follow the pointers around the loop.  */
4953             SV *next;
4954             while ((next = SV_COW_NEXT_SV(current)) != sv) {
4955                 assert (next);
4956                 current = next;
4957                  /* don't loop forever if the structure is bust, and we have
4958                     a pointer into a closed loop.  */
4959                 assert (current != after);
4960                 assert (SvPVX_const(current) == pvx);
4961             }
4962             /* Make the SV before us point to the SV after us.  */
4963             SV_COW_NEXT_SV_SET(current, after);
4964         }
4965     }
4966 }
4967 #endif
4968 /*
4969 =for apidoc sv_force_normal_flags
4970
4971 Undo various types of fakery on an SV, where fakery means
4972 "more than" a string: if the PV is a shared string, make
4973 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4974 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4975 we do the copy, and is also used locally; if this is a
4976 vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
4977 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4978 SvPOK_off rather than making a copy.  (Used where this
4979 scalar is about to be set to some other value.)  In addition,
4980 the C<flags> parameter gets passed to C<sv_unref_flags()>
4981 when unreffing.  C<sv_force_normal> calls this function
4982 with flags set to 0.
4983
4984 This function is expected to be used to signal to perl that this SV is
4985 about to be written to, and any extra book-keeping needs to be taken care
4986 of.  Hence, it croaks on read-only values.
4987
4988 =cut
4989 */
4990
4991 static void
4992 S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
4993 {
4994     assert(SvIsCOW(sv));
4995     {
4996 #ifdef PERL_ANY_COW
4997         const char * const pvx = SvPVX_const(sv);
4998         const STRLEN len = SvLEN(sv);
4999         const STRLEN cur = SvCUR(sv);
5000 # ifdef PERL_OLD_COPY_ON_WRITE
5001         /* next COW sv in the loop.  If len is 0 then this is a shared-hash
5002            key scalar, so we mustn't attempt to call SV_COW_NEXT_SV(), as
5003            we'll fail an assertion.  */
5004         SV * const next = len ? SV_COW_NEXT_SV(sv) : 0;
5005 # endif
5006
5007         if (DEBUG_C_TEST) {
5008                 PerlIO_printf(Perl_debug_log,
5009                               "Copy on write: Force normal %ld\n",
5010                               (long) flags);
5011                 sv_dump(sv);
5012         }
5013         SvIsCOW_off(sv);
5014 # ifdef PERL_NEW_COPY_ON_WRITE
5015         if (len && CowREFCNT(sv) == 0)
5016             /* We own the buffer ourselves. */
5017             sv_buf_to_rw(sv);
5018         else
5019 # endif
5020         {
5021                 
5022             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
5023 # ifdef PERL_NEW_COPY_ON_WRITE
5024             /* Must do this first, since the macro uses SvPVX. */
5025             if (len) {
5026                 sv_buf_to_rw(sv);
5027                 CowREFCNT(sv)--;
5028                 sv_buf_to_ro(sv);
5029             }
5030 # endif
5031             SvPV_set(sv, NULL);
5032             SvCUR_set(sv, 0);
5033             SvLEN_set(sv, 0);
5034             if (flags & SV_COW_DROP_PV) {
5035                 /* OK, so we don't need to copy our buffer.  */
5036                 SvPOK_off(sv);
5037             } else {
5038                 SvGROW(sv, cur + 1);
5039                 Move(pvx,SvPVX(sv),cur,char);
5040                 SvCUR_set(sv, cur);
5041                 *SvEND(sv) = '\0';
5042             }
5043             if (len) {
5044 # ifdef PERL_OLD_COPY_ON_WRITE
5045                 sv_release_COW(sv, pvx, next);
5046 # endif
5047             } else {
5048                 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5049             }
5050             if (DEBUG_C_TEST) {
5051                 sv_dump(sv);
5052             }
5053         }
5054 #else
5055             const char * const pvx = SvPVX_const(sv);
5056             const STRLEN len = SvCUR(sv);
5057             SvIsCOW_off(sv);
5058             SvPV_set(sv, NULL);
5059             SvLEN_set(sv, 0);
5060             if (flags & SV_COW_DROP_PV) {
5061                 /* OK, so we don't need to copy our buffer.  */
5062                 SvPOK_off(sv);
5063             } else {
5064                 SvGROW(sv, len + 1);
5065                 Move(pvx,SvPVX(sv),len,char);
5066                 *SvEND(sv) = '\0';
5067             }
5068             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
5069 #endif
5070     }
5071 }
5072
5073 void
5074 Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags)
5075 {
5076     PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS;
5077
5078     if (SvREADONLY(sv))
5079         Perl_croak_no_modify();
5080     else if (SvIsCOW(sv))
5081         S_sv_uncow(aTHX_ sv, flags);
5082     if (SvROK(sv))
5083         sv_unref_flags(sv, flags);
5084     else if (SvFAKE(sv) && isGV_with_GP(sv))
5085         sv_unglob(sv, flags);
5086     else if (SvFAKE(sv) && isREGEXP(sv)) {
5087         /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous
5088            to sv_unglob. We only need it here, so inline it.  */
5089         const bool islv = SvTYPE(sv) == SVt_PVLV;
5090         const svtype new_type =
5091           islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV;
5092         SV *const temp = newSV_type(new_type);
5093         regexp *const temp_p = ReANY((REGEXP *)sv);
5094
5095         if (new_type == SVt_PVMG) {
5096             SvMAGIC_set(temp, SvMAGIC(sv));
5097             SvMAGIC_set(sv, NULL);
5098             SvSTASH_set(temp, SvSTASH(sv));
5099             SvSTASH_set(sv, NULL);
5100         }
5101         if (!islv) SvCUR_set(temp, SvCUR(sv));
5102         /* Remember that SvPVX is in the head, not the body.  But
5103            RX_WRAPPED is in the body. */
5104         assert(ReANY((REGEXP *)sv)->mother_re);
5105         /* Their buffer is already owned by someone else. */
5106         if (flags & SV_COW_DROP_PV) {
5107             /* SvLEN is already 0.  For SVt_REGEXP, we have a brand new
5108                zeroed body.  For SVt_PVLV, it should have been set to 0
5109                before turning into a regexp. */
5110             assert(!SvLEN(islv ? sv : temp));
5111             sv->sv_u.svu_pv = 0;
5112         }
5113         else {
5114             sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv));
5115             SvLEN_set(islv ? sv : temp, SvCUR(sv)+1);
5116             SvPOK_on(sv);
5117         }
5118
5119         /* Now swap the rest of the bodies. */
5120
5121         SvFAKE_off(sv);
5122         if (!islv) {
5123             SvFLAGS(sv) &= ~SVTYPEMASK;
5124             SvFLAGS(sv) |= new_type;
5125             SvANY(sv) = SvANY(temp);
5126         }
5127
5128         SvFLAGS(temp) &= ~(SVTYPEMASK);
5129         SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE;
5130         SvANY(temp) = temp_p;
5131         temp->sv_u.svu_rx = (regexp *)temp_p;
5132
5133         SvREFCNT_dec_NN(temp);
5134     }
5135     else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
5136 }
5137
5138 /*
5139 =for apidoc sv_chop
5140
5141 Efficient removal of characters from the beginning of the string buffer.
5142 SvPOK(sv), or at least SvPOKp(sv), must be true and the C<ptr> must be a
5143 pointer to somewhere inside the string buffer.  The C<ptr> becomes the first
5144 character of the adjusted string.  Uses the "OOK hack".  On return, only
5145 SvPOK(sv) and SvPOKp(sv) among the OK flags will be true.
5146
5147 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
5148 refer to the same chunk of data.
5149
5150 The unfortunate similarity of this function's name to that of Perl's C<chop>
5151 operator is strictly coincidental.  This function works from the left;
5152 C<chop> works from the right.
5153
5154 =cut
5155 */
5156
5157 void
5158 Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr)
5159 {
5160     STRLEN delta;
5161     STRLEN old_delta;
5162     U8 *p;
5163 #ifdef DEBUGGING
5164     const U8 *evacp;
5165     STRLEN evacn;
5166 #endif
5167     STRLEN max_delta;
5168
5169     PERL_ARGS_ASSERT_SV_CHOP;
5170
5171     if (!ptr || !SvPOKp(sv))
5172         return;
5173     delta = ptr - SvPVX_const(sv);
5174     if (!delta) {
5175         /* Nothing to do.  */
5176         return;
5177     }
5178     max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv);
5179     if (delta > max_delta)
5180         Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p",
5181                    ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta);
5182     /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */
5183     SV_CHECK_THINKFIRST(sv);
5184     SvPOK_only_UTF8(sv);
5185
5186     if (!SvOOK(sv)) {
5187         if (!SvLEN(sv)) { /* make copy of shared string */
5188             const char *pvx = SvPVX_const(sv);
5189             const STRLEN len = SvCUR(sv);
5190             SvGROW(sv, len + 1);
5191             Move(pvx,SvPVX(sv),len,char);
5192             *SvEND(sv) = '\0';
5193         }
5194         SvOOK_on(sv);
5195         old_delta = 0;
5196     } else {
5197         SvOOK_offset(sv, old_delta);
5198     }
5199     SvLEN_set(sv, SvLEN(sv) - delta);
5200     SvCUR_set(sv, SvCUR(sv) - delta);
5201     SvPV_set(sv, SvPVX(sv) + delta);
5202
5203     p = (U8 *)SvPVX_const(sv);
5204
5205 #ifdef DEBUGGING
5206     /* how many bytes were evacuated?  we will fill them with sentinel
5207        bytes, except for the part holding the new offset of course. */
5208     evacn = delta;
5209     if (old_delta)
5210         evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN));
5211     assert(evacn);
5212     assert(evacn <= delta + old_delta);
5213     evacp = p - evacn;
5214 #endif
5215
5216     /* This sets 'delta' to the accumulated value of all deltas so far */
5217     delta += old_delta;
5218     assert(delta);
5219
5220     /* If 'delta' fits in a byte, store it just prior to the new beginning of
5221      * the string; otherwise store a 0 byte there and store 'delta' just prior
5222      * to that, using as many bytes as a STRLEN occupies.  Thus it overwrites a
5223      * portion of the chopped part of the string */
5224     if (delta < 0x100) {
5225         *--p = (U8) delta;
5226     } else {
5227         *--p = 0;
5228         p -= sizeof(STRLEN);
5229         Copy((U8*)&delta, p, sizeof(STRLEN), U8);
5230     }
5231
5232 #ifdef DEBUGGING
5233     /* Fill the preceding buffer with sentinals to verify that no-one is
5234        using it.  */
5235     while (p > evacp) {
5236         --p;
5237         *p = (U8)PTR2UV(p);
5238     }
5239 #endif
5240 }
5241
5242 /*
5243 =for apidoc sv_catpvn
5244
5245 Concatenates the string onto the end of the string which is in the SV.  The
5246 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5247 status set, then the bytes appended should be valid UTF-8.
5248 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
5249
5250 =for apidoc sv_catpvn_flags
5251
5252 Concatenates the string onto the end of the string which is in the SV.  The
5253 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
5254 status set, then the bytes appended should be valid UTF-8.
5255 If C<flags> has the C<SV_SMAGIC> bit set, will
5256 C<mg_set> on C<dsv> afterwards if appropriate.
5257 C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
5258 in terms of this function.
5259
5260 =cut
5261 */
5262
5263 void
5264 Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
5265 {
5266     STRLEN dlen;
5267     const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
5268
5269     PERL_ARGS_ASSERT_SV_CATPVN_FLAGS;
5270     assert((flags & (SV_CATBYTES|SV_CATUTF8)) != (SV_CATBYTES|SV_CATUTF8));
5271
5272     if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) {
5273       if (flags & SV_CATUTF8 && !SvUTF8(dsv)) {
5274          sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
5275          dlen = SvCUR(dsv);
5276       }
5277       else SvGROW(dsv, dlen + slen + 1);
5278       if (sstr == dstr)
5279         sstr = SvPVX_const(dsv);
5280       Move(sstr, SvPVX(dsv) + dlen, slen, char);
5281       SvCUR_set(dsv, SvCUR(dsv) + slen);
5282     }
5283     else {
5284         /* We inline bytes_to_utf8, to avoid an extra malloc. */
5285         const char * const send = sstr + slen;
5286         U8 *d;
5287
5288         /* Something this code does not account for, which I think is
5289            impossible; it would require the same pv to be treated as
5290            bytes *and* utf8, which would indicate a bug elsewhere. */
5291         assert(sstr != dstr);
5292
5293         SvGROW(dsv, dlen + slen * 2 + 1);
5294         d = (U8 *)SvPVX(dsv) + dlen;
5295
5296         while (sstr < send) {
5297             append_utf8_from_native_byte(*sstr, &d);
5298             sstr++;
5299         }
5300         SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
5301     }
5302     *SvEND(dsv) = '\0';
5303     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
5304     SvTAINT(dsv);
5305     if (flags & SV_SMAGIC)
5306         SvSETMAGIC(dsv);
5307 }
5308
5309 /*
5310 =for apidoc sv_catsv
5311
5312 Concatenates the string from SV C<ssv> onto the end of the string in SV
5313 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5314 Handles 'get' magic on both SVs, but no 'set' magic.  See C<sv_catsv_mg> and
5315 C<sv_catsv_nomg>.
5316
5317 =for apidoc sv_catsv_flags
5318
5319 Concatenates the string from SV C<ssv> onto the end of the string in SV
5320 C<dsv>.  If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
5321 If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
5322 appropriate.  If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
5323 the modified SV afterward, if appropriate.  C<sv_catsv>, C<sv_catsv_nomg>,
5324 and C<sv_catsv_mg> are implemented in terms of this function.
5325
5326 =cut */
5327
5328 void
5329 Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
5330 {
5331     PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
5332
5333     if (ssv) {
5334         STRLEN slen;
5335         const char *spv = SvPV_flags_const(ssv, slen, flags);
5336         if (spv) {
5337             if (flags & SV_GMAGIC)
5338                 SvGETMAGIC(dsv);
5339             sv_catpvn_flags(dsv, spv, slen,
5340                             DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
5341             if (flags & SV_SMAGIC)
5342                 SvSETMAGIC(dsv);
5343         }
5344     }
5345 }
5346
5347 /*
5348 =for apidoc sv_catpv
5349
5350 Concatenates the C<NUL>-terminated string onto the end of the string which is
5351 in the SV.
5352 If the SV has the UTF-8 status set, then the bytes appended should be
5353 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
5354
5355 =cut */
5356
5357 void
5358 Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
5359 {
5360     STRLEN len;
5361     STRLEN tlen;
5362     char *junk;
5363
5364     PERL_ARGS_ASSERT_SV_CATPV;
5365
5366     if (!ptr)
5367         return;
5368     junk = SvPV_force(sv, tlen);
5369     len = strlen(ptr);
5370     SvGROW(sv, tlen + len + 1);
5371     if (ptr == junk)
5372         ptr = SvPVX_const(sv);
5373     Move(ptr,SvPVX(sv)+tlen,len+1,char);
5374     SvCUR_set(sv, SvCUR(sv) + len);
5375     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
5376     SvTAINT(sv);
5377 }
5378
5379 /*
5380 =for apidoc sv_catpv_flags
5381
5382 Concatenates the C<NUL>-terminated string onto the end of the string which is
5383 in the SV.
5384 If the SV has the UTF-8 status set, then the bytes appended should
5385 be valid UTF-8.  If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
5386 on the modified SV if appropriate.
5387
5388 =cut
5389 */
5390
5391 void
5392 Perl_sv_catpv_flags(pTHX_ SV *dstr, const char *sstr, const I32 flags)
5393 {
5394     PERL_ARGS_ASSERT_SV_CATPV_FLAGS;
5395     sv_catpvn_flags(dstr, sstr, strlen(sstr), flags);
5396 }
5397
5398 /*
5399 =for apidoc sv_catpv_mg
5400
5401 Like C<sv_catpv>, but also handles 'set' magic.
5402
5403 =cut
5404 */
5405
5406 void
5407 Perl_sv_catpv_mg(pTHX_ SV *const sv, const char *const ptr)
5408 {
5409     PERL_ARGS_ASSERT_SV_CATPV_MG;
5410
5411     sv_catpv(sv,ptr);
5412     SvSETMAGIC(sv);
5413 }
5414
5415 /*
5416 =for apidoc newSV
5417
5418 Creates a new SV.  A non-zero C<len> parameter indicates the number of
5419 bytes of preallocated string space the SV should have.  An extra byte for a
5420 trailing C<NUL> is also reserved.  (SvPOK is not set for the SV even if string
5421 space is allocated.)  The reference count for the new SV is set to 1.
5422
5423 In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
5424 parameter, I<x>, a debug aid which allowed callers to identify themselves.
5425 This aid has been superseded by a new build option, PERL_MEM_LOG (see
5426 L<perlhacktips/PERL_MEM_LOG>).  The older API is still there for use in XS
5427 modules supporting older perls.
5428
5429 =cut
5430 */
5431
5432 SV *
5433 Perl_newSV(pTHX_ const STRLEN len)
5434 {
5435     SV *sv;
5436
5437     new_SV(sv);
5438     if (len) {
5439         sv_upgrade(sv, SVt_PV);
5440         SvGROW(sv, len + 1);
5441     }
5442     return sv;
5443 }
5444 /*
5445 =for apidoc sv_magicext
5446
5447 Adds magic to an SV, upgrading it if necessary.  Applies the
5448 supplied vtable and returns a pointer to the magic added.
5449
5450 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
5451 In particular, you can add magic to SvREADONLY SVs, and add more than
5452 one instance of the same 'how'.
5453
5454 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
5455 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
5456 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
5457 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
5458
5459 (This is now used as a subroutine by C<sv_magic>.)
5460
5461 =cut
5462 */
5463 MAGIC * 
5464 Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, 
5465                 const MGVTBL *const vtable, const char *const name, const I32 namlen)
5466 {
5467     MAGIC* mg;
5468
5469     PERL_ARGS_ASSERT_SV_MAGICEXT;
5470
5471     if (SvTYPE(sv)==SVt_PVAV) { assert (!AvPAD_NAMELIST(sv)); }
5472
5473     SvUPGRADE(sv, SVt_PVMG);
5474     Newxz(mg, 1, MAGIC);
5475     mg->mg_moremagic = SvMAGIC(sv);
5476     SvMAGIC_set(sv, mg);
5477
5478     /* Sometimes a magic contains a reference loop, where the sv and
5479        object refer to each other.  To prevent a reference loop that
5480        would prevent such objects being freed, we look for such loops
5481        and if we find one we avoid incrementing the object refcount.
5482
5483        Note we cannot do this to avoid self-tie loops as intervening RV must
5484        have its REFCNT incremented to keep it in existence.
5485
5486     */
5487     if (!obj || obj == sv ||
5488         how == PERL_MAGIC_arylen ||
5489         how == PERL_MAGIC_symtab ||
5490         (SvTYPE(obj) == SVt_PVGV &&
5491             (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
5492              || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
5493              || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv)))
5494     {
5495         mg->mg_obj = obj;
5496     }
5497     else {
5498         mg->mg_obj = SvREFCNT_inc_simple(obj);
5499         mg->mg_flags |= MGf_REFCOUNTED;
5500     }
5501
5502     /* Normal self-ties simply pass a null object, and instead of
5503        using mg_obj directly, use the SvTIED_obj macro to produce a
5504        new RV as needed.  For glob "self-ties", we are tieing the PVIO
5505        with an RV obj pointing to the glob containing the PVIO.  In
5506        this case, to avoid a reference loop, we need to weaken the
5507        reference.
5508     */
5509
5510     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
5511         obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv)
5512     {
5513       sv_rvweaken(obj);
5514     }
5515
5516     mg->mg_type = how;
5517     mg->mg_len = namlen;
5518     if (name) {
5519         if (namlen > 0)
5520             mg->mg_ptr = savepvn(name, namlen);
5521         else if (namlen == HEf_SVKEY) {
5522             /* Yes, this is casting away const. This is only for the case of
5523                HEf_SVKEY. I think we need to document this aberation of the
5524                constness of the API, rather than making name non-const, as
5525                that change propagating outwards a long way.  */
5526             mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name);
5527         } else
5528             mg->mg_ptr = (char *) name;
5529     }
5530     mg->mg_virtual = (MGVTBL *) vtable;
5531
5532     mg_magical(sv);
5533     return mg;
5534 }
5535
5536 MAGIC *
5537 Perl_sv_magicext_mglob(pTHX_ SV *sv)
5538 {
5539     PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB;
5540     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
5541         /* This sv is only a delegate.  //g magic must be attached to
5542            its target. */
5543         vivify_defelem(sv);
5544         sv = LvTARG(sv);
5545     }
5546 #ifdef PERL_OLD_COPY_ON_WRITE
5547     if (SvIsCOW(sv))
5548         sv_force_normal_flags(sv, 0);
5549 #endif
5550     return sv_magicext(sv, NULL, PERL_MAGIC_regex_global,
5551                        &PL_vtbl_mglob, 0, 0);
5552 }
5553
5554 /*
5555 =for apidoc sv_magic
5556
5557 Adds magic to an SV.  First upgrades C<sv> to type C<SVt_PVMG> if
5558 necessary, then adds a new magic item of type C<how> to the head of the
5559 magic list.
5560
5561 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
5562 handling of the C<name> and C<namlen> arguments.
5563
5564 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
5565 to add more than one instance of the same 'how'.
5566
5567 =cut
5568 */
5569
5570 void
5571 Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
5572              const char *const name, const I32 namlen)
5573 {
5574     const MGVTBL *vtable;
5575     MAGIC* mg;
5576     unsigned int flags;
5577     unsigned int vtable_index;
5578
5579     PERL_ARGS_ASSERT_SV_MAGIC;
5580
5581     if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
5582         || ((flags = PL_magic_data[how]),
5583             (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
5584             > magic_vtable_max))
5585         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5586
5587     /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
5588        Useful for attaching extension internal data to perl vars.
5589        Note that multiple extensions may clash if magical scalars
5590        etc holding private data from one are passed to another. */
5591
5592     vtable = (vtable_index == magic_vtable_max)
5593         ? NULL : PL_magic_vtables + vtable_index;
5594
5595 #ifdef PERL_OLD_COPY_ON_WRITE
5596     if (SvIsCOW(sv))
5597         sv_force_normal_flags(sv, 0);
5598 #endif
5599     if (SvREADONLY(sv)) {
5600         if (
5601             !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
5602            )
5603         {
5604             Perl_croak_no_modify();
5605         }
5606     }
5607     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
5608         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
5609             /* sv_magic() refuses to add a magic of the same 'how' as an
5610                existing one
5611              */
5612             if (how == PERL_MAGIC_taint)
5613                 mg->mg_len |= 1;
5614             return;
5615         }
5616     }
5617
5618     /* Force pos to be stored as characters, not bytes. */
5619     if (SvMAGICAL(sv) && DO_UTF8(sv)
5620       && (mg = mg_find(sv, PERL_MAGIC_regex_global))
5621       && mg->mg_len != -1
5622       && mg->mg_flags & MGf_BYTES) {
5623         mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
5624                                                SV_CONST_RETURN);
5625         mg->mg_flags &= ~MGf_BYTES;
5626     }
5627
5628     /* Rest of work is done else where */
5629     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5630
5631     switch (how) {
5632     case PERL_MAGIC_taint:
5633         mg->mg_len = 1;
5634         break;
5635     case PERL_MAGIC_ext:
5636     case PERL_MAGIC_dbfile:
5637         SvRMAGICAL_on(sv);
5638         break;
5639     }
5640 }
5641
5642 static int
5643 S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U32 flags)
5644 {
5645     MAGIC* mg;
5646     MAGIC** mgp;
5647
5648     assert(flags <= 1);
5649
5650     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5651         return 0;
5652     mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic);
5653     for (mg = *mgp; mg; mg = *mgp) {
5654         const MGVTBL* const virt = mg->mg_virtual;
5655         if (mg->mg_type == type && (!flags || virt == vtbl)) {
5656             *mgp = mg->mg_moremagic;
5657             if (virt && virt->svt_free)
5658                 virt->svt_free(aTHX_ sv, mg);
5659             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5660                 if (mg->mg_len > 0)
5661                     Safefree(mg->mg_ptr);
5662                 else if (mg->mg_len == HEf_SVKEY)
5663                     SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
5664                 else if (mg->mg_type == PERL_MAGIC_utf8)
5665                     Safefree(mg->mg_ptr);
5666             }
5667             if (mg->mg_flags & MGf_REFCOUNTED)
5668                 SvREFCNT_dec(mg->mg_obj);
5669             Safefree(mg);
5670         }
5671         else
5672             mgp = &mg->mg_moremagic;
5673     }
5674     if (SvMAGIC(sv)) {
5675         if (SvMAGICAL(sv))      /* if we're under save_magic, wait for restore_magic; */
5676             mg_magical(sv);     /*    else fix the flags now */
5677     }
5678     else {
5679         SvMAGICAL_off(sv);
5680         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5681     }
5682     return 0;
5683 }
5684
5685 /*
5686 =for apidoc sv_unmagic
5687
5688 Removes all magic of type C<type> from an SV.
5689
5690 =cut
5691 */
5692
5693 int
5694 Perl_sv_unmagic(pTHX_ SV *const sv, const int type)
5695 {
5696     PERL_ARGS_ASSERT_SV_UNMAGIC;
5697     return S_sv_unmagicext_flags(aTHX_ sv, type, NULL, 0);
5698 }
5699
5700 /*
5701 =for apidoc sv_unmagicext
5702
5703 Removes all magic of type C<type> with the specified C<vtbl> from an SV.
5704
5705 =cut
5706 */
5707
5708 int
5709 Perl_sv_unmagicext(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
5710 {
5711     PERL_ARGS_ASSERT_SV_UNMAGICEXT;
5712     return S_sv_unmagicext_flags(aTHX_ sv, type, vtbl, 1);
5713 }
5714
5715 /*
5716 =for apidoc sv_rvweaken
5717
5718 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5719 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5720 push a back-reference to this RV onto the array of backreferences
5721 associated with that magic.  If the RV is magical, set magic will be
5722 called after the RV is cleared.
5723
5724 =cut
5725 */
5726
5727 SV *
5728 Perl_sv_rvweaken(pTHX_ SV *const sv)
5729 {
5730     SV *tsv;
5731
5732     PERL_ARGS_ASSERT_SV_RVWEAKEN;
5733
5734     if (!SvOK(sv))  /* let undefs pass */
5735         return sv;
5736     if (!SvROK(sv))
5737         Perl_croak(aTHX_ "Can't weaken a nonreference");
5738     else if (SvWEAKREF(sv)) {
5739         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5740         return sv;
5741     }
5742     else if (SvREADONLY(sv)) croak_no_modify();
5743     tsv = SvRV(sv);
5744     Perl_sv_add_backref(aTHX_ tsv, sv);
5745     SvWEAKREF_on(sv);
5746     SvREFCNT_dec_NN(tsv);
5747     return sv;
5748 }
5749
5750 /* Give tsv backref magic if it hasn't already got it, then push a
5751  * back-reference to sv onto the array associated with the backref magic.
5752  *
5753  * As an optimisation, if there's only one backref and it's not an AV,
5754  * store it directly in the HvAUX or mg_obj slot, avoiding the need to
5755  * allocate an AV. (Whether the slot holds an AV tells us whether this is
5756  * active.)
5757  */
5758
5759 /* A discussion about the backreferences array and its refcount:
5760  *
5761  * The AV holding the backreferences is pointed to either as the mg_obj of
5762  * PERL_MAGIC_backref, or in the specific case of a HV, from the
5763  * xhv_backreferences field. The array is created with a refcount
5764  * of 2. This means that if during global destruction the array gets
5765  * picked on before its parent to have its refcount decremented by the
5766  * random zapper, it won't actually be freed, meaning it's still there for
5767  * when its parent gets freed.
5768  *
5769  * When the parent SV is freed, the extra ref is killed by
5770  * Perl_sv_kill_backrefs.  The other ref is killed, in the case of magic,
5771  * by mg_free() / MGf_REFCOUNTED, or for a hash, by Perl_hv_kill_backrefs.
5772  *
5773  * When a single backref SV is stored directly, it is not reference
5774  * counted.
5775  */
5776
5777 void
5778 Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
5779 {
5780     SV **svp;
5781     AV *av = NULL;
5782     MAGIC *mg = NULL;
5783
5784     PERL_ARGS_ASSERT_SV_ADD_BACKREF;
5785
5786     /* find slot to store array or singleton backref */
5787
5788     if (SvTYPE(tsv) == SVt_PVHV) {
5789         svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5790     } else {
5791         if (SvMAGICAL(tsv))
5792             mg = mg_find(tsv, PERL_MAGIC_backref);
5793         if (!mg)
5794             mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
5795         svp = &(mg->mg_obj);
5796     }
5797
5798     /* create or retrieve the array */
5799
5800     if (   (!*svp && SvTYPE(sv) == SVt_PVAV)
5801         || (*svp && SvTYPE(*svp) != SVt_PVAV)
5802     ) {
5803         /* create array */
5804         if (mg)
5805             mg->mg_flags |= MGf_REFCOUNTED;
5806         av = newAV();
5807         AvREAL_off(av);
5808         SvREFCNT_inc_simple_void_NN(av);
5809         /* av now has a refcnt of 2; see discussion above */
5810         av_extend(av, *svp ? 2 : 1);
5811         if (*svp) {
5812             /* move single existing backref to the array */
5813             AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
5814         }
5815         *svp = (SV*)av;
5816     }
5817     else {
5818         av = MUTABLE_AV(*svp);
5819         if (!av) {
5820             /* optimisation: store single backref directly in HvAUX or mg_obj */
5821             *svp = sv;
5822             return;
5823         }
5824         assert(SvTYPE(av) == SVt_PVAV);
5825         if (AvFILLp(av) >= AvMAX(av)) {
5826             av_extend(av, AvFILLp(av)+1);
5827         }
5828     }
5829     /* push new backref */
5830     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5831 }
5832
5833 /* delete a back-reference to ourselves from the backref magic associated
5834  * with the SV we point to.
5835  */
5836
5837 void
5838 Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
5839 {
5840     SV **svp = NULL;
5841
5842     PERL_ARGS_ASSERT_SV_DEL_BACKREF;
5843
5844     if (SvTYPE(tsv) == SVt_PVHV) {
5845         if (SvOOK(tsv))
5846             svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
5847     }
5848     else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) {
5849         /* It's possible for the the last (strong) reference to tsv to have
5850            become freed *before* the last thing holding a weak reference.
5851            If both survive longer than the backreferences array, then when
5852            the referent's reference count drops to 0 and it is freed, it's
5853            not able to chase the backreferences, so they aren't NULLed.
5854
5855            For example, a CV holds a weak reference to its stash. If both the
5856            CV and the stash survive longer than the backreferences array,
5857            and the CV gets picked for the SvBREAK() treatment first,
5858            *and* it turns out that the stash is only being kept alive because
5859            of an our variable in the pad of the CV, then midway during CV
5860            destruction the stash gets freed, but CvSTASH() isn't set to NULL.
5861            It ends up pointing to the freed HV. Hence it's chased in here, and
5862            if this block wasn't here, it would hit the !svp panic just below.
5863
5864            I don't believe that "better" destruction ordering is going to help
5865            here - during global destruction there's always going to be the
5866            chance that something goes out of order. We've tried to make it
5867            foolproof before, and it only resulted in evolutionary pressure on
5868            fools. Which made us look foolish for our hubris. :-(
5869         */
5870         return;
5871     }
5872     else {
5873         MAGIC *const mg
5874             = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL;
5875         svp =  mg ? &(mg->mg_obj) : NULL;
5876     }
5877
5878     if (!svp)
5879         Perl_croak(aTHX_ "panic: del_backref, svp=0");
5880     if (!*svp) {
5881         /* It's possible that sv is being freed recursively part way through the
5882            freeing of tsv. If this happens, the backreferences array of tsv has
5883            already been freed, and so svp will be NULL. If this is the case,
5884            we should not panic. Instead, nothing needs doing, so return.  */
5885         if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
5886             return;
5887         Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
5888                    (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
5889     }
5890
5891     if (SvTYPE(*svp) == SVt_PVAV) {
5892 #ifdef DEBUGGING
5893         int count = 1;
5894 #endif
5895         AV * const av = (AV*)*svp;
5896         SSize_t fill;
5897         assert(!SvIS_FREED(av));
5898         fill = AvFILLp(av);
5899         assert(fill > -1);
5900         svp = AvARRAY(av);
5901         /* for an SV with N weak references to it, if all those
5902          * weak refs are deleted, then sv_del_backref will be called
5903          * N times and O(N^2) compares will be done within the backref
5904          * array. To ameliorate this potential slowness, we:
5905          * 1) make sure this code is as tight as possible;
5906          * 2) when looking for SV, look for it at both the head and tail of the
5907          *    array first before searching the rest, since some create/destroy
5908          *    patterns will cause the backrefs to be freed in order.
5909          */
5910         if (*svp == sv) {
5911             AvARRAY(av)++;
5912             AvMAX(av)--;
5913         }
5914         else {
5915             SV **p = &svp[fill];
5916             SV *const topsv = *p;
5917             if (topsv != sv) {
5918 #ifdef DEBUGGING
5919                 count = 0;
5920 #endif
5921                 while (--p > svp) {
5922                     if (*p == sv) {
5923                         /* We weren't the last entry.
5924                            An unordered list has this property that you
5925                            can take the last element off the end to fill
5926                            the hole, and it's still an unordered list :-)
5927                         */
5928                         *p = topsv;
5929 #ifdef DEBUGGING
5930                         count++;
5931 #else
5932                         break; /* should only be one */
5933 #endif
5934                     }
5935                 }
5936             }
5937         }
5938         assert(count ==1);
5939         AvFILLp(av) = fill-1;
5940     }
5941     else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) {
5942         /* freed AV; skip */
5943     }
5944     else {
5945         /* optimisation: only a single backref, stored directly */
5946         if (*svp != sv)
5947             Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
5948                        (void*)*svp, (void*)sv);
5949         *svp = NULL;
5950     }
5951
5952 }
5953
5954 void
5955 Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av)
5956 {
5957     SV **svp;
5958     SV **last;
5959     bool is_array;
5960
5961     PERL_ARGS_ASSERT_SV_KILL_BACKREFS;
5962
5963     if (!av)
5964         return;
5965
5966     /* after multiple passes through Perl_sv_clean_all() for a thingy
5967      * that has badly leaked, the backref array may have gotten freed,
5968      * since we only protect it against 1 round of cleanup */
5969     if (SvIS_FREED(av)) {
5970         if (PL_in_clean_all) /* All is fair */
5971             return;
5972         Perl_croak(aTHX_
5973                    "panic: magic_killbackrefs (freed backref AV/SV)");
5974     }
5975
5976
5977     is_array = (SvTYPE(av) == SVt_PVAV);
5978     if (is_array) {
5979         assert(!SvIS_FREED(av));
5980         svp = AvARRAY(av);
5981         if (svp)
5982             last = svp + AvFILLp(av);
5983     }
5984     else {
5985         /* optimisation: only a single backref, stored directly */
5986         svp = (SV**)&av;
5987         last = svp;
5988     }
5989
5990     if (svp) {
5991         while (svp <= last) {
5992             if (*svp) {
5993                 SV *const referrer = *svp;
5994                 if (SvWEAKREF(referrer)) {
5995                     /* XXX Should we check that it hasn't changed? */
5996                     assert(SvROK(referrer));
5997                     SvRV_set(referrer, 0);
5998                     SvOK_off(referrer);
5999                     SvWEAKREF_off(referrer);
6000                     SvSETMAGIC(referrer);
6001                 } else if (SvTYPE(referrer) == SVt_PVGV ||
6002                            SvTYPE(referrer) == SVt_PVLV) {
6003                     assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */
6004                     /* You lookin' at me?  */
6005                     assert(GvSTASH(referrer));
6006                     assert(GvSTASH(referrer) == (const HV *)sv);
6007                     GvSTASH(referrer) = 0;
6008                 } else if (SvTYPE(referrer) == SVt_PVCV ||
6009                            SvTYPE(referrer) == SVt_PVFM) {
6010                     if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */
6011                         /* You lookin' at me?  */
6012                         assert(CvSTASH(referrer));
6013                         assert(CvSTASH(referrer) == (const HV *)sv);
6014                         SvANY(MUTABLE_CV(referrer))->xcv_stash = 0;
6015                     }
6016                     else {
6017                         assert(SvTYPE(sv) == SVt_PVGV);
6018                         /* You lookin' at me?  */
6019                         assert(CvGV(referrer));
6020                         assert(CvGV(referrer) == (const GV *)sv);
6021                         anonymise_cv_maybe(MUTABLE_GV(sv),
6022                                                 MUTABLE_CV(referrer));
6023                     }
6024
6025                 } else {
6026                     Perl_croak(aTHX_
6027                                "panic: magic_killbackrefs (flags=%"UVxf")",
6028                                (UV)SvFLAGS(referrer));
6029                 }
6030
6031                 if (is_array)
6032                     *svp = NULL;
6033             }
6034             svp++;
6035         }
6036     }
6037     if (is_array) {
6038         AvFILLp(av) = -1;
6039         SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */
6040     }
6041     return;
6042 }
6043
6044 /*
6045 =for apidoc sv_insert
6046
6047 Inserts a string at the specified offset/length within the SV.  Similar to
6048 the Perl substr() function.  Handles get magic.
6049
6050 =for apidoc sv_insert_flags
6051
6052 Same as C<sv_insert>, but the extra C<flags> are passed to the
6053 C<SvPV_force_flags> that applies to C<bigstr>.
6054
6055 =cut
6056 */
6057
6058 void
6059 Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
6060 {
6061     char *big;
6062     char *mid;
6063     char *midend;
6064     char *bigend;
6065     SSize_t i;          /* better be sizeof(STRLEN) or bad things happen */
6066     STRLEN curlen;
6067
6068     PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
6069
6070     if (!bigstr)
6071         Perl_croak(aTHX_ "Can't modify nonexistent substring");
6072     SvPV_force_flags(bigstr, curlen, flags);
6073     (void)SvPOK_only_UTF8(bigstr);
6074     if (offset + len > curlen) {
6075         SvGROW(bigstr, offset+len+1);
6076         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
6077         SvCUR_set(bigstr, offset+len);
6078     }
6079
6080     SvTAINT(bigstr);
6081     i = littlelen - len;
6082     if (i > 0) {                        /* string might grow */
6083         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
6084         mid = big + offset + len;
6085         midend = bigend = big + SvCUR(bigstr);
6086         bigend += i;
6087         *bigend = '\0';
6088         while (midend > mid)            /* shove everything down */
6089             *--bigend = *--midend;
6090         Move(little,big+offset,littlelen,char);
6091         SvCUR_set(bigstr, SvCUR(bigstr) + i);
6092         SvSETMAGIC(bigstr);
6093         return;
6094     }
6095     else if (i == 0) {
6096         Move(little,SvPVX(bigstr)+offset,len,char);
6097         SvSETMAGIC(bigstr);
6098         return;
6099     }
6100
6101     big = SvPVX(bigstr);
6102     mid = big + offset;
6103     midend = mid + len;
6104     bigend = big + SvCUR(bigstr);
6105
6106     if (midend > bigend)
6107         Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p",
6108                    midend, bigend);
6109
6110     if (mid - big > bigend - midend) {  /* faster to shorten from end */
6111         if (littlelen) {
6112             Move(little, mid, littlelen,char);
6113             mid += littlelen;
6114         }
6115         i = bigend - midend;
6116         if (i > 0) {
6117             Move(midend, mid, i,char);
6118             mid += i;
6119         }
6120         *mid = '\0';
6121         SvCUR_set(bigstr, mid - big);
6122     }
6123     else if ((i = mid - big)) { /* faster from front */
6124         midend -= littlelen;
6125         mid = midend;
6126         Move(big, midend - i, i, char);
6127         sv_chop(bigstr,midend-i);
6128         if (littlelen)
6129             Move(little, mid, littlelen,char);
6130     }
6131     else if (littlelen) {
6132         midend -= littlelen;
6133         sv_chop(bigstr,midend);
6134         Move(little,midend,littlelen,char);
6135     }
6136     else {
6137         sv_chop(bigstr,midend);
6138     }
6139     SvSETMAGIC(bigstr);
6140 }
6141
6142 /*
6143 =for apidoc sv_replace
6144
6145 Make the first argument a copy of the second, then delete the original.
6146 The target SV physically takes over ownership of the body of the source SV
6147 and inherits its flags; however, the target keeps any magic it owns,
6148 and any magic in the source is discarded.
6149 Note that this is a rather specialist SV copying operation; most of the
6150 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
6151
6152 =cut
6153 */
6154
6155 void
6156 Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
6157 {
6158     const U32 refcnt = SvREFCNT(sv);
6159
6160     PERL_ARGS_ASSERT_SV_REPLACE;
6161
6162     SV_CHECK_THINKFIRST_COW_DROP(sv);
6163     if (SvREFCNT(nsv) != 1) {
6164         Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()"
6165                    " (%" UVuf " != 1)", (UV) SvREFCNT(nsv));
6166     }
6167     if (SvMAGICAL(sv)) {
6168         if (SvMAGICAL(nsv))
6169             mg_free(nsv);
6170         else
6171             sv_upgrade(nsv, SVt_PVMG);
6172         SvMAGIC_set(nsv, SvMAGIC(sv));
6173         SvFLAGS(nsv) |= SvMAGICAL(sv);
6174         SvMAGICAL_off(sv);
6175         SvMAGIC_set(sv, NULL);
6176     }
6177     SvREFCNT(sv) = 0;
6178     sv_clear(sv);
6179     assert(!SvREFCNT(sv));
6180 #ifdef DEBUG_LEAKING_SCALARS
6181     sv->sv_flags  = nsv->sv_flags;
6182     sv->sv_any    = nsv->sv_any;
6183     sv->sv_refcnt = nsv->sv_refcnt;
6184     sv->sv_u      = nsv->sv_u;
6185 #else
6186     StructCopy(nsv,sv,SV);
6187 #endif
6188     if(SvTYPE(sv) == SVt_IV) {
6189         SvANY(sv)
6190             = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
6191     }
6192         
6193
6194 #ifdef PERL_OLD_COPY_ON_WRITE
6195     if (SvIsCOW_normal(nsv)) {
6196         /* We need to follow the pointers around the loop to make the
6197            previous SV point to sv, rather than nsv.  */
6198         SV *next;
6199         SV *current = nsv;
6200         while ((next = SV_COW_NEXT_SV(current)) != nsv) {
6201             assert(next);
6202             current = next;
6203             assert(SvPVX_const(current) == SvPVX_const(nsv));
6204         }
6205         /* Make the SV before us point to the SV after us.  */
6206         if (DEBUG_C_TEST) {
6207             PerlIO_printf(Perl_debug_log, "previous is\n");
6208             sv_dump(current);
6209             PerlIO_printf(Perl_debug_log,
6210                           "move it from 0x%"UVxf" to 0x%"UVxf"\n",
6211                           (UV) SV_COW_NEXT_SV(current), (UV) sv);
6212         }
6213         SV_COW_NEXT_SV_SET(current, sv);
6214     }
6215 #endif
6216     SvREFCNT(sv) = refcnt;
6217     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
6218     SvREFCNT(nsv) = 0;
6219     del_SV(nsv);
6220 }
6221
6222 /* We're about to free a GV which has a CV that refers back to us.
6223  * If that CV will outlive us, make it anonymous (i.e. fix up its CvGV
6224  * field) */
6225
6226 STATIC void
6227 S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
6228 {
6229     SV *gvname;
6230     GV *anongv;
6231
6232     PERL_ARGS_ASSERT_ANONYMISE_CV_MAYBE;
6233
6234     /* be assertive! */
6235     assert(SvREFCNT(gv) == 0);
6236     assert(isGV(gv) && isGV_with_GP(gv));
6237     assert(GvGP(gv));
6238     assert(!CvANON(cv));
6239     assert(CvGV(cv) == gv);
6240     assert(!CvNAMED(cv));
6241
6242     /* will the CV shortly be freed by gp_free() ? */
6243     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
6244         SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
6245         return;
6246     }
6247
6248     /* if not, anonymise: */
6249     gvname = (GvSTASH(gv) && HvNAME(GvSTASH(gv)) && HvENAME(GvSTASH(gv)))
6250                     ? newSVhek(HvENAME_HEK(GvSTASH(gv)))
6251                     : newSVpvn_flags( "__ANON__", 8, 0 );
6252     sv_catpvs(gvname, "::__ANON__");
6253     anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV);
6254     SvREFCNT_dec_NN(gvname);
6255
6256     CvANON_on(cv);
6257     CvCVGV_RC_on(cv);
6258     SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
6259 }
6260
6261
6262 /*
6263 =for apidoc sv_clear
6264
6265 Clear an SV: call any destructors, free up any memory used by the body,
6266 and free the body itself.  The SV's head is I<not> freed, although
6267 its type is set to all 1's so that it won't inadvertently be assumed
6268 to be live during global destruction etc.
6269 This function should only be called when REFCNT is zero.  Most of the time
6270 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
6271 instead.
6272
6273 =cut
6274 */
6275
6276 void
6277 Perl_sv_clear(pTHX_ SV *const orig_sv)
6278 {
6279     dVAR;
6280     HV *stash;
6281     U32 type;
6282     const struct body_details *sv_type_details;
6283     SV* iter_sv = NULL;
6284     SV* next_sv = NULL;
6285     SV *sv = orig_sv;
6286     STRLEN hash_index;
6287
6288     PERL_ARGS_ASSERT_SV_CLEAR;
6289
6290     /* within this loop, sv is the SV currently being freed, and
6291      * iter_sv is the most recent AV or whatever that's being iterated
6292      * over to provide more SVs */
6293
6294     while (sv) {
6295
6296         type = SvTYPE(sv);
6297
6298         assert(SvREFCNT(sv) == 0);
6299         assert(SvTYPE(sv) != (svtype)SVTYPEMASK);
6300
6301         if (type <= SVt_IV) {
6302             /* See the comment in sv.h about the collusion between this
6303              * early return and the overloading of the NULL slots in the
6304              * size table.  */
6305             if (SvROK(sv))
6306                 goto free_rv;
6307             SvFLAGS(sv) &= SVf_BREAK;
6308             SvFLAGS(sv) |= SVTYPEMASK;
6309             goto free_head;
6310         }
6311
6312         assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
6313
6314         if (type >= SVt_PVMG) {
6315             if (SvOBJECT(sv)) {
6316                 if (!curse(sv, 1)) goto get_next_sv;
6317                 type = SvTYPE(sv); /* destructor may have changed it */
6318             }
6319             /* Free back-references before magic, in case the magic calls
6320              * Perl code that has weak references to sv. */
6321             if (type == SVt_PVHV) {
6322                 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
6323                 if (SvMAGIC(sv))
6324                     mg_free(sv);
6325             }
6326             else if (type == SVt_PVMG && SvPAD_OUR(sv)) {
6327                 SvREFCNT_dec(SvOURSTASH(sv));
6328             }
6329             else if (type == SVt_PVAV && AvPAD_NAMELIST(sv)) {
6330                 assert(!SvMAGICAL(sv));
6331             } else if (SvMAGIC(sv)) {
6332                 /* Free back-references before other types of magic. */
6333                 sv_unmagic(sv, PERL_MAGIC_backref);
6334                 mg_free(sv);
6335             }
6336             SvMAGICAL_off(sv);
6337             if (type == SVt_PVMG && SvPAD_TYPED(sv))
6338                 SvREFCNT_dec(SvSTASH(sv));
6339         }
6340         switch (type) {
6341             /* case SVt_INVLIST: */
6342         case SVt_PVIO:
6343             if (IoIFP(sv) &&
6344                 IoIFP(sv) != PerlIO_stdin() &&
6345                 IoIFP(sv) != PerlIO_stdout() &&
6346                 IoIFP(sv) != PerlIO_stderr() &&
6347                 !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6348             {
6349                 io_close(MUTABLE_IO(sv), FALSE);
6350             }
6351             if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
6352                 PerlDir_close(IoDIRP(sv));
6353             IoDIRP(sv) = (DIR*)NULL;
6354             Safefree(IoTOP_NAME(sv));
6355             Safefree(IoFMT_NAME(sv));
6356             Safefree(IoBOTTOM_NAME(sv));
6357             if ((const GV *)sv == PL_statgv)
6358                 PL_statgv = NULL;
6359             goto freescalar;
6360         case SVt_REGEXP:
6361             /* FIXME for plugins */
6362           freeregexp:
6363             pregfree2((REGEXP*) sv);
6364             goto freescalar;
6365         case SVt_PVCV:
6366         case SVt_PVFM:
6367             cv_undef(MUTABLE_CV(sv));
6368             /* If we're in a stash, we don't own a reference to it.
6369              * However it does have a back reference to us, which needs to
6370              * be cleared.  */
6371             if ((stash = CvSTASH(sv)))
6372                 sv_del_backref(MUTABLE_SV(stash), sv);
6373             goto freescalar;
6374         case SVt_PVHV:
6375             if (PL_last_swash_hv == (const HV *)sv) {
6376                 PL_last_swash_hv = NULL;
6377             }
6378             if (HvTOTALKEYS((HV*)sv) > 0) {
6379                 const char *name;
6380                 /* this statement should match the one at the beginning of
6381                  * hv_undef_flags() */
6382                 if (   PL_phase != PERL_PHASE_DESTRUCT
6383                     && (name = HvNAME((HV*)sv)))
6384                 {
6385                     if (PL_stashcache) {
6386                     DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
6387                                      SVfARG(sv)));
6388                         (void)hv_deletehek(PL_stashcache,
6389                                            HvNAME_HEK((HV*)sv), G_DISCARD);
6390                     }
6391                     hv_name_set((HV*)sv, NULL, 0, 0);
6392                 }
6393
6394                 /* save old iter_sv in unused SvSTASH field */
6395                 assert(!SvOBJECT(sv));
6396                 SvSTASH(sv) = (HV*)iter_sv;
6397                 iter_sv = sv;
6398
6399                 /* save old hash_index in unused SvMAGIC field */
6400                 assert(!SvMAGICAL(sv));
6401                 assert(!SvMAGIC(sv));
6402                 ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index;
6403                 hash_index = 0;
6404
6405                 next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index);
6406                 goto get_next_sv; /* process this new sv */
6407             }
6408             /* free empty hash */
6409             Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL);
6410             assert(!HvARRAY((HV*)sv));
6411             break;
6412         case SVt_PVAV:
6413             {
6414                 AV* av = MUTABLE_AV(sv);
6415                 if (PL_comppad == av) {
6416                     PL_comppad = NULL;
6417                     PL_curpad = NULL;
6418                 }
6419                 if (AvREAL(av) && AvFILLp(av) > -1) {
6420                     next_sv = AvARRAY(av)[AvFILLp(av)--];
6421                     /* save old iter_sv in top-most slot of AV,
6422                      * and pray that it doesn't get wiped in the meantime */
6423                     AvARRAY(av)[AvMAX(av)] = iter_sv;
6424                     iter_sv = sv;
6425                     goto get_next_sv; /* process this new sv */
6426                 }
6427                 Safefree(AvALLOC(av));
6428             }
6429
6430             break;
6431         case SVt_PVLV:
6432             if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
6433                 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
6434                 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
6435                 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
6436             }
6437             else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
6438                 SvREFCNT_dec(LvTARG(sv));
6439             if (isREGEXP(sv)) goto freeregexp;
6440         case SVt_PVGV:
6441             if (isGV_with_GP(sv)) {
6442                 if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
6443                    && HvENAME_get(stash))
6444                     mro_method_changed_in(stash);
6445                 gp_free(MUTABLE_GV(sv));
6446                 if (GvNAME_HEK(sv))
6447                     unshare_hek(GvNAME_HEK(sv));
6448                 /* If we're in a stash, we don't own a reference to it.
6449                  * However it does have a back reference to us, which
6450                  * needs to be cleared.  */
6451                 if (!SvVALID(sv) && (stash = GvSTASH(sv)))
6452                         sv_del_backref(MUTABLE_SV(stash), sv);
6453             }
6454             /* FIXME. There are probably more unreferenced pointers to SVs
6455              * in the interpreter struct that we should check and tidy in
6456              * a similar fashion to this:  */
6457             /* See also S_sv_unglob, which does the same thing. */
6458             if ((const GV *)sv == PL_last_in_gv)
6459                 PL_last_in_gv = NULL;
6460             else if ((const GV *)sv == PL_statgv)
6461                 PL_statgv = NULL;
6462             else if ((const GV *)sv == PL_stderrgv)
6463                 PL_stderrgv = NULL;
6464         case SVt_PVMG:
6465         case SVt_PVNV:
6466         case SVt_PVIV:
6467         case SVt_INVLIST:
6468         case SVt_PV:
6469           freescalar:
6470             /* Don't bother with SvOOK_off(sv); as we're only going to
6471              * free it.  */
6472             if (SvOOK(sv)) {
6473                 STRLEN offset;
6474                 SvOOK_offset(sv, offset);
6475                 SvPV_set(sv, SvPVX_mutable(sv) - offset);
6476                 /* Don't even bother with turning off the OOK flag.  */
6477             }
6478             if (SvROK(sv)) {
6479             free_rv:
6480                 {
6481                     SV * const target = SvRV(sv);
6482                     if (SvWEAKREF(sv))
6483                         sv_del_backref(target, sv);
6484                     else
6485                         next_sv = target;
6486                 }
6487             }
6488 #ifdef PERL_ANY_COW
6489             else if (SvPVX_const(sv)
6490                      && !(SvTYPE(sv) == SVt_PVIO
6491                      && !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
6492             {
6493                 if (SvIsCOW(sv)) {
6494                     if (DEBUG_C_TEST) {
6495                         PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
6496                         sv_dump(sv);
6497                     }
6498                     if (SvLEN(sv)) {
6499 # ifdef PERL_OLD_COPY_ON_WRITE
6500                         sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
6501 # else
6502                         if (CowREFCNT(sv)) {
6503                             sv_buf_to_rw(sv);
6504                             CowREFCNT(sv)--;
6505                             sv_buf_to_ro(sv);
6506                             SvLEN_set(sv, 0);
6507                         }
6508 # endif
6509                     } else {
6510                         unshar