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
Put back the #8840, it was innocent.
[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; \
66 if (PL_debug & 32768) \
67 del_sv(p); \
68 else \
69 plant_SV(p); \
70 UNLOCK_SV_MUTEX; \
71 } STMT_END
a0d0e21e 72
76e3520e 73STATIC void
cea2e8a9 74S_del_sv(pTHX_ SV *p)
463ee0b2 75{
3280af22 76 if (PL_debug & 32768) {
4633a7c4 77 SV* sva;
a0d0e21e
LW		 78 SV* sv;
79 SV* svend;
80 int ok = 0;
3280af22 81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
4633a7c4
LW		 82 sv = sva + 1;
83 svend = &sva[SvREFCNT(sva)];
a0d0e21e
LW		 84 if (p >= sv && p < svend)
85 ok = 1;
86 }
87 if (!ok) {
0453d815
PM		 88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
1d7c1841
GS		 90 "Attempt to free non-arena SV: 0x%"UVxf,
91 PTR2UV(p));
a0d0e21e
LW		 92 return;
93 }
94 }
4561caa4 95 plant_SV(p);
463ee0b2 96}
a0d0e21e 97
4561caa4
CS		 98#else /* ! DEBUGGING */
99
100#define del_SV(p) plant_SV(p)
101
102#endif /* DEBUGGING */
463ee0b2 103
4633a7c4 104void
864dbfa3 105Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
463ee0b2 106{
4633a7c4 107 SV* sva = (SV*)ptr;
463ee0b2
LW		 108 register SV* sv;
109 register SV* svend;
14dd3ad8 110 Zero(ptr, size, char);
4633a7c4
LW		 111
112 /* The first SV in an arena isn't an SV. */
3280af22 113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
4633a7c4
LW		 114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
116
3280af22
NIS		 117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
4633a7c4
LW		 119
120 svend = &sva[SvREFCNT(sva) - 1];
121 sv = sva + 1;
463ee0b2 122 while (sv < svend) {
a0d0e21e 123 SvANY(sv) = (void *)(SV*)(sv + 1);
8990e307 124 SvFLAGS(sv) = SVTYPEMASK;
463ee0b2
LW		 125 sv++;
126 }
127 SvANY(sv) = 0;
4633a7c4
LW		 128 SvFLAGS(sv) = SVTYPEMASK;
129}
130
fba3b22e 131/* sv_mutex must be held while calling more_sv() */
76e3520e 132STATIC SV*
cea2e8a9 133S_more_sv(pTHX)
4633a7c4 134{
4561caa4
CS		 135 register SV* sv;
136
3280af22
NIS		 137 if (PL_nice_chunk) {
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
c07a80fd 140 }
1edc1566 141 else {
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
145 }
4561caa4
CS		 146 uproot_SV(sv);
147 return sv;
463ee0b2
LW		 148}
149
76e3520e 150STATIC void
cea2e8a9 151S_visit(pTHX_ SVFUNC_t f)
8990e307 152{
4633a7c4 153 SV* sva;
8990e307
LW		 154 SV* sv;
155 register SV* svend;
156
3280af22 157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
4633a7c4 158 svend = &sva[SvREFCNT(sva)];
4561caa4
CS		 159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
51371543 161 (FCALL)(aTHXo_ sv);
8990e307
LW		 162 }
163 }
164}
165
166void
864dbfa3 167Perl_sv_report_used(pTHX)
4561caa4 168{
0b94c7bb 169 visit(do_report_used);
4561caa4
CS		 170}
171
4561caa4 172void
864dbfa3 173Perl_sv_clean_objs(pTHX)
4561caa4 174{
3280af22 175 PL_in_clean_objs = TRUE;
0b94c7bb 176 visit(do_clean_objs);
4561caa4 177#ifndef DISABLE_DESTRUCTOR_KLUDGE
2d0f3c12 178 /* some barnacles may yet remain, clinging to typeglobs */
0b94c7bb 179 visit(do_clean_named_objs);
4561caa4 180#endif
3280af22 181 PL_in_clean_objs = FALSE;
4561caa4
CS		 182}
183
8990e307 184void
864dbfa3 185Perl_sv_clean_all(pTHX)
8990e307 186{
3280af22 187 PL_in_clean_all = TRUE;
0b94c7bb 188 visit(do_clean_all);
3280af22 189 PL_in_clean_all = FALSE;
8990e307 190}
463ee0b2 191
4633a7c4 192void
864dbfa3 193Perl_sv_free_arenas(pTHX)
4633a7c4
LW		 194{
195 SV* sva;
196 SV* svanext;
612f20c3 197 XPV *arena, *arenanext;
4633a7c4
LW		 198
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
201
3280af22 202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
4633a7c4
LW		 203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
206
207 if (!SvFAKE(sva))
1edc1566 208 Safefree((void *)sva);
4633a7c4 209 }
5f05dabc 210
612f20c3
GS		 211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
213 Safefree(arena);
214 }
215 PL_xiv_arenaroot = 0;
216
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
219 Safefree(arena);
220 }
221 PL_xnv_arenaroot = 0;
222
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
225 Safefree(arena);
226 }
227 PL_xrv_arenaroot = 0;
228
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
231 Safefree(arena);
232 }
233 PL_xpv_arenaroot = 0;
234
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
237 Safefree(arena);
238 }
239 PL_xpviv_arenaroot = 0;
240
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
243 Safefree(arena);
244 }
245 PL_xpvnv_arenaroot = 0;
246
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
249 Safefree(arena);
250 }
251 PL_xpvcv_arenaroot = 0;
252
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
255 Safefree(arena);
256 }
257 PL_xpvav_arenaroot = 0;
258
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
261 Safefree(arena);
262 }
263 PL_xpvhv_arenaroot = 0;
264
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
267 Safefree(arena);
268 }
269 PL_xpvmg_arenaroot = 0;
270
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
273 Safefree(arena);
274 }
275 PL_xpvlv_arenaroot = 0;
276
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
279 Safefree(arena);
280 }
281 PL_xpvbm_arenaroot = 0;
282
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
285 Safefree(arena);
286 }
287 PL_he_arenaroot = 0;
288
3280af22
NIS		 289 if (PL_nice_chunk)
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
293 PL_sv_arenaroot = 0;
294 PL_sv_root = 0;
4633a7c4
LW		 295}
296
1d7c1841
GS		 297void
298Perl_report_uninit(pTHX)
299{
300 if (PL_op)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
303 else
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
305}
306
76e3520e 307STATIC XPVIV*
cea2e8a9 308S_new_xiv(pTHX)
463ee0b2 309{
ea7c11a3 310 IV* xiv;
cbe51380
GS		 311 LOCK_SV_MUTEX;
312 if (!PL_xiv_root)
313 more_xiv();
314 xiv = PL_xiv_root;
315 /*
316 * See comment in more_xiv() -- RAM.
317 */
318 PL_xiv_root = *(IV**)xiv;
319 UNLOCK_SV_MUTEX;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
463ee0b2
LW		 321}
322
76e3520e 323STATIC void
cea2e8a9 324S_del_xiv(pTHX_ XPVIV *p)
463ee0b2 325{
23e6a22f 326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
cbe51380 327 LOCK_SV_MUTEX;
3280af22
NIS		 328 *(IV**)xiv = PL_xiv_root;
329 PL_xiv_root = xiv;
cbe51380 330 UNLOCK_SV_MUTEX;
463ee0b2
LW		 331}
332
cbe51380 333STATIC void
cea2e8a9 334S_more_xiv(pTHX)
463ee0b2 335{
ea7c11a3
SM		 336 register IV* xiv;
337 register IV* xivend;
8c52afec
IZ		 338 XPV* ptr;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
3280af22
NIS		 340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
a0d0e21e 342
ea7c11a3
SM		 343 xiv = (IV*) ptr;
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
3280af22 346 PL_xiv_root = xiv;
463ee0b2 347 while (xiv < xivend) {
ea7c11a3 348 *(IV**)xiv = (IV *)(xiv + 1);
463ee0b2
LW		 349 xiv++;
350 }
ea7c11a3 351 *(IV**)xiv = 0;
463ee0b2
LW		 352}
353
76e3520e 354STATIC XPVNV*
cea2e8a9 355S_new_xnv(pTHX)
463ee0b2 356{
65202027 357 NV* xnv;
cbe51380
GS		 358 LOCK_SV_MUTEX;
359 if (!PL_xnv_root)
360 more_xnv();
361 xnv = PL_xnv_root;
65202027 362 PL_xnv_root = *(NV**)xnv;
cbe51380
GS		 363 UNLOCK_SV_MUTEX;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
463ee0b2
LW		 365}
366
76e3520e 367STATIC void
cea2e8a9 368S_del_xnv(pTHX_ XPVNV *p)
463ee0b2 369{
65202027 370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
cbe51380 371 LOCK_SV_MUTEX;
65202027 372 *(NV**)xnv = PL_xnv_root;
3280af22 373 PL_xnv_root = xnv;
cbe51380 374 UNLOCK_SV_MUTEX;
463ee0b2
LW		 375}
376
cbe51380 377STATIC void
cea2e8a9 378S_more_xnv(pTHX)
463ee0b2 379{
65202027
DS		 380 register NV* xnv;
381 register NV* xnvend;
612f20c3
GS		 382 XPV *ptr;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
386
387 xnv = (NV*) ptr;
65202027
DS		 388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
3280af22 390 PL_xnv_root = xnv;
463ee0b2 391 while (xnv < xnvend) {
65202027 392 *(NV**)xnv = (NV*)(xnv + 1);
463ee0b2
LW		 393 xnv++;
394 }
65202027 395 *(NV**)xnv = 0;
463ee0b2
LW		 396}
397
76e3520e 398STATIC XRV*
cea2e8a9 399S_new_xrv(pTHX)
ed6116ce
LW		 400{
401 XRV* xrv;
cbe51380
GS		 402 LOCK_SV_MUTEX;
403 if (!PL_xrv_root)
404 more_xrv();
405 xrv = PL_xrv_root;
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
407 UNLOCK_SV_MUTEX;
408 return xrv;
ed6116ce
LW		 409}
410
76e3520e 411STATIC void
cea2e8a9 412S_del_xrv(pTHX_ XRV *p)
ed6116ce 413{
cbe51380 414 LOCK_SV_MUTEX;
3280af22
NIS		 415 p->xrv_rv = (SV*)PL_xrv_root;
416 PL_xrv_root = p;
cbe51380 417 UNLOCK_SV_MUTEX;
ed6116ce
LW		 418}
419
cbe51380 420STATIC void
cea2e8a9 421S_more_xrv(pTHX)
ed6116ce 422{
ed6116ce
LW		 423 register XRV* xrv;
424 register XRV* xrvend;
612f20c3
GS		 425 XPV *ptr;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
429
430 xrv = (XRV*) ptr;
ed6116ce 431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
612f20c3
GS		 432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
433 PL_xrv_root = xrv;
ed6116ce
LW		 434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
436 xrv++;
437 }
438 xrv->xrv_rv = 0;
ed6116ce
LW		 439}
440
76e3520e 441STATIC XPV*
cea2e8a9 442S_new_xpv(pTHX)
463ee0b2
LW		 443{
444 XPV* xpv;
cbe51380
GS		 445 LOCK_SV_MUTEX;
446 if (!PL_xpv_root)
447 more_xpv();
448 xpv = PL_xpv_root;
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
450 UNLOCK_SV_MUTEX;
451 return xpv;
463ee0b2
LW		 452}
453
76e3520e 454STATIC void
cea2e8a9 455S_del_xpv(pTHX_ XPV *p)
463ee0b2 456{
cbe51380 457 LOCK_SV_MUTEX;
3280af22
NIS		 458 p->xpv_pv = (char*)PL_xpv_root;
459 PL_xpv_root = p;
cbe51380 460 UNLOCK_SV_MUTEX;
463ee0b2
LW		 461}
462
cbe51380 463STATIC void
cea2e8a9 464S_more_xpv(pTHX)
463ee0b2 465{
463ee0b2
LW		 466 register XPV* xpv;
467 register XPV* xpvend;
612f20c3
GS		 468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
471
463ee0b2 472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
612f20c3 473 PL_xpv_root = ++xpv;
463ee0b2
LW		 474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
476 xpv++;
477 }
478 xpv->xpv_pv = 0;
463ee0b2
LW		 479}
480
932e9ff9
VB		 481STATIC XPVIV*
482S_new_xpviv(pTHX)
483{
484 XPVIV* xpviv;
485 LOCK_SV_MUTEX;
486 if (!PL_xpviv_root)
487 more_xpviv();
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
490 UNLOCK_SV_MUTEX;
491 return xpviv;
492}
493
494STATIC void
495S_del_xpviv(pTHX_ XPVIV *p)
496{
497 LOCK_SV_MUTEX;
498 p->xpv_pv = (char*)PL_xpviv_root;
499 PL_xpviv_root = p;
500 UNLOCK_SV_MUTEX;
501}
502
932e9ff9
VB		 503STATIC void
504S_more_xpviv(pTHX)
505{
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
612f20c3
GS		 508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
511
932e9ff9 512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
612f20c3 513 PL_xpviv_root = ++xpviv;
932e9ff9
VB		 514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
516 xpviv++;
517 }
518 xpviv->xpv_pv = 0;
519}
520
932e9ff9
VB		 521STATIC XPVNV*
522S_new_xpvnv(pTHX)
523{
524 XPVNV* xpvnv;
525 LOCK_SV_MUTEX;
526 if (!PL_xpvnv_root)
527 more_xpvnv();
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
530 UNLOCK_SV_MUTEX;
531 return xpvnv;
532}
533
534STATIC void
535S_del_xpvnv(pTHX_ XPVNV *p)
536{
537 LOCK_SV_MUTEX;
538 p->xpv_pv = (char*)PL_xpvnv_root;
539 PL_xpvnv_root = p;
540 UNLOCK_SV_MUTEX;
541}
542
932e9ff9
VB		 543STATIC void
544S_more_xpvnv(pTHX)
545{
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
612f20c3
GS		 548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
551
932e9ff9 552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
612f20c3 553 PL_xpvnv_root = ++xpvnv;
932e9ff9
VB		 554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
556 xpvnv++;
557 }
558 xpvnv->xpv_pv = 0;
559}
560
932e9ff9
VB		 561STATIC XPVCV*
562S_new_xpvcv(pTHX)
563{
564 XPVCV* xpvcv;
565 LOCK_SV_MUTEX;
566 if (!PL_xpvcv_root)
567 more_xpvcv();
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
570 UNLOCK_SV_MUTEX;
571 return xpvcv;
572}
573
574STATIC void
575S_del_xpvcv(pTHX_ XPVCV *p)
576{
577 LOCK_SV_MUTEX;
578 p->xpv_pv = (char*)PL_xpvcv_root;
579 PL_xpvcv_root = p;
580 UNLOCK_SV_MUTEX;
581}
582
932e9ff9
VB		 583STATIC void
584S_more_xpvcv(pTHX)
585{
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
612f20c3
GS		 588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
591
932e9ff9 592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
612f20c3 593 PL_xpvcv_root = ++xpvcv;
932e9ff9
VB		 594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
596 xpvcv++;
597 }
598 xpvcv->xpv_pv = 0;
599}
600
932e9ff9
VB		 601STATIC XPVAV*
602S_new_xpvav(pTHX)
603{
604 XPVAV* xpvav;
605 LOCK_SV_MUTEX;
606 if (!PL_xpvav_root)
607 more_xpvav();
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
610 UNLOCK_SV_MUTEX;
611 return xpvav;
612}
613
614STATIC void
615S_del_xpvav(pTHX_ XPVAV *p)
616{
617 LOCK_SV_MUTEX;
618 p->xav_array = (char*)PL_xpvav_root;
619 PL_xpvav_root = p;
620 UNLOCK_SV_MUTEX;
621}
622
932e9ff9
VB		 623STATIC void
624S_more_xpvav(pTHX)
625{
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
612f20c3
GS		 628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
631
932e9ff9 632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
612f20c3 633 PL_xpvav_root = ++xpvav;
932e9ff9
VB		 634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
636 xpvav++;
637 }
638 xpvav->xav_array = 0;
639}
640
932e9ff9
VB		 641STATIC XPVHV*
642S_new_xpvhv(pTHX)
643{
644 XPVHV* xpvhv;
645 LOCK_SV_MUTEX;
646 if (!PL_xpvhv_root)
647 more_xpvhv();
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
650 UNLOCK_SV_MUTEX;
651 return xpvhv;
652}
653
654STATIC void
655S_del_xpvhv(pTHX_ XPVHV *p)
656{
657 LOCK_SV_MUTEX;
658 p->xhv_array = (char*)PL_xpvhv_root;
659 PL_xpvhv_root = p;
660 UNLOCK_SV_MUTEX;
661}
662
932e9ff9
VB		 663STATIC void
664S_more_xpvhv(pTHX)
665{
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
612f20c3
GS		 668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
671
932e9ff9 672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
612f20c3 673 PL_xpvhv_root = ++xpvhv;
932e9ff9
VB		 674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
676 xpvhv++;
677 }
678 xpvhv->xhv_array = 0;
679}
680
932e9ff9
VB		 681STATIC XPVMG*
682S_new_xpvmg(pTHX)
683{
684 XPVMG* xpvmg;
685 LOCK_SV_MUTEX;
686 if (!PL_xpvmg_root)
687 more_xpvmg();
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
690 UNLOCK_SV_MUTEX;
691 return xpvmg;
692}
693
694STATIC void
695S_del_xpvmg(pTHX_ XPVMG *p)
696{
697 LOCK_SV_MUTEX;
698 p->xpv_pv = (char*)PL_xpvmg_root;
699 PL_xpvmg_root = p;
700 UNLOCK_SV_MUTEX;
701}
702
932e9ff9
VB		 703STATIC void
704S_more_xpvmg(pTHX)
705{
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
612f20c3
GS		 708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
711
932e9ff9 712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
612f20c3 713 PL_xpvmg_root = ++xpvmg;
932e9ff9
VB		 714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
716 xpvmg++;
717 }
718 xpvmg->xpv_pv = 0;
719}
720
932e9ff9
VB		 721STATIC XPVLV*
722S_new_xpvlv(pTHX)
723{
724 XPVLV* xpvlv;
725 LOCK_SV_MUTEX;
726 if (!PL_xpvlv_root)
727 more_xpvlv();
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
730 UNLOCK_SV_MUTEX;
731 return xpvlv;
732}
733
734STATIC void
735S_del_xpvlv(pTHX_ XPVLV *p)
736{
737 LOCK_SV_MUTEX;
738 p->xpv_pv = (char*)PL_xpvlv_root;
739 PL_xpvlv_root = p;
740 UNLOCK_SV_MUTEX;
741}
742
932e9ff9
VB		 743STATIC void
744S_more_xpvlv(pTHX)
745{
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
612f20c3
GS		 748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
751
932e9ff9 752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
612f20c3 753 PL_xpvlv_root = ++xpvlv;
932e9ff9
VB		 754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
756 xpvlv++;
757 }
758 xpvlv->xpv_pv = 0;
759}
760
932e9ff9
VB		 761STATIC XPVBM*
762S_new_xpvbm(pTHX)
763{
764 XPVBM* xpvbm;
765 LOCK_SV_MUTEX;
766 if (!PL_xpvbm_root)
767 more_xpvbm();
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
770 UNLOCK_SV_MUTEX;
771 return xpvbm;
772}
773
774STATIC void
775S_del_xpvbm(pTHX_ XPVBM *p)
776{
777 LOCK_SV_MUTEX;
778 p->xpv_pv = (char*)PL_xpvbm_root;
779 PL_xpvbm_root = p;
780 UNLOCK_SV_MUTEX;
781}
782
932e9ff9
VB		 783STATIC void
784S_more_xpvbm(pTHX)
785{
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
612f20c3
GS		 788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
791
932e9ff9 792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
612f20c3 793 PL_xpvbm_root = ++xpvbm;
932e9ff9
VB		 794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
796 xpvbm++;
797 }
798 xpvbm->xpv_pv = 0;
799}
800
d33b2eba
GS		 801#ifdef LEAKTEST
802# define my_safemalloc(s) (void*)safexmalloc(717,s)
803# define my_safefree(p) safexfree((char*)p)
804#else
805# define my_safemalloc(s) (void*)safemalloc(s)
806# define my_safefree(p) safefree((char*)p)
807#endif
463ee0b2 808
d33b2eba 809#ifdef PURIFY
463ee0b2 810
d33b2eba
GS		 811#define new_XIV() my_safemalloc(sizeof(XPVIV))
812#define del_XIV(p) my_safefree(p)
ed6116ce 813
d33b2eba
GS		 814#define new_XNV() my_safemalloc(sizeof(XPVNV))
815#define del_XNV(p) my_safefree(p)
463ee0b2 816
d33b2eba
GS		 817#define new_XRV() my_safemalloc(sizeof(XRV))
818#define del_XRV(p) my_safefree(p)
8c52afec 819
d33b2eba
GS		 820#define new_XPV() my_safemalloc(sizeof(XPV))
821#define del_XPV(p) my_safefree(p)
9b94d1dd 822
d33b2eba
GS		 823#define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824#define del_XPVIV(p) my_safefree(p)
932e9ff9 825
d33b2eba
GS		 826#define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827#define del_XPVNV(p) my_safefree(p)
932e9ff9 828
d33b2eba
GS		 829#define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830#define del_XPVCV(p) my_safefree(p)
932e9ff9 831
d33b2eba
GS		 832#define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833#define del_XPVAV(p) my_safefree(p)
834
835#define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836#define del_XPVHV(p) my_safefree(p)
1c846c1f 837
d33b2eba
GS		 838#define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839#define del_XPVMG(p) my_safefree(p)
840
841#define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842#define del_XPVLV(p) my_safefree(p)
843
844#define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845#define del_XPVBM(p) my_safefree(p)
846
847#else /* !PURIFY */
848
849#define new_XIV() (void*)new_xiv()
850#define del_XIV(p) del_xiv((XPVIV*) p)
851
852#define new_XNV() (void*)new_xnv()
853#define del_XNV(p) del_xnv((XPVNV*) p)
9b94d1dd 854
d33b2eba
GS		 855#define new_XRV() (void*)new_xrv()
856#define del_XRV(p) del_xrv((XRV*) p)
9b94d1dd 857
d33b2eba
GS		 858#define new_XPV() (void*)new_xpv()
859#define del_XPV(p) del_xpv((XPV *)p)
860
861#define new_XPVIV() (void*)new_xpviv()
862#define del_XPVIV(p) del_xpviv((XPVIV *)p)
863
864#define new_XPVNV() (void*)new_xpvnv()
865#define del_XPVNV(p) del_xpvnv((XPVNV *)p)
866
867#define new_XPVCV() (void*)new_xpvcv()
868#define del_XPVCV(p) del_xpvcv((XPVCV *)p)
869
870#define new_XPVAV() (void*)new_xpvav()
871#define del_XPVAV(p) del_xpvav((XPVAV *)p)
872
873#define new_XPVHV() (void*)new_xpvhv()
874#define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1c846c1f 875
d33b2eba
GS		 876#define new_XPVMG() (void*)new_xpvmg()
877#define del_XPVMG(p) del_xpvmg((XPVMG *)p)
878
879#define new_XPVLV() (void*)new_xpvlv()
880#define del_XPVLV(p) del_xpvlv((XPVLV *)p)
881
882#define new_XPVBM() (void*)new_xpvbm()
883#define del_XPVBM(p) del_xpvbm((XPVBM *)p)
884
885#endif /* PURIFY */
9b94d1dd 886
d33b2eba
GS		 887#define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888#define del_XPVGV(p) my_safefree(p)
1c846c1f 889
d33b2eba
GS		 890#define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891#define del_XPVFM(p) my_safefree(p)
1c846c1f 892
d33b2eba
GS		 893#define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894#define del_XPVIO(p) my_safefree(p)
8990e307 895
954c1994
GS		 896/*
897=for apidoc sv_upgrade
898
899Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
900C<svtype>.
901
902=cut
903*/
904
79072805 905bool
864dbfa3 906Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
79072805
LW		 907{
908 char* pv;
909 U32 cur;
910 U32 len;
a0d0e21e 911 IV iv;
65202027 912 NV nv;
79072805
LW		 913 MAGIC* magic;
914 HV* stash;
915
f130fd45
NIS		 916 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
917 sv_force_normal(sv);
918 }
919
79072805
LW		 920 if (SvTYPE(sv) == mt)
921 return TRUE;
922
a5f75d66
AD		 923 if (mt < SVt_PVIV)
924 (void)SvOOK_off(sv);
925
79072805
LW		 926 switch (SvTYPE(sv)) {
927 case SVt_NULL:
928 pv = 0;
929 cur = 0;
930 len = 0;
931 iv = 0;
932 nv = 0.0;
933 magic = 0;
934 stash = 0;
935 break;
79072805
LW		 936 case SVt_IV:
937 pv = 0;
938 cur = 0;
939 len = 0;
463ee0b2 940 iv = SvIVX(sv);
65202027 941 nv = (NV)SvIVX(sv);
79072805
LW		 942 del_XIV(SvANY(sv));
943 magic = 0;
944 stash = 0;
ed6116ce 945 if (mt == SVt_NV)
463ee0b2 946 mt = SVt_PVNV;
ed6116ce
LW		 947 else if (mt < SVt_PVIV)
948 mt = SVt_PVIV;
79072805
LW		 949 break;
950 case SVt_NV:
951 pv = 0;
952 cur = 0;
953 len = 0;
463ee0b2 954 nv = SvNVX(sv);
1bd302c3 955 iv = I_V(nv);
79072805
LW		 956 magic = 0;
957 stash = 0;
958 del_XNV(SvANY(sv));
959 SvANY(sv) = 0;
ed6116ce 960 if (mt < SVt_PVNV)
79072805
LW		 961 mt = SVt_PVNV;
962 break;
ed6116ce
LW		 963 case SVt_RV:
964 pv = (char*)SvRV(sv);
965 cur = 0;
966 len = 0;
56431972
RB		 967 iv = PTR2IV(pv);
968 nv = PTR2NV(pv);
ed6116ce
LW		 969 del_XRV(SvANY(sv));
970 magic = 0;
971 stash = 0;
972 break;
79072805 973 case SVt_PV:
463ee0b2 974 pv = SvPVX(sv);
79072805
LW		 975 cur = SvCUR(sv);
976 len = SvLEN(sv);
977 iv = 0;
978 nv = 0.0;
979 magic = 0;
980 stash = 0;
981 del_XPV(SvANY(sv));
748a9306
LW		 982 if (mt <= SVt_IV)
983 mt = SVt_PVIV;
984 else if (mt == SVt_NV)
985 mt = SVt_PVNV;
79072805
LW		 986 break;
987 case SVt_PVIV:
463ee0b2 988 pv = SvPVX(sv);
79072805
LW		 989 cur = SvCUR(sv);
990 len = SvLEN(sv);
463ee0b2 991 iv = SvIVX(sv);
79072805
LW		 992 nv = 0.0;
993 magic = 0;
994 stash = 0;
995 del_XPVIV(SvANY(sv));
996 break;
997 case SVt_PVNV:
463ee0b2 998 pv = SvPVX(sv);
79072805
LW		 999 cur = SvCUR(sv);
1000 len = SvLEN(sv);
463ee0b2
LW		 1001 iv = SvIVX(sv);
1002 nv = SvNVX(sv);
79072805
LW		 1003 magic = 0;
1004 stash = 0;
1005 del_XPVNV(SvANY(sv));
1006 break;
1007 case SVt_PVMG:
463ee0b2 1008 pv = SvPVX(sv);
79072805
LW		 1009 cur = SvCUR(sv);
1010 len = SvLEN(sv);
463ee0b2
LW		 1011 iv = SvIVX(sv);
1012 nv = SvNVX(sv);
79072805
LW		 1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1016 break;
1017 default:
cea2e8a9 1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
79072805
LW		 1019 }
1020
1021 switch (mt) {
1022 case SVt_NULL:
cea2e8a9 1023 Perl_croak(aTHX_ "Can't upgrade to undef");
79072805
LW		 1024 case SVt_IV:
1025 SvANY(sv) = new_XIV();
463ee0b2 1026 SvIVX(sv) = iv;
79072805
LW		 1027 break;
1028 case SVt_NV:
1029 SvANY(sv) = new_XNV();
463ee0b2 1030 SvNVX(sv) = nv;
79072805 1031 break;
ed6116ce
LW		 1032 case SVt_RV:
1033 SvANY(sv) = new_XRV();
1034 SvRV(sv) = (SV*)pv;
ed6116ce 1035 break;
79072805
LW		 1036 case SVt_PV:
1037 SvANY(sv) = new_XPV();
463ee0b2 1038 SvPVX(sv) = pv;
79072805
LW		 1039 SvCUR(sv) = cur;
1040 SvLEN(sv) = len;
1041 break;
1042 case SVt_PVIV:
1043 SvANY(sv) = new_XPVIV();
463ee0b2 1044 SvPVX(sv) = pv;
79072805
LW		 1045 SvCUR(sv) = cur;
1046 SvLEN(sv) = len;
463ee0b2 1047 SvIVX(sv) = iv;
79072805 1048 if (SvNIOK(sv))
a0d0e21e 1049 (void)SvIOK_on(sv);
79072805
LW		 1050 SvNOK_off(sv);
1051 break;
1052 case SVt_PVNV:
1053 SvANY(sv) = new_XPVNV();
463ee0b2 1054 SvPVX(sv) = pv;
79072805
LW		 1055 SvCUR(sv) = cur;
1056 SvLEN(sv) = len;
463ee0b2
LW		 1057 SvIVX(sv) = iv;
1058 SvNVX(sv) = nv;
79072805
LW		 1059 break;
1060 case SVt_PVMG:
1061 SvANY(sv) = new_XPVMG();
463ee0b2 1062 SvPVX(sv) = pv;
79072805
LW		 1063 SvCUR(sv) = cur;
1064 SvLEN(sv) = len;
463ee0b2
LW		 1065 SvIVX(sv) = iv;
1066 SvNVX(sv) = nv;
79072805
LW		 1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1069 break;
1070 case SVt_PVLV:
1071 SvANY(sv) = new_XPVLV();
463ee0b2 1072 SvPVX(sv) = pv;
79072805
LW		 1073 SvCUR(sv) = cur;
1074 SvLEN(sv) = len;
463ee0b2
LW		 1075 SvIVX(sv) = iv;
1076 SvNVX(sv) = nv;
79072805
LW		 1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1079 LvTARGOFF(sv) = 0;
1080 LvTARGLEN(sv) = 0;
1081 LvTARG(sv) = 0;
1082 LvTYPE(sv) = 0;
1083 break;
1084 case SVt_PVAV:
1085 SvANY(sv) = new_XPVAV();
463ee0b2
LW		 1086 if (pv)
1087 Safefree(pv);
2304df62 1088 SvPVX(sv) = 0;
d1bf51dd 1089 AvMAX(sv) = -1;
93965878 1090 AvFILLp(sv) = -1;
463ee0b2
LW		 1091 SvIVX(sv) = 0;
1092 SvNVX(sv) = 0.0;
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1095 AvALLOC(sv) = 0;
79072805
LW		 1096 AvARYLEN(sv) = 0;
1097 AvFLAGS(sv) = 0;
1098 break;
1099 case SVt_PVHV:
1100 SvANY(sv) = new_XPVHV();
463ee0b2
LW		 1101 if (pv)
1102 Safefree(pv);
1103 SvPVX(sv) = 0;
1104 HvFILL(sv) = 0;
1105 HvMAX(sv) = 0;
1106 HvKEYS(sv) = 0;
1107 SvNVX(sv) = 0.0;
79072805
LW		 1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
79072805
LW		 1110 HvRITER(sv) = 0;
1111 HvEITER(sv) = 0;
1112 HvPMROOT(sv) = 0;
1113 HvNAME(sv) = 0;
79072805
LW		 1114 break;
1115 case SVt_PVCV:
1116 SvANY(sv) = new_XPVCV();
748a9306 1117 Zero(SvANY(sv), 1, XPVCV);
463ee0b2 1118 SvPVX(sv) = pv;
79072805
LW		 1119 SvCUR(sv) = cur;
1120 SvLEN(sv) = len;
463ee0b2
LW		 1121 SvIVX(sv) = iv;
1122 SvNVX(sv) = nv;
79072805
LW		 1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
79072805
LW		 1125 break;
1126 case SVt_PVGV:
1127 SvANY(sv) = new_XPVGV();
463ee0b2 1128 SvPVX(sv) = pv;
79072805
LW		 1129 SvCUR(sv) = cur;
1130 SvLEN(sv) = len;
463ee0b2
LW		 1131 SvIVX(sv) = iv;
1132 SvNVX(sv) = nv;
79072805
LW		 1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
93a17b20 1135 GvGP(sv) = 0;
79072805
LW		 1136 GvNAME(sv) = 0;
1137 GvNAMELEN(sv) = 0;
1138 GvSTASH(sv) = 0;
a5f75d66 1139 GvFLAGS(sv) = 0;
79072805
LW		 1140 break;
1141 case SVt_PVBM:
1142 SvANY(sv) = new_XPVBM();
463ee0b2 1143 SvPVX(sv) = pv;
79072805
LW		 1144 SvCUR(sv) = cur;
1145 SvLEN(sv) = len;
463ee0b2
LW		 1146 SvIVX(sv) = iv;
1147 SvNVX(sv) = nv;
79072805
LW		 1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1150 BmRARE(sv) = 0;
1151 BmUSEFUL(sv) = 0;
1152 BmPREVIOUS(sv) = 0;
1153 break;
1154 case SVt_PVFM:
1155 SvANY(sv) = new_XPVFM();
748a9306 1156 Zero(SvANY(sv), 1, XPVFM);
463ee0b2 1157 SvPVX(sv) = pv;
79072805
LW		 1158 SvCUR(sv) = cur;
1159 SvLEN(sv) = len;
463ee0b2
LW		 1160 SvIVX(sv) = iv;
1161 SvNVX(sv) = nv;
79072805
LW		 1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
79072805 1164 break;
8990e307
LW		 1165 case SVt_PVIO:
1166 SvANY(sv) = new_XPVIO();
748a9306 1167 Zero(SvANY(sv), 1, XPVIO);
8990e307
LW		 1168 SvPVX(sv) = pv;
1169 SvCUR(sv) = cur;
1170 SvLEN(sv) = len;
1171 SvIVX(sv) = iv;
1172 SvNVX(sv) = nv;
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
85e6fe83 1175 IoPAGE_LEN(sv) = 60;
8990e307
LW		 1176 break;
1177 }
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1179 SvFLAGS(sv) |= mt;
79072805
LW		 1180 return TRUE;
1181}
1182
79072805 1183int
864dbfa3 1184Perl_sv_backoff(pTHX_ register SV *sv)
79072805
LW		 1185{
1186 assert(SvOOK(sv));
463ee0b2
LW		 1187 if (SvIVX(sv)) {
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
79072805 1191 SvIV_set(sv, 0);
463ee0b2 1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
79072805
LW		 1193 }
1194 SvFLAGS(sv) &= ~SVf_OOK;
a0d0e21e 1195 return 0;
79072805
LW		 1196}
1197
954c1994
GS		 1198/*
1199=for apidoc sv_grow
1200
1201Expands the character buffer in the SV. This will use C<sv_unref> and will
1202upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1203Use C<SvGROW>.
1204
1205=cut
1206*/
1207
79072805 1208char *
864dbfa3 1209Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
79072805
LW		 1210{
1211 register char *s;
1212
55497cff 1213#ifdef HAS_64K_LIMIT
79072805 1214 if (newlen >= 0x10000) {
1d7c1841
GS		 1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
79072805
LW		 1217 my_exit(1);
1218 }
55497cff 1219#endif /* HAS_64K_LIMIT */
a0d0e21e
LW		 1220 if (SvROK(sv))
1221 sv_unref(sv);
79072805
LW		 1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
463ee0b2 1224 s = SvPVX(sv);
79072805
LW		 1225 }
1226 else if (SvOOK(sv)) { /* pv is offset? */
1227 sv_backoff(sv);
463ee0b2 1228 s = SvPVX(sv);
79072805
LW		 1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
c6f8c383
GA		 1231#ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1233 newlen = 0xFFFF;
1234#endif
79072805
LW		 1235 }
1236 else
463ee0b2 1237 s = SvPVX(sv);
79072805 1238 if (newlen > SvLEN(sv)) { /* need more room? */
8d6dde3e 1239 if (SvLEN(sv) && s) {
f5a32c7f 1240#if defined(MYMALLOC) && !defined(LEAKTEST)
8d6dde3e
IZ		 1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1242 if (newlen <= l) {
1243 SvLEN_set(sv, l);
1244 return s;
1245 } else
c70c8a0a 1246#endif
79072805 1247 Renew(s,newlen,char);
8d6dde3e 1248 }
79072805
LW		 1249 else
1250 New(703,s,newlen,char);
1251 SvPV_set(sv, s);
1252 SvLEN_set(sv, newlen);
1253 }
1254 return s;
1255}
1256
954c1994
GS		 1257/*
1258=for apidoc sv_setiv
1259
1260Copies an integer into the given SV. Does not handle 'set' magic. See
1261C<sv_setiv_mg>.
1262
1263=cut
1264*/
1265
79072805 1266void
864dbfa3 1267Perl_sv_setiv(pTHX_ register SV *sv, IV i)
79072805 1268{
2213622d 1269 SV_CHECK_THINKFIRST(sv);
463ee0b2
LW		 1270 switch (SvTYPE(sv)) {
1271 case SVt_NULL:
79072805 1272 sv_upgrade(sv, SVt_IV);
463ee0b2
LW		 1273 break;
1274 case SVt_NV:
1275 sv_upgrade(sv, SVt_PVNV);
1276 break;
ed6116ce 1277 case SVt_RV:
463ee0b2 1278 case SVt_PV:
79072805 1279 sv_upgrade(sv, SVt_PVIV);
463ee0b2 1280 break;
a0d0e21e
LW		 1281
1282 case SVt_PVGV:
a0d0e21e
LW		 1283 case SVt_PVAV:
1284 case SVt_PVHV:
1285 case SVt_PVCV:
1286 case SVt_PVFM:
1287 case SVt_PVIO:
411caa50
JH		 1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
463ee0b2 1290 }
a0d0e21e 1291 (void)SvIOK_only(sv); /* validate number */
a5f75d66 1292 SvIVX(sv) = i;
463ee0b2 1293 SvTAINT(sv);
79072805
LW		 1294}
1295
954c1994
GS		 1296/*
1297=for apidoc sv_setiv_mg
1298
1299Like C<sv_setiv>, but also handles 'set' magic.
1300
1301=cut
1302*/
1303
79072805 1304void
864dbfa3 1305Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
ef50df4b
GS		 1306{
1307 sv_setiv(sv,i);
1308 SvSETMAGIC(sv);
1309}
1310
954c1994
GS		 1311/*
1312=for apidoc sv_setuv
1313
1314Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1315See C<sv_setuv_mg>.
1316
1317=cut
1318*/
1319
ef50df4b 1320void
864dbfa3 1321Perl_sv_setuv(pTHX_ register SV *sv, UV u)
55497cff 1322{
55ada374
NC		 1323 /* With these two if statements:
1324 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 1325
55ada374
NC		 1326 without
1327 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 1328
55ada374
NC		 1329 If you wish to remove them, please benchmark to see what the effect is
1330 */
28e5dec8
JH		 1331 if (u <= (UV)IV_MAX) {
1332 sv_setiv(sv, (IV)u);
1333 return;
1334 }
25da4f38
IZ		 1335 sv_setiv(sv, 0);
1336 SvIsUV_on(sv);
1337 SvUVX(sv) = u;
55497cff 1338}
1339
954c1994
GS		 1340/*
1341=for apidoc sv_setuv_mg
1342
1343Like C<sv_setuv>, but also handles 'set' magic.
1344
1345=cut
1346*/
1347
55497cff 1348void
864dbfa3 1349Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b 1350{
55ada374
NC		 1351 /* With these two if statements:
1352 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
d460ef45 1353
55ada374
NC		 1354 without
1355 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
d460ef45 1356
55ada374
NC		 1357 If you wish to remove them, please benchmark to see what the effect is
1358 */
28e5dec8
JH		 1359 if (u <= (UV)IV_MAX) {
1360 sv_setiv(sv, (IV)u);
1361 } else {
1362 sv_setiv(sv, 0);
1363 SvIsUV_on(sv);
1364 sv_setuv(sv,u);
1365 }
ef50df4b
GS		 1366 SvSETMAGIC(sv);
1367}
1368
954c1994
GS		 1369/*
1370=for apidoc sv_setnv
1371
1372Copies a double into the given SV. Does not handle 'set' magic. See
1373C<sv_setnv_mg>.
1374
1375=cut
1376*/
1377
ef50df4b 1378void
65202027 1379Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 1380{
2213622d 1381 SV_CHECK_THINKFIRST(sv);
a0d0e21e
LW		 1382 switch (SvTYPE(sv)) {
1383 case SVt_NULL:
1384 case SVt_IV:
79072805 1385 sv_upgrade(sv, SVt_NV);
a0d0e21e 1386 break;
a0d0e21e
LW		 1387 case SVt_RV:
1388 case SVt_PV:
1389 case SVt_PVIV:
79072805 1390 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 1391 break;
827b7e14 1392
a0d0e21e 1393 case SVt_PVGV:
a0d0e21e
LW		 1394 case SVt_PVAV:
1395 case SVt_PVHV:
1396 case SVt_PVCV:
1397 case SVt_PVFM:
1398 case SVt_PVIO:
411caa50
JH		 1399 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400 PL_op_name[PL_op->op_type]);
79072805 1401 }
463ee0b2 1402 SvNVX(sv) = num;
a0d0e21e 1403 (void)SvNOK_only(sv); /* validate number */
463ee0b2 1404 SvTAINT(sv);
79072805
LW		 1405}
1406
954c1994
GS		 1407/*
1408=for apidoc sv_setnv_mg
1409
1410Like C<sv_setnv>, but also handles 'set' magic.
1411
1412=cut
1413*/
1414
ef50df4b 1415void
65202027 1416Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS		 1417{
1418 sv_setnv(sv,num);
1419 SvSETMAGIC(sv);
1420}
1421
76e3520e 1422STATIC void
cea2e8a9 1423S_not_a_number(pTHX_ SV *sv)
a0d0e21e
LW		 1424{
1425 char tmpbuf[64];
1426 char *d = tmpbuf;
1427 char *s;
dc28f22b
GA		 1428 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429 /* each *s can expand to 4 chars + "...\0",
1430 i.e. need room for 8 chars */
a0d0e21e 1431
dc28f22b 1432 for (s = SvPVX(sv); *s && d < limit; s++) {
bbce6d69 1433 int ch = *s & 0xFF;
1434 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW		 1435 *d++ = 'M';
1436 *d++ = '-';
1437 ch &= 127;
1438 }
bbce6d69 1439 if (ch == '\n') {
1440 *d++ = '\\';
1441 *d++ = 'n';
1442 }
1443 else if (ch == '\r') {
1444 *d++ = '\\';
1445 *d++ = 'r';
1446 }
1447 else if (ch == '\f') {
1448 *d++ = '\\';
1449 *d++ = 'f';
1450 }
1451 else if (ch == '\\') {
1452 *d++ = '\\';
1453 *d++ = '\\';
1454 }
1455 else if (isPRINT_LC(ch))
a0d0e21e
LW		 1456 *d++ = ch;
1457 else {
1458 *d++ = '^';
bbce6d69 1459 *d++ = toCTRL(ch);
a0d0e21e
LW		 1460 }
1461 }
1462 if (*s) {
1463 *d++ = '.';
1464 *d++ = '.';
1465 *d++ = '.';
1466 }
1467 *d = '\0';
1468
533c011a 1469 if (PL_op)
42d38218
MS		 1470 Perl_warner(aTHX_ WARN_NUMERIC,
1471 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472 PL_op_desc[PL_op->op_type]);
a0d0e21e 1473 else
42d38218
MS		 1474 Perl_warner(aTHX_ WARN_NUMERIC,
1475 "Argument \"%s\" isn't numeric", tmpbuf);
a0d0e21e
LW		 1476}
1477
28e5dec8
JH		 1478/* the number can be converted to integer with atol() or atoll() although */
1479#define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1480#define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1481#define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1482#define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483#define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1484#define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1485#define IS_NUMBER_NEG 0x40 /* seen a leading - */
1486#define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
25da4f38
IZ		 1487
1488/* Actually, ISO C leaves conversion of UV to IV undefined, but
1489 until proven guilty, assume that things are not that bad... */
1490
28e5dec8
JH		 1491/* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492 an IV (an assumption perl has been based on to date) it becomes necessary
1493 to remove the assumption that the NV always carries enough precision to
1494 recreate the IV whenever needed, and that the NV is the canonical form.
1495 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496 precision as an side effect of conversion (which would lead to insanity
1497 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498 1) to distinguish between IV/UV/NV slots that have cached a valid
1499 conversion where precision was lost and IV/UV/NV slots that have a
1500 valid conversion which has lost no precision
1501 2) to ensure that if a numeric conversion to one form is request that
1502 would lose precision, the precise conversion (or differently
1503 imprecise conversion) is also performed and cached, to prevent
1504 requests for different numeric formats on the same SV causing
1505 lossy conversion chains. (lossless conversion chains are perfectly
1506 acceptable (still))
1507
1508
1509 flags are used:
1510 SvIOKp is true if the IV slot contains a valid value
1511 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1512 SvNOKp is true if the NV slot contains a valid value
1513 SvNOK is true only if the NV value is accurate
1514
1515 so
1516 while converting from PV to NV check to see if converting that NV to an
1517 IV(or UV) would lose accuracy over a direct conversion from PV to
1518 IV(or UV). If it would, cache both conversions, return NV, but mark
1519 SV as IOK NOKp (ie not NOK).
1520
1521 while converting from PV to IV check to see if converting that IV to an
1522 NV would lose accuracy over a direct conversion from PV to NV. If it
1523 would, cache both conversions, flag similarly.
1524
1525 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526 correctly because if IV & NV were set NV *always* overruled.
1527 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528 changes - now IV and NV together means that the two are interchangeable
1529 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
d460ef45 1530
28e5dec8
JH		 1531 The benefit of this is operations such as pp_add know that if SvIOK is
1532 true for both left and right operands, then integer addition can be
1533 used instead of floating point. (for cases where the result won't
1534 overflow) Before, floating point was always used, which could lead to
1535 loss of precision compared with integer addition.
1536
1537 * making IV and NV equal status should make maths accurate on 64 bit
1538 platforms
1539 * may speed up maths somewhat if pp_add and friends start to use
1540 integers when possible instead of fp. (hopefully the overhead in
1541 looking for SvIOK and checking for overflow will not outweigh the
1542 fp to integer speedup)
1543 * will slow down integer operations (callers of SvIV) on "inaccurate"
1544 values, as the change from SvIOK to SvIOKp will cause a call into
1545 sv_2iv each time rather than a macro access direct to the IV slot
1546 * should speed up number->string conversion on integers as IV is
1547 favoured when IV and NV equally accurate
1548
1549 ####################################################################
1550 You had better be using SvIOK_notUV if you want an IV for arithmetic
1551 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552 SvUOK is true iff UV.
1553 ####################################################################
1554
1555 Your mileage will vary depending your CPUs relative fp to integer
1556 performance ratio.
1557*/
1558
1559#ifndef NV_PRESERVES_UV
1560#define IS_NUMBER_UNDERFLOW_IV 1
1561#define IS_NUMBER_UNDERFLOW_UV 2
1562#define IS_NUMBER_IV_AND_UV 2
1563#define IS_NUMBER_OVERFLOW_IV 4
1564#define IS_NUMBER_OVERFLOW_UV 5
1565/* Hopefully your optimiser will consider inlining these two functions. */
1566STATIC int
1567S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1569 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
159fae86 1570 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		 1571 if (nv_as_uv <= (UV)IV_MAX) {
1572 (void)SvIOKp_on(sv);
1573 (void)SvNOKp_on(sv);
1574 /* Within suitable range to fit in an IV, atol won't overflow */
1575 /* XXX quite sure? Is that your final answer? not really, I'm
1576 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578 if (numtype & IS_NUMBER_NOT_INT) {
1579 /* I believe that even if the original PV had decimals, they
1580 are lost beyond the limit of the FP precision.
1581 However, neither is canonical, so both only get p flags.
1582 NWC, 2000/11/25 */
1583 /* Both already have p flags, so do nothing */
1584 } else if (SvIVX(sv) == I_V(nv)) {
1585 SvNOK_on(sv);
1586 SvIOK_on(sv);
1587 } else {
1588 SvIOK_on(sv);
1589 /* It had no "." so it must be integer. assert (get in here from
1590 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592 conversion routines need audit. */
1593 }
1594 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1595 }
1596 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597 (void)SvIOKp_on(sv);
1598 (void)SvNOKp_on(sv);
1599#ifdef HAS_STRTOUL
1600 {
1601 int save_errno = errno;
1602 errno = 0;
1603 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1604 if (errno == 0) {
1605 if (numtype & IS_NUMBER_NOT_INT) {
1606 /* UV and NV both imprecise. */
1607 SvIsUV_on(sv);
1608 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1609 SvNOK_on(sv);
1610 SvIOK_on(sv);
1611 SvIsUV_on(sv);
1612 } else {
1613 SvIOK_on(sv);
1614 SvIsUV_on(sv);
1615 }
1616 errno = save_errno;
1617 return IS_NUMBER_OVERFLOW_IV;
1618 }
1619 errno = save_errno;
1620 SvNOK_on(sv);
1621 /* Must have just overflowed UV, but not enough that an NV could spot
1622 this.. */
1623 return IS_NUMBER_OVERFLOW_UV;
1624 }
1625#else
1626 /* We've just lost integer precision, nothing we could do. */
1627 SvUVX(sv) = nv_as_uv;
159fae86 1628 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		 1629 /* UV and NV slots equally valid only if we have casting symmetry. */
1630 if (numtype & IS_NUMBER_NOT_INT) {
1631 SvIsUV_on(sv);
1632 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635 get to this point if NVs don't preserve UVs) */
1636 SvNOK_on(sv);
1637 SvIOK_on(sv);
1638 SvIsUV_on(sv);
1639 } else {
1640 /* As above, I believe UV at least as good as NV */
1641 SvIsUV_on(sv);
1642 }
1643#endif /* HAS_STRTOUL */
1644 return IS_NUMBER_OVERFLOW_IV;
1645}
1646
1647/* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1648STATIC int
1649S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1650{
159fae86 1651 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		 1652 if (SvNVX(sv) < (NV)IV_MIN) {
1653 (void)SvIOKp_on(sv);
1654 (void)SvNOK_on(sv);
1655 SvIVX(sv) = IV_MIN;
1656 return IS_NUMBER_UNDERFLOW_IV;
1657 }
1658 if (SvNVX(sv) > (NV)UV_MAX) {
1659 (void)SvIOKp_on(sv);
1660 (void)SvNOK_on(sv);
1661 SvIsUV_on(sv);
1662 SvUVX(sv) = UV_MAX;
1663 return IS_NUMBER_OVERFLOW_UV;
1664 }
1665 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666 (void)SvIOKp_on(sv);
1667 (void)SvNOK_on(sv);
1668 /* Can't use strtol etc to convert this string */
1669 if (SvNVX(sv) <= (UV)IV_MAX) {
1670 SvIVX(sv) = I_V(SvNVX(sv));
1671 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1673 } else {
1674 /* Integer is imprecise. NOK, IOKp */
1675 }
1676 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1677 }
1678 SvIsUV_on(sv);
1679 SvUVX(sv) = U_V(SvNVX(sv));
1680 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
09bb3e27
NC		 1681 if (SvUVX(sv) == UV_MAX) {
1682 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1683 possibly be preserved by NV. Hence, it must be overflow.
1684 NOK, IOKp */
1685 return IS_NUMBER_OVERFLOW_UV;
1686 }
28e5dec8
JH		 1687 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1688 } else {
1689 /* Integer is imprecise. NOK, IOKp */
1690 }
1691 return IS_NUMBER_OVERFLOW_IV;
1692 }
e57fe1aa 1693 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
28e5dec8
JH		 1694}
1695#endif /* NV_PRESERVES_UV*/
1696
a0d0e21e 1697IV
864dbfa3 1698Perl_sv_2iv(pTHX_ register SV *sv)
79072805
LW		 1699{
1700 if (!sv)
1701 return 0;
8990e307 1702 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1703 mg_get(sv);
1704 if (SvIOKp(sv))
1705 return SvIVX(sv);
748a9306 1706 if (SvNOKp(sv)) {
25da4f38 1707 return I_V(SvNVX(sv));
748a9306 1708 }
36477c24 1709 if (SvPOKp(sv) && SvLEN(sv))
1710 return asIV(sv);
3fe9a6f1 1711 if (!SvROK(sv)) {
d008e5eb 1712 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 1713 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1714 report_uninit();
c6ee37c5 1715 }
36477c24 1716 return 0;
3fe9a6f1 1717 }
463ee0b2 1718 }
ed6116ce 1719 if (SvTHINKFIRST(sv)) {
a0d0e21e 1720 if (SvROK(sv)) {
a0d0e21e 1721 SV* tmpstr;
1554e226
DC		 1722 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1723 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 1724 return SvIV(tmpstr);
56431972 1725 return PTR2IV(SvRV(sv));
a0d0e21e 1726 }
47deb5e7
NIS		 1727 if (SvREADONLY(sv) && SvFAKE(sv)) {
1728 sv_force_normal(sv);
1729 }
0336b60e 1730 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 1731 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1732 report_uninit();
ed6116ce
LW		 1733 return 0;
1734 }
79072805 1735 }
25da4f38
IZ		 1736 if (SvIOKp(sv)) {
1737 if (SvIsUV(sv)) {
1738 return (IV)(SvUVX(sv));
1739 }
1740 else {
1741 return SvIVX(sv);
1742 }
463ee0b2 1743 }
748a9306 1744 if (SvNOKp(sv)) {
28e5dec8
JH		 1745 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1746 * without also getting a cached IV/UV from it at the same time
1747 * (ie PV->NV conversion should detect loss of accuracy and cache
1748 * IV or UV at same time to avoid this. NWC */
25da4f38
IZ		 1749
1750 if (SvTYPE(sv) == SVt_NV)
1751 sv_upgrade(sv, SVt_PVNV);
1752
28e5dec8
JH		 1753 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1754 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1755 certainly cast into the IV range at IV_MAX, whereas the correct
1756 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1757 cases go to UV */
1758 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
748a9306 1759 SvIVX(sv) = I_V(SvNVX(sv));
28e5dec8
JH		 1760 if (SvNVX(sv) == (NV) SvIVX(sv)
1761#ifndef NV_PRESERVES_UV
1762 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1763 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1764 /* Don't flag it as "accurately an integer" if the number
1765 came from a (by definition imprecise) NV operation, and
1766 we're outside the range of NV integer precision */
1767#endif
1768 ) {
1769 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1770 DEBUG_c(PerlIO_printf(Perl_debug_log,
1771 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1772 PTR2UV(sv),
1773 SvNVX(sv),
1774 SvIVX(sv)));
1775
1776 } else {
1777 /* IV not precise. No need to convert from PV, as NV
1778 conversion would already have cached IV if it detected
1779 that PV->IV would be better than PV->NV->IV
1780 flags already correct - don't set public IOK. */
1781 DEBUG_c(PerlIO_printf(Perl_debug_log,
1782 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1783 PTR2UV(sv),
1784 SvNVX(sv),
1785 SvIVX(sv)));
1786 }
1787 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1788 but the cast (NV)IV_MIN rounds to a the value less (more
1789 negative) than IV_MIN which happens to be equal to SvNVX ??
1790 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1791 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1792 (NV)UVX == NVX are both true, but the values differ. :-(
1793 Hopefully for 2s complement IV_MIN is something like
1794 0x8000000000000000 which will be exact. NWC */
d460ef45 1795 }
25da4f38 1796 else {
ff68c719 1797 SvUVX(sv) = U_V(SvNVX(sv));
28e5dec8
JH		 1798 if (
1799 (SvNVX(sv) == (NV) SvUVX(sv))
1800#ifndef NV_PRESERVES_UV
1801 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1802 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1803 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1804 /* Don't flag it as "accurately an integer" if the number
1805 came from a (by definition imprecise) NV operation, and
1806 we're outside the range of NV integer precision */
1807#endif
1808 )
1809 SvIOK_on(sv);
25da4f38
IZ		 1810 SvIsUV_on(sv);
1811 ret_iv_max:
1c846c1f 1812 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 1813 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 1814 PTR2UV(sv),
57def98f
JH		 1815 SvUVX(sv),
1816 SvUVX(sv)));
25da4f38
IZ		 1817 return (IV)SvUVX(sv);
1818 }
748a9306
LW		 1819 }
1820 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1821 I32 numtype = looks_like_number(sv);
1822
1823 /* We want to avoid a possible problem when we cache an IV which
1824 may be later translated to an NV, and the resulting NV is not
1825 the translation of the initial data.
1c846c1f 1826
25da4f38
IZ		 1827 This means that if we cache such an IV, we need to cache the
1828 NV as well. Moreover, we trade speed for space, and do not
28e5dec8 1829 cache the NV if we are sure it's not needed.
25da4f38 1830 */
16b7a9a4 1831
28e5dec8
JH		 1832 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1833 /* The NV may be reconstructed from IV - safe to cache IV,
1834 which may be calculated by atol(). */
1835 if (SvTYPE(sv) < SVt_PVIV)
1836 sv_upgrade(sv, SVt_PVIV);
f7bbb42a 1837 (void)SvIOK_on(sv);
28e5dec8
JH		 1838 SvIVX(sv) = Atol(SvPVX(sv));
1839 } else {
1840#ifdef HAS_STRTOL
1841 IV i;
1842 int save_errno = errno;
1843 /* Is it an integer that we could convert with strtol?
1844 So try it, and if it doesn't set errno then it's pukka.
1845 This should be faster than going atof and then thinking. */
1846 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1847 == IS_NUMBER_TO_INT_BY_STRTOL)
1848 /* && is a sequence point. Without it not sure if I'm trying
1849 to do too much between sequence points and hence going
1850 undefined */
1851 && ((errno = 0), 1) /* , 1 so always true */
1852 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1853 && (errno == 0)) {
1854 if (SvTYPE(sv) < SVt_PVIV)
1855 sv_upgrade(sv, SVt_PVIV);
1856 (void)SvIOK_on(sv);
1857 SvIVX(sv) = i;
1858 errno = save_errno;
1859 } else
1860#endif
1861 {
1862 NV d;
1863#ifdef HAS_STRTOL
1864 /* Hopefully trace flow will optimise this away where possible
1865 */
1866 errno = save_errno;
1867#endif
1868 /* It wasn't an integer, or it overflowed, or we don't have
1869 strtol. Do things the slow way - check if it's a UV etc. */
1870 d = Atof(SvPVX(sv));
1871
1872 if (SvTYPE(sv) < SVt_PVNV)
1873 sv_upgrade(sv, SVt_PVNV);
1874 SvNVX(sv) = d;
1875
1876 if (! numtype && ckWARN(WARN_NUMERIC))
1877 not_a_number(sv);
1878
65202027 1879#if defined(USE_LONG_DOUBLE)
28e5dec8
JH		 1880 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1881 PTR2UV(sv), SvNVX(sv)));
65202027 1882#else
28e5dec8
JH		 1883 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1884 PTR2UV(sv), SvNVX(sv)));
65202027 1885#endif
28e5dec8
JH		 1886
1887
1888#ifdef NV_PRESERVES_UV
1889 (void)SvIOKp_on(sv);
1890 (void)SvNOK_on(sv);
1891 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1892 SvIVX(sv) = I_V(SvNVX(sv));
1893 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1894 SvIOK_on(sv);
1895 } else {
1896 /* Integer is imprecise. NOK, IOKp */
1897 }
1898 /* UV will not work better than IV */
1899 } else {
1900 if (SvNVX(sv) > (NV)UV_MAX) {
1901 SvIsUV_on(sv);
1902 /* Integer is inaccurate. NOK, IOKp, is UV */
1903 SvUVX(sv) = UV_MAX;
1904 SvIsUV_on(sv);
1905 } else {
1906 SvUVX(sv) = U_V(SvNVX(sv));
1907 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1908 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1909 SvIOK_on(sv);
1910 SvIsUV_on(sv);
1911 } else {
1912 /* Integer is imprecise. NOK, IOKp, is UV */
1913 SvIsUV_on(sv);
1914 }
1915 }
1916 goto ret_iv_max;
1917 }
1918#else /* NV_PRESERVES_UV */
1919 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1920 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1921 /* Small enough to preserve all bits. */
1922 (void)SvIOKp_on(sv);
1923 SvNOK_on(sv);
1924 SvIVX(sv) = I_V(SvNVX(sv));
1925 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1926 SvIOK_on(sv);
1927 /* Assumption: first non-preserved integer is < IV_MAX,
1928 this NV is in the preserved range, therefore: */
1929 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1930 < (UV)IV_MAX)) {
1931 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);
1932 }
1933 } else if (sv_2iuv_non_preserve (sv, numtype)
1934 >= IS_NUMBER_OVERFLOW_IV)
1935 goto ret_iv_max;
1936#endif /* NV_PRESERVES_UV */
25da4f38
IZ		 1937 }
1938 }
28e5dec8 1939 } else {
599cee73 1940 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1941 report_uninit();
25da4f38
IZ		 1942 if (SvTYPE(sv) < SVt_IV)
1943 /* Typically the caller expects that sv_any is not NULL now. */
1944 sv_upgrade(sv, SVt_IV);
a0d0e21e 1945 return 0;
79072805 1946 }
1d7c1841
GS		 1947 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1948 PTR2UV(sv),SvIVX(sv)));
25da4f38 1949 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW		 1950}
1951
ff68c719 1952UV
864dbfa3 1953Perl_sv_2uv(pTHX_ register SV *sv)
ff68c719 1954{
1955 if (!sv)
1956 return 0;
1957 if (SvGMAGICAL(sv)) {
1958 mg_get(sv);
1959 if (SvIOKp(sv))
1960 return SvUVX(sv);
1961 if (SvNOKp(sv))
1962 return U_V(SvNVX(sv));
36477c24 1963 if (SvPOKp(sv) && SvLEN(sv))
1964 return asUV(sv);
3fe9a6f1 1965 if (!SvROK(sv)) {
d008e5eb 1966 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 1967 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1968 report_uninit();
c6ee37c5 1969 }
36477c24 1970 return 0;
3fe9a6f1 1971 }
ff68c719 1972 }
1973 if (SvTHINKFIRST(sv)) {
1974 if (SvROK(sv)) {
ff68c719 1975 SV* tmpstr;
1554e226
DC		 1976 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1977 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 1978 return SvUV(tmpstr);
56431972 1979 return PTR2UV(SvRV(sv));
ff68c719 1980 }
8a818333
NIS		 1981 if (SvREADONLY(sv) && SvFAKE(sv)) {
1982 sv_force_normal(sv);
1983 }
0336b60e 1984 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 1985 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1986 report_uninit();
ff68c719 1987 return 0;
1988 }
1989 }
25da4f38
IZ		 1990 if (SvIOKp(sv)) {
1991 if (SvIsUV(sv)) {
1992 return SvUVX(sv);
1993 }
1994 else {
1995 return (UV)SvIVX(sv);
1996 }
ff68c719 1997 }
1998 if (SvNOKp(sv)) {
28e5dec8
JH		 1999 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2000 * without also getting a cached IV/UV from it at the same time
2001 * (ie PV->NV conversion should detect loss of accuracy and cache
2002 * IV or UV at same time to avoid this. */
2003 /* IV-over-UV optimisation - choose to cache IV if possible */
2004
25da4f38
IZ		 2005 if (SvTYPE(sv) == SVt_NV)
2006 sv_upgrade(sv, SVt_PVNV);
28e5dec8
JH		 2007
2008 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2009 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
f7bbb42a 2010 SvIVX(sv) = I_V(SvNVX(sv));
28e5dec8
JH		 2011 if (SvNVX(sv) == (NV) SvIVX(sv)
2012#ifndef NV_PRESERVES_UV
2013 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2014 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2015 /* Don't flag it as "accurately an integer" if the number
2016 came from a (by definition imprecise) NV operation, and
2017 we're outside the range of NV integer precision */
2018#endif
2019 ) {
2020 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2021 DEBUG_c(PerlIO_printf(Perl_debug_log,
2022 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2023 PTR2UV(sv),
2024 SvNVX(sv),
2025 SvIVX(sv)));
2026
2027 } else {
2028 /* IV not precise. No need to convert from PV, as NV
2029 conversion would already have cached IV if it detected
2030 that PV->IV would be better than PV->NV->IV
2031 flags already correct - don't set public IOK. */
2032 DEBUG_c(PerlIO_printf(Perl_debug_log,
2033 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2034 PTR2UV(sv),
2035 SvNVX(sv),
2036 SvIVX(sv)));
2037 }
2038 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2039 but the cast (NV)IV_MIN rounds to a the value less (more
2040 negative) than IV_MIN which happens to be equal to SvNVX ??
2041 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2042 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2043 (NV)UVX == NVX are both true, but the values differ. :-(
2044 Hopefully for 2s complement IV_MIN is something like
2045 0x8000000000000000 which will be exact. NWC */
d460ef45 2046 }
28e5dec8
JH		 2047 else {
2048 SvUVX(sv) = U_V(SvNVX(sv));
2049 if (
2050 (SvNVX(sv) == (NV) SvUVX(sv))
2051#ifndef NV_PRESERVES_UV
2052 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2053 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2054 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2055 /* Don't flag it as "accurately an integer" if the number
2056 came from a (by definition imprecise) NV operation, and
2057 we're outside the range of NV integer precision */
2058#endif
2059 )
2060 SvIOK_on(sv);
2061 SvIsUV_on(sv);
1c846c1f 2062 DEBUG_c(PerlIO_printf(Perl_debug_log,
28e5dec8 2063 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
57def98f 2064 PTR2UV(sv),
28e5dec8
JH		 2065 SvUVX(sv),
2066 SvUVX(sv)));
25da4f38 2067 }
ff68c719 2068 }
2069 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 2070 I32 numtype = looks_like_number(sv);
2071
2072 /* We want to avoid a possible problem when we cache a UV which
2073 may be later translated to an NV, and the resulting NV is not
2074 the translation of the initial data.
1c846c1f 2075
25da4f38
IZ		 2076 This means that if we cache such a UV, we need to cache the
2077 NV as well. Moreover, we trade speed for space, and do not
2078 cache the NV if not needed.
2079 */
16b7a9a4 2080
28e5dec8 2081 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
f7bbb42a 2082 /* The NV may be reconstructed from IV - safe to cache IV,
28e5dec8
JH		 2083 which may be calculated by atol(). */
2084 if (SvTYPE(sv) < SVt_PVIV)
f7bbb42a
JH		 2085 sv_upgrade(sv, SVt_PVIV);
2086 (void)SvIOK_on(sv);
28e5dec8
JH		 2087 SvIVX(sv) = Atol(SvPVX(sv));
2088 } else {
f7bbb42a 2089#ifdef HAS_STRTOUL
28e5dec8 2090 UV u;
f9172815 2091 char *num_begin = SvPVX(sv);
28e5dec8 2092 int save_errno = errno;
d460ef45 2093
f9172815
JH		 2094 /* seems that strtoul taking numbers that start with - is
2095 implementation dependant, and can't be relied upon. */
2096 if (numtype & IS_NUMBER_NEG) {
2097 /* Not totally defensive. assumine that looks_like_num
2098 didn't lie about a - sign */
2099 while (isSPACE(*num_begin))
2100 num_begin++;
2101 if (*num_begin == '-')
2102 num_begin++;
2103 }
d460ef45 2104
28e5dec8
JH		 2105 /* Is it an integer that we could convert with strtoul?
2106 So try it, and if it doesn't set errno then it's pukka.
2107 This should be faster than going atof and then thinking. */
2108 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2109 == IS_NUMBER_TO_INT_BY_STRTOL)
2110 && ((errno = 0), 1) /* always true */
f9172815 2111 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
28e5dec8 2112 && (errno == 0)
d460ef45 2113 /* If known to be negative, check it didn't undeflow IV
f9172815
JH		 2114 XXX possibly we should put more negative values as NVs
2115 direct rather than go via atof below */
2116 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
28e5dec8
JH		 2117 errno = save_errno;
2118
2119 if (SvTYPE(sv) < SVt_PVIV)
2120 sv_upgrade(sv, SVt_PVIV);
2121 (void)SvIOK_on(sv);
2122
2123 /* If it's negative must use IV.
2124 IV-over-UV optimisation */
f9172815
JH		 2125 if (numtype & IS_NUMBER_NEG) {
2126 SvIVX(sv) = -(IV)u;
2127 } else if (u <= (UV) IV_MAX) {
28e5dec8
JH		 2128 SvIVX(sv) = (IV)u;
2129 } else {
2130 /* it didn't overflow, and it was positive. */
2131 SvUVX(sv) = u;
2132 SvIsUV_on(sv);
2133 }
2134 } else
f7bbb42a 2135#endif
28e5dec8
JH		 2136 {
2137 NV d;
2138#ifdef HAS_STRTOUL
2139 /* Hopefully trace flow will optimise this away where possible
2140 */
2141 errno = save_errno;
2142#endif
2143 /* It wasn't an integer, or it overflowed, or we don't have
2144 strtol. Do things the slow way - check if it's a IV etc. */
2145 d = Atof(SvPVX(sv));
2146
2147 if (SvTYPE(sv) < SVt_PVNV)
2148 sv_upgrade(sv, SVt_PVNV);
2149 SvNVX(sv) = d;
2150
2151 if (! numtype && ckWARN(WARN_NUMERIC))
2152 not_a_number(sv);
2153
2154#if defined(USE_LONG_DOUBLE)
2155 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2156 PTR2UV(sv), SvNVX(sv)));
2157#else
2158 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2159 PTR2UV(sv), SvNVX(sv)));
2160#endif
2161
2162#ifdef NV_PRESERVES_UV
2163 (void)SvIOKp_on(sv);
2164 (void)SvNOK_on(sv);
2165 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2166 SvIVX(sv) = I_V(SvNVX(sv));
2167 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2168 SvIOK_on(sv);
2169 } else {
2170 /* Integer is imprecise. NOK, IOKp */
2171 }
2172 /* UV will not work better than IV */
2173 } else {
2174 if (SvNVX(sv) > (NV)UV_MAX) {
2175 SvIsUV_on(sv);
2176 /* Integer is inaccurate. NOK, IOKp, is UV */
2177 SvUVX(sv) = UV_MAX;
2178 SvIsUV_on(sv);
2179 } else {
2180 SvUVX(sv) = U_V(SvNVX(sv));
2181 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2182 NV preservse UV so can do correct comparison. */
2183 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2184 SvIOK_on(sv);
2185 SvIsUV_on(sv);
2186 } else {
2187 /* Integer is imprecise. NOK, IOKp, is UV */
2188 SvIsUV_on(sv);
2189 }
2190 }
2191 }
2192#else /* NV_PRESERVES_UV */
2193 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2194 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2195 /* Small enough to preserve all bits. */
2196 (void)SvIOKp_on(sv);
2197 SvNOK_on(sv);
2198 SvIVX(sv) = I_V(SvNVX(sv));
2199 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2200 SvIOK_on(sv);
2201 /* Assumption: first non-preserved integer is < IV_MAX,
2202 this NV is in the preserved range, therefore: */
2203 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2204 < (UV)IV_MAX)) {
2205 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);
2206 }
2207 } else
2208 sv_2iuv_non_preserve (sv, numtype);
2209#endif /* NV_PRESERVES_UV */
2210 }
f7bbb42a 2211 }
ff68c719 2212 }
2213 else {
d008e5eb 2214 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2215 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2216 report_uninit();
c6ee37c5 2217 }
25da4f38
IZ		 2218 if (SvTYPE(sv) < SVt_IV)
2219 /* Typically the caller expects that sv_any is not NULL now. */
2220 sv_upgrade(sv, SVt_IV);
ff68c719 2221 return 0;
2222 }
25da4f38 2223
1d7c1841
GS		 2224 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2225 PTR2UV(sv),SvUVX(sv)));
25da4f38 2226 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719 2227}
2228
65202027 2229NV
864dbfa3 2230Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW		 2231{
2232 if (!sv)
2233 return 0.0;
8990e307 2234 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 2235 mg_get(sv);
2236 if (SvNOKp(sv))
2237 return SvNVX(sv);
a0d0e21e 2238 if (SvPOKp(sv) && SvLEN(sv)) {
599cee73 2239 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 2240 not_a_number(sv);
097ee67d 2241 return Atof(SvPVX(sv));
a0d0e21e 2242 }
25da4f38 2243 if (SvIOKp(sv)) {
1c846c1f 2244 if (SvIsUV(sv))
65202027 2245 return (NV)SvUVX(sv);
25da4f38 2246 else
65202027 2247 return (NV)SvIVX(sv);
25da4f38 2248 }
16d20bd9 2249 if (!SvROK(sv)) {
d008e5eb 2250 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2251 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2252 report_uninit();
c6ee37c5 2253 }
16d20bd9
AD		 2254 return 0;
2255 }
463ee0b2 2256 }
ed6116ce 2257 if (SvTHINKFIRST(sv)) {
a0d0e21e 2258 if (SvROK(sv)) {
a0d0e21e 2259 SV* tmpstr;
1554e226
DC		 2260 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2261 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 2262 return SvNV(tmpstr);
56431972 2263 return PTR2NV(SvRV(sv));
a0d0e21e 2264 }
8a818333
NIS		 2265 if (SvREADONLY(sv) && SvFAKE(sv)) {
2266 sv_force_normal(sv);
2267 }
0336b60e 2268 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 2269 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2270 report_uninit();
ed6116ce
LW		 2271 return 0.0;
2272 }
79072805
LW		 2273 }
2274 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW		 2275 if (SvTYPE(sv) == SVt_IV)
2276 sv_upgrade(sv, SVt_PVNV);
2277 else
2278 sv_upgrade(sv, SVt_NV);
572bbb43 2279#if defined(USE_LONG_DOUBLE)
097ee67d 2280 DEBUG_c({
f93f4e46 2281 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2282 PerlIO_printf(Perl_debug_log,
2283 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2284 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 2285 RESTORE_NUMERIC_LOCAL();
2286 });
65202027 2287#else
572bbb43 2288 DEBUG_c({
f93f4e46 2289 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2290 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2291 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 2292 RESTORE_NUMERIC_LOCAL();
2293 });
572bbb43 2294#endif
79072805
LW		 2295 }
2296 else if (SvTYPE(sv) < SVt_PVNV)
2297 sv_upgrade(sv, SVt_PVNV);
748a9306
LW		 2298 if (SvIOKp(sv) &&
2299 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 2300 {
65202027 2301 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
28e5dec8
JH		 2302#ifdef NV_PRESERVES_UV
2303 SvNOK_on(sv);
2304#else
2305 /* Only set the public NV OK flag if this NV preserves the IV */
2306 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2307 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2308 : (SvIVX(sv) == I_V(SvNVX(sv))))
2309 SvNOK_on(sv);
2310 else
2311 SvNOKp_on(sv);
2312#endif
93a17b20 2313 }
748a9306 2314 else if (SvPOKp(sv) && SvLEN(sv)) {
599cee73 2315 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 2316 not_a_number(sv);
097ee67d 2317 SvNVX(sv) = Atof(SvPVX(sv));
28e5dec8
JH		 2318#ifdef NV_PRESERVES_UV
2319 SvNOK_on(sv);
2320#else
2321 /* Only set the public NV OK flag if this NV preserves the value in
2322 the PV at least as well as an IV/UV would.
2323 Not sure how to do this 100% reliably. */
2324 /* if that shift count is out of range then Configure's test is
2325 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2326 UV_BITS */
2327 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2328 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2329 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2330 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2331 /* Definitely too large/small to fit in an integer, so no loss
2332 of precision going to integer in the future via NV */
2333 SvNOK_on(sv);
2334 } else {
2335 /* Is it something we can run through strtol etc (ie no
2336 trailing exponent part)? */
2337 int numtype = looks_like_number(sv);
2338 /* XXX probably should cache this if called above */
2339
2340 if (!(numtype &
2341 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2342 /* Can't use strtol etc to convert this string, so don't try */
2343 SvNOK_on(sv);
2344 } else
2345 sv_2inuv_non_preserve (sv, numtype);
2346 }
2347#endif /* NV_PRESERVES_UV */
93a17b20 2348 }
79072805 2349 else {
599cee73 2350 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2351 report_uninit();
25da4f38
IZ		 2352 if (SvTYPE(sv) < SVt_NV)
2353 /* Typically the caller expects that sv_any is not NULL now. */
28e5dec8
JH		 2354 /* XXX Ilya implies that this is a bug in callers that assume this
2355 and ideally should be fixed. */
25da4f38 2356 sv_upgrade(sv, SVt_NV);
a0d0e21e 2357 return 0.0;
79072805 2358 }
572bbb43 2359#if defined(USE_LONG_DOUBLE)
097ee67d 2360 DEBUG_c({
f93f4e46 2361 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2362 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2363 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 2364 RESTORE_NUMERIC_LOCAL();
2365 });
65202027 2366#else
572bbb43 2367 DEBUG_c({
f93f4e46 2368 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2369 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2370 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 2371 RESTORE_NUMERIC_LOCAL();
2372 });
572bbb43 2373#endif
463ee0b2 2374 return SvNVX(sv);
79072805
LW		 2375}
2376
76e3520e 2377STATIC IV
cea2e8a9 2378S_asIV(pTHX_ SV *sv)
36477c24 2379{
2380 I32 numtype = looks_like_number(sv);
65202027 2381 NV d;
36477c24 2382
25da4f38 2383 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 2384 return Atol(SvPVX(sv));
d008e5eb 2385 if (!numtype) {
d008e5eb
GS		 2386 if (ckWARN(WARN_NUMERIC))
2387 not_a_number(sv);
2388 }
097ee67d 2389 d = Atof(SvPVX(sv));
25da4f38 2390 return I_V(d);
36477c24 2391}
2392
76e3520e 2393STATIC UV
cea2e8a9 2394S_asUV(pTHX_ SV *sv)
36477c24 2395{
2396 I32 numtype = looks_like_number(sv);
2397
84902520 2398#ifdef HAS_STRTOUL
25da4f38 2399 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 2400 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 2401#endif
d008e5eb 2402 if (!numtype) {
d008e5eb
GS		 2403 if (ckWARN(WARN_NUMERIC))
2404 not_a_number(sv);
2405 }
097ee67d 2406 return U_V(Atof(SvPVX(sv)));
36477c24 2407}
2408
25da4f38
IZ		 2409/*
2410 * Returns a combination of (advisory only - can get false negatives)
28e5dec8
JH		 2411 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2412 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2413 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
25da4f38
IZ		 2414 * 0 if does not look like number.
2415 *
28e5dec8
JH		 2416 * (atol and strtol stop when they hit a decimal point. strtol will return
2417 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2418 * do this, and vendors have had 11 years to get it right.
2419 * However, will try to make it still work with only atol
d460ef45 2420 *
28e5dec8
JH		 2421 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2422 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2423 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2424 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2425 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2426 * IS_NUMBER_NOT_INT saw "." or "e"
2427 * IS_NUMBER_NEG
300aed98 2428 * IS_NUMBER_INFINITY
25da4f38
IZ		 2429 */
2430
954c1994
GS		 2431/*
2432=for apidoc looks_like_number
2433
2434Test if an the content of an SV looks like a number (or is a
28e5dec8
JH		 2435number). C<Inf> and C<Infinity> are treated as numbers (so will not
2436issue a non-numeric warning), even if your atof() doesn't grok them.
954c1994
GS		 2437
2438=cut
2439*/
2440
36477c24 2441I32
864dbfa3 2442Perl_looks_like_number(pTHX_ SV *sv)
36477c24 2443{
2444 register char *s;
2445 register char *send;
2446 register char *sbegin;
25da4f38
IZ		 2447 register char *nbegin;
2448 I32 numtype = 0;
300aed98 2449 I32 sawinf = 0;
36477c24 2450 STRLEN len;
9c7192ba 2451#ifdef USE_LOCALE_NUMERIC
eff180cd 2452 bool specialradix = FALSE;
9c7192ba 2453#endif
36477c24 2454
2455 if (SvPOK(sv)) {
1c846c1f 2456 sbegin = SvPVX(sv);
36477c24 2457 len = SvCUR(sv);
2458 }
2459 else if (SvPOKp(sv))
2460 sbegin = SvPV(sv, len);
2461 else
2462 return 1;
2463 send = sbegin + len;
2464
2465 s = sbegin;
2466 while (isSPACE(*s))
2467 s++;
25da4f38
IZ		 2468 if (*s == '-') {
2469 s++;
2470 numtype = IS_NUMBER_NEG;
2471 }
2472 else if (*s == '+')
36477c24 2473 s++;
ff0cee69 2474
25da4f38
IZ		 2475 nbegin = s;
2476 /*
d460ef45 2477 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
28e5dec8
JH		 2478 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2479 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2480 * will need (int)atof().
25da4f38
IZ		 2481 */
2482
300aed98 2483 /* next must be digit or the radix separator or beginning of infinity */
ff0cee69 2484 if (isDIGIT(*s)) {
2485 do {
2486 s++;
2487 } while (isDIGIT(*s));
25da4f38 2488
28e5dec8
JH		 2489 /* Aaargh. long long really is irritating.
2490 In the gospel according to ANSI 1989, it is an axiom that "long"
2491 is the longest integer type, and that if you don't know how long
2492 something is you can cast it to long, and nothing will be lost
2493 (except possibly speed of execution if long is slower than the
2494 type is was).
2495 Now, one can't be sure if the old rules apply, or long long
2496 (or some other newfangled thing) is actually longer than the
2497 (formerly) longest thing.
2498 */
2499 /* This lot will work for 64 bit *as long as* either
2500 either long is 64 bit
2501 or we can find both strtol/strtoq and strtoul/strtouq
2502 If not, we really should refuse to let the user use 64 bit IVs
2503 By "64 bit" I really mean IVs that don't get preserved by NVs
2504 It also should work for 128 bit IVs. Can any lend me a machine to
2505 test this?
2506 */
2507 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2508 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2509 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2510 ? sizeof(long) : sizeof (IV))*8-1))
f7bbb42a 2511 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
28e5dec8
JH		 2512 else
2513 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2514 digit less (IV_MAX= 9223372036854775807,
2515 UV_MAX= 18446744073709551615) so be cautious */
2516 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
25da4f38 2517
097ee67d 2518 if (*s == '.'
1c846c1f 2519#ifdef USE_LOCALE_NUMERIC
eff180cd 2520 || (specialradix = IS_NUMERIC_RADIX(s))
097ee67d
JH		 2521#endif
2522 ) {
9c7192ba 2523#ifdef USE_LOCALE_NUMERIC
eff180cd
JH		 2524 if (specialradix)
2525 s += SvCUR(PL_numeric_radix);
2526 else
9c7192ba 2527#endif
eff180cd 2528 s++;
28e5dec8 2529 numtype |= IS_NUMBER_NOT_INT;
097ee67d 2530 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69 2531 s++;
2532 }
36477c24 2533 }
097ee67d 2534 else if (*s == '.'
1c846c1f 2535#ifdef USE_LOCALE_NUMERIC
eff180cd 2536 || (specialradix = IS_NUMERIC_RADIX(s))
097ee67d
JH		 2537#endif
2538 ) {
9c7192ba 2539#ifdef USE_LOCALE_NUMERIC
eff180cd
JH		 2540 if (specialradix)
2541 s += SvCUR(PL_numeric_radix);
2542 else
9c7192ba 2543#endif
eff180cd 2544 s++;
28e5dec8 2545 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
097ee67d 2546 /* no digits before the radix means we need digits after it */
ff0cee69 2547 if (isDIGIT(*s)) {
2548 do {
2549 s++;
2550 } while (isDIGIT(*s));
2551 }
2552 else
2553 return 0;
2554 }
300aed98
JH		 2555 else if (*s == 'I' || *s == 'i') {
2556 s++; if (*s != 'N' && *s != 'n') return 0;
2557 s++; if (*s != 'F' && *s != 'f') return 0;
2558 s++; if (*s == 'I' || *s == 'i') {
2559 s++; if (*s != 'N' && *s != 'n') return 0;
2560 s++; if (*s != 'I' && *s != 'i') return 0;
2561 s++; if (*s != 'T' && *s != 't') return 0;
2562 s++; if (*s != 'Y' && *s != 'y') return 0;
99938567 2563 s++;
300aed98
JH		 2564 }
2565 sawinf = 1;
2566 }
ff0cee69 2567 else
2568 return 0;
2569
300aed98 2570 if (sawinf)
28e5dec8
JH		 2571 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2572 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
300aed98
JH		 2573 else {
2574 /* we can have an optional exponent part */
2575 if (*s == 'e' || *s == 'E') {
28e5dec8
JH		 2576 numtype &= IS_NUMBER_NEG;
2577 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
36477c24 2578 s++;
300aed98
JH		 2579 if (*s == '+' || *s == '-')
2580 s++;
2581 if (isDIGIT(*s)) {
2582 do {
2583 s++;
2584 } while (isDIGIT(*s));
2585 }
2586 else
2587 return 0;
2588 }
36477c24 2589 }
2590 while (isSPACE(*s))
2591 s++;
80f3f388 2592 if (s >= send)
36477c24 2593 return numtype;
2594 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 2595 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24 2596 return 0;
2597}
2598
79072805 2599char *
864dbfa3 2600Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD		 2601{
2602 STRLEN n_a;
2603 return sv_2pv(sv, &n_a);
2604}
2605
25da4f38 2606/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 2607static char *
25da4f38
IZ		 2608uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2609{
25da4f38
IZ		 2610 char *ptr = buf + TYPE_CHARS(UV);
2611 char *ebuf = ptr;
2612 int sign;
25da4f38
IZ		 2613
2614 if (is_uv)
2615 sign = 0;
2616 else if (iv >= 0) {
2617 uv = iv;
2618 sign = 0;
2619 } else {
2620 uv = -iv;
2621 sign = 1;
2622 }
2623 do {
2624 *--ptr = '0' + (uv % 10);
2625 } while (uv /= 10);
2626 if (sign)
2627 *--ptr = '-';
2628 *peob = ebuf;
2629 return ptr;
2630}
2631
1fa8b10d 2632char *
864dbfa3 2633Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805
LW		 2634{
2635 register char *s;
2636 int olderrno;
46fc3d4c 2637 SV *tsv;
25da4f38
IZ		 2638 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2639 char *tmpbuf = tbuf;
79072805 2640
463ee0b2
LW		 2641 if (!sv) {
2642 *lp = 0;
2643 return "";
2644 }
8990e307 2645 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 2646 mg_get(sv);
2647 if (SvPOKp(sv)) {
2648 *lp = SvCUR(sv);
2649 return SvPVX(sv);
2650 }
cf2093f6 2651 if (SvIOKp(sv)) {
1c846c1f 2652 if (SvIsUV(sv))
57def98f 2653 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2654 else
57def98f 2655 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2656 tsv = Nullsv;
a0d0e21e 2657 goto tokensave;
463ee0b2
LW		 2658 }
2659 if (SvNOKp(sv)) {
2d4389e4 2660 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2661 tsv = Nullsv;
a0d0e21e 2662 goto tokensave;
463ee0b2 2663 }
16d20bd9 2664 if (!SvROK(sv)) {
d008e5eb 2665 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2666 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2667 report_uninit();
c6ee37c5 2668 }
16d20bd9
AD		 2669 *lp = 0;
2670 return "";
2671 }
463ee0b2 2672 }
ed6116ce
LW		 2673 if (SvTHINKFIRST(sv)) {
2674 if (SvROK(sv)) {
a0d0e21e 2675 SV* tmpstr;
1554e226
DC		 2676 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2677 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 2678 return SvPV(tmpstr,*lp);
ed6116ce
LW		 2679 sv = (SV*)SvRV(sv);
2680 if (!sv)
2681 s = "NULLREF";
2682 else {
f9277f47
IZ		 2683 MAGIC *mg;
2684
ed6116ce 2685 switch (SvTYPE(sv)) {
f9277f47
IZ		 2686 case SVt_PVMG:
2687 if ( ((SvFLAGS(sv) &
1c846c1f 2688 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2689 == (SVs_OBJECT|SVs_RMG))
57668c4d 2690 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
f9277f47 2691 && (mg = mg_find(sv, 'r'))) {
2cd61cdb 2692 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2693
2cd61cdb 2694 if (!mg->mg_ptr) {
8782bef2
GB		 2695 char *fptr = "msix";
2696 char reflags[6];
2697 char ch;
2698 int left = 0;
2699 int right = 4;
2700 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2701
155aba94 2702 while((ch = *fptr++)) {
8782bef2
GB		 2703 if(reganch & 1) {
2704 reflags[left++] = ch;
2705 }
2706 else {
2707 reflags[right--] = ch;
2708 }
2709 reganch >>= 1;
2710 }
2711 if(left != 4) {
2712 reflags[left] = '-';
2713 left = 5;
2714 }
2715
2716 mg->mg_len = re->prelen + 4 + left;
2717 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2718 Copy("(?", mg->mg_ptr, 2, char);
2719 Copy(reflags, mg->mg_ptr+2, left, char);
2720 Copy(":", mg->mg_ptr+left+2, 1, char);
2721 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ		 2722 mg->mg_ptr[mg->mg_len - 1] = ')';
2723 mg->mg_ptr[mg->mg_len] = 0;
2724 }
3280af22 2725 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ		 2726 *lp = mg->mg_len;
2727 return mg->mg_ptr;
f9277f47
IZ		 2728 }
2729 /* Fall through */
ed6116ce
LW		 2730 case SVt_NULL:
2731 case SVt_IV:
2732 case SVt_NV:
2733 case SVt_RV:
2734 case SVt_PV:
2735 case SVt_PVIV:
2736 case SVt_PVNV:
81689caa
HS		 2737 case SVt_PVBM: if (SvROK(sv))
2738 s = "REF";
2739 else
2740 s = "SCALAR"; break;
ed6116ce
LW		 2741 case SVt_PVLV: s = "LVALUE"; break;
2742 case SVt_PVAV: s = "ARRAY"; break;
2743 case SVt_PVHV: s = "HASH"; break;
2744 case SVt_PVCV: s = "CODE"; break;
2745 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2746 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2747 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW		 2748 default: s = "UNKNOWN"; break;
2749 }
46fc3d4c 2750 tsv = NEWSV(0,0);
ed6116ce 2751 if (SvOBJECT(sv))
cea2e8a9 2752 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2753 else
46fc3d4c 2754 sv_setpv(tsv, s);
57def98f 2755 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2756 goto tokensaveref;
463ee0b2 2757 }
ed6116ce
LW		 2758 *lp = strlen(s);
2759 return s;
79072805 2760 }
0336b60e 2761 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2762 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2763 report_uninit();
ed6116ce
LW		 2764 *lp = 0;
2765 return "";
79072805 2766 }
79072805 2767 }
28e5dec8
JH		 2768 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2769 /* I'm assuming that if both IV and NV are equally valid then
2770 converting the IV is going to be more efficient */
2771 U32 isIOK = SvIOK(sv);
2772 U32 isUIOK = SvIsUV(sv);
2773 char buf[TYPE_CHARS(UV)];
2774 char *ebuf, *ptr;
2775
2776 if (SvTYPE(sv) < SVt_PVIV)
2777 sv_upgrade(sv, SVt_PVIV);
2778 if (isUIOK)
2779 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2780 else
2781 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2782 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2783 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2784 SvCUR_set(sv, ebuf - ptr);
2785 s = SvEND(sv);
2786 *s = '\0';
2787 if (isIOK)
2788 SvIOK_on(sv);
2789 else
2790 SvIOKp_on(sv);
2791 if (isUIOK)
2792 SvIsUV_on(sv);
2793 }
2794 else if (SvNOKp(sv)) {
79072805
LW		 2795 if (SvTYPE(sv) < SVt_PVNV)
2796 sv_upgrade(sv, SVt_PVNV);
1c846c1f 2797 /* The +20 is pure guesswork. Configure test needed. --jhi */
59155cc0 2798 SvGROW(sv, NV_DIG + 20);
463ee0b2 2799 s = SvPVX(sv);
79072805 2800 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2801#ifdef apollo
463ee0b2 2802 if (SvNVX(sv) == 0.0)
79072805
LW		 2803 (void)strcpy(s,"0");
2804 else
2805#endif /*apollo*/
bbce6d69 2806 {
2d4389e4 2807 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2808 }
79072805 2809 errno = olderrno;
a0d0e21e
LW		 2810#ifdef FIXNEGATIVEZERO
2811 if (*s == '-' && s[1] == '0' && !s[2])
2812 strcpy(s,"0");
2813#endif
79072805
LW		 2814 while (*s) s++;
2815#ifdef hcx
2816 if (s[-1] == '.')
46fc3d4c 2817 *--s = '\0';
79072805
LW		 2818#endif
2819 }
79072805 2820 else {
0336b60e
IZ		 2821 if (ckWARN(WARN_UNINITIALIZED)
2822 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2823 report_uninit();
a0d0e21e 2824 *lp = 0;
25da4f38
IZ		 2825 if (SvTYPE(sv) < SVt_PV)
2826 /* Typically the caller expects that sv_any is not NULL now. */
2827 sv_upgrade(sv, SVt_PV);
a0d0e21e 2828 return "";
79072805 2829 }
463ee0b2
LW		 2830 *lp = s - SvPVX(sv);
2831 SvCUR_set(sv, *lp);
79072805 2832 SvPOK_on(sv);
1d7c1841
GS		 2833 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2834 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2835 return SvPVX(sv);
a0d0e21e
LW		 2836
2837 tokensave:
2838 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2839 /* Sneaky stuff here */
2840
2841 tokensaveref:
46fc3d4c 2842 if (!tsv)
96827780 2843 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 2844 sv_2mortal(tsv);
2845 *lp = SvCUR(tsv);
2846 return SvPVX(tsv);
a0d0e21e
LW		 2847 }
2848 else {
2849 STRLEN len;
46fc3d4c 2850 char *t;
2851
2852 if (tsv) {
2853 sv_2mortal(tsv);
2854 t = SvPVX(tsv);
2855 len = SvCUR(tsv);
2856 }
2857 else {
96827780
MB		 2858 t = tmpbuf;
2859 len = strlen(tmpbuf);
46fc3d4c 2860 }
a0d0e21e 2861#ifdef FIXNEGATIVEZERO
46fc3d4c 2862 if (len == 2 && t[0] == '-' && t[1] == '0') {
2863 t = "0";
2864 len = 1;
2865 }
a0d0e21e
LW		 2866#endif
2867 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2868 *lp = len;
a0d0e21e
LW		 2869 s = SvGROW(sv, len + 1);
2870 SvCUR_set(sv, len);
46fc3d4c 2871 (void)strcpy(s, t);
6bf554b4 2872 SvPOKp_on(sv);
a0d0e21e
LW		 2873 return s;
2874 }
463ee0b2
LW		 2875}
2876
7340a771
GS		 2877char *
2878Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2879{
560a288e
GS		 2880 STRLEN n_a;
2881 return sv_2pvbyte(sv, &n_a);
7340a771
GS		 2882}
2883
2884char *
2885Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2886{
2887 return sv_2pv(sv,lp);
2888}
2889
2890char *
2891Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2892{
560a288e
GS		 2893 STRLEN n_a;
2894 return sv_2pvutf8(sv, &n_a);
7340a771
GS		 2895}
2896
2897char *
2898Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2899{
560a288e 2900 sv_utf8_upgrade(sv);
7d59b7e4 2901 return SvPV(sv,*lp);
7340a771 2902}
1c846c1f 2903
463ee0b2
LW		 2904/* This function is only called on magical items */
2905bool
864dbfa3 2906Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2907{
8990e307 2908 if (SvGMAGICAL(sv))
463ee0b2
LW		 2909 mg_get(sv);
2910
a0d0e21e
LW		 2911 if (!SvOK(sv))
2912 return 0;
2913 if (SvROK(sv)) {
a0d0e21e 2914 SV* tmpsv;
1554e226
DC		 2915 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2916 (SvRV(tmpsv) != SvRV(sv)))
9e7bc3e8 2917 return SvTRUE(tmpsv);
a0d0e21e
LW		 2918 return SvRV(sv) != 0;
2919 }
463ee0b2 2920 if (SvPOKp(sv)) {
11343788
MB		 2921 register XPV* Xpvtmp;
2922 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2923 (*Xpvtmp->xpv_pv > '0' ||
2924 Xpvtmp->xpv_cur > 1 ||
2925 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW		 2926 return 1;
2927 else
2928 return 0;
2929 }
2930 else {
2931 if (SvIOKp(sv))
2932 return SvIVX(sv) != 0;
2933 else {
2934 if (SvNOKp(sv))
2935 return SvNVX(sv) != 0.0;
2936 else
2937 return FALSE;
2938 }
2939 }
79072805
LW		 2940}
2941
c461cf8f
JH		 2942/*
2943=for apidoc sv_utf8_upgrade
2944
2945Convert the PV of an SV to its UTF8-encoded form.
2946
2947=cut
2948*/
2949
560a288e
GS		 2950void
2951Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2952{
511c2ff0
NIS		 2953 char *s, *t, *e;
2954 int hibit = 0;
560a288e 2955
0c981600 2956 if (!sv || !SvPOK(sv) || SvUTF8(sv))
560a288e
GS		 2957 return;
2958
40826f67
JH		 2959 /* This function could be much more efficient if we had a FLAG in SVs
2960 * to signal if there are any hibit chars in the PV.
511c2ff0 2961 * Given that there isn't make loop fast as possible
560a288e 2962 */
511c2ff0
NIS		 2963 s = SvPVX(sv);
2964 e = SvEND(sv);
2965 t = s;
2966 while (t < e) {
fd400ab9 2967 if ((hibit = UTF8_IS_CONTINUED(*t++)))
8a818333 2968 break;
8a818333 2969 }
560a288e 2970
40826f67 2971 if (hibit) {
8a818333 2972 STRLEN len;
652088fc 2973
8a818333 2974 if (SvREADONLY(sv) && SvFAKE(sv)) {
8a818333
NIS		 2975 sv_force_normal(sv);
2976 s = SvPVX(sv);
2977 }
2978 len = SvCUR(sv) + 1; /* Plus the \0 */
00df9076 2979 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
841d7a39 2980 SvCUR(sv) = len - 1;
511c2ff0
NIS		 2981 if (SvLEN(sv) != 0)
2982 Safefree(s); /* No longer using what was there before. */
841d7a39 2983 SvLEN(sv) = len; /* No longer know the real size. */
560a288e
GS		 2984 SvUTF8_on(sv);
2985 }
2986}
2987
c461cf8f
JH		 2988/*
2989=for apidoc sv_utf8_downgrade
2990
2991Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2992This may not be possible if the PV contains non-byte encoding characters;
2993if this is the case, either returns false or, if C<fail_ok> is not
2994true, croaks.
2995
2996=cut
2997*/
2998
560a288e
GS		 2999bool
3000Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3001{
3002 if (SvPOK(sv) && SvUTF8(sv)) {
fa301091 3003 if (SvCUR(sv)) {
652088fc
JH		 3004 char *s;
3005 STRLEN len;
fa301091 3006
652088fc
JH		 3007 if (SvREADONLY(sv) && SvFAKE(sv))
3008 sv_force_normal(sv);
3009 s = SvPV(sv, len);
3010 if (!utf8_to_bytes((U8*)s, &len)) {
fa301091
JH		 3011 if (fail_ok)
3012 return FALSE;
3013 else {
3014 if (PL_op)
3015 Perl_croak(aTHX_ "Wide character in %s",
3016 PL_op_desc[PL_op->op_type]);
3017 else
3018 Perl_croak(aTHX_ "Wide character");
3019 }
4b3603a4 3020 }
fa301091 3021 SvCUR(sv) = len;
67e989fb 3022 }
9f9ab905 3023 SvUTF8_off(sv);
560a288e 3024 }
fa301091 3025
560a288e
GS		 3026 return TRUE;
3027}
3028
c461cf8f
JH		 3029/*
3030=for apidoc sv_utf8_encode
3031
3032Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
1c846c1f 3033flag so that it looks like bytes again. Nothing calls this.
c461cf8f
JH		 3034
3035=cut
3036*/
3037
560a288e
GS		 3038void
3039Perl_sv_utf8_encode(pTHX_ register SV *sv)
3040{
3041 sv_utf8_upgrade(sv);
3042 SvUTF8_off(sv);
3043}
3044
3045bool
3046Perl_sv_utf8_decode(pTHX_ register SV *sv)
3047{
3048 if (SvPOK(sv)) {
3049 char *c;
511c2ff0 3050 char *e;
9cbac4c7 3051
560a288e
GS		 3052 if (!sv_utf8_downgrade(sv, TRUE))
3053 return FALSE;
3054
3055 /* it is actually just a matter of turning the utf8 flag on, but
3056 * we want to make sure everything inside is valid utf8 first.
3057 */
3058 c = SvPVX(sv);
00df9076 3059 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
67e989fb 3060 return FALSE;
511c2ff0
NIS		 3061 e = SvEND(sv);
3062 while (c < e) {
fd400ab9 3063 if (UTF8_IS_CONTINUED(*c++)) {
67e989fb
JH		 3064 SvUTF8_on(sv);
3065 break;
3066 }
560a288e 3067 }
560a288e
GS		 3068 }
3069 return TRUE;
3070}
3071
3072
79072805 3073/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 3074 * to be reused, since it may destroy the source string if it is marked
79072805
LW		 3075 * as temporary.
3076 */
3077
954c1994
GS		 3078/*
3079=for apidoc sv_setsv
3080
3081Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3082The source SV may be destroyed if it is mortal. Does not handle 'set'
3083magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3084C<sv_setsv_mg>.
3085
3086=cut
3087*/
3088
79072805 3089void
864dbfa3 3090Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 3091{
8990e307
LW		 3092 register U32 sflags;
3093 register int dtype;
3094 register int stype;
463ee0b2 3095
79072805
LW		 3096 if (sstr == dstr)
3097 return;
2213622d 3098 SV_CHECK_THINKFIRST(dstr);
79072805 3099 if (!sstr)
3280af22 3100 sstr = &PL_sv_undef;
8990e307
LW		 3101 stype = SvTYPE(sstr);
3102 dtype = SvTYPE(dstr);
79072805 3103
a0d0e21e 3104 SvAMAGIC_off(dstr);
9e7bc3e8 3105
463ee0b2 3106 /* There's a lot of redundancy below but we're going for speed here */
79072805 3107
8990e307 3108 switch (stype) {
79072805 3109 case SVt_NULL:
aece5585 3110 undef_sstr:
20408e3c
GS		 3111 if (dtype != SVt_PVGV) {
3112 (void)SvOK_off(dstr);
3113 return;
3114 }
3115 break;
463ee0b2 3116 case SVt_IV:
aece5585
GA		 3117 if (SvIOK(sstr)) {
3118 switch (dtype) {
3119 case SVt_NULL:
8990e307 3120 sv_upgrade(dstr, SVt_IV);
aece5585
GA		 3121 break;
3122 case SVt_NV:
8990e307 3123 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 3124 break;
3125 case SVt_RV:
3126 case SVt_PV:
a0d0e21e 3127 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA		 3128 break;
3129 }
3130 (void)SvIOK_only(dstr);
3131 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 3132 if (SvIsUV(sstr))
3133 SvIsUV_on(dstr);
27c9684d
AP		 3134 if (SvTAINTED(sstr))
3135 SvTAINT(dstr);
aece5585 3136 return;
8990e307 3137 }
aece5585
GA		 3138 goto undef_sstr;
3139
463ee0b2 3140 case SVt_NV:
aece5585
GA		 3141 if (SvNOK(sstr)) {
3142 switch (dtype) {
3143 case SVt_NULL:
3144 case SVt_IV:
8990e307 3145 sv_upgrade(dstr, SVt_NV);
aece5585
GA		 3146 break;
3147 case SVt_RV:
3148 case SVt_PV:
3149 case SVt_PVIV:
a0d0e21e 3150 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 3151 break;
3152 }
3153 SvNVX(dstr) = SvNVX(sstr);
3154 (void)SvNOK_only(dstr);
27c9684d
AP		 3155 if (SvTAINTED(sstr))
3156 SvTAINT(dstr);
aece5585 3157 return;
8990e307 3158 }
aece5585
GA		 3159 goto undef_sstr;
3160
ed6116ce 3161 case SVt_RV:
8990e307 3162 if (dtype < SVt_RV)
ed6116ce 3163 sv_upgrade(dstr, SVt_RV);
c07a80fd 3164 else if (dtype == SVt_PVGV &&
3165 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3166 sstr = SvRV(sstr);
a5f75d66 3167 if (sstr == dstr) {
1d7c1841
GS		 3168 if (GvIMPORTED(dstr) != GVf_IMPORTED
3169 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3170 {
a5f75d66 3171 GvIMPORTED_on(dstr);
1d7c1841 3172 }
a5f75d66
AD		 3173 GvMULTI_on(dstr);
3174 return;
3175 }
c07a80fd 3176 goto glob_assign;
3177 }
ed6116ce 3178 break;
463ee0b2 3179 case SVt_PV:
fc36a67e 3180 case SVt_PVFM:
8990e307 3181 if (dtype < SVt_PV)
463ee0b2 3182 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW		 3183 break;
3184 case SVt_PVIV:
8990e307 3185 if (dtype < SVt_PVIV)
463ee0b2 3186 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW		 3187 break;
3188 case SVt_PVNV:
8990e307 3189 if (dtype < SVt_PVNV)
463ee0b2 3190 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 3191 break;
4633a7c4
LW		 3192 case SVt_PVAV:
3193 case SVt_PVHV:
3194 case SVt_PVCV:
4633a7c4 3195 case SVt_PVIO:
533c011a 3196 if (PL_op)
cea2e8a9 3197 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 3198 PL_op_name[PL_op->op_type]);
4633a7c4 3199 else
cea2e8a9 3200 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW		 3201 break;
3202
79072805 3203 case SVt_PVGV:
8990e307 3204 if (dtype <= SVt_PVGV) {
c07a80fd 3205 glob_assign:
a5f75d66 3206 if (dtype != SVt_PVGV) {
a0d0e21e
LW		 3207 char *name = GvNAME(sstr);
3208 STRLEN len = GvNAMELEN(sstr);
463ee0b2 3209 sv_upgrade(dstr, SVt_PVGV);
6662521e 3210 sv_magic(dstr, dstr, '*', Nullch, 0);
85aff577 3211 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW		 3212 GvNAME(dstr) = savepvn(name, len);
3213 GvNAMELEN(dstr) = len;
3214 SvFAKE_on(dstr); /* can coerce to non-glob */
3215 }
7bac28a0 3216 /* ahem, death to those who redefine active sort subs */
3280af22
NIS		 3217 else if (PL_curstackinfo->si_type == PERLSI_SORT
3218 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 3219 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 3220 GvNAME(dstr));
5bd07a3d
DM		 3221
3222#ifdef GV_SHARED_CHECK
3223 if (GvSHARED((GV*)dstr)) {
3224 Perl_croak(aTHX_ PL_no_modify);
3225 }
3226#endif
3227
a0d0e21e 3228 (void)SvOK_off(dstr);
a5f75d66 3229 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 3230 gp_free((GV*)dstr);
79072805 3231 GvGP(dstr) = gp_ref(GvGP(sstr));
27c9684d
AP		 3232 if (SvTAINTED(sstr))
3233 SvTAINT(dstr);
1d7c1841
GS		 3234 if (GvIMPORTED(dstr) != GVf_IMPORTED
3235 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3236 {
a5f75d66 3237 GvIMPORTED_on(dstr);
1d7c1841 3238 }
a5f75d66 3239 GvMULTI_on(dstr);
79072805
LW		 3240 return;
3241 }
3242 /* FALL THROUGH */
3243
3244 default:
973f89ab
CS		 3245 if (SvGMAGICAL(sstr)) {
3246 mg_get(sstr);
3247 if (SvTYPE(sstr) != stype) {
3248 stype = SvTYPE(sstr);
3249 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3250 goto glob_assign;
3251 }
3252 }
ded42b9f 3253 if (stype == SVt_PVLV)
6fc92669 3254 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 3255 else
6fc92669 3256 (void)SvUPGRADE(dstr, stype);
79072805
LW		 3257 }
3258
8990e307
LW		 3259 sflags = SvFLAGS(sstr);
3260
3261 if (sflags & SVf_ROK) {
3262 if (dtype >= SVt_PV) {
3263 if (dtype == SVt_PVGV) {
3264 SV *sref = SvREFCNT_inc(SvRV(sstr));
3265 SV *dref = 0;
a5f75d66 3266 int intro = GvINTRO(dstr);
a0d0e21e 3267
5bd07a3d
DM		 3268#ifdef GV_SHARED_CHECK
3269 if (GvSHARED((GV*)dstr)) {
3270 Perl_croak(aTHX_ PL_no_modify);
3271 }
3272#endif
3273
a0d0e21e
LW		 3274 if (intro) {
3275 GP *gp;
1d7c1841 3276 gp_free((GV*)dstr);
a5f75d66 3277 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 3278 Newz(602,gp, 1, GP);
44a8e56a 3279 GvGP(dstr) = gp_ref(gp);
a0d0e21e 3280 GvSV(dstr) = NEWSV(72,0);
1d7c1841 3281 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 3282 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 3283 }
a5f75d66 3284 GvMULTI_on(dstr);
8990e307
LW		 3285 switch (SvTYPE(sref)) {
3286 case SVt_PVAV:
a0d0e21e
LW		 3287 if (intro)
3288 SAVESPTR(GvAV(dstr));
3289 else
3290 dref = (SV*)GvAV(dstr);
8990e307 3291 GvAV(dstr) = (AV*)sref;
39bac7f7 3292 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS		 3293 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3294 {
a5f75d66 3295 GvIMPORTED_AV_on(dstr);
1d7c1841 3296 }
8990e307
LW		 3297 break;
3298 case SVt_PVHV:
a0d0e21e
LW		 3299 if (intro)
3300 SAVESPTR(GvHV(dstr));
3301 else
3302 dref = (SV*)GvHV(dstr);
8990e307 3303 GvHV(dstr) = (HV*)sref;
39bac7f7 3304 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS		 3305 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3306 {
a5f75d66 3307 GvIMPORTED_HV_on(dstr);
1d7c1841 3308 }
8990e307
LW		 3309 break;
3310 case SVt_PVCV:
8ebc5c01 3311 if (intro) {
3312 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3313 SvREFCNT_dec(GvCV(dstr));
3314 GvCV(dstr) = Nullcv;
68dc0745 3315 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 3316 PL_sub_generation++;
8ebc5c01 3317 }
a0d0e21e 3318 SAVESPTR(GvCV(dstr));
8ebc5c01 3319 }
68dc0745 3320 else
3321 dref = (SV*)GvCV(dstr);
3322 if (GvCV(dstr) != (CV*)sref) {
748a9306 3323 CV* cv = GvCV(dstr);
4633a7c4 3324 if (cv) {
68dc0745 3325 if (!GvCVGEN((GV*)dstr) &&
3326 (CvROOT(cv) || CvXSUB(cv)))
3327 {
7bac28a0 3328 /* ahem, death to those who redefine
3329 * active sort subs */
3280af22
NIS		 3330 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3331 PL_sortcop == CvSTART(cv))
1c846c1f 3332 Perl_croak(aTHX_
7bac28a0 3333 "Can't redefine active sort subroutine %s",
3334 GvENAME((GV*)dstr));
beab0874
JT		 3335 /* Redefining a sub - warning is mandatory if
3336 it was a const and its value changed. */
3337 if (ckWARN(WARN_REDEFINE)
3338 || (CvCONST(cv)
3339 && (!CvCONST((CV*)sref)
3340 || sv_cmp(cv_const_sv(cv),
3341 cv_const_sv((CV*)sref)))))
3342 {
3343 Perl_warner(aTHX_ WARN_REDEFINE,
3344 CvCONST(cv)
3345 ? "Constant subroutine %s redefined"
47deb5e7 3346 : "Subroutine %s redefined",
beab0874
JT		 3347 GvENAME((GV*)dstr));
3348 }
9607fc9c 3349 }
3fe9a6f1 3350 cv_ckproto(cv, (GV*)dstr,
3351 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 3352 }
a5f75d66 3353 GvCV(dstr) = (CV*)sref;
7a4c00b4 3354 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 3355 GvASSUMECV_on(dstr);
3280af22 3356 PL_sub_generation++;
a5f75d66 3357 }
39bac7f7 3358 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS		 3359 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3360 {
a5f75d66 3361 GvIMPORTED_CV_on(dstr);
1d7c1841 3362 }
8990e307 3363 break;
91bba347
LW		 3364 case SVt_PVIO:
3365 if (intro)
3366 SAVESPTR(GvIOp(dstr));
3367 else
3368 dref = (SV*)GvIOp(dstr);
3369 GvIOp(dstr) = (IO*)sref;
3370 break;
f4d13ee9
JH		 3371 case SVt_PVFM:
3372 if (intro)
3373 SAVESPTR(GvFORM(dstr));
3374 else
3375 dref = (SV*)GvFORM(dstr);
3376 GvFORM(dstr) = (CV*)sref;
3377 break;
8990e307 3378 default:
a0d0e21e
LW		 3379 if (intro)
3380 SAVESPTR(GvSV(dstr));
3381 else
3382 dref = (SV*)GvSV(dstr);
8990e307 3383 GvSV(dstr) = sref;
39bac7f7 3384 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS		 3385 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3386 {
a5f75d66 3387 GvIMPORTED_SV_on(dstr);
1d7c1841 3388 }
8990e307
LW		 3389 break;
3390 }
3391 if (dref)
3392 SvREFCNT_dec(dref);
a0d0e21e
LW		 3393 if (intro)
3394 SAVEFREESV(sref);
27c9684d
AP		 3395 if (SvTAINTED(sstr))
3396 SvTAINT(dstr);
8990e307
LW		 3397 return;
3398 }
a0d0e21e 3399 if (SvPVX(dstr)) {
760ac839 3400 (void)SvOOK_off(dstr); /* backoff */
50483b2c
JD		 3401 if (SvLEN(dstr))
3402 Safefree(SvPVX(dstr));
a0d0e21e
LW		 3403 SvLEN(dstr)=SvCUR(dstr)=0;
3404 }
8990e307 3405 }
a0d0e21e 3406 (void)SvOK_off(dstr);
8990e307 3407 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 3408 SvROK_on(dstr);
8990e307 3409 if (sflags & SVp_NOK) {
3332b3c1
JH		 3410 SvNOKp_on(dstr);
3411 /* Only set the public OK flag if the source has public OK. */
3412 if (sflags & SVf_NOK)
3413 SvFLAGS(dstr) |= SVf_NOK;
ed6116ce
LW		 3414 SvNVX(dstr) = SvNVX(sstr);
3415 }
8990e307 3416 if (sflags & SVp_IOK) {
3332b3c1
JH		 3417 (void)SvIOKp_on(dstr);
3418 if (sflags & SVf_IOK)
3419 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3420 if (sflags & SVf_IVisUV)
25da4f38 3421 SvIsUV_on(dstr);
3332b3c1 3422 SvIVX(dstr) = SvIVX(sstr);
ed6116ce 3423 }
a0d0e21e
LW		 3424 if (SvAMAGIC(sstr)) {
3425 SvAMAGIC_on(dstr);
3426 }
ed6116ce 3427 }
8990e307 3428 else if (sflags & SVp_POK) {
79072805
LW		 3429
3430 /*
3431 * Check to see if we can just swipe the string. If so, it's a
3432 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW		 3433 * It might even be a win on short strings if SvPVX(dstr)
3434 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW		 3435 */
3436
ff68c719 3437 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 3438 SvREFCNT(sstr) == 1 && /* and no other references to it? */
1c846c1f 3439 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4c8f17b9
BH		 3440 SvLEN(sstr) && /* and really is a string */
3441 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
a5f75d66 3442 {
adbc6bb1 3443 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD		 3444 if (SvOOK(dstr)) {
3445 SvFLAGS(dstr) &= ~SVf_OOK;
3446 Safefree(SvPVX(dstr) - SvIVX(dstr));
3447 }
50483b2c 3448 else if (SvLEN(dstr))
a5f75d66 3449 Safefree(SvPVX(dstr));
79072805 3450 }
a5f75d66 3451 (void)SvPOK_only(dstr);
463ee0b2 3452 SvPV_set(dstr, SvPVX(sstr));
79072805
LW		 3453 SvLEN_set(dstr, SvLEN(sstr));
3454 SvCUR_set(dstr, SvCUR(sstr));
f4e86e0f 3455
79072805 3456 SvTEMP_off(dstr);
2b1c7e3e 3457 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
79072805
LW		 3458 SvPV_set(sstr, Nullch);
3459 SvLEN_set(sstr, 0);
a5f75d66
AD		 3460 SvCUR_set(sstr, 0);
3461 SvTEMP_off(sstr);
79072805
LW		 3462 }
3463 else { /* have to copy actual string */
8990e307
LW		 3464 STRLEN len = SvCUR(sstr);
3465
3466 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3467 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3468 SvCUR_set(dstr, len);
3469 *SvEND(dstr) = '\0';
a0d0e21e 3470 (void)SvPOK_only(dstr);
79072805 3471 }
9aa983d2 3472 if (sflags & SVf_UTF8)
a7cb1f99 3473 SvUTF8_on(dstr);
79072805 3474 /*SUPPRESS 560*/
8990e307 3475 if (sflags & SVp_NOK) {
3332b3c1
JH		 3476 SvNOKp_on(dstr);
3477 if (sflags & SVf_NOK)
3478 SvFLAGS(dstr) |= SVf_NOK;
463ee0b2 3479 SvNVX(dstr) = SvNVX(sstr);
79072805 3480 }
8990e307 3481 if (sflags & SVp_IOK) {
3332b3c1
JH		 3482 (void)SvIOKp_on(dstr);
3483 if (sflags & SVf_IOK)
3484 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3485 if (sflags & SVf_IVisUV)
25da4f38 3486 SvIsUV_on(dstr);
463ee0b2 3487 SvIVX(dstr) = SvIVX(sstr);
79072805
LW		 3488 }
3489 }
8990e307 3490 else if (sflags & SVp_IOK) {
3332b3c1
JH		 3491 if (sflags & SVf_IOK)
3492 (void)SvIOK_only(dstr);
3493 else {
9cbac4c7
DM		 3494 (void)SvOK_off(dstr);
3495 (void)SvIOKp_on(dstr);
3332b3c1
JH		 3496 }
3497 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2b1c7e3e 3498 if (sflags & SVf_IVisUV)
25da4f38 3499 SvIsUV_on(dstr);
3332b3c1
JH		 3500 SvIVX(dstr) = SvIVX(sstr);
3501 if (sflags & SVp_NOK) {
3502 if (sflags & SVf_NOK)
3503 (void)SvNOK_on(dstr);
3504 else
3505 (void)SvNOKp_on(dstr);
3506 SvNVX(dstr) = SvNVX(sstr);
3507 }
3508 }
3509 else if (sflags & SVp_NOK) {
3510 if (sflags & SVf_NOK)
3511 (void)SvNOK_only(dstr);
3512 else {
9cbac4c7 3513 (void)SvOK_off(dstr);
3332b3c1
JH		 3514 SvNOKp_on(dstr);
3515 }
3516 SvNVX(dstr) = SvNVX(sstr);
79072805
LW		 3517 }
3518 else {
20408e3c 3519 if (dtype == SVt_PVGV) {
e476b1b5
GS		 3520 if (ckWARN(WARN_MISC))
3521 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
20408e3c
GS		 3522 }
3523 else
3524 (void)SvOK_off(dstr);
a0d0e21e 3525 }
27c9684d
AP		 3526 if (SvTAINTED(sstr))
3527 SvTAINT(dstr);
79072805
LW		 3528}
3529
954c1994
GS		 3530/*
3531=for apidoc sv_setsv_mg
3532
3533Like C<sv_setsv>, but also handles 'set' magic.
3534
3535=cut
3536*/
3537
79072805 3538void
864dbfa3 3539Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 3540{
3541 sv_setsv(dstr,sstr);
3542 SvSETMAGIC(dstr);
3543}
3544
954c1994
GS		 3545/*
3546=for apidoc sv_setpvn
3547
3548Copies a string into an SV. The C<len> parameter indicates the number of
3549bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3550
3551=cut
3552*/
3553
ef50df4b 3554void
864dbfa3 3555Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3556{
c6f8c383 3557 register char *dptr;
22c522df 3558
2213622d 3559 SV_CHECK_THINKFIRST(sv);
463ee0b2 3560 if (!ptr) {
a0d0e21e 3561 (void)SvOK_off(sv);
463ee0b2
LW		 3562 return;
3563 }
22c522df
JH		 3564 else {
3565 /* len is STRLEN which is unsigned, need to copy to signed */
3566 IV iv = len;
3567 assert(iv >= 0);
3568 }
6fc92669 3569 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 3570
79072805 3571 SvGROW(sv, len + 1);
c6f8c383
GA		 3572 dptr = SvPVX(sv);
3573 Move(ptr,dptr,len,char);
3574 dptr[len] = '\0';
79072805 3575 SvCUR_set(sv, len);
1aa99e6b 3576 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3577 SvTAINT(sv);
79072805
LW		 3578}
3579
954c1994
GS		 3580/*
3581=for apidoc sv_setpvn_mg
3582
3583Like C<sv_setpvn>, but also handles 'set' magic.
3584
3585=cut
3586*/
3587
79072805 3588void
864dbfa3 3589Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3590{
3591 sv_setpvn(sv,ptr,len);
3592 SvSETMAGIC(sv);
3593}
3594
954c1994
GS		 3595/*
3596=for apidoc sv_setpv
3597
3598Copies a string into an SV. The string must be null-terminated. Does not
3599handle 'set' magic. See C<sv_setpv_mg>.
3600
3601=cut
3602*/
3603
ef50df4b 3604void
864dbfa3 3605Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 3606{
3607 register STRLEN len;
3608
2213622d 3609 SV_CHECK_THINKFIRST(sv);
463ee0b2 3610 if (!ptr) {
a0d0e21e 3611 (void)SvOK_off(sv);
463ee0b2
LW		 3612 return;
3613 }
79072805 3614 len = strlen(ptr);
6fc92669 3615 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 3616
79072805 3617 SvGROW(sv, len + 1);
463ee0b2 3618 Move(ptr,SvPVX(sv),len+1,char);
79072805 3619 SvCUR_set(sv, len);
1aa99e6b 3620 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2
LW		 3621 SvTAINT(sv);
3622}
3623
954c1994
GS		 3624/*
3625=for apidoc sv_setpv_mg
3626
3627Like C<sv_setpv>, but also handles 'set' magic.
3628
3629=cut
3630*/
3631
463ee0b2 3632void
864dbfa3 3633Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS		 3634{
3635 sv_setpv(sv,ptr);
3636 SvSETMAGIC(sv);
3637}
3638
954c1994
GS		 3639/*
3640=for apidoc sv_usepvn
3641
3642Tells an SV to use C<ptr> to find its string value. Normally the string is
1c846c1f 3643stored inside the SV but sv_usepvn allows the SV to use an outside string.
954c1994
GS		 3644The C<ptr> should point to memory that was allocated by C<malloc>. The
3645string length, C<len>, must be supplied. This function will realloc the
3646memory pointed to by C<ptr>, so that pointer should not be freed or used by
3647the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3648See C<sv_usepvn_mg>.
3649
3650=cut
3651*/
3652
ef50df4b 3653void
864dbfa3 3654Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 3655{
2213622d 3656 SV_CHECK_THINKFIRST(sv);
c6f8c383 3657 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 3658 if (!ptr) {
a0d0e21e 3659 (void)SvOK_off(sv);
463ee0b2
LW		 3660 return;
3661 }
a0ed51b3 3662 (void)SvOOK_off(sv);
50483b2c 3663 if (SvPVX(sv) && SvLEN(sv))
463ee0b2
LW		 3664 Safefree(SvPVX(sv));
3665 Renew(ptr, len+1, char);
3666 SvPVX(sv) = ptr;
3667 SvCUR_set(sv, len);
3668 SvLEN_set(sv, len+1);
3669 *SvEND(sv) = '\0';
1aa99e6b 3670 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3671 SvTAINT(sv);
79072805
LW		 3672}
3673
954c1994
GS		 3674/*
3675=for apidoc sv_usepvn_mg
3676
3677Like C<sv_usepvn>, but also handles 'set' magic.
3678
3679=cut
3680*/
3681
ef50df4b 3682void
864dbfa3 3683Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 3684{
51c1089b 3685 sv_usepvn(sv,ptr,len);
ef50df4b
GS		 3686 SvSETMAGIC(sv);
3687}
3688
6fc92669 3689void
840a7b70 3690Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
0f15f207 3691{
2213622d 3692 if (SvREADONLY(sv)) {
1c846c1f
NIS		 3693 if (SvFAKE(sv)) {
3694 char *pvx = SvPVX(sv);
3695 STRLEN len = SvCUR(sv);
3696 U32 hash = SvUVX(sv);
3697 SvGROW(sv, len + 1);
3698 Move(pvx,SvPVX(sv),len,char);
3699 *SvEND(sv) = '\0';
3700 SvFAKE_off(sv);
3701 SvREADONLY_off(sv);
c3654f1a 3702 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
1c846c1f
NIS		 3703 }
3704 else if (PL_curcop != &PL_compiling)
cea2e8a9 3705 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3706 }
2213622d 3707 if (SvROK(sv))
840a7b70 3708 sv_unref_flags(sv, flags);
6fc92669
GS		 3709 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3710 sv_unglob(sv);
0f15f207 3711}
1c846c1f 3712
840a7b70
IZ		 3713void
3714Perl_sv_force_normal(pTHX_ register SV *sv)
3715{
3716 sv_force_normal_flags(sv, 0);
3717}
3718
954c1994
GS		 3719/*
3720=for apidoc sv_chop
3721
1c846c1f 3722Efficient removal of characters from the beginning of the string buffer.
954c1994
GS		 3723SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3724the string buffer. The C<ptr> becomes the first character of the adjusted
3725string.
3726
3727=cut
3728*/
3729
79072805 3730void
864dbfa3 3731Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
1c846c1f
NIS		 3732
3733
79072805
LW		 3734{
3735 register STRLEN delta;
3736
a0d0e21e 3737 if (!ptr || !SvPOKp(sv))
79072805 3738 return;
2213622d 3739 SV_CHECK_THINKFIRST(sv);
79072805
LW		 3740 if (SvTYPE(sv) < SVt_PVIV)
3741 sv_upgrade(sv,SVt_PVIV);
3742
3743 if (!SvOOK(sv)) {
50483b2c
JD		 3744 if (!SvLEN(sv)) { /* make copy of shared string */
3745 char *pvx = SvPVX(sv);
3746 STRLEN len = SvCUR(sv);
3747 SvGROW(sv, len + 1);
3748 Move(pvx,SvPVX(sv),len,char);
3749 *SvEND(sv) = '\0';
3750 }
463ee0b2 3751 SvIVX(sv) = 0;
79072805
LW		 3752 SvFLAGS(sv) |= SVf_OOK;
3753 }
25da4f38 3754 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
463ee0b2 3755 delta = ptr - SvPVX(sv);
79072805
LW		 3756 SvLEN(sv) -= delta;
3757 SvCUR(sv) -= delta;
463ee0b2
LW		 3758 SvPVX(sv) += delta;
3759 SvIVX(sv) += delta;
79072805
LW		 3760}
3761
954c1994
GS		 3762/*
3763=for apidoc sv_catpvn
3764
3765Concatenates the string onto the end of the string which is in the SV. The
3766C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3767'set' magic. See C<sv_catpvn_mg>.
3768
3769=cut
3770*/
3771
79072805 3772void
864dbfa3 3773Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3774{
463ee0b2 3775 STRLEN tlen;
748a9306 3776 char *junk;
a0d0e21e 3777
748a9306 3778 junk = SvPV_force(sv, tlen);
463ee0b2 3779 SvGROW(sv, tlen + len + 1);
4633a7c4
LW		 3780 if (ptr == junk)
3781 ptr = SvPVX(sv);
463ee0b2 3782 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW		 3783 SvCUR(sv) += len;
3784 *SvEND(sv) = '\0';
d41ff1b8 3785 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3786 SvTAINT(sv);
79072805
LW		 3787}
3788
954c1994
GS		 3789/*
3790=for apidoc sv_catpvn_mg
3791
3792Like C<sv_catpvn>, but also handles 'set' magic.
3793
3794=cut
3795*/
3796
79072805 3797void
864dbfa3 3798Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3799{
3800 sv_catpvn(sv,ptr,len);
3801 SvSETMAGIC(sv);
3802}
3803
954c1994
GS		 3804/*
3805=for apidoc sv_catsv
3806
13e8c8e3
JH		 3807Concatenates the string from SV C<ssv> onto the end of the string in
3808SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3809not 'set' magic. See C<sv_catsv_mg>.
954c1994 3810
13e8c8e3 3811=cut */
954c1994 3812
ef50df4b 3813void
46199a12 3814Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
79072805 3815{
13e8c8e3
JH		 3816 char *spv;
3817 STRLEN slen;
46199a12 3818 if (!ssv)
79072805 3819 return;
46199a12
JH		 3820 if ((spv = SvPV(ssv, slen))) {
3821 bool dutf8 = DO_UTF8(dsv);
3822 bool sutf8 = DO_UTF8(ssv);
13e8c8e3
JH		 3823
3824 if (dutf8 == sutf8)
46199a12 3825 sv_catpvn(dsv,spv,slen);
13e8c8e3
JH		 3826 else {
3827 if (dutf8) {
46199a12
JH		 3828 /* Not modifying source SV, so taking a temporary copy. */
3829 SV* csv = sv_2mortal(newSVsv(ssv));
13e8c8e3
JH		 3830 char *cpv;
3831 STRLEN clen;
3832
46199a12
JH		 3833 sv_utf8_upgrade(csv);
3834 cpv = SvPV(csv,clen);
3835 sv_catpvn(dsv,cpv,clen);
13e8c8e3
JH		 3836 }
3837 else {
46199a12
JH		 3838 sv_utf8_upgrade(dsv);
3839 sv_catpvn(dsv,spv,slen);
3840 SvUTF8_on(dsv); /* If dsv has no wide characters. */
13e8c8e3 3841 }
e84ff256 3842 }
560a288e 3843 }
79072805
LW		 3844}
3845
954c1994
GS		 3846/*
3847=for apidoc sv_catsv_mg
3848
3849Like C<sv_catsv>, but also handles 'set' magic.
3850
3851=cut
3852*/
3853
79072805 3854void
46199a12 3855Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
ef50df4b 3856{
46199a12
JH		 3857 sv_catsv(dsv,ssv);
3858 SvSETMAGIC(dsv);
ef50df4b
GS		 3859}
3860
954c1994
GS		 3861/*
3862=for apidoc sv_catpv
3863
3864Concatenates the string onto the end of the string which is in the SV.
3865Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3866
3867=cut
3868*/
3869
ef50df4b 3870void
0c981600 3871Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 3872{
3873 register STRLEN len;
463ee0b2 3874 STRLEN tlen;
748a9306 3875 char *junk;
79072805 3876
0c981600 3877 if (!ptr)
79072805 3878 return;
748a9306 3879 junk = SvPV_force(sv, tlen);
0c981600 3880 len = strlen(ptr);
463ee0b2 3881 SvGROW(sv, tlen + len + 1);
0c981600
JH		 3882 if (ptr == junk)
3883 ptr = SvPVX(sv);
3884 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 3885 SvCUR(sv) += len;
d41ff1b8 3886 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3887 SvTAINT(sv);
79072805
LW		 3888}
3889
954c1994
GS		 3890/*
3891=for apidoc sv_catpv_mg
3892
3893Like C<sv_catpv>, but also handles 'set' magic.
3894
3895=cut
3896*/
3897
ef50df4b 3898void
0c981600 3899Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b 3900{
0c981600 3901 sv_catpv(sv,ptr);
ef50df4b
GS		 3902 SvSETMAGIC(sv);
3903}
3904
79072805 3905SV *
864dbfa3 3906Perl_newSV(pTHX_ STRLEN len)
79072805
LW		 3907{
3908 register SV *sv;
1c846c1f 3909
4561caa4 3910 new_SV(sv);
79072805
LW		 3911 if (len) {
3912 sv_upgrade(sv, SVt_PV);
3913 SvGROW(sv, len + 1);
3914 }
3915 return sv;
3916}
3917
1edc1566 3918/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3919
954c1994
GS		 3920/*
3921=for apidoc sv_magic
3922
3923Adds magic to an SV.
3924
3925=cut
3926*/
3927
79072805 3928void
864dbfa3 3929Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
79072805
LW		 3930{
3931 MAGIC* mg;
1c846c1f 3932
0f15f207 3933 if (SvREADONLY(sv)) {
3280af22 3934 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
cea2e8a9 3935 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3936 }
4633a7c4 3937 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW		 3938 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3939 if (how == 't')
565764a8 3940 mg->mg_len |= 1;
463ee0b2 3941 return;
748a9306 3942 }
463ee0b2
LW		 3943 }
3944 else {
c6f8c383 3945 (void)SvUPGRADE(sv, SVt_PVMG);
463ee0b2 3946 }
79072805
LW		 3947 Newz(702,mg, 1, MAGIC);
3948 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 3949
79072805 3950 SvMAGIC(sv) = mg;
c277df42 3951 if (!obj || obj == sv || how == '#' || how == 'r')
8990e307 3952 mg->mg_obj = obj;
85e6fe83 3953 else {
8990e307 3954 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW		 3955 mg->mg_flags |= MGf_REFCOUNTED;
3956 }
79072805 3957 mg->mg_type = how;
565764a8 3958 mg->mg_len = namlen;
9cbac4c7 3959 if (name) {
1edc1566 3960 if (namlen >= 0)
3961 mg->mg_ptr = savepvn(name, namlen);
c6ee37c5 3962 else if (namlen == HEf_SVKEY)
1edc1566 3963 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
9cbac4c7 3964 }
1c846c1f 3965
79072805
LW		 3966 switch (how) {
3967 case 0:
22c35a8c 3968 mg->mg_virtual = &PL_vtbl_sv;
79072805 3969 break;
a0d0e21e 3970 case 'A':
22c35a8c 3971 mg->mg_virtual = &PL_vtbl_amagic;
a0d0e21e
LW		 3972 break;
3973 case 'a':
22c35a8c 3974 mg->mg_virtual = &PL_vtbl_amagicelem;
a0d0e21e
LW		 3975 break;
3976 case 'c':
d460ef45 3977 mg->mg_virtual = &PL_vtbl_ovrld;
a0d0e21e 3978 break;
79072805 3979 case 'B':
22c35a8c 3980 mg->mg_virtual = &PL_vtbl_bm;
79072805 3981 break;
6cef1e77 3982 case 'D':
22c35a8c 3983 mg->mg_virtual = &PL_vtbl_regdata;
6cef1e77
IZ		 3984 break;
3985 case 'd':
22c35a8c 3986 mg->mg_virtual = &PL_vtbl_regdatum;
6cef1e77 3987 break;
79072805 3988 case 'E':
22c35a8c 3989 mg->mg_virtual = &PL_vtbl_env;
79072805 3990 break;
55497cff 3991 case 'f':
22c35a8c 3992 mg->mg_virtual = &PL_vtbl_fm;
55497cff 3993 break;
79072805 3994 case 'e':
22c35a8c 3995 mg->mg_virtual = &PL_vtbl_envelem;
79072805 3996 break;
93a17b20 3997 case 'g':
22c35a8c 3998 mg->mg_virtual = &PL_vtbl_mglob;
93a17b20 3999 break;
463ee0b2 4000 case 'I':
22c35a8c 4001 mg->mg_virtual = &PL_vtbl_isa;
463ee0b2
LW		 4002 break;
4003 case 'i':
22c35a8c 4004 mg->mg_virtual = &PL_vtbl_isaelem;
463ee0b2 4005 break;
16660edb 4006 case 'k':
22c35a8c 4007 mg->mg_virtual = &PL_vtbl_nkeys;
16660edb 4008 break;
79072805 4009 case 'L':
a0d0e21e 4010 SvRMAGICAL_on(sv);
93a17b20
LW		 4011 mg->mg_virtual = 0;
4012 break;
4013 case 'l':
22c35a8c 4014 mg->mg_virtual = &PL_vtbl_dbline;
79072805 4015 break;
f93b4edd
MB		 4016#ifdef USE_THREADS
4017 case 'm':
22c35a8c 4018 mg->mg_virtual = &PL_vtbl_mutex;
f93b4edd
MB		 4019 break;
4020#endif /* USE_THREADS */
36477c24 4021#ifdef USE_LOCALE_COLLATE
bbce6d69 4022 case 'o':
22c35a8c 4023 mg->mg_virtual = &PL_vtbl_collxfrm;
bbce6d69 4024 break;
36477c24 4025#endif /* USE_LOCALE_COLLATE */
463ee0b2 4026 case 'P':
22c35a8c 4027 mg->mg_virtual = &PL_vtbl_pack;
463ee0b2
LW		 4028 break;
4029 case 'p':
a0d0e21e 4030 case 'q':
22c35a8c 4031 mg->mg_virtual = &PL_vtbl_packelem;
463ee0b2 4032 break;
c277df42 4033 case 'r':
22c35a8c 4034 mg->mg_virtual = &PL_vtbl_regexp;
c277df42 4035 break;
79072805 4036 case 'S':
22c35a8c 4037 mg->mg_virtual = &PL_vtbl_sig;
79072805
LW		 4038 break;
4039 case 's':
22c35a8c 4040 mg->mg_virtual = &PL_vtbl_sigelem;
79072805 4041 break;
463ee0b2 4042 case 't':
22c35a8c 4043 mg->mg_virtual = &PL_vtbl_taint;
565764a8 4044 mg->mg_len = 1;
463ee0b2 4045 break;
79072805 4046 case 'U':
22c35a8c 4047 mg->mg_virtual = &PL_vtbl_uvar;
79072805
LW		 4048 break;
4049 case 'v':
22c35a8c 4050 mg->mg_virtual = &PL_vtbl_vec;
79072805
LW		 4051 break;
4052 case 'x':
22c35a8c 4053 mg->mg_virtual = &PL_vtbl_substr;
79072805 4054 break;
5f05dabc 4055 case 'y':
22c35a8c 4056 mg->mg_virtual = &PL_vtbl_defelem;
5f05dabc 4057 break;
79072805 4058 case '*':
22c35a8c 4059 mg->mg_virtual = &PL_vtbl_glob;
79072805
LW		 4060 break;
4061 case '#':
22c35a8c 4062 mg->mg_virtual = &PL_vtbl_arylen;
79072805 4063 break;
a0d0e21e 4064 case '.':
22c35a8c 4065 mg->mg_virtual = &PL_vtbl_pos;
a0d0e21e 4066 break;
810b8aa5
GS		 4067 case '<':
4068 mg->mg_virtual = &PL_vtbl_backref;
4069 break;
4633a7c4
LW		 4070 case '~': /* Reserved for use by extensions not perl internals. */
4071 /* Useful for attaching extension internal data to perl vars. */
4072 /* Note that multiple extensions may clash if magical scalars */
4073 /* etc holding private data from one are passed to another. */
4074 SvRMAGICAL_on(sv);
a0d0e21e 4075 break;
79072805 4076 default:
cea2e8a9 4077 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
463ee0b2 4078 }
8990e307
LW		 4079 mg_magical(sv);
4080 if (SvGMAGICAL(sv))
4081 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW		 4082}
4083
c461cf8f
JH		 4084/*
4085=for apidoc sv_unmagic
4086
4087Removes magic from an SV.
4088
4089=cut
4090*/
4091
463ee0b2 4092int
864dbfa3 4093Perl_sv_unmagic(pTHX_ SV *sv, int type)
463ee0b2
LW		 4094{
4095 MAGIC* mg;
4096 MAGIC** mgp;
91bba347 4097 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW		 4098 return 0;
4099 mgp = &SvMAGIC(sv);
4100 for (mg = *mgp; mg; mg = *mgp) {
4101 if (mg->mg_type == type) {
4102 MGVTBL* vtbl = mg->mg_virtual;
4103 *mgp = mg->mg_moremagic;
1d7c1841 4104 if (vtbl && vtbl->svt_free)
fc0dc3b3 4105 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
9cbac4c7 4106 if (mg->mg_ptr && mg->mg_type != 'g') {
565764a8 4107 if (mg->mg_len >= 0)
1edc1566 4108 Safefree(mg->mg_ptr);
565764a8 4109 else if (mg->mg_len == HEf_SVKEY)
1edc1566 4110 SvREFCNT_dec((SV*)mg->mg_ptr);
9cbac4c7 4111 }
a0d0e21e
LW		 4112 if (mg->mg_flags & MGf_REFCOUNTED)
4113 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW		 4114 Safefree(mg);
4115 }
4116 else
4117 mgp = &mg->mg_moremagic;
79072805 4118 }
91bba347 4119 if (!SvMAGIC(sv)) {
463ee0b2 4120 SvMAGICAL_off(sv);
8990e307 4121 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW		 4122 }
4123
4124 return 0;
79072805
LW		 4125}
4126
c461cf8f
JH		 4127/*
4128=for apidoc sv_rvweaken
4129
4130Weaken a reference.
4131
4132=cut
4133*/
4134
810b8aa5 4135SV *
864dbfa3 4136Perl_sv_rvweaken(pTHX_ SV *sv)
810b8aa5
GS		 4137{
4138 SV *tsv;
4139 if (!SvOK(sv)) /* let undefs pass */
4140 return sv;
4141 if (!SvROK(sv))
cea2e8a9 4142 Perl_croak(aTHX_ "Can't weaken a nonreference");
810b8aa5 4143 else if (SvWEAKREF(sv)) {
810b8aa5 4144 if (ckWARN(WARN_MISC))
cea2e8a9 4145 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
810b8aa5
GS		 4146 return sv;
4147 }
4148 tsv = SvRV(sv);
4149 sv_add_backref(tsv, sv);
4150 SvWEAKREF_on(sv);
1c846c1f 4151 SvREFCNT_dec(tsv);
810b8aa5
GS		 4152 return sv;
4153}
4154
4155STATIC void
cea2e8a9 4156S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
810b8aa5
GS		 4157{
4158 AV *av;
4159 MAGIC *mg;
4160 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4161 av = (AV*)mg->mg_obj;
4162 else {
4163 av = newAV();
4164 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4165 SvREFCNT_dec(av); /* for sv_magic */
4166 }
4167 av_push(av,sv);
4168}
4169
1c846c1f 4170STATIC void
cea2e8a9 4171S_sv_del_backref(pTHX_ SV *sv)
810b8aa5
GS		 4172{
4173 AV *av;
4174 SV **svp;
4175 I32 i;
4176 SV *tsv = SvRV(sv);
4177 MAGIC *mg;
4178 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
cea2e8a9 4179 Perl_croak(aTHX_ "panic: del_backref");
810b8aa5
GS		 4180 av = (AV *)mg->mg_obj;
4181 svp = AvARRAY(av);
4182 i = AvFILLp(av);
4183 while (i >= 0) {
4184 if (svp[i] == sv) {
4185 svp[i] = &PL_sv_undef; /* XXX */
4186 }
4187 i--;
4188 }
4189}
4190
954c1994
GS		 4191/*
4192=for apidoc sv_insert
4193
4194Inserts a string at the specified offset/length within the SV. Similar to
4195the Perl substr() function.
4196
4197=cut
4198*/
4199
79072805 4200void
864dbfa3 4201Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
79072805
LW		 4202{
4203 register char *big;
4204 register char *mid;
4205 register char *midend;
4206 register char *bigend;
4207 register I32 i;
6ff81951 4208 STRLEN curlen;
1c846c1f 4209
79072805 4210
8990e307 4211 if (!bigstr)
cea2e8a9 4212 Perl_croak(aTHX_ "Can't modify non-existent substring");
6ff81951 4213 SvPV_force(bigstr, curlen);
60fa28ff 4214 (void)SvPOK_only_UTF8(bigstr);
6ff81951
GS		 4215 if (offset + len > curlen) {
4216 SvGROW(bigstr, offset+len+1);
4217 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4218 SvCUR_set(bigstr, offset+len);
4219 }
79072805 4220
69b47968 4221 SvTAINT(bigstr);
79072805
LW		 4222 i = littlelen - len;
4223 if (i > 0) { /* string might grow */
a0d0e21e 4224 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW		 4225 mid = big + offset + len;
4226 midend = bigend = big + SvCUR(bigstr);
4227 bigend += i;
4228 *bigend = '\0';
4229 while (midend > mid) /* shove everything down */
4230 *--bigend = *--midend;
4231 Move(little,big+offset,littlelen,char);
4232 SvCUR(bigstr) += i;
4233 SvSETMAGIC(bigstr);
4234 return;
4235 }
4236 else if (i == 0) {
463ee0b2 4237 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW		 4238 SvSETMAGIC(bigstr);
4239 return;
4240 }
4241
463ee0b2 4242 big = SvPVX(bigstr);
79072805
LW		 4243 mid = big + offset;
4244 midend = mid + len;
4245 bigend = big + SvCUR(bigstr);
4246
4247 if (midend > bigend)
cea2e8a9 4248 Perl_croak(aTHX_ "panic: sv_insert");
79072805
LW		 4249
4250 if (mid - big > bigend - midend) { /* faster to shorten from end */
4251 if (littlelen) {
4252 Move(little, mid, littlelen,char);
4253 mid += littlelen;
4254 }
4255 i = bigend - midend;
4256 if (i > 0) {
4257 Move(midend, mid, i,char);
4258 mid += i;
4259 }
4260 *mid = '\0';
4261 SvCUR_set(bigstr, mid - big);
4262 }
4263 /*SUPPRESS 560*/
155aba94 4264 else if ((i = mid - big)) { /* faster from front */
79072805
LW		 4265 midend -= littlelen;
4266 mid = midend;
4267 sv_chop(bigstr,midend-i);
4268 big += i;
4269 while (i--)
4270 *--midend = *--big;
4271 if (littlelen)
4272 Move(little, mid, littlelen,char);
4273 }
4274 else if (littlelen) {
4275 midend -= littlelen;
4276 sv_chop(bigstr,midend);
4277 Move(little,midend,littlelen,char);
4278 }
4279 else {
4280 sv_chop(bigstr,midend);
4281 }
4282 SvSETMAGIC(bigstr);
4283}
4284
c461cf8f
JH		 4285/*
4286=for apidoc sv_replace
4287
4288Make the first argument a copy of the second, then delete the original.
4289
4290=cut
4291*/
79072805
LW		 4292
4293void
864dbfa3 4294Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
79072805
LW		 4295{
4296 U32 refcnt = SvREFCNT(sv);
2213622d 4297 SV_CHECK_THINKFIRST(sv);
0453d815
PM		 4298 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4299 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
93a17b20 4300 if (SvMAGICAL(sv)) {
a0d0e21e
LW		 4301 if (SvMAGICAL(nsv))
4302 mg_free(nsv);
4303 else
4304 sv_upgrade(nsv, SVt_PVMG);
93a17b20 4305 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 4306 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW		 4307 SvMAGICAL_off(sv);
4308 SvMAGIC(sv) = 0;
4309 }
79072805
LW		 4310 SvREFCNT(sv) = 0;
4311 sv_clear(sv);
477f5d66 4312 assert(!SvREFCNT(sv));
79072805
LW		 4313 StructCopy(nsv,sv,SV);
4314 SvREFCNT(sv) = refcnt;
1edc1566 4315 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 4316 del_SV(nsv);
79072805
LW		 4317}
4318
c461cf8f
JH		 4319/*
4320=for apidoc sv_clear
4321
4322Clear an SV, making it empty. Does not free the memory used by the SV
4323itself.
4324
4325=cut
4326*/
4327
79072805 4328void
864dbfa3 4329Perl_sv_clear(pTHX_ register SV *sv)
79072805 4330{
ec12f114 4331 HV* stash;
79072805
LW		 4332 assert(sv);
4333 assert(SvREFCNT(sv) == 0);
4334
ed6116ce 4335 if (SvOBJECT(sv)) {
3280af22 4336 if (PL_defstash) { /* Still have a symbol table? */
4e35701f 4337 djSP;
32251b26 4338 CV* destructor;
837485b6 4339 SV tmpref;
a0d0e21e 4340
837485b6
GS		 4341 Zero(&tmpref, 1, SV);
4342 sv_upgrade(&tmpref, SVt_RV);
4343 SvROK_on(&tmpref);
4344 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4345 SvREFCNT(&tmpref) = 1;
8ebc5c01 4346
d460ef45 4347 do {
4e8e7886 4348 stash = SvSTASH(sv);
32251b26 4349 destructor = StashHANDLER(stash,DESTROY);
4e8e7886
GS		 4350 if (destructor) {
4351 ENTER;
e788e7d3 4352 PUSHSTACKi(PERLSI_DESTROY);
837485b6 4353 SvRV(&tmpref) = SvREFCNT_inc(sv);
4e8e7886
GS		 4354 EXTEND(SP, 2);
4355 PUSHMARK(SP);
837485b6 4356 PUSHs(&tmpref);
4e8e7886 4357 PUTBACK;
32251b26 4358 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4e8e7886 4359 SvREFCNT(sv)--;
d3acc0f7 4360 POPSTACK;
3095d977 4361 SPAGAIN;
4e8e7886
GS		 4362 LEAVE;
4363 }
4364 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
8ebc5c01 4365
837485b6 4366 del_XRV(SvANY(&tmpref));
6f44e0a4
JP		 4367
4368 if (SvREFCNT(sv)) {
4369 if (PL_in_clean_objs)
cea2e8a9 4370 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
6f44e0a4
JP		 4371 HvNAME(stash));
4372 /* DESTROY gave object new lease on life */
4373 return;
4374 }
a0d0e21e 4375 }
4e8e7886 4376
a0d0e21e 4377 if (SvOBJECT(sv)) {
4e8e7886 4378 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
a0d0e21e
LW		 4379 SvOBJECT_off(sv); /* Curse the object. */
4380 if (SvTYPE(sv) != SVt_PVIO)
3280af22 4381 --PL_sv_objcount; /* XXX Might want something more general */
a0d0e21e 4382 }
463ee0b2 4383 }
c07a80fd 4384 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 4385 mg_free(sv);
ec12f114 4386 stash = NULL;
79072805 4387 switch (SvTYPE(sv)) {
8990e307 4388 case SVt_PVIO:
df0bd2f4
GS		 4389 if (IoIFP(sv) &&
4390 IoIFP(sv) != PerlIO_stdin() &&
5f05dabc 4391 IoIFP(sv) != PerlIO_stdout() &&
4392 IoIFP(sv) != PerlIO_stderr())
93578b34 4393 {
f2b5be74 4394 io_close((IO*)sv, FALSE);
93578b34 4395 }
1d7c1841 4396 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
1236053a 4397 PerlDir_close(IoDIRP(sv));
1d7c1841 4398 IoDIRP(sv) = (DIR*)NULL;
8990e307
LW		 4399 Safefree(IoTOP_NAME(sv));
4400 Safefree(IoFMT_NAME(sv));
4401 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 4402 /* FALL THROUGH */
79072805 4403 case SVt_PVBM:
a0d0e21e 4404 goto freescalar;
79072805 4405 case SVt_PVCV:
748a9306 4406 case SVt_PVFM:
85e6fe83 4407 cv_undef((CV*)sv);
a0d0e21e 4408 goto freescalar;
79072805 4409 case SVt_PVHV:
85e6fe83 4410 hv_undef((HV*)sv);
a0d0e21e 4411 break;
79072805 4412 case SVt_PVAV:
85e6fe83 4413 av_undef((AV*)sv);
a0d0e21e 4414 break;
02270b4e
GS		 4415 case SVt_PVLV:
4416 SvREFCNT_dec(LvTARG(sv));
4417 goto freescalar;
a0d0e21e 4418 case SVt_PVGV:
1edc1566 4419 gp_free((GV*)sv);
a0d0e21e 4420 Safefree(GvNAME(sv));
ec12f114
JPC		 4421 /* cannot decrease stash refcount yet, as we might recursively delete
4422 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4423 of stash until current sv is completely gone.
4424 -- JohnPC, 27 Mar 1998 */
4425 stash = GvSTASH(sv);
a0d0e21e 4426 /* FALL THROUGH */
79072805 4427 case SVt_PVMG:
79072805
LW		 4428 case SVt_PVNV:
4429 case SVt_PVIV:
a0d0e21e
LW		 4430 freescalar:
4431 (void)SvOOK_off(sv);
79072805
LW		 4432 /* FALL THROUGH */
4433 case SVt_PV:
a0d0e21e 4434 case SVt_RV:
810b8aa5
GS		 4435 if (SvROK(sv)) {
4436 if (SvWEAKREF(sv))
4437 sv_del_backref(sv);
4438 else
4439 SvREFCNT_dec(SvRV(sv));
4440 }
1edc1566 4441 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 4442 Safefree(SvPVX(sv));
1c846c1f 4443 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
c3654f1a 4444 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
1c846c1f
NIS		 4445 SvFAKE_off(sv);
4446 }
79072805 4447 break;
a0d0e21e 4448/*
79072805 4449 case SVt_NV:
79072805 4450 case SVt_IV:
79072805
LW		 4451 case SVt_NULL:
4452 break;
a0d0e21e 4453*/
79072805
LW		 4454 }
4455
4456 switch (SvTYPE(sv)) {
4457 case SVt_NULL:
4458 break;
79072805
LW		 4459 case SVt_IV:
4460 del_XIV(SvANY(sv));
4461 break;
4462 case SVt_NV:
4463 del_XNV(SvANY(sv));
4464 break;
ed6116ce
LW		 4465 case SVt_RV:
4466 del_XRV(SvANY(sv));
4467 break;
79072805
LW		 4468 case SVt_PV:
4469 del_XPV(SvANY(sv));
4470 break;
4471 case SVt_PVIV:
4472 del_XPVIV(SvANY(sv));
4473 break;
4474 case SVt_PVNV:
4475 del_XPVNV(SvANY(sv));
4476 break;
4477 case SVt_PVMG:
4478 del_XPVMG(SvANY(sv));
4479 break;
4480 case SVt_PVLV:
4481 del_XPVLV(SvANY(sv));
4482 break;
4483 case SVt_PVAV:
4484 del_XPVAV(SvANY(sv));
4485 break;
4486 case SVt_PVHV:
4487 del_XPVHV(SvANY(sv));
4488 break;
4489 case SVt_PVCV:
4490 del_XPVCV(SvANY(sv));
4491 break;
4492 case SVt_PVGV:
4493 del_XPVGV(SvANY(sv));
ec12f114
JPC		 4494 /* code duplication for increased performance. */
4495 SvFLAGS(sv) &= SVf_BREAK;
4496 SvFLAGS(sv) |= SVTYPEMASK;
4497 /* decrease refcount of the stash that owns this GV, if any */
4498 if (stash)
4499 SvREFCNT_dec(stash);
4500 return; /* not break, SvFLAGS reset already happened */
79072805
LW		 4501 case SVt_PVBM:
4502 del_XPVBM(SvANY(sv));
4503 break;
4504 case SVt_PVFM:
4505 del_XPVFM(SvANY(sv));
4506 break;
8990e307
LW		 4507 case SVt_PVIO:
4508 del_XPVIO(SvANY(sv));
4509 break;
79072805 4510 }
a0d0e21e 4511 SvFLAGS(sv) &= SVf_BREAK;
8990e307 4512 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW		 4513}
4514
4515SV *
864dbfa3 4516Perl_sv_newref(pTHX_ SV *sv)
79072805 4517{
463ee0b2 4518 if (sv)
dce16143 4519 ATOMIC_INC(SvREFCNT(sv));
79072805
LW		 4520 return sv;
4521}
4522
c461cf8f
JH		 4523/*
4524=for apidoc sv_free
4525
4526Free the memory used by an SV.
4527
4528=cut
4529*/
4530
79072805 4531void
864dbfa3 4532Perl_sv_free(pTHX_ SV *sv)
79072805 4533{
dce16143
MB		 4534 int refcount_is_zero;
4535
79072805
LW		 4536 if (!sv)
4537 return;
a0d0e21e
LW		 4538 if (SvREFCNT(sv) == 0) {
4539 if (SvFLAGS(sv) & SVf_BREAK)
4540 return;
3280af22 4541 if (PL_in_clean_all) /* All is fair */
1edc1566 4542 return;
d689ffdd
JP		 4543 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4544 /* make sure SvREFCNT(sv)==0 happens very seldom */
4545 SvREFCNT(sv) = (~(U32)0)/2;
4546 return;
4547 }
0453d815
PM		 4548 if (ckWARN_d(WARN_INTERNAL))
4549 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
79072805
LW		 4550 return;
4551 }
dce16143
MB		 4552 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4553 if (!refcount_is_zero)
8990e307 4554 return;
463ee0b2
LW		 4555#ifdef DEBUGGING
4556 if (SvTEMP(sv)) {
0453d815 4557 if (ckWARN_d(WARN_DEBUGGING))
f248d071 4558 Perl_warner(aTHX_ WARN_DEBUGGING,
1d7c1841
GS		 4559 "Attempt to free temp prematurely: SV 0x%"UVxf,
4560 PTR2UV(sv));
79072805 4561 return;
79072805 4562 }
463ee0b2 4563#endif
d689ffdd
JP		 4564 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4565 /* make sure SvREFCNT(sv)==0 happens very seldom */
4566 SvREFCNT(sv) = (~(U32)0)/2;
4567 return;
4568 }
79072805 4569 sv_clear(sv);
477f5d66
CS		 4570 if (! SvREFCNT(sv))
4571 del_SV(sv);
79072805
LW		 4572}
4573
954c1994
GS		 4574/*
4575=for apidoc sv_len
4576
4577Returns the length of the string in the SV. See also C<SvCUR>.
4578
4579=cut
4580*/
4581
79072805 4582STRLEN
864dbfa3 4583Perl_sv_len(pTHX_ register SV *sv)
79072805 4584{
748a9306 4585 char *junk;
463ee0b2 4586 STRLEN len;
79072805
LW		 4587
4588 if (!sv)
4589 return 0;
4590
8990e307 4591 if (SvGMAGICAL(sv))
565764a8 4592 len = mg_length(sv);
8990e307 4593 else
748a9306 4594 junk = SvPV(sv, len);
463ee0b2 4595 return len;
79072805
LW		 4596}
4597
c461cf8f
JH		 4598/*
4599=for apidoc sv_len_utf8
4600
4601Returns the number of characters in the string in an SV, counting wide
4602UTF8 bytes as a single character.
4603
4604=cut
4605*/
4606
a0ed51b3 4607STRLEN
864dbfa3 4608Perl_sv_len_utf8(pTHX_ register SV *sv)
a0ed51b3 4609{
a0ed51b3
LW		 4610 if (!sv)
4611 return 0;
4612
a0ed51b3 4613 if (SvGMAGICAL(sv))
b76347f2 4614 return mg_length(sv);
a0ed51b3 4615 else
b76347f2
JH		 4616 {
4617 STRLEN len;
4618 U8 *s = (U8*)SvPV(sv, len);
4619
d6efbbad 4620 return Perl_utf8_length(aTHX_ s, s + len);
a0ed51b3 4621 }
a0ed51b3
LW		 4622}
4623
4624void
864dbfa3 4625Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
a0ed51b3 4626{
dfe13c55
GS		 4627 U8 *start;
4628 U8 *s;
4629 U8 *send;
a0ed51b3
LW		 4630 I32 uoffset = *offsetp;
4631 STRLEN len;
4632
4633 if (!sv)
4634 return;
4635
dfe13c55 4636 start = s = (U8*)SvPV(sv, len);
a0ed51b3
LW		 4637 send = s + len;
4638 while (s < send && uoffset--)
4639 s += UTF8SKIP(s);
bb40f870
GA		 4640 if (s >= send)
4641 s = send;
a0ed51b3
LW		 4642 *offsetp = s - start;
4643 if (lenp) {
4644 I32 ulen = *lenp;
4645 start = s;
4646 while (s < send && ulen--)
4647 s += UTF8SKIP(s);
bb40f870
GA		 4648 if (s >= send)
4649 s = send;
a0ed51b3
LW		 4650 *lenp = s - start;
4651 }
4652 return;
4653}
4654
4655void
864dbfa3 4656Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
a0ed51b3 4657{
dfe13c55
GS		 4658 U8 *s;
4659 U8 *send;
a0ed51b3
LW		 4660 STRLEN len;
4661
4662 if (!sv)
4663 return;
4664
dfe13c55 4665 s = (U8*)SvPV(sv, len);
a0ed51b3 4666 if (len < *offsetp)
a0dbb045 4667 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
a0ed51b3
LW		 4668 send = s + *offsetp;
4669 len = 0;
4670 while (s < send) {
a0dbb045
JH		 4671 STRLEN n;
4672
4673 if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
4674 s += n;
4675 len++;
4676 }
4677 else
4678 break;
a0ed51b3
LW		 4679 }
4680 *offsetp = len;
4681 return;
4682}
4683
954c1994
GS		 4684/*
4685=for apidoc sv_eq
4686
4687Returns a boolean indicating whether the strings in the two SVs are
4688identical.
4689
4690=cut
4691*/
4692
79072805 4693I32
e01b9e88 4694Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
79072805
LW		 4695{
4696 char *pv1;
463ee0b2 4697 STRLEN cur1;
79072805 4698 char *pv2;
463ee0b2 4699 STRLEN cur2;
e01b9e88
SC		 4700 I32 eq = 0;
4701 bool pv1tmp = FALSE;
4702 bool pv2tmp = FALSE;
79072805 4703
e01b9e88 4704 if (!sv1) {
79072805
LW		 4705 pv1 = "";
4706 cur1 = 0;
4707 }
463ee0b2 4708 else
e01b9e88 4709 pv1 = SvPV(sv1, cur1);
79072805 4710
e01b9e88
SC		 4711 if (!sv2){
4712 pv2 = "";
4713 cur2 = 0;
92d29cee 4714 }
e01b9e88
SC		 4715 else
4716 pv2 = SvPV(sv2, cur2);
79072805 4717
e01b9e88 4718 /* do not utf8ize the comparands as a side-effect */
7bbb0251 4719 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
f9a63242
JH		 4720 bool is_utf8 = TRUE;
4721
1aa99e6b
IH		 4722 if (PL_hints & HINT_UTF8_DISTINCT)
4723 return FALSE;
4724
e01b9e88 4725 if (SvUTF8(sv1)) {
f34ff0a8 4726 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
90f44359
JH		 4727
4728 if ((pv1tmp = (pv != pv1)))
4729 pv1 = pv;
e01b9e88
SC		 4730 }
4731 else {
f34ff0a8 4732 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
90f44359
JH		 4733
4734 if ((pv2tmp = (pv != pv2)))
4735 pv2 = pv;
e01b9e88
SC		 4736 }
4737 }
79072805 4738
e01b9e88
SC		 4739 if (cur1 == cur2)
4740 eq = memEQ(pv1, pv2, cur1);
4741
4742 if (pv1tmp)
4743 Safefree(pv1);
4744 if (pv2tmp)
4745 Safefree(pv2);
4746
4747 return eq;
79072805
LW		 4748}
4749
954c1994
GS		 4750/*
4751=for apidoc sv_cmp
4752
4753Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4754string in C<sv1> is less than, equal to, or greater than the string in
4755C<sv2>.
4756
4757=cut
4758*/
4759
79072805 4760I32
e01b9e88 4761Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
79072805 4762{
560a288e
GS		 4763 STRLEN cur1, cur2;
4764 char *pv1, *pv2;
1c846c1f 4765 I32 cmp;
e01b9e88
SC		 4766 bool pv1tmp = FALSE;
4767 bool pv2tmp = FALSE;
560a288e 4768
e01b9e88
SC		 4769 if (!sv1) {
4770 pv1 = "";
560a288e
GS		 4771 cur1 = 0;
4772 }
e01b9e88
SC		 4773 else
4774 pv1 = SvPV(sv1, cur1);
560a288e 4775
e01b9e88
SC		 4776 if (!sv2){
4777 pv2 = "";
560a288e
GS		 4778 cur2 = 0;
4779 }
e01b9e88
SC		 4780 else
4781 pv2 = SvPV(sv2, cur2);
79072805 4782
e01b9e88
SC		 4783 /* do not utf8ize the comparands as a side-effect */
4784 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
1aa99e6b
IH		 4785 if (PL_hints & HINT_UTF8_DISTINCT)
4786 return SvUTF8(sv1) ? 1 : -1;
4787
e01b9e88
SC		 4788 if (SvUTF8(sv1)) {
4789 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4790 pv2tmp = TRUE;
4791 }
4792 else {
4793 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4794 pv1tmp = TRUE;
4795 }
4796 }
79072805 4797
e01b9e88
SC		 4798 if (!cur1) {
4799 cmp = cur2 ? -1 : 0;
4800 } else if (!cur2) {
4801 cmp = 1;
4802 } else {
4803 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4804
4805 if (retval) {
4806 cmp = retval < 0 ? -1 : 1;
4807 } else if (cur1 == cur2) {
4808 cmp = 0;
4809 } else {
4810 cmp = cur1 < cur2 ? -1 : 1;
4811 }
4812 }
16660edb 4813
e01b9e88
SC		 4814 if (pv1tmp)
4815 Safefree(pv1);
4816 if (pv2tmp)
4817 Safefree(pv2);
16660edb 4818
e01b9e88 4819 return cmp;
bbce6d69 4820}
16660edb 4821
c461cf8f
JH		 4822/*
4823=for apidoc sv_cmp_locale
4824
4825Compares the strings in two SVs in a locale-aware manner. See
4826L</sv_cmp_locale>
4827
4828=cut
4829*/
4830
bbce6d69 4831I32
864dbfa3 4832Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
bbce6d69 4833{
36477c24 4834#ifdef USE_LOCALE_COLLATE
16660edb 4835
bbce6d69 4836 char *pv1, *pv2;
4837 STRLEN len1, len2;
4838 I32 retval;
16660edb 4839
3280af22 4840 if (PL_collation_standard)
bbce6d69 4841 goto raw_compare;
16660edb 4842
bbce6d69 4843 len1 = 0;
8ac85365 4844 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
bbce6d69 4845 len2 = 0;
8ac85365 4846 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
16660edb 4847
bbce6d69 4848 if (!pv1 || !len1) {
4849 if (pv2 && len2)
4850 return -1;
4851 else
4852 goto raw_compare;
4853 }
4854 else {
4855 if (!pv2 || !len2)
4856 return 1;
4857 }
16660edb 4858
bbce6d69 4859 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 4860
bbce6d69 4861 if (retval)
16660edb 4862 return retval < 0 ? -1 : 1;
4863
bbce6d69 4864 /*
4865 * When the result of collation is equality, that doesn't mean
4866 * that there are no differences -- some locales exclude some
4867 * characters from consideration. So to avoid false equalities,
4868 * we use the raw string as a tiebreaker.
4869 */
16660edb 4870
bbce6d69 4871 raw_compare:
4872 /* FALL THROUGH */
16660edb 4873
36477c24 4874#endif /* USE_LOCALE_COLLATE */
16660edb 4875
bbce6d69 4876 return sv_cmp(sv1, sv2);
4877}
79072805 4878
36477c24 4879#ifdef USE_LOCALE_COLLATE
7a4c00b4 4880/*
4881 * Any scalar variable may carry an 'o' magic that contains the
4882 * scalar data of the variable transformed to such a format that
4883 * a normal memory comparison can be used to compare the data
4884 * according to the locale settings.
4885 */
bbce6d69 4886char *
864dbfa3 4887Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
bbce6d69 4888{
7a4c00b4 4889 MAGIC *mg;
16660edb 4890
8ac85365 4891 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3280af22 4892 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
bbce6d69 4893 char *s, *xf;
4894 STRLEN len, xlen;
4895
7a4c00b4 4896 if (mg)
4897 Safefree(mg->mg_ptr);
bbce6d69 4898 s = SvPV(sv, len);
4899 if ((xf = mem_collxfrm(s, len, &xlen))) {
ff0cee69 4900 if (SvREADONLY(sv)) {
4901 SAVEFREEPV(xf);
4902 *nxp = xlen;
3280af22 4903 return xf + sizeof(PL_collation_ix);
ff0cee69 4904 }
7a4c00b4 4905 if (! mg) {
4906 sv_magic(sv, 0, 'o', 0, 0);
4907 mg = mg_find(sv, 'o');
4908 assert(mg);
bbce6d69 4909 }
7a4c00b4 4910 mg->mg_ptr = xf;
565764a8 4911 mg->mg_len = xlen;
7a4c00b4 4912 }
4913 else {
ff0cee69 4914 if (mg) {
4915 mg->mg_ptr = NULL;
565764a8 4916 mg->mg_len = -1;
ff0cee69 4917 }
bbce6d69 4918 }
4919 }
7a4c00b4 4920 if (mg && mg->mg_ptr) {
565764a8 4921 *nxp = mg->mg_len;
3280af22 4922 return mg->mg_ptr + sizeof(PL_collation_ix);
bbce6d69 4923 }
4924 else {
4925 *nxp = 0;
4926 return NULL;
16660edb 4927 }
79072805
LW		 4928}
4929
36477c24 4930#endif /* USE_LOCALE_COLLATE */
bbce6d69 4931
c461cf8f
JH		 4932/*
4933=for apidoc sv_gets
4934
4935Get a line from the filehandle and store it into the SV, optionally
4936appending to the currently-stored string.
4937
4938=cut
4939*/
4940
79072805 4941char *
864dbfa3 4942Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
79072805 4943{
c07a80fd 4944 char *rsptr;
4945 STRLEN rslen;
4946 register STDCHAR rslast;
4947 register STDCHAR *bp;
4948 register I32 cnt;
4949 I32 i;
4950
2213622d 4951 SV_CHECK_THINKFIRST(sv);
6fc92669 4952 (void)SvUPGRADE(sv, SVt_PV);
99491443 4953
ff68c719 4954 SvSCREAM_off(sv);
c07a80fd 4955
3280af22 4956 if (RsSNARF(PL_rs)) {
c07a80fd 4957 rsptr = NULL;
4958 rslen = 0;
4959 }
3280af22 4960 else if (RsRECORD(PL_rs)) {
5b2b9c68
HM		 4961 I32 recsize, bytesread;
4962 char *buffer;
4963
4964 /* Grab the size of the record we're getting */
3280af22 4965 recsize = SvIV(SvRV(PL_rs));
5b2b9c68 4966 (void)SvPOK_only(sv); /* Validate pointer */
e670df4e 4967 buffer = SvGROW(sv, recsize + 1);
5b2b9c68
HM		 4968 /* Go yank in */
4969#ifdef VMS
4970 /* VMS wants read instead of fread, because fread doesn't respect */
4971 /* RMS record boundaries. This is not necessarily a good thing to be */
4972 /* doing, but we've got no other real choice */
4973 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4974#else
4975 bytesread = PerlIO_read(fp, buffer, recsize);
4976#endif
4977 SvCUR_set(sv, bytesread);
e670df4e 4978 buffer[bytesread] = '\0';
7d59b7e4
NIS		 4979 if (PerlIO_isutf8(fp))
4980 SvUTF8_on(sv);
4981 else
4982 SvUTF8_off(sv);
5b2b9c68
HM		 4983 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4984 }
3280af22 4985 else if (RsPARA(PL_rs)) {
c07a80fd 4986 rsptr = "\n\n";
4987 rslen = 2;
4988 }
7d59b7e4
NIS		 4989 else {
4990 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4991 if (PerlIO_isutf8(fp)) {
4992 rsptr = SvPVutf8(PL_rs, rslen);
4993 }
4994 else {
4995 if (SvUTF8(PL_rs)) {
4996 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4997 Perl_croak(aTHX_ "Wide character in $/");
4998 }
4999 }
5000 rsptr = SvPV(PL_rs, rslen);
5001 }
5002 }
5003
c07a80fd 5004 rslast = rslen ? rsptr[rslen - 1] : '\0';
5005
3280af22 5006 if (RsPARA(PL_rs)) { /* have to do this both before and after */
79072805 5007 do { /* to make sure file boundaries work right */
760ac839 5008 if (PerlIO_eof(fp))
a0d0e21e 5009 return 0;
760ac839 5010 i = PerlIO_getc(fp);
79072805 5011 if (i != '\n') {
a0d0e21e
LW		 5012 if (i == -1)
5013 return 0;
760ac839 5014 PerlIO_ungetc(fp,i);
79072805
LW		 5015 break;
5016 }
5017 } while (i != EOF);
5018 }
c07a80fd 5019
760ac839
LW		 5020 /* See if we know enough about I/O mechanism to cheat it ! */
5021
5022 /* This used to be #ifdef test - it is made run-time test for ease
1c846c1f 5023 of abstracting out stdio interface. One call should be cheap
760ac839
LW		 5024 enough here - and may even be a macro allowing compile
5025 time optimization.
5026 */
5027
5028 if (PerlIO_fast_gets(fp)) {
5029
5030 /*
5031 * We're going to steal some values from the stdio struct
5032 * and put EVERYTHING in the innermost loop into registers.
5033 */
5034 register STDCHAR *ptr;
5035 STRLEN bpx;
5036 I32 shortbuffered;
5037
16660edb 5038#if defined(VMS) && defined(PERLIO_IS_STDIO)
5039 /* An ungetc()d char is handled separately from the regular
5040 * buffer, so we getc() it back out and stuff it in the buffer.
5041 */
5042 i = PerlIO_getc(fp);
5043 if (i == EOF) return 0;
5044 *(--((*fp)->_ptr)) = (unsigned char) i;
5045 (*fp)->_cnt++;
5046#endif
c07a80fd 5047
c2960299 5048 /* Here is some breathtakingly efficient cheating */
c07a80fd 5049
a20bf0c3 5050 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 5051 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW		 5052 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5053 if (cnt > 80 && SvLEN(sv) > append) {
5054 shortbuffered = cnt - SvLEN(sv) + append + 1;
5055 cnt -= shortbuffered;
5056 }
5057 else {
5058 shortbuffered = 0;
bbce6d69 5059 /* remember that cnt can be negative */
5060 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW		 5061 }
5062 }
5063 else
5064 shortbuffered = 0;
c07a80fd 5065 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
a20bf0c3 5066 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb 5067 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5068 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
16660edb 5069 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5070 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5071 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5072 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
79072805
LW		 5073 for (;;) {
5074 screamer:
93a17b20 5075 if (cnt > 0) {
c07a80fd 5076 if (rslen) {
760ac839
LW		 5077 while (cnt > 0) { /* this | eat */
5078 cnt--;
c07a80fd 5079 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5080 goto thats_all_folks; /* screams | sed :-) */
5081 }
5082 }
5083 else {
1c846c1f
NIS		 5084 Copy(ptr, bp, cnt, char); /* this | eat */
5085 bp += cnt; /* screams | dust */
c07a80fd 5086 ptr += cnt; /* louder | sed :-) */
a5f75d66 5087 cnt = 0;
93a17b20 5088 }
79072805
LW		 5089 }
5090
748a9306 5091 if (shortbuffered) { /* oh well, must extend */
79072805
LW		 5092 cnt = shortbuffered;
5093 shortbuffered = 0;
c07a80fd 5094 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 5095 SvCUR_set(sv, bpx);
5096 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 5097 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW		 5098 continue;
5099 }
5100
16660edb 5101 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 5102 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5103 PTR2UV(ptr),(long)cnt));
a20bf0c3 5104 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb 5105 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5106 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5107 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5108 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
1c846c1f 5109 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b 5110 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5111 another abstraction. */
760ac839 5112 i = PerlIO_getc(fp); /* get more characters */
16660edb 5113 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5114 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5115 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5116 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
a20bf0c3
JH		 5117 cnt = PerlIO_get_cnt(fp);
5118 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb 5119 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5120 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
79072805 5121
748a9306
LW		 5122 if (i == EOF) /* all done for ever? */
5123 goto thats_really_all_folks;
5124
c07a80fd 5125 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 5126 SvCUR_set(sv, bpx);
5127 SvGROW(sv, bpx + cnt + 2);
c07a80fd 5128 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5129
760ac839 5130 *bp++ = i; /* store character from PerlIO_getc */
79072805 5131
c07a80fd 5132 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 5133 goto thats_all_folks;
79072805
LW		 5134 }
5135
5136thats_all_folks:
c07a80fd 5137 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 5138 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 5139 goto screamer; /* go back to the fray */
79072805
LW		 5140thats_really_all_folks:
5141 if (shortbuffered)
5142 cnt += shortbuffered;
16660edb 5143 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5144 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
a20bf0c3 5145 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb 5146 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5147 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5148 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5149 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
79072805 5150 *bp = '\0';
760ac839 5151 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb 5152 DEBUG_P(PerlIO_printf(Perl_debug_log,
fb73857a 5153 "Screamer: done, len=%ld, string=|%.*s|\n",
5154 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
760ac839
LW		 5155 }
5156 else
79072805 5157 {
4d2c4e07 5158#ifndef EPOC
760ac839 5159 /*The big, slow, and stupid way */
c07a80fd 5160 STDCHAR buf[8192];
4d2c4e07
OF		 5161#else
5162 /* Need to work around EPOC SDK features */
5163 /* On WINS: MS VC5 generates calls to _chkstk, */
5164 /* if a `large' stack frame is allocated */
5165 /* gcc on MARM does not generate calls like these */
5166 STDCHAR buf[1024];
5167#endif
79072805 5168
760ac839 5169screamer2:
c07a80fd 5170 if (rslen) {
760ac839
LW		 5171 register STDCHAR *bpe = buf + sizeof(buf);
5172 bp = buf;
5173 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5174 ; /* keep reading */
5175 cnt = bp - buf;
c07a80fd 5176 }
5177 else {
760ac839 5178 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb 5179 /* Accomodate broken VAXC compiler, which applies U8 cast to
5180 * both args of ?: operator, causing EOF to change into 255
5181 */
5182 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 5183 }
79072805
LW		 5184
5185 if (append)
760ac839 5186 sv_catpvn(sv, (char *) buf, cnt);
79072805 5187 else
760ac839 5188 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd 5189
5190 if (i != EOF && /* joy */
5191 (!rslen ||
5192 SvCUR(sv) < rslen ||
36477c24 5193 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW		 5194 {
5195 append = -1;
63e4d877
CS		 5196 /*
5197 * If we're reading from a TTY and we get a short read,
5198 * indicating that the user hit his EOF character, we need
5199 * to notice it now, because if we try to read from the TTY
5200 * again, the EOF condition will disappear.
5201 *
5202 * The comparison of cnt to sizeof(buf) is an optimization
5203 * that prevents unnecessary calls to feof().
5204 *
5205 * - jik 9/25/96
5206 */
5207 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5208 goto screamer2;
79072805
LW		 5209 }
5210 }
5211
1c846c1f 5212 if (RsPARA(PL_rs)) { /* have to do this both before and after */
c07a80fd 5213 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 5214 i = PerlIO_getc(fp);
79072805 5215 if (i != '\n') {
760ac839 5216 PerlIO_ungetc(fp,i);
79072805
LW		 5217 break;
5218 }
5219 }
5220 }
c07a80fd 5221
7d59b7e4
NIS		 5222 if (PerlIO_isutf8(fp))
5223 SvUTF8_on(sv);
5224 else
5225 SvUTF8_off(sv);
5226
c07a80fd 5227 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW		 5228}
5229
760ac839 5230
954c1994
GS		 5231/*
5232=for apidoc sv_inc
5233
5234Auto-increment of the value in the SV.
5235
5236=cut
5237*/
5238
79072805 5239void
864dbfa3 5240Perl_sv_inc(pTHX_ register SV *sv)
79072805
LW		 5241{
5242 register char *d;
463ee0b2 5243 int flags;
79072805
LW		 5244
5245 if (!sv)
5246 return;
b23a5f78
GB		 5247 if (SvGMAGICAL(sv))
5248 mg_get(sv);
ed6116ce 5249 if (SvTHINKFIRST(sv)) {
0f15f207 5250 if (SvREADONLY(sv)) {
3280af22 5251 if (PL_curcop != &PL_compiling)
cea2e8a9 5252 Perl_croak(aTHX_ PL_no_modify);
0f15f207 5253 }
a0d0e21e 5254 if (SvROK(sv)) {
b5be31e9 5255 IV i;
9e7bc3e8
JD		 5256 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5257 return;
56431972 5258 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 5259 sv_unref(sv);
5260 sv_setiv(sv, i);
a0d0e21e 5261 }
ed6116ce 5262 }
8990e307 5263 flags = SvFLAGS(sv);
28e5dec8
JH		 5264 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5265 /* It's (privately or publicly) a float, but not tested as an
5266 integer, so test it to see. */
d460ef45 5267 (void) SvIV(sv);
28e5dec8
JH		 5268 flags = SvFLAGS(sv);
5269 }
5270 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5271 /* It's publicly an integer, or privately an integer-not-float */
5272 oops_its_int:
25da4f38
IZ		 5273 if (SvIsUV(sv)) {
5274 if (SvUVX(sv) == UV_MAX)
65202027 5275 sv_setnv(sv, (NV)UV_MAX + 1.0);
25da4f38
IZ		 5276 else
5277 (void)SvIOK_only_UV(sv);
5278 ++SvUVX(sv);
5279 } else {
5280 if (SvIVX(sv) == IV_MAX)
28e5dec8 5281 sv_setuv(sv, (UV)IV_MAX + 1);
25da4f38
IZ		 5282 else {
5283 (void)SvIOK_only(sv);
5284 ++SvIVX(sv);
1c846c1f 5285 }
55497cff 5286 }
79072805
LW		 5287 return;
5288 }
28e5dec8
JH		 5289 if (flags & SVp_NOK) {
5290 (void)SvNOK_only(sv);
5291 SvNVX(sv) += 1.0;
5292 return;
5293 }
5294
8990e307 5295 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
28e5dec8
JH		 5296 if ((flags & SVTYPEMASK) < SVt_PVIV)
5297 sv_upgrade(sv, SVt_IV);
5298 (void)SvIOK_only(sv);
5299 SvIVX(sv) = 1;
79072805
LW		 5300 return;
5301 }
463ee0b2 5302 d = SvPVX(sv);
79072805
LW		 5303 while (isALPHA(*d)) d++;
5304 while (isDIGIT(*d)) d++;
5305 if (*d) {
28e5dec8
JH		 5306#ifdef PERL_PRESERVE_IVUV
5307 /* Got to punt this an an integer if needs be, but we don't issue
5308 warnings. Probably ought to make the sv_iv_please() that does
5309 the conversion if possible, and silently. */
5310 I32 numtype = looks_like_number(sv);
5311 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5312 /* Need to try really hard to see if it's an integer.
5313 9.22337203685478e+18 is an integer.
5314 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5315 so $a="9.22337203685478e+18"; $a+0; $a++
5316 needs to be the same as $a="9.22337203685478e+18"; $a++
5317 or we go insane. */
d460ef45 5318
28e5dec8
JH		 5319 (void) sv_2iv(sv);
5320 if (SvIOK(sv))
5321 goto oops_its_int;
5322
5323 /* sv_2iv *should* have made this an NV */
5324 if (flags & SVp_NOK) {
5325 (void)SvNOK_only(sv);
5326 SvNVX(sv) += 1.0;
5327 return;
5328 }
5329 /* I don't think we can get here. Maybe I should assert this
5330 And if we do get here I suspect that sv_setnv will croak. NWC
5331 Fall through. */
5332#if defined(USE_LONG_DOUBLE)
5333 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
5334 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5335#else
5336 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5337 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5338#endif
5339 }
5340#endif /* PERL_PRESERVE_IVUV */
5341 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
79072805
LW		 5342 return;
5343 }
5344 d--;
463ee0b2 5345 while (d >= SvPVX(sv)) {
79072805
LW		 5346 if (isDIGIT(*d)) {
5347 if (++*d <= '9')
5348 return;
5349 *(d--) = '0';
5350 }
5351 else {
9d116dd7
JH		 5352#ifdef EBCDIC
5353 /* MKS: The original code here died if letters weren't consecutive.
5354 * at least it didn't have to worry about non-C locales. The
5355 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
1c846c1f 5356 * arranged in order (although not consecutively) and that only
9d116dd7
JH		 5357 * [A-Za-z] are accepted by isALPHA in the C locale.
5358 */
5359 if (*d != 'z' && *d != 'Z') {
5360 do { ++*d; } while (!isALPHA(*d));
5361 return;
5362 }
5363 *(d--) -= 'z' - 'a';
5364#else
79072805
LW		 5365 ++*d;
5366 if (isALPHA(*d))
5367 return;
5368 *(d--) -= 'z' - 'a' + 1;
9d116dd7 5369#endif
79072805
LW		 5370 }
5371 }
5372 /* oh,oh, the number grew */
5373 SvGROW(sv, SvCUR(sv) + 2);
5374 SvCUR(sv)++;
463ee0b2 5375 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW		 5376 *d = d[-1];
5377 if (isDIGIT(d[1]))
5378 *d = '1';
5379 else
5380 *d = d[1];
5381}
5382
954c1994
GS		 5383/*
5384=for apidoc sv_dec
5385
5386Auto-decrement of the value in the SV.
5387
5388=cut
5389*/
5390
79072805 5391void
864dbfa3 5392Perl_sv_dec(pTHX_ register SV *sv)
79072805 5393{
463ee0b2
LW		 5394 int flags;
5395
79072805
LW		 5396 if (!sv)
5397 return;
b23a5f78
GB		 5398 if (SvGMAGICAL(sv))
5399 mg_get(sv);
ed6116ce 5400 if (SvTHINKFIRST(sv)) {
0f15f207 5401 if (SvREADONLY(sv)) {
3280af22 5402 if (PL_curcop != &PL_compiling)
cea2e8a9 5403 Perl_croak(aTHX_ PL_no_modify);
0f15f207 5404 }
a0d0e21e 5405 if (SvROK(sv)) {
b5be31e9 5406 IV i;
9e7bc3e8
JD		 5407 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5408 return;
56431972 5409 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 5410 sv_unref(sv);
5411 sv_setiv(sv, i);
a0d0e21e 5412 }
ed6116ce 5413 }
28e5dec8
JH		 5414 /* Unlike sv_inc we don't have to worry about string-never-numbers
5415 and keeping them magic. But we mustn't warn on punting */
8990e307 5416 flags = SvFLAGS(sv);
28e5dec8
JH		 5417 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5418 /* It's publicly an integer, or privately an integer-not-float */
5419 oops_its_int:
25da4f38
IZ		 5420 if (SvIsUV(sv)) {
5421 if (SvUVX(sv) == 0) {
5422 (void)SvIOK_only(sv);
5423 SvIVX(sv) = -1;
5424 }
5425 else {
5426 (void)SvIOK_only_UV(sv);
5427 --SvUVX(sv);
1c846c1f 5428 }
25da4f38
IZ		 5429 } else {
5430 if (SvIVX(sv) == IV_MIN)
65202027 5431 sv_setnv(sv, (NV)IV_MIN - 1.0);
25da4f38
IZ		 5432 else {
5433 (void)SvIOK_only(sv);
5434 --SvIVX(sv);
1c846c1f 5435 }
55497cff 5436 }
5437 return;
5438 }
28e5dec8
JH		 5439 if (flags & SVp_NOK) {
5440 SvNVX(sv) -= 1.0;
5441 (void)SvNOK_only(sv);
5442 return;
5443 }
8990e307 5444 if (!(flags & SVp_POK)) {
4633a7c4
LW		 5445 if ((flags & SVTYPEMASK) < SVt_PVNV)
5446 sv_upgrade(sv, SVt_NV);
463ee0b2 5447 SvNVX(sv) = -1.0;
a0d0e21e 5448 (void)SvNOK_only(sv);
79072805
LW		 5449 return;
5450 }
28e5dec8
JH		 5451#ifdef PERL_PRESERVE_IVUV
5452 {
5453 I32 numtype = looks_like_number(sv);
5454 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5455 /* Need to try really hard to see if it's an integer.
5456 9.22337203685478e+18 is an integer.
5457 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5458 so $a="9.22337203685478e+18"; $a+0; $a--
5459 needs to be the same as $a="9.22337203685478e+18"; $a--
5460 or we go insane. */
d460ef45 5461
28e5dec8
JH		 5462 (void) sv_2iv(sv);
5463 if (SvIOK(sv))
5464 goto oops_its_int;
5465
5466 /* sv_2iv *should* have made this an NV */
5467 if (flags & SVp_NOK) {
5468 (void)SvNOK_only(sv);
5469 SvNVX(sv) -= 1.0;
5470 return;
5471 }
5472 /* I don't think we can get here. Maybe I should assert this
5473 And if we do get here I suspect that sv_setnv will croak. NWC
5474 Fall through. */
5475#if defined(USE_LONG_DOUBLE)
5476 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
5477 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5478#else
5479 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5480 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5481#endif
5482 }
5483 }
5484#endif /* PERL_PRESERVE_IVUV */
097ee67d 5485 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW		 5486}
5487
954c1994
GS		 5488/*
5489=for apidoc sv_mortalcopy
5490
5491Creates a new SV which is a copy of the original SV. The new SV is marked
5492as mortal.
5493
5494=cut
5495*/
5496
79072805
LW		 5497/* Make a string that will exist for the duration of the expression
5498 * evaluation. Actually, it may have to last longer than that, but
5499 * hopefully we won't free it until it has been assigned to a
5500 * permanent location. */
5501
5502SV *
864dbfa3 5503Perl_sv_mortalcopy(pTHX_ SV *oldstr)
79072805 5504{
463ee0b2 5505 register SV *sv;
79072805 5506
4561caa4 5507 new_SV(sv);
79072805 5508 sv_setsv(sv,oldstr);
677b06e3
GS		 5509 EXTEND_MORTAL(1);
5510 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307
LW		 5511 SvTEMP_on(sv);
5512 return sv;
5513}
5514
954c1994
GS		 5515/*
5516=for apidoc sv_newmortal
5517
5518Creates a new SV which is mortal. The reference count of the SV is set to 1.
5519
5520=cut
5521*/
5522
8990e307 5523SV *
864dbfa3 5524Perl_sv_newmortal(pTHX)
8990e307
LW		 5525{
5526 register SV *sv;
5527
4561caa4 5528 new_SV(sv);
8990e307 5529 SvFLAGS(sv) = SVs_TEMP;
677b06e3
GS		 5530 EXTEND_MORTAL(1);
5531 PL_tmps_stack[++PL_tmps_ix] = sv;
79072805
LW		 5532 return sv;
5533}
5534
954c1994
GS		 5535/*
5536=for apidoc sv_2mortal
5537
5538Marks an SV as mortal. The SV will be destroyed when the current context
5539ends.
5540
5541=cut
5542*/
5543
79072805
LW		 5544/* same thing without the copying */
5545
5546SV *
864dbfa3 5547Perl_sv_2mortal(pTHX_ register SV *sv)
79072805
LW		 5548{
5549 if (!sv)
5550 return sv;
d689ffdd 5551 if (SvREADONLY(sv) && SvIMMORTAL(sv))
11162842 5552 return sv;
677b06e3
GS		 5553 EXTEND_MORTAL(1);
5554 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307 5555 SvTEMP_on(sv);
79072805
LW		 5556 return sv;
5557}
5558
954c1994
GS		 5559/*
5560=for apidoc newSVpv
5561
5562Creates a new SV and copies a string into it. The reference count for the
5563SV is set to 1. If C<len> is zero, Perl will compute the length using
5564strlen(). For efficiency, consider using C<newSVpvn> instead.
5565
5566=cut
5567*/
5568
79072805 5569SV *
864dbfa3 5570Perl_newSVpv(pTHX_ const char *s, STRLEN len)
79072805 5571{
463ee0b2 5572 register SV *sv;
79072805 5573
4561caa4 5574 new_SV(sv);
79072805
LW		 5575 if (!len)
5576 len = strlen(s);
5577 sv_setpvn(sv,s,len);
5578 return sv;
5579}
5580
954c1994
GS		 5581/*
5582=for apidoc newSVpvn
5583
5584Creates a new SV and copies a string into it. The reference count for the
1c846c1f 5585SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
954c1994
GS		 5586string. You are responsible for ensuring that the source string is at least
5587C<len> bytes long.
5588
5589=cut
5590*/
5591
9da1e3b5 5592SV *
864dbfa3 5593Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
9da1e3b5
MUN		 5594{
5595 register SV *sv;
5596
5597 new_SV(sv);
9da1e3b5
MUN		 5598 sv_setpvn(sv,s,len);
5599 return sv;
5600}
5601
1c846c1f
NIS		 5602/*
5603=for apidoc newSVpvn_share
5604
5605Creates a new SV and populates it with a string from
5606the string table. Turns on READONLY and FAKE.
5607The idea here is that as string table is used for shared hash
5608keys these strings will have SvPVX == HeKEY and hash lookup
5609will avoid string compare.
5610
5611=cut
5612*/
5613
5614SV *
c3654f1a 5615Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
1c846c1f
NIS		 5616{
5617 register SV *sv;
c3654f1a
IH		 5618 bool is_utf8 = FALSE;
5619 if (len < 0) {
5620 len = -len;
5621 is_utf8 = TRUE;
5622 }
75a54232
JH		 5623 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5624 STRLEN tmplen = len;
5625 /* See the note in hv.c:hv_fetch() --jhi */
5626 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5627 len = tmplen;
5628 }
1c846c1f
NIS		 5629 if (!hash)
5630 PERL_HASH(hash, src, len);
5631 new_SV(sv);
5632 sv_upgrade(sv, SVt_PVIV);
c3654f1a 5633 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
1c846c1f
NIS		 5634 SvCUR(sv) = len;
5635 SvUVX(sv) = hash;
5636 SvLEN(sv) = 0;
5637 SvREADONLY_on(sv);
5638 SvFAKE_on(sv);
5639 SvPOK_on(sv);
c3654f1a
IH		 5640 if (is_utf8)
5641 SvUTF8_on(sv);
1c846c1f
NIS		 5642 return sv;
5643}
5644
cea2e8a9 5645#if defined(PERL_IMPLICIT_CONTEXT)
46fc3d4c 5646SV *
cea2e8a9 5647Perl_newSVpvf_nocontext(const char* pat, ...)
46fc3d4c 5648{
cea2e8a9 5649 dTHX;
46fc3d4c 5650 register SV *sv;
5651 va_list args;
46fc3d4c 5652 va_start(args, pat);
c5be433b 5653 sv = vnewSVpvf(pat, &args);
46fc3d4c 5654 va_end(args);
5655 return sv;
5656}
cea2e8a9 5657#endif
46fc3d4c 5658
954c1994
GS		 5659/*
5660=for apidoc newSVpvf
5661
5662Creates a new SV an initialize it with the string formatted like
5663C<sprintf>.
5664
5665=cut
5666*/
5667
cea2e8a9
GS		 5668SV *
5669Perl_newSVpvf(pTHX_ const char* pat, ...)
5670{
5671 register SV *sv;
5672 va_list args;
cea2e8a9 5673 va_start(args, pat);
c5be433b 5674 sv = vnewSVpvf(pat, &args);
cea2e8a9
GS		 5675 va_end(args);
5676 return sv;
5677}
46fc3d4c 5678
79072805 5679SV *
c5be433b
GS		 5680Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5681{
5682 register SV *sv;
5683 new_SV(sv);
5684 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5685 return sv;
5686}
5687
954c1994
GS		 5688/*
5689=for apidoc newSVnv
5690
5691Creates a new SV and copies a floating point value into it.
5692The reference count for the SV is set to 1.
5693
5694=cut
5695*/
5696
c5be433b 5697SV *
65202027 5698Perl_newSVnv(pTHX_ NV n)
79072805 5699{
463ee0b2 5700 register SV *sv;
79072805 5701
4561caa4 5702 new_SV(sv);
79072805
LW		 5703 sv_setnv(sv,n);
5704 return sv;
5705}
5706
954c1994
GS		 5707/*
5708=for apidoc newSViv
5709
5710Creates a new SV and copies an integer into it. The reference count for the
5711SV is set to 1.
5712
5713=cut
5714*/
5715
79072805 5716SV *
864dbfa3 5717Perl_newSViv(pTHX_ IV i)
79072805 5718{
463ee0b2 5719 register SV *sv;
79072805 5720
4561caa4 5721 new_SV(sv);
79072805
LW		 5722 sv_setiv(sv,i);
5723 return sv;
5724}
5725
954c1994 5726/*
1a3327fb
JH		 5727=for apidoc newSVuv
5728
5729Creates a new SV and copies an unsigned integer into it.
5730The reference count for the SV is set to 1.
5731
5732=cut
5733*/
5734
5735SV *
5736Perl_newSVuv(pTHX_ UV u)
5737{
5738 register SV *sv;
5739
5740 new_SV(sv);
5741 sv_setuv(sv,u);
5742 return sv;
5743}
5744
5745/*
954c1994
GS		 5746=for apidoc newRV_noinc
5747
5748Creates an RV wrapper for an SV. The reference count for the original
5749SV is B<not> incremented.
5750
5751=cut
5752*/
5753
2304df62 5754SV *
864dbfa3 5755Perl_newRV_noinc(pTHX_ SV *tmpRef)
2304df62
AD		 5756{
5757 register SV *sv;
5758
4561caa4 5759 new_SV(sv);
2304df62 5760 sv_upgrade(sv, SVt_RV);
76e3520e 5761 SvTEMP_off(tmpRef);
d689ffdd 5762 SvRV(sv) = tmpRef;
2304df62 5763 SvROK_on(sv);
2304df62
AD		 5764 return sv;
5765}
5766
954c1994 5767/* newRV_inc is #defined to newRV in sv.h */
5f05dabc 5768SV *
864dbfa3 5769Perl_newRV(pTHX_ SV *tmpRef)
5f05dabc 5770{
5f6447b6 5771 return newRV_noinc(SvREFCNT_inc(tmpRef));
5f05dabc 5772}
5f05dabc 5773
954c1994
GS		 5774/*
5775=for apidoc newSVsv
5776
5777Creates a new SV which is an exact duplicate of the original SV.
5778
5779=cut
5780*/
5781
79072805
LW		 5782/* make an exact duplicate of old */
5783
5784SV *
864dbfa3 5785Perl_newSVsv(pTHX_ register SV *old)
79072805 5786{
463ee0b2 5787 register SV *sv;
79072805
LW		 5788
5789 if (!old)
5790 return Nullsv;
8990e307 5791 if (SvTYPE(old) == SVTYPEMASK) {
0453d815
PM		 5792 if (ckWARN_d(WARN_INTERNAL))
5793 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
79072805
LW		 5794 return Nullsv;
5795 }
4561caa4 5796 new_SV(sv);
ff68c719 5797 if (SvTEMP(old)) {
5798 SvTEMP_off(old);
463ee0b2 5799 sv_setsv(sv,old);
ff68c719 5800 SvTEMP_on(old);
79072805
LW		 5801 }
5802 else
463ee0b2
LW		 5803 sv_setsv(sv,old);
5804 return sv;
79072805
LW		 5805}
5806
5807void
864dbfa3 5808Perl_sv_reset(pTHX_ register char *s, HV *stash)
79072805
LW		 5809{
5810 register HE *entry;
5811 register GV *gv;
5812 register SV *sv;
5813 register I32 i;
5814 register PMOP *pm;
5815 register I32 max;
4802d5d7 5816 char todo[PERL_UCHAR_MAX+1];
79072805 5817
49d8d3a1
MB		 5818 if (!stash)
5819 return;
5820
79072805
LW		 5821 if (!*s) { /* reset ?? searches */
5822 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
48c036b1 5823 pm->op_pmdynflags &= ~PMdf_USED;
79072805
LW		 5824 }
5825 return;
5826 }
5827
5828 /* reset variables */
5829
5830 if (!HvARRAY(stash))
5831 return;
463ee0b2
LW		 5832
5833 Zero(todo, 256, char);
79072805 5834 while (*s) {
4802d5d7 5835 i = (unsigned char)*s;
79072805
LW		 5836 if (s[1] == '-') {
5837 s += 2;
5838 }
4802d5d7 5839 max = (unsigned char)*s++;
79072805 5840 for ( ; i <= max; i++) {
463ee0b2
LW		 5841 todo[i] = 1;
5842 }
a0d0e21e 5843 for (i = 0; i <= (I32) HvMAX(stash); i++) {
79072805 5844 for (entry = HvARRAY(stash)[i];
9e35f4b3
GS		 5845 entry;
5846 entry = HeNEXT(entry))
5847 {
1edc1566 5848 if (!todo[(U8)*HeKEY(entry)])
463ee0b2 5849 continue;
1edc1566 5850 gv = (GV*)HeVAL(entry);
79072805 5851 sv = GvSV(gv);
9e35f4b3
GS		 5852 if (SvTHINKFIRST(sv)) {
5853 if (!SvREADONLY(sv) && SvROK(sv))
5854 sv_unref(sv);
5855 continue;
5856 }
a0d0e21e 5857 (void)SvOK_off(sv);
79072805
LW		 5858 if (SvTYPE(sv) >= SVt_PV) {
5859 SvCUR_set(sv, 0);
463ee0b2
LW		 5860 if (SvPVX(sv) != Nullch)
5861 *SvPVX(sv) = '\0';
44a8e56a 5862 SvTAINT(sv);
79072805
LW		 5863 }
5864 if (GvAV(gv)) {
5865 av_clear(GvAV(gv));
5866 }
44a8e56a 5867 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
463ee0b2 5868 hv_clear(GvHV(gv));
fa6a1c44 5869#ifdef USE_ENVIRON_ARRAY
3280af22 5870 if (gv == PL_envgv)
79072805 5871 environ[0] = Nullch;
a0d0e21e 5872#endif
79072805
LW		 5873 }
5874 }
5875 }
5876 }
5877}
5878
46fc3d4c 5879IO*
864dbfa3 5880Perl_sv_2io(pTHX_ SV *sv)
46fc3d4c 5881{
5882 IO* io;
5883 GV* gv;
2d8e6c8d 5884 STRLEN n_a;
46fc3d4c 5885
5886 switch (SvTYPE(sv)) {
5887 case SVt_PVIO:
5888 io = (IO*)sv;
5889 break;
5890 case SVt_PVGV:
5891 gv = (GV*)sv;
5892 io = GvIO(gv);
5893 if (!io)
cea2e8a9 5894 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
46fc3d4c 5895 break;
5896 default:
5897 if (!SvOK(sv))
cea2e8a9 5898 Perl_croak(aTHX_ PL_no_usym, "filehandle");
46fc3d4c 5899 if (SvROK(sv))
5900 return sv_2io(SvRV(sv));
2d8e6c8d 5901 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
46fc3d4c 5902 if (gv)
5903 io = GvIO(gv);
5904 else
5905 io = 0;
5906 if (!io)
cea2e8a9 5907 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
46fc3d4c 5908 break;
5909 }
5910 return io;
5911}
5912
79072805 5913CV *
864dbfa3 5914Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
79072805
LW		 5915{
5916 GV *gv;
5917 CV *cv;
2d8e6c8d 5918 STRLEN n_a;
79072805
LW		 5919
5920 if (!sv)
93a17b20 5921 return *gvp = Nullgv, Nullcv;
79072805 5922 switch (SvTYPE(sv)) {
79072805
LW		 5923 case SVt_PVCV:
5924 *st = CvSTASH(sv);
5925 *gvp = Nullgv;
5926 return (CV*)sv;
5927 case SVt_PVHV:
5928 case SVt_PVAV:
5929 *gvp = Nullgv;
5930 return Nullcv;
8990e307
LW		 5931 case SVt_PVGV:
5932 gv = (GV*)sv;
a0d0e21e 5933 *gvp = gv;
8990e307
LW		 5934 *st = GvESTASH(gv);
5935 goto fix_gv;
5936
79072805 5937 default:
a0d0e21e
LW		 5938 if (SvGMAGICAL(sv))
5939 mg_get(sv);
5940 if (SvROK(sv)) {
f5284f61
IZ		 5941 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5942 tryAMAGICunDEREF(to_cv);
5943
62f274bf
GS		 5944 sv = SvRV(sv);
5945 if (SvTYPE(sv) == SVt_PVCV) {
5946 cv = (CV*)sv;
5947 *gvp = Nullgv;
5948 *st = CvSTASH(cv);
5949 return cv;
5950 }
5951 else if(isGV(sv))
5952 gv = (GV*)sv;
5953 else
cea2e8a9 5954 Perl_croak(aTHX_ "Not a subroutine reference");
a0d0e21e 5955 }
62f274bf 5956 else if (isGV(sv))
79072805
LW		 5957 gv = (GV*)sv;
5958 else
2d8e6c8d 5959 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
79072805
LW		 5960 *gvp = gv;
5961 if (!gv)
5962 return Nullcv;
5963 *st = GvESTASH(gv);
8990e307 5964 fix_gv:
8ebc5c01 5965 if (lref && !GvCVu(gv)) {
4633a7c4 5966 SV *tmpsv;
748a9306 5967 ENTER;
4633a7c4 5968 tmpsv = NEWSV(704,0);
16660edb 5969 gv_efullname3(tmpsv, gv, Nullch);
f6ec51f7
GS		 5970 /* XXX this is probably not what they think they're getting.
5971 * It has the same effect as "sub name;", i.e. just a forward
5972 * declaration! */
774d564b 5973 newSUB(start_subparse(FALSE, 0),
4633a7c4
LW		 5974 newSVOP(OP_CONST, 0, tmpsv),
5975 Nullop,
8990e307 5976 Nullop);
748a9306 5977 LEAVE;
8ebc5c01 5978 if (!GvCVu(gv))
cea2e8a9 5979 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
8990e307 5980 }
8ebc5c01 5981 return GvCVu(gv);
79072805
LW		 5982 }
5983}
5984
c461cf8f
JH		 5985/*
5986=for apidoc sv_true
5987
5988Returns true if the SV has a true value by Perl's rules.
5989
5990=cut
5991*/
5992
79072805 5993I32
864dbfa3 5994Perl_sv_true(pTHX_ register SV *sv)
79072805 5995{
8990e307
LW		 5996 if (!sv)
5997 return 0;
79072805 5998 if (SvPOK(sv)) {
4e35701f
NIS		 5999 register XPV* tXpv;
6000 if ((tXpv = (XPV*)SvANY(sv)) &&
c2f1de04 6001 (tXpv->xpv_cur > 1 ||
4e35701f 6002 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
79072805
LW		 6003 return 1;
6004 else
6005 return 0;
6006 }
6007 else {
6008 if (SvIOK(sv))
463ee0b2 6009 return SvIVX(sv) != 0;
79072805
LW		 6010 else {
6011 if (SvNOK(sv))
463ee0b2 6012 return SvNVX(sv) != 0.0;
79072805 6013 else
463ee0b2 6014 return sv_2bool(sv);
79072805
LW		 6015 }
6016 }
6017}
79072805 6018
ff68c719 6019IV
864dbfa3 6020Perl_sv_iv(pTHX_ register SV *sv)
85e6fe83 6021{
25da4f38
IZ		 6022 if (SvIOK(sv)) {
6023 if (SvIsUV(sv))
6024 return (IV)SvUVX(sv);
ff68c719 6025 return SvIVX(sv);
25da4f38 6026 }
ff68c719 6027 return sv_2iv(sv);
85e6fe83 6028}
85e6fe83 6029
ff68c719 6030UV
864dbfa3 6031Perl_sv_uv(pTHX_ register SV *sv)
ff68c719 6032{
25da4f38
IZ		 6033 if (SvIOK(sv)) {
6034 if (SvIsUV(sv))
6035 return SvUVX(sv);
6036 return (UV)SvIVX(sv);
6037 }
ff68c719 6038 return sv_2uv(sv);
6039}
85e6fe83 6040
65202027 6041NV
864dbfa3 6042Perl_sv_nv(pTHX_ register SV *sv)
79072805 6043{
ff68c719 6044 if (SvNOK(sv))
6045 return SvNVX(sv);
6046 return sv_2nv(sv);
79072805 6047}
79072805 6048
79072805 6049char *
864dbfa3 6050Perl_sv_pv(pTHX_ SV *sv)
1fa8b10d
JD		 6051{
6052 STRLEN n_a;
6053
6054 if (SvPOK(sv))
6055 return SvPVX(sv);
6056
6057 return sv_2pv(sv, &n_a);
6058}
6059
6060char *
864dbfa3 6061Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
79072805 6062{
85e6fe83
LW		 6063 if (SvPOK(sv)) {
6064 *lp = SvCUR(sv);
a0d0e21e 6065 return SvPVX(sv);
85e6fe83 6066 }
463ee0b2 6067 return sv_2pv(sv, lp);
79072805 6068}
79072805 6069
c461cf8f
JH		 6070/*
6071=for apidoc sv_pvn_force
6072
6073Get a sensible string out of the SV somehow.
6074
6075=cut
6076*/
6077
a0d0e21e 6078char *
864dbfa3 6079Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
a0d0e21e
LW		 6080{
6081 char *s;
6082
6fc92669
GS		 6083 if (SvTHINKFIRST(sv) && !SvROK(sv))
6084 sv_force_normal(sv);
1c846c1f 6085
a0d0e21e
LW		 6086 if (SvPOK(sv)) {
6087 *lp = SvCUR(sv);
6088 }
6089 else {
748a9306 6090 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
cea2e8a9 6091 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6fc92669 6092 PL_op_name[PL_op->op_type]);
a0d0e21e 6093 }
4633a7c4
LW		 6094 else
6095 s = sv_2pv(sv, lp);
a0d0e21e
LW		 6096 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6097 STRLEN len = *lp;
1c846c1f 6098
a0d0e21e
LW		 6099 if (SvROK(sv))
6100 sv_unref(sv);
6101 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6102 SvGROW(sv, len + 1);
6103 Move(s,SvPVX(sv),len,char);
6104 SvCUR_set(sv, len);
6105 *SvEND(sv) = '\0';
6106 }
6107 if (!SvPOK(sv)) {
6108 SvPOK_on(sv); /* validate pointer */
6109 SvTAINT(sv);
1d7c1841
GS		 6110 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6111 PTR2UV(sv),SvPVX(sv)));
a0d0e21e
LW		 6112 }
6113 }
6114 return SvPVX(sv);
6115}
6116
6117char *
7340a771
GS		 6118Perl_sv_pvbyte(pTHX_ SV *sv)
6119{
6120 return sv_pv(sv);
6121}
6122
6123char *
6124Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6125{
6126 return sv_pvn(sv,lp);
6127}
6128
6129char *
6130Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6131{
6132 return sv_pvn_force(sv,lp);
6133}
6134
6135char *
6136Perl_sv_pvutf8(pTHX_ SV *sv)
6137{
560a288e 6138 sv_utf8_upgrade(sv);
7340a771
GS		 6139 return sv_pv(sv);
6140}
6141
6142char *
6143Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6144{
560a288e 6145 sv_utf8_upgrade(sv);
7340a771
GS		 6146 return sv_pvn(sv,lp);
6147}
6148
c461cf8f
JH		 6149/*
6150=for apidoc sv_pvutf8n_force
6151
6152Get a sensible UTF8-encoded string out of the SV somehow. See
6153L</sv_pvn_force>.
6154
6155=cut
6156*/
6157
7340a771
GS		 6158char *
6159Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6160{
560a288e 6161 sv_utf8_upgrade(sv);
7340a771
GS		 6162 return sv_pvn_force(sv,lp);
6163}
6164
c461cf8f
JH		 6165/*
6166=for apidoc sv_reftype
6167
6168Returns a string describing what the SV is a reference to.
6169
6170=cut
6171*/
6172
7340a771 6173char *
864dbfa3 6174Perl_sv_reftype(pTHX_ SV *sv, int ob)
a0d0e21e
LW		 6175{
6176 if (ob && SvOBJECT(sv))
6177 return HvNAME(SvSTASH(sv));
6178 else {
6179 switch (SvTYPE(sv)) {
6180 case SVt_NULL:
6181 case SVt_IV:
6182 case SVt_NV:
6183 case SVt_RV:
6184 case SVt_PV:
6185 case SVt_PVIV:
6186 case SVt_PVNV:
6187 case SVt_PVMG:
6188 case SVt_PVBM:
6189 if (SvROK(sv))
6190 return "REF";
6191 else
6192 return "SCALAR";
6193 case SVt_PVLV: return "LVALUE";
6194 case SVt_PVAV: return "ARRAY";
6195 case SVt_PVHV: return "HASH";
6196 case SVt_PVCV: return "CODE";
6197 case SVt_PVGV: return "GLOB";
1d2dff63 6198 case SVt_PVFM: return "FORMAT";
27f9d8f3 6199 case SVt_PVIO: return "IO";
a0d0e21e
LW		 6200 default: return "UNKNOWN";
6201 }
6202 }
6203}
6204
954c1994
GS		 6205/*
6206=for apidoc sv_isobject
6207
6208Returns a boolean indicating whether the SV is an RV pointing to a blessed
6209object. If the SV is not an RV, or if the object is not blessed, then this
6210will return false.
6211
6212=cut
6213*/
6214
463ee0b2 6215int
864dbfa3 6216Perl_sv_isobject(pTHX_ SV *sv)
85e6fe83 6217{
68dc0745 6218 if (!sv)
6219 return 0;
6220 if (SvGMAGICAL(sv))
6221 mg_get(sv);
85e6fe83
LW		 6222 if (!SvROK(sv))
6223 return 0;
6224 sv = (SV*)SvRV(sv);
6225 if (!SvOBJECT(sv))
6226 return 0;
6227 return 1;
6228}
6229
954c1994
GS		 6230/*
6231=for apidoc sv_isa
6232
6233Returns a boolean indicating whether the SV is blessed into the specified
6234class. This does not check for subtypes; use C<sv_derived_from> to verify
6235an inheritance relationship.
6236
6237=cut
6238*/
6239
85e6fe83 6240int
864dbfa3 6241Perl_sv_isa(pTHX_ SV *sv, const char *name)
463ee0b2 6242{
68dc0745 6243 if (!sv)
6244 return 0;
6245 if (SvGMAGICAL(sv))
6246 mg_get(sv);
ed6116ce 6247 if (!SvROK(sv))
463ee0b2 6248 return 0;
ed6116ce
LW		 6249 sv = (SV*)SvRV(sv);
6250 if (!SvOBJECT(sv))
463ee0b2
LW		 6251 return 0;
6252
6253 return strEQ(HvNAME(SvSTASH(sv)), name);
6254}
6255
954c1994
GS		 6256/*
6257=for apidoc newSVrv
6258
6259Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6260it will be upgraded to one. If C<classname> is non-null then the new SV will
6261be blessed in the specified package. The new SV is returned and its
6262reference count is 1.
6263
6264=cut
6265*/
6266
463ee0b2 6267SV*
864dbfa3 6268Perl_newSVrv(pTHX_ SV *rv, const char *classname)
463ee0b2 6269{
463ee0b2
LW		 6270 SV *sv;
6271
4561caa4 6272 new_SV(sv);
51cf62d8 6273
2213622d 6274 SV_CHECK_THINKFIRST(rv);
51cf62d8 6275 SvAMAGIC_off(rv);
51cf62d8 6276
0199fce9
JD		 6277 if (SvTYPE(rv) >= SVt_PVMG) {
6278 U32 refcnt = SvREFCNT(rv);
6279 SvREFCNT(rv) = 0;
6280 sv_clear(rv);
6281 SvFLAGS(rv) = 0;
6282 SvREFCNT(rv) = refcnt;
6283 }
6284
51cf62d8 6285 if (SvTYPE(rv) < SVt_RV)
0199fce9
JD		 6286 sv_upgrade(rv, SVt_RV);
6287 else if (SvTYPE(rv) > SVt_RV) {
6288 (void)SvOOK_off(rv);
6289 if (SvPVX(rv) && SvLEN(rv))
6290 Safefree(SvPVX(rv));
6291 SvCUR_set(rv, 0);
6292 SvLEN_set(rv, 0);
6293 }
51cf62d8
OT		 6294
6295 (void)SvOK_off(rv);
053fc874 6296 SvRV(rv) = sv;
ed6116ce 6297 SvROK_on(rv);
463ee0b2 6298
a0d0e21e
LW		 6299 if (classname) {
6300 HV* stash = gv_stashpv(classname, TRUE);
6301 (void)sv_bless(rv, stash);
6302 }
6303 return sv;
6304}
6305
954c1994
GS		 6306/*
6307=for apidoc sv_setref_pv
6308
6309Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6310argument will be upgraded to an RV. That RV will be modified to point to
6311the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6312into the SV. The C<classname> argument indicates the package for the
6313blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6314will be returned and will have a reference count of 1.
6315
6316Do not use with other Perl types such as HV, AV, SV, CV, because those
6317objects will become corrupted by the pointer copy process.
6318
6319Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6320
6321=cut
6322*/
6323
a0d0e21e 6324SV*
864dbfa3 6325Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
a0d0e21e 6326{
189b2af5 6327 if (!pv) {
3280af22 6328 sv_setsv(rv, &PL_sv_undef);
189b2af5
GS		 6329 SvSETMAGIC(rv);
6330 }
a0d0e21e 6331 else
56431972 6332 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
a0d0e21e
LW		 6333 return rv;
6334}
6335
954c1994
GS		 6336/*
6337=for apidoc sv_setref_iv
6338
6339Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6340argument will be upgraded to an RV. That RV will be modified to point to
6341the new SV. The C<classname> argument indicates the package for the
6342blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6343will be returned and will have a reference count of 1.
6344
6345=cut
6346*/
6347
a0d0e21e 6348SV*
864dbfa3 6349Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
a0d0e21e
LW		 6350{
6351 sv_setiv(newSVrv(rv,classname), iv);
6352 return rv;
6353}
6354
954c1994 6355/*
e1c57cef
JH		 6356=for apidoc sv_setref_uv
6357
6358Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6359argument will be upgraded to an RV. That RV will be modified to point to
6360the new SV. The C<classname> argument indicates the package for the
6361blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6362will be returned and will have a reference count of 1.
6363
6364=cut
6365*/
6366
6367SV*
6368Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6369{
6370 sv_setuv(newSVrv(rv,classname), uv);
6371 return rv;
6372}
6373
6374/*
954c1994
GS		 6375=for apidoc sv_setref_nv
6376
6377Copies a double into a new SV, optionally blessing the SV. The C<rv>
6378argument will be upgraded to an RV. That RV will be modified to point to
6379the new SV. The C<classname> argument indicates the package for the
6380blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6381will be returned and will have a reference count of 1.
6382
6383=cut
6384*/
6385
a0d0e21e 6386SV*
65202027 6387Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
a0d0e21e
LW		 6388{
6389 sv_setnv(newSVrv(rv,classname), nv);
6390 return rv;
6391}
463ee0b2 6392
954c1994
GS		 6393/*
6394=for apidoc sv_setref_pvn
6395
6396Copies a string into a new SV, optionally blessing the SV. The length of the
6397string must be specified with C<n>. The C<rv> argument will be upgraded to
6398an RV. That RV will be modified to point to the new SV. The C<classname>
6399argument indicates the package for the blessing. Set C<classname> to
6400C<Nullch> to avoid the blessing. The new SV will be returned and will have
6401a reference count of 1.
6402
6403Note that C<sv_setref_pv> copies the pointer while this copies the string.
6404
6405=cut
6406*/
6407
a0d0e21e 6408SV*
864dbfa3 6409Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
a0d0e21e
LW		 6410{
6411 sv_setpvn(newSVrv(rv,classname), pv, n);
463ee0b2
LW		 6412 return rv;
6413}
6414
954c1994
GS		 6415/*
6416=for apidoc sv_bless
6417
6418Blesses an SV into a specified package. The SV must be an RV. The package
6419must be designated by its stash (see C<gv_stashpv()>). The reference count
6420of the SV is unaffected.
6421
6422=cut
6423*/
6424
a0d0e21e 6425SV*
864dbfa3 6426Perl_sv_bless(pTHX_ SV *sv, HV *stash)
a0d0e21e 6427{
76e3520e 6428 SV *tmpRef;
a0d0e21e 6429 if (!SvROK(sv))
cea2e8a9 6430 Perl_croak(aTHX_ "Can't bless non-reference value");
76e3520e
GS		 6431 tmpRef = SvRV(sv);
6432 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6433 if (SvREADONLY(tmpRef))
cea2e8a9 6434 Perl_croak(aTHX_ PL_no_modify);
76e3520e
GS		 6435 if (SvOBJECT(tmpRef)) {
6436 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 6437 --PL_sv_objcount;
76e3520e 6438 SvREFCNT_dec(SvSTASH(tmpRef));
2e3febc6 6439 }
a0d0e21e 6440 }
76e3520e
GS		 6441 SvOBJECT_on(tmpRef);
6442 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 6443 ++PL_sv_objcount;
76e3520e
GS		 6444 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6445 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 6446
2e3febc6
CS		 6447 if (Gv_AMG(stash))
6448 SvAMAGIC_on(sv);
6449 else
6450 SvAMAGIC_off(sv);
a0d0e21e
LW		 6451
6452 return sv;
6453}
6454
76e3520e 6455STATIC void
cea2e8a9 6456S_sv_unglob(pTHX_ SV *sv)
a0d0e21e 6457{
850fabdf
GS		 6458 void *xpvmg;
6459
a0d0e21e
LW		 6460 assert(SvTYPE(sv) == SVt_PVGV);
6461 SvFAKE_off(sv);
6462 if (GvGP(sv))
1edc1566 6463 gp_free((GV*)sv);
e826b3c7
GS		 6464 if (GvSTASH(sv)) {
6465 SvREFCNT_dec(GvSTASH(sv));
6466 GvSTASH(sv) = Nullhv;
6467 }
a0d0e21e
LW		 6468 sv_unmagic(sv, '*');
6469 Safefree(GvNAME(sv));
a5f75d66 6470 GvMULTI_off(sv);
850fabdf
GS		 6471
6472 /* need to keep SvANY(sv) in the right arena */
6473 xpvmg = new_XPVMG();
6474 StructCopy(SvANY(sv), xpvmg, XPVMG);
6475 del_XPVGV(SvANY(sv));
6476 SvANY(sv) = xpvmg;
6477
a0d0e21e
LW		 6478 SvFLAGS(sv) &= ~SVTYPEMASK;
6479 SvFLAGS(sv) |= SVt_PVMG;
6480}
6481
954c1994 6482/*
840a7b70 6483=for apidoc sv_unref_flags
954c1994
GS		 6484
6485Unsets the RV status of the SV, and decrements the reference count of
6486whatever was being referenced by the RV. This can almost be thought of
840a7b70
IZ		 6487as a reversal of C<newSVrv>. The C<cflags> argument can contain
6488C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6489(otherwise the decrementing is conditional on the reference count being
6490different from one or the reference being a readonly SV).
7889fe52 6491See C<SvROK_off>.
954c1994
GS		 6492
6493=cut
6494*/
6495
ed6116ce 6496void
840a7b70 6497Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
ed6116ce 6498{
a0d0e21e 6499 SV* rv = SvRV(sv);
810b8aa5
GS		 6500
6501 if (SvWEAKREF(sv)) {
6502 sv_del_backref(sv);
6503 SvWEAKREF_off(sv);
6504 SvRV(sv) = 0;
6505 return;
6506 }
ed6116ce
LW		 6507 SvRV(sv) = 0;
6508 SvROK_off(sv);
840a7b70 6509 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
4633a7c4 6510 SvREFCNT_dec(rv);
840a7b70 6511 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
4633a7c4 6512 sv_2mortal(rv); /* Schedule for freeing later */
ed6116ce 6513}
8990e307 6514
840a7b70
IZ		 6515/*
6516=for apidoc sv_unref
6517
6518Unsets the RV status of the SV, and decrements the reference count of
6519whatever was being referenced by the RV. This can almost be thought of
6520as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7889fe52 6521being zero. See C<SvROK_off>.
840a7b70
IZ		 6522
6523=cut
6524*/
6525
6526void
6527Perl_sv_unref(pTHX_ SV *sv)
6528{
6529 sv_unref_flags(sv, 0);
6530}
6531
bbce6d69 6532void
864dbfa3 6533Perl_sv_taint(pTHX_ SV *sv)
bbce6d69 6534{
6535 sv_magic((sv), Nullsv, 't', Nullch, 0);
6536}
6537
6538void
864dbfa3 6539Perl_sv_untaint(pTHX_ SV *sv)
bbce6d69 6540{
13f57bf8 6541 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
36477c24 6542 MAGIC *mg = mg_find(sv, 't');
6543 if (mg)
565764a8 6544 mg->mg_len &= ~1;
36477c24 6545 }
bbce6d69 6546}
6547
6548bool
864dbfa3 6549Perl_sv_tainted(pTHX_ SV *sv)
bbce6d69 6550{
13f57bf8 6551 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
36477c24 6552 MAGIC *mg = mg_find(sv, 't');
155aba94 6553 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
36477c24 6554 return TRUE;
6555 }
6556 return FALSE;
bbce6d69 6557}
6558
954c1994
GS		 6559/*
6560=for apidoc sv_setpviv
6561
6562Copies an integer into the given SV, also updating its string value.
6563Does not handle 'set' magic. See C<sv_setpviv_mg>.
6564
6565=cut
6566*/
6567
84902520 6568void
864dbfa3 6569Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
84902520 6570{
25da4f38
IZ		 6571 char buf[TYPE_CHARS(UV)];
6572 char *ebuf;
6573 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
84902520 6574
25da4f38 6575 sv_setpvn(sv, ptr, ebuf - ptr);
84902520
TB		 6576}
6577
ef50df4b 6578
954c1994
GS		 6579/*
6580=for apidoc sv_setpviv_mg
6581
6582Like C<sv_setpviv>, but also handles 'set' magic.
6583
6584=cut
6585*/
6586
ef50df4b 6587void
864dbfa3 6588Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
ef50df4b 6589{
25da4f38
IZ		 6590 char buf[TYPE_CHARS(UV)];
6591 char *ebuf;
6592 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6593
6594 sv_setpvn(sv, ptr, ebuf - ptr);
ef50df4b
GS		 6595 SvSETMAGIC(sv);
6596}
6597
cea2e8a9
GS		 6598#if defined(PERL_IMPLICIT_CONTEXT)
6599void
6600Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6601{
6602 dTHX;
6603 va_list args;
6604 va_start(args, pat);
c5be433b 6605 sv_vsetpvf(sv, pat, &args);
cea2e8a9
GS		 6606 va_end(args);
6607}
6608
6609
6610void
6611Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6612{
6613 dTHX;
6614 va_list args;
6615 va_start(args, pat);
c5be433b 6616 sv_vsetpvf_mg(sv, pat, &args);
cea2e8a9 6617 va_end(args);
cea2e8a9
GS		 6618}
6619#endif
6620
954c1994
GS		 6621/*
6622=for apidoc sv_setpvf
6623
6624Processes its arguments like C<sprintf> and sets an SV to the formatted
6625output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6626
6627=cut
6628*/
6629
46fc3d4c 6630void
864dbfa3 6631Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 6632{
6633 va_list args;
46fc3d4c 6634 va_start(args, pat);
c5be433b 6635 sv_vsetpvf(sv, pat, &args);
46fc3d4c 6636 va_end(args);
6637}
6638
c5be433b
GS		 6639void
6640Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6641{
6642 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6643}
ef50df4b 6644
954c1994
GS		 6645/*
6646=for apidoc sv_setpvf_mg
6647
6648Like C<sv_setpvf>, but also handles 'set' magic.
6649
6650=cut
6651*/
6652
ef50df4b 6653void
864dbfa3 6654Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 6655{
6656 va_list args;
ef50df4b 6657 va_start(args, pat);
c5be433b 6658 sv_vsetpvf_mg(sv, pat, &args);
ef50df4b 6659 va_end(args);
c5be433b
GS		 6660}
6661
6662void
6663Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6664{
6665 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 6666 SvSETMAGIC(sv);
6667}
6668
cea2e8a9
GS		 6669#if defined(PERL_IMPLICIT_CONTEXT)
6670void
6671Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6672{
6673 dTHX;
6674 va_list args;
6675 va_start(args, pat);
c5be433b 6676 sv_vcatpvf(sv, pat, &args);
cea2e8a9
GS		 6677 va_end(args);
6678}
6679
6680void
6681Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6682{
6683 dTHX;
6684 va_list args;
6685 va_start(args, pat);
c5be433b 6686 sv_vcatpvf_mg(sv, pat, &args);
cea2e8a9 6687 va_end(args);
cea2e8a9
GS		 6688}
6689#endif
6690
954c1994
GS		 6691/*
6692=for apidoc sv_catpvf
6693
6694Processes its arguments like C<sprintf> and appends the formatted output
6695to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6696typically be called after calling this function to handle 'set' magic.
6697
6698=cut
6699*/
6700
46fc3d4c 6701void
864dbfa3 6702Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 6703{
6704 va_list args;
46fc3d4c 6705 va_start(args, pat);
c5be433b 6706 sv_vcatpvf(sv, pat, &args);
46fc3d4c 6707 va_end(args);
6708}
6709
ef50df4b 6710void
c5be433b
GS		 6711Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6712{
6713 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6714}
6715
954c1994
GS		 6716/*
6717=for apidoc sv_catpvf_mg
6718
6719Like C<sv_catpvf>, but also handles 'set' magic.
6720
6721=cut
6722*/
6723
c5be433b 6724void
864dbfa3 6725Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 6726{
6727 va_list args;
ef50df4b 6728 va_start(args, pat);
c5be433b 6729 sv_vcatpvf_mg(sv, pat, &args);
ef50df4b 6730 va_end(args);
c5be433b
GS		 6731}
6732
6733void
6734Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6735{
6736 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 6737 SvSETMAGIC(sv);
6738}
6739
954c1994
GS		 6740/*
6741=for apidoc sv_vsetpvfn
6742
6743Works like C<vcatpvfn> but copies the text into the SV instead of
6744appending it.
6745
6746=cut
6747*/
6748
46fc3d4c 6749void
7d5ea4e7 6750Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 6751{
6752 sv_setpvn(sv, "", 0);
7d5ea4e7 6753 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
46fc3d4c 6754}
6755
2d00ba3b 6756STATIC I32
9dd79c3f 6757S_expect_number(pTHX_ char** pattern)
211dfcf1
HS		 6758{
6759 I32 var = 0;
6760 switch (**pattern) {
6761 case '1': case '2': case '3':
6762 case '4': case '5': case '6':
6763 case '7': case '8': case '9':
6764 while (isDIGIT(**pattern))
6765 var = var * 10 + (*(*pattern)++ - '0');
6766 }
6767 return var;
6768}
9dd79c3f 6769#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
211dfcf1 6770
954c1994
GS		 6771/*
6772=for apidoc sv_vcatpvfn
6773
6774Processes its arguments like C<vsprintf> and appends the formatted output
6775to an SV. Uses an array of SVs if the C style variable argument list is
6776missing (NULL). When running with taint checks enabled, indicates via
6777C<maybe_tainted> if results are untrustworthy (often due to the use of
6778locales).
6779
6780=cut
6781*/
6782
46fc3d4c 6783void
7d5ea4e7 6784Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 6785{
6786 char *p;
6787 char *q;
6788 char *patend;
fc36a67e 6789 STRLEN origlen;
46fc3d4c 6790 I32 svix = 0;
c635e13b 6791 static char nullstr[] = "(null)";
7e2040f0 6792 SV *argsv;
46fc3d4c 6793
6794 /* no matter what, this is a string now */
fc36a67e 6795 (void)SvPV_force(sv, origlen);
46fc3d4c 6796
fc36a67e 6797 /* special-case "", "%s", and "%_" */
46fc3d4c 6798 if (patlen == 0)
6799 return;
fc36a67e 6800 if (patlen == 2 && pat[0] == '%') {
6801 switch (pat[1]) {
6802 case 's':
c635e13b 6803 if (args) {
6804 char *s = va_arg(*args, char*);
6805 sv_catpv(sv, s ? s : nullstr);
6806 }
7e2040f0 6807 else if (svix < svmax) {
fc36a67e 6808 sv_catsv(sv, *svargs);
7e2040f0
GS		 6809 if (DO_UTF8(*svargs))
6810 SvUTF8_on(sv);
6811 }
fc36a67e 6812 return;
6813 case '_':
6814 if (args) {
7e2040f0
GS		 6815 argsv = va_arg(*args, SV*);
6816 sv_catsv(sv, argsv);
6817 if (DO_UTF8(argsv))
6818 SvUTF8_on(sv);
fc36a67e 6819 return;
6820 }
6821 /* See comment on '_' below */
6822 break;
6823 }
46fc3d4c 6824 }
6825
6826 patend = (char*)pat + patlen;
6827 for (p = (char*)pat; p < patend; p = q) {
6828 bool alt = FALSE;
6829 bool left = FALSE;
b22c7a20 6830 bool vectorize = FALSE;
211dfcf1 6831 bool vectorarg = FALSE;
b2e23cf9 6832 bool vec_utf = FALSE;
46fc3d4c 6833 char fill = ' ';
6834 char plus = 0;
6835 char intsize = 0;
6836 STRLEN width = 0;
fc36a67e 6837 STRLEN zeros = 0;
46fc3d4c 6838 bool has_precis = FALSE;
6839 STRLEN precis = 0;
7e2040f0 6840 bool is_utf = FALSE;
eb3fce90 6841
46fc3d4c 6842 char esignbuf[4];
ad391ad9 6843 U8 utf8buf[UTF8_MAXLEN+1];
46fc3d4c 6844 STRLEN esignlen = 0;
6845
6846 char *eptr = Nullch;
fc36a67e 6847 STRLEN elen = 0;
089c015b
JH		 6848 /* Times 4: a decimal digit takes more than 3 binary digits.
6849 * NV_DIG: mantissa takes than many decimal digits.
6850 * Plus 32: Playing safe. */
6851 char ebuf[IV_DIG * 4 + NV_DIG + 32];
2d4389e4
JH		 6852 /* large enough for "%#.#f" --chip */
6853 /* what about long double NVs? --jhi */
b22c7a20
GS		 6854
6855 SV *vecsv;
a05b299f 6856 U8 *vecstr = Null(U8*);
b22c7a20 6857 STRLEN veclen = 0;
46fc3d4c 6858 char c;
6859 int i;
6860 unsigned base;
6861 IV iv;
6862 UV uv;
65202027 6863 NV nv;
46fc3d4c 6864 STRLEN have;
6865 STRLEN need;
6866 STRLEN gap;
b22c7a20
GS		 6867 char *dotstr = ".";
6868 STRLEN dotstrlen = 1;
211dfcf1 6869 I32 efix = 0; /* explicit format parameter index */
eb3fce90 6870 I32 ewix = 0; /* explicit width index */
211dfcf1
HS		 6871 I32 epix = 0; /* explicit precision index */
6872 I32 evix = 0; /* explicit vector index */
eb3fce90 6873 bool asterisk = FALSE;
46fc3d4c 6874
211dfcf1 6875 /* echo everything up to the next format specification */
46fc3d4c 6876 for (q = p; q < patend && *q != '%'; ++q) ;
6877 if (q > p) {
6878 sv_catpvn(sv, p, q - p);
6879 p = q;
6880 }
6881 if (q++ >= patend)
6882 break;
6883
211dfcf1
HS		 6884/*
6885 We allow format specification elements in this order:
6886 \d+\$ explicit format parameter index
6887 [-+ 0#]+ flags
6888 \*?(\d+\$)?v vector with optional (optionally specified) arg
6889 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6890 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6891 [hlqLV] size
6892 [%bcdefginopsux_DFOUX] format (mandatory)
6893*/
6894 if (EXPECT_NUMBER(q, width)) {
6895 if (*q == '$') {
6896 ++q;
6897 efix = width;
6898 } else {
6899 goto gotwidth;
6900 }
6901 }
6902
fc36a67e 6903 /* FLAGS */
6904
46fc3d4c 6905 while (*q) {
6906 switch (*q) {
6907 case ' ':
6908 case '+':
6909 plus = *q++;
6910 continue;
6911
6912 case '-':
6913 left = TRUE;
6914 q++;
6915 continue;
6916
6917 case '0':
6918 fill = *q++;
6919 continue;
6920
6921 case '#':
6922 alt = TRUE;
6923 q++;
6924 continue;
6925
fc36a67e 6926 default:
6927 break;
6928 }
6929 break;
6930 }
46fc3d4c 6931
211dfcf1 6932 tryasterisk:
eb3fce90 6933 if (*q == '*') {
211dfcf1
HS		 6934 q++;
6935 if (EXPECT_NUMBER(q, ewix))
6936 if (*q++ != '$')
6937 goto unknown;
eb3fce90 6938 asterisk = TRUE;
211dfcf1
HS		 6939 }
6940 if (*q == 'v') {
eb3fce90 6941 q++;
211dfcf1
HS		 6942 if (vectorize)
6943 goto unknown;
9cbac4c7 6944 if ((vectorarg = asterisk)) {
211dfcf1
HS		 6945 evix = ewix;
6946 ewix = 0;
6947 asterisk = FALSE;
6948 }
6949 vectorize = TRUE;
6950 goto tryasterisk;
eb3fce90
JH		 6951 }
6952
211dfcf1
HS		 6953 if (!asterisk)
6954 EXPECT_NUMBER(q, width);
6955
6956 if (vectorize) {
6957 if (vectorarg) {
6958 if (args)
6959 vecsv = va_arg(*args, SV*);
6960 else
6961 vecsv = (evix ? evix <= svmax : svix < svmax) ?
6962 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
4459522c 6963 dotstr = SvPVx(vecsv, dotstrlen);
211dfcf1
HS		 6964 if (DO_UTF8(vecsv))
6965 is_utf = TRUE;
6966 }
6967 if (args) {
6968 vecsv = va_arg(*args, SV*);
6969 vecstr = (U8*)SvPVx(vecsv,veclen);
b2e23cf9 6970 vec_utf = DO_UTF8(vecsv);
eb3fce90 6971 }
211dfcf1
HS		 6972 else if (efix ? efix <= svmax : svix < svmax) {
6973 vecsv = svargs[efix ? efix-1 : svix++];
6974 vecstr = (U8*)SvPVx(vecsv,veclen);
b2e23cf9 6975 vec_utf = DO_UTF8(vecsv);
211dfcf1
HS		 6976 }
6977 else {
6978 vecstr = (U8*)"";
6979 veclen = 0;
6980 }
eb3fce90 6981 }
fc36a67e 6982
eb3fce90 6983 if (asterisk) {
fc36a67e 6984 if (args)
6985 i = va_arg(*args, int);
6986 else
eb3fce90
JH		 6987 i = (ewix ? ewix <= svmax : svix < svmax) ?
6988 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
fc36a67e 6989 left |= (i < 0);
6990 width = (i < 0) ? -i : i;
fc36a67e 6991 }
211dfcf1 6992 gotwidth:
fc36a67e 6993
6994 /* PRECISION */
46fc3d4c 6995
fc36a67e 6996 if (*q == '.') {
6997 q++;
6998 if (*q == '*') {
211dfcf1
HS		 6999 q++;
7000 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7001 goto unknown;
46fc3d4c 7002 if (args)
7003 i = va_arg(*args, int);
7004 else
eb3fce90
JH		 7005 i = (ewix ? ewix <= svmax : svix < svmax)
7006 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
fc36a67e 7007 precis = (i < 0) ? 0 : i;
fc36a67e 7008 }
7009 else {
7010 precis = 0;
7011 while (isDIGIT(*q))
7012 precis = precis * 10 + (*q++ - '0');
7013 }
7014 has_precis = TRUE;
7015 }
46fc3d4c 7016
fc36a67e 7017 /* SIZE */
46fc3d4c 7018
fc36a67e 7019 switch (*q) {
e5c81feb 7020#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6f9bb7fd 7021 case 'L': /* Ld */
e5c81feb
JH		 7022 /* FALL THROUGH */
7023#endif
7024#ifdef HAS_QUAD
6f9bb7fd
GS		 7025 case 'q': /* qd */
7026 intsize = 'q';
7027 q++;
7028 break;
7029#endif
fc36a67e 7030 case 'l':
e5c81feb
JH		 7031#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7032 if (*(q + 1) == 'l') { /* lld, llf */
fc36a67e 7033 intsize = 'q';
7034 q += 2;
46fc3d4c 7035 break;
cf2093f6 7036 }
fc36a67e 7037#endif
6f9bb7fd 7038 /* FALL THROUGH */
fc36a67e 7039 case 'h':
cf2093f6 7040 /* FALL THROUGH */
fc36a67e 7041 case 'V':
7042 intsize = *q++;
46fc3d4c 7043 break;
7044 }
7045
fc36a67e 7046 /* CONVERSION */
7047
211dfcf1
HS		 7048 if (*q == '%') {
7049 eptr = q++;
7050 elen = 1;
7051 goto string;
7052 }
7053
7054 if (!args)
7055 argsv = (efix ? efix <= svmax : svix < svmax) ?
7056 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7057
46fc3d4c 7058 switch (c = *q++) {
7059
7060 /* STRINGS */
7061
46fc3d4c 7062 case 'c':
211dfcf1 7063 uv = args ? va_arg(*args, int) : SvIVx(argsv);
3969a896 7064 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
dfe13c55
GS		 7065 eptr = (char*)utf8buf;
7066 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
7e2040f0
GS		 7067 is_utf = TRUE;
7068 }
7069 else {
7070 c = (char)uv;
7071 eptr = &c;
7072 elen = 1;
a0ed51b3 7073 }
46fc3d4c 7074 goto string;
7075
46fc3d4c 7076 case 's':
7077 if (args) {
fc36a67e 7078 eptr = va_arg(*args, char*);
c635e13b 7079 if (eptr)
1d7c1841
GS		 7080#ifdef MACOS_TRADITIONAL
7081 /* On MacOS, %#s format is used for Pascal strings */
7082 if (alt)
7083 elen = *eptr++;
7084 else
7085#endif
c635e13b 7086 elen = strlen(eptr);
7087 else {
7088 eptr = nullstr;
7089 elen = sizeof nullstr - 1;
7090 }
46fc3d4c 7091 }
211dfcf1 7092 else {
7e2040f0
GS		 7093 eptr = SvPVx(argsv, elen);
7094 if (DO_UTF8(argsv)) {
a0ed51b3
LW		 7095 if (has_precis && precis < elen) {
7096 I32 p = precis;
7e2040f0 7097 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
a0ed51b3
LW		 7098 precis = p;
7099 }
7100 if (width) { /* fudge width (can't fudge elen) */
7e2040f0 7101 width += elen - sv_len_utf8(argsv);
a0ed51b3 7102 }
7e2040f0 7103 is_utf = TRUE;
a0ed51b3
LW		 7104 }
7105 }
46fc3d4c 7106 goto string;
7107
fc36a67e 7108 case '_':
7109 /*
7110 * The "%_" hack might have to be changed someday,
7111 * if ISO or ANSI decide to use '_' for something.
7112 * So we keep it hidden from users' code.
7113 */
7114 if (!args)
7115 goto unknown;
211dfcf1 7116 argsv = va_arg(*args, SV*);
7e2040f0
GS		 7117 eptr = SvPVx(argsv, elen);
7118 if (DO_UTF8(argsv))
7119 is_utf = TRUE;
fc36a67e 7120
46fc3d4c 7121 string:
b22c7a20 7122 vectorize = FALSE;
46fc3d4c 7123 if (has_precis && elen > precis)
7124 elen = precis;
7125 break;
7126
7127 /* INTEGERS */
7128
fc36a67e 7129 case 'p':
c2e66d9e
GS		 7130 if (alt)
7131 goto unknown;
211dfcf1 7132 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
fc36a67e 7133 base = 16;
7134 goto integer;
7135
46fc3d4c 7136 case 'D':
29fe7a80 7137#ifdef IV_IS_QUAD
22f3ae8c 7138 intsize = 'q';
29fe7a80 7139#else
46fc3d4c 7140 intsize = 'l';
29fe7a80 7141#endif
46fc3d4c 7142 /* FALL THROUGH */
7143 case 'd':
7144 case 'i':
b22c7a20 7145 if (vectorize) {
ba210ebe 7146 STRLEN ulen;
211dfcf1
HS		 7147 if (!veclen)
7148 continue;
b2e23cf9 7149 if (vec_utf)
dcad2880 7150 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
b22c7a20 7151 else {
a05b299f 7152 iv = *vecstr;
b22c7a20
GS		 7153 ulen = 1;
7154 }
7155 vecstr += ulen;
7156 veclen -= ulen;
7157 }
7158 else if (args) {
46fc3d4c 7159 switch (intsize) {
7160 case 'h': iv = (short)va_arg(*args, int); break;
7161 default: iv = va_arg(*args, int); break;
7162 case 'l': iv = va_arg(*args, long); break;
fc36a67e 7163 case 'V': iv = va_arg(*args, IV); break;
cf2093f6
JH		 7164#ifdef HAS_QUAD
7165 case 'q': iv = va_arg(*args, Quad_t); break;
7166#endif
46fc3d4c 7167 }
7168 }
7169 else {
211dfcf1 7170 iv = SvIVx(argsv);
46fc3d4c 7171 switch (intsize) {
7172 case 'h': iv = (short)iv; break;
be28567c 7173 default: break;
46fc3d4c 7174 case 'l': iv = (long)iv; break;
fc36a67e 7175 case 'V': break;
cf2093f6
JH		 7176#ifdef HAS_QUAD
7177 case 'q': iv = (Quad_t)iv; break;
7178#endif
46fc3d4c 7179 }
7180 }
7181 if (iv >= 0) {
7182 uv = iv;
7183 if (plus)
7184 esignbuf[esignlen++] = plus;
7185 }
7186 else {
7187 uv = -iv;
7188 esignbuf[esignlen++] = '-';
7189 }
7190 base = 10;
7191 goto integer;
7192
fc36a67e 7193 case 'U':
29fe7a80 7194#ifdef IV_IS_QUAD
22f3ae8c 7195 intsize = 'q';
29fe7a80 7196#else
fc36a67e 7197 intsize = 'l';
29fe7a80 7198#endif
fc36a67e 7199 /* FALL THROUGH */
7200 case 'u':
7201 base = 10;
7202 goto uns_integer;
7203
4f19785b
WSI		 7204 case 'b':
7205 base = 2;
7206 goto uns_integer;
7207
46fc3d4c 7208 case 'O':
29fe7a80 7209#ifdef IV_IS_QUAD
22f3ae8c 7210 intsize = 'q';
29fe7a80 7211#else
46fc3d4c 7212 intsize = 'l';
29fe7a80 7213#endif
46fc3d4c 7214 /* FALL THROUGH */
7215 case 'o':
7216 base = 8;
7217 goto uns_integer;
7218
7219 case 'X':
46fc3d4c 7220 case 'x':
7221 base = 16;
46fc3d4c 7222
7223 uns_integer:
b22c7a20 7224 if (vectorize) {
ba210ebe 7225 STRLEN ulen;
b22c7a20 7226 vector:
211dfcf1
HS		 7227 if (!veclen)
7228 continue;
b2e23cf9 7229 if (vec_utf)
dcad2880 7230 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
b22c7a20 7231 else {
a05b299f 7232 uv = *vecstr;
b22c7a20
GS		 7233 ulen = 1;
7234 }
7235 vecstr += ulen;
7236 veclen -= ulen;
7237 }
7238 else if (args) {
46fc3d4c 7239 switch (intsize) {
7240 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7241 default: uv = va_arg(*args, unsigned); break;
7242 case 'l': uv = va_arg(*args, unsigned long); break;
fc36a67e 7243 case 'V': uv = va_arg(*args, UV); break;
cf2093f6
JH		 7244#ifdef HAS_QUAD
7245 case 'q': uv = va_arg(*args, Quad_t); break;
7246#endif
46fc3d4c 7247 }
7248 }
7249 else {
211dfcf1 7250 uv = SvUVx(argsv);
46fc3d4c 7251 switch (intsize) {
7252 case 'h': uv = (unsigned short)uv; break;
be28567c 7253 default: break;
46fc3d4c 7254 case 'l': uv = (unsigned long)uv; break;
fc36a67e 7255 case 'V': break;
cf2093f6
JH		 7256#ifdef HAS_QUAD
7257 case 'q': uv = (Quad_t)uv; break;
7258#endif
46fc3d4c 7259 }
7260 }
7261
7262 integer:
46fc3d4c 7263 eptr = ebuf + sizeof ebuf;
fc36a67e 7264 switch (base) {
7265 unsigned dig;
7266 case 16:
c10ed8b9
HS		 7267 if (!uv)
7268 alt = FALSE;
1d7c1841
GS		 7269 p = (char*)((c == 'X')
7270 ? "0123456789ABCDEF" : "0123456789abcdef");
fc36a67e 7271 do {
7272 dig = uv & 15;
7273 *--eptr = p[dig];
7274 } while (uv >>= 4);
7275 if (alt) {
46fc3d4c 7276 esignbuf[esignlen++] = '0';
fc36a67e 7277 esignbuf[esignlen++] = c; /* 'x' or 'X' */
46fc3d4c 7278 }
fc36a67e 7279 break;
7280 case 8:
7281 do {
7282 dig = uv & 7;
7283 *--eptr = '0' + dig;
7284 } while (uv >>= 3);
7285 if (alt && *eptr != '0')
7286 *--eptr = '0';
7287 break;
4f19785b
WSI		 7288 case 2:
7289 do {
7290 dig = uv & 1;
7291 *--eptr = '0' + dig;
7292 } while (uv >>= 1);
eda88b6d
JH		 7293 if (alt) {
7294 esignbuf[esignlen++] = '0';
7481bb52 7295 esignbuf[esignlen++] = 'b';
eda88b6d 7296 }
4f19785b 7297 break;
fc36a67e 7298 default: /* it had better be ten or less */
6bc102ca 7299#if defined(PERL_Y2KWARN)
e476b1b5 7300 if (ckWARN(WARN_Y2K)) {
6bc102ca
GS		 7301 STRLEN n;
7302 char *s = SvPV(sv,n);
7303 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7304 && (n == 2 || !isDIGIT(s[n-3])))
7305 {
e476b1b5 7306 Perl_warner(aTHX_ WARN_Y2K,
6bc102ca
GS		 7307 "Possible Y2K bug: %%%c %s",
7308 c, "format string following '19'");
7309 }
7310 }
7311#endif
fc36a67e 7312 do {
7313 dig = uv % base;
7314 *--eptr = '0' + dig;
7315 } while (uv /= base);
7316 break;
46fc3d4c 7317 }
7318 elen = (ebuf + sizeof ebuf) - eptr;
c10ed8b9
HS		 7319 if (has_precis) {
7320 if (precis > elen)
7321 zeros = precis - elen;
7322 else if (precis == 0 && elen == 1 && *eptr == '0')
7323 elen = 0;
7324 }
46fc3d4c 7325 break;
7326
7327 /* FLOATING POINT */
7328
fc36a67e 7329 case 'F':
7330 c = 'f'; /* maybe %F isn't supported here */
7331 /* FALL THROUGH */
46fc3d4c 7332 case 'e': case 'E':
fc36a67e 7333 case 'f':
46fc3d4c 7334 case 'g': case 'G':
7335
7336 /* This is evil, but floating point is even more evil */
7337
b22c7a20 7338 vectorize = FALSE;
211dfcf1 7339 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
fc36a67e 7340
7341 need = 0;
7342 if (c != 'e' && c != 'E') {
7343 i = PERL_INT_MIN;
73b309ea 7344 (void)Perl_frexp(nv, &i);
fc36a67e 7345 if (i == PERL_INT_MIN)
cea2e8a9 7346 Perl_die(aTHX_ "panic: frexp");
c635e13b 7347 if (i > 0)
fc36a67e 7348 need = BIT_DIGITS(i);
7349 }
7350 need += has_precis ? precis : 6; /* known default */
7351 if (need < width)
7352 need = width;
7353
46fc3d4c 7354 need += 20; /* fudge factor */
80252599
GS		 7355 if (PL_efloatsize < need) {
7356 Safefree(PL_efloatbuf);
7357 PL_efloatsize = need + 20; /* more fudge */
7358 New(906, PL_efloatbuf, PL_efloatsize, char);
7d5ea4e7 7359 PL_efloatbuf[0] = '\0';
46fc3d4c 7360 }
7361
7362 eptr = ebuf + sizeof ebuf;
7363 *--eptr = '\0';
7364 *--eptr = c;
e5c81feb 7365#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
cf2093f6 7366 {
e5c81feb
JH		 7367 /* Copy the one or more characters in a long double
7368 * format before the 'base' ([efgEFG]) character to
7369 * the format string. */
7370 static char const prifldbl[] = PERL_PRIfldbl;
7371 char const *p = prifldbl + sizeof(prifldbl) - 3;
7372 while (p >= prifldbl) { *--eptr = *p--; }
cf2093f6 7373 }
65202027 7374#endif
46fc3d4c 7375 if (has_precis) {
7376 base = precis;
7377 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7378 *--eptr = '.';
7379 }
7380 if (width) {
7381 base = width;
7382 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7383 }
7384 if (fill == '0')
7385 *--eptr = fill;
84902520
TB		 7386 if (left)
7387 *--eptr = '-';
46fc3d4c 7388 if (plus)
7389 *--eptr = plus;
7390 if (alt)
7391 *--eptr = '#';
7392 *--eptr = '%';
7393
ff9121f8
JH		 7394 /* No taint. Otherwise we are in the strange situation
7395 * where printf() taints but print($float) doesn't.
bda0f7a5 7396 * --jhi */
dd8482fc 7397 (void)sprintf(PL_efloatbuf, eptr, nv);
8af02333 7398
80252599
GS		 7399 eptr = PL_efloatbuf;
7400 elen = strlen(PL_efloatbuf);
46fc3d4c 7401 break;
7402
fc36a67e 7403 /* SPECIAL */
7404
7405 case 'n':
b22c7a20 7406 vectorize = FALSE;
fc36a67e 7407 i = SvCUR(sv) - origlen;
7408 if (args) {
c635e13b 7409 switch (intsize) {
7410 case 'h': *(va_arg(*args, short*)) = i; break;
7411 default: *(va_arg(*args, int*)) = i; break;
7412 case 'l': *(va_arg(*args, long*)) = i; break;
7413 case 'V': *(va_arg(*args, IV*)) = i; break;
cf2093f6
JH		 7414#ifdef HAS_QUAD
7415 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7416#endif
c635e13b 7417 }
fc36a67e 7418 }
9dd79c3f 7419 else
211dfcf1 7420 sv_setuv_mg(argsv, (UV)i);
fc36a67e 7421 continue; /* not "break" */
7422
7423 /* UNKNOWN */
7424
46fc3d4c 7425 default:
fc36a67e 7426 unknown:
b22c7a20 7427 vectorize = FALSE;
599cee73 7428 if (!args && ckWARN(WARN_PRINTF) &&
533c011a 7429 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
c635e13b 7430 SV *msg = sv_newmortal();
cea2e8a9 7431 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
533c011a 7432 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
0f4b6630 7433 if (c) {
0f4b6630 7434 if (isPRINT(c))
1c846c1f 7435 Perl_sv_catpvf(aTHX_ msg,
0f4b6630
JH		 7436 "\"%%%c\"", c & 0xFF);
7437 else
7438 Perl_sv_catpvf(aTHX_ msg,
57def98f 7439 "\"%%\\%03"UVof"\"",
0f4b6630 7440 (UV)c & 0xFF);
0f4b6630 7441 } else
c635e13b 7442 sv_catpv(msg, "end of string");
894356b3 7443 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
c635e13b 7444 }
fb73857a 7445
7446 /* output mangled stuff ... */
7447 if (c == '\0')
7448 --q;
46fc3d4c 7449 eptr = p;
7450 elen = q - p;
fb73857a 7451
7452 /* ... right here, because formatting flags should not apply */
7453 SvGROW(sv, SvCUR(sv) + elen + 1);
7454 p = SvEND(sv);
4459522c 7455 Copy(eptr, p, elen, char);
fb73857a 7456 p += elen;
7457 *p = '\0';
7458 SvCUR(sv) = p - SvPVX(sv);
7459 continue; /* not "break" */
46fc3d4c 7460 }
7461
fc36a67e 7462 have = esignlen + zeros + elen;
46fc3d4c 7463 need = (have > width ? have : width);
7464 gap = need - have;
7465
b22c7a20 7466 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
46fc3d4c 7467 p = SvEND(sv);
7468 if (esignlen && fill == '0') {
7469 for (i = 0; i < esignlen; i++)
7470 *p++ = esignbuf[i];
7471 }
7472 if (gap && !left) {
7473 memset(p, fill, gap);
7474 p += gap;
7475 }
7476 if (esignlen && fill != '0') {
7477 for (i = 0; i < esignlen; i++)
7478 *p++ = esignbuf[i];
7479 }
fc36a67e 7480 if (zeros) {
7481 for (i = zeros; i; i--)
7482 *p++ = '0';
7483 }
46fc3d4c 7484 if (elen) {
4459522c 7485 Copy(eptr, p, elen, char);
46fc3d4c 7486 p += elen;
7487 }
7488 if (gap && left) {
7489 memset(p, ' ', gap);
7490 p += gap;
7491 }
b22c7a20
GS		 7492 if (vectorize) {
7493 if (veclen) {
4459522c 7494 Copy(dotstr, p, dotstrlen, char);
b22c7a20
GS		 7495 p += dotstrlen;
7496 }
7497 else
7498 vectorize = FALSE; /* done iterating over vecstr */
7499 }
7e2040f0
GS		 7500 if (is_utf)
7501 SvUTF8_on(sv);
46fc3d4c 7502 *p = '\0';
7503 SvCUR(sv) = p - SvPVX(sv);
b22c7a20
GS		 7504 if (vectorize) {
7505 esignlen = 0;
7506 goto vector;
7507 }
46fc3d4c 7508 }
7509}
51371543 7510
1d7c1841
GS		 7511#if defined(USE_ITHREADS)
7512
7513#if defined(USE_THREADS)
7514# include "error: USE_THREADS and USE_ITHREADS are incompatible"
7515#endif
7516
1d7c1841
GS		 7517#ifndef GpREFCNT_inc
7518# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7519#endif
7520
7521
7522#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7523#define av_dup(s) (AV*)sv_dup((SV*)s)
7524#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7525#define hv_dup(s) (HV*)sv_dup((SV*)s)
7526#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7527#define cv_dup(s) (CV*)sv_dup((SV*)s)
7528#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7529#define io_dup(s) (IO*)sv_dup((SV*)s)
7530#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7531#define gv_dup(s) (GV*)sv_dup((SV*)s)
7532#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7533#define SAVEPV(p) (p ? savepv(p) : Nullch)
7534#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7535
7536REGEXP *
7537Perl_re_dup(pTHX_ REGEXP *r)
7538{
7539 /* XXX fix when pmop->op_pmregexp becomes shared */
7540 return ReREFCNT_inc(r);
7541}
7542
7543PerlIO *
7544Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7545{
7546 PerlIO *ret;
7547 if (!fp)
7548 return (PerlIO*)NULL;
7549
7550 /* look for it in the table first */
7551 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7552 if (ret)
7553 return ret;
7554
7555 /* create anew and remember what it is */
5f1a76d0 7556 ret = PerlIO_fdupopen(aTHX_ fp);
1d7c1841
GS		 7557 ptr_table_store(PL_ptr_table, fp, ret);
7558 return ret;
7559}
7560
7561DIR *
7562Perl_dirp_dup(pTHX_ DIR *dp)
7563{
7564 if (!dp)
7565 return (DIR*)NULL;
7566 /* XXX TODO */
7567 return dp;
7568}
7569
7570GP *
7571Perl_gp_dup(pTHX_ GP *gp)
7572{
7573 GP *ret;
7574 if (!gp)
7575 return (GP*)NULL;
7576 /* look for it in the table first */
7577 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7578 if (ret)
7579 return ret;
7580
7581 /* create anew and remember what it is */
7582 Newz(0, ret, 1, GP);
7583 ptr_table_store(PL_ptr_table, gp, ret);
7584
7585 /* clone */
7586 ret->gp_refcnt = 0; /* must be before any other dups! */
7587 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7588 ret->gp_io = io_dup_inc(gp->gp_io);
7589 ret->gp_form = cv_dup_inc(gp->gp_form);
7590 ret->gp_av = av_dup_inc(gp->gp_av);
7591 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7592 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7593 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7594 ret->gp_cvgen = gp->gp_cvgen;
7595 ret->gp_flags = gp->gp_flags;
7596 ret->gp_line = gp->gp_line;
7597 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7598 return ret;
7599}
7600
7601MAGIC *
7602Perl_mg_dup(pTHX_ MAGIC *mg)
7603{
7604 MAGIC *mgret = (MAGIC*)NULL;
7605 MAGIC *mgprev;
7606 if (!mg)
7607 return (MAGIC*)NULL;
7608 /* look for it in the table first */
7609 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7610 if (mgret)
7611 return mgret;
7612
7613 for (; mg; mg = mg->mg_moremagic) {
7614 MAGIC *nmg;
7615 Newz(0, nmg, 1, MAGIC);
7616 if (!mgret)
7617 mgret = nmg;
7618 else
7619 mgprev->mg_moremagic = nmg;
7620 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7621 nmg->mg_private = mg->mg_private;
7622 nmg->mg_type = mg->mg_type;
7623 nmg->mg_flags = mg->mg_flags;
7624 if (mg->mg_type == 'r') {
7625 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7626 }
7627 else {
7628 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7629 ? sv_dup_inc(mg->mg_obj)
7630 : sv_dup(mg->mg_obj);
7631 }
7632 nmg->mg_len = mg->mg_len;
7633 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7634 if (mg->mg_ptr && mg->mg_type != 'g') {
7635 if (mg->mg_len >= 0) {
7636 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7637 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7638 AMT *amtp = (AMT*)mg->mg_ptr;
7639 AMT *namtp = (AMT*)nmg->mg_ptr;
7640 I32 i;
7641 for (i = 1; i < NofAMmeth; i++) {
7642 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7643 }
7644 }
7645 }
7646 else if (mg->mg_len == HEf_SVKEY)
7647 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7648 }
7649 mgprev = nmg;
7650 }
7651 return mgret;
7652}
7653
7654PTR_TBL_t *
7655Perl_ptr_table_new(pTHX)
7656{
7657 PTR_TBL_t *tbl;
7658 Newz(0, tbl, 1, PTR_TBL_t);
7659 tbl->tbl_max = 511;
7660 tbl->tbl_items = 0;
7661 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7662 return tbl;
7663}
7664
7665void *
7666Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7667{
7668 PTR_TBL_ENT_t *tblent;
d2a79402 7669 UV hash = PTR2UV(sv);
1d7c1841
GS		 7670 assert(tbl);
7671 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7672 for (; tblent; tblent = tblent->next) {
7673 if (tblent->oldval == sv)
7674 return tblent->newval;
7675 }
7676 return (void*)NULL;
7677}
7678
7679void
7680Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7681{
7682 PTR_TBL_ENT_t *tblent, **otblent;
7683 /* XXX this may be pessimal on platforms where pointers aren't good
7684 * hash values e.g. if they grow faster in the most significant
7685 * bits */
d2a79402 7686 UV hash = PTR2UV(oldv);
1d7c1841
GS		 7687 bool i = 1;
7688
7689 assert(tbl);
7690 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7691 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7692 if (tblent->oldval == oldv) {
7693 tblent->newval = newv;
7694 tbl->tbl_items++;
7695 return;
7696 }
7697 }
7698 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7699 tblent->oldval = oldv;
7700 tblent->newval = newv;
7701 tblent->next = *otblent;
7702 *otblent = tblent;
7703 tbl->tbl_items++;
7704 if (i && tbl->tbl_items > tbl->tbl_max)
7705 ptr_table_split(tbl);
7706}
7707
7708void
7709Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7710{
7711 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7712 UV oldsize = tbl->tbl_max + 1;
7713 UV newsize = oldsize * 2;
7714 UV i;
7715
7716 Renew(ary, newsize, PTR_TBL_ENT_t*);
7717 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7718 tbl->tbl_max = --newsize;
7719 tbl->tbl_ary = ary;
7720 for (i=0; i < oldsize; i++, ary++) {
7721 PTR_TBL_ENT_t **curentp, **entp, *ent;
7722 if (!*ary)
7723 continue;
7724 curentp = ary + oldsize;
7725 for (entp = ary, ent = *ary; ent; ent = *entp) {
d2a79402 7726 if ((newsize & PTR2UV(ent->oldval)) != i) {
1d7c1841
GS		 7727 *entp = ent->next;
7728 ent->next = *curentp;
7729 *curentp = ent;
7730 continue;
7731 }
7732 else
7733 entp = &ent->next;
7734 }
7735 }
7736}
7737
a0739874
DM		 7738void
7739Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7740{
7741 register PTR_TBL_ENT_t **array;
7742 register PTR_TBL_ENT_t *entry;
7743 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7744 UV riter = 0;
7745 UV max;
7746
7747 if (!tbl || !tbl->tbl_items) {
7748 return;
7749 }
7750
7751 array = tbl->tbl_ary;
7752 entry = array[0];
7753 max = tbl->tbl_max;
7754
7755 for (;;) {
7756 if (entry) {
7757 oentry = entry;
7758 entry = entry->next;
7759 Safefree(oentry);
7760 }
7761 if (!entry) {
7762 if (++riter > max) {
7763 break;
7764 }
7765 entry = array[riter];
7766 }
7767 }
7768
7769 tbl->tbl_items = 0;
7770}
7771
7772void
7773Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7774{
7775 if (!tbl) {
7776 return;
7777 }
7778 ptr_table_clear(tbl);
7779 Safefree(tbl->tbl_ary);
7780 Safefree(tbl);
7781}
7782
1d7c1841
GS		 7783#ifdef DEBUGGING
7784char *PL_watch_pvx;
7785#endif
7786
5bd07a3d
DM		 7787STATIC SV *
7788S_gv_share(pTHX_ SV *sstr)
7789{
7790 GV *gv = (GV*)sstr;
7791 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7792
7793 if (GvIO(gv) || GvFORM(gv)) {
7794 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7795 }
7796 else if (!GvCV(gv)) {
7797 GvCV(gv) = (CV*)sv;
7798 }
7799 else {
7800 /* CvPADLISTs cannot be shared */
7801 if (!CvXSUB(GvCV(gv))) {
7802 GvSHARED_off(gv);
7803 }
7804 }
7805
7806 if (!GvSHARED(gv)) {
7807#if 0
7808 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7809 HvNAME(GvSTASH(gv)), GvNAME(gv));
7810#endif
7811 return Nullsv;
7812 }
7813
7814 /*
7815 * write attempts will die with
7816 * "Modification of a read-only value attempted"
7817 */
7818 if (!GvSV(gv)) {
7819 GvSV(gv) = sv;
7820 }
7821 else {
7822 SvREADONLY_on(GvSV(gv));
7823 }
7824
7825 if (!GvAV(gv)) {
7826 GvAV(gv) = (AV*)sv;
7827 }
7828 else {
7829 SvREADONLY_on(GvAV(gv));
7830 }
7831
7832 if (!GvHV(gv)) {
7833 GvHV(gv) = (HV*)sv;
7834 }
7835 else {
7836 SvREADONLY_on(GvAV(gv));
7837 }
7838
7839 return sstr; /* he_dup() will SvREFCNT_inc() */
7840}
7841
1d7c1841
GS		 7842SV *
7843Perl_sv_dup(pTHX_ SV *sstr)
7844{
1d7c1841
GS		 7845 SV *dstr;
7846
7847 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7848 return Nullsv;
7849 /* look for it in the table first */
7850 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7851 if (dstr)
7852 return dstr;
7853
7854 /* create anew and remember what it is */
7855 new_SV(dstr);
7856 ptr_table_store(PL_ptr_table, sstr, dstr);
7857
7858 /* clone */
7859 SvFLAGS(dstr) = SvFLAGS(sstr);
7860 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7861 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7862
7863#ifdef DEBUGGING
7864 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7865 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7866 PL_watch_pvx, SvPVX(sstr));
7867#endif
7868
7869 switch (SvTYPE(sstr)) {
7870 case SVt_NULL:
7871 SvANY(dstr) = NULL;
7872 break;
7873 case SVt_IV:
7874 SvANY(dstr) = new_XIV();
7875 SvIVX(dstr) = SvIVX(sstr);
7876 break;
7877 case SVt_NV:
7878 SvANY(dstr) = new_XNV();
7879 SvNVX(dstr) = SvNVX(sstr);
7880 break;
7881 case SVt_RV:
7882 SvANY(dstr) = new_XRV();
7883 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7884 break;
7885 case SVt_PV:
7886 SvANY(dstr) = new_XPV();
7887 SvCUR(dstr) = SvCUR(sstr);
7888 SvLEN(dstr) = SvLEN(sstr);
7889 if (SvROK(sstr))
7890 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7891 else if (SvPVX(sstr) && SvLEN(sstr))
7892 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7893 else
7894 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7895 break;
7896 case SVt_PVIV:
7897 SvANY(dstr) = new_XPVIV();
7898 SvCUR(dstr) = SvCUR(sstr);
7899 SvLEN(dstr) = SvLEN(sstr);
7900 SvIVX(dstr) = SvIVX(sstr);
7901 if (SvROK(sstr))
7902 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7903 else if (SvPVX(sstr) && SvLEN(sstr))
7904 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7905 else
7906 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7907 break;
7908 case SVt_PVNV:
7909 SvANY(dstr) = new_XPVNV();
7910 SvCUR(dstr) = SvCUR(sstr);
7911 SvLEN(dstr) = SvLEN(sstr);
7912 SvIVX(dstr) = SvIVX(sstr);
7913 SvNVX(dstr) = SvNVX(sstr);
7914 if (SvROK(sstr))
7915 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7916 else if (SvPVX(sstr) && SvLEN(sstr))
7917 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7918 else
7919 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7920 break;
7921 case SVt_PVMG:
7922 SvANY(dstr) = new_XPVMG();
7923 SvCUR(dstr) = SvCUR(sstr);
7924 SvLEN(dstr) = SvLEN(sstr);
7925 SvIVX(dstr) = SvIVX(sstr);
7926 SvNVX(dstr) = SvNVX(sstr);
7927 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7928 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7929 if (SvROK(sstr))
7930 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7931 else if (SvPVX(sstr) && SvLEN(sstr))
7932 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7933 else
7934 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7935 break;
7936 case SVt_PVBM:
7937 SvANY(dstr) = new_XPVBM();
7938 SvCUR(dstr) = SvCUR(sstr);
7939 SvLEN(dstr) = SvLEN(sstr);
7940 SvIVX(dstr) = SvIVX(sstr);
7941 SvNVX(dstr) = SvNVX(sstr);
7942 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7943 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7944 if (SvROK(sstr))
7945 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7946 else if (SvPVX(sstr) && SvLEN(sstr))
7947 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7948 else
7949 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7950 BmRARE(dstr) = BmRARE(sstr);
7951 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7952 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7953 break;
7954 case SVt_PVLV:
7955 SvANY(dstr) = new_XPVLV();
7956 SvCUR(dstr) = SvCUR(sstr);
7957 SvLEN(dstr) = SvLEN(sstr);
7958 SvIVX(dstr) = SvIVX(sstr);
7959 SvNVX(dstr) = SvNVX(sstr);
7960 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7961 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7962 if (SvROK(sstr))
7963 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7964 else if (SvPVX(sstr) && SvLEN(sstr))
7965 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7966 else
7967 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7968 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7969 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7970 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7971 LvTYPE(dstr) = LvTYPE(sstr);
7972 break;
7973 case SVt_PVGV:
5bd07a3d
DM		 7974 if (GvSHARED((GV*)sstr)) {
7975 SV *share;
7976 if ((share = gv_share(sstr))) {
7977 del_SV(dstr);
7978 dstr = share;
7979#if 0
7980 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
7981 HvNAME(GvSTASH(share)), GvNAME(share));
7982#endif
7983 break;
7984 }
7985 }
1d7c1841
GS		 7986 SvANY(dstr) = new_XPVGV();
7987 SvCUR(dstr) = SvCUR(sstr);
7988 SvLEN(dstr) = SvLEN(sstr);
7989 SvIVX(dstr) = SvIVX(sstr);
7990 SvNVX(dstr) = SvNVX(sstr);
7991 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7992 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7993 if (SvROK(sstr))
7994 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7995 else if (SvPVX(sstr) && SvLEN(sstr))
7996 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7997 else
7998 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7999 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8000 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8001 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8002 GvFLAGS(dstr) = GvFLAGS(sstr);
8003 GvGP(dstr) = gp_dup(GvGP(sstr));
8004 (void)GpREFCNT_inc(GvGP(dstr));
8005 break;
8006 case SVt_PVIO:
8007 SvANY(dstr) = new_XPVIO();
8008 SvCUR(dstr) = SvCUR(sstr);
8009 SvLEN(dstr) = SvLEN(sstr);
8010 SvIVX(dstr) = SvIVX(sstr);
8011 SvNVX(dstr) = SvNVX(sstr);
8012 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8013 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8014 if (SvROK(sstr))
8015 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8016 else if (SvPVX(sstr) && SvLEN(sstr))
8017 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8018 else
8019 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8020 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8021 if (IoOFP(sstr) == IoIFP(sstr))
8022 IoOFP(dstr) = IoIFP(dstr);
8023 else
8024 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8025 /* PL_rsfp_filters entries have fake IoDIRP() */
8026 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8027 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8028 else
8029 IoDIRP(dstr) = IoDIRP(sstr);
8030 IoLINES(dstr) = IoLINES(sstr);
8031 IoPAGE(dstr) = IoPAGE(sstr);
8032 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8033 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8034 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8035 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8036 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8037 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8038 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8039 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8040 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8041 IoTYPE(dstr) = IoTYPE(sstr);
8042 IoFLAGS(dstr) = IoFLAGS(sstr);
8043 break;
8044 case SVt_PVAV:
8045 SvANY(dstr) = new_XPVAV();
8046 SvCUR(dstr) = SvCUR(sstr);
8047 SvLEN(dstr) = SvLEN(sstr);
8048 SvIVX(dstr) = SvIVX(sstr);
8049 SvNVX(dstr) = SvNVX(sstr);
8050 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8051 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8052 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8053 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8054 if (AvARRAY((AV*)sstr)) {
8055 SV **dst_ary, **src_ary;
8056 SSize_t items = AvFILLp((AV*)sstr) + 1;
8057
8058 src_ary = AvARRAY((AV*)sstr);
8059 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8060 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8061 SvPVX(dstr) = (char*)dst_ary;
8062 AvALLOC((AV*)dstr) = dst_ary;
8063 if (AvREAL((AV*)sstr)) {
8064 while (items-- > 0)
8065 *dst_ary++ = sv_dup_inc(*src_ary++);
8066 }
8067 else {
8068 while (items-- > 0)
8069 *dst_ary++ = sv_dup(*src_ary++);
8070 }
8071 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8072 while (items-- > 0) {
8073 *dst_ary++ = &PL_sv_undef;
8074 }
8075 }
8076 else {
8077 SvPVX(dstr) = Nullch;
8078 AvALLOC((AV*)dstr) = (SV**)NULL;
8079 }
8080 break;
8081 case SVt_PVHV:
8082 SvANY(dstr) = new_XPVHV();
8083 SvCUR(dstr) = SvCUR(sstr);
8084 SvLEN(dstr) = SvLEN(sstr);
8085 SvIVX(dstr) = SvIVX(sstr);
8086 SvNVX(dstr) = SvNVX(sstr);
8087 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8088 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8089 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8090 if (HvARRAY((HV*)sstr)) {
1d7c1841
GS		 8091 STRLEN i = 0;
8092 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8093 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8094 Newz(0, dxhv->xhv_array,
8095 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8096 while (i <= sxhv->xhv_max) {
8097 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8098 !!HvSHAREKEYS(sstr));
8099 ++i;
8100 }
8101 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8102 }
8103 else {
8104 SvPVX(dstr) = Nullch;
8105 HvEITER((HV*)dstr) = (HE*)NULL;
8106 }
8107 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8108 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8109 break;
8110 case SVt_PVFM:
8111 SvANY(dstr) = new_XPVFM();
8112 FmLINES(dstr) = FmLINES(sstr);
8113 goto dup_pvcv;
8114 /* NOTREACHED */
8115 case SVt_PVCV:
8116 SvANY(dstr) = new_XPVCV();
8117dup_pvcv:
8118 SvCUR(dstr) = SvCUR(sstr);
8119 SvLEN(dstr) = SvLEN(sstr);
8120 SvIVX(dstr) = SvIVX(sstr);
8121 SvNVX(dstr) = SvNVX(sstr);
8122 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8123 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8124 if (SvPVX(sstr) && SvLEN(sstr))
8125 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8126 else
8127 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8128 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8129 CvSTART(dstr) = CvSTART(sstr);
8130 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8131 CvXSUB(dstr) = CvXSUB(sstr);
8132 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8133 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
8134 CvDEPTH(dstr) = CvDEPTH(sstr);
8135 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8136 /* XXX padlists are real, but pretend to be not */
8137 AvREAL_on(CvPADLIST(sstr));
8138 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8139 AvREAL_off(CvPADLIST(sstr));
8140 AvREAL_off(CvPADLIST(dstr));
8141 }
8142 else
8143 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8144 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8145 CvFLAGS(dstr) = CvFLAGS(sstr);
8146 break;
8147 default:
8148 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8149 break;
8150 }
8151
8152 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8153 ++PL_sv_objcount;
8154
8155 return dstr;
8156}
8157
8158PERL_CONTEXT *
8159Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8160{
8161 PERL_CONTEXT *ncxs;
8162
8163 if (!cxs)
8164 return (PERL_CONTEXT*)NULL;
8165
8166 /* look for it in the table first */
8167 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8168 if (ncxs)
8169 return ncxs;
8170
8171 /* create anew and remember what it is */
8172 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8173 ptr_table_store(PL_ptr_table, cxs, ncxs);
8174
8175 while (ix >= 0) {
8176 PERL_CONTEXT *cx = &cxs[ix];
8177 PERL_CONTEXT *ncx = &ncxs[ix];
8178 ncx->cx_type = cx->cx_type;
8179 if (CxTYPE(cx) == CXt_SUBST) {
8180 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8181 }
8182 else {
8183 ncx->blk_oldsp = cx->blk_oldsp;
8184 ncx->blk_oldcop = cx->blk_oldcop;
8185 ncx->blk_oldretsp = cx->blk_oldretsp;
8186 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8187 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8188 ncx->blk_oldpm = cx->blk_oldpm;
8189 ncx->blk_gimme = cx->blk_gimme;
8190 switch (CxTYPE(cx)) {
8191 case CXt_SUB:
8192 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8193 ? cv_dup_inc(cx->blk_sub.cv)
8194 : cv_dup(cx->blk_sub.cv));
8195 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8196 ? av_dup_inc(cx->blk_sub.argarray)
8197 : Nullav);
8198 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8199 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8200 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8201 ncx->blk_sub.lval = cx->blk_sub.lval;
8202 break;
8203 case CXt_EVAL:
8204 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8205 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
0f79a09d 8206 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
1d7c1841
GS		 8207 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8208 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8209 break;
8210 case CXt_LOOP:
8211 ncx->blk_loop.label = cx->blk_loop.label;
8212 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8213 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8214 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8215 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8216 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8217 ? cx->blk_loop.iterdata
8218 : gv_dup((GV*)cx->blk_loop.iterdata));
a4b82a6f
GS		 8219 ncx->blk_loop.oldcurpad
8220 = (SV**)ptr_table_fetch(PL_ptr_table,
8221 cx->blk_loop.oldcurpad);
1d7c1841
GS		 8222 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8223 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8224 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8225 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8226 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8227 break;
8228 case CXt_FORMAT:
8229 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8230 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8231 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8232 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8233 break;
8234 case CXt_BLOCK:
8235 case CXt_NULL:
8236 break;
8237 }
8238 }
8239 --ix;
8240 }
8241 return ncxs;
8242}
8243
8244PERL_SI *
8245Perl_si_dup(pTHX_ PERL_SI *si)
8246{
8247 PERL_SI *nsi;
8248
8249 if (!si)
8250 return (PERL_SI*)NULL;
8251
8252 /* look for it in the table first */
8253 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8254 if (nsi)
8255 return nsi;
8256
8257 /* create anew and remember what it is */
8258 Newz(56, nsi, 1, PERL_SI);
8259 ptr_table_store(PL_ptr_table, si, nsi);
8260
8261 nsi->si_stack = av_dup_inc(si->si_stack);
8262 nsi->si_cxix = si->si_cxix;
8263 nsi->si_cxmax = si->si_cxmax;
8264 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8265 nsi->si_type = si->si_type;
8266 nsi->si_prev = si_dup(si->si_prev);
8267 nsi->si_next = si_dup(si->si_next);
8268 nsi->si_markoff = si->si_markoff;
8269
8270 return nsi;
8271}
8272
8273#define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8274#define TOPINT(ss,ix) ((ss)[ix].any_i32)
8275#define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8276#define TOPLONG(ss,ix) ((ss)[ix].any_long)
8277#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8278#define TOPIV(ss,ix) ((ss)[ix].any_iv)
8279#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8280#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8281#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8282#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8283#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8284#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8285
8286/* XXXXX todo */
8287#define pv_dup_inc(p) SAVEPV(p)
8288#define pv_dup(p) SAVEPV(p)
8289#define svp_dup_inc(p,pp) any_dup(p,pp)
8290
8291void *
8292Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8293{
8294 void *ret;
8295
8296 if (!v)
8297 return (void*)NULL;
8298
8299 /* look for it in the table first */
8300 ret = ptr_table_fetch(PL_ptr_table, v);
8301 if (ret)
8302 return ret;
8303
8304 /* see if it is part of the interpreter structure */
8305 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8306 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8307 else
8308 ret = v;
8309
8310 return ret;
8311}
8312
8313ANY *
8314Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8315{
8316 ANY *ss = proto_perl->Tsavestack;
8317 I32 ix = proto_perl->Tsavestack_ix;
8318 I32 max = proto_perl->Tsavestack_max;
8319 ANY *nss;
8320 SV *sv;
8321 GV *gv;
8322 AV *av;
8323 HV *hv;
8324 void* ptr;
8325 int intval;
8326 long longval;
8327 GP *gp;
8328 IV iv;
8329 I32 i;
8330 char *c;
8331 void (*dptr) (void*);
8332 void (*dxptr) (pTHXo_ void*);
e977893f 8333 OP *o;
1d7c1841
GS		 8334
8335 Newz(54, nss, max, ANY);
8336
8337 while (ix > 0) {
8338 i = POPINT(ss,ix);
8339 TOPINT(nss,ix) = i;
8340 switch (i) {
8341 case SAVEt_ITEM: /* normal string */
8342 sv = (SV*)POPPTR(ss,ix);
8343 TOPPTR(nss,ix) = sv_dup_inc(sv);
8344 sv = (SV*)POPPTR(ss,ix);
8345 TOPPTR(nss,ix) = sv_dup_inc(sv);
8346 break;
8347 case SAVEt_SV: /* scalar reference */
8348 sv = (SV*)POPPTR(ss,ix);
8349 TOPPTR(nss,ix) = sv_dup_inc(sv);
8350 gv = (GV*)POPPTR(ss,ix);
8351 TOPPTR(nss,ix) = gv_dup_inc(gv);
8352 break;
f4dd75d9
GS		 8353 case SAVEt_GENERIC_PVREF: /* generic char* */
8354 c = (char*)POPPTR(ss,ix);
8355 TOPPTR(nss,ix) = pv_dup(c);
8356 ptr = POPPTR(ss,ix);
8357 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8358 break;
1d7c1841
GS		 8359 case SAVEt_GENERIC_SVREF: /* generic sv */
8360 case SAVEt_SVREF: /* scalar reference */
8361 sv = (SV*)POPPTR(ss,ix);
8362 TOPPTR(nss,ix) = sv_dup_inc(sv);
8363 ptr = POPPTR(ss,ix);
8364 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8365 break;
8366 case SAVEt_AV: /* array reference */
8367 av = (AV*)POPPTR(ss,ix);
8368 TOPPTR(nss,ix) = av_dup_inc(av);
8369 gv = (GV*)POPPTR(ss,ix);
8370 TOPPTR(nss,ix) = gv_dup(gv);
8371 break;
8372 case SAVEt_HV: /* hash reference */
8373 hv = (HV*)POPPTR(ss,ix);
8374 TOPPTR(nss,ix) = hv_dup_inc(hv);
8375 gv = (GV*)POPPTR(ss,ix);
8376 TOPPTR(nss,ix) = gv_dup(gv);
8377 break;
8378 case SAVEt_INT: /* int reference */
8379 ptr = POPPTR(ss,ix);
8380 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8381 intval = (int)POPINT(ss,ix);
8382 TOPINT(nss,ix) = intval;
8383 break;
8384 case SAVEt_LONG: /* long reference */
8385 ptr = POPPTR(ss,ix);
8386 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8387 longval = (long)POPLONG(ss,ix);
8388 TOPLONG(nss,ix) = longval;
8389 break;
8390 case SAVEt_I32: /* I32 reference */
8391 case SAVEt_I16: /* I16 reference */
8392 case SAVEt_I8: /* I8 reference */
8393 ptr = POPPTR(ss,ix);
8394 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8395 i = POPINT(ss,ix);
8396 TOPINT(nss,ix) = i;
8397 break;
8398 case SAVEt_IV: /* IV reference */
8399 ptr = POPPTR(ss,ix);
8400 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8401 iv = POPIV(ss,ix);
8402 TOPIV(nss,ix) = iv;
8403 break;
8404 case SAVEt_SPTR: /* SV* reference */
8405 ptr = POPPTR(ss,ix);
8406 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8407 sv = (SV*)POPPTR(ss,ix);
8408 TOPPTR(nss,ix) = sv_dup(sv);
8409 break;
8410 case SAVEt_VPTR: /* random* reference */
8411 ptr = POPPTR(ss,ix);
8412 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8413 ptr = POPPTR(ss,ix);
8414 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8415 break;
8416 case SAVEt_PPTR: /* char* reference */
8417 ptr = POPPTR(ss,ix);
8418 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8419 c = (char*)POPPTR(ss,ix);
8420 TOPPTR(nss,ix) = pv_dup(c);
8421 break;
8422 case SAVEt_HPTR: /* HV* reference */
8423 ptr = POPPTR(ss,ix);
8424 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8425 hv = (HV*)POPPTR(ss,ix);
8426 TOPPTR(nss,ix) = hv_dup(hv);
8427 break;
8428 case SAVEt_APTR: /* AV* reference */
8429 ptr = POPPTR(ss,ix);
8430 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8431 av = (AV*)POPPTR(ss,ix);
8432 TOPPTR(nss,ix) = av_dup(av);
8433 break;
8434 case SAVEt_NSTAB:
8435 gv = (GV*)POPPTR(ss,ix);
8436 TOPPTR(nss,ix) = gv_dup(gv);
8437 break;
8438 case SAVEt_GP: /* scalar reference */
8439 gp = (GP*)POPPTR(ss,ix);
8440 TOPPTR(nss,ix) = gp = gp_dup(gp);
8441 (void)GpREFCNT_inc(gp);
8442 gv = (GV*)POPPTR(ss,ix);
8443 TOPPTR(nss,ix) = gv_dup_inc(c);
8444 c = (char*)POPPTR(ss,ix);
8445 TOPPTR(nss,ix) = pv_dup(c);
8446 iv = POPIV(ss,ix);
8447 TOPIV(nss,ix) = iv;
8448 iv = POPIV(ss,ix);
8449 TOPIV(nss,ix) = iv;
8450 break;
8451 case SAVEt_FREESV:
8452 sv = (SV*)POPPTR(ss,ix);
8453 TOPPTR(nss,ix) = sv_dup_inc(sv);
8454 break;
8455 case SAVEt_FREEOP:
8456 ptr = POPPTR(ss,ix);
8457 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8458 /* these are assumed to be refcounted properly */
8459 switch (((OP*)ptr)->op_type) {
8460 case OP_LEAVESUB:
8461 case OP_LEAVESUBLV:
8462 case OP_LEAVEEVAL:
8463 case OP_LEAVE:
8464 case OP_SCOPE:
8465 case OP_LEAVEWRITE:
e977893f
GS		 8466 TOPPTR(nss,ix) = ptr;
8467 o = (OP*)ptr;
8468 OpREFCNT_inc(o);
1d7c1841
GS		 8469 break;
8470 default:
8471 TOPPTR(nss,ix) = Nullop;
8472 break;
8473 }
8474 }
8475 else
8476 TOPPTR(nss,ix) = Nullop;
8477 break;
8478 case SAVEt_FREEPV:
8479 c = (char*)POPPTR(ss,ix);
8480 TOPPTR(nss,ix) = pv_dup_inc(c);
8481 break;
8482 case SAVEt_CLEARSV:
8483 longval = POPLONG(ss,ix);
8484 TOPLONG(nss,ix) = longval;
8485 break;
8486 case SAVEt_DELETE:
8487 hv = (HV*)POPPTR(ss,ix);
8488 TOPPTR(nss,ix) = hv_dup_inc(hv);
8489 c = (char*)POPPTR(ss,ix);
8490 TOPPTR(nss,ix) = pv_dup_inc(c);
8491 i = POPINT(ss,ix);
8492 TOPINT(nss,ix) = i;
8493 break;
8494 case SAVEt_DESTRUCTOR:
8495 ptr = POPPTR(ss,ix);
8496 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8497 dptr = POPDPTR(ss,ix);
ef75a179 8498 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
1d7c1841
GS		 8499 break;
8500 case SAVEt_DESTRUCTOR_X:
8501 ptr = POPPTR(ss,ix);
8502 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8503 dxptr = POPDXPTR(ss,ix);
ef75a179 8504 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
1d7c1841
GS		 8505 break;
8506 case SAVEt_REGCONTEXT:
8507 case SAVEt_ALLOC:
8508 i = POPINT(ss,ix);
8509 TOPINT(nss,ix) = i;
8510 ix -= i;
8511 break;
8512 case SAVEt_STACK_POS: /* Position on Perl stack */
8513 i = POPINT(ss,ix);
8514 TOPINT(nss,ix) = i;
8515 break;
8516 case SAVEt_AELEM: /* array element */
8517 sv = (SV*)POPPTR(ss,ix);
8518 TOPPTR(nss,ix) = sv_dup_inc(sv);
8519 i = POPINT(ss,ix);
8520 TOPINT(nss,ix) = i;
8521 av = (AV*)POPPTR(ss,ix);
8522 TOPPTR(nss,ix) = av_dup_inc(av);
8523 break;
8524 case SAVEt_HELEM: /* hash element */
8525 sv = (SV*)POPPTR(ss,ix);
8526 TOPPTR(nss,ix) = sv_dup_inc(sv);
8527 sv = (SV*)POPPTR(ss,ix);
8528 TOPPTR(nss,ix) = sv_dup_inc(sv);
8529 hv = (HV*)POPPTR(ss,ix);
8530 TOPPTR(nss,ix) = hv_dup_inc(hv);
8531 break;
8532 case SAVEt_OP:
8533 ptr = POPPTR(ss,ix);
8534 TOPPTR(nss,ix) = ptr;
8535 break;
8536 case SAVEt_HINTS:
8537 i = POPINT(ss,ix);
8538 TOPINT(nss,ix) = i;
8539 break;
c4410b1b
GS		 8540 case SAVEt_COMPPAD:
8541 av = (AV*)POPPTR(ss,ix);
8542 TOPPTR(nss,ix) = av_dup(av);
8543 break;
c3564e5c
GS		 8544 case SAVEt_PADSV:
8545 longval = (long)POPLONG(ss,ix);
8546 TOPLONG(nss,ix) = longval;
8547 ptr = POPPTR(ss,ix);
8548 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8549 sv = (SV*)POPPTR(ss,ix);
8550 TOPPTR(nss,ix) = sv_dup(sv);
8551 break;
1d7c1841
GS		 8552 default:
8553 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8554 }
8555 }
8556
8557 return nss;
8558}
8559
8560#ifdef PERL_OBJECT
8561#include "XSUB.h"
8562#endif
8563
8564PerlInterpreter *
8565perl_clone(PerlInterpreter *proto_perl, UV flags)
8566{
8567#ifdef PERL_OBJECT
8568 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8569#endif
8570
8571#ifdef PERL_IMPLICIT_SYS
8572 return perl_clone_using(proto_perl, flags,
8573 proto_perl->IMem,
8574 proto_perl->IMemShared,
8575 proto_perl->IMemParse,
8576 proto_perl->IEnv,
8577 proto_perl->IStdIO,
8578 proto_perl->ILIO,
8579 proto_perl->IDir,
8580 proto_perl->ISock,
8581 proto_perl->IProc);
8582}
8583
8584PerlInterpreter *
8585perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8586 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8587 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8588 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8589 struct IPerlDir* ipD, struct IPerlSock* ipS,
8590 struct IPerlProc* ipP)
8591{
8592 /* XXX many of the string copies here can be optimized if they're
8593 * constants; they need to be allocated as common memory and just
8594 * their pointers copied. */
8595
8596 IV i;
1d7c1841
GS		 8597# ifdef PERL_OBJECT
8598 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8599 ipD, ipS, ipP);
ba869deb 8600 PERL_SET_THX(pPerl);
1d7c1841
GS		 8601# else /* !PERL_OBJECT */
8602 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
ba869deb 8603 PERL_SET_THX(my_perl);
1d7c1841
GS		 8604
8605# ifdef DEBUGGING
8606 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8607 PL_markstack = 0;
8608 PL_scopestack = 0;
8609 PL_savestack = 0;
8610 PL_retstack = 0;
66fe0623 8611 PL_sig_pending = 0;
1d7c1841
GS		 8612# else /* !DEBUGGING */
8613 Zero(my_perl, 1, PerlInterpreter);
8614# endif /* DEBUGGING */
8615
8616 /* host pointers */
8617 PL_Mem = ipM;
8618 PL_MemShared = ipMS;
8619 PL_MemParse = ipMP;
8620 PL_Env = ipE;
8621 PL_StdIO = ipStd;
8622 PL_LIO = ipLIO;
8623 PL_Dir = ipD;
8624 PL_Sock = ipS;
8625 PL_Proc = ipP;
8626# endif /* PERL_OBJECT */
8627#else /* !PERL_IMPLICIT_SYS */
8628 IV i;
1d7c1841 8629 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 8630 PERL_SET_THX(my_perl);
1d7c1841
GS		 8631
8632# ifdef DEBUGGING
8633 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8634 PL_markstack = 0;
8635 PL_scopestack = 0;
8636 PL_savestack = 0;
8637 PL_retstack = 0;
66fe0623 8638 PL_sig_pending = 0;
1d7c1841
GS		 8639# else /* !DEBUGGING */
8640 Zero(my_perl, 1, PerlInterpreter);
8641# endif /* DEBUGGING */
8642#endif /* PERL_IMPLICIT_SYS */
8643
8644 /* arena roots */
8645 PL_xiv_arenaroot = NULL;
8646 PL_xiv_root = NULL;
612f20c3 8647 PL_xnv_arenaroot = NULL;
1d7c1841 8648 PL_xnv_root = NULL;
612f20c3 8649 PL_xrv_arenaroot = NULL;
1d7c1841 8650 PL_xrv_root = NULL;
612f20c3 8651 PL_xpv_arenaroot = NULL;
1d7c1841 8652 PL_xpv_root = NULL;
612f20c3 8653 PL_xpviv_arenaroot = NULL;
1d7c1841 8654 PL_xpviv_root = NULL;
612f20c3 8655 PL_xpvnv_arenaroot = NULL;
1d7c1841 8656 PL_xpvnv_root = NULL;
612f20c3 8657 PL_xpvcv_arenaroot = NULL;
1d7c1841 8658 PL_xpvcv_root = NULL;
612f20c3 8659 PL_xpvav_arenaroot = NULL;
1d7c1841 8660 PL_xpvav_root = NULL;
612f20c3 8661 PL_xpvhv_arenaroot = NULL;
1d7c1841 8662 PL_xpvhv_root = NULL;
612f20c3 8663 PL_xpvmg_arenaroot = NULL;
1d7c1841 8664 PL_xpvmg_root = NULL;
612f20c3 8665 PL_xpvlv_arenaroot = NULL;
1d7c1841 8666 PL_xpvlv_root = NULL;
612f20c3 8667 PL_xpvbm_arenaroot = NULL;
1d7c1841 8668 PL_xpvbm_root = NULL;
612f20c3 8669 PL_he_arenaroot = NULL;
1d7c1841
GS		 8670 PL_he_root = NULL;
8671 PL_nice_chunk = NULL;
8672 PL_nice_chunk_size = 0;
8673 PL_sv_count = 0;
8674 PL_sv_objcount = 0;
8675 PL_sv_root = Nullsv;
8676 PL_sv_arenaroot = Nullsv;
8677
8678 PL_debug = proto_perl->Idebug;
8679
8680 /* create SV map for pointer relocation */
8681 PL_ptr_table = ptr_table_new();
8682
8683 /* initialize these special pointers as early as possible */
8684 SvANY(&PL_sv_undef) = NULL;
8685 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8686 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8687 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8688
8689#ifdef PERL_OBJECT
8690 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8691#else
8692 SvANY(&PL_sv_no) = new_XPVNV();
8693#endif
8694 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8695 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8696 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8697 SvCUR(&PL_sv_no) = 0;
8698 SvLEN(&PL_sv_no) = 1;
8699 SvNVX(&PL_sv_no) = 0;
8700 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8701
8702#ifdef PERL_OBJECT
8703 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8704#else
8705 SvANY(&PL_sv_yes) = new_XPVNV();
8706#endif
8707 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8708 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8709 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8710 SvCUR(&PL_sv_yes) = 1;
8711 SvLEN(&PL_sv_yes) = 2;
8712 SvNVX(&PL_sv_yes) = 1;
8713 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8714
8715 /* create shared string table */
8716 PL_strtab = newHV();
8717 HvSHAREKEYS_off(PL_strtab);
8718 hv_ksplit(PL_strtab, 512);
8719 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8720
8721 PL_compiling = proto_perl->Icompiling;
8722 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8723 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8724 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8725 if (!specialWARN(PL_compiling.cop_warnings))
8726 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
ac27b0f5
NIS		 8727 if (!specialCopIO(PL_compiling.cop_io))
8728 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
1d7c1841
GS		 8729 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8730
8731 /* pseudo environmental stuff */
8732 PL_origargc = proto_perl->Iorigargc;
8733 i = PL_origargc;
8734 New(0, PL_origargv, i+1, char*);
8735 PL_origargv[i] = '\0';
8736 while (i-- > 0) {
8737 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8738 }
8739 PL_envgv = gv_dup(proto_perl->Ienvgv);
8740 PL_incgv = gv_dup(proto_perl->Iincgv);
8741 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8742 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8743 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8744 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8745
8746 /* switches */
8747 PL_minus_c = proto_perl->Iminus_c;
a7cb1f99 8748 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
1d7c1841
GS		 8749 PL_localpatches = proto_perl->Ilocalpatches;
8750 PL_splitstr = proto_perl->Isplitstr;
8751 PL_preprocess = proto_perl->Ipreprocess;
8752 PL_minus_n = proto_perl->Iminus_n;
8753 PL_minus_p = proto_perl->Iminus_p;
8754 PL_minus_l = proto_perl->Iminus_l;
8755 PL_minus_a = proto_perl->Iminus_a;
8756 PL_minus_F = proto_perl->Iminus_F;
8757 PL_doswitches = proto_perl->Idoswitches;
8758 PL_dowarn = proto_perl->Idowarn;
8759 PL_doextract = proto_perl->Idoextract;
8760 PL_sawampersand = proto_perl->Isawampersand;
8761 PL_unsafe = proto_perl->Iunsafe;
8762 PL_inplace = SAVEPV(proto_perl->Iinplace);
8763 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8764 PL_perldb = proto_perl->Iperldb;
8765 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8766
8767 /* magical thingies */
8768 /* XXX time(&PL_basetime) when asked for? */
8769 PL_basetime = proto_perl->Ibasetime;
8770 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8771
8772 PL_maxsysfd = proto_perl->Imaxsysfd;
8773 PL_multiline = proto_perl->Imultiline;
8774 PL_statusvalue = proto_perl->Istatusvalue;
8775#ifdef VMS
8776 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8777#endif
8778
8779 /* shortcuts to various I/O objects */
8780 PL_stdingv = gv_dup(proto_perl->Istdingv);
8781 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8782 PL_defgv = gv_dup(proto_perl->Idefgv);
8783 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8784 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8785 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8786
8787 /* shortcuts to regexp stuff */
8788 PL_replgv = gv_dup(proto_perl->Ireplgv);
8789
8790 /* shortcuts to misc objects */
8791 PL_errgv = gv_dup(proto_perl->Ierrgv);
8792
8793 /* shortcuts to debugging objects */
8794 PL_DBgv = gv_dup(proto_perl->IDBgv);
8795 PL_DBline = gv_dup(proto_perl->IDBline);
8796 PL_DBsub = gv_dup(proto_perl->IDBsub);
8797 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8798 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8799 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8800 PL_lineary = av_dup(proto_perl->Ilineary);
8801 PL_dbargs = av_dup(proto_perl->Idbargs);
8802
8803 /* symbol tables */
8804 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8805 PL_curstash = hv_dup(proto_perl->Tcurstash);
8806 PL_debstash = hv_dup(proto_perl->Idebstash);
8807 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8808 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8809
8810 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8811 PL_endav = av_dup_inc(proto_perl->Iendav);
7d30b5c4 8812 PL_checkav = av_dup_inc(proto_perl->Icheckav);
1d7c1841
GS		 8813 PL_initav = av_dup_inc(proto_perl->Iinitav);
8814
8815 PL_sub_generation = proto_perl->Isub_generation;
8816
8817 /* funky return mechanisms */
8818 PL_forkprocess = proto_perl->Iforkprocess;
8819
8820 /* subprocess state */
8821 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8822
8823 /* internal state */
8824 PL_tainting = proto_perl->Itainting;
8825 PL_maxo = proto_perl->Imaxo;
8826 if (proto_perl->Iop_mask)
8827 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8828 else
8829 PL_op_mask = Nullch;
8830
8831 /* current interpreter roots */
8832 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8833 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8834 PL_main_start = proto_perl->Imain_start;
e977893f 8835 PL_eval_root = proto_perl->Ieval_root;
1d7c1841
GS		 8836 PL_eval_start = proto_perl->Ieval_start;
8837
8838 /* runtime control stuff */
8839 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8840 PL_copline = proto_perl->Icopline;
8841
8842 PL_filemode = proto_perl->Ifilemode;
8843 PL_lastfd = proto_perl->Ilastfd;
8844 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8845 PL_Argv = NULL;
8846 PL_Cmd = Nullch;
8847 PL_gensym = proto_perl->Igensym;
8848 PL_preambled = proto_perl->Ipreambled;
8849 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8850 PL_laststatval = proto_perl->Ilaststatval;
8851 PL_laststype = proto_perl->Ilaststype;
8852 PL_mess_sv = Nullsv;
8853
7889fe52 8854 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
1d7c1841
GS		 8855 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8856
8857 /* interpreter atexit processing */
8858 PL_exitlistlen = proto_perl->Iexitlistlen;
8859 if (PL_exitlistlen) {
8860 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8861 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8862 }
8863 else
8864 PL_exitlist = (PerlExitListEntry*)NULL;
8865 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8866
8867 PL_profiledata = NULL;
8868 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8869 /* PL_rsfp_filters entries have fake IoDIRP() */
8870 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8871
8872 PL_compcv = cv_dup(proto_perl->Icompcv);
8873 PL_comppad = av_dup(proto_perl->Icomppad);
8874 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8875 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8876 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8877 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8878 proto_perl->Tcurpad);
8879
8880#ifdef HAVE_INTERP_INTERN
8881 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8882#endif
8883
8884 /* more statics moved here */
8885 PL_generation = proto_perl->Igeneration;
8886 PL_DBcv = cv_dup(proto_perl->IDBcv);
1d7c1841
GS		 8887
8888 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8889 PL_in_clean_all = proto_perl->Iin_clean_all;
8890
8891 PL_uid = proto_perl->Iuid;
8892 PL_euid = proto_perl->Ieuid;
8893 PL_gid = proto_perl->Igid;
8894 PL_egid = proto_perl->Iegid;
8895 PL_nomemok = proto_perl->Inomemok;
8896 PL_an = proto_perl->Ian;
8897 PL_cop_seqmax = proto_perl->Icop_seqmax;
8898 PL_op_seqmax = proto_perl->Iop_seqmax;
8899 PL_evalseq = proto_perl->Ievalseq;
8900 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8901 PL_origalen = proto_perl->Iorigalen;
8902 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8903 PL_osname = SAVEPV(proto_perl->Iosname);
8904 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8905 PL_sighandlerp = proto_perl->Isighandlerp;
8906
8907
8908 PL_runops = proto_perl->Irunops;
8909
8910 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8911
8912#ifdef CSH
8913 PL_cshlen = proto_perl->Icshlen;
8914 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8915#endif
8916
8917 PL_lex_state = proto_perl->Ilex_state;
8918 PL_lex_defer = proto_perl->Ilex_defer;
8919 PL_lex_expect = proto_perl->Ilex_expect;
8920 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8921 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8922 PL_lex_starts = proto_perl->Ilex_starts;
8923 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8924 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8925 PL_lex_op = proto_perl->Ilex_op;
8926 PL_lex_inpat = proto_perl->Ilex_inpat;
8927 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8928 PL_lex_brackets = proto_perl->Ilex_brackets;
8929 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8930 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8931 PL_lex_casemods = proto_perl->Ilex_casemods;
8932 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8933 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8934
8935 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8936 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8937 PL_nexttoke = proto_perl->Inexttoke;
8938
8939 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8940 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8941 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8942 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8943 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8944 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8945 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8946 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8947 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8948 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8949 PL_pending_ident = proto_perl->Ipending_ident;
8950 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8951
8952 PL_expect = proto_perl->Iexpect;
8953
8954 PL_multi_start = proto_perl->Imulti_start;
8955 PL_multi_end = proto_perl->Imulti_end;
8956 PL_multi_open = proto_perl->Imulti_open;
8957 PL_multi_close = proto_perl->Imulti_close;
8958
8959 PL_error_count = proto_perl->Ierror_count;
8960 PL_subline = proto_perl->Isubline;
8961 PL_subname = sv_dup_inc(proto_perl->Isubname);
8962
8963 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8964 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8965 PL_padix = proto_perl->Ipadix;
8966 PL_padix_floor = proto_perl->Ipadix_floor;
8967 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8968
8969 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8970 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8971 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8972 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8973 PL_last_lop_op = proto_perl->Ilast_lop_op;
8974 PL_in_my = proto_perl->Iin_my;
8975 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8976#ifdef FCRYPT
8977 PL_cryptseen = proto_perl->Icryptseen;
8978#endif
8979
8980 PL_hints = proto_perl->Ihints;
8981
8982 PL_amagic_generation = proto_perl->Iamagic_generation;
8983
8984#ifdef USE_LOCALE_COLLATE
8985 PL_collation_ix = proto_perl->Icollation_ix;
8986 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8987 PL_collation_standard = proto_perl->Icollation_standard;
8988 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8989 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8990#endif /* USE_LOCALE_COLLATE */
8991
8992#ifdef USE_LOCALE_NUMERIC
8993 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8994 PL_numeric_standard = proto_perl->Inumeric_standard;
8995 PL_numeric_local = proto_perl->Inumeric_local;
ac634a9a 8996 PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
1d7c1841
GS		 8997#endif /* !USE_LOCALE_NUMERIC */
8998
8999 /* utf8 character classes */
9000 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9001 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9002 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9003 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9004 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9005 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9006 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9007 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9008 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9009 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9010 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9011 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9012 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9013 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9014 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9015 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9016 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9017
9018 /* swatch cache */
9019 PL_last_swash_hv = Nullhv; /* reinits on demand */
9020 PL_last_swash_klen = 0;
9021 PL_last_swash_key[0]= '\0';
9022 PL_last_swash_tmps = (U8*)NULL;
9023 PL_last_swash_slen = 0;
9024
9025 /* perly.c globals */
9026 PL_yydebug = proto_perl->Iyydebug;
9027 PL_yynerrs = proto_perl->Iyynerrs;
9028 PL_yyerrflag = proto_perl->Iyyerrflag;
9029 PL_yychar = proto_perl->Iyychar;
9030 PL_yyval = proto_perl->Iyyval;
9031 PL_yylval = proto_perl->Iyylval;
9032
9033 PL_glob_index = proto_perl->Iglob_index;
9034 PL_srand_called = proto_perl->Isrand_called;
9035 PL_uudmap['M'] = 0; /* reinits on demand */
9036 PL_bitcount = Nullch; /* reinits on demand */
9037
66fe0623
NIS		 9038 if (proto_perl->Ipsig_pend) {
9039 Newz(0, PL_psig_pend, SIG_SIZE, int);
9dd79c3f 9040 }
66fe0623
NIS		 9041 else {
9042 PL_psig_pend = (int*)NULL;
9043 }
9044
1d7c1841 9045 if (proto_perl->Ipsig_ptr) {
76d3c696
JH		 9046 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9047 Newz(0, PL_psig_name, SIG_SIZE, SV*);
76d3c696
JH		 9048 for (i = 1; i < SIG_SIZE; i++) {
9049 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
1d7c1841
GS		 9050 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9051 }
9052 }
9053 else {
9054 PL_psig_ptr = (SV**)NULL;
9055 PL_psig_name = (SV**)NULL;
9056 }
9057
9058 /* thrdvar.h stuff */
9059
a0739874 9060 if (flags & CLONEf_COPY_STACKS) {
1d7c1841
GS		 9061 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9062 PL_tmps_ix = proto_perl->Ttmps_ix;
9063 PL_tmps_max = proto_perl->Ttmps_max;
9064 PL_tmps_floor = proto_perl->Ttmps_floor;
9065 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9066 i = 0;
9067 while (i <= PL_tmps_ix) {
9068 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9069 ++i;
9070 }
9071
9072 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9073 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9074 Newz(54, PL_markstack, i, I32);
9075 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9076 - proto_perl->Tmarkstack);
9077 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9078 - proto_perl->Tmarkstack);
9079 Copy(proto_perl->Tmarkstack, PL_markstack,
9080 PL_markstack_ptr - PL_markstack + 1, I32);
9081
9082 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9083 * NOTE: unlike the others! */
9084 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9085 PL_scopestack_max = proto_perl->Tscopestack_max;
9086 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9087 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9088
9089 /* next push_return() sets PL_retstack[PL_retstack_ix]
9090 * NOTE: unlike the others! */
9091 PL_retstack_ix = proto_perl->Tretstack_ix;
9092 PL_retstack_max = proto_perl->Tretstack_max;
9093 Newz(54, PL_retstack, PL_retstack_max, OP*);
9094 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9095
9096 /* NOTE: si_dup() looks at PL_markstack */
9097 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9098
9099 /* PL_curstack = PL_curstackinfo->si_stack; */
9100 PL_curstack = av_dup(proto_perl->Tcurstack);
9101 PL_mainstack = av_dup(proto_perl->Tmainstack);
9102
9103 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9104 PL_stack_base = AvARRAY(PL_curstack);
9105 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9106 - proto_perl->Tstack_base);
9107 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9108
9109 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9110 * NOTE: unlike the others! */
9111 PL_savestack_ix = proto_perl->Tsavestack_ix;
9112 PL_savestack_max = proto_perl->Tsavestack_max;
9113 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9114 PL_savestack = ss_dup(proto_perl);
9115 }
9116 else {
9117 init_stacks();
985e7056 9118 ENTER; /* perl_destruct() wants to LEAVE; */
1d7c1841
GS		 9119 }
9120
9121 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9122 PL_top_env = &PL_start_env;
9123
9124 PL_op = proto_perl->Top;
9125
9126 PL_Sv = Nullsv;
9127 PL_Xpv = (XPV*)NULL;
9128 PL_na = proto_perl->Tna;
9129
9130 PL_statbuf = proto_perl->Tstatbuf;
9131 PL_statcache = proto_perl->Tstatcache;
9132 PL_statgv = gv_dup(proto_perl->Tstatgv);
9133 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9134#ifdef HAS_TIMES
9135 PL_timesbuf = proto_perl->Ttimesbuf;
9136#endif
9137
9138 PL_tainted = proto_perl->Ttainted;
9139 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9140 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9141 PL_rs = sv_dup_inc(proto_perl->Trs);
9142 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7889fe52 9143 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
1d7c1841
GS		 9144 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9145 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9146 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9147 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9148 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9149
9150 PL_restartop = proto_perl->Trestartop;
9151 PL_in_eval = proto_perl->Tin_eval;
9152 PL_delaymagic = proto_perl->Tdelaymagic;
9153 PL_dirty = proto_perl->Tdirty;
9154 PL_localizing = proto_perl->Tlocalizing;
9155
14dd3ad8 9156#ifdef PERL_FLEXIBLE_EXCEPTIONS
1d7c1841 9157 PL_protect = proto_perl->Tprotect;
14dd3ad8 9158#endif
1d7c1841
GS		 9159 PL_errors = sv_dup_inc(proto_perl->Terrors);
9160 PL_av_fetch_sv = Nullsv;
9161 PL_hv_fetch_sv = Nullsv;
9162 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9163 PL_modcount = proto_perl->Tmodcount;
9164 PL_lastgotoprobe = Nullop;
9165 PL_dumpindent = proto_perl->Tdumpindent;
9166
9167 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9168 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9169 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9170 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9171 PL_sortcxix = proto_perl->Tsortcxix;
9172 PL_efloatbuf = Nullch; /* reinits on demand */
9173 PL_efloatsize = 0; /* reinits on demand */
9174
9175 /* regex stuff */
9176
9177 PL_screamfirst = NULL;
9178 PL_screamnext = NULL;
9179 PL_maxscream = -1; /* reinits on demand */
9180 PL_lastscream = Nullsv;
9181
9182 PL_watchaddr = NULL;
9183 PL_watchok = Nullch;
9184
9185 PL_regdummy = proto_perl->Tregdummy;
9186 PL_regcomp_parse = Nullch;
9187 PL_regxend = Nullch;
9188 PL_regcode = (regnode*)NULL;
9189 PL_regnaughty = 0;
9190 PL_regsawback = 0;
9191 PL_regprecomp = Nullch;
9192 PL_regnpar = 0;
9193 PL_regsize = 0;
9194 PL_regflags = 0;
9195 PL_regseen = 0;
9196 PL_seen_zerolen = 0;
9197 PL_seen_evals = 0;
9198 PL_regcomp_rx = (regexp*)NULL;
9199 PL_extralen = 0;
9200 PL_colorset = 0; /* reinits PL_colors[] */
9201 /*PL_colors[6] = {0,0,0,0,0,0};*/
9202 PL_reg_whilem_seen = 0;
9203 PL_reginput = Nullch;
9204 PL_regbol = Nullch;
9205 PL_regeol = Nullch;
9206 PL_regstartp = (I32*)NULL;
9207 PL_regendp = (I32*)NULL;
9208 PL_reglastparen = (U32*)NULL;
9209 PL_regtill = Nullch;
9210 PL_regprev = '\n';
9211 PL_reg_start_tmp = (char**)NULL;
9212 PL_reg_start_tmpl = 0;
9213 PL_regdata = (struct reg_data*)NULL;
9214 PL_bostr = Nullch;
9215 PL_reg_flags = 0;
9216 PL_reg_eval_set = 0;
9217 PL_regnarrate = 0;
9218 PL_regprogram = (regnode*)NULL;
9219 PL_regindent = 0;
9220 PL_regcc = (CURCUR*)NULL;
9221 PL_reg_call_cc = (struct re_cc_state*)NULL;
9222 PL_reg_re = (regexp*)NULL;
9223 PL_reg_ganch = Nullch;
9224 PL_reg_sv = Nullsv;
9225 PL_reg_magic = (MAGIC*)NULL;
9226 PL_reg_oldpos = 0;
9227 PL_reg_oldcurpm = (PMOP*)NULL;
9228 PL_reg_curpm = (PMOP*)NULL;
9229 PL_reg_oldsaved = Nullch;
9230 PL_reg_oldsavedlen = 0;
9231 PL_reg_maxiter = 0;
9232 PL_reg_leftiter = 0;
9233 PL_reg_poscache = Nullch;
9234 PL_reg_poscache_size= 0;
9235
9236 /* RE engine - function pointers */
9237 PL_regcompp = proto_perl->Tregcompp;
9238 PL_regexecp = proto_perl->Tregexecp;
9239 PL_regint_start = proto_perl->Tregint_start;
9240 PL_regint_string = proto_perl->Tregint_string;
9241 PL_regfree = proto_perl->Tregfree;
9242
9243 PL_reginterp_cnt = 0;
9244 PL_reg_starttry = 0;
9245
a0739874
DM		 9246 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9247 ptr_table_free(PL_ptr_table);
9248 PL_ptr_table = NULL;
9249 }
9250
1d7c1841
GS		 9251#ifdef PERL_OBJECT
9252 return (PerlInterpreter*)pPerl;
9253#else
9254 return my_perl;
9255#endif
9256}
9257
9258#else /* !USE_ITHREADS */
51371543
GS		 9259
9260#ifdef PERL_OBJECT
51371543
GS		 9261#include "XSUB.h"
9262#endif
9263
1d7c1841
GS		 9264#endif /* USE_ITHREADS */
9265
51371543
GS		 9266static void
9267do_report_used(pTHXo_ SV *sv)
9268{
9269 if (SvTYPE(sv) != SVTYPEMASK) {
bf49b057 9270 PerlIO_printf(Perl_debug_log, "****\n");
51371543
GS		 9271 sv_dump(sv);
9272 }
9273}
9274
9275static void
9276do_clean_objs(pTHXo_ SV *sv)
9277{
9278 SV* rv;
9279
9280 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9281 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8b6e653b
HS		 9282 if (SvWEAKREF(sv)) {
9283 sv_del_backref(sv);
9284 SvWEAKREF_off(sv);
9285 SvRV(sv) = 0;
9286 } else {
9287 SvROK_off(sv);
9288 SvRV(sv) = 0;
9289 SvREFCNT_dec(rv);
9290 }
51371543
GS		 9291 }
9292
9293 /* XXX Might want to check arrays, etc. */
9294}
9295
9296#ifndef DISABLE_DESTRUCTOR_KLUDGE
9297static void
9298do_clean_named_objs(pTHXo_ SV *sv)
9299{
f472eb5c 9300 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
51371543 9301 if ( SvOBJECT(GvSV(sv)) ||
155aba94
GS		 9302 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9303 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9304 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9305 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
51371543
GS		 9306 {
9307 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9308 SvREFCNT_dec(sv);
9309 }
9310 }
9311}
9312#endif
9313
9314static void
9315do_clean_all(pTHXo_ SV *sv)
9316{
1d7c1841 9317 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
51371543
GS		 9318 SvFLAGS(sv) |= SVf_BREAK;
9319 SvREFCNT_dec(sv);
9320}
8af02333 9321
Unnamed repository; edit this file 'description' to name the repository.