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