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