This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
fix problem pointer casts
[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,
b900a521
JH		 189 "Attempt to free non-arena SV: 0x%"UVxf,
190 PTR2UV(p));
a0d0e21e
LW		 191 return;
192 }
193 }
4561caa4 194 plant_SV(p);
463ee0b2 195}
a0d0e21e 196
4561caa4
CS		 197#else /* ! DEBUGGING */
198
199#define del_SV(p) plant_SV(p)
200
201#endif /* DEBUGGING */
463ee0b2 202
4633a7c4 203void
864dbfa3 204Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
463ee0b2 205{
4633a7c4 206 SV* sva = (SV*)ptr;
463ee0b2
LW		 207 register SV* sv;
208 register SV* svend;
4633a7c4
LW		 209 Zero(sva, size, char);
210
211 /* The first SV in an arena isn't an SV. */
3280af22 212 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
4633a7c4
LW		 213 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
214 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
215
3280af22
NIS		 216 PL_sv_arenaroot = sva;
217 PL_sv_root = sva + 1;
4633a7c4
LW		 218
219 svend = &sva[SvREFCNT(sva) - 1];
220 sv = sva + 1;
463ee0b2 221 while (sv < svend) {
a0d0e21e 222 SvANY(sv) = (void *)(SV*)(sv + 1);
8990e307 223 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW		 224 sv++;
225 }
226 SvANY(sv) = 0;
4633a7c4
LW		 227 SvFLAGS(sv) = SVTYPEMASK;
228}
229
fba3b22e 230/* sv_mutex must be held while calling more_sv() */
76e3520e 231STATIC SV*
cea2e8a9 232S_more_sv(pTHX)
4633a7c4 233{
4561caa4
CS		 234 register SV* sv;
235
3280af22
NIS		 236 if (PL_nice_chunk) {
237 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
238 PL_nice_chunk = Nullch;
c07a80fd 239 }
1edc1566
PP		 240 else {
241 char *chunk; /* must use New here to match call to */
242 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
243 sv_add_arena(chunk, 1008, 0);
244 }
4561caa4
CS		 245 uproot_SV(sv);
246 return sv;
463ee0b2
LW		 247}
248
76e3520e 249STATIC void
cea2e8a9 250S_visit(pTHX_ SVFUNC_t f)
8990e307 251{
4633a7c4 252 SV* sva;
8990e307
LW		 253 SV* sv;
254 register SV* svend;
255
3280af22 256 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
4633a7c4 257 svend = &sva[SvREFCNT(sva)];
4561caa4
CS		 258 for (sv = sva + 1; sv < svend; ++sv) {
259 if (SvTYPE(sv) != SVTYPEMASK)
51371543 260 (FCALL)(aTHXo_ sv);
8990e307
LW		 261 }
262 }
263}
264
4561caa4
CS		 265#endif /* PURIFY */
266
8990e307 267void
864dbfa3 268Perl_sv_report_used(pTHX)
4561caa4 269{
0b94c7bb 270 visit(do_report_used);
4561caa4
CS		 271}
272
4561caa4 273void
864dbfa3 274Perl_sv_clean_objs(pTHX)
4561caa4 275{
3280af22 276 PL_in_clean_objs = TRUE;
0b94c7bb 277 visit(do_clean_objs);
4561caa4 278#ifndef DISABLE_DESTRUCTOR_KLUDGE
2d0f3c12 279 /* some barnacles may yet remain, clinging to typeglobs */
0b94c7bb 280 visit(do_clean_named_objs);
4561caa4 281#endif
3280af22 282 PL_in_clean_objs = FALSE;
4561caa4
CS		 283}
284
8990e307 285void
864dbfa3 286Perl_sv_clean_all(pTHX)
8990e307 287{
3280af22 288 PL_in_clean_all = TRUE;
0b94c7bb 289 visit(do_clean_all);
3280af22 290 PL_in_clean_all = FALSE;
8990e307 291}
463ee0b2 292
4633a7c4 293void
864dbfa3 294Perl_sv_free_arenas(pTHX)
4633a7c4
LW		 295{
296 SV* sva;
297 SV* svanext;
298
299 /* Free arenas here, but be careful about fake ones. (We assume
300 contiguity of the fake ones with the corresponding real ones.) */
301
3280af22 302 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
4633a7c4
LW		 303 svanext = (SV*) SvANY(sva);
304 while (svanext && SvFAKE(svanext))
305 svanext = (SV*) SvANY(svanext);
306
307 if (!SvFAKE(sva))
1edc1566 308 Safefree((void *)sva);
4633a7c4 309 }
5f05dabc 310
3280af22
NIS		 311 if (PL_nice_chunk)
312 Safefree(PL_nice_chunk);
313 PL_nice_chunk = Nullch;
314 PL_nice_chunk_size = 0;
315 PL_sv_arenaroot = 0;
316 PL_sv_root = 0;
4633a7c4
LW		 317}
318
76e3520e 319STATIC XPVIV*
cea2e8a9 320S_new_xiv(pTHX)
463ee0b2 321{
ea7c11a3 322 IV* xiv;
cbe51380
GS		 323 LOCK_SV_MUTEX;
324 if (!PL_xiv_root)
325 more_xiv();
326 xiv = PL_xiv_root;
327 /*
328 * See comment in more_xiv() -- RAM.
329 */
330 PL_xiv_root = *(IV**)xiv;
331 UNLOCK_SV_MUTEX;
332 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
463ee0b2
LW		 333}
334
76e3520e 335STATIC void
cea2e8a9 336S_del_xiv(pTHX_ XPVIV *p)
463ee0b2 337{
23e6a22f 338 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
cbe51380 339 LOCK_SV_MUTEX;
3280af22
NIS		 340 *(IV**)xiv = PL_xiv_root;
341 PL_xiv_root = xiv;
cbe51380 342 UNLOCK_SV_MUTEX;
463ee0b2
LW		 343}
344
cbe51380 345STATIC void
cea2e8a9 346S_more_xiv(pTHX)
463ee0b2 347{
ea7c11a3
SM		 348 register IV* xiv;
349 register IV* xivend;
8c52afec
IZ		 350 XPV* ptr;
351 New(705, ptr, 1008/sizeof(XPV), XPV);
3280af22
NIS		 352 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
353 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
a0d0e21e 354
ea7c11a3
SM		 355 xiv = (IV*) ptr;
356 xivend = &xiv[1008 / sizeof(IV) - 1];
357 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
3280af22 358 PL_xiv_root = xiv;
463ee0b2 359 while (xiv < xivend) {
ea7c11a3 360 *(IV**)xiv = (IV *)(xiv + 1);
463ee0b2
LW		 361 xiv++;
362 }
ea7c11a3 363 *(IV**)xiv = 0;
463ee0b2
LW		 364}
365
76e3520e 366STATIC XPVNV*
cea2e8a9 367S_new_xnv(pTHX)
463ee0b2 368{
65202027 369 NV* xnv;
cbe51380
GS		 370 LOCK_SV_MUTEX;
371 if (!PL_xnv_root)
372 more_xnv();
373 xnv = PL_xnv_root;
65202027 374 PL_xnv_root = *(NV**)xnv;
cbe51380
GS		 375 UNLOCK_SV_MUTEX;
376 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
463ee0b2
LW		 377}
378
76e3520e 379STATIC void
cea2e8a9 380S_del_xnv(pTHX_ XPVNV *p)
463ee0b2 381{
65202027 382 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
cbe51380 383 LOCK_SV_MUTEX;
65202027 384 *(NV**)xnv = PL_xnv_root;
3280af22 385 PL_xnv_root = xnv;
cbe51380 386 UNLOCK_SV_MUTEX;
463ee0b2
LW		 387}
388
cbe51380 389STATIC void
cea2e8a9 390S_more_xnv(pTHX)
463ee0b2 391{
65202027
DS		 392 register NV* xnv;
393 register NV* xnvend;
394 New(711, xnv, 1008/sizeof(NV), NV);
395 xnvend = &xnv[1008 / sizeof(NV) - 1];
396 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
3280af22 397 PL_xnv_root = xnv;
463ee0b2 398 while (xnv < xnvend) {
65202027 399 *(NV**)xnv = (NV*)(xnv + 1);
463ee0b2
LW		 400 xnv++;
401 }
65202027 402 *(NV**)xnv = 0;
463ee0b2
LW		 403}
404
76e3520e 405STATIC XRV*
cea2e8a9 406S_new_xrv(pTHX)
ed6116ce
LW		 407{
408 XRV* xrv;
cbe51380
GS		 409 LOCK_SV_MUTEX;
410 if (!PL_xrv_root)
411 more_xrv();
412 xrv = PL_xrv_root;
413 PL_xrv_root = (XRV*)xrv->xrv_rv;
414 UNLOCK_SV_MUTEX;
415 return xrv;
ed6116ce
LW		 416}
417
76e3520e 418STATIC void
cea2e8a9 419S_del_xrv(pTHX_ XRV *p)
ed6116ce 420{
cbe51380 421 LOCK_SV_MUTEX;
3280af22
NIS		 422 p->xrv_rv = (SV*)PL_xrv_root;
423 PL_xrv_root = p;
cbe51380 424 UNLOCK_SV_MUTEX;
ed6116ce
LW		 425}
426
cbe51380 427STATIC void
cea2e8a9 428S_more_xrv(pTHX)
ed6116ce 429{
ed6116ce
LW		 430 register XRV* xrv;
431 register XRV* xrvend;
3280af22
NIS		 432 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
433 xrv = PL_xrv_root;
ed6116ce
LW		 434 xrvend = &xrv[1008 / sizeof(XRV) - 1];
435 while (xrv < xrvend) {
436 xrv->xrv_rv = (SV*)(xrv + 1);
437 xrv++;
438 }
439 xrv->xrv_rv = 0;
ed6116ce
LW		 440}
441
76e3520e 442STATIC XPV*
cea2e8a9 443S_new_xpv(pTHX)
463ee0b2
LW		 444{
445 XPV* xpv;
cbe51380
GS		 446 LOCK_SV_MUTEX;
447 if (!PL_xpv_root)
448 more_xpv();
449 xpv = PL_xpv_root;
450 PL_xpv_root = (XPV*)xpv->xpv_pv;
451 UNLOCK_SV_MUTEX;
452 return xpv;
463ee0b2
LW		 453}
454
76e3520e 455STATIC void
cea2e8a9 456S_del_xpv(pTHX_ XPV *p)
463ee0b2 457{
cbe51380 458 LOCK_SV_MUTEX;
3280af22
NIS		 459 p->xpv_pv = (char*)PL_xpv_root;
460 PL_xpv_root = p;
cbe51380 461 UNLOCK_SV_MUTEX;
463ee0b2
LW		 462}
463
cbe51380 464STATIC void
cea2e8a9 465S_more_xpv(pTHX)
463ee0b2 466{
463ee0b2
LW		 467 register XPV* xpv;
468 register XPV* xpvend;
3280af22
NIS		 469 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
470 xpv = PL_xpv_root;
463ee0b2
LW		 471 xpvend = &xpv[1008 / sizeof(XPV) - 1];
472 while (xpv < xpvend) {
473 xpv->xpv_pv = (char*)(xpv + 1);
474 xpv++;
475 }
476 xpv->xpv_pv = 0;
463ee0b2
LW		 477}
478
932e9ff9
VB		 479STATIC XPVIV*
480S_new_xpviv(pTHX)
481{
482 XPVIV* xpviv;
483 LOCK_SV_MUTEX;
484 if (!PL_xpviv_root)
485 more_xpviv();
486 xpviv = PL_xpviv_root;
487 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
488 UNLOCK_SV_MUTEX;
489 return xpviv;
490}
491
492STATIC void
493S_del_xpviv(pTHX_ XPVIV *p)
494{
495 LOCK_SV_MUTEX;
496 p->xpv_pv = (char*)PL_xpviv_root;
497 PL_xpviv_root = p;
498 UNLOCK_SV_MUTEX;
499}
500
501
502STATIC void
503S_more_xpviv(pTHX)
504{
505 register XPVIV* xpviv;
506 register XPVIV* xpvivend;
507 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
508 xpviv = PL_xpviv_root;
509 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
510 while (xpviv < xpvivend) {
511 xpviv->xpv_pv = (char*)(xpviv + 1);
512 xpviv++;
513 }
514 xpviv->xpv_pv = 0;
515}
516
517
518STATIC XPVNV*
519S_new_xpvnv(pTHX)
520{
521 XPVNV* xpvnv;
522 LOCK_SV_MUTEX;
523 if (!PL_xpvnv_root)
524 more_xpvnv();
525 xpvnv = PL_xpvnv_root;
526 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
527 UNLOCK_SV_MUTEX;
528 return xpvnv;
529}
530
531STATIC void
532S_del_xpvnv(pTHX_ XPVNV *p)
533{
534 LOCK_SV_MUTEX;
535 p->xpv_pv = (char*)PL_xpvnv_root;
536 PL_xpvnv_root = p;
537 UNLOCK_SV_MUTEX;
538}
539
540
541STATIC void
542S_more_xpvnv(pTHX)
543{
544 register XPVNV* xpvnv;
545 register XPVNV* xpvnvend;
546 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
547 xpvnv = PL_xpvnv_root;
548 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
549 while (xpvnv < xpvnvend) {
550 xpvnv->xpv_pv = (char*)(xpvnv + 1);
551 xpvnv++;
552 }
553 xpvnv->xpv_pv = 0;
554}
555
556
557
558STATIC XPVCV*
559S_new_xpvcv(pTHX)
560{
561 XPVCV* xpvcv;
562 LOCK_SV_MUTEX;
563 if (!PL_xpvcv_root)
564 more_xpvcv();
565 xpvcv = PL_xpvcv_root;
566 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
567 UNLOCK_SV_MUTEX;
568 return xpvcv;
569}
570
571STATIC void
572S_del_xpvcv(pTHX_ XPVCV *p)
573{
574 LOCK_SV_MUTEX;
575 p->xpv_pv = (char*)PL_xpvcv_root;
576 PL_xpvcv_root = p;
577 UNLOCK_SV_MUTEX;
578}
579
580
581STATIC void
582S_more_xpvcv(pTHX)
583{
584 register XPVCV* xpvcv;
585 register XPVCV* xpvcvend;
586 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
587 xpvcv = PL_xpvcv_root;
588 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
589 while (xpvcv < xpvcvend) {
590 xpvcv->xpv_pv = (char*)(xpvcv + 1);
591 xpvcv++;
592 }
593 xpvcv->xpv_pv = 0;
594}
595
596
597
598STATIC XPVAV*
599S_new_xpvav(pTHX)
600{
601 XPVAV* xpvav;
602 LOCK_SV_MUTEX;
603 if (!PL_xpvav_root)
604 more_xpvav();
605 xpvav = PL_xpvav_root;
606 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
607 UNLOCK_SV_MUTEX;
608 return xpvav;
609}
610
611STATIC void
612S_del_xpvav(pTHX_ XPVAV *p)
613{
614 LOCK_SV_MUTEX;
615 p->xav_array = (char*)PL_xpvav_root;
616 PL_xpvav_root = p;
617 UNLOCK_SV_MUTEX;
618}
619
620
621STATIC void
622S_more_xpvav(pTHX)
623{
624 register XPVAV* xpvav;
625 register XPVAV* xpvavend;
626 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
627 xpvav = PL_xpvav_root;
628 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
629 while (xpvav < xpvavend) {
630 xpvav->xav_array = (char*)(xpvav + 1);
631 xpvav++;
632 }
633 xpvav->xav_array = 0;
634}
635
636
637
638STATIC XPVHV*
639S_new_xpvhv(pTHX)
640{
641 XPVHV* xpvhv;
642 LOCK_SV_MUTEX;
643 if (!PL_xpvhv_root)
644 more_xpvhv();
645 xpvhv = PL_xpvhv_root;
646 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
647 UNLOCK_SV_MUTEX;
648 return xpvhv;
649}
650
651STATIC void
652S_del_xpvhv(pTHX_ XPVHV *p)
653{
654 LOCK_SV_MUTEX;
655 p->xhv_array = (char*)PL_xpvhv_root;
656 PL_xpvhv_root = p;
657 UNLOCK_SV_MUTEX;
658}
659
660
661STATIC void
662S_more_xpvhv(pTHX)
663{
664 register XPVHV* xpvhv;
665 register XPVHV* xpvhvend;
666 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
667 xpvhv = PL_xpvhv_root;
668 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
669 while (xpvhv < xpvhvend) {
670 xpvhv->xhv_array = (char*)(xpvhv + 1);
671 xpvhv++;
672 }
673 xpvhv->xhv_array = 0;
674}
675
676
677STATIC XPVMG*
678S_new_xpvmg(pTHX)
679{
680 XPVMG* xpvmg;
681 LOCK_SV_MUTEX;
682 if (!PL_xpvmg_root)
683 more_xpvmg();
684 xpvmg = PL_xpvmg_root;
685 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
686 UNLOCK_SV_MUTEX;
687 return xpvmg;
688}
689
690STATIC void
691S_del_xpvmg(pTHX_ XPVMG *p)
692{
693 LOCK_SV_MUTEX;
694 p->xpv_pv = (char*)PL_xpvmg_root;
695 PL_xpvmg_root = p;
696 UNLOCK_SV_MUTEX;
697}
698
699
700STATIC void
701S_more_xpvmg(pTHX)
702{
703 register XPVMG* xpvmg;
704 register XPVMG* xpvmgend;
705 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
706 xpvmg = PL_xpvmg_root;
707 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
708 while (xpvmg < xpvmgend) {
709 xpvmg->xpv_pv = (char*)(xpvmg + 1);
710 xpvmg++;
711 }
712 xpvmg->xpv_pv = 0;
713}
714
715
716
717STATIC XPVLV*
718S_new_xpvlv(pTHX)
719{
720 XPVLV* xpvlv;
721 LOCK_SV_MUTEX;
722 if (!PL_xpvlv_root)
723 more_xpvlv();
724 xpvlv = PL_xpvlv_root;
725 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
726 UNLOCK_SV_MUTEX;
727 return xpvlv;
728}
729
730STATIC void
731S_del_xpvlv(pTHX_ XPVLV *p)
732{
733 LOCK_SV_MUTEX;
734 p->xpv_pv = (char*)PL_xpvlv_root;
735 PL_xpvlv_root = p;
736 UNLOCK_SV_MUTEX;
737}
738
739
740STATIC void
741S_more_xpvlv(pTHX)
742{
743 register XPVLV* xpvlv;
744 register XPVLV* xpvlvend;
745 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
746 xpvlv = PL_xpvlv_root;
747 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
748 while (xpvlv < xpvlvend) {
749 xpvlv->xpv_pv = (char*)(xpvlv + 1);
750 xpvlv++;
751 }
752 xpvlv->xpv_pv = 0;
753}
754
755
756STATIC XPVBM*
757S_new_xpvbm(pTHX)
758{
759 XPVBM* xpvbm;
760 LOCK_SV_MUTEX;
761 if (!PL_xpvbm_root)
762 more_xpvbm();
763 xpvbm = PL_xpvbm_root;
764 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
765 UNLOCK_SV_MUTEX;
766 return xpvbm;
767}
768
769STATIC void
770S_del_xpvbm(pTHX_ XPVBM *p)
771{
772 LOCK_SV_MUTEX;
773 p->xpv_pv = (char*)PL_xpvbm_root;
774 PL_xpvbm_root = p;
775 UNLOCK_SV_MUTEX;
776}
777
778
779STATIC void
780S_more_xpvbm(pTHX)
781{
782 register XPVBM* xpvbm;
783 register XPVBM* xpvbmend;
784 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
785 xpvbm = PL_xpvbm_root;
786 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
787 while (xpvbm < xpvbmend) {
788 xpvbm->xpv_pv = (char*)(xpvbm + 1);
789 xpvbm++;
790 }
791 xpvbm->xpv_pv = 0;
792}
793
463ee0b2 794#ifdef PURIFY
8990e307 795#define new_XIV() (void*)safemalloc(sizeof(XPVIV))
6ad3d225 796#define del_XIV(p) Safefree((char*)p)
463ee0b2 797#else
85e6fe83 798#define new_XIV() (void*)new_xiv()
8ac85365 799#define del_XIV(p) del_xiv((XPVIV*) p)
463ee0b2
LW		 800#endif
801
802#ifdef PURIFY
8990e307 803#define new_XNV() (void*)safemalloc(sizeof(XPVNV))
6ad3d225 804#define del_XNV(p) Safefree((char*)p)
463ee0b2 805#else
85e6fe83 806#define new_XNV() (void*)new_xnv()
8ac85365 807#define del_XNV(p) del_xnv((XPVNV*) p)
463ee0b2
LW		 808#endif
809
810#ifdef PURIFY
8990e307 811#define new_XRV() (void*)safemalloc(sizeof(XRV))
6ad3d225 812#define del_XRV(p) Safefree((char*)p)
ed6116ce 813#else
85e6fe83 814#define new_XRV() (void*)new_xrv()
8ac85365 815#define del_XRV(p) del_xrv((XRV*) p)
ed6116ce
LW		 816#endif
817
818#ifdef PURIFY
8990e307 819#define new_XPV() (void*)safemalloc(sizeof(XPV))
6ad3d225 820#define del_XPV(p) Safefree((char*)p)
463ee0b2 821#else
85e6fe83 822#define new_XPV() (void*)new_xpv()
8ac85365 823#define del_XPV(p) del_xpv((XPV *)p)
463ee0b2
LW		 824#endif
825
8c52afec
IZ		 826#ifdef PURIFY
827# define my_safemalloc(s) safemalloc(s)
86058a2d 828# define my_safefree(s) safefree(s)
8c52afec 829#else
9d8a25dc 830STATIC void*
4f63d024 831S_my_safemalloc(MEM_SIZE size)
8c52afec
IZ		 832{
833 char *p;
834 New(717, p, size, char);
835 return (void*)p;
836}
837# define my_safefree(s) Safefree(s)
838#endif
839
932e9ff9
VB		 840#ifdef PURIFY
841#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
842#define del_XPVIV(p) Safefree((char*)p)
843#else
844#define new_XPVIV() (void*)new_xpviv()
845#define del_XPVIV(p) del_xpviv((XPVIV *)p)
846#endif
8c52afec 847
932e9ff9
VB		 848#ifdef PURIFY
849#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
850#define del_XPVNV(p) Safefree((char*)p)
851#else
852#define new_XPVNV() (void*)new_xpvnv()
853#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
854#endif
855
856
857#ifdef PURIFY
858#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
859#define del_XPVCV(p) Safefree((char*)p)
860#else
861#define new_XPVCV() (void*)new_xpvcv()
862#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
863#endif
864
865#ifdef PURIFY
866#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
867#define del_XPVAV(p) Safefree((char*)p)
868#else
869#define new_XPVAV() (void*)new_xpvav()
870#define del_XPVAV(p) del_xpvav((XPVAV *)p)
871#endif
872
873#ifdef PURIFY
874#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
875#define del_XPVHV(p) Safefree((char*)p)
876#else
877#define new_XPVHV() (void*)new_xpvhv()
878#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
879#endif
8c52afec 880
932e9ff9
VB		 881#ifdef PURIFY
882#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
883#define del_XPVMG(p) Safefree((char*)p)
884#else
885#define new_XPVMG() (void*)new_xpvmg()
886#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
887#endif
8c52afec 888
932e9ff9
VB		 889#ifdef PURIFY
890#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
891#define del_XPVLV(p) Safefree((char*)p)
892#else
893#define new_XPVLV() (void*)new_xpvlv()
894#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
895#endif
8c52afec
IZ		 896
897#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
898#define del_XPVGV(p) my_safefree((char*)p)
899
932e9ff9
VB		 900#ifdef PURIFY
901#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
902#define del_XPVBM(p) Safefree((char*)p)
903#else
904#define new_XPVBM() (void*)new_xpvbm()
905#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
906#endif
8c52afec
IZ		 907
908#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
909#define del_XPVFM(p) my_safefree((char*)p)
910
911#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
912#define del_XPVIO(p) my_safefree((char*)p)
8990e307 913
79072805 914bool
864dbfa3 915Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
79072805
LW		 916{
917 char* pv;
918 U32 cur;
919 U32 len;
a0d0e21e 920 IV iv;
65202027 921 NV nv;
79072805
LW		 922 MAGIC* magic;
923 HV* stash;
924
925 if (SvTYPE(sv) == mt)
926 return TRUE;
927
a5f75d66
AD		 928 if (mt < SVt_PVIV)
929 (void)SvOOK_off(sv);
930
79072805
LW		 931 switch (SvTYPE(sv)) {
932 case SVt_NULL:
933 pv = 0;
934 cur = 0;
935 len = 0;
936 iv = 0;
937 nv = 0.0;
938 magic = 0;
939 stash = 0;
940 break;
79072805
LW		 941 case SVt_IV:
942 pv = 0;
943 cur = 0;
944 len = 0;
463ee0b2 945 iv = SvIVX(sv);
65202027 946 nv = (NV)SvIVX(sv);
79072805
LW		 947 del_XIV(SvANY(sv));
948 magic = 0;
949 stash = 0;
ed6116ce 950 if (mt == SVt_NV)
463ee0b2 951 mt = SVt_PVNV;
ed6116ce
LW		 952 else if (mt < SVt_PVIV)
953 mt = SVt_PVIV;
79072805
LW		 954 break;
955 case SVt_NV:
956 pv = 0;
957 cur = 0;
958 len = 0;
463ee0b2 959 nv = SvNVX(sv);
1bd302c3 960 iv = I_V(nv);
79072805
LW		 961 magic = 0;
962 stash = 0;
963 del_XNV(SvANY(sv));
964 SvANY(sv) = 0;
ed6116ce 965 if (mt < SVt_PVNV)
79072805
LW		 966 mt = SVt_PVNV;
967 break;
ed6116ce
LW		 968 case SVt_RV:
969 pv = (char*)SvRV(sv);
970 cur = 0;
971 len = 0;
56431972
RB		 972 iv = PTR2IV(pv);
973 nv = PTR2NV(pv);
ed6116ce
LW		 974 del_XRV(SvANY(sv));
975 magic = 0;
976 stash = 0;
977 break;
79072805 978 case SVt_PV:
463ee0b2 979 pv = SvPVX(sv);
79072805
LW		 980 cur = SvCUR(sv);
981 len = SvLEN(sv);
982 iv = 0;
983 nv = 0.0;
984 magic = 0;
985 stash = 0;
986 del_XPV(SvANY(sv));
748a9306
LW		 987 if (mt <= SVt_IV)
988 mt = SVt_PVIV;
989 else if (mt == SVt_NV)
990 mt = SVt_PVNV;
79072805
LW		 991 break;
992 case SVt_PVIV:
463ee0b2 993 pv = SvPVX(sv);
79072805
LW		 994 cur = SvCUR(sv);
995 len = SvLEN(sv);
463ee0b2 996 iv = SvIVX(sv);
79072805
LW		 997 nv = 0.0;
998 magic = 0;
999 stash = 0;
1000 del_XPVIV(SvANY(sv));
1001 break;
1002 case SVt_PVNV:
463ee0b2 1003 pv = SvPVX(sv);
79072805
LW		 1004 cur = SvCUR(sv);
1005 len = SvLEN(sv);
463ee0b2
LW		 1006 iv = SvIVX(sv);
1007 nv = SvNVX(sv);
79072805
LW		 1008 magic = 0;
1009 stash = 0;
1010 del_XPVNV(SvANY(sv));
1011 break;
1012 case SVt_PVMG:
463ee0b2 1013 pv = SvPVX(sv);
79072805
LW		 1014 cur = SvCUR(sv);
1015 len = SvLEN(sv);
463ee0b2
LW		 1016 iv = SvIVX(sv);
1017 nv = SvNVX(sv);
79072805
LW		 1018 magic = SvMAGIC(sv);
1019 stash = SvSTASH(sv);
1020 del_XPVMG(SvANY(sv));
1021 break;
1022 default:
cea2e8a9 1023 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
79072805
LW		 1024 }
1025
1026 switch (mt) {
1027 case SVt_NULL:
cea2e8a9 1028 Perl_croak(aTHX_ "Can't upgrade to undef");
79072805
LW		 1029 case SVt_IV:
1030 SvANY(sv) = new_XIV();
463ee0b2 1031 SvIVX(sv) = iv;
79072805
LW		 1032 break;
1033 case SVt_NV:
1034 SvANY(sv) = new_XNV();
463ee0b2 1035 SvNVX(sv) = nv;
79072805 1036 break;
ed6116ce
LW		 1037 case SVt_RV:
1038 SvANY(sv) = new_XRV();
1039 SvRV(sv) = (SV*)pv;
ed6116ce 1040 break;
79072805
LW		 1041 case SVt_PV:
1042 SvANY(sv) = new_XPV();
463ee0b2 1043 SvPVX(sv) = pv;
79072805
LW		 1044 SvCUR(sv) = cur;
1045 SvLEN(sv) = len;
1046 break;
1047 case SVt_PVIV:
1048 SvANY(sv) = new_XPVIV();
463ee0b2 1049 SvPVX(sv) = pv;
79072805
LW		 1050 SvCUR(sv) = cur;
1051 SvLEN(sv) = len;
463ee0b2 1052 SvIVX(sv) = iv;
79072805 1053 if (SvNIOK(sv))
a0d0e21e 1054 (void)SvIOK_on(sv);
79072805
LW		 1055 SvNOK_off(sv);
1056 break;
1057 case SVt_PVNV:
1058 SvANY(sv) = new_XPVNV();
463ee0b2 1059 SvPVX(sv) = pv;
79072805
LW		 1060 SvCUR(sv) = cur;
1061 SvLEN(sv) = len;
463ee0b2
LW		 1062 SvIVX(sv) = iv;
1063 SvNVX(sv) = nv;
79072805
LW		 1064 break;
1065 case SVt_PVMG:
1066 SvANY(sv) = new_XPVMG();
463ee0b2 1067 SvPVX(sv) = pv;
79072805
LW		 1068 SvCUR(sv) = cur;
1069 SvLEN(sv) = len;
463ee0b2
LW		 1070 SvIVX(sv) = iv;
1071 SvNVX(sv) = nv;
79072805
LW		 1072 SvMAGIC(sv) = magic;
1073 SvSTASH(sv) = stash;
1074 break;
1075 case SVt_PVLV:
1076 SvANY(sv) = new_XPVLV();
463ee0b2 1077 SvPVX(sv) = pv;
79072805
LW		 1078 SvCUR(sv) = cur;
1079 SvLEN(sv) = len;
463ee0b2
LW		 1080 SvIVX(sv) = iv;
1081 SvNVX(sv) = nv;
79072805
LW		 1082 SvMAGIC(sv) = magic;
1083 SvSTASH(sv) = stash;
1084 LvTARGOFF(sv) = 0;
1085 LvTARGLEN(sv) = 0;
1086 LvTARG(sv) = 0;
1087 LvTYPE(sv) = 0;
1088 break;
1089 case SVt_PVAV:
1090 SvANY(sv) = new_XPVAV();
463ee0b2
LW		 1091 if (pv)
1092 Safefree(pv);
2304df62 1093 SvPVX(sv) = 0;
d1bf51dd 1094 AvMAX(sv) = -1;
93965878 1095 AvFILLp(sv) = -1;
463ee0b2
LW		 1096 SvIVX(sv) = 0;
1097 SvNVX(sv) = 0.0;
1098 SvMAGIC(sv) = magic;
1099 SvSTASH(sv) = stash;
1100 AvALLOC(sv) = 0;
79072805
LW		 1101 AvARYLEN(sv) = 0;
1102 AvFLAGS(sv) = 0;
1103 break;
1104 case SVt_PVHV:
1105 SvANY(sv) = new_XPVHV();
463ee0b2
LW		 1106 if (pv)
1107 Safefree(pv);
1108 SvPVX(sv) = 0;
1109 HvFILL(sv) = 0;
1110 HvMAX(sv) = 0;
1111 HvKEYS(sv) = 0;
1112 SvNVX(sv) = 0.0;
79072805
LW		 1113 SvMAGIC(sv) = magic;
1114 SvSTASH(sv) = stash;
79072805
LW		 1115 HvRITER(sv) = 0;
1116 HvEITER(sv) = 0;
1117 HvPMROOT(sv) = 0;
1118 HvNAME(sv) = 0;
79072805
LW		 1119 break;
1120 case SVt_PVCV:
1121 SvANY(sv) = new_XPVCV();
748a9306 1122 Zero(SvANY(sv), 1, XPVCV);
463ee0b2 1123 SvPVX(sv) = pv;
79072805
LW		 1124 SvCUR(sv) = cur;
1125 SvLEN(sv) = len;
463ee0b2
LW		 1126 SvIVX(sv) = iv;
1127 SvNVX(sv) = nv;
79072805
LW		 1128 SvMAGIC(sv) = magic;
1129 SvSTASH(sv) = stash;
79072805
LW		 1130 break;
1131 case SVt_PVGV:
1132 SvANY(sv) = new_XPVGV();
463ee0b2 1133 SvPVX(sv) = pv;
79072805
LW		 1134 SvCUR(sv) = cur;
1135 SvLEN(sv) = len;
463ee0b2
LW		 1136 SvIVX(sv) = iv;
1137 SvNVX(sv) = nv;
79072805
LW		 1138 SvMAGIC(sv) = magic;
1139 SvSTASH(sv) = stash;
93a17b20 1140 GvGP(sv) = 0;
79072805
LW		 1141 GvNAME(sv) = 0;
1142 GvNAMELEN(sv) = 0;
1143 GvSTASH(sv) = 0;
a5f75d66 1144 GvFLAGS(sv) = 0;
79072805
LW		 1145 break;
1146 case SVt_PVBM:
1147 SvANY(sv) = new_XPVBM();
463ee0b2 1148 SvPVX(sv) = pv;
79072805
LW		 1149 SvCUR(sv) = cur;
1150 SvLEN(sv) = len;
463ee0b2
LW		 1151 SvIVX(sv) = iv;
1152 SvNVX(sv) = nv;
79072805
LW		 1153 SvMAGIC(sv) = magic;
1154 SvSTASH(sv) = stash;
1155 BmRARE(sv) = 0;
1156 BmUSEFUL(sv) = 0;
1157 BmPREVIOUS(sv) = 0;
1158 break;
1159 case SVt_PVFM:
1160 SvANY(sv) = new_XPVFM();
748a9306 1161 Zero(SvANY(sv), 1, XPVFM);
463ee0b2 1162 SvPVX(sv) = pv;
79072805
LW		 1163 SvCUR(sv) = cur;
1164 SvLEN(sv) = len;
463ee0b2
LW		 1165 SvIVX(sv) = iv;
1166 SvNVX(sv) = nv;
79072805
LW		 1167 SvMAGIC(sv) = magic;
1168 SvSTASH(sv) = stash;
79072805 1169 break;
8990e307
LW		 1170 case SVt_PVIO:
1171 SvANY(sv) = new_XPVIO();
748a9306 1172 Zero(SvANY(sv), 1, XPVIO);
8990e307
LW		 1173 SvPVX(sv) = pv;
1174 SvCUR(sv) = cur;
1175 SvLEN(sv) = len;
1176 SvIVX(sv) = iv;
1177 SvNVX(sv) = nv;
1178 SvMAGIC(sv) = magic;
1179 SvSTASH(sv) = stash;
85e6fe83 1180 IoPAGE_LEN(sv) = 60;
8990e307
LW		 1181 break;
1182 }
1183 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 SvFLAGS(sv) |= mt;
79072805
LW		 1185 return TRUE;
1186}
1187
79072805 1188int
864dbfa3 1189Perl_sv_backoff(pTHX_ register SV *sv)
79072805
LW		 1190{
1191 assert(SvOOK(sv));
463ee0b2
LW		 1192 if (SvIVX(sv)) {
1193 char *s = SvPVX(sv);
1194 SvLEN(sv) += SvIVX(sv);
1195 SvPVX(sv) -= SvIVX(sv);
79072805 1196 SvIV_set(sv, 0);
463ee0b2 1197 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW		 1198 }
1199 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 1200 return 0;
79072805
LW		 1201}
1202
1203char *
864dbfa3 1204Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
79072805
LW		 1205{
1206 register char *s;
1207
55497cff 1208#ifdef HAS_64K_LIMIT
79072805 1209 if (newlen >= 0x10000) {
b900a521
JH		 1210 PerlIO_printf(Perl_debug_log,
1211 "Allocation too large: %"UVxf"\n", (UV)newlen);
79072805
LW		 1212 my_exit(1);
1213 }
55497cff 1214#endif /* HAS_64K_LIMIT */
a0d0e21e
LW		 1215 if (SvROK(sv))
1216 sv_unref(sv);
79072805
LW		 1217 if (SvTYPE(sv) < SVt_PV) {
1218 sv_upgrade(sv, SVt_PV);
463ee0b2 1219 s = SvPVX(sv);
79072805
LW		 1220 }
1221 else if (SvOOK(sv)) { /* pv is offset? */
1222 sv_backoff(sv);
463ee0b2 1223 s = SvPVX(sv);
79072805
LW		 1224 if (newlen > SvLEN(sv))
1225 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
c6f8c383
GA		 1226#ifdef HAS_64K_LIMIT
1227 if (newlen >= 0x10000)
1228 newlen = 0xFFFF;
1229#endif
79072805
LW		 1230 }
1231 else
463ee0b2 1232 s = SvPVX(sv);
79072805 1233 if (newlen > SvLEN(sv)) { /* need more room? */
8d6dde3e 1234 if (SvLEN(sv) && s) {
1fe09876 1235#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
8d6dde3e
IZ		 1236 STRLEN l = malloced_size((void*)SvPVX(sv));
1237 if (newlen <= l) {
1238 SvLEN_set(sv, l);
1239 return s;
1240 } else
c70c8a0a 1241#endif
79072805 1242 Renew(s,newlen,char);
8d6dde3e 1243 }
79072805
LW		 1244 else
1245 New(703,s,newlen,char);
1246 SvPV_set(sv, s);
1247 SvLEN_set(sv, newlen);
1248 }
1249 return s;
1250}
1251
1252void
864dbfa3 1253Perl_sv_setiv(pTHX_ register SV *sv, IV i)
79072805 1254{
2213622d 1255 SV_CHECK_THINKFIRST(sv);
463ee0b2
LW		 1256 switch (SvTYPE(sv)) {
1257 case SVt_NULL:
79072805 1258 sv_upgrade(sv, SVt_IV);
463ee0b2
LW		 1259 break;
1260 case SVt_NV:
1261 sv_upgrade(sv, SVt_PVNV);
1262 break;
ed6116ce 1263 case SVt_RV:
463ee0b2 1264 case SVt_PV:
79072805 1265 sv_upgrade(sv, SVt_PVIV);
463ee0b2 1266 break;
a0d0e21e
LW		 1267
1268 case SVt_PVGV:
a0d0e21e
LW		 1269 case SVt_PVAV:
1270 case SVt_PVHV:
1271 case SVt_PVCV:
1272 case SVt_PVFM:
1273 case SVt_PVIO:
11343788
MB		 1274 {
1275 dTHR;
cea2e8a9 1276 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
22c35a8c 1277 PL_op_desc[PL_op->op_type]);
11343788 1278 }
463ee0b2 1279 }
a0d0e21e 1280 (void)SvIOK_only(sv); /* validate number */
a5f75d66 1281 SvIVX(sv) = i;
463ee0b2 1282 SvTAINT(sv);
79072805
LW		 1283}
1284
1285void
864dbfa3 1286Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
ef50df4b
GS		 1287{
1288 sv_setiv(sv,i);
1289 SvSETMAGIC(sv);
1290}
1291
1292void
864dbfa3 1293Perl_sv_setuv(pTHX_ register SV *sv, UV u)
55497cff 1294{
25da4f38
IZ		 1295 sv_setiv(sv, 0);
1296 SvIsUV_on(sv);
1297 SvUVX(sv) = u;
55497cff
PP		 1298}
1299
1300void
864dbfa3 1301Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b
GS		 1302{
1303 sv_setuv(sv,u);
1304 SvSETMAGIC(sv);
1305}
1306
1307void
65202027 1308Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 1309{
2213622d 1310 SV_CHECK_THINKFIRST(sv);
a0d0e21e
LW		 1311 switch (SvTYPE(sv)) {
1312 case SVt_NULL:
1313 case SVt_IV:
79072805 1314 sv_upgrade(sv, SVt_NV);
a0d0e21e 1315 break;
a0d0e21e
LW		 1316 case SVt_RV:
1317 case SVt_PV:
1318 case SVt_PVIV:
79072805 1319 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 1320 break;
827b7e14 1321
a0d0e21e 1322 case SVt_PVGV:
a0d0e21e
LW		 1323 case SVt_PVAV:
1324 case SVt_PVHV:
1325 case SVt_PVCV:
1326 case SVt_PVFM:
1327 case SVt_PVIO:
11343788
MB		 1328 {
1329 dTHR;
cea2e8a9 1330 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
22c35a8c 1331 PL_op_name[PL_op->op_type]);
11343788 1332 }
79072805 1333 }
463ee0b2 1334 SvNVX(sv) = num;
a0d0e21e 1335 (void)SvNOK_only(sv); /* validate number */
463ee0b2 1336 SvTAINT(sv);
79072805
LW		 1337}
1338
ef50df4b 1339void
65202027 1340Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS		 1341{
1342 sv_setnv(sv,num);
1343 SvSETMAGIC(sv);
1344}
1345
76e3520e 1346STATIC void
cea2e8a9 1347S_not_a_number(pTHX_ SV *sv)
a0d0e21e 1348{
11343788 1349 dTHR;
a0d0e21e
LW		 1350 char tmpbuf[64];
1351 char *d = tmpbuf;
1352 char *s;
dc28f22b
GA		 1353 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1354 /* each *s can expand to 4 chars + "...\0",
1355 i.e. need room for 8 chars */
a0d0e21e 1356
dc28f22b 1357 for (s = SvPVX(sv); *s && d < limit; s++) {
bbce6d69
PP		 1358 int ch = *s & 0xFF;
1359 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW		 1360 *d++ = 'M';
1361 *d++ = '-';
1362 ch &= 127;
1363 }
bbce6d69
PP		 1364 if (ch == '\n') {
1365 *d++ = '\\';
1366 *d++ = 'n';
1367 }
1368 else if (ch == '\r') {
1369 *d++ = '\\';
1370 *d++ = 'r';
1371 }
1372 else if (ch == '\f') {
1373 *d++ = '\\';
1374 *d++ = 'f';
1375 }
1376 else if (ch == '\\') {
1377 *d++ = '\\';
1378 *d++ = '\\';
1379 }
1380 else if (isPRINT_LC(ch))
a0d0e21e
LW		 1381 *d++ = ch;
1382 else {
1383 *d++ = '^';
bbce6d69 1384 *d++ = toCTRL(ch);
a0d0e21e
LW		 1385 }
1386 }
1387 if (*s) {
1388 *d++ = '.';
1389 *d++ = '.';
1390 *d++ = '.';
1391 }
1392 *d = '\0';
1393
533c011a 1394 if (PL_op)
42d38218
MS		 1395 Perl_warner(aTHX_ WARN_NUMERIC,
1396 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1397 PL_op_desc[PL_op->op_type]);
a0d0e21e 1398 else
42d38218
MS		 1399 Perl_warner(aTHX_ WARN_NUMERIC,
1400 "Argument \"%s\" isn't numeric", tmpbuf);
a0d0e21e
LW		 1401}
1402
cf2093f6 1403/* the number can be converted to integer with atol() or atoll() */
25da4f38
IZ		 1404#define IS_NUMBER_TO_INT_BY_ATOL 0x01
1405#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1406#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1407#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1408
1409/* Actually, ISO C leaves conversion of UV to IV undefined, but
1410 until proven guilty, assume that things are not that bad... */
1411
a0d0e21e 1412IV
864dbfa3 1413Perl_sv_2iv(pTHX_ register SV *sv)
79072805
LW		 1414{
1415 if (!sv)
1416 return 0;
8990e307 1417 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1418 mg_get(sv);
1419 if (SvIOKp(sv))
1420 return SvIVX(sv);
748a9306 1421 if (SvNOKp(sv)) {
25da4f38 1422 return I_V(SvNVX(sv));
748a9306 1423 }
36477c24
PP		 1424 if (SvPOKp(sv) && SvLEN(sv))
1425 return asIV(sv);
3fe9a6f1 1426 if (!SvROK(sv)) {
d008e5eb 1427 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1428 dTHR;
d008e5eb 1429 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
cea2e8a9 1430 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
c6ee37c5 1431 }
36477c24 1432 return 0;
3fe9a6f1 1433 }
463ee0b2 1434 }
ed6116ce 1435 if (SvTHINKFIRST(sv)) {
a0d0e21e 1436 if (SvROK(sv)) {
a0d0e21e
LW		 1437 SV* tmpstr;
1438 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
9e7bc3e8 1439 return SvIV(tmpstr);
56431972 1440 return PTR2IV(SvRV(sv));
a0d0e21e 1441 }
0336b60e
IZ		 1442 if (SvREADONLY(sv) && !SvOK(sv)) {
1443 dTHR;
1444 if (ckWARN(WARN_UNINITIALIZED))
1445 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
ed6116ce
LW		 1446 return 0;
1447 }
79072805 1448 }
25da4f38
IZ		 1449 if (SvIOKp(sv)) {
1450 if (SvIsUV(sv)) {
1451 return (IV)(SvUVX(sv));
1452 }
1453 else {
1454 return SvIVX(sv);
1455 }
463ee0b2 1456 }
748a9306 1457 if (SvNOKp(sv)) {
25da4f38
IZ		 1458 /* We can cache the IV/UV value even if it not good enough
1459 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1460 * NV over IV/UV.
25da4f38
IZ		 1461 */
1462
1463 if (SvTYPE(sv) == SVt_NV)
1464 sv_upgrade(sv, SVt_PVNV);
1465
a5f75d66 1466 (void)SvIOK_on(sv);
65202027 1467 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
748a9306 1468 SvIVX(sv) = I_V(SvNVX(sv));
25da4f38 1469 else {
ff68c719 1470 SvUVX(sv) = U_V(SvNVX(sv));
25da4f38
IZ		 1471 SvIsUV_on(sv);
1472 ret_iv_max:
cf2093f6 1473 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 1474 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 1475 PTR2UV(sv),
57def98f
JH		 1476 SvUVX(sv),
1477 SvUVX(sv)));
25da4f38
IZ		 1478 return (IV)SvUVX(sv);
1479 }
748a9306
LW		 1480 }
1481 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1482 I32 numtype = looks_like_number(sv);
1483
1484 /* We want to avoid a possible problem when we cache an IV which
1485 may be later translated to an NV, and the resulting NV is not
1486 the translation of the initial data.
1487
1488 This means that if we cache such an IV, we need to cache the
1489 NV as well. Moreover, we trade speed for space, and do not
1490 cache the NV if not needed.
1491 */
1492 if (numtype & IS_NUMBER_NOT_IV) {
1493 /* May be not an integer. Need to cache NV if we cache IV
1494 * - otherwise future conversion to NV will be wrong. */
65202027 1495 NV d;
25da4f38 1496
097ee67d 1497 d = Atof(SvPVX(sv));
25da4f38
IZ		 1498
1499 if (SvTYPE(sv) < SVt_PVNV)
1500 sv_upgrade(sv, SVt_PVNV);
1501 SvNVX(sv) = d;
1502 (void)SvNOK_on(sv);
1503 (void)SvIOK_on(sv);
65202027 1504#if defined(USE_LONG_DOUBLE)
b900a521
JH		 1505 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1506 PTR2UV(sv), SvNVX(sv)));
65202027 1507#else
b900a521
JH		 1508 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1509 PTR2UV(sv), SvNVX(sv)));
65202027 1510#endif
65202027 1511 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
25da4f38
IZ		 1512 SvIVX(sv) = I_V(SvNVX(sv));
1513 else {
1514 SvUVX(sv) = U_V(SvNVX(sv));
1515 SvIsUV_on(sv);
1516 goto ret_iv_max;
1517 }
1518 }
1519 else if (numtype) {
1520 /* The NV may be reconstructed from IV - safe to cache IV,
1521 which may be calculated by atol(). */
1522 if (SvTYPE(sv) == SVt_PV)
1523 sv_upgrade(sv, SVt_PVIV);
1524 (void)SvIOK_on(sv);
cf2093f6 1525 SvIVX(sv) = Atol(SvPVX(sv));
25da4f38
IZ		 1526 }
1527 else { /* Not a number. Cache 0. */
1528 dTHR;
1529
1530 if (SvTYPE(sv) < SVt_PVIV)
1531 sv_upgrade(sv, SVt_PVIV);
1532 SvIVX(sv) = 0;
1533 (void)SvIOK_on(sv);
1534 if (ckWARN(WARN_NUMERIC))
1535 not_a_number(sv);
1536 }
93a17b20 1537 }
79072805 1538 else {
11343788 1539 dTHR;
599cee73 1540 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
cea2e8a9 1541 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
25da4f38
IZ		 1542 if (SvTYPE(sv) < SVt_IV)
1543 /* Typically the caller expects that sv_any is not NULL now. */
1544 sv_upgrade(sv, SVt_IV);
a0d0e21e 1545 return 0;
79072805 1546 }
b900a521
JH		 1547 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1548 PTR2UV(sv),SvIVX(sv)));
25da4f38 1549 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW		 1550}
1551
ff68c719 1552UV
864dbfa3 1553Perl_sv_2uv(pTHX_ register SV *sv)
ff68c719
PP		 1554{
1555 if (!sv)
1556 return 0;
1557 if (SvGMAGICAL(sv)) {
1558 mg_get(sv);
1559 if (SvIOKp(sv))
1560 return SvUVX(sv);
1561 if (SvNOKp(sv))
1562 return U_V(SvNVX(sv));
36477c24
PP		 1563 if (SvPOKp(sv) && SvLEN(sv))
1564 return asUV(sv);
3fe9a6f1 1565 if (!SvROK(sv)) {
d008e5eb 1566 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1567 dTHR;
d008e5eb 1568 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
cea2e8a9 1569 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
c6ee37c5 1570 }
36477c24 1571 return 0;
3fe9a6f1 1572 }
ff68c719
PP		 1573 }
1574 if (SvTHINKFIRST(sv)) {
1575 if (SvROK(sv)) {
ff68c719
PP		 1576 SV* tmpstr;
1577 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
9e7bc3e8 1578 return SvUV(tmpstr);
56431972 1579 return PTR2UV(SvRV(sv));
ff68c719 1580 }
0336b60e
IZ		 1581 if (SvREADONLY(sv) && !SvOK(sv)) {
1582 dTHR;
1583 if (ckWARN(WARN_UNINITIALIZED))
1584 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
ff68c719
PP		 1585 return 0;
1586 }
1587 }
25da4f38
IZ		 1588 if (SvIOKp(sv)) {
1589 if (SvIsUV(sv)) {
1590 return SvUVX(sv);
1591 }
1592 else {
1593 return (UV)SvIVX(sv);
1594 }
ff68c719
PP		 1595 }
1596 if (SvNOKp(sv)) {
25da4f38
IZ		 1597 /* We can cache the IV/UV value even if it not good enough
1598 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1599 * NV over IV/UV.
25da4f38
IZ		 1600 */
1601 if (SvTYPE(sv) == SVt_NV)
1602 sv_upgrade(sv, SVt_PVNV);
ff68c719 1603 (void)SvIOK_on(sv);
25da4f38
IZ		 1604 if (SvNVX(sv) >= -0.5) {
1605 SvIsUV_on(sv);
1606 SvUVX(sv) = U_V(SvNVX(sv));
1607 }
1608 else {
1609 SvIVX(sv) = I_V(SvNVX(sv));
1610 ret_zero:
cf2093f6 1611 DEBUG_c(PerlIO_printf(Perl_debug_log,
07270b1a 1612 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
57def98f
JH		 1613 PTR2UV(sv),
1614 SvIVX(sv),
1615 (IV)(UV)SvIVX(sv)));
25da4f38
IZ		 1616 return (UV)SvIVX(sv);
1617 }
ff68c719
PP		 1618 }
1619 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1620 I32 numtype = looks_like_number(sv);
1621
1622 /* We want to avoid a possible problem when we cache a UV which
1623 may be later translated to an NV, and the resulting NV is not
1624 the translation of the initial data.
1625
1626 This means that if we cache such a UV, we need to cache the
1627 NV as well. Moreover, we trade speed for space, and do not
1628 cache the NV if not needed.
1629 */
1630 if (numtype & IS_NUMBER_NOT_IV) {
1631 /* May be not an integer. Need to cache NV if we cache IV
1632 * - otherwise future conversion to NV will be wrong. */
65202027 1633 NV d;
25da4f38 1634
cf2093f6 1635 d = Atof(SvPVX(sv));
25da4f38
IZ		 1636
1637 if (SvTYPE(sv) < SVt_PVNV)
1638 sv_upgrade(sv, SVt_PVNV);
1639 SvNVX(sv) = d;
1640 (void)SvNOK_on(sv);
1641 (void)SvIOK_on(sv);
65202027 1642#if defined(USE_LONG_DOUBLE)
b900a521
JH		 1643 DEBUG_c(PerlIO_printf(Perl_debug_log,
1644 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1645 PTR2UV(sv), SvNVX(sv)));
65202027 1646#else
b900a521
JH		 1647 DEBUG_c(PerlIO_printf(Perl_debug_log,
1648 "0x%"UVxf" 2nv(%g)\n",
1649 PTR2UV(sv), SvNVX(sv)));
65202027 1650#endif
25da4f38
IZ		 1651 if (SvNVX(sv) < -0.5) {
1652 SvIVX(sv) = I_V(SvNVX(sv));
1653 goto ret_zero;
1654 } else {
1655 SvUVX(sv) = U_V(SvNVX(sv));
1656 SvIsUV_on(sv);
1657 }
1658 }
1659 else if (numtype & IS_NUMBER_NEG) {
1660 /* The NV may be reconstructed from IV - safe to cache IV,
1661 which may be calculated by atol(). */
1662 if (SvTYPE(sv) == SVt_PV)
1663 sv_upgrade(sv, SVt_PVIV);
1664 (void)SvIOK_on(sv);
cf2093f6 1665 SvIVX(sv) = (IV)Atol(SvPVX(sv));
25da4f38
IZ		 1666 }
1667 else if (numtype) { /* Non-negative */
1668 /* The NV may be reconstructed from UV - safe to cache UV,
1669 which may be calculated by strtoul()/atol. */
1670 if (SvTYPE(sv) == SVt_PV)
1671 sv_upgrade(sv, SVt_PVIV);
1672 (void)SvIOK_on(sv);
1673 (void)SvIsUV_on(sv);
1674#ifdef HAS_STRTOUL
cf2093f6 1675 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
25da4f38
IZ		 1676#else /* no atou(), but we know the number fits into IV... */
1677 /* The only problem may be if it is negative... */
cf2093f6 1678 SvUVX(sv) = (UV)Atol(SvPVX(sv));
25da4f38
IZ		 1679#endif
1680 }
1681 else { /* Not a number. Cache 0. */
1682 dTHR;
1683
1684 if (SvTYPE(sv) < SVt_PVIV)
1685 sv_upgrade(sv, SVt_PVIV);
1686 SvUVX(sv) = 0; /* We assume that 0s have the
1687 same bitmap in IV and UV. */
1688 (void)SvIOK_on(sv);
1689 (void)SvIsUV_on(sv);
1690 if (ckWARN(WARN_NUMERIC))
1691 not_a_number(sv);
1692 }
ff68c719
PP		 1693 }
1694 else {
d008e5eb 1695 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1696 dTHR;
d008e5eb 1697 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
cea2e8a9 1698 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
c6ee37c5 1699 }
25da4f38
IZ		 1700 if (SvTYPE(sv) < SVt_IV)
1701 /* Typically the caller expects that sv_any is not NULL now. */
1702 sv_upgrade(sv, SVt_IV);
ff68c719
PP		 1703 return 0;
1704 }
25da4f38 1705
7b0972df 1706 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
4265b575 1707 PTR2UV(sv),SvUVX(sv)));
25da4f38 1708 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP		 1709}
1710
65202027 1711NV
864dbfa3 1712Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW		 1713{
1714 if (!sv)
1715 return 0.0;
8990e307 1716 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1717 mg_get(sv);
1718 if (SvNOKp(sv))
1719 return SvNVX(sv);
a0d0e21e 1720 if (SvPOKp(sv) && SvLEN(sv)) {
d008e5eb 1721 dTHR;
599cee73 1722 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1723 not_a_number(sv);
097ee67d 1724 return Atof(SvPVX(sv));
a0d0e21e 1725 }
25da4f38
IZ		 1726 if (SvIOKp(sv)) {
1727 if (SvIsUV(sv))
65202027 1728 return (NV)SvUVX(sv);
25da4f38 1729 else
65202027 1730 return (NV)SvIVX(sv);
25da4f38 1731 }
16d20bd9 1732 if (!SvROK(sv)) {
d008e5eb 1733 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1734 dTHR;
d008e5eb 1735 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
cea2e8a9 1736 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
c6ee37c5 1737 }
16d20bd9
AD		 1738 return 0;
1739 }
463ee0b2 1740 }
ed6116ce 1741 if (SvTHINKFIRST(sv)) {
a0d0e21e 1742 if (SvROK(sv)) {
a0d0e21e
LW		 1743 SV* tmpstr;
1744 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
9e7bc3e8 1745 return SvNV(tmpstr);
56431972 1746 return PTR2NV(SvRV(sv));
a0d0e21e 1747 }
0336b60e 1748 if (SvREADONLY(sv) && !SvOK(sv)) {
d008e5eb 1749 dTHR;
599cee73 1750 if (ckWARN(WARN_UNINITIALIZED))
cea2e8a9 1751 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
ed6116ce
LW		 1752 return 0.0;
1753 }
79072805
LW		 1754 }
1755 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW		 1756 if (SvTYPE(sv) == SVt_IV)
1757 sv_upgrade(sv, SVt_PVNV);
1758 else
1759 sv_upgrade(sv, SVt_NV);
572bbb43 1760#if defined(USE_LONG_DOUBLE)
097ee67d
JH		 1761 DEBUG_c({
1762 RESTORE_NUMERIC_STANDARD();
b900a521
JH		 1763 PerlIO_printf(Perl_debug_log,
1764 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1765 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 1766 RESTORE_NUMERIC_LOCAL();
1767 });
65202027 1768#else
572bbb43
GS		 1769 DEBUG_c({
1770 RESTORE_NUMERIC_STANDARD();
b900a521
JH		 1771 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1772 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 1773 RESTORE_NUMERIC_LOCAL();
1774 });
572bbb43 1775#endif
79072805
LW		 1776 }
1777 else if (SvTYPE(sv) < SVt_PVNV)
1778 sv_upgrade(sv, SVt_PVNV);
748a9306
LW		 1779 if (SvIOKp(sv) &&
1780 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 1781 {
65202027 1782 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
93a17b20 1783 }
748a9306 1784 else if (SvPOKp(sv) && SvLEN(sv)) {
d008e5eb 1785 dTHR;
599cee73 1786 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1787 not_a_number(sv);
097ee67d 1788 SvNVX(sv) = Atof(SvPVX(sv));
93a17b20 1789 }
79072805 1790 else {
11343788 1791 dTHR;
599cee73 1792 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
cea2e8a9 1793 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
25da4f38
IZ		 1794 if (SvTYPE(sv) < SVt_NV)
1795 /* Typically the caller expects that sv_any is not NULL now. */
1796 sv_upgrade(sv, SVt_NV);
a0d0e21e 1797 return 0.0;
79072805
LW		 1798 }
1799 SvNOK_on(sv);
572bbb43 1800#if defined(USE_LONG_DOUBLE)
097ee67d
JH		 1801 DEBUG_c({
1802 RESTORE_NUMERIC_STANDARD();
b900a521
JH		 1803 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1804 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 1805 RESTORE_NUMERIC_LOCAL();
1806 });
65202027 1807#else
572bbb43
GS		 1808 DEBUG_c({
1809 RESTORE_NUMERIC_STANDARD();
b900a521
JH		 1810 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1811 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 1812 RESTORE_NUMERIC_LOCAL();
1813 });
572bbb43 1814#endif
463ee0b2 1815 return SvNVX(sv);
79072805
LW		 1816}
1817
76e3520e 1818STATIC IV
cea2e8a9 1819S_asIV(pTHX_ SV *sv)
36477c24
PP		 1820{
1821 I32 numtype = looks_like_number(sv);
65202027 1822 NV d;
36477c24 1823
25da4f38 1824 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1825 return Atol(SvPVX(sv));
d008e5eb
GS		 1826 if (!numtype) {
1827 dTHR;
1828 if (ckWARN(WARN_NUMERIC))
1829 not_a_number(sv);
1830 }
097ee67d 1831 d = Atof(SvPVX(sv));
25da4f38 1832 return I_V(d);
36477c24
PP		 1833}
1834
76e3520e 1835STATIC UV
cea2e8a9 1836S_asUV(pTHX_ SV *sv)
36477c24
PP		 1837{
1838 I32 numtype = looks_like_number(sv);
1839
84902520 1840#ifdef HAS_STRTOUL
25da4f38 1841 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1842 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 1843#endif
d008e5eb
GS		 1844 if (!numtype) {
1845 dTHR;
1846 if (ckWARN(WARN_NUMERIC))
1847 not_a_number(sv);
1848 }
097ee67d 1849 return U_V(Atof(SvPVX(sv)));
36477c24
PP		 1850}
1851
25da4f38
IZ		 1852/*
1853 * Returns a combination of (advisory only - can get false negatives)
1854 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1855 * IS_NUMBER_NEG
1856 * 0 if does not look like number.
1857 *
1858 * In fact possible values are 0 and
1859 * IS_NUMBER_TO_INT_BY_ATOL 123
1860 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1861 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1862 * with a possible addition of IS_NUMBER_NEG.
1863 */
1864
36477c24 1865I32
864dbfa3 1866Perl_looks_like_number(pTHX_ SV *sv)
36477c24
PP		 1867{
1868 register char *s;
1869 register char *send;
1870 register char *sbegin;
25da4f38
IZ		 1871 register char *nbegin;
1872 I32 numtype = 0;
36477c24
PP		 1873 STRLEN len;
1874
1875 if (SvPOK(sv)) {
1876 sbegin = SvPVX(sv);
1877 len = SvCUR(sv);
1878 }
1879 else if (SvPOKp(sv))
1880 sbegin = SvPV(sv, len);
1881 else
1882 return 1;
1883 send = sbegin + len;
1884
1885 s = sbegin;
1886 while (isSPACE(*s))
1887 s++;
25da4f38
IZ		 1888 if (*s == '-') {
1889 s++;
1890 numtype = IS_NUMBER_NEG;
1891 }
1892 else if (*s == '+')
36477c24 1893 s++;
ff0cee69 1894
25da4f38
IZ		 1895 nbegin = s;
1896 /*
097ee67d
JH		 1897 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1898 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1899 * (int)atof().
25da4f38
IZ		 1900 */
1901
097ee67d 1902 /* next must be digit or the radix separator */
ff0cee69
PP		 1903 if (isDIGIT(*s)) {
1904 do {
1905 s++;
1906 } while (isDIGIT(*s));
25da4f38
IZ		 1907
1908 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1909 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1910 else
1911 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1912
097ee67d
JH		 1913 if (*s == '.'
1914#ifdef USE_LOCALE_NUMERIC
1915 || IS_NUMERIC_RADIX(*s)
1916#endif
1917 ) {
ff0cee69 1918 s++;
25da4f38 1919 numtype |= IS_NUMBER_NOT_IV;
097ee67d 1920 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69
PP		 1921 s++;
1922 }
36477c24 1923 }
097ee67d
JH		 1924 else if (*s == '.'
1925#ifdef USE_LOCALE_NUMERIC
1926 || IS_NUMERIC_RADIX(*s)
1927#endif
1928 ) {
ff0cee69 1929 s++;
25da4f38 1930 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
097ee67d 1931 /* no digits before the radix means we need digits after it */
ff0cee69
PP		 1932 if (isDIGIT(*s)) {
1933 do {
1934 s++;
1935 } while (isDIGIT(*s));
1936 }
1937 else
1938 return 0;
1939 }
1940 else
1941 return 0;
1942
ff0cee69 1943 /* we can have an optional exponent part */
36477c24 1944 if (*s == 'e' || *s == 'E') {
25da4f38
IZ		 1945 numtype &= ~IS_NUMBER_NEG;
1946 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
36477c24
PP		 1947 s++;
1948 if (*s == '+' || *s == '-')
1949 s++;
ff0cee69
PP		 1950 if (isDIGIT(*s)) {
1951 do {
1952 s++;
1953 } while (isDIGIT(*s));
1954 }
1955 else
1956 return 0;
36477c24
PP		 1957 }
1958 while (isSPACE(*s))
1959 s++;
1960 if (s >= send)
1961 return numtype;
1962 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 1963 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24
PP		 1964 return 0;
1965}
1966
79072805 1967char *
864dbfa3 1968Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD		 1969{
1970 STRLEN n_a;
1971 return sv_2pv(sv, &n_a);
1972}
1973
25da4f38 1974/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 1975static char *
25da4f38
IZ		 1976uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1977{
1978 STRLEN len;
1979 char *ptr = buf + TYPE_CHARS(UV);
1980 char *ebuf = ptr;
1981 int sign;
1982 char *p;
1983
1984 if (is_uv)
1985 sign = 0;
1986 else if (iv >= 0) {
1987 uv = iv;
1988 sign = 0;
1989 } else {
1990 uv = -iv;
1991 sign = 1;
1992 }
1993 do {
1994 *--ptr = '0' + (uv % 10);
1995 } while (uv /= 10);
1996 if (sign)
1997 *--ptr = '-';
1998 *peob = ebuf;
1999 return ptr;
2000}
2001
1fa8b10d 2002char *
864dbfa3 2003Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805
LW		 2004{
2005 register char *s;
2006 int olderrno;
46fc3d4c 2007 SV *tsv;
25da4f38
IZ		 2008 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2009 char *tmpbuf = tbuf;
79072805 2010
463ee0b2
LW		 2011 if (!sv) {
2012 *lp = 0;
2013 return "";
2014 }
8990e307 2015 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 2016 mg_get(sv);
2017 if (SvPOKp(sv)) {
2018 *lp = SvCUR(sv);
2019 return SvPVX(sv);
2020 }
cf2093f6 2021 if (SvIOKp(sv)) {
cf2093f6 2022 if (SvIsUV(sv))
57def98f 2023 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2024 else
57def98f 2025 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2026 tsv = Nullsv;
a0d0e21e 2027 goto tokensave;
463ee0b2
LW		 2028 }
2029 if (SvNOKp(sv)) {
2d4389e4 2030 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2031 tsv = Nullsv;
a0d0e21e 2032 goto tokensave;
463ee0b2 2033 }
16d20bd9 2034 if (!SvROK(sv)) {
d008e5eb 2035 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 2036 dTHR;
d008e5eb 2037 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
cea2e8a9 2038 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
c6ee37c5 2039 }
16d20bd9
AD		 2040 *lp = 0;
2041 return "";
2042 }
463ee0b2 2043 }
ed6116ce
LW		 2044 if (SvTHINKFIRST(sv)) {
2045 if (SvROK(sv)) {
a0d0e21e
LW		 2046 SV* tmpstr;
2047 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
9e7bc3e8 2048 return SvPV(tmpstr,*lp);
ed6116ce
LW		 2049 sv = (SV*)SvRV(sv);
2050 if (!sv)
2051 s = "NULLREF";
2052 else {
f9277f47
IZ		 2053 MAGIC *mg;
2054
ed6116ce 2055 switch (SvTYPE(sv)) {
f9277f47
IZ		 2056 case SVt_PVMG:
2057 if ( ((SvFLAGS(sv) &
2058 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2059 == (SVs_OBJECT|SVs_RMG))
57668c4d 2060 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
f9277f47 2061 && (mg = mg_find(sv, 'r'))) {
5c0ca799 2062 dTHR;
2cd61cdb 2063 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2064
2cd61cdb 2065 if (!mg->mg_ptr) {
8782bef2
GB		 2066 char *fptr = "msix";
2067 char reflags[6];
2068 char ch;
2069 int left = 0;
2070 int right = 4;
2071 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2072
2073 while(ch = *fptr++) {
2074 if(reganch & 1) {
2075 reflags[left++] = ch;
2076 }
2077 else {
2078 reflags[right--] = ch;
2079 }
2080 reganch >>= 1;
2081 }
2082 if(left != 4) {
2083 reflags[left] = '-';
2084 left = 5;
2085 }
2086
2087 mg->mg_len = re->prelen + 4 + left;
2088 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2089 Copy("(?", mg->mg_ptr, 2, char);
2090 Copy(reflags, mg->mg_ptr+2, left, char);
2091 Copy(":", mg->mg_ptr+left+2, 1, char);
2092 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ		 2093 mg->mg_ptr[mg->mg_len - 1] = ')';
2094 mg->mg_ptr[mg->mg_len] = 0;
2095 }
3280af22 2096 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ		 2097 *lp = mg->mg_len;
2098 return mg->mg_ptr;
f9277f47
IZ		 2099 }
2100 /* Fall through */
ed6116ce
LW		 2101 case SVt_NULL:
2102 case SVt_IV:
2103 case SVt_NV:
2104 case SVt_RV:
2105 case SVt_PV:
2106 case SVt_PVIV:
2107 case SVt_PVNV:
f9277f47 2108 case SVt_PVBM: s = "SCALAR"; break;
ed6116ce
LW		 2109 case SVt_PVLV: s = "LVALUE"; break;
2110 case SVt_PVAV: s = "ARRAY"; break;
2111 case SVt_PVHV: s = "HASH"; break;
2112 case SVt_PVCV: s = "CODE"; break;
2113 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2114 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2115 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW		 2116 default: s = "UNKNOWN"; break;
2117 }
46fc3d4c 2118 tsv = NEWSV(0,0);
ed6116ce 2119 if (SvOBJECT(sv))
cea2e8a9 2120 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2121 else
46fc3d4c 2122 sv_setpv(tsv, s);
57def98f 2123 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2124 goto tokensaveref;
463ee0b2 2125 }
ed6116ce
LW		 2126 *lp = strlen(s);
2127 return s;
79072805 2128 }
0336b60e
IZ		 2129 if (SvREADONLY(sv) && !SvOK(sv)) {
2130 dTHR;
2131 if (ckWARN(WARN_UNINITIALIZED))
2132 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
ed6116ce
LW		 2133 *lp = 0;
2134 return "";
79072805 2135 }
79072805 2136 }
25da4f38
IZ		 2137 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2138 /* XXXX 64-bit? IV may have better precision... */
34d861e4
JH		 2139 /* I tried changing this for to be 64-bit-aware and
2140 * the t/op/numconvert.t became very, very, angry.
2141 * --jhi Sep 1999 */
79072805
LW		 2142 if (SvTYPE(sv) < SVt_PVNV)
2143 sv_upgrade(sv, SVt_PVNV);
2144 SvGROW(sv, 28);
463ee0b2 2145 s = SvPVX(sv);
79072805 2146 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2147#ifdef apollo
463ee0b2 2148 if (SvNVX(sv) == 0.0)
79072805
LW		 2149 (void)strcpy(s,"0");
2150 else
2151#endif /*apollo*/
bbce6d69 2152 {
2d4389e4 2153 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2154 }
79072805 2155 errno = olderrno;
a0d0e21e
LW		 2156#ifdef FIXNEGATIVEZERO
2157 if (*s == '-' && s[1] == '0' && !s[2])
2158 strcpy(s,"0");
2159#endif
79072805
LW		 2160 while (*s) s++;
2161#ifdef hcx
2162 if (s[-1] == '.')
46fc3d4c 2163 *--s = '\0';
79072805
LW		 2164#endif
2165 }
748a9306 2166 else if (SvIOKp(sv)) {
25da4f38 2167 U32 isIOK = SvIOK(sv);
0336b60e 2168 U32 isUIOK = SvIsUV(sv);
25da4f38
IZ		 2169 char buf[TYPE_CHARS(UV)];
2170 char *ebuf, *ptr;
2171
79072805
LW		 2172 if (SvTYPE(sv) < SVt_PVIV)
2173 sv_upgrade(sv, SVt_PVIV);
0336b60e 2174 if (isUIOK)
25da4f38 2175 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
0336b60e 2176 else
25da4f38 2177 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
0336b60e
IZ		 2178 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2179 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2180 SvCUR_set(sv, ebuf - ptr);
46fc3d4c 2181 s = SvEND(sv);
0336b60e 2182 *s = '\0';
25da4f38 2183 if (isIOK)
64f14228
GA		 2184 SvIOK_on(sv);
2185 else
2186 SvIOKp_on(sv);
0336b60e
IZ		 2187 if (isUIOK)
2188 SvIsUV_on(sv);
2189 SvPOK_on(sv);
79072805
LW		 2190 }
2191 else {
11343788 2192 dTHR;
0336b60e
IZ		 2193 if (ckWARN(WARN_UNINITIALIZED)
2194 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2195 {
cea2e8a9 2196 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
0336b60e 2197 }
a0d0e21e 2198 *lp = 0;
25da4f38
IZ		 2199 if (SvTYPE(sv) < SVt_PV)
2200 /* Typically the caller expects that sv_any is not NULL now. */
2201 sv_upgrade(sv, SVt_PV);
a0d0e21e 2202 return "";
79072805 2203 }
463ee0b2
LW		 2204 *lp = s - SvPVX(sv);
2205 SvCUR_set(sv, *lp);
79072805 2206 SvPOK_on(sv);
b900a521
JH		 2207 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2208 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2209 return SvPVX(sv);
a0d0e21e
LW		 2210
2211 tokensave:
2212 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2213 /* Sneaky stuff here */
2214
2215 tokensaveref:
46fc3d4c 2216 if (!tsv)
96827780 2217 tsv = newSVpv(tmpbuf, 0);
46fc3d4c
PP		 2218 sv_2mortal(tsv);
2219 *lp = SvCUR(tsv);
2220 return SvPVX(tsv);
a0d0e21e
LW		 2221 }
2222 else {
2223 STRLEN len;
46fc3d4c
PP		 2224 char *t;
2225
2226 if (tsv) {
2227 sv_2mortal(tsv);
2228 t = SvPVX(tsv);
2229 len = SvCUR(tsv);
2230 }
2231 else {
96827780
MB		 2232 t = tmpbuf;
2233 len = strlen(tmpbuf);
46fc3d4c 2234 }
a0d0e21e 2235#ifdef FIXNEGATIVEZERO
46fc3d4c
PP		 2236 if (len == 2 && t[0] == '-' && t[1] == '0') {
2237 t = "0";
2238 len = 1;
2239 }
a0d0e21e
LW		 2240#endif
2241 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2242 *lp = len;
a0d0e21e
LW		 2243 s = SvGROW(sv, len + 1);
2244 SvCUR_set(sv, len);
46fc3d4c 2245 (void)strcpy(s, t);
6bf554b4 2246 SvPOKp_on(sv);
a0d0e21e
LW		 2247 return s;
2248 }
463ee0b2
LW		 2249}
2250
2251/* This function is only called on magical items */
2252bool
864dbfa3 2253Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2254{
8990e307 2255 if (SvGMAGICAL(sv))
463ee0b2
LW		 2256 mg_get(sv);
2257
a0d0e21e
LW		 2258 if (!SvOK(sv))
2259 return 0;
2260 if (SvROK(sv)) {
11343788 2261 dTHR;
a0d0e21e
LW		 2262 SV* tmpsv;
2263 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
9e7bc3e8 2264 return SvTRUE(tmpsv);
a0d0e21e
LW		 2265 return SvRV(sv) != 0;
2266 }
463ee0b2 2267 if (SvPOKp(sv)) {
11343788
MB		 2268 register XPV* Xpvtmp;
2269 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2270 (*Xpvtmp->xpv_pv > '0' ||
2271 Xpvtmp->xpv_cur > 1 ||
2272 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW		 2273 return 1;
2274 else
2275 return 0;
2276 }
2277 else {
2278 if (SvIOKp(sv))
2279 return SvIVX(sv) != 0;
2280 else {
2281 if (SvNOKp(sv))
2282 return SvNVX(sv) != 0.0;
2283 else
2284 return FALSE;
2285 }
2286 }
79072805
LW		 2287}
2288
2289/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 2290 * to be reused, since it may destroy the source string if it is marked
79072805
LW		 2291 * as temporary.
2292 */
2293
2294void
864dbfa3 2295Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 2296{
11343788 2297 dTHR;
8990e307
LW		 2298 register U32 sflags;
2299 register int dtype;
2300 register int stype;
463ee0b2 2301
79072805
LW		 2302 if (sstr == dstr)
2303 return;
2213622d 2304 SV_CHECK_THINKFIRST(dstr);
79072805 2305 if (!sstr)
3280af22 2306 sstr = &PL_sv_undef;
8990e307
LW		 2307 stype = SvTYPE(sstr);
2308 dtype = SvTYPE(dstr);
79072805 2309
a0d0e21e 2310 SvAMAGIC_off(dstr);
9e7bc3e8 2311
463ee0b2 2312 /* There's a lot of redundancy below but we're going for speed here */
79072805 2313
8990e307 2314 switch (stype) {
79072805 2315 case SVt_NULL:
aece5585 2316 undef_sstr:
20408e3c
GS		 2317 if (dtype != SVt_PVGV) {
2318 (void)SvOK_off(dstr);
2319 return;
2320 }
2321 break;
463ee0b2 2322 case SVt_IV:
aece5585
GA		 2323 if (SvIOK(sstr)) {
2324 switch (dtype) {
2325 case SVt_NULL:
8990e307 2326 sv_upgrade(dstr, SVt_IV);
aece5585
GA		 2327 break;
2328 case SVt_NV:
8990e307 2329 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 2330 break;
2331 case SVt_RV:
2332 case SVt_PV:
a0d0e21e 2333 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA		 2334 break;
2335 }
2336 (void)SvIOK_only(dstr);
2337 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2338 if (SvIsUV(sstr))
2339 SvIsUV_on(dstr);
aece5585
GA		 2340 SvTAINT(dstr);
2341 return;
8990e307 2342 }
aece5585
GA		 2343 goto undef_sstr;
2344
463ee0b2 2345 case SVt_NV:
aece5585
GA		 2346 if (SvNOK(sstr)) {
2347 switch (dtype) {
2348 case SVt_NULL:
2349 case SVt_IV:
8990e307 2350 sv_upgrade(dstr, SVt_NV);
aece5585
GA		 2351 break;
2352 case SVt_RV:
2353 case SVt_PV:
2354 case SVt_PVIV:
a0d0e21e 2355 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 2356 break;
2357 }
2358 SvNVX(dstr) = SvNVX(sstr);
2359 (void)SvNOK_only(dstr);
2360 SvTAINT(dstr);
2361 return;
8990e307 2362 }
aece5585
GA		 2363 goto undef_sstr;
2364
ed6116ce 2365 case SVt_RV:
8990e307 2366 if (dtype < SVt_RV)
ed6116ce 2367 sv_upgrade(dstr, SVt_RV);
c07a80fd
PP		 2368 else if (dtype == SVt_PVGV &&
2369 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2370 sstr = SvRV(sstr);
a5f75d66 2371 if (sstr == dstr) {
11faa288 2372 if (GvIMPORTED(dstr) != GVf_IMPORTED
ed094faf 2373 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
11faa288 2374 {
a5f75d66 2375 GvIMPORTED_on(dstr);
11faa288 2376 }
a5f75d66
AD		 2377 GvMULTI_on(dstr);
2378 return;
2379 }
c07a80fd
PP		 2380 goto glob_assign;
2381 }
ed6116ce 2382 break;
463ee0b2 2383 case SVt_PV:
fc36a67e 2384 case SVt_PVFM:
8990e307 2385 if (dtype < SVt_PV)
463ee0b2 2386 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW		 2387 break;
2388 case SVt_PVIV:
8990e307 2389 if (dtype < SVt_PVIV)
463ee0b2 2390 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW		 2391 break;
2392 case SVt_PVNV:
8990e307 2393 if (dtype < SVt_PVNV)
463ee0b2 2394 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 2395 break;
4633a7c4
LW		 2396 case SVt_PVAV:
2397 case SVt_PVHV:
2398 case SVt_PVCV:
4633a7c4 2399 case SVt_PVIO:
533c011a 2400 if (PL_op)
cea2e8a9 2401 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 2402 PL_op_name[PL_op->op_type]);
4633a7c4 2403 else
cea2e8a9 2404 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW		 2405 break;
2406
79072805 2407 case SVt_PVGV:
8990e307 2408 if (dtype <= SVt_PVGV) {
c07a80fd 2409 glob_assign:
a5f75d66 2410 if (dtype != SVt_PVGV) {
a0d0e21e
LW		 2411 char *name = GvNAME(sstr);
2412 STRLEN len = GvNAMELEN(sstr);
463ee0b2 2413 sv_upgrade(dstr, SVt_PVGV);
a0d0e21e 2414 sv_magic(dstr, dstr, '*', name, len);
85aff577 2415 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW		 2416 GvNAME(dstr) = savepvn(name, len);
2417 GvNAMELEN(dstr) = len;
2418 SvFAKE_on(dstr); /* can coerce to non-glob */
2419 }
7bac28a0 2420 /* ahem, death to those who redefine active sort subs */
3280af22
NIS		 2421 else if (PL_curstackinfo->si_type == PERLSI_SORT
2422 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 2423 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 2424 GvNAME(dstr));
a0d0e21e 2425 (void)SvOK_off(dstr);
a5f75d66 2426 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 2427 gp_free((GV*)dstr);
79072805 2428 GvGP(dstr) = gp_ref(GvGP(sstr));
8990e307 2429 SvTAINT(dstr);
11faa288 2430 if (GvIMPORTED(dstr) != GVf_IMPORTED
ed094faf 2431 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
11faa288 2432 {
a5f75d66 2433 GvIMPORTED_on(dstr);
11faa288 2434 }
a5f75d66 2435 GvMULTI_on(dstr);
79072805
LW		 2436 return;
2437 }
2438 /* FALL THROUGH */
2439
2440 default:
973f89ab
CS		 2441 if (SvGMAGICAL(sstr)) {
2442 mg_get(sstr);
2443 if (SvTYPE(sstr) != stype) {
2444 stype = SvTYPE(sstr);
2445 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2446 goto glob_assign;
2447 }
2448 }
ded42b9f 2449 if (stype == SVt_PVLV)
6fc92669 2450 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 2451 else
6fc92669 2452 (void)SvUPGRADE(dstr, stype);
79072805
LW		 2453 }
2454
8990e307
LW		 2455 sflags = SvFLAGS(sstr);
2456
2457 if (sflags & SVf_ROK) {
2458 if (dtype >= SVt_PV) {
2459 if (dtype == SVt_PVGV) {
2460 SV *sref = SvREFCNT_inc(SvRV(sstr));
2461 SV *dref = 0;
a5f75d66 2462 int intro = GvINTRO(dstr);
a0d0e21e
LW		 2463
2464 if (intro) {
2465 GP *gp;
ed094faf 2466 gp_free((GV*)dstr);
a5f75d66 2467 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 2468 Newz(602,gp, 1, GP);
44a8e56a 2469 GvGP(dstr) = gp_ref(gp);
a0d0e21e 2470 GvSV(dstr) = NEWSV(72,0);
57843af0 2471 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 2472 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 2473 }
a5f75d66 2474 GvMULTI_on(dstr);
8990e307
LW		 2475 switch (SvTYPE(sref)) {
2476 case SVt_PVAV:
a0d0e21e
LW		 2477 if (intro)
2478 SAVESPTR(GvAV(dstr));
2479 else
2480 dref = (SV*)GvAV(dstr);
8990e307 2481 GvAV(dstr) = (AV*)sref;
11faa288 2482 if (GvIMPORTED_AV_off(dstr)
ed094faf 2483 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
11faa288 2484 {
a5f75d66 2485 GvIMPORTED_AV_on(dstr);
11faa288 2486 }
8990e307
LW		 2487 break;
2488 case SVt_PVHV:
a0d0e21e
LW		 2489 if (intro)
2490 SAVESPTR(GvHV(dstr));
2491 else
2492 dref = (SV*)GvHV(dstr);
8990e307 2493 GvHV(dstr) = (HV*)sref;
11faa288 2494 if (GvIMPORTED_HV_off(dstr)
ed094faf 2495 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
11faa288 2496 {
a5f75d66 2497 GvIMPORTED_HV_on(dstr);
11faa288 2498 }
8990e307
LW		 2499 break;
2500 case SVt_PVCV:
8ebc5c01
PP		 2501 if (intro) {
2502 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2503 SvREFCNT_dec(GvCV(dstr));
2504 GvCV(dstr) = Nullcv;
68dc0745 2505 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 2506 PL_sub_generation++;
8ebc5c01 2507 }
a0d0e21e 2508 SAVESPTR(GvCV(dstr));
8ebc5c01 2509 }
68dc0745
PP		 2510 else
2511 dref = (SV*)GvCV(dstr);
2512 if (GvCV(dstr) != (CV*)sref) {
748a9306 2513 CV* cv = GvCV(dstr);
4633a7c4 2514 if (cv) {
68dc0745
PP		 2515 if (!GvCVGEN((GV*)dstr) &&
2516 (CvROOT(cv) || CvXSUB(cv)))
2517 {
fe5e78ed
GS		 2518 SV *const_sv = cv_const_sv(cv);
2519 bool const_changed = TRUE;
2520 if(const_sv)
2521 const_changed = sv_cmp(const_sv,
2522 op_const_sv(CvSTART((CV*)sref),
2523 Nullcv));
7bac28a0
PP		 2524 /* ahem, death to those who redefine
2525 * active sort subs */
3280af22
NIS		 2526 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2527 PL_sortcop == CvSTART(cv))
cea2e8a9 2528 Perl_croak(aTHX_
7bac28a0
PP		 2529 "Can't redefine active sort subroutine %s",
2530 GvENAME((GV*)dstr));
599cee73 2531 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2f34f9d4
IZ		 2532 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2533 && HvNAME(GvSTASH(CvGV(cv)))
2534 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2535 "autouse")))
cea2e8a9 2536 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
fe5e78ed
GS		 2537 "Constant subroutine %s redefined"
2538 : "Subroutine %s redefined",
2f34f9d4
IZ		 2539 GvENAME((GV*)dstr));
2540 }
9607fc9c 2541 }
3fe9a6f1
PP		 2542 cv_ckproto(cv, (GV*)dstr,
2543 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 2544 }
a5f75d66 2545 GvCV(dstr) = (CV*)sref;
7a4c00b4 2546 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 2547 GvASSUMECV_on(dstr);
3280af22 2548 PL_sub_generation++;
a5f75d66 2549 }
11faa288 2550 if (GvIMPORTED_CV_off(dstr)
ed094faf 2551 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
11faa288 2552 {
a5f75d66 2553 GvIMPORTED_CV_on(dstr);
11faa288 2554 }
8990e307 2555 break;
91bba347
LW		 2556 case SVt_PVIO:
2557 if (intro)
2558 SAVESPTR(GvIOp(dstr));
2559 else
2560 dref = (SV*)GvIOp(dstr);
2561 GvIOp(dstr) = (IO*)sref;
2562 break;
8990e307 2563 default:
a0d0e21e
LW		 2564 if (intro)
2565 SAVESPTR(GvSV(dstr));
2566 else
2567 dref = (SV*)GvSV(dstr);
8990e307 2568 GvSV(dstr) = sref;
11faa288 2569 if (GvIMPORTED_SV_off(dstr)
ed094faf 2570 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
11faa288 2571 {
a5f75d66 2572 GvIMPORTED_SV_on(dstr);
11faa288 2573 }
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;
2b260de0 3078 if (vtbl && vtbl->svt_free)
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 }
e0c19803 3339 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
1236053a 3340 PerlDir_close(IoDIRP(sv));
e0c19803 3341 IoDIRP(sv) = (DIR*)NULL;
8990e307
LW		 3342 Safefree(IoTOP_NAME(sv));
3343 Safefree(IoFMT_NAME(sv));
3344 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 3345 /* FALL THROUGH */
79072805 3346 case SVt_PVBM:
a0d0e21e 3347 goto freescalar;
79072805 3348 case SVt_PVCV:
748a9306 3349 case SVt_PVFM:
85e6fe83 3350 cv_undef((CV*)sv);
a0d0e21e 3351 goto freescalar;
79072805 3352 case SVt_PVHV:
85e6fe83 3353 hv_undef((HV*)sv);
a0d0e21e 3354 break;
79072805 3355 case SVt_PVAV:
85e6fe83 3356 av_undef((AV*)sv);
a0d0e21e 3357 break;
02270b4e
GS		 3358 case SVt_PVLV:
3359 SvREFCNT_dec(LvTARG(sv));
3360 goto freescalar;
a0d0e21e 3361 case SVt_PVGV:
1edc1566 3362 gp_free((GV*)sv);
a0d0e21e 3363 Safefree(GvNAME(sv));
ec12f114
JPC		 3364 /* cannot decrease stash refcount yet, as we might recursively delete
3365 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3366 of stash until current sv is completely gone.
3367 -- JohnPC, 27 Mar 1998 */
3368 stash = GvSTASH(sv);
a0d0e21e 3369 /* FALL THROUGH */
79072805 3370 case SVt_PVMG:
79072805
LW		 3371 case SVt_PVNV:
3372 case SVt_PVIV:
a0d0e21e
LW		 3373 freescalar:
3374 (void)SvOOK_off(sv);
79072805
LW		 3375 /* FALL THROUGH */
3376 case SVt_PV:
a0d0e21e 3377 case SVt_RV:
810b8aa5
GS		 3378 if (SvROK(sv)) {
3379 if (SvWEAKREF(sv))
3380 sv_del_backref(sv);
3381 else
3382 SvREFCNT_dec(SvRV(sv));
3383 }
1edc1566 3384 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 3385 Safefree(SvPVX(sv));
79072805 3386 break;
a0d0e21e 3387/*
79072805 3388 case SVt_NV:
79072805 3389 case SVt_IV:
79072805
LW		 3390 case SVt_NULL:
3391 break;
a0d0e21e 3392*/
79072805
LW		 3393 }
3394
3395 switch (SvTYPE(sv)) {
3396 case SVt_NULL:
3397 break;
79072805
LW		 3398 case SVt_IV:
3399 del_XIV(SvANY(sv));
3400 break;
3401 case SVt_NV:
3402 del_XNV(SvANY(sv));
3403 break;
ed6116ce
LW		 3404 case SVt_RV:
3405 del_XRV(SvANY(sv));
3406 break;
79072805
LW		 3407 case SVt_PV:
3408 del_XPV(SvANY(sv));
3409 break;
3410 case SVt_PVIV:
3411 del_XPVIV(SvANY(sv));
3412 break;
3413 case SVt_PVNV:
3414 del_XPVNV(SvANY(sv));
3415 break;
3416 case SVt_PVMG:
3417 del_XPVMG(SvANY(sv));
3418 break;
3419 case SVt_PVLV:
3420 del_XPVLV(SvANY(sv));
3421 break;
3422 case SVt_PVAV:
3423 del_XPVAV(SvANY(sv));
3424 break;
3425 case SVt_PVHV:
3426 del_XPVHV(SvANY(sv));
3427 break;
3428 case SVt_PVCV:
3429 del_XPVCV(SvANY(sv));
3430 break;
3431 case SVt_PVGV:
3432 del_XPVGV(SvANY(sv));
ec12f114
JPC		 3433 /* code duplication for increased performance. */
3434 SvFLAGS(sv) &= SVf_BREAK;
3435 SvFLAGS(sv) |= SVTYPEMASK;
3436 /* decrease refcount of the stash that owns this GV, if any */
3437 if (stash)
3438 SvREFCNT_dec(stash);
3439 return; /* not break, SvFLAGS reset already happened */
79072805
LW		 3440 case SVt_PVBM:
3441 del_XPVBM(SvANY(sv));
3442 break;
3443 case SVt_PVFM:
3444 del_XPVFM(SvANY(sv));
3445 break;
8990e307
LW		 3446 case SVt_PVIO:
3447 del_XPVIO(SvANY(sv));
3448 break;
79072805 3449 }
a0d0e21e 3450 SvFLAGS(sv) &= SVf_BREAK;
8990e307 3451 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW		 3452}
3453
3454SV *
864dbfa3 3455Perl_sv_newref(pTHX_ SV *sv)
79072805 3456{
463ee0b2 3457 if (sv)
dce16143 3458 ATOMIC_INC(SvREFCNT(sv));
79072805
LW		 3459 return sv;
3460}
3461
3462void
864dbfa3 3463Perl_sv_free(pTHX_ SV *sv)
79072805 3464{
0453d815 3465 dTHR;
dce16143
MB		 3466 int refcount_is_zero;
3467
79072805
LW		 3468 if (!sv)
3469 return;
a0d0e21e
LW		 3470 if (SvREFCNT(sv) == 0) {
3471 if (SvFLAGS(sv) & SVf_BREAK)
3472 return;
3280af22 3473 if (PL_in_clean_all) /* All is fair */
1edc1566 3474 return;
d689ffdd
JP		 3475 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3476 /* make sure SvREFCNT(sv)==0 happens very seldom */
3477 SvREFCNT(sv) = (~(U32)0)/2;
3478 return;
3479 }
0453d815
PM		 3480 if (ckWARN_d(WARN_INTERNAL))
3481 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
79072805
LW		 3482 return;
3483 }
dce16143
MB		 3484 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3485 if (!refcount_is_zero)
8990e307 3486 return;
463ee0b2
LW		 3487#ifdef DEBUGGING
3488 if (SvTEMP(sv)) {
0453d815 3489 if (ckWARN_d(WARN_DEBUGGING))
f248d071 3490 Perl_warner(aTHX_ WARN_DEBUGGING,
b900a521
JH		 3491 "Attempt to free temp prematurely: SV 0x%"UVxf,
3492 PTR2UV(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 con