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