This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix formatting in perldiag
[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
PP
17#ifdef OVR_DBL_DIG
18/* Use an overridden DBL_DIG */
19# ifdef DBL_DIG
20# undef DBL_DIG
21# endif
22# define DBL_DIG OVR_DBL_DIG
23#else
a0d0e21e
LW
24/* The following is all to get DBL_DIG, in order to pick a nice
25 default value for printing floating point numbers in Gconvert.
26 (see config.h)
27*/
28#ifdef I_LIMITS
29#include <limits.h>
30#endif
31#ifdef I_FLOAT
32#include <float.h>
33#endif
34#ifndef HAS_DBL_DIG
35#define DBL_DIG 15 /* A guess that works lots of places */
36#endif
c07a80fd
PP
37#endif
38
1edc1566 39#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
c07a80fd
PP
40# define FAST_SV_GETS
41#endif
a0d0e21e 42
36477c24
PP
43static IV asIV _((SV* sv));
44static UV asUV _((SV* sv));
a0d0e21e
LW
45static SV *more_sv _((void));
46static XPVIV *more_xiv _((void));
47static XPVNV *more_xnv _((void));
48static XPV *more_xpv _((void));
49static XRV *more_xrv _((void));
a0d0e21e
LW
50static XPVIV *new_xiv _((void));
51static XPVNV *new_xnv _((void));
52static XPV *new_xpv _((void));
53static XRV *new_xrv _((void));
54static void del_xiv _((XPVIV* p));
55static void del_xnv _((XPVNV* p));
56static void del_xpv _((XPV* p));
57static void del_xrv _((XRV* p));
58static void sv_mortalgrow _((void));
a0d0e21e
LW
59static void sv_unglob _((SV* sv));
60
4561caa4
CS
61typedef void (*SVFUNC) _((SV*));
62
a0d0e21e 63#ifdef PURIFY
79072805 64
4561caa4
CS
65#define new_SV(p) \
66 do { \
67 (p) = (SV*)safemalloc(sizeof(SV)); \
68 reg_add(p); \
69 } while (0)
70
71#define del_SV(p) \
72 do { \
73 reg_remove(p); \
74 free((char*)(p)); \
75 } while (0)
76
77static SV **registry;
78static I32 regsize;
79
80#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
81
82#define REG_REPLACE(sv,a,b) \
83 do { \
84 void* p = sv->sv_any; \
85 I32 h = REGHASH(sv, regsize); \
86 I32 i = h; \
87 while (registry[i] != (a)) { \
88 if (++i >= regsize) \
89 i = 0; \
90 if (i == h) \
91 die("SV registry bug"); \
92 } \
93 registry[i] = (b); \
94 } while (0)
95
96#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
97#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
98
99static void
100reg_add(sv)
101SV* sv;
102{
103 if (sv_count >= (regsize >> 1))
104 {
105 SV **oldreg = registry;
106 I32 oldsize = regsize;
107
108 regsize = regsize ? ((regsize << 2) + 1) : 2037;
109 registry = (SV**)safemalloc(regsize * sizeof(SV*));
110 memzero(registry, regsize * sizeof(SV*));
111
112 if (oldreg) {
113 I32 i;
114
115 for (i = 0; i < oldsize; ++i) {
116 SV* oldsv = oldreg[i];
117 if (oldsv)
118 REG_ADD(oldsv);
119 }
120 Safefree(oldreg);
121 }
122 }
123
124 REG_ADD(sv);
125 ++sv_count;
126}
127
128static void
129reg_remove(sv)
130SV* sv;
131{
132 REG_REMOVE(sv);
133 --sv_count;
134}
135
136static void
137visit(f)
138SVFUNC f;
139{
140 I32 i;
141
142 for (i = 0; i < regsize; ++i) {
143 SV* sv = registry[i];
144 if (sv)
145 (*f)(sv);
146 }
147}
a0d0e21e 148
4633a7c4
LW
149void
150sv_add_arena(ptr, size, flags)
151char* ptr;
152U32 size;
153U32 flags;
154{
155 if (!(flags & SVf_FAKE))
156 free(ptr);
157}
158
4561caa4
CS
159#else /* ! PURIFY */
160
161/*
162 * "A time to plant, and a time to uproot what was planted..."
163 */
164
165#define plant_SV(p) \
166 do { \
167 SvANY(p) = (void *)sv_root; \
168 SvFLAGS(p) = SVTYPEMASK; \
169 sv_root = (p); \
170 --sv_count; \
171 } while (0)
a0d0e21e 172
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
PP
258 if (nice_chunk) {
259 sv_add_arena(nice_chunk, nice_chunk_size, 0);
260 nice_chunk = Nullch;
261 }
1edc1566
PP
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
PP
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
PP
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
PP
1203 int ch = *s & 0xFF;
1204 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW
1205 *d++ = 'M';
1206 *d++ = '-';
1207 ch &= 127;
1208 }
bbce6d69
PP
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
PP
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
PP
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
PP
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
PP
1334 if (SvPOKp(sv) && SvLEN(sv))
1335 return asUV(sv);
1336 if (!SvROK(sv))
1337 return 0;
ff68c719
PP
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
PP
1352 if (SvPOKp(sv) && SvLEN(sv))
1353 return asUV(sv);
ff68c719
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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;
1507 I32 numtype = 1;
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++;
1523 if (s >= send)
1524 return 0;
1525 if (*s == '+' || *s == '-')
1526 s++;
1527 while (isDIGIT(*s))
1528 s++;
1529 if (s == send)
1530 return numtype;
1531 if (*s == '.') {
1532 numtype = 1;
1533 s++;
1534 }
1535 else if (s == SvPVX(sv))
1536 return 0;
1537 while (isDIGIT(*s))
1538 s++;
1539 if (s == send)
1540 return numtype;
1541 if (*s == 'e' || *s == 'E') {
1542 numtype = 2;
1543 s++;
1544 if (*s == '+' || *s == '-')
1545 s++;
1546 while (isDIGIT(*s))
1547 s++;
1548 }
1549 while (isSPACE(*s))
1550 s++;
1551 if (s >= send)
1552 return numtype;
1553 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1554 return 1;
1555 return 0;
1556}
1557
79072805 1558char *
463ee0b2 1559sv_2pv(sv, lp)
79072805 1560register SV *sv;
463ee0b2 1561STRLEN *lp;
79072805
LW
1562{
1563 register char *s;
1564 int olderrno;
1565
463ee0b2
LW
1566 if (!sv) {
1567 *lp = 0;
1568 return "";
1569 }
8990e307 1570 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1571 mg_get(sv);
1572 if (SvPOKp(sv)) {
1573 *lp = SvCUR(sv);
1574 return SvPVX(sv);
1575 }
1576 if (SvIOKp(sv)) {
a0d0e21e
LW
1577 (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
1578 goto tokensave;
463ee0b2
LW
1579 }
1580 if (SvNOKp(sv)) {
36477c24 1581 SET_NUMERIC_STANDARD();
a0d0e21e
LW
1582 Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
1583 goto tokensave;
463ee0b2 1584 }
16d20bd9
AD
1585 if (!SvROK(sv)) {
1586 *lp = 0;
1587 return "";
1588 }
463ee0b2 1589 }
ed6116ce
LW
1590 if (SvTHINKFIRST(sv)) {
1591 if (SvROK(sv)) {
a0d0e21e
LW
1592#ifdef OVERLOAD
1593 SV* tmpstr;
1594 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1595 return SvPV(tmpstr,*lp);
1596#endif /* OVERLOAD */
ed6116ce
LW
1597 sv = (SV*)SvRV(sv);
1598 if (!sv)
1599 s = "NULLREF";
1600 else {
1601 switch (SvTYPE(sv)) {
1602 case SVt_NULL:
1603 case SVt_IV:
1604 case SVt_NV:
1605 case SVt_RV:
1606 case SVt_PV:
1607 case SVt_PVIV:
1608 case SVt_PVNV:
1609 case SVt_PVBM:
1610 case SVt_PVMG: s = "SCALAR"; break;
1611 case SVt_PVLV: s = "LVALUE"; break;
1612 case SVt_PVAV: s = "ARRAY"; break;
1613 case SVt_PVHV: s = "HASH"; break;
1614 case SVt_PVCV: s = "CODE"; break;
1615 case SVt_PVGV: s = "GLOB"; break;
1616 case SVt_PVFM: s = "FORMATLINE"; break;
36477c24 1617 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW
1618 default: s = "UNKNOWN"; break;
1619 }
1620 if (SvOBJECT(sv))
1621 sprintf(tokenbuf, "%s=%s(0x%lx)",
1622 HvNAME(SvSTASH(sv)), s, (unsigned long)sv);
1623 else
1624 sprintf(tokenbuf, "%s(0x%lx)", s, (unsigned long)sv);
a0d0e21e 1625 goto tokensaveref;
463ee0b2 1626 }
ed6116ce
LW
1627 *lp = strlen(s);
1628 return s;
79072805 1629 }
ed6116ce 1630 if (SvREADONLY(sv)) {
748a9306 1631 if (SvNOKp(sv)) {
36477c24 1632 SET_NUMERIC_STANDARD();
a0d0e21e
LW
1633 Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
1634 goto tokensave;
ed6116ce 1635 }
8bb9dbe4
LW
1636 if (SvIOKp(sv)) {
1637 (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
1638 goto tokensave;
1639 }
ed6116ce 1640 if (dowarn)
8990e307 1641 warn(warn_uninit);
ed6116ce
LW
1642 *lp = 0;
1643 return "";
79072805 1644 }
79072805
LW
1645 }
1646 if (!SvUPGRADE(sv, SVt_PV))
1647 return 0;
748a9306 1648 if (SvNOKp(sv)) {
79072805
LW
1649 if (SvTYPE(sv) < SVt_PVNV)
1650 sv_upgrade(sv, SVt_PVNV);
1651 SvGROW(sv, 28);
463ee0b2 1652 s = SvPVX(sv);
79072805 1653 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 1654#ifdef apollo
463ee0b2 1655 if (SvNVX(sv) == 0.0)
79072805
LW
1656 (void)strcpy(s,"0");
1657 else
1658#endif /*apollo*/
bbce6d69 1659 {
36477c24 1660 SET_NUMERIC_STANDARD();
a0d0e21e 1661 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
bbce6d69 1662 }
79072805 1663 errno = olderrno;
a0d0e21e
LW
1664#ifdef FIXNEGATIVEZERO
1665 if (*s == '-' && s[1] == '0' && !s[2])
1666 strcpy(s,"0");
1667#endif
79072805
LW
1668 while (*s) s++;
1669#ifdef hcx
1670 if (s[-1] == '.')
1671 s--;
1672#endif
1673 }
748a9306 1674 else if (SvIOKp(sv)) {
79072805
LW
1675 if (SvTYPE(sv) < SVt_PVIV)
1676 sv_upgrade(sv, SVt_PVIV);
1677 SvGROW(sv, 11);
463ee0b2 1678 s = SvPVX(sv);
79072805 1679 olderrno = errno; /* some Xenix systems wipe out errno here */
a0d0e21e 1680 (void)sprintf(s,"%ld",(long)SvIVX(sv));
79072805
LW
1681 errno = olderrno;
1682 while (*s) s++;
1683 }
1684 else {
91bba347 1685 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
8990e307 1686 warn(warn_uninit);
a0d0e21e
LW
1687 *lp = 0;
1688 return "";
79072805
LW
1689 }
1690 *s = '\0';
463ee0b2
LW
1691 *lp = s - SvPVX(sv);
1692 SvCUR_set(sv, *lp);
79072805 1693 SvPOK_on(sv);
760ac839 1694 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
463ee0b2 1695 return SvPVX(sv);
a0d0e21e
LW
1696
1697 tokensave:
1698 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1699 /* Sneaky stuff here */
1700
1701 tokensaveref:
1702 sv = sv_newmortal();
1703 *lp = strlen(tokenbuf);
1704 sv_setpvn(sv, tokenbuf, *lp);
1705 return SvPVX(sv);
1706 }
1707 else {
1708 STRLEN len;
1709
1710#ifdef FIXNEGATIVEZERO
1711 if (*tokenbuf == '-' && tokenbuf[1] == '0' && !tokenbuf[2])
1712 strcpy(tokenbuf,"0");
1713#endif
1714 (void)SvUPGRADE(sv, SVt_PV);
1715 len = *lp = strlen(tokenbuf);
1716 s = SvGROW(sv, len + 1);
1717 SvCUR_set(sv, len);
1718 (void)strcpy(s, tokenbuf);
6bf554b4 1719 SvPOKp_on(sv);
a0d0e21e
LW
1720 return s;
1721 }
463ee0b2
LW
1722}
1723
1724/* This function is only called on magical items */
1725bool
1726sv_2bool(sv)
1727register SV *sv;
1728{
8990e307 1729 if (SvGMAGICAL(sv))
463ee0b2
LW
1730 mg_get(sv);
1731
a0d0e21e
LW
1732 if (!SvOK(sv))
1733 return 0;
1734 if (SvROK(sv)) {
1735#ifdef OVERLOAD
1736 {
1737 SV* tmpsv;
1738 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1739 return SvTRUE(tmpsv);
1740 }
1741#endif /* OVERLOAD */
1742 return SvRV(sv) != 0;
1743 }
463ee0b2
LW
1744 if (SvPOKp(sv)) {
1745 register XPV* Xpv;
1746 if ((Xpv = (XPV*)SvANY(sv)) &&
1747 (*Xpv->xpv_pv > '0' ||
1748 Xpv->xpv_cur > 1 ||
1749 (Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
1750 return 1;
1751 else
1752 return 0;
1753 }
1754 else {
1755 if (SvIOKp(sv))
1756 return SvIVX(sv) != 0;
1757 else {
1758 if (SvNOKp(sv))
1759 return SvNVX(sv) != 0.0;
1760 else
1761 return FALSE;
1762 }
1763 }
79072805
LW
1764}
1765
1766/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 1767 * to be reused, since it may destroy the source string if it is marked
79072805
LW
1768 * as temporary.
1769 */
1770
1771void
1772sv_setsv(dstr,sstr)
1773SV *dstr;
1774register SV *sstr;
1775{
8990e307
LW
1776 register U32 sflags;
1777 register int dtype;
1778 register int stype;
463ee0b2 1779
79072805
LW
1780 if (sstr == dstr)
1781 return;
ed6116ce 1782 if (SvTHINKFIRST(dstr)) {
8990e307 1783 if (SvREADONLY(dstr) && curcop != &compiling)
ed6116ce
LW
1784 croak(no_modify);
1785 if (SvROK(dstr))
1786 sv_unref(dstr);
1787 }
79072805
LW
1788 if (!sstr)
1789 sstr = &sv_undef;
8990e307
LW
1790 stype = SvTYPE(sstr);
1791 dtype = SvTYPE(dstr);
79072805 1792
8e07c86e
AD
1793 if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
1794 sv_unglob(dstr); /* so fake GLOB won't perpetuate */
4633a7c4
LW
1795 sv_setpvn(dstr, "", 0);
1796 (void)SvPOK_only(dstr);
8e07c86e
AD
1797 dtype = SvTYPE(dstr);
1798 }
1799
a0d0e21e
LW
1800#ifdef OVERLOAD
1801 SvAMAGIC_off(dstr);
1802#endif /* OVERLOAD */
463ee0b2 1803 /* There's a lot of redundancy below but we're going for speed here */
79072805 1804
8990e307 1805 switch (stype) {
79072805 1806 case SVt_NULL:
a0d0e21e 1807 (void)SvOK_off(dstr);
79072805 1808 return;
463ee0b2 1809 case SVt_IV:
ff68c719 1810 if (dtype != SVt_IV && dtype < SVt_PVIV) {
8990e307
LW
1811 if (dtype < SVt_IV)
1812 sv_upgrade(dstr, SVt_IV);
8990e307
LW
1813 else if (dtype == SVt_NV)
1814 sv_upgrade(dstr, SVt_PVNV);
ff68c719 1815 else
a0d0e21e 1816 sv_upgrade(dstr, SVt_PVIV);
8990e307 1817 }
463ee0b2
LW
1818 break;
1819 case SVt_NV:
ff68c719 1820 if (dtype != SVt_NV && dtype < SVt_PVNV) {
8990e307
LW
1821 if (dtype < SVt_NV)
1822 sv_upgrade(dstr, SVt_NV);
ff68c719 1823 else
a0d0e21e 1824 sv_upgrade(dstr, SVt_PVNV);
8990e307 1825 }
463ee0b2 1826 break;
ed6116ce 1827 case SVt_RV:
8990e307 1828 if (dtype < SVt_RV)
ed6116ce 1829 sv_upgrade(dstr, SVt_RV);
c07a80fd
PP
1830 else if (dtype == SVt_PVGV &&
1831 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
1832 sstr = SvRV(sstr);
a5f75d66
AD
1833 if (sstr == dstr) {
1834 if (curcop->cop_stash != GvSTASH(dstr))
1835 GvIMPORTED_on(dstr);
1836 GvMULTI_on(dstr);
1837 return;
1838 }
c07a80fd
PP
1839 goto glob_assign;
1840 }
ed6116ce 1841 break;
463ee0b2 1842 case SVt_PV:
8990e307 1843 if (dtype < SVt_PV)
463ee0b2 1844 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
1845 break;
1846 case SVt_PVIV:
8990e307 1847 if (dtype < SVt_PVIV)
463ee0b2 1848 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW
1849 break;
1850 case SVt_PVNV:
8990e307 1851 if (dtype < SVt_PVNV)
463ee0b2 1852 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 1853 break;
4633a7c4
LW
1854
1855 case SVt_PVLV:
4561caa4 1856 sv_upgrade(dstr, SVt_PVLV);
4633a7c4
LW
1857 break;
1858
1859 case SVt_PVAV:
1860 case SVt_PVHV:
1861 case SVt_PVCV:
4633a7c4
LW
1862 case SVt_PVIO:
1863 if (op)
1864 croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
1865 op_name[op->op_type]);
1866 else
1867 croak("Bizarre copy of %s", sv_reftype(sstr, 0));
1868 break;
1869
79072805 1870 case SVt_PVGV:
8990e307 1871 if (dtype <= SVt_PVGV) {
c07a80fd 1872 glob_assign:
a5f75d66 1873 if (dtype != SVt_PVGV) {
a0d0e21e
LW
1874 char *name = GvNAME(sstr);
1875 STRLEN len = GvNAMELEN(sstr);
463ee0b2 1876 sv_upgrade(dstr, SVt_PVGV);
a0d0e21e
LW
1877 sv_magic(dstr, dstr, '*', name, len);
1878 GvSTASH(dstr) = GvSTASH(sstr);
1879 GvNAME(dstr) = savepvn(name, len);
1880 GvNAMELEN(dstr) = len;
1881 SvFAKE_on(dstr); /* can coerce to non-glob */
1882 }
1883 (void)SvOK_off(dstr);
a5f75d66 1884 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 1885 gp_free((GV*)dstr);
79072805 1886 GvGP(dstr) = gp_ref(GvGP(sstr));
8990e307 1887 SvTAINT(dstr);
a5f75d66
AD
1888 if (curcop->cop_stash != GvSTASH(dstr))
1889 GvIMPORTED_on(dstr);
1890 GvMULTI_on(dstr);
79072805
LW
1891 return;
1892 }
1893 /* FALL THROUGH */
1894
1895 default:
8990e307
LW
1896 if (dtype < stype)
1897 sv_upgrade(dstr, stype);
1898 if (SvGMAGICAL(sstr))
79072805 1899 mg_get(sstr);
79072805
LW
1900 }
1901
8990e307
LW
1902 sflags = SvFLAGS(sstr);
1903
1904 if (sflags & SVf_ROK) {
1905 if (dtype >= SVt_PV) {
1906 if (dtype == SVt_PVGV) {
1907 SV *sref = SvREFCNT_inc(SvRV(sstr));
1908 SV *dref = 0;
a5f75d66 1909 int intro = GvINTRO(dstr);
a0d0e21e
LW
1910
1911 if (intro) {
1912 GP *gp;
1913 GvGP(dstr)->gp_refcnt--;
a5f75d66 1914 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 1915 Newz(602,gp, 1, GP);
44a8e56a 1916 GvGP(dstr) = gp_ref(gp);
a0d0e21e
LW
1917 GvSV(dstr) = NEWSV(72,0);
1918 GvLINE(dstr) = curcop->cop_line;
1edc1566 1919 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 1920 }
a5f75d66 1921 GvMULTI_on(dstr);
8990e307
LW
1922 switch (SvTYPE(sref)) {
1923 case SVt_PVAV:
a0d0e21e
LW
1924 if (intro)
1925 SAVESPTR(GvAV(dstr));
1926 else
1927 dref = (SV*)GvAV(dstr);
8990e307 1928 GvAV(dstr) = (AV*)sref;
a5f75d66
AD
1929 if (curcop->cop_stash != GvSTASH(dstr))
1930 GvIMPORTED_AV_on(dstr);
8990e307
LW
1931 break;
1932 case SVt_PVHV:
a0d0e21e
LW
1933 if (intro)
1934 SAVESPTR(GvHV(dstr));
1935 else
1936 dref = (SV*)GvHV(dstr);
8990e307 1937 GvHV(dstr) = (HV*)sref;
a5f75d66
AD
1938 if (curcop->cop_stash != GvSTASH(dstr))
1939 GvIMPORTED_HV_on(dstr);
8990e307
LW
1940 break;
1941 case SVt_PVCV:
8ebc5c01
PP
1942 if (intro) {
1943 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
1944 SvREFCNT_dec(GvCV(dstr));
1945 GvCV(dstr) = Nullcv;
1946 GvCVGEN(dstr) = 0;
1947 }
a0d0e21e 1948 SAVESPTR(GvCV(dstr));
8ebc5c01 1949 }
748a9306
LW
1950 else {
1951 CV* cv = GvCV(dstr);
4633a7c4
LW
1952 if (cv) {
1953 dref = (SV*)cv;
1954 if (dowarn && sref != dref &&
1955 !GvCVGEN((GV*)dstr) &&
1956 (CvROOT(cv) || CvXSUB(cv)) )
1957 warn("Subroutine %s redefined",
1958 GvENAME((GV*)dstr));
4633a7c4 1959 }
748a9306 1960 }
a5f75d66
AD
1961 if (GvCV(dstr) != (CV*)sref) {
1962 GvCV(dstr) = (CV*)sref;
7a4c00b4 1963 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 1964 GvASSUMECV_on(dstr);
8ebc5c01 1965 sub_generation++;
a5f75d66
AD
1966 }
1967 if (curcop->cop_stash != GvSTASH(dstr))
1968 GvIMPORTED_CV_on(dstr);
8990e307 1969 break;
91bba347
LW
1970 case SVt_PVIO:
1971 if (intro)
1972 SAVESPTR(GvIOp(dstr));
1973 else
1974 dref = (SV*)GvIOp(dstr);
1975 GvIOp(dstr) = (IO*)sref;
1976 break;
8990e307 1977 default:
a0d0e21e
LW
1978 if (intro)
1979 SAVESPTR(GvSV(dstr));
1980 else
1981 dref = (SV*)GvSV(dstr);
8990e307 1982 GvSV(dstr) = sref;
a5f75d66
AD
1983 if (curcop->cop_stash != GvSTASH(dstr))
1984 GvIMPORTED_SV_on(dstr);
8990e307
LW
1985 break;
1986 }
1987 if (dref)
1988 SvREFCNT_dec(dref);
a0d0e21e
LW
1989 if (intro)
1990 SAVEFREESV(sref);
8990e307
LW
1991 SvTAINT(dstr);
1992 return;
1993 }
a0d0e21e 1994 if (SvPVX(dstr)) {
760ac839 1995 (void)SvOOK_off(dstr); /* backoff */
8990e307 1996 Safefree(SvPVX(dstr));
a0d0e21e
LW
1997 SvLEN(dstr)=SvCUR(dstr)=0;
1998 }
8990e307 1999 }
a0d0e21e 2000 (void)SvOK_off(dstr);
8990e307 2001 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 2002 SvROK_on(dstr);
8990e307 2003 if (sflags & SVp_NOK) {
ed6116ce
LW
2004 SvNOK_on(dstr);
2005 SvNVX(dstr) = SvNVX(sstr);
2006 }
8990e307 2007 if (sflags & SVp_IOK) {
a0d0e21e 2008 (void)SvIOK_on(dstr);
ed6116ce
LW
2009 SvIVX(dstr) = SvIVX(sstr);
2010 }
a0d0e21e
LW
2011#ifdef OVERLOAD
2012 if (SvAMAGIC(sstr)) {
2013 SvAMAGIC_on(dstr);
2014 }
2015#endif /* OVERLOAD */
ed6116ce 2016 }
8990e307 2017 else if (sflags & SVp_POK) {
79072805
LW
2018
2019 /*
2020 * Check to see if we can just swipe the string. If so, it's a
2021 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW
2022 * It might even be a win on short strings if SvPVX(dstr)
2023 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW
2024 */
2025
ff68c719 2026 if (SvTEMP(sstr) && /* slated for free anyway? */
a5f75d66
AD
2027 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2028 {
adbc6bb1 2029 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD
2030 if (SvOOK(dstr)) {
2031 SvFLAGS(dstr) &= ~SVf_OOK;
2032 Safefree(SvPVX(dstr) - SvIVX(dstr));
2033 }
2034 else
2035 Safefree(SvPVX(dstr));
79072805 2036 }
a5f75d66 2037 (void)SvPOK_only(dstr);
463ee0b2 2038 SvPV_set(dstr, SvPVX(sstr));
79072805
LW
2039 SvLEN_set(dstr, SvLEN(sstr));
2040 SvCUR_set(dstr, SvCUR(sstr));
79072805 2041 SvTEMP_off(dstr);
a5f75d66 2042 (void)SvOK_off(sstr);
79072805
LW
2043 SvPV_set(sstr, Nullch);
2044 SvLEN_set(sstr, 0);
a5f75d66
AD
2045 SvCUR_set(sstr, 0);
2046 SvTEMP_off(sstr);
79072805
LW
2047 }
2048 else { /* have to copy actual string */
8990e307
LW
2049 STRLEN len = SvCUR(sstr);
2050
2051 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2052 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2053 SvCUR_set(dstr, len);
2054 *SvEND(dstr) = '\0';
a0d0e21e 2055 (void)SvPOK_only(dstr);
79072805
LW
2056 }
2057 /*SUPPRESS 560*/
8990e307 2058 if (sflags & SVp_NOK) {
79072805 2059 SvNOK_on(dstr);
463ee0b2 2060 SvNVX(dstr) = SvNVX(sstr);
79072805 2061 }
8990e307 2062 if (sflags & SVp_IOK) {
a0d0e21e 2063 (void)SvIOK_on(dstr);
463ee0b2 2064 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2065 }
2066 }
8990e307 2067 else if (sflags & SVp_NOK) {
463ee0b2 2068 SvNVX(dstr) = SvNVX(sstr);
a0d0e21e 2069 (void)SvNOK_only(dstr);
79072805 2070 if (SvIOK(sstr)) {
a0d0e21e 2071 (void)SvIOK_on(dstr);
463ee0b2 2072 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2073 }
2074 }
8990e307 2075 else if (sflags & SVp_IOK) {
a0d0e21e 2076 (void)SvIOK_only(dstr);
463ee0b2 2077 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2078 }
2079 else {
a0d0e21e
LW
2080 (void)SvOK_off(dstr);
2081 }
463ee0b2 2082 SvTAINT(dstr);
79072805
LW
2083}
2084
2085void
2086sv_setpvn(sv,ptr,len)
2087register SV *sv;
71be2cbc 2088register const char *ptr;
79072805
LW
2089register STRLEN len;
2090{
4561caa4
CS
2091 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2092 elicit a warning, but it won't hurt. */
ed6116ce 2093 if (SvTHINKFIRST(sv)) {
8990e307 2094 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2095 croak(no_modify);
2096 if (SvROK(sv))
2097 sv_unref(sv);
2098 }
463ee0b2 2099 if (!ptr) {
a0d0e21e 2100 (void)SvOK_off(sv);
463ee0b2
LW
2101 return;
2102 }
c07a80fd
PP
2103 if (SvTYPE(sv) >= SVt_PV) {
2104 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2105 sv_unglob(sv);
2106 }
2107 else if (!sv_upgrade(sv, SVt_PV))
79072805
LW
2108 return;
2109 SvGROW(sv, len + 1);
a0d0e21e 2110 Move(ptr,SvPVX(sv),len,char);
79072805
LW
2111 SvCUR_set(sv, len);
2112 *SvEND(sv) = '\0';
a0d0e21e 2113 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2114 SvTAINT(sv);
79072805
LW
2115}
2116
2117void
2118sv_setpv(sv,ptr)
2119register SV *sv;
71be2cbc 2120register const char *ptr;
79072805
LW
2121{
2122 register STRLEN len;
2123
ed6116ce 2124 if (SvTHINKFIRST(sv)) {
8990e307 2125 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2126 croak(no_modify);
2127 if (SvROK(sv))
2128 sv_unref(sv);
2129 }
463ee0b2 2130 if (!ptr) {
a0d0e21e 2131 (void)SvOK_off(sv);
463ee0b2
LW
2132 return;
2133 }
79072805 2134 len = strlen(ptr);
c07a80fd
PP
2135 if (SvTYPE(sv) >= SVt_PV) {
2136 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2137 sv_unglob(sv);
2138 }
2139 else if (!sv_upgrade(sv, SVt_PV))
79072805
LW
2140 return;
2141 SvGROW(sv, len + 1);
463ee0b2 2142 Move(ptr,SvPVX(sv),len+1,char);
79072805 2143 SvCUR_set(sv, len);
a0d0e21e 2144 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2
LW
2145 SvTAINT(sv);
2146}
2147
2148void
2149sv_usepvn(sv,ptr,len)
2150register SV *sv;
2151register char *ptr;
2152register STRLEN len;
2153{
ed6116ce 2154 if (SvTHINKFIRST(sv)) {
8990e307 2155 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2156 croak(no_modify);
2157 if (SvROK(sv))
2158 sv_unref(sv);
2159 }
463ee0b2
LW
2160 if (!SvUPGRADE(sv, SVt_PV))
2161 return;
2162 if (!ptr) {
a0d0e21e 2163 (void)SvOK_off(sv);
463ee0b2
LW
2164 return;
2165 }
2166 if (SvPVX(sv))
2167 Safefree(SvPVX(sv));
2168 Renew(ptr, len+1, char);
2169 SvPVX(sv) = ptr;
2170 SvCUR_set(sv, len);
2171 SvLEN_set(sv, len+1);
2172 *SvEND(sv) = '\0';
a0d0e21e 2173 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2174 SvTAINT(sv);
79072805
LW
2175}
2176
2177void
2178sv_chop(sv,ptr) /* like set but assuming ptr is in sv */
2179register SV *sv;
2180register char *ptr;
2181{
2182 register STRLEN delta;
2183
a0d0e21e 2184 if (!ptr || !SvPOKp(sv))
79072805 2185 return;
ed6116ce 2186 if (SvTHINKFIRST(sv)) {
8990e307 2187 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2188 croak(no_modify);
2189 if (SvROK(sv))
2190 sv_unref(sv);
2191 }
79072805
LW
2192 if (SvTYPE(sv) < SVt_PVIV)
2193 sv_upgrade(sv,SVt_PVIV);
2194
2195 if (!SvOOK(sv)) {
463ee0b2 2196 SvIVX(sv) = 0;
79072805
LW
2197 SvFLAGS(sv) |= SVf_OOK;
2198 }
8990e307 2199 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
463ee0b2 2200 delta = ptr - SvPVX(sv);
79072805
LW
2201 SvLEN(sv) -= delta;
2202 SvCUR(sv) -= delta;
463ee0b2
LW
2203 SvPVX(sv) += delta;
2204 SvIVX(sv) += delta;
79072805
LW
2205}
2206
2207void
2208sv_catpvn(sv,ptr,len)
2209register SV *sv;
2210register char *ptr;
2211register STRLEN len;
2212{
463ee0b2 2213 STRLEN tlen;
748a9306 2214 char *junk;
a0d0e21e 2215
748a9306 2216 junk = SvPV_force(sv, tlen);
463ee0b2 2217 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
2218 if (ptr == junk)
2219 ptr = SvPVX(sv);
463ee0b2 2220 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW
2221 SvCUR(sv) += len;
2222 *SvEND(sv) = '\0';
a0d0e21e 2223 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2224 SvTAINT(sv);
79072805
LW
2225}
2226
2227void
2228sv_catsv(dstr,sstr)
2229SV *dstr;
2230register SV *sstr;
2231{
2232 char *s;
463ee0b2 2233 STRLEN len;
79072805
LW
2234 if (!sstr)
2235 return;
463ee0b2
LW
2236 if (s = SvPV(sstr, len))
2237 sv_catpvn(dstr,s,len);
79072805
LW
2238}
2239
2240void
2241sv_catpv(sv,ptr)
2242register SV *sv;
2243register char *ptr;
2244{
2245 register STRLEN len;
463ee0b2 2246 STRLEN tlen;
748a9306 2247 char *junk;
79072805 2248
79072805
LW
2249 if (!ptr)
2250 return;
748a9306 2251 junk = SvPV_force(sv, tlen);
79072805 2252 len = strlen(ptr);
463ee0b2 2253 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
2254 if (ptr == junk)
2255 ptr = SvPVX(sv);
463ee0b2 2256 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 2257 SvCUR(sv) += len;
a0d0e21e 2258 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2259 SvTAINT(sv);
79072805
LW
2260}
2261
79072805
LW
2262SV *
2263#ifdef LEAKTEST
2264newSV(x,len)
2265I32 x;
2266#else
2267newSV(len)
2268#endif
2269STRLEN len;
2270{
2271 register SV *sv;
2272
4561caa4 2273 new_SV(sv);
8990e307
LW
2274 SvANY(sv) = 0;
2275 SvREFCNT(sv) = 1;
2276 SvFLAGS(sv) = 0;
79072805
LW
2277 if (len) {
2278 sv_upgrade(sv, SVt_PV);
2279 SvGROW(sv, len + 1);
2280 }
2281 return sv;
2282}
2283
1edc1566
PP
2284/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2285
79072805
LW
2286void
2287sv_magic(sv, obj, how, name, namlen)
2288register SV *sv;
2289SV *obj;
a0d0e21e 2290int how;
79072805 2291char *name;
463ee0b2 2292I32 namlen;
79072805
LW
2293{
2294 MAGIC* mg;
2295
55497cff 2296 if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
a0d0e21e 2297 croak(no_modify);
4633a7c4 2298 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW
2299 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2300 if (how == 't')
2301 mg->mg_len |= 1;
463ee0b2 2302 return;
748a9306 2303 }
463ee0b2
LW
2304 }
2305 else {
2306 if (!SvUPGRADE(sv, SVt_PVMG))
2307 return;
463ee0b2 2308 }
79072805
LW
2309 Newz(702,mg, 1, MAGIC);
2310 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 2311
79072805 2312 SvMAGIC(sv) = mg;
748a9306 2313 if (!obj || obj == sv || how == '#')
8990e307 2314 mg->mg_obj = obj;
85e6fe83 2315 else {
8990e307 2316 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW
2317 mg->mg_flags |= MGf_REFCOUNTED;
2318 }
79072805 2319 mg->mg_type = how;
463ee0b2 2320 mg->mg_len = namlen;
1edc1566
PP
2321 if (name)
2322 if (namlen >= 0)
2323 mg->mg_ptr = savepvn(name, namlen);
2324 else if (namlen == HEf_SVKEY)
2325 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2326
79072805
LW
2327 switch (how) {
2328 case 0:
2329 mg->mg_virtual = &vtbl_sv;
2330 break;
a0d0e21e
LW
2331#ifdef OVERLOAD
2332 case 'A':
2333 mg->mg_virtual = &vtbl_amagic;
2334 break;
2335 case 'a':
2336 mg->mg_virtual = &vtbl_amagicelem;
2337 break;
2338 case 'c':
2339 mg->mg_virtual = 0;
2340 break;
2341#endif /* OVERLOAD */
79072805
LW
2342 case 'B':
2343 mg->mg_virtual = &vtbl_bm;
2344 break;
79072805
LW
2345 case 'E':
2346 mg->mg_virtual = &vtbl_env;
2347 break;
55497cff
PP
2348 case 'f':
2349 mg->mg_virtual = &vtbl_fm;
2350 break;
79072805
LW
2351 case 'e':
2352 mg->mg_virtual = &vtbl_envelem;
2353 break;
93a17b20
LW
2354 case 'g':
2355 mg->mg_virtual = &vtbl_mglob;
2356 break;
463ee0b2
LW
2357 case 'I':
2358 mg->mg_virtual = &vtbl_isa;
2359 break;
2360 case 'i':
2361 mg->mg_virtual = &vtbl_isaelem;
2362 break;
16660edb
PP
2363 case 'k':
2364 mg->mg_virtual = &vtbl_nkeys;
2365 break;
79072805 2366 case 'L':
a0d0e21e 2367 SvRMAGICAL_on(sv);
93a17b20
LW
2368 mg->mg_virtual = 0;
2369 break;
2370 case 'l':
79072805
LW
2371 mg->mg_virtual = &vtbl_dbline;
2372 break;
36477c24 2373#ifdef USE_LOCALE_COLLATE
bbce6d69
PP
2374 case 'o':
2375 mg->mg_virtual = &vtbl_collxfrm;
2376 break;
36477c24 2377#endif /* USE_LOCALE_COLLATE */
463ee0b2
LW
2378 case 'P':
2379 mg->mg_virtual = &vtbl_pack;
2380 break;
2381 case 'p':
a0d0e21e 2382 case 'q':
463ee0b2
LW
2383 mg->mg_virtual = &vtbl_packelem;
2384 break;
79072805
LW
2385 case 'S':
2386 mg->mg_virtual = &vtbl_sig;
2387 break;
2388 case 's':
2389 mg->mg_virtual = &vtbl_sigelem;
2390 break;
463ee0b2
LW
2391 case 't':
2392 mg->mg_virtual = &vtbl_taint;
748a9306 2393 mg->mg_len = 1;
463ee0b2 2394 break;
79072805
LW
2395 case 'U':
2396 mg->mg_virtual = &vtbl_uvar;
2397 break;
2398 case 'v':
2399 mg->mg_virtual = &vtbl_vec;
2400 break;
2401 case 'x':
2402 mg->mg_virtual = &vtbl_substr;
2403 break;
5f05dabc 2404 case 'y':
71be2cbc 2405 mg->mg_virtual = &vtbl_itervar;
5f05dabc 2406 break;
79072805
LW
2407 case '*':
2408 mg->mg_virtual = &vtbl_glob;
2409 break;
2410 case '#':
2411 mg->mg_virtual = &vtbl_arylen;
2412 break;
a0d0e21e
LW
2413 case '.':
2414 mg->mg_virtual = &vtbl_pos;
2415 break;
4633a7c4
LW
2416 case '~': /* Reserved for use by extensions not perl internals. */
2417 /* Useful for attaching extension internal data to perl vars. */
2418 /* Note that multiple extensions may clash if magical scalars */
2419 /* etc holding private data from one are passed to another. */
2420 SvRMAGICAL_on(sv);
a0d0e21e 2421 break;
79072805 2422 default:
463ee0b2
LW
2423 croak("Don't know how to handle magic of type '%c'", how);
2424 }
8990e307
LW
2425 mg_magical(sv);
2426 if (SvGMAGICAL(sv))
2427 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW
2428}
2429
2430int
2431sv_unmagic(sv, type)
2432SV* sv;
a0d0e21e 2433int type;
463ee0b2
LW
2434{
2435 MAGIC* mg;
2436 MAGIC** mgp;
91bba347 2437 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW
2438 return 0;
2439 mgp = &SvMAGIC(sv);
2440 for (mg = *mgp; mg; mg = *mgp) {
2441 if (mg->mg_type == type) {
2442 MGVTBL* vtbl = mg->mg_virtual;
2443 *mgp = mg->mg_moremagic;
2444 if (vtbl && vtbl->svt_free)
2445 (*vtbl->svt_free)(sv, mg);
2446 if (mg->mg_ptr && mg->mg_type != 'g')
1edc1566
PP
2447 if (mg->mg_len >= 0)
2448 Safefree(mg->mg_ptr);
2449 else if (mg->mg_len == HEf_SVKEY)
2450 SvREFCNT_dec((SV*)mg->mg_ptr);
a0d0e21e
LW
2451 if (mg->mg_flags & MGf_REFCOUNTED)
2452 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW
2453 Safefree(mg);
2454 }
2455 else
2456 mgp = &mg->mg_moremagic;
79072805 2457 }
91bba347 2458 if (!SvMAGIC(sv)) {
463ee0b2 2459 SvMAGICAL_off(sv);
8990e307 2460 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW
2461 }
2462
2463 return 0;
79072805
LW
2464}
2465
2466void
2467sv_insert(bigstr,offset,len,little,littlelen)
2468SV *bigstr;
2469STRLEN offset;
2470STRLEN len;
2471char *little;
2472STRLEN littlelen;
2473{
2474 register char *big;
2475 register char *mid;
2476 register char *midend;
2477 register char *bigend;
2478 register I32 i;
2479
8990e307
LW
2480 if (!bigstr)
2481 croak("Can't modify non-existent substring");
a0d0e21e 2482 SvPV_force(bigstr, na);
79072805
LW
2483
2484 i = littlelen - len;
2485 if (i > 0) { /* string might grow */
a0d0e21e 2486 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW
2487 mid = big + offset + len;
2488 midend = bigend = big + SvCUR(bigstr);
2489 bigend += i;
2490 *bigend = '\0';
2491 while (midend > mid) /* shove everything down */
2492 *--bigend = *--midend;
2493 Move(little,big+offset,littlelen,char);
2494 SvCUR(bigstr) += i;
2495 SvSETMAGIC(bigstr);
2496 return;
2497 }
2498 else if (i == 0) {
463ee0b2 2499 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW
2500 SvSETMAGIC(bigstr);
2501 return;
2502 }
2503
463ee0b2 2504 big = SvPVX(bigstr);
79072805
LW
2505 mid = big + offset;
2506 midend = mid + len;
2507 bigend = big + SvCUR(bigstr);
2508
2509 if (midend > bigend)
463ee0b2 2510 croak("panic: sv_insert");
79072805
LW
2511
2512 if (mid - big > bigend - midend) { /* faster to shorten from end */
2513 if (littlelen) {
2514 Move(little, mid, littlelen,char);
2515 mid += littlelen;
2516 }
2517 i = bigend - midend;
2518 if (i > 0) {
2519 Move(midend, mid, i,char);
2520 mid += i;
2521 }
2522 *mid = '\0';
2523 SvCUR_set(bigstr, mid - big);
2524 }
2525 /*SUPPRESS 560*/
2526 else if (i = mid - big) { /* faster from front */
2527 midend -= littlelen;
2528 mid = midend;
2529 sv_chop(bigstr,midend-i);
2530 big += i;
2531 while (i--)
2532 *--midend = *--big;
2533 if (littlelen)
2534 Move(little, mid, littlelen,char);
2535 }
2536 else if (littlelen) {
2537 midend -= littlelen;
2538 sv_chop(bigstr,midend);
2539 Move(little,midend,littlelen,char);
2540 }
2541 else {
2542 sv_chop(bigstr,midend);
2543 }
2544 SvSETMAGIC(bigstr);
2545}
2546
2547/* make sv point to what nstr did */
2548
2549void
2550sv_replace(sv,nsv)
2551register SV *sv;
2552register SV *nsv;
2553{
2554 U32 refcnt = SvREFCNT(sv);
ed6116ce 2555 if (SvTHINKFIRST(sv)) {
8990e307 2556 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2557 croak(no_modify);
2558 if (SvROK(sv))
2559 sv_unref(sv);
2560 }
79072805
LW
2561 if (SvREFCNT(nsv) != 1)
2562 warn("Reference miscount in sv_replace()");
93a17b20 2563 if (SvMAGICAL(sv)) {
a0d0e21e
LW
2564 if (SvMAGICAL(nsv))
2565 mg_free(nsv);
2566 else
2567 sv_upgrade(nsv, SVt_PVMG);
93a17b20 2568 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 2569 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW
2570 SvMAGICAL_off(sv);
2571 SvMAGIC(sv) = 0;
2572 }
79072805
LW
2573 SvREFCNT(sv) = 0;
2574 sv_clear(sv);
477f5d66 2575 assert(!SvREFCNT(sv));
79072805
LW
2576 StructCopy(nsv,sv,SV);
2577 SvREFCNT(sv) = refcnt;
1edc1566 2578 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 2579 del_SV(nsv);
79072805
LW
2580}
2581
2582void
2583sv_clear(sv)
2584register SV *sv;
2585{
2586 assert(sv);
2587 assert(SvREFCNT(sv) == 0);
2588
ed6116ce 2589 if (SvOBJECT(sv)) {
a0d0e21e 2590 if (defstash) { /* Still have a symbol table? */
8ebc5c01
PP
2591 dSP;
2592 GV* destructor;
a0d0e21e
LW
2593
2594 ENTER;
2595 SAVEFREESV(SvSTASH(sv));
8ebc5c01
PP
2596
2597 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2598 if (destructor) {
a0d0e21e
LW
2599 SV ref;
2600
2601 Zero(&ref, 1, SV);
2602 sv_upgrade(&ref, SVt_RV);
a0d0e21e
LW
2603 SvRV(&ref) = SvREFCNT_inc(sv);
2604 SvROK_on(&ref);
2605
2606 EXTEND(SP, 2);
2607 PUSHMARK(SP);
2608 PUSHs(&ref);
2609 PUTBACK;
8ebc5c01
PP
2610 perl_call_sv((SV*)GvCV(destructor),
2611 G_DISCARD|G_EVAL|G_KEEPERR);
748a9306 2612 del_XRV(SvANY(&ref));
1edc1566 2613 SvREFCNT(sv)--;
a0d0e21e 2614 }
8ebc5c01 2615
a0d0e21e
LW
2616 LEAVE;
2617 }
4633a7c4
LW
2618 else
2619 SvREFCNT_dec(SvSTASH(sv));
a0d0e21e
LW
2620 if (SvOBJECT(sv)) {
2621 SvOBJECT_off(sv); /* Curse the object. */
2622 if (SvTYPE(sv) != SVt_PVIO)
2623 --sv_objcount; /* XXX Might want something more general */
2624 }
1edc1566 2625 if (SvREFCNT(sv)) {
477f5d66 2626 SV *ret;
1edc1566
PP
2627 if ( perldb
2628 && (ret = perl_get_sv("DB::ret", FALSE))
2629 && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) {
2630 /* Debugger is prone to dangling references. */
2631 SvRV(ret) = 0;
2632 SvROK_off(ret);
2633 SvREFCNT(sv) = 0;
477f5d66
CS
2634 }
2635 else {
2636 if (in_clean_objs)
2637 croak("DESTROY created new reference to dead object");
2638 /* DESTROY gave object new lease on life */
2639 return;
1edc1566
PP
2640 }
2641 }
463ee0b2 2642 }
c07a80fd 2643 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 2644 mg_free(sv);
79072805 2645 switch (SvTYPE(sv)) {
8990e307 2646 case SVt_PVIO:
5f05dabc
PP
2647 if (IoIFP(sv) != PerlIO_stdin() &&
2648 IoIFP(sv) != PerlIO_stdout() &&
2649 IoIFP(sv) != PerlIO_stderr())
2650 io_close((IO*)sv);
8990e307
LW
2651 Safefree(IoTOP_NAME(sv));
2652 Safefree(IoFMT_NAME(sv));
2653 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 2654 /* FALL THROUGH */
79072805 2655 case SVt_PVBM:
a0d0e21e 2656 goto freescalar;
79072805 2657 case SVt_PVCV:
748a9306 2658 case SVt_PVFM:
85e6fe83 2659 cv_undef((CV*)sv);
a0d0e21e 2660 goto freescalar;
79072805 2661 case SVt_PVHV:
85e6fe83 2662 hv_undef((HV*)sv);
a0d0e21e 2663 break;
79072805 2664 case SVt_PVAV:
85e6fe83 2665 av_undef((AV*)sv);
a0d0e21e
LW
2666 break;
2667 case SVt_PVGV:
1edc1566 2668 gp_free((GV*)sv);
a0d0e21e
LW
2669 Safefree(GvNAME(sv));
2670 /* FALL THROUGH */
79072805 2671 case SVt_PVLV:
79072805 2672 case SVt_PVMG:
79072805
LW
2673 case SVt_PVNV:
2674 case SVt_PVIV:
a0d0e21e
LW
2675 freescalar:
2676 (void)SvOOK_off(sv);
79072805
LW
2677 /* FALL THROUGH */
2678 case SVt_PV:
a0d0e21e 2679 case SVt_RV:
8990e307
LW
2680 if (SvROK(sv))
2681 SvREFCNT_dec(SvRV(sv));
1edc1566 2682 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 2683 Safefree(SvPVX(sv));
79072805 2684 break;
a0d0e21e 2685/*
79072805 2686 case SVt_NV:
79072805 2687 case SVt_IV:
79072805
LW
2688 case SVt_NULL:
2689 break;
a0d0e21e 2690*/
79072805
LW
2691 }
2692
2693 switch (SvTYPE(sv)) {
2694 case SVt_NULL:
2695 break;
79072805
LW
2696 case SVt_IV:
2697 del_XIV(SvANY(sv));
2698 break;
2699 case SVt_NV:
2700 del_XNV(SvANY(sv));
2701 break;
ed6116ce
LW
2702 case SVt_RV:
2703 del_XRV(SvANY(sv));
2704 break;
79072805
LW
2705 case SVt_PV:
2706 del_XPV(SvANY(sv));
2707 break;
2708 case SVt_PVIV:
2709 del_XPVIV(SvANY(sv));
2710 break;
2711 case SVt_PVNV:
2712 del_XPVNV(SvANY(sv));
2713 break;
2714 case SVt_PVMG:
2715 del_XPVMG(SvANY(sv));
2716 break;
2717 case SVt_PVLV:
2718 del_XPVLV(SvANY(sv));
2719 break;
2720 case SVt_PVAV:
2721 del_XPVAV(SvANY(sv));
2722 break;
2723 case SVt_PVHV:
2724 del_XPVHV(SvANY(sv));
2725 break;
2726 case SVt_PVCV:
2727 del_XPVCV(SvANY(sv));
2728 break;
2729 case SVt_PVGV:
2730 del_XPVGV(SvANY(sv));
2731 break;
2732 case SVt_PVBM:
2733 del_XPVBM(SvANY(sv));
2734 break;
2735 case SVt_PVFM:
2736 del_XPVFM(SvANY(sv));
2737 break;
8990e307
LW
2738 case SVt_PVIO:
2739 del_XPVIO(SvANY(sv));
2740 break;
79072805 2741 }
a0d0e21e 2742 SvFLAGS(sv) &= SVf_BREAK;
8990e307 2743 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW
2744}
2745
2746SV *
8990e307 2747sv_newref(sv)
79072805
LW
2748SV* sv;
2749{
463ee0b2
LW
2750 if (sv)
2751 SvREFCNT(sv)++;
79072805
LW
2752 return sv;
2753}
2754
2755void
2756sv_free(sv)
2757SV *sv;
2758{
2759 if (!sv)
2760 return;
a0d0e21e
LW
2761 if (SvREADONLY(sv)) {
2762 if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no)
2763 return;
79072805 2764 }
a0d0e21e
LW
2765 if (SvREFCNT(sv) == 0) {
2766 if (SvFLAGS(sv) & SVf_BREAK)
2767 return;
1edc1566
PP
2768 if (in_clean_all) /* All is fair */
2769 return;
79072805
LW
2770 warn("Attempt to free unreferenced scalar");
2771 return;
2772 }
8990e307
LW
2773 if (--SvREFCNT(sv) > 0)
2774 return;
463ee0b2
LW
2775#ifdef DEBUGGING
2776 if (SvTEMP(sv)) {
2777 warn("Attempt to free temp prematurely");
79072805 2778 return;
79072805 2779 }
463ee0b2 2780#endif
79072805 2781 sv_clear(sv);
477f5d66
CS
2782 if (! SvREFCNT(sv))
2783 del_SV(sv);
79072805
LW
2784}
2785
2786STRLEN
2787sv_len(sv)
2788register SV *sv;
2789{
748a9306 2790 char *junk;
463ee0b2 2791 STRLEN len;
79072805
LW
2792
2793 if (!sv)
2794 return 0;
2795
8990e307
LW
2796 if (SvGMAGICAL(sv))
2797 len = mg_len(sv);
2798 else
748a9306 2799 junk = SvPV(sv, len);
463ee0b2 2800 return len;
79072805
LW
2801}
2802
2803I32
2804sv_eq(str1,str2)
2805register SV *str1;
2806register SV *str2;
2807{
2808 char *pv1;
463ee0b2 2809 STRLEN cur1;
79072805 2810 char *pv2;
463ee0b2 2811 STRLEN cur2;
79072805
LW
2812
2813 if (!str1) {
2814 pv1 = "";
2815 cur1 = 0;
2816 }
463ee0b2
LW
2817 else
2818 pv1 = SvPV(str1, cur1);
79072805
LW
2819
2820 if (!str2)
2821 return !cur1;
463ee0b2
LW
2822 else
2823 pv2 = SvPV(str2, cur2);
79072805
LW
2824
2825 if (cur1 != cur2)
2826 return 0;
2827
36477c24 2828 return memEQ(pv1, pv2, cur1);
79072805
LW
2829}
2830
2831I32
bbce6d69 2832sv_cmp(str1, str2)
79072805
LW
2833register SV *str1;
2834register SV *str2;
2835{
bbce6d69
PP
2836 STRLEN cur1 = 0;
2837 char *pv1 = str1 ? SvPV(str1, cur1) : NULL;
2838 STRLEN cur2 = 0;
2839 char *pv2 = str2 ? SvPV(str2, cur2) : NULL;
79072805 2840 I32 retval;
79072805 2841
bbce6d69
PP
2842 if (!cur1)
2843 return cur2 ? -1 : 0;
16660edb 2844
bbce6d69
PP
2845 if (!cur2)
2846 return 1;
79072805 2847
bbce6d69 2848 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
16660edb 2849
bbce6d69
PP
2850 if (retval)
2851 return retval < 0 ? -1 : 1;
16660edb 2852
bbce6d69
PP
2853 if (cur1 == cur2)
2854 return 0;
2855 else
2856 return cur1 < cur2 ? -1 : 1;
2857}
16660edb 2858
bbce6d69
PP
2859I32
2860sv_cmp_locale(sv1, sv2)
2861register SV *sv1;
2862register SV *sv2;
2863{
36477c24 2864#ifdef USE_LOCALE_COLLATE
16660edb 2865
bbce6d69
PP
2866 char *pv1, *pv2;
2867 STRLEN len1, len2;
2868 I32 retval;
16660edb 2869
bbce6d69
PP
2870 if (collation_standard)
2871 goto raw_compare;
16660edb 2872
bbce6d69
PP
2873 len1 = 0;
2874 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL;
2875 len2 = 0;
2876 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : NULL;
16660edb 2877
bbce6d69
PP
2878 if (!pv1 || !len1) {
2879 if (pv2 && len2)
2880 return -1;
2881 else
2882 goto raw_compare;
2883 }
2884 else {
2885 if (!pv2 || !len2)
2886 return 1;
2887 }
16660edb 2888
bbce6d69 2889 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 2890
bbce6d69 2891 if (retval)
16660edb
PP
2892 return retval < 0 ? -1 : 1;
2893
bbce6d69
PP
2894 /*
2895 * When the result of collation is equality, that doesn't mean
2896 * that there are no differences -- some locales exclude some
2897 * characters from consideration. So to avoid false equalities,
2898 * we use the raw string as a tiebreaker.
2899 */
16660edb 2900
bbce6d69
PP
2901 raw_compare:
2902 /* FALL THROUGH */
16660edb 2903
36477c24 2904#endif /* USE_LOCALE_COLLATE */
16660edb 2905
bbce6d69
PP
2906 return sv_cmp(sv1, sv2);
2907}
79072805 2908
36477c24 2909#ifdef USE_LOCALE_COLLATE
7a4c00b4
PP
2910/*
2911 * Any scalar variable may carry an 'o' magic that contains the
2912 * scalar data of the variable transformed to such a format that
2913 * a normal memory comparison can be used to compare the data
2914 * according to the locale settings.
2915 */
bbce6d69
PP
2916char *
2917sv_collxfrm(sv, nxp)
2918 SV *sv;
2919 STRLEN *nxp;
2920{
7a4c00b4 2921 MAGIC *mg;
16660edb 2922
7a4c00b4
PP
2923 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
2924 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
bbce6d69
PP
2925 char *s, *xf;
2926 STRLEN len, xlen;
2927
7a4c00b4
PP
2928 if (mg)
2929 Safefree(mg->mg_ptr);
bbce6d69
PP
2930 s = SvPV(sv, len);
2931 if ((xf = mem_collxfrm(s, len, &xlen))) {
7a4c00b4
PP
2932 if (! mg) {
2933 sv_magic(sv, 0, 'o', 0, 0);
2934 mg = mg_find(sv, 'o');
2935 assert(mg);
bbce6d69 2936 }
7a4c00b4
PP
2937 mg->mg_ptr = xf;
2938 mg->mg_len = xlen;
2939 }
2940 else {
2941 mg->mg_ptr = NULL;
2942 mg->mg_len = -1;
bbce6d69
PP
2943 }
2944 }
7a4c00b4 2945 if (mg && mg->mg_ptr) {
bbce6d69
PP
2946 *nxp = mg->mg_len;
2947 return mg->mg_ptr + sizeof(collation_ix);
2948 }
2949 else {
2950 *nxp = 0;
2951 return NULL;
16660edb 2952 }
79072805
LW
2953}
2954
36477c24 2955#endif /* USE_LOCALE_COLLATE */
bbce6d69 2956
79072805
LW
2957char *
2958sv_gets(sv,fp,append)
2959register SV *sv;
760ac839 2960register PerlIO *fp;
79072805
LW
2961I32 append;
2962{
c07a80fd
PP
2963 char *rsptr;
2964 STRLEN rslen;
2965 register STDCHAR rslast;
2966 register STDCHAR *bp;
2967 register I32 cnt;
2968 I32 i;
2969
ed6116ce 2970 if (SvTHINKFIRST(sv)) {
8990e307 2971 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce
LW
2972 croak(no_modify);
2973 if (SvROK(sv))
2974 sv_unref(sv);
2975 }
79072805 2976 if (!SvUPGRADE(sv, SVt_PV))
a0d0e21e 2977 return 0;
ff68c719 2978 SvSCREAM_off(sv);
c07a80fd
PP
2979
2980 if (RsSNARF(rs)) {
2981 rsptr = NULL;
2982 rslen = 0;
2983 }
2984 else if (RsPARA(rs)) {
2985 rsptr = "\n\n";
2986 rslen = 2;
2987 }
2988 else
2989 rsptr = SvPV(rs, rslen);
2990 rslast = rslen ? rsptr[rslen - 1] : '\0';
2991
2992 if (RsPARA(rs)) { /* have to do this both before and after */
79072805 2993 do { /* to make sure file boundaries work right */
760ac839 2994 if (PerlIO_eof(fp))
a0d0e21e 2995 return 0;
760ac839 2996 i = PerlIO_getc(fp);
79072805 2997 if (i != '\n') {
a0d0e21e
LW
2998 if (i == -1)
2999 return 0;
760ac839 3000 PerlIO_ungetc(fp,i);
79072805
LW
3001 break;
3002 }
3003 } while (i != EOF);
3004 }
c07a80fd 3005
760ac839
LW
3006 /* See if we know enough about I/O mechanism to cheat it ! */
3007
3008 /* This used to be #ifdef test - it is made run-time test for ease
3009 of abstracting out stdio interface. One call should be cheap
3010 enough here - and may even be a macro allowing compile
3011 time optimization.
3012 */
3013
3014 if (PerlIO_fast_gets(fp)) {
3015
3016 /*
3017 * We're going to steal some values from the stdio struct
3018 * and put EVERYTHING in the innermost loop into registers.
3019 */
3020 register STDCHAR *ptr;
3021 STRLEN bpx;
3022 I32 shortbuffered;
3023
16660edb
PP
3024#if defined(VMS) && defined(PERLIO_IS_STDIO)
3025 /* An ungetc()d char is handled separately from the regular
3026 * buffer, so we getc() it back out and stuff it in the buffer.
3027 */
3028 i = PerlIO_getc(fp);
3029 if (i == EOF) return 0;
3030 *(--((*fp)->_ptr)) = (unsigned char) i;
3031 (*fp)->_cnt++;
3032#endif
c07a80fd 3033
c2960299 3034 /* Here is some breathtakingly efficient cheating */
c07a80fd 3035
760ac839 3036 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 3037 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW
3038 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3039 if (cnt > 80 && SvLEN(sv) > append) {
3040 shortbuffered = cnt - SvLEN(sv) + append + 1;
3041 cnt -= shortbuffered;
3042 }
3043 else {
3044 shortbuffered = 0;
bbce6d69
PP
3045 /* remember that cnt can be negative */
3046 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW
3047 }
3048 }
3049 else
3050 shortbuffered = 0;
c07a80fd 3051 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
760ac839 3052 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb
PP
3053 DEBUG_P(PerlIO_printf(Perl_debug_log,
3054 "Screamer: entering, ptr=%d, cnt=%d\n",ptr,cnt));
3055 DEBUG_P(PerlIO_printf(Perl_debug_log,
3056 "Screamer: entering: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
bbce6d69
PP
3057 PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
3058 PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0));
79072805
LW
3059 for (;;) {
3060 screamer:
93a17b20 3061 if (cnt > 0) {
c07a80fd 3062 if (rslen) {
760ac839
LW
3063 while (cnt > 0) { /* this | eat */
3064 cnt--;
c07a80fd
PP
3065 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3066 goto thats_all_folks; /* screams | sed :-) */
3067 }
3068 }
3069 else {
36477c24 3070 Copy(ptr, bp, cnt, char); /* this | eat */
c07a80fd
PP
3071 bp += cnt; /* screams | dust */
3072 ptr += cnt; /* louder | sed :-) */
a5f75d66 3073 cnt = 0;
93a17b20 3074 }
79072805
LW
3075 }
3076
748a9306 3077 if (shortbuffered) { /* oh well, must extend */
79072805
LW
3078 cnt = shortbuffered;
3079 shortbuffered = 0;
c07a80fd 3080 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW
3081 SvCUR_set(sv, bpx);
3082 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 3083 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW
3084 continue;
3085 }
3086
16660edb
PP
3087 DEBUG_P(PerlIO_printf(Perl_debug_log,
3088 "Screamer: going to getc, ptr=%d, cnt=%d\n",ptr,cnt));
d1bf51dd 3089 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb
PP
3090 DEBUG_P(PerlIO_printf(Perl_debug_log,
3091 "Screamer: pre: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
bbce6d69
PP
3092 PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
3093 PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0));
16660edb 3094 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b
PP
3095 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3096 another abstraction. */
760ac839 3097 i = PerlIO_getc(fp); /* get more characters */
16660edb
PP
3098 DEBUG_P(PerlIO_printf(Perl_debug_log,
3099 "Screamer: post: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
bbce6d69
PP
3100 PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
3101 PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0));
760ac839
LW
3102 cnt = PerlIO_get_cnt(fp);
3103 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb
PP
3104 DEBUG_P(PerlIO_printf(Perl_debug_log,
3105 "Screamer: after getc, ptr=%d, cnt=%d\n",ptr,cnt));
79072805 3106
748a9306
LW
3107 if (i == EOF) /* all done for ever? */
3108 goto thats_really_all_folks;
3109
c07a80fd 3110 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW
3111 SvCUR_set(sv, bpx);
3112 SvGROW(sv, bpx + cnt + 2);
c07a80fd
PP
3113 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3114
760ac839 3115 *bp++ = i; /* store character from PerlIO_getc */
79072805 3116
c07a80fd 3117 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 3118 goto thats_all_folks;
79072805
LW
3119 }
3120
3121thats_all_folks:
c07a80fd 3122 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 3123 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 3124 goto screamer; /* go back to the fray */
79072805
LW
3125thats_really_all_folks:
3126 if (shortbuffered)
3127 cnt += shortbuffered;
16660edb
PP
3128 DEBUG_P(PerlIO_printf(Perl_debug_log,
3129 "Screamer: quitting, ptr=%d, cnt=%d\n",ptr,cnt));
d1bf51dd 3130 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb
PP
3131 DEBUG_P(PerlIO_printf(Perl_debug_log,
3132 "Screamer: end: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
bbce6d69
PP
3133 PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
3134 PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0));
79072805 3135 *bp = '\0';
760ac839 3136 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb
PP
3137 DEBUG_P(PerlIO_printf(Perl_debug_log,
3138 "Screamer: done, len=%d, string=|%.*s|\n",
3139 SvCUR(sv),SvCUR(sv),SvPVX(sv)));
760ac839
LW
3140 }
3141 else
79072805 3142 {
760ac839 3143 /*The big, slow, and stupid way */
c07a80fd 3144 STDCHAR buf[8192];
79072805 3145
760ac839 3146screamer2:
c07a80fd 3147 if (rslen) {
760ac839
LW
3148 register STDCHAR *bpe = buf + sizeof(buf);
3149 bp = buf;
3150 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3151 ; /* keep reading */
3152 cnt = bp - buf;
c07a80fd
PP
3153 }
3154 else {
760ac839 3155 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb
PP
3156 /* Accomodate broken VAXC compiler, which applies U8 cast to
3157 * both args of ?: operator, causing EOF to change into 255
3158 */
3159 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 3160 }
79072805
LW
3161
3162 if (append)
760ac839 3163 sv_catpvn(sv, (char *) buf, cnt);
79072805 3164 else
760ac839 3165 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd
PP
3166
3167 if (i != EOF && /* joy */
3168 (!rslen ||
3169 SvCUR(sv) < rslen ||
36477c24 3170 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW
3171 {
3172 append = -1;
760ac839 3173 goto screamer2;
79072805
LW
3174 }
3175 }
3176
c07a80fd
PP
3177 if (RsPARA(rs)) { /* have to do this both before and after */
3178 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 3179 i = PerlIO_getc(fp);
79072805 3180 if (i != '\n') {
760ac839 3181 PerlIO_ungetc(fp,i);
79072805
LW
3182 break;
3183 }
3184 }
3185 }
c07a80fd
PP
3186
3187 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW
3188}
3189
760ac839 3190
79072805
LW
3191void
3192sv_inc(sv)
3193register SV *sv;
3194{
3195 register char *d;
463ee0b2 3196 int flags;
79072805
LW
3197
3198 if (!sv)
3199 return;
ed6116ce 3200 if (SvTHINKFIRST(sv)) {
8990e307 3201 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce 3202 croak(no_modify);
a0d0e21e
LW
3203 if (SvROK(sv)) {
3204#ifdef OVERLOAD
3205 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
3206#endif /* OVERLOAD */
3207 sv_unref(sv);
3208 }
ed6116ce 3209 }
8990e307 3210 if (SvGMAGICAL(sv))
79072805 3211 mg_get(sv);
8990e307 3212 flags = SvFLAGS(sv);
8990e307 3213 if (flags & SVp_NOK) {
a0d0e21e 3214 (void)SvNOK_only(sv);
55497cff
PP
3215 SvNVX(sv) += 1.0;
3216 return;
3217 }
3218 if (flags & SVp_IOK) {
3219 if (SvIVX(sv) == IV_MAX)
3220 sv_setnv(sv, (double)IV_MAX + 1.0);
3221 else {
3222 (void)SvIOK_only(sv);
3223 ++SvIVX(sv);
3224 }
79072805
LW
3225 return;
3226 }
8990e307 3227 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4633a7c4
LW
3228 if ((flags & SVTYPEMASK) < SVt_PVNV)
3229 sv_upgrade(sv, SVt_NV);
463ee0b2 3230 SvNVX(sv) = 1.0;
a0d0e21e 3231 (void)SvNOK_only(sv);
79072805
LW
3232 return;
3233 }
463ee0b2 3234 d = SvPVX(sv);
79072805
LW
3235 while (isALPHA(*d)) d++;
3236 while (isDIGIT(*d)) d++;
3237 if (*d) {
36477c24 3238 SET_NUMERIC_STANDARD();
bbce6d69 3239 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
79072805
LW
3240 return;
3241 }
3242 d--;
463ee0b2 3243 while (d >= SvPVX(sv)) {
79072805
LW
3244 if (isDIGIT(*d)) {
3245 if (++*d <= '9')
3246 return;
3247 *(d--) = '0';
3248 }
3249 else {
3250 ++*d;
3251 if (isALPHA(*d))
3252 return;
3253 *(d--) -= 'z' - 'a' + 1;
3254 }
3255 }
3256 /* oh,oh, the number grew */
3257 SvGROW(sv, SvCUR(sv) + 2);
3258 SvCUR(sv)++;
463ee0b2 3259 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW
3260 *d = d[-1];
3261 if (isDIGIT(d[1]))
3262 *d = '1';
3263 else
3264 *d = d[1];
3265}
3266
3267void
3268sv_dec(sv)
3269register SV *sv;
3270{
463ee0b2
LW
3271 int flags;
3272
79072805
LW
3273 if (!sv)
3274 return;
ed6116ce 3275 if (SvTHINKFIRST(sv)) {
8990e307 3276 if (SvREADONLY(sv) && curcop != &compiling)
ed6116ce 3277 croak(no_modify);
a0d0e21e
LW
3278 if (SvROK(sv)) {
3279#ifdef OVERLOAD
3280 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
3281#endif /* OVERLOAD */
3282 sv_unref(sv);
3283 }
ed6116ce 3284 }
8990e307 3285 if (SvGMAGICAL(sv))
79072805 3286 mg_get(sv);
8990e307 3287 flags = SvFLAGS(sv);
8990e307 3288 if (flags & SVp_NOK) {
463ee0b2 3289 SvNVX(sv) -= 1.0;
a0d0e21e 3290 (void)SvNOK_only(sv);
79072805
LW
3291 return;
3292 }
55497cff
PP
3293 if (flags & SVp_IOK) {
3294 if (SvIVX(sv) == IV_MIN)
3295 sv_setnv(sv, (double)IV_MIN - 1.0);
3296 else {
3297 (void)SvIOK_only(sv);
3298 --SvIVX(sv);
3299 }
3300 return;
3301 }
8990e307 3302 if (!(flags & SVp_POK)) {
4633a7c4
LW
3303 if ((flags & SVTYPEMASK) < SVt_PVNV)
3304 sv_upgrade(sv, SVt_NV);
463ee0b2 3305 SvNVX(sv) = -1.0;
a0d0e21e 3306 (void)SvNOK_only(sv);
79072805
LW
3307 return;
3308 }
36477c24 3309 SET_NUMERIC_STANDARD();
bbce6d69 3310 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW
3311}
3312
3313/* Make a string that will exist for the duration of the expression
3314 * evaluation. Actually, it may have to last longer than that, but
3315 * hopefully we won't free it until it has been assigned to a
3316 * permanent location. */
3317
8990e307
LW
3318static void
3319sv_mortalgrow()
3320{
55497cff 3321 tmps_max += (tmps_max < 512) ? 128 : 512;
8990e307
LW
3322 Renew(tmps_stack, tmps_max, SV*);
3323}
3324
79072805
LW
3325SV *
3326sv_mortalcopy(oldstr)
3327SV *oldstr;
3328{
463ee0b2 3329 register SV *sv;
79072805 3330
4561caa4 3331 new_SV(sv);
8990e307
LW
3332 SvANY(sv) = 0;
3333 SvREFCNT(sv) = 1;
3334 SvFLAGS(sv) = 0;
79072805 3335 sv_setsv(sv,oldstr);
8990e307
LW
3336 if (++tmps_ix >= tmps_max)
3337 sv_mortalgrow();
3338 tmps_stack[tmps_ix] = sv;
3339 SvTEMP_on(sv);
3340 return sv;
3341}
3342
3343SV *
3344sv_newmortal()
3345{
3346 register SV *sv;
3347
4561caa4 3348 new_SV(sv);
8990e307
LW
3349 SvANY(sv) = 0;
3350 SvREFCNT(sv) = 1;
3351 SvFLAGS(sv) = SVs_TEMP;
3352 if (++tmps_ix >= tmps_max)
3353 sv_mortalgrow();
79072805 3354 tmps_stack[tmps_ix] = sv;
79072805
LW
3355 return sv;
3356}
3357
3358/* same thing without the copying */
3359
3360SV *
3361sv_2mortal(sv)
3362register SV *sv;
3363{
3364 if (!sv)
3365 return sv;
a0d0e21e
LW
3366 if (SvREADONLY(sv) && curcop != &compiling)
3367 croak(no_modify);
8990e307
LW
3368 if (++tmps_ix >= tmps_max)
3369 sv_mortalgrow();
79072805 3370 tmps_stack[tmps_ix] = sv;
8990e307 3371 SvTEMP_on(sv);
79072805
LW
3372 return sv;
3373}
3374
3375SV *
3376newSVpv(s,len)
3377char *s;
3378STRLEN len;
3379{
463ee0b2 3380 register SV *sv;
79072805 3381
4561caa4 3382 new_SV(sv);
8990e307
LW
3383 SvANY(sv) = 0;
3384 SvREFCNT(sv) = 1;
3385 SvFLAGS(sv) = 0;
79072805
LW
3386 if (!len)
3387 len = strlen(s);
3388 sv_setpvn(sv,s,len);
3389 return sv;
3390}
3391
3392SV *
3393newSVnv(n)
3394double n;
3395{
463ee0b2 3396 register SV *sv;
79072805 3397
4561caa4 3398 new_SV(sv);
8990e307
LW
3399 SvANY(sv) = 0;
3400 SvREFCNT(sv) = 1;
3401 SvFLAGS(sv) = 0;
79072805
LW
3402 sv_setnv(sv,n);
3403 return sv;
3404}
3405
3406SV *
3407newSViv(i)
a0d0e21e 3408IV i;
79072805 3409{
463ee0b2 3410 register SV *sv;
79072805 3411
4561caa4 3412 new_SV(sv);
8990e307
LW
3413 SvANY(sv) = 0;
3414 SvREFCNT(sv) = 1;
3415 SvFLAGS(sv) = 0;
79072805
LW
3416 sv_setiv(sv,i);
3417 return sv;
3418}
3419
2304df62
AD
3420SV *
3421newRV(ref)
3422SV *ref;
3423{
3424 register SV *sv;
3425
4561caa4 3426 new_SV(sv);
2304df62
AD
3427 SvANY(sv) = 0;
3428 SvREFCNT(sv) = 1;
3429 SvFLAGS(sv) = 0;
3430 sv_upgrade(sv, SVt_RV);
a0d0e21e 3431 SvTEMP_off(ref);
2304df62
AD
3432 SvRV(sv) = SvREFCNT_inc(ref);
3433 SvROK_on(sv);
2304df62
AD
3434 return sv;
3435}
3436
5f05dabc
PP
3437#ifdef CRIPPLED_CC
3438SV *
3439newRV_noinc(ref)
3440SV *ref;
3441{
3442 register SV *sv;
3443
3444 sv = newRV(ref);
3445 SvREFCNT_dec(ref);
3446 return sv;
3447}
3448#endif /* CRIPPLED_CC */
3449
79072805
LW
3450/* make an exact duplicate of old */
3451
3452SV *
3453newSVsv(old)
3454register SV *old;
3455{
463ee0b2 3456 register SV *sv;
79072805
LW
3457
3458 if (!old)
3459 return Nullsv;
8990e307 3460 if (SvTYPE(old) == SVTYPEMASK) {
79072805
LW
3461 warn("semi-panic: attempt to dup freed string");
3462 return Nullsv;
3463 }
4561caa4 3464 new_SV(sv);
8990e307
LW
3465 SvANY(sv) = 0;
3466 SvREFCNT(sv) = 1;
3467 SvFLAGS(sv) = 0;
ff68c719
PP
3468 if (SvTEMP(old)) {
3469 SvTEMP_off(old);
463ee0b2 3470 sv_setsv(sv,old);
ff68c719 3471 SvTEMP_on(old);
79072805
LW
3472 }
3473 else
463ee0b2
LW
3474 sv_setsv(sv,old);
3475 return sv;
79072805
LW
3476}
3477
3478void
3479sv_reset(s,stash)
3480register char *s;
3481HV *stash;
3482{
3483 register HE *entry;
3484 register GV *gv;
3485 register SV *sv;
3486 register I32 i;
3487 register PMOP *pm;
3488 register I32 max;
463ee0b2 3489 char todo[256];
79072805
LW
3490
3491 if (!*s) { /* reset ?? searches */
3492 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
3493 pm->op_pmflags &= ~PMf_USED;
3494 }
3495 return;
3496 }
3497
3498 /* reset variables */
3499
3500 if (!HvARRAY(stash))
3501 return;
463ee0b2
LW
3502
3503 Zero(todo, 256, char);
79072805
LW
3504 while (*s) {
3505 i = *s;
3506 if (s[1] == '-') {
3507 s += 2;
3508 }
3509 max = *s++;
3510 for ( ; i <= max; i++) {
463ee0b2
LW
3511 todo[i] = 1;
3512 }
a0d0e21e 3513 for (i = 0; i <= (I32) HvMAX(stash); i++) {
79072805
LW
3514 for (entry = HvARRAY(stash)[i];
3515 entry;
1edc1566
PP
3516 entry = HeNEXT(entry)) {
3517 if (!todo[(U8)*HeKEY(entry)])
463ee0b2 3518 continue;
1edc1566 3519 gv = (GV*)HeVAL(entry);
79072805 3520 sv = GvSV(gv);
a0d0e21e 3521 (void)SvOK_off(sv);
79072805
LW
3522 if (SvTYPE(sv) >= SVt_PV) {
3523 SvCUR_set(sv, 0);
463ee0b2
LW
3524 if (SvPVX(sv) != Nullch)
3525 *SvPVX(sv) = '\0';
44a8e56a 3526 SvTAINT(sv);
79072805
LW
3527 }
3528 if (GvAV(gv)) {
3529 av_clear(GvAV(gv));
3530 }
44a8e56a 3531 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
463ee0b2 3532 hv_clear(GvHV(gv));
a0d0e21e 3533#ifndef VMS /* VMS has no environ array */
79072805
LW
3534 if (gv == envgv)
3535 environ[0] = Nullch;
a0d0e21e 3536#endif
79072805
LW
3537 }
3538 }
3539 }
3540 }
3541}
3542
79072805
LW
3543CV *
3544sv_2cv(sv, st, gvp, lref)
3545SV *sv;
3546HV **st;
3547GV **gvp;
3548I32 lref;
3549{
3550 GV *gv;
3551 CV *cv;
3552
3553 if (!sv)
93a17b20 3554 return *gvp = Nullgv, Nullcv;
79072805 3555 switch (SvTYPE(sv)) {
79072805
LW
3556 case SVt_PVCV:
3557 *st = CvSTASH(sv);
3558 *gvp = Nullgv;
3559 return (CV*)sv;
3560 case SVt_PVHV:
3561 case SVt_PVAV:
3562 *gvp = Nullgv;
3563 return Nullcv;
8990e307
LW
3564 case SVt_PVGV:
3565 gv = (GV*)sv;
a0d0e21e 3566 *gvp = gv;
8990e307
LW
3567 *st = GvESTASH(gv);
3568 goto fix_gv;
3569
79072805 3570 default:
a0d0e21e
LW
3571 if (SvGMAGICAL(sv))
3572 mg_get(sv);
3573 if (SvROK(sv)) {
3574 cv = (CV*)SvRV(sv);
3575 if (SvTYPE(cv) != SVt_PVCV)
3576 croak("Not a subroutine reference");
3577 *gvp = Nullgv;
3578 *st = CvSTASH(cv);
3579 return cv;
3580 }
79072805
LW
3581 if (isGV(sv))
3582 gv = (GV*)sv;
3583 else
85e6fe83 3584 gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV);
79072805
LW
3585 *gvp = gv;
3586 if (!gv)
3587 return Nullcv;
3588 *st = GvESTASH(gv);
8990e307 3589 fix_gv:
8ebc5c01 3590 if (lref && !GvCVu(gv)) {
4633a7c4 3591 SV *tmpsv;
748a9306 3592 ENTER;
4633a7c4 3593 tmpsv = NEWSV(704,0);
16660edb 3594 gv_efullname3(tmpsv, gv, Nullch);
774d564b 3595 newSUB(start_subparse(FALSE, 0),
4633a7c4
LW
3596 newSVOP(OP_CONST, 0, tmpsv),
3597 Nullop,
8990e307 3598 Nullop);
748a9306 3599 LEAVE;
8ebc5c01 3600 if (!GvCVu(gv))
4633a7c4 3601 croak("Unable to create sub named \"%s\"", SvPV(sv,na));
8990e307 3602 }
8ebc5c01 3603 return GvCVu(gv);
79072805
LW
3604 }
3605}
3606
3607#ifndef SvTRUE
3608I32
3609SvTRUE(sv)
3610register SV *sv;
3611{
8990e307
LW
3612 if (!sv)
3613 return 0;
3614 if (SvGMAGICAL(sv))
79072805
LW
3615 mg_get(sv);
3616 if (SvPOK(sv)) {
3617 register XPV* Xpv;
3618 if ((Xpv = (XPV*)SvANY(sv)) &&
3619 (*Xpv->xpv_pv > '0' ||
3620 Xpv->xpv_cur > 1 ||
3621 (Xpv->xpv_cur && *Xpv->xpv_pv != '0')))
3622 return 1;
3623 else
3624 return 0;
3625 }
3626 else {
3627 if (SvIOK(sv))
463ee0b2 3628 return SvIVX(sv) != 0;
79072805
LW
3629 else {
3630 if (SvNOK(sv))
463ee0b2 3631 return SvNVX(sv) != 0.0;
79072805 3632 else
463ee0b2 3633 return sv_2bool(sv);
79072805
LW
3634 }
3635 }
3636}
ff68c719 3637#endif /* !SvTRUE */
79072805 3638
85e6fe83 3639#ifndef SvIV
ff68c719
PP
3640IV
3641SvIV(sv)
3642register SV *sv;
85e6fe83 3643{
ff68c719
PP
3644 if (SvIOK(sv))
3645 return SvIVX(sv);
3646 return sv_2iv(sv);
85e6fe83 3647}
ff68c719 3648#endif /* !SvIV */
85e6fe83 3649
ff68c719
PP
3650#ifndef SvUV
3651UV
3652SvUV(sv)
3653register SV *sv;
3654{
3655 if (SvIOK(sv))
3656 return SvUVX(sv);
3657 return sv_2uv(sv);
3658}
3659#endif /* !SvUV */
85e6fe83 3660
463ee0b2 3661#ifndef SvNV
ff68c719
PP
3662double
3663SvNV(sv)
3664register SV *sv;
79072805 3665{
ff68c719
PP
3666 if (SvNOK(sv))
3667 return SvNVX(sv);
3668 return sv_2nv(sv);
79072805 3669}
ff68c719 3670#endif /* !SvNV */
79072805 3671
463ee0b2 3672#ifdef CRIPPLED_CC
79072805 3673char *
463ee0b2 3674sv_pvn(sv, lp)
79072805 3675SV *sv;
463ee0b2 3676STRLEN *lp;
79072805 3677{
85e6fe83
LW
3678 if (SvPOK(sv)) {
3679 *lp = SvCUR(sv);
a0d0e21e 3680 return SvPVX(sv);
85e6fe83 3681 }
463ee0b2 3682 return sv_2pv(sv, lp);
79072805
LW
3683}
3684#endif
3685
a0d0e21e
LW
3686char *
3687sv_pvn_force(sv, lp)
3688SV *sv;
3689STRLEN *lp;
3690{
3691 char *s;
3692
3693 if (SvREADONLY(sv) && curcop != &compiling)
3694 croak(no_modify);
3695
3696 if (SvPOK(sv)) {
3697 *lp = SvCUR(sv);
3698 }
3699 else {
748a9306 3700 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4633a7c4 3701 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) {
a0d0e21e 3702 sv_unglob(sv);
4633a7c4
LW
3703 s = SvPVX(sv);
3704 *lp = SvCUR(sv);
3705 }
a0d0e21e
LW
3706 else
3707 croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
3708 op_name[op->op_type]);
3709 }
4633a7c4
LW
3710 else
3711 s = sv_2pv(sv, lp);
a0d0e21e
LW
3712 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
3713 STRLEN len = *lp;
3714
3715 if (SvROK(sv))
3716 sv_unref(sv);
3717 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
3718 SvGROW(sv, len + 1);
3719 Move(s,SvPVX(sv),len,char);
3720 SvCUR_set(sv, len);
3721 *SvEND(sv) = '\0';
3722 }
3723 if (!SvPOK(sv)) {
3724 SvPOK_on(sv); /* validate pointer */
3725 SvTAINT(sv);
760ac839 3726 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
a0d0e21e
LW
3727 (unsigned long)sv,SvPVX(sv)));
3728 }
3729 }
3730 return SvPVX(sv);
3731}
3732
3733char *
3734sv_reftype(sv, ob)
3735SV* sv;
3736int ob;
3737{
3738 if (ob && SvOBJECT(sv))
3739 return HvNAME(SvSTASH(sv));
3740 else {
3741 switch (SvTYPE(sv)) {
3742 case SVt_NULL:
3743 case SVt_IV:
3744 case SVt_NV:
3745 case SVt_RV:
3746 case SVt_PV:
3747 case SVt_PVIV:
3748 case SVt_PVNV:
3749 case SVt_PVMG:
3750 case SVt_PVBM:
3751 if (SvROK(sv))
3752 return "REF";
3753 else
3754 return "SCALAR";
3755 case SVt_PVLV: return "LVALUE";
3756 case SVt_PVAV: return "ARRAY";
3757 case SVt_PVHV: return "HASH";
3758 case SVt_PVCV: return "CODE";
3759 case SVt_PVGV: return "GLOB";
3760 case SVt_PVFM: return "FORMLINE";
3761 default: return "UNKNOWN";
3762 }
3763 }
3764}
3765
463ee0b2 3766int
85e6fe83
LW
3767sv_isobject(sv)
3768SV *sv;
3769{
3770 if (!SvROK(sv))
3771 return 0;
3772 sv = (SV*)SvRV(sv);
3773 if (!SvOBJECT(sv))
3774 return 0;
3775 return 1;
3776}
3777
3778int
463ee0b2
LW
3779sv_isa(sv, name)
3780SV *sv;
3781char *name;
3782{
ed6116ce 3783 if (!SvROK(sv))
463ee0b2 3784 return 0;
ed6116ce
LW
3785 sv = (SV*)SvRV(sv);
3786 if (!SvOBJECT(sv))
463ee0b2
LW
3787 return 0;
3788
3789 return strEQ(HvNAME(SvSTASH(sv)), name);
3790}
3791
3792SV*
a0d0e21e 3793newSVrv(rv, classname)
463ee0b2 3794SV *rv;
a0d0e21e 3795char *classname;
463ee0b2 3796{
463ee0b2
LW
3797 SV *sv;
3798
4561caa4 3799 new_SV(sv);
8990e307 3800 SvANY(sv) = 0;
a0d0e21e 3801 SvREFCNT(sv) = 0;
8990e307 3802 SvFLAGS(sv) = 0;
ed6116ce 3803 sv_upgrade(rv, SVt_RV);
8990e307 3804 SvRV(rv) = SvREFCNT_inc(sv);
ed6116ce 3805 SvROK_on(rv);
463ee0b2 3806
a0d0e21e
LW
3807 if (classname) {
3808 HV* stash = gv_stashpv(classname, TRUE);
3809 (void)sv_bless(rv, stash);
3810 }
3811 return sv;
3812}
3813
3814SV*
3815sv_setref_pv(rv, classname, pv)
3816SV *rv;
3817char *classname;
3818void* pv;
3819{
3820 if (!pv)
3821 sv_setsv(rv, &sv_undef);
3822 else
3823 sv_setiv(newSVrv(rv,classname), (IV)pv);
3824 return rv;
3825}
3826
3827SV*
3828sv_setref_iv(rv, classname, iv)
3829SV *rv;
3830char *classname;
3831IV iv;
3832{
3833 sv_setiv(newSVrv(rv,classname), iv);
3834 return rv;
3835}
3836
3837SV*
3838sv_setref_nv(rv, classname, nv)
3839SV *rv;
3840char *classname;
3841double nv;
3842{
3843 sv_setnv(newSVrv(rv,classname), nv);
3844 return rv;
3845}
463ee0b2 3846
a0d0e21e
LW
3847SV*
3848sv_setref_pvn(rv, classname, pv, n)
3849SV *rv;
3850char *classname;
3851char* pv;
3852I32 n;
3853{
3854 sv_setpvn(newSVrv(rv,classname), pv, n);
463ee0b2
LW
3855 return rv;
3856}
3857
a0d0e21e
LW
3858SV*
3859sv_bless(sv,stash)
3860SV* sv;
3861HV* stash;
3862{
3863 SV *ref;
3864 if (!SvROK(sv))
3865 croak("Can't bless non-reference value");
3866 ref = SvRV(sv);
3867 if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) {
3868 if (SvREADONLY(ref))
3869 croak(no_modify);
2e3febc6
CS
3870 if (SvOBJECT(ref)) {
3871 if (SvTYPE(ref) != SVt_PVIO)
3872 --sv_objcount;
3873 SvREFCNT_dec(SvSTASH(ref));
3874 }
a0d0e21e
LW
3875 }
3876 SvOBJECT_on(ref);
2e3febc6
CS
3877 if (SvTYPE(ref) != SVt_PVIO)
3878 ++sv_objcount;
a0d0e21e
LW
3879 (void)SvUPGRADE(ref, SVt_PVMG);
3880 SvSTASH(ref) = (HV*)SvREFCNT_inc(stash);
3881
3882#ifdef OVERLOAD
2e3febc6
CS
3883 if (Gv_AMG(stash))
3884 SvAMAGIC_on(sv);
3885 else
3886 SvAMAGIC_off(sv);
a0d0e21e
LW
3887#endif /* OVERLOAD */
3888
3889 return sv;
3890}
3891
3892static void
3893sv_unglob(sv)
3894SV* sv;
3895{
3896 assert(SvTYPE(sv) == SVt_PVGV);
3897 SvFAKE_off(sv);
3898 if (GvGP(sv))
1edc1566 3899 gp_free((GV*)sv);
a0d0e21e
LW
3900 sv_unmagic(sv, '*');
3901 Safefree(GvNAME(sv));
a5f75d66 3902 GvMULTI_off(sv);
a0d0e21e
LW
3903 SvFLAGS(sv) &= ~SVTYPEMASK;
3904 SvFLAGS(sv) |= SVt_PVMG;
3905}
3906
ed6116ce
LW
3907void
3908sv_unref(sv)
3909SV* sv;
3910{
a0d0e21e
LW
3911 SV* rv = SvRV(sv);
3912
ed6116ce
LW
3913 SvRV(sv) = 0;
3914 SvROK_off(sv);
4633a7c4
LW
3915 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
3916 SvREFCNT_dec(rv);
8e07c86e 3917 else
4633a7c4 3918 sv_2mortal(rv); /* Schedule for freeing later */
ed6116ce 3919}
8990e307 3920
bbce6d69
PP
3921IO*