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