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