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