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