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