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