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