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