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