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