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