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