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