This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sv_2pv_flags shouldn't return a constant string "NULLREF" - it was the
[perl5.git] / sv.c
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
10  *
11  *
12  * This file contains the code that creates, manipulates and destroys
13  * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14  * structure of an SV, so their creation and destruction is handled
15  * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16  * level functions (eg. substr, split, join) for each of the types are
17  * in the pp*.c files.
18  */
19
20 #include "EXTERN.h"
21 #define PERL_IN_SV_C
22 #include "perl.h"
23 #include "regcomp.h"
24
25 #define FCALL *f
26
27 #ifdef __Lynx__
28 /* Missing proto on LynxOS */
29   char *gconvert(double, int, int,  char *);
30 #endif
31
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34  * the cache element 1 is the byte offset of the element 0;
35  * the cache element 2 is the Unicode length of the substring;
36  * the cache element 3 is the byte length of the substring;
37  * The checking of the substring side would be good
38  * but substr() has enough code paths to make my head spin;
39  * if adding more checks watch out for the following tests:
40  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41  *   lib/utf8.t lib/Unicode/Collate/t/index.t
42  * --jhi
43  */
44 #define ASSERT_UTF8_CACHE(cache) \
45         STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
46 #else
47 #define ASSERT_UTF8_CACHE(cache) NOOP
48 #endif
49
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv)      INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next)        SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
54    on-write.  */
55 #endif
56
57 /* ============================================================================
58
59 =head1 Allocation and deallocation of SVs.
60
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
65
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
71
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena.  In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots.  Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
78
79 The following global variables are associated with arenas:
80
81     PL_sv_arenaroot     pointer to list of SV arenas
82     PL_sv_root          pointer to list of free SV structures
83
84     PL_body_arenaroots[]  array of pointers to list of arenas, 1 per svtype
85     PL_body_roots[]       array of pointers to list of free bodies of svtype
86                           arrays are indexed by the svtype needed
87
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
91
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
96
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
99
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
105
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
112
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
116
117 Manipulation of any of the PL_*root pointers is protected by enclosing
118 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
119 if threads are enabled.
120
121 The function visit() scans the SV arenas list, and calls a specified
122 function for each SV it finds which is still live - ie which has an SvTYPE
123 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
124 following functions (specified as [function that calls visit()] / [function
125 called by visit() for each SV]):
126
127     sv_report_used() / do_report_used()
128                         dump all remaining SVs (debugging aid)
129
130     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
131                         Attempt to free all objects pointed to by RVs,
132                         and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
133                         try to do the same for all objects indirectly
134                         referenced by typeglobs too.  Called once from
135                         perl_destruct(), prior to calling sv_clean_all()
136                         below.
137
138     sv_clean_all() / do_clean_all()
139                         SvREFCNT_dec(sv) each remaining SV, possibly
140                         triggering an sv_free(). It also sets the
141                         SVf_BREAK flag on the SV to indicate that the
142                         refcnt has been artificially lowered, and thus
143                         stopping sv_free() from giving spurious warnings
144                         about SVs which unexpectedly have a refcnt
145                         of zero.  called repeatedly from perl_destruct()
146                         until there are no SVs left.
147
148 =head2 Arena allocator API Summary
149
150 Private API to rest of sv.c
151
152     new_SV(),  del_SV(),
153
154     new_XIV(), del_XIV(),
155     new_XNV(), del_XNV(),
156     etc
157
158 Public API:
159
160     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
161
162
163 =cut
164
165 ============================================================================ */
166
167
168
169 /*
170  * "A time to plant, and a time to uproot what was planted..."
171  */
172
173 /*
174  * nice_chunk and nice_chunk size need to be set
175  * and queried under the protection of sv_mutex
176  */
177 void
178 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
179 {
180     void *new_chunk;
181     U32 new_chunk_size;
182     LOCK_SV_MUTEX;
183     new_chunk = (void *)(chunk);
184     new_chunk_size = (chunk_size);
185     if (new_chunk_size > PL_nice_chunk_size) {
186         Safefree(PL_nice_chunk);
187         PL_nice_chunk = (char *) new_chunk;
188         PL_nice_chunk_size = new_chunk_size;
189     } else {
190         Safefree(chunk);
191     }
192     UNLOCK_SV_MUTEX;
193 }
194
195 #ifdef DEBUG_LEAKING_SCALARS
196 #  define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
197 #else
198 #  define FREE_SV_DEBUG_FILE(sv)
199 #endif
200
201 #ifdef PERL_POISON
202 #  define SvARENA_CHAIN(sv)     ((sv)->sv_u.svu_rv)
203 /* Whilst I'd love to do this, it seems that things like to check on
204    unreferenced scalars
205 #  define POSION_SV_HEAD(sv)    Poison(sv, 1, struct STRUCT_SV)
206 */
207 #  define POSION_SV_HEAD(sv)    Poison(&SvANY(sv), 1, void *), \
208                                 Poison(&SvREFCNT(sv), 1, U32)
209 #else
210 #  define SvARENA_CHAIN(sv)     SvANY(sv)
211 #  define POSION_SV_HEAD(sv)
212 #endif
213
214 #define plant_SV(p) \
215     STMT_START {                                        \
216         FREE_SV_DEBUG_FILE(p);                          \
217         POSION_SV_HEAD(p);                              \
218         SvARENA_CHAIN(p) = (void *)PL_sv_root;          \
219         SvFLAGS(p) = SVTYPEMASK;                        \
220         PL_sv_root = (p);                               \
221         --PL_sv_count;                                  \
222     } STMT_END
223
224 /* sv_mutex must be held while calling uproot_SV() */
225 #define uproot_SV(p) \
226     STMT_START {                                        \
227         (p) = PL_sv_root;                               \
228         PL_sv_root = (SV*)SvARENA_CHAIN(p);                     \
229         ++PL_sv_count;                                  \
230     } STMT_END
231
232
233 /* make some more SVs by adding another arena */
234
235 /* sv_mutex must be held while calling more_sv() */
236 STATIC SV*
237 S_more_sv(pTHX)
238 {
239     SV* sv;
240
241     if (PL_nice_chunk) {
242         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
243         PL_nice_chunk = Nullch;
244         PL_nice_chunk_size = 0;
245     }
246     else {
247         char *chunk;                /* must use New here to match call to */
248         Newx(chunk,PERL_ARENA_SIZE,char);   /* Safefree() in sv_free_arenas()     */
249         sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
250     }
251     uproot_SV(sv);
252     return sv;
253 }
254
255 /* new_SV(): return a new, empty SV head */
256
257 #ifdef DEBUG_LEAKING_SCALARS
258 /* provide a real function for a debugger to play with */
259 STATIC SV*
260 S_new_SV(pTHX)
261 {
262     SV* sv;
263
264     LOCK_SV_MUTEX;
265     if (PL_sv_root)
266         uproot_SV(sv);
267     else
268         sv = S_more_sv(aTHX);
269     UNLOCK_SV_MUTEX;
270     SvANY(sv) = 0;
271     SvREFCNT(sv) = 1;
272     SvFLAGS(sv) = 0;
273     sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
274     sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
275         (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
276     sv->sv_debug_inpad = 0;
277     sv->sv_debug_cloned = 0;
278     sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
279     
280     return sv;
281 }
282 #  define new_SV(p) (p)=S_new_SV(aTHX)
283
284 #else
285 #  define new_SV(p) \
286     STMT_START {                                        \
287         LOCK_SV_MUTEX;                                  \
288         if (PL_sv_root)                                 \
289             uproot_SV(p);                               \
290         else                                            \
291             (p) = S_more_sv(aTHX);                      \
292         UNLOCK_SV_MUTEX;                                \
293         SvANY(p) = 0;                                   \
294         SvREFCNT(p) = 1;                                \
295         SvFLAGS(p) = 0;                                 \
296     } STMT_END
297 #endif
298
299
300 /* del_SV(): return an empty SV head to the free list */
301
302 #ifdef DEBUGGING
303
304 #define del_SV(p) \
305     STMT_START {                                        \
306         LOCK_SV_MUTEX;                                  \
307         if (DEBUG_D_TEST)                               \
308             del_sv(p);                                  \
309         else                                            \
310             plant_SV(p);                                \
311         UNLOCK_SV_MUTEX;                                \
312     } STMT_END
313
314 STATIC void
315 S_del_sv(pTHX_ SV *p)
316 {
317     if (DEBUG_D_TEST) {
318         SV* sva;
319         bool ok = 0;
320         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
321             const SV * const sv = sva + 1;
322             const SV * const svend = &sva[SvREFCNT(sva)];
323             if (p >= sv && p < svend) {
324                 ok = 1;
325                 break;
326             }
327         }
328         if (!ok) {
329             if (ckWARN_d(WARN_INTERNAL))        
330                 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
331                             "Attempt to free non-arena SV: 0x%"UVxf
332                             pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
333             return;
334         }
335     }
336     plant_SV(p);
337 }
338
339 #else /* ! DEBUGGING */
340
341 #define del_SV(p)   plant_SV(p)
342
343 #endif /* DEBUGGING */
344
345
346 /*
347 =head1 SV Manipulation Functions
348
349 =for apidoc sv_add_arena
350
351 Given a chunk of memory, link it to the head of the list of arenas,
352 and split it into a list of free SVs.
353
354 =cut
355 */
356
357 void
358 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
359 {
360     SV* sva = (SV*)ptr;
361     register SV* sv;
362     register SV* svend;
363
364     /* The first SV in an arena isn't an SV. */
365     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
366     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
367     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
368
369     PL_sv_arenaroot = sva;
370     PL_sv_root = sva + 1;
371
372     svend = &sva[SvREFCNT(sva) - 1];
373     sv = sva + 1;
374     while (sv < svend) {
375         SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
376 #ifdef DEBUGGING
377         SvREFCNT(sv) = 0;
378 #endif
379         /* Must always set typemask because it's awlays checked in on cleanup
380            when the arenas are walked looking for objects.  */
381         SvFLAGS(sv) = SVTYPEMASK;
382         sv++;
383     }
384     SvARENA_CHAIN(sv) = 0;
385 #ifdef DEBUGGING
386     SvREFCNT(sv) = 0;
387 #endif
388     SvFLAGS(sv) = SVTYPEMASK;
389 }
390
391 /* visit(): call the named function for each non-free SV in the arenas
392  * whose flags field matches the flags/mask args. */
393
394 STATIC I32
395 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
396 {
397     SV* sva;
398     I32 visited = 0;
399
400     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
401         register const SV * const svend = &sva[SvREFCNT(sva)];
402         register SV* sv;
403         for (sv = sva + 1; sv < svend; ++sv) {
404             if (SvTYPE(sv) != SVTYPEMASK
405                     && (sv->sv_flags & mask) == flags
406                     && SvREFCNT(sv))
407             {
408                 (FCALL)(aTHX_ sv);
409                 ++visited;
410             }
411         }
412     }
413     return visited;
414 }
415
416 #ifdef DEBUGGING
417
418 /* called by sv_report_used() for each live SV */
419
420 static void
421 do_report_used(pTHX_ SV *sv)
422 {
423     if (SvTYPE(sv) != SVTYPEMASK) {
424         PerlIO_printf(Perl_debug_log, "****\n");
425         sv_dump(sv);
426     }
427 }
428 #endif
429
430 /*
431 =for apidoc sv_report_used
432
433 Dump the contents of all SVs not yet freed. (Debugging aid).
434
435 =cut
436 */
437
438 void
439 Perl_sv_report_used(pTHX)
440 {
441 #ifdef DEBUGGING
442     visit(do_report_used, 0, 0);
443 #endif
444 }
445
446 /* called by sv_clean_objs() for each live SV */
447
448 static void
449 do_clean_objs(pTHX_ SV *ref)
450 {
451     if (SvROK(ref)) {
452         SV * const target = SvRV(ref);
453         if (SvOBJECT(target)) {
454             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
455             if (SvWEAKREF(ref)) {
456                 sv_del_backref(target, ref);
457                 SvWEAKREF_off(ref);
458                 SvRV_set(ref, NULL);
459             } else {
460                 SvROK_off(ref);
461                 SvRV_set(ref, NULL);
462                 SvREFCNT_dec(target);
463             }
464         }
465     }
466
467     /* XXX Might want to check arrays, etc. */
468 }
469
470 /* called by sv_clean_objs() for each live SV */
471
472 #ifndef DISABLE_DESTRUCTOR_KLUDGE
473 static void
474 do_clean_named_objs(pTHX_ SV *sv)
475 {
476     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
477         if ((
478 #ifdef PERL_DONT_CREATE_GVSV
479              GvSV(sv) &&
480 #endif
481              SvOBJECT(GvSV(sv))) ||
482              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
483              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
484              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
485              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
486         {
487             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
488             SvFLAGS(sv) |= SVf_BREAK;
489             SvREFCNT_dec(sv);
490         }
491     }
492 }
493 #endif
494
495 /*
496 =for apidoc sv_clean_objs
497
498 Attempt to destroy all objects not yet freed
499
500 =cut
501 */
502
503 void
504 Perl_sv_clean_objs(pTHX)
505 {
506     PL_in_clean_objs = TRUE;
507     visit(do_clean_objs, SVf_ROK, SVf_ROK);
508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
509     /* some barnacles may yet remain, clinging to typeglobs */
510     visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
511 #endif
512     PL_in_clean_objs = FALSE;
513 }
514
515 /* called by sv_clean_all() for each live SV */
516
517 static void
518 do_clean_all(pTHX_ SV *sv)
519 {
520     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
521     SvFLAGS(sv) |= SVf_BREAK;
522     if (PL_comppad == (AV*)sv) {
523         PL_comppad = Nullav;
524         PL_curpad = Null(SV**);
525     }
526     SvREFCNT_dec(sv);
527 }
528
529 /*
530 =for apidoc sv_clean_all
531
532 Decrement the refcnt of each remaining SV, possibly triggering a
533 cleanup. This function may have to be called multiple times to free
534 SVs which are in complex self-referential hierarchies.
535
536 =cut
537 */
538
539 I32
540 Perl_sv_clean_all(pTHX)
541 {
542     I32 cleaned;
543     PL_in_clean_all = TRUE;
544     cleaned = visit(do_clean_all, 0,0);
545     PL_in_clean_all = FALSE;
546     return cleaned;
547 }
548
549 static void 
550 S_free_arena(pTHX_ void **root) {
551     while (root) {
552         void ** const next = *(void **)root;
553         Safefree(root);
554         root = next;
555     }
556 }
557     
558 /*
559 =for apidoc sv_free_arenas
560
561 Deallocate the memory used by all arenas. Note that all the individual SV
562 heads and bodies within the arenas must already have been freed.
563
564 =cut
565 */
566 #define free_arena(name)                                        \
567     STMT_START {                                                \
568         S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
569         PL_ ## name ## _arenaroot = 0;                          \
570         PL_ ## name ## _root = 0;                               \
571     } STMT_END
572
573 void
574 Perl_sv_free_arenas(pTHX)
575 {
576     SV* sva;
577     SV* svanext;
578     int i;
579
580     /* Free arenas here, but be careful about fake ones.  (We assume
581        contiguity of the fake ones with the corresponding real ones.) */
582
583     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
584         svanext = (SV*) SvANY(sva);
585         while (svanext && SvFAKE(svanext))
586             svanext = (SV*) SvANY(svanext);
587
588         if (!SvFAKE(sva))
589             Safefree(sva);
590     }
591
592     for (i=0; i<SVt_LAST; i++) {
593         S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
594         PL_body_arenaroots[i] = 0;
595         PL_body_roots[i] = 0;
596     }
597
598     Safefree(PL_nice_chunk);
599     PL_nice_chunk = Nullch;
600     PL_nice_chunk_size = 0;
601     PL_sv_arenaroot = 0;
602     PL_sv_root = 0;
603 }
604
605 /*
606   Here are mid-level routines that manage the allocation of bodies out
607   of the various arenas.  There are 5 kinds of arenas:
608
609   1. SV-head arenas, which are discussed and handled above
610   2. regular body arenas
611   3. arenas for reduced-size bodies
612   4. Hash-Entry arenas
613   5. pte arenas (thread related)
614
615   Arena types 2 & 3 are chained by body-type off an array of
616   arena-root pointers, which is indexed by svtype.  Some of the
617   larger/less used body types are malloced singly, since a large
618   unused block of them is wasteful.  Also, several svtypes dont have
619   bodies; the data fits into the sv-head itself.  The arena-root
620   pointer thus has a few unused root-pointers (which may be hijacked
621   later for arena types 4,5)
622
623   3 differs from 2 as an optimization; some body types have several
624   unused fields in the front of the structure (which are kept in-place
625   for consistency).  These bodies can be allocated in smaller chunks,
626   because the leading fields arent accessed.  Pointers to such bodies
627   are decremented to point at the unused 'ghost' memory, knowing that
628   the pointers are used with offsets to the real memory.
629
630   HE, HEK arenas are managed separately, with separate code, but may
631   be merge-able later..
632
633   PTE arenas are not sv-bodies, but they share these mid-level
634   mechanics, so are considered here.  The new mid-level mechanics rely
635   on the sv_type of the body being allocated, so we just reserve one
636   of the unused body-slots for PTEs, then use it in those (2) PTE
637   contexts below (line ~10k)
638 */
639
640 STATIC void *
641 S_more_bodies (pTHX_ size_t size, svtype sv_type)
642 {
643     void **arena_root   = &PL_body_arenaroots[sv_type];
644     void **root         = &PL_body_roots[sv_type];
645     char *start;
646     const char *end;
647     const size_t count = PERL_ARENA_SIZE / size;
648
649     Newx(start, count*size, char);
650     *((void **) start) = *arena_root;
651     *arena_root = (void *)start;
652
653     end = start + (count-1) * size;
654
655     /* The initial slot is used to link the arenas together, so it isn't to be
656        linked into the list of ready-to-use bodies.  */
657
658     start += size;
659
660     *root = (void *)start;
661
662     while (start < end) {
663         char * const next = start + size;
664         *(void**) start = (void *)next;
665         start = next;
666     }
667     *(void **)start = 0;
668
669     return *root;
670 }
671
672 /* grab a new thing from the free list, allocating more if necessary */
673
674 /* 1st, the inline version  */
675
676 #define new_body_inline(xpv, size, sv_type) \
677     STMT_START { \
678         void **r3wt = &PL_body_roots[sv_type]; \
679         LOCK_SV_MUTEX; \
680         xpv = *((void **)(r3wt)) \
681           ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
682         *(r3wt) = *(void**)(xpv); \
683         UNLOCK_SV_MUTEX; \
684     } STMT_END
685
686 /* now use the inline version in the proper function */
687
688 #ifndef PURIFY
689
690 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
691    compilers issue warnings.  */
692
693 STATIC void *
694 S_new_body(pTHX_ size_t size, svtype sv_type)
695 {
696     void *xpv;
697     new_body_inline(xpv, size, sv_type);
698     return xpv;
699 }
700
701 #endif
702
703 /* return a thing to the free list */
704
705 #define del_body(thing, root)                   \
706     STMT_START {                                \
707         void **thing_copy = (void **)thing;     \
708         LOCK_SV_MUTEX;                          \
709         *thing_copy = *root;                    \
710         *root = (void*)thing_copy;              \
711         UNLOCK_SV_MUTEX;                        \
712     } STMT_END
713
714 /* 
715    Revisiting type 3 arenas, there are 4 body-types which have some
716    members that are never accessed.  They are XPV, XPVIV, XPVAV,
717    XPVHV, which have corresponding types: xpv_allocated,
718    xpviv_allocated, xpvav_allocated, xpvhv_allocated,
719
720    For these types, the arenas are carved up into *_allocated size
721    chunks, we thus avoid wasted memory for those unaccessed members.
722    When bodies are allocated, we adjust the pointer back in memory by
723    the size of the bit not allocated, so it's as if we allocated the
724    full structure.  (But things will all go boom if you write to the
725    part that is "not there", because you'll be overwriting the last
726    members of the preceding structure in memory.)
727
728    We calculate the correction using the STRUCT_OFFSET macro. For example, if
729    xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
730    and the pointer is unchanged. If the allocated structure is smaller (no
731    initial NV actually allocated) then the net effect is to subtract the size
732    of the NV from the pointer, to return a new pointer as if an initial NV were
733    actually allocated.
734
735    This is the same trick as was used for NV and IV bodies. Ironically it
736    doesn't need to be used for NV bodies any more, because NV is now at the
737    start of the structure. IV bodies don't need it either, because they are
738    no longer allocated.  */
739
740 /* The following 2 arrays hide the above details in a pair of
741    lookup-tables, allowing us to be body-type agnostic.
742
743    size maps svtype to its body's allocated size.
744    offset maps svtype to the body-pointer adjustment needed
745
746    NB: elements in latter are 0 or <0, and are added during
747    allocation, and subtracted during deallocation.  It may be clearer
748    to invert the values, and call it shrinkage_by_svtype.
749 */
750
751 struct body_details {
752     size_t size;        /* Size to allocate  */
753     size_t copy;        /* Size of structure to copy (may be shorter)  */
754     size_t offset;
755     bool cant_upgrade;  /* Can upgrade this type */
756     bool zero_nv;       /* zero the NV when upgrading from this */
757     bool arena;         /* Allocated from an arena */
758 };
759
760 #define HADNV FALSE
761 #define NONV TRUE
762
763 #ifdef PURIFY
764 /* With -DPURFIY we allocate everything directly, and don't use arenas.
765    This seems a rather elegant way to simplify some of the code below.  */
766 #define HASARENA FALSE
767 #else
768 #define HASARENA TRUE
769 #endif
770 #define NOARENA FALSE
771
772 /* A macro to work out the offset needed to subtract from a pointer to (say)
773
774 typedef struct {
775     STRLEN      xpv_cur;
776     STRLEN      xpv_len;
777 } xpv_allocated;
778
779 to make its members accessible via a pointer to (say)
780
781 struct xpv {
782     NV          xnv_nv;
783     STRLEN      xpv_cur;
784     STRLEN      xpv_len;
785 };
786
787 */
788
789 #define relative_STRUCT_OFFSET(longer, shorter, member) \
790     (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member))
791
792 /* Calculate the length to copy. Specifically work out the length less any
793    final padding the compiler needed to add.  See the comment in sv_upgrade
794    for why copying the padding proved to be a bug.  */
795
796 #define copy_length(type, last_member) \
797         STRUCT_OFFSET(type, last_member) \
798         + sizeof (((type*)SvANY((SV*)0))->last_member)
799
800 static const struct body_details bodies_by_type[] = {
801     {0, 0, 0, FALSE, NONV, NOARENA},
802     /* IVs are in the head, so the allocation size is 0  */
803     {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
804     /* 8 bytes on most ILP32 with IEEE doubles */
805     {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
806     /* RVs are in the head now */
807     /* However, this slot is overloaded and used by the pte  */
808     {0, 0, 0, FALSE, NONV, NOARENA},
809     /* 8 bytes on most ILP32 with IEEE doubles */
810     {sizeof(xpv_allocated),
811      copy_length(XPV, xpv_len)
812      + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
813      - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur),
814      FALSE, NONV, HASARENA},
815     /* 12 */
816     {sizeof(xpviv_allocated),
817      copy_length(XPVIV, xiv_u)
818      + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
819      - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur),
820      FALSE, NONV, HASARENA},
821     /* 20 */
822     {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA},
823     /* 28 */
824     {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA},
825     /* 36 */
826     {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
827     /* 48 */
828     {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
829     /* 64 */
830     {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
831     /* 20 */
832     {sizeof(xpvav_allocated),
833      copy_length(XPVAV, xmg_stash)
834      + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
835      - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill),
836      TRUE, HADNV, HASARENA},
837     /* 20 */
838     {sizeof(xpvhv_allocated),
839      copy_length(XPVHV, xmg_stash)
840      + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
841      - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill),
842      TRUE, HADNV, HASARENA},
843     /* 76 */
844     {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
845     /* 80 */
846     {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
847     /* 84 */
848     {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
849 };
850
851 #define new_body_type(sv_type)                  \
852     (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
853              - bodies_by_type[sv_type].offset)
854
855 #define del_body_type(p, sv_type)       \
856     del_body(p, &PL_body_roots[sv_type])
857
858
859 #define new_body_allocated(sv_type)             \
860     (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
861              - bodies_by_type[sv_type].offset)
862
863 #define del_body_allocated(p, sv_type)          \
864     del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
865
866
867 #define my_safemalloc(s)        (void*)safemalloc(s)
868 #define my_safecalloc(s)        (void*)safecalloc(s, 1)
869 #define my_safefree(p)  safefree((char*)p)
870
871 #ifdef PURIFY
872
873 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
874 #define del_XNV(p)      my_safefree(p)
875
876 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
877 #define del_XPVNV(p)    my_safefree(p)
878
879 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
880 #define del_XPVAV(p)    my_safefree(p)
881
882 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
883 #define del_XPVHV(p)    my_safefree(p)
884
885 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
886 #define del_XPVMG(p)    my_safefree(p)
887
888 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
889 #define del_XPVGV(p)    my_safefree(p)
890
891 #else /* !PURIFY */
892
893 #define new_XNV()       new_body_type(SVt_NV)
894 #define del_XNV(p)      del_body_type(p, SVt_NV)
895
896 #define new_XPVNV()     new_body_type(SVt_PVNV)
897 #define del_XPVNV(p)    del_body_type(p, SVt_PVNV)
898
899 #define new_XPVAV()     new_body_allocated(SVt_PVAV)
900 #define del_XPVAV(p)    del_body_allocated(p, SVt_PVAV)
901
902 #define new_XPVHV()     new_body_allocated(SVt_PVHV)
903 #define del_XPVHV(p)    del_body_allocated(p, SVt_PVHV)
904
905 #define new_XPVMG()     new_body_type(SVt_PVMG)
906 #define del_XPVMG(p)    del_body_type(p, SVt_PVMG)
907
908 #define new_XPVGV()     new_body_type(SVt_PVGV)
909 #define del_XPVGV(p)    del_body_type(p, SVt_PVGV)
910
911 #endif /* PURIFY */
912
913 /* no arena for you! */
914
915 #define new_NOARENA(details) \
916         my_safemalloc((details)->size + (details)->offset)
917 #define new_NOARENAZ(details) \
918         my_safecalloc((details)->size + (details)->offset)
919
920 /*
921 =for apidoc sv_upgrade
922
923 Upgrade an SV to a more complex form.  Generally adds a new body type to the
924 SV, then copies across as much information as possible from the old body.
925 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
926
927 =cut
928 */
929
930 void
931 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
932 {
933     void*       old_body;
934     void*       new_body;
935     const U32   old_type = SvTYPE(sv);
936     const struct body_details *const old_type_details
937         = bodies_by_type + old_type;
938     const struct body_details *new_type_details = bodies_by_type + new_type;
939
940     if (new_type != SVt_PV && SvIsCOW(sv)) {
941         sv_force_normal_flags(sv, 0);
942     }
943
944     if (old_type == new_type)
945         return;
946
947     if (old_type > new_type)
948         Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
949                 (int)old_type, (int)new_type);
950
951
952     old_body = SvANY(sv);
953
954     /* Copying structures onto other structures that have been neatly zeroed
955        has a subtle gotcha. Consider XPVMG
956
957        +------+------+------+------+------+-------+-------+
958        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |
959        +------+------+------+------+------+-------+-------+
960        0      4      8     12     16     20      24      28
961
962        where NVs are aligned to 8 bytes, so that sizeof that structure is
963        actually 32 bytes long, with 4 bytes of padding at the end:
964
965        +------+------+------+------+------+-------+-------+------+
966        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH | ???  |
967        +------+------+------+------+------+-------+-------+------+
968        0      4      8     12     16     20      24      28     32
969
970        so what happens if you allocate memory for this structure:
971
972        +------+------+------+------+------+-------+-------+------+------+...
973        |     NV      | CUR  | LEN  |  IV  | MAGIC | STASH |  GP  | NAME |
974        +------+------+------+------+------+-------+-------+------+------+...
975        0      4      8     12     16     20      24      28     32     36
976
977        zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
978        expect, because you copy the area marked ??? onto GP. Now, ??? may have
979        started out as zero once, but it's quite possible that it isn't. So now,
980        rather than a nicely zeroed GP, you have it pointing somewhere random.
981        Bugs ensue.
982
983        (In fact, GP ends up pointing at a previous GP structure, because the
984        principle cause of the padding in XPVMG getting garbage is a copy of
985        sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
986
987        So we are careful and work out the size of used parts of all the
988        structures.  */
989
990     switch (old_type) {
991     case SVt_NULL:
992         break;
993     case SVt_IV:
994         if (new_type < SVt_PVIV) {
995             new_type = (new_type == SVt_NV)
996                 ? SVt_PVNV : SVt_PVIV;
997             new_type_details = bodies_by_type + new_type;
998         }
999         break;
1000     case SVt_NV:
1001         if (new_type < SVt_PVNV) {
1002             new_type = SVt_PVNV;
1003             new_type_details = bodies_by_type + new_type;
1004         }
1005         break;
1006     case SVt_RV:
1007         break;
1008     case SVt_PV:
1009         assert(new_type > SVt_PV);
1010         assert(SVt_IV < SVt_PV);
1011         assert(SVt_NV < SVt_PV);
1012         break;
1013     case SVt_PVIV:
1014         break;
1015     case SVt_PVNV:
1016         break;
1017     case SVt_PVMG:
1018         /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1019            there's no way that it can be safely upgraded, because perl.c
1020            expects to Safefree(SvANY(PL_mess_sv))  */
1021         assert(sv != PL_mess_sv);
1022         /* This flag bit is used to mean other things in other scalar types.
1023            Given that it only has meaning inside the pad, it shouldn't be set
1024            on anything that can get upgraded.  */
1025         assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1026         break;
1027     default:
1028         if (old_type_details->cant_upgrade)
1029             Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1030     }
1031
1032     SvFLAGS(sv) &= ~SVTYPEMASK;
1033     SvFLAGS(sv) |= new_type;
1034
1035     switch (new_type) {
1036     case SVt_NULL:
1037         Perl_croak(aTHX_ "Can't upgrade to undef");
1038     case SVt_IV:
1039         assert(old_type == SVt_NULL);
1040         SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1041         SvIV_set(sv, 0);
1042         return;
1043     case SVt_NV:
1044         assert(old_type == SVt_NULL);
1045         SvANY(sv) = new_XNV();
1046         SvNV_set(sv, 0);
1047         return;
1048     case SVt_RV:
1049         assert(old_type == SVt_NULL);
1050         SvANY(sv) = &sv->sv_u.svu_rv;
1051         SvRV_set(sv, 0);
1052         return;
1053     case SVt_PVHV:
1054         SvANY(sv) = new_XPVHV();
1055         HvFILL(sv)      = 0;
1056         HvMAX(sv)       = 0;
1057         HvTOTALKEYS(sv) = 0;
1058
1059         goto hv_av_common;
1060
1061     case SVt_PVAV:
1062         SvANY(sv) = new_XPVAV();
1063         AvMAX(sv)       = -1;
1064         AvFILLp(sv)     = -1;
1065         AvALLOC(sv)     = 0;
1066         AvREAL_only(sv);
1067
1068     hv_av_common:
1069         /* SVt_NULL isn't the only thing upgraded to AV or HV.
1070            The target created by newSVrv also is, and it can have magic.
1071            However, it never has SvPVX set.
1072         */
1073         if (old_type >= SVt_RV) {
1074             assert(SvPVX_const(sv) == 0);
1075         }
1076
1077         /* Could put this in the else clause below, as PVMG must have SvPVX
1078            0 already (the assertion above)  */
1079         SvPV_set(sv, (char*)0);
1080
1081         if (old_type >= SVt_PVMG) {
1082             SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1083             SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1084         } else {
1085             SvMAGIC_set(sv, 0);
1086             SvSTASH_set(sv, 0);
1087         }
1088         break;
1089
1090
1091     case SVt_PVIV:
1092         /* XXX Is this still needed?  Was it ever needed?   Surely as there is
1093            no route from NV to PVIV, NOK can never be true  */
1094         assert(!SvNOKp(sv));
1095         assert(!SvNOK(sv));
1096     case SVt_PVIO:
1097     case SVt_PVFM:
1098     case SVt_PVBM:
1099     case SVt_PVGV:
1100     case SVt_PVCV:
1101     case SVt_PVLV:
1102     case SVt_PVMG:
1103     case SVt_PVNV:
1104     case SVt_PV:
1105
1106         assert(new_type_details->size);
1107         /* We always allocated the full length item with PURIFY. To do this
1108            we fake things so that arena is false for all 16 types..  */
1109         if(new_type_details->arena) {
1110             /* This points to the start of the allocated area.  */
1111             new_body_inline(new_body, new_type_details->size, new_type);
1112             Zero(new_body, new_type_details->size, char);
1113             new_body = ((char *)new_body) - new_type_details->offset;
1114         } else {
1115             new_body = new_NOARENAZ(new_type_details);
1116         }
1117         SvANY(sv) = new_body;
1118
1119         if (old_type_details->copy) {
1120             Copy((char *)old_body + old_type_details->offset,
1121                  (char *)new_body + old_type_details->offset,
1122                  old_type_details->copy, char);
1123         }
1124
1125 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1126     /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1127        0.0 for us.  */
1128         if (old_type_details->zero_nv)
1129             SvNV_set(sv, 0);
1130 #endif
1131
1132         if (new_type == SVt_PVIO)
1133             IoPAGE_LEN(sv)      = 60;
1134         if (old_type < SVt_RV)
1135             SvPV_set(sv, 0);
1136         break;
1137     default:
1138         Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
1139     }
1140
1141     if (old_type_details->size) {
1142         /* If the old body had an allocated size, then we need to free it.  */
1143 #ifdef PURIFY
1144         my_safefree(old_body);
1145 #else
1146         del_body((void*)((char*)old_body + old_type_details->offset),
1147                  &PL_body_roots[old_type]);
1148 #endif
1149     }
1150 }
1151
1152 /*
1153 =for apidoc sv_backoff
1154
1155 Remove any string offset. You should normally use the C<SvOOK_off> macro
1156 wrapper instead.
1157
1158 =cut
1159 */
1160
1161 int
1162 Perl_sv_backoff(pTHX_ register SV *sv)
1163 {
1164     assert(SvOOK(sv));
1165     assert(SvTYPE(sv) != SVt_PVHV);
1166     assert(SvTYPE(sv) != SVt_PVAV);
1167     if (SvIVX(sv)) {
1168         const char * const s = SvPVX_const(sv);
1169         SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1170         SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1171         SvIV_set(sv, 0);
1172         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1173     }
1174     SvFLAGS(sv) &= ~SVf_OOK;
1175     return 0;
1176 }
1177
1178 /*
1179 =for apidoc sv_grow
1180
1181 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1182 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1183 Use the C<SvGROW> wrapper instead.
1184
1185 =cut
1186 */
1187
1188 char *
1189 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1190 {
1191     register char *s;
1192
1193 #ifdef HAS_64K_LIMIT
1194     if (newlen >= 0x10000) {
1195         PerlIO_printf(Perl_debug_log,
1196                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1197         my_exit(1);
1198     }
1199 #endif /* HAS_64K_LIMIT */
1200     if (SvROK(sv))
1201         sv_unref(sv);
1202     if (SvTYPE(sv) < SVt_PV) {
1203         sv_upgrade(sv, SVt_PV);
1204         s = SvPVX_mutable(sv);
1205     }
1206     else if (SvOOK(sv)) {       /* pv is offset? */
1207         sv_backoff(sv);
1208         s = SvPVX_mutable(sv);
1209         if (newlen > SvLEN(sv))
1210             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1211 #ifdef HAS_64K_LIMIT
1212         if (newlen >= 0x10000)
1213             newlen = 0xFFFF;
1214 #endif
1215     }
1216     else
1217         s = SvPVX_mutable(sv);
1218
1219     if (newlen > SvLEN(sv)) {           /* need more room? */
1220         newlen = PERL_STRLEN_ROUNDUP(newlen);
1221         if (SvLEN(sv) && s) {
1222 #ifdef MYMALLOC
1223             const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1224             if (newlen <= l) {
1225                 SvLEN_set(sv, l);
1226                 return s;
1227             } else
1228 #endif
1229             s = saferealloc(s, newlen);
1230         }
1231         else {
1232             s = safemalloc(newlen);
1233             if (SvPVX_const(sv) && SvCUR(sv)) {
1234                 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1235             }
1236         }
1237         SvPV_set(sv, s);
1238         SvLEN_set(sv, newlen);
1239     }
1240     return s;
1241 }
1242
1243 /*
1244 =for apidoc sv_setiv
1245
1246 Copies an integer into the given SV, upgrading first if necessary.
1247 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1248
1249 =cut
1250 */
1251
1252 void
1253 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1254 {
1255     SV_CHECK_THINKFIRST_COW_DROP(sv);
1256     switch (SvTYPE(sv)) {
1257     case SVt_NULL:
1258         sv_upgrade(sv, SVt_IV);
1259         break;
1260     case SVt_NV:
1261         sv_upgrade(sv, SVt_PVNV);
1262         break;
1263     case SVt_RV:
1264     case SVt_PV:
1265         sv_upgrade(sv, SVt_PVIV);
1266         break;
1267
1268     case SVt_PVGV:
1269     case SVt_PVAV:
1270     case SVt_PVHV:
1271     case SVt_PVCV:
1272     case SVt_PVFM:
1273     case SVt_PVIO:
1274         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1275                    OP_DESC(PL_op));
1276     }
1277     (void)SvIOK_only(sv);                       /* validate number */
1278     SvIV_set(sv, i);
1279     SvTAINT(sv);
1280 }
1281
1282 /*
1283 =for apidoc sv_setiv_mg
1284
1285 Like C<sv_setiv>, but also handles 'set' magic.
1286
1287 =cut
1288 */
1289
1290 void
1291 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1292 {
1293     sv_setiv(sv,i);
1294     SvSETMAGIC(sv);
1295 }
1296
1297 /*
1298 =for apidoc sv_setuv
1299
1300 Copies an unsigned integer into the given SV, upgrading first if necessary.
1301 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1302
1303 =cut
1304 */
1305
1306 void
1307 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1308 {
1309     /* With these two if statements:
1310        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1311
1312        without
1313        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1314
1315        If you wish to remove them, please benchmark to see what the effect is
1316     */
1317     if (u <= (UV)IV_MAX) {
1318        sv_setiv(sv, (IV)u);
1319        return;
1320     }
1321     sv_setiv(sv, 0);
1322     SvIsUV_on(sv);
1323     SvUV_set(sv, u);
1324 }
1325
1326 /*
1327 =for apidoc sv_setuv_mg
1328
1329 Like C<sv_setuv>, but also handles 'set' magic.
1330
1331 =cut
1332 */
1333
1334 void
1335 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1336 {
1337     sv_setiv(sv, 0);
1338     SvIsUV_on(sv);
1339     sv_setuv(sv,u);
1340     SvSETMAGIC(sv);
1341 }
1342
1343 /*
1344 =for apidoc sv_setnv
1345
1346 Copies a double into the given SV, upgrading first if necessary.
1347 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1348
1349 =cut
1350 */
1351
1352 void
1353 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1354 {
1355     SV_CHECK_THINKFIRST_COW_DROP(sv);
1356     switch (SvTYPE(sv)) {
1357     case SVt_NULL:
1358     case SVt_IV:
1359         sv_upgrade(sv, SVt_NV);
1360         break;
1361     case SVt_RV:
1362     case SVt_PV:
1363     case SVt_PVIV:
1364         sv_upgrade(sv, SVt_PVNV);
1365         break;
1366
1367     case SVt_PVGV:
1368     case SVt_PVAV:
1369     case SVt_PVHV:
1370     case SVt_PVCV:
1371     case SVt_PVFM:
1372     case SVt_PVIO:
1373         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1374                    OP_NAME(PL_op));
1375     }
1376     SvNV_set(sv, num);
1377     (void)SvNOK_only(sv);                       /* validate number */
1378     SvTAINT(sv);
1379 }
1380
1381 /*
1382 =for apidoc sv_setnv_mg
1383
1384 Like C<sv_setnv>, but also handles 'set' magic.
1385
1386 =cut
1387 */
1388
1389 void
1390 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1391 {
1392     sv_setnv(sv,num);
1393     SvSETMAGIC(sv);
1394 }
1395
1396 /* Print an "isn't numeric" warning, using a cleaned-up,
1397  * printable version of the offending string
1398  */
1399
1400 STATIC void
1401 S_not_a_number(pTHX_ SV *sv)
1402 {
1403      SV *dsv;
1404      char tmpbuf[64];
1405      const char *pv;
1406
1407      if (DO_UTF8(sv)) {
1408           dsv = sv_2mortal(newSVpvn("", 0));
1409           pv = sv_uni_display(dsv, sv, 10, 0);
1410      } else {
1411           char *d = tmpbuf;
1412           const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1413           /* each *s can expand to 4 chars + "...\0",
1414              i.e. need room for 8 chars */
1415         
1416           const char *s, *end;
1417           for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1418                s++) {
1419                int ch = *s & 0xFF;
1420                if (ch & 128 && !isPRINT_LC(ch)) {
1421                     *d++ = 'M';
1422                     *d++ = '-';
1423                     ch &= 127;
1424                }
1425                if (ch == '\n') {
1426                     *d++ = '\\';
1427                     *d++ = 'n';
1428                }
1429                else if (ch == '\r') {
1430                     *d++ = '\\';
1431                     *d++ = 'r';
1432                }
1433                else if (ch == '\f') {
1434                     *d++ = '\\';
1435                     *d++ = 'f';
1436                }
1437                else if (ch == '\\') {
1438                     *d++ = '\\';
1439                     *d++ = '\\';
1440                }
1441                else if (ch == '\0') {
1442                     *d++ = '\\';
1443                     *d++ = '0';
1444                }
1445                else if (isPRINT_LC(ch))
1446                     *d++ = ch;
1447                else {
1448                     *d++ = '^';
1449                     *d++ = toCTRL(ch);
1450                }
1451           }
1452           if (s < end) {
1453                *d++ = '.';
1454                *d++ = '.';
1455                *d++ = '.';
1456           }
1457           *d = '\0';
1458           pv = tmpbuf;
1459     }
1460
1461     if (PL_op)
1462         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1463                     "Argument \"%s\" isn't numeric in %s", pv,
1464                     OP_DESC(PL_op));
1465     else
1466         Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1467                     "Argument \"%s\" isn't numeric", pv);
1468 }
1469
1470 /*
1471 =for apidoc looks_like_number
1472
1473 Test if the content of an SV looks like a number (or is a number).
1474 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1475 non-numeric warning), even if your atof() doesn't grok them.
1476
1477 =cut
1478 */
1479
1480 I32
1481 Perl_looks_like_number(pTHX_ SV *sv)
1482 {
1483     register const char *sbegin;
1484     STRLEN len;
1485
1486     if (SvPOK(sv)) {
1487         sbegin = SvPVX_const(sv);
1488         len = SvCUR(sv);
1489     }
1490     else if (SvPOKp(sv))
1491         sbegin = SvPV_const(sv, len);
1492     else
1493         return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1494     return grok_number(sbegin, len, NULL);
1495 }
1496
1497 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1498    until proven guilty, assume that things are not that bad... */
1499
1500 /*
1501    NV_PRESERVES_UV:
1502
1503    As 64 bit platforms often have an NV that doesn't preserve all bits of
1504    an IV (an assumption perl has been based on to date) it becomes necessary
1505    to remove the assumption that the NV always carries enough precision to
1506    recreate the IV whenever needed, and that the NV is the canonical form.
1507    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1508    precision as a side effect of conversion (which would lead to insanity
1509    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1510    1) to distinguish between IV/UV/NV slots that have cached a valid
1511       conversion where precision was lost and IV/UV/NV slots that have a
1512       valid conversion which has lost no precision
1513    2) to ensure that if a numeric conversion to one form is requested that
1514       would lose precision, the precise conversion (or differently
1515       imprecise conversion) is also performed and cached, to prevent
1516       requests for different numeric formats on the same SV causing
1517       lossy conversion chains. (lossless conversion chains are perfectly
1518       acceptable (still))
1519
1520
1521    flags are used:
1522    SvIOKp is true if the IV slot contains a valid value
1523    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1524    SvNOKp is true if the NV slot contains a valid value
1525    SvNOK  is true only if the NV value is accurate
1526
1527    so
1528    while converting from PV to NV, check to see if converting that NV to an
1529    IV(or UV) would lose accuracy over a direct conversion from PV to
1530    IV(or UV). If it would, cache both conversions, return NV, but mark
1531    SV as IOK NOKp (ie not NOK).
1532
1533    While converting from PV to IV, check to see if converting that IV to an
1534    NV would lose accuracy over a direct conversion from PV to NV. If it
1535    would, cache both conversions, flag similarly.
1536
1537    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1538    correctly because if IV & NV were set NV *always* overruled.
1539    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1540    changes - now IV and NV together means that the two are interchangeable:
1541    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1542
1543    The benefit of this is that operations such as pp_add know that if
1544    SvIOK is true for both left and right operands, then integer addition
1545    can be used instead of floating point (for cases where the result won't
1546    overflow). Before, floating point was always used, which could lead to
1547    loss of precision compared with integer addition.
1548
1549    * making IV and NV equal status should make maths accurate on 64 bit
1550      platforms
1551    * may speed up maths somewhat if pp_add and friends start to use
1552      integers when possible instead of fp. (Hopefully the overhead in
1553      looking for SvIOK and checking for overflow will not outweigh the
1554      fp to integer speedup)
1555    * will slow down integer operations (callers of SvIV) on "inaccurate"
1556      values, as the change from SvIOK to SvIOKp will cause a call into
1557      sv_2iv each time rather than a macro access direct to the IV slot
1558    * should speed up number->string conversion on integers as IV is
1559      favoured when IV and NV are equally accurate
1560
1561    ####################################################################
1562    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1563    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1564    On the other hand, SvUOK is true iff UV.
1565    ####################################################################
1566
1567    Your mileage will vary depending your CPU's relative fp to integer
1568    performance ratio.
1569 */
1570
1571 #ifndef NV_PRESERVES_UV
1572 #  define IS_NUMBER_UNDERFLOW_IV 1
1573 #  define IS_NUMBER_UNDERFLOW_UV 2
1574 #  define IS_NUMBER_IV_AND_UV    2
1575 #  define IS_NUMBER_OVERFLOW_IV  4
1576 #  define IS_NUMBER_OVERFLOW_UV  5
1577
1578 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1579
1580 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1581 STATIC int
1582 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1583 {
1584     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));
1585     if (SvNVX(sv) < (NV)IV_MIN) {
1586         (void)SvIOKp_on(sv);
1587         (void)SvNOK_on(sv);
1588         SvIV_set(sv, IV_MIN);
1589         return IS_NUMBER_UNDERFLOW_IV;
1590     }
1591     if (SvNVX(sv) > (NV)UV_MAX) {
1592         (void)SvIOKp_on(sv);
1593         (void)SvNOK_on(sv);
1594         SvIsUV_on(sv);
1595         SvUV_set(sv, UV_MAX);
1596         return IS_NUMBER_OVERFLOW_UV;
1597     }
1598     (void)SvIOKp_on(sv);
1599     (void)SvNOK_on(sv);
1600     /* Can't use strtol etc to convert this string.  (See truth table in
1601        sv_2iv  */
1602     if (SvNVX(sv) <= (UV)IV_MAX) {
1603         SvIV_set(sv, I_V(SvNVX(sv)));
1604         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1605             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1606         } else {
1607             /* Integer is imprecise. NOK, IOKp */
1608         }
1609         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1610     }
1611     SvIsUV_on(sv);
1612     SvUV_set(sv, U_V(SvNVX(sv)));
1613     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1614         if (SvUVX(sv) == UV_MAX) {
1615             /* As we know that NVs don't preserve UVs, UV_MAX cannot
1616                possibly be preserved by NV. Hence, it must be overflow.
1617                NOK, IOKp */
1618             return IS_NUMBER_OVERFLOW_UV;
1619         }
1620         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1621     } else {
1622         /* Integer is imprecise. NOK, IOKp */
1623     }
1624     return IS_NUMBER_OVERFLOW_IV;
1625 }
1626 #endif /* !NV_PRESERVES_UV*/
1627
1628 /*
1629 =for apidoc sv_2iv_flags
1630
1631 Return the integer value of an SV, doing any necessary string
1632 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
1633 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1634
1635 =cut
1636 */
1637
1638 IV
1639 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
1640 {
1641     if (!sv)
1642         return 0;
1643     if (SvGMAGICAL(sv)) {
1644         if (flags & SV_GMAGIC)
1645             mg_get(sv);
1646         if (SvIOKp(sv))
1647             return SvIVX(sv);
1648         if (SvNOKp(sv)) {
1649             return I_V(SvNVX(sv));
1650         }
1651         if (SvPOKp(sv) && SvLEN(sv))
1652             return asIV(sv);
1653         if (!SvROK(sv)) {
1654             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1655                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1656                     report_uninit(sv);
1657             }
1658             return 0;
1659         }
1660     }
1661     if (SvTHINKFIRST(sv)) {
1662         if (SvROK(sv)) {
1663             if (SvAMAGIC(sv)) {
1664                 SV * const tmpstr=AMG_CALLun(sv,numer);
1665                 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
1666                     return SvIV(tmpstr);
1667                 }
1668             }
1669             return PTR2IV(SvRV(sv));
1670         }
1671         if (SvIsCOW(sv)) {
1672             sv_force_normal_flags(sv, 0);
1673         }
1674         if (SvREADONLY(sv) && !SvOK(sv)) {
1675             if (ckWARN(WARN_UNINITIALIZED))
1676                 report_uninit(sv);
1677             return 0;
1678         }
1679     }
1680     if (SvIOKp(sv)) {
1681         if (SvIsUV(sv)) {
1682             return (IV)(SvUVX(sv));
1683         }
1684         else {
1685             return SvIVX(sv);
1686         }
1687     }
1688     if (SvNOKp(sv)) {
1689         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1690          * without also getting a cached IV/UV from it at the same time
1691          * (ie PV->NV conversion should detect loss of accuracy and cache
1692          * IV or UV at same time to avoid this.  NWC */
1693
1694         if (SvTYPE(sv) == SVt_NV)
1695             sv_upgrade(sv, SVt_PVNV);
1696
1697         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1698         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1699            certainly cast into the IV range at IV_MAX, whereas the correct
1700            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1701            cases go to UV */
1702         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1703             SvIV_set(sv, I_V(SvNVX(sv)));
1704             if (SvNVX(sv) == (NV) SvIVX(sv)
1705 #ifndef NV_PRESERVES_UV
1706                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1707                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1708                 /* Don't flag it as "accurately an integer" if the number
1709                    came from a (by definition imprecise) NV operation, and
1710                    we're outside the range of NV integer precision */
1711 #endif
1712                 ) {
1713                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1714                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1715                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
1716                                       PTR2UV(sv),
1717                                       SvNVX(sv),
1718                                       SvIVX(sv)));
1719
1720             } else {
1721                 /* IV not precise.  No need to convert from PV, as NV
1722                    conversion would already have cached IV if it detected
1723                    that PV->IV would be better than PV->NV->IV
1724                    flags already correct - don't set public IOK.  */
1725                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1726                                       "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
1727                                       PTR2UV(sv),
1728                                       SvNVX(sv),
1729                                       SvIVX(sv)));
1730             }
1731             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1732                but the cast (NV)IV_MIN rounds to a the value less (more
1733                negative) than IV_MIN which happens to be equal to SvNVX ??
1734                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1735                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1736                (NV)UVX == NVX are both true, but the values differ. :-(
1737                Hopefully for 2s complement IV_MIN is something like
1738                0x8000000000000000 which will be exact. NWC */
1739         }
1740         else {
1741             SvUV_set(sv, U_V(SvNVX(sv)));
1742             if (
1743                 (SvNVX(sv) == (NV) SvUVX(sv))
1744 #ifndef  NV_PRESERVES_UV
1745                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1746                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1747                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1748                 /* Don't flag it as "accurately an integer" if the number
1749                    came from a (by definition imprecise) NV operation, and
1750                    we're outside the range of NV integer precision */
1751 #endif
1752                 )
1753                 SvIOK_on(sv);
1754             SvIsUV_on(sv);
1755             DEBUG_c(PerlIO_printf(Perl_debug_log,
1756                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1757                                   PTR2UV(sv),
1758                                   SvUVX(sv),
1759                                   SvUVX(sv)));
1760         }
1761     }
1762     else if (SvPOKp(sv) && SvLEN(sv)) {
1763         UV value;
1764         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
1765         /* We want to avoid a possible problem when we cache an IV which
1766            may be later translated to an NV, and the resulting NV is not
1767            the same as the direct translation of the initial string
1768            (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1769            be careful to ensure that the value with the .456 is around if the
1770            NV value is requested in the future).
1771         
1772            This means that if we cache such an IV, we need to cache the
1773            NV as well.  Moreover, we trade speed for space, and do not
1774            cache the NV if we are sure it's not needed.
1775          */
1776
1777         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
1778         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1779              == IS_NUMBER_IN_UV) {
1780             /* It's definitely an integer, only upgrade to PVIV */
1781             if (SvTYPE(sv) < SVt_PVIV)
1782                 sv_upgrade(sv, SVt_PVIV);
1783             (void)SvIOK_on(sv);
1784         } else if (SvTYPE(sv) < SVt_PVNV)
1785             sv_upgrade(sv, SVt_PVNV);
1786
1787         /* If NV preserves UV then we only use the UV value if we know that
1788            we aren't going to call atof() below. If NVs don't preserve UVs
1789            then the value returned may have more precision than atof() will
1790            return, even though value isn't perfectly accurate.  */
1791         if ((numtype & (IS_NUMBER_IN_UV
1792 #ifdef NV_PRESERVES_UV
1793                         | IS_NUMBER_NOT_INT
1794 #endif
1795             )) == IS_NUMBER_IN_UV) {
1796             /* This won't turn off the public IOK flag if it was set above  */
1797             (void)SvIOKp_on(sv);
1798
1799             if (!(numtype & IS_NUMBER_NEG)) {
1800                 /* positive */;
1801                 if (value <= (UV)IV_MAX) {
1802                     SvIV_set(sv, (IV)value);
1803                 } else {
1804                     SvUV_set(sv, value);
1805                     SvIsUV_on(sv);
1806                 }
1807             } else {
1808                 /* 2s complement assumption  */
1809                 if (value <= (UV)IV_MIN) {
1810                     SvIV_set(sv, -(IV)value);
1811                 } else {
1812                     /* Too negative for an IV.  This is a double upgrade, but
1813                        I'm assuming it will be rare.  */
1814                     if (SvTYPE(sv) < SVt_PVNV)
1815                         sv_upgrade(sv, SVt_PVNV);
1816                     SvNOK_on(sv);
1817                     SvIOK_off(sv);
1818                     SvIOKp_on(sv);
1819                     SvNV_set(sv, -(NV)value);
1820                     SvIV_set(sv, IV_MIN);
1821                 }
1822             }
1823         }
1824         /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
1825            will be in the previous block to set the IV slot, and the next
1826            block to set the NV slot.  So no else here.  */
1827         
1828         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1829             != IS_NUMBER_IN_UV) {
1830             /* It wasn't an (integer that doesn't overflow the UV). */
1831             SvNV_set(sv, Atof(SvPVX_const(sv)));
1832
1833             if (! numtype && ckWARN(WARN_NUMERIC))
1834                 not_a_number(sv);
1835
1836 #if defined(USE_LONG_DOUBLE)
1837             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1838                                   PTR2UV(sv), SvNVX(sv)));
1839 #else
1840             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
1841                                   PTR2UV(sv), SvNVX(sv)));
1842 #endif
1843
1844
1845 #ifdef NV_PRESERVES_UV
1846             (void)SvIOKp_on(sv);
1847             (void)SvNOK_on(sv);
1848             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1849                 SvIV_set(sv, I_V(SvNVX(sv)));
1850                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1851                     SvIOK_on(sv);
1852                 } else {
1853                     /* Integer is imprecise. NOK, IOKp */
1854                 }
1855                 /* UV will not work better than IV */
1856             } else {
1857                 if (SvNVX(sv) > (NV)UV_MAX) {
1858                     SvIsUV_on(sv);
1859                     /* Integer is inaccurate. NOK, IOKp, is UV */
1860                     SvUV_set(sv, UV_MAX);
1861                     SvIsUV_on(sv);
1862                 } else {
1863                     SvUV_set(sv, U_V(SvNVX(sv)));
1864                     /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1865                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1866                         SvIOK_on(sv);
1867                         SvIsUV_on(sv);
1868                     } else {
1869                         /* Integer is imprecise. NOK, IOKp, is UV */
1870                         SvIsUV_on(sv);
1871                     }
1872                 }
1873             }
1874 #else /* NV_PRESERVES_UV */
1875             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1876                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
1877                 /* The IV slot will have been set from value returned by
1878                    grok_number above.  The NV slot has just been set using
1879                    Atof.  */
1880                 SvNOK_on(sv);
1881                 assert (SvIOKp(sv));
1882             } else {
1883                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1884                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1885                     /* Small enough to preserve all bits. */
1886                     (void)SvIOKp_on(sv);
1887                     SvNOK_on(sv);
1888                     SvIV_set(sv, I_V(SvNVX(sv)));
1889                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
1890                         SvIOK_on(sv);
1891                     /* Assumption: first non-preserved integer is < IV_MAX,
1892                        this NV is in the preserved range, therefore: */
1893                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1894                           < (UV)IV_MAX)) {
1895                         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);
1896                     }
1897                 } else {
1898                     /* IN_UV NOT_INT
1899                          0      0       already failed to read UV.
1900                          0      1       already failed to read UV.
1901                          1      0       you won't get here in this case. IV/UV
1902                                         slot set, public IOK, Atof() unneeded.
1903                          1      1       already read UV.
1904                        so there's no point in sv_2iuv_non_preserve() attempting
1905                        to use atol, strtol, strtoul etc.  */
1906                     sv_2iuv_non_preserve (sv, numtype);
1907                 }
1908             }
1909 #endif /* NV_PRESERVES_UV */
1910         }
1911     } else  {
1912         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
1913             report_uninit(sv);
1914         if (SvTYPE(sv) < SVt_IV)
1915             /* Typically the caller expects that sv_any is not NULL now.  */
1916             sv_upgrade(sv, SVt_IV);
1917         return 0;
1918     }
1919     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1920         PTR2UV(sv),SvIVX(sv)));
1921     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1922 }
1923
1924 /*
1925 =for apidoc sv_2uv_flags
1926
1927 Return the unsigned integer value of an SV, doing any necessary string
1928 conversion.  If flags includes SV_GMAGIC, does an mg_get() first.
1929 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
1930
1931 =cut
1932 */
1933
1934 UV
1935 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
1936 {
1937     if (!sv)
1938         return 0;
1939     if (SvGMAGICAL(sv)) {
1940         if (flags & SV_GMAGIC)
1941             mg_get(sv);
1942         if (SvIOKp(sv))
1943             return SvUVX(sv);
1944         if (SvNOKp(sv))
1945             return U_V(SvNVX(sv));
1946         if (SvPOKp(sv) && SvLEN(sv))
1947             return asUV(sv);
1948         if (!SvROK(sv)) {
1949             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1950                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
1951                     report_uninit(sv);
1952             }
1953             return 0;
1954         }
1955     }
1956     if (SvTHINKFIRST(sv)) {
1957         if (SvROK(sv)) {
1958           SV* tmpstr;
1959           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1960                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
1961               return SvUV(tmpstr);
1962           return PTR2UV(SvRV(sv));
1963         }
1964         if (SvIsCOW(sv)) {
1965             sv_force_normal_flags(sv, 0);
1966         }
1967         if (SvREADONLY(sv) && !SvOK(sv)) {
1968             if (ckWARN(WARN_UNINITIALIZED))
1969                 report_uninit(sv);
1970             return 0;
1971         }
1972     }
1973     if (SvIOKp(sv)) {
1974         if (SvIsUV(sv)) {
1975             return SvUVX(sv);
1976         }
1977         else {
1978             return (UV)SvIVX(sv);
1979         }
1980     }
1981     if (SvNOKp(sv)) {
1982         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1983          * without also getting a cached IV/UV from it at the same time
1984          * (ie PV->NV conversion should detect loss of accuracy and cache
1985          * IV or UV at same time to avoid this. */
1986         /* IV-over-UV optimisation - choose to cache IV if possible */
1987
1988         if (SvTYPE(sv) == SVt_NV)
1989             sv_upgrade(sv, SVt_PVNV);
1990
1991         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1992         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1993             SvIV_set(sv, I_V(SvNVX(sv)));
1994             if (SvNVX(sv) == (NV) SvIVX(sv)
1995 #ifndef NV_PRESERVES_UV
1996                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1997                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1998                 /* Don't flag it as "accurately an integer" if the number
1999                    came from a (by definition imprecise) NV operation, and
2000                    we're outside the range of NV integer precision */
2001 #endif
2002                 ) {
2003                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2004                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2005                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2006                                       PTR2UV(sv),
2007                                       SvNVX(sv),
2008                                       SvIVX(sv)));
2009
2010             } else {
2011                 /* IV not precise.  No need to convert from PV, as NV
2012                    conversion would already have cached IV if it detected
2013                    that PV->IV would be better than PV->NV->IV
2014                    flags already correct - don't set public IOK.  */
2015                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2016                                       "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2017                                       PTR2UV(sv),
2018                                       SvNVX(sv),
2019                                       SvIVX(sv)));
2020             }
2021             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2022                but the cast (NV)IV_MIN rounds to a the value less (more
2023                negative) than IV_MIN which happens to be equal to SvNVX ??
2024                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2025                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2026                (NV)UVX == NVX are both true, but the values differ. :-(
2027                Hopefully for 2s complement IV_MIN is something like
2028                0x8000000000000000 which will be exact. NWC */
2029         }
2030         else {
2031             SvUV_set(sv, U_V(SvNVX(sv)));
2032             if (
2033                 (SvNVX(sv) == (NV) SvUVX(sv))
2034 #ifndef  NV_PRESERVES_UV
2035                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2036                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2037                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2038                 /* Don't flag it as "accurately an integer" if the number
2039                    came from a (by definition imprecise) NV operation, and
2040                    we're outside the range of NV integer precision */
2041 #endif
2042                 )
2043                 SvIOK_on(sv);
2044             SvIsUV_on(sv);
2045             DEBUG_c(PerlIO_printf(Perl_debug_log,
2046                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2047                                   PTR2UV(sv),
2048                                   SvUVX(sv),
2049                                   SvUVX(sv)));
2050         }
2051     }
2052     else if (SvPOKp(sv) && SvLEN(sv)) {
2053         UV value;
2054         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2055
2056         /* We want to avoid a possible problem when we cache a UV which
2057            may be later translated to an NV, and the resulting NV is not
2058            the translation of the initial data.
2059         
2060            This means that if we cache such a UV, we need to cache the
2061            NV as well.  Moreover, we trade speed for space, and do not
2062            cache the NV if not needed.
2063          */
2064
2065         /* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2066         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2067              == IS_NUMBER_IN_UV) {
2068             /* It's definitely an integer, only upgrade to PVIV */
2069             if (SvTYPE(sv) < SVt_PVIV)
2070                 sv_upgrade(sv, SVt_PVIV);
2071             (void)SvIOK_on(sv);
2072         } else if (SvTYPE(sv) < SVt_PVNV)
2073             sv_upgrade(sv, SVt_PVNV);
2074
2075         /* If NV preserves UV then we only use the UV value if we know that
2076            we aren't going to call atof() below. If NVs don't preserve UVs
2077            then the value returned may have more precision than atof() will
2078            return, even though it isn't accurate.  */
2079         if ((numtype & (IS_NUMBER_IN_UV
2080 #ifdef NV_PRESERVES_UV
2081                         | IS_NUMBER_NOT_INT
2082 #endif
2083             )) == IS_NUMBER_IN_UV) {
2084             /* This won't turn off the public IOK flag if it was set above  */
2085             (void)SvIOKp_on(sv);
2086
2087             if (!(numtype & IS_NUMBER_NEG)) {
2088                 /* positive */;
2089                 if (value <= (UV)IV_MAX) {
2090                     SvIV_set(sv, (IV)value);
2091                 } else {
2092                     /* it didn't overflow, and it was positive. */
2093                     SvUV_set(sv, value);
2094                     SvIsUV_on(sv);
2095                 }
2096             } else {
2097                 /* 2s complement assumption  */
2098                 if (value <= (UV)IV_MIN) {
2099                     SvIV_set(sv, -(IV)value);
2100                 } else {
2101                     /* Too negative for an IV.  This is a double upgrade, but
2102                        I'm assuming it will be rare.  */
2103                     if (SvTYPE(sv) < SVt_PVNV)
2104                         sv_upgrade(sv, SVt_PVNV);
2105                     SvNOK_on(sv);
2106                     SvIOK_off(sv);
2107                     SvIOKp_on(sv);
2108                     SvNV_set(sv, -(NV)value);
2109                     SvIV_set(sv, IV_MIN);
2110                 }
2111             }
2112         }
2113         
2114         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2115             != IS_NUMBER_IN_UV) {
2116             /* It wasn't an integer, or it overflowed the UV. */
2117             SvNV_set(sv, Atof(SvPVX_const(sv)));
2118
2119             if (! numtype && ckWARN(WARN_NUMERIC))
2120                     not_a_number(sv);
2121
2122 #if defined(USE_LONG_DOUBLE)
2123             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2124                                   PTR2UV(sv), SvNVX(sv)));
2125 #else
2126             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2127                                   PTR2UV(sv), SvNVX(sv)));
2128 #endif
2129
2130 #ifdef NV_PRESERVES_UV
2131             (void)SvIOKp_on(sv);
2132             (void)SvNOK_on(sv);
2133             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2134                 SvIV_set(sv, I_V(SvNVX(sv)));
2135                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2136                     SvIOK_on(sv);
2137                 } else {
2138                     /* Integer is imprecise. NOK, IOKp */
2139                 }
2140                 /* UV will not work better than IV */
2141             } else {
2142                 if (SvNVX(sv) > (NV)UV_MAX) {
2143                     SvIsUV_on(sv);
2144                     /* Integer is inaccurate. NOK, IOKp, is UV */
2145                     SvUV_set(sv, UV_MAX);
2146                     SvIsUV_on(sv);
2147                 } else {
2148                     SvUV_set(sv, U_V(SvNVX(sv)));
2149                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2150                        NV preservse UV so can do correct comparison.  */
2151                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2152                         SvIOK_on(sv);
2153                         SvIsUV_on(sv);
2154                     } else {
2155                         /* Integer is imprecise. NOK, IOKp, is UV */
2156                         SvIsUV_on(sv);
2157                     }
2158                 }
2159             }
2160 #else /* NV_PRESERVES_UV */
2161             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2162                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2163                 /* The UV slot will have been set from value returned by
2164                    grok_number above.  The NV slot has just been set using
2165                    Atof.  */
2166                 SvNOK_on(sv);
2167                 assert (SvIOKp(sv));
2168             } else {
2169                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2170                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2171                     /* Small enough to preserve all bits. */
2172                     (void)SvIOKp_on(sv);
2173                     SvNOK_on(sv);
2174                     SvIV_set(sv, I_V(SvNVX(sv)));
2175                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2176                         SvIOK_on(sv);
2177                     /* Assumption: first non-preserved integer is < IV_MAX,
2178                        this NV is in the preserved range, therefore: */
2179                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2180                           < (UV)IV_MAX)) {
2181                         Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2182                     }
2183                 } else
2184                     sv_2iuv_non_preserve (sv, numtype);
2185             }
2186 #endif /* NV_PRESERVES_UV */
2187         }
2188     }
2189     else  {
2190         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2191             if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2192                 report_uninit(sv);
2193         }
2194         if (SvTYPE(sv) < SVt_IV)
2195             /* Typically the caller expects that sv_any is not NULL now.  */
2196             sv_upgrade(sv, SVt_IV);
2197         return 0;
2198     }
2199
2200     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2201                           PTR2UV(sv),SvUVX(sv)));
2202     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2203 }
2204
2205 /*
2206 =for apidoc sv_2nv
2207
2208 Return the num value of an SV, doing any necessary string or integer
2209 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2210 macros.
2211
2212 =cut
2213 */
2214
2215 NV
2216 Perl_sv_2nv(pTHX_ register SV *sv)
2217 {
2218     if (!sv)
2219         return 0.0;
2220     if (SvGMAGICAL(sv)) {
2221         mg_get(sv);
2222         if (SvNOKp(sv))
2223             return SvNVX(sv);
2224         if (SvPOKp(sv) && SvLEN(sv)) {
2225             if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2226                 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2227                 not_a_number(sv);
2228             return Atof(SvPVX_const(sv));
2229         }
2230         if (SvIOKp(sv)) {
2231             if (SvIsUV(sv))
2232                 return (NV)SvUVX(sv);
2233             else
2234                 return (NV)SvIVX(sv);
2235         }       
2236         if (!SvROK(sv)) {
2237             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2238                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2239                     report_uninit(sv);
2240             }
2241             return (NV)0;
2242         }
2243     }
2244     if (SvTHINKFIRST(sv)) {
2245         if (SvROK(sv)) {
2246           SV* tmpstr;
2247           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2248                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2249               return SvNV(tmpstr);
2250           return PTR2NV(SvRV(sv));
2251         }
2252         if (SvIsCOW(sv)) {
2253             sv_force_normal_flags(sv, 0);
2254         }
2255         if (SvREADONLY(sv) && !SvOK(sv)) {
2256             if (ckWARN(WARN_UNINITIALIZED))
2257                 report_uninit(sv);
2258             return 0.0;
2259         }
2260     }
2261     if (SvTYPE(sv) < SVt_NV) {
2262         if (SvTYPE(sv) == SVt_IV)
2263             sv_upgrade(sv, SVt_PVNV);
2264         else
2265             sv_upgrade(sv, SVt_NV);
2266 #ifdef USE_LONG_DOUBLE
2267         DEBUG_c({
2268             STORE_NUMERIC_LOCAL_SET_STANDARD();
2269             PerlIO_printf(Perl_debug_log,
2270                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2271                           PTR2UV(sv), SvNVX(sv));
2272             RESTORE_NUMERIC_LOCAL();
2273         });
2274 #else
2275         DEBUG_c({
2276             STORE_NUMERIC_LOCAL_SET_STANDARD();
2277             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2278                           PTR2UV(sv), SvNVX(sv));
2279             RESTORE_NUMERIC_LOCAL();
2280         });
2281 #endif
2282     }
2283     else if (SvTYPE(sv) < SVt_PVNV)
2284         sv_upgrade(sv, SVt_PVNV);
2285     if (SvNOKp(sv)) {
2286         return SvNVX(sv);
2287     }
2288     if (SvIOKp(sv)) {
2289         SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2290 #ifdef NV_PRESERVES_UV
2291         SvNOK_on(sv);
2292 #else
2293         /* Only set the public NV OK flag if this NV preserves the IV  */
2294         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2295         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2296                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2297             SvNOK_on(sv);
2298         else
2299             SvNOKp_on(sv);
2300 #endif
2301     }
2302     else if (SvPOKp(sv) && SvLEN(sv)) {
2303         UV value;
2304         const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2305         if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2306             not_a_number(sv);
2307 #ifdef NV_PRESERVES_UV
2308         if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2309             == IS_NUMBER_IN_UV) {
2310             /* It's definitely an integer */
2311             SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2312         } else
2313             SvNV_set(sv, Atof(SvPVX_const(sv)));
2314         SvNOK_on(sv);
2315 #else
2316         SvNV_set(sv, Atof(SvPVX_const(sv)));
2317         /* Only set the public NV OK flag if this NV preserves the value in
2318            the PV at least as well as an IV/UV would.
2319            Not sure how to do this 100% reliably. */
2320         /* if that shift count is out of range then Configure's test is
2321            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2322            UV_BITS */
2323         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2324             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2325             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2326         } else if (!(numtype & IS_NUMBER_IN_UV)) {
2327             /* Can't use strtol etc to convert this string, so don't try.
2328                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2329             SvNOK_on(sv);
2330         } else {
2331             /* value has been set.  It may not be precise.  */
2332             if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2333                 /* 2s complement assumption for (UV)IV_MIN  */
2334                 SvNOK_on(sv); /* Integer is too negative.  */
2335             } else {
2336                 SvNOKp_on(sv);
2337                 SvIOKp_on(sv);
2338
2339                 if (numtype & IS_NUMBER_NEG) {
2340                     SvIV_set(sv, -(IV)value);
2341                 } else if (value <= (UV)IV_MAX) {
2342                     SvIV_set(sv, (IV)value);
2343                 } else {
2344                     SvUV_set(sv, value);
2345                     SvIsUV_on(sv);
2346                 }
2347
2348                 if (numtype & IS_NUMBER_NOT_INT) {
2349                     /* I believe that even if the original PV had decimals,
2350                        they are lost beyond the limit of the FP precision.
2351                        However, neither is canonical, so both only get p
2352                        flags.  NWC, 2000/11/25 */
2353                     /* Both already have p flags, so do nothing */
2354                 } else {
2355                     const NV nv = SvNVX(sv);
2356                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2357                         if (SvIVX(sv) == I_V(nv)) {
2358                             SvNOK_on(sv);
2359                             SvIOK_on(sv);
2360                         } else {
2361                             SvIOK_on(sv);
2362                             /* It had no "." so it must be integer.  */
2363                         }
2364                     } else {
2365                         /* between IV_MAX and NV(UV_MAX).
2366                            Could be slightly > UV_MAX */
2367
2368                         if (numtype & IS_NUMBER_NOT_INT) {
2369                             /* UV and NV both imprecise.  */
2370                         } else {
2371                             const UV nv_as_uv = U_V(nv);
2372
2373                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2374                                 SvNOK_on(sv);
2375                                 SvIOK_on(sv);
2376                             } else {
2377                                 SvIOK_on(sv);
2378                             }
2379                         }
2380                     }
2381                 }
2382             }
2383         }
2384 #endif /* NV_PRESERVES_UV */
2385     }
2386     else  {
2387         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2388             report_uninit(sv);
2389         if (SvTYPE(sv) < SVt_NV)
2390             /* Typically the caller expects that sv_any is not NULL now.  */
2391             /* XXX Ilya implies that this is a bug in callers that assume this
2392                and ideally should be fixed.  */
2393             sv_upgrade(sv, SVt_NV);
2394         return 0.0;
2395     }
2396 #if defined(USE_LONG_DOUBLE)
2397     DEBUG_c({
2398         STORE_NUMERIC_LOCAL_SET_STANDARD();
2399         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2400                       PTR2UV(sv), SvNVX(sv));
2401         RESTORE_NUMERIC_LOCAL();
2402     });
2403 #else
2404     DEBUG_c({
2405         STORE_NUMERIC_LOCAL_SET_STANDARD();
2406         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2407                       PTR2UV(sv), SvNVX(sv));
2408         RESTORE_NUMERIC_LOCAL();
2409     });
2410 #endif
2411     return SvNVX(sv);
2412 }
2413
2414 /* asIV(): extract an integer from the string value of an SV.
2415  * Caller must validate PVX  */
2416
2417 STATIC IV
2418 S_asIV(pTHX_ SV *sv)
2419 {
2420     UV value;
2421     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2422
2423     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2424         == IS_NUMBER_IN_UV) {
2425         /* It's definitely an integer */
2426         if (numtype & IS_NUMBER_NEG) {
2427             if (value < (UV)IV_MIN)
2428                 return -(IV)value;
2429         } else {
2430             if (value < (UV)IV_MAX)
2431                 return (IV)value;
2432         }
2433     }
2434     if (!numtype) {
2435         if (ckWARN(WARN_NUMERIC))
2436             not_a_number(sv);
2437     }
2438     return I_V(Atof(SvPVX_const(sv)));
2439 }
2440
2441 /* asUV(): extract an unsigned integer from the string value of an SV
2442  * Caller must validate PVX  */
2443
2444 STATIC UV
2445 S_asUV(pTHX_ SV *sv)
2446 {
2447     UV value;
2448     const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2449
2450     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2451         == IS_NUMBER_IN_UV) {
2452         /* It's definitely an integer */
2453         if (!(numtype & IS_NUMBER_NEG))
2454             return value;
2455     }
2456     if (!numtype) {
2457         if (ckWARN(WARN_NUMERIC))
2458             not_a_number(sv);
2459     }
2460     return U_V(Atof(SvPVX_const(sv)));
2461 }
2462
2463 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2464  * UV as a string towards the end of buf, and return pointers to start and
2465  * end of it.
2466  *
2467  * We assume that buf is at least TYPE_CHARS(UV) long.
2468  */
2469
2470 static char *
2471 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2472 {
2473     char *ptr = buf + TYPE_CHARS(UV);
2474     char * const ebuf = ptr;
2475     int sign;
2476
2477     if (is_uv)
2478         sign = 0;
2479     else if (iv >= 0) {
2480         uv = iv;
2481         sign = 0;
2482     } else {
2483         uv = -iv;
2484         sign = 1;
2485     }
2486     do {
2487         *--ptr = '0' + (char)(uv % 10);
2488     } while (uv /= 10);
2489     if (sign)
2490         *--ptr = '-';
2491     *peob = ebuf;
2492     return ptr;
2493 }
2494
2495 /*
2496 =for apidoc sv_2pv_flags
2497
2498 Returns a pointer to the string value of an SV, and sets *lp to its length.
2499 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2500 if necessary.
2501 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2502 usually end up here too.
2503
2504 =cut
2505 */
2506
2507 char *
2508 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2509 {
2510     register char *s;
2511     int olderrno;
2512     SV *tsv;
2513     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2514     char *tmpbuf = tbuf;
2515     STRLEN len = 0;     /* Hush gcc. len is always initialised before use.  */
2516
2517     if (!sv) {
2518         if (lp)
2519             *lp = 0;
2520         return (char *)"";
2521     }
2522     if (SvGMAGICAL(sv)) {
2523         if (flags & SV_GMAGIC)
2524             mg_get(sv);
2525         if (SvPOKp(sv)) {
2526             if (lp)
2527                 *lp = SvCUR(sv);
2528             if (flags & SV_MUTABLE_RETURN)
2529                 return SvPVX_mutable(sv);
2530             if (flags & SV_CONST_RETURN)
2531                 return (char *)SvPVX_const(sv);
2532             return SvPVX(sv);
2533         }
2534         if (SvIOKp(sv)) {
2535             len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
2536                 : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2537             tsv = Nullsv;
2538             goto tokensave_has_len;
2539         }
2540         if (SvNOKp(sv)) {
2541             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2542             tsv = Nullsv;
2543             goto tokensave;
2544         }
2545         if (!SvROK(sv)) {
2546             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2547                 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2548                     report_uninit(sv);
2549             }
2550             if (lp)
2551                 *lp = 0;
2552             return (char *)"";
2553         }
2554     }
2555     if (SvTHINKFIRST(sv)) {
2556         if (SvROK(sv)) {
2557             SV* tmpstr;
2558
2559             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2560                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2561                 /* Unwrap this:  */
2562                 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
2563
2564                 char *pv;
2565                 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
2566                     if (flags & SV_CONST_RETURN) {
2567                         pv = (char *) SvPVX_const(tmpstr);
2568                     } else {
2569                         pv = (flags & SV_MUTABLE_RETURN)
2570                             ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
2571                     }
2572                     if (lp)
2573                         *lp = SvCUR(tmpstr);
2574                 } else {
2575                     pv = sv_2pv_flags(tmpstr, lp, flags);
2576                 }
2577                 if (SvUTF8(tmpstr))
2578                     SvUTF8_on(sv);
2579                 else
2580                     SvUTF8_off(sv);
2581                 return pv;
2582             } else {
2583                 MAGIC *mg;
2584                 const SV *const referent = (SV*)SvRV(sv);
2585
2586                 if (!referent) {
2587                     tsv = sv_2mortal(newSVpvn("NULLREF", 7));
2588                 } else if (SvTYPE(referent) == SVt_PVMG
2589                            && ((SvFLAGS(referent) &
2590                                 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2591                                == (SVs_OBJECT|SVs_SMG))
2592                            && (mg = mg_find(referent, PERL_MAGIC_qr))) {
2593                     const regexp *re = (regexp *)mg->mg_obj;
2594
2595                     if (!mg->mg_ptr) {
2596                         const char *fptr = "msix";
2597                         char reflags[6];
2598                         char ch;
2599                         int left = 0;
2600                         int right = 4;
2601                         char need_newline = 0;
2602                         U16 reganch =
2603                             (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2604
2605                         while((ch = *fptr++)) {
2606                             if(reganch & 1) {
2607                                 reflags[left++] = ch;
2608                             }
2609                             else {
2610                                 reflags[right--] = ch;
2611                             }
2612                             reganch >>= 1;
2613                         }
2614                         if(left != 4) {
2615                             reflags[left] = '-';
2616                             left = 5;
2617                         }
2618
2619                         mg->mg_len = re->prelen + 4 + left;
2620                         /*
2621                          * If /x was used, we have to worry about a regex
2622                          * ending with a comment later being embedded
2623                          * within another regex. If so, we don't want this
2624                          * regex's "commentization" to leak out to the
2625                          * right part of the enclosing regex, we must cap
2626                          * it with a newline.
2627                          *
2628                          * So, if /x was used, we scan backwards from the
2629                          * end of the regex. If we find a '#' before we
2630                          * find a newline, we need to add a newline
2631                          * ourself. If we find a '\n' first (or if we
2632                          * don't find '#' or '\n'), we don't need to add
2633                          * anything.  -jfriedl
2634                          */
2635                         if (PMf_EXTENDED & re->reganch) {
2636                             const char *endptr = re->precomp + re->prelen;
2637                             while (endptr >= re->precomp) {
2638                                 const char c = *(endptr--);
2639                                 if (c == '\n')
2640                                     break; /* don't need another */
2641                                 if (c == '#') {
2642                                     /* we end while in a comment, so we
2643                                        need a newline */
2644                                     mg->mg_len++; /* save space for it */
2645                                     need_newline = 1; /* note to add it */
2646                                     break;
2647                                 }
2648                             }
2649                         }
2650
2651                         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
2652                         Copy("(?", mg->mg_ptr, 2, char);
2653                         Copy(reflags, mg->mg_ptr+2, left, char);
2654                         Copy(":", mg->mg_ptr+left+2, 1, char);
2655                         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2656                         if (need_newline)
2657                             mg->mg_ptr[mg->mg_len - 2] = '\n';
2658                         mg->mg_ptr[mg->mg_len - 1] = ')';
2659                         mg->mg_ptr[mg->mg_len] = 0;
2660                     }
2661                     PL_reginterp_cnt += re->program[0].next_off;
2662
2663                     if (re->reganch & ROPT_UTF8)
2664                         SvUTF8_on(sv);
2665                     else
2666                         SvUTF8_off(sv);
2667                     if (lp)
2668                         *lp = mg->mg_len;
2669                     return mg->mg_ptr;
2670                 } else {
2671                     const char *const typestr = sv_reftype(referent, 0);
2672
2673                     tsv = sv_newmortal();
2674                     if (SvOBJECT(referent)) {
2675                         const char *const name = HvNAME_get(SvSTASH(referent));
2676                         Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
2677                                        name ? name : "__ANON__" , typestr,
2678                                        PTR2UV(referent));
2679                     }
2680                     else
2681                         Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
2682                                        PTR2UV(referent));
2683                 }
2684                 if (lp)
2685                     *lp = SvCUR(tsv);
2686                 return SvPVX(tsv);
2687             }
2688         }
2689         if (SvREADONLY(sv) && !SvOK(sv)) {
2690             if (ckWARN(WARN_UNINITIALIZED))
2691                 report_uninit(sv);
2692             if (lp)
2693                 *lp = 0;
2694             return (char *)"";
2695         }
2696     }
2697     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2698         /* I'm assuming that if both IV and NV are equally valid then
2699            converting the IV is going to be more efficient */
2700         const U32 isIOK = SvIOK(sv);
2701         const U32 isUIOK = SvIsUV(sv);
2702         char buf[TYPE_CHARS(UV)];
2703         char *ebuf, *ptr;
2704
2705         if (SvTYPE(sv) < SVt_PVIV)
2706             sv_upgrade(sv, SVt_PVIV);
2707         if (isUIOK)
2708             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2709         else
2710             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2711         /* inlined from sv_setpvn */
2712         SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
2713         Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
2714         SvCUR_set(sv, ebuf - ptr);
2715         s = SvEND(sv);
2716         *s = '\0';
2717         if (isIOK)
2718             SvIOK_on(sv);
2719         else
2720             SvIOKp_on(sv);
2721         if (isUIOK)
2722             SvIsUV_on(sv);
2723     }
2724     else if (SvNOKp(sv)) {
2725         if (SvTYPE(sv) < SVt_PVNV)
2726             sv_upgrade(sv, SVt_PVNV);
2727         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2728         s = SvGROW_mutable(sv, NV_DIG + 20);
2729         olderrno = errno;       /* some Xenix systems wipe out errno here */
2730 #ifdef apollo
2731         if (SvNVX(sv) == 0.0)
2732             (void)strcpy(s,"0");
2733         else
2734 #endif /*apollo*/
2735         {
2736             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2737         }
2738         errno = olderrno;
2739 #ifdef FIXNEGATIVEZERO
2740         if (*s == '-' && s[1] == '0' && !s[2])
2741             strcpy(s,"0");
2742 #endif
2743         while (*s) s++;
2744 #ifdef hcx
2745         if (s[-1] == '.')
2746             *--s = '\0';
2747 #endif
2748     }
2749     else {
2750         if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2751             report_uninit(sv);
2752         if (lp)
2753         *lp = 0;
2754         if (SvTYPE(sv) < SVt_PV)
2755             /* Typically the caller expects that sv_any is not NULL now.  */
2756             sv_upgrade(sv, SVt_PV);
2757         return (char *)"";
2758     }
2759     {
2760         const STRLEN len = s - SvPVX_const(sv);
2761         if (lp) 
2762             *lp = len;
2763         SvCUR_set(sv, len);
2764     }
2765     SvPOK_on(sv);
2766     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2767                           PTR2UV(sv),SvPVX_const(sv)));
2768     if (flags & SV_CONST_RETURN)
2769         return (char *)SvPVX_const(sv);
2770     if (flags & SV_MUTABLE_RETURN)
2771         return SvPVX_mutable(sv);
2772     return SvPVX(sv);
2773
2774   tokensave:
2775     len = strlen(tmpbuf);
2776  tokensave_has_len:
2777     assert (!tsv);
2778     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2779         /* Sneaky stuff here */
2780
2781         if (!tsv)
2782             tsv = newSVpvn(tmpbuf, len);
2783         sv_2mortal(tsv);
2784         if (lp)
2785             *lp = SvCUR(tsv);
2786         return SvPVX(tsv);
2787     }
2788     else {
2789         dVAR;
2790
2791 #ifdef FIXNEGATIVEZERO
2792         if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
2793             tmpbuf[0] = '0';
2794             tmpbuf[1] = 0;
2795             len = 1;
2796         }
2797 #endif
2798         SvUPGRADE(sv, SVt_PV);
2799         if (lp)
2800             *lp = len;
2801         s = SvGROW_mutable(sv, len + 1);
2802         SvCUR_set(sv, len);
2803         SvPOKp_on(sv);
2804         return memcpy(s, tmpbuf, len + 1);
2805     }
2806 }
2807
2808 /*
2809 =for apidoc sv_copypv
2810
2811 Copies a stringified representation of the source SV into the
2812 destination SV.  Automatically performs any necessary mg_get and
2813 coercion of numeric values into strings.  Guaranteed to preserve
2814 UTF-8 flag even from overloaded objects.  Similar in nature to
2815 sv_2pv[_flags] but operates directly on an SV instead of just the
2816 string.  Mostly uses sv_2pv_flags to do its work, except when that
2817 would lose the UTF-8'ness of the PV.
2818
2819 =cut
2820 */
2821
2822 void
2823 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
2824 {
2825     STRLEN len;
2826     const char * const s = SvPV_const(ssv,len);
2827     sv_setpvn(dsv,s,len);
2828     if (SvUTF8(ssv))
2829         SvUTF8_on(dsv);
2830     else
2831         SvUTF8_off(dsv);
2832 }
2833
2834 /*
2835 =for apidoc sv_2pvbyte
2836
2837 Return a pointer to the byte-encoded representation of the SV, and set *lp
2838 to its length.  May cause the SV to be downgraded from UTF-8 as a
2839 side-effect.
2840
2841 Usually accessed via the C<SvPVbyte> macro.
2842
2843 =cut
2844 */
2845
2846 char *
2847 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2848 {
2849     sv_utf8_downgrade(sv,0);
2850     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2851 }
2852
2853 /*
2854 =for apidoc sv_2pvutf8
2855
2856 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
2857 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
2858
2859 Usually accessed via the C<SvPVutf8> macro.
2860
2861 =cut
2862 */
2863
2864 char *
2865 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2866 {
2867     sv_utf8_upgrade(sv);
2868     return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
2869 }
2870
2871
2872 /*
2873 =for apidoc sv_2bool
2874
2875 This function is only called on magical items, and is only used by
2876 sv_true() or its macro equivalent.
2877
2878 =cut
2879 */
2880
2881 bool
2882 Perl_sv_2bool(pTHX_ register SV *sv)
2883 {
2884     SvGETMAGIC(sv);
2885
2886     if (!SvOK(sv))
2887         return 0;
2888     if (SvROK(sv)) {
2889         SV* tmpsv;
2890         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2891                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
2892             return (bool)SvTRUE(tmpsv);
2893       return SvRV(sv) != 0;
2894     }
2895     if (SvPOKp(sv)) {
2896         register XPV* const Xpvtmp = (XPV*)SvANY(sv);
2897         if (Xpvtmp &&
2898                 (*sv->sv_u.svu_pv > '0' ||
2899                 Xpvtmp->xpv_cur > 1 ||
2900                 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
2901             return 1;
2902         else
2903             return 0;
2904     }
2905     else {
2906         if (SvIOKp(sv))
2907             return SvIVX(sv) != 0;
2908         else {
2909             if (SvNOKp(sv))
2910                 return SvNVX(sv) != 0.0;
2911             else
2912                 return FALSE;
2913         }
2914     }
2915 }
2916
2917 /*
2918 =for apidoc sv_utf8_upgrade
2919
2920 Converts the PV of an SV to its UTF-8-encoded form.
2921 Forces the SV to string form if it is not already.
2922 Always sets the SvUTF8 flag to avoid future validity checks even
2923 if all the bytes have hibit clear.
2924
2925 This is not as a general purpose byte encoding to Unicode interface:
2926 use the Encode extension for that.
2927
2928 =for apidoc sv_utf8_upgrade_flags
2929
2930 Converts the PV of an SV to its UTF-8-encoded form.
2931 Forces the SV to string form if it is not already.
2932 Always sets the SvUTF8 flag to avoid future validity checks even
2933 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2934 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2935 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2936
2937 This is not as a general purpose byte encoding to Unicode interface:
2938 use the Encode extension for that.
2939
2940 =cut
2941 */
2942
2943 STRLEN
2944 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2945 {
2946     if (sv == &PL_sv_undef)
2947         return 0;
2948     if (!SvPOK(sv)) {
2949         STRLEN len = 0;
2950         if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
2951             (void) sv_2pv_flags(sv,&len, flags);
2952             if (SvUTF8(sv))
2953                 return len;
2954         } else {
2955             (void) SvPV_force(sv,len);
2956         }
2957     }
2958
2959     if (SvUTF8(sv)) {
2960         return SvCUR(sv);
2961     }
2962
2963     if (SvIsCOW(sv)) {
2964         sv_force_normal_flags(sv, 0);
2965     }
2966
2967     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
2968         sv_recode_to_utf8(sv, PL_encoding);
2969     else { /* Assume Latin-1/EBCDIC */
2970         /* This function could be much more efficient if we
2971          * had a FLAG in SVs to signal if there are any hibit
2972          * chars in the PV.  Given that there isn't such a flag
2973          * make the loop as fast as possible. */
2974         const U8 *s = (U8 *) SvPVX_const(sv);
2975         const U8 * const e = (U8 *) SvEND(sv);
2976         const U8 *t = s;
2977         int hibit = 0;
2978         
2979         while (t < e) {
2980             const U8 ch = *t++;
2981             if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2982                 break;
2983         }
2984         if (hibit) {
2985             STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2986             U8 * const recoded = bytes_to_utf8((U8*)s, &len);
2987
2988             SvPV_free(sv); /* No longer using what was there before. */
2989
2990             SvPV_set(sv, (char*)recoded);
2991             SvCUR_set(sv, len - 1);
2992             SvLEN_set(sv, len); /* No longer know the real size. */
2993         }
2994         /* Mark as UTF-8 even if no hibit - saves scanning loop */
2995         SvUTF8_on(sv);
2996     }
2997     return SvCUR(sv);
2998 }
2999
3000 /*
3001 =for apidoc sv_utf8_downgrade
3002
3003 Attempts to convert the PV of an SV from characters to bytes.
3004 If the PV contains a character beyond byte, this conversion will fail;
3005 in this case, either returns false or, if C<fail_ok> is not
3006 true, croaks.
3007
3008 This is not as a general purpose Unicode to byte encoding interface:
3009 use the Encode extension for that.
3010
3011 =cut
3012 */
3013
3014 bool
3015 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3016 {
3017     if (SvPOKp(sv) && SvUTF8(sv)) {
3018         if (SvCUR(sv)) {
3019             U8 *s;
3020             STRLEN len;
3021
3022             if (SvIsCOW(sv)) {
3023                 sv_force_normal_flags(sv, 0);
3024             }
3025             s = (U8 *) SvPV(sv, len);
3026             if (!utf8_to_bytes(s, &len)) {
3027                 if (fail_ok)
3028                     return FALSE;
3029                 else {
3030                     if (PL_op)
3031                         Perl_croak(aTHX_ "Wide character in %s",
3032                                    OP_DESC(PL_op));
3033                     else
3034                         Perl_croak(aTHX_ "Wide character");
3035                 }
3036             }
3037             SvCUR_set(sv, len);
3038         }
3039     }
3040     SvUTF8_off(sv);
3041     return TRUE;
3042 }
3043
3044 /*
3045 =for apidoc sv_utf8_encode
3046
3047 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3048 flag off so that it looks like octets again.
3049
3050 =cut
3051 */
3052
3053 void
3054 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3055 {
3056     (void) sv_utf8_upgrade(sv);
3057     if (SvIsCOW(sv)) {
3058         sv_force_normal_flags(sv, 0);
3059     }
3060     if (SvREADONLY(sv)) {
3061         Perl_croak(aTHX_ PL_no_modify);
3062     }
3063     SvUTF8_off(sv);
3064 }
3065
3066 /*
3067 =for apidoc sv_utf8_decode
3068
3069 If the PV of the SV is an octet sequence in UTF-8
3070 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3071 so that it looks like a character. If the PV contains only single-byte
3072 characters, the C<SvUTF8> flag stays being off.
3073 Scans PV for validity and returns false if the PV is invalid UTF-8.
3074
3075 =cut
3076 */
3077
3078 bool
3079 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3080 {
3081     if (SvPOKp(sv)) {
3082         const U8 *c;
3083         const U8 *e;
3084
3085         /* The octets may have got themselves encoded - get them back as
3086          * bytes
3087          */
3088         if (!sv_utf8_downgrade(sv, TRUE))
3089             return FALSE;
3090
3091         /* it is actually just a matter of turning the utf8 flag on, but
3092          * we want to make sure everything inside is valid utf8 first.
3093          */
3094         c = (const U8 *) SvPVX_const(sv);
3095         if (!is_utf8_string(c, SvCUR(sv)+1))
3096             return FALSE;
3097         e = (const U8 *) SvEND(sv);
3098         while (c < e) {
3099             const U8 ch = *c++;
3100             if (!UTF8_IS_INVARIANT(ch)) {
3101                 SvUTF8_on(sv);
3102                 break;
3103             }
3104         }
3105     }
3106     return TRUE;
3107 }
3108
3109 /*
3110 =for apidoc sv_setsv
3111
3112 Copies the contents of the source SV C<ssv> into the destination SV
3113 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3114 function if the source SV needs to be reused. Does not handle 'set' magic.
3115 Loosely speaking, it performs a copy-by-value, obliterating any previous
3116 content of the destination.
3117
3118 You probably want to use one of the assortment of wrappers, such as
3119 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3120 C<SvSetMagicSV_nosteal>.
3121
3122 =for apidoc sv_setsv_flags
3123
3124 Copies the contents of the source SV C<ssv> into the destination SV
3125 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3126 function if the source SV needs to be reused. Does not handle 'set' magic.
3127 Loosely speaking, it performs a copy-by-value, obliterating any previous
3128 content of the destination.
3129 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3130 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3131 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3132 and C<sv_setsv_nomg> are implemented in terms of this function.
3133
3134 You probably want to use one of the assortment of wrappers, such as
3135 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3136 C<SvSetMagicSV_nosteal>.
3137
3138 This is the primary function for copying scalars, and most other
3139 copy-ish functions and macros use this underneath.
3140
3141 =cut
3142 */
3143
3144 void
3145 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3146 {
3147     register U32 sflags;
3148     register int dtype;
3149     register int stype;
3150
3151     if (sstr == dstr)
3152         return;
3153     SV_CHECK_THINKFIRST_COW_DROP(dstr);
3154     if (!sstr)
3155         sstr = &PL_sv_undef;
3156     stype = SvTYPE(sstr);
3157     dtype = SvTYPE(dstr);
3158
3159     SvAMAGIC_off(dstr);
3160     if ( SvVOK(dstr) )
3161     {
3162         /* need to nuke the magic */
3163         mg_free(dstr);
3164         SvRMAGICAL_off(dstr);
3165     }
3166
3167     /* There's a lot of redundancy below but we're going for speed here */
3168
3169     switch (stype) {
3170     case SVt_NULL:
3171       undef_sstr:
3172         if (dtype != SVt_PVGV) {
3173             (void)SvOK_off(dstr);
3174             return;
3175         }
3176         break;
3177     case SVt_IV:
3178         if (SvIOK(sstr)) {
3179             switch (dtype) {
3180             case SVt_NULL:
3181                 sv_upgrade(dstr, SVt_IV);
3182                 break;
3183             case SVt_NV:
3184                 sv_upgrade(dstr, SVt_PVNV);
3185                 break;
3186             case SVt_RV:
3187             case SVt_PV:
3188                 sv_upgrade(dstr, SVt_PVIV);
3189                 break;
3190             }
3191             (void)SvIOK_only(dstr);
3192             SvIV_set(dstr,  SvIVX(sstr));
3193             if (SvIsUV(sstr))
3194                 SvIsUV_on(dstr);
3195             if (SvTAINTED(sstr))
3196                 SvTAINT(dstr);
3197             return;
3198         }
3199         goto undef_sstr;
3200
3201     case SVt_NV:
3202         if (SvNOK(sstr)) {
3203             switch (dtype) {
3204             case SVt_NULL:
3205             case SVt_IV:
3206                 sv_upgrade(dstr, SVt_NV);
3207                 break;
3208             case SVt_RV:
3209             case SVt_PV:
3210             case SVt_PVIV:
3211                 sv_upgrade(dstr, SVt_PVNV);
3212                 break;
3213             }
3214             SvNV_set(dstr, SvNVX(sstr));
3215             (void)SvNOK_only(dstr);
3216             if (SvTAINTED(sstr))
3217                 SvTAINT(dstr);
3218             return;
3219         }
3220         goto undef_sstr;
3221
3222     case SVt_RV:
3223         if (dtype < SVt_RV)
3224             sv_upgrade(dstr, SVt_RV);
3225         else if (dtype == SVt_PVGV &&
3226                  SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3227             sstr = SvRV(sstr);
3228             if (sstr == dstr) {
3229                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3230                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3231                 {
3232                     GvIMPORTED_on(dstr);
3233                 }
3234                 GvMULTI_on(dstr);
3235                 return;
3236             }
3237             goto glob_assign;
3238         }
3239         break;
3240     case SVt_PVFM:
3241 #ifdef PERL_OLD_COPY_ON_WRITE
3242         if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3243             if (dtype < SVt_PVIV)
3244                 sv_upgrade(dstr, SVt_PVIV);
3245             break;
3246         }
3247         /* Fall through */
3248 #endif
3249     case SVt_PV:
3250         if (dtype < SVt_PV)
3251             sv_upgrade(dstr, SVt_PV);
3252         break;
3253     case SVt_PVIV:
3254         if (dtype < SVt_PVIV)
3255             sv_upgrade(dstr, SVt_PVIV);
3256         break;
3257     case SVt_PVNV:
3258         if (dtype < SVt_PVNV)
3259             sv_upgrade(dstr, SVt_PVNV);
3260         break;
3261     case SVt_PVAV:
3262     case SVt_PVHV:
3263     case SVt_PVCV:
3264     case SVt_PVIO:
3265         {
3266         const char * const type = sv_reftype(sstr,0);
3267         if (PL_op)
3268             Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3269         else
3270             Perl_croak(aTHX_ "Bizarre copy of %s", type);
3271         }
3272         break;
3273
3274     case SVt_PVGV:
3275         if (dtype <= SVt_PVGV) {
3276   glob_assign:
3277             if (dtype != SVt_PVGV) {
3278                 const char * const name = GvNAME(sstr);
3279                 const STRLEN len = GvNAMELEN(sstr);
3280                 /* don't upgrade SVt_PVLV: it can hold a glob */
3281                 if (dtype != SVt_PVLV)
3282                     sv_upgrade(dstr, SVt_PVGV);
3283                 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3284                 GvSTASH(dstr) = GvSTASH(sstr);
3285                 if (GvSTASH(dstr))
3286                     Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3287                 GvNAME(dstr) = savepvn(name, len);
3288                 GvNAMELEN(dstr) = len;
3289                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3290             }
3291
3292 #ifdef GV_UNIQUE_CHECK
3293                 if (GvUNIQUE((GV*)dstr)) {
3294                     Perl_croak(aTHX_ PL_no_modify);
3295                 }
3296 #endif
3297
3298             (void)SvOK_off(dstr);
3299             GvINTRO_off(dstr);          /* one-shot flag */
3300             gp_free((GV*)dstr);
3301             GvGP(dstr) = gp_ref(GvGP(sstr));
3302             if (SvTAINTED(sstr))
3303                 SvTAINT(dstr);
3304             if (GvIMPORTED(dstr) != GVf_IMPORTED
3305                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3306             {
3307                 GvIMPORTED_on(dstr);
3308             }
3309             GvMULTI_on(dstr);
3310             return;
3311         }
3312         /* FALL THROUGH */
3313
3314     default:
3315         if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3316             mg_get(sstr);
3317             if ((int)SvTYPE(sstr) != stype) {
3318                 stype = SvTYPE(sstr);
3319                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3320                     goto glob_assign;
3321             }
3322         }
3323         if (stype == SVt_PVLV)
3324             SvUPGRADE(dstr, SVt_PVNV);
3325         else
3326             SvUPGRADE(dstr, (U32)stype);
3327     }
3328
3329     sflags = SvFLAGS(sstr);
3330
3331     if (sflags & SVf_ROK) {
3332         if (dtype >= SVt_PV) {
3333             if (dtype == SVt_PVGV) {
3334                 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3335                 SV *dref = 0;
3336                 const int intro = GvINTRO(dstr);
3337
3338 #ifdef GV_UNIQUE_CHECK
3339                 if (GvUNIQUE((GV*)dstr)) {
3340                     Perl_croak(aTHX_ PL_no_modify);
3341                 }
3342 #endif
3343
3344                 if (intro) {
3345                     GvINTRO_off(dstr);  /* one-shot flag */
3346                     GvLINE(dstr) = CopLINE(PL_curcop);
3347                     GvEGV(dstr) = (GV*)dstr;
3348                 }
3349                 GvMULTI_on(dstr);
3350                 switch (SvTYPE(sref)) {
3351                 case SVt_PVAV:
3352                     if (intro)
3353                         SAVEGENERICSV(GvAV(dstr));
3354                     else
3355                         dref = (SV*)GvAV(dstr);
3356                     GvAV(dstr) = (AV*)sref;
3357                     if (!GvIMPORTED_AV(dstr)
3358                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3359                     {
3360                         GvIMPORTED_AV_on(dstr);
3361                     }
3362                     break;
3363                 case SVt_PVHV:
3364                     if (intro)
3365                         SAVEGENERICSV(GvHV(dstr));
3366                     else
3367                         dref = (SV*)GvHV(dstr);
3368                     GvHV(dstr) = (HV*)sref;
3369                     if (!GvIMPORTED_HV(dstr)
3370                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3371                     {
3372                         GvIMPORTED_HV_on(dstr);
3373                     }
3374                     break;
3375                 case SVt_PVCV:
3376                     if (intro) {
3377                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3378                             SvREFCNT_dec(GvCV(dstr));
3379                             GvCV(dstr) = Nullcv;
3380                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3381                             PL_sub_generation++;
3382                         }
3383                         SAVEGENERICSV(GvCV(dstr));
3384                     }
3385                     else
3386                         dref = (SV*)GvCV(dstr);
3387                     if (GvCV(dstr) != (CV*)sref) {
3388                         CV* const cv = GvCV(dstr);
3389                         if (cv) {
3390                             if (!GvCVGEN((GV*)dstr) &&
3391                                 (CvROOT(cv) || CvXSUB(cv)))
3392                             {
3393                                 /* Redefining a sub - warning is mandatory if
3394                                    it was a const and its value changed. */
3395                                 if (ckWARN(WARN_REDEFINE)
3396                                     || (CvCONST(cv)
3397                                         && (!CvCONST((CV*)sref)
3398                                             || sv_cmp(cv_const_sv(cv),
3399                                                       cv_const_sv((CV*)sref)))))
3400                                 {
3401                                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3402                                         CvCONST(cv)
3403                                         ? "Constant subroutine %s::%s redefined"
3404                                         : "Subroutine %s::%s redefined",
3405                                         HvNAME_get(GvSTASH((GV*)dstr)),
3406                                         GvENAME((GV*)dstr));
3407                                 }
3408                             }
3409                             if (!intro)
3410                                 cv_ckproto(cv, (GV*)dstr,
3411                                            SvPOK(sref)
3412                                            ? SvPVX_const(sref) : Nullch);
3413                         }
3414                         GvCV(dstr) = (CV*)sref;
3415                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3416                         GvASSUMECV_on(dstr);
3417                         PL_sub_generation++;
3418                     }
3419                     if (!GvIMPORTED_CV(dstr)
3420                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3421                     {
3422                         GvIMPORTED_CV_on(dstr);
3423                     }
3424                     break;
3425                 case SVt_PVIO:
3426                     if (intro)
3427                         SAVEGENERICSV(GvIOp(dstr));
3428                     else
3429                         dref = (SV*)GvIOp(dstr);
3430                     GvIOp(dstr) = (IO*)sref;
3431                     break;
3432                 case SVt_PVFM:
3433                     if (intro)
3434                         SAVEGENERICSV(GvFORM(dstr));
3435                     else
3436                         dref = (SV*)GvFORM(dstr);
3437                     GvFORM(dstr) = (CV*)sref;
3438                     break;
3439                 default:
3440                     if (intro)
3441                         SAVEGENERICSV(GvSV(dstr));
3442                     else
3443                         dref = (SV*)GvSV(dstr);
3444                     GvSV(dstr) = sref;
3445                     if (!GvIMPORTED_SV(dstr)
3446                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3447                     {
3448                         GvIMPORTED_SV_on(dstr);
3449                     }
3450                     break;
3451                 }
3452                 if (dref)
3453                     SvREFCNT_dec(dref);
3454                 if (SvTAINTED(sstr))
3455                     SvTAINT(dstr);
3456                 return;
3457             }
3458             if (SvPVX_const(dstr)) {
3459                 SvPV_free(dstr);
3460                 SvLEN_set(dstr, 0);
3461                 SvCUR_set(dstr, 0);
3462             }
3463         }
3464         (void)SvOK_off(dstr);
3465         SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3466         SvROK_on(dstr);
3467         if (sflags & SVp_NOK) {
3468             SvNOKp_on(dstr);
3469             /* Only set the public OK flag if the source has public OK.  */
3470             if (sflags & SVf_NOK)
3471                 SvFLAGS(dstr) |= SVf_NOK;
3472             SvNV_set(dstr, SvNVX(sstr));
3473         }
3474         if (sflags & SVp_IOK) {
3475             (void)SvIOKp_on(dstr);
3476             if (sflags & SVf_IOK)
3477                 SvFLAGS(dstr) |= SVf_IOK;
3478             if (sflags & SVf_IVisUV)
3479                 SvIsUV_on(dstr);
3480             SvIV_set(dstr, SvIVX(sstr));
3481         }
3482         if (SvAMAGIC(sstr)) {
3483             SvAMAGIC_on(dstr);
3484         }
3485     }
3486     else if (sflags & SVp_POK) {
3487         bool isSwipe = 0;
3488
3489         /*
3490          * Check to see if we can just swipe the string.  If so, it's a
3491          * possible small lose on short strings, but a big win on long ones.
3492          * It might even be a win on short strings if SvPVX_const(dstr)
3493          * has to be allocated and SvPVX_const(sstr) has to be freed.
3494          */
3495
3496         /* Whichever path we take through the next code, we want this true,
3497            and doing it now facilitates the COW check.  */
3498         (void)SvPOK_only(dstr);
3499
3500         if (
3501             /* We're not already COW  */
3502             ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3503 #ifndef PERL_OLD_COPY_ON_WRITE
3504              /* or we are, but dstr isn't a suitable target.  */
3505              || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3506 #endif
3507              )
3508             &&
3509             !(isSwipe =
3510                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
3511                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
3512                  (!(flags & SV_NOSTEAL)) &&
3513                                         /* and we're allowed to steal temps */
3514                  SvREFCNT(sstr) == 1 &&   /* and no other references to it? */
3515                  SvLEN(sstr)    &&        /* and really is a string */
3516                                 /* and won't be needed again, potentially */
3517               !(PL_op && PL_op->op_type == OP_AASSIGN))
3518 #ifdef PERL_OLD_COPY_ON_WRITE
3519             && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3520                  && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
3521                  && SvTYPE(sstr) >= SVt_PVIV)
3522 #endif
3523             ) {
3524             /* Failed the swipe test, and it's not a shared hash key either.
3525                Have to copy the string.  */
3526             STRLEN len = SvCUR(sstr);
3527             SvGROW(dstr, len + 1);      /* inlined from sv_setpvn */
3528             Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
3529             SvCUR_set(dstr, len);
3530             *SvEND(dstr) = '\0';
3531         } else {
3532             /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
3533                be true in here.  */
3534             /* Either it's a shared hash key, or it's suitable for
3535                copy-on-write or we can swipe the string.  */
3536             if (DEBUG_C_TEST) {
3537                 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3538                 sv_dump(sstr);
3539                 sv_dump(dstr);
3540             }
3541 #ifdef PERL_OLD_COPY_ON_WRITE
3542             if (!isSwipe) {
3543                 /* I believe I should acquire a global SV mutex if
3544                    it's a COW sv (not a shared hash key) to stop
3545                    it going un copy-on-write.
3546                    If the source SV has gone un copy on write between up there
3547                    and down here, then (assert() that) it is of the correct
3548                    form to make it copy on write again */
3549                 if ((sflags & (SVf_FAKE | SVf_READONLY))
3550                     != (SVf_FAKE | SVf_READONLY)) {
3551                     SvREADONLY_on(sstr);
3552                     SvFAKE_on(sstr);
3553                     /* Make the source SV into a loop of 1.
3554                        (about to become 2) */
3555                     SV_COW_NEXT_SV_SET(sstr, sstr);
3556                 }
3557             }
3558 #endif
3559             /* Initial code is common.  */
3560             if (SvPVX_const(dstr)) {    /* we know that dtype >= SVt_PV */
3561                 SvPV_free(dstr);
3562             }
3563
3564             if (!isSwipe) {
3565                 /* making another shared SV.  */
3566                 STRLEN cur = SvCUR(sstr);
3567                 STRLEN len = SvLEN(sstr);
3568 #ifdef PERL_OLD_COPY_ON_WRITE
3569                 if (len) {
3570                     assert (SvTYPE(dstr) >= SVt_PVIV);
3571                     /* SvIsCOW_normal */
3572                     /* splice us in between source and next-after-source.  */
3573                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3574                     SV_COW_NEXT_SV_SET(sstr, dstr);
3575                     SvPV_set(dstr, SvPVX_mutable(sstr));
3576                 } else
3577 #endif
3578                 {
3579                     /* SvIsCOW_shared_hash */
3580                     DEBUG_C(PerlIO_printf(Perl_debug_log,
3581                                           "Copy on write: Sharing hash\n"));
3582
3583                     assert (SvTYPE(dstr) >= SVt_PV);
3584                     SvPV_set(dstr,
3585                              HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
3586                 }
3587                 SvLEN_set(dstr, len);
3588                 SvCUR_set(dstr, cur);
3589                 SvREADONLY_on(dstr);
3590                 SvFAKE_on(dstr);
3591                 /* Relesase a global SV mutex.  */
3592             }
3593             else
3594                 {       /* Passes the swipe test.  */
3595                 SvPV_set(dstr, SvPVX_mutable(sstr));
3596                 SvLEN_set(dstr, SvLEN(sstr));
3597                 SvCUR_set(dstr, SvCUR(sstr));
3598
3599                 SvTEMP_off(dstr);
3600                 (void)SvOK_off(sstr);   /* NOTE: nukes most SvFLAGS on sstr */
3601                 SvPV_set(sstr, Nullch);
3602                 SvLEN_set(sstr, 0);
3603                 SvCUR_set(sstr, 0);
3604                 SvTEMP_off(sstr);
3605             }
3606         }
3607         if (sflags & SVf_UTF8)
3608             SvUTF8_on(dstr);
3609         if (sflags & SVp_NOK) {
3610             SvNOKp_on(dstr);
3611             if (sflags & SVf_NOK)
3612                 SvFLAGS(dstr) |= SVf_NOK;
3613             SvNV_set(dstr, SvNVX(sstr));
3614         }
3615         if (sflags & SVp_IOK) {
3616             (void)SvIOKp_on(dstr);
3617             if (sflags & SVf_IOK)
3618                 SvFLAGS(dstr) |= SVf_IOK;
3619             if (sflags & SVf_IVisUV)
3620                 SvIsUV_on(dstr);
3621             SvIV_set(dstr, SvIVX(sstr));
3622         }
3623         if (SvVOK(sstr)) {
3624             MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
3625             sv_magic(dstr, NULL, PERL_MAGIC_vstring,
3626                         smg->mg_ptr, smg->mg_len);
3627             SvRMAGICAL_on(dstr);
3628         }
3629     }
3630     else if (sflags & SVp_IOK) {
3631         if (sflags & SVf_IOK)
3632             (void)SvIOK_only(dstr);
3633         else {
3634             (void)SvOK_off(dstr);
3635             (void)SvIOKp_on(dstr);
3636         }
3637         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3638         if (sflags & SVf_IVisUV)
3639             SvIsUV_on(dstr);
3640         SvIV_set(dstr, SvIVX(sstr));
3641         if (sflags & SVp_NOK) {
3642             if (sflags & SVf_NOK)
3643                 (void)SvNOK_on(dstr);
3644             else
3645                 (void)SvNOKp_on(dstr);
3646             SvNV_set(dstr, SvNVX(sstr));
3647         }
3648     }
3649     else if (sflags & SVp_NOK) {
3650         if (sflags & SVf_NOK)
3651             (void)SvNOK_only(dstr);
3652         else {
3653             (void)SvOK_off(dstr);
3654             SvNOKp_on(dstr);
3655         }
3656         SvNV_set(dstr, SvNVX(sstr));
3657     }
3658     else {
3659         if (dtype == SVt_PVGV) {
3660             if (ckWARN(WARN_MISC))
3661                 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
3662         }
3663         else
3664             (void)SvOK_off(dstr);
3665     }
3666     if (SvTAINTED(sstr))
3667         SvTAINT(dstr);
3668 }
3669
3670 /*
3671 =for apidoc sv_setsv_mg
3672
3673 Like C<sv_setsv>, but also handles 'set' magic.
3674
3675 =cut
3676 */
3677
3678 void
3679 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3680 {
3681     sv_setsv(dstr,sstr);
3682     SvSETMAGIC(dstr);
3683 }
3684
3685 #ifdef PERL_OLD_COPY_ON_WRITE
3686 SV *
3687 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
3688 {
3689     STRLEN cur = SvCUR(sstr);
3690     STRLEN len = SvLEN(sstr);
3691     register char *new_pv;
3692
3693     if (DEBUG_C_TEST) {
3694         PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
3695                       sstr, dstr);
3696         sv_dump(sstr);
3697         if (dstr)
3698                     sv_dump(dstr);
3699     }
3700
3701     if (dstr) {
3702         if (SvTHINKFIRST(dstr))
3703             sv_force_normal_flags(dstr, SV_COW_DROP_PV);
3704         else if (SvPVX_const(dstr))
3705             Safefree(SvPVX_const(dstr));
3706     }
3707     else
3708         new_SV(dstr);
3709     SvUPGRADE(dstr, SVt_PVIV);
3710
3711     assert (SvPOK(sstr));
3712     assert (SvPOKp(sstr));
3713     assert (!SvIOK(sstr));
3714     assert (!SvIOKp(sstr));
3715     assert (!SvNOK(sstr));
3716     assert (!SvNOKp(sstr));
3717
3718     if (SvIsCOW(sstr)) {
3719
3720         if (SvLEN(sstr) == 0) {
3721             /* source is a COW shared hash key.  */
3722             DEBUG_C(PerlIO_printf(Perl_debug_log,
3723                                   "Fast copy on write: Sharing hash\n"));
3724             new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
3725             goto common_exit;
3726         }
3727         SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
3728     } else {
3729         assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
3730         SvUPGRADE(sstr, SVt_PVIV);
3731         SvREADONLY_on(sstr);
3732         SvFAKE_on(sstr);
3733         DEBUG_C(PerlIO_printf(Perl_debug_log,
3734                               "Fast copy on write: Converting sstr to COW\n"));
3735         SV_COW_NEXT_SV_SET(dstr, sstr);
3736     }
3737     SV_COW_NEXT_SV_SET(sstr, dstr);
3738     new_pv = SvPVX_mutable(sstr);
3739
3740   common_exit:
3741     SvPV_set(dstr, new_pv);
3742     SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
3743     if (SvUTF8(sstr))
3744         SvUTF8_on(dstr);
3745     SvLEN_set(dstr, len);
3746     SvCUR_set(dstr, cur);
3747     if (DEBUG_C_TEST) {
3748         sv_dump(dstr);
3749     }
3750     return dstr;
3751 }
3752 #endif
3753
3754 /*
3755 =for apidoc sv_setpvn
3756
3757 Copies a string into an SV.  The C<len> parameter indicates the number of
3758 bytes to be copied.  If the C<ptr> argument is NULL the SV will become
3759 undefined.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3760
3761 =cut
3762 */
3763
3764 void
3765 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3766 {
3767     register char *dptr;
3768
3769     SV_CHECK_THINKFIRST_COW_DROP(sv);
3770     if (!ptr) {
3771         (void)SvOK_off(sv);
3772         return;
3773     }
3774     else {
3775         /* len is STRLEN which is unsigned, need to copy to signed */
3776         const IV iv = len;
3777         if (iv < 0)
3778             Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3779     }
3780     SvUPGRADE(sv, SVt_PV);
3781
3782     dptr = SvGROW(sv, len + 1);
3783     Move(ptr,dptr,len,char);
3784     dptr[len] = '\0';
3785     SvCUR_set(sv, len);
3786     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3787     SvTAINT(sv);
3788 }
3789
3790 /*
3791 =for apidoc sv_setpvn_mg
3792
3793 Like C<sv_setpvn>, but also handles 'set' magic.
3794
3795 =cut
3796 */
3797
3798 void
3799 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3800 {
3801     sv_setpvn(sv,ptr,len);
3802     SvSETMAGIC(sv);
3803 }
3804
3805 /*
3806 =for apidoc sv_setpv
3807
3808 Copies a string into an SV.  The string must be null-terminated.  Does not
3809 handle 'set' magic.  See C<sv_setpv_mg>.
3810
3811 =cut
3812 */
3813
3814 void
3815 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3816 {
3817     register STRLEN len;
3818
3819     SV_CHECK_THINKFIRST_COW_DROP(sv);
3820     if (!ptr) {
3821         (void)SvOK_off(sv);
3822         return;
3823     }
3824     len = strlen(ptr);
3825     SvUPGRADE(sv, SVt_PV);
3826
3827     SvGROW(sv, len + 1);
3828     Move(ptr,SvPVX(sv),len+1,char);
3829     SvCUR_set(sv, len);
3830     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3831     SvTAINT(sv);
3832 }
3833
3834 /*
3835 =for apidoc sv_setpv_mg
3836
3837 Like C<sv_setpv>, but also handles 'set' magic.
3838
3839 =cut
3840 */
3841
3842 void
3843 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3844 {
3845     sv_setpv(sv,ptr);
3846     SvSETMAGIC(sv);
3847 }
3848
3849 /*
3850 =for apidoc sv_usepvn
3851
3852 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3853 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3854 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3855 string length, C<len>, must be supplied.  This function will realloc the
3856 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3857 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3858 See C<sv_usepvn_mg>.
3859
3860 =cut
3861 */
3862
3863 void
3864 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3865 {
3866     STRLEN allocate;
3867     SV_CHECK_THINKFIRST_COW_DROP(sv);
3868     SvUPGRADE(sv, SVt_PV);
3869     if (!ptr) {
3870         (void)SvOK_off(sv);
3871         return;
3872     }
3873     if (SvPVX_const(sv))
3874         SvPV_free(sv);
3875
3876     allocate = PERL_STRLEN_ROUNDUP(len + 1);
3877     ptr = saferealloc (ptr, allocate);
3878     SvPV_set(sv, ptr);
3879     SvCUR_set(sv, len);
3880     SvLEN_set(sv, allocate);
3881     *SvEND(sv) = '\0';
3882     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3883     SvTAINT(sv);
3884 }
3885
3886 /*
3887 =for apidoc sv_usepvn_mg
3888
3889 Like C<sv_usepvn>, but also handles 'set' magic.
3890
3891 =cut
3892 */
3893
3894 void
3895 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3896 {
3897     sv_usepvn(sv,ptr,len);
3898     SvSETMAGIC(sv);
3899 }
3900
3901 #ifdef PERL_OLD_COPY_ON_WRITE
3902 /* Need to do this *after* making the SV normal, as we need the buffer
3903    pointer to remain valid until after we've copied it.  If we let go too early,
3904    another thread could invalidate it by unsharing last of the same hash key
3905    (which it can do by means other than releasing copy-on-write Svs)
3906    or by changing the other copy-on-write SVs in the loop.  */
3907 STATIC void
3908 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
3909 {
3910     if (len) { /* this SV was SvIsCOW_normal(sv) */
3911          /* we need to find the SV pointing to us.  */
3912         SV * const current = SV_COW_NEXT_SV(after);
3913
3914         if (current == sv) {
3915             /* The SV we point to points back to us (there were only two of us
3916                in the loop.)
3917                Hence other SV is no longer copy on write either.  */
3918             SvFAKE_off(after);
3919             SvREADONLY_off(after);
3920         } else {
3921             /* We need to follow the pointers around the loop.  */
3922             SV *next;
3923             while ((next = SV_COW_NEXT_SV(current)) != sv) {
3924                 assert (next);
3925                 current = next;
3926                  /* don't loop forever if the structure is bust, and we have
3927                     a pointer into a closed loop.  */
3928                 assert (current != after);
3929                 assert (SvPVX_const(current) == pvx);
3930             }
3931             /* Make the SV before us point to the SV after us.  */
3932             SV_COW_NEXT_SV_SET(current, after);
3933         }
3934     } else {
3935         unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
3936     }
3937 }
3938
3939 int
3940 Perl_sv_release_IVX(pTHX_ register SV *sv)
3941 {
3942     if (SvIsCOW(sv))
3943         sv_force_normal_flags(sv, 0);
3944     SvOOK_off(sv);
3945     return 0;
3946 }
3947 #endif
3948 /*
3949 =for apidoc sv_force_normal_flags
3950
3951 Undo various types of fakery on an SV: if the PV is a shared string, make
3952 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
3953 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
3954 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
3955 then a copy-on-write scalar drops its PV buffer (if any) and becomes
3956 SvPOK_off rather than making a copy. (Used where this scalar is about to be
3957 set to some other value.) In addition, the C<flags> parameter gets passed to
3958 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
3959 with flags set to 0.
3960
3961 =cut
3962 */
3963
3964 void
3965 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3966 {
3967 #ifdef PERL_OLD_COPY_ON_WRITE
3968     if (SvREADONLY(sv)) {
3969         /* At this point I believe I should acquire a global SV mutex.  */
3970         if (SvFAKE(sv)) {
3971             const char * const pvx = SvPVX_const(sv);
3972             const STRLEN len = SvLEN(sv);
3973             const STRLEN cur = SvCUR(sv);
3974             SV * const next = SV_COW_NEXT_SV(sv);   /* next COW sv in the loop. */
3975             if (DEBUG_C_TEST) {
3976                 PerlIO_printf(Perl_debug_log,
3977                               "Copy on write: Force normal %ld\n",
3978                               (long) flags);
3979                 sv_dump(sv);
3980             }
3981             SvFAKE_off(sv);
3982             SvREADONLY_off(sv);
3983             /* This SV doesn't own the buffer, so need to Newx() a new one:  */
3984             SvPV_set(sv, (char*)0);
3985             SvLEN_set(sv, 0);
3986             if (flags & SV_COW_DROP_PV) {
3987                 /* OK, so we don't need to copy our buffer.  */
3988                 SvPOK_off(sv);
3989             } else {
3990                 SvGROW(sv, cur + 1);
3991                 Move(pvx,SvPVX(sv),cur,char);
3992                 SvCUR_set(sv, cur);
3993                 *SvEND(sv) = '\0';
3994             }
3995             sv_release_COW(sv, pvx, len, next);
3996             if (DEBUG_C_TEST) {
3997                 sv_dump(sv);
3998             }
3999         }
4000         else if (IN_PERL_RUNTIME)
4001             Perl_croak(aTHX_ PL_no_modify);
4002         /* At this point I believe that I can drop the global SV mutex.  */
4003     }
4004 #else
4005     if (SvREADONLY(sv)) {
4006         if (SvFAKE(sv)) {
4007             const char * const pvx = SvPVX_const(sv);
4008             const STRLEN len = SvCUR(sv);
4009             SvFAKE_off(sv);
4010             SvREADONLY_off(sv);
4011             SvPV_set(sv, Nullch);
4012             SvLEN_set(sv, 0);
4013             SvGROW(sv, len + 1);
4014             Move(pvx,SvPVX(sv),len,char);
4015             *SvEND(sv) = '\0';
4016             unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4017         }
4018         else if (IN_PERL_RUNTIME)
4019             Perl_croak(aTHX_ PL_no_modify);
4020     }
4021 #endif
4022     if (SvROK(sv))
4023         sv_unref_flags(sv, flags);
4024     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4025         sv_unglob(sv);
4026 }
4027
4028 /*
4029 =for apidoc sv_chop
4030
4031 Efficient removal of characters from the beginning of the string buffer.
4032 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4033 the string buffer.  The C<ptr> becomes the first character of the adjusted
4034 string. Uses the "OOK hack".
4035 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4036 refer to the same chunk of data.
4037
4038 =cut
4039 */
4040
4041 void
4042 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4043 {
4044     register STRLEN delta;
4045     if (!ptr || !SvPOKp(sv))
4046         return;
4047     delta = ptr - SvPVX_const(sv);
4048     SV_CHECK_THINKFIRST(sv);
4049     if (SvTYPE(sv) < SVt_PVIV)
4050         sv_upgrade(sv,SVt_PVIV);
4051
4052     if (!SvOOK(sv)) {
4053         if (!SvLEN(sv)) { /* make copy of shared string */
4054             const char *pvx = SvPVX_const(sv);
4055             const STRLEN len = SvCUR(sv);
4056             SvGROW(sv, len + 1);
4057             Move(pvx,SvPVX(sv),len,char);
4058             *SvEND(sv) = '\0';
4059         }
4060         SvIV_set(sv, 0);
4061         /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4062            and we do that anyway inside the SvNIOK_off
4063         */
4064         SvFLAGS(sv) |= SVf_OOK;
4065     }
4066     SvNIOK_off(sv);
4067     SvLEN_set(sv, SvLEN(sv) - delta);
4068     SvCUR_set(sv, SvCUR(sv) - delta);
4069     SvPV_set(sv, SvPVX(sv) + delta);
4070     SvIV_set(sv, SvIVX(sv) + delta);
4071 }
4072
4073 /*
4074 =for apidoc sv_catpvn
4075
4076 Concatenates the string onto the end of the string which is in the SV.  The
4077 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4078 status set, then the bytes appended should be valid UTF-8.
4079 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4080
4081 =for apidoc sv_catpvn_flags
4082
4083 Concatenates the string onto the end of the string which is in the SV.  The
4084 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4085 status set, then the bytes appended should be valid UTF-8.
4086 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4087 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4088 in terms of this function.
4089
4090 =cut
4091 */
4092
4093 void
4094 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4095 {
4096     STRLEN dlen;
4097     const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4098
4099     SvGROW(dsv, dlen + slen + 1);
4100     if (sstr == dstr)
4101         sstr = SvPVX_const(dsv);
4102     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4103     SvCUR_set(dsv, SvCUR(dsv) + slen);
4104     *SvEND(dsv) = '\0';
4105     (void)SvPOK_only_UTF8(dsv);         /* validate pointer */
4106     SvTAINT(dsv);
4107     if (flags & SV_SMAGIC)
4108         SvSETMAGIC(dsv);
4109 }
4110
4111 /*
4112 =for apidoc sv_catsv
4113
4114 Concatenates the string from SV C<ssv> onto the end of the string in
4115 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4116 not 'set' magic.  See C<sv_catsv_mg>.
4117
4118 =for apidoc sv_catsv_flags
4119
4120 Concatenates the string from SV C<ssv> onto the end of the string in
4121 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4122 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4123 and C<sv_catsv_nomg> are implemented in terms of this function.
4124
4125 =cut */
4126
4127 void
4128 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4129 {
4130     const char *spv;
4131     STRLEN slen;
4132     if (ssv) {
4133         if ((spv = SvPV_const(ssv, slen))) {
4134             /*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4135                 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4136                 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4137                 get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4138                 dsv->sv_flags doesn't have that bit set.
4139                 Andy Dougherty  12 Oct 2001
4140             */
4141             const I32 sutf8 = DO_UTF8(ssv);
4142             I32 dutf8;
4143
4144             if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4145                 mg_get(dsv);
4146             dutf8 = DO_UTF8(dsv);
4147
4148             if (dutf8 != sutf8) {
4149                 if (dutf8) {
4150                     /* Not modifying source SV, so taking a temporary copy. */
4151                     SV* csv = sv_2mortal(newSVpvn(spv, slen));
4152
4153                     sv_utf8_upgrade(csv);
4154                     spv = SvPV_const(csv, slen);
4155                 }
4156                 else
4157                     sv_utf8_upgrade_nomg(dsv);
4158             }
4159             sv_catpvn_nomg(dsv, spv, slen);
4160         }
4161     }
4162     if (flags & SV_SMAGIC)
4163         SvSETMAGIC(dsv);
4164 }
4165
4166 /*
4167 =for apidoc sv_catpv
4168
4169 Concatenates the string onto the end of the string which is in the SV.
4170 If the SV has the UTF-8 status set, then the bytes appended should be
4171 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4172
4173 =cut */
4174
4175 void
4176 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4177 {
4178     register STRLEN len;
4179     STRLEN tlen;
4180     char *junk;
4181
4182     if (!ptr)
4183         return;
4184     junk = SvPV_force(sv, tlen);
4185     len = strlen(ptr);
4186     SvGROW(sv, tlen + len + 1);
4187     if (ptr == junk)
4188         ptr = SvPVX_const(sv);
4189     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4190     SvCUR_set(sv, SvCUR(sv) + len);
4191     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
4192     SvTAINT(sv);
4193 }
4194
4195 /*
4196 =for apidoc sv_catpv_mg
4197
4198 Like C<sv_catpv>, but also handles 'set' magic.
4199
4200 =cut
4201 */
4202
4203 void
4204 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4205 {
4206     sv_catpv(sv,ptr);
4207     SvSETMAGIC(sv);
4208 }
4209
4210 /*
4211 =for apidoc newSV
4212
4213 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4214 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4215 macro.
4216
4217 =cut
4218 */
4219
4220 SV *
4221 Perl_newSV(pTHX_ STRLEN len)
4222 {
4223     register SV *sv;
4224
4225     new_SV(sv);
4226     if (len) {
4227         sv_upgrade(sv, SVt_PV);
4228         SvGROW(sv, len + 1);
4229     }
4230     return sv;
4231 }
4232 /*
4233 =for apidoc sv_magicext
4234
4235 Adds magic to an SV, upgrading it if necessary. Applies the
4236 supplied vtable and returns a pointer to the magic added.
4237
4238 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4239 In particular, you can add magic to SvREADONLY SVs, and add more than
4240 one instance of the same 'how'.
4241
4242 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4243 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4244 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4245 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4246
4247 (This is now used as a subroutine by C<sv_magic>.)
4248
4249 =cut
4250 */
4251 MAGIC * 
4252 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4253                  const char* name, I32 namlen)
4254 {
4255     MAGIC* mg;
4256
4257     if (SvTYPE(sv) < SVt_PVMG) {
4258         SvUPGRADE(sv, SVt_PVMG);
4259     }
4260     Newxz(mg, 1, MAGIC);
4261     mg->mg_moremagic = SvMAGIC(sv);
4262     SvMAGIC_set(sv, mg);
4263
4264     /* Sometimes a magic contains a reference loop, where the sv and
4265        object refer to each other.  To prevent a reference loop that
4266        would prevent such objects being freed, we look for such loops
4267        and if we find one we avoid incrementing the object refcount.
4268
4269        Note we cannot do this to avoid self-tie loops as intervening RV must
4270        have its REFCNT incremented to keep it in existence.
4271
4272     */
4273     if (!obj || obj == sv ||
4274         how == PERL_MAGIC_arylen ||
4275         how == PERL_MAGIC_qr ||
4276         how == PERL_MAGIC_symtab ||
4277         (SvTYPE(obj) == SVt_PVGV &&
4278             (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4279             GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4280             GvFORM(obj) == (CV*)sv)))
4281     {
4282         mg->mg_obj = obj;
4283     }
4284     else {
4285         mg->mg_obj = SvREFCNT_inc(obj);
4286         mg->mg_flags |= MGf_REFCOUNTED;
4287     }
4288
4289     /* Normal self-ties simply pass a null object, and instead of
4290        using mg_obj directly, use the SvTIED_obj macro to produce a
4291        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4292        with an RV obj pointing to the glob containing the PVIO.  In
4293        this case, to avoid a reference loop, we need to weaken the
4294        reference.
4295     */
4296
4297     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4298         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4299     {
4300       sv_rvweaken(obj);
4301     }
4302
4303     mg->mg_type = how;
4304     mg->mg_len = namlen;
4305     if (name) {
4306         if (namlen > 0)
4307             mg->mg_ptr = savepvn(name, namlen);
4308         else if (namlen == HEf_SVKEY)
4309             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4310         else
4311             mg->mg_ptr = (char *) name;
4312     }
4313     mg->mg_virtual = vtable;
4314
4315     mg_magical(sv);
4316     if (SvGMAGICAL(sv))
4317         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4318     return mg;
4319 }
4320
4321 /*
4322 =for apidoc sv_magic
4323
4324 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4325 then adds a new magic item of type C<how> to the head of the magic list.
4326
4327 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4328 handling of the C<name> and C<namlen> arguments.
4329
4330 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4331 to add more than one instance of the same 'how'.
4332
4333 =cut
4334 */
4335
4336 void
4337 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4338 {
4339     const MGVTBL *vtable;
4340     MAGIC* mg;
4341
4342 #ifdef PERL_OLD_COPY_ON_WRITE
4343     if (SvIsCOW(sv))
4344         sv_force_normal_flags(sv, 0);
4345 #endif
4346     if (SvREADONLY(sv)) {
4347         if (
4348             /* its okay to attach magic to shared strings; the subsequent
4349              * upgrade to PVMG will unshare the string */
4350             !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4351
4352             && IN_PERL_RUNTIME
4353             && how != PERL_MAGIC_regex_global
4354             && how != PERL_MAGIC_bm
4355             && how != PERL_MAGIC_fm
4356             && how != PERL_MAGIC_sv
4357             && how != PERL_MAGIC_backref
4358            )
4359         {
4360             Perl_croak(aTHX_ PL_no_modify);
4361         }
4362     }
4363     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4364         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4365             /* sv_magic() refuses to add a magic of the same 'how' as an
4366                existing one
4367              */
4368             if (how == PERL_MAGIC_taint)
4369                 mg->mg_len |= 1;
4370             return;
4371         }
4372     }
4373
4374     switch (how) {
4375     case PERL_MAGIC_sv:
4376         vtable = &PL_vtbl_sv;
4377         break;
4378     case PERL_MAGIC_overload:
4379         vtable = &PL_vtbl_amagic;
4380         break;
4381     case PERL_MAGIC_overload_elem:
4382         vtable = &PL_vtbl_amagicelem;
4383         break;
4384     case PERL_MAGIC_overload_table:
4385         vtable = &PL_vtbl_ovrld;
4386         break;
4387     case PERL_MAGIC_bm:
4388         vtable = &PL_vtbl_bm;
4389         break;
4390     case PERL_MAGIC_regdata:
4391         vtable = &PL_vtbl_regdata;
4392         break;
4393     case PERL_MAGIC_regdatum:
4394         vtable = &PL_vtbl_regdatum;
4395         break;
4396     case PERL_MAGIC_env:
4397         vtable = &PL_vtbl_env;
4398         break;
4399     case PERL_MAGIC_fm:
4400         vtable = &PL_vtbl_fm;
4401         break;
4402     case PERL_MAGIC_envelem:
4403         vtable = &PL_vtbl_envelem;
4404         break;
4405     case PERL_MAGIC_regex_global:
4406         vtable = &PL_vtbl_mglob;
4407         break;
4408     case PERL_MAGIC_isa:
4409         vtable = &PL_vtbl_isa;
4410         break;
4411     case PERL_MAGIC_isaelem:
4412         vtable = &PL_vtbl_isaelem;
4413         break;
4414     case PERL_MAGIC_nkeys:
4415         vtable = &PL_vtbl_nkeys;
4416         break;
4417     case PERL_MAGIC_dbfile:
4418         vtable = NULL;
4419         break;
4420     case PERL_MAGIC_dbline:
4421         vtable = &PL_vtbl_dbline;
4422         break;
4423 #ifdef USE_LOCALE_COLLATE
4424     case PERL_MAGIC_collxfrm:
4425         vtable = &PL_vtbl_collxfrm;
4426         break;
4427 #endif /* USE_LOCALE_COLLATE */
4428     case PERL_MAGIC_tied:
4429         vtable = &PL_vtbl_pack;
4430         break;
4431     case PERL_MAGIC_tiedelem:
4432     case PERL_MAGIC_tiedscalar:
4433         vtable = &PL_vtbl_packelem;
4434         break;
4435     case PERL_MAGIC_qr:
4436         vtable = &PL_vtbl_regexp;
4437         break;
4438     case PERL_MAGIC_sig:
4439         vtable = &PL_vtbl_sig;
4440         break;
4441     case PERL_MAGIC_sigelem:
4442         vtable = &PL_vtbl_sigelem;
4443         break;
4444     case PERL_MAGIC_taint:
4445         vtable = &PL_vtbl_taint;
4446         break;
4447     case PERL_MAGIC_uvar:
4448         vtable = &PL_vtbl_uvar;
4449         break;
4450     case PERL_MAGIC_vec:
4451         vtable = &PL_vtbl_vec;
4452         break;
4453     case PERL_MAGIC_arylen_p:
4454     case PERL_MAGIC_rhash:
4455     case PERL_MAGIC_symtab:
4456     case PERL_MAGIC_vstring:
4457         vtable = NULL;
4458         break;
4459     case PERL_MAGIC_utf8:
4460         vtable = &PL_vtbl_utf8;
4461         break;
4462     case PERL_MAGIC_substr:
4463         vtable = &PL_vtbl_substr;
4464         break;
4465     case PERL_MAGIC_defelem:
4466         vtable = &PL_vtbl_defelem;
4467         break;
4468     case PERL_MAGIC_glob:
4469         vtable = &PL_vtbl_glob;
4470         break;
4471     case PERL_MAGIC_arylen:
4472         vtable = &PL_vtbl_arylen;
4473         break;
4474     case PERL_MAGIC_pos:
4475         vtable = &PL_vtbl_pos;
4476         break;
4477     case PERL_MAGIC_backref:
4478         vtable = &PL_vtbl_backref;
4479         break;
4480     case PERL_MAGIC_ext:
4481         /* Reserved for use by extensions not perl internals.           */
4482         /* Useful for attaching extension internal data to perl vars.   */
4483         /* Note that multiple extensions may clash if magical scalars   */
4484         /* etc holding private data from one are passed to another.     */
4485         vtable = NULL;
4486         break;
4487     default:
4488         Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4489     }
4490
4491     /* Rest of work is done else where */
4492     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4493
4494     switch (how) {
4495     case PERL_MAGIC_taint:
4496         mg->mg_len = 1;
4497         break;
4498     case PERL_MAGIC_ext:
4499     case PERL_MAGIC_dbfile:
4500         SvRMAGICAL_on(sv);
4501         break;
4502     }
4503 }
4504
4505 /*
4506 =for apidoc sv_unmagic
4507
4508 Removes all magic of type C<type> from an SV.
4509
4510 =cut
4511 */
4512
4513 int
4514 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4515 {
4516     MAGIC* mg;
4517     MAGIC** mgp;
4518     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4519         return 0;
4520     mgp = &SvMAGIC(sv);
4521     for (mg = *mgp; mg; mg = *mgp) {
4522         if (mg->mg_type == type) {
4523             const MGVTBL* const vtbl = mg->mg_virtual;
4524             *mgp = mg->mg_moremagic;
4525             if (vtbl && vtbl->svt_free)
4526                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4527             if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4528                 if (mg->mg_len > 0)
4529                     Safefree(mg->mg_ptr);
4530                 else if (mg->mg_len == HEf_SVKEY)
4531                     SvREFCNT_dec((SV*)mg->mg_ptr);
4532                 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4533                     Safefree(mg->mg_ptr);
4534             }
4535             if (mg->mg_flags & MGf_REFCOUNTED)
4536                 SvREFCNT_dec(mg->mg_obj);
4537             Safefree(mg);
4538         }
4539         else
4540             mgp = &mg->mg_moremagic;
4541     }
4542     if (!SvMAGIC(sv)) {
4543         SvMAGICAL_off(sv);
4544        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4545     }
4546
4547     return 0;
4548 }
4549
4550 /*
4551 =for apidoc sv_rvweaken
4552
4553 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4554 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4555 push a back-reference to this RV onto the array of backreferences
4556 associated with that magic.
4557
4558 =cut
4559 */
4560
4561 SV *
4562 Perl_sv_rvweaken(pTHX_ SV *sv)
4563 {
4564     SV *tsv;
4565     if (!SvOK(sv))  /* let undefs pass */
4566         return sv;
4567     if (!SvROK(sv))
4568         Perl_croak(aTHX_ "Can't weaken a nonreference");
4569     else if (SvWEAKREF(sv)) {
4570         if (ckWARN(WARN_MISC))
4571             Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4572         return sv;
4573     }
4574     tsv = SvRV(sv);
4575     Perl_sv_add_backref(aTHX_ tsv, sv);
4576     SvWEAKREF_on(sv);
4577     SvREFCNT_dec(tsv);
4578     return sv;
4579 }
4580
4581 /* Give tsv backref magic if it hasn't already got it, then push a
4582  * back-reference to sv onto the array associated with the backref magic.
4583  */
4584
4585 void
4586 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4587 {
4588     AV *av;
4589     MAGIC *mg;
4590     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4591         av = (AV*)mg->mg_obj;
4592     else {
4593         av = newAV();
4594         sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4595         /* av now has a refcnt of 2, which avoids it getting freed
4596          * before us during global cleanup. The extra ref is removed
4597          * by magic_killbackrefs() when tsv is being freed */
4598     }
4599     if (AvFILLp(av) >= AvMAX(av)) {
4600         av_extend(av, AvFILLp(av)+1);
4601     }
4602     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4603 }
4604
4605 /* delete a back-reference to ourselves from the backref magic associated
4606  * with the SV we point to.
4607  */
4608
4609 STATIC void
4610 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
4611 {
4612     AV *av;
4613     SV **svp;
4614     I32 i;
4615     MAGIC *mg = NULL;
4616     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
4617         if (PL_in_clean_all)
4618             return;
4619     }
4620     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4621         Perl_croak(aTHX_ "panic: del_backref");
4622     av = (AV *)mg->mg_obj;
4623     svp = AvARRAY(av);
4624     /* We shouldn't be in here more than once, but for paranoia reasons lets
4625        not assume this.  */
4626     for (i = AvFILLp(av); i >= 0; i--) {
4627         if (svp[i] == sv) {
4628             const SSize_t fill = AvFILLp(av);
4629             if (i != fill) {
4630                 /* We weren't the last entry.
4631                    An unordered list has this property that you can take the
4632                    last element off the end to fill the hole, and it's still
4633                    an unordered list :-)
4634                 */
4635                 svp[i] = svp[fill];
4636             }
4637             svp[fill] = Nullsv;
4638             AvFILLp(av) = fill - 1;
4639         }
4640     }
4641 }
4642
4643 /*
4644 =for apidoc sv_insert
4645
4646 Inserts a string at the specified offset/length within the SV. Similar to
4647 the Perl substr() function.
4648
4649 =cut
4650 */
4651
4652 void
4653 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
4654 {
4655     register char *big;
4656     register char *mid;
4657     register char *midend;
4658     register char *bigend;
4659     register I32 i;
4660     STRLEN curlen;
4661
4662
4663     if (!bigstr)
4664         Perl_croak(aTHX_ "Can't modify non-existent substring");
4665     SvPV_force(bigstr, curlen);
4666     (void)SvPOK_only_UTF8(bigstr);
4667     if (offset + len > curlen) {
4668         SvGROW(bigstr, offset+len+1);
4669         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4670         SvCUR_set(bigstr, offset+len);
4671     }
4672
4673     SvTAINT(bigstr);
4674     i = littlelen - len;
4675     if (i > 0) {                        /* string might grow */
4676         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4677         mid = big + offset + len;
4678         midend = bigend = big + SvCUR(bigstr);
4679         bigend += i;
4680         *bigend = '\0';
4681         while (midend > mid)            /* shove everything down */
4682             *--bigend = *--midend;
4683         Move(little,big+offset,littlelen,char);
4684         SvCUR_set(bigstr, SvCUR(bigstr) + i);
4685         SvSETMAGIC(bigstr);
4686         return;
4687     }
4688     else if (i == 0) {
4689         Move(little,SvPVX(bigstr)+offset,len,char);
4690         SvSETMAGIC(bigstr);
4691         return;
4692     }
4693
4694     big = SvPVX(bigstr);
4695     mid = big + offset;
4696     midend = mid + len;
4697     bigend = big + SvCUR(bigstr);
4698
4699     if (midend > bigend)
4700         Perl_croak(aTHX_ "panic: sv_insert");
4701
4702     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4703         if (littlelen) {
4704             Move(little, mid, littlelen,char);
4705             mid += littlelen;
4706         }
4707         i = bigend - midend;
4708         if (i > 0) {
4709             Move(midend, mid, i,char);
4710             mid += i;