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