perldelta - Add links for rt.perl.org bugs
[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 #ifdef __Lynx__
39 /* Missing proto on LynxOS */
40   char *gconvert(double, int, int,  char *);
41 #endif
42
43 #ifdef PERL_NEW_COPY_ON_WRITE
44 #   ifndef SV_COW_THRESHOLD
45 #    define SV_COW_THRESHOLD                    0   /* COW iff len > K */
46 #   endif
47 #   ifndef SV_COWBUF_THRESHOLD
48 #    define SV_COWBUF_THRESHOLD                 1250 /* COW iff len > K */
49 #   endif
50 #   ifndef SV_COW_MAX_WASTE_THRESHOLD
51 #    define SV_COW_MAX_WASTE_THRESHOLD          80   /* COW iff (len - cur) < K */
52 #   endif
53 #   ifndef SV_COWBUF_WASTE_THRESHOLD
54 #    define SV_COWBUF_WASTE_THRESHOLD           80   /* COW iff (len - cur) < K */
55 #   endif
56 #   ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
57 #    define SV_COW_MAX_WASTE_FACTOR_THRESHOLD   2    /* COW iff len < (cur * K) */
58 #   endif
59 #   ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
60 #    define SV_COWBUF_WASTE_FACTOR_THRESHOLD    2    /* COW iff len < (cur * K) */
61 #   endif
62 #endif
63 /* Work around compiler warnings about unsigned >= THRESHOLD when thres-
64    hold is 0. */
65 #if SV_COW_THRESHOLD
66 # define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
67 #else
68 # define GE_COW_THRESHOLD(cur) 1
69 #endif
70 #if SV_COWBUF_THRESHOLD
71 # define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
72 #else
73 # define GE_COWBUF_THRESHOLD(cur) 1
74 #endif
75 #if SV_COW_MAX_WASTE_THRESHOLD
76 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
77 #else
78 # define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
79 #endif
80 #if SV_COWBUF_WASTE_THRESHOLD
81 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
82 #else
83 # define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
84 #endif
85 #if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
86 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
87 #else
88 # define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
89 #endif
90 #if SV_COWBUF_WASTE_FACTOR_THRESHOLD
91 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
92 #else
93 # define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
94 #endif
95
96 #define CHECK_COW_THRESHOLD(cur,len) (\
97     GE_COW_THRESHOLD((cur)) && \
98     GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
99     GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
100 )
101 #define CHECK_COWBUF_THRESHOLD(cur,len) (\
102     GE_COWBUF_THRESHOLD((cur)) && \
103     GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
104     GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
105 )
106
107 #ifdef PERL_UTF8_CACHE_ASSERT
108 /* if adding more checks watch out for the following tests:
109  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
110  *   lib/utf8.t lib/Unicode/Collate/t/index.t
111  * --jhi
112  */
113 #   define ASSERT_UTF8_CACHE(cache) \
114     STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
115                               assert((cache)[2] <= (cache)[3]); \
116                               assert((cache)[3] <= (cache)[1]);} \
117                               } STMT_END
118 #else
119 #   define ASSERT_UTF8_CACHE(cache) NOOP
120 #endif
121
122 #ifdef PERL_OLD_COPY_ON_WRITE
123 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
124 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
125 #endif
126
127 /* ============================================================================
128
129 =head1 Allocation and deallocation of SVs.
130 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
131 sv, av, hv...) contains type and reference count information, and for
132 many types, a pointer to the body (struct xrv, xpv, xpviv...), which
133 contains fields specific to each type.  Some types store all they need
134 in the head, so don't have a body.
135
136 In all but the most memory-paranoid configurations (ex: PURIFY), heads
137 and bodies are allocated out of arenas, which by default are
138 approximately 4K chunks of memory parcelled up into N heads or bodies.
139 Sv-bodies are allocated by their sv-type, guaranteeing size
140 consistency needed to allocate safely from arrays.
141
142 For SV-heads, the first slot in each arena is reserved, and holds a
143 link to the next arena, some flags, and a note of the number of slots.
144 Snaked through each arena chain is a linked list of free items; when
145 this becomes empty, an extra arena is allocated and divided up into N
146 items which are threaded into the free list.
147
148 SV-bodies are similar, but they use arena-sets by default, which
149 separate the link and info from the arena itself, and reclaim the 1st
150 slot in the arena.  SV-bodies are further described later.
151
152 The following global variables are associated with arenas:
153
154  PL_sv_arenaroot     pointer to list of SV arenas
155  PL_sv_root          pointer to list of free SV structures
156
157  PL_body_arenas      head of linked-list of body arenas
158  PL_body_roots[]     array of pointers to list of free bodies of svtype
159                      arrays are indexed by the svtype needed
160
161 A few special SV heads are not allocated from an arena, but are
162 instead directly created in the interpreter structure, eg PL_sv_undef.
163 The size of arenas can be changed from the default by setting
164 PERL_ARENA_SIZE appropriately at compile time.
165
166 The SV arena serves the secondary purpose of allowing still-live SVs
167 to be located and destroyed during final cleanup.
168
169 At the lowest level, the macros new_SV() and del_SV() grab and free
170 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
171 to return the SV to the free list with error checking.) new_SV() calls
172 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
173 SVs in the free list have their SvTYPE field set to all ones.
174
175 At the time of very final cleanup, sv_free_arenas() is called from
176 perl_destruct() to physically free all the arenas allocated since the
177 start of the interpreter.
178
179 The function visit() scans the SV arenas list, and calls a specified
180 function for each SV it finds which is still live - ie which has an SvTYPE
181 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
182 following functions (specified as [function that calls visit()] / [function
183 called by visit() for each SV]):
184
185     sv_report_used() / do_report_used()
186                         dump all remaining SVs (debugging aid)
187
188     sv_clean_objs() / do_clean_objs(),do_clean_named_objs(),
189                       do_clean_named_io_objs(),do_curse()
190                         Attempt to free all objects pointed to by RVs,
191                         try to do the same for all objects indir-
192                         ectly referenced by typeglobs too, and
193                         then do a final sweep, cursing any
194                         objects that remain.  Called once from
195                         perl_destruct(), prior to calling sv_clean_all()
196                         below.
197
198     sv_clean_all() / do_clean_all()
199                         SvREFCNT_dec(sv) each remaining SV, possibly
200                         triggering an sv_free(). It also sets the
201                         SVf_BREAK flag on the SV to indicate that the
202                         refcnt has been artificially lowered, and thus
203                         stopping sv_free() from giving spurious warnings
204                         about SVs which unexpectedly have a refcnt
205                         of zero.  called repeatedly from perl_destruct()
206                         until there are no SVs left.
207
208 =head2 Arena allocator API Summary
209
210 Private API to rest of sv.c
211
212     new_SV(),  del_SV(),
213
214     new_XPVNV(), del_XPVGV(),
215     etc
216
217 Public API:
218
219     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
220
221 =cut
222
223  * ========================================================================= */
224
225 /*
226  * "A time to plant, and a time to uproot what was planted..."
227  */
228
229 #ifdef PERL_MEM_LOG
230 #  define MEM_LOG_NEW_SV(sv, file, line, func)  \
231             Perl_mem_log_new_sv(sv, file, line, func)
232 #  define MEM_LOG_DEL_SV(sv, file, line, func)  \
233             Perl_mem_log_del_sv(sv, file, line, func)
234 #else
235 #  define MEM_LOG_NEW_SV(sv, file, line, func)  NOOP
236 #  define MEM_LOG_DEL_SV(sv, file, line, func)  NOOP
237 #endif
238
239 #ifdef DEBUG_LEAKING_SCALARS
240 #  define FREE_SV_DEBUG_FILE(sv) STMT_START { \
241         if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
242     } STMT_END
243 #  define DEBUG_SV_SERIAL(sv)                                               \
244     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n",    \
245             PTR2UV(sv), (long)(sv)->sv_debug_serial))
246 #else
247 #  define FREE_SV_DEBUG_FILE(sv)
248 #  define DEBUG_SV_SERIAL(sv)   NOOP
249 #endif
250
251 #ifdef PERL_POISON
252 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
253 #  define SvARENA_CHAIN_SET(sv,val)     (sv)->sv_u.svu_rv = MUTABLE_SV((val))
254 /* Whilst I'd love to do this, it seems that things like to check on
255    unreferenced scalars
256 #  define POSION_SV_HEAD(sv)    PoisonNew(sv, 1, struct STRUCT_SV)
257 */
258 #  define POSION_SV_HEAD(sv)    PoisonNew(&SvANY(sv), 1, void *), \
259                                 PoisonNew(&SvREFCNT(sv), 1, U32)
260 #else
261 #  define SvARENA_CHAIN(sv)     SvANY(sv)
262 #  define SvARENA_CHAIN_SET(sv,val)     SvANY(sv) = (void *)(val)
263 #  define POSION_SV_HEAD(sv)
264 #endif
265
266 /* Mark an SV head as unused, and add to free list.
267  *
268  * If SVf_BREAK is set, skip adding it to the free list, as this SV had
269  * its refcount artificially decremented during global destruction, so
270  * there may be dangling pointers to it. The last thing we want in that
271  * case is for it to be reused. */
272
273 #define plant_SV(p) \
274     STMT_START {                                        \
275         const U32 old_flags = SvFLAGS(p);                       \
276         MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__);  \
277         DEBUG_SV_SERIAL(p);                             \
278         FREE_SV_DEBUG_FILE(p);                          \
279         POSION_SV_HEAD(p);                              \
280         SvFLAGS(p) = SVTYPEMASK;                        \
281         if (!(old_flags & SVf_BREAK)) {         \
282             SvARENA_CHAIN_SET(p, PL_sv_root);   \
283             PL_sv_root = (p);                           \
284         }                                               \
285         --PL_sv_count;                                  \
286     } STMT_END
287
288 #define uproot_SV(p) \
289     STMT_START {                                        \
290         (p) = PL_sv_root;                               \
291         PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p));              \
292         ++PL_sv_count;                                  \
293     } STMT_END
294
295
296 /* make some more SVs by adding another arena */
297
298 STATIC SV*
299 S_more_sv(pTHX)
300 {
301     SV* sv;
302     char *chunk;                /* must use New here to match call to */
303     Newx(chunk,PERL_ARENA_SIZE,char);  /* Safefree() in sv_free_arenas() */
304     sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
305     uproot_SV(sv);
306     return sv;
307 }
308
309 /* new_SV(): return a new, empty SV head */
310
311 #ifdef DEBUG_LEAKING_SCALARS
312 /* provide a real function for a debugger to play with */
313 STATIC SV*
314 S_new_SV(pTHX_ const char *file, int line, const char *func)
315 {
316     SV* sv;
317
318     if (PL_sv_root)
319         uproot_SV(sv);
320     else
321         sv = S_more_sv(aTHX);
322     SvANY(sv) = 0;
323     SvREFCNT(sv) = 1;
324     SvFLAGS(sv) = 0;
325     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
326     sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE
327                 ? PL_parser->copline
328                 :  PL_curcop
329                     ? CopLINE(PL_curcop)
330                     : 0
331             );
332     sv->sv_debug_inpad = 0;
333     sv->sv_debug_parent = NULL;
334     sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL;
335
336     sv->sv_debug_serial = PL_sv_serial++;
337
338     MEM_LOG_NEW_SV(sv, file, line, func);
339     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
340             PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
341
342     return sv;
343 }
344 #  define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__)
345
346 #else
347 #  define new_SV(p) \
348     STMT_START {                                        \
349         if (PL_sv_root)                                 \
350             uproot_SV(p);                               \
351         else                                            \
352             (p) = S_more_sv(aTHX);                      \
353         SvANY(p) = 0;                                   \
354         SvREFCNT(p) = 1;                                \
355         SvFLAGS(p) = 0;                                 \
356         MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__);  \
357     } STMT_END
358 #endif
359
360
361 /* del_SV(): return an empty SV head to the free list */
362
363 #ifdef DEBUGGING
364
365 #define del_SV(p) \
366     STMT_START {                                        \
367         if (DEBUG_D_TEST)                               \
368             del_sv(p);                                  \
369         else                                            \
370             plant_SV(p);                                \
371     } STMT_END
372
373 STATIC void
374 S_del_sv(pTHX_ SV *p)
375 {
376     PERL_ARGS_ASSERT_DEL_SV;
377
378     if (DEBUG_D_TEST) {
379         SV* sva;
380         bool ok = 0;
381         for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
382             const SV * const sv = sva + 1;
383             const SV * const svend = &sva[SvREFCNT(sva)];
384             if (p >= sv && p < svend) {
385                 ok = 1;
386                 break;
387             }
388         }
389         if (!ok) {
390             Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
391                              "Attempt to free non-arena SV: 0x%"UVxf
392                              pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
393             return;
394         }
395     }
396     plant_SV(p);
397 }
398
399 #else /* ! DEBUGGING */
400
401 #define del_SV(p)   plant_SV(p)
402
403 #endif /* DEBUGGING */
404
405
406 /*
407 =head1 SV Manipulation Functions
408
409 =for apidoc sv_add_arena
410
411 Given a chunk of memory, link it to the head of the list of arenas,
412 and split it into a list of free SVs.
413
414 =cut
415 */
416
417 static void
418 S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
419 {
420     SV *const sva = MUTABLE_SV(ptr);
421     SV* sv;
422     SV* svend;
423
424     PERL_ARGS_ASSERT_SV_ADD_ARENA;
425
426     /* The first SV in an arena isn't an SV. */
427     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
428     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
429     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
430
431     PL_sv_arenaroot = sva;
432     PL_sv_root = sva + 1;
433
434     svend = &sva[SvREFCNT(sva) - 1];
435     sv = sva + 1;
436     while (sv < svend) {
437         SvARENA_CHAIN_SET(sv, (sv + 1));
438 #ifdef DEBUGGING
439         SvREFCNT(sv) = 0;
440 #endif
441         /* Must always set typemask because it's always checked in on cleanup
442            when the arenas are walked looking for objects.  */
443         SvFLAGS(sv) = SVTYPEMASK;
444         sv++;
445     }
446     SvARENA_CHAIN_SET(sv, 0);
447 #ifdef DEBUGGING
448     SvREFCNT(sv) = 0;
449 #endif
450     SvFLAGS(sv) = SVTYPEMASK;
451 }
452
453 /* visit(): call the named function for each non-free SV in the arenas
454  * whose flags field matches the flags/mask args. */
455
456 STATIC I32
457 S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
458 {
459     SV* sva;
460     I32 visited = 0;
461
462     PERL_ARGS_ASSERT_VISIT;
463
464     for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
465         const SV * const svend = &sva[SvREFCNT(sva)];
466         SV* sv;
467         for (sv = sva + 1; sv < svend; ++sv) {
468             if (SvTYPE(sv) != (svtype)SVTYPEMASK
469                     && (sv->sv_flags & mask) == flags
470                     && SvREFCNT(sv))
471             {
472                 (*f)(aTHX_ sv);
473                 ++visited;
474             }
475         }
476     }
477     return visited;
478 }
479
480 #ifdef DEBUGGING
481
482 /* called by sv_report_used() for each live SV */
483
484 static void
485 do_report_used(pTHX_ SV *const sv)
486 {
487     if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
488         PerlIO_printf(Perl_debug_log, "****\n");
489         sv_dump(sv);
490     }
491 }
492 #endif
493
494 /*
495 =for apidoc sv_report_used
496
497 Dump the contents of all SVs not yet freed (debugging aid).
498
499 =cut
500 */
501
502 void
503 Perl_sv_report_used(pTHX)
504 {
505 #ifdef DEBUGGING
506     visit(do_report_used, 0, 0);
507 #else
508     PERL_UNUSED_CONTEXT;
509 #endif
510 }
511
512 /* called by sv_clean_objs() for each live SV */
513
514 static void
515 do_clean_objs(pTHX_ SV *const ref)
516 {
517     assert (SvROK(ref));
518     {
519         SV * const target = SvRV(ref);
520         if (SvOBJECT(target)) {
521             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
522             if (SvWEAKREF(ref)) {
523                 sv_del_backref(target, ref);
524                 SvWEAKREF_off(ref);
525                 SvRV_set(ref, NULL);
526             } else {
527                 SvROK_off(ref);
528                 SvRV_set(ref, NULL);
529                 SvREFCNT_dec_NN(target);
530             }
531         }
532     }
533 }
534
535
536 /* clear any slots in a GV which hold objects - except IO;
537  * called by sv_clean_objs() for each live GV */
538
539 static void
540 do_clean_named_objs(pTHX_ SV *const sv)
541 {
542     SV *obj;
543     assert(SvTYPE(sv) == SVt_PVGV);
544     assert(isGV_with_GP(sv));
545     if (!GvGP(sv))
546         return;
547
548     /* freeing GP entries may indirectly free the current GV;
549      * hold onto it while we mess with the GP slots */
550     SvREFCNT_inc(sv);
551
552     if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) {
553         DEBUG_D((PerlIO_printf(Perl_debug_log,
554                 "Cleaning named glob SV object:\n "), sv_dump(obj)));
555         GvSV(sv) = NULL;
556         SvREFCNT_dec_NN(obj);
557     }
558     if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) {
559         DEBUG_D((PerlIO_printf(Perl_debug_log,
560                 "Cleaning named glob AV object:\n "), sv_dump(obj)));
561         GvAV(sv) = NULL;
562         SvREFCNT_dec_NN(obj);
563     }
564     if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) {
565         DEBUG_D((PerlIO_printf(Perl_debug_log,
566                 "Cleaning named glob HV object:\n "), sv_dump(obj)));
567         GvHV(sv) = NULL;
568         SvREFCNT_dec_NN(obj);
569     }
570     if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) {
571         DEBUG_D((PerlIO_printf(Perl_debug_log,
572                 "Cleaning named glob CV object:\n "), sv_dump(obj)));
573         GvCV_set(sv, NULL);
574         SvREFCNT_dec_NN(obj);
575     }
576     SvREFCNT_dec_NN(sv); /* undo the inc above */
577 }
578
579 /* clear any IO slots in a GV which hold objects (except stderr, defout);
580  * called by sv_clean_objs() for each live GV */
581
582 static void
583 do_clean_named_io_objs(pTHX_ SV *const sv)
584 {
585     SV *obj;
586     assert(SvTYPE(sv) == SVt_PVGV);
587     assert(isGV_with_GP(sv));
588     if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv)
589         return;
590
591     SvREFCNT_inc(sv);
592     if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) {
593         DEBUG_D((PerlIO_printf(Perl_debug_log,
594                 "Cleaning named glob IO object:\n "), sv_dump(obj)));
595         GvIOp(sv) = NULL;
596         SvREFCNT_dec_NN(obj);
597     }
598     SvREFCNT_dec_NN(sv); /* undo the inc above */
599 }
600
601 /* Void wrapper to pass to visit() */
602 static void
603 do_curse(pTHX_ SV * const sv) {
604     if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
605      || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
606         return;
607     (void)curse(sv, 0);
608 }
609
610 /*
611 =for apidoc sv_clean_objs
612
613 Attempt to destroy all objects not yet freed.
614
615 =cut
616 */
617
618 void
619 Perl_sv_clean_objs(pTHX)
620 {
621     GV *olddef, *olderr;
622     PL_in_clean_objs = TRUE;
623     visit(do_clean_objs, SVf_ROK, SVf_ROK);
624     /* Some barnacles may yet remain, clinging to typeglobs.
625      * Run the non-IO destructors first: they may want to output
626      * error messages, close files etc */
627     visit(do_clean_named_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
628     visit(do_clean_named_io_objs, SVt_PVGV|SVpgv_GP, SVTYPEMASK|SVp_POK|SVpgv_GP);
629     /* And if there are some very tenacious barnacles clinging to arrays,
630        closures, or what have you.... */
631     visit(do_curse, SVs_OBJECT, SVs_OBJECT);
632     olddef = PL_defoutgv;
633     PL_defoutgv = NULL; /* disable skip of PL_defoutgv */
634     if (olddef && isGV_with_GP(olddef))
635         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef));
636     olderr = PL_stderrgv;
637     PL_stderrgv = NULL; /* disable skip of PL_stderrgv */
638     if (olderr && isGV_with_GP(olderr))
639         do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr));
640     SvREFCNT_dec(olddef);
641     PL_in_clean_objs = FALSE;
642 }
643
644 /* called by sv_clean_all() for each live SV */
645
646 static void
647 do_clean_all(pTHX_ SV *const sv)
648 {
649     if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
650         /* don't clean pid table and strtab */
651         return;
652     }
653     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
654     SvFLAGS(sv) |= SVf_BREAK;
655     SvREFCNT_dec_NN(sv);
656 }
657
658 /*
659 =for apidoc sv_clean_all
660
661 Decrement the refcnt of each remaining SV, possibly triggering a
662 cleanup.  This function may have to be called multiple times to free
663 SVs which are in complex self-referential hierarchies.
664
665 =cut
666 */
667
668 I32
669 Perl_sv_clean_all(pTHX)
670 {
671     I32 cleaned;
672     PL_in_clean_all = TRUE;
673     cleaned = visit(do_clean_all, 0,0);
674     return cleaned;
675 }
676
677 /*
678   ARENASETS: a meta-arena implementation which separates arena-info
679   into struct arena_set, which contains an array of struct
680   arena_descs, each holding info for a single arena.  By separating
681   the meta-info from the arena, we recover the 1st slot, formerly
682   borrowed for list management.  The arena_set is about the size of an
683   arena, avoiding the needless malloc overhead of a naive linked-list.
684
685   The cost is 1 arena-set malloc per ~320 arena-mallocs, + the unused
686   memory in the last arena-set (1/2 on average).  In trade, we get
687   back the 1st slot in each arena (ie 1.7% of a CV-arena, less for
688   smaller types).  The recovery of the wasted space allows use of
689   small arenas for large, rare body types, by changing array* fields
690   in body_details_by_type[] below.
691 */
692 struct arena_desc {
693     char       *arena;          /* the raw storage, allocated aligned */
694     size_t      size;           /* its size ~4k typ */
695     svtype      utype;          /* bodytype stored in arena */
696 };
697
698 struct arena_set;
699
700 /* Get the maximum number of elements in set[] such that struct arena_set
701    will fit within PERL_ARENA_SIZE, which is probably just under 4K, and
702    therefore likely to be 1 aligned memory page.  */
703
704 #define ARENAS_PER_SET  ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \
705                           - 2 * sizeof(int)) / sizeof (struct arena_desc))
706
707 struct arena_set {
708     struct arena_set* next;
709     unsigned int   set_size;    /* ie ARENAS_PER_SET */
710     unsigned int   curr;        /* index of next available arena-desc */
711     struct arena_desc set[ARENAS_PER_SET];
712 };
713
714 /*
715 =for apidoc sv_free_arenas
716
717 Deallocate the memory used by all arenas.  Note that all the individual SV
718 heads and bodies within the arenas must already have been freed.
719
720 =cut
721
722 */
723 void
724 Perl_sv_free_arenas(pTHX)
725 {
726     SV* sva;
727     SV* svanext;
728     unsigned int i;
729
730     /* Free arenas here, but be careful about fake ones.  (We assume
731        contiguity of the fake ones with the corresponding real ones.) */
732
733     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
734         svanext = MUTABLE_SV(SvANY(sva));
735         while (svanext && SvFAKE(svanext))
736             svanext = MUTABLE_SV(SvANY(svanext));
737
738         if (!SvFAKE(sva))
739             Safefree(sva);
740     }
741
742     {
743         struct arena_set *aroot = (struct arena_set*) PL_body_arenas;
744
745         while (aroot) {
746             struct arena_set *current = aroot;
747             i = aroot->curr;
748             while (i--) {
749                 assert(aroot->set[i].arena);
750                 Safefree(aroot->set[i].arena);
751             }
752             aroot = aroot->next;
753             Safefree(current);
754         }
755     }
756     PL_body_arenas = 0;
757
758     i = PERL_ARENA_ROOTS_SIZE;
759     while (i--)
760         PL_body_roots[i] = 0;
761
762     PL_sv_arenaroot = 0;
763     PL_sv_root = 0;
764 }
765
766 /*
767   Here are mid-level routines that manage the allocation of bodies out
768   of the various arenas.  There are 5 kinds of arenas:
769
770   1. SV-head arenas, which are discussed and handled above
771   2. regular body arenas
772   3. arenas for reduced-size bodies
773   4. Hash-Entry arenas
774
775   Arena types 2 & 3 are chained by body-type off an array of
776   arena-root pointers, which is indexed by svtype.  Some of the
777   larger/less used body types are malloced singly, since a large
778   unused block of them is wasteful.  Also, several svtypes dont have
779   bodies; the data fits into the sv-head itself.  The arena-root
780   pointer thus has a few unused root-pointers (which may be hijacked
781   later for arena types 4,5)
782
783   3 differs from 2 as an optimization; some body types have several
784   unused fields in the front of the structure (which are kept in-place
785   for consistency).  These bodies can be allocated in smaller chunks,
786   because the leading fields arent accessed.  Pointers to such bodies
787   are decremented to point at the unused 'ghost' memory, knowing that
788   the pointers are used with offsets to the real memory.
789
790
791 =head1 SV-Body Allocation
792
793 =cut
794
795 Allocation of SV-bodies is similar to SV-heads, differing as follows;
796 the allocation mechanism is used for many body types, so is somewhat
797 more complicated, it uses arena-sets, and has no need for still-live
798 SV detection.
799
800 At the outermost level, (new|del)_X*V macros return bodies of the
801 appropriate type.  These macros call either (new|del)_body_type or
802 (new|del)_body_allocated macro pairs, depending on specifics of the
803 type.  Most body types use the former pair, the latter pair is used to
804 allocate body types with "ghost fields".
805
806 "ghost fields" are fields that are unused in certain types, and
807 consequently don't need to actually exist.  They are declared because
808 they're part of a "base type", which allows use of functions as
809 methods.  The simplest examples are AVs and HVs, 2 aggregate types
810 which don't use the fields which support SCALAR semantics.
811
812 For these types, the arenas are carved up into appropriately sized
813 chunks, we thus avoid wasted memory for those unaccessed members.
814 When bodies are allocated, we adjust the pointer back in memory by the
815 size of the part not allocated, so it's as if we allocated the full
816 structure.  (But things will all go boom if you write to the part that
817 is "not there", because you'll be overwriting the last members of the
818 preceding structure in memory.)
819
820 We calculate the correction using the STRUCT_OFFSET macro on the first
821 member present.  If the allocated structure is smaller (no initial NV
822 actually allocated) then the net effect is to subtract the size of the NV
823 from the pointer, to return a new pointer as if an initial NV were actually
824 allocated.  (We were using structures named *_allocated for this, but
825 this turned out to be a subtle bug, because a structure without an NV
826 could have a lower alignment constraint, but the compiler is allowed to
827 optimised accesses based on the alignment constraint of the actual pointer
828 to the full structure, for example, using a single 64 bit load instruction
829 because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
830
831 This is the same trick as was used for NV and IV bodies.  Ironically it
832 doesn't need to be used for NV bodies any more, because NV is now at
833 the start of the structure.  IV bodies don't need it either, because
834 they are no longer allocated.
835
836 In turn, the new_body_* allocators call S_new_body(), which invokes
837 new_body_inline macro, which takes a lock, and takes a body off the
838 linked list at PL_body_roots[sv_type], calling Perl_more_bodies() if
839 necessary to refresh an empty list.  Then the lock is released, and
840 the body is returned.
841
842 Perl_more_bodies allocates a new arena, and carves it up into an array of N
843 bodies, which it strings into a linked list.  It looks up arena-size
844 and body-size from the body_details table described below, thus
845 supporting the multiple body-types.
846
847 If PURIFY is defined, or PERL_ARENA_SIZE=0, arenas are not used, and
848 the (new|del)_X*V macros are mapped directly to malloc/free.
849
850 For each sv-type, struct body_details bodies_by_type[] carries
851 parameters which control these aspects of SV handling:
852
853 Arena_size determines whether arenas are used for this body type, and if
854 so, how big they are.  PURIFY or PERL_ARENA_SIZE=0 set this field to
855 zero, forcing individual mallocs and frees.
856
857 Body_size determines how big a body is, and therefore how many fit into
858 each arena.  Offset carries the body-pointer adjustment needed for
859 "ghost fields", and is used in *_allocated macros.
860
861 But its main purpose is to parameterize info needed in
862 Perl_sv_upgrade().  The info here dramatically simplifies the function
863 vs the implementation in 5.8.8, making it table-driven.  All fields
864 are used for this, except for arena_size.
865
866 For the sv-types that have no bodies, arenas are not used, so those
867 PL_body_roots[sv_type] are unused, and can be overloaded.  In
868 something of a special case, SVt_NULL is borrowed for HE arenas;
869 PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the
870 bodies_by_type[SVt_NULL] slot is not used, as the table is not
871 available in hv.c.
872
873 */
874
875 struct body_details {
876     U8 body_size;       /* Size to allocate  */
877     U8 copy;            /* Size of structure to copy (may be shorter)  */
878     U8 offset;
879     unsigned int type : 4;          /* We have space for a sanity check.  */
880     unsigned int cant_upgrade : 1;  /* Cannot upgrade this type */
881     unsigned int zero_nv : 1;       /* zero the NV when upgrading from this */
882     unsigned int arena : 1;         /* Allocated from an arena */
883     size_t arena_size;              /* Size of arena to allocate */
884 };
885
886 #define HADNV FALSE
887 #define NONV TRUE
888
889
890 #ifdef PURIFY
891 /* With -DPURFIY we allocate everything directly, and don't use arenas.
892    This seems a rather elegant way to simplify some of the code below.  */
893 #define HASARENA FALSE
894 #else
895 #define HASARENA TRUE
896 #endif
897 #define NOARENA FALSE
898
899 /* Size the arenas to exactly fit a given number of bodies.  A count
900    of 0 fits the max number bodies into a PERL_ARENA_SIZE.block,
901    simplifying the default.  If count > 0, the arena is sized to fit
902    only that many bodies, allowing arenas to be used for large, rare
903    bodies (XPVFM, XPVIO) without undue waste.  The arena size is
904    limited by PERL_ARENA_SIZE, so we can safely oversize the
905    declarations.
906  */
907 #define FIT_ARENA0(body_size)                           \
908     ((size_t)(PERL_ARENA_SIZE / body_size) * body_size)
909 #define FIT_ARENAn(count,body_size)                     \
910     ( count * body_size <= PERL_ARENA_SIZE)             \
911     ? count * body_size                                 \
912     : FIT_ARENA0 (body_size)
913 #define FIT_ARENA(count,body_size)                      \
914     count                                               \
915     ? FIT_ARENAn (count, body_size)                     \
916     : FIT_ARENA0 (body_size)
917
918 /* Calculate the length to copy. Specifically work out the length less any
919    final padding the compiler needed to add.  See the comment in sv_upgrade
920    for why copying the padding proved to be a bug.  */
921
922 #define copy_length(type, last_member) \
923         STRUCT_OFFSET(type, last_member) \
924         + sizeof (((type*)SvANY((const SV *)0))->last_member)
925
926 static const struct body_details bodies_by_type[] = {
927     /* HEs use this offset for their arena.  */
928     { 0, 0, 0, SVt_NULL, FALSE, NONV, NOARENA, 0 },
929
930     /* IVs are in the head, so the allocation size is 0.  */
931     { 0,
932       sizeof(IV), /* This is used to copy out the IV body.  */
933       STRUCT_OFFSET(XPVIV, xiv_iv), SVt_IV, FALSE, NONV,
934       NOARENA /* IVS don't need an arena  */, 0
935     },
936
937     { sizeof(NV), sizeof(NV),
938       STRUCT_OFFSET(XPVNV, xnv_u),
939       SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) },
940
941     { sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur),
942       copy_length(XPV, xpv_len) - STRUCT_OFFSET(XPV, xpv_cur),
943       + STRUCT_OFFSET(XPV, xpv_cur),
944       SVt_PV, FALSE, NONV, HASARENA,
945       FIT_ARENA(0, sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur)) },
946
947     { sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur),
948       copy_length(XINVLIST, is_offset) - STRUCT_OFFSET(XPV, xpv_cur),
949       + STRUCT_OFFSET(XPV, xpv_cur),
950       SVt_INVLIST, TRUE, NONV, HASARENA,
951       FIT_ARENA(0, sizeof(XINVLIST) - STRUCT_OFFSET(XPV, xpv_cur)) },
952
953     { sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur),
954       copy_length(XPVIV, xiv_u) - STRUCT_OFFSET(XPV, xpv_cur),
955       + STRUCT_OFFSET(XPV, xpv_cur),
956       SVt_PVIV, FALSE, NONV, HASARENA,
957       FIT_ARENA(0, sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur)) },
958
959     { sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur),
960       copy_length(XPVNV, xnv_u) - STRUCT_OFFSET(XPV, xpv_cur),
961       + STRUCT_OFFSET(XPV, xpv_cur),
962       SVt_PVNV, FALSE, HADNV, HASARENA,
963       FIT_ARENA(0, sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur)) },
964
965     { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV,
966       HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
967
968     { sizeof(regexp),
969       sizeof(regexp),
970       0,
971       SVt_REGEXP, TRUE, NONV, HASARENA,
972       FIT_ARENA(0, sizeof(regexp))
973     },
974
975     { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV,
976       HASARENA, FIT_ARENA(0, sizeof(XPVGV)) },
977     
978     { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV,
979       HASARENA, FIT_ARENA(0, sizeof(XPVLV)) },
980
981     { sizeof(XPVAV),
982       copy_length(XPVAV, xav_alloc),
983       0,
984       SVt_PVAV, TRUE, NONV, HASARENA,
985       FIT_ARENA(0, sizeof(XPVAV)) },
986
987     { sizeof(XPVHV),
988       copy_length(XPVHV, xhv_max),
989       0,
990       SVt_PVHV, TRUE, NONV, HASARENA,
991       FIT_ARENA(0, sizeof(XPVHV)) },
992
993     { sizeof(XPVCV),
994       sizeof(XPVCV),
995       0,
996       SVt_PVCV, TRUE, NONV, HASARENA,
997       FIT_ARENA(0, sizeof(XPVCV)) },
998
999     { sizeof(XPVFM),
1000       sizeof(XPVFM),
1001       0,
1002       SVt_PVFM, TRUE, NONV, NOARENA,
1003       FIT_ARENA(20, sizeof(XPVFM)) },
1004
1005     { sizeof(XPVIO),
1006       sizeof(XPVIO),
1007       0,
1008       SVt_PVIO, TRUE, NONV, HASARENA,
1009       FIT_ARENA(24, sizeof(XPVIO)) },
1010 };
1011
1012 #define new_body_allocated(sv_type)             \
1013     (void *)((char *)S_new_body(aTHX_ sv_type)  \
1014              - bodies_by_type[sv_type].offset)
1015
1016 /* return a thing to the free list */
1017
1018 #define del_body(thing, root)                           \
1019     STMT_START {                                        \
1020         void ** const thing_copy = (void **)thing;      \
1021         *thing_copy = *root;                            \
1022         *root = (void*)thing_copy;                      \
1023     } STMT_END
1024
1025 #ifdef PURIFY
1026
1027 #define new_XNV()       safemalloc(sizeof(XPVNV))
1028 #define new_XPVNV()     safemalloc(sizeof(XPVNV))
1029 #define new_XPVMG()     safemalloc(sizeof(XPVMG))
1030
1031 #define del_XPVGV(p)    safefree(p)
1032
1033 #else /* !PURIFY */
1034
1035 #define new_XNV()       new_body_allocated(SVt_NV)
1036 #define new_XPVNV()     new_body_allocated(SVt_PVNV)
1037 #define new_XPVMG()     new_body_allocated(SVt_PVMG)
1038
1039 #define del_XPVGV(p)    del_body(p + bodies_by_type[SVt_PVGV].offset,   \
1040                                  &PL_body_roots[SVt_PVGV])
1041
1042 #endif /* PURIFY */
1043
1044 /* no arena for you! */
1045
1046 #define new_NOARENA(details) \
1047         safemalloc((details)->body_size + (details)->offset)
1048 #define new_NOARENAZ(details) \
1049         safecalloc((details)->body_size + (details)->offset, 1)
1050
1051 void *
1052 Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
1053                   const size_t arena_size)
1054 {
1055     void ** const root = &PL_body_roots[sv_type];
1056     struct arena_desc *adesc;
1057     struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
1058     unsigned int curr;
1059     char *start;
1060     const char *end;
1061     const size_t good_arena_size = Perl_malloc_good_size(arena_size);
1062 #if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
1063     dVAR;
1064 #endif
1065 #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
1066     static bool done_sanity_check;
1067
1068     /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
1069      * variables like done_sanity_check. */
1070     if (!done_sanity_check) {
1071         unsigned int i = SVt_LAST;
1072
1073         done_sanity_check = TRUE;
1074
1075         while (i--)
1076             assert (bodies_by_type[i].type == i);
1077     }
1078 #endif
1079
1080     assert(arena_size);
1081
1082     /* may need new arena-set to hold new arena */
1083     if (!aroot || aroot->curr >= aroot->set_size) {
1084         struct arena_set *newroot;
1085         Newxz(newroot, 1, struct arena_set);
1086         newroot->set_size = ARENAS_PER_SET;
1087         newroot->next = aroot;
1088         aroot = newroot;
1089         PL_body_arenas = (void *) newroot;
1090         DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot));
1091     }
1092
1093     /* ok, now have arena-set with at least 1 empty/available arena-desc */
1094     curr = aroot->curr++;
1095     adesc = &(aroot->set[curr]);
1096     assert(!adesc->arena);
1097     
1098     Newx(adesc->arena, good_arena_size, char);
1099     adesc->size = good_arena_size;
1100     adesc->utype = sv_type;
1101     DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", 
1102                           curr, (void*)adesc->arena, (UV)good_arena_size));
1103
1104     start = (char *) adesc->arena;
1105
1106     /* Get the address of the byte after the end of the last body we can fit.
1107        Remember, this is integer division:  */
1108     end = start + good_arena_size / body_size * body_size;
1109
1110     /* computed count doesn't reflect the 1st slot reservation */
1111 #if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
1112     DEBUG_m(PerlIO_printf(Perl_debug_log,
1113                           "arena %p end %p arena-size %d (from %d) type %d "
1114                           "size %d ct %d\n",
1115                           (void*)start, (void*)end, (int)good_arena_size,
1116                           (int)arena_size, sv_type, (int)body_size,
1117                           (int)good_arena_size / (int)body_size));
1118 #else
1119     DEBUG_m(PerlIO_printf(Perl_debug_log,
1120                           "arena %p end %p arena-size %d type %d size %d ct %d\n",
1121                           (void*)start, (void*)end,
1122                           (int)arena_size, sv_type, (int)body_size,
1123                           (int)good_arena_size / (int)body_size));
1124 #endif
1125     *root = (void *)start;
1126
1127     while (1) {
1128         /* Where the next body would start:  */
1129         char * const next = start + body_size;
1130
1131         if (next >= end) {
1132             /* This is the last body:  */
1133             assert(next == end);
1134
1135             *(void **)start = 0;
1136             return *root;
1137         }
1138
1139         *(void**) start = (void *)next;
1140         start = next;
1141     }
1142 }
1143
1144 /* grab a new thing from the free list, allocating more if necessary.
1145    The inline version is used for speed in hot routines, and the
1146    function using it serves the rest (unless PURIFY).
1147 */
1148 #define new_body_inline(xpv, sv_type) \
1149     STMT_START { \
1150         void ** const r3wt = &PL_body_roots[sv_type]; \
1151         xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt))      \
1152           ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \
1153                                              bodies_by_type[sv_type].body_size,\
1154                                              bodies_by_type[sv_type].arena_size)); \
1155         *(r3wt) = *(void**)(xpv); \
1156     } STMT_END
1157
1158 #ifndef PURIFY
1159
1160 STATIC void *
1161 S_new_body(pTHX_ const svtype sv_type)
1162 {
1163     void *xpv;
1164     new_body_inline(xpv, sv_type);
1165     return xpv;
1166 }
1167
1168 #endif
1169
1170 static const struct body_details fake_rv =
1171     { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 };
1172
1173 /*
1174 =for apidoc sv_upgrade
1175
1176 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1177 SV, then copies across as much information as possible from the old body.
1178 It croaks if the SV is already in a more complex form than requested.  You
1179 generally want to use the C<SvUPGRADE> macro wrapper, which checks the type
1180 before calling C<sv_upgrade>, and hence does not croak.  See also
1181 C<svtype>.
1182
1183 =cut
1184 */
1185
1186 void
1187 Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
1188 {
1189     void*       old_body;
1190     void*       new_body;
1191     const svtype old_type = SvTYPE(sv);
1192     const struct body_details *new_type_details;
1193     const struct body_details *old_type_details
1194         = bodies_by_type + old_type;
1195     SV *referant = NULL;
1196
1197     PERL_ARGS_ASSERT_SV_UPGRADE;
1198
1199     if (old_type == new_type)
1200         return;
1201
1202     /* This clause was purposefully added ahead of the early return above to
1203        the shared string hackery for (sort {$a <=> $b} keys %hash), with the
1204        inference by Nick I-S that it would fix other troublesome cases. See
1205        changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
1206
1207        Given that shared hash key scalars are no longer PVIV, but PV, there is
1208        no longer need to unshare so as to free up the IVX slot for its proper
1209        purpose. So it's safe to move the early return earlier.  */
1210
1211     if (new_type > SVt_PVMG && SvIsCOW(sv)) {
1212         sv_force_normal_flags(sv, 0);
1213     }
1214
1215     old_body = SvANY(sv);
1216
1217     /* Copying structures onto other structures that have been neatly zeroed
1218        has a subtle gotcha. Consider XPVMG
1219
1220        +------+------+------+------+------+-------+-------+
1221        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
1222        +------+------+------+------+------+-------+-------+
1223        0      4      8     12     16     20      24      28
1224
1225        where NVs are aligned to 8 bytes, so that sizeof that structure is
1226        actually 32 bytes long, with 4 bytes of padding at the end:
1227
1228        +------+------+------+------+------+-------+-------+------+
1229        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
1230        +------+------+------+------+------+-------+-------+------+
1231        0      4      8     12     16     20      24      28     32
1232
1233        so what happens if you allocate memory for this structure:
1234
1235        +------+------+------+------+------+-------+-------+------+------+...
1236        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
1237        +------+------+------+------+------+-------+-------+------+------+...
1238        0      4      8     12     16     20      24      28     32     36
1239
1240        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1241        expect, because you copy the area marked ??? onto GP. Now, ??? may have
1242        started out as zero once, but it's quite possible that it isn't. So now,
1243        rather than a nicely zeroed GP, you have it pointing somewhere random.
1244        Bugs ensue.
1245
1246        (In fact, GP ends up pointing at a previous GP structure, because the
1247        principle cause of the padding in XPVMG getting garbage is a copy of
1248        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob. Right now
1249        this happens to be moot because XPVGV has been re-ordered, with GP
1250        no longer after STASH)
1251
1252        So we are careful and work out the size of used parts of all the
1253        structures.  */
1254
1255     switch (old_type) {
1256     case SVt_NULL:
1257         break;
1258     case SVt_IV:
1259         if (SvROK(sv)) {
1260             referant = SvRV(sv);
1261             old_type_details = &fake_rv;
1262             if (new_type == SVt_NV)
1263                 new_type = SVt_PVNV;
1264         } else {
1265             if (new_type < SVt_PVIV) {
1266                 new_type = (new_type == SVt_NV)
1267                     ? SVt_PVNV : SVt_PVIV;
1268             }
1269         }
1270         break;
1271     case SVt_NV:
1272         if (new_type < SVt_PVNV) {
1273             new_type = SVt_PVNV;
1274         }
1275         break;
1276     case SVt_PV:
1277         assert(new_type > SVt_PV);
1278         assert(SVt_IV < SVt_PV);
1279         assert(SVt_NV < SVt_PV);
1280         break;
1281     case SVt_PVIV:
1282         break;
1283     case SVt_PVNV:
1284         break;
1285     case SVt_PVMG:
1286         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1287            there's no way that it can be safely upgraded, because perl.c
1288            expects to Safefree(SvANY(PL_mess_sv))  */
1289         assert(sv != PL_mess_sv);
1290         /* This flag bit is used to mean other things in other scalar types.
1291            Given that it only has meaning inside the pad, it shouldn't be set
1292            on anything that can get upgraded.  */
1293         assert(!SvPAD_TYPED(sv));
1294         break;
1295     default:
1296         if (UNLIKELY(old_type_details->cant_upgrade))
1297             Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf,
1298                        sv_reftype(sv, 0), (UV) old_type, (UV) new_type);
1299     }
1300
1301     if (UNLIKELY(old_type > new_type))
1302         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1303                 (int)old_type, (int)new_type);
1304
1305     new_type_details = bodies_by_type + new_type;
1306
1307     SvFLAGS(sv) &= ~SVTYPEMASK;
1308     SvFLAGS(sv) |= new_type;
1309
1310     /* This can't happen, as SVt_NULL is <= all values of new_type, so one of
1311        the return statements above will have triggered.  */
1312     assert (new_type != SVt_NULL);
1313     switch (new_type) {
1314     case SVt_IV:
1315         assert(old_type == SVt_NULL);
1316         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1317         SvIV_set(sv, 0);
1318         return;
1319     case SVt_NV:
1320         assert(old_type == SVt_NULL);
1321         SvANY(sv) = new_XNV();
1322         SvNV_set(sv, 0);
1323         return;
1324     case SVt_PVHV:
1325     case SVt_PVAV:
1326         assert(new_type_details->body_size);
1327
1328 #ifndef PURIFY  
1329         assert(new_type_details->arena);
1330         assert(new_type_details->arena_size);
1331         /* This points to the start of the allocated area.  */
1332         new_body_inline(new_body, new_type);
1333         Zero(new_body, new_type_details->body_size, char);
1334         new_body = ((char *)new_body) - new_type_details->offset;
1335 #else
1336         /* We always allocated the full length item with PURIFY. To do this
1337            we fake things so that arena is false for all 16 types..  */
1338         new_body = new_NOARENAZ(new_type_details);
1339 #endif
1340         SvANY(sv) = new_body;
1341         if (new_type == SVt_PVAV) {
1342             AvMAX(sv)   = -1;
1343             AvFILLp(sv) = -1;
1344             AvREAL_only(sv);
1345             if (old_type_details->body_size) {
1346                 AvALLOC(sv) = 0;
1347             } else {
1348                 /* It will have been zeroed when the new body was allocated.
1349                    Lets not write to it, in case it confuses a write-back
1350                    cache.  */
1351             }
1352         } else {
1353             assert(!SvOK(sv));
1354             SvOK_off(sv);
1355 #ifndef NODEFAULT_SHAREKEYS
1356             HvSHAREKEYS_on(sv);         /* key-sharing on by default */
1357 #endif
1358             /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */
1359             HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX;
1360         }
1361
1362         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1363            The target created by newSVrv also is, and it can have magic.
1364            However, it never has SvPVX set.
1365         */
1366         if (old_type == SVt_IV) {
1367             assert(!SvROK(sv));
1368         } else if (old_type >= SVt_PV) {
1369             assert(SvPVX_const(sv) == 0);
1370         }
1371
1372         if (old_type >= SVt_PVMG) {
1373             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic);
1374             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1375         } else {
1376             sv->sv_u.svu_array = NULL; /* or svu_hash  */
1377         }
1378         break;
1379
1380     case SVt_PVIV:
1381         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1382            no route from NV to PVIV, NOK can never be true  */
1383         assert(!SvNOKp(sv));
1384         assert(!SvNOK(sv));
1385     case SVt_PVIO:
1386     case SVt_PVFM:
1387     case SVt_PVGV:
1388     case SVt_PVCV:
1389     case SVt_PVLV:
1390     case SVt_INVLIST:
1391     case SVt_REGEXP:
1392     case SVt_PVMG:
1393     case SVt_PVNV:
1394     case SVt_PV:
1395
1396         assert(new_type_details->body_size);
1397         /* We always allocated the full length item with PURIFY. To do this
1398            we fake things so that arena is false for all 16 types..  */
1399         if(new_type_details->arena) {
1400             /* This points to the start of the allocated area.  */
1401             new_body_inline(new_body, new_type);
1402             Zero(new_body, new_type_details->body_size, char);
1403             new_body = ((char *)new_body) - new_type_details->offset;
1404         } else {
1405             new_body = new_NOARENAZ(new_type_details);
1406         }
1407         SvANY(sv) = new_body;
1408
1409         if (old_type_details->copy) {
1410             /* There is now the potential for an upgrade from something without
1411                an offset (PVNV or PVMG) to something with one (PVCV, PVFM)  */
1412             int offset = old_type_details->offset;
1413             int length = old_type_details->copy;
1414
1415             if (new_type_details->offset > old_type_details->offset) {
1416                 const int difference
1417                     = new_type_details->offset - old_type_details->offset;
1418                 offset += difference;
1419                 length -= difference;
1420             }
1421             assert (length >= 0);
1422                 
1423             Copy((char *)old_body + offset, (char *)new_body + offset, length,
1424                  char);
1425         }
1426
1427 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1428         /* If NV 0.0 is stores as all bits 0 then Zero() already creates a
1429          * correct 0.0 for us.  Otherwise, if the old body didn't have an
1430          * NV slot, but the new one does, then we need to initialise the
1431          * freshly created NV slot with whatever the correct bit pattern is
1432          * for 0.0  */
1433         if (old_type_details->zero_nv && !new_type_details->zero_nv
1434             && !isGV_with_GP(sv))
1435             SvNV_set(sv, 0);
1436 #endif
1437
1438         if (UNLIKELY(new_type == SVt_PVIO)) {
1439             IO * const io = MUTABLE_IO(sv);
1440             GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV);
1441
1442             SvOBJECT_on(io);
1443             /* Clear the stashcache because a new IO could overrule a package
1444                name */
1445             DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
1446             hv_clear(PL_stashcache);
1447
1448             SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
1449             IoPAGE_LEN(sv) = 60;
1450         }
1451         if (UNLIKELY(new_type == SVt_REGEXP))
1452             sv->sv_u.svu_rx = (regexp *)new_body;
1453         else if (old_type < SVt_PV) {
1454             /* referant will be NULL unless the old type was SVt_IV emulating
1455                SVt_RV */
1456             sv->sv_u.svu_rv = referant;
1457         }
1458         break;
1459     default:
1460         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu",
1461                    (unsigned long)new_type);
1462     }
1463
1464     if (old_type > SVt_IV) {
1465 #ifdef PURIFY
1466         safefree(old_body);
1467 #else
1468         /* Note that there is an assumption that all bodies of types that
1469            can be upgraded came from arenas. Only the more complex non-
1470            upgradable types are allowed to be directly malloc()ed.  */
1471         assert(old_type_details->arena);
1472         del_body((void*)((char*)old_body + old_type_details->offset),
1473                  &PL_body_roots[old_type]);
1474 #endif
1475     }
1476 }
1477
1478 /*
1479 =for apidoc sv_backoff
1480
1481 Remove any string offset.  You should normally use the C<SvOOK_off> macro
1482 wrapper instead.
1483
1484 =cut
1485 */
1486
1487 int
1488 Perl_sv_backoff(SV *const sv)
1489 {
1490     STRLEN delta;
1491     const char * const s = SvPVX_const(sv);
1492
1493     PERL_ARGS_ASSERT_SV_BACKOFF;
1494
1495     assert(SvOOK(sv));
1496     assert(SvTYPE(sv) != SVt_PVHV);
1497     assert(SvTYPE(sv) != SVt_PVAV);
1498
1499     SvOOK_offset(sv, delta);
1500     
1501     SvLEN_set(sv, SvLEN(sv) + delta);
1502     SvPV_set(sv, SvPVX(sv) - delta);
1503     Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1504     SvFLAGS(sv) &= ~SVf_OOK;
1505     return 0;
1506 }
1507
1508 /*
1509 =for apidoc sv_grow
1510
1511 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1512 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1513 Use the C<SvGROW> wrapper instead.
1514
1515 =cut
1516 */
1517
1518 static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
1519
1520 char *
1521 Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
1522 {
1523     char *s;
1524
1525     PERL_ARGS_ASSERT_SV_GROW;
1526
1527     if (SvROK(sv))
1528         sv_unref(sv);
1529     if (SvTYPE(sv) < SVt_PV) {
1530         sv_upgrade(sv, SVt_PV);
1531         s = SvPVX_mutable(sv);
1532     }
1533     else if (SvOOK(sv)) {       /* pv is offset? */
1534         sv_backoff(sv);
1535         s = SvPVX_mutable(sv);
1536         if (newlen > SvLEN(sv))
1537             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1538     }
1539     else
1540     {
1541         if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
1542         s = SvPVX_mutable(sv);
1543     }
1544
1545 #ifdef PERL_NEW_COPY_ON_WRITE
1546     /* the new COW scheme uses SvPVX(sv)[SvLEN(sv)-1] (if spare)
1547      * to store the COW count. So in general, allocate one more byte than
1548      * asked for, to make it likely this byte is always spare: and thus
1549      * make more strings COW-able.
1550      * If the new size is a big power of two, don't bother: we assume the
1551      * caller wanted a nice 2^N sized block and will be annoyed at getting
1552      * 2^N+1 */
1553     if (newlen & 0xff)
1554         newlen++;
1555 #endif
1556
1557 #if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
1558 #define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1559 #endif
1560
1561     if (newlen > SvLEN(sv)) {           /* need more room? */
1562         STRLEN minlen = SvCUR(sv);
1563         minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
1564         if (newlen < minlen)
1565             newlen = minlen;
1566 #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1567
1568         /* Don't round up on the first allocation, as odds are pretty good that
1569          * the initial request is accurate as to what is really needed */
1570         if (SvLEN(sv)) {
1571             newlen = PERL_STRLEN_ROUNDUP(newlen);
1572         }
1573 #endif
1574         if (SvLEN(sv) && s) {
1575             s = (char*)saferealloc(s, newlen);
1576         }
1577         else {
1578             s = (char*)safemalloc(newlen);
1579             if (SvPVX_const(sv) && SvCUR(sv)) {
1580                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1581             }
1582         }
1583         SvPV_set(sv, s);
1584 #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
1585         /* Do this here, do it once, do it right, and then we will never get
1586            called back into sv_grow() unless there really is some growing
1587            needed.  */
1588         SvLEN_set(sv, Perl_safesysmalloc_size(s));
1589 #else
1590         SvLEN_set(sv, newlen);
1591 #endif
1592     }
1593     return s;
1594 }
1595
1596 /*
1597 =for apidoc sv_setiv
1598
1599 Copies an integer into the given SV, upgrading first if necessary.
1600 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1601
1602 =cut
1603 */
1604
1605 void
1606 Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
1607 {
1608     PERL_ARGS_ASSERT_SV_SETIV;
1609
1610     SV_CHECK_THINKFIRST_COW_DROP(sv);
1611     switch (SvTYPE(sv)) {
1612     case SVt_NULL:
1613     case SVt_NV:
1614         sv_upgrade(sv, SVt_IV);
1615         break;
1616     case SVt_PV:
1617         sv_upgrade(sv, SVt_PVIV);
1618         break;
1619
1620     case SVt_PVGV:
1621         if (!isGV_with_GP(sv))
1622             break;
1623     case SVt_PVAV:
1624     case SVt_PVHV:
1625     case SVt_PVCV:
1626     case SVt_PVFM:
1627     case SVt_PVIO:
1628         /* diag_listed_as: Can't coerce %s to %s in %s */
1629         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1630                    OP_DESC(PL_op));
1631     default: NOOP;
1632     }
1633     (void)SvIOK_only(sv);                       /* validate number */
1634     SvIV_set(sv, i);
1635     SvTAINT(sv);
1636 }
1637
1638 /*
1639 =for apidoc sv_setiv_mg
1640
1641 Like C<sv_setiv>, but also handles 'set' magic.
1642
1643 =cut
1644 */
1645
1646 void
1647 Perl_sv_setiv_mg(pTHX_ SV *const sv, const IV i)
1648 {
1649     PERL_ARGS_ASSERT_SV_SETIV_MG;
1650
1651     sv_setiv(sv,i);
1652     SvSETMAGIC(sv);
1653 }
1654
1655 /*
1656 =for apidoc sv_setuv
1657
1658 Copies an unsigned integer into the given SV, upgrading first if necessary.
1659 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1660
1661 =cut
1662 */
1663
1664 void
1665 Perl_sv_setuv(pTHX_ SV *const sv, const UV u)
1666 {
1667     PERL_ARGS_ASSERT_SV_SETUV;
1668
1669     /* With the if statement to ensure that integers are stored as IVs whenever
1670        possible:
1671        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1672
1673        without
1674        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1675
1676        If you wish to remove the following if statement, so that this routine
1677        (and its callers) always return UVs, please benchmark to see what the
1678        effect is. Modern CPUs may be different. Or may not :-)
1679     */
1680     if (u <= (UV)IV_MAX) {
1681        sv_setiv(sv, (IV)u);
1682        return;
1683     }
1684     sv_setiv(sv, 0);
1685     SvIsUV_on(sv);
1686     SvUV_set(sv, u);
1687 }
1688
1689 /*
1690 =for apidoc sv_setuv_mg
1691
1692 Like C<sv_setuv>, but also handles 'set' magic.
1693
1694 =cut
1695 */
1696
1697 void
1698 Perl_sv_setuv_mg(pTHX_ SV *const sv, const UV u)
1699 {
1700     PERL_ARGS_ASSERT_SV_SETUV_MG;
1701
1702     sv_setuv(sv,u);
1703     SvSETMAGIC(sv);
1704 }
1705
1706 /*
1707 =for apidoc sv_setnv
1708
1709 Copies a double into the given SV, upgrading first if necessary.
1710 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1711
1712 =cut
1713 */
1714
1715 void
1716 Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
1717 {
1718     PERL_ARGS_ASSERT_SV_SETNV;
1719
1720     SV_CHECK_THINKFIRST_COW_DROP(sv);
1721     switch (SvTYPE(sv)) {
1722     case SVt_NULL:
1723     case SVt_IV:
1724         sv_upgrade(sv, SVt_NV);
1725         break;
1726     case SVt_PV:
1727     case SVt_PVIV:
1728         sv_upgrade(sv, SVt_PVNV);
1729         break;
1730
1731     case SVt_PVGV:
1732         if (!isGV_with_GP(sv))
1733             break;
1734     case SVt_PVAV:
1735     case SVt_PVHV:
1736     case SVt_PVCV:
1737     case SVt_PVFM:
1738     case SVt_PVIO:
1739         /* diag_listed_as: Can't coerce %s to %s in %s */
1740         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1741                    OP_DESC(PL_op));
1742     default: NOOP;
1743     }
1744     SvNV_set(sv, num);
1745     (void)SvNOK_only(sv);                       /* validate number */
1746     SvTAINT(sv);
1747 }
1748
1749 /*
1750 =for apidoc sv_setnv_mg
1751
1752 Like C<sv_setnv>, but also handles 'set' magic.
1753
1754 =cut
1755 */
1756
1757 void
1758 Perl_sv_setnv_mg(pTHX_ SV *const sv, const NV num)
1759 {
1760     PERL_ARGS_ASSERT_SV_SETNV_MG;
1761
1762     sv_setnv(sv,num);
1763     SvSETMAGIC(sv);
1764 }
1765
1766 /* Return a cleaned-up, printable version of sv, for non-numeric, or
1767  * not incrementable warning display.
1768  * Originally part of S_not_a_number().
1769  * The return value may be != tmpbuf.
1770  */
1771
1772 STATIC const char *
1773 S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
1774     const char *pv;
1775
1776      PERL_ARGS_ASSERT_SV_DISPLAY;
1777
1778      if (DO_UTF8(sv)) {
1779           SV *dsv = newSVpvs_flags("", SVs_TEMP);
1780           pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
1781      } else {
1782           char *d = tmpbuf;
1783           const char * const limit = tmpbuf + tmpbuf_size - 8;
1784           /* each *s can expand to 4 chars + "...\0",
1785              i.e. need room for 8 chars */
1786         
1787           const char *s = SvPVX_const(sv);
1788           const char * const end = s + SvCUR(sv);
1789           for ( ; s < end && d < limit; s++ ) {
1790                int ch = *s & 0xFF;
1791                if (! isASCII(ch) && !isPRINT_LC(ch)) {
1792                     *d++ = 'M';
1793                     *d++ = '-';
1794
1795                     /* Map to ASCII "equivalent" of Latin1 */
1796                     ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
1797                }
1798                if (ch == '\n') {
1799                     *d++ = '\\';
1800                     *d++ = 'n';
1801                }
1802                else if (ch == '\r') {
1803                     *d++ = '\\';
1804                     *d++ = 'r';
1805                }
1806                else if (ch == '\f') {
1807                     *d++ = '\\';
1808                     *d++ = 'f';
1809                }
1810                else if (ch == '\\') {
1811                     *d++ = '\\';
1812                     *d++ = '\\';
1813                }
1814                else if (ch == '\0') {
1815                     *d++ = '\\';
1816                     *d++ = '0';
1817                }
1818                else if (isPRINT_LC(ch))
1819                     *d++ = ch;
1820                else {
1821                     *d++ = '^';
1822                     *d++ = toCTRL(ch);
1823                }
1824           }
1825           if (s < end) {
1826                *d++ = '.';
1827                *d++ = '.';
1828                *d++ = '.';
1829           }
1830           *d = '\0';
1831           pv = tmpbuf;
1832     }
1833
1834     return pv;
1835 }
1836
1837 /* Print an "isn't numeric" warning, using a cleaned-up,
1838  * printable version of the offending string
1839  */
1840
1841 STATIC void
1842 S_not_a_number(pTHX_ SV *const sv)
1843 {
1844      char tmpbuf[64];
1845      const char *pv;
1846
1847      PERL_ARGS_ASSERT_NOT_A_NUMBER;
1848
1849      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1850
1851     if (PL_op)
1852         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1853                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1854                     "Argument \"%s\" isn't numeric in %s", pv,
1855                     OP_DESC(PL_op));
1856     else
1857         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1858                     /* diag_listed_as: Argument "%s" isn't numeric%s */
1859                     "Argument \"%s\" isn't numeric", pv);
1860 }
1861
1862 STATIC void
1863 S_not_incrementable(pTHX_ SV *const sv) {
1864      char tmpbuf[64];
1865      const char *pv;
1866
1867      PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
1868
1869      pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
1870
1871      Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1872                  "Argument \"%s\" treated as 0 in increment (++)", pv);
1873 }
1874
1875 /*
1876 =for apidoc looks_like_number
1877
1878 Test if the content of an SV looks like a number (or is a number).
1879 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1880 non-numeric warning), even if your atof() doesn't grok them.  Get-magic is
1881 ignored.
1882
1883 =cut
1884 */
1885
1886 I32
1887 Perl_looks_like_number(pTHX_ SV *const sv)
1888 {
1889     const char *sbegin;
1890     STRLEN len;
1891
1892     PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
1893
1894     if (SvPOK(sv) || SvPOKp(sv)) {
1895         sbegin = SvPV_nomg_const(sv, len);
1896     }
1897     else
1898         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1899     return grok_number(sbegin, len, NULL);
1900 }
1901
1902 STATIC bool
1903 S_glob_2number(pTHX_ GV * const gv)
1904 {
1905     PERL_ARGS_ASSERT_GLOB_2NUMBER;
1906
1907     /* We know that all GVs stringify to something that is not-a-number,
1908         so no need to test that.  */
1909     if (ckWARN(WARN_NUMERIC))
1910     {
1911         SV *const buffer = sv_newmortal();
1912         gv_efullname3(buffer, gv, "*");
1913         not_a_number(buffer);
1914     }
1915     /* We just want something true to return, so that S_sv_2iuv_common
1916         can tail call us and return true.  */
1917     return TRUE;
1918 }
1919
1920 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1921    until proven guilty, assume that things are not that bad... */
1922
1923 /*
1924    NV_PRESERVES_UV:
1925
1926    As 64 bit platforms often have an NV that doesn't preserve all bits of
1927    an IV (an assumption perl has been based on to date) it becomes necessary
1928    to remove the assumption that the NV always carries enough precision to
1929    recreate the IV whenever needed, and that the NV is the canonical form.
1930    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1931    precision as a side effect of conversion (which would lead to insanity
1932    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1933    1) to distinguish between IV/UV/NV slots that have a valid conversion cached
1934       where precision was lost, and IV/UV/NV slots that have a valid conversion
1935       which has lost no precision
1936    2) to ensure that if a numeric conversion to one form is requested that
1937       would lose precision, the precise conversion (or differently
1938       imprecise conversion) is also performed and cached, to prevent
1939       requests for different numeric formats on the same SV causing
1940       lossy conversion chains. (lossless conversion chains are perfectly
1941       acceptable (still))
1942
1943
1944    flags are used:
1945    SvIOKp is true if the IV slot contains a valid value
1946    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1947    SvNOKp is true if the NV slot contains a valid value
1948    SvNOK  is true only if the NV value is accurate
1949
1950    so
1951    while converting from PV to NV, check to see if converting that NV to an
1952    IV(or UV) would lose accuracy over a direct conversion from PV to
1953    IV(or UV). If it would, cache both conversions, return NV, but mark
1954    SV as IOK NOKp (ie not NOK).
1955
1956    While converting from PV to IV, check to see if converting that IV to an
1957    NV would lose accuracy over a direct conversion from PV to NV. If it
1958    would, cache both conversions, flag similarly.
1959
1960    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1961    correctly because if IV & NV were set NV *always* overruled.
1962    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1963    changes - now IV and NV together means that the two are interchangeable:
1964    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1965
1966    The benefit of this is that operations such as pp_add know that if
1967    SvIOK is true for both left and right operands, then integer addition
1968    can be used instead of floating point (for cases where the result won't
1969    overflow). Before, floating point was always used, which could lead to
1970    loss of precision compared with integer addition.
1971
1972    * making IV and NV equal status should make maths accurate on 64 bit
1973      platforms
1974    * may speed up maths somewhat if pp_add and friends start to use
1975      integers when possible instead of fp. (Hopefully the overhead in
1976      looking for SvIOK and checking for overflow will not outweigh the
1977      fp to integer speedup)
1978    * will slow down integer operations (callers of SvIV) on "inaccurate"
1979      values, as the change from SvIOK to SvIOKp will cause a call into
1980      sv_2iv each time rather than a macro access direct to the IV slot
1981    * should speed up number->string conversion on integers as IV is
1982      favoured when IV and NV are equally accurate
1983
1984    ####################################################################
1985    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1986    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1987    On the other hand, SvUOK is true iff UV.
1988    ####################################################################
1989
1990    Your mileage will vary depending your CPU's relative fp to integer
1991    performance ratio.
1992 */
1993
1994 #ifndef NV_PRESERVES_UV
1995 #  define IS_NUMBER_UNDERFLOW_IV 1
1996 #  define IS_NUMBER_UNDERFLOW_UV 2
1997 #  define IS_NUMBER_IV_AND_UV    2
1998 #  define IS_NUMBER_OVERFLOW_IV  4
1999 #  define IS_NUMBER_OVERFLOW_UV  5
2000
2001 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2002
2003 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
2004 STATIC int
2005 S_sv_2iuv_non_preserve(pTHX_ SV *const sv
2006 #  ifdef DEBUGGING
2007                        , I32 numtype
2008 #  endif
2009                        )
2010 {
2011     PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
2012     PERL_UNUSED_CONTEXT;
2013
2014     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));
2015     if (SvNVX(sv) < (NV)IV_MIN) {
2016         (void)SvIOKp_on(sv);
2017         (void)SvNOK_on(sv);
2018         SvIV_set(sv, IV_MIN);
2019         return IS_NUMBER_UNDERFLOW_IV;
2020     }
2021     if (SvNVX(sv) > (NV)UV_MAX) {
2022         (void)SvIOKp_on(sv);
2023         (void)SvNOK_on(sv);
2024         SvIsUV_on(sv);
2025         SvUV_set(sv, UV_MAX);
2026         return IS_NUMBER_OVERFLOW_UV;
2027     }
2028     (void)SvIOKp_on(sv);
2029     (void)SvNOK_on(sv);
2030     /* Can't use strtol etc to convert this string.  (See truth table in
2031        sv_2iv  */
2032     if (SvNVX(sv) <= (UV)IV_MAX) {
2033         SvIV_set(sv, I_V(SvNVX(sv)));
2034         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2035             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2036         } else {
2037             /* Integer is imprecise. NOK, IOKp */
2038         }
2039         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2040     }
2041     SvIsUV_on(sv);
2042     SvUV_set(sv, U_V(SvNVX(sv)));
2043     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2044         if (SvUVX(sv) == UV_MAX) {
2045             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2046                possibly be preserved by NV. Hence, it must be overflow.
2047                NOK, IOKp */
2048             return IS_NUMBER_OVERFLOW_UV;
2049         }
2050         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2051     } else {
2052         /* Integer is imprecise. NOK, IOKp */
2053     }
2054     return IS_NUMBER_OVERFLOW_IV;
2055 }
2056 #endif /* !NV_PRESERVES_UV*/
2057
2058 STATIC bool
2059 S_sv_2iuv_common(pTHX_ SV *const sv)
2060 {
2061     PERL_ARGS_ASSERT_SV_2IUV_COMMON;
2062
2063     if (SvNOKp(sv)) {
2064         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2065          * without also getting a cached IV/UV from it at the same time
2066          * (ie PV->NV conversion should detect loss of accuracy and cache
2067          * IV or UV at same time to avoid this. */
2068         /* IV-over-UV optimisation - choose to cache IV if possible */
2069
2070         if (SvTYPE(sv) == SVt_NV)
2071             sv_upgrade(sv, SVt_PVNV);
2072
2073         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2074         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2075            certainly cast into the IV range at IV_MAX, whereas the correct
2076            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2077            cases go to UV */
2078 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2079         if (Perl_isnan(SvNVX(sv))) {
2080             SvUV_set(sv, 0);
2081             SvIsUV_on(sv);
2082             return FALSE;
2083         }
2084 #endif
2085         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2086             SvIV_set(sv, I_V(SvNVX(sv)));
2087             if (SvNVX(sv) == (NV) SvIVX(sv)
2088 #ifndef NV_PRESERVES_UV
2089                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2090                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2091                 /* Don't flag it as "accurately an integer" if the number
2092                    came from a (by definition imprecise) NV operation, and
2093                    we're outside the range of NV integer precision */
2094 #endif
2095                 ) {
2096                 if (SvNOK(sv))
2097                     SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2098                 else {
2099                     /* scalar has trailing garbage, eg "42a" */
2100                 }
2101                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2102                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2103                                       PTR2UV(sv),
2104                                       SvNVX(sv),
2105                                       SvIVX(sv)));
2106
2107             } else {
2108                 /* IV not precise.  No need to convert from PV, as NV
2109                    conversion would already have cached IV if it detected
2110                    that PV->IV would be better than PV->NV->IV
2111                    flags already correct - don't set public IOK.  */
2112                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2113                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2114                                       PTR2UV(sv),
2115                                       SvNVX(sv),
2116                                       SvIVX(sv)));
2117             }
2118             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2119                but the cast (NV)IV_MIN rounds to a the value less (more
2120                negative) than IV_MIN which happens to be equal to SvNVX ??
2121                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2122                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2123                (NV)UVX == NVX are both true, but the values differ. :-(
2124                Hopefully for 2s complement IV_MIN is something like
2125                0x8000000000000000 which will be exact. NWC */
2126         }
2127         else {
2128             SvUV_set(sv, U_V(SvNVX(sv)));
2129             if (
2130                 (SvNVX(sv) == (NV) SvUVX(sv))
2131 #ifndef  NV_PRESERVES_UV
2132                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2133                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2134                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2135                 /* Don't flag it as "accurately an integer" if the number
2136                    came from a (by definition imprecise) NV operation, and
2137                    we're outside the range of NV integer precision */
2138 #endif
2139                 && SvNOK(sv)
2140                 )
2141                 SvIOK_on(sv);
2142             SvIsUV_on(sv);
2143             DEBUG_c(PerlIO_printf(Perl_debug_log,
2144                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2145                                   PTR2UV(sv),
2146                                   SvUVX(sv),
2147                                   SvUVX(sv)));
2148         }
2149     }
2150     else if (SvPOKp(sv)) {
2151         UV value;
2152         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2153         /* We want to avoid a possible problem when we cache an IV/ a UV which
2154            may be later translated to an NV, and the resulting NV is not
2155            the same as the direct translation of the initial string
2156            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2157            be careful to ensure that the value with the .456 is around if the
2158            NV value is requested in the future).
2159         
2160            This means that if we cache such an IV/a UV, we need to cache the
2161            NV as well.  Moreover, we trade speed for space, and do not
2162            cache the NV if we are sure it's not needed.
2163          */
2164
2165         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2166         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2167              == IS_NUMBER_IN_UV) {
2168             /* It's definitely an integer, only upgrade to PVIV */
2169             if (SvTYPE(sv) < SVt_PVIV)
2170                 sv_upgrade(sv, SVt_PVIV);
2171             (void)SvIOK_on(sv);
2172         } else if (SvTYPE(sv) < SVt_PVNV)
2173             sv_upgrade(sv, SVt_PVNV);
2174
2175         /* If NVs preserve UVs then we only use the UV value if we know that
2176            we aren't going to call atof() below. If NVs don't preserve UVs
2177            then the value returned may have more precision than atof() will
2178            return, even though value isn't perfectly accurate.  */
2179         if ((numtype & (IS_NUMBER_IN_UV
2180 #ifdef NV_PRESERVES_UV
2181                         | IS_NUMBER_NOT_INT
2182 #endif
2183             )) == IS_NUMBER_IN_UV) {
2184             /* This won't turn off the public IOK flag if it was set above  */
2185             (void)SvIOKp_on(sv);
2186
2187             if (!(numtype & IS_NUMBER_NEG)) {
2188                 /* positive */;
2189                 if (value <= (UV)IV_MAX) {
2190                     SvIV_set(sv, (IV)value);
2191                 } else {
2192                     /* it didn't overflow, and it was positive. */
2193                     SvUV_set(sv, value);
2194                     SvIsUV_on(sv);
2195                 }
2196             } else {
2197                 /* 2s complement assumption  */
2198                 if (value <= (UV)IV_MIN) {
2199                     SvIV_set(sv, -(IV)value);
2200                 } else {
2201                     /* Too negative for an IV.  This is a double upgrade, but
2202                        I'm assuming it will be rare.  */
2203                     if (SvTYPE(sv) < SVt_PVNV)
2204                         sv_upgrade(sv, SVt_PVNV);
2205                     SvNOK_on(sv);
2206                     SvIOK_off(sv);
2207                     SvIOKp_on(sv);
2208                     SvNV_set(sv, -(NV)value);
2209                     SvIV_set(sv, IV_MIN);
2210                 }
2211             }
2212         }
2213         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2214            will be in the previous block to set the IV slot, and the next
2215            block to set the NV slot.  So no else here.  */
2216         
2217         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2218             != IS_NUMBER_IN_UV) {
2219             /* It wasn't an (integer that doesn't overflow the UV). */
2220             SvNV_set(sv, Atof(SvPVX_const(sv)));
2221
2222             if (! numtype && ckWARN(WARN_NUMERIC))
2223                 not_a_number(sv);
2224
2225             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
2226                                   PTR2UV(sv), SvNVX(sv)));
2227
2228 #ifdef NV_PRESERVES_UV
2229             (void)SvIOKp_on(sv);
2230             (void)SvNOK_on(sv);
2231 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
2232             if (Perl_isnan(SvNVX(sv))) {
2233                 SvUV_set(sv, 0);
2234                 SvIsUV_on(sv);
2235                 return FALSE;
2236             }
2237 #endif
2238             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2239                 SvIV_set(sv, I_V(SvNVX(sv)));
2240                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2241                     SvIOK_on(sv);
2242                 } else {
2243                     NOOP;  /* Integer is imprecise. NOK, IOKp */
2244                 }
2245                 /* UV will not work better than IV */
2246             } else {
2247                 if (SvNVX(sv) > (NV)UV_MAX) {
2248                     SvIsUV_on(sv);
2249                     /* Integer is inaccurate. NOK, IOKp, is UV */
2250                     SvUV_set(sv, UV_MAX);
2251                 } else {
2252                     SvUV_set(sv, U_V(SvNVX(sv)));
2253                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2254                        NV preservse UV so can do correct comparison.  */
2255                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2256                         SvIOK_on(sv);
2257                     } else {
2258                         NOOP;   /* Integer is imprecise. NOK, IOKp, is UV */
2259                     }
2260                 }
2261                 SvIsUV_on(sv);
2262             }
2263 #else /* NV_PRESERVES_UV */
2264             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2265                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2266                 /* The IV/UV slot will have been set from value returned by
2267                    grok_number above.  The NV slot has just been set using
2268                    Atof.  */
2269                 SvNOK_on(sv);
2270                 assert (SvIOKp(sv));
2271             } else {
2272                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2273                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2274                     /* Small enough to preserve all bits. */
2275                     (void)SvIOKp_on(sv);
2276                     SvNOK_on(sv);
2277                     SvIV_set(sv, I_V(SvNVX(sv)));
2278                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2279                         SvIOK_on(sv);
2280                     /* Assumption: first non-preserved integer is < IV_MAX,
2281                        this NV is in the preserved range, therefore: */
2282                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2283                           < (UV)IV_MAX)) {
2284                         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);
2285                     }
2286                 } else {
2287                     /* IN_UV NOT_INT
2288                          0      0       already failed to read UV.
2289                          0      1       already failed to read UV.
2290                          1      0       you won't get here in this case. IV/UV
2291                                         slot set, public IOK, Atof() unneeded.
2292                          1      1       already read UV.
2293                        so there's no point in sv_2iuv_non_preserve() attempting
2294                        to use atol, strtol, strtoul etc.  */
2295 #  ifdef DEBUGGING
2296                     sv_2iuv_non_preserve (sv, numtype);
2297 #  else
2298                     sv_2iuv_non_preserve (sv);
2299 #  endif
2300                 }
2301             }
2302 #endif /* NV_PRESERVES_UV */
2303         /* It might be more code efficient to go through the entire logic above
2304            and conditionally set with SvIOKp_on() rather than SvIOK(), but it
2305            gets complex and potentially buggy, so more programmer efficient
2306            to do it this way, by turning off the public flags:  */
2307         if (!numtype)
2308             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK);
2309         }
2310     }
2311     else  {
2312         if (isGV_with_GP(sv))
2313             return glob_2number(MUTABLE_GV(sv));
2314
2315         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2316                 report_uninit(sv);
2317         if (SvTYPE(sv) < SVt_IV)
2318             /* Typically the caller expects that sv_any is not NULL now.  */
2319             sv_upgrade(sv, SVt_IV);
2320         /* Return 0 from the caller.  */
2321         return TRUE;
2322     }
2323     return FALSE;
2324 }
2325
2326 /*
2327 =for apidoc sv_2iv_flags
2328
2329 Return the integer value of an SV, doing any necessary string
2330 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2331 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2332
2333 =cut
2334 */
2335
2336 IV
2337 Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
2338 {
2339     PERL_ARGS_ASSERT_SV_2IV_FLAGS;
2340
2341     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2342          && SvTYPE(sv) != SVt_PVFM);
2343
2344     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2345         mg_get(sv);
2346
2347     if (SvROK(sv)) {
2348         if (SvAMAGIC(sv)) {
2349             SV * tmpstr;
2350             if (flags & SV_SKIP_OVERLOAD)
2351                 return 0;
2352             tmpstr = AMG_CALLunary(sv, numer_amg);
2353             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2354                 return SvIV(tmpstr);
2355             }
2356         }
2357         return PTR2IV(SvRV(sv));
2358     }
2359
2360     if (SvVALID(sv) || isREGEXP(sv)) {
2361         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2362            the same flag bit as SVf_IVisUV, so must not let them cache IVs.
2363            In practice they are extremely unlikely to actually get anywhere
2364            accessible by user Perl code - the only way that I'm aware of is when
2365            a constant subroutine which is used as the second argument to index.
2366
2367            Regexps have no SvIVX and SvNVX fields.
2368         */
2369         assert(isREGEXP(sv) || SvPOKp(sv));
2370         {
2371             UV value;
2372             const char * const ptr =
2373                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2374             const int numtype
2375                 = grok_number(ptr, SvCUR(sv), &value);
2376
2377             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2378                 == IS_NUMBER_IN_UV) {
2379                 /* It's definitely an integer */
2380                 if (numtype & IS_NUMBER_NEG) {
2381                     if (value < (UV)IV_MIN)
2382                         return -(IV)value;
2383                 } else {
2384                     if (value < (UV)IV_MAX)
2385                         return (IV)value;
2386                 }
2387             }
2388
2389             /* Quite wrong but no good choices. */
2390             if ((numtype & IS_NUMBER_INFINITY)) {
2391                 return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX;
2392             } else if ((numtype & IS_NUMBER_NAN)) {
2393                 return 0; /* So wrong. */
2394             }
2395
2396             if (!numtype) {
2397                 if (ckWARN(WARN_NUMERIC))
2398                     not_a_number(sv);
2399             }
2400             return I_V(Atof(ptr));
2401         }
2402     }
2403
2404     if (SvTHINKFIRST(sv)) {
2405 #ifdef PERL_OLD_COPY_ON_WRITE
2406         if (SvIsCOW(sv)) {
2407             sv_force_normal_flags(sv, 0);
2408         }
2409 #endif
2410         if (SvREADONLY(sv) && !SvOK(sv)) {
2411             if (ckWARN(WARN_UNINITIALIZED))
2412                 report_uninit(sv);
2413             return 0;
2414         }
2415     }
2416
2417     if (!SvIOKp(sv)) {
2418         if (S_sv_2iuv_common(aTHX_ sv))
2419             return 0;
2420     }
2421
2422     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2423         PTR2UV(sv),SvIVX(sv)));
2424     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2425 }
2426
2427 /*
2428 =for apidoc sv_2uv_flags
2429
2430 Return the unsigned integer value of an SV, doing any necessary string
2431 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2432 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2433
2434 =cut
2435 */
2436
2437 UV
2438 Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
2439 {
2440     PERL_ARGS_ASSERT_SV_2UV_FLAGS;
2441
2442     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2443         mg_get(sv);
2444
2445     if (SvROK(sv)) {
2446         if (SvAMAGIC(sv)) {
2447             SV *tmpstr;
2448             if (flags & SV_SKIP_OVERLOAD)
2449                 return 0;
2450             tmpstr = AMG_CALLunary(sv, numer_amg);
2451             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2452                 return SvUV(tmpstr);
2453             }
2454         }
2455         return PTR2UV(SvRV(sv));
2456     }
2457
2458     if (SvVALID(sv) || isREGEXP(sv)) {
2459         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2460            the same flag bit as SVf_IVisUV, so must not let them cache IVs.  
2461            Regexps have no SvIVX and SvNVX fields. */
2462         assert(isREGEXP(sv) || SvPOKp(sv));
2463         {
2464             UV value;
2465             const char * const ptr =
2466                 isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv);
2467             const int numtype
2468                 = grok_number(ptr, SvCUR(sv), &value);
2469
2470             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2471                 == IS_NUMBER_IN_UV) {
2472                 /* It's definitely an integer */
2473                 if (!(numtype & IS_NUMBER_NEG))
2474                     return value;
2475             }
2476
2477             /* Quite wrong but no good choices. */
2478             if ((numtype & IS_NUMBER_INFINITY)) {
2479                 return UV_MAX; /* So wrong. */
2480             } else if ((numtype & IS_NUMBER_NAN)) {
2481                 return 0; /* So wrong. */
2482             }
2483
2484             if (!numtype) {
2485                 if (ckWARN(WARN_NUMERIC))
2486                     not_a_number(sv);
2487             }
2488             return U_V(Atof(ptr));
2489         }
2490     }
2491
2492     if (SvTHINKFIRST(sv)) {
2493 #ifdef PERL_OLD_COPY_ON_WRITE
2494         if (SvIsCOW(sv)) {
2495             sv_force_normal_flags(sv, 0);
2496         }
2497 #endif
2498         if (SvREADONLY(sv) && !SvOK(sv)) {
2499             if (ckWARN(WARN_UNINITIALIZED))
2500                 report_uninit(sv);
2501             return 0;
2502         }
2503     }
2504
2505     if (!SvIOKp(sv)) {
2506         if (S_sv_2iuv_common(aTHX_ sv))
2507             return 0;
2508     }
2509
2510     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2511                           PTR2UV(sv),SvUVX(sv)));
2512     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2513 }
2514
2515 /*
2516 =for apidoc sv_2nv_flags
2517
2518 Return the num value of an SV, doing any necessary string or integer
2519 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
2520 Normally used via the C<SvNV(sv)> and C<SvNVx(sv)> macros.
2521
2522 =cut
2523 */
2524
2525 NV
2526 Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
2527 {
2528     PERL_ARGS_ASSERT_SV_2NV_FLAGS;
2529
2530     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2531          && SvTYPE(sv) != SVt_PVFM);
2532     if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
2533         /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
2534            the same flag bit as SVf_IVisUV, so must not let them cache NVs.
2535            Regexps have no SvIVX and SvNVX fields.  */
2536         const char *ptr;
2537         if (flags & SV_GMAGIC)
2538             mg_get(sv);
2539         if (SvNOKp(sv))
2540             return SvNVX(sv);
2541         if (SvPOKp(sv) && !SvIOKp(sv)) {
2542             ptr = SvPVX_const(sv);
2543           grokpv:
2544             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2545                 !grok_number(ptr, SvCUR(sv), NULL))
2546                 not_a_number(sv);
2547             return Atof(ptr);
2548         }
2549         if (SvIOKp(sv)) {
2550             if (SvIsUV(sv))
2551                 return (NV)SvUVX(sv);
2552             else
2553                 return (NV)SvIVX(sv);
2554         }
2555         if (SvROK(sv)) {
2556             goto return_rok;
2557         }
2558         if (isREGEXP(sv)) {
2559             ptr = RX_WRAPPED((REGEXP *)sv);
2560             goto grokpv;
2561         }
2562         assert(SvTYPE(sv) >= SVt_PVMG);
2563         /* This falls through to the report_uninit near the end of the
2564            function. */
2565     } else if (SvTHINKFIRST(sv)) {
2566         if (SvROK(sv)) {
2567         return_rok:
2568             if (SvAMAGIC(sv)) {
2569                 SV *tmpstr;
2570                 if (flags & SV_SKIP_OVERLOAD)
2571                     return 0;
2572                 tmpstr = AMG_CALLunary(sv, numer_amg);
2573                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2574                     return SvNV(tmpstr);
2575                 }
2576             }
2577             return PTR2NV(SvRV(sv));
2578         }
2579 #ifdef PERL_OLD_COPY_ON_WRITE
2580         if (SvIsCOW(sv)) {
2581             sv_force_normal_flags(sv, 0);
2582         }
2583 #endif
2584         if (SvREADONLY(sv) && !SvOK(sv)) {
2585             if (ckWARN(WARN_UNINITIALIZED))
2586                 report_uninit(sv);
2587             return 0.0;
2588         }
2589     }
2590     if (SvTYPE(sv) < SVt_NV) {
2591         /* The logic to use SVt_PVNV if necessary is in sv_upgrade.  */
2592         sv_upgrade(sv, SVt_NV);
2593         DEBUG_c({
2594             STORE_NUMERIC_LOCAL_SET_STANDARD();
2595             PerlIO_printf(Perl_debug_log,
2596                           "0x%"UVxf" num(%" NVgf ")\n",
2597                           PTR2UV(sv), SvNVX(sv));
2598             RESTORE_NUMERIC_LOCAL();
2599         });
2600     }
2601     else if (SvTYPE(sv) < SVt_PVNV)
2602         sv_upgrade(sv, SVt_PVNV);
2603     if (SvNOKp(sv)) {
2604         return SvNVX(sv);
2605     }
2606     if (SvIOKp(sv)) {
2607         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2608 #ifdef NV_PRESERVES_UV
2609         if (SvIOK(sv))
2610             SvNOK_on(sv);
2611         else
2612             SvNOKp_on(sv);
2613 #else
2614         /* Only set the public NV OK flag if this NV preserves the IV  */
2615         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2616         if (SvIOK(sv) &&
2617             SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2618                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2619             SvNOK_on(sv);
2620         else
2621             SvNOKp_on(sv);
2622 #endif
2623     }
2624     else if (SvPOKp(sv)) {
2625         UV value;
2626         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2627         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2628             not_a_number(sv);
2629 #ifdef NV_PRESERVES_UV
2630         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2631             == IS_NUMBER_IN_UV) {
2632             /* It's definitely an integer */
2633             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2634         } else {
2635             if ((numtype & IS_NUMBER_INFINITY)) {
2636                 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
2637             } else if ((numtype & IS_NUMBER_NAN)) {
2638                 SvNV_set(sv, NV_NAN);
2639             } else
2640                 SvNV_set(sv, Atof(SvPVX_const(sv)));
2641         }
2642         if (numtype)
2643             SvNOK_on(sv);
2644         else
2645             SvNOKp_on(sv);
2646 #else
2647         SvNV_set(sv, Atof(SvPVX_const(sv)));
2648         /* Only set the public NV OK flag if this NV preserves the value in
2649            the PV at least as well as an IV/UV would.
2650            Not sure how to do this 100% reliably. */
2651         /* if that shift count is out of range then Configure's test is
2652            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2653            UV_BITS */
2654         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2655             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2656             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2657         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2658             /* Can't use strtol etc to convert this string, so don't try.
2659                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2660             SvNOK_on(sv);
2661         } else {
2662             /* value has been set.  It may not be precise.  */
2663             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2664                 /* 2s complement assumption for (UV)IV_MIN  */
2665                 SvNOK_on(sv); /* Integer is too negative.  */
2666             } else {
2667                 SvNOKp_on(sv);
2668                 SvIOKp_on(sv);
2669
2670                 if (numtype & IS_NUMBER_NEG) {
2671                     SvIV_set(sv, -(IV)value);
2672                 } else if (value <= (UV)IV_MAX) {
2673                     SvIV_set(sv, (IV)value);
2674                 } else {
2675                     SvUV_set(sv, value);
2676                     SvIsUV_on(sv);
2677                 }
2678
2679                 if (numtype & IS_NUMBER_NOT_INT) {
2680                     /* I believe that even if the original PV had decimals,
2681                        they are lost beyond the limit of the FP precision.
2682                        However, neither is canonical, so both only get p
2683                        flags.  NWC, 2000/11/25 */
2684                     /* Both already have p flags, so do nothing */
2685                 } else {
2686                     const NV nv = SvNVX(sv);
2687                     /* XXX should this spot have NAN_COMPARE_BROKEN, too? */
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     DEBUG_c({
2736         STORE_NUMERIC_LOCAL_SET_STANDARD();
2737         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
2738                       PTR2UV(sv), SvNVX(sv));
2739         RESTORE_NUMERIC_LOCAL();
2740     });
2741     return SvNVX(sv);
2742 }
2743
2744 /*
2745 =for apidoc sv_2num
2746
2747 Return an SV with the numeric value of the source SV, doing any necessary
2748 reference or overload conversion.  You must use the C<SvNUM(sv)> macro to
2749 access this function.
2750
2751 =cut
2752 */
2753
2754 SV *
2755 Perl_sv_2num(pTHX_ SV *const sv)
2756 {
2757     PERL_ARGS_ASSERT_SV_2NUM;
2758
2759     if (!SvROK(sv))
2760         return sv;
2761     if (SvAMAGIC(sv)) {
2762         SV * const tmpsv = AMG_CALLunary(sv, numer_amg);
2763         TAINT_IF(tmpsv && SvTAINTED(tmpsv));
2764         if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2765             return sv_2num(tmpsv);
2766     }
2767     return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));
2768 }
2769
2770 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2771  * UV as a string towards the end of buf, and return pointers to start and
2772  * end of it.
2773  *
2774  * We assume that buf is at least TYPE_CHARS(UV) long.
2775  */
2776
2777 static char *
2778 S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob)
2779 {
2780     char *ptr = buf + TYPE_CHARS(UV);
2781     char * const ebuf = ptr;
2782     int sign;
2783
2784     PERL_ARGS_ASSERT_UIV_2BUF;
2785
2786     if (is_uv)
2787         sign = 0;
2788     else if (iv >= 0) {
2789         uv = iv;
2790         sign = 0;
2791     } else {
2792         uv = -iv;
2793         sign = 1;
2794     }
2795     do {
2796         *--ptr = '0' + (char)(uv % 10);
2797     } while (uv /= 10);
2798     if (sign)
2799         *--ptr = '-';
2800     *peob = ebuf;
2801     return ptr;
2802 }
2803
2804 /* Helper for sv_2pv_flags and sv_vcatpvfn_flags.  If the NV is an
2805  * infinity or a not-a-number, writes the appropriate strings to the
2806  * buffer, including a zero byte.  On success returns the written length,
2807  * excluding the zero byte, on failure (not an infinity, not a nan, or the
2808  * maxlen too small) returns zero. */
2809 STATIC size_t
2810 S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
2811     /* XXX this should be an assert */
2812     if (maxlen < 4) /* "Inf\0", "NaN\0" */
2813         return 0;
2814     else {
2815         char* s = buffer;
2816         /* isnan must be first due to NAN_COMPARE_BROKEN builds, since NAN might
2817            use the broken for NAN >/< ops in the inf check, and then the inf
2818            check returns true for NAN on NAN_COMPARE_BROKEN compilers */
2819         if (Perl_isnan(nv)) {
2820             *s++ = 'N';
2821             *s++ = 'a';
2822             *s++ = 'N';
2823             /* XXX optionally output the payload mantissa bits as
2824              * "(unsigned)" (to match the nan("...") C99 function,
2825              * or maybe as "(0xhhh...)"  would make more sense...
2826              * provide a format string so that the user can decide?
2827              * NOTE: would affect the maxlen and assert() logic.*/
2828         }
2829         else if (Perl_isinf(nv)) {
2830             if (nv < 0) {
2831                 if (maxlen < 5) /* "-Inf\0"  */
2832                     return 0;
2833                 *s++ = '-';
2834             }
2835             *s++ = 'I';
2836             *s++ = 'n';
2837             *s++ = 'f';
2838         }
2839
2840         else
2841             return 0;
2842         assert((s == buffer + 3) || (s == buffer + 4));
2843         *s++ = 0;
2844         return s - buffer - 1; /* -1: excluding the zero byte */
2845     }
2846 }
2847
2848 /*
2849 =for apidoc sv_2pv_flags
2850
2851 Returns a pointer to the string value of an SV, and sets *lp to its length.
2852 If flags includes SV_GMAGIC, does an mg_get() first.  Coerces sv to a
2853 string if necessary.  Normally invoked via the C<SvPV_flags> macro.
2854 C<sv_2pv()> and C<sv_2pv_nomg> usually end up here too.
2855
2856 =cut
2857 */
2858
2859 char *
2860 Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
2861 {
2862     char *s;
2863
2864     PERL_ARGS_ASSERT_SV_2PV_FLAGS;
2865
2866     assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
2867          && SvTYPE(sv) != SVt_PVFM);
2868     if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
2869         mg_get(sv);
2870     if (SvROK(sv)) {
2871         if (SvAMAGIC(sv)) {
2872             SV *tmpstr;
2873             if (flags & SV_SKIP_OVERLOAD)
2874                 return NULL;
2875             tmpstr = AMG_CALLunary(sv, string_amg);
2876             TAINT_IF(tmpstr && SvTAINTED(tmpstr));
2877             if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2878                 /* Unwrap this:  */
2879                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
2880                  */
2881
2882                 char *pv;
2883                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2884                     if (flags & SV_CONST_RETURN) {
2885                         pv = (char *) SvPVX_const(tmpstr);
2886                     } else {
2887                         pv = (flags & SV_MUTABLE_RETURN)
2888                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2889                     }
2890                     if (lp)
2891                         *lp = SvCUR(tmpstr);
2892                 } else {
2893                     pv = sv_2pv_flags(tmpstr, lp, flags);
2894                 }
2895                 if (SvUTF8(tmpstr))
2896                     SvUTF8_on(sv);
2897                 else
2898                     SvUTF8_off(sv);
2899                 return pv;
2900             }
2901         }
2902         {
2903             STRLEN len;
2904             char *retval;
2905             char *buffer;
2906             SV *const referent = SvRV(sv);
2907
2908             if (!referent) {
2909                 len = 7;
2910                 retval = buffer = savepvn("NULLREF", len);
2911             } else if (SvTYPE(referent) == SVt_REGEXP &&
2912                        (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
2913                         amagic_is_enabled(string_amg))) {
2914                 REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
2915
2916                 assert(re);
2917                         
2918                 /* If the regex is UTF-8 we want the containing scalar to
2919                    have an UTF-8 flag too */
2920                 if (RX_UTF8(re))
2921                     SvUTF8_on(sv);
2922                 else
2923                     SvUTF8_off(sv);     
2924
2925                 if (lp)
2926                     *lp = RX_WRAPLEN(re);
2927  
2928                 return RX_WRAPPED(re);
2929             } else {
2930                 const char *const typestr = sv_reftype(referent, 0);
2931                 const STRLEN typelen = strlen(typestr);
2932                 UV addr = PTR2UV(referent);
2933                 const char *stashname = NULL;
2934                 STRLEN stashnamelen = 0; /* hush, gcc */
2935                 const char *buffer_end;
2936
2937                 if (SvOBJECT(referent)) {
2938                     const HEK *const name = HvNAME_HEK(SvSTASH(referent));
2939
2940                     if (name) {
2941                         stashname = HEK_KEY(name);
2942                         stashnamelen = HEK_LEN(name);
2943
2944                         if (HEK_UTF8(name)) {
2945                             SvUTF8_on(sv);
2946                         } else {
2947                             SvUTF8_off(sv);
2948                         }
2949                     } else {
2950                         stashname = "__ANON__";
2951                         stashnamelen = 8;
2952                     }
2953                     len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
2954                         + 2 * sizeof(UV) + 2 /* )\0 */;
2955                 } else {
2956                     len = typelen + 3 /* (0x */
2957                         + 2 * sizeof(UV) + 2 /* )\0 */;
2958                 }
2959
2960                 Newx(buffer, len, char);
2961                 buffer_end = retval = buffer + len;
2962
2963                 /* Working backwards  */
2964                 *--retval = '\0';
2965                 *--retval = ')';
2966                 do {
2967                     *--retval = PL_hexdigit[addr & 15];
2968                 } while (addr >>= 4);
2969                 *--retval = 'x';
2970                 *--retval = '0';
2971                 *--retval = '(';
2972
2973                 retval -= typelen;
2974                 memcpy(retval, typestr, typelen);
2975
2976                 if (stashname) {
2977                     *--retval = '=';
2978                     retval -= stashnamelen;
2979                     memcpy(retval, stashname, stashnamelen);
2980                 }
2981                 /* retval may not necessarily have reached the start of the
2982                    buffer here.  */
2983                 assert (retval >= buffer);
2984
2985                 len = buffer_end - retval - 1; /* -1 for that \0  */
2986             }
2987             if (lp)
2988                 *lp = len;
2989             SAVEFREEPV(buffer);
2990             return retval;
2991         }
2992     }
2993
2994     if (SvPOKp(sv)) {
2995         if (lp)
2996             *lp = SvCUR(sv);
2997         if (flags & SV_MUTABLE_RETURN)
2998             return SvPVX_mutable(sv);
2999         if (flags & SV_CONST_RETURN)
3000             return (char *)SvPVX_const(sv);
3001         return SvPVX(sv);
3002     }
3003
3004     if (SvIOK(sv)) {
3005         /* I'm assuming that if both IV and NV are equally valid then
3006            converting the IV is going to be more efficient */
3007         const U32 isUIOK = SvIsUV(sv);
3008         char buf[TYPE_CHARS(UV)];
3009         char *ebuf, *ptr;
3010         STRLEN len;
3011
3012         if (SvTYPE(sv) < SVt_PVIV)
3013             sv_upgrade(sv, SVt_PVIV);
3014         ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf);
3015         len = ebuf - ptr;
3016         /* inlined from sv_setpvn */
3017         s = SvGROW_mutable(sv, len + 1);
3018         Move(ptr, s, len, char);
3019         s += len;
3020         *s = '\0';
3021         SvPOK_on(sv);
3022     }
3023     else if (SvNOK(sv)) {
3024         if (SvTYPE(sv) < SVt_PVNV)
3025             sv_upgrade(sv, SVt_PVNV);
3026         if (SvNVX(sv) == 0.0
3027 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
3028             && !Perl_isnan(SvNVX(sv))
3029 #endif
3030         ) {
3031             s = SvGROW_mutable(sv, 2);
3032             *s++ = '0';
3033             *s = '\0';
3034         } else {
3035             /* The +20 is pure guesswork.  Configure test needed. --jhi */
3036             STRLEN size = NV_DIG + 20;
3037             STRLEN len;
3038             s = SvGROW_mutable(sv, size);
3039
3040             len = S_infnan_2pv(SvNVX(sv), s, size);
3041             if (len > 0)
3042                 s += len;
3043             else {
3044                 dSAVE_ERRNO;
3045                 /* some Xenix systems wipe out errno here */
3046
3047 #ifndef USE_LOCALE_NUMERIC
3048                 PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3049                 SvPOK_on(sv);
3050 #else
3051                 {
3052                     DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
3053                     PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
3054
3055                     /* If the radix character is UTF-8, and actually is in the
3056                      * output, turn on the UTF-8 flag for the scalar */
3057                     if (PL_numeric_local
3058                         && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
3059                         && instr(s, SvPVX_const(PL_numeric_radix_sv)))
3060                         {
3061                             SvUTF8_on(sv);
3062                         }
3063                     RESTORE_LC_NUMERIC();
3064                 }
3065
3066                 /* We don't call SvPOK_on(), because it may come to
3067                  * pass that the locale changes so that the
3068                  * stringification we just did is no longer correct.  We
3069                  * will have to re-stringify every time it is needed */
3070 #endif
3071                 RESTORE_ERRNO;
3072             }
3073             while (*s) s++;
3074         }
3075     }
3076     else if (isGV_with_GP(sv)) {
3077         GV *const gv = MUTABLE_GV(sv);
3078         SV *const buffer = sv_newmortal();
3079
3080         gv_efullname3(buffer, gv, "*");
3081
3082         assert(SvPOK(buffer));
3083         if (SvUTF8(buffer))
3084             SvUTF8_on(sv);
3085         if (lp)
3086             *lp = SvCUR(buffer);
3087         return SvPVX(buffer);
3088     }
3089     else if (isREGEXP(sv)) {
3090         if (lp) *lp = RX_WRAPLEN((REGEXP *)sv);
3091         return RX_WRAPPED((REGEXP *)sv);
3092     }
3093     else {
3094         if (lp)
3095             *lp = 0;
3096         if (flags & SV_UNDEF_RETURNS_NULL)
3097             return NULL;
3098         if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3099             report_uninit(sv);
3100         /* Typically the caller expects that sv_any is not NULL now.  */
3101         if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
3102             sv_upgrade(sv, SVt_PV);
3103         return (char *)"";
3104     }
3105
3106     {
3107         const STRLEN len = s - SvPVX_const(sv);
3108         if (lp) 
3109             *lp = len;
3110         SvCUR_set(sv, len);
3111     }
3112     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3113                           PTR2UV(sv),SvPVX_const(sv)));
3114     if (flags & SV_CONST_RETURN)
3115         return (char *)SvPVX_const(sv);
3116     if (flags & SV_MUTABLE_RETURN)
3117         return SvPVX_mutable(sv);
3118     return SvPVX(sv);
3119 }
3120
3121 /*
3122 =for apidoc sv_copypv
3123
3124 Copies a stringified representation of the source SV into the
3125 destination SV.  Automatically performs any necessary mg_get and
3126 coercion of numeric values into strings.  Guaranteed to preserve
3127 UTF8 flag even from overloaded objects.  Similar in nature to
3128 sv_2pv[_flags] but operates directly on an SV instead of just the
3129 string.  Mostly uses sv_2pv_flags to do its work, except when that
3130 would lose the UTF-8'ness of the PV.
3131
3132 =for apidoc sv_copypv_nomg
3133
3134 Like sv_copypv, but doesn't invoke get magic first.
3135
3136 =for apidoc sv_copypv_flags
3137
3138 Implementation of sv_copypv and sv_copypv_nomg.  Calls get magic iff flags
3139 include SV_GMAGIC.
3140
3141 =cut
3142 */
3143
3144 void
3145 Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
3146 {
3147     PERL_ARGS_ASSERT_SV_COPYPV;
3148
3149     sv_copypv_flags(dsv, ssv, 0);
3150 }
3151
3152 void
3153 Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
3154 {
3155     STRLEN len;
3156     const char *s;
3157
3158     PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
3159
3160     s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC));
3161     sv_setpvn(dsv,s,len);
3162     if (SvUTF8(ssv))
3163         SvUTF8_on(dsv);
3164     else
3165         SvUTF8_off(dsv);
3166 }
3167
3168 /*
3169 =for apidoc sv_2pvbyte
3170
3171 Return a pointer to the byte-encoded representation of the SV, and set *lp
3172 to its length.  May cause the SV to be downgraded from UTF-8 as a
3173 side-effect.
3174
3175 Usually accessed via the C<SvPVbyte> macro.
3176
3177 =cut
3178 */
3179
3180 char *
3181 Perl_sv_2pvbyte(pTHX_ SV *sv, STRLEN *const lp)
3182 {
3183     PERL_ARGS_ASSERT_SV_2PVBYTE;
3184
3185     SvGETMAGIC(sv);
3186     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3187      || isGV_with_GP(sv) || SvROK(sv)) {
3188         SV *sv2 = sv_newmortal();
3189         sv_copypv_nomg(sv2,sv);
3190         sv = sv2;
3191     }
3192     sv_utf8_downgrade(sv,0);
3193     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3194 }
3195
3196 /*
3197 =for apidoc sv_2pvutf8
3198
3199 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3200 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3201
3202 Usually accessed via the C<SvPVutf8> macro.
3203
3204 =cut
3205 */
3206
3207 char *
3208 Perl_sv_2pvutf8(pTHX_ SV *sv, STRLEN *const lp)
3209 {
3210     PERL_ARGS_ASSERT_SV_2PVUTF8;
3211
3212     if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
3213      || isGV_with_GP(sv) || SvROK(sv))
3214         sv = sv_mortalcopy(sv);
3215     else
3216         SvGETMAGIC(sv);
3217     sv_utf8_upgrade_nomg(sv);
3218     return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
3219 }
3220
3221
3222 /*
3223 =for apidoc sv_2bool
3224
3225 This macro is only used by sv_true() or its macro equivalent, and only if
3226 the latter's argument is neither SvPOK, SvIOK nor SvNOK.
3227 It calls sv_2bool_flags with the SV_GMAGIC flag.
3228
3229 =for apidoc sv_2bool_flags
3230
3231 This function is only used by sv_true() and friends,  and only if
3232 the latter's argument is neither SvPOK, SvIOK nor SvNOK.  If the flags
3233 contain SV_GMAGIC, then it does an mg_get() first.
3234
3235
3236 =cut
3237 */
3238
3239 bool
3240 Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
3241 {
3242     PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
3243
3244     restart:
3245     if(flags & SV_GMAGIC) SvGETMAGIC(sv);
3246
3247     if (!SvOK(sv))
3248         return 0;
3249     if (SvROK(sv)) {
3250         if (SvAMAGIC(sv)) {
3251             SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
3252             if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
3253                 bool svb;
3254                 sv = tmpsv;
3255                 if(SvGMAGICAL(sv)) {
3256                     flags = SV_GMAGIC;
3257                     goto restart; /* call sv_2bool */
3258                 }
3259                 /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
3260                 else if(!SvOK(sv)) {
3261                     svb = 0;
3262                 }
3263                 else if(SvPOK(sv)) {
3264                     svb = SvPVXtrue(sv);
3265                 }
3266                 else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
3267                     svb = (SvIOK(sv) && SvIVX(sv) != 0)
3268                         || (SvNOK(sv) && SvNVX(sv) != 0.0);
3269                 }
3270                 else {
3271                     flags = 0;
3272                     goto restart; /* call sv_2bool_nomg */
3273                 }
3274                 return cBOOL(svb);
3275             }
3276         }
3277         return SvRV(sv) != 0;
3278     }
3279     if (isREGEXP(sv))
3280         return
3281           RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
3282     return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
3283 }
3284
3285 /*
3286 =for apidoc sv_utf8_upgrade
3287
3288 Converts the PV of an SV to its UTF-8-encoded form.
3289 Forces the SV to string form if it is not already.
3290 Will C<mg_get> on C<sv> if appropriate.
3291 Always sets the SvUTF8 flag to avoid future validity checks even
3292 if the whole string is the same in UTF-8 as not.
3293 Returns the number of bytes in the converted string
3294
3295 This is not a general purpose byte encoding to Unicode interface:
3296 use the Encode extension for that.
3297
3298 =for apidoc sv_utf8_upgrade_nomg
3299
3300 Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
3301
3302 =for apidoc sv_utf8_upgrade_flags
3303
3304 Converts the PV of an SV to its UTF-8-encoded form.
3305 Forces the SV to string form if it is not already.
3306 Always sets the SvUTF8 flag to avoid future validity checks even
3307 if all the bytes are invariant in UTF-8.
3308 If C<flags> has C<SV_GMAGIC> bit set,
3309 will C<mg_get> on C<sv> if appropriate, else not.
3310
3311 If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
3312 will expand when converted to UTF-8, and skips the extra work of checking for
3313 that.  Typically this flag is used by a routine that has already parsed the
3314 string and found such characters, and passes this information on so that the
3315 work doesn't have to be repeated.
3316
3317 Returns the number of bytes in the converted string.
3318
3319 This is not a general purpose byte encoding to Unicode interface:
3320 use the Encode extension for that.
3321
3322 =for apidoc sv_utf8_upgrade_flags_grow
3323
3324 Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
3325 the number of unused bytes the string of 'sv' is guaranteed to have free after
3326 it upon return.  This allows the caller to reserve extra space that it intends
3327 to fill, to avoid extra grows.
3328
3329 C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
3330 are implemented in terms of this function.
3331
3332 Returns the number of bytes in the converted string (not including the spares).
3333
3334 =cut
3335
3336 (One might think that the calling routine could pass in the position of the
3337 first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
3338 have to be found again.  But that is not the case, because typically when the
3339 caller is likely to use this flag, it won't be calling this routine unless it
3340 finds something that won't fit into a byte.  Otherwise it tries to not upgrade
3341 and just use bytes.  But some things that do fit into a byte are variants in
3342 utf8, and the caller may not have been keeping track of these.)
3343
3344 If the routine itself changes the string, it adds a trailing C<NUL>.  Such a
3345 C<NUL> isn't guaranteed due to having other routines do the work in some input
3346 cases, or if the input is already flagged as being in utf8.
3347
3348 The speed of this could perhaps be improved for many cases if someone wanted to
3349 write a fast function that counts the number of variant characters in a string,
3350 especially if it could return the position of the first one.
3351
3352 */
3353
3354 STRLEN
3355 Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
3356 {
3357     PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
3358
3359     if (sv == &PL_sv_undef)
3360         return 0;
3361     if (!SvPOK_nog(sv)) {
3362         STRLEN len = 0;
3363         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3364             (void) sv_2pv_flags(sv,&len, flags);
3365             if (SvUTF8(sv)) {
3366                 if (extra) SvGROW(sv, SvCUR(sv) + extra);
3367                 return len;
3368             }
3369         } else {
3370             (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC);
3371         }
3372     }
3373
3374     if (SvUTF8(sv)) {
3375         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3376         return SvCUR(sv);
3377     }
3378
3379     if (SvIsCOW(sv)) {
3380         S_sv_uncow(aTHX_ sv, 0);
3381     }
3382
3383     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) {
3384         sv_recode_to_utf8(sv, PL_encoding);
3385         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3386         return SvCUR(sv);
3387     }
3388
3389     if (SvCUR(sv) == 0) {
3390         if (extra) SvGROW(sv, extra);
3391     } else { /* Assume Latin-1/EBCDIC */
3392         /* This function could be much more efficient if we
3393          * had a FLAG in SVs to signal if there are any variant
3394          * chars in the PV.  Given that there isn't such a flag
3395          * make the loop as fast as possible (although there are certainly ways
3396          * to speed this up, eg. through vectorization) */
3397         U8 * s = (U8 *) SvPVX_const(sv);
3398         U8 * e = (U8 *) SvEND(sv);
3399         U8 *t = s;
3400         STRLEN two_byte_count = 0;
3401         
3402         if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8;
3403
3404         /* See if really will need to convert to utf8.  We mustn't rely on our
3405          * incoming SV being well formed and having a trailing '\0', as certain
3406          * code in pp_formline can send us partially built SVs. */
3407
3408         while (t < e) {
3409             const U8 ch = *t++;
3410             if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
3411
3412             t--;    /* t already incremented; re-point to first variant */
3413             two_byte_count = 1;
3414             goto must_be_utf8;
3415         }
3416
3417         /* utf8 conversion not needed because all are invariants.  Mark as
3418          * UTF-8 even if no variant - saves scanning loop */
3419         SvUTF8_on(sv);
3420         if (extra) SvGROW(sv, SvCUR(sv) + extra);
3421         return SvCUR(sv);
3422
3423 must_be_utf8:
3424
3425         /* Here, the string should be converted to utf8, either because of an
3426          * input flag (two_byte_count = 0), or because a character that
3427          * requires 2 bytes was found (two_byte_count = 1).  t points either to
3428          * the beginning of the string (if we didn't examine anything), or to
3429          * the first variant.  In either case, everything from s to t - 1 will
3430          * occupy only 1 byte each on output.
3431          *
3432          * There are two main ways to convert.  One is to create a new string
3433          * and go through the input starting from the beginning, appending each
3434          * converted value onto the new string as we go along.  It's probably
3435          * best to allocate enough space in the string for the worst possible
3436          * case rather than possibly running out of space and having to
3437          * reallocate and then copy what we've done so far.  Since everything
3438          * from s to t - 1 is invariant, the destination can be initialized
3439          * with these using a fast memory copy
3440          *
3441          * The other way is to figure out exactly how big the string should be
3442          * by parsing the entire input.  Then you don't have to make it big
3443          * enough to handle the worst possible case, and more importantly, if
3444          * the string you already have is large enough, you don't have to
3445          * allocate a new string, you can copy the last character in the input
3446          * string to the final position(s) that will be occupied by the
3447          * converted string and go backwards, stopping at t, since everything
3448          * before that is invariant.
3449          *
3450          * There are advantages and disadvantages to each method.
3451          *
3452          * In the first method, we can allocate a new string, do the memory
3453          * copy from the s to t - 1, and then proceed through the rest of the
3454          * string byte-by-byte.
3455          *
3456          * In the second method, we proceed through the rest of the input
3457          * string just calculating how big the converted string will be.  Then
3458          * there are two cases:
3459          *  1)  if the string has enough extra space to handle the converted
3460          *      value.  We go backwards through the string, converting until we
3461          *      get to the position we are at now, and then stop.  If this
3462          *      position is far enough along in the string, this method is
3463          *      faster than the other method.  If the memory copy were the same
3464          *      speed as the byte-by-byte loop, that position would be about
3465          *      half-way, as at the half-way mark, parsing to the end and back
3466          *      is one complete string's parse, the same amount as starting
3467          *      over and going all the way through.  Actually, it would be
3468          *      somewhat less than half-way, as it's faster to just count bytes
3469          *      than to also copy, and we don't have the overhead of allocating
3470          *      a new string, changing the scalar to use it, and freeing the
3471          *      existing one.  But if the memory copy is fast, the break-even
3472          *      point is somewhere after half way.  The counting loop could be
3473          *      sped up by vectorization, etc, to move the break-even point
3474          *      further towards the beginning.
3475          *  2)  if the string doesn't have enough space to handle the converted
3476          *      value.  A new string will have to be allocated, and one might
3477          *      as well, given that, start from the beginning doing the first
3478          *      method.  We've spent extra time parsing the string and in
3479          *      exchange all we've gotten is that we know precisely how big to
3480          *      make the new one.  Perl is more optimized for time than space,
3481          *      so this case is a loser.
3482          * So what I've decided to do is not use the 2nd method unless it is
3483          * guaranteed that a new string won't have to be allocated, assuming
3484          * the worst case.  I also decided not to put any more conditions on it
3485          * than this, for now.  It seems likely that, since the worst case is
3486          * twice as big as the unknown portion of the string (plus 1), we won't
3487          * be guaranteed enough space, causing us to go to the first method,
3488          * unless the string is short, or the first variant character is near
3489          * the end of it.  In either of these cases, it seems best to use the
3490          * 2nd method.  The only circumstance I can think of where this would
3491          * be really slower is if the string had once had much more data in it
3492          * than it does now, but there is still a substantial amount in it  */
3493
3494         {
3495             STRLEN invariant_head = t - s;
3496             STRLEN size = invariant_head + (e - t) * 2 + 1 + extra;
3497             if (SvLEN(sv) < size) {
3498
3499                 /* Here, have decided to allocate a new string */
3500
3501                 U8 *dst;
3502                 U8 *d;
3503
3504                 Newx(dst, size, U8);
3505
3506                 /* If no known invariants at the beginning of the input string,
3507                  * set so starts from there.  Otherwise, can use memory copy to
3508                  * get up to where we are now, and then start from here */
3509
3510                 if (invariant_head == 0) {
3511                     d = dst;
3512                 } else {
3513                     Copy(s, dst, invariant_head, char);
3514                     d = dst + invariant_head;
3515                 }
3516
3517                 while (t < e) {
3518                     append_utf8_from_native_byte(*t, &d);
3519                     t++;
3520                 }
3521                 *d = '\0';
3522                 SvPV_free(sv); /* No longer using pre-existing string */
3523                 SvPV_set(sv, (char*)dst);
3524                 SvCUR_set(sv, d - dst);
3525                 SvLEN_set(sv, size);
3526             } else {
3527
3528                 /* Here, have decided to get the exact size of the string.
3529                  * Currently this happens only when we know that there is
3530                  * guaranteed enough space to fit the converted string, so
3531                  * don't have to worry about growing.  If two_byte_count is 0,
3532                  * then t points to the first byte of the string which hasn't
3533                  * been examined yet.  Otherwise two_byte_count is 1, and t
3534                  * points to the first byte in the string that will expand to
3535                  * two.  Depending on this, start examining at t or 1 after t.
3536                  * */
3537
3538                 U8 *d = t + two_byte_count;
3539
3540
3541                 /* Count up the remaining bytes that expand to two */
3542
3543                 while (d < e) {
3544                     const U8 chr = *d++;
3545                     if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
3546                 }
3547
3548                 /* The string will expand by just the number of bytes that
3549                  * occupy two positions.  But we are one afterwards because of
3550                  * the increment just above.  This is the place to put the
3551                  * trailing NUL, and to set the length before we decrement */
3552
3553                 d += two_byte_count;
3554                 SvCUR_set(sv, d - s);
3555                 *d-- = '\0';
3556
3557
3558                 /* Having decremented d, it points to the position to put the
3559                  * very last byte of the expanded string.  Go backwards through
3560                  * the string, copying and expanding as we go, stopping when we
3561                  * get to the part that is invariant the rest of the way down */
3562
3563                 e--;
3564                 while (e >= t) {
3565                     if (NATIVE_BYTE_IS_INVARIANT(*e)) {
3566                         *d-- = *e;
3567                     } else {
3568                         *d-- = UTF8_EIGHT_BIT_LO(*e);
3569                         *d-- = UTF8_EIGHT_BIT_HI(*e);
3570                     }
3571                     e--;
3572                 }
3573             }
3574
3575             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3576                 /* Update pos. We do it at the end rather than during
3577                  * the upgrade, to avoid slowing down the common case
3578                  * (upgrade without pos).
3579                  * pos can be stored as either bytes or characters.  Since
3580                  * this was previously a byte string we can just turn off
3581                  * the bytes flag. */
3582                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3583                 if (mg) {
3584                     mg->mg_flags &= ~MGf_BYTES;
3585                 }
3586                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3587                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3588             }
3589         }
3590     }
3591
3592     /* Mark as UTF-8 even if no variant - saves scanning loop */
3593     SvUTF8_on(sv);
3594     return SvCUR(sv);
3595 }
3596
3597 /*
3598 =for apidoc sv_utf8_downgrade
3599
3600 Attempts to convert the PV of an SV from characters to bytes.
3601 If the PV contains a character that cannot fit
3602 in a byte, this conversion will fail;
3603 in this case, either returns false or, if C<fail_ok> is not
3604 true, croaks.
3605
3606 This is not a general purpose Unicode to byte encoding interface:
3607 use the Encode extension for that.
3608
3609 =cut
3610 */
3611
3612 bool
3613 Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
3614 {
3615     PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
3616
3617     if (SvPOKp(sv) && SvUTF8(sv)) {
3618         if (SvCUR(sv)) {
3619             U8 *s;
3620             STRLEN len;
3621             int mg_flags = SV_GMAGIC;
3622
3623             if (SvIsCOW(sv)) {
3624                 S_sv_uncow(aTHX_ sv, 0);
3625             }
3626             if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3627                 /* update pos */
3628                 MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3629                 if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
3630                         mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
3631                                                 SV_GMAGIC|SV_CONST_RETURN);
3632                         mg_flags = 0; /* sv_pos_b2u does get magic */
3633                 }
3634                 if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3635                     magic_setutf8(sv,mg); /* clear UTF8 cache */
3636
3637             }
3638             s = (U8 *) SvPV_flags(sv, len, mg_flags);
3639
3640             if (!utf8_to_bytes(s, &len)) {
3641                 if (fail_ok)
3642                     return FALSE;
3643                 else {
3644                     if (PL_op)
3645                         Perl_croak(aTHX_ "Wide character in %s",
3646                                    OP_DESC(PL_op));
3647                     else
3648                         Perl_croak(aTHX_ "Wide character");
3649                 }
3650             }
3651             SvCUR_set(sv, len);
3652         }
3653     }
3654     SvUTF8_off(sv);
3655     return TRUE;
3656 }
3657
3658 /*
3659 =for apidoc sv_utf8_encode
3660
3661 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3662 flag off so that it looks like octets again.
3663
3664 =cut
3665 */
3666
3667 void
3668 Perl_sv_utf8_encode(pTHX_ SV *const sv)
3669 {
3670     PERL_ARGS_ASSERT_SV_UTF8_ENCODE;
3671
3672     if (SvREADONLY(sv)) {
3673         sv_force_normal_flags(sv, 0);
3674     }
3675     (void) sv_utf8_upgrade(sv);
3676     SvUTF8_off(sv);
3677 }
3678
3679 /*
3680 =for apidoc sv_utf8_decode
3681
3682 If the PV of the SV is an octet sequence in UTF-8
3683 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3684 so that it looks like a character.  If the PV contains only single-byte
3685 characters, the C<SvUTF8> flag stays off.
3686 Scans PV for validity and returns false if the PV is invalid UTF-8.
3687
3688 =cut
3689 */
3690
3691 bool
3692 Perl_sv_utf8_decode(pTHX_ SV *const sv)
3693 {
3694     PERL_ARGS_ASSERT_SV_UTF8_DECODE;
3695
3696     if (SvPOKp(sv)) {
3697         const U8 *start, *c;
3698         const U8 *e;
3699
3700         /* The octets may have got themselves encoded - get them back as
3701          * bytes
3702          */
3703         if (!sv_utf8_downgrade(sv, TRUE))
3704             return FALSE;
3705
3706         /* it is actually just a matter of turning the utf8 flag on, but
3707          * we want to make sure everything inside is valid utf8 first.
3708          */
3709         c = start = (const U8 *) SvPVX_const(sv);
3710         if (!is_utf8_string(c, SvCUR(sv)))
3711             return FALSE;
3712         e = (const U8 *) SvEND(sv);
3713         while (c < e) {
3714             const U8 ch = *c++;
3715             if (!UTF8_IS_INVARIANT(ch)) {
3716                 SvUTF8_on(sv);
3717                 break;
3718             }
3719         }
3720         if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3721             /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
3722                    after this, clearing pos.  Does anything on CPAN
3723                    need this? */
3724             /* adjust pos to the start of a UTF8 char sequence */
3725             MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
3726             if (mg) {
3727                 I32 pos = mg->mg_len;
3728                 if (pos > 0) {
3729                     for (c = start + pos; c > start; c--) {
3730                         if (UTF8_IS_START(*c))
3731                             break;
3732                     }
3733                     mg->mg_len  = c - start;
3734                 }
3735             }
3736             if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
3737                 magic_setutf8(sv,mg); /* clear UTF8 cache */
3738         }
3739     }
3740     return TRUE;
3741 }
3742
3743 /*
3744 =for apidoc sv_setsv
3745
3746 Copies the contents of the source SV C<ssv> into the destination SV
3747 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3748 function if the source SV needs to be reused.  Does not handle 'set' magic on
3749 destination SV.  Calls 'get' magic on source SV.  Loosely speaking, it
3750 performs a copy-by-value, obliterating any previous content of the
3751 destination.
3752
3753 You probably want to use one of the assortment of wrappers, such as
3754 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3755 C<SvSetMagicSV_nosteal>.
3756
3757 =for apidoc sv_setsv_flags
3758
3759 Copies the contents of the source SV C<ssv> into the destination SV
3760 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3761 function if the source SV needs to be reused.  Does not handle 'set' magic.
3762 Loosely speaking, it performs a copy-by-value, obliterating any previous
3763 content of the destination.
3764 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3765 C<ssv> if appropriate, else not.  If the C<flags>
3766 parameter has the C<SV_NOSTEAL> bit set then the
3767 buffers of temps will not be stolen.  <sv_setsv>
3768 and C<sv_setsv_nomg> are implemented in terms of this function.
3769
3770 You probably want to use one of the assortment of wrappers, such as
3771 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3772 C<SvSetMagicSV_nosteal>.
3773
3774 This is the primary function for copying scalars, and most other
3775 copy-ish functions and macros use this underneath.
3776
3777 =cut
3778 */
3779
3780 static void
3781 S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype)
3782 {
3783     I32 mro_changes = 0; /* 1 = method, 2 = isa, 3 = recursive isa */
3784     HV *old_stash = NULL;
3785
3786     PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB;
3787
3788     if (dtype != SVt_PVGV && !isGV_with_GP(dstr)) {
3789         const char * const name = GvNAME(sstr);
3790         const STRLEN len = GvNAMELEN(sstr);
3791         {
3792             if (dtype >= SVt_PV) {
3793                 SvPV_free(dstr);
3794                 SvPV_set(dstr, 0);
3795                 SvLEN_set(dstr, 0);
3796                 SvCUR_set(dstr, 0);
3797             }
3798             SvUPGRADE(dstr, SVt_PVGV);
3799             (void)SvOK_off(dstr);
3800             isGV_with_GP_on(dstr);
3801         }
3802         GvSTASH(dstr) = GvSTASH(sstr);
3803         if (GvSTASH(dstr))
3804             Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr);
3805         gv_name_set(MUTABLE_GV(dstr), name, len,
3806                         GV_ADD | (GvNAMEUTF8(sstr) ? SVf_UTF8 : 0 ));
3807         SvFAKE_on(dstr);        /* can coerce to non-glob */
3808     }
3809
3810     if(GvGP(MUTABLE_GV(sstr))) {
3811         /* If source has method cache entry, clear it */
3812         if(GvCVGEN(sstr)) {
3813             SvREFCNT_dec(GvCV(sstr));
3814             GvCV_set(sstr, NULL);
3815             GvCVGEN(sstr) = 0;
3816         }
3817         /* If source has a real method, then a method is
3818            going to change */
3819         else if(
3820          GvCV((const GV *)sstr) && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3821         ) {
3822             mro_changes = 1;
3823         }
3824     }
3825
3826     /* If dest already had a real method, that's a change as well */
3827     if(
3828         !mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)
3829      && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3830     ) {
3831         mro_changes = 1;
3832     }
3833
3834     /* We don't need to check the name of the destination if it was not a
3835        glob to begin with. */
3836     if(dtype == SVt_PVGV) {
3837         const char * const name = GvNAME((const GV *)dstr);
3838         if(
3839             strEQ(name,"ISA")
3840          /* The stash may have been detached from the symbol table, so
3841             check its name. */
3842          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
3843         )
3844             mro_changes = 2;
3845         else {
3846             const STRLEN len = GvNAMELEN(dstr);
3847             if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
3848              || (len == 1 && name[0] == ':')) {
3849                 mro_changes = 3;
3850
3851                 /* Set aside the old stash, so we can reset isa caches on
3852                    its subclasses. */
3853                 if((old_stash = GvHV(dstr)))
3854                     /* Make sure we do not lose it early. */
3855                     SvREFCNT_inc_simple_void_NN(
3856                      sv_2mortal((SV *)old_stash)
3857                     );
3858             }
3859         }
3860
3861         SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
3862     }
3863
3864     gp_free(MUTABLE_GV(dstr));
3865     GvINTRO_off(dstr);          /* one-shot flag */
3866     GvGP_set(dstr, gp_ref(GvGP(sstr)));
3867     if (SvTAINTED(sstr))
3868         SvTAINT(dstr);
3869     if (GvIMPORTED(dstr) != GVf_IMPORTED
3870         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3871         {
3872             GvIMPORTED_on(dstr);
3873         }
3874     GvMULTI_on(dstr);
3875     if(mro_changes == 2) {
3876       if (GvAV((const GV *)sstr)) {
3877         MAGIC *mg;
3878         SV * const sref = (SV *)GvAV((const GV *)dstr);
3879         if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
3880             if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
3881                 AV * const ary = newAV();
3882                 av_push(ary, mg->mg_obj); /* takes the refcount */
3883                 mg->mg_obj = (SV *)ary;
3884             }
3885             av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dstr));
3886         }
3887         else sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0);
3888       }
3889       mro_isa_changed_in(GvSTASH(dstr));
3890     }
3891     else if(mro_changes == 3) {
3892         HV * const stash = GvHV(dstr);
3893         if(old_stash ? (HV *)HvENAME_get(old_stash) : stash)
3894             mro_package_moved(
3895                 stash, old_stash,
3896                 (GV *)dstr, 0
3897             );
3898     }
3899     else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
3900     if (GvIO(dstr) && dtype == SVt_PVGV) {
3901         DEBUG_o(Perl_deb(aTHX_
3902                         "glob_assign_glob clearing PL_stashcache\n"));
3903         /* It's a cache. It will rebuild itself quite happily.
3904            It's a lot of effort to work out exactly which key (or keys)
3905            might be invalidated by the creation of the this file handle.
3906          */
3907         hv_clear(PL_stashcache);
3908     }
3909     return;
3910 }
3911
3912 static void
3913 S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
3914 {
3915     SV * const sref = SvRV(sstr);
3916     SV *dref;
3917     const int intro = GvINTRO(dstr);
3918     SV **location;
3919     U8 import_flag = 0;
3920     const U32 stype = SvTYPE(sref);
3921
3922     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
3923
3924     if (intro) {
3925         GvINTRO_off(dstr);      /* one-shot flag */
3926         GvLINE(dstr) = CopLINE(PL_curcop);
3927         GvEGV(dstr) = MUTABLE_GV(dstr);
3928     }
3929     GvMULTI_on(dstr);
3930     switch (stype) {
3931     case SVt_PVCV:
3932         location = (SV **) &(GvGP(dstr)->gp_cv); /* XXX bypassing GvCV_set */
3933         import_flag = GVf_IMPORTED_CV;
3934         goto common;
3935     case SVt_PVHV:
3936         location = (SV **) &GvHV(dstr);
3937         import_flag = GVf_IMPORTED_HV;
3938         goto common;
3939     case SVt_PVAV:
3940         location = (SV **) &GvAV(dstr);
3941         import_flag = GVf_IMPORTED_AV;
3942         goto common;
3943     case SVt_PVIO:
3944         location = (SV **) &GvIOp(dstr);
3945         goto common;
3946     case SVt_PVFM:
3947         location = (SV **) &GvFORM(dstr);
3948         goto common;
3949     default:
3950         location = &GvSV(dstr);
3951         import_flag = GVf_IMPORTED_SV;
3952     common:
3953         if (intro) {
3954             if (stype == SVt_PVCV) {
3955                 /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/
3956                 if (GvCVGEN(dstr)) {
3957                     SvREFCNT_dec(GvCV(dstr));
3958                     GvCV_set(dstr, NULL);
3959                     GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3960                 }
3961             }
3962             /* SAVEt_GVSLOT takes more room on the savestack and has more
3963                overhead in leave_scope than SAVEt_GENERIC_SV.  But for CVs
3964                leave_scope needs access to the GV so it can reset method
3965                caches.  We must use SAVEt_GVSLOT whenever the type is
3966                SVt_PVCV, even if the stash is anonymous, as the stash may
3967                gain a name somehow before leave_scope. */
3968             if (stype == SVt_PVCV) {
3969                 /* There is no save_pushptrptrptr.  Creating it for this
3970                    one call site would be overkill.  So inline the ss add
3971                    routines here. */
3972                 dSS_ADD;
3973                 SS_ADD_PTR(dstr);
3974                 SS_ADD_PTR(location);
3975                 SS_ADD_PTR(SvREFCNT_inc(*location));
3976                 SS_ADD_UV(SAVEt_GVSLOT);
3977                 SS_ADD_END(4);
3978             }
3979             else SAVEGENERICSV(*location);
3980         }
3981         dref = *location;
3982         if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) {
3983             CV* const cv = MUTABLE_CV(*location);
3984             if (cv) {
3985                 if (!GvCVGEN((const GV *)dstr) &&
3986                     (CvROOT(cv) || CvXSUB(cv)) &&
3987                     /* redundant check that avoids creating the extra SV
3988                        most of the time: */
3989                     (CvCONST(cv) || ckWARN(WARN_REDEFINE)))
3990                     {
3991                         SV * const new_const_sv =
3992                             CvCONST((const CV *)sref)
3993                                  ? cv_const_sv((const CV *)sref)
3994                                  : NULL;
3995                         report_redefined_cv(
3996                            sv_2mortal(Perl_newSVpvf(aTHX_
3997                                 "%"HEKf"::%"HEKf,
3998                                 HEKfARG(
3999                                  HvNAME_HEK(GvSTASH((const GV *)dstr))
4000                                 ),
4001                                 HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
4002                            )),
4003                            cv,
4004                            CvCONST((const CV *)sref) ? &new_const_sv : NULL
4005                         );
4006                     }
4007                 if (!intro)
4008                     cv_ckproto_len_flags(cv, (const GV *)dstr,
4009                                    SvPOK(sref) ? CvPROTO(sref) : NULL,
4010                                    SvPOK(sref) ? CvPROTOLEN(sref) : 0,
4011                                    SvPOK(sref) ? SvUTF8(sref) : 0);
4012             }
4013             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
4014             GvASSUMECV_on(dstr);
4015             if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */
4016                 if (intro && GvREFCNT(dstr) > 1) {
4017                     /* temporary remove extra savestack's ref */
4018                     --GvREFCNT(dstr);
4019                     gv_method_changed(dstr);
4020                     ++GvREFCNT(dstr);
4021                 }
4022                 else gv_method_changed(dstr);
4023             }
4024         }
4025         *location = SvREFCNT_inc_simple_NN(sref);
4026         if (import_flag && !(GvFLAGS(dstr) & import_flag)
4027             && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) {
4028             GvFLAGS(dstr) |= import_flag;
4029         }
4030         if (import_flag == GVf_IMPORTED_SV) {
4031             if (intro) {
4032                 dSS_ADD;
4033                 SS_ADD_PTR(gp_ref(GvGP(dstr)));
4034                 SS_ADD_UV(SAVEt_GP_ALIASED_SV
4035                         | cBOOL(GvALIASED_SV(dstr)) << 8);
4036                 SS_ADD_END(2);
4037             }
4038             /* Turn off the flag if sref is not referenced elsewhere,
4039                even by weak refs.  (SvRMAGICAL is a pessimistic check for
4040                back refs.)  */
4041             if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref))
4042                 GvALIASED_SV_off(dstr);
4043             else
4044                 GvALIASED_SV_on(dstr);
4045         }
4046         if (stype == SVt_PVHV) {
4047             const char * const name = GvNAME((GV*)dstr);
4048             const STRLEN len = GvNAMELEN(dstr);
4049             if (
4050                 (
4051                    (len > 1 && name[len-2] == ':' && name[len-1] == ':')
4052                 || (len == 1 && name[0] == ':')
4053                 )
4054              && (!dref || HvENAME_get(dref))
4055             ) {
4056                 mro_package_moved(
4057                     (HV *)sref, (HV *)dref,
4058                     (GV *)dstr, 0
4059                 );
4060             }
4061         }
4062         else if (
4063             stype == SVt_PVAV && sref != dref
4064          && strEQ(GvNAME((GV*)dstr), "ISA")
4065          /* The stash may have been detached from the symbol table, so
4066             check its name before doing anything. */
4067          && GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
4068         ) {
4069             MAGIC *mg;
4070             MAGIC * const omg = dref && SvSMAGICAL(dref)
4071                                  ? mg_find(dref, PERL_MAGIC_isa)
4072                                  : NULL;
4073             if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) {
4074                 if (SvTYPE(mg->mg_obj) != SVt_PVAV) {
4075                     AV * const ary = newAV();
4076                     av_push(ary, mg->mg_obj); /* takes the refcount */
4077                     mg->mg_obj = (SV *)ary;
4078                 }
4079                 if (omg) {
4080                     if (SvTYPE(omg->mg_obj) == SVt_PVAV) {
4081                         SV **svp = AvARRAY((AV *)omg->mg_obj);
4082                         I32 items = AvFILLp((AV *)omg->mg_obj) + 1;
4083                         while (items--)
4084                             av_push(
4085                              (AV *)mg->mg_obj,
4086                              SvREFCNT_inc_simple_NN(*svp++)
4087                             );
4088                     }
4089                     else
4090                         av_push(
4091                          (AV *)mg->mg_obj,
4092                          SvREFCNT_inc_simple_NN(omg->mg_obj)
4093                         );
4094                 }
4095                 else
4096                     av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dstr));
4097             }
4098             else
4099             {
4100                 sv_magic(
4101                  sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
4102                 );
4103                 mg = mg_find(sref, PERL_MAGIC_isa);
4104             }
4105             /* Since the *ISA assignment could have affected more than
4106                one stash, don't call mro_isa_changed_in directly, but let
4107                magic_clearisa do it for us, as it already has the logic for
4108                dealing with globs vs arrays of globs. */
4109             assert(mg);
4110             Perl_magic_clearisa(aTHX_ NULL, mg);
4111         }
4112         else if (stype == SVt_PVIO) {
4113             DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
4114             /* It's a cache. It will rebuild itself quite happily.
4115                It's a lot of effort to work out exactly which key (or keys)
4116                might be invalidated by the creation of the this file handle.
4117             */
4118             hv_clear(PL_stashcache);
4119         }
4120         break;
4121     }
4122     if (!intro) SvREFCNT_dec(dref);
4123     if (SvTAINTED(sstr))
4124         SvTAINT(dstr);
4125     return;
4126 }
4127
4128
4129
4130
4131 #ifdef PERL_DEBUG_READONLY_COW
4132 # include <sys/mman.h>
4133
4134 # ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
4135 #  define PERL_MEMORY_DEBUG_HEADER_SIZE 0
4136 # endif
4137
4138 void
4139 Perl_sv_buf_to_ro(pTHX_ SV *sv)
4140 {
4141     struct perl_memory_debug_header * const header =
4142         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4143     const MEM_SIZE len = header->size;
4144     PERL_ARGS_ASSERT_SV_BUF_TO_RO;
4145 # ifdef PERL_TRACK_MEMPOOL
4146     if (!header->readonly) header->readonly = 1;
4147 # endif
4148     if (mprotect(header, len, PROT_READ))
4149         Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
4150                          header, len, errno);
4151 }
4152
4153 static void
4154 S_sv_buf_to_rw(pTHX_ SV *sv)
4155 {
4156     struct perl_memory_debug_header * const header =
4157         (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
4158     const MEM_SIZE len = header->size;
4159     PERL_ARGS_ASSERT_SV_BUF_TO_RW;
4160     if (mprotect(header, len, PROT_READ|PROT_WRITE))
4161         Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
4162                          header, len, errno);
4163 # ifdef PERL_TRACK_MEMPOOL
4164     header->readonly = 0;
4165 # endif
4166 }
4167
4168 #else
4169 # define sv_buf_to_ro(sv)       NOOP
4170 # define sv_buf_to_rw(sv)       NOOP
4171 #endif
4172
4173 void
4174 Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
4175 {
4176     U32 sflags;
4177     int dtype;
4178     svtype stype;
4179
4180     PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
4181
4182     if (sstr == dstr)
4183         return;
4184
4185     if (SvIS_FREED(dstr)) {
4186         Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
4187                    " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
4188     }
4189     SV_CHECK_THINKFIRST_COW_DROP(dstr);
4190     if (!sstr)
4191         sstr = &PL_sv_undef;
4192     if (SvIS_FREED(sstr)) {
4193         Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
4194                    (void*)sstr, (void*)dstr);
4195     }
4196     stype = SvTYPE(sstr);
4197     dtype = SvTYPE(dstr);
4198
4199     /* There's a lot of redundancy below but we're going for speed here */
4200
4201     switch (stype) {
4202     case SVt_NULL:
4203       undef_sstr:
4204         if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
4205             (void)SvOK_off(dstr);
4206             return;
4207         }
4208         break;
4209     case SVt_IV:
4210         if (SvIOK(sstr)) {
4211             switch (dtype) {
4212             case SVt_NULL:
4213                 sv_upgrade(dstr, SVt_IV);
4214                 break;
4215             case SVt_NV:
4216             case SVt_PV:
4217                 sv_upgrade(dstr, SVt_PVIV);
4218                 break;
4219             case SVt_PVGV:
4220             case SVt_PVLV:
4221                 goto end_of_first_switch;
4222             }
4223             (void)SvIOK_only(dstr);
4224             SvIV_set(dstr,  SvIVX(sstr));
4225             if (SvIsUV(sstr))
4226                 SvIsUV_on(dstr);
4227             /* SvTAINTED can only be true if the SV has taint magic, which in
4228                turn means that the SV type is PVMG (or greater). This is the
4229                case statement for SVt_IV, so this cannot be true (whatever gcov
4230                may say).  */
4231             assert(!SvTAINTED(sstr));
4232             return;
4233         }
4234         if (!SvROK(sstr))
4235             goto undef_sstr;
4236         if (dtype < SVt_PV && dtype != SVt_IV)
4237             sv_upgrade(dstr, SVt_IV);
4238         break;
4239
4240     case SVt_NV:
4241         if (SvNOK(sstr)) {
4242             switch (dtype) {
4243             case SVt_NULL:
4244             case SVt_IV:
4245                 sv_upgrade(dstr, SVt_NV);
4246                 break;
4247             case SVt_PV:
4248             case SVt_PVIV:
4249                 sv_upgrade(dstr, SVt_PVNV);
4250                 break;
4251             case SVt_PVGV:
4252             case SVt_PVLV:
4253                 goto end_of_first_switch;
4254             }
4255             SvNV_set(dstr, SvNVX(sstr));
4256             (void)SvNOK_only(dstr);
4257             /* SvTAINTED can only be true if the SV has taint magic, which in
4258                turn means that the SV type is PVMG (or greater). This is the
4259                case statement for SVt_NV, so this cannot be true (whatever gcov
4260                may say).  */
4261             assert(!SvTAINTED(sstr));
4262             return;
4263         }
4264         goto undef_sstr;
4265
4266     case SVt_PV:
4267         if (dtype < SVt_PV)
4268             sv_upgrade(dstr, SVt_PV);
4269         break;
4270     case SVt_PVIV:
4271         if (dtype < SVt_PVIV)
4272             sv_upgrade(dstr, SVt_PVIV);
4273         break;
4274     case SVt_PVNV:
4275         if (dtype < SVt_PVNV)
4276             sv_upgrade(dstr, SVt_PVNV);
4277         break;
4278     default:
4279         {
4280         const char * const type = sv_reftype(sstr,0);
4281         if (PL_op)
4282             /* diag_listed_as: Bizarre copy of %s */
4283             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
4284         else
4285             Perl_croak(aTHX_ "Bizarre copy of %s", type);
4286         }
4287         NOT_REACHED; /* NOTREACHED */
4288
4289     case SVt_REGEXP:
4290       upgregexp:
4291         if (dtype < SVt_REGEXP)
4292         {
4293             if (dtype >= SVt_PV) {
4294                 SvPV_free(dstr);
4295                 SvPV_set(dstr, 0);
4296                 SvLEN_set(dstr, 0);
4297                 SvCUR_set(dstr, 0);
4298             }
4299             sv_upgrade(dstr, SVt_REGEXP);
4300         }
4301         break;
4302
4303         case SVt_INVLIST:
4304     case SVt_PVLV:
4305     case SVt_PVGV:
4306     case SVt_PVMG:
4307         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
4308             mg_get(sstr);
4309             if (SvTYPE(sstr) != stype)
4310                 stype = SvTYPE(sstr);
4311         }
4312         if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
4313                     glob_assign_glob(dstr, sstr, dtype);
4314                     return;
4315         }
4316         if (stype == SVt_PVLV)
4317         {
4318             if (isREGEXP(sstr)) goto upgregexp;
4319             SvUPGRADE(dstr, SVt_PVNV);
4320         }
4321         else
4322             SvUPGRADE(dstr, (svtype)stype);
4323     }
4324  end_of_first_switch:
4325
4326     /* dstr may have been upgraded.  */
4327     dtype = SvTYPE(dstr);
4328     sflags = SvFLAGS(sstr);
4329
4330     if (dtype == SVt_PVCV) {
4331         /* Assigning to a subroutine sets the prototype.  */
4332         if (SvOK(sstr)) {
4333             STRLEN len;
4334             const char *const ptr = SvPV_const(sstr, len);
4335
4336             SvGROW(dstr, len + 1);
4337             Copy(ptr, SvPVX(dstr), len + 1, char);
4338             SvCUR_set(dstr, len);
4339             SvPOK_only(dstr);
4340             SvFLAGS(dstr) |= sflags & SVf_UTF8;
4341             CvAUTOLOAD_off(dstr);
4342         } else {
4343             SvOK_off(dstr);
4344         }
4345     }
4346     else if (dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM) {
4347         const char * const type = sv_reftype(dstr,0);
4348         if (PL_op)
4349             /* diag_listed_as: Cannot copy to %s */
4350             Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
4351         else
4352             Perl_croak(aTHX_ "Cannot copy to %s", type);
4353     } else if (sflags & SVf_ROK) {
4354         if (isGV_with_GP(dstr)
4355             && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
4356             sstr = SvRV(sstr);
4357             if (sstr == dstr) {
4358                 if (GvIMPORTED(dstr) != GVf_IMPORTED
4359                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
4360                 {
4361                     GvIMPORTED_on(dstr);
4362                 }
4363                 GvMULTI_on(dstr);
4364                 return;
4365             }
4366             glob_assign_glob(dstr, sstr, dtype);
4367             return;
4368         }
4369
4370         if (dtype >= SVt_PV) {
4371             if (isGV_with_GP(dstr)) {
4372                 glob_assign_ref(dstr, sstr);
4373                 return;
4374             }
4375             if (SvPVX_const(dstr)) {
4376                 SvPV_free(dstr);
4377                 SvLEN_set(dstr, 0);
4378                 SvCUR_set(dstr, 0);
4379             }
4380         }
4381         (void)SvOK_off(dstr);
4382         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
4383         SvFLAGS(dstr) |= sflags & SVf_ROK;
4384         assert(!(sflags & SVp_NOK));
4385         assert(!(sflags & SVp_IOK));
4386         assert(!(sflags & SVf_NOK));
4387         assert(!(sflags & SVf_IOK));
4388     }
4389     else if (isGV_with_GP(dstr)) {
4390         if (!(sflags & SVf_OK)) {
4391             Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4392                            "Undefined value assigned to typeglob");
4393         }
4394         else {
4395             GV *gv = gv_fetchsv_nomg(sstr, GV_ADD, SVt_PVGV);
4396             if (dstr != (const SV *)gv) {
4397                 const char * const name = GvNAME((const GV *)dstr);
4398                 const STRLEN len = GvNAMELEN(dstr);
4399                 HV *old_stash = NULL;
4400                 bool reset_isa = FALSE;
4401                 if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
4402                  || (len == 1 && name[0] == ':')) {
4403                     /* Set aside the old stash, so we can reset isa caches
4404                        on its subclasses. */
4405                     if((old_stash = GvHV(dstr))) {
4406                         /* Make sure we do not lose it early. */
4407                         SvREFCNT_inc_simple_void_NN(
4408                          sv_2mortal((SV *)old_stash)
4409                         );
4410                     }
4411                     reset_isa = TRUE;
4412                 }
4413
4414                 if (GvGP(dstr)) {
4415                     SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
4416                     gp_free(MUTABLE_GV(dstr));
4417                 }
4418                 GvGP_set(dstr, gp_ref(GvGP(gv)));
4419
4420                 if (reset_isa) {
4421                     HV * const stash = GvHV(dstr);
4422                     if(
4423                         old_stash ? (HV *)HvENAME_get(old_stash) : stash
4424                     )
4425                         mro_package_moved(
4426                          stash, old_stash,
4427                          (GV *)dstr, 0
4428                         );
4429                 }
4430             }
4431         }
4432     }
4433     else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV)
4434           && (stype == SVt_REGEXP || isREGEXP(sstr))) {
4435         reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
4436     }
4437     else if (sflags & SVp_POK) {
4438         const STRLEN cur = SvCUR(sstr);
4439         const STRLEN len = SvLEN(sstr);
4440
4441         /*
4442          * We have three basic ways to copy the string:
4443          *
4444          *  1. Swipe
4445          *  2. Copy-on-write
4446          *  3. Actual copy
4447          * 
4448          * Which we choose is based on various factors.  The following
4449          * things are listed in order of speed, fastest to slowest:
4450          *  - Swipe
4451          *  - Copying a short string
4452          *  - Copy-on-write bookkeeping
4453          *  - malloc
4454          *  - Copying a long string
4455          * 
4456          * We swipe the string (steal the string buffer) if the SV on the
4457          * rhs is about to be freed anyway (TEMP and refcnt==1).  This is a
4458          * big win on long strings.  It should be a win on short strings if
4459          * SvPVX_const(dstr) has to be allocated.  If not, it should not 
4460          * slow things down, as SvPVX_const(sstr) would have been freed
4461          * soon anyway.
4462          * 
4463          * We also steal the buffer from a PADTMP (operator target) if it
4464          * is ‘long enough’.  For short strings, a swipe does not help
4465          * here, as it causes more malloc calls the next time the target
4466          * is used.  Benchmarks show that even if SvPVX_const(dstr) has to
4467          * be allocated it is still not worth swiping PADTMPs for short
4468          * strings, as the savings here are small.
4469          * 
4470          * If the rhs is already flagged as a copy-on-write string and COW
4471          * is possible here, we use copy-on-write and make both SVs share
4472          * the string buffer.
4473          * 
4474          * If the rhs is not flagged as copy-on-write, then we see whether
4475          * it is worth upgrading it to such.  If the lhs already has a buf-
4476          * fer big enough and the string is short, we skip it and fall back
4477          * to method 3, since memcpy is faster for short strings than the
4478          * later bookkeeping overhead that copy-on-write entails.
4479          * 
4480          * If there is no buffer on the left, or the buffer is too small,
4481          * then we use copy-on-write.
4482          */
4483
4484         /* Whichever path we take through the next code, we want this true,
4485            and doing it now facilitates the COW check.  */
4486         (void)SvPOK_only(dstr);
4487
4488         if (
4489                  (              /* Either ... */
4490                                 /* slated for free anyway (and not COW)? */
4491                     (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
4492                                 /* or a swipable TARG */
4493                  || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
4494                        == SVs_PADTMP
4495                                 /* whose buffer is worth stealing */
4496                      && CHECK_COWBUF_THRESHOLD(cur,len)
4497                     )
4498                  ) &&
4499                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
4500                  (!(flags & SV_NOSTEAL)) &&
4501                                         /* and we're allowed to steal temps */
4502                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
4503                  len)             /* and really is a string */
4504         {       /* Passes the swipe test.  */
4505             if (SvPVX_const(dstr))      /* we know that dtype >= SVt_PV */
4506                 SvPV_free(dstr);
4507             SvPV_set(dstr, SvPVX_mutable(sstr));
4508             SvLEN_set(dstr, SvLEN(sstr));
4509             SvCUR_set(dstr, SvCUR(sstr));
4510
4511             SvTEMP_off(dstr);
4512             (void)SvOK_off(sstr);       /* NOTE: nukes most SvFLAGS on sstr */
4513             SvPV_set(sstr, NULL);
4514             SvLEN_set(sstr, 0);
4515             SvCUR_set(sstr, 0);
4516             SvTEMP_off(sstr);
4517         }
4518         else if (flags & SV_COW_SHARED_HASH_KEYS
4519               &&
4520 #ifdef PERL_OLD_COPY_ON_WRITE
4521                  (  sflags & SVf_IsCOW
4522                  || (   (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4523                      && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4524                      && SvTYPE(sstr) >= SVt_PVIV && len
4525                     )
4526                  )
4527 #elif defined(PERL_NEW_COPY_ON_WRITE)
4528                  (sflags & SVf_IsCOW
4529                    ? (!len ||
4530                        (  (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4531                           /* If this is a regular (non-hek) COW, only so
4532                              many COW "copies" are possible. */
4533                        && CowREFCNT(sstr) != SV_COW_REFCNT_MAX  ))
4534                    : (  (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4535                      && !(SvFLAGS(dstr) & SVf_BREAK)
4536                      && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
4537                      && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
4538                     ))
4539 #else
4540                  sflags & SVf_IsCOW
4541               && !(SvFLAGS(dstr) & SVf_BREAK)
4542 #endif
4543             ) {
4544             /* Either it's a shared hash key, or it's suitable for
4545                copy-on-write.  */
4546             if (DEBUG_C_TEST) {
4547                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4548                 sv_dump(sstr);
4549                 sv_dump(dstr);
4550             }
4551 #ifdef PERL_ANY_COW
4552             if (!(sflags & SVf_IsCOW)) {
4553                     SvIsCOW_on(sstr);
4554 # ifdef PERL_OLD_COPY_ON_WRITE
4555                     /* Make the source SV into a loop of 1.
4556                        (about to become 2) */
4557                     SV_COW_NEXT_SV_SET(sstr, sstr);
4558 # else
4559                     CowREFCNT(sstr) = 0;
4560 # endif
4561             }
4562 #endif
4563             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
4564                 SvPV_free(dstr);
4565             }
4566
4567 #ifdef PERL_ANY_COW
4568             if (len) {
4569 # ifdef PERL_OLD_COPY_ON_WRITE
4570                     assert (SvTYPE(dstr) >= SVt_PVIV);
4571                     /* SvIsCOW_normal */
4572                     /* splice us in between source and next-after-source.  */
4573                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4574                     SV_COW_NEXT_SV_SET(sstr, dstr);
4575 # else
4576                     if (sflags & SVf_IsCOW) {
4577                         sv_buf_to_rw(sstr);
4578                     }
4579                     CowREFCNT(sstr)++;
4580 # endif
4581                     SvPV_set(dstr, SvPVX_mutable(sstr));
4582                     sv_buf_to_ro(sstr);
4583             } else
4584 #endif
4585             {
4586                     /* SvIsCOW_shared_hash */
4587                     DEBUG_C(PerlIO_printf(Perl_debug_log,
4588                                           "Copy on write: Sharing hash\n"));
4589
4590                     assert (SvTYPE(dstr) >= SVt_PV);
4591                     SvPV_set(dstr,
4592                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4593             }
4594             SvLEN_set(dstr, len);
4595             SvCUR_set(dstr, cur);
4596             SvIsCOW_on(dstr);
4597         } else {
4598             /* Failed the swipe test, and we cannot do copy-on-write either.
4599                Have to copy the string.  */
4600             SvGROW(dstr, cur + 1);      /* inlined from sv_setpvn */
4601             Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
4602             SvCUR_set(dstr, cur);
4603             *SvEND(dstr) = '\0';
4604         }
4605         if (sflags & SVp_NOK) {
4606             SvNV_set(dstr, SvNVX(sstr));
4607         }
4608         if (sflags & SVp_IOK) {
4609             SvIV_set(dstr, SvIVX(sstr));
4610             /* Must do this otherwise some other overloaded use of 0x80000000
4611                gets confused. I guess SVpbm_VALID */
4612             if (sflags & SVf_IVisUV)
4613                 SvIsUV_on(dstr);
4614         }
4615         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8);
4616         {
4617             const MAGIC * const smg = SvVSTRING_mg(sstr);
4618             if (smg) {
4619                 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4620                          smg->mg_ptr, smg->mg_len);
4621                 SvRMAGICAL_on(dstr);
4622             }
4623         }
4624     }
4625     else if (sflags & (SVp_IOK|SVp_NOK)) {
4626         (void)SvOK_off(dstr);
4627         SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK);