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