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