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
fix old $^S description in perlvms.pod
[perl5.git] / sv.c
CommitLineData
a0d0e21e 1/* sv.c
79072805 2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
79072805
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
a0d0e21e
LW		 8 */
9
10/*
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
79072805
LW		 12 */
13
14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_SV_C
79072805 16#include "perl.h"
79072805 17
51371543 18#define FCALL *f
6fc92669 19#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
2c5424a7 20
51371543
GS		 21static void do_report_used(pTHXo_ SV *sv);
22static void do_clean_objs(pTHXo_ SV *sv);
23#ifndef DISABLE_DESTRUCTOR_KLUDGE
24static void do_clean_named_objs(pTHXo_ SV *sv);
25#endif
26static void do_clean_all(pTHXo_ SV *sv);
27
4561caa4
CS		 28/*
29 * "A time to plant, and a time to uproot what was planted..."
30 */
31
053fc874
GS		 32#define plant_SV(p) \
33 STMT_START { \
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
36 PL_sv_root = (p); \
37 --PL_sv_count; \
38 } STMT_END
a0d0e21e 39
fba3b22e 40/* sv_mutex must be held while calling uproot_SV() */
053fc874
GS		 41#define uproot_SV(p) \
42 STMT_START { \
43 (p) = PL_sv_root; \
44 PL_sv_root = (SV*)SvANY(p); \
45 ++PL_sv_count; \
46 } STMT_END
47
48#define new_SV(p) \
49 STMT_START { \
50 LOCK_SV_MUTEX; \
51 if (PL_sv_root) \
52 uproot_SV(p); \
53 else \
54 (p) = more_sv(); \
55 UNLOCK_SV_MUTEX; \
56 SvANY(p) = 0; \
57 SvREFCNT(p) = 1; \
58 SvFLAGS(p) = 0; \
59 } STMT_END
463ee0b2 60
a0d0e21e 61#ifdef DEBUGGING
4561caa4 62
053fc874
GS		 63#define del_SV(p) \
64 STMT_START { \
65 LOCK_SV_MUTEX; \
aea4f609 66 if (DEBUG_D_TEST) \
053fc874
GS		 67 del_sv(p); \
68 else \
69 plant_SV(p); \
70 UNLOCK_SV_MUTEX; \
71 } STMT_END
a0d0e21e 72
76e3520e 73STATIC void
cea2e8a9 74S_del_sv(pTHX_ SV *p)
463ee0b2 75{
aea4f609 76 if (DEBUG_D_TEST) {
4633a7c4 77 SV* sva;
a0d0e21e
LW		 78 SV* sv;
79 SV* svend;
80 int ok = 0;
3280af22 81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
4633a7c4
LW		 82 sv = sva + 1;
83 svend = &sva[SvREFCNT(sva)];
a0d0e21e
LW		 84 if (p >= sv && p < svend)
85 ok = 1;
86 }
87 if (!ok) {
0453d815
PM		 88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
1d7c1841
GS		 90 "Attempt to free non-arena SV: 0x%"UVxf,
91 PTR2UV(p));
a0d0e21e
LW		 92 return;
93 }
94 }
4561caa4 95 plant_SV(p);
463ee0b2 96}
a0d0e21e 97
4561caa4
CS		 98#else /* ! DEBUGGING */
99
100#define del_SV(p) plant_SV(p)
101
102#endif /* DEBUGGING */
463ee0b2 103
4633a7c4 104void
864dbfa3 105Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
463ee0b2 106{
4633a7c4 107 SV* sva = (SV*)ptr;
463ee0b2
LW		 108 register SV* sv;
109 register SV* svend;
14dd3ad8 110 Zero(ptr, size, char);
4633a7c4
LW		 111
112 /* The first SV in an arena isn't an SV. */
3280af22 113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
4633a7c4
LW		 114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
116
3280af22
NIS		 117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
4633a7c4
LW		 119
120 svend = &sva[SvREFCNT(sva) - 1];
121 sv = sva + 1;
463ee0b2 122 while (sv < svend) {
a0d0e21e 123 SvANY(sv) = (void *)(SV*)(sv + 1);
8990e307 124 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW		 125 sv++;
126 }
127 SvANY(sv) = 0;
4633a7c4
LW		 128 SvFLAGS(sv) = SVTYPEMASK;
129}
130
fba3b22e 131/* sv_mutex must be held while calling more_sv() */
76e3520e 132STATIC SV*
cea2e8a9 133S_more_sv(pTHX)
4633a7c4 134{
4561caa4
CS		 135 register SV* sv;
136
3280af22
NIS		 137 if (PL_nice_chunk) {
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
30ad99e7 140 PL_nice_chunk_size = 0;
c07a80fd 141 }
1edc1566 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);
61604483
HS		 2309 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2310 SvNOK_on(sv);
2311 }
2312 else if (SvIOKp(sv) &&
748a9306 2313 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 2314 {
65202027 2315 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
28e5dec8
JH		 2316#ifdef NV_PRESERVES_UV
2317 SvNOK_on(sv);
2318#else
2319 /* Only set the public NV OK flag if this NV preserves the IV */
2320 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2321 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2322 : (SvIVX(sv) == I_V(SvNVX(sv))))
2323 SvNOK_on(sv);
2324 else
2325 SvNOKp_on(sv);
2326#endif
93a17b20 2327 }
748a9306 2328 else if (SvPOKp(sv) && SvLEN(sv)) {
599cee73 2329 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 2330 not_a_number(sv);
097ee67d 2331 SvNVX(sv) = Atof(SvPVX(sv));
28e5dec8
JH		 2332#ifdef NV_PRESERVES_UV
2333 SvNOK_on(sv);
2334#else
2335 /* Only set the public NV OK flag if this NV preserves the value in
2336 the PV at least as well as an IV/UV would.
2337 Not sure how to do this 100% reliably. */
2338 /* if that shift count is out of range then Configure's test is
2339 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2340 UV_BITS */
2341 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2342 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2343 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2344 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2345 /* Definitely too large/small to fit in an integer, so no loss
2346 of precision going to integer in the future via NV */
2347 SvNOK_on(sv);
2348 } else {
2349 /* Is it something we can run through strtol etc (ie no
2350 trailing exponent part)? */
2351 int numtype = looks_like_number(sv);
2352 /* XXX probably should cache this if called above */
2353
2354 if (!(numtype &
2355 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2356 /* Can't use strtol etc to convert this string, so don't try */
2357 SvNOK_on(sv);
2358 } else
2359 sv_2inuv_non_preserve (sv, numtype);
2360 }
2361#endif /* NV_PRESERVES_UV */
93a17b20 2362 }
79072805 2363 else {
599cee73 2364 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2365 report_uninit();
25da4f38
IZ		 2366 if (SvTYPE(sv) < SVt_NV)
2367 /* Typically the caller expects that sv_any is not NULL now. */
28e5dec8
JH		 2368 /* XXX Ilya implies that this is a bug in callers that assume this
2369 and ideally should be fixed. */
25da4f38 2370 sv_upgrade(sv, SVt_NV);
a0d0e21e 2371 return 0.0;
79072805 2372 }
572bbb43 2373#if defined(USE_LONG_DOUBLE)
097ee67d 2374 DEBUG_c({
f93f4e46 2375 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2376 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2377 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 2378 RESTORE_NUMERIC_LOCAL();
2379 });
65202027 2380#else
572bbb43 2381 DEBUG_c({
f93f4e46 2382 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2383 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2384 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 2385 RESTORE_NUMERIC_LOCAL();
2386 });
572bbb43 2387#endif
463ee0b2 2388 return SvNVX(sv);
79072805
LW		 2389}
2390
76e3520e 2391STATIC IV
cea2e8a9 2392S_asIV(pTHX_ SV *sv)
36477c24 2393{
2394 I32 numtype = looks_like_number(sv);
65202027 2395 NV d;
36477c24 2396
25da4f38 2397 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 2398 return Atol(SvPVX(sv));
d008e5eb 2399 if (!numtype) {
d008e5eb
GS		 2400 if (ckWARN(WARN_NUMERIC))
2401 not_a_number(sv);
2402 }
097ee67d 2403 d = Atof(SvPVX(sv));
25da4f38 2404 return I_V(d);
36477c24 2405}
2406
76e3520e 2407STATIC UV
cea2e8a9 2408S_asUV(pTHX_ SV *sv)
36477c24 2409{
2410 I32 numtype = looks_like_number(sv);
2411
84902520 2412#ifdef HAS_STRTOUL
25da4f38 2413 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 2414 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 2415#endif
d008e5eb 2416 if (!numtype) {
d008e5eb
GS		 2417 if (ckWARN(WARN_NUMERIC))
2418 not_a_number(sv);
2419 }
097ee67d 2420 return U_V(Atof(SvPVX(sv)));
36477c24 2421}
2422
25da4f38
IZ		 2423/*
2424 * Returns a combination of (advisory only - can get false negatives)
28e5dec8
JH		 2425 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2426 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2427 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
25da4f38
IZ		 2428 * 0 if does not look like number.
2429 *
28e5dec8
JH		 2430 * (atol and strtol stop when they hit a decimal point. strtol will return
2431 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2432 * do this, and vendors have had 11 years to get it right.
2433 * However, will try to make it still work with only atol
d460ef45 2434 *
28e5dec8
JH		 2435 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2436 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2437 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2438 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2439 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2440 * IS_NUMBER_NOT_INT saw "." or "e"
2441 * IS_NUMBER_NEG
300aed98 2442 * IS_NUMBER_INFINITY
25da4f38
IZ		 2443 */
2444
954c1994
GS		 2445/*
2446=for apidoc looks_like_number
2447
2448Test if an the content of an SV looks like a number (or is a
28e5dec8
JH		 2449number). C<Inf> and C<Infinity> are treated as numbers (so will not
2450issue a non-numeric warning), even if your atof() doesn't grok them.
954c1994
GS		 2451
2452=cut
2453*/
2454
36477c24 2455I32
864dbfa3 2456Perl_looks_like_number(pTHX_ SV *sv)
36477c24 2457{
2458 register char *s;
2459 register char *send;
2460 register char *sbegin;
25da4f38
IZ		 2461 register char *nbegin;
2462 I32 numtype = 0;
300aed98 2463 I32 sawinf = 0;
36477c24 2464 STRLEN len;
9c7192ba 2465#ifdef USE_LOCALE_NUMERIC
eff180cd 2466 bool specialradix = FALSE;
9c7192ba 2467#endif
36477c24 2468
2469 if (SvPOK(sv)) {
1c846c1f 2470 sbegin = SvPVX(sv);
36477c24 2471 len = SvCUR(sv);
2472 }
2473 else if (SvPOKp(sv))
2474 sbegin = SvPV(sv, len);
2475 else
2476 return 1;
2477 send = sbegin + len;
2478
2479 s = sbegin;
2480 while (isSPACE(*s))
2481 s++;
25da4f38
IZ		 2482 if (*s == '-') {
2483 s++;
2484 numtype = IS_NUMBER_NEG;
2485 }
2486 else if (*s == '+')
36477c24 2487 s++;
ff0cee69 2488
25da4f38
IZ		 2489 nbegin = s;
2490 /*
d460ef45 2491 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
28e5dec8
JH		 2492 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2493 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2494 * will need (int)atof().
25da4f38
IZ		 2495 */
2496
300aed98 2497 /* next must be digit or the radix separator or beginning of infinity */
ff0cee69 2498 if (isDIGIT(*s)) {
2499 do {
2500 s++;
2501 } while (isDIGIT(*s));
25da4f38 2502
28e5dec8
JH		 2503 /* Aaargh. long long really is irritating.
2504 In the gospel according to ANSI 1989, it is an axiom that "long"
2505 is the longest integer type, and that if you don't know how long
2506 something is you can cast it to long, and nothing will be lost
2507 (except possibly speed of execution if long is slower than the
2508 type is was).
2509 Now, one can't be sure if the old rules apply, or long long
2510 (or some other newfangled thing) is actually longer than the
2511 (formerly) longest thing.
2512 */
2513 /* This lot will work for 64 bit *as long as* either
2514 either long is 64 bit
2515 or we can find both strtol/strtoq and strtoul/strtouq
2516 If not, we really should refuse to let the user use 64 bit IVs
2517 By "64 bit" I really mean IVs that don't get preserved by NVs
2518 It also should work for 128 bit IVs. Can any lend me a machine to
2519 test this?
2520 */
2521 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2522 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2523 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2524 ? sizeof(long) : sizeof (IV))*8-1))
f7bbb42a 2525 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
28e5dec8
JH		 2526 else
2527 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2528 digit less (IV_MAX= 9223372036854775807,
2529 UV_MAX= 18446744073709551615) so be cautious */
2530 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
25da4f38 2531
b1d91914 2532 if (
1c846c1f 2533#ifdef USE_LOCALE_NUMERIC
b1d91914 2534 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
097ee67d 2535#endif
b1d91914 2536 *s == '.') {
9c7192ba 2537#ifdef USE_LOCALE_NUMERIC
eff180cd 2538 if (specialradix)
a453c169 2539 s += SvCUR(PL_numeric_radix_sv);
eff180cd 2540 else
9c7192ba 2541#endif
eff180cd 2542 s++;
28e5dec8 2543 numtype |= IS_NUMBER_NOT_INT;
097ee67d 2544 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69 2545 s++;
2546 }
36477c24 2547 }
b1d91914 2548 else if (
1c846c1f 2549#ifdef USE_LOCALE_NUMERIC
b1d91914 2550 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
097ee67d 2551#endif
b1d91914 2552 *s == '.'
097ee67d 2553 ) {
9c7192ba 2554#ifdef USE_LOCALE_NUMERIC
eff180cd 2555 if (specialradix)
a453c169 2556 s += SvCUR(PL_numeric_radix_sv);
eff180cd 2557 else
9c7192ba 2558#endif
eff180cd 2559 s++;
28e5dec8 2560 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
097ee67d 2561 /* no digits before the radix means we need digits after it */
ff0cee69 2562 if (isDIGIT(*s)) {
2563 do {
2564 s++;
2565 } while (isDIGIT(*s));
2566 }
2567 else
2568 return 0;
2569 }
300aed98
JH		 2570 else if (*s == 'I' || *s == 'i') {
2571 s++; if (*s != 'N' && *s != 'n') return 0;
2572 s++; if (*s != 'F' && *s != 'f') return 0;
2573 s++; if (*s == 'I' || *s == 'i') {
2574 s++; if (*s != 'N' && *s != 'n') return 0;
2575 s++; if (*s != 'I' && *s != 'i') return 0;
2576 s++; if (*s != 'T' && *s != 't') return 0;
2577 s++; if (*s != 'Y' && *s != 'y') return 0;
99938567 2578 s++;
300aed98
JH		 2579 }
2580 sawinf = 1;
2581 }
ff0cee69 2582 else
2583 return 0;
2584
300aed98 2585 if (sawinf)
28e5dec8
JH		 2586 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2587 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
300aed98
JH		 2588 else {
2589 /* we can have an optional exponent part */
2590 if (*s == 'e' || *s == 'E') {
28e5dec8
JH		 2591 numtype &= IS_NUMBER_NEG;
2592 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
36477c24 2593 s++;
300aed98
JH		 2594 if (*s == '+' || *s == '-')
2595 s++;
2596 if (isDIGIT(*s)) {
2597 do {
2598 s++;
2599 } while (isDIGIT(*s));
2600 }
2601 else
2602 return 0;
2603 }
36477c24 2604 }
2605 while (isSPACE(*s))
2606 s++;
80f3f388 2607 if (s >= send)
36477c24 2608 return numtype;
2609 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 2610 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24 2611 return 0;
2612}
2613
79072805 2614char *
864dbfa3 2615Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD		 2616{
2617 STRLEN n_a;
2618 return sv_2pv(sv, &n_a);
2619}
2620
25da4f38 2621/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 2622static char *
25da4f38
IZ		 2623uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2624{
25da4f38
IZ		 2625 char *ptr = buf + TYPE_CHARS(UV);
2626 char *ebuf = ptr;
2627 int sign;
25da4f38
IZ		 2628
2629 if (is_uv)
2630 sign = 0;
2631 else if (iv >= 0) {
2632 uv = iv;
2633 sign = 0;
2634 } else {
2635 uv = -iv;
2636 sign = 1;
2637 }
2638 do {
2639 *--ptr = '0' + (uv % 10);
2640 } while (uv /= 10);
2641 if (sign)
2642 *--ptr = '-';
2643 *peob = ebuf;
2644 return ptr;
2645}
2646
1fa8b10d 2647char *
864dbfa3 2648Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805 2649{
36f65ada 2650 return sv_2pv_flags(sv, lp, SV_GMAGIC);
8d6d96c1
HS		 2651}
2652
2653char *
2654Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2655{
79072805
LW		 2656 register char *s;
2657 int olderrno;
46fc3d4c 2658 SV *tsv;
25da4f38
IZ		 2659 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2660 char *tmpbuf = tbuf;
79072805 2661
463ee0b2
LW		 2662 if (!sv) {
2663 *lp = 0;
2664 return "";
2665 }
8990e307 2666 if (SvGMAGICAL(sv)) {
8d6d96c1
HS		 2667 if (flags & SV_GMAGIC)
2668 mg_get(sv);
463ee0b2
LW		 2669 if (SvPOKp(sv)) {
2670 *lp = SvCUR(sv);
2671 return SvPVX(sv);
2672 }
cf2093f6 2673 if (SvIOKp(sv)) {
1c846c1f 2674 if (SvIsUV(sv))
57def98f 2675 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2676 else
57def98f 2677 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2678 tsv = Nullsv;
a0d0e21e 2679 goto tokensave;
463ee0b2
LW		 2680 }
2681 if (SvNOKp(sv)) {
2d4389e4 2682 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2683 tsv = Nullsv;
a0d0e21e 2684 goto tokensave;
463ee0b2 2685 }
16d20bd9 2686 if (!SvROK(sv)) {
d008e5eb 2687 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2688 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2689 report_uninit();
c6ee37c5 2690 }
16d20bd9
AD		 2691 *lp = 0;
2692 return "";
2693 }
463ee0b2 2694 }
ed6116ce
LW		 2695 if (SvTHINKFIRST(sv)) {
2696 if (SvROK(sv)) {
a0d0e21e 2697 SV* tmpstr;
1554e226 2698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
1dc13c17 2699 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2700 return SvPV(tmpstr,*lp);
ed6116ce
LW		 2701 sv = (SV*)SvRV(sv);
2702 if (!sv)
2703 s = "NULLREF";
2704 else {
f9277f47
IZ		 2705 MAGIC *mg;
2706
ed6116ce 2707 switch (SvTYPE(sv)) {
f9277f47
IZ		 2708 case SVt_PVMG:
2709 if ( ((SvFLAGS(sv) &
1c846c1f 2710 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2711 == (SVs_OBJECT|SVs_RMG))
57668c4d 2712 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
14befaf4 2713 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2cd61cdb 2714 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2715
2cd61cdb 2716 if (!mg->mg_ptr) {
8782bef2
GB		 2717 char *fptr = "msix";
2718 char reflags[6];
2719 char ch;
2720 int left = 0;
2721 int right = 4;
2722 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2723
155aba94 2724 while((ch = *fptr++)) {
8782bef2
GB		 2725 if(reganch & 1) {
2726 reflags[left++] = ch;
2727 }
2728 else {
2729 reflags[right--] = ch;
2730 }
2731 reganch >>= 1;
2732 }
2733 if(left != 4) {
2734 reflags[left] = '-';
2735 left = 5;
2736 }
2737
2738 mg->mg_len = re->prelen + 4 + left;
2739 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2740 Copy("(?", mg->mg_ptr, 2, char);
2741 Copy(reflags, mg->mg_ptr+2, left, char);
2742 Copy(":", mg->mg_ptr+left+2, 1, char);
2743 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ		 2744 mg->mg_ptr[mg->mg_len - 1] = ')';
2745 mg->mg_ptr[mg->mg_len] = 0;
2746 }
3280af22 2747 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ		 2748 *lp = mg->mg_len;
2749 return mg->mg_ptr;
f9277f47
IZ		 2750 }
2751 /* Fall through */
ed6116ce
LW		 2752 case SVt_NULL:
2753 case SVt_IV:
2754 case SVt_NV:
2755 case SVt_RV:
2756 case SVt_PV:
2757 case SVt_PVIV:
2758 case SVt_PVNV:
81689caa
HS		 2759 case SVt_PVBM: if (SvROK(sv))
2760 s = "REF";
2761 else
2762 s = "SCALAR"; break;
ed6116ce
LW		 2763 case SVt_PVLV: s = "LVALUE"; break;
2764 case SVt_PVAV: s = "ARRAY"; break;
2765 case SVt_PVHV: s = "HASH"; break;
2766 case SVt_PVCV: s = "CODE"; break;
2767 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2768 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2769 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW		 2770 default: s = "UNKNOWN"; break;
2771 }
46fc3d4c 2772 tsv = NEWSV(0,0);
ed6116ce 2773 if (SvOBJECT(sv))
cea2e8a9 2774 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2775 else
46fc3d4c 2776 sv_setpv(tsv, s);
57def98f 2777 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2778 goto tokensaveref;
463ee0b2 2779 }
ed6116ce
LW		 2780 *lp = strlen(s);
2781 return s;
79072805 2782 }
0336b60e 2783 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2784 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2785 report_uninit();
ed6116ce
LW		 2786 *lp = 0;
2787 return "";
79072805 2788 }
79072805 2789 }
28e5dec8
JH		 2790 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2791 /* I'm assuming that if both IV and NV are equally valid then
2792 converting the IV is going to be more efficient */
2793 U32 isIOK = SvIOK(sv);
2794 U32 isUIOK = SvIsUV(sv);
2795 char buf[TYPE_CHARS(UV)];
2796 char *ebuf, *ptr;
2797
2798 if (SvTYPE(sv) < SVt_PVIV)
2799 sv_upgrade(sv, SVt_PVIV);
2800 if (isUIOK)
2801 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2802 else
2803 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2804 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2805 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2806 SvCUR_set(sv, ebuf - ptr);
2807 s = SvEND(sv);
2808 *s = '\0';
2809 if (isIOK)
2810 SvIOK_on(sv);
2811 else
2812 SvIOKp_on(sv);
2813 if (isUIOK)
2814 SvIsUV_on(sv);
2815 }
2816 else if (SvNOKp(sv)) {
79072805
LW		 2817 if (SvTYPE(sv) < SVt_PVNV)
2818 sv_upgrade(sv, SVt_PVNV);
1c846c1f 2819 /* The +20 is pure guesswork. Configure test needed. --jhi */
59155cc0 2820 SvGROW(sv, NV_DIG + 20);
463ee0b2 2821 s = SvPVX(sv);
79072805 2822 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2823#ifdef apollo
463ee0b2 2824 if (SvNVX(sv) == 0.0)
79072805
LW		 2825 (void)strcpy(s,"0");
2826 else
2827#endif /*apollo*/
bbce6d69 2828 {
2d4389e4 2829 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2830 }
79072805 2831 errno = olderrno;
a0d0e21e
LW		 2832#ifdef FIXNEGATIVEZERO
2833 if (*s == '-' && s[1] == '0' && !s[2])
2834 strcpy(s,"0");
2835#endif
79072805
LW		 2836 while (*s) s++;
2837#ifdef hcx
2838 if (s[-1] == '.')
46fc3d4c 2839 *--s = '\0';
79072805
LW		 2840#endif
2841 }
79072805 2842 else {
0336b60e
IZ		 2843 if (ckWARN(WARN_UNINITIALIZED)
2844 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2845 report_uninit();
a0d0e21e 2846 *lp = 0;
25da4f38
IZ		 2847 if (SvTYPE(sv) < SVt_PV)
2848 /* Typically the caller expects that sv_any is not NULL now. */
2849 sv_upgrade(sv, SVt_PV);
a0d0e21e 2850 return "";
79072805 2851 }
463ee0b2
LW		 2852 *lp = s - SvPVX(sv);
2853 SvCUR_set(sv, *lp);
79072805 2854 SvPOK_on(sv);
1d7c1841
GS		 2855 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2856 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2857 return SvPVX(sv);
a0d0e21e
LW		 2858
2859 tokensave:
2860 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2861 /* Sneaky stuff here */
2862
2863 tokensaveref:
46fc3d4c 2864 if (!tsv)
96827780 2865 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 2866 sv_2mortal(tsv);
2867 *lp = SvCUR(tsv);
2868 return SvPVX(tsv);
a0d0e21e
LW		 2869 }
2870 else {
2871 STRLEN len;
46fc3d4c 2872 char *t;
2873
2874 if (tsv) {
2875 sv_2mortal(tsv);
2876 t = SvPVX(tsv);
2877 len = SvCUR(tsv);
2878 }
2879 else {
96827780
MB		 2880 t = tmpbuf;
2881 len = strlen(tmpbuf);
46fc3d4c 2882 }
a0d0e21e 2883#ifdef FIXNEGATIVEZERO
46fc3d4c 2884 if (len == 2 && t[0] == '-' && t[1] == '0') {
2885 t = "0";
2886 len = 1;
2887 }
a0d0e21e
LW		 2888#endif
2889 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2890 *lp = len;
a0d0e21e
LW		 2891 s = SvGROW(sv, len + 1);
2892 SvCUR_set(sv, len);
46fc3d4c 2893 (void)strcpy(s, t);
6bf554b4 2894 SvPOKp_on(sv);
a0d0e21e
LW		 2895 return s;
2896 }
463ee0b2
LW		 2897}
2898
7340a771
GS		 2899char *
2900Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2901{
560a288e
GS		 2902 STRLEN n_a;
2903 return sv_2pvbyte(sv, &n_a);
7340a771
GS		 2904}
2905
2906char *
2907Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2908{
0875d2fe
NIS		 2909 sv_utf8_downgrade(sv,0);
2910 return SvPV(sv,*lp);
7340a771
GS		 2911}
2912
2913char *
2914Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2915{
560a288e
GS		 2916 STRLEN n_a;
2917 return sv_2pvutf8(sv, &n_a);
7340a771
GS		 2918}
2919
2920char *
2921Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2922{
560a288e 2923 sv_utf8_upgrade(sv);
7d59b7e4 2924 return SvPV(sv,*lp);
7340a771 2925}
1c846c1f 2926
463ee0b2
LW		 2927/* This function is only called on magical items */
2928bool
864dbfa3 2929Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2930{
8990e307 2931 if (SvGMAGICAL(sv))
463ee0b2
LW		 2932 mg_get(sv);
2933
a0d0e21e
LW		 2934 if (!SvOK(sv))
2935 return 0;
2936 if (SvROK(sv)) {
a0d0e21e 2937 SV* tmpsv;
1554e226 2938 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
1dc13c17 2939 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
9e7bc3e8 2940 return SvTRUE(tmpsv);
a0d0e21e
LW		 2941 return SvRV(sv) != 0;
2942 }
463ee0b2 2943 if (SvPOKp(sv)) {
11343788
MB		 2944 register XPV* Xpvtmp;
2945 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2946 (*Xpvtmp->xpv_pv > '0' ||
2947 Xpvtmp->xpv_cur > 1 ||
2948 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW		 2949 return 1;
2950 else
2951 return 0;
2952 }
2953 else {
2954 if (SvIOKp(sv))
2955 return SvIVX(sv) != 0;
2956 else {
2957 if (SvNOKp(sv))
2958 return SvNVX(sv) != 0.0;
2959 else
2960 return FALSE;
2961 }
2962 }
79072805
LW		 2963}
2964
c461cf8f
JH		 2965/*
2966=for apidoc sv_utf8_upgrade
2967
2968Convert the PV of an SV to its UTF8-encoded form.
4411f3b6
NIS		 2969Forces the SV to string form it it is not already.
2970Always sets the SvUTF8 flag to avoid future validity checks even
2971if all the bytes have hibit clear.
c461cf8f
JH		 2972
2973=cut
2974*/
2975
4411f3b6 2976STRLEN
560a288e
GS		 2977Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2978{
36f65ada 2979 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
8d6d96c1
HS		 2980}
2981
2982/*
2983=for apidoc sv_utf8_upgrade_flags
2984
2985Convert the PV of an SV to its UTF8-encoded form.
2986Forces the SV to string form it it is not already.
2987Always sets the SvUTF8 flag to avoid future validity checks even
2988if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2989will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2990C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2991
2992=cut
2993*/
2994
2995STRLEN
2996Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2997{
db42d148 2998 U8 *s, *t, *e;
511c2ff0 2999 int hibit = 0;
560a288e 3000
4411f3b6
NIS		 3001 if (!sv)
3002 return 0;
3003
e0e62c2a
NIS		 3004 if (!SvPOK(sv)) {
3005 STRLEN len = 0;
8d6d96c1 3006 (void) sv_2pv_flags(sv,&len, flags);
e0e62c2a
NIS		 3007 if (!SvPOK(sv))
3008 return len;
3009 }
4411f3b6
NIS		 3010
3011 if (SvUTF8(sv))
3012 return SvCUR(sv);
560a288e 3013
db42d148
NIS		 3014 if (SvREADONLY(sv) && SvFAKE(sv)) {
3015 sv_force_normal(sv);
3016 }
3017
40826f67
JH		 3018 /* This function could be much more efficient if we had a FLAG in SVs
3019 * to signal if there are any hibit chars in the PV.
511c2ff0 3020 * Given that there isn't make loop fast as possible
560a288e 3021 */
db42d148
NIS		 3022 s = (U8 *) SvPVX(sv);
3023 e = (U8 *) SvEND(sv);
511c2ff0
NIS		 3024 t = s;
3025 while (t < e) {
c4d5f83a
NIS		 3026 U8 ch = *t++;
3027 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
8a818333 3028 break;
8a818333 3029 }
40826f67 3030 if (hibit) {
8a818333 3031 STRLEN len;
652088fc 3032
8a818333 3033 len = SvCUR(sv) + 1; /* Plus the \0 */
00df9076 3034 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
841d7a39 3035 SvCUR(sv) = len - 1;
511c2ff0
NIS		 3036 if (SvLEN(sv) != 0)
3037 Safefree(s); /* No longer using what was there before. */
841d7a39 3038 SvLEN(sv) = len; /* No longer know the real size. */
560a288e 3039 }
4411f3b6
NIS		 3040 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3041 SvUTF8_on(sv);
3042 return SvCUR(sv);
560a288e
GS		 3043}
3044
c461cf8f
JH		 3045/*
3046=for apidoc sv_utf8_downgrade
3047
3048Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3049This may not be possible if the PV contains non-byte encoding characters;
3050if this is the case, either returns false or, if C<fail_ok> is not
3051true, croaks.
3052
3053=cut
3054*/
3055
560a288e
GS		 3056bool
3057Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3058{
3059 if (SvPOK(sv) && SvUTF8(sv)) {
fa301091 3060 if (SvCUR(sv)) {
03cfe0ae 3061 U8 *s;
652088fc 3062 STRLEN len;
fa301091 3063
652088fc
JH		 3064 if (SvREADONLY(sv) && SvFAKE(sv))
3065 sv_force_normal(sv);
03cfe0ae
NIS		 3066 s = (U8 *) SvPV(sv, len);
3067 if (!utf8_to_bytes(s, &len)) {
fa301091
JH		 3068 if (fail_ok)
3069 return FALSE;
03cfe0ae 3070#ifdef USE_BYTES_DOWNGRADES
0064a8a9 3071 else if (IN_BYTES) {
03cfe0ae
NIS		 3072 U8 *d = s;
3073 U8 *e = (U8 *) SvEND(sv);
3074 int first = 1;
3075 while (s < e) {
3076 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3077 if (first && ch > 255) {
3078 if (PL_op)
3079 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3080 PL_op_desc[PL_op->op_type]);
3081 else
3082 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3083 first = 0;
3084 }
3085 *d++ = ch;
3086 s += len;
3087 }
3088 *d = '\0';
3089 len = (d - (U8 *) SvPVX(sv));
3090 }
3091#endif
fa301091
JH		 3092 else {
3093 if (PL_op)
3094 Perl_croak(aTHX_ "Wide character in %s",
3095 PL_op_desc[PL_op->op_type]);
3096 else
3097 Perl_croak(aTHX_ "Wide character");
3098 }
4b3603a4 3099 }
fa301091 3100 SvCUR(sv) = len;
67e989fb 3101 }
560a288e 3102 }
ffebcc3e 3103 SvUTF8_off(sv);
560a288e
GS		 3104 return TRUE;
3105}
3106
c461cf8f
JH		 3107/*
3108=for apidoc sv_utf8_encode
3109
3110Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
4411f3b6
NIS		 3111flag so that it looks like octets again. Used as a building block
3112for encode_utf8 in Encode.xs
c461cf8f
JH		 3113
3114=cut
3115*/
3116
560a288e
GS		 3117void
3118Perl_sv_utf8_encode(pTHX_ register SV *sv)
3119{
4411f3b6 3120 (void) sv_utf8_upgrade(sv);
560a288e
GS		 3121 SvUTF8_off(sv);
3122}
3123
4411f3b6
NIS		 3124/*
3125=for apidoc sv_utf8_decode
3126
3127Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3128turn of SvUTF8 if needed so that we see characters. Used as a building block
3129for decode_utf8 in Encode.xs
3130
3131=cut
3132*/
3133
3134
3135
560a288e
GS		 3136bool
3137Perl_sv_utf8_decode(pTHX_ register SV *sv)
3138{
3139 if (SvPOK(sv)) {
63cd0674
NIS		 3140 U8 *c;
3141 U8 *e;
9cbac4c7 3142
4411f3b6 3143 /* The octets may have got themselves encoded - get them back as bytes */
560a288e
GS		 3144 if (!sv_utf8_downgrade(sv, TRUE))
3145 return FALSE;
3146
3147 /* it is actually just a matter of turning the utf8 flag on, but
3148 * we want to make sure everything inside is valid utf8 first.
3149 */
63cd0674
NIS		 3150 c = (U8 *) SvPVX(sv);
3151 if (!is_utf8_string(c, SvCUR(sv)+1))
67e989fb 3152 return FALSE;
63cd0674 3153 e = (U8 *) SvEND(sv);
511c2ff0 3154 while (c < e) {
c4d5f83a
NIS		 3155 U8 ch = *c++;
3156 if (!UTF8_IS_INVARIANT(ch)) {
67e989fb
JH		 3157 SvUTF8_on(sv);
3158 break;
3159 }
560a288e 3160 }
560a288e
GS		 3161 }
3162 return TRUE;
3163}
3164
3165
79072805 3166/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 3167 * to be reused, since it may destroy the source string if it is marked
79072805
LW		 3168 * as temporary.
3169 */
3170
954c1994
GS		 3171/*
3172=for apidoc sv_setsv
3173
3174Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3175The source SV may be destroyed if it is mortal. Does not handle 'set'
3176magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3177C<sv_setsv_mg>.
3178
3179=cut
3180*/
3181
8d6d96c1
HS		 3182/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3183 for binary compatibility only
3184*/
79072805 3185void
864dbfa3 3186Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 3187{
8d6d96c1
HS		 3188 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3189}
3190
3191/*
3192=for apidoc sv_setsv_flags
3193
3194Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3195The source SV may be destroyed if it is mortal. Does not handle 'set'
3196magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3197appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3198in terms of this function.
3199
3200=cut
3201*/
3202
3203void
3204Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3205{
8990e307
LW		 3206 register U32 sflags;
3207 register int dtype;
3208 register int stype;
463ee0b2 3209
79072805
LW		 3210 if (sstr == dstr)
3211 return;
2213622d 3212 SV_CHECK_THINKFIRST(dstr);
79072805 3213 if (!sstr)
3280af22 3214 sstr = &PL_sv_undef;
8990e307
LW		 3215 stype = SvTYPE(sstr);
3216 dtype = SvTYPE(dstr);
79072805 3217
a0d0e21e 3218 SvAMAGIC_off(dstr);
9e7bc3e8 3219
463ee0b2 3220 /* There's a lot of redundancy below but we're going for speed here */
79072805 3221
8990e307 3222 switch (stype) {
79072805 3223 case SVt_NULL:
aece5585 3224 undef_sstr:
20408e3c
GS		 3225 if (dtype != SVt_PVGV) {
3226 (void)SvOK_off(dstr);
3227 return;
3228 }
3229 break;
463ee0b2 3230 case SVt_IV:
aece5585
GA		 3231 if (SvIOK(sstr)) {
3232 switch (dtype) {
3233 case SVt_NULL:
8990e307 3234 sv_upgrade(dstr, SVt_IV);
aece5585
GA		 3235 break;
3236 case SVt_NV:
8990e307 3237 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 3238 break;
3239 case SVt_RV:
3240 case SVt_PV:
a0d0e21e 3241 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA		 3242 break;
3243 }
3244 (void)SvIOK_only(dstr);
3245 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 3246 if (SvIsUV(sstr))
3247 SvIsUV_on(dstr);
27c9684d
AP		 3248 if (SvTAINTED(sstr))
3249 SvTAINT(dstr);
aece5585 3250 return;
8990e307 3251 }
aece5585
GA		 3252 goto undef_sstr;
3253
463ee0b2 3254 case SVt_NV:
aece5585
GA		 3255 if (SvNOK(sstr)) {
3256 switch (dtype) {
3257 case SVt_NULL:
3258 case SVt_IV:
8990e307 3259 sv_upgrade(dstr, SVt_NV);
aece5585
GA		 3260 break;
3261 case SVt_RV:
3262 case SVt_PV:
3263 case SVt_PVIV:
a0d0e21e 3264 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 3265 break;
3266 }
3267 SvNVX(dstr) = SvNVX(sstr);
3268 (void)SvNOK_only(dstr);
27c9684d
AP		 3269 if (SvTAINTED(sstr))
3270 SvTAINT(dstr);
aece5585 3271 return;
8990e307 3272 }
aece5585
GA		 3273 goto undef_sstr;
3274
ed6116ce 3275 case SVt_RV:
8990e307 3276 if (dtype < SVt_RV)
ed6116ce 3277 sv_upgrade(dstr, SVt_RV);
c07a80fd 3278 else if (dtype == SVt_PVGV &&
3279 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3280 sstr = SvRV(sstr);
a5f75d66 3281 if (sstr == dstr) {
1d7c1841
GS		 3282 if (GvIMPORTED(dstr) != GVf_IMPORTED
3283 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3284 {
a5f75d66 3285 GvIMPORTED_on(dstr);
1d7c1841 3286 }
a5f75d66
AD		 3287 GvMULTI_on(dstr);
3288 return;
3289 }
c07a80fd 3290 goto glob_assign;
3291 }
ed6116ce 3292 break;
463ee0b2 3293 case SVt_PV:
fc36a67e 3294 case SVt_PVFM:
8990e307 3295 if (dtype < SVt_PV)
463ee0b2 3296 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW		 3297 break;
3298 case SVt_PVIV:
8990e307 3299 if (dtype < SVt_PVIV)
463ee0b2 3300 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW		 3301 break;
3302 case SVt_PVNV:
8990e307 3303 if (dtype < SVt_PVNV)
463ee0b2 3304 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 3305 break;
4633a7c4
LW		 3306 case SVt_PVAV:
3307 case SVt_PVHV:
3308 case SVt_PVCV:
4633a7c4 3309 case SVt_PVIO:
533c011a 3310 if (PL_op)
cea2e8a9 3311 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 3312 PL_op_name[PL_op->op_type]);
4633a7c4 3313 else
cea2e8a9 3314 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW		 3315 break;
3316
79072805 3317 case SVt_PVGV:
8990e307 3318 if (dtype <= SVt_PVGV) {
c07a80fd 3319 glob_assign:
a5f75d66 3320 if (dtype != SVt_PVGV) {
a0d0e21e
LW		 3321 char *name = GvNAME(sstr);
3322 STRLEN len = GvNAMELEN(sstr);
463ee0b2 3323 sv_upgrade(dstr, SVt_PVGV);
14befaf4 3324 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
85aff577 3325 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW		 3326 GvNAME(dstr) = savepvn(name, len);
3327 GvNAMELEN(dstr) = len;
3328 SvFAKE_on(dstr); /* can coerce to non-glob */
3329 }
7bac28a0 3330 /* ahem, death to those who redefine active sort subs */
3280af22
NIS		 3331 else if (PL_curstackinfo->si_type == PERLSI_SORT
3332 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 3333 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 3334 GvNAME(dstr));
5bd07a3d
DM		 3335
3336#ifdef GV_SHARED_CHECK
3337 if (GvSHARED((GV*)dstr)) {
3338 Perl_croak(aTHX_ PL_no_modify);
3339 }
3340#endif
3341
a0d0e21e 3342 (void)SvOK_off(dstr);
a5f75d66 3343 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 3344 gp_free((GV*)dstr);
79072805 3345 GvGP(dstr) = gp_ref(GvGP(sstr));
27c9684d
AP		 3346 if (SvTAINTED(sstr))
3347 SvTAINT(dstr);
1d7c1841
GS		 3348 if (GvIMPORTED(dstr) != GVf_IMPORTED
3349 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3350 {
a5f75d66 3351 GvIMPORTED_on(dstr);
1d7c1841 3352 }
a5f75d66 3353 GvMULTI_on(dstr);
79072805
LW		 3354 return;
3355 }
3356 /* FALL THROUGH */
3357
3358 default:
8d6d96c1 3359 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
973f89ab
CS		 3360 mg_get(sstr);
3361 if (SvTYPE(sstr) != stype) {
3362 stype = SvTYPE(sstr);
3363 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3364 goto glob_assign;
3365 }
3366 }
ded42b9f 3367 if (stype == SVt_PVLV)
6fc92669 3368 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 3369 else
6fc92669 3370 (void)SvUPGRADE(dstr, stype);
79072805
LW		 3371 }
3372
8990e307
LW		 3373 sflags = SvFLAGS(sstr);
3374
3375 if (sflags & SVf_ROK) {
3376 if (dtype >= SVt_PV) {
3377 if (dtype == SVt_PVGV) {
3378 SV *sref = SvREFCNT_inc(SvRV(sstr));
3379 SV *dref = 0;
a5f75d66 3380 int intro = GvINTRO(dstr);
a0d0e21e 3381
5bd07a3d
DM		 3382#ifdef GV_SHARED_CHECK
3383 if (GvSHARED((GV*)dstr)) {
3384 Perl_croak(aTHX_ PL_no_modify);
3385 }
3386#endif
3387
a0d0e21e
LW		 3388 if (intro) {
3389 GP *gp;
1d7c1841 3390 gp_free((GV*)dstr);
a5f75d66 3391 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 3392 Newz(602,gp, 1, GP);
44a8e56a 3393 GvGP(dstr) = gp_ref(gp);
a0d0e21e 3394 GvSV(dstr) = NEWSV(72,0);
1d7c1841 3395 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 3396 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 3397 }
a5f75d66 3398 GvMULTI_on(dstr);
8990e307
LW		 3399 switch (SvTYPE(sref)) {
3400 case SVt_PVAV:
a0d0e21e
LW		 3401 if (intro)
3402 SAVESPTR(GvAV(dstr));
3403 else
3404 dref = (SV*)GvAV(dstr);
8990e307 3405 GvAV(dstr) = (AV*)sref;
39bac7f7 3406 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS		 3407 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3408 {
a5f75d66 3409 GvIMPORTED_AV_on(dstr);
1d7c1841 3410 }
8990e307
LW		 3411 break;
3412 case SVt_PVHV:
a0d0e21e
LW		 3413 if (intro)
3414 SAVESPTR(GvHV(dstr));
3415 else
3416 dref = (SV*)GvHV(dstr);
8990e307 3417 GvHV(dstr) = (HV*)sref;
39bac7f7 3418 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS		 3419 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3420 {
a5f75d66 3421 GvIMPORTED_HV_on(dstr);
1d7c1841 3422 }
8990e307
LW		 3423 break;
3424 case SVt_PVCV:
8ebc5c01 3425 if (intro) {
3426 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3427 SvREFCNT_dec(GvCV(dstr));
3428 GvCV(dstr) = Nullcv;
68dc0745 3429 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 3430 PL_sub_generation++;
8ebc5c01 3431 }
a0d0e21e 3432 SAVESPTR(GvCV(dstr));
8ebc5c01 3433 }
68dc0745 3434 else
3435 dref = (SV*)GvCV(dstr);
3436 if (GvCV(dstr) != (CV*)sref) {
748a9306 3437 CV* cv = GvCV(dstr);
4633a7c4 3438 if (cv) {
68dc0745 3439 if (!GvCVGEN((GV*)dstr) &&
3440 (CvROOT(cv) || CvXSUB(cv)))
3441 {
7bac28a0 3442 /* ahem, death to those who redefine
3443 * active sort subs */
3280af22
NIS		 3444 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3445 PL_sortcop == CvSTART(cv))
1c846c1f 3446 Perl_croak(aTHX_
7bac28a0 3447 "Can't redefine active sort subroutine %s",
3448 GvENAME((GV*)dstr));
beab0874
JT		 3449 /* Redefining a sub - warning is mandatory if
3450 it was a const and its value changed. */
3451 if (ckWARN(WARN_REDEFINE)
3452 || (CvCONST(cv)
3453 && (!CvCONST((CV*)sref)
3454 || sv_cmp(cv_const_sv(cv),
3455 cv_const_sv((CV*)sref)))))
3456 {
3457 Perl_warner(aTHX_ WARN_REDEFINE,
3458 CvCONST(cv)
3459 ? "Constant subroutine %s redefined"
47deb5e7 3460 : "Subroutine %s redefined",
beab0874
JT		 3461 GvENAME((GV*)dstr));
3462 }
9607fc9c 3463 }
3fe9a6f1 3464 cv_ckproto(cv, (GV*)dstr,
3465 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 3466 }
a5f75d66 3467 GvCV(dstr) = (CV*)sref;
7a4c00b4 3468 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 3469 GvASSUMECV_on(dstr);
3280af22 3470 PL_sub_generation++;
a5f75d66 3471 }
39bac7f7 3472 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS		 3473 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3474 {
a5f75d66 3475 GvIMPORTED_CV_on(dstr);
1d7c1841 3476 }
8990e307 3477 break;
91bba347
LW		 3478 case SVt_PVIO:
3479 if (intro)
3480 SAVESPTR(GvIOp(dstr));
3481 else
3482 dref = (SV*)GvIOp(dstr);
3483 GvIOp(dstr) = (IO*)sref;
3484 break;
f4d13ee9
JH		 3485 case SVt_PVFM:
3486 if (intro)
3487 SAVESPTR(GvFORM(dstr));
3488 else
3489 dref = (SV*)GvFORM(dstr);
3490 GvFORM(dstr) = (CV*)sref;
3491 break;
8990e307 3492 default:
a0d0e21e
LW		 3493 if (intro)
3494 SAVESPTR(GvSV(dstr));
3495 else
3496 dref = (SV*)GvSV(dstr);
8990e307 3497 GvSV(dstr) = sref;
39bac7f7 3498 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS		 3499 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3500 {
a5f75d66 3501 GvIMPORTED_SV_on(dstr);
1d7c1841 3502 }
8990e307
LW		 3503 break;
3504 }
3505 if (dref)
3506 SvREFCNT_dec(dref);
a0d0e21e
LW		 3507 if (intro)
3508 SAVEFREESV(sref);
27c9684d
AP		 3509 if (SvTAINTED(sstr))
3510 SvTAINT(dstr);
8990e307
LW		 3511 return;
3512 }
a0d0e21e 3513 if (SvPVX(dstr)) {
760ac839 3514 (void)SvOOK_off(dstr); /* backoff */
50483b2c
JD		 3515 if (SvLEN(dstr))
3516 Safefree(SvPVX(dstr));
a0d0e21e
LW		 3517 SvLEN(dstr)=SvCUR(dstr)=0;
3518 }
8990e307 3519 }
a0d0e21e 3520 (void)SvOK_off(dstr);
8990e307 3521 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 3522 SvROK_on(dstr);
8990e307 3523 if (sflags & SVp_NOK) {
3332b3c1
JH		 3524 SvNOKp_on(dstr);
3525 /* Only set the public OK flag if the source has public OK. */
3526 if (sflags & SVf_NOK)
3527 SvFLAGS(dstr) |= SVf_NOK;
ed6116ce
LW		 3528 SvNVX(dstr) = SvNVX(sstr);
3529 }
8990e307 3530 if (sflags & SVp_IOK) {
3332b3c1
JH		 3531 (void)SvIOKp_on(dstr);
3532 if (sflags & SVf_IOK)
3533 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3534 if (sflags & SVf_IVisUV)
25da4f38 3535 SvIsUV_on(dstr);
3332b3c1 3536 SvIVX(dstr) = SvIVX(sstr);
ed6116ce 3537 }
a0d0e21e
LW		 3538 if (SvAMAGIC(sstr)) {
3539 SvAMAGIC_on(dstr);
3540 }
ed6116ce 3541 }
8990e307 3542 else if (sflags & SVp_POK) {
79072805
LW		 3543
3544 /*
3545 * Check to see if we can just swipe the string. If so, it's a
3546 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW		 3547 * It might even be a win on short strings if SvPVX(dstr)
3548 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW		 3549 */
3550
ff68c719 3551 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 3552 SvREFCNT(sstr) == 1 && /* and no other references to it? */
1c846c1f 3553 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4c8f17b9
BH		 3554 SvLEN(sstr) && /* and really is a string */
3555 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
a5f75d66 3556 {
adbc6bb1 3557 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD		 3558 if (SvOOK(dstr)) {
3559 SvFLAGS(dstr) &= ~SVf_OOK;
3560 Safefree(SvPVX(dstr) - SvIVX(dstr));
3561 }
50483b2c 3562 else if (SvLEN(dstr))
a5f75d66 3563 Safefree(SvPVX(dstr));
79072805 3564 }
a5f75d66 3565 (void)SvPOK_only(dstr);
463ee0b2 3566 SvPV_set(dstr, SvPVX(sstr));
79072805
LW		 3567 SvLEN_set(dstr, SvLEN(sstr));
3568 SvCUR_set(dstr, SvCUR(sstr));
f4e86e0f 3569
79072805 3570 SvTEMP_off(dstr);
2b1c7e3e 3571 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
79072805
LW		 3572 SvPV_set(sstr, Nullch);
3573 SvLEN_set(sstr, 0);
a5f75d66
AD		 3574 SvCUR_set(sstr, 0);
3575 SvTEMP_off(sstr);
79072805
LW		 3576 }
3577 else { /* have to copy actual string */
8990e307
LW		 3578 STRLEN len = SvCUR(sstr);
3579
3580 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3581 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3582 SvCUR_set(dstr, len);
3583 *SvEND(dstr) = '\0';
a0d0e21e 3584 (void)SvPOK_only(dstr);
79072805 3585 }
9aa983d2 3586 if (sflags & SVf_UTF8)
a7cb1f99 3587 SvUTF8_on(dstr);
79072805 3588 /*SUPPRESS 560*/
8990e307 3589 if (sflags & SVp_NOK) {
3332b3c1
JH		 3590 SvNOKp_on(dstr);
3591 if (sflags & SVf_NOK)
3592 SvFLAGS(dstr) |= SVf_NOK;
463ee0b2 3593 SvNVX(dstr) = SvNVX(sstr);
79072805 3594 }
8990e307 3595 if (sflags & SVp_IOK) {
3332b3c1
JH		 3596 (void)SvIOKp_on(dstr);
3597 if (sflags & SVf_IOK)
3598 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3599 if (sflags & SVf_IVisUV)
25da4f38 3600 SvIsUV_on(dstr);
463ee0b2 3601 SvIVX(dstr) = SvIVX(sstr);
79072805
LW		 3602 }
3603 }
8990e307 3604 else if (sflags & SVp_IOK) {
3332b3c1
JH		 3605 if (sflags & SVf_IOK)
3606 (void)SvIOK_only(dstr);
3607 else {
9cbac4c7
DM		 3608 (void)SvOK_off(dstr);
3609 (void)SvIOKp_on(dstr);
3332b3c1
JH		 3610 }
3611 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2b1c7e3e 3612 if (sflags & SVf_IVisUV)
25da4f38 3613 SvIsUV_on(dstr);
3332b3c1
JH		 3614 SvIVX(dstr) = SvIVX(sstr);
3615 if (sflags & SVp_NOK) {
3616 if (sflags & SVf_NOK)
3617 (void)SvNOK_on(dstr);
3618 else
3619 (void)SvNOKp_on(dstr);
3620 SvNVX(dstr) = SvNVX(sstr);
3621 }
3622 }
3623 else if (sflags & SVp_NOK) {
3624 if (sflags & SVf_NOK)
3625 (void)SvNOK_only(dstr);
3626 else {
9cbac4c7 3627 (void)SvOK_off(dstr);
3332b3c1
JH		 3628 SvNOKp_on(dstr);
3629 }
3630 SvNVX(dstr) = SvNVX(sstr);
79072805
LW		 3631 }
3632 else {
20408e3c 3633 if (dtype == SVt_PVGV) {
e476b1b5
GS		 3634 if (ckWARN(WARN_MISC))
3635 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
20408e3c
GS		 3636 }
3637 else
3638 (void)SvOK_off(dstr);
a0d0e21e 3639 }
27c9684d
AP		 3640 if (SvTAINTED(sstr))
3641 SvTAINT(dstr);
79072805
LW		 3642}
3643
954c1994
GS		 3644/*
3645=for apidoc sv_setsv_mg
3646
3647Like C<sv_setsv>, but also handles 'set' magic.
3648
3649=cut
3650*/
3651
79072805 3652void
864dbfa3 3653Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 3654{
3655 sv_setsv(dstr,sstr);
3656 SvSETMAGIC(dstr);
3657}
3658
954c1994
GS		 3659/*
3660=for apidoc sv_setpvn
3661
3662Copies a string into an SV. The C<len> parameter indicates the number of
3663bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3664
3665=cut
3666*/
3667
ef50df4b 3668void
864dbfa3 3669Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3670{
c6f8c383 3671 register char *dptr;
22c522df 3672
2213622d 3673 SV_CHECK_THINKFIRST(sv);
463ee0b2 3674 if (!ptr) {
a0d0e21e 3675 (void)SvOK_off(sv);
463ee0b2
LW		 3676 return;
3677 }
22c522df
JH		 3678 else {
3679 /* len is STRLEN which is unsigned, need to copy to signed */
3680 IV iv = len;
9c5ffd7c
JH		 3681 if (iv < 0)
3682 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
22c522df 3683 }
6fc92669 3684 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 3685
79072805 3686 SvGROW(sv, len + 1);
c6f8c383
GA		 3687 dptr = SvPVX(sv);
3688 Move(ptr,dptr,len,char);
3689 dptr[len] = '\0';
79072805 3690 SvCUR_set(sv, len);
1aa99e6b 3691 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3692 SvTAINT(sv);
79072805
LW		 3693}
3694
954c1994
GS		 3695/*
3696=for apidoc sv_setpvn_mg
3697
3698Like C<sv_setpvn>, but also handles 'set' magic.
3699
3700=cut
3701*/
3702
79072805 3703void
864dbfa3 3704Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3705{
3706 sv_setpvn(sv,ptr,len);
3707 SvSETMAGIC(sv);
3708}
3709
954c1994
GS		 3710/*
3711=for apidoc sv_setpv
3712
3713Copies a string into an SV. The string must be null-terminated. Does not
3714handle 'set' magic. See C<sv_setpv_mg>.
3715
3716=cut
3717*/
3718
ef50df4b 3719void
864dbfa3 3720Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 3721{
3722 register STRLEN len;
3723
2213622d 3724 SV_CHECK_THINKFIRST(sv);
463ee0b2 3725 if (!ptr) {
a0d0e21e 3726 (void)SvOK_off(sv);
463ee0b2
LW		 3727 return;
3728 }
79072805 3729 len = strlen(ptr);
6fc92669 3730 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 3731
79072805 3732 SvGROW(sv, len + 1);
463ee0b2 3733 Move(ptr,SvPVX(sv),len+1,char);
79072805 3734 SvCUR_set(sv, len);
1aa99e6b 3735 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2
LW		 3736 SvTAINT(sv);
3737}
3738
954c1994
GS		 3739/*
3740=for apidoc sv_setpv_mg
3741
3742Like C<sv_setpv>, but also handles 'set' magic.
3743
3744=cut
3745*/
3746
463ee0b2 3747void
864dbfa3 3748Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS		 3749{
3750 sv_setpv(sv,ptr);
3751 SvSETMAGIC(sv);
3752}
3753
954c1994
GS		 3754/*
3755=for apidoc sv_usepvn
3756
3757Tells an SV to use C<ptr> to find its string value. Normally the string is
1c846c1f 3758stored inside the SV but sv_usepvn allows the SV to use an outside string.
954c1994
GS		 3759The C<ptr> should point to memory that was allocated by C<malloc>. The
3760string length, C<len>, must be supplied. This function will realloc the
3761memory pointed to by C<ptr>, so that pointer should not be freed or used by
3762the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3763See C<sv_usepvn_mg>.
3764
3765=cut
3766*/
3767
ef50df4b 3768void
864dbfa3 3769Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 3770{
2213622d 3771 SV_CHECK_THINKFIRST(sv);
c6f8c383 3772 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 3773 if (!ptr) {
a0d0e21e 3774 (void)SvOK_off(sv);
463ee0b2
LW		 3775 return;
3776 }
a0ed51b3 3777 (void)SvOOK_off(sv);
50483b2c 3778 if (SvPVX(sv) && SvLEN(sv))
463ee0b2
LW		 3779 Safefree(SvPVX(sv));
3780 Renew(ptr, len+1, char);
3781 SvPVX(sv) = ptr;
3782 SvCUR_set(sv, len);
3783 SvLEN_set(sv, len+1);
3784 *SvEND(sv) = '\0';
1aa99e6b 3785 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3786 SvTAINT(sv);
79072805
LW		 3787}
3788
954c1994
GS		 3789/*
3790=for apidoc sv_usepvn_mg
3791
3792Like C<sv_usepvn>, but also handles 'set' magic.
3793
3794=cut
3795*/
3796
ef50df4b 3797void
864dbfa3 3798Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 3799{
51c1089b 3800 sv_usepvn(sv,ptr,len);
ef50df4b
GS		 3801 SvSETMAGIC(sv);
3802}
3803
6fc92669 3804void
840a7b70 3805Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
0f15f207 3806{
2213622d 3807 if (SvREADONLY(sv)) {
1c846c1f
NIS		 3808 if (SvFAKE(sv)) {
3809 char *pvx = SvPVX(sv);
3810 STRLEN len = SvCUR(sv);
3811 U32 hash = SvUVX(sv);
3812 SvGROW(sv, len + 1);
3813 Move(pvx,SvPVX(sv),len,char);
3814 *SvEND(sv) = '\0';
3815 SvFAKE_off(sv);
3816 SvREADONLY_off(sv);
c3654f1a 3817 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
1c846c1f
NIS		 3818 }
3819 else if (PL_curcop != &PL_compiling)
cea2e8a9 3820 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3821 }
2213622d