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