This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add a few more PURIFY guards
[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{
00db4c45 124 if (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);
145 ++sv_count;
146}
147
148static void
149reg_remove(sv)
150SV* sv;
151{
152 REG_REMOVE(sv);
153 --sv_count;
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 { \
187 SvANY(p) = (void *)sv_root; \
188 SvFLAGS(p) = SVTYPEMASK; \
189 sv_root = (p); \
190 --sv_count; \
191 } while (0)
a0d0e21e 192
fba3b22e 193/* sv_mutex must be held while calling uproot_SV() */
fc36a67e 194#define uproot_SV(p) \
4561caa4
CS
195 do { \
196 (p) = sv_root; \
197 sv_root = (SV*)SvANY(p); \
a0d0e21e 198 ++sv_count; \
4561caa4 199 } while (0)
463ee0b2 200
940cb80d
MB
201#define new_SV(p) do { \
202 LOCK_SV_MUTEX; \
203 if (sv_root) \
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; \
214 if (debug & 32768) \
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{
a0d0e21e 224 if (debug & 32768) {
4633a7c4 225 SV* sva;
a0d0e21e
LW
226 SV* sv;
227 SV* svend;
228 int ok = 0;
4633a7c4
LW
229 for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
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. */
258 SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */
259 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
260 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
261
262 sv_arenaroot = sva;
263 sv_root = sva + 1;
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
c07a80fd
PP
282 if (nice_chunk) {
283 sv_add_arena(nice_chunk, nice_chunk_size, 0);
284 nice_chunk = Nullch;
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
4561caa4 302 for (sva = 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{
477f5d66 365 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
477f5d66 371 in_clean_objs = FALSE;
4561caa4
CS
372}
373
76e3520e 374STATIC void
8ac85365 375do_clean_all(SV *sv)
4561caa4 376{
d1bf51dd 377 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));)
4561caa4
CS
378 SvFLAGS(sv) |= SVf_BREAK;
379 SvREFCNT_dec(sv);
8990e307
LW
380}
381
382void
8ac85365 383sv_clean_all(void)
8990e307 384{
477f5d66 385 in_clean_all = TRUE;
ac4c12e7 386 visit(FUNC_NAME_TO_PTR(do_clean_all));
477f5d66 387 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
399 for (sva = sv_arenaroot; sva; sva = svanext) {
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
fc80cf79
GS
408 if (nice_chunk)
409 Safefree(nice_chunk);
410 nice_chunk = Nullch;
411 nice_chunk_size = 0;
5f05dabc
PP
412 sv_arenaroot = 0;
413 sv_root = 0;
4633a7c4
LW
414}
415
76e3520e 416STATIC XPVIV*
8ac85365 417new_xiv(void)
463ee0b2 418{
ea7c11a3 419 IV* xiv;
463ee0b2
LW
420 if (xiv_root) {
421 xiv = xiv_root;
85e6fe83
LW
422 /*
423 * See comment in more_xiv() -- RAM.
424 */
ea7c11a3 425 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));
ea7c11a3 435 *(IV**)xiv = xiv_root;
463ee0b2
LW
436 xiv_root = xiv;
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);
a0d0e21e
LW
446 ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */
447 xiv_arenaroot = ptr; /* to keep Purify happy */
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 */
463ee0b2
LW
452 xiv_root = xiv;
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;
465 if (xnv_root) {
466 xnv = xnv_root;
467 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));
463ee0b2
LW
477 *(double**)xnv = xnv_root;
478 xnv_root = xnv;
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 */
489 xnv_root = xnv;
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;
502 if (xrv_root) {
503 xrv = xrv_root;
504 xrv_root = (XRV*)xrv->xrv_rv;
505 return xrv;
506 }
507 return more_xrv();
508}
509
76e3520e 510STATIC void
8ac85365 511del_xrv(XRV *p)
ed6116ce
LW
512{
513 p->xrv_rv = (SV*)xrv_root;
514 xrv_root = p;
515}
516
76e3520e 517STATIC XRV*
8ac85365 518more_xrv(void)
ed6116ce 519{
ed6116ce
LW
520 register XRV* xrv;
521 register XRV* xrvend;
8c52afec 522 New(712, xrv_root, 1008/sizeof(XRV), XRV);
ed6116ce
LW
523 xrv = xrv_root;
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;
537 if (xpv_root) {
538 xpv = xpv_root;
539 xpv_root = (XPV*)xpv->xpv_pv;
540 return xpv;
541 }
542 return more_xpv();
543}
544
76e3520e 545STATIC void
8ac85365 546del_xpv(XPV *p)
463ee0b2
LW
547{
548 p->xpv_pv = (char*)xpv_root;
549 xpv_root = p;
550}
551
76e3520e 552STATIC XPV*
8ac85365 553more_xpv(void)
463ee0b2 554{
463ee0b2
LW
555 register XPV* xpv;
556 register XPV* xpvend;
8c52afec 557 New(713, xpv_root, 1008/sizeof(XPV), XPV);
463ee0b2
LW
558 xpv = xpv_root;
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 }
939 else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) {
940 if (sv == &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 }
947 else if (sv == &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 }
46fc3d4c 1065 return SvPV(t, 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) {
c70c8a0a 1121#if defined(MYMALLOC) && !defined(PURIFY)
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),
5dc0d613 1168 op_desc[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),
1228 op_name[op->op_type]);
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
1291 if (op)
c07a80fd 1292 warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
a0d0e21e
LW
1293 op_name[op->op_type]);
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)) {
c6ee37c5
MB
1316 if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1317 dTHR;
1318 if (!localizing)
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);
ed6116ce 1342 if (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;
91bba347 1371 if (dowarn && !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)) {
c6ee37c5
MB
1394 if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1395 dTHR;
1396 if (!localizing)
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);
ff68c719
PP
1417 if (dowarn)
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 {
c6ee37c5
MB
1442 if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1443 dTHR;
1444 if (!localizing)
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)) {
748a9306 1464 if (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)) {
c6ee37c5
MB
1472 if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1473 dTHR;
1474 if (!localizing)
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
LW
1490 if (SvPOKp(sv) && SvLEN(sv)) {
1491 if (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);
ed6116ce 1498 if (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
LW
1519 else if (SvPOKp(sv) && SvLEN(sv)) {
1520 if (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;
91bba347 1527 if (dowarn && !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));
1546 if (!numtype && dowarn)
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
36477c24
PP
1565 if (!numtype && dowarn)
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)) {
c6ee37c5
MB
1680 if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
1681 dTHR;
1682 if (!localizing)
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) {
1bd3ad17
IZ
1713 mg->mg_len = re->prelen + 4;
1714 New(616, mg->mg_ptr, mg->mg_len + 1, char);
1715 Copy("(?:", mg->mg_ptr, 3, char);
1716 Copy(re->precomp, mg->mg_ptr+3, re->prelen, char);
1717 mg->mg_ptr[mg->mg_len - 1] = ')';
1718 mg->mg_ptr[mg->mg_len] = 0;
1719 }
2cd61cdb 1720 reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ
1721 *lp = mg->mg_len;
1722 return mg->mg_ptr;
f9277f47
IZ
1723 }
1724 /* Fall through */
ed6116ce
LW
1725 case SVt_NULL:
1726 case SVt_IV:
1727 case SVt_NV:
1728 case SVt_RV:
1729 case SVt_PV:
1730 case SVt_PVIV:
1731 case SVt_PVNV:
f9277f47 1732 case SVt_PVBM: s = "SCALAR"; break;
ed6116ce
LW
1733 case SVt_PVLV: s = "LVALUE"; break;
1734 case SVt_PVAV: s = "ARRAY"; break;
1735 case SVt_PVHV: s = "HASH"; break;
1736 case SVt_PVCV: s = "CODE"; break;
1737 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 1738 case SVt_PVFM: s = "FORMAT"; break;
36477c24 1739 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW
1740 default: s = "UNKNOWN"; break;
1741 }
46fc3d4c 1742 tsv = NEWSV(0,0);
ed6116ce 1743 if (SvOBJECT(sv))
46fc3d4c 1744 sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 1745 else
46fc3d4c
PP
1746 sv_setpv(tsv, s);
1747 sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
a0d0e21e 1748 goto tokensaveref;
463ee0b2 1749 }
ed6116ce
LW
1750 *lp = strlen(s);
1751 return s;
79072805 1752 }
ed6116ce 1753 if (SvREADONLY(sv)) {
748a9306 1754 if (SvNOKp(sv)) {
36477c24 1755 SET_NUMERIC_STANDARD();
96827780 1756 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
46fc3d4c 1757 tsv = Nullsv;
a0d0e21e 1758 goto tokensave;
ed6116ce 1759 }
8bb9dbe4 1760 if (SvIOKp(sv)) {
96827780 1761 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
46fc3d4c 1762 tsv = Nullsv;
8bb9dbe4
LW
1763 goto tokensave;
1764 }
ed6116ce 1765 if (dowarn)
8990e307 1766 warn(warn_uninit);
ed6116ce
LW
1767 *lp = 0;
1768 return "";
79072805 1769 }
79072805 1770 }
c6f8c383 1771 (void)SvUPGRADE(sv, SVt_PV);
748a9306 1772 if (SvNOKp(sv)) {
79072805
LW
1773 if (SvTYPE(sv) < SVt_PVNV)
1774 sv_upgrade(sv, SVt_PVNV);
1775 SvGROW(sv, 28);
463ee0b2 1776 s = SvPVX(sv);
79072805 1777 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 1778#ifdef apollo
463ee0b2 1779 if (SvNVX(sv) == 0.0)
79072805
LW
1780 (void)strcpy(s,"0");
1781 else
1782#endif /*apollo*/
bbce6d69 1783 {
36477c24 1784 SET_NUMERIC_STANDARD();
a0d0e21e 1785 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
bbce6d69 1786 }
79072805 1787 errno = olderrno;
a0d0e21e
LW
1788#ifdef FIXNEGATIVEZERO
1789 if (*s == '-' && s[1] == '0' && !s[2])
1790 strcpy(s,"0");
1791#endif
79072805
LW
1792 while (*s) s++;
1793#ifdef hcx
1794 if (s[-1] == '.')
46fc3d4c 1795 *--s = '\0';
79072805
LW
1796#endif
1797 }
748a9306 1798 else if (SvIOKp(sv)) {
64f14228 1799 U32 oldIOK = SvIOK(sv);
79072805
LW
1800 if (SvTYPE(sv) < SVt_PVIV)
1801 sv_upgrade(sv, SVt_PVIV);
79072805 1802 olderrno = errno; /* some Xenix systems wipe out errno here */
84902520 1803 sv_setpviv(sv, SvIVX(sv));
79072805 1804 errno = olderrno;
46fc3d4c 1805 s = SvEND(sv);
64f14228
GA
1806 if (oldIOK)
1807 SvIOK_on(sv);
1808 else
1809 SvIOKp_on(sv);
79072805
LW
1810 }
1811 else {
11343788 1812 dTHR;
91bba347 1813 if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
8990e307 1814 warn(warn_uninit);
a0d0e21e
LW
1815 *lp = 0;
1816 return "";
79072805 1817 }
463ee0b2
LW
1818 *lp = s - SvPVX(sv);
1819 SvCUR_set(sv, *lp);
79072805 1820 SvPOK_on(sv);
760ac839 1821 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
463ee0b2 1822 return SvPVX(sv);
a0d0e21e
LW
1823
1824 tokensave:
1825 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1826 /* Sneaky stuff here */
1827
1828 tokensaveref:
46fc3d4c 1829 if (!tsv)
96827780 1830 tsv = newSVpv(tmpbuf, 0);
46fc3d4c
PP
1831 sv_2mortal(tsv);
1832 *lp = SvCUR(tsv);
1833 return SvPVX(tsv);
a0d0e21e
LW
1834 }
1835 else {
1836 STRLEN len;
46fc3d4c
PP
1837 char *t;
1838
1839 if (tsv) {
1840 sv_2mortal(tsv);
1841 t = SvPVX(tsv);
1842 len = SvCUR(tsv);
1843 }
1844 else {
96827780
MB
1845 t = tmpbuf;
1846 len = strlen(tmpbuf);
46fc3d4c 1847 }
a0d0e21e 1848#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
1849 if (len == 2 && t[0] == '-' && t[1] == '0') {
1850 t = "0";
1851 len = 1;
1852 }
a0d0e21e
LW
1853#endif
1854 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 1855 *lp = len;
a0d0e21e
LW
1856 s = SvGROW(sv, len + 1);
1857 SvCUR_set(sv, len);
46fc3d4c 1858 (void)strcpy(s, t);
6bf554b4 1859 SvPOKp_on(sv);
a0d0e21e
LW
1860 return s;
1861 }
463ee0b2
LW
1862}
1863
1864/* This function is only called on magical items */
1865bool
8ac85365 1866sv_2bool(register SV *sv)
463ee0b2 1867{
8990e307 1868 if (SvGMAGICAL(sv))
463ee0b2
LW
1869 mg_get(sv);
1870
a0d0e21e
LW
1871 if (!SvOK(sv))
1872 return 0;
1873 if (SvROK(sv)) {
1874#ifdef OVERLOAD
1875 {
11343788 1876 dTHR;
a0d0e21e
LW
1877 SV* tmpsv;
1878 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1879 return SvTRUE(tmpsv);
1880 }
1881#endif /* OVERLOAD */
1882 return SvRV(sv) != 0;
1883 }
463ee0b2 1884 if (SvPOKp(sv)) {
11343788
MB
1885 register XPV* Xpvtmp;
1886 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1887 (*Xpvtmp->xpv_pv > '0' ||
1888 Xpvtmp->xpv_cur > 1 ||
1889 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW
1890 return 1;
1891 else
1892 return 0;
1893 }
1894 else {
1895 if (SvIOKp(sv))
1896 return SvIVX(sv) != 0;
1897 else {
1898 if (SvNOKp(sv))
1899 return SvNVX(sv) != 0.0;
1900 else
1901 return FALSE;
1902 }
1903 }
79072805
LW
1904}
1905
1906/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 1907 * to be reused, since it may destroy the source string if it is marked
79072805
LW
1908 * as temporary.
1909 */
1910
1911void
8ac85365 1912sv_setsv(SV *dstr, register SV *sstr)
79072805 1913{
11343788 1914 dTHR;
8990e307
LW
1915 register U32 sflags;
1916 register int dtype;
1917 register int stype;
463ee0b2 1918
79072805
LW
1919 if (sstr == dstr)
1920 return;
2213622d 1921 SV_CHECK_THINKFIRST(dstr);
79072805
LW
1922 if (!sstr)
1923 sstr = &sv_undef;
8990e307
LW
1924 stype = SvTYPE(sstr);
1925 dtype = SvTYPE(dstr);
79072805 1926
8e07c86e
AD
1927 if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
1928 sv_unglob(dstr); /* so fake GLOB won't perpetuate */
4633a7c4
LW
1929 sv_setpvn(dstr, "", 0);
1930 (void)SvPOK_only(dstr);
8e07c86e
AD
1931 dtype = SvTYPE(dstr);
1932 }
1933
a0d0e21e
LW
1934#ifdef OVERLOAD
1935 SvAMAGIC_off(dstr);
1936#endif /* OVERLOAD */
463ee0b2 1937 /* There's a lot of redundancy below but we're going for speed here */
79072805 1938
8990e307 1939 switch (stype) {
79072805 1940 case SVt_NULL:
aece5585 1941 undef_sstr:
20408e3c
GS
1942 if (dtype != SVt_PVGV) {
1943 (void)SvOK_off(dstr);
1944 return;
1945 }
1946 break;
463ee0b2 1947 case SVt_IV:
aece5585
GA
1948 if (SvIOK(sstr)) {
1949 switch (dtype) {
1950 case SVt_NULL:
8990e307 1951 sv_upgrade(dstr, SVt_IV);
aece5585
GA
1952 break;
1953 case SVt_NV:
8990e307 1954 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
1955 break;
1956 case SVt_RV:
1957 case SVt_PV:
a0d0e21e 1958 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA
1959 break;
1960 }
1961 (void)SvIOK_only(dstr);
1962 SvIVX(dstr) = SvIVX(sstr);
1963 SvTAINT(dstr);
1964 return;
8990e307 1965 }
aece5585
GA
1966 goto undef_sstr;
1967
463ee0b2 1968 case SVt_NV:
aece5585
GA
1969 if (SvNOK(sstr)) {
1970 switch (dtype) {
1971 case SVt_NULL:
1972 case SVt_IV:
8990e307 1973 sv_upgrade(dstr, SVt_NV);
aece5585
GA
1974 break;
1975 case SVt_RV:
1976 case SVt_PV:
1977 case SVt_PVIV:
a0d0e21e 1978 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
1979 break;
1980 }
1981 SvNVX(dstr) = SvNVX(sstr);
1982 (void)SvNOK_only(dstr);
1983 SvTAINT(dstr);
1984 return;
8990e307 1985 }
aece5585
GA
1986 goto undef_sstr;
1987
ed6116ce 1988 case SVt_RV:
8990e307 1989 if (dtype < SVt_RV)
ed6116ce 1990 sv_upgrade(dstr, SVt_RV);
c07a80fd
PP
1991 else if (dtype == SVt_PVGV &&
1992 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
1993 sstr = SvRV(sstr);
a5f75d66
AD
1994 if (sstr == dstr) {
1995 if (curcop->cop_stash != GvSTASH(dstr))
1996 GvIMPORTED_on(dstr);
1997 GvMULTI_on(dstr);
1998 return;
1999 }
c07a80fd
PP
2000 goto glob_assign;
2001 }
ed6116ce 2002 break;
463ee0b2 2003 case SVt_PV:
fc36a67e 2004 case SVt_PVFM:
8990e307 2005 if (dtype < SVt_PV)
463ee0b2 2006 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
2007 break;
2008 case SVt_PVIV:
8990e307 2009 if (dtype < SVt_PVIV)
463ee0b2 2010 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW
2011 break;
2012 case SVt_PVNV:
8990e307 2013 if (dtype < SVt_PVNV)
463ee0b2 2014 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 2015 break;
4633a7c4
LW
2016 case SVt_PVAV:
2017 case SVt_PVHV:
2018 case SVt_PVCV:
4633a7c4
LW
2019 case SVt_PVIO:
2020 if (op)
2021 croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2022 op_name[op->op_type]);
2023 else
2024 croak("Bizarre copy of %s", sv_reftype(sstr, 0));
2025 break;
2026
79072805 2027 case SVt_PVGV:
8990e307 2028 if (dtype <= SVt_PVGV) {
c07a80fd 2029 glob_assign:
a5f75d66 2030 if (dtype != SVt_PVGV) {
a0d0e21e
LW
2031 char *name = GvNAME(sstr);
2032 STRLEN len = GvNAMELEN(sstr);
463ee0b2 2033 sv_upgrade(dstr, SVt_PVGV);
a0d0e21e 2034 sv_magic(dstr, dstr, '*', name, len);
85aff577 2035 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW
2036 GvNAME(dstr) = savepvn(name, len);
2037 GvNAMELEN(dstr) = len;
2038 SvFAKE_on(dstr); /* can coerce to non-glob */
2039 }
7bac28a0 2040 /* ahem, death to those who redefine active sort subs */
e788e7d3 2041 else if (curstackinfo->si_type == PERLSI_SORT
7bac28a0
PP
2042 && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr)))
2043 croak("Can't redefine active sort subroutine %s",
2044 GvNAME(dstr));
a0d0e21e 2045 (void)SvOK_off(dstr);
a5f75d66 2046 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 2047 gp_free((GV*)dstr);
79072805 2048 GvGP(dstr) = gp_ref(GvGP(sstr));
8990e307 2049 SvTAINT(dstr);
a5f75d66
AD
2050 if (curcop->cop_stash != GvSTASH(dstr))
2051 GvIMPORTED_on(dstr);
2052 GvMULTI_on(dstr);
79072805
LW
2053 return;
2054 }
2055 /* FALL THROUGH */
2056
2057 default:
973f89ab
CS
2058 if (SvGMAGICAL(sstr)) {
2059 mg_get(sstr);
2060 if (SvTYPE(sstr) != stype) {
2061 stype = SvTYPE(sstr);
2062 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2063 goto glob_assign;
2064 }
2065 }
ded42b9f
CS
2066 if (stype == SVt_PVLV)
2067 SvUPGRADE(dstr, SVt_PVNV);
2068 else
2069 SvUPGRADE(dstr, stype);
79072805
LW
2070 }
2071
8990e307
LW
2072 sflags = SvFLAGS(sstr);
2073
2074 if (sflags & SVf_ROK) {
2075 if (dtype >= SVt_PV) {
2076 if (dtype == SVt_PVGV) {
11343788 2077 dTHR;
8990e307
LW
2078 SV *sref = SvREFCNT_inc(SvRV(sstr));
2079 SV *dref = 0;
a5f75d66 2080 int intro = GvINTRO(dstr);
a0d0e21e
LW
2081
2082 if (intro) {
2083 GP *gp;
2084 GvGP(dstr)->gp_refcnt--;
a5f75d66 2085 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 2086 Newz(602,gp, 1, GP);
44a8e56a 2087 GvGP(dstr) = gp_ref(gp);
a0d0e21e
LW
2088 GvSV(dstr) = NEWSV(72,0);
2089 GvLINE(dstr) = curcop->cop_line;
1edc1566 2090 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 2091 }
a5f75d66 2092 GvMULTI_on(dstr);
8990e307
LW
2093 switch (SvTYPE(sref)) {
2094 case SVt_PVAV:
a0d0e21e
LW
2095 if (intro)
2096 SAVESPTR(GvAV(dstr));
2097 else
2098 dref = (SV*)GvAV(dstr);
8990e307 2099 GvAV(dstr) = (AV*)sref;
a5f75d66
AD
2100 if (curcop->cop_stash != GvSTASH(dstr))
2101 GvIMPORTED_AV_on(dstr);
8990e307
LW
2102 break;
2103 case SVt_PVHV:
a0d0e21e
LW
2104 if (intro)
2105 SAVESPTR(GvHV(dstr));
2106 else
2107 dref = (SV*)GvHV(dstr);
8990e307 2108 GvHV(dstr) = (HV*)sref;
a5f75d66
AD
2109 if (curcop->cop_stash != GvSTASH(dstr))
2110 GvIMPORTED_HV_on(dstr);
8990e307
LW
2111 break;
2112 case SVt_PVCV:
8ebc5c01
PP
2113 if (intro) {
2114 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2115 SvREFCNT_dec(GvCV(dstr));
2116 GvCV(dstr) = Nullcv;
68dc0745
PP
2117 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2118 sub_generation++;
8ebc5c01 2119 }
a0d0e21e 2120 SAVESPTR(GvCV(dstr));
8ebc5c01 2121 }
68dc0745
PP
2122 else
2123 dref = (SV*)GvCV(dstr);
2124 if (GvCV(dstr) != (CV*)sref) {
748a9306 2125 CV* cv = GvCV(dstr);
4633a7c4 2126 if (cv) {
68dc0745
PP
2127 if (!GvCVGEN((GV*)dstr) &&
2128 (CvROOT(cv) || CvXSUB(cv)))
2129 {
fe5e78ed
GS
2130 SV *const_sv = cv_const_sv(cv);
2131 bool const_changed = TRUE;
2132 if(const_sv)
2133 const_changed = sv_cmp(const_sv,
2134 op_const_sv(CvSTART((CV*)sref),
2135 Nullcv));
7bac28a0
PP
2136 /* ahem, death to those who redefine
2137 * active sort subs */
e788e7d3 2138 if (curstackinfo->si_type == PERLSI_SORT &&
7bac28a0
PP
2139 sortcop == CvSTART(cv))
2140 croak(
2141 "Can't redefine active sort subroutine %s",
2142 GvENAME((GV*)dstr));
fe5e78ed 2143 if (dowarn || (const_changed && const_sv)) {
2f34f9d4
IZ
2144 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2145 && HvNAME(GvSTASH(CvGV(cv)))
2146 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2147 "autouse")))
fe5e78ed
GS
2148 warn(const_sv ?
2149 "Constant subroutine %s redefined"
2150 : "Subroutine %s redefined",
2f34f9d4
IZ
2151 GvENAME((GV*)dstr));
2152 }
9607fc9c 2153 }
3fe9a6f1
PP
2154 cv_ckproto(cv, (GV*)dstr,
2155 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 2156 }
a5f75d66 2157 GvCV(dstr) = (CV*)sref;
7a4c00b4 2158 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 2159 GvASSUMECV_on(dstr);
8ebc5c01 2160 sub_generation++;
a5f75d66
AD
2161 }
2162 if (curcop->cop_stash != GvSTASH(dstr))
2163 GvIMPORTED_CV_on(dstr);
8990e307 2164 break;
91bba347
LW
2165 case SVt_PVIO:
2166 if (intro)
2167 SAVESPTR(GvIOp(dstr));
2168 else
2169 dref = (SV*)GvIOp(dstr);
2170 GvIOp(dstr) = (IO*)sref;
2171 break;
8990e307 2172 default:
a0d0e21e
LW
2173 if (intro)
2174 SAVESPTR(GvSV(dstr));
2175 else
2176 dref = (SV*)GvSV(dstr);
8990e307 2177 GvSV(dstr) = sref;
a5f75d66
AD
2178 if (curcop->cop_stash != GvSTASH(dstr))
2179 GvIMPORTED_SV_on(dstr);
8990e307
LW
2180 break;
2181 }
2182 if (dref)
2183 SvREFCNT_dec(dref);
a0d0e21e
LW
2184 if (intro)
2185 SAVEFREESV(sref);
8990e307
LW
2186 SvTAINT(dstr);
2187 return;
2188 }
a0d0e21e 2189 if (SvPVX(dstr)) {
760ac839 2190 (void)SvOOK_off(dstr); /* backoff */
8990e307 2191 Safefree(SvPVX(dstr));
a0d0e21e
LW
2192 SvLEN(dstr)=SvCUR(dstr)=0;
2193 }
8990e307 2194 }
a0d0e21e 2195 (void)SvOK_off(dstr);
8990e307 2196 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 2197 SvROK_on(dstr);
8990e307 2198 if (sflags & SVp_NOK) {
ed6116ce
LW
2199 SvNOK_on(dstr);
2200 SvNVX(dstr) = SvNVX(sstr);
2201 }
8990e307 2202 if (sflags & SVp_IOK) {
a0d0e21e 2203 (void)SvIOK_on(dstr);
ed6116ce
LW
2204 SvIVX(dstr) = SvIVX(sstr);
2205 }
a0d0e21e
LW
2206#ifdef OVERLOAD
2207 if (SvAMAGIC(sstr)) {
2208 SvAMAGIC_on(dstr);
2209 }
2210#endif /* OVERLOAD */
ed6116ce 2211 }
8990e307 2212 else if (sflags & SVp_POK) {
79072805
LW
2213
2214 /*
2215 * Check to see if we can just swipe the string. If so, it's a
2216 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW
2217 * It might even be a win on short strings if SvPVX(dstr)
2218 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW
2219 */
2220
ff68c719 2221 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 2222 SvREFCNT(sstr) == 1 && /* and no other references to it? */
a5f75d66
AD
2223 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2224 {
adbc6bb1 2225 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD
2226 if (SvOOK(dstr)) {
2227 SvFLAGS(dstr) &= ~SVf_OOK;
2228 Safefree(SvPVX(dstr) - SvIVX(dstr));
2229 }
2230 else
2231 Safefree(SvPVX(dstr));
79072805 2232 }
a5f75d66 2233 (void)SvPOK_only(dstr);
463ee0b2 2234 SvPV_set(dstr, SvPVX(sstr));
79072805
LW
2235 SvLEN_set(dstr, SvLEN(sstr));
2236 SvCUR_set(dstr, SvCUR(sstr));
79072805 2237 SvTEMP_off(dstr);
a5f75d66 2238 (void)SvOK_off(sstr);
79072805
LW
2239 SvPV_set(sstr, Nullch);
2240 SvLEN_set(sstr, 0);
a5f75d66
AD
2241 SvCUR_set(sstr, 0);
2242 SvTEMP_off(sstr);
79072805
LW
2243 }
2244 else { /* have to copy actual string */
8990e307
LW
2245 STRLEN len = SvCUR(sstr);
2246
2247 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2248 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2249 SvCUR_set(dstr, len);
2250 *SvEND(dstr) = '\0';
a0d0e21e 2251 (void)SvPOK_only(dstr);
79072805
LW
2252 }
2253 /*SUPPRESS 560*/
8990e307 2254 if (sflags & SVp_NOK) {
79072805 2255 SvNOK_on(dstr);
463ee0b2 2256 SvNVX(dstr) = SvNVX(sstr);
79072805 2257 }
8990e307 2258 if (sflags & SVp_IOK) {
a0d0e21e 2259 (void)SvIOK_on(dstr);
463ee0b2 2260 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2261 }
2262 }
8990e307 2263 else if (sflags & SVp_NOK) {
463ee0b2 2264 SvNVX(dstr) = SvNVX(sstr);
a0d0e21e 2265 (void)SvNOK_only(dstr);
79072805 2266 if (SvIOK(sstr)) {
a0d0e21e 2267 (void)SvIOK_on(dstr);
463ee0b2 2268 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2269 }
2270 }
8990e307 2271 else if (sflags & SVp_IOK) {
a0d0e21e 2272 (void)SvIOK_only(dstr);
463ee0b2 2273 SvIVX(dstr) = SvIVX(sstr);
79072805
LW
2274 }
2275 else {
20408e3c
GS
2276 if (dtype == SVt_PVGV) {
2277 if (dowarn)
2278 warn("Undefined value assigned to typeglob");
2279 }
2280 else
2281 (void)SvOK_off(dstr);
a0d0e21e 2282 }
463ee0b2 2283 SvTAINT(dstr);
79072805
LW
2284}
2285
2286void
ef50df4b
GS
2287sv_setsv_mg(SV *dstr, register SV *sstr)
2288{
2289 sv_setsv(dstr,sstr);
2290 SvSETMAGIC(dstr);
2291}
2292
2293void
8ac85365 2294sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len)
79072805 2295{
c6f8c383 2296 register char *dptr;
4561caa4
CS
2297 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2298 elicit a warning, but it won't hurt. */
2213622d 2299 SV_CHECK_THINKFIRST(sv);
463ee0b2 2300 if (!ptr) {
a0d0e21e 2301 (void)SvOK_off(sv);
463ee0b2
LW
2302 return;
2303 }
c07a80fd
PP
2304 if (SvTYPE(sv) >= SVt_PV) {
2305 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2306 sv_unglob(sv);
2307 }
c6f8c383
GA
2308 else
2309 sv_upgrade(sv, SVt_PV);
2310
79072805 2311 SvGROW(sv, len + 1);
c6f8c383
GA
2312 dptr = SvPVX(sv);
2313 Move(ptr,dptr,len,char);
2314 dptr[len] = '\0';
79072805 2315 SvCUR_set(sv, len);
a0d0e21e 2316 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2317 SvTAINT(sv);
79072805
LW
2318}
2319
2320void
ef50df4b
GS
2321sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
2322{
2323 sv_setpvn(sv,ptr,len);
2324 SvSETMAGIC(sv);
2325}
2326
2327void
8ac85365 2328sv_setpv(register SV *sv, register const char *ptr)
79072805
LW
2329{
2330 register STRLEN len;
2331
2213622d 2332 SV_CHECK_THINKFIRST(sv);
463ee0b2 2333 if (!ptr) {
a0d0e21e 2334 (void)SvOK_off(sv);
463ee0b2
LW
2335 return;
2336 }
79072805 2337 len = strlen(ptr);
c07a80fd
PP
2338 if (SvTYPE(sv) >= SVt_PV) {
2339 if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2340 sv_unglob(sv);
2341 }
c6f8c383
GA
2342 else
2343 sv_upgrade(sv, SVt_PV);
2344
79072805 2345 SvGROW(sv, len + 1);
463ee0b2 2346 Move(ptr,SvPVX(sv),len+1,char);
79072805 2347 SvCUR_set(sv, len);
a0d0e21e 2348 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2
LW
2349 SvTAINT(sv);
2350}
2351
2352void
ef50df4b
GS
2353sv_setpv_mg(register SV *sv, register const char *ptr)
2354{
2355 sv_setpv(sv,ptr);
2356 SvSETMAGIC(sv);
2357}
2358
2359void
8ac85365 2360sv_usepvn(register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 2361{
2213622d 2362 SV_CHECK_THINKFIRST(sv);
c6f8c383 2363 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 2364 if (!ptr) {
a0d0e21e 2365 (void)SvOK_off(sv);
463ee0b2
LW
2366 return;
2367 }
2368 if (SvPVX(sv))
2369 Safefree(SvPVX(sv));
2370 Renew(ptr, len+1, char);
2371 SvPVX(sv) = ptr;
2372 SvCUR_set(sv, len);
2373 SvLEN_set(sv, len+1);
2374 *SvEND(sv) = '\0';
a0d0e21e 2375 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2376 SvTAINT(sv);
79072805
LW
2377}
2378
ef50df4b
GS
2379void
2380sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len)
2381{
51c1089b 2382 sv_usepvn(sv,ptr,len);
ef50df4b
GS
2383 SvSETMAGIC(sv);
2384}
2385
76e3520e 2386STATIC void
8ac85365 2387sv_check_thinkfirst(register SV *sv)
0f15f207 2388{
2213622d
GA
2389 if (SvREADONLY(sv)) {
2390 dTHR;
2391 if (curcop != &compiling)
2392 croak(no_modify);
0f15f207 2393 }
2213622d
GA
2394 if (SvROK(sv))
2395 sv_unref(sv);
0f15f207
MB
2396}
2397
79072805 2398void
8ac85365
NIS
2399sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2400
2401
79072805
LW
2402{
2403 register STRLEN delta;
2404
a0d0e21e 2405 if (!ptr || !SvPOKp(sv))
79072805 2406 return;
2213622d 2407 SV_CHECK_THINKFIRST(sv);
79072805
LW
2408 if (SvTYPE(sv) < SVt_PVIV)
2409 sv_upgrade(sv,SVt_PVIV);
2410
2411 if (!SvOOK(sv)) {
463ee0b2 2412 SvIVX(sv) = 0;
79072805
LW
2413 SvFLAGS(sv) |= SVf_OOK;
2414 }
8990e307 2415 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
463ee0b2 2416 delta = ptr - SvPVX(sv);
79072805
LW
2417 SvLEN(sv) -= delta;
2418 SvCUR(sv) -= delta;
463ee0b2
LW
2419 SvPVX(sv) += delta;
2420 SvIVX(sv) += delta;
79072805
LW
2421}
2422
2423void
8ac85365 2424sv_catpvn(register SV *sv, register char *ptr, register STRLEN len)
79072805 2425{
463ee0b2 2426 STRLEN tlen;
748a9306 2427 char *junk;
a0d0e21e 2428
748a9306 2429 junk = SvPV_force(sv, tlen);
463ee0b2 2430 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
2431 if (ptr == junk)
2432 ptr = SvPVX(sv);
463ee0b2 2433 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW
2434 SvCUR(sv) += len;
2435 *SvEND(sv) = '\0';
a0d0e21e 2436 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2437 SvTAINT(sv);
79072805
LW
2438}
2439
2440void
ef50df4b
GS
2441sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len)
2442{
2443 sv_catpvn(sv,ptr,len);
2444 SvSETMAGIC(sv);
2445}
2446
2447void
8ac85365 2448sv_catsv(SV *dstr, register SV *sstr)
79072805
LW
2449{
2450 char *s;
463ee0b2 2451 STRLEN len;
79072805
LW
2452 if (!sstr)
2453 return;
463ee0b2
LW
2454 if (s = SvPV(sstr, len))
2455 sv_catpvn(dstr,s,len);
79072805
LW
2456}
2457
2458void
ef50df4b
GS
2459sv_catsv_mg(SV *dstr, register SV *sstr)
2460{
2461 sv_catsv(dstr,sstr);
2462 SvSETMAGIC(dstr);
2463}
2464
2465void
8ac85365 2466sv_catpv(register SV *sv, register char *ptr)
79072805
LW
2467{
2468 register STRLEN len;
463ee0b2 2469 STRLEN tlen;
748a9306 2470 char *junk;
79072805 2471
79072805
LW
2472 if (!ptr)
2473 return;
748a9306 2474 junk = SvPV_force(sv, tlen);
79072805 2475 len = strlen(ptr);
463ee0b2 2476 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
2477 if (ptr == junk)
2478 ptr = SvPVX(sv);
463ee0b2 2479 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 2480 SvCUR(sv) += len;
a0d0e21e 2481 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2482 SvTAINT(sv);
79072805
LW
2483}
2484
ef50df4b
GS
2485void
2486sv_catpv_mg(register SV *sv, register char *ptr)
2487{
51c1089b 2488 sv_catpv(sv,ptr);
ef50df4b
GS
2489 SvSETMAGIC(sv);
2490}
2491
79072805 2492SV *
8ac85365 2493newSV(STRLEN len)
79072805
LW
2494{
2495 register SV *sv;
2496
4561caa4 2497 new_SV(sv);
8990e307
LW
2498 SvANY(sv) = 0;
2499 SvREFCNT(sv) = 1;
2500 SvFLAGS(sv) = 0;
79072805
LW
2501 if (len) {
2502 sv_upgrade(sv, SVt_PV);
2503 SvGROW(sv, len + 1);
2504 }
2505 return sv;
2506}
2507
1edc1566
PP
2508/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2509
79072805 2510void
8ac85365 2511sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
79072805
LW
2512{
2513 MAGIC* mg;
2514
0f15f207
MB
2515 if (SvREADONLY(sv)) {
2516 dTHR;
2517 if (curcop != &compiling && !strchr("gBf", how))
2518 croak(no_modify);
2519 }
4633a7c4 2520 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW
2521 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2522 if (how == 't')
565764a8 2523 mg->mg_len |= 1;
463ee0b2 2524 return;
748a9306 2525 }
463ee0b2
LW
2526 }
2527 else {
c6f8c383 2528 (void)SvUPGRADE(sv, SVt_PVMG);
463ee0b2 2529 }
79072805
LW
2530 Newz(702,mg, 1, MAGIC);
2531 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 2532
79072805 2533 SvMAGIC(sv) = mg;
c277df42 2534 if (!obj || obj == sv || how == '#' || how == 'r')
8990e307 2535 mg->mg_obj = obj;
85e6fe83 2536 else {
11343788 2537 dTHR;
8990e307 2538 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW
2539 mg->mg_flags |= MGf_REFCOUNTED;
2540 }
79072805 2541 mg->mg_type = how;
565764a8 2542 mg->mg_len = namlen;
1edc1566
PP
2543 if (name)
2544 if (namlen >= 0)
2545 mg->mg_ptr = savepvn(name, namlen);
c6ee37c5 2546 else if (namlen == HEf_SVKEY)
1edc1566
PP
2547 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2548
79072805
LW
2549 switch (how) {
2550 case 0:
2551 mg->mg_virtual = &vtbl_sv;
2552 break;
a0d0e21e
LW
2553#ifdef OVERLOAD
2554 case 'A':
2555 mg->mg_virtual = &vtbl_amagic;
2556 break;
2557 case 'a':
2558 mg->mg_virtual = &vtbl_amagicelem;
2559 break;
2560 case 'c':
2561 mg->mg_virtual = 0;
2562 break;
2563#endif /* OVERLOAD */
79072805
LW
2564 case 'B':
2565 mg->mg_virtual = &vtbl_bm;
2566 break;
79072805
LW
2567 case 'E':
2568 mg->mg_virtual = &vtbl_env;
2569 break;
55497cff
PP
2570 case 'f':
2571 mg->mg_virtual = &vtbl_fm;
2572 break;
79072805
LW
2573 case 'e':
2574 mg->mg_virtual = &vtbl_envelem;
2575 break;
93a17b20
LW
2576 case 'g':
2577 mg->mg_virtual = &vtbl_mglob;
2578 break;
463ee0b2
LW
2579 case 'I':
2580 mg->mg_virtual = &vtbl_isa;
2581 break;
2582 case 'i':
2583 mg->mg_virtual = &vtbl_isaelem;
2584 break;
16660edb
PP
2585 case 'k':
2586 mg->mg_virtual = &vtbl_nkeys;
2587 break;
79072805 2588 case 'L':
a0d0e21e 2589 SvRMAGICAL_on(sv);
93a17b20
LW
2590 mg->mg_virtual = 0;
2591 break;
2592 case 'l':
79072805
LW
2593 mg->mg_virtual = &vtbl_dbline;
2594 break;
f93b4edd
MB
2595#ifdef USE_THREADS
2596 case 'm':
2597 mg->mg_virtual = &vtbl_mutex;
2598 break;
2599#endif /* USE_THREADS */
36477c24 2600#ifdef USE_LOCALE_COLLATE
bbce6d69
PP
2601 case 'o':
2602 mg->mg_virtual = &vtbl_collxfrm;
2603 break;
36477c24 2604#endif /* USE_LOCALE_COLLATE */
463ee0b2
LW
2605 case 'P':
2606 mg->mg_virtual = &vtbl_pack;
2607 break;
2608 case 'p':
a0d0e21e 2609 case 'q':
463ee0b2
LW
2610 mg->mg_virtual = &vtbl_packelem;
2611 break;
c277df42
IZ
2612 case 'r':
2613 mg->mg_virtual = &vtbl_regexp;
2614 break;
79072805
LW
2615 case 'S':
2616 mg->mg_virtual = &vtbl_sig;
2617 break;
2618 case 's':
2619 mg->mg_virtual = &vtbl_sigelem;
2620 break;
463ee0b2
LW
2621 case 't':
2622 mg->mg_virtual = &vtbl_taint;
565764a8 2623 mg->mg_len = 1;
463ee0b2 2624 break;
79072805
LW
2625 case 'U':
2626 mg->mg_virtual = &vtbl_uvar;
2627 break;
2628 case 'v':
2629 mg->mg_virtual = &vtbl_vec;
2630 break;
2631 case 'x':
2632 mg->mg_virtual = &vtbl_substr;
2633 break;
5f05dabc 2634 case 'y':
68dc0745 2635 mg->mg_virtual = &vtbl_defelem;
5f05dabc 2636 break;
79072805
LW
2637 case '*':
2638 mg->mg_virtual = &vtbl_glob;
2639 break;
2640 case '#':
2641 mg->mg_virtual = &vtbl_arylen;
2642 break;
a0d0e21e
LW
2643 case '.':
2644 mg->mg_virtual = &vtbl_pos;
2645 break;
4633a7c4
LW
2646 case '~': /* Reserved for use by extensions not perl internals. */
2647 /* Useful for attaching extension internal data to perl vars. */
2648 /* Note that multiple extensions may clash if magical scalars */
2649 /* etc holding private data from one are passed to another. */
2650 SvRMAGICAL_on(sv);
a0d0e21e 2651 break;
79072805 2652 default:
463ee0b2
LW
2653 croak("Don't know how to handle magic of type '%c'", how);
2654 }
8990e307
LW
2655 mg_magical(sv);
2656 if (SvGMAGICAL(sv))
2657 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW
2658}
2659
2660int
8ac85365 2661sv_unmagic(SV *sv, int type)
463ee0b2
LW
2662{
2663 MAGIC* mg;
2664 MAGIC** mgp;
91bba347 2665 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW
2666 return 0;
2667 mgp = &SvMAGIC(sv);
2668 for (mg = *mgp; mg; mg = *mgp) {
2669 if (mg->mg_type == type) {
2670 MGVTBL* vtbl = mg->mg_virtual;
2671 *mgp = mg->mg_moremagic;
76e3520e
GS
2672 if (vtbl && (vtbl->svt_free != NULL))
2673 (VTBL->svt_free)(sv, mg);
463ee0b2 2674 if (mg->mg_ptr && mg->mg_type != 'g')
565764a8 2675 if (mg->mg_len >= 0)
1edc1566 2676 Safefree(mg->mg_ptr);
565764a8 2677 else if (mg->mg_len == HEf_SVKEY)
1edc1566 2678 SvREFCNT_dec((SV*)mg->mg_ptr);
a0d0e21e
LW
2679 if (mg->mg_flags & MGf_REFCOUNTED)
2680 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW
2681 Safefree(mg);
2682 }
2683 else
2684 mgp = &mg->mg_moremagic;
79072805 2685 }
91bba347 2686 if (!SvMAGIC(sv)) {
463ee0b2 2687 SvMAGICAL_off(sv);
8990e307 2688 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW
2689 }
2690
2691 return 0;
79072805
LW
2692}
2693
2694void
8ac85365 2695sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
79072805
LW
2696{
2697 register char *big;
2698 register char *mid;
2699 register char *midend;
2700 register char *bigend;
2701 register I32 i;
6ff81951
GS
2702 STRLEN curlen;
2703
79072805 2704
8990e307
LW
2705 if (!bigstr)
2706 croak("Can't modify non-existent substring");
6ff81951
GS
2707 SvPV_force(bigstr, curlen);
2708 if (offset + len > curlen) {
2709 SvGROW(bigstr, offset+len+1);
2710 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2711 SvCUR_set(bigstr, offset+len);
2712 }
79072805
LW
2713
2714 i = littlelen - len;
2715 if (i > 0) { /* string might grow */
a0d0e21e 2716 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW
2717 mid = big + offset + len;
2718 midend = bigend = big + SvCUR(bigstr);
2719 bigend += i;
2720 *bigend = '\0';
2721 while (midend > mid) /* shove everything down */
2722 *--bigend = *--midend;
2723 Move(little,big+offset,littlelen,char);
2724 SvCUR(bigstr) += i;
2725 SvSETMAGIC(bigstr);
2726 return;
2727 }
2728 else if (i == 0) {
463ee0b2 2729 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW
2730 SvSETMAGIC(bigstr);
2731 return;
2732 }
2733
463ee0b2 2734 big = SvPVX(bigstr);
79072805
LW
2735 mid = big + offset;
2736 midend = mid + len;
2737 bigend = big + SvCUR(bigstr);
2738
2739 if (midend > bigend)
463ee0b2 2740 croak("panic: sv_insert");
79072805
LW
2741
2742 if (mid - big > bigend - midend) { /* faster to shorten from end */
2743 if (littlelen) {
2744 Move(little, mid, littlelen,char);
2745 mid += littlelen;
2746 }
2747 i = bigend - midend;
2748 if (i > 0) {
2749 Move(midend, mid, i,char);
2750 mid += i;
2751 }
2752 *mid = '\0';
2753 SvCUR_set(bigstr, mid - big);
2754 }
2755 /*SUPPRESS 560*/
2756 else if (i = mid - big) { /* faster from front */
2757 midend -= littlelen;
2758 mid = midend;
2759 sv_chop(bigstr,midend-i);
2760 big += i;
2761 while (i--)
2762 *--midend = *--big;
2763 if (littlelen)
2764 Move(little, mid, littlelen,char);
2765 }
2766 else if (littlelen) {
2767 midend -= littlelen;
2768 sv_chop(bigstr,midend);
2769 Move(little,midend,littlelen,char);
2770 }
2771 else {
2772 sv_chop(bigstr,midend);
2773 }
2774 SvSETMAGIC(bigstr);
2775}
2776
2777/* make sv point to what nstr did */
2778
2779void
8ac85365 2780sv_replace(register SV *sv, register SV *nsv)
79072805
LW
2781{
2782 U32 refcnt = SvREFCNT(sv);
2213622d 2783 SV_CHECK_THINKFIRST(sv);
79072805
LW
2784 if (SvREFCNT(nsv) != 1)
2785 warn("Reference miscount in sv_replace()");
93a17b20 2786 if (SvMAGICAL(sv)) {
a0d0e21e
LW
2787 if (SvMAGICAL(nsv))
2788 mg_free(nsv);
2789 else
2790 sv_upgrade(nsv, SVt_PVMG);
93a17b20 2791 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 2792 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW
2793 SvMAGICAL_off(sv);
2794 SvMAGIC(sv) = 0;
2795 }
79072805
LW
2796 SvREFCNT(sv) = 0;
2797 sv_clear(sv);
477f5d66 2798 assert(!SvREFCNT(sv));
79072805
LW
2799 StructCopy(nsv,sv,SV);
2800 SvREFCNT(sv) = refcnt;
1edc1566 2801 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 2802 del_SV(nsv);
79072805
LW
2803}
2804
2805void
8ac85365 2806sv_clear(register SV *sv)
79072805 2807{
ec12f114 2808 HV* stash;
79072805
LW
2809 assert(sv);
2810 assert(SvREFCNT(sv) == 0);
2811
ed6116ce 2812 if (SvOBJECT(sv)) {
e858de61 2813 dTHR;
a0d0e21e 2814 if (defstash) { /* Still have a symbol table? */
4e35701f 2815 djSP;
8ebc5c01 2816 GV* destructor;
837485b6 2817 SV tmpref;
a0d0e21e 2818
837485b6
GS
2819 Zero(&tmpref, 1, SV);
2820 sv_upgrade(&tmpref, SVt_RV);
2821 SvROK_on(&tmpref);
2822 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2823 SvREFCNT(&tmpref) = 1;
8ebc5c01 2824
4e8e7886
GS
2825 do {
2826 stash = SvSTASH(sv);
2827 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2828 if (destructor) {
2829 ENTER;
e788e7d3 2830 PUSHSTACKi(PERLSI_DESTROY);
837485b6 2831 SvRV(&tmpref) = SvREFCNT_inc(sv);
4e8e7886
GS
2832 EXTEND(SP, 2);
2833 PUSHMARK(SP);
837485b6 2834 PUSHs(&tmpref);
4e8e7886
GS
2835 PUTBACK;
2836 perl_call_sv((SV*)GvCV(destructor),
2837 G_DISCARD|G_EVAL|G_KEEPERR);
2838 SvREFCNT(sv)--;
d3acc0f7 2839 POPSTACK;
4e8e7886
GS
2840 LEAVE;
2841 }
2842 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
8ebc5c01 2843
837485b6 2844 del_XRV(SvANY(&tmpref));
a0d0e21e 2845 }
4e8e7886 2846
a0d0e21e 2847 if (SvOBJECT(sv)) {
4e8e7886 2848 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
a0d0e21e
LW
2849 SvOBJECT_off(sv); /* Curse the object. */
2850 if (SvTYPE(sv) != SVt_PVIO)
2851 --sv_objcount; /* XXX Might want something more general */
2852 }
1edc1566 2853 if (SvREFCNT(sv)) {
477f5d66
CS
2854 if (in_clean_objs)
2855 croak("DESTROY created new reference to dead object");
2856 /* DESTROY gave object new lease on life */
2857 return;
1edc1566 2858 }
463ee0b2 2859 }
c07a80fd 2860 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 2861 mg_free(sv);
ec12f114 2862 stash = NULL;
79072805 2863 switch (SvTYPE(sv)) {
8990e307 2864 case SVt_PVIO:
5f05dabc
PP
2865 if (IoIFP(sv) != PerlIO_stdin() &&
2866 IoIFP(sv) != PerlIO_stdout() &&
2867 IoIFP(sv) != PerlIO_stderr())
2868 io_close((IO*)sv);
8990e307
LW
2869 Safefree(IoTOP_NAME(sv));
2870 Safefree(IoFMT_NAME(sv));
2871 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 2872 /* FALL THROUGH */
79072805 2873 case SVt_PVBM:
a0d0e21e 2874 goto freescalar;
79072805 2875 case SVt_PVCV:
748a9306 2876 case SVt_PVFM:
85e6fe83 2877 cv_undef((CV*)sv);
a0d0e21e 2878 goto freescalar;
79072805 2879 case SVt_PVHV:
85e6fe83 2880 hv_undef((HV*)sv);
a0d0e21e 2881 break;
79072805 2882 case SVt_PVAV:
85e6fe83 2883 av_undef((AV*)sv);
a0d0e21e
LW
2884 break;
2885 case SVt_PVGV:
1edc1566 2886 gp_free((GV*)sv);
a0d0e21e 2887 Safefree(GvNAME(sv));
ec12f114
JPC
2888 /* cannot decrease stash refcount yet, as we might recursively delete
2889 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
2890 of stash until current sv is completely gone.
2891 -- JohnPC, 27 Mar 1998 */
2892 stash = GvSTASH(sv);
a0d0e21e 2893 /* FALL THROUGH */
79072805 2894 case SVt_PVLV:
79072805 2895 case SVt_PVMG:
79072805
LW
2896 case SVt_PVNV:
2897 case SVt_PVIV:
a0d0e21e
LW
2898 freescalar:
2899 (void)SvOOK_off(sv);
79072805
LW
2900 /* FALL THROUGH */
2901 case SVt_PV:
a0d0e21e 2902 case SVt_RV:
8990e307
LW
2903 if (SvROK(sv))
2904 SvREFCNT_dec(SvRV(sv));
1edc1566 2905 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 2906 Safefree(SvPVX(sv));
79072805 2907 break;
a0d0e21e 2908/*
79072805 2909 case SVt_NV:
79072805 2910 case SVt_IV:
79072805
LW
2911 case SVt_NULL:
2912 break;
a0d0e21e 2913*/
79072805
LW
2914 }
2915
2916 switch (SvTYPE(sv)) {
2917 case SVt_NULL:
2918 break;
79072805
LW
2919 case SVt_IV:
2920 del_XIV(SvANY(sv));
2921 break;
2922 case SVt_NV:
2923 del_XNV(SvANY(sv));
2924 break;
ed6116ce
LW
2925 case SVt_RV:
2926 del_XRV(SvANY(sv));
2927 break;
79072805
LW
2928 case SVt_PV:
2929 del_XPV(SvANY(sv));
2930 break;
2931 case SVt_PVIV:
2932 del_XPVIV(SvANY(sv));
2933 break;
2934 case SVt_PVNV:
2935 del_XPVNV(SvANY(sv));
2936 break;
2937 case SVt_PVMG:
2938 del_XPVMG(SvANY(sv));
2939 break;
2940 case SVt_PVLV:
2941 del_XPVLV(SvANY(sv));
2942 break;
2943 case SVt_PVAV:
2944 del_XPVAV(SvANY(sv));
2945 break;
2946 case SVt_PVHV:
2947 del_XPVHV(SvANY(sv));
2948 break;
2949 case SVt_PVCV:
2950 del_XPVCV(SvANY(sv));
2951 break;
2952 case SVt_PVGV:
2953 del_XPVGV(SvANY(sv));
ec12f114
JPC
2954 /* code duplication for increased performance. */
2955 SvFLAGS(sv) &= SVf_BREAK;
2956 SvFLAGS(sv) |= SVTYPEMASK;
2957 /* decrease refcount of the stash that owns this GV, if any */
2958 if (stash)
2959 SvREFCNT_dec(stash);
2960 return; /* not break, SvFLAGS reset already happened */
79072805
LW
2961 case SVt_PVBM:
2962 del_XPVBM(SvANY(sv));
2963 break;
2964 case SVt_PVFM:
2965 del_XPVFM(SvANY(sv));
2966 break;
8990e307
LW
2967 case SVt_PVIO:
2968 del_XPVIO(SvANY(sv));
2969 break;
79072805 2970 }
a0d0e21e 2971 SvFLAGS(sv) &= SVf_BREAK;
8990e307 2972 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW
2973}
2974
2975SV *
8ac85365 2976sv_newref(SV *sv)
79072805 2977{
463ee0b2 2978 if (sv)
dce16143 2979 ATOMIC_INC(SvREFCNT(sv));
79072805
LW
2980 return sv;
2981}
2982
2983void
8ac85365 2984sv_free(SV *sv)
79072805 2985{
dce16143
MB
2986 int refcount_is_zero;
2987
79072805
LW
2988 if (!sv)
2989 return;
a0d0e21e
LW
2990 if (SvREFCNT(sv) == 0) {
2991 if (SvFLAGS(sv) & SVf_BREAK)
2992 return;
1edc1566
PP
2993 if (in_clean_all) /* All is fair */
2994 return;
d689ffdd
JP
2995 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
2996 /* make sure SvREFCNT(sv)==0 happens very seldom */
2997 SvREFCNT(sv) = (~(U32)0)/2;
2998 return;
2999 }
79072805
LW
3000 warn("Attempt to free unreferenced scalar");
3001 return;
3002 }
dce16143
MB
3003 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3004 if (!refcount_is_zero)
8990e307 3005 return;
463ee0b2
LW
3006#ifdef DEBUGGING
3007 if (SvTEMP(sv)) {
0f15f207 3008 warn("Attempt to free temp prematurely: %s", SvPEEK(sv));
79072805 3009 return;
79072805 3010 }
463ee0b2 3011#endif
d689ffdd
JP
3012 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3013 /* make sure SvREFCNT(sv)==0 happens very seldom */
3014 SvREFCNT(sv) = (~(U32)0)/2;
3015 return;
3016 }
79072805 3017 sv_clear(sv);
477f5d66
CS
3018 if (! SvREFCNT(sv))
3019 del_SV(sv);
79072805
LW
3020}
3021
3022STRLEN
8ac85365 3023sv_len(register SV *sv)
79072805 3024{
748a9306 3025 char *junk;
463ee0b2 3026 STRLEN len;
79072805
LW
3027
3028 if (!sv)
3029 return 0;
3030
8990e307 3031 if (SvGMAGICAL(sv))
565764a8 3032 len = mg_length(sv);
8990e307 3033 else
748a9306 3034 junk = SvPV(sv, len);
463ee0b2 3035 return len;
79072805
LW
3036}
3037
3038I32
8ac85365 3039sv_eq(register SV *str1, register SV *str2)
79072805
LW
3040{
3041 char *pv1;
463ee0b2 3042 STRLEN cur1;
79072805 3043 char *pv2;
463ee0b2 3044 STRLEN cur2;
79072805
LW
3045
3046 if (!str1) {
3047 pv1 = "";
3048 cur1 = 0;
3049 }
463ee0b2
LW
3050 else
3051 pv1 = SvPV(str1, cur1);
79072805
LW
3052
3053 if (!str2)
3054 return !cur1;
463ee0b2
LW
3055 else
3056 pv2 = SvPV(str2, cur2);
79072805
LW
3057
3058 if (cur1 != cur2)
3059 return 0;
3060
36477c24 3061 return memEQ(pv1, pv2, cur1);
79072805
LW
3062}
3063
3064I32
8ac85365 3065sv_cmp(register SV *str1, register SV *str2)
79072805 3066{
bbce6d69 3067 STRLEN cur1 = 0;
8ac85365 3068 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
bbce6d69 3069 STRLEN cur2 = 0;
8ac85365 3070 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
79072805 3071 I32 retval;
79072805 3072
bbce6d69
PP
3073 if (!cur1)
3074 return cur2 ? -1 : 0;
16660edb 3075
bbce6d69
PP
3076 if (!cur2)
3077 return 1;
79072805 3078
bbce6d69 3079 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
16660edb 3080
bbce6d69
PP
3081 if (retval)
3082 return retval < 0 ? -1 : 1;
16660edb 3083
bbce6d69
PP
3084 if (cur1 == cur2)
3085 return 0;
3086 else
3087 return cur1 < cur2 ? -1 : 1;
3088}
16660edb 3089
bbce6d69 3090I32
8ac85365 3091sv_cmp_locale(register SV *sv1, register SV *sv2)
bbce6d69 3092{
36477c24 3093#ifdef USE_LOCALE_COLLATE
16660edb 3094
bbce6d69
PP
3095 char *pv1, *pv2;
3096 STRLEN len1, len2;
3097 I32 retval;
16660edb 3098
bbce6d69
PP
3099 if (collation_standard)
3100 goto raw_compare;
16660edb 3101
bbce6d69 3102 len1 = 0;
8ac85365 3103 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
bbce6d69 3104 len2 = 0;
8ac85365 3105 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
16660edb 3106
bbce6d69
PP
3107 if (!pv1 || !len1) {
3108 if (pv2 && len2)
3109 return -1;
3110 else
3111 goto raw_compare;
3112 }
3113 else {
3114 if (!pv2 || !len2)
3115 return 1;
3116 }
16660edb 3117
bbce6d69 3118 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 3119
bbce6d69 3120 if (retval)
16660edb
PP
3121 return retval < 0 ? -1 : 1;
3122
bbce6d69
PP
3123 /*
3124 * When the result of collation is equality, that doesn't mean
3125 * that there are no differences -- some locales exclude some
3126 * characters from consideration. So to avoid false equalities,
3127 * we use the raw string as a tiebreaker.
3128 */
16660edb 3129
bbce6d69
PP
3130 raw_compare:
3131 /* FALL THROUGH */
16660edb 3132
36477c24 3133#endif /* USE_LOCALE_COLLATE */
16660edb 3134
bbce6d69
PP
3135 return sv_cmp(sv1, sv2);
3136}
79072805 3137
36477c24 3138#ifdef USE_LOCALE_COLLATE
7a4c00b4
PP
3139/*
3140 * Any scalar variable may carry an 'o' magic that contains the
3141 * scalar data of the variable transformed to such a format that
3142 * a normal memory comparison can be used to compare the data
3143 * according to the locale settings.
3144 */
bbce6d69 3145char *
8ac85365 3146sv_collxfrm(SV *sv, STRLEN *nxp)
bbce6d69 3147{
7a4c00b4 3148 MAGIC *mg;
16660edb 3149
8ac85365 3150 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
7a4c00b4 3151 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
bbce6d69
PP
3152 char *s, *xf;
3153 STRLEN len, xlen;
3154
7a4c00b4
PP
3155 if (mg)
3156 Safefree(mg->mg_ptr);
bbce6d69
PP
3157 s = SvPV(sv, len);
3158 if ((xf = mem_collxfrm(s, len, &xlen))) {
ff0cee69
PP
3159 if (SvREADONLY(sv)) {
3160 SAVEFREEPV(xf);
3161 *nxp = xlen;
fb73857a 3162 return xf + sizeof(collation_ix);
ff0cee69 3163 }
7a4c00b4
PP
3164 if (! mg) {
3165 sv_magic(sv, 0, 'o', 0, 0);
3166 mg = mg_find(sv, 'o');
3167 assert(mg);
bbce6d69 3168 }
7a4c00b4 3169 mg->mg_ptr = xf;
565764a8 3170 mg->mg_len = xlen;
7a4c00b4
PP
3171 }
3172 else {
ff0cee69
PP
3173 if (mg) {
3174 mg->mg_ptr = NULL;
565764a8 3175 mg->mg_len = -1;
ff0cee69 3176 }
bbce6d69
PP
3177 }
3178 }
7a4c00b4 3179 if (mg && mg->mg_ptr) {
565764a8 3180 *nxp = mg->mg_len;
bbce6d69
PP
3181 return mg->mg_ptr + sizeof(collation_ix);
3182 }
3183 else {
3184 *nxp = 0;
3185 return NULL;
16660edb 3186 }
79072805
LW
3187}
3188
36477c24 3189#endif /* USE_LOCALE_COLLATE */
bbce6d69 3190
79072805 3191char *
76e3520e 3192sv_gets(register SV *sv, register PerlIO *fp, I32 append)
79072805 3193{
aeea060c 3194 dTHR;
c07a80fd
PP
3195 char *rsptr;
3196 STRLEN rslen;
3197 register STDCHAR rslast;
3198 register STDCHAR *bp;
3199 register I32 cnt;
3200 I32 i;
3201
2213622d 3202 SV_CHECK_THINKFIRST(sv);
c6f8c383 3203 (void)SvUPGRADE(sv, SVt_PV);
ff68c719 3204 SvSCREAM_off(sv);
c07a80fd
PP
3205
3206 if (RsSNARF(rs)) {
3207 rsptr = NULL;
3208 rslen = 0;
3209 }
5b2b9c68
HM
3210 else if (RsRECORD(rs)) {
3211 I32 recsize, bytesread;
3212 char *buffer;
3213
3214 /* Grab the size of the record we're getting */
3215 recsize = SvIV(SvRV(rs));
3216 (void)SvPOK_only(sv); /* Validate pointer */
3217 /* Make sure we've got the room to yank in the whole thing */
3218 if (SvLEN(sv) <= recsize + 3) {
3219 /* No, so make it bigger */
3220 SvGROW(sv, recsize + 3);
3221 }
3222 buffer = SvPVX(sv); /* Get the location of the final buffer */
3223 /* Go yank in */
3224#ifdef VMS
3225 /* VMS wants read instead of fread, because fread doesn't respect */
3226 /* RMS record boundaries. This is not necessarily a good thing to be */
3227 /* doing, but we've got no other real choice */
3228 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3229#else
3230 bytesread = PerlIO_read(fp, buffer, recsize);
3231#endif
3232 SvCUR_set(sv, bytesread);
3233 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3234 }
c07a80fd
PP
3235 else if (RsPARA(rs)) {
3236 rsptr = "\n\n";
3237 rslen = 2;
3238 }
3239 else
3240 rsptr = SvPV(rs, rslen);
3241 rslast = rslen ? rsptr[rslen - 1] : '\0';
3242
3243 if (RsPARA(rs)) { /* have to do this both before and after */
79072805 3244 do { /* to make sure file boundaries work right */
760ac839 3245 if (PerlIO_eof(fp))
a0d0e21e 3246 return 0;
760ac839 3247 i = PerlIO_getc(fp);
79072805 3248 if (i != '\n') {
a0d0e21e
LW
3249 if (i == -1)
3250 return 0;
760ac839 3251 PerlIO_ungetc(fp,i);
79072805
LW
3252 break;
3253 }
3254 } while (i != EOF);
3255 }
c07a80fd 3256
760ac839
LW
3257 /* See if we know enough about I/O mechanism to cheat it ! */
3258
3259 /* This used to be #ifdef test - it is made run-time test for ease
3260 of abstracting out stdio interface. One call should be cheap
3261 enough here - and may even be a macro allowing compile
3262 time optimization.
3263 */
3264
3265 if (PerlIO_fast_gets(fp)) {
3266
3267 /*
3268 * We're going to steal some values from the stdio struct
3269 * and put EVERYTHING in the innermost loop into registers.
3270 */
3271 register STDCHAR *ptr;
3272 STRLEN bpx;
3273 I32 shortbuffered;
3274
16660edb
PP
3275#if defined(VMS) && defined(PERLIO_IS_STDIO)
3276 /* An ungetc()d char is handled separately from the regular
3277 * buffer, so we getc() it back out and stuff it in the buffer.
3278 */
3279 i = PerlIO_getc(fp);
3280 if (i == EOF) return 0;
3281 *(--((*fp)->_ptr)) = (unsigned char) i;
3282 (*fp)->_cnt++;
3283#endif
c07a80fd 3284
c2960299 3285 /* Here is some breathtakingly efficient cheating */
c07a80fd 3286
760ac839 3287 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 3288 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW
3289 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3290 if (cnt > 80 && SvLEN(sv) > append) {
3291 shortbuffered = cnt - SvLEN(sv) + append + 1;
3292 cnt -= shortbuffered;
3293 }
3294 else {
3295 shortbuffered = 0;
bbce6d69
PP
3296 /* remember that cnt can be negative */
3297 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW
3298 }
3299 }
3300 else
3301 shortbuffered = 0;
c07a80fd 3302 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
760ac839 3303 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb 3304 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3305 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
16660edb 3306 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3307 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3308 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3309 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
79072805
LW
3310 for (;;) {
3311 screamer:
93a17b20 3312 if (cnt > 0) {
c07a80fd 3313 if (rslen) {
760ac839
LW
3314 while (cnt > 0) { /* this | eat */
3315 cnt--;
c07a80fd
PP
3316 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3317 goto thats_all_folks; /* screams | sed :-) */
3318 }
3319 }
3320 else {
36477c24 3321 Copy(ptr, bp, cnt, char); /* this | eat */
c07a80fd
PP
3322 bp += cnt; /* screams | dust */
3323 ptr += cnt; /* louder | sed :-) */
a5f75d66 3324 cnt = 0;
93a17b20 3325 }
79072805
LW
3326 }
3327
748a9306 3328 if (shortbuffered) { /* oh well, must extend */
79072805
LW
3329 cnt = shortbuffered;
3330 shortbuffered = 0;
c07a80fd 3331 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW
3332 SvCUR_set(sv, bpx);
3333 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 3334 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW
3335 continue;
3336 }
3337
16660edb 3338 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3339 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
d1bf51dd 3340 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb 3341 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3342 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3343 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3344 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
16660edb 3345 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b
PP
3346 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3347 another abstraction. */
760ac839 3348 i = PerlIO_getc(fp); /* get more characters */
16660edb 3349 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3350 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3351 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3352 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
760ac839
LW
3353 cnt = PerlIO_get_cnt(fp);
3354 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb 3355 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3356 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
79072805 3357
748a9306
LW
3358 if (i == EOF) /* all done for ever? */
3359 goto thats_really_all_folks;
3360
c07a80fd 3361 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW
3362 SvCUR_set(sv, bpx);
3363 SvGROW(sv, bpx + cnt + 2);
c07a80fd
PP
3364 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3365
760ac839 3366 *bp++ = i; /* store character from PerlIO_getc */
79072805 3367
c07a80fd 3368 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 3369 goto thats_all_folks;
79072805
LW
3370 }
3371
3372thats_all_folks:
c07a80fd 3373 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 3374 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 3375 goto screamer; /* go back to the fray */
79072805
LW
3376thats_really_all_folks:
3377 if (shortbuffered)
3378 cnt += shortbuffered;
16660edb 3379 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745 3380 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
d1bf51dd 3381 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb 3382 DEBUG_P(PerlIO_printf(Perl_debug_log,
68dc0745
PP
3383 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3384 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3385 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
79072805 3386 *bp = '\0';
760ac839 3387 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb 3388 DEBUG_P(PerlIO_printf(Perl_debug_log,
fb73857a
PP
3389 "Screamer: done, len=%ld, string=|%.*s|\n",
3390 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
760ac839
LW
3391 }
3392 else
79072805 3393 {
760ac839 3394 /*The big, slow, and stupid way */
c07a80fd 3395 STDCHAR buf[8192];
79072805 3396
760ac839 3397screamer2:
c07a80fd 3398 if (rslen) {
760ac839
LW
3399 register STDCHAR *bpe = buf + sizeof(buf);
3400 bp = buf;
3401 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3402 ; /* keep reading */
3403 cnt = bp - buf;
c07a80fd
PP
3404 }
3405 else {
760ac839 3406 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb
PP
3407 /* Accomodate broken VAXC compiler, which applies U8 cast to
3408 * both args of ?: operator, causing EOF to change into 255
3409 */
3410 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 3411 }
79072805
LW
3412
3413 if (append)
760ac839 3414 sv_catpvn(sv, (char *) buf, cnt);
79072805 3415 else
760ac839 3416 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd
PP
3417
3418 if (i != EOF && /* joy */
3419 (!rslen ||
3420 SvCUR(sv) < rslen ||
36477c24 3421 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW
3422 {
3423 append = -1;
63e4d877
CS
3424 /*
3425 * If we're reading from a TTY and we get a short read,
3426 * indicating that the user hit his EOF character, we need
3427 * to notice it now, because if we try to read from the TTY
3428 * again, the EOF condition will disappear.
3429 *
3430 * The comparison of cnt to sizeof(buf) is an optimization
3431 * that prevents unnecessary calls to feof().
3432 *
3433 * - jik 9/25/96
3434 */
3435 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3436 goto screamer2;
79072805
LW
3437 }
3438 }
3439
c07a80fd
PP
3440 if (RsPARA(rs)) { /* have to do this both before and after */
3441 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 3442 i = PerlIO_getc(fp);
79072805 3443 if (i != '\n') {
760ac839 3444 PerlIO_ungetc(fp,i);
79072805
LW
3445 break;
3446 }
3447 }
3448 }
c07a80fd 3449
a868473f
NIS
3450#ifdef WIN32
3451 win32_strip_return(sv);
3452#endif
3453
c07a80fd 3454 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW
3455}
3456
760ac839 3457
79072805 3458void
8ac85365 3459sv_inc(register SV *sv)
79072805
LW
3460{
3461 register char *d;
463ee0b2 3462 int flags;
79072805
LW
3463
3464 if (!sv)
3465 return;
ed6116ce 3466 if (SvTHINKFIRST(sv)) {
0f15f207
MB
3467 if (SvREADONLY(sv)) {
3468 dTHR;
3469 if (curcop != &compiling)
3470 croak(no_modify);
3471 }
a0d0e21e 3472 if (SvROK(sv)) {
b5be31e9 3473 IV i;
a0d0e21e 3474#ifdef OVERLOAD
b5be31e9 3475 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
a0d0e21e 3476#endif /* OVERLOAD */
b5be31e9
SM
3477 i = (IV)SvRV(sv);
3478 sv_unref(sv);
3479 sv_setiv(sv, i);
a0d0e21e 3480 }
ed6116ce 3481 }
8990e307 3482 if (SvGMAGICAL(sv))
79072805 3483 mg_get(sv);
8990e307 3484 flags = SvFLAGS(sv);
8990e307 3485 if (flags & SVp_NOK) {
a0d0e21e 3486 (void)SvNOK_only(sv);
55497cff
PP
3487 SvNVX(sv) += 1.0;
3488 return;
3489 }
3490 if (flags & SVp_IOK) {
3491 if (SvIVX(sv) == IV_MAX)
3492 sv_setnv(sv, (double)IV_MAX + 1.0);
3493 else {
3494 (void)SvIOK_only(sv);
3495 ++SvIVX(sv);
3496 }
79072805
LW
3497 return;
3498 }
8990e307 3499 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4633a7c4
LW
3500 if ((flags & SVTYPEMASK) < SVt_PVNV)
3501 sv_upgrade(sv, SVt_NV);
463ee0b2 3502 SvNVX(sv) = 1.0;
a0d0e21e 3503 (void)SvNOK_only(sv);
79072805
LW
3504 return;
3505 }
463ee0b2 3506 d = SvPVX(sv);
79072805
LW
3507 while (isALPHA(*d)) d++;
3508 while (isDIGIT(*d)) d++;
3509 if (*d) {
36477c24 3510 SET_NUMERIC_STANDARD();
bbce6d69 3511 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
79072805
LW
3512 return;
3513 }
3514 d--;
463ee0b2 3515 while (d >= SvPVX(sv)) {
79072805
LW
3516 if (isDIGIT(*d)) {
3517 if (++*d <= '9')
3518 return;
3519 *(d--) = '0';
3520 }
3521 else {
3522 ++*d;
3523 if (isALPHA(*d))
3524 return;
3525 *(d--) -= 'z' - 'a' + 1;
3526 }
3527 }
3528 /* oh,oh, the number grew */
3529 SvGROW(sv, SvCUR(sv) + 2);
3530 SvCUR(sv)++;
463ee0b2 3531 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW
3532 *d = d[-1];
3533 if (isDIGIT(d[1]))
3534 *d = '1';
3535 else
3536 *d = d[1];
3537}
3538
3539void
8ac85365 3540sv_dec(register SV *sv)
79072805 3541{
463ee0b2
LW
3542 int flags;
3543
79072805
LW
3544 if (!sv)
3545 return;
ed6116ce 3546 if (SvTHINKFIRST(sv)) {
0f15f207
MB
3547 if (SvREADONLY(sv)) {
3548 dTHR;
3549 if (curcop != &compiling)
3550 croak(no_modify);
3551 }
a0d0e21e 3552 if (SvROK(sv)) {
b5be31e9 3553 IV i;
a0d0e21e 3554#ifdef OVERLOAD
b5be31e9 3555 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
a0d0e21e 3556#endif /* OVERLOAD */
b5be31e9
SM
3557 i = (IV)SvRV(sv);
3558 sv_unref(sv);
3559 sv_setiv(sv, i);
a0d0e21e 3560 }
ed6116ce 3561 }
8990e307 3562 if (SvGMAGICAL(sv))
79072805 3563 mg_get(sv);
8990e307 3564 flags = SvFLAGS(sv);
8990e307 3565 if (flags & SVp_NOK) {
463ee0b2 3566 SvNVX(sv) -= 1.0;
a0d0e21e 3567 (void)SvNOK_only(sv);
79072805
LW
3568 return;
3569 }
55497cff
PP
3570 if (flags & SVp_IOK) {
3571 if (SvIVX(sv) == IV_MIN)
3572 sv_setnv(sv, (double)IV_MIN - 1.0);
3573 else {
3574 (void)SvIOK_only(sv);
3575 --SvIVX(sv);
3576 }
3577 return;
3578 }
8990e307 3579 if (!(flags & SVp_POK)) {
4633a7c4
LW
3580 if ((flags & SVTYPEMASK) < SVt_PVNV)
3581 sv_upgrade(sv, SVt_NV);
463ee0b2 3582 SvNVX(sv) = -1.0;
a0d0e21e 3583 (void)SvNOK_only(sv);
79072805
LW
3584 return;
3585 }
36477c24 3586 SET_NUMERIC_STANDARD();
bbce6d69 3587 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW
3588}
3589
3590/* Make a string that will exist for the duration of the expression
3591 * evaluation. Actually, it may have to last longer than that, but
3592 * hopefully we won't free it until it has been assigned to a
3593 * permanent location. */
3594
76e3520e 3595STATIC void
8ac85365 3596sv_mortalgrow(void)
8990e307 3597{
11343788 3598 dTHR;
55497cff 3599 tmps_max += (tmps_max < 512) ? 128 : 512;
8990e307
LW
3600 Renew(tmps_stack, tmps_max, SV*);
3601}
3602
79072805 3603SV *
8ac85365 3604sv_mortalcopy(SV *oldstr)
79072805 3605{
11343788 3606 dTHR;
463ee0b2 3607 register SV *sv;
79072805 3608
4561caa4 3609 new_SV(sv);
8990e307
LW
3610 SvANY(sv) = 0;
3611 SvREFCNT(sv) = 1;
3612 SvFLAGS(sv) = 0;
79072805 3613 sv_setsv(sv,oldstr);
8990e307
LW
3614 if (++tmps_ix >= tmps_max)
3615 sv_mortalgrow();
3616 tmps_stack[tmps_ix] = sv;
3617 SvTEMP_on(sv);
3618 return sv;
3619}
3620
3621SV *
8ac85365 3622sv_newmortal(void)
8990e307 3623{
11343788 3624 dTHR;
8990e307
LW
3625 register SV *sv;
3626
4561caa4 3627 new_SV(sv);
8990e307
LW
3628 SvANY(sv) = 0;
3629 SvREFCNT(sv) = 1;
3630 SvFLAGS(sv) = SVs_TEMP;
3631 if (++tmps_ix >= tmps_max)
3632 sv_mortalgrow();
79072805 3633 tmps_stack[tmps_ix] = sv;
79072805
LW
3634 return sv;
3635}
3636
3637/* same thing without the copying */
3638
3639SV *
8ac85365 3640sv_2mortal(register SV *sv)
79072805 3641{
11343788 3642 dTHR;
79072805
LW
3643 if (!sv)
3644 return sv;
d689ffdd 3645 if (SvREADONLY(sv) && SvIMMORTAL(sv))
11162842 3646 return sv;
8990e307
LW
3647 if (++tmps_ix >= tmps_max)
3648 sv_mortalgrow();
79072805 3649 tmps_stack[tmps_ix] = sv;
8990e307 3650 SvTEMP_on(sv);
79072805
LW
3651 return sv;
3652}
3653
3654SV *
8ac85365 3655newSVpv(char *s, STRLEN len)
79072805 3656{
463ee0b2 3657 register SV *sv;
79072805 3658
4561caa4 3659 new_SV(sv);
8990e307
LW
3660 SvANY(sv) = 0;
3661 SvREFCNT(sv) = 1;
3662 SvFLAGS(sv) = 0;
79072805
LW
3663 if (!len)
3664 len = strlen(s);
3665 sv_setpvn(sv,s,len);
3666 return sv;
3667}
3668
9da1e3b5 3669SV *
9d8a25dc 3670newSVpvn(char *s, STRLEN len)
9da1e3b5
MUN
3671{
3672 register SV *sv;
3673
3674 new_SV(sv);
3675 SvANY(sv) = 0;
3676 SvREFCNT(sv) = 1;
3677 SvFLAGS(sv) = 0;
3678 sv_setpvn(sv,s,len);
3679 return sv;
3680}
3681
46fc3d4c
PP
3682SV *
3683newSVpvf(const char* pat, ...)
46fc3d4c
PP
3684{
3685 register SV *sv;
3686 va_list args;