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