This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Start support for fake threads.
[perl5.git] / sv.c
CommitLineData
a0d0e21e 1/* sv.c
79072805 2 *
9607fc9c 3 * Copyright (c) 1991-1997, Larry Wall
79072805
LW
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 *
a0d0e21e
LW
8 */
9
10/*
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
79072805
LW
12 */
13
14#include "EXTERN.h"
15#include "perl.h"
79072805 16
c07a80fd
PP
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
a0d0e21e
LW
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
c07a80fd
PP
37#endif
38
1edc1566 39#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
c07a80fd
PP
40# define FAST_SV_GETS
41#endif
a0d0e21e 42
36477c24
PP
43static IV asIV _((SV* sv));
44static UV asUV _((SV* sv));
a0d0e21e
LW
45static SV *more_sv _((void));
46static XPVIV *more_xiv _((void));
47static XPVNV *more_xnv _((void));
48static XPV *more_xpv _((void));
49static XRV *more_xrv _((void));
a0d0e21e
LW
50static XPVIV *new_xiv _((void));
51static XPVNV *new_xnv _((void));
52static XPV *new_xpv _((void));
53static XRV *new_xrv _((void));
54static void del_xiv _((XPVIV* p));
55static void del_xnv _((XPVNV* p));
56static void del_xpv _((XPV* p));
57static void del_xrv _((XRV* p));
58static void sv_mortalgrow _((void));
a0d0e21e
LW
59static void sv_unglob _((SV* sv));
60
4561caa4
CS
61typedef void (*SVFUNC) _((SV*));
62
a0d0e21e 63#ifdef PURIFY
79072805 64
4561caa4
CS
65#define new_SV(p) \
66 do { \
67 (p) = (SV*)safemalloc(sizeof(SV)); \
68 reg_add(p); \
69 } while (0)
70
71#define del_SV(p) \
72 do { \
73 reg_remove(p); \
74 free((char*)(p)); \
75 } while (0)
76
77static SV **registry;
78static I32 regsize;
79
80#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
81
82#define REG_REPLACE(sv,a,b) \
83 do { \
84 void* p = sv->sv_any; \
85 I32 h = REGHASH(sv, regsize); \
86 I32 i = h; \
87 while (registry[i] != (a)) { \
88 if (++i >= regsize) \
89 i = 0; \
90 if (i == h) \
91 die("SV registry bug"); \
92 } \
93 registry[i] = (b); \
94 } while (0)
95
96#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
97#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
98
99static void
100reg_add(sv)
101SV* sv;
102{
103 if (sv_count >= (regsize >> 1))
104 {
105 SV **oldreg = registry;
106 I32 oldsize = regsize;
107
108 regsize = regsize ? ((regsize << 2) + 1) : 2037;
109 registry = (SV**)safemalloc(regsize * sizeof(SV*));
110 memzero(registry, regsize * sizeof(SV*));
111
112 if (oldreg) {
113 I32 i;
114
115 for (i = 0; i < oldsize; ++i) {
116 SV* oldsv = oldreg[i];
117 if (oldsv)
118 REG_ADD(oldsv);
119 }
120 Safefree(oldreg);
121 }
122 }
123
124 REG_ADD(sv);
125 ++sv_count;
126}
127
128static void
129reg_remove(sv)
130SV* sv;
131{
132 REG_REMOVE(sv);
133 --sv_count;
134}
135
136static void
137visit(f)
138SVFUNC f;
139{
140 I32 i;
141
142 for (i = 0; i < regsize; ++i) {
143 SV* sv = registry[i];
144 if (sv)
145 (*f)(sv);
146 }
147}
a0d0e21e 148
4633a7c4
LW
149void
150sv_add_arena(ptr, size, flags)
151char* ptr;
152U32 size;
153U32 flags;
154{
155 if (!(flags & SVf_FAKE))
156 free(ptr);
157}
158
4561caa4
CS
159#else /* ! PURIFY */
160
161/*
162 * "A time to plant, and a time to uproot what was planted..."
163 */
164
165#define plant_SV(p) \
166 do { \
167 SvANY(p) = (void *)sv_root; \
168 SvFLAGS(p) = SVTYPEMASK; \
169 sv_root = (p); \
170 --sv_count; \
171 } while (0)
a0d0e21e 172
fc36a67e 173#define uproot_SV(p) \
4561caa4 174 do { \
11343788 175 MUTEX_LOCK(&sv_mutex); \
4561caa4
CS
176 (p) = sv_root; \
177 sv_root = (SV*)SvANY(p); \
a0d0e21e 178 ++sv_count; \
11343788 179 MUTEX_UNLOCK(&sv_mutex); \
4561caa4 180 } while (0)
463ee0b2 181
4561caa4
CS
182#define new_SV(p) \
183 if (sv_root) \
184 uproot_SV(p); \
185 else \
186 (p) = more_sv()
463ee0b2 187
a0d0e21e 188#ifdef DEBUGGING
4561caa4 189
a0d0e21e
LW
190#define del_SV(p) \
191 if (debug & 32768) \
192 del_sv(p); \
4561caa4
CS
193 else \
194 plant_SV(p)
a0d0e21e 195
463ee0b2
LW
196static void
197del_sv(p)
198SV* p;
199{
a0d0e21e 200 if (debug & 32768) {
4633a7c4 201 SV* sva;
a0d0e21e
LW
202 SV* sv;
203 SV* svend;
204 int ok = 0;
4633a7c4
LW
205 for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
206 sv = sva + 1;
207 svend = &sva[SvREFCNT(sva)];
a0d0e21e
LW
208 if (p >= sv && p < svend)
209 ok = 1;
210 }
211 if (!ok) {
212 warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
213 return;
214 }
215 }
4561caa4 216 plant_SV(p);
463ee0b2 217}
a0d0e21e 218
4561caa4
CS
219#else /* ! DEBUGGING */
220
221#define del_SV(p) plant_SV(p)
222
223#endif /* DEBUGGING */
463ee0b2 224
4633a7c4
LW
225void
226sv_add_arena(ptr, size, flags)
227char* ptr;
228U32 size;
229U32 flags;
463ee0b2 230{
4633a7c4 231 SV* sva = (SV*)ptr;
463ee0b2
LW
232 register SV* sv;
233 register SV* svend;
4633a7c4
LW
234 Zero(sva, size, char);
235
236 /* The first SV in an arena isn't an SV. */
237 SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */
238 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
239 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
240
241 sv_arenaroot = sva;
242 sv_root = sva + 1;
243
244 svend = &sva[SvREFCNT(sva) - 1];
245 sv = sva + 1;
463ee0b2 246 while (sv < svend) {
a0d0e21e 247 SvANY(sv) = (void *)(SV*)(sv + 1);
8990e307 248 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW
249 sv++;
250 }
251 SvANY(sv) = 0;
4633a7c4
LW
252 SvFLAGS(sv) = SVTYPEMASK;
253}
254
255static SV*
256more_sv()
257{
4561caa4
CS
258 register SV* sv;
259
c07a80fd
PP
260 if (nice_chunk) {
261 sv_add_arena(nice_chunk, nice_chunk_size, 0);
262 nice_chunk = Nullch;
263 }
1edc1566
PP
264 else {
265 char *chunk; /* must use New here to match call to */
266 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
267 sv_add_arena(chunk, 1008, 0);
268 }
4561caa4
CS
269 uproot_SV(sv);
270 return sv;
463ee0b2
LW
271}
272
4561caa4
CS
273static void
274visit(f)
275SVFUNC f;
8990e307 276{
4633a7c4 277 SV* sva;
8990e307
LW
278 SV* sv;
279 register SV* svend;
280
4561caa4 281 for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
4633a7c4 282 svend = &sva[SvREFCNT(sva)];
4561caa4
CS
283 for (sv = sva + 1; sv < svend; ++sv) {
284 if (SvTYPE(sv) != SVTYPEMASK)
285 (*f)(sv);
8990e307
LW
286 }
287 }
288}
289
4561caa4
CS
290#endif /* PURIFY */
291
292static void
293do_report_used(sv)
294SV* sv;
295{
296 if (SvTYPE(sv) != SVTYPEMASK) {
d1bf51dd 297 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
4561caa4
CS
298 PerlIO_printf(PerlIO_stderr(), "****\n");
299 sv_dump(sv);
300 }
301}
302
8990e307 303void
4561caa4
CS
304sv_report_used()
305{
306 visit(do_report_used);
307}
308
309static void
310do_clean_objs(sv)
311SV* sv;
8990e307 312{
a0d0e21e 313 SV* rv;
8990e307 314
4561caa4 315 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
d1bf51dd 316 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
4561caa4
CS
317 SvROK_off(sv);
318 SvRV(sv) = 0;
319 SvREFCNT_dec(rv);
a5f75d66 320 }
4561caa4
CS
321
322 /* XXX Might want to check arrays, etc. */
323}
324
325#ifndef DISABLE_DESTRUCTOR_KLUDGE
326static void
327do_clean_named_objs(sv)
328SV* sv;
329{
330 if (SvTYPE(sv) == SVt_PVGV && GvSV(sv))
331 do_clean_objs(GvSV(sv));
332}
a5f75d66 333#endif
4561caa4 334
477f5d66
CS
335static bool in_clean_objs = FALSE;
336
4561caa4
CS
337void
338sv_clean_objs()
339{
477f5d66 340 in_clean_objs = TRUE;
4561caa4
CS
341#ifndef DISABLE_DESTRUCTOR_KLUDGE
342 visit(do_clean_named_objs);
343#endif
344 visit(do_clean_objs);
477f5d66 345 in_clean_objs = FALSE;
4561caa4
CS
346}
347
348static void
349do_clean_all(sv)
350SV* sv;
351{
d1bf51dd 352 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));)
4561caa4
CS
353 SvFLAGS(sv) |= SVf_BREAK;
354 SvREFCNT_dec(sv);
8990e307
LW
355}
356
477f5d66 357static bool in_clean_all = FALSE;
1edc1566 358
8990e307 359void
8990e307
LW
360sv_clean_all()
361{
477f5d66 362 in_clean_all = TRUE;
4561caa4 363 visit(do_clean_all);
477f5d66 364 in_clean_all = FALSE;
8990e307 365}
463ee0b2 366
4633a7c4
LW
367void
368sv_free_arenas()
369{
370 SV* sva;
371 SV* svanext;
372
373 /* Free arenas here, but be careful about fake ones. (We assume
374 contiguity of the fake ones with the corresponding real ones.) */
375
376 for (sva = sv_arenaroot; sva; sva = svanext) {
377 svanext = (SV*) SvANY(sva);
378 while (svanext && SvFAKE(svanext))
379 svanext = (SV*) SvANY(svanext);
380
381 if (!SvFAKE(sva))
1edc1566 382 Safefree((void *)sva);
4633a7c4 383 }
5f05dabc
PP
384
385 sv_arenaroot = 0;
386 sv_root = 0;
4633a7c4
LW
387}
388
463ee0b2
LW
389static XPVIV*
390new_xiv()
391{
a0d0e21e 392 IV** xiv;
463ee0b2
LW
393 if (xiv_root) {
394 xiv = xiv_root;
85e6fe83
LW
395 /*
396 * See comment in more_xiv() -- RAM.
397 */
a0d0e21e 398 xiv_root = (IV**)*xiv;
463ee0b2
LW
399 return (XPVIV*)((char*)xiv - sizeof(XPV));
400 }
401 return more_xiv();
402}
403
404static void
405del_xiv(p)
406XPVIV* p;
407{
a0d0e21e
LW
408 IV** xiv = (IV**)((char*)(p) + sizeof(XPV));
409 *xiv = (IV *)xiv_root;
463ee0b2
LW
410 xiv_root = xiv;
411}
412
413static XPVIV*
414more_xiv()
415{
a0d0e21e
LW
416 register IV** xiv;
417 register IV** xivend;
418 XPV* ptr = (XPV*)safemalloc(1008);
419 ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */
420 xiv_arenaroot = ptr; /* to keep Purify happy */
421
422 xiv = (IV**) ptr;
423 xivend = &xiv[1008 / sizeof(IV *) - 1];
424 xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */
463ee0b2
LW
425 xiv_root = xiv;
426 while (xiv < xivend) {
a0d0e21e 427 *xiv = (IV *)(xiv + 1);
463ee0b2
LW
428 xiv++;
429 }
85e6fe83 430 *xiv = 0;
463ee0b2
LW
431 return new_xiv();
432}
433
463ee0b2
LW
434static XPVNV*
435new_xnv()
436{
437 double* xnv;
438 if (xnv_root) {
439 xnv = xnv_root;
440 xnv_root = *(double**)xnv;
441 return (XPVNV*)((char*)xnv - sizeof(XPVIV));
442 }
443 return more_xnv();
444}
445
446static void
447del_xnv(p)
448XPVNV* p;
449{
450 double* xnv = (double*)((char*)(p) + sizeof(XPVIV));
451 *(double**)xnv = xnv_root;
452 xnv_root = xnv;
453}
454
455static XPVNV*
456more_xnv()
457{
463ee0b2
LW
458 register double* xnv;
459 register double* xnvend;
8990e307 460 xnv = (double*)safemalloc(1008);
463ee0b2
LW
461 xnvend = &xnv[1008 / sizeof(double) - 1];
462 xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
463 xnv_root = xnv;
464 while (xnv < xnvend) {
465 *(double**)xnv = (double*)(xnv + 1);
466 xnv++;
467 }
468 *(double**)xnv = 0;
469 return new_xnv();
470}
471
ed6116ce
LW
472static XRV*
473new_xrv()
474{
475 XRV* xrv;
476 if (xrv_root) {
477 xrv = xrv_root;
478 xrv_root = (XRV*)xrv->xrv_rv;
479 return xrv;
480 }
481 return more_xrv();
482}
483
484static void
485del_xrv(p)
486XRV* p;
487{
488 p->xrv_rv = (SV*)xrv_root;
489 xrv_root = p;
490}
491
492static XRV*
493more_xrv()
494{
ed6116ce
LW
495 register XRV* xrv;
496 register XRV* xrvend;
8990e307 497 xrv_root = (XRV*)safemalloc(1008);
ed6116ce
LW
498 xrv = xrv_root;
499 xrvend = &xrv[1008 / sizeof(XRV) - 1];
500 while (xrv < xrvend) {
501 xrv->xrv_rv = (SV*)(xrv + 1);
502 xrv++;
503 }
504 xrv->xrv_rv = 0;
505 return new_xrv();
506}
507
463ee0b2
LW
508static XPV*
509new_xpv()
510{
511 XPV* xpv;
512 if (xpv_root) {
513 xpv = xpv_root;
514 xpv_root = (XPV*)xpv->xpv_pv;
515 return xpv;
516 }
517 return more_xpv();
518}
519
520static void
521del_xpv(p)
522XPV* p;
523{
524 p->xpv_pv = (char*)xpv_root;
525 xpv_root = p;
526}
527
528static XPV*
529more_xpv()
530{
463ee0b2
LW
531 register XPV* xpv;
532 register XPV* xpvend;
8990e307 533 xpv_root = (XPV*)safemalloc(1008);
463ee0b2
LW
534 xpv = xpv_root;
535 xpvend = &xpv[1008 / sizeof(XPV) - 1];
536 while (xpv < xpvend) {
537 xpv->xpv_pv = (char*)(xpv + 1);
538 xpv++;
539 }
540 xpv->xpv_pv = 0;
541 return new_xpv();
542}
543
544#ifdef PURIFY
8990e307 545#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
463ee0b2
LW
546#define del_XIV(p) free((char*)p)
547#else
85e6fe83 548#define new_XIV() (void*)new_xiv()
463ee0b2
LW
549#define del_XIV(p) del_xiv(p)
550#endif
551
552#ifdef PURIFY
8990e307 553#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
463ee0b2
LW
554#define del_XNV(p) free((char*)p)
555#else
85e6fe83 556#define new_XNV() (void*)new_xnv()
463ee0b2
LW
557#define del_XNV(p) del_xnv(p)
558#endif
559
560#ifdef PURIFY
8990e307 561#define new_XRV() (void*)safemalloc(sizeof(XRV))
ed6116ce
LW
562#define del_XRV(p) free((char*)p)
563#else
85e6fe83 564#define new_XRV() (void*)new_xrv()
ed6116ce
LW
565#define del_XRV(p) del_xrv(p)
566#endif
567
568#ifdef PURIFY
8990e307 569#define new_XPV() (void*)safemalloc(sizeof(XPV))
463ee0b2
LW
570#define del_XPV(p) free((char*)p)
571#else
85e6fe83 572#define new_XPV() (void*)new_xpv()
463ee0b2
LW
573#define del_XPV(p) del_xpv(p)
574#endif
575
8990e307 576#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
463ee0b2
LW
577#define del_XPVIV(p) free((char*)p)
578
8990e307 579#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
463ee0b2
LW
580#define del_XPVNV(p) free((char*)p)
581
8990e307 582#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
463ee0b2
LW
583#define del_XPVMG(p) free((char*)p)
584
8990e307 585#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
463ee0b2
LW
586#define del_XPVLV(p) free((char*)p)
587
8990e307 588#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
463ee0b2
LW
589#define del_XPVAV(p) free((char*)p)
590
8990e307 591#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
463ee0b2
LW
592#define del_XPVHV(p) free((char*)p)
593
8990e307 594#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
463ee0b2
LW
595#define del_XPVCV(p) free((char*)p)
596
8990e307 597#define new_XPVGV() (void*)safemalloc(sizeof(XPVGV))
463ee0b2
LW
598#define del_XPVGV(p) free((char*)p)
599
8990e307 600#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
463ee0b2
LW
601#define del_XPVBM(p) free((char*)p)
602
8990e307 603#define new_XPVFM() (void*)safemalloc(sizeof(XPVFM))
463ee0b2
LW
604#define del_XPVFM(p) free((char*)p)
605
8990e307
LW
606#define new_XPVIO() (void*)safemalloc(sizeof(XPVIO))
607#define del_XPVIO(p) free((char*)p)
608
79072805
LW
609bool
610sv_upgrade(sv, mt)
611register SV* sv;
612U32 mt;
613{
614 char* pv;
615 U32 cur;
616 U32 len;
a0d0e21e 617 IV iv;
79072805
LW
618 double nv;
619 MAGIC* magic;
620 HV* stash;
621
622 if (SvTYPE(sv) == mt)
623 return TRUE;
624
a5f75d66
AD
625 if (mt < SVt_PVIV)
626 (void)SvOOK_off(sv);
627
79072805
LW
628 switch (SvTYPE(sv)) {
629 case SVt_NULL:
630 pv = 0;
631 cur = 0;
632 len = 0;
633 iv = 0;
634 nv = 0.0;
635 magic = 0;
636 stash = 0;
637 break;
79072805
LW
638 case SVt_IV:
639 pv = 0;
640 cur = 0;
641 len = 0;
463ee0b2
LW
642 iv = SvIVX(sv);
643 nv = (double)SvIVX(sv);
79072805
LW
644 del_XIV(SvANY(sv));
645 magic = 0;
646 stash = 0;
ed6116ce 647 if (mt == SVt_NV)
463ee0b2 648 mt = SVt_PVNV;
ed6116ce
LW
649 else if (mt < SVt_PVIV)
650 mt = SVt_PVIV;
79072805
LW
651 break;
652 case SVt_NV:
653 pv = 0;
654 cur = 0;
655 len = 0;
463ee0b2 656 nv = SvNVX(sv);
ed6116ce 657 iv = I_32(nv);
79072805
LW
658 magic = 0;
659 stash = 0;
660 del_XNV(SvANY(sv));
661 SvANY(sv) = 0;
ed6116ce 662 if (mt < SVt_PVNV)
79072805
LW
663 mt = SVt_PVNV;
664 break;
ed6116ce
LW
665 case SVt_RV:
666 pv = (char*)SvRV(sv);
667 cur = 0;
668 len = 0;
a0d0e21e 669 iv = (IV)pv;
ed6116ce
LW
670 nv = (double)(unsigned long)pv;
671 del_XRV(SvANY(sv));
672 magic = 0;
673 stash = 0;
674 break;
79072805 675 case SVt_PV:
463ee0b2 676 pv = SvPVX(sv);
79072805
LW
677 cur = SvCUR(sv);
678 len = SvLEN(sv);
679 iv = 0;
680 nv = 0.0;
681 magic = 0;
682 stash = 0;
683 del_XPV(SvANY(sv));
748a9306
LW
684 if (mt <= SVt_IV)
685 mt = SVt_PVIV;
686 else if (mt == SVt_NV)
687 mt = SVt_PVNV;
79072805
LW
688 break;
689 case SVt_PVIV:
463ee0b2 690 pv = SvPVX(sv);
79072805
LW
691 cur = SvCUR(sv);
692 len = SvLEN(sv);
463ee0b2 693 iv = SvIVX(sv);
79072805
LW
694 nv = 0.0;
695 magic = 0;
696 stash = 0;
697 del_XPVIV(SvANY(sv));
698 break;
699 case SVt_PVNV:
463ee0b2 700 pv = SvPVX(sv);
79072805
LW
701 cur = SvCUR(sv);
702 len = SvLEN(sv);
463ee0b2
LW
703 iv = SvIVX(sv);
704 nv = SvNVX(sv);
79072805
LW
705 magic = 0;
706 stash = 0;
707 del_XPVNV(SvANY(sv));
708 break;
709 case SVt_PVMG:
463ee0b2 710 pv = SvPVX(sv);
79072805
LW
711 cur = SvCUR(sv);
712 len = SvLEN(sv);
463ee0b2
LW
713 iv = SvIVX(sv);
714 nv = SvNVX(sv);
79072805
LW
715 magic = SvMAGIC(sv);
716 stash = SvSTASH(sv);
717 del_XPVMG(SvANY(sv));
718 break;
719 default:
463ee0b2 720 croak("Can't upgrade that kind of scalar");
79072805
LW
721 }
722
723 switch (mt) {
724 case SVt_NULL:
463ee0b2 725 croak("Can't upgrade to undef");
79072805
LW
726 case SVt_IV:
727 SvANY(sv) = new_XIV();
463ee0b2 728 SvIVX(sv) = iv;
79072805
LW
729 break;
730 case SVt_NV:
731 SvANY(sv) = new_XNV();
463ee0b2 732 SvNVX(sv) = nv;
79072805 733 break;
ed6116ce
LW
734 case SVt_RV:
735 SvANY(sv) = new_XRV();
736 SvRV(sv) = (SV*)pv;
ed6116ce 737 break;
79072805
LW
738 case SVt_PV:
739 SvANY(sv) = new_XPV();
463ee0b2 740 SvPVX(sv) = pv;
79072805
LW
741 SvCUR(sv) = cur;
742 SvLEN(sv) = len;
743 break;
744 case SVt_PVIV:
745 SvANY(sv) = new_XPVIV();
463ee0b2 746 SvPVX(sv) = pv;
79072805
LW
747 SvCUR(sv) = cur;
748 SvLEN(sv) = len;
463ee0b2 749 SvIVX(sv) = iv;
79072805 750 if (SvNIOK(sv))
a0d0e21e 751 (void)SvIOK_on(sv);
79072805
LW
752 SvNOK_off(sv);
753 break;
754 case SVt_PVNV:
755 SvANY(sv) = new_XPVNV();
463ee0b2 756 SvPVX(sv) = pv;
79072805
LW
757 SvCUR(sv) = cur;
758 SvLEN(sv) = len;
463ee0b2
LW
759 SvIVX(sv) = iv;
760 SvNVX(sv) = nv;
79072805
LW
761 break;
762 case SVt_PVMG:
763 SvANY(sv) = new_XPVMG();
463ee0b2 764 SvPVX(sv) = pv;
79072805
LW
765 SvCUR(sv) = cur;
766 SvLEN(sv) = len;
463ee0b2
LW
767 SvIVX(sv) = iv;
768 SvNVX(sv) = nv;
79072805
LW
769 SvMAGIC(sv) = magic;
770 SvSTASH(sv) = stash;
771 break;
772 case SVt_PVLV:
773 SvANY(sv) = new_XPVLV();
463ee0b2 774 SvPVX(sv) = pv;
79072805
LW
775 SvCUR(sv) = cur;
776 SvLEN(sv) = len;
463ee0b2
LW
777 SvIVX(sv) = iv;
778 SvNVX(sv) = nv;
79072805
LW
779 SvMAGIC(sv) = magic;
780 SvSTASH(sv) = stash;
781 LvTARGOFF(sv) = 0;
782 LvTARGLEN(sv) = 0;
783 LvTARG(sv) = 0;
784 LvTYPE(sv) = 0;
785 break;
786 case SVt_PVAV:
787 SvANY(sv) = new_XPVAV();
463ee0b2
LW
788 if (pv)
789 Safefree(pv);
2304df62 790 SvPVX(sv) = 0;
d1bf51dd
CS
791 AvMAX(sv) = -1;
792 AvFILL(sv) = -1;
463ee0b2
LW
793 SvIVX(sv) = 0;
794 SvNVX(sv) = 0.0;
795 SvMAGIC(sv) = magic;
796 SvSTASH(sv) = stash;
797 AvALLOC(sv) = 0;
79072805
LW
798 AvARYLEN(sv) = 0;
799 AvFLAGS(sv) = 0;
800 break;
801 case SVt_PVHV:
802 SvANY(sv) = new_XPVHV();
463ee0b2
LW
803 if (pv)
804 Safefree(pv);
805 SvPVX(sv) = 0;
806 HvFILL(sv) = 0;
807 HvMAX(sv) = 0;
808 HvKEYS(sv) = 0;
809 SvNVX(sv) = 0.0;
79072805
LW
810 SvMAGIC(sv) = magic;
811 SvSTASH(sv) = stash;
79072805
LW
812 HvRITER(sv) = 0;
813 HvEITER(sv) = 0;
814 HvPMROOT(sv) = 0;
815 HvNAME(sv) = 0;
79072805
LW
816 break;
817 case SVt_PVCV:
818 SvANY(sv) = new_XPVCV();
748a9306 819 Zero(SvANY(sv), 1, XPVCV);
463ee0b2 820 SvPVX(sv) = pv;
79072805
LW
821 SvCUR(sv) = cur;
822 SvLEN(sv) = len;
463ee0b2
LW
823 SvIVX(sv) = iv;
824 SvNVX(sv) = nv;
79072805
LW
825 SvMAGIC(sv) = magic;
826 SvSTASH(sv) = stash;
79072805
LW
827 break;
828 case SVt_PVGV:
829 SvANY(sv) = new_XPVGV();
463ee0b2 830 SvPVX(sv) = pv;
79072805
LW
831 SvCUR(sv) = cur;
832 SvLEN(sv) = len;
463ee0b2
LW
833 SvIVX(sv) = iv;
834 SvNVX(sv) = nv;
79072805
LW
835 SvMAGIC(sv) = magic;
836 SvSTASH(sv) = stash;
93a17b20 837 GvGP(sv) = 0;
79072805
LW
838 GvNAME(sv) = 0;
839 GvNAMELEN(sv) = 0;
840 GvSTASH(sv) = 0;
a5f75d66 841 GvFLAGS(sv) = 0;
79072805
LW
842 break;
843 case SVt_PVBM:
844 SvANY(sv) = new_XPVBM();
463ee0b2 845 SvPVX(sv) = pv;
79072805
LW
846 SvCUR(sv) = cur;
847 SvLEN(sv) = len;
463ee0b2
LW
848 SvIVX(sv) = iv;
849 SvNVX(sv) = nv;
79072805
LW
850 SvMAGIC(sv) = magic;
851 SvSTASH(sv) = stash;
852 BmRARE(sv) = 0;
853 BmUSEFUL(sv) = 0;
854 BmPREVIOUS(sv) = 0;
855 break;
856 case SVt_PVFM:
857 SvANY(sv) = new_XPVFM();
748a9306 858 Zero(SvANY(sv), 1, XPVFM);
463ee0b2 859 SvPVX(sv) = pv;
79072805
LW
860 SvCUR(sv) = cur;
861 SvLEN(sv) = len;
463ee0b2
LW
862 SvIVX(sv) = iv;
863 SvNVX(sv) = nv;
79072805
LW
864 SvMAGIC(sv) = magic;
865 SvSTASH(sv) = stash;
79072805 866 break;
8990e307
LW
867 case SVt_PVIO:
868 SvANY(sv) = new_XPVIO();
748a9306 869 Zero(SvANY(sv), 1, XPVIO);
8990e307
LW
870 SvPVX(sv) = pv;
871 SvCUR(sv) = cur;
872 SvLEN(sv) = len;
873 SvIVX(sv) = iv;
874 SvNVX(sv) = nv;
875 SvMAGIC(sv) = magic;
876 SvSTASH(sv) = stash;
85e6fe83 877 IoPAGE_LEN(sv) = 60;
8990e307
LW
878 break;
879 }
880 SvFLAGS(sv) &= ~SVTYPEMASK;
881 SvFLAGS(sv) |= mt;
79072805
LW
882 return TRUE;
883}
884
a0d0e21e 885#ifdef DEBUGGING
79072805
LW
886char *
887sv_peek(sv)
888register SV *sv;
889{
46fc3d4c
PP
890 SV *t = sv_newmortal();
891 STRLEN prevlen;
a0d0e21e 892 int unref = 0;
79072805
LW
893
894 retry:
895 if (!sv) {
46fc3d4c 896 sv_catpv(t, "VOID");
a0d0e21e 897 goto finish;
79072805
LW
898 }
899 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
46fc3d4c 900 sv_catpv(t, "WILD");
a0d0e21e
LW
901 goto finish;
902 }
903 else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) {
904 if (sv == &sv_undef) {
46fc3d4c 905 sv_catpv(t, "SV_UNDEF");
a0d0e21e
LW
906 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
907 SVs_GMG|SVs_SMG|SVs_RMG)) &&
908 SvREADONLY(sv))
909 goto finish;
910 }
911 else if (sv == &sv_no) {
46fc3d4c 912 sv_catpv(t, "SV_NO");
a0d0e21e
LW
913 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
914 SVs_GMG|SVs_SMG|SVs_RMG)) &&
915 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
916 SVp_POK|SVp_NOK)) &&
917 SvCUR(sv) == 0 &&
918 SvNVX(sv) == 0.0)
919 goto finish;
920 }
921 else {
46fc3d4c 922 sv_catpv(t, "SV_YES");
a0d0e21e
LW
923 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
924 SVs_GMG|SVs_SMG|SVs_RMG)) &&
925 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
926 SVp_POK|SVp_NOK)) &&
927 SvCUR(sv) == 1 &&
928 SvPVX(sv) && *SvPVX(sv) == '1' &&
929 SvNVX(sv) == 1.0)
930 goto finish;
931 }
46fc3d4c 932 sv_catpv(t, ":");
79072805 933 }
a0d0e21e 934 else if (SvREFCNT(sv) == 0) {
46fc3d4c 935 sv_catpv(t, "(");
a0d0e21e 936 unref++;
79072805 937 }
a0d0e21e 938 if (SvROK(sv)) {
46fc3d4c
PP
939 sv_catpv(t, "\\");
940 if (SvCUR(t) + unref > 10) {
941 SvCUR(t) = unref + 3;
942 *SvEND(t) = '\0';
943 sv_catpv(t, "...");
a0d0e21e 944 goto finish;
79072805 945 }
a0d0e21e
LW
946 sv = (SV*)SvRV(sv);
947 goto retry;
948 }
949 switch (SvTYPE(sv)) {
950 default:
46fc3d4c 951 sv_catpv(t, "FREED");
a0d0e21e
LW
952 goto finish;
953
954 case SVt_NULL:
46fc3d4c 955 sv_catpv(t, "UNDEF");
a0d0e21e
LW
956 return tokenbuf;
957 case SVt_IV:
46fc3d4c 958 sv_catpv(t, "IV");
a0d0e21e
LW
959 break;
960 case SVt_NV:
46fc3d4c 961 sv_catpv(t, "NV");
a0d0e21e
LW
962 break;
963 case SVt_RV:
46fc3d4c 964 sv_catpv(t, "RV");
a0d0e21e
LW
965 break;
966 case SVt_PV:
46fc3d4c 967 sv_catpv(t, "PV");
a0d0e21e
LW
968 break;
969 case SVt_PVIV:
46fc3d4c 970 sv_catpv(t, "PVIV");
a0d0e21e
LW
971 break;
972 case SVt_PVNV:
46fc3d4c 973 sv_catpv(t, "PVNV");
a0d0e21e
LW
974 break;
975 case SVt_PVMG:
46fc3d4c 976 sv_catpv(t, "PVMG");
a0d0e21e
LW
977 break;
978 case SVt_PVLV:
46fc3d4c 979 sv_catpv(t, "PVLV");
a0d0e21e
LW
980 break;
981 case SVt_PVAV:
46fc3d4c 982 sv_catpv(t, "AV");
a0d0e21e
LW
983 break;
984 case SVt_PVHV:
46fc3d4c 985 sv_catpv(t, "HV");
a0d0e21e
LW
986 break;
987 case SVt_PVCV:
988 if (CvGV(sv))
46fc3d4c 989 sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
a0d0e21e 990 else
46fc3d4c 991 sv_catpv(t, "CV()");
a0d0e21e
LW
992 goto finish;
993 case SVt_PVGV:
46fc3d4c 994 sv_catpv(t, "GV");
a0d0e21e
LW
995 break;
996 case SVt_PVBM:
46fc3d4c 997 sv_catpv(t, "BM");
a0d0e21e
LW
998 break;
999 case SVt_PVFM:
46fc3d4c 1000 sv_catpv(t, "FM");
a0d0e21e
LW
1001 break;
1002 case SVt_PVIO:
46fc3d4c 1003 sv_catpv(t, "IO");
a0d0e21e 1004 break;
79072805 1005 }
79072805 1006
a0d0e21e 1007 if (SvPOKp(sv)) {
463ee0b2 1008 if (!SvPVX(sv))
46fc3d4c 1009 sv_catpv(t, "(null)");
79072805 1010 if (SvOOK(sv))
46fc3d4c 1011 sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
79072805 1012 else
46fc3d4c 1013 sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
79072805 1014 }
bbce6d69 1015 else if (SvNOKp(sv)) {
36477c24 1016 SET_NUMERIC_STANDARD();
46fc3d4c 1017 sv_catpvf(t, "(%g)",SvNVX(sv));
bbce6d69 1018 }
a0d0e21e 1019 else if (SvIOKp(sv))
46fc3d4c 1020 sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
79072805 1021 else
46fc3d4c 1022 sv_catpv(t, "()");
a0d0e21e
LW
1023
1024 finish:
1025 if (unref) {
a0d0e21e 1026 while (unref--)
46fc3d4c 1027 sv_catpv(t, ")");
a0d0e21e 1028 }
46fc3d4c 1029 return SvPV(t, na);
79072805 1030}
a0d0e21e 1031#endif
79072805
LW
1032
1033int
1034sv_backoff(sv)
1035register SV *sv;
1036{
1037 assert(SvOOK(sv));
463ee0b2
LW
1038 if (SvIVX(sv)) {
1039 char *s = SvPVX(sv);
1040 SvLEN(sv) += SvIVX(sv);
1041 SvPVX(sv) -= SvIVX(sv);
79072805 1042 SvIV_set(sv, 0);
463ee0b2 1043 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW
1044 }
1045 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 1046 return 0;
79072805
LW
1047}
1048
1049char *
1050sv_grow(sv,newlen)
1051register SV *sv;
1052#ifndef DOSISH
1053register I32 newlen;
1054#else
1055unsigned long newlen;
1056#endif
1057{
1058 register char *s;
1059
55497cff 1060#ifdef HAS_64K_LIMIT
79072805 1061 if (newlen >= 0x10000) {
d1bf51dd 1062 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
79072805
LW
1063 my_exit(1);
1064 }
55497cff 1065#endif /* HAS_64K_LIMIT */
a0d0e21e
LW
1066 if (SvROK(sv))
1067 sv_unref(sv);
79072805
LW
1068 if (SvTYPE(sv) < SVt_PV) {
1069 sv_upgrade(sv, SVt_PV);
463ee0b2 1070 s = SvPVX(sv);
79072805
LW
1071 }
1072 else if (SvOOK(sv)) { /* pv is offset? */
1073 sv_backoff(sv);
463ee0b2 1074 s = SvPVX(sv);
79072805
LW
1075 if (newlen > SvLEN(sv))
1076 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1077 }
1078 else
463ee0b2 1079 s = SvPVX(sv);
79072805 1080 if (newlen > SvLEN(sv)) { /* need more room? */
85e6fe83 1081 if (SvLEN(sv) && s)
79072805
LW
1082 Renew(s,newlen,char);
1083 else
1084 New(703,s,newlen,char);
1085 SvPV_set(sv, s);
1086 SvLEN_set(sv, newlen);
1087 }
1088 return s;
1089}
1090
1091void
1092sv_setiv(sv,i)
1093register SV *sv;
a0d0e21e 1094IV i;
79072805 1095{
ed6116ce 1096 if (SvTHINKFIRST(sv)) {
8990e307 1097 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
1098 croak(no_modify);
1099 if (SvROK(sv))
1100 sv_unref(sv);
1101 }
463ee0b2
LW
1102 switch (SvTYPE(sv)) {
1103 case SVt_NULL:
79072805 1104 sv_upgrade(sv, SVt_IV);
463ee0b2
LW
1105 break;
1106 case SVt_NV:
1107 sv_upgrade(sv, SVt_PVNV);
1108 break;
ed6116ce 1109 case SVt_RV:
463ee0b2 1110 case SVt_PV:
79072805 1111 sv_upgrade(sv, SVt_PVIV);
463ee0b2 1112 break;
a0d0e21e
LW
1113
1114 case SVt_PVGV:
1115 if (SvFAKE(sv)) {
1116 sv_unglob(sv);
1117 break;
1118 }
1119 /* FALL THROUGH */
1120 case SVt_PVAV:
1121 case SVt_PVHV:
1122 case SVt_PVCV:
1123 case SVt_PVFM:
1124 case SVt_PVIO:
11343788
MB
1125 {
1126 dTHR;
1127 croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
5dc0d613 1128 op_desc[op->op_type]);
11343788 1129 }
463ee0b2 1130 }
a0d0e21e 1131 (void)SvIOK_only(sv); /* validate number */
a5f75d66 1132 SvIVX(sv) = i;
463ee0b2 1133 SvTAINT(sv);
79072805
LW
1134}
1135
1136void
55497cff
PP
1137sv_setuv(sv,u)
1138register SV *sv;
1139UV u;
1140{
1141 if (u <= IV_MAX)
1142 sv_setiv(sv, u);
1143 else
1144 sv_setnv(sv, (double)u);
1145}
1146
1147void
79072805
LW
1148sv_setnv(sv,num)
1149register SV *sv;
1150double num;
1151{
ed6116ce 1152 if (SvTHINKFIRST(sv)) {
8990e307 1153 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
1154 croak(no_modify);
1155 if (SvROK(sv))
1156 sv_unref(sv);
1157 }
a0d0e21e
LW
1158 switch (SvTYPE(sv)) {
1159 case SVt_NULL:
1160 case SVt_IV:
79072805 1161 sv_upgrade(sv, SVt_NV);
a0d0e21e
LW
1162 break;
1163 case SVt_NV:
1164 case SVt_RV:
1165 case SVt_PV:
1166 case SVt_PVIV:
79072805 1167 sv_upgrade(sv, SVt_PVNV);
a0d0e21e
LW
1168 /* FALL THROUGH */
1169 case SVt_PVNV:
1170 case SVt_PVMG:
1171 case SVt_PVBM:
1172 case SVt_PVLV:
1173 if (SvOOK(sv))
1174 (void)SvOOK_off(sv);
1175 break;
1176 case SVt_PVGV:
1177 if (SvFAKE(sv)) {
1178 sv_unglob(sv);
1179 break;
1180 }
1181 /* FALL THROUGH */
1182 case SVt_PVAV:
1183 case SVt_PVHV:
1184 case SVt_PVCV:
1185 case SVt_PVFM:
1186 case SVt_PVIO:
11343788
MB
1187 {
1188 dTHR;
1189 croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
1190 op_name[op->op_type]);
1191 }
79072805 1192 }
463ee0b2 1193 SvNVX(sv) = num;
a0d0e21e 1194 (void)SvNOK_only(sv); /* validate number */
463ee0b2 1195 SvTAINT(sv);
79072805
LW
1196}
1197
a0d0e21e
LW
1198static void
1199not_a_number(sv)
1200SV *sv;
1201{
11343788 1202 dTHR;
a0d0e21e
LW
1203 char tmpbuf[64];
1204 char *d = tmpbuf;
1205 char *s;
dc28f22b
GA
1206 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1207 /* each *s can expand to 4 chars + "...\0",
1208 i.e. need room for 8 chars */
a0d0e21e 1209
dc28f22b 1210 for (s = SvPVX(sv); *s && d < limit; s++) {
bbce6d69
PP
1211 int ch = *s & 0xFF;
1212 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW
1213 *d++ = 'M';
1214 *d++ = '-';
1215 ch &= 127;
1216 }
bbce6d69
PP
1217 if (ch == '\n') {
1218 *d++ = '\\';
1219 *d++ = 'n';
1220 }
1221 else if (ch == '\r') {
1222 *d++ = '\\';
1223 *d++ = 'r';
1224 }
1225 else if (ch == '\f') {
1226 *d++ = '\\';
1227 *d++ = 'f';
1228 }
1229 else if (ch == '\\') {
1230 *d++ = '\\';
1231 *d++ = '\\';
1232 }
1233 else if (isPRINT_LC(ch))
a0d0e21e
LW
1234 *d++ = ch;
1235 else {
1236 *d++ = '^';
bbce6d69 1237 *d++ = toCTRL(ch);
a0d0e21e
LW
1238 }
1239 }
1240 if (*s) {
1241 *d++ = '.';
1242 *d++ = '.';
1243 *d++ = '.';
1244 }
1245 *d = '\0';
1246
1247 if (op)
c07a80fd 1248 warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
a0d0e21e
LW
1249 op_name[op->op_type]);
1250 else
1251 warn("Argument \"%s\" isn't numeric", tmpbuf);
1252}
1253
1254IV
79072805
LW
1255sv_2iv(sv)
1256register SV *sv;
1257{
1258 if (!sv)
1259 return 0;
8990e307 1260 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1261 mg_get(sv);
1262 if (SvIOKp(sv))
1263 return SvIVX(sv);
748a9306
LW
1264 if (SvNOKp(sv)) {
1265 if (SvNVX(sv) < 0.0)
1266 return I_V(SvNVX(sv));
1267 else
5d94fbed 1268 return (IV) U_V(SvNVX(sv));
748a9306 1269 }
36477c24
PP
1270 if (SvPOKp(sv) && SvLEN(sv))
1271 return asIV(sv);
3fe9a6f1 1272 if (!SvROK(sv)) {
e858de61 1273 dTHR; /* just for localizing */
3fe9a6f1
PP
1274 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1275 warn(warn_uninit);
36477c24 1276 return 0;
3fe9a6f1 1277 }
463ee0b2 1278 }
ed6116ce 1279 if (SvTHINKFIRST(sv)) {
a0d0e21e
LW
1280 if (SvROK(sv)) {
1281#ifdef OVERLOAD
1282 SV* tmpstr;
1283 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1284 return SvIV(tmpstr);
1285#endif /* OVERLOAD */
1286 return (IV)SvRV(sv);
1287 }
ed6116ce 1288 if (SvREADONLY(sv)) {
748a9306
LW
1289 if (SvNOKp(sv)) {
1290 if (SvNVX(sv) < 0.0)
1291 return I_V(SvNVX(sv));
1292 else
5d94fbed 1293 return (IV) U_V(SvNVX(sv));
748a9306 1294 }
36477c24
PP
1295 if (SvPOKp(sv) && SvLEN(sv))
1296 return asIV(sv);
ed6116ce 1297 if (dowarn)
8990e307 1298 warn(warn_uninit);
ed6116ce
LW
1299 return 0;
1300 }
79072805 1301 }
463ee0b2 1302 switch (SvTYPE(sv)) {
463ee0b2 1303 case SVt_NULL:
79072805 1304 sv_upgrade(sv, SVt_IV);
8ebc5c01 1305 break;
463ee0b2 1306 case SVt_PV:
79072805 1307 sv_upgrade(sv, SVt_PVIV);
463ee0b2
LW
1308 break;
1309 case SVt_NV:
1310 sv_upgrade(sv, SVt_PVNV);
1311 break;
1312 }
748a9306 1313 if (SvNOKp(sv)) {
a5f75d66 1314 (void)SvIOK_on(sv);
748a9306
LW
1315 if (SvNVX(sv) < 0.0)
1316 SvIVX(sv) = I_V(SvNVX(sv));
1317 else
ff68c719 1318 SvUVX(sv) = U_V(SvNVX(sv));
748a9306
LW
1319 }
1320 else if (SvPOKp(sv) && SvLEN(sv)) {
a5f75d66 1321 (void)SvIOK_on(sv);
36477c24 1322 SvIVX(sv) = asIV(sv);
93a17b20 1323 }
79072805 1324 else {
11343788 1325 dTHR;
91bba347 1326 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
8990e307 1327 warn(warn_uninit);
a0d0e21e 1328 return 0;
79072805 1329 }
760ac839 1330 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
a0d0e21e 1331 (unsigned long)sv,(long)SvIVX(sv)));
463ee0b2 1332 return SvIVX(sv);
79072805
LW
1333}
1334
ff68c719
PP
1335UV
1336sv_2uv(sv)
1337register SV *sv;
1338{
1339 if (!sv)
1340 return 0;
1341 if (SvGMAGICAL(sv)) {
1342 mg_get(sv);
1343 if (SvIOKp(sv))
1344 return SvUVX(sv);
1345 if (SvNOKp(sv))
1346 return U_V(SvNVX(sv));
36477c24
PP
1347 if (SvPOKp(sv) && SvLEN(sv))
1348 return asUV(sv);
3fe9a6f1 1349 if (!SvROK(sv)) {
e858de61 1350 dTHR; /* just for localizing */
3fe9a6f1
PP
1351 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1352 warn(warn_uninit);
36477c24 1353 return 0;
3fe9a6f1 1354 }
ff68c719
PP
1355 }
1356 if (SvTHINKFIRST(sv)) {
1357 if (SvROK(sv)) {
1358#ifdef OVERLOAD
1359 SV* tmpstr;
1360 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1361 return SvUV(tmpstr);
1362#endif /* OVERLOAD */
1363 return (UV)SvRV(sv);
1364 }
1365 if (SvREADONLY(sv)) {
1366 if (SvNOKp(sv)) {
1367 return U_V(SvNVX(sv));
1368 }
36477c24
PP
1369 if (SvPOKp(sv) && SvLEN(sv))
1370 return asUV(sv);
ff68c719
PP
1371 if (dowarn)
1372 warn(warn_uninit);
1373 return 0;
1374 }
1375 }
1376 switch (SvTYPE(sv)) {
1377 case SVt_NULL:
1378 sv_upgrade(sv, SVt_IV);
8ebc5c01 1379 break;
ff68c719
PP
1380 case SVt_PV:
1381 sv_upgrade(sv, SVt_PVIV);
1382 break;
1383 case SVt_NV:
1384 sv_upgrade(sv, SVt_PVNV);
1385 break;
1386 }
1387 if (SvNOKp(sv)) {
1388 (void)SvIOK_on(sv);
1389 SvUVX(sv) = U_V(SvNVX(sv));
1390 }
1391 else if (SvPOKp(sv) && SvLEN(sv)) {
ff68c719 1392 (void)SvIOK_on(sv);
36477c24 1393 SvUVX(sv) = asUV(sv);
ff68c719
PP
1394 }
1395 else {
e858de61 1396 dTHR; /* just for localizing */
ff68c719
PP
1397 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1398 warn(warn_uninit);
1399 return 0;
1400 }
1401 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1402 (unsigned long)sv,SvUVX(sv)));
1403 return SvUVX(sv);
1404}
1405
79072805
LW
1406double
1407sv_2nv(sv)
1408register SV *sv;
1409{
1410 if (!sv)
1411 return 0.0;
8990e307 1412 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1413 mg_get(sv);
1414 if (SvNOKp(sv))
1415 return SvNVX(sv);
a0d0e21e 1416 if (SvPOKp(sv) && SvLEN(sv)) {
748a9306 1417 if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1418 not_a_number(sv);
36477c24 1419 SET_NUMERIC_STANDARD();
463ee0b2 1420 return atof(SvPVX(sv));
a0d0e21e 1421 }
463ee0b2
LW
1422 if (SvIOKp(sv))
1423 return (double)SvIVX(sv);
16d20bd9 1424 if (!SvROK(sv)) {
e858de61 1425 dTHR; /* just for localizing */
3fe9a6f1
PP
1426 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1427 warn(warn_uninit);
16d20bd9
AD
1428 return 0;
1429 }
463ee0b2 1430 }
ed6116ce 1431 if (SvTHINKFIRST(sv)) {
a0d0e21e
LW
1432 if (SvROK(sv)) {
1433#ifdef OVERLOAD
1434 SV* tmpstr;
1435 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1436 return SvNV(tmpstr);
1437#endif /* OVERLOAD */
1438 return (double)(unsigned long)SvRV(sv);
1439 }
ed6116ce 1440 if (SvREADONLY(sv)) {
748a9306
LW
1441 if (SvPOKp(sv) && SvLEN(sv)) {
1442 if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1443 not_a_number(sv);
36477c24 1444 SET_NUMERIC_STANDARD();
ed6116ce 1445 return atof(SvPVX(sv));
a0d0e21e 1446 }
748a9306 1447 if (SvIOKp(sv))
8990e307 1448 return (double)SvIVX(sv);
ed6116ce 1449 if (dowarn)
8990e307 1450 warn(warn_uninit);
ed6116ce
LW
1451 return 0.0;
1452 }
79072805
LW
1453 }
1454 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW
1455 if (SvTYPE(sv) == SVt_IV)
1456 sv_upgrade(sv, SVt_PVNV);
1457 else
1458 sv_upgrade(sv, SVt_NV);
36477c24 1459 DEBUG_c(SET_NUMERIC_STANDARD());
bbce6d69
PP
1460 DEBUG_c(PerlIO_printf(Perl_debug_log,
1461 "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
79072805
LW
1462 }
1463 else if (SvTYPE(sv) < SVt_PVNV)
1464 sv_upgrade(sv, SVt_PVNV);
748a9306
LW
1465 if (SvIOKp(sv) &&
1466 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 1467 {
463ee0b2 1468 SvNVX(sv) = (double)SvIVX(sv);
93a17b20 1469 }
748a9306
LW
1470 else if (SvPOKp(sv) && SvLEN(sv)) {
1471 if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1472 not_a_number(sv);
36477c24 1473 SET_NUMERIC_STANDARD();
463ee0b2 1474 SvNVX(sv) = atof(SvPVX(sv));
93a17b20 1475 }
79072805 1476 else {
11343788 1477 dTHR;
91bba347 1478 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
8990e307 1479 warn(warn_uninit);
a0d0e21e 1480 return 0.0;
79072805
LW
1481 }
1482 SvNOK_on(sv);
36477c24 1483 DEBUG_c(SET_NUMERIC_STANDARD());
bbce6d69
PP
1484 DEBUG_c(PerlIO_printf(Perl_debug_log,
1485 "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
463ee0b2 1486 return SvNVX(sv);
79072805
LW
1487}
1488
36477c24
PP
1489static IV
1490asIV(sv)
1491SV *sv;
1492{
1493 I32 numtype = looks_like_number(sv);
1494 double d;
1495
1496 if (numtype == 1)
1497 return atol(SvPVX(sv));
1498 if (!numtype && dowarn)
1499 not_a_number(sv);
1500 SET_NUMERIC_STANDARD();
1501 d = atof(SvPVX(sv));
1502 if (d < 0.0)
1503 return I_V(d);
1504 else
1505 return (IV) U_V(d);
1506}
1507
1508static UV
1509asUV(sv)
1510SV *sv;
1511{
1512 I32 numtype = looks_like_number(sv);
1513
1514 if (numtype == 1)
1515 return atol(SvPVX(sv));
1516 if (!numtype && dowarn)
1517 not_a_number(sv);
1518 SET_NUMERIC_STANDARD();
1519 return U_V(atof(SvPVX(sv)));
1520}
1521
1522I32
1523looks_like_number(sv)
1524SV *sv;
1525{
1526 register char *s;
1527 register char *send;
1528 register char *sbegin;
ff0cee69 1529 I32 numtype;
36477c24
PP
1530 STRLEN len;
1531
1532 if (SvPOK(sv)) {
1533 sbegin = SvPVX(sv);
1534 len = SvCUR(sv);
1535 }
1536 else if (SvPOKp(sv))
1537 sbegin = SvPV(sv, len);
1538 else
1539 return 1;
1540 send = sbegin + len;
1541
1542 s = sbegin;
1543 while (isSPACE(*s))
1544 s++;
36477c24
PP
1545 if (*s == '+' || *s == '-')
1546 s++;
ff0cee69
PP
1547
1548 /* next must be digit or '.' */
1549 if (isDIGIT(*s)) {
1550 do {
1551 s++;
1552 } while (isDIGIT(*s));
1553 if (*s == '.') {
1554 s++;
1555 while (isDIGIT(*s)) /* optional digits after "." */
1556 s++;
1557 }
36477c24 1558 }
ff0cee69
PP
1559 else if (*s == '.') {
1560 s++;
1561 /* no digits before '.' means we need digits after it */
1562 if (isDIGIT(*s)) {
1563 do {
1564 s++;
1565 } while (isDIGIT(*s));
1566 }
1567 else
1568 return 0;
1569 }
1570 else
1571 return 0;
1572
1573 /*
1574 * we return 1 if the number can be converted to _integer_ with atol()
1575 * and 2 if you need (int)atof().
1576 */
1577 numtype = 1;
1578
1579 /* we can have an optional exponent part */
36477c24
PP
1580 if (*s == 'e' || *s == 'E') {
1581 numtype = 2;
1582 s++;
1583 if (*s == '+' || *s == '-')
1584 s++;
ff0cee69
PP
1585 if (isDIGIT(*s)) {
1586 do {
1587 s++;
1588 } while (isDIGIT(*s));
1589 }
1590 else
1591 return 0;
36477c24
PP
1592 }
1593 while (isSPACE(*s))
1594 s++;
1595 if (s >= send)
1596 return numtype;
1597 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1598 return 1;
1599 return 0;
1600}
1601
79072805 1602char *
463ee0b2 1603sv_2pv(sv, lp)
79072805 1604register SV *sv;
463ee0b2 1605STRLEN *lp;
79072805
LW
1606{
1607 register char *s;
1608 int olderrno;
46fc3d4c 1609 SV *tsv;
79072805 1610
463ee0b2
LW
1611 if (!sv) {
1612 *lp = 0;
1613 return "";
1614 }
8990e307 1615 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1616 mg_get(sv);
1617 if (SvPOKp(sv)) {
1618 *lp = SvCUR(sv);
1619 return SvPVX(sv);
1620 }
1621 if (SvIOKp(sv)) {
a0d0e21e 1622 (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
46fc3d4c 1623 tsv = Nullsv;
a0d0e21e 1624 goto tokensave;
463ee0b2
LW
1625 }
1626 if (SvNOKp(sv)) {
36477c24 1627 SET_NUMERIC_STANDARD();
a0d0e21e 1628 Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
46fc3d4c 1629 tsv = Nullsv;
a0d0e21e 1630 goto tokensave;
463ee0b2 1631 }
16d20bd9 1632 if (!SvROK(sv)) {
e858de61 1633 dTHR; /* just for localizing */
3fe9a6f1
PP
1634 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1635 warn(warn_uninit);
16d20bd9
AD
1636 *lp = 0;
1637 return "";
1638 }
463ee0b2 1639 }
ed6116ce
LW
1640 if (SvTHINKFIRST(sv)) {
1641 if (SvROK(sv)) {
a0d0e21e
LW
1642#ifdef OVERLOAD
1643 SV* tmpstr;
1644 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1645 return SvPV(tmpstr,*lp);
1646#endif /* OVERLOAD */
ed6116ce
LW
1647 sv = (SV*)SvRV(sv);
1648 if (!sv)
1649 s = "NULLREF";
1650 else {
1651 switch (SvTYPE(sv)) {
1652 case SVt_NULL:
1653 case SVt_IV:
1654 case SVt_NV:
1655 case SVt_RV:
1656 case SVt_PV:
1657 case SVt_PVIV:
1658 case SVt_PVNV:
1659 case SVt_PVBM:
1660 case SVt_PVMG: s = "SCALAR"; break;
1661 case SVt_PVLV: s = "LVALUE"; break;
1662 case SVt_PVAV: s = "ARRAY"; break;
1663 case SVt_PVHV: s = "HASH"; break;
1664 case SVt_PVCV: s = "CODE"; break;
1665 case SVt_PVGV: s = "GLOB"; break;
1666 case SVt_PVFM: s = "FORMATLINE"; break;
36477c24 1667 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW
1668 default: s = "UNKNOWN"; break;
1669 }
46fc3d4c 1670 tsv = NEWSV(0,0);
ed6116ce 1671 if (SvOBJECT(sv))
46fc3d4c 1672 sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 1673 else
46fc3d4c
PP
1674 sv_setpv(tsv, s);
1675 sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
a0d0e21e 1676 goto tokensaveref;
463ee0b2 1677 }
ed6116ce
LW
1678 *lp = strlen(s);
1679 return s;
79072805 1680 }
ed6116ce 1681 if (SvREADONLY(sv)) {
748a9306 1682 if (SvNOKp(sv)) {
36477c24 1683 SET_NUMERIC_STANDARD();
a0d0e21e 1684 Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
46fc3d4c 1685 tsv = Nullsv;
a0d0e21e 1686 goto tokensave;
ed6116ce 1687 }
8bb9dbe4
LW
1688 if (SvIOKp(sv)) {
1689 (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
46fc3d4c 1690 tsv = Nullsv;
8bb9dbe4
LW
1691 goto tokensave;
1692 }
ed6116ce 1693 if (dowarn)
8990e307 1694 warn(warn_uninit);
ed6116ce
LW
1695 *lp = 0;
1696 return "";
79072805 1697 }
79072805
LW
1698 }
1699 if (!SvUPGRADE(sv, SVt_PV))
1700 return 0;
748a9306 1701 if (SvNOKp(sv)) {
79072805
LW
1702 if (SvTYPE(sv) < SVt_PVNV)
1703 sv_upgrade(sv, SVt_PVNV);
1704 SvGROW(sv, 28);
463ee0b2 1705 s = SvPVX(sv);
79072805 1706 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 1707#ifdef apollo
463ee0b2 1708 if (SvNVX(sv) == 0.0)
79072805
LW
1709 (void)strcpy(s,"0");
1710 else
1711#endif /*apollo*/
bbce6d69 1712 {
36477c24 1713 SET_NUMERIC_STANDARD();
a0d0e21e 1714 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
bbce6d69 1715 }
79072805 1716 errno = olderrno;
a0d0e21e
LW
1717#ifdef FIXNEGATIVEZERO
1718 if (*s == '-' && s[1] == '0' && !s[2])
1719 strcpy(s,"0");
1720#endif
79072805
LW
1721 while (*s) s++;
1722#ifdef hcx
1723 if (s[-1] == '.')
46fc3d4c 1724 *--s = '\0';
79072805
LW
1725#endif
1726 }
748a9306 1727 else if (SvIOKp(sv)) {
79072805
LW
1728 if (SvTYPE(sv) < SVt_PVIV)
1729 sv_upgrade(sv, SVt_PVIV);
79072805 1730 olderrno = errno; /* some Xenix systems wipe out errno here */
fc36a67e 1731 sv_setpvf(sv, "%Vd", SvIVX(sv));
79072805 1732 errno = olderrno;
46fc3d4c 1733 s = SvEND(sv);
79072805
LW
1734 }
1735 else {
11343788 1736 dTHR;
91bba347 1737 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
8990e307 1738 warn(warn_uninit);
a0d0e21e
LW
1739 *lp = 0;
1740 return "";
79072805 1741 }
463ee0b2
LW
1742 *lp = s - SvPVX(sv);
1743 SvCUR_set(sv, *lp);
79072805 1744 SvPOK_on(sv);
760ac839 1745 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
463ee0b2 1746 return SvPVX(sv);
a0d0e21e
LW
1747
1748 tokensave:
1749 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1750 /* Sneaky stuff here */
1751
1752 tokensaveref:
46fc3d4c
PP
1753 if (!tsv)
1754 tsv = newSVpv(tokenbuf, 0);
1755 sv_2mortal(tsv);
1756 *lp = SvCUR(tsv);
1757 return SvPVX(tsv);
a0d0e21e
LW
1758 }
1759 else {
1760 STRLEN len;
46fc3d4c
PP
1761 char *t;
1762
1763 if (tsv) {
1764 sv_2mortal(tsv);
1765 t = SvPVX(tsv);
1766 len = SvCUR(tsv);
1767 }
1768 else {
1769 t = tokenbuf;
1770 len = strlen(tokenbuf);
1771 }
a0d0e21e 1772#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
1773 if (len == 2 && t[0] == '-' && t[1] == '0') {
1774 t = "0";
1775 len = 1;
1776 }
a0d0e21e
LW
1777#endif
1778 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 1779 *lp = len;
a0d0e21e
LW
1780 s = SvGROW(sv, len + 1);
1781 SvCUR_set(sv, len);
46fc3d4c 1782 (void)strcpy(s, t);
6bf554b4 1783 SvPOKp_on(sv);
a0d0e21e
LW
1784 return s;
1785 }
463ee0b2
LW
1786}
1787
1788/* This function is only called on magical items */
1789bool
1790sv_2bool(sv)
1791register SV *sv;
1792{
8990e307 1793 if (SvGMAGICAL(sv))
463ee0b2
LW
1794 mg_get(sv);
1795
a0d0e21e
LW
1796 if (!SvOK(sv))
1797 return 0;
1798 if (SvROK(sv)) {
1799#ifdef OVERLOAD
1800 {
11343788 1801 dTHR;
a0d0e21e
LW
1802 SV* tmpsv;
1803 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1804 return SvTRUE(tmpsv);
1805 }
1806#endif /* OVERLOAD */
1807 return SvRV(sv) != 0;
1808 }
463ee0b2 1809 if (SvPOKp(sv)) {
11343788
MB
1810 register XPV* Xpvtmp;
1811 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1812 (*Xpvtmp->xpv_pv > '0' ||
1813 Xpvtmp->xpv_cur > 1 ||
1814 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW
1815 return 1;
1816 else
1817 return 0;
1818 }
1819 else {
1820 if (SvIOKp(sv))
1821 return SvIVX(sv) != 0;
1822 else {
1823 if (SvNOKp(sv))
1824 return SvNVX(sv) != 0.0;
1825 else
1826 return FALSE;
1827 }
1828 }
79072805
LW
1829}
1830
1831/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 1832 * to be reused, since it may destroy the source string if it is marked
79072805
LW
1833 * as temporary.
1834 */
1835
1836void
1837sv_setsv(dstr,sstr)
1838SV *dstr;
1839register SV *sstr;
1840{
11343788 1841 dTHR;
8990e307
LW
1842 register U32 sflags;
1843 register int dtype;
1844 register int stype;
463ee0b2 1845
79072805
LW
1846 if (sstr == dstr)
1847 return;
ed6116ce 1848 if (SvTHINKFIRST(dstr)) {
8990e307 1849 if (SvREADONLY(dstr) && curcop != &compiling)
ed6116ce
LW
1850 croak(no_modify);
1851 if (SvROK(dstr))
1852 sv_unref(dstr);
1853 }
79072805
LW
1854 if (!sstr)
1855 sstr = &sv_undef;
8990e307
LW
1856 stype = SvTYPE(sstr);
1857 dtype = SvTYPE(dstr);
79072805 1858
8e07c86e
AD
1859 if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
1860 sv_unglob(dstr); /* so fake GLOB won't perpetuate */
4633a7c4
LW
1861 sv_setpvn(dstr, "", 0);
1862 (void)SvPOK_only(dstr);
8e07c86e
AD
1863 dtype = SvTYPE(dstr);
1864 }
1865
a0d0e21e
LW
1866#ifdef OVERLOAD
1867 SvAMAGIC_off(dstr);
1868#endif /* OVERLOAD */
463ee0b2 1869 /* There's a lot of redundancy below but we're going for speed here */
79072805 1870
8990e307 1871 switch (stype) {
79072805 1872 case SVt_NULL:
a0d0e21e 1873 (void)SvOK_off(dstr);
79072805 1874 return;
463ee0b2 1875 case SVt_IV:
ff68c719 1876 if (dtype != SVt_IV && dtype < SVt_PVIV) {
8990e307
LW
1877 if (dtype < SVt_IV)
1878 sv_upgrade(dstr, SVt_IV);
8990e307
LW
1879 else if (dtype == SVt_NV)
1880 sv_upgrade(dstr, SVt_PVNV);
ff68c719 1881 else
a0d0e21e 1882 sv_upgrade(dstr, SVt_PVIV);
8990e307 1883 }
463ee0b2
LW
1884 break;
1885 case SVt_NV:
ff68c719 1886 if (dtype != SVt_NV && dtype < SVt_PVNV) {
8990e307
LW
1887 if (dtype < SVt_NV)
1888 sv_upgrade(dstr, SVt_NV);
ff68c719 1889 else
a0d0e21e 1890 sv_upgrade(dstr, SVt_PVNV);
8990e307 1891 }
463ee0b2 1892 break;
ed6116ce 1893 case SVt_RV:
8990e307 1894 if (dtype < SVt_RV)
ed6116ce 1895 sv_upgrade(dstr, SVt_RV);
c07a80fd
PP
1896 else if (dtype == SVt_PVGV &&
1897 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
1898 sstr = SvRV(sstr);
a5f75d66
AD
1899 if (sstr == dstr) {
1900 if (curcop->cop_stash != GvSTASH(dstr))
1901 GvIMPORTED_on(dstr);
1902 GvMULTI_on(dstr);
1903 return;
1904 }
c07a80fd
PP
1905 goto glob_assign;
1906 }
ed6116ce 1907 break;
463ee0b2 1908 case SVt_PV:
fc36a67e 1909 case SVt_PVFM:
8990e307 1910 if (dtype < SVt_PV)
463ee0b2 1911 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
1912 break;
1913 case SVt_PVIV:
8990e307 1914 if (dtype < SVt_PVIV)
463ee0b2 1915 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW
1916 break;
1917 case SVt_PVNV:
8990e307 1918 if (dtype < SVt_PVNV)
463ee0b2 1919 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 1920 break;
4633a7c4
LW
1921
1922 case SVt_PVLV:
4561caa4 1923 sv_upgrade(dstr, SVt_PVLV);
4633a7c4
LW
1924 break;
1925
1926 case SVt_PVAV:
1927 case SVt_PVHV:
1928 case SVt_PVCV:
4633a7c4
LW
1929 case SVt_PVIO:
1930 if (op)
1931 croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
1932 op_name[op->op_type]);
1933 else
1934 croak("Bizarre copy of %s", sv_reftype(sstr, 0));
1935 break;
1936
79072805 1937 case SVt_PVGV:
8990e307 1938 if (dtype <= SVt_PVGV) {
c07a80fd 1939 glob_assign:
a5f75d66 1940 if (dtype != SVt_PVGV) {
a0d0e21e
LW
1941 char *name = GvNAME(sstr);
1942 STRLEN len = GvNAMELEN(sstr);
463ee0b2 1943 sv_upgrade(dstr, SVt_PVGV);
a0d0e21e
LW
1944 sv_magic(dstr, dstr, '*', name, len);
1945 GvSTASH(dstr) = GvSTASH(sstr);
1946 GvNAME(dstr) = savepvn(name, len);
1947 GvNAMELEN(dstr) = len;
1948 SvFAKE_on(dstr); /* can coerce to non-glob */
1949 }
7bac28a0
PP
1950 /* ahem, death to those who redefine active sort subs */
1951 else if (curstack == sortstack
1952 && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
1953 croak("Can't redefine active sort subroutine %s",
1954 GvNAME(dstr));
a0d0e21e 1955 (void)SvOK_off(dstr);
a5f75d66 1956 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 1957 gp_free((GV*)dstr);
79072805 1958 GvGP(dstr) = gp_ref(GvGP(sstr));
8990e307 1959 SvTAINT(dstr);
a5f75d66
AD
1960 if (curcop->cop_stash != GvSTASH(dstr))
1961 GvIMPORTED_on(dstr);
1962 GvMULTI_on(dstr);
79072805
LW
1963 return;
1964 }
1965 /* FALL THROUGH */
1966
1967 default:
973f89ab
CS
1968 if (SvGMAGICAL(sstr)) {
1969 mg_get(sstr);
1970 if (SvTYPE(sstr) != stype) {
1971 stype = SvTYPE(sstr);
1972 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
1973 goto glob_assign;
1974 }
1975 }
8990e307
LW
1976 if (dtype < stype)
1977 sv_upgrade(dstr, stype);
79072805
LW
1978 }
1979
8990e307
LW
1980 sflags = SvFLAGS(sstr);
1981
1982 if (sflags & SVf_ROK) {
1983 if (dtype >= SVt_PV) {
1984 if (dtype == SVt_PVGV) {
11343788 1985 dTHR;
8990e307
LW
1986 SV *sref = SvREFCNT_inc(SvRV(sstr));
1987 SV *dref = 0;
a5f75d66 1988 int intro = GvINTRO(dstr);
a0d0e21e
LW
1989
1990 if (intro) {
1991 GP *gp;
1992 GvGP(dstr)->gp_refcnt--;
a5f75d66 1993 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 1994 Newz(602,gp, 1, GP);
44a8e56a 1995 GvGP(dstr) = gp_ref(gp);
a0d0e21e
LW
1996 GvSV(dstr) = NEWSV(72,0);
1997 GvLINE(dstr) = curcop->cop_line;
1edc1566 1998 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 1999 }
a5f75d66 2000 GvMULTI_on(dstr);
8990e307
LW
2001 switch (SvTYPE(sref)) {
2002 case SVt_PVAV:
a0d0e21e
LW
2003 if (intro)
2004 SAVESPTR(GvAV(dstr));
2005 else
2006 dref = (SV*)GvAV(dstr);
8990e307 2007 GvAV(dstr) = (AV*)sref;
a5f75d66
AD
2008 if (curcop->cop_stash != GvSTASH(dstr))
2009 GvIMPORTED_AV_on(dstr);
8990e307
LW
2010 break;
2011 case SVt_PVHV:
a0d0e21e
LW
2012 if (intro)
2013 SAVESPTR(GvHV(dstr));
2014 else
2015 dref = (SV*)GvHV(dstr);
8990e307 2016 GvHV(dstr) = (HV*)sref;
a5f75d66
AD
2017 if (curcop->cop_stash != GvSTASH(dstr))
2018 GvIMPORTED_HV_on(dstr);
8990e307
LW
2019 break;
2020 case SVt_PVCV:
8ebc5c01
PP
2021 if (intro) {
2022 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2023 SvREFCNT_dec(GvCV(dstr));
2024 GvCV(dstr) = Nullcv;
68dc0745
PP
2025 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2026 sub_generation++;
8ebc5c01 2027 }
a0d0e21e 2028 SAVESPTR(GvCV(dstr));
8ebc5c01 2029 }
68dc0745
PP
2030 else
2031 dref = (SV*)GvCV(dstr);
2032 if (GvCV(dstr) != (CV*)sref) {
748a9306 2033 CV* cv = GvCV(dstr);
4633a7c4 2034 if (cv) {
68dc0745
PP
2035 if (!GvCVGEN((GV*)dstr) &&
2036 (CvROOT(cv) || CvXSUB(cv)))
2037 {
7bac28a0
PP
2038 /* ahem, death to those who redefine
2039 * active sort subs */
2040 if (curstack == sortstack &&
2041 sortcop == CvSTART(cv))
2042 croak(
2043 "Can't redefine active sort subroutine %s",
2044 GvENAME((GV*)dstr));
9607fc9c
PP
2045 if (cv_const_sv(cv))
2046 warn("Constant subroutine %s redefined",
2047 GvENAME((GV*)dstr));
2048 else if (dowarn)
2049 warn("Subroutine %s redefined",
2050 GvENAME((GV*)dstr));
2051 }
3fe9a6f1
PP
2052 cv_ckproto(cv, (GV*)dstr,
2053 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 2054 }
a5f75d66 2055 GvCV(dstr) = (CV*)sref;
7a4c00b4 2056 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 2057 GvASSUMECV_on(dstr);
8ebc5c01 2058 sub_generation++;
a5f75d66
AD
2059 }
2060 if (curcop->cop_stash != GvSTASH(dstr))
2061 GvIMPORTED_CV_on(dstr);
8990e307 2062 break;
91bba347
LW
2063 case SVt_PVIO:
2064 if (intro)
2065 SAVESPTR(GvIOp(dstr));
2066 else
2067 dref = (SV*)GvIOp(dstr);
2068 GvIOp(dstr) = (IO*)sref;
2069 break;
8990e307 2070 default:
a0d0e21e
LW
2071 if (intro)
2072 SAVESPTR(GvSV(dstr));
2073 else
2074 dref = (SV*)GvSV(dstr);
8990e307 2075 GvSV(dstr) = sref;
a5f75d66
AD
2076 if (curcop->cop_stash != GvSTASH(dstr))
2077 GvIMPORTED_SV_on(dstr);
8990e307
LW
2078 break;
2079 }
2080 if (dref)
2081 SvREFCNT_dec(dref);
a0d0e21e
LW
2082 if (intro)
2083 SAVEFREESV(sref);
8990e307
LW
2084 SvTAINT(dstr);
2085 return;
2086 }
a0d0e21e 2087 if (SvPVX(dstr)) {
760ac839 2088 (void)SvOOK_off(dstr); /* backoff */
8990e307 2089 Safefree(SvPVX(dstr));
a0d0e21e
LW
2090 SvLEN(dstr)=SvCUR(dstr)=0;
2091 }
8990e307 2092 }
a0d0e21e 2093 (void)SvOK_off(dstr);
8990e307 2094 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 2095 SvROK_on(dstr);
8990e307 2096 if (sflags & SVp_NOK) {
ed6116ce
LW
2097 SvNOK_on(dstr);
2098 SvNVX(dstr) = SvNVX(sstr);
2099 }
8990e307 2100 if (sflags & SVp_IOK) {
a0d0e21e 2101 (void)SvIOK_on(dstr);
ed6116ce
LW
2102 SvIVX(dstr) = SvIVX(sstr);
2103 }
a0d0e21e
LW
2104#ifdef OVERLOAD
2105 if (SvAMAGIC(sstr)) {
2106 SvAMAGIC_on(dstr);
2107 }
2108#endif /* OVERLOAD */
ed6116ce 2109 }
8990e307 2110 else if (sflags & SVp_POK) {
79072805
LW
2111
2112 /*
2113 * Check to see if we can just swipe the string. If so, it's a
2114 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW
2115 * It might even be a win on short strings if SvPVX(dstr)
2116 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW
2117 */
2118
ff68c719 2119 if (SvTEMP(sstr) && /* slated for free anyway? */
a5f75d66
AD
2120 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2121 {
adbc6bb1 2122 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD
2123 if (SvOOK(dstr)) {
2124 SvFLAGS(dstr) &= ~SVf_OOK;
2125 Safefree(SvPVX(dstr) - SvIVX(dstr));
2126 }
2127 else
2128 Safefree(SvPVX(dstr));
79072805 2129 }
a5f75d66 2130 (void)SvPOK_only(dstr);
463ee0b2 2131 SvPV_set(dstr, SvPVX(sstr));
79072805
LW
2132 SvLEN_set(dstr, SvLEN(sstr));
2133 SvCUR_set(dstr, SvCUR(sstr));
79072805 2134 SvTEMP_off(dstr);
a5f75d66 2135 (void)SvOK_off(sstr);
79072805
LW
2136 SvPV_set(sstr, Nullch);
2137 SvLEN_set(sstr, 0);
a5f75d66
AD
2138 SvCUR_set(sstr, 0);
2139 SvTEMP_off(sstr);
79072805
LW
2140 }
2141 else { /* have to copy actual string */
8990e307
LW
2142 STRLEN len = SvCUR(sstr);
2143
2144 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2145 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2146 SvCUR_set(dstr, len);
2147 *SvEND(dstr) = '\0';
a0d0e21e 2148 (void)SvPOK_only(dstr);
79072805
LW
2149 }
2150 /*SUPPRESS 560*/
8990e307 2151 if (sflags & SVp_NOK) {
79072805 2152 SvNOK_on(dstr);
463ee0b2 2153 SvNVX(dstr) = SvNVX(sstr);
79072805 2154 }
8990e307 2155 if (sflags & SVp_IOK) {
a0d0e21e 2156 (void)SvIOK_on(dstr);
463ee0b2 2157 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2158 }
2159 }
8990e307 2160 else if (sflags & SVp_NOK) {
463ee0b2 2161 SvNVX(dstr) = SvNVX(sstr);
a0d0e21e 2162 (void)SvNOK_only(dstr);
79072805 2163 if (SvIOK(sstr)) {
a0d0e21e 2164 (void)SvIOK_on(dstr);
463ee0b2 2165 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2166 }
2167 }
8990e307 2168 else if (sflags & SVp_IOK) {
a0d0e21e 2169 (void)SvIOK_only(dstr);
463ee0b2 2170 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2171 }
2172 else {
a0d0e21e
LW
2173 (void)SvOK_off(dstr);
2174 }
463ee0b2 2175 SvTAINT(dstr);
79072805
LW
2176}
2177
2178void
2179sv_setpvn(sv,ptr,len)
2180register SV *sv;
71be2cbc 2181register const char *ptr;
79072805
LW
2182register STRLEN len;
2183{
4561caa4
CS
2184 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2185 elicit a warning, but it won't hurt. */
ed6116ce 2186 if (SvTHINKFIRST(sv)) {
8990e307 2187 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2188 croak(no_modify);
2189 if (SvROK(sv))
2190 sv_unref(sv);
2191 }
463ee0b2 2192 if (!ptr) {
a0d0e21e 2193 (void)SvOK_off(sv);
463ee0b2
LW
2194 return;
2195 }
c07a80fd
PP
2196 if (SvTYPE(sv) >= SVt_PV) {
2197 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2198 sv_unglob(sv);
2199 }
2200 else if (!sv_upgrade(sv, SVt_PV))
79072805
LW
2201 return;
2202 SvGROW(sv, len + 1);
a0d0e21e 2203 Move(ptr,SvPVX(sv),len,char);
79072805
LW
2204 SvCUR_set(sv, len);
2205 *SvEND(sv) = '\0';
a0d0e21e 2206 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2207 SvTAINT(sv);
79072805
LW
2208}
2209
2210void
2211sv_setpv(sv,ptr)
2212register SV *sv;
71be2cbc 2213register const char *ptr;
79072805
LW
2214{
2215 register STRLEN len;
2216
ed6116ce 2217 if (SvTHINKFIRST(sv)) {
8990e307 2218 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2219 croak(no_modify);
2220 if (SvROK(sv))
2221 sv_unref(sv);
2222 }
463ee0b2 2223 if (!ptr) {
a0d0e21e 2224 (void)SvOK_off(sv);
463ee0b2
LW
2225 return;
2226 }
79072805 2227 len = strlen(ptr);
c07a80fd
PP
2228 if (SvTYPE(sv) >= SVt_PV) {
2229 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2230 sv_unglob(sv);
2231 }
2232 else if (!sv_upgrade(sv, SVt_PV))
79072805
LW
2233 return;
2234 SvGROW(sv, len + 1);
463ee0b2 2235 Move(ptr,SvPVX(sv),len+1,char);
79072805 2236 SvCUR_set(sv, len);
a0d0e21e 2237 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2
LW
2238 SvTAINT(sv);
2239}
2240
2241void
2242sv_usepvn(sv,ptr,len)
2243register SV *sv;
2244register char *ptr;
2245register STRLEN len;
2246{
ed6116ce 2247 if (SvTHINKFIRST(sv)) {
8990e307 2248 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2249 croak(no_modify);
2250 if (SvROK(sv))
2251 sv_unref(sv);
2252 }
463ee0b2
LW
2253 if (!SvUPGRADE(sv, SVt_PV))
2254 return;
2255 if (!ptr) {
a0d0e21e 2256 (void)SvOK_off(sv);
463ee0b2
LW
2257 return;
2258 }
2259 if (SvPVX(sv))
2260 Safefree(SvPVX(sv));
2261 Renew(ptr, len+1, char);
2262 SvPVX(sv) = ptr;
2263 SvCUR_set(sv, len);
2264 SvLEN_set(sv, len+1);
2265 *SvEND(sv) = '\0';
a0d0e21e 2266 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2267 SvTAINT(sv);
79072805
LW
2268}
2269
2270void
2271sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
2272register SV *sv;
2273register char *ptr;
2274{
2275 register STRLEN delta;
2276
a0d0e21e 2277 if (!ptr || !SvPOKp(sv))
79072805 2278 return;
ed6116ce 2279 if (SvTHINKFIRST(sv)) {
8990e307 2280 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2281 croak(no_modify);
2282 if (SvROK(sv))
2283 sv_unref(sv);
2284 }
79072805
LW
2285 if (SvTYPE(sv) < SVt_PVIV)
2286 sv_upgrade(sv,SVt_PVIV);
2287
2288 if (!SvOOK(sv)) {
463ee0b2 2289 SvIVX(sv) = 0;
79072805
LW
2290 SvFLAGS(sv) |= SVf_OOK;
2291 }
8990e307 2292 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
463ee0b2 2293 delta = ptr - SvPVX(sv);
79072805
LW
2294 SvLEN(sv) -= delta;
2295 SvCUR(sv) -= delta;
463ee0b2
LW
2296 SvPVX(sv) += delta;
2297 SvIVX(sv) += delta;
79072805
LW
2298}
2299
2300void
2301sv_catpvn(sv,ptr,len)
2302register SV *sv;
2303register char *ptr;
2304register STRLEN len;
2305{
463ee0b2 2306 STRLEN tlen;
748a9306 2307 char *junk;
a0d0e21e 2308
748a9306 2309 junk = SvPV_force(sv, tlen);
463ee0b2 2310 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
2311 if (ptr == junk)
2312 ptr = SvPVX(sv);
463ee0b2 2313 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW
2314 SvCUR(sv) += len;
2315 *SvEND(sv) = '\0';
a0d0e21e 2316 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2317 SvTAINT(sv);
79072805
LW
2318}
2319
2320void
2321sv_catsv(dstr,sstr)
2322SV *dstr;
2323register SV *sstr;
2324{
2325 char *s;
463ee0b2 2326 STRLEN len;
79072805
LW
2327 if (!sstr)
2328 return;
463ee0b2
LW
2329 if (s = SvPV(sstr, len))
2330 sv_catpvn(dstr,s,len);
79072805
LW
2331}
2332
2333void
2334sv_catpv(sv,ptr)
2335register SV *sv;
2336register char *ptr;
2337{
2338 register STRLEN len;
463ee0b2 2339 STRLEN tlen;
748a9306 2340 char *junk;
79072805 2341
79072805
LW
2342 if (!ptr)
2343 return;
748a9306 2344 junk = SvPV_force(sv, tlen);
79072805 2345 len = strlen(ptr);
463ee0b2 2346 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
2347 if (ptr == junk)
2348 ptr = SvPVX(sv);
463ee0b2 2349 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 2350 SvCUR(sv) += len;
a0d0e21e 2351 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2352 SvTAINT(sv);
79072805
LW
2353}
2354
79072805
LW
2355SV *
2356#ifdef LEAKTEST
2357newSV(x,len)
2358I32 x;
2359#else
2360newSV(len)
2361#endif
2362STRLEN len;
2363{
2364 register SV *sv;
2365
4561caa4 2366 new_SV(sv);
8990e307
LW
2367 SvANY(sv) = 0;
2368 SvREFCNT(sv) = 1;
2369 SvFLAGS(sv) = 0;
79072805
LW
2370 if (len) {
2371 sv_upgrade(sv, SVt_PV);
2372 SvGROW(sv, len + 1);
2373 }
2374 return sv;
2375}
2376
1edc1566
PP
2377/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2378
79072805
LW
2379void
2380sv_magic(sv, obj, how, name, namlen)
2381register SV *sv;
2382SV *obj;
a0d0e21e 2383int how;
79072805 2384char *name;
463ee0b2 2385I32 namlen;
79072805
LW
2386{
2387 MAGIC* mg;
2388
55497cff 2389 if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
a0d0e21e 2390 croak(no_modify);
4633a7c4 2391 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW
2392 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2393 if (how == 't')
2394 mg->mg_len |= 1;
463ee0b2 2395 return;
748a9306 2396 }
463ee0b2
LW
2397 }
2398 else {
2399 if (!SvUPGRADE(sv, SVt_PVMG))
2400 return;
463ee0b2 2401 }
79072805
LW
2402 Newz(702,mg, 1, MAGIC);
2403 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 2404
79072805 2405 SvMAGIC(sv) = mg;
748a9306 2406 if (!obj || obj == sv || how == '#')
8990e307 2407 mg->mg_obj = obj;
85e6fe83 2408 else {
11343788 2409 dTHR;
8990e307 2410 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW
2411 mg->mg_flags |= MGf_REFCOUNTED;
2412 }
79072805 2413 mg->mg_type = how;
463ee0b2 2414 mg->mg_len = namlen;
1edc1566
PP
2415 if (name)
2416 if (namlen >= 0)
2417 mg->mg_ptr = savepvn(name, namlen);
e858de61
MB
2418 else if (namlen == HEf_SVKEY) {
2419 dTHR; /* just for SvREFCNT_inc */
1edc1566 2420 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
e858de61 2421 }
1edc1566 2422
79072805
LW
2423 switch (how) {
2424 case 0:
2425 mg->mg_virtual = &vtbl_sv;
2426 break;
a0d0e21e
LW
2427#ifdef OVERLOAD
2428 case 'A':
2429 mg->mg_virtual = &vtbl_amagic;
2430 break;
2431 case 'a':
2432 mg->mg_virtual = &vtbl_amagicelem;
2433 break;
2434 case 'c':
2435 mg->mg_virtual = 0;
2436 break;
2437#endif /* OVERLOAD */
79072805
LW
2438 case 'B':
2439 mg->mg_virtual = &vtbl_bm;
2440 break;
79072805
LW
2441 case 'E':
2442 mg->mg_virtual = &vtbl_env;
2443 break;
55497cff
PP
2444 case 'f':
2445 mg->mg_virtual = &vtbl_fm;
2446 break;
79072805
LW
2447 case 'e':
2448 mg->mg_virtual = &vtbl_envelem;
2449 break;
93a17b20
LW
2450 case 'g':
2451 mg->mg_virtual = &vtbl_mglob;
2452 break;
463ee0b2
LW
2453 case 'I':
2454 mg->mg_virtual = &vtbl_isa;
2455 break;
2456 case 'i':
2457 mg->mg_virtual = &vtbl_isaelem;
2458 break;
16660edb
PP
2459 case 'k':
2460 mg->mg_virtual = &vtbl_nkeys;
2461 break;
79072805 2462 case 'L':
a0d0e21e 2463 SvRMAGICAL_on(sv);
93a17b20
LW
2464 mg->mg_virtual = 0;
2465 break;
2466 case 'l':
79072805
LW
2467 mg->mg_virtual = &vtbl_dbline;
2468 break;
f93b4edd
MB
2469#ifdef USE_THREADS
2470 case 'm':
2471 mg->mg_virtual = &vtbl_mutex;
2472 break;
2473#endif /* USE_THREADS */
36477c24 2474#ifdef USE_LOCALE_COLLATE
bbce6d69
PP
2475 case 'o':
2476 mg->mg_virtual = &vtbl_collxfrm;
2477 break;
36477c24 2478#endif /* USE_LOCALE_COLLATE */
463ee0b2
LW
2479 case 'P':
2480 mg->mg_virtual = &vtbl_pack;
2481 break;
2482 case 'p':
a0d0e21e 2483 case 'q':
463ee0b2
LW
2484 mg->mg_virtual = &vtbl_packelem;
2485 break;
79072805
LW
2486 case 'S':
2487 mg->mg_virtual = &vtbl_sig;
2488 break;
2489 case 's':
2490 mg->mg_virtual = &vtbl_sigelem;
2491 break;
463ee0b2
LW
2492 case 't':
2493 mg->mg_virtual = &vtbl_taint;
748a9306 2494 mg->mg_len = 1;
463ee0b2 2495 break;
79072805
LW
2496 case 'U':
2497 mg->mg_virtual = &vtbl_uvar;
2498 break;
2499 case 'v':
2500 mg->mg_virtual = &vtbl_vec;
2501 break;
2502 case 'x':
2503 mg->mg_virtual = &vtbl_substr;
2504 break;
5f05dabc 2505 case 'y':
68dc0745 2506 mg->mg_virtual = &vtbl_defelem;
5f05dabc 2507 break;
79072805
LW
2508 case '*':
2509 mg->mg_virtual = &vtbl_glob;
2510 break;
2511 case '#':
2512 mg->mg_virtual = &vtbl_arylen;
2513 break;
a0d0e21e
LW
2514 case '.':
2515 mg->mg_virtual = &vtbl_pos;
2516 break;
4633a7c4
LW
2517 case '~': /* Reserved for use by extensions not perl internals. */
2518 /* Useful for attaching extension internal data to perl vars. */
2519 /* Note that multiple extensions may clash if magical scalars */
2520 /* etc holding private data from one are passed to another. */
2521 SvRMAGICAL_on(sv);
a0d0e21e 2522 break;
79072805 2523 default:
463ee0b2
LW
2524 croak("Don't know how to handle magic of type '%c'", how);
2525 }
8990e307
LW
2526 mg_magical(sv);
2527 if (SvGMAGICAL(sv))
2528 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW
2529}
2530
2531int
2532sv_unmagic(sv, type)
2533SV* sv;
a0d0e21e 2534int type;
463ee0b2
LW
2535{
2536 MAGIC* mg;
2537 MAGIC** mgp;
91bba347 2538 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW
2539 return 0;
2540 mgp = &SvMAGIC(sv);
2541 for (mg = *mgp; mg; mg = *mgp) {
2542 if (mg->mg_type == type) {
2543 MGVTBL* vtbl = mg->mg_virtual;
2544 *mgp = mg->mg_moremagic;
2545 if (vtbl && vtbl->svt_free)
2546 (*vtbl->svt_free)(sv, mg);
2547 if (mg->mg_ptr && mg->mg_type != 'g')
1edc1566
PP
2548 if (mg->mg_len >= 0)
2549 Safefree(mg->mg_ptr);
2550 else if (mg->mg_len == HEf_SVKEY)
2551 SvREFCNT_dec((SV*)mg->mg_ptr);
a0d0e21e
LW
2552 if (mg->mg_flags & MGf_REFCOUNTED)
2553 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW
2554 Safefree(mg);
2555 }
2556 else
2557 mgp = &mg->mg_moremagic;
79072805 2558 }
91bba347 2559 if (!SvMAGIC(sv)) {
463ee0b2 2560 SvMAGICAL_off(sv);
8990e307 2561 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW
2562 }
2563
2564 return 0;
79072805
LW
2565}
2566
2567void
2568sv_insert(bigstr,offset,len,little,littlelen)
2569SV *bigstr;
2570STRLEN offset;
2571STRLEN len;
2572char *little;
2573STRLEN littlelen;
2574{
2575 register char *big;
2576 register char *mid;
2577 register char *midend;
2578 register char *bigend;
2579 register I32 i;
2580
8990e307
LW
2581 if (!bigstr)
2582 croak("Can't modify non-existent substring");
a0d0e21e 2583 SvPV_force(bigstr, na);
79072805
LW
2584
2585 i = littlelen - len;
2586 if (i > 0) { /* string might grow */
a0d0e21e 2587 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW
2588 mid = big + offset + len;
2589 midend = bigend = big + SvCUR(bigstr);
2590 bigend += i;
2591 *bigend = '\0';
2592 while (midend > mid) /* shove everything down */
2593 *--bigend = *--midend;
2594 Move(little,big+offset,littlelen,char);
2595 SvCUR(bigstr) += i;
2596 SvSETMAGIC(bigstr);
2597 return;
2598 }
2599 else if (i == 0) {
463ee0b2 2600 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW
2601 SvSETMAGIC(bigstr);
2602 return;
2603 }
2604
463ee0b2 2605 big = SvPVX(bigstr);
79072805
LW
2606 mid = big + offset;
2607 midend = mid + len;
2608 bigend = big + SvCUR(bigstr);
2609
2610 if (midend > bigend)
463ee0b2 2611 croak("panic: sv_insert");
79072805
LW
2612
2613 if (mid - big > bigend - midend) { /* faster to shorten from end */
2614 if (littlelen) {
2615 Move(little, mid, littlelen,char);
2616 mid += littlelen;
2617 }
2618 i = bigend - midend;
2619 if (i > 0) {
2620 Move(midend, mid, i,char);
2621 mid += i;
2622 }
2623 *mid = '\0';
2624 SvCUR_set(bigstr, mid - big);
2625 }
2626 /*SUPPRESS 560*/
2627 else if (i = mid - big) { /* faster from front */
2628 midend -= littlelen;
2629 mid = midend;
2630 sv_chop(bigstr,midend-i);
2631 big += i;
2632 while (i--)
2633 *--midend = *--big;
2634 if (littlelen)
2635 Move(little, mid, littlelen,char);
2636 }
2637 else if (littlelen) {
2638 midend -= littlelen;
2639 sv_chop(bigstr,midend);
2640 Move(little,midend,littlelen,char);
2641 }
2642 else {
2643 sv_chop(bigstr,midend);
2644 }
2645 SvSETMAGIC(bigstr);
2646}
2647
2648/* make sv point to what nstr did */
2649
2650void
2651sv_replace(sv,nsv)
2652register SV *sv;
2653register SV *nsv;
2654{
2655 U32 refcnt = SvREFCNT(sv);
ed6116ce 2656 if (SvTHINKFIRST(sv)) {
8990e307 2657 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2658 croak(no_modify);
2659 if (SvROK(sv))
2660 sv_unref(sv);
2661 }
79072805
LW
2662 if (SvREFCNT(nsv) != 1)
2663 warn("Reference miscount in sv_replace()");
93a17b20 2664 if (SvMAGICAL(sv)) {
a0d0e21e
LW
2665 if (SvMAGICAL(nsv))
2666 mg_free(nsv);
2667 else
2668 sv_upgrade(nsv, SVt_PVMG);
93a17b20 2669 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 2670 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW
2671 SvMAGICAL_off(sv);
2672 SvMAGIC(sv) = 0;
2673 }
79072805
LW
2674 SvREFCNT(sv) = 0;
2675 sv_clear(sv);
477f5d66 2676 assert(!SvREFCNT(sv));
79072805
LW
2677 StructCopy(nsv,sv,SV);
2678 SvREFCNT(sv) = refcnt;
1edc1566 2679 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 2680 del_SV(nsv);
79072805
LW
2681}
2682
2683void
2684sv_clear(sv)
2685register SV *sv;
2686{
2687 assert(sv);
2688 assert(SvREFCNT(sv) == 0);
2689
ed6116ce 2690 if (SvOBJECT(sv)) {
e858de61 2691 dTHR;
a0d0e21e 2692 if (defstash) { /* Still have a symbol table? */
5dc0d613 2693 dTHR;
8ebc5c01
PP
2694 dSP;
2695 GV* destructor;
a0d0e21e
LW
2696
2697 ENTER;
2698 SAVEFREESV(SvSTASH(sv));
8ebc5c01
PP
2699
2700 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2701 if (destructor) {
a0d0e21e
LW
2702 SV ref;
2703
2704 Zero(&ref, 1, SV);
2705 sv_upgrade(&ref, SVt_RV);
a0d0e21e
LW
2706 SvRV(&ref) = SvREFCNT_inc(sv);
2707 SvROK_on(&ref);
d368068e
IZ
2708 SvREFCNT(&ref) = 1; /* Fake, but otherwise
2709 creating+destructing a ref
2710 leads to disaster. */
a0d0e21e
LW
2711
2712 EXTEND(SP, 2);
2713 PUSHMARK(SP);
2714 PUSHs(&ref);
2715 PUTBACK;
8ebc5c01
PP
2716 perl_call_sv((SV*)GvCV(destructor),
2717 G_DISCARD|G_EVAL|G_KEEPERR);
748a9306 2718 del_XRV(SvANY(&ref));
1edc1566 2719 SvREFCNT(sv)--;
a0d0e21e 2720 }
8ebc5c01 2721
a0d0e21e
LW
2722 LEAVE;
2723 }
4633a7c4
LW
2724 else
2725 SvREFCNT_dec(SvSTASH(sv));
a0d0e21e
LW
2726 if (SvOBJECT(sv)) {
2727 SvOBJECT_off(sv); /* Curse the object. */
2728 if (SvTYPE(sv) != SVt_PVIO)
2729 --sv_objcount; /* XXX Might want something more general */
2730 }
1edc1566 2731 if (SvREFCNT(sv)) {
477f5d66 2732 SV *ret;
1edc1566
PP
2733 if ( perldb
2734 && (ret = perl_get_sv("DB::ret", FALSE))
2735 && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) {
2736 /* Debugger is prone to dangling references. */
2737 SvRV(ret) = 0;
2738 SvROK_off(ret);
2739 SvREFCNT(sv) = 0;
477f5d66
CS
2740 }
2741 else {
2742 if (in_clean_objs)
2743 croak("DESTROY created new reference to dead object");
2744 /* DESTROY gave object new lease on life */
2745 return;
1edc1566
PP
2746 }
2747 }
463ee0b2 2748 }
c07a80fd 2749 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 2750 mg_free(sv);
79072805 2751 switch (SvTYPE(sv)) {
8990e307 2752 case SVt_PVIO:
5f05dabc
PP
2753 if (IoIFP(sv) != PerlIO_stdin() &&
2754 IoIFP(sv) != PerlIO_stdout() &&
2755 IoIFP(sv) != PerlIO_stderr())
2756 io_close((IO*)sv);
8990e307
LW
2757 Safefree(IoTOP_NAME(sv));
2758 Safefree(IoFMT_NAME(sv));
2759 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 2760 /* FALL THROUGH */
79072805 2761 case SVt_PVBM:
a0d0e21e 2762 goto freescalar;
79072805 2763 case SVt_PVCV:
748a9306 2764 case SVt_PVFM:
85e6fe83 2765 cv_undef((CV*)sv);
a0d0e21e 2766 goto freescalar;
79072805 2767 case SVt_PVHV:
85e6fe83 2768 hv_undef((HV*)sv);
a0d0e21e 2769 break;
79072805 2770 case SVt_PVAV:
85e6fe83 2771 av_undef((AV*)sv);
a0d0e21e
LW
2772 break;
2773 case SVt_PVGV:
1edc1566 2774 gp_free((GV*)sv);
a0d0e21e
LW
2775 Safefree(GvNAME(sv));
2776 /* FALL THROUGH */
79072805 2777 case SVt_PVLV:
79072805 2778 case SVt_PVMG:
79072805
LW
2779 case SVt_PVNV:
2780 case SVt_PVIV:
a0d0e21e
LW
2781 freescalar:
2782 (void)SvOOK_off(sv);
79072805
LW
2783 /* FALL THROUGH */
2784 case SVt_PV:
a0d0e21e 2785 case SVt_RV:
8990e307
LW
2786 if (SvROK(sv))
2787 SvREFCNT_dec(SvRV(sv));
1edc1566 2788 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 2789 Safefree(SvPVX(sv));
79072805 2790 break;
a0d0e21e 2791/*
79072805 2792 case SVt_NV:
79072805 2793 case SVt_IV:
79072805
LW
2794 case SVt_NULL:
2795 break;
a0d0e21e 2796*/
79072805
LW
2797 }
2798
2799 switch (SvTYPE(sv)) {
2800 case SVt_NULL:
2801 break;
79072805
LW
2802 case SVt_IV:
2803 del_XIV(SvANY(sv));
2804 break;
2805 case SVt_NV:
2806 del_XNV(SvANY(sv));
2807 break;
ed6116ce
LW
2808 case SVt_RV:
2809 del_XRV(SvANY(sv));
2810 break;
79072805
LW
2811 case SVt_PV:
2812 del_XPV(SvANY(sv));
2813 break;
2814 case SVt_PVIV:
2815 del_XPVIV(SvANY(sv));
2816 break;
2817 case SVt_PVNV:
2818 del_XPVNV(SvANY(sv));
2819 break;
2820 case SVt_PVMG:
2821 del_XPVMG(SvANY(sv));
2822 break;
2823 case SVt_PVLV:
2824 del_XPVLV(SvANY(sv));
2825 break;
2826 case SVt_PVAV:
2827 del_XPVAV(SvANY(sv));
2828 break;
2829 case SVt_PVHV:
2830 del_XPVHV(SvANY(sv));
2831 break;
2832 case SVt_PVCV:
2833 del_XPVCV(SvANY(sv));
2834 break;
2835 case SVt_PVGV:
2836 del_XPVGV(SvANY(sv));
2837 break;
2838 case SVt_PVBM:
2839 del_XPVBM(SvANY(sv));
2840 break;
2841 case SVt_PVFM:
2842 del_XPVFM(SvANY(sv));
2843 break;
8990e307
LW
2844 case SVt_PVIO:
2845 del_XPVIO(SvANY(sv));
2846 break;
79072805 2847 }
a0d0e21e 2848 SvFLAGS(sv) &= SVf_BREAK;
8990e307 2849 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW
2850}
2851
2852SV *
8990e307 2853sv_newref(sv)
79072805
LW
2854SV* sv;
2855{
463ee0b2
LW
2856 if (sv)
2857 SvREFCNT(sv)++;
79072805
LW
2858 return sv;
2859}
2860
2861void
2862sv_free(sv)
2863SV *sv;
2864{
2865 if (!sv)
2866 return;
a0d0e21e
LW
2867 if (SvREADONLY(sv)) {
2868 if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no)
2869 return;
79072805 2870 }
a0d0e21e
LW
2871 if (SvREFCNT(sv) == 0) {
2872 if (SvFLAGS(sv) & SVf_BREAK)
2873 return;
1edc1566
PP
2874 if (in_clean_all) /* All is fair */
2875 return;
79072805
LW
2876 warn("Attempt to free unreferenced scalar");
2877 return;
2878 }
8990e307
LW
2879 if (--SvREFCNT(sv) > 0)
2880 return;
463ee0b2
LW
2881#ifdef DEBUGGING
2882 if (SvTEMP(sv)) {
2883 warn("Attempt to free temp prematurely");
79072805 2884 return;
79072805 2885 }
463ee0b2 2886#endif
79072805 2887 sv_clear(sv);
477f5d66
CS
2888 if (! SvREFCNT(sv))
2889 del_SV(sv);
79072805
LW
2890}
2891
2892STRLEN
2893sv_len(sv)
2894register SV *sv;
2895{
748a9306 2896 char *junk;
463ee0b2 2897 STRLEN len;
79072805
LW
2898
2899 if (!sv)
2900 return 0;
2901
8990e307
LW
2902 if (SvGMAGICAL(sv))
2903 len = mg_len(sv);
2904 else
748a9306 2905 junk = SvPV(sv, len);
463ee0b2 2906 return len;
79072805
LW
2907}
2908
2909I32
2910sv_eq(str1,str2)
2911register SV *str1;
2912register SV *str2;
2913{
2914 char *pv1;
463ee0b2 2915 STRLEN cur1;
79072805 2916 char *pv2;
463ee0b2 2917 STRLEN cur2;
79072805
LW
2918
2919 if (!str1) {
2920 pv1 = "";
2921 cur1 = 0;
2922 }
463ee0b2
LW
2923 else
2924 pv1 = SvPV(str1, cur1);
79072805
LW
2925
2926 if (!str2)
2927 return !cur1;
463ee0b2
LW
2928 else
2929 pv2 = SvPV(str2, cur2);
79072805
LW
2930
2931 if (cur1 != cur2)
2932 return 0;
2933
36477c24 2934 return memEQ(pv1, pv2, cur1);
79072805
LW
2935}
2936
2937I32
bbce6d69 2938sv_cmp(str1, str2)
79072805
LW
2939register SV *str1;
2940register SV *str2;
2941{
bbce6d69
PP
2942 STRLEN cur1 = 0;
2943 char *pv1 = str1 ? SvPV(str1, cur1) : NULL;
2944 STRLEN cur2 = 0;
2945 char *pv2 = str2 ? SvPV(str2, cur2) : NULL;
79072805 2946 I32 retval;
79072805 2947
bbce6d69
PP
2948 if (!cur1)
2949 return cur2 ? -1 : 0;
16660edb 2950
bbce6d69
PP
2951 if (!cur2)
2952 return 1;
79072805 2953
bbce6d69 2954 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
16660edb 2955
bbce6d69
PP
2956 if (retval)
2957 return retval < 0 ? -1 : 1;
16660edb 2958
bbce6d69
PP
2959 if (cur1 == cur2)
2960 return 0;
2961 else
2962 return cur1 < cur2 ? -1 : 1;
2963}
16660edb 2964
bbce6d69
PP
2965I32
2966sv_cmp_locale(sv1, sv2)
2967register SV *sv1;
2968register SV *sv2;
2969{
36477c24 2970#ifdef USE_LOCALE_COLLATE
16660edb 2971
bbce6d69
PP
2972 char *pv1, *pv2;
2973 STRLEN len1, len2;
2974 I32 retval;
16660edb 2975
bbce6d69
PP
2976 if (collation_standard)
2977 goto raw_compare;
16660edb 2978
bbce6d69
PP
2979 len1 = 0;
2980 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL;
2981 len2 = 0;
2982 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : NULL;
16660edb 2983
bbce6d69
PP
2984 if (!pv1 || !len1) {
2985 if (pv2 && len2)
2986 return -1;
2987 else
2988 goto raw_compare;
2989 }
2990 else {
2991 if (!pv2 || !len2)
2992 return 1;
2993 }
16660edb 2994
bbce6d69 2995 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 2996
bbce6d69 2997 if (retval)
16660edb
PP
2998 return retval < 0 ? -1 : 1;
2999
bbce6d69
PP
3000 /*
3001 * When the result of collation is equality, that doesn't mean
3002 * that there are no differences -- some locales exclude some
3003 * characters from consideration. So to avoid false equalities,
3004 * we use the raw string as a tiebreaker.
3005 */
16660edb 3006
bbce6d69
PP
3007 raw_compare:
3008 /* FALL THROUGH */
16660edb 3009
36477c24 3010#endif /* USE_LOCALE_COLLATE */
16660edb 3011
bbce6d69
PP
3012 return sv_cmp(sv1, sv2);
3013}
79072805 3014
36477c24 3015#ifdef USE_LOCALE_COLLATE
7a4c00b4
PP
3016/*
3017 * Any scalar variable may carry an 'o' magic that contains the
3018 * scalar data of the variable transformed to such a format that
3019 * a normal memory comparison can be used to compare the data
3020 * according to the locale settings.
3021 */
bbce6d69
PP
3022char *
3023sv_collxfrm(sv, nxp)
3024 SV *sv;
3025 STRLEN *nxp;
3026{
7a4c00b4 3027 MAGIC *mg;
16660edb 3028
7a4c00b4
PP
3029 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
3030 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
bbce6d69
PP
3031 char *s, *xf;
3032 STRLEN len, xlen;
3033
7a4c00b4
PP
3034 if (mg)
3035 Safefree(mg->mg_ptr);
bbce6d69
PP
3036 s = SvPV(sv, len);
3037 if ((xf = mem_collxfrm(s, len, &xlen))) {
ff0cee69
PP
3038 if (SvREADONLY(sv)) {
3039 SAVEFREEPV(xf);
3040 *nxp = xlen;
3041 return xf;
3042 }
7a4c00b4
PP
3043 if (! mg) {
3044 sv_magic(sv, 0, 'o', 0, 0);
3045 mg = mg_find(sv, 'o');
3046 assert(mg);
bbce6d69 3047 }
7a4c00b4
PP
3048 mg->mg_ptr = xf;
3049 mg->mg_len = xlen;
3050 }
3051 else {
ff0cee69
PP
3052 if (mg) {
3053 mg->mg_ptr = NULL;
3054 mg->mg_len = -1;
3055 }
bbce6d69
PP
3056 }
3057 }
7a4c00b4 3058 if (mg && mg->mg_ptr) {
bbce6d69
PP
3059 *nxp = mg->mg_len;
3060 return mg->mg_ptr + sizeof(collation_ix);
3061 }
3062 else {
3063 *nxp = 0;
3064 return NULL;
16660edb 3065 }
79072805
LW
3066}
3067
36477c24 3068#endif /* USE_LOCALE_COLLATE */
bbce6d69 3069
79072805
LW
3070char *
3071sv_gets(sv,fp,append)
3072register SV *sv;
760ac839 3073register PerlIO *fp;
79072805
LW
3074I32 append;
3075{
c07a80fd
PP
3076 char *rsptr;
3077 STRLEN rslen;
3078 register STDCHAR rslast;
3079 register STDCHAR *bp;
3080 register I32 cnt;
3081 I32 i;
3082
ed6116ce 3083 if (SvTHINKFIRST(sv)) {
8990e307 3084 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
3085 croak(no_modify);
3086 if (SvROK(sv))
3087 sv_unref(sv);
3088 }
79072805 3089 if (!SvUPGRADE(sv, SVt_PV))
a0d0e21e 3090 return 0;
ff68c719 3091 SvSCREAM_off(sv);
c07a80fd
PP
3092
3093 if (RsSNARF(rs)) {
3094 rsptr = NULL;
3095 rslen = 0;
3096 }
3097 else if (RsPARA(rs)) {
3098 rsptr = "\n\n";
3099 rslen = 2;
3100 }
3101 else
3102 rsptr = SvPV(rs, rslen);
3103 rslast = rslen ? rsptr[rslen - 1] : '\0';
3104
3105 if (RsPARA(rs)) { /* have to do this both before and after */
79072805 3106 do { /* to make sure file boundaries work right */
760ac839 3107 if (PerlIO_eof(fp))
a0d0e21e 3108 return 0;
760ac839 3109 i = PerlIO_getc(fp);
79072805 3110 if (i != '\n') {
a0d0e21e
LW
3111 if (i == -1)
3112 return 0;
760ac839 3113 PerlIO_ungetc(fp,i);
79072805
LW
3114 break;
3115 }
3116 } while (i != EOF);
3117 }
c07a80fd 3118
760ac839
LW
3119 /* See if we know enough about I/O mechanism to cheat it ! */
3120
3121 /* This used to be #ifdef test - it is made run-time test for ease
3122 of abstracting out stdio interface. One call should be cheap
3123 enough here - and may even be a macro allowing compile
3124 time optimization.
3125 */
3126
3127 if (PerlIO_fast_gets(fp)) {
3128
3129 /*
3130 * We're going to steal some values from the stdio struct
3131 * and put EVERYTHING in the innermost loop into registers.
3132 */
3133 register STDCHAR *ptr;
3134 STRLEN bpx;
3135 I32 shortbuffered;
3136
16660edb
PP
3137#if defined(VMS) && defined(PERLIO_IS_STDIO)
3138 /* An ungetc()d char is handled separately from the regular
3139 * buffer, so we getc() it back out and stuff it in the buffer.
3140 */
3141 i = PerlIO_getc(fp);
3142 if (i == EOF) return 0;
3143 *(--((*fp)->_ptr)) = (unsigned char) i;
3144 (*fp)->_cnt++;
3145#endif
c07a80fd 3146
c2960299 3147 /* Here is some breathtakingly efficient cheating */
c07a80fd 3148
760ac839 3149 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 3150 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW
3151 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3152 if (cnt > 80 && SvLEN(sv) > append) {
3153 shortbuffered = cnt - SvLEN(sv) + append + 1;
3154 cnt -= shortbuffered;
3155 }
3156 else {
3157 shortbuffered = 0;
bbce6d69
PP
3158 /* remember that cnt can be negative */
3159 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW
3160 }
3161 }
3162 else
3163 shortbuffered = 0;
c07a80fd 3164 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
760ac839 3165 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb 3166 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3167 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
16660edb 3168 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3169 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3170 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3171 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
79072805
LW
3172 for (;;) {
3173 screamer:
93a17b20 3174 if (cnt > 0) {
c07a80fd 3175 if (rslen) {
760ac839
LW
3176 while (cnt > 0) { /* this | eat */
3177 cnt--;
c07a80fd
PP
3178 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3179 goto thats_all_folks; /* screams | sed :-) */
3180 }
3181 }
3182 else {
36477c24 3183 Copy(ptr, bp, cnt, char); /* this | eat */
c07a80fd
PP
3184 bp += cnt; /* screams | dust */
3185 ptr += cnt; /* louder | sed :-) */
a5f75d66 3186 cnt = 0;
93a17b20 3187 }
79072805
LW
3188 }
3189
748a9306 3190 if (shortbuffered) { /* oh well, must extend */
79072805
LW
3191 cnt = shortbuffered;
3192 shortbuffered = 0;
c07a80fd 3193 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW
3194 SvCUR_set(sv, bpx);
3195 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 3196 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW
3197 continue;
3198 }
3199
16660edb 3200 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3201 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
d1bf51dd 3202 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb 3203 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3204 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3205 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3206 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
16660edb 3207 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b
PP
3208 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3209 another abstraction. */
760ac839 3210 i = PerlIO_getc(fp); /* get more characters */
16660edb 3211 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3212 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3213 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3214 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
760ac839
LW
3215 cnt = PerlIO_get_cnt(fp);
3216 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb 3217 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3218 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
79072805 3219
748a9306
LW
3220 if (i == EOF) /* all done for ever? */
3221 goto thats_really_all_folks;
3222
c07a80fd 3223 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW
3224 SvCUR_set(sv, bpx);
3225 SvGROW(sv, bpx + cnt + 2);
c07a80fd
PP
3226 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3227
760ac839 3228 *bp++ = i; /* store character from PerlIO_getc */
79072805 3229
c07a80fd 3230 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 3231 goto thats_all_folks;
79072805
LW
3232 }
3233
3234thats_all_folks:
c07a80fd 3235 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 3236 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 3237 goto screamer; /* go back to the fray */
79072805
LW
3238thats_really_all_folks:
3239 if (shortbuffered)
3240 cnt += shortbuffered;
16660edb 3241 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3242 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
d1bf51dd 3243 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb 3244 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3245 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3246 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3247 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
79072805 3248 *bp = '\0';
760ac839 3249 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb
PP
3250 DEBUG_P(PerlIO_printf(Perl_debug_log,
3251 "Screamer: done, len=%d, string=|%.*s|\n",
9607fc9c 3252 SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
760ac839
LW
3253 }
3254 else
79072805 3255 {
760ac839 3256 /*The big, slow, and stupid way */
c07a80fd 3257 STDCHAR buf[8192];
79072805 3258
760ac839 3259screamer2:
c07a80fd 3260 if (rslen) {
760ac839
LW
3261 register STDCHAR *bpe = buf + sizeof(buf);
3262 bp = buf;
3263 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3264 ; /* keep reading */
3265 cnt = bp - buf;
c07a80fd
PP
3266 }
3267 else {
760ac839 3268 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb
PP
3269 /* Accomodate broken VAXC compiler, which applies U8 cast to
3270 * both args of ?: operator, causing EOF to change into 255
3271 */
3272 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 3273 }
79072805
LW
3274
3275 if (append)
760ac839 3276 sv_catpvn(sv, (char *) buf, cnt);
79072805 3277 else
760ac839 3278 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd
PP
3279
3280 if (i != EOF && /* joy */
3281 (!rslen ||
3282 SvCUR(sv) < rslen ||
36477c24 3283 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW
3284 {
3285 append = -1;
63e4d877
CS
3286 /*
3287 * If we're reading from a TTY and we get a short read,
3288 * indicating that the user hit his EOF character, we need
3289 * to notice it now, because if we try to read from the TTY
3290 * again, the EOF condition will disappear.
3291 *
3292 * The comparison of cnt to sizeof(buf) is an optimization
3293 * that prevents unnecessary calls to feof().
3294 *
3295 * - jik 9/25/96
3296 */
3297 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3298 goto screamer2;
79072805
LW
3299 }
3300 }
3301
c07a80fd
PP
3302 if (RsPARA(rs)) { /* have to do this both before and after */
3303 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 3304 i = PerlIO_getc(fp);
79072805 3305 if (i != '\n') {
760ac839 3306 PerlIO_ungetc(fp,i);
79072805
LW
3307 break;
3308 }
3309 }
3310 }
c07a80fd
PP
3311
3312 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW
3313}
3314
760ac839 3315
79072805
LW
3316void
3317sv_inc(sv)
3318register SV *sv;
3319{
3320 register char *d;
463ee0b2 3321 int flags;
79072805
LW
3322
3323 if (!sv)
3324 return;
ed6116ce 3325 if (SvTHINKFIRST(sv)) {
8990e307 3326 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce 3327 croak(no_modify);
a0d0e21e
LW
3328 if (SvROK(sv)) {
3329#ifdef OVERLOAD
3330 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
3331#endif /* OVERLOAD */
3332 sv_unref(sv);
3333 }
ed6116ce 3334 }
8990e307 3335 if (SvGMAGICAL(sv))
79072805 3336 mg_get(sv);
8990e307 3337 flags = SvFLAGS(sv);
8990e307 3338 if (flags & SVp_NOK) {
a0d0e21e 3339 (void)SvNOK_only(sv);
55497cff
PP
3340 SvNVX(sv) += 1.0;
3341 return;
3342 }
3343 if (flags & SVp_IOK) {
3344 if (SvIVX(sv) == IV_MAX)
3345 sv_setnv(sv, (double)IV_MAX + 1.0);
3346 else {
3347 (void)SvIOK_only(sv);
3348 ++SvIVX(sv);
3349 }
79072805
LW
3350 return;
3351 }
8990e307 3352 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4633a7c4
LW
3353 if ((flags & SVTYPEMASK) < SVt_PVNV)
3354 sv_upgrade(sv, SVt_NV);
463ee0b2 3355 SvNVX(sv) = 1.0;
a0d0e21e 3356 (void)SvNOK_only(sv);
79072805
LW
3357 return;
3358 }
463ee0b2 3359 d = SvPVX(sv);
79072805
LW
3360 while (isALPHA(*d)) d++;
3361 while (isDIGIT(*d)) d++;
3362 if (*d) {
36477c24 3363 SET_NUMERIC_STANDARD();
bbce6d69 3364 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
79072805
LW
3365 return;
3366 }
3367 d--;
463ee0b2 3368 while (d >= SvPVX(sv)) {
79072805
LW
3369 if (isDIGIT(*d)) {
3370 if (++*d <= '9')
3371 return;
3372 *(d--) = '0';
3373 }
3374 else {
3375 ++*d;
3376 if (isALPHA(*d))
3377 return;
3378 *(d--) -= 'z' - 'a' + 1;
3379 }
3380 }
3381 /* oh,oh, the number grew */
3382 SvGROW(sv, SvCUR(sv) + 2);
3383 SvCUR(sv)++;
463ee0b2 3384 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW
3385 *d = d[-1];
3386 if (isDIGIT(d[1]))
3387 *d = '1';
3388 else
3389 *d = d[1];
3390}
3391
3392void
3393sv_dec(sv)
3394register SV *sv;
3395{
463ee0b2
LW
3396 int flags;
3397
79072805
LW
3398 if (!sv)
3399 return;
ed6116ce 3400 if (SvTHINKFIRST(sv)) {
8990e307 3401 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce 3402 croak(no_modify);
a0d0e21e
LW
3403 if (SvROK(sv)) {
3404#ifdef OVERLOAD
3405 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
3406#endif /* OVERLOAD */
3407 sv_unref(sv);
3408 }
ed6116ce 3409 }
8990e307 3410 if (SvGMAGICAL(sv))
79072805 3411 mg_get(sv);
8990e307 3412 flags = SvFLAGS(sv);
8990e307 3413 if (flags & SVp_NOK) {
463ee0b2 3414 SvNVX(sv) -= 1.0;
a0d0e21e 3415 (void)SvNOK_only(sv);
79072805
LW
3416 return;
3417 }
55497cff
PP
3418 if (flags & SVp_IOK) {
3419 if (SvIVX(sv) == IV_MIN)
3420 sv_setnv(sv, (double)IV_MIN - 1.0);
3421 else {
3422 (void)SvIOK_only(sv);
3423 --SvIVX(sv);
3424 }
3425 return;
3426 }
8990e307 3427 if (!(flags & SVp_POK)) {
4633a7c4
LW
3428 if ((flags & SVTYPEMASK) < SVt_PVNV)
3429 sv_upgrade(sv, SVt_NV);
463ee0b2 3430 SvNVX(sv) = -1.0;
a0d0e21e 3431 (void)SvNOK_only(sv);
79072805
LW
3432 return;
3433 }
36477c24 3434 SET_NUMERIC_STANDARD();
bbce6d69 3435 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW
3436}
3437
3438/* Make a string that will exist for the duration of the expression
3439 * evaluation. Actually, it may have to last longer than that, but
3440 * hopefully we won't free it until it has been assigned to a
3441 * permanent location. */
3442
8990e307
LW
3443static void
3444sv_mortalgrow()
3445{
11343788 3446 dTHR;
55497cff 3447 tmps_max += (tmps_max < 512) ? 128 : 512;
8990e307
LW
3448 Renew(tmps_stack, tmps_max, SV*);
3449}
3450
79072805
LW
3451SV *
3452sv_mortalcopy(oldstr)
3453SV *oldstr;
3454{
11343788 3455 dTHR;
463ee0b2 3456 register SV *sv;
79072805 3457
4561caa4 3458 new_SV(sv);
8990e307
LW
3459 SvANY(sv) = 0;
3460 SvREFCNT(sv) = 1;
3461 SvFLAGS(sv) = 0;
79072805 3462 sv_setsv(sv,oldstr);
8990e307
LW
3463 if (++tmps_ix >= tmps_max)
3464 sv_mortalgrow();
3465 tmps_stack[tmps_ix] = sv;
3466 SvTEMP_on(sv);
3467 return sv;
3468}
3469
3470SV *
3471sv_newmortal()
3472{
11343788 3473 dTHR;
8990e307
LW
3474 register SV *sv;
3475
4561caa4 3476 new_SV(sv);
8990e307
LW
3477 SvANY(sv) = 0;
3478 SvREFCNT(sv) = 1;
3479 SvFLAGS(sv) = SVs_TEMP;
3480 if (++tmps_ix >= tmps_max)
3481 sv_mortalgrow();
79072805 3482 tmps_stack[tmps_ix] = sv;
79072805
LW
3483 return sv;
3484}
3485
3486/* same thing without the copying */
3487
3488SV *
3489sv_2mortal(sv)
3490register SV *sv;
3491{
11343788 3492 dTHR;
79072805
LW
3493 if (!sv)
3494 return sv;
a0d0e21e
LW
3495 if (SvREADONLY(sv) && curcop != &compiling)
3496 croak(no_modify);
8990e307
LW
3497 if (++tmps_ix >= tmps_max)
3498 sv_mortalgrow();
79072805 3499 tmps_stack[tmps_ix] = sv;
8990e307 3500 SvTEMP_on(sv);
79072805
LW
3501 return sv;
3502}
3503
3504SV *
3505newSVpv(s,len)
3506char *s;
3507STRLEN len;
3508{
463ee0b2 3509 register SV *sv;
79072805 3510
4561caa4 3511 new_SV(sv);
8990e307
LW
3512 SvANY(sv) = 0;
3513 SvREFCNT(sv) = 1;
3514 SvFLAGS(sv) = 0;
79072805
LW
3515 if (!len)
3516 len = strlen(s);
3517 sv_setpvn(sv,s,len);
3518 return sv;
3519}
3520
46fc3d4c
PP
3521#ifdef I_STDARG
3522SV *
3523newSVpvf(const char* pat, ...)
3524#else
3525/*VARARGS0*/
3526SV *
fc36a67e 3527newSVpvf(pat, va_alist)
46fc3d4c
PP
3528const char *pat;
3529va_dcl
3530#endif
3531{
3532 register SV *sv;
3533 va_list args;
3534
3535 new_SV(sv);
3536 SvANY(sv) = 0;
3537 SvREFCNT(sv) = 1;
3538 SvFLAGS(sv) = 0;
3539#ifdef I_STDARG
3540 va_start(args, pat);
3541#else
3542 va_start(args);
3543#endif
fc36a67e 3544 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
46fc3d4c
PP
3545 va_end(args);
3546 return sv;
3547}
3548
3549
79072805
LW
3550SV *
3551newSVnv(n)
3552double n;
3553{
463ee0b2 3554 register SV *sv;
79072805 3555
4561caa4 3556 new_SV(sv);
8990e307
LW
3557 SvANY(sv) = 0;
3558 SvREFCNT(sv) = 1;
3559 SvFLAGS(sv) = 0;
79072805
LW
3560 sv_setnv(sv,n);
3561 return sv;
3562}
3563
3564SV *
3565newSViv(i)
a0d0e21e 3566IV i;
79072805 3567{
463ee0b2 3568 register SV *sv;
79072805 3569
4561caa4 3570 new_SV(sv);
8990e307
LW
3571 SvANY(sv) = 0;
3572 SvREFCNT(sv) = 1;
3573 SvFLAGS(sv) = 0;
79072805
LW
3574 sv_setiv(sv,i);
3575 return sv;
3576}
3577
2304df62
AD
3578SV *
3579newRV(ref)
3580SV *ref;
3581{
11343788 3582 dTHR;
2304df62
AD
3583 register SV *sv;
3584
4561caa4 3585 new_SV(sv);
2304df62
AD
3586 SvANY(sv) = 0;
3587 SvREFCNT(sv) = 1;
3588 SvFLAGS(sv) = 0;
3589 sv_upgrade(sv, SVt_RV);
a0d0e21e 3590 SvTEMP_off(ref);
2304df62
AD
3591 SvRV(sv) = SvREFCNT_inc(ref);
3592 SvROK_on(sv);
2304df62
AD
3593 return sv;
3594}
3595
5f05dabc
PP
3596#ifdef CRIPPLED_CC
3597SV *
3598newRV_noinc(ref)
3599SV *ref;
3600{
3601 register SV *sv;
3602
3603 sv = newRV(ref);
3604 SvREFCNT_dec(ref);
3605 return sv;
3606}
3607#endif /* CRIPPLED_CC */
3608
79072805
LW
3609/* make an exact duplicate of old */
3610
3611SV *
3612newSVsv(old)
3613register SV *old;
3614{
463ee0b2 3615 register SV *sv;
79072805
LW
3616
3617 if (!old)
3618 return Nullsv;
8990e307 3619 if (SvTYPE(old) == SVTYPEMASK) {
79072805
LW
3620 warn("semi-panic: attempt to dup freed string");
3621 return Nullsv;
3622 }
4561caa4 3623 new_SV(sv);
8990e307
LW
3624 SvANY(sv) = 0;
3625 SvREFCNT(sv) = 1;
3626 SvFLAGS(sv) = 0;
ff68c719
PP
3627 if (SvTEMP(old)) {
3628 SvTEMP_off(old);
463ee0b2 3629 sv_setsv(sv,old);
ff68c719 3630 SvTEMP_on(old);
79072805
LW
3631 }
3632 else
463ee0b2
LW
3633 sv_setsv(sv,old);
3634 return sv;
79072805
LW
3635}
3636
3637void
3638sv_reset(s,stash)
3639register char *s;
3640HV *stash;
3641{
3642 register HE *entry;
3643 register GV *gv;
3644 register SV *sv;
3645 register I32 i;
3646 register PMOP *pm;
3647 register I32 max;
463ee0b2 3648 char todo[256];
79072805
LW
3649
3650 if (!*s) { /* reset ?? searches */
3651 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
3652 pm->op_pmflags &= ~PMf_USED;
3653 }
3654 return;
3655 }
3656
3657 /* reset variables */
3658
3659 if (!HvARRAY(stash))
3660 return;
463ee0b2
LW
3661
3662 Zero(todo, 256, char);
79072805
LW
3663 while (*s) {
3664 i = *s;
3665 if (s[1] == '-') {
3666 s += 2;
3667 }
3668 max = *s++;
3669 for ( ; i <= max; i++) {
463ee0b2
LW
3670 todo[i] = 1;
3671 }
a0d0e21e 3672 for (i = 0; i <= (I32) HvMAX(stash); i++) {
79072805
LW
3673 for (entry = HvARRAY(stash)[i];
3674 entry;
1edc1566
PP
3675 entry = HeNEXT(entry)) {
3676 if (!todo[(U8)*HeKEY(entry)])
463ee0b2 3677 continue;
1edc1566 3678 gv = (GV*)HeVAL(entry);
79072805 3679 sv = GvSV(gv);
a0d0e21e 3680 (void)SvOK_off(sv);
79072805
LW
3681 if (SvTYPE(sv) >= SVt_PV) {
3682 SvCUR_set(sv, 0);
463ee0b2
LW
3683 if (SvPVX(sv) != Nullch)
3684 *SvPVX(sv) = '\0';
44a8e56a 3685 SvTAINT(sv);
79072805
LW
3686 }
3687 if (GvAV(gv)) {
3688 av_clear(GvAV(gv));
3689 }
44a8e56a 3690 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
463ee0b2 3691 hv_clear(GvHV(gv));
a0d0e21e 3692#ifndef VMS /* VMS has no environ array */
79072805
LW
3693 if (gv == envgv)
3694 environ[0] = Nullch;
a0d0e21e 3695#endif
79072805
LW
3696 }
3697 }
3698 }
3699 }
3700}
3701
46fc3d4c
PP
3702IO*
3703sv_2io(sv)
3704SV *sv;
3705{
3706 IO* io;
3707 GV* gv;
3708
3709 switch (SvTYPE(sv)) {
3710 case SVt_PVIO:
3711 io = (IO*)sv;
3712 break;
3713 case SVt_PVGV:
3714 gv = (GV*)sv;
3715 io = GvIO(gv);
3716 if (!io)
3717 croak("Bad filehandle: %s", GvNAME(gv));
3718 break;
3719 default:
3720 if (!SvOK(sv))
3721 croak(no_usym, "filehandle");
3722 if (SvROK(sv))
3723 return sv_2io(SvRV(sv));
3724 gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO);
3725 if (gv)
3726 io = GvIO(gv);
3727 else
3728 io = 0;
3729 if (!io)
3730 croak("Bad filehandle: %s", SvPV(sv,na));
3731 break;
3732 }
3733 return io;
3734}
3735
79072805
LW
3736CV *
3737sv_2cv(sv, st, gvp, lref)
3738SV *sv;
3739HV **st;
3740GV **gvp;
3741I32 lref;
3742{
3743 GV *gv;
3744 CV *cv;
3745
3746 if (!sv)
93a17b20 3747 return *gvp = Nullgv, Nullcv;
79072805 3748 switch (SvTYPE(sv)) {
79072805
LW
3749 case SVt_PVCV:
3750 *st = CvSTASH(sv);
3751 *gvp = Nullgv;
3752 return (CV*)sv;
3753 case SVt_PVHV:
3754 case SVt_PVAV:
3755 *gvp = Nullgv;
3756 return Nullcv;
8990e307
LW
3757 case SVt_PVGV:
3758 gv = (GV*)sv;
a0d0e21e 3759 *gvp = gv;
8990e307
LW
3760 *st = GvESTASH(gv);
3761 goto fix_gv;
3762
79072805 3763 default:
a0d0e21e
LW
3764 if (SvGMAGICAL(sv))
3765 mg_get(sv);
3766 if (SvROK(sv)) {
3767 cv = (CV*)SvRV(sv);
3768 if (SvTYPE(cv) != SVt_PVCV)
3769 croak("Not a subroutine reference");
3770 *gvp = Nullgv;
3771 *st = CvSTASH(cv);
3772 return cv;
3773 }
79072805
LW
3774 if (isGV(sv))
3775 gv = (GV*)sv;
3776 else
85e6fe83 3777 gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV);
79072805
LW
3778 *gvp = gv;
3779 if (!gv)
3780 return Nullcv;
3781 *st = GvESTASH(gv);
8990e307 3782 fix_gv:
8ebc5c01 3783 if (lref && !GvCVu(gv)) {
4633a7c4 3784 SV *tmpsv;
748a9306 3785 ENTER;
4633a7c4 3786 tmpsv = NEWSV(704,0);
16660edb 3787 gv_efullname3(tmpsv, gv, Nullch);
774d564b 3788 newSUB(start_subparse(FALSE, 0),
4633a7c4
LW
3789 newSVOP(OP_CONST, 0, tmpsv),
3790 Nullop,
8990e307 3791 Nullop);
748a9306 3792 LEAVE;
8ebc5c01 3793 if (!GvCVu(gv))
4633a7c4 3794 croak("Unable to create sub named \"%s\"", SvPV(sv,na));
8990e307 3795 }
8ebc5c01 3796 return GvCVu(gv);
79072805
LW
3797 }
3798}
3799
3800#ifndef SvTRUE
3801I32
3802SvTRUE(sv)
3803register SV *sv;
3804{
8990e307
LW
3805 if (!sv)
3806 return 0;
3807 if (SvGMAGICAL(sv))
79072805
LW
3808 mg_get(sv);
3809 if (SvPOK(sv)) {
3810 register XPV* Xpv;
3811 if ((Xpv = (XPV*)SvANY(sv)) &&
3812 (*Xpv->xpv_pv > '0' ||
3813 Xpv->xpv_cur > 1 ||
3814 (Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
3815 return 1;
3816 else
3817 return 0;
3818 }
3819 else {
3820 if (SvIOK(sv))
463ee0b2 3821 return SvIVX(sv) != 0;
79072805
LW
3822 else {
3823 if (SvNOK(sv))
463ee0b2 3824 return SvNVX(sv) != 0.0;
79072805 3825 else
463ee0b2 3826 return sv_2bool(sv);
79072805
LW
3827 }
3828 }
3829}
ff68c719 3830#endif /* !SvTRUE */
79072805 3831
85e6fe83 3832#ifndef SvIV
ff68c719
PP
3833IV
3834SvIV(sv)
3835register SV *sv;
85e6fe83 3836{