This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix ~320 byte memory leak (psig_{ptr,name} tables were never freed)
[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
PP
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
PP
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
PP
1312 int ch = *s & 0xFF;
1313 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW
1314 *d++ = 'M';
1315 *d++ = '-';
1316 ch &= 127;
1317 }
bbce6d69
PP
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 */
300aed98 1362#define IS_NUMBER_INFINITY 0x10 /* this is big */
25da4f38
IZ
1363
1364/* Actually, ISO C leaves conversion of UV to IV undefined, but
1365 until proven guilty, assume that things are not that bad... */
1366
a0d0e21e 1367IV
864dbfa3 1368Perl_sv_2iv(pTHX_ register SV *sv)
79072805
LW
1369{
1370 if (!sv)
1371 return 0;
8990e307 1372 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1373 mg_get(sv);
1374 if (SvIOKp(sv))
1375 return SvIVX(sv);
748a9306 1376 if (SvNOKp(sv)) {
25da4f38 1377 return I_V(SvNVX(sv));
748a9306 1378 }
36477c24
PP
1379 if (SvPOKp(sv) && SvLEN(sv))
1380 return asIV(sv);
3fe9a6f1 1381 if (!SvROK(sv)) {
d008e5eb 1382 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1383 dTHR;
d008e5eb 1384 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1385 report_uninit();
c6ee37c5 1386 }
36477c24 1387 return 0;
3fe9a6f1 1388 }
463ee0b2 1389 }
ed6116ce 1390 if (SvTHINKFIRST(sv)) {
a0d0e21e 1391 if (SvROK(sv)) {
a0d0e21e
LW
1392 SV* tmpstr;
1393 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
9e7bc3e8 1394 return SvIV(tmpstr);
56431972 1395 return PTR2IV(SvRV(sv));
a0d0e21e 1396 }
0336b60e
IZ
1397 if (SvREADONLY(sv) && !SvOK(sv)) {
1398 dTHR;
1399 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1400 report_uninit();
ed6116ce
LW
1401 return 0;
1402 }
79072805 1403 }
25da4f38
IZ
1404 if (SvIOKp(sv)) {
1405 if (SvIsUV(sv)) {
1406 return (IV)(SvUVX(sv));
1407 }
1408 else {
1409 return SvIVX(sv);
1410 }
463ee0b2 1411 }
748a9306 1412 if (SvNOKp(sv)) {
25da4f38
IZ
1413 /* We can cache the IV/UV value even if it not good enough
1414 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1415 * NV over IV/UV.
25da4f38
IZ
1416 */
1417
1418 if (SvTYPE(sv) == SVt_NV)
1419 sv_upgrade(sv, SVt_PVNV);
1420
a5f75d66 1421 (void)SvIOK_on(sv);
65202027 1422 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
748a9306 1423 SvIVX(sv) = I_V(SvNVX(sv));
25da4f38 1424 else {
ff68c719 1425 SvUVX(sv) = U_V(SvNVX(sv));
25da4f38
IZ
1426 SvIsUV_on(sv);
1427 ret_iv_max:
cf2093f6 1428 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 1429 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 1430 PTR2UV(sv),
57def98f
JH
1431 SvUVX(sv),
1432 SvUVX(sv)));
25da4f38
IZ
1433 return (IV)SvUVX(sv);
1434 }
748a9306
LW
1435 }
1436 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ
1437 I32 numtype = looks_like_number(sv);
1438
1439 /* We want to avoid a possible problem when we cache an IV which
1440 may be later translated to an NV, and the resulting NV is not
1441 the translation of the initial data.
1442
1443 This means that if we cache such an IV, we need to cache the
1444 NV as well. Moreover, we trade speed for space, and do not
1445 cache the NV if not needed.
1446 */
1447 if (numtype & IS_NUMBER_NOT_IV) {
1448 /* May be not an integer. Need to cache NV if we cache IV
1449 * - otherwise future conversion to NV will be wrong. */
65202027 1450 NV d;
25da4f38 1451
097ee67d 1452 d = Atof(SvPVX(sv));
25da4f38
IZ
1453
1454 if (SvTYPE(sv) < SVt_PVNV)
1455 sv_upgrade(sv, SVt_PVNV);
1456 SvNVX(sv) = d;
1457 (void)SvNOK_on(sv);
1458 (void)SvIOK_on(sv);
65202027 1459#if defined(USE_LONG_DOUBLE)
1d7c1841
GS
1460 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1461 PTR2UV(sv), SvNVX(sv)));
65202027 1462#else
1d7c1841
GS
1463 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1464 PTR2UV(sv), SvNVX(sv)));
65202027 1465#endif
65202027 1466 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
25da4f38
IZ
1467 SvIVX(sv) = I_V(SvNVX(sv));
1468 else {
1469 SvUVX(sv) = U_V(SvNVX(sv));
1470 SvIsUV_on(sv);
1471 goto ret_iv_max;
1472 }
1473 }
1474 else if (numtype) {
1475 /* The NV may be reconstructed from IV - safe to cache IV,
1476 which may be calculated by atol(). */
1477 if (SvTYPE(sv) == SVt_PV)
1478 sv_upgrade(sv, SVt_PVIV);
1479 (void)SvIOK_on(sv);
cf2093f6 1480 SvIVX(sv) = Atol(SvPVX(sv));
25da4f38
IZ
1481 }
1482 else { /* Not a number. Cache 0. */
1483 dTHR;
1484
1485 if (SvTYPE(sv) < SVt_PVIV)
1486 sv_upgrade(sv, SVt_PVIV);
25da4f38 1487 (void)SvIOK_on(sv);
7b9e3c00 1488 SvIVX(sv) = 0;
25da4f38
IZ
1489 if (ckWARN(WARN_NUMERIC))
1490 not_a_number(sv);
1491 }
93a17b20 1492 }
79072805 1493 else {
11343788 1494 dTHR;
599cee73 1495 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1496 report_uninit();
25da4f38
IZ
1497 if (SvTYPE(sv) < SVt_IV)
1498 /* Typically the caller expects that sv_any is not NULL now. */
1499 sv_upgrade(sv, SVt_IV);
a0d0e21e 1500 return 0;
79072805 1501 }
1d7c1841
GS
1502 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1503 PTR2UV(sv),SvIVX(sv)));
25da4f38 1504 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW
1505}
1506
ff68c719 1507UV
864dbfa3 1508Perl_sv_2uv(pTHX_ register SV *sv)
ff68c719
PP
1509{
1510 if (!sv)
1511 return 0;
1512 if (SvGMAGICAL(sv)) {
1513 mg_get(sv);
1514 if (SvIOKp(sv))
1515 return SvUVX(sv);
1516 if (SvNOKp(sv))
1517 return U_V(SvNVX(sv));
36477c24
PP
1518 if (SvPOKp(sv) && SvLEN(sv))
1519 return asUV(sv);
3fe9a6f1 1520 if (!SvROK(sv)) {
d008e5eb 1521 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1522 dTHR;
d008e5eb 1523 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1524 report_uninit();
c6ee37c5 1525 }
36477c24 1526 return 0;
3fe9a6f1 1527 }
ff68c719
PP
1528 }
1529 if (SvTHINKFIRST(sv)) {
1530 if (SvROK(sv)) {
ff68c719
PP
1531 SV* tmpstr;
1532 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
9e7bc3e8 1533 return SvUV(tmpstr);
56431972 1534 return PTR2UV(SvRV(sv));
ff68c719 1535 }
0336b60e
IZ
1536 if (SvREADONLY(sv) && !SvOK(sv)) {
1537 dTHR;
1538 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1539 report_uninit();
ff68c719
PP
1540 return 0;
1541 }
1542 }
25da4f38
IZ
1543 if (SvIOKp(sv)) {
1544 if (SvIsUV(sv)) {
1545 return SvUVX(sv);
1546 }
1547 else {
1548 return (UV)SvIVX(sv);
1549 }
ff68c719
PP
1550 }
1551 if (SvNOKp(sv)) {
25da4f38
IZ
1552 /* We can cache the IV/UV value even if it not good enough
1553 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1554 * NV over IV/UV.
25da4f38
IZ
1555 */
1556 if (SvTYPE(sv) == SVt_NV)
1557 sv_upgrade(sv, SVt_PVNV);
ff68c719 1558 (void)SvIOK_on(sv);
25da4f38
IZ
1559 if (SvNVX(sv) >= -0.5) {
1560 SvIsUV_on(sv);
1561 SvUVX(sv) = U_V(SvNVX(sv));
1562 }
1563 else {
1564 SvIVX(sv) = I_V(SvNVX(sv));
1565 ret_zero:
cf2093f6 1566 DEBUG_c(PerlIO_printf(Perl_debug_log,
07270b1a 1567 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
57def98f
JH
1568 PTR2UV(sv),
1569 SvIVX(sv),
1570 (IV)(UV)SvIVX(sv)));
25da4f38
IZ
1571 return (UV)SvIVX(sv);
1572 }
ff68c719
PP
1573 }
1574 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ
1575 I32 numtype = looks_like_number(sv);
1576
1577 /* We want to avoid a possible problem when we cache a UV which
1578 may be later translated to an NV, and the resulting NV is not
1579 the translation of the initial data.
1580
1581 This means that if we cache such a UV, we need to cache the
1582 NV as well. Moreover, we trade speed for space, and do not
1583 cache the NV if not needed.
1584 */
1585 if (numtype & IS_NUMBER_NOT_IV) {
1586 /* May be not an integer. Need to cache NV if we cache IV
1587 * - otherwise future conversion to NV will be wrong. */
65202027 1588 NV d;
25da4f38 1589
cf2093f6 1590 d = Atof(SvPVX(sv));
25da4f38
IZ
1591
1592 if (SvTYPE(sv) < SVt_PVNV)
1593 sv_upgrade(sv, SVt_PVNV);
1594 SvNVX(sv) = d;
1595 (void)SvNOK_on(sv);
1596 (void)SvIOK_on(sv);
65202027 1597#if defined(USE_LONG_DOUBLE)
1d7c1841
GS
1598 DEBUG_c(PerlIO_printf(Perl_debug_log,
1599 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1600 PTR2UV(sv), SvNVX(sv)));
65202027 1601#else
1d7c1841
GS
1602 DEBUG_c(PerlIO_printf(Perl_debug_log,
1603 "0x%"UVxf" 2nv(%g)\n",
1604 PTR2UV(sv), SvNVX(sv)));
65202027 1605#endif
25da4f38
IZ
1606 if (SvNVX(sv) < -0.5) {
1607 SvIVX(sv) = I_V(SvNVX(sv));
1608 goto ret_zero;
1609 } else {
1610 SvUVX(sv) = U_V(SvNVX(sv));
1611 SvIsUV_on(sv);
1612 }
1613 }
1614 else if (numtype & IS_NUMBER_NEG) {
1615 /* The NV may be reconstructed from IV - safe to cache IV,
1616 which may be calculated by atol(). */
1617 if (SvTYPE(sv) == SVt_PV)
1618 sv_upgrade(sv, SVt_PVIV);
1619 (void)SvIOK_on(sv);
cf2093f6 1620 SvIVX(sv) = (IV)Atol(SvPVX(sv));
25da4f38
IZ
1621 }
1622 else if (numtype) { /* Non-negative */
1623 /* The NV may be reconstructed from UV - safe to cache UV,
1624 which may be calculated by strtoul()/atol. */
1625 if (SvTYPE(sv) == SVt_PV)
1626 sv_upgrade(sv, SVt_PVIV);
1627 (void)SvIOK_on(sv);
1628 (void)SvIsUV_on(sv);
1629#ifdef HAS_STRTOUL
cf2093f6 1630 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
25da4f38
IZ
1631#else /* no atou(), but we know the number fits into IV... */
1632 /* The only problem may be if it is negative... */
cf2093f6 1633 SvUVX(sv) = (UV)Atol(SvPVX(sv));
25da4f38
IZ
1634#endif
1635 }
1636 else { /* Not a number. Cache 0. */
1637 dTHR;
1638
1639 if (SvTYPE(sv) < SVt_PVIV)
1640 sv_upgrade(sv, SVt_PVIV);
25da4f38
IZ
1641 (void)SvIOK_on(sv);
1642 (void)SvIsUV_on(sv);
7b9e3c00
GS
1643 SvUVX(sv) = 0; /* We assume that 0s have the
1644 same bitmap in IV and UV. */
25da4f38
IZ
1645 if (ckWARN(WARN_NUMERIC))
1646 not_a_number(sv);
1647 }
ff68c719
PP
1648 }
1649 else {
d008e5eb 1650 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1651 dTHR;
d008e5eb 1652 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1653 report_uninit();
c6ee37c5 1654 }
25da4f38
IZ
1655 if (SvTYPE(sv) < SVt_IV)
1656 /* Typically the caller expects that sv_any is not NULL now. */
1657 sv_upgrade(sv, SVt_IV);
ff68c719
PP
1658 return 0;
1659 }
25da4f38 1660
1d7c1841
GS
1661 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1662 PTR2UV(sv),SvUVX(sv)));
25da4f38 1663 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719
PP
1664}
1665
65202027 1666NV
864dbfa3 1667Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW
1668{
1669 if (!sv)
1670 return 0.0;
8990e307 1671 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1672 mg_get(sv);
1673 if (SvNOKp(sv))
1674 return SvNVX(sv);
a0d0e21e 1675 if (SvPOKp(sv) && SvLEN(sv)) {
d008e5eb 1676 dTHR;
599cee73 1677 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1678 not_a_number(sv);
097ee67d 1679 return Atof(SvPVX(sv));
a0d0e21e 1680 }
25da4f38
IZ
1681 if (SvIOKp(sv)) {
1682 if (SvIsUV(sv))
65202027 1683 return (NV)SvUVX(sv);
25da4f38 1684 else
65202027 1685 return (NV)SvIVX(sv);
25da4f38 1686 }
16d20bd9 1687 if (!SvROK(sv)) {
d008e5eb 1688 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 1689 dTHR;
d008e5eb 1690 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1691 report_uninit();
c6ee37c5 1692 }
16d20bd9
AD
1693 return 0;
1694 }
463ee0b2 1695 }
ed6116ce 1696 if (SvTHINKFIRST(sv)) {
a0d0e21e 1697 if (SvROK(sv)) {
a0d0e21e
LW
1698 SV* tmpstr;
1699 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
9e7bc3e8 1700 return SvNV(tmpstr);
56431972 1701 return PTR2NV(SvRV(sv));
a0d0e21e 1702 }
0336b60e 1703 if (SvREADONLY(sv) && !SvOK(sv)) {
d008e5eb 1704 dTHR;
599cee73 1705 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1706 report_uninit();
ed6116ce
LW
1707 return 0.0;
1708 }
79072805
LW
1709 }
1710 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW
1711 if (SvTYPE(sv) == SVt_IV)
1712 sv_upgrade(sv, SVt_PVNV);
1713 else
1714 sv_upgrade(sv, SVt_NV);
572bbb43 1715#if defined(USE_LONG_DOUBLE)
097ee67d
JH
1716 DEBUG_c({
1717 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS
1718 PerlIO_printf(Perl_debug_log,
1719 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1720 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
1721 RESTORE_NUMERIC_LOCAL();
1722 });
65202027 1723#else
572bbb43
GS
1724 DEBUG_c({
1725 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS
1726 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1727 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
1728 RESTORE_NUMERIC_LOCAL();
1729 });
572bbb43 1730#endif
79072805
LW
1731 }
1732 else if (SvTYPE(sv) < SVt_PVNV)
1733 sv_upgrade(sv, SVt_PVNV);
748a9306
LW
1734 if (SvIOKp(sv) &&
1735 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 1736 {
65202027 1737 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
93a17b20 1738 }
748a9306 1739 else if (SvPOKp(sv) && SvLEN(sv)) {
d008e5eb 1740 dTHR;
599cee73 1741 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1742 not_a_number(sv);
097ee67d 1743 SvNVX(sv) = Atof(SvPVX(sv));
93a17b20 1744 }
79072805 1745 else {
11343788 1746 dTHR;
599cee73 1747 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1748 report_uninit();
25da4f38
IZ
1749 if (SvTYPE(sv) < SVt_NV)
1750 /* Typically the caller expects that sv_any is not NULL now. */
1751 sv_upgrade(sv, SVt_NV);
a0d0e21e 1752 return 0.0;
79072805
LW
1753 }
1754 SvNOK_on(sv);
572bbb43 1755#if defined(USE_LONG_DOUBLE)
097ee67d
JH
1756 DEBUG_c({
1757 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS
1758 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1759 PTR2UV(sv), SvNVX(sv));
572bbb43
GS
1760 RESTORE_NUMERIC_LOCAL();
1761 });
65202027 1762#else
572bbb43
GS
1763 DEBUG_c({
1764 RESTORE_NUMERIC_STANDARD();
1d7c1841
GS
1765 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1766 PTR2UV(sv), SvNVX(sv));
097ee67d
JH
1767 RESTORE_NUMERIC_LOCAL();
1768 });
572bbb43 1769#endif
463ee0b2 1770 return SvNVX(sv);
79072805
LW
1771}
1772
76e3520e 1773STATIC IV
cea2e8a9 1774S_asIV(pTHX_ SV *sv)
36477c24
PP
1775{
1776 I32 numtype = looks_like_number(sv);
65202027 1777 NV d;
36477c24 1778
25da4f38 1779 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1780 return Atol(SvPVX(sv));
d008e5eb
GS
1781 if (!numtype) {
1782 dTHR;
1783 if (ckWARN(WARN_NUMERIC))
1784 not_a_number(sv);
1785 }
097ee67d 1786 d = Atof(SvPVX(sv));
25da4f38 1787 return I_V(d);
36477c24
PP
1788}
1789
76e3520e 1790STATIC UV
cea2e8a9 1791S_asUV(pTHX_ SV *sv)
36477c24
PP
1792{
1793 I32 numtype = looks_like_number(sv);
1794
84902520 1795#ifdef HAS_STRTOUL
25da4f38 1796 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1797 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 1798#endif
d008e5eb
GS
1799 if (!numtype) {
1800 dTHR;
1801 if (ckWARN(WARN_NUMERIC))
1802 not_a_number(sv);
1803 }
097ee67d 1804 return U_V(Atof(SvPVX(sv)));
36477c24
PP
1805}
1806
25da4f38
IZ
1807/*
1808 * Returns a combination of (advisory only - can get false negatives)
1809 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1810 * IS_NUMBER_NEG
1811 * 0 if does not look like number.
1812 *
1813 * In fact possible values are 0 and
1814 * IS_NUMBER_TO_INT_BY_ATOL 123
1815 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1816 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
300aed98 1817 * IS_NUMBER_INFINITY
25da4f38
IZ
1818 * with a possible addition of IS_NUMBER_NEG.
1819 */
1820
954c1994
GS
1821/*
1822=for apidoc looks_like_number
1823
1824Test if an the content of an SV looks like a number (or is a
1825number).
1826
1827=cut
1828*/
1829
36477c24 1830I32
864dbfa3 1831Perl_looks_like_number(pTHX_ SV *sv)
36477c24
PP
1832{
1833 register char *s;
1834 register char *send;
1835 register char *sbegin;
25da4f38
IZ
1836 register char *nbegin;
1837 I32 numtype = 0;
300aed98 1838 I32 sawinf = 0;
36477c24
PP
1839 STRLEN len;
1840
1841 if (SvPOK(sv)) {
1842 sbegin = SvPVX(sv);
1843 len = SvCUR(sv);
1844 }
1845 else if (SvPOKp(sv))
1846 sbegin = SvPV(sv, len);
1847 else
1848 return 1;
1849 send = sbegin + len;
1850
1851 s = sbegin;
1852 while (isSPACE(*s))
1853 s++;
25da4f38
IZ
1854 if (*s == '-') {
1855 s++;
1856 numtype = IS_NUMBER_NEG;
1857 }
1858 else if (*s == '+')
36477c24 1859 s++;
ff0cee69 1860
25da4f38
IZ
1861 nbegin = s;
1862 /*
097ee67d
JH
1863 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1864 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1865 * (int)atof().
25da4f38
IZ
1866 */
1867
300aed98 1868 /* next must be digit or the radix separator or beginning of infinity */
ff0cee69
PP
1869 if (isDIGIT(*s)) {
1870 do {
1871 s++;
1872 } while (isDIGIT(*s));
25da4f38
IZ
1873
1874 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1875 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1876 else
1877 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1878
097ee67d
JH
1879 if (*s == '.'
1880#ifdef USE_LOCALE_NUMERIC
1881 || IS_NUMERIC_RADIX(*s)
1882#endif
1883 ) {
ff0cee69 1884 s++;
25da4f38 1885 numtype |= IS_NUMBER_NOT_IV;
097ee67d 1886 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69
PP
1887 s++;
1888 }
36477c24 1889 }
097ee67d
JH
1890 else if (*s == '.'
1891#ifdef USE_LOCALE_NUMERIC
1892 || IS_NUMERIC_RADIX(*s)
1893#endif
1894 ) {
ff0cee69 1895 s++;
25da4f38 1896 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
097ee67d 1897 /* no digits before the radix means we need digits after it */
ff0cee69
PP
1898 if (isDIGIT(*s)) {
1899 do {
1900 s++;
1901 } while (isDIGIT(*s));
1902 }
1903 else
1904 return 0;
1905 }
300aed98
JH
1906 else if (*s == 'I' || *s == 'i') {
1907 s++; if (*s != 'N' && *s != 'n') return 0;
1908 s++; if (*s != 'F' && *s != 'f') return 0;
1909 s++; if (*s == 'I' || *s == 'i') {
1910 s++; if (*s != 'N' && *s != 'n') return 0;
1911 s++; if (*s != 'I' && *s != 'i') return 0;
1912 s++; if (*s != 'T' && *s != 't') return 0;
1913 s++; if (*s != 'Y' && *s != 'y') return 0;
1914 }
1915 sawinf = 1;
1916 }
ff0cee69
PP
1917 else
1918 return 0;
1919
300aed98
JH
1920 if (sawinf)
1921 numtype = IS_NUMBER_INFINITY;
1922 else {
1923 /* we can have an optional exponent part */
1924 if (*s == 'e' || *s == 'E') {
1925 numtype &= ~IS_NUMBER_NEG;
1926 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
36477c24 1927 s++;
300aed98
JH
1928 if (*s == '+' || *s == '-')
1929 s++;
1930 if (isDIGIT(*s)) {
1931 do {
1932 s++;
1933 } while (isDIGIT(*s));
1934 }
1935 else
1936 return 0;
1937 }
36477c24
PP
1938 }
1939 while (isSPACE(*s))
1940 s++;
1941 if (s >= send)
1942 return numtype;
1943 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 1944 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24
PP
1945 return 0;
1946}
1947
79072805 1948char *
864dbfa3 1949Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD
1950{
1951 STRLEN n_a;
1952 return sv_2pv(sv, &n_a);
1953}
1954
25da4f38 1955/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 1956static char *
25da4f38
IZ
1957uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1958{
25da4f38
IZ
1959 char *ptr = buf + TYPE_CHARS(UV);
1960 char *ebuf = ptr;
1961 int sign;
25da4f38
IZ
1962
1963 if (is_uv)
1964 sign = 0;
1965 else if (iv >= 0) {
1966 uv = iv;
1967 sign = 0;
1968 } else {
1969 uv = -iv;
1970 sign = 1;
1971 }
1972 do {
1973 *--ptr = '0' + (uv % 10);
1974 } while (uv /= 10);
1975 if (sign)
1976 *--ptr = '-';
1977 *peob = ebuf;
1978 return ptr;
1979}
1980
1fa8b10d 1981char *
864dbfa3 1982Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805
LW
1983{
1984 register char *s;
1985 int olderrno;
46fc3d4c 1986 SV *tsv;
25da4f38
IZ
1987 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1988 char *tmpbuf = tbuf;
79072805 1989
463ee0b2
LW
1990 if (!sv) {
1991 *lp = 0;
1992 return "";
1993 }
8990e307 1994 if (SvGMAGICAL(sv)) {
463ee0b2
LW
1995 mg_get(sv);
1996 if (SvPOKp(sv)) {
1997 *lp = SvCUR(sv);
1998 return SvPVX(sv);
1999 }
cf2093f6 2000 if (SvIOKp(sv)) {
cf2093f6 2001 if (SvIsUV(sv))
57def98f 2002 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2003 else
57def98f 2004 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2005 tsv = Nullsv;
a0d0e21e 2006 goto tokensave;
463ee0b2
LW
2007 }
2008 if (SvNOKp(sv)) {
2d4389e4 2009 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2010 tsv = Nullsv;
a0d0e21e 2011 goto tokensave;
463ee0b2 2012 }
16d20bd9 2013 if (!SvROK(sv)) {
d008e5eb 2014 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
c6ee37c5 2015 dTHR;
d008e5eb 2016 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2017 report_uninit();
c6ee37c5 2018 }
16d20bd9
AD
2019 *lp = 0;
2020 return "";
2021 }
463ee0b2 2022 }
ed6116ce
LW
2023 if (SvTHINKFIRST(sv)) {
2024 if (SvROK(sv)) {
a0d0e21e
LW
2025 SV* tmpstr;
2026 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
9e7bc3e8 2027 return SvPV(tmpstr,*lp);
ed6116ce
LW
2028 sv = (SV*)SvRV(sv);
2029 if (!sv)
2030 s = "NULLREF";
2031 else {
f9277f47
IZ
2032 MAGIC *mg;
2033
ed6116ce 2034 switch (SvTYPE(sv)) {
f9277f47
IZ
2035 case SVt_PVMG:
2036 if ( ((SvFLAGS(sv) &
2037 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2038 == (SVs_OBJECT|SVs_RMG))
57668c4d 2039 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
f9277f47 2040 && (mg = mg_find(sv, 'r'))) {
5c0ca799 2041 dTHR;
2cd61cdb 2042 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2043
2cd61cdb 2044 if (!mg->mg_ptr) {
8782bef2
GB
2045 char *fptr = "msix";
2046 char reflags[6];
2047 char ch;
2048 int left = 0;
2049 int right = 4;
2050 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2051
155aba94 2052 while((ch = *fptr++)) {
8782bef2
GB
2053 if(reganch & 1) {
2054 reflags[left++] = ch;
2055 }
2056 else {
2057 reflags[right--] = ch;
2058 }
2059 reganch >>= 1;
2060 }
2061 if(left != 4) {
2062 reflags[left] = '-';
2063 left = 5;
2064 }
2065
2066 mg->mg_len = re->prelen + 4 + left;
2067 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2068 Copy("(?", mg->mg_ptr, 2, char);
2069 Copy(reflags, mg->mg_ptr+2, left, char);
2070 Copy(":", mg->mg_ptr+left+2, 1, char);
2071 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ
2072 mg->mg_ptr[mg->mg_len - 1] = ')';
2073 mg->mg_ptr[mg->mg_len] = 0;
2074 }
3280af22 2075 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ
2076 *lp = mg->mg_len;
2077 return mg->mg_ptr;
f9277f47
IZ
2078 }
2079 /* Fall through */
ed6116ce
LW
2080 case SVt_NULL:
2081 case SVt_IV:
2082 case SVt_NV:
2083 case SVt_RV:
2084 case SVt_PV:
2085 case SVt_PVIV:
2086 case SVt_PVNV:
f9277f47 2087 case SVt_PVBM: s = "SCALAR"; break;
ed6116ce
LW
2088 case SVt_PVLV: s = "LVALUE"; break;
2089 case SVt_PVAV: s = "ARRAY"; break;
2090 case SVt_PVHV: s = "HASH"; break;
2091 case SVt_PVCV: s = "CODE"; break;
2092 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2093 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2094 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW
2095 default: s = "UNKNOWN"; break;
2096 }
46fc3d4c 2097 tsv = NEWSV(0,0);
ed6116ce 2098 if (SvOBJECT(sv))
cea2e8a9 2099 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2100 else
46fc3d4c 2101 sv_setpv(tsv, s);
57def98f 2102 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2103 goto tokensaveref;
463ee0b2 2104 }
ed6116ce
LW
2105 *lp = strlen(s);
2106 return s;
79072805 2107 }
0336b60e
IZ
2108 if (SvREADONLY(sv) && !SvOK(sv)) {
2109 dTHR;
2110 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2111 report_uninit();
ed6116ce
LW
2112 *lp = 0;
2113 return "";
79072805 2114 }
79072805 2115 }
25da4f38
IZ
2116 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2117 /* XXXX 64-bit? IV may have better precision... */
34d861e4
JH
2118 /* I tried changing this for to be 64-bit-aware and
2119 * the t/op/numconvert.t became very, very, angry.
2120 * --jhi Sep 1999 */
79072805
LW
2121 if (SvTYPE(sv) < SVt_PVNV)
2122 sv_upgrade(sv, SVt_PVNV);
2123 SvGROW(sv, 28);
463ee0b2 2124 s = SvPVX(sv);
79072805 2125 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2126#ifdef apollo
463ee0b2 2127 if (SvNVX(sv) == 0.0)
79072805
LW
2128 (void)strcpy(s,"0");
2129 else
2130#endif /*apollo*/
bbce6d69 2131 {
2d4389e4 2132 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2133 }
79072805 2134 errno = olderrno;
a0d0e21e
LW
2135#ifdef FIXNEGATIVEZERO
2136 if (*s == '-' && s[1] == '0' && !s[2])
2137 strcpy(s,"0");
2138#endif
79072805
LW
2139 while (*s) s++;
2140#ifdef hcx
2141 if (s[-1] == '.')
46fc3d4c 2142 *--s = '\0';
79072805
LW
2143#endif
2144 }
748a9306 2145 else if (SvIOKp(sv)) {
25da4f38 2146 U32 isIOK = SvIOK(sv);
0336b60e 2147 U32 isUIOK = SvIsUV(sv);
25da4f38
IZ
2148 char buf[TYPE_CHARS(UV)];
2149 char *ebuf, *ptr;
2150
79072805
LW
2151 if (SvTYPE(sv) < SVt_PVIV)
2152 sv_upgrade(sv, SVt_PVIV);
0336b60e 2153 if (isUIOK)
25da4f38 2154 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
0336b60e 2155 else
25da4f38 2156 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
0336b60e
IZ
2157 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2158 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2159 SvCUR_set(sv, ebuf - ptr);
46fc3d4c 2160 s = SvEND(sv);
0336b60e 2161 *s = '\0';
25da4f38 2162 if (isIOK)
64f14228
GA
2163 SvIOK_on(sv);
2164 else
2165 SvIOKp_on(sv);
0336b60e
IZ
2166 if (isUIOK)
2167 SvIsUV_on(sv);
2168 SvPOK_on(sv);
79072805
LW
2169 }
2170 else {
11343788 2171 dTHR;
0336b60e
IZ
2172 if (ckWARN(WARN_UNINITIALIZED)
2173 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2174 {
1d7c1841 2175 report_uninit();
0336b60e 2176 }
a0d0e21e 2177 *lp = 0;
25da4f38
IZ
2178 if (SvTYPE(sv) < SVt_PV)
2179 /* Typically the caller expects that sv_any is not NULL now. */
2180 sv_upgrade(sv, SVt_PV);
a0d0e21e 2181 return "";
79072805 2182 }
463ee0b2
LW
2183 *lp = s - SvPVX(sv);
2184 SvCUR_set(sv, *lp);
79072805 2185 SvPOK_on(sv);
1d7c1841
GS
2186 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2187 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2188 return SvPVX(sv);
a0d0e21e
LW
2189
2190 tokensave:
2191 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2192 /* Sneaky stuff here */
2193
2194 tokensaveref:
46fc3d4c 2195 if (!tsv)
96827780 2196 tsv = newSVpv(tmpbuf, 0);
46fc3d4c
PP
2197 sv_2mortal(tsv);
2198 *lp = SvCUR(tsv);
2199 return SvPVX(tsv);
a0d0e21e
LW
2200 }
2201 else {
2202 STRLEN len;
46fc3d4c
PP
2203 char *t;
2204
2205 if (tsv) {
2206 sv_2mortal(tsv);
2207 t = SvPVX(tsv);
2208 len = SvCUR(tsv);
2209 }
2210 else {
96827780
MB
2211 t = tmpbuf;
2212 len = strlen(tmpbuf);
46fc3d4c 2213 }
a0d0e21e 2214#ifdef FIXNEGATIVEZERO
46fc3d4c
PP
2215 if (len == 2 && t[0] == '-' && t[1] == '0') {
2216 t = "0";
2217 len = 1;
2218 }
a0d0e21e
LW
2219#endif
2220 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2221 *lp = len;
a0d0e21e
LW
2222 s = SvGROW(sv, len + 1);
2223 SvCUR_set(sv, len);
46fc3d4c 2224 (void)strcpy(s, t);
6bf554b4 2225 SvPOKp_on(sv);
a0d0e21e
LW
2226 return s;
2227 }
463ee0b2
LW
2228}
2229
7340a771
GS
2230char *
2231Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2232{
560a288e
GS
2233 STRLEN n_a;
2234 return sv_2pvbyte(sv, &n_a);
7340a771
GS
2235}
2236
2237char *
2238Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2239{
2240 return sv_2pv(sv,lp);
2241}
2242
2243char *
2244Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2245{
560a288e
GS
2246 STRLEN n_a;
2247 return sv_2pvutf8(sv, &n_a);
7340a771
GS
2248}
2249
2250char *
2251Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2252{
560a288e 2253 sv_utf8_upgrade(sv);
7340a771
GS
2254 return sv_2pv(sv,lp);
2255}
2256
463ee0b2
LW
2257/* This function is only called on magical items */
2258bool
864dbfa3 2259Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2260{
8990e307 2261 if (SvGMAGICAL(sv))
463ee0b2
LW
2262 mg_get(sv);
2263
a0d0e21e
LW
2264 if (!SvOK(sv))
2265 return 0;
2266 if (SvROK(sv)) {
11343788 2267 dTHR;
a0d0e21e
LW
2268 SV* tmpsv;
2269 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
9e7bc3e8 2270 return SvTRUE(tmpsv);
a0d0e21e
LW
2271 return SvRV(sv) != 0;
2272 }
463ee0b2 2273 if (SvPOKp(sv)) {
11343788
MB
2274 register XPV* Xpvtmp;
2275 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2276 (*Xpvtmp->xpv_pv > '0' ||
2277 Xpvtmp->xpv_cur > 1 ||
2278 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW
2279 return 1;
2280 else
2281 return 0;
2282 }
2283 else {
2284 if (SvIOKp(sv))
2285 return SvIVX(sv) != 0;
2286 else {
2287 if (SvNOKp(sv))
2288 return SvNVX(sv) != 0.0;
2289 else
2290 return FALSE;
2291 }
2292 }
79072805
LW
2293}
2294
560a288e
GS
2295void
2296Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2297{
2298 int hicount;
2299 char *c;
2300
2301 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2302 return;
2303
2304 /* This function could be much more efficient if we had a FLAG
2305 * to signal if there are any hibit chars in the string
2306 */
2307 hicount = 0;
2308 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2309 if (*c & 0x80)
2310 hicount++;
2311 }
2312
2313 if (hicount) {
2314 char *src, *dst;
2315 SvGROW(sv, SvCUR(sv) + hicount + 1);
2316
2317 src = SvEND(sv) - 1;
2318 SvCUR_set(sv, SvCUR(sv) + hicount);
2319 dst = SvEND(sv) - 1;
2320
2321 while (src < dst) {
2322 if (*src & 0x80) {
2323 dst--;
2324 uv_to_utf8((U8*)dst, (U8)*src--);
2325 dst--;
2326 }
2327 else {
2328 *dst-- = *src--;
2329 }
2330 }
2331
2332 SvUTF8_on(sv);
2333 }
2334}
2335
2336bool
2337Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2338{
2339 if (SvPOK(sv) && SvUTF8(sv)) {
2340 char *c = SvPVX(sv);
2341 char *first_hi = 0;
2342 /* need to figure out if this is possible at all first */
2343 while (c < SvEND(sv)) {
2344 if (*c & 0x80) {
2345 I32 len;
ce32ed4b 2346 UV uv = utf8_to_uv((U8*)c, &len);
560a288e
GS
2347 if (uv >= 256) {
2348 if (fail_ok)
2349 return FALSE;
2350 else {
2351 /* XXX might want to make a callback here instead */
9a54186f 2352 Perl_croak(aTHX_ "Big byte");
560a288e
GS
2353 }
2354 }
2355 if (!first_hi)
2356 first_hi = c;
2357 c += len;
2358 }
2359 else {
2360 c++;
2361 }
2362 }
2363
2364 if (first_hi) {
2365 char *src = first_hi;
2366 char *dst = first_hi;
2367 while (src < SvEND(sv)) {
2368 if (*src & 0x80) {
2369 I32 len;
ce32ed4b 2370 U8 u = (U8)utf8_to_uv((U8*)src, &len);
560a288e
GS
2371 *dst++ = u;
2372 src += len;
2373 }
2374 else {
2375 *dst++ = *src++;
2376 }
2377 }
2378 SvCUR_set(sv, dst - SvPVX(sv));
2379 }
2380 SvUTF8_off(sv);
2381 }
2382 return TRUE;
2383}
2384
2385void
2386Perl_sv_utf8_encode(pTHX_ register SV *sv)
2387{
2388 sv_utf8_upgrade(sv);
2389 SvUTF8_off(sv);
2390}
2391
2392bool
2393Perl_sv_utf8_decode(pTHX_ register SV *sv)
2394{
2395 if (SvPOK(sv)) {
2396 char *c;
2397 bool has_utf = FALSE;
2398 if (!sv_utf8_downgrade(sv, TRUE))
2399 return FALSE;
2400
2401 /* it is actually just a matter of turning the utf8 flag on, but
2402 * we want to make sure everything inside is valid utf8 first.
2403 */
2404 c = SvPVX(sv);
2405 while (c < SvEND(sv)) {
2406 if (*c & 0x80) {
2407 I32 len;
2408 (void)utf8_to_uv((U8*)c, &len);
2409 if (len == 1) {
2410 /* bad utf8 */
2411 return FALSE;
2412 }
2413 c += len;
2414 has_utf = TRUE;
2415 }
2416 else {
2417 c++;
2418 }
2419 }
2420
2421 if (has_utf)
2422 SvUTF8_on(sv);
2423 }
2424 return TRUE;
2425}
2426
2427
79072805 2428/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 2429 * to be reused, since it may destroy the source string if it is marked
79072805
LW
2430 * as temporary.
2431 */
2432
954c1994
GS
2433/*
2434=for apidoc sv_setsv
2435
2436Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2437The source SV may be destroyed if it is mortal. Does not handle 'set'
2438magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2439C<sv_setsv_mg>.
2440
2441=cut
2442*/
2443
79072805 2444void
864dbfa3 2445Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 2446{
11343788 2447 dTHR;
8990e307
LW
2448 register U32 sflags;
2449 register int dtype;
2450 register int stype;
463ee0b2 2451
79072805
LW
2452 if (sstr == dstr)
2453 return;
2213622d 2454 SV_CHECK_THINKFIRST(dstr);
79072805 2455 if (!sstr)
3280af22 2456 sstr = &PL_sv_undef;
8990e307
LW
2457 stype = SvTYPE(sstr);
2458 dtype = SvTYPE(dstr);
79072805 2459
a0d0e21e 2460 SvAMAGIC_off(dstr);
9e7bc3e8 2461
463ee0b2 2462 /* There's a lot of redundancy below but we're going for speed here */
79072805 2463
8990e307 2464 switch (stype) {
79072805 2465 case SVt_NULL:
aece5585 2466 undef_sstr:
20408e3c
GS
2467 if (dtype != SVt_PVGV) {
2468 (void)SvOK_off(dstr);
2469 return;
2470 }
2471 break;
463ee0b2 2472 case SVt_IV:
aece5585
GA
2473 if (SvIOK(sstr)) {
2474 switch (dtype) {
2475 case SVt_NULL:
8990e307 2476 sv_upgrade(dstr, SVt_IV);
aece5585
GA
2477 break;
2478 case SVt_NV:
8990e307 2479 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
2480 break;
2481 case SVt_RV:
2482 case SVt_PV:
a0d0e21e 2483 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA
2484 break;
2485 }
2486 (void)SvIOK_only(dstr);
2487 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ
2488 if (SvIsUV(sstr))
2489 SvIsUV_on(dstr);
aece5585
GA
2490 SvTAINT(dstr);
2491 return;
8990e307 2492 }
aece5585
GA
2493 goto undef_sstr;
2494
463ee0b2 2495 case SVt_NV:
aece5585
GA
2496 if (SvNOK(sstr)) {
2497 switch (dtype) {
2498 case SVt_NULL:
2499 case SVt_IV:
8990e307 2500 sv_upgrade(dstr, SVt_NV);
aece5585
GA
2501 break;
2502 case SVt_RV:
2503 case SVt_PV:
2504 case SVt_PVIV:
a0d0e21e 2505 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA
2506 break;
2507 }
2508 SvNVX(dstr) = SvNVX(sstr);
2509 (void)SvNOK_only(dstr);
2510 SvTAINT(dstr);
2511 return;
8990e307 2512 }
aece5585
GA
2513 goto undef_sstr;
2514
ed6116ce 2515 case SVt_RV:
8990e307 2516 if (dtype < SVt_RV)
ed6116ce 2517 sv_upgrade(dstr, SVt_RV);
c07a80fd
PP
2518 else if (dtype == SVt_PVGV &&
2519 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2520 sstr = SvRV(sstr);
a5f75d66 2521 if (sstr == dstr) {
1d7c1841
GS
2522 if (GvIMPORTED(dstr) != GVf_IMPORTED
2523 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2524 {
a5f75d66 2525 GvIMPORTED_on(dstr);
1d7c1841 2526 }
a5f75d66
AD
2527 GvMULTI_on(dstr);
2528 return;
2529 }
c07a80fd
PP
2530 goto glob_assign;
2531 }
ed6116ce 2532 break;
463ee0b2 2533 case SVt_PV:
fc36a67e 2534 case SVt_PVFM:
8990e307 2535 if (dtype < SVt_PV)
463ee0b2 2536 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW
2537 break;
2538 case SVt_PVIV:
8990e307 2539 if (dtype < SVt_PVIV)
463ee0b2 2540 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW
2541 break;
2542 case SVt_PVNV:
8990e307 2543 if (dtype < SVt_PVNV)
463ee0b2 2544 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 2545 break;
4633a7c4
LW
2546 case SVt_PVAV:
2547 case SVt_PVHV:
2548 case SVt_PVCV:
4633a7c4 2549 case SVt_PVIO:
533c011a 2550 if (PL_op)
cea2e8a9 2551 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 2552 PL_op_name[PL_op->op_type]);
4633a7c4 2553 else
cea2e8a9 2554 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW
2555 break;
2556
79072805 2557 case SVt_PVGV:
8990e307 2558 if (dtype <= SVt_PVGV) {
c07a80fd 2559 glob_assign:
a5f75d66 2560 if (dtype != SVt_PVGV) {
a0d0e21e
LW
2561 char *name = GvNAME(sstr);
2562 STRLEN len = GvNAMELEN(sstr);
463ee0b2 2563 sv_upgrade(dstr, SVt_PVGV);
a0d0e21e 2564 sv_magic(dstr, dstr, '*', name, len);
85aff577 2565 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW
2566 GvNAME(dstr) = savepvn(name, len);
2567 GvNAMELEN(dstr) = len;
2568 SvFAKE_on(dstr); /* can coerce to non-glob */
2569 }
7bac28a0 2570 /* ahem, death to those who redefine active sort subs */
3280af22
NIS
2571 else if (PL_curstackinfo->si_type == PERLSI_SORT
2572 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 2573 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 2574 GvNAME(dstr));
a0d0e21e 2575 (void)SvOK_off(dstr);
a5f75d66 2576 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 2577 gp_free((GV*)dstr);
79072805 2578 GvGP(dstr) = gp_ref(GvGP(sstr));
8990e307 2579 SvTAINT(dstr);
1d7c1841
GS
2580 if (GvIMPORTED(dstr) != GVf_IMPORTED
2581 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2582 {
a5f75d66 2583 GvIMPORTED_on(dstr);
1d7c1841 2584 }
a5f75d66 2585 GvMULTI_on(dstr);
79072805
LW
2586 return;
2587 }
2588 /* FALL THROUGH */
2589
2590 default:
973f89ab
CS
2591 if (SvGMAGICAL(sstr)) {
2592 mg_get(sstr);
2593 if (SvTYPE(sstr) != stype) {
2594 stype = SvTYPE(sstr);
2595 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2596 goto glob_assign;
2597 }
2598 }
ded42b9f 2599 if (stype == SVt_PVLV)
6fc92669 2600 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 2601 else
6fc92669 2602 (void)SvUPGRADE(dstr, stype);
79072805
LW
2603 }
2604
8990e307
LW
2605 sflags = SvFLAGS(sstr);
2606
2607 if (sflags & SVf_ROK) {
2608 if (dtype >= SVt_PV) {
2609 if (dtype == SVt_PVGV) {
2610 SV *sref = SvREFCNT_inc(SvRV(sstr));
2611 SV *dref = 0;
a5f75d66 2612 int intro = GvINTRO(dstr);
a0d0e21e
LW
2613
2614 if (intro) {
2615 GP *gp;
1d7c1841 2616 gp_free((GV*)dstr);
a5f75d66 2617 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 2618 Newz(602,gp, 1, GP);
44a8e56a 2619 GvGP(dstr) = gp_ref(gp);
a0d0e21e 2620 GvSV(dstr) = NEWSV(72,0);
1d7c1841 2621 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 2622 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 2623 }
a5f75d66 2624 GvMULTI_on(dstr);
8990e307
LW
2625 switch (SvTYPE(sref)) {
2626 case SVt_PVAV:
a0d0e21e
LW
2627 if (intro)
2628 SAVESPTR(GvAV(dstr));
2629 else
2630 dref = (SV*)GvAV(dstr);
8990e307 2631 GvAV(dstr) = (AV*)sref;
39bac7f7 2632 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS
2633 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2634 {
a5f75d66 2635 GvIMPORTED_AV_on(dstr);
1d7c1841 2636 }
8990e307
LW
2637 break;
2638 case SVt_PVHV:
a0d0e21e
LW
2639 if (intro)
2640 SAVESPTR(GvHV(dstr));
2641 else
2642 dref = (SV*)GvHV(dstr);
8990e307 2643 GvHV(dstr) = (HV*)sref;
39bac7f7 2644 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS
2645 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2646 {
a5f75d66 2647 GvIMPORTED_HV_on(dstr);
1d7c1841 2648 }
8990e307
LW
2649 break;
2650 case SVt_PVCV:
8ebc5c01
PP
2651 if (intro) {
2652 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2653 SvREFCNT_dec(GvCV(dstr));
2654 GvCV(dstr) = Nullcv;
68dc0745 2655 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 2656 PL_sub_generation++;
8ebc5c01 2657 }
a0d0e21e 2658 SAVESPTR(GvCV(dstr));
8ebc5c01 2659 }
68dc0745
PP
2660 else
2661 dref = (SV*)GvCV(dstr);
2662 if (GvCV(dstr) != (CV*)sref) {
748a9306 2663 CV* cv = GvCV(dstr);
4633a7c4 2664 if (cv) {
68dc0745
PP
2665 if (!GvCVGEN((GV*)dstr) &&
2666 (CvROOT(cv) || CvXSUB(cv)))
2667 {
fe5e78ed
GS
2668 SV *const_sv = cv_const_sv(cv);
2669 bool const_changed = TRUE;
2670 if(const_sv)
2671 const_changed = sv_cmp(const_sv,
2672 op_const_sv(CvSTART((CV*)sref),
2673 Nullcv));
7bac28a0
PP
2674 /* ahem, death to those who redefine
2675 * active sort subs */
3280af22
NIS
2676 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2677 PL_sortcop == CvSTART(cv))
cea2e8a9 2678 Perl_croak(aTHX_
7bac28a0
PP
2679 "Can't redefine active sort subroutine %s",
2680 GvENAME((GV*)dstr));
e476b1b5
GS
2681 if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2682 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
fe5e78ed
GS
2683 "Constant subroutine %s redefined"
2684 : "Subroutine %s redefined",
2f34f9d4 2685 GvENAME((GV*)dstr));
9607fc9c 2686 }
3fe9a6f1
PP
2687 cv_ckproto(cv, (GV*)dstr,
2688 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 2689 }
a5f75d66 2690 GvCV(dstr) = (CV*)sref;
7a4c00b4 2691 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 2692 GvASSUMECV_on(dstr);
3280af22 2693 PL_sub_generation++;
a5f75d66 2694 }
39bac7f7 2695 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS
2696 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2697 {
a5f75d66 2698 GvIMPORTED_CV_on(dstr);
1d7c1841 2699 }
8990e307 2700 break;
91bba347
LW
2701 case SVt_PVIO:
2702 if (intro)
2703 SAVESPTR(GvIOp(dstr));
2704 else
2705 dref = (SV*)GvIOp(dstr);
2706 GvIOp(dstr) = (IO*)sref;
2707 break;
8990e307 2708 default:
a0d0e21e
LW
2709 if (intro)
2710 SAVESPTR(GvSV(dstr));
2711 else
2712 dref = (SV*)GvSV(dstr);
8990e307 2713 GvSV(dstr) = sref;
39bac7f7 2714 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS
2715 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2716 {
a5f75d66 2717 GvIMPORTED_SV_on(dstr);
1d7c1841 2718 }
8990e307
LW
2719 break;
2720 }
2721 if (dref)
2722 SvREFCNT_dec(dref);
a0d0e21e
LW
2723 if (intro)
2724 SAVEFREESV(sref);
8990e307
LW
2725 SvTAINT(dstr);
2726 return;
2727 }
a0d0e21e 2728 if (SvPVX(dstr)) {
760ac839 2729 (void)SvOOK_off(dstr); /* backoff */
50483b2c
JD
2730 if (SvLEN(dstr))
2731 Safefree(SvPVX(dstr));
a0d0e21e
LW
2732 SvLEN(dstr)=SvCUR(dstr)=0;
2733 }
8990e307 2734 }
a0d0e21e 2735 (void)SvOK_off(dstr);
8990e307 2736 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 2737 SvROK_on(dstr);
8990e307 2738 if (sflags & SVp_NOK) {
ed6116ce
LW
2739 SvNOK_on(dstr);
2740 SvNVX(dstr) = SvNVX(sstr);
2741 }
8990e307 2742 if (sflags & SVp_IOK) {
a0d0e21e 2743 (void)SvIOK_on(dstr);
ed6116ce 2744 SvIVX(dstr) = SvIVX(sstr);
2b1c7e3e 2745 if (sflags & SVf_IVisUV)
25da4f38 2746 SvIsUV_on(dstr);
ed6116ce 2747 }
a0d0e21e
LW
2748 if (SvAMAGIC(sstr)) {
2749 SvAMAGIC_on(dstr);
2750 }
ed6116ce 2751 }
8990e307 2752 else if (sflags & SVp_POK) {
79072805
LW
2753
2754 /*
2755 * Check to see if we can just swipe the string. If so, it's a
2756 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW
2757 * It might even be a win on short strings if SvPVX(dstr)
2758 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW
2759 */
2760
ff68c719 2761 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 2762 SvREFCNT(sstr) == 1 && /* and no other references to it? */
a5f75d66
AD
2763 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2764 {
adbc6bb1 2765 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD
2766 if (SvOOK(dstr)) {
2767 SvFLAGS(dstr) &= ~SVf_OOK;
2768 Safefree(SvPVX(dstr) - SvIVX(dstr));
2769 }
50483b2c 2770 else if (SvLEN(dstr))
a5f75d66 2771 Safefree(SvPVX(dstr));
79072805 2772 }
a5f75d66 2773 (void)SvPOK_only(dstr);
463ee0b2 2774 SvPV_set(dstr, SvPVX(sstr));
79072805
LW
2775 SvLEN_set(dstr, SvLEN(sstr));
2776 SvCUR_set(dstr, SvCUR(sstr));
f4e86e0f 2777
79072805 2778 SvTEMP_off(dstr);
2b1c7e3e 2779 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
79072805
LW
2780 SvPV_set(sstr, Nullch);
2781 SvLEN_set(sstr, 0);
a5f75d66
AD
2782 SvCUR_set(sstr, 0);
2783 SvTEMP_off(sstr);
79072805
LW
2784 }
2785 else { /* have to copy actual string */
8990e307
LW
2786 STRLEN len = SvCUR(sstr);
2787
2788 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2789 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2790 SvCUR_set(dstr, len);
2791 *SvEND(dstr) = '\0';
a0d0e21e 2792 (void)SvPOK_only(dstr);
79072805 2793 }
3aa33fe5 2794 if ((sflags & SVf_UTF8) && !IN_BYTE)
a7cb1f99 2795 SvUTF8_on(dstr);
79072805 2796 /*SUPPRESS 560*/
8990e307 2797 if (sflags & SVp_NOK) {
79072805 2798 SvNOK_on(dstr);
463ee0b2 2799 SvNVX(dstr) = SvNVX(sstr);
79072805 2800 }
8990e307 2801 if (sflags & SVp_IOK) {
a0d0e21e 2802 (void)SvIOK_on(dstr);
463ee0b2 2803 SvIVX(dstr) = SvIVX(sstr);
2b1c7e3e 2804 if (sflags & SVf_IVisUV)
25da4f38 2805 SvIsUV_on(dstr);
79072805
LW
2806 }
2807 }
8990e307 2808 else if (sflags & SVp_NOK) {
463ee0b2 2809 SvNVX(dstr) = SvNVX(sstr);
a0d0e21e 2810 (void)SvNOK_only(dstr);
2b1c7e3e 2811 if (sflags & SVf_IOK) {
a0d0e21e 2812 (void)SvIOK_on(dstr);
463ee0b2 2813 SvIVX(dstr) = SvIVX(sstr);
25da4f38 2814 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2b1c7e3e 2815 if (sflags & SVf_IVisUV)
25da4f38 2816 SvIsUV_on(dstr);
79072805
LW
2817 }
2818 }
8990e307 2819 else if (sflags & SVp_IOK) {
a0d0e21e 2820 (void)SvIOK_only(dstr);
463ee0b2 2821 SvIVX(dstr) = SvIVX(sstr);
2b1c7e3e 2822 if (sflags & SVf_IVisUV)
25da4f38 2823 SvIsUV_on(dstr);
79072805
LW
2824 }
2825 else {
20408e3c 2826 if (dtype == SVt_PVGV) {
e476b1b5
GS
2827 if (ckWARN(WARN_MISC))
2828 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
20408e3c
GS
2829 }
2830 else
2831 (void)SvOK_off(dstr);
a0d0e21e 2832 }
463ee0b2 2833 SvTAINT(dstr);
79072805
LW
2834}
2835
954c1994
GS
2836/*
2837=for apidoc sv_setsv_mg
2838
2839Like C<sv_setsv>, but also handles 'set' magic.
2840
2841=cut
2842*/
2843
79072805 2844void
864dbfa3 2845Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS
2846{
2847 sv_setsv(dstr,sstr);
2848 SvSETMAGIC(dstr);
2849}
2850
954c1994
GS
2851/*
2852=for apidoc sv_setpvn
2853
2854Copies a string into an SV. The C<len> parameter indicates the number of
2855bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2856
2857=cut
2858*/
2859
ef50df4b 2860void
864dbfa3 2861Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 2862{
c6f8c383 2863 register char *dptr;
4561caa4
CS
2864 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2865 elicit a warning, but it won't hurt. */
2213622d 2866 SV_CHECK_THINKFIRST(sv);
463ee0b2 2867 if (!ptr) {
a0d0e21e 2868 (void)SvOK_off(sv);
463ee0b2
LW
2869 return;
2870 }
6fc92669 2871 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 2872
79072805 2873 SvGROW(sv, len + 1);
c6f8c383
GA
2874 dptr = SvPVX(sv);
2875 Move(ptr,dptr,len,char);
2876 dptr[len] = '\0';
79072805 2877 SvCUR_set(sv, len);
a0d0e21e 2878 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2879 SvTAINT(sv);
79072805
LW
2880}
2881
954c1994
GS
2882/*
2883=for apidoc sv_setpvn_mg
2884
2885Like C<sv_setpvn>, but also handles 'set' magic.
2886
2887=cut
2888*/
2889
79072805 2890void
864dbfa3 2891Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS
2892{
2893 sv_setpvn(sv,ptr,len);
2894 SvSETMAGIC(sv);
2895}
2896
954c1994
GS
2897/*
2898=for apidoc sv_setpv
2899
2900Copies a string into an SV. The string must be null-terminated. Does not
2901handle 'set' magic. See C<sv_setpv_mg>.
2902
2903=cut
2904*/
2905
ef50df4b 2906void
864dbfa3 2907Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW
2908{
2909 register STRLEN len;
2910
2213622d 2911 SV_CHECK_THINKFIRST(sv);
463ee0b2 2912 if (!ptr) {
a0d0e21e 2913 (void)SvOK_off(sv);
463ee0b2
LW
2914 return;
2915 }
79072805 2916 len = strlen(ptr);
6fc92669 2917 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 2918
79072805 2919 SvGROW(sv, len + 1);
463ee0b2 2920 Move(ptr,SvPVX(sv),len+1,char);
79072805 2921 SvCUR_set(sv, len);
a0d0e21e 2922 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2
LW
2923 SvTAINT(sv);
2924}
2925
954c1994
GS
2926/*
2927=for apidoc sv_setpv_mg
2928
2929Like C<sv_setpv>, but also handles 'set' magic.
2930
2931=cut
2932*/
2933
463ee0b2 2934void
864dbfa3 2935Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS
2936{
2937 sv_setpv(sv,ptr);
2938 SvSETMAGIC(sv);
2939}
2940
954c1994
GS
2941/*
2942=for apidoc sv_usepvn
2943
2944Tells an SV to use C<ptr> to find its string value. Normally the string is
2945stored inside the SV but sv_usepvn allows the SV to use an outside string.
2946The C<ptr> should point to memory that was allocated by C<malloc>. The
2947string length, C<len>, must be supplied. This function will realloc the
2948memory pointed to by C<ptr>, so that pointer should not be freed or used by
2949the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2950See C<sv_usepvn_mg>.
2951
2952=cut
2953*/
2954
ef50df4b 2955void
864dbfa3 2956Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 2957{
2213622d 2958 SV_CHECK_THINKFIRST(sv);
c6f8c383 2959 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 2960 if (!ptr) {
a0d0e21e 2961 (void)SvOK_off(sv);
463ee0b2
LW
2962 return;
2963 }
a0ed51b3 2964 (void)SvOOK_off(sv);
50483b2c 2965 if (SvPVX(sv) && SvLEN(sv))
463ee0b2
LW
2966 Safefree(SvPVX(sv));
2967 Renew(ptr, len+1, char);
2968 SvPVX(sv) = ptr;
2969 SvCUR_set(sv, len);
2970 SvLEN_set(sv, len+1);
2971 *SvEND(sv) = '\0';
a0d0e21e 2972 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2973 SvTAINT(sv);
79072805
LW
2974}
2975
954c1994
GS
2976/*
2977=for apidoc sv_usepvn_mg
2978
2979Like C<sv_usepvn>, but also handles 'set' magic.
2980
2981=cut
2982*/
2983
ef50df4b 2984void
864dbfa3 2985Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 2986{
51c1089b 2987 sv_usepvn(sv,ptr,len);
ef50df4b
GS
2988 SvSETMAGIC(sv);
2989}
2990
6fc92669 2991void
864dbfa3 2992Perl_sv_force_normal(pTHX_ register SV *sv)
0f15f207 2993{
2213622d
GA
2994 if (SvREADONLY(sv)) {
2995 dTHR;
3280af22 2996 if (PL_curcop != &PL_compiling)
cea2e8a9 2997 Perl_croak(aTHX_ PL_no_modify);
0f15f207 2998 }
2213622d
GA
2999 if (SvROK(sv))
3000 sv_unref(sv);
6fc92669
GS
3001 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3002 sv_unglob(sv);
0f15f207
MB
3003}
3004
954c1994
GS
3005/*
3006=for apidoc sv_chop
3007
3008Efficient removal of characters from the beginning of the string buffer.
3009SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3010the string buffer. The C<ptr> becomes the first character of the adjusted
3011string.
3012
3013=cut
3014*/
3015
79072805 3016void
864dbfa3 3017Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
8ac85365
NIS
3018
3019
79072805
LW
3020{
3021 register STRLEN delta;
3022
a0d0e21e 3023 if (!ptr || !SvPOKp(sv))
79072805 3024 return;
2213622d 3025 SV_CHECK_THINKFIRST(sv);
79072805
LW
3026 if (SvTYPE(sv) < SVt_PVIV)
3027 sv_upgrade(sv,SVt_PVIV);
3028
3029 if (!SvOOK(sv)) {
50483b2c
JD
3030 if (!SvLEN(sv)) { /* make copy of shared string */
3031 char *pvx = SvPVX(sv);
3032 STRLEN len = SvCUR(sv);
3033 SvGROW(sv, len + 1);
3034 Move(pvx,SvPVX(sv),len,char);
3035 *SvEND(sv) = '\0';
3036 }
463ee0b2 3037 SvIVX(sv) = 0;
79072805
LW
3038 SvFLAGS(sv) |= SVf_OOK;
3039 }
25da4f38 3040 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
463ee0b2 3041 delta = ptr - SvPVX(sv);
79072805
LW
3042 SvLEN(sv) -= delta;
3043 SvCUR(sv) -= delta;
463ee0b2
LW
3044 SvPVX(sv) += delta;
3045 SvIVX(sv) += delta;
79072805
LW
3046}
3047
954c1994
GS
3048/*
3049=for apidoc sv_catpvn
3050
3051Concatenates the string onto the end of the string which is in the SV. The
3052C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3053'set' magic. See C<sv_catpvn_mg>.
3054
3055=cut
3056*/
3057
79072805 3058void
864dbfa3 3059Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3060{
463ee0b2 3061 STRLEN tlen;
748a9306 3062 char *junk;
a0d0e21e 3063
748a9306 3064 junk = SvPV_force(sv, tlen);
463ee0b2 3065 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
3066 if (ptr == junk)
3067 ptr = SvPVX(sv);
463ee0b2 3068 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW
3069 SvCUR(sv) += len;
3070 *SvEND(sv) = '\0';
d41ff1b8 3071 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3072 SvTAINT(sv);
79072805
LW
3073}
3074
954c1994
GS
3075/*
3076=for apidoc sv_catpvn_mg
3077
3078Like C<sv_catpvn>, but also handles 'set' magic.
3079
3080=cut
3081*/
3082
79072805 3083void
864dbfa3 3084Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS
3085{
3086 sv_catpvn(sv,ptr,len);
3087 SvSETMAGIC(sv);
3088}
3089
954c1994
GS
3090/*
3091=for apidoc sv_catsv
3092
3093Concatenates the string from SV C<ssv> onto the end of the string in SV
3094C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3095
3096=cut
3097*/
3098
ef50df4b 3099void
864dbfa3 3100Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
79072805
LW
3101{
3102 char *s;
463ee0b2 3103 STRLEN len;
79072805
LW
3104 if (!sstr)
3105 return;
155aba94 3106 if ((s = SvPV(sstr, len))) {
e84ff256 3107 if (DO_UTF8(sstr)) {
560a288e 3108 sv_utf8_upgrade(dstr);
e84ff256 3109 sv_catpvn(dstr,s,len);
560a288e 3110 SvUTF8_on(dstr);
e84ff256
GS
3111 }
3112 else
3113 sv_catpvn(dstr,s,len);
560a288e 3114 }
79072805
LW
3115}
3116
954c1994
GS
3117/*
3118=for apidoc sv_catsv_mg
3119
3120Like C<sv_catsv>, but also handles 'set' magic.
3121
3122=cut
3123*/
3124
79072805 3125void
864dbfa3 3126Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS
3127{
3128 sv_catsv(dstr,sstr);
3129 SvSETMAGIC(dstr);
3130}
3131
954c1994
GS
3132/*
3133=for apidoc sv_catpv
3134
3135Concatenates the string onto the end of the string which is in the SV.
3136Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3137
3138=cut
3139*/
3140
ef50df4b 3141void
864dbfa3 3142Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW
3143{
3144 register STRLEN len;
463ee0b2 3145 STRLEN tlen;
748a9306 3146 char *junk;
79072805 3147
79072805
LW
3148 if (!ptr)
3149 return;
748a9306 3150 junk = SvPV_force(sv, tlen);
79072805 3151 len = strlen(ptr);
463ee0b2 3152 SvGROW(sv, tlen + len + 1);
4633a7c4
LW
3153 if (ptr == junk)
3154 ptr = SvPVX(sv);
463ee0b2 3155 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 3156 SvCUR(sv) += len;
d41ff1b8 3157 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3158 SvTAINT(sv);
79072805
LW
3159}
3160
954c1994
GS
3161/*
3162=for apidoc sv_catpv_mg
3163
3164Like C<sv_catpv>, but also handles 'set' magic.
3165
3166=cut
3167*/
3168
ef50df4b 3169void
864dbfa3 3170Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b 3171{
51c1089b 3172 sv_catpv(sv,ptr);
ef50df4b
GS
3173 SvSETMAGIC(sv);
3174}
3175
79072805 3176SV *
864dbfa3 3177Perl_newSV(pTHX_ STRLEN len)
79072805
LW
3178{
3179 register SV *sv;
3180
4561caa4 3181 new_SV(sv);
79072805
LW
3182 if (len) {
3183 sv_upgrade(sv, SVt_PV);
3184 SvGROW(sv, len + 1);
3185 }
3186 return sv;
3187}
3188
1edc1566
PP
3189/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3190
954c1994
GS
3191/*
3192=for apidoc sv_magic
3193
3194Adds magic to an SV.
3195
3196=cut
3197*/
3198
79072805 3199void
864dbfa3 3200Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
79072805
LW
3201{
3202 MAGIC* mg;
3203
0f15f207
MB
3204 if (SvREADONLY(sv)) {
3205 dTHR;
3280af22 3206 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
cea2e8a9 3207 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3208 }
4633a7c4 3209 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW
3210 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3211 if (how == 't')
565764a8 3212 mg->mg_len |= 1;
463ee0b2 3213 return;
748a9306 3214 }
463ee0b2
LW
3215 }
3216 else {
c6f8c383 3217 (void)SvUPGRADE(sv, SVt_PVMG);
463ee0b2 3218 }
79072805
LW
3219 Newz(702,mg, 1, MAGIC);
3220 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 3221
79072805 3222 SvMAGIC(sv) = mg;
c277df42 3223 if (!obj || obj == sv || how == '#' || how == 'r')
8990e307 3224 mg->mg_obj = obj;
85e6fe83 3225 else {
11343788 3226 dTHR;
8990e307 3227 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW
3228 mg->mg_flags |= MGf_REFCOUNTED;
3229 }
79072805 3230 mg->mg_type = how;
565764a8 3231 mg->mg_len = namlen;
1edc1566
PP
3232 if (name)
3233 if (namlen >= 0)
3234 mg->mg_ptr = savepvn(name, namlen);
c6ee37c5 3235 else if (namlen == HEf_SVKEY)
1edc1566
PP
3236 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3237
79072805
LW
3238 switch (how) {
3239 case 0:
22c35a8c 3240 mg->mg_virtual = &PL_vtbl_sv;
79072805 3241 break;
a0d0e21e 3242 case 'A':
22c35a8c 3243 mg->mg_virtual = &PL_vtbl_amagic;
a0d0e21e
LW
3244 break;
3245 case 'a':
22c35a8c 3246 mg->mg_virtual = &PL_vtbl_amagicelem;
a0d0e21e
LW
3247 break;
3248 case 'c':
3249 mg->mg_virtual = 0;
3250 break;
79072805 3251 case 'B':
22c35a8c 3252 mg->mg_virtual = &PL_vtbl_bm;
79072805 3253 break;
6cef1e77 3254 case 'D':
22c35a8c 3255 mg->mg_virtual = &PL_vtbl_regdata;
6cef1e77
IZ
3256 break;
3257 case 'd':
22c35a8c 3258 mg->mg_virtual = &PL_vtbl_regdatum;
6cef1e77 3259 break;
79072805 3260 case 'E':
22c35a8c 3261 mg->mg_virtual = &PL_vtbl_env;
79072805 3262 break;
55497cff 3263 case 'f':
22c35a8c 3264 mg->mg_virtual = &PL_vtbl_fm;
55497cff 3265 break;
79072805 3266 case 'e':
22c35a8c 3267 mg->mg_virtual = &PL_vtbl_envelem;
79072805 3268 break;
93a17b20 3269 case 'g':
22c35a8c 3270 mg->mg_virtual = &PL_vtbl_mglob;
93a17b20 3271 break;
463ee0b2 3272 case 'I':
22c35a8c 3273 mg->mg_virtual = &PL_vtbl_isa;
463ee0b2
LW
3274 break;
3275 case 'i':
22c35a8c 3276 mg->mg_virtual = &PL_vtbl_isaelem;
463ee0b2 3277 break;
16660edb 3278 case 'k':
22c35a8c 3279 mg->mg_virtual = &PL_vtbl_nkeys;
16660edb 3280 break;
79072805 3281 case 'L':
a0d0e21e 3282 SvRMAGICAL_on(sv);
93a17b20
LW
3283 mg->mg_virtual = 0;
3284 break;
3285 case 'l':
22c35a8c 3286 mg->mg_virtual = &PL_vtbl_dbline;
79072805 3287 break;
f93b4edd
MB
3288#ifdef USE_THREADS
3289 case 'm':
22c35a8c 3290 mg->mg_virtual = &PL_vtbl_mutex;
f93b4edd
MB
3291 break;
3292#endif /* USE_THREADS */
36477c24 3293#ifdef USE_LOCALE_COLLATE
bbce6d69 3294 case 'o':
22c35a8c 3295 mg->mg_virtual = &PL_vtbl_collxfrm;
bbce6d69 3296 break;
36477c24 3297#endif /* USE_LOCALE_COLLATE */
463ee0b2 3298 case 'P':
22c35a8c 3299 mg->mg_virtual = &PL_vtbl_pack;
463ee0b2
LW
3300 break;
3301 case 'p':
a0d0e21e 3302 case 'q':
22c35a8c 3303 mg->mg_virtual = &PL_vtbl_packelem;
463ee0b2 3304 break;
c277df42 3305 case 'r':
22c35a8c 3306 mg->mg_virtual = &PL_vtbl_regexp;
c277df42 3307 break;
79072805 3308 case 'S':
22c35a8c 3309 mg->mg_virtual = &PL_vtbl_sig;
79072805
LW
3310 break;
3311 case 's':
22c35a8c 3312 mg->mg_virtual = &PL_vtbl_sigelem;
79072805 3313 break;
463ee0b2 3314 case 't':
22c35a8c 3315 mg->mg_virtual = &PL_vtbl_taint;
565764a8 3316 mg->mg_len = 1;
463ee0b2 3317 break;
79072805 3318 case 'U':
22c35a8c 3319 mg->mg_virtual = &PL_vtbl_uvar;
79072805
LW
3320 break;
3321 case 'v':
22c35a8c 3322 mg->mg_virtual = &PL_vtbl_vec;
79072805
LW
3323 break;
3324 case 'x':
22c35a8c 3325 mg->mg_virtual = &PL_vtbl_substr;
79072805 3326 break;
5f05dabc 3327 case 'y':
22c35a8c 3328 mg->mg_virtual = &PL_vtbl_defelem;
5f05dabc 3329 break;
79072805 3330 case '*':
22c35a8c 3331 mg->mg_virtual = &PL_vtbl_glob;
79072805
LW
3332 break;
3333 case '#':
22c35a8c 3334 mg->mg_virtual = &PL_vtbl_arylen;
79072805 3335 break;
a0d0e21e 3336 case '.':
22c35a8c 3337 mg->mg_virtual = &PL_vtbl_pos;
a0d0e21e 3338 break;
810b8aa5
GS
3339 case '<':
3340 mg->mg_virtual = &PL_vtbl_backref;
3341 break;
4633a7c4
LW
3342 case '~': /* Reserved for use by extensions not perl internals. */
3343 /* Useful for attaching extension internal data to perl vars. */
3344 /* Note that multiple extensions may clash if magical scalars */
3345 /* etc holding private data from one are passed to another. */
3346 SvRMAGICAL_on(sv);
a0d0e21e 3347 break;
79072805 3348 default:
cea2e8a9 3349 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
463ee0b2 3350 }
8990e307
LW
3351 mg_magical(sv);
3352 if (SvGMAGICAL(sv))
3353 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW
3354}
3355
3356int
864dbfa3 3357Perl_sv_unmagic(pTHX_ SV *sv, int type)
463ee0b2
LW
3358{
3359 MAGIC* mg;
3360 MAGIC** mgp;
91bba347 3361 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW
3362 return 0;
3363 mgp = &SvMAGIC(sv);
3364 for (mg = *mgp; mg; mg = *mgp) {
3365 if (mg->mg_type == type) {
3366 MGVTBL* vtbl = mg->mg_virtual;
3367 *mgp = mg->mg_moremagic;
1d7c1841 3368 if (vtbl && vtbl->svt_free)
fc0dc3b3 3369 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
463ee0b2 3370 if (mg->mg_ptr && mg->mg_type != 'g')
565764a8 3371 if (mg->mg_len >= 0)
1edc1566 3372 Safefree(mg->mg_ptr);
565764a8 3373 else if (mg->mg_len == HEf_SVKEY)
1edc1566 3374 SvREFCNT_dec((SV*)mg->mg_ptr);
a0d0e21e
LW
3375 if (mg->mg_flags & MGf_REFCOUNTED)
3376 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW
3377 Safefree(mg);
3378 }
3379 else
3380 mgp = &mg->mg_moremagic;
79072805 3381 }
91bba347 3382 if (!SvMAGIC(sv)) {
463ee0b2 3383 SvMAGICAL_off(sv);
8990e307 3384 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW
3385 }
3386
3387 return 0;
79072805
LW
3388}
3389
810b8aa5 3390SV *
864dbfa3 3391Perl_sv_rvweaken(pTHX_ SV *sv)
810b8aa5
GS
3392{
3393 SV *tsv;
3394 if (!SvOK(sv)) /* let undefs pass */
3395 return sv;
3396 if (!SvROK(sv))
cea2e8a9 3397 Perl_croak(aTHX_ "Can't weaken a nonreference");
810b8aa5
GS
3398 else if (SvWEAKREF(sv)) {
3399 dTHR;
3400 if (ckWARN(WARN_MISC))
cea2e8a9 3401 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
810b8aa5
GS
3402 return sv;
3403 }
3404 tsv = SvRV(sv);
3405 sv_add_backref(tsv, sv);
3406 SvWEAKREF_on(sv);
3407 SvREFCNT_dec(tsv);
3408 return sv;
3409}
3410
3411STATIC void
cea2e8a9 3412S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
810b8aa5
GS
3413{
3414 AV *av;
3415 MAGIC *mg;
3416 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3417 av = (AV*)mg->mg_obj;
3418 else {
3419 av = newAV();
3420 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3421 SvREFCNT_dec(av); /* for sv_magic */
3422 }
3423 av_push(av,sv);
3424}
3425
3426STATIC void
cea2e8a9 3427S_sv_del_backref(pTHX_ SV *sv)
810b8aa5
GS
3428{
3429 AV *av;
3430 SV **svp;
3431 I32 i;
3432 SV *tsv = SvRV(sv);
3433 MAGIC *mg;
3434 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
cea2e8a9 3435 Perl_croak(aTHX_ "panic: del_backref");
810b8aa5
GS
3436 av = (AV *)mg->mg_obj;
3437 svp = AvARRAY(av);
3438 i = AvFILLp(av);
3439 while (i >= 0) {
3440 if (svp[i] == sv) {
3441 svp[i] = &PL_sv_undef; /* XXX */
3442 }
3443 i--;
3444 }
3445}
3446
954c1994
GS
3447/*
3448=for apidoc sv_insert
3449
3450Inserts a string at the specified offset/length within the SV. Similar to
3451the Perl substr() function.
3452
3453=cut
3454*/
3455
79072805 3456void
864dbfa3 3457Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
79072805
LW
3458{
3459 register char *big;
3460 register char *mid;
3461 register char *midend;
3462 register char *bigend;
3463 register I32 i;
6ff81951
GS
3464 STRLEN curlen;
3465
79072805 3466
8990e307 3467 if (!bigstr)
cea2e8a9 3468 Perl_croak(aTHX_ "Can't modify non-existent substring");
6ff81951 3469 SvPV_force(bigstr, curlen);
60fa28ff 3470 (void)SvPOK_only_UTF8(bigstr);
6ff81951
GS
3471 if (offset + len > curlen) {
3472 SvGROW(bigstr, offset+len+1);
3473 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3474 SvCUR_set(bigstr, offset+len);
3475 }
79072805 3476
69b47968 3477 SvTAINT(bigstr);
79072805
LW
3478 i = littlelen - len;
3479 if (i > 0) { /* string might grow */
a0d0e21e 3480 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW
3481 mid = big + offset + len;
3482 midend = bigend = big + SvCUR(bigstr);
3483 bigend += i;
3484 *bigend = '\0';
3485 while (midend > mid) /* shove everything down */
3486 *--bigend = *--midend;
3487 Move(little,big+offset,littlelen,char);
3488 SvCUR(bigstr) += i;
3489 SvSETMAGIC(bigstr);
3490 return;
3491 }
3492 else if (i == 0) {
463ee0b2 3493 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW
3494 SvSETMAGIC(bigstr);
3495 return;
3496 }
3497
463ee0b2 3498 big = SvPVX(bigstr);
79072805
LW
3499 mid = big + offset;
3500 midend = mid + len;
3501 bigend = big + SvCUR(bigstr);
3502
3503 if (midend > bigend)
cea2e8a9 3504 Perl_croak(aTHX_ "panic: sv_insert");
79072805
LW
3505
3506 if (mid - big > bigend - midend) { /* faster to shorten from end */
3507 if (littlelen) {
3508 Move(little, mid, littlelen,char);
3509 mid += littlelen;
3510 }
3511 i = bigend - midend;
3512 if (i > 0) {
3513 Move(midend, mid, i,char);
3514 mid += i;
3515 }
3516 *mid = '\0';
3517 SvCUR_set(bigstr, mid - big);
3518 }
3519 /*SUPPRESS 560*/
155aba94 3520 else if ((i = mid - big)) { /* faster from front */
79072805
LW
3521 midend -= littlelen;
3522 mid = midend;
3523 sv_chop(bigstr,midend-i);
3524 big += i;
3525 while (i--)
3526 *--midend = *--big;
3527 if (littlelen)
3528 Move(little, mid, littlelen,char);
3529 }
3530 else if (littlelen) {
3531 midend -= littlelen;
3532 sv_chop(bigstr,midend);
3533 Move(little,midend,littlelen,char);
3534 }
3535 else {
3536 sv_chop(bigstr,midend);
3537 }
3538 SvSETMAGIC(bigstr);
3539}
3540
3541/* make sv point to what nstr did */
3542
3543void
864dbfa3 3544Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
79072805 3545{
0453d815 3546 dTHR;
79072805 3547 U32 refcnt = SvREFCNT(sv);
2213622d 3548 SV_CHECK_THINKFIRST(sv);
0453d815
PM
3549 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3550 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
93a17b20 3551 if (SvMAGICAL(sv)) {
a0d0e21e
LW
3552 if (SvMAGICAL(nsv))
3553 mg_free(nsv);
3554 else
3555 sv_upgrade(nsv, SVt_PVMG);
93a17b20 3556 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 3557 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW
3558 SvMAGICAL_off(sv);
3559 SvMAGIC(sv) = 0;
3560 }
79072805
LW
3561 SvREFCNT(sv) = 0;
3562 sv_clear(sv);
477f5d66 3563 assert(!SvREFCNT(sv));
79072805
LW
3564 StructCopy(nsv,sv,SV);
3565 SvREFCNT(sv) = refcnt;
1edc1566 3566 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 3567 del_SV(nsv);
79072805
LW
3568}
3569
3570void
864dbfa3 3571Perl_sv_clear(pTHX_ register SV *sv)
79072805 3572{
ec12f114 3573 HV* stash;
79072805
LW
3574 assert(sv);
3575 assert(SvREFCNT(sv) == 0);
3576
ed6116ce 3577 if (SvOBJECT(sv)) {
e858de61 3578 dTHR;
3280af22 3579 if (PL_defstash) { /* Still have a symbol table? */
4e35701f 3580 djSP;
8ebc5c01 3581 GV* destructor;
837485b6 3582 SV tmpref;
a0d0e21e 3583
837485b6
GS
3584 Zero(&tmpref, 1, SV);
3585 sv_upgrade(&tmpref, SVt_RV);
3586 SvROK_on(&tmpref);
3587 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3588 SvREFCNT(&tmpref) = 1;
8ebc5c01 3589
4e8e7886
GS
3590 do {
3591 stash = SvSTASH(sv);
3592 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3593 if (destructor) {
3594 ENTER;
e788e7d3 3595 PUSHSTACKi(PERLSI_DESTROY);
837485b6 3596 SvRV(&tmpref) = SvREFCNT_inc(sv);
4e8e7886
GS
3597 EXTEND(SP, 2);
3598 PUSHMARK(SP);
837485b6 3599 PUSHs(&tmpref);
4e8e7886 3600 PUTBACK;
864dbfa3
GS
3601 call_sv((SV*)GvCV(destructor),
3602 G_DISCARD|G_EVAL|G_KEEPERR);
4e8e7886 3603 SvREFCNT(sv)--;
d3acc0f7 3604 POPSTACK;
3095d977 3605 SPAGAIN;
4e8e7886
GS
3606 LEAVE;
3607 }
3608 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
8ebc5c01 3609
837485b6 3610 del_XRV(SvANY(&tmpref));
6f44e0a4
JP
3611
3612 if (SvREFCNT(sv)) {
3613 if (PL_in_clean_objs)
cea2e8a9 3614 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
6f44e0a4
JP
3615 HvNAME(stash));
3616 /* DESTROY gave object new lease on life */
3617 return;
3618 }
a0d0e21e 3619 }
4e8e7886 3620
a0d0e21e 3621 if (SvOBJECT(sv)) {
4e8e7886 3622 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
a0d0e21e
LW
3623 SvOBJECT_off(sv); /* Curse the object. */
3624 if (SvTYPE(sv) != SVt_PVIO)
3280af22 3625 --PL_sv_objcount; /* XXX Might want something more general */
a0d0e21e 3626 }
463ee0b2 3627 }
c07a80fd 3628 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 3629 mg_free(sv);
ec12f114 3630 stash = NULL;
79072805 3631 switch (SvTYPE(sv)) {
8990e307 3632 case SVt_PVIO:
df0bd2f4
GS
3633 if (IoIFP(sv) &&
3634 IoIFP(sv) != PerlIO_stdin() &&
5f05dabc
PP
3635 IoIFP(sv) != PerlIO_stdout() &&
3636 IoIFP(sv) != PerlIO_stderr())
93578b34 3637 {
f2b5be74 3638 io_close((IO*)sv, FALSE);
93578b34 3639 }
1d7c1841 3640 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
1236053a 3641 PerlDir_close(IoDIRP(sv));
1d7c1841 3642 IoDIRP(sv) = (DIR*)NULL;
8990e307
LW
3643 Safefree(IoTOP_NAME(sv));
3644 Safefree(IoFMT_NAME(sv));
3645 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 3646 /* FALL THROUGH */
79072805 3647 case SVt_PVBM:
a0d0e21e 3648 goto freescalar;
79072805 3649 case SVt_PVCV:
748a9306 3650 case SVt_PVFM:
85e6fe83 3651 cv_undef((CV*)sv);
a0d0e21e 3652 goto freescalar;
79072805 3653 case SVt_PVHV:
85e6fe83 3654 hv_undef((HV*)sv);
a0d0e21e 3655 break;
79072805 3656 case SVt_PVAV:
85e6fe83 3657 av_undef((AV*)sv);
a0d0e21e 3658 break;
02270b4e
GS
3659 case SVt_PVLV:
3660 SvREFCNT_dec(LvTARG(sv));
3661 goto freescalar;
a0d0e21e 3662 case SVt_PVGV:
1edc1566 3663 gp_free((GV*)sv);
a0d0e21e 3664 Safefree(GvNAME(sv));
ec12f114
JPC
3665 /* cannot decrease stash refcount yet, as we might recursively delete
3666 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3667 of stash until current sv is completely gone.
3668 -- JohnPC, 27 Mar 1998 */
3669 stash = GvSTASH(sv);
a0d0e21e 3670 /* FALL THROUGH */
79072805 3671 case SVt_PVMG:
79072805
LW
3672 case SVt_PVNV:
3673 case SVt_PVIV:
a0d0e21e
LW
3674 freescalar:
3675 (void)SvOOK_off(sv);
79072805
LW
3676 /* FALL THROUGH */
3677 case SVt_PV:
a0d0e21e 3678 case SVt_RV:
810b8aa5
GS
3679 if (SvROK(sv)) {
3680 if (SvWEAKREF(sv))
3681 sv_del_backref(sv);
3682 else
3683 SvREFCNT_dec(SvRV(sv));
3684 }
1edc1566 3685 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 3686 Safefree(SvPVX(sv));
79072805 3687 break;
a0d0e21e 3688/*
79072805 3689 case SVt_NV:
79072805 3690 case SVt_IV:
79072805
LW
3691 case SVt_NULL:
3692 break;
a0d0e21e 3693*/
79072805
LW
3694 }
3695
3696 switch (SvTYPE(sv)) {
3697 case SVt_NULL:
3698 break;
79072805
LW
3699 case SVt_IV:
3700 del_XIV(SvANY(sv));
3701 break;
3702 case SVt_NV:
3703 del_XNV(SvANY(sv));
3704 break;
ed6116ce
LW
3705 case SVt_RV:
3706 del_XRV(SvANY(sv));
3707 break;
79072805
LW
3708 case SVt_PV:
3709 del_XPV(SvANY(sv));
3710 break;
3711 case SVt_PVIV:
3712 del_XPVIV(SvANY(sv));
3713 break;
3714 case SVt_PVNV:
3715 del_XPVNV(SvANY(sv));
3716 break;
3717 case SVt_PVMG:
3718 del_XPVMG(SvANY(sv));
3719 break;
3720 case SVt_PVLV:
3721 del_XPVLV(SvANY(sv));
3722 break;
3723 case SVt_PVAV:
3724 del_XPVAV(SvANY(sv));
3725 break;
3726 case SVt_PVHV:
3727 del_XPVHV(SvANY(sv));
3728 break;
3729 case SVt_PVCV:
3730 del_XPVCV(SvANY(sv));
3731 break;
3732 case SVt_PVGV:
3733 del_XPVGV(SvANY(sv));
ec12f114
JPC
3734 /* code duplication for increased performance. */
3735 SvFLAGS(sv) &= SVf_BREAK;
3736 SvFLAGS(sv) |= SVTYPEMASK;
3737 /* decrease refcount of the stash that owns this GV, if any */
3738 if (stash)
3739 SvREFCNT_dec(stash);
3740 return; /* not break, SvFLAGS reset already happened */
79072805
LW
3741 case SVt_PVBM:
3742 del_XPVBM(SvANY(sv));
3743 break;
3744 case SVt_PVFM:
3745 del_XPVFM(SvANY(sv));
3746 break;
8990e307
LW
3747 case SVt_PVIO:
3748 del_XPVIO(SvANY(sv));
3749 break;
79072805 3750 }
a0d0e21e 3751 SvFLAGS(sv) &= SVf_BREAK;
8990e307 3752 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW
3753}
3754
3755SV *
864dbfa3 3756Perl_sv_newref(pTHX_ SV *sv)
79072805 3757{
463ee0b2 3758 if