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