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