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