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