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