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