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