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