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