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