This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate mainline.
[perl5.git] / sv.c
CommitLineData
a0d0e21e 1/* sv.c
79072805 2 *
3818b22b 3 * Copyright (c) 1991-2000, 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{
25da4f38
IZ		 1323 sv_setiv(sv, 0);
1324 SvIsUV_on(sv);
1325 SvUVX(sv) = u;
55497cff 1326}
1327
954c1994
GS		 1328/*
1329=for apidoc sv_setuv_mg
1330
1331Like C<sv_setuv>, but also handles 'set' magic.
1332
1333=cut
1334*/
1335
55497cff 1336void
864dbfa3 1337Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
ef50df4b
GS		 1338{
1339 sv_setuv(sv,u);
1340 SvSETMAGIC(sv);
1341}
1342
954c1994
GS		 1343/*
1344=for apidoc sv_setnv
1345
1346Copies a double into the given SV. Does not handle 'set' magic. See
1347C<sv_setnv_mg>.
1348
1349=cut
1350*/
1351
ef50df4b 1352void
65202027 1353Perl_sv_setnv(pTHX_ register SV *sv, NV num)
79072805 1354{
2213622d 1355 SV_CHECK_THINKFIRST(sv);
a0d0e21e
LW		 1356 switch (SvTYPE(sv)) {
1357 case SVt_NULL:
1358 case SVt_IV:
79072805 1359 sv_upgrade(sv, SVt_NV);
a0d0e21e 1360 break;
a0d0e21e
LW		 1361 case SVt_RV:
1362 case SVt_PV:
1363 case SVt_PVIV:
79072805 1364 sv_upgrade(sv, SVt_PVNV);
a0d0e21e 1365 break;
827b7e14 1366
a0d0e21e 1367 case SVt_PVGV:
a0d0e21e
LW		 1368 case SVt_PVAV:
1369 case SVt_PVHV:
1370 case SVt_PVCV:
1371 case SVt_PVFM:
1372 case SVt_PVIO:
411caa50
JH		 1373 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1374 PL_op_name[PL_op->op_type]);
79072805 1375 }
463ee0b2 1376 SvNVX(sv) = num;
a0d0e21e 1377 (void)SvNOK_only(sv); /* validate number */
463ee0b2 1378 SvTAINT(sv);
79072805
LW		 1379}
1380
954c1994
GS		 1381/*
1382=for apidoc sv_setnv_mg
1383
1384Like C<sv_setnv>, but also handles 'set' magic.
1385
1386=cut
1387*/
1388
ef50df4b 1389void
65202027 1390Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
ef50df4b
GS		 1391{
1392 sv_setnv(sv,num);
1393 SvSETMAGIC(sv);
1394}
1395
76e3520e 1396STATIC void
cea2e8a9 1397S_not_a_number(pTHX_ SV *sv)
a0d0e21e
LW		 1398{
1399 char tmpbuf[64];
1400 char *d = tmpbuf;
1401 char *s;
dc28f22b
GA		 1402 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1403 /* each *s can expand to 4 chars + "...\0",
1404 i.e. need room for 8 chars */
a0d0e21e 1405
dc28f22b 1406 for (s = SvPVX(sv); *s && d < limit; s++) {
bbce6d69 1407 int ch = *s & 0xFF;
1408 if (ch & 128 && !isPRINT_LC(ch)) {
a0d0e21e
LW		 1409 *d++ = 'M';
1410 *d++ = '-';
1411 ch &= 127;
1412 }
bbce6d69 1413 if (ch == '\n') {
1414 *d++ = '\\';
1415 *d++ = 'n';
1416 }
1417 else if (ch == '\r') {
1418 *d++ = '\\';
1419 *d++ = 'r';
1420 }
1421 else if (ch == '\f') {
1422 *d++ = '\\';
1423 *d++ = 'f';
1424 }
1425 else if (ch == '\\') {
1426 *d++ = '\\';
1427 *d++ = '\\';
1428 }
1429 else if (isPRINT_LC(ch))
a0d0e21e
LW		 1430 *d++ = ch;
1431 else {
1432 *d++ = '^';
bbce6d69 1433 *d++ = toCTRL(ch);
a0d0e21e
LW		 1434 }
1435 }
1436 if (*s) {
1437 *d++ = '.';
1438 *d++ = '.';
1439 *d++ = '.';
1440 }
1441 *d = '\0';
1442
533c011a 1443 if (PL_op)
42d38218
MS		 1444 Perl_warner(aTHX_ WARN_NUMERIC,
1445 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1446 PL_op_desc[PL_op->op_type]);
a0d0e21e 1447 else
42d38218
MS		 1448 Perl_warner(aTHX_ WARN_NUMERIC,
1449 "Argument \"%s\" isn't numeric", tmpbuf);
a0d0e21e
LW		 1450}
1451
cf2093f6 1452/* the number can be converted to integer with atol() or atoll() */
25da4f38
IZ		 1453#define IS_NUMBER_TO_INT_BY_ATOL 0x01
1454#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1455#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1456#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
300aed98 1457#define IS_NUMBER_INFINITY 0x10 /* this is big */
25da4f38
IZ		 1458
1459/* Actually, ISO C leaves conversion of UV to IV undefined, but
1460 until proven guilty, assume that things are not that bad... */
1461
a0d0e21e 1462IV
864dbfa3 1463Perl_sv_2iv(pTHX_ register SV *sv)
79072805
LW		 1464{
1465 if (!sv)
1466 return 0;
8990e307 1467 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1468 mg_get(sv);
1469 if (SvIOKp(sv))
1470 return SvIVX(sv);
748a9306 1471 if (SvNOKp(sv)) {
25da4f38 1472 return I_V(SvNVX(sv));
748a9306 1473 }
36477c24 1474 if (SvPOKp(sv) && SvLEN(sv))
1475 return asIV(sv);
3fe9a6f1 1476 if (!SvROK(sv)) {
d008e5eb 1477 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 1478 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1479 report_uninit();
c6ee37c5 1480 }
36477c24 1481 return 0;
3fe9a6f1 1482 }
463ee0b2 1483 }
ed6116ce 1484 if (SvTHINKFIRST(sv)) {
a0d0e21e 1485 if (SvROK(sv)) {
a0d0e21e 1486 SV* tmpstr;
1554e226
DC		 1487 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1488 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 1489 return SvIV(tmpstr);
56431972 1490 return PTR2IV(SvRV(sv));
a0d0e21e 1491 }
47deb5e7
NIS		 1492 if (SvREADONLY(sv) && SvFAKE(sv)) {
1493 sv_force_normal(sv);
1494 }
0336b60e 1495 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 1496 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1497 report_uninit();
ed6116ce
LW		 1498 return 0;
1499 }
79072805 1500 }
25da4f38
IZ		 1501 if (SvIOKp(sv)) {
1502 if (SvIsUV(sv)) {
1503 return (IV)(SvUVX(sv));
1504 }
1505 else {
1506 return SvIVX(sv);
1507 }
463ee0b2 1508 }
748a9306 1509 if (SvNOKp(sv)) {
25da4f38
IZ		 1510 /* We can cache the IV/UV value even if it not good enough
1511 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1512 * NV over IV/UV.
25da4f38
IZ		 1513 */
1514
1515 if (SvTYPE(sv) == SVt_NV)
1516 sv_upgrade(sv, SVt_PVNV);
1517
a5f75d66 1518 (void)SvIOK_on(sv);
65202027 1519 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
748a9306 1520 SvIVX(sv) = I_V(SvNVX(sv));
25da4f38 1521 else {
ff68c719 1522 SvUVX(sv) = U_V(SvNVX(sv));
25da4f38
IZ		 1523 SvIsUV_on(sv);
1524 ret_iv_max:
1c846c1f 1525 DEBUG_c(PerlIO_printf(Perl_debug_log,
57def98f 1526 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
56431972 1527 PTR2UV(sv),
57def98f
JH		 1528 SvUVX(sv),
1529 SvUVX(sv)));
25da4f38
IZ		 1530 return (IV)SvUVX(sv);
1531 }
748a9306
LW		 1532 }
1533 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1534 I32 numtype = looks_like_number(sv);
1535
1536 /* We want to avoid a possible problem when we cache an IV which
1537 may be later translated to an NV, and the resulting NV is not
1538 the translation of the initial data.
1c846c1f 1539
25da4f38
IZ		 1540 This means that if we cache such an IV, we need to cache the
1541 NV as well. Moreover, we trade speed for space, and do not
1542 cache the NV if not needed.
1543 */
1544 if (numtype & IS_NUMBER_NOT_IV) {
1545 /* May be not an integer. Need to cache NV if we cache IV
1546 * - otherwise future conversion to NV will be wrong. */
65202027 1547 NV d;
25da4f38 1548
097ee67d 1549 d = Atof(SvPVX(sv));
25da4f38
IZ		 1550
1551 if (SvTYPE(sv) < SVt_PVNV)
1552 sv_upgrade(sv, SVt_PVNV);
1553 SvNVX(sv) = d;
1554 (void)SvNOK_on(sv);
1555 (void)SvIOK_on(sv);
65202027 1556#if defined(USE_LONG_DOUBLE)
1d7c1841
GS		 1557 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1558 PTR2UV(sv), SvNVX(sv)));
65202027 1559#else
1d7c1841
GS		 1560 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1561 PTR2UV(sv), SvNVX(sv)));
65202027 1562#endif
65202027 1563 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
25da4f38
IZ		 1564 SvIVX(sv) = I_V(SvNVX(sv));
1565 else {
1566 SvUVX(sv) = U_V(SvNVX(sv));
1567 SvIsUV_on(sv);
1568 goto ret_iv_max;
1569 }
1570 }
0a3ece55
MG		 1571 else { /* The NV may be reconstructed from IV - safe to cache IV,
1572 which may be calculated by atol(). */
25da4f38
IZ		 1573 if (SvTYPE(sv) < SVt_PVIV)
1574 sv_upgrade(sv, SVt_PVIV);
25da4f38 1575 (void)SvIOK_on(sv);
0a3ece55
MG		 1576 SvIVX(sv) = Atol(SvPVX(sv));
1577 if (! numtype && ckWARN(WARN_NUMERIC))
25da4f38
IZ		 1578 not_a_number(sv);
1579 }
93a17b20 1580 }
79072805 1581 else {
599cee73 1582 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1583 report_uninit();
25da4f38
IZ		 1584 if (SvTYPE(sv) < SVt_IV)
1585 /* Typically the caller expects that sv_any is not NULL now. */
1586 sv_upgrade(sv, SVt_IV);
a0d0e21e 1587 return 0;
79072805 1588 }
1d7c1841
GS		 1589 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1590 PTR2UV(sv),SvIVX(sv)));
25da4f38 1591 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
79072805
LW		 1592}
1593
ff68c719 1594UV
864dbfa3 1595Perl_sv_2uv(pTHX_ register SV *sv)
ff68c719 1596{
1597 if (!sv)
1598 return 0;
1599 if (SvGMAGICAL(sv)) {
1600 mg_get(sv);
1601 if (SvIOKp(sv))
1602 return SvUVX(sv);
1603 if (SvNOKp(sv))
1604 return U_V(SvNVX(sv));
36477c24 1605 if (SvPOKp(sv) && SvLEN(sv))
1606 return asUV(sv);
3fe9a6f1 1607 if (!SvROK(sv)) {
d008e5eb 1608 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 1609 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1610 report_uninit();
c6ee37c5 1611 }
36477c24 1612 return 0;
3fe9a6f1 1613 }
ff68c719 1614 }
1615 if (SvTHINKFIRST(sv)) {
1616 if (SvROK(sv)) {
ff68c719 1617 SV* tmpstr;
1554e226
DC		 1618 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1619 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 1620 return SvUV(tmpstr);
56431972 1621 return PTR2UV(SvRV(sv));
ff68c719 1622 }
0336b60e 1623 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 1624 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1625 report_uninit();
ff68c719 1626 return 0;
1627 }
1628 }
25da4f38
IZ		 1629 if (SvIOKp(sv)) {
1630 if (SvIsUV(sv)) {
1631 return SvUVX(sv);
1632 }
1633 else {
1634 return (UV)SvIVX(sv);
1635 }
ff68c719 1636 }
1637 if (SvNOKp(sv)) {
25da4f38
IZ		 1638 /* We can cache the IV/UV value even if it not good enough
1639 * to reconstruct NV, since the conversion to PV will prefer
cf2093f6 1640 * NV over IV/UV.
25da4f38
IZ		 1641 */
1642 if (SvTYPE(sv) == SVt_NV)
1643 sv_upgrade(sv, SVt_PVNV);
ff68c719 1644 (void)SvIOK_on(sv);
25da4f38
IZ		 1645 if (SvNVX(sv) >= -0.5) {
1646 SvIsUV_on(sv);
1647 SvUVX(sv) = U_V(SvNVX(sv));
1648 }
1649 else {
1650 SvIVX(sv) = I_V(SvNVX(sv));
1651 ret_zero:
1c846c1f 1652 DEBUG_c(PerlIO_printf(Perl_debug_log,
07270b1a 1653 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
57def98f
JH		 1654 PTR2UV(sv),
1655 SvIVX(sv),
1656 (IV)(UV)SvIVX(sv)));
25da4f38
IZ		 1657 return (UV)SvIVX(sv);
1658 }
ff68c719 1659 }
1660 else if (SvPOKp(sv) && SvLEN(sv)) {
25da4f38
IZ		 1661 I32 numtype = looks_like_number(sv);
1662
1663 /* We want to avoid a possible problem when we cache a UV which
1664 may be later translated to an NV, and the resulting NV is not
1665 the translation of the initial data.
1c846c1f 1666
25da4f38
IZ		 1667 This means that if we cache such a UV, we need to cache the
1668 NV as well. Moreover, we trade speed for space, and do not
1669 cache the NV if not needed.
1670 */
1671 if (numtype & IS_NUMBER_NOT_IV) {
1672 /* May be not an integer. Need to cache NV if we cache IV
1673 * - otherwise future conversion to NV will be wrong. */
65202027 1674 NV d;
25da4f38 1675
cf2093f6 1676 d = Atof(SvPVX(sv));
25da4f38
IZ		 1677
1678 if (SvTYPE(sv) < SVt_PVNV)
1679 sv_upgrade(sv, SVt_PVNV);
1680 SvNVX(sv) = d;
1681 (void)SvNOK_on(sv);
1682 (void)SvIOK_on(sv);
65202027 1683#if defined(USE_LONG_DOUBLE)
1d7c1841
GS		 1684 DEBUG_c(PerlIO_printf(Perl_debug_log,
1685 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1686 PTR2UV(sv), SvNVX(sv)));
65202027 1687#else
1d7c1841
GS		 1688 DEBUG_c(PerlIO_printf(Perl_debug_log,
1689 "0x%"UVxf" 2nv(%g)\n",
1690 PTR2UV(sv), SvNVX(sv)));
65202027 1691#endif
25da4f38
IZ		 1692 if (SvNVX(sv) < -0.5) {
1693 SvIVX(sv) = I_V(SvNVX(sv));
1694 goto ret_zero;
1695 } else {
1696 SvUVX(sv) = U_V(SvNVX(sv));
1697 SvIsUV_on(sv);
1698 }
1699 }
1700 else if (numtype & IS_NUMBER_NEG) {
1701 /* The NV may be reconstructed from IV - safe to cache IV,
1702 which may be calculated by atol(). */
1703 if (SvTYPE(sv) == SVt_PV)
1704 sv_upgrade(sv, SVt_PVIV);
1705 (void)SvIOK_on(sv);
cf2093f6 1706 SvIVX(sv) = (IV)Atol(SvPVX(sv));
25da4f38
IZ		 1707 }
1708 else if (numtype) { /* Non-negative */
1709 /* The NV may be reconstructed from UV - safe to cache UV,
1710 which may be calculated by strtoul()/atol. */
1711 if (SvTYPE(sv) == SVt_PV)
1712 sv_upgrade(sv, SVt_PVIV);
1713 (void)SvIOK_on(sv);
1714 (void)SvIsUV_on(sv);
1715#ifdef HAS_STRTOUL
cf2093f6 1716 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
25da4f38
IZ		 1717#else /* no atou(), but we know the number fits into IV... */
1718 /* The only problem may be if it is negative... */
cf2093f6 1719 SvUVX(sv) = (UV)Atol(SvPVX(sv));
25da4f38
IZ		 1720#endif
1721 }
1722 else { /* Not a number. Cache 0. */
25da4f38
IZ		 1723 if (SvTYPE(sv) < SVt_PVIV)
1724 sv_upgrade(sv, SVt_PVIV);
25da4f38
IZ		 1725 (void)SvIOK_on(sv);
1726 (void)SvIsUV_on(sv);
7b9e3c00
GS		 1727 SvUVX(sv) = 0; /* We assume that 0s have the
1728 same bitmap in IV and UV. */
25da4f38
IZ		 1729 if (ckWARN(WARN_NUMERIC))
1730 not_a_number(sv);
1731 }
ff68c719 1732 }
1733 else {
d008e5eb 1734 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 1735 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1736 report_uninit();
c6ee37c5 1737 }
25da4f38
IZ		 1738 if (SvTYPE(sv) < SVt_IV)
1739 /* Typically the caller expects that sv_any is not NULL now. */
1740 sv_upgrade(sv, SVt_IV);
ff68c719 1741 return 0;
1742 }
25da4f38 1743
1d7c1841
GS		 1744 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1745 PTR2UV(sv),SvUVX(sv)));
25da4f38 1746 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
ff68c719 1747}
1748
65202027 1749NV
864dbfa3 1750Perl_sv_2nv(pTHX_ register SV *sv)
79072805
LW		 1751{
1752 if (!sv)
1753 return 0.0;
8990e307 1754 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 1755 mg_get(sv);
1756 if (SvNOKp(sv))
1757 return SvNVX(sv);
a0d0e21e 1758 if (SvPOKp(sv) && SvLEN(sv)) {
599cee73 1759 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1760 not_a_number(sv);
097ee67d 1761 return Atof(SvPVX(sv));
a0d0e21e 1762 }
25da4f38 1763 if (SvIOKp(sv)) {
1c846c1f 1764 if (SvIsUV(sv))
65202027 1765 return (NV)SvUVX(sv);
25da4f38 1766 else
65202027 1767 return (NV)SvIVX(sv);
25da4f38 1768 }
16d20bd9 1769 if (!SvROK(sv)) {
d008e5eb 1770 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 1771 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 1772 report_uninit();
c6ee37c5 1773 }
16d20bd9
AD		 1774 return 0;
1775 }
463ee0b2 1776 }
ed6116ce 1777 if (SvTHINKFIRST(sv)) {
a0d0e21e 1778 if (SvROK(sv)) {
a0d0e21e 1779 SV* tmpstr;
1554e226
DC		 1780 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1781 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 1782 return SvNV(tmpstr);
56431972 1783 return PTR2NV(SvRV(sv));
a0d0e21e 1784 }
0336b60e 1785 if (SvREADONLY(sv) && !SvOK(sv)) {
599cee73 1786 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 1787 report_uninit();
ed6116ce
LW		 1788 return 0.0;
1789 }
79072805
LW		 1790 }
1791 if (SvTYPE(sv) < SVt_NV) {
463ee0b2
LW		 1792 if (SvTYPE(sv) == SVt_IV)
1793 sv_upgrade(sv, SVt_PVNV);
1794 else
1795 sv_upgrade(sv, SVt_NV);
572bbb43 1796#if defined(USE_LONG_DOUBLE)
097ee67d 1797 DEBUG_c({
f93f4e46 1798 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 1799 PerlIO_printf(Perl_debug_log,
1800 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1801 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 1802 RESTORE_NUMERIC_LOCAL();
1803 });
65202027 1804#else
572bbb43 1805 DEBUG_c({
f93f4e46 1806 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 1807 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1808 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 1809 RESTORE_NUMERIC_LOCAL();
1810 });
572bbb43 1811#endif
79072805
LW		 1812 }
1813 else if (SvTYPE(sv) < SVt_PVNV)
1814 sv_upgrade(sv, SVt_PVNV);
748a9306
LW		 1815 if (SvIOKp(sv) &&
1816 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 1817 {
65202027 1818 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
93a17b20 1819 }
748a9306 1820 else if (SvPOKp(sv) && SvLEN(sv)) {
599cee73 1821 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 1822 not_a_number(sv);
097ee67d 1823 SvNVX(sv) = Atof(SvPVX(sv));
93a17b20 1824 }
79072805 1825 else {
599cee73 1826 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 1827 report_uninit();
25da4f38
IZ		 1828 if (SvTYPE(sv) < SVt_NV)
1829 /* Typically the caller expects that sv_any is not NULL now. */
1830 sv_upgrade(sv, SVt_NV);
a0d0e21e 1831 return 0.0;
79072805
LW		 1832 }
1833 SvNOK_on(sv);
572bbb43 1834#if defined(USE_LONG_DOUBLE)
097ee67d 1835 DEBUG_c({
f93f4e46 1836 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 1837 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1838 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 1839 RESTORE_NUMERIC_LOCAL();
1840 });
65202027 1841#else
572bbb43 1842 DEBUG_c({
f93f4e46 1843 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 1844 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1845 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 1846 RESTORE_NUMERIC_LOCAL();
1847 });
572bbb43 1848#endif
463ee0b2 1849 return SvNVX(sv);
79072805
LW		 1850}
1851
76e3520e 1852STATIC IV
cea2e8a9 1853S_asIV(pTHX_ SV *sv)
36477c24 1854{
1855 I32 numtype = looks_like_number(sv);
65202027 1856 NV d;
36477c24 1857
25da4f38 1858 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1859 return Atol(SvPVX(sv));
d008e5eb 1860 if (!numtype) {
d008e5eb
GS		 1861 if (ckWARN(WARN_NUMERIC))
1862 not_a_number(sv);
1863 }
097ee67d 1864 d = Atof(SvPVX(sv));
25da4f38 1865 return I_V(d);
36477c24 1866}
1867
76e3520e 1868STATIC UV
cea2e8a9 1869S_asUV(pTHX_ SV *sv)
36477c24 1870{
1871 I32 numtype = looks_like_number(sv);
1872
84902520 1873#ifdef HAS_STRTOUL
25da4f38 1874 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 1875 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 1876#endif
d008e5eb 1877 if (!numtype) {
d008e5eb
GS		 1878 if (ckWARN(WARN_NUMERIC))
1879 not_a_number(sv);
1880 }
097ee67d 1881 return U_V(Atof(SvPVX(sv)));
36477c24 1882}
1883
25da4f38
IZ		 1884/*
1885 * Returns a combination of (advisory only - can get false negatives)
1886 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1887 * IS_NUMBER_NEG
1888 * 0 if does not look like number.
1889 *
1890 * In fact possible values are 0 and
1891 * IS_NUMBER_TO_INT_BY_ATOL 123
1892 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1893 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
300aed98 1894 * IS_NUMBER_INFINITY
25da4f38
IZ		 1895 * with a possible addition of IS_NUMBER_NEG.
1896 */
1897
954c1994
GS		 1898/*
1899=for apidoc looks_like_number
1900
1901Test if an the content of an SV looks like a number (or is a
1902number).
1903
1904=cut
1905*/
1906
36477c24 1907I32
864dbfa3 1908Perl_looks_like_number(pTHX_ SV *sv)
36477c24 1909{
1910 register char *s;
1911 register char *send;
1912 register char *sbegin;
25da4f38
IZ		 1913 register char *nbegin;
1914 I32 numtype = 0;
300aed98 1915 I32 sawinf = 0;
36477c24 1916 STRLEN len;
1917
1918 if (SvPOK(sv)) {
1c846c1f 1919 sbegin = SvPVX(sv);
36477c24 1920 len = SvCUR(sv);
1921 }
1922 else if (SvPOKp(sv))
1923 sbegin = SvPV(sv, len);
1924 else
1925 return 1;
1926 send = sbegin + len;
1927
1928 s = sbegin;
1929 while (isSPACE(*s))
1930 s++;
25da4f38
IZ		 1931 if (*s == '-') {
1932 s++;
1933 numtype = IS_NUMBER_NEG;
1934 }
1935 else if (*s == '+')
36477c24 1936 s++;
ff0cee69 1937
25da4f38
IZ		 1938 nbegin = s;
1939 /*
097ee67d
JH		 1940 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1941 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1942 * (int)atof().
25da4f38
IZ		 1943 */
1944
300aed98 1945 /* next must be digit or the radix separator or beginning of infinity */
ff0cee69 1946 if (isDIGIT(*s)) {
1947 do {
1948 s++;
1949 } while (isDIGIT(*s));
25da4f38
IZ		 1950
1951 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1952 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1953 else
1954 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1955
097ee67d 1956 if (*s == '.'
1c846c1f 1957#ifdef USE_LOCALE_NUMERIC
097ee67d
JH		 1958 || IS_NUMERIC_RADIX(*s)
1959#endif
1960 ) {
ff0cee69 1961 s++;
25da4f38 1962 numtype |= IS_NUMBER_NOT_IV;
097ee67d 1963 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69 1964 s++;
1965 }
36477c24 1966 }
097ee67d 1967 else if (*s == '.'
1c846c1f 1968#ifdef USE_LOCALE_NUMERIC
097ee67d
JH		 1969 || IS_NUMERIC_RADIX(*s)
1970#endif
1971 ) {
ff0cee69 1972 s++;
25da4f38 1973 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
097ee67d 1974 /* no digits before the radix means we need digits after it */
ff0cee69 1975 if (isDIGIT(*s)) {
1976 do {
1977 s++;
1978 } while (isDIGIT(*s));
1979 }
1980 else
1981 return 0;
1982 }
300aed98
JH		 1983 else if (*s == 'I' || *s == 'i') {
1984 s++; if (*s != 'N' && *s != 'n') return 0;
1985 s++; if (*s != 'F' && *s != 'f') return 0;
1986 s++; if (*s == 'I' || *s == 'i') {
1987 s++; if (*s != 'N' && *s != 'n') return 0;
1988 s++; if (*s != 'I' && *s != 'i') return 0;
1989 s++; if (*s != 'T' && *s != 't') return 0;
1990 s++; if (*s != 'Y' && *s != 'y') return 0;
99938567 1991 s++;
300aed98
JH		 1992 }
1993 sawinf = 1;
1994 }
ff0cee69 1995 else
1996 return 0;
1997
300aed98
JH		 1998 if (sawinf)
1999 numtype = IS_NUMBER_INFINITY;
2000 else {
2001 /* we can have an optional exponent part */
2002 if (*s == 'e' || *s == 'E') {
2003 numtype &= ~IS_NUMBER_NEG;
2004 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
36477c24 2005 s++;
300aed98
JH		 2006 if (*s == '+' || *s == '-')
2007 s++;
2008 if (isDIGIT(*s)) {
2009 do {
2010 s++;
2011 } while (isDIGIT(*s));
2012 }
2013 else
2014 return 0;
2015 }
36477c24 2016 }
2017 while (isSPACE(*s))
2018 s++;
80f3f388 2019 if (s >= send)
36477c24 2020 return numtype;
2021 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 2022 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24 2023 return 0;
2024}
2025
79072805 2026char *
864dbfa3 2027Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD		 2028{
2029 STRLEN n_a;
2030 return sv_2pv(sv, &n_a);
2031}
2032
25da4f38 2033/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 2034static char *
25da4f38
IZ		 2035uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2036{
25da4f38
IZ		 2037 char *ptr = buf + TYPE_CHARS(UV);
2038 char *ebuf = ptr;
2039 int sign;
25da4f38
IZ		 2040
2041 if (is_uv)
2042 sign = 0;
2043 else if (iv >= 0) {
2044 uv = iv;
2045 sign = 0;
2046 } else {
2047 uv = -iv;
2048 sign = 1;
2049 }
2050 do {
2051 *--ptr = '0' + (uv % 10);
2052 } while (uv /= 10);
2053 if (sign)
2054 *--ptr = '-';
2055 *peob = ebuf;
2056 return ptr;
2057}
2058
1fa8b10d 2059char *
864dbfa3 2060Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805
LW		 2061{
2062 register char *s;
2063 int olderrno;
46fc3d4c 2064 SV *tsv;
25da4f38
IZ		 2065 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2066 char *tmpbuf = tbuf;
79072805 2067
463ee0b2
LW		 2068 if (!sv) {
2069 *lp = 0;
2070 return "";
2071 }
8990e307 2072 if (SvGMAGICAL(sv)) {
463ee0b2
LW		 2073 mg_get(sv);
2074 if (SvPOKp(sv)) {
2075 *lp = SvCUR(sv);
2076 return SvPVX(sv);
2077 }
cf2093f6 2078 if (SvIOKp(sv)) {
1c846c1f 2079 if (SvIsUV(sv))
57def98f 2080 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2081 else
57def98f 2082 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2083 tsv = Nullsv;
a0d0e21e 2084 goto tokensave;
463ee0b2
LW		 2085 }
2086 if (SvNOKp(sv)) {
2d4389e4 2087 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2088 tsv = Nullsv;
a0d0e21e 2089 goto tokensave;
463ee0b2 2090 }
16d20bd9 2091 if (!SvROK(sv)) {
d008e5eb 2092 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2093 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2094 report_uninit();
c6ee37c5 2095 }
16d20bd9
AD		 2096 *lp = 0;
2097 return "";
2098 }
463ee0b2 2099 }
ed6116ce
LW		 2100 if (SvTHINKFIRST(sv)) {
2101 if (SvROK(sv)) {
a0d0e21e 2102 SV* tmpstr;
1554e226
DC		 2103 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2104 (SvRV(tmpstr) != SvRV(sv)))
9e7bc3e8 2105 return SvPV(tmpstr,*lp);
ed6116ce
LW		 2106 sv = (SV*)SvRV(sv);
2107 if (!sv)
2108 s = "NULLREF";
2109 else {
f9277f47
IZ		 2110 MAGIC *mg;
2111
ed6116ce 2112 switch (SvTYPE(sv)) {
f9277f47
IZ		 2113 case SVt_PVMG:
2114 if ( ((SvFLAGS(sv) &
1c846c1f 2115 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2116 == (SVs_OBJECT|SVs_RMG))
57668c4d 2117 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
f9277f47 2118 && (mg = mg_find(sv, 'r'))) {
2cd61cdb 2119 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2120
2cd61cdb 2121 if (!mg->mg_ptr) {
8782bef2
GB		 2122 char *fptr = "msix";
2123 char reflags[6];
2124 char ch;
2125 int left = 0;
2126 int right = 4;
2127 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2128
155aba94 2129 while((ch = *fptr++)) {
8782bef2
GB		 2130 if(reganch & 1) {
2131 reflags[left++] = ch;
2132 }
2133 else {
2134 reflags[right--] = ch;
2135 }
2136 reganch >>= 1;
2137 }
2138 if(left != 4) {
2139 reflags[left] = '-';
2140 left = 5;
2141 }
2142
2143 mg->mg_len = re->prelen + 4 + left;
2144 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2145 Copy("(?", mg->mg_ptr, 2, char);
2146 Copy(reflags, mg->mg_ptr+2, left, char);
2147 Copy(":", mg->mg_ptr+left+2, 1, char);
2148 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ		 2149 mg->mg_ptr[mg->mg_len - 1] = ')';
2150 mg->mg_ptr[mg->mg_len] = 0;
2151 }
3280af22 2152 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ		 2153 *lp = mg->mg_len;
2154 return mg->mg_ptr;
f9277f47
IZ		 2155 }
2156 /* Fall through */
ed6116ce
LW		 2157 case SVt_NULL:
2158 case SVt_IV:
2159 case SVt_NV:
2160 case SVt_RV:
2161 case SVt_PV:
2162 case SVt_PVIV:
2163 case SVt_PVNV:
81689caa
HS		 2164 case SVt_PVBM: if (SvROK(sv))
2165 s = "REF";
2166 else
2167 s = "SCALAR"; break;
ed6116ce
LW		 2168 case SVt_PVLV: s = "LVALUE"; break;
2169 case SVt_PVAV: s = "ARRAY"; break;
2170 case SVt_PVHV: s = "HASH"; break;
2171 case SVt_PVCV: s = "CODE"; break;
2172 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2173 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2174 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW		 2175 default: s = "UNKNOWN"; break;
2176 }
46fc3d4c 2177 tsv = NEWSV(0,0);
ed6116ce 2178 if (SvOBJECT(sv))
cea2e8a9 2179 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2180 else
46fc3d4c 2181 sv_setpv(tsv, s);
57def98f 2182 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2183 goto tokensaveref;
463ee0b2 2184 }
ed6116ce
LW		 2185 *lp = strlen(s);
2186 return s;
79072805 2187 }
0336b60e 2188 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2189 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2190 report_uninit();
ed6116ce
LW		 2191 *lp = 0;
2192 return "";
79072805 2193 }
79072805 2194 }
25da4f38
IZ		 2195 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2196 /* XXXX 64-bit? IV may have better precision... */
8aad8eb3 2197 /* I tried changing this to be 64-bit-aware and
34d861e4
JH		 2198 * the t/op/numconvert.t became very, very, angry.
2199 * --jhi Sep 1999 */
79072805
LW		 2200 if (SvTYPE(sv) < SVt_PVNV)
2201 sv_upgrade(sv, SVt_PVNV);
1c846c1f 2202 /* The +20 is pure guesswork. Configure test needed. --jhi */
59155cc0 2203 SvGROW(sv, NV_DIG + 20);
463ee0b2 2204 s = SvPVX(sv);
79072805 2205 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2206#ifdef apollo
463ee0b2 2207 if (SvNVX(sv) == 0.0)
79072805
LW		 2208 (void)strcpy(s,"0");
2209 else
2210#endif /*apollo*/
bbce6d69 2211 {
2d4389e4 2212 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2213 }
79072805 2214 errno = olderrno;
a0d0e21e
LW		 2215#ifdef FIXNEGATIVEZERO
2216 if (*s == '-' && s[1] == '0' && !s[2])
2217 strcpy(s,"0");
2218#endif
79072805
LW		 2219 while (*s) s++;
2220#ifdef hcx
2221 if (s[-1] == '.')
46fc3d4c 2222 *--s = '\0';
79072805
LW		 2223#endif
2224 }
748a9306 2225 else if (SvIOKp(sv)) {
25da4f38 2226 U32 isIOK = SvIOK(sv);
0336b60e 2227 U32 isUIOK = SvIsUV(sv);
25da4f38
IZ		 2228 char buf[TYPE_CHARS(UV)];
2229 char *ebuf, *ptr;
2230
79072805
LW		 2231 if (SvTYPE(sv) < SVt_PVIV)
2232 sv_upgrade(sv, SVt_PVIV);
0336b60e 2233 if (isUIOK)
25da4f38 2234 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
0336b60e 2235 else
25da4f38 2236 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
0336b60e
IZ		 2237 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2238 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2239 SvCUR_set(sv, ebuf - ptr);
46fc3d4c 2240 s = SvEND(sv);
0336b60e 2241 *s = '\0';
25da4f38 2242 if (isIOK)
64f14228
GA		 2243 SvIOK_on(sv);
2244 else
2245 SvIOKp_on(sv);
0336b60e
IZ		 2246 if (isUIOK)
2247 SvIsUV_on(sv);
2248 SvPOK_on(sv);
79072805
LW		 2249 }
2250 else {
0336b60e
IZ		 2251 if (ckWARN(WARN_UNINITIALIZED)
2252 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2253 report_uninit();
a0d0e21e 2254 *lp = 0;
25da4f38
IZ		 2255 if (SvTYPE(sv) < SVt_PV)
2256 /* Typically the caller expects that sv_any is not NULL now. */
2257 sv_upgrade(sv, SVt_PV);
a0d0e21e 2258 return "";
79072805 2259 }
463ee0b2
LW		 2260 *lp = s - SvPVX(sv);
2261 SvCUR_set(sv, *lp);
79072805 2262 SvPOK_on(sv);
1d7c1841
GS		 2263 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2264 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2265 return SvPVX(sv);
a0d0e21e
LW		 2266
2267 tokensave:
2268 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2269 /* Sneaky stuff here */
2270
2271 tokensaveref:
46fc3d4c 2272 if (!tsv)
96827780 2273 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 2274 sv_2mortal(tsv);
2275 *lp = SvCUR(tsv);
2276 return SvPVX(tsv);
a0d0e21e
LW		 2277 }
2278 else {
2279 STRLEN len;
46fc3d4c 2280 char *t;
2281
2282 if (tsv) {
2283 sv_2mortal(tsv);
2284 t = SvPVX(tsv);
2285 len = SvCUR(tsv);
2286 }
2287 else {
96827780
MB		 2288 t = tmpbuf;
2289 len = strlen(tmpbuf);
46fc3d4c 2290 }
a0d0e21e 2291#ifdef FIXNEGATIVEZERO
46fc3d4c 2292 if (len == 2 && t[0] == '-' && t[1] == '0') {
2293 t = "0";
2294 len = 1;
2295 }
a0d0e21e
LW		 2296#endif
2297 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2298 *lp = len;
a0d0e21e
LW		 2299 s = SvGROW(sv, len + 1);
2300 SvCUR_set(sv, len);
46fc3d4c 2301 (void)strcpy(s, t);
6bf554b4 2302 SvPOKp_on(sv);
a0d0e21e
LW		 2303 return s;
2304 }
463ee0b2
LW		 2305}
2306
7340a771
GS		 2307char *
2308Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2309{
560a288e
GS		 2310 STRLEN n_a;
2311 return sv_2pvbyte(sv, &n_a);
7340a771
GS		 2312}
2313
2314char *
2315Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2316{
2317 return sv_2pv(sv,lp);
2318}
2319
2320char *
2321Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2322{
560a288e
GS		 2323 STRLEN n_a;
2324 return sv_2pvutf8(sv, &n_a);
7340a771
GS		 2325}
2326
2327char *
2328Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2329{
560a288e 2330 sv_utf8_upgrade(sv);
7340a771
GS		 2331 return sv_2pv(sv,lp);
2332}
1c846c1f 2333
463ee0b2
LW		 2334/* This function is only called on magical items */
2335bool
864dbfa3 2336Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2337{
8990e307 2338 if (SvGMAGICAL(sv))
463ee0b2
LW		 2339 mg_get(sv);
2340
a0d0e21e
LW		 2341 if (!SvOK(sv))
2342 return 0;
2343 if (SvROK(sv)) {
a0d0e21e 2344 SV* tmpsv;
1554e226
DC		 2345 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2346 (SvRV(tmpsv) != SvRV(sv)))
9e7bc3e8 2347 return SvTRUE(tmpsv);
a0d0e21e
LW		 2348 return SvRV(sv) != 0;
2349 }
463ee0b2 2350 if (SvPOKp(sv)) {
11343788
MB		 2351 register XPV* Xpvtmp;
2352 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2353 (*Xpvtmp->xpv_pv > '0' ||
2354 Xpvtmp->xpv_cur > 1 ||
2355 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW		 2356 return 1;
2357 else
2358 return 0;
2359 }
2360 else {
2361 if (SvIOKp(sv))
2362 return SvIVX(sv) != 0;
2363 else {
2364 if (SvNOKp(sv))
2365 return SvNVX(sv) != 0.0;
2366 else
2367 return FALSE;
2368 }
2369 }
79072805
LW		 2370}
2371
c461cf8f
JH		 2372/*
2373=for apidoc sv_utf8_upgrade
2374
2375Convert the PV of an SV to its UTF8-encoded form.
2376
2377=cut
2378*/
2379
560a288e
GS		 2380void
2381Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2382{
40826f67
JH		 2383 char *s, *t;
2384 bool hibit;
560a288e
GS		 2385
2386 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2387 return;
2388
40826f67
JH		 2389 /* This function could be much more efficient if we had a FLAG in SVs
2390 * to signal if there are any hibit chars in the PV.
560a288e 2391 */
40826f67
JH		 2392 for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
2393 if (*t & 0x80)
2394 hibit = TRUE;
560a288e 2395
40826f67 2396 if (hibit) {
67e989fb 2397 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
00df9076 2398 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
841d7a39
JH		 2399 SvCUR(sv) = len - 1;
2400 SvLEN(sv) = len; /* No longer know the real size. */
560a288e 2401 SvUTF8_on(sv);
d2f449dd 2402 Safefree(s); /* No longer using what was there before. */
560a288e
GS		 2403 }
2404}
2405
c461cf8f
JH		 2406/*
2407=for apidoc sv_utf8_downgrade
2408
2409Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2410This may not be possible if the PV contains non-byte encoding characters;
2411if this is the case, either returns false or, if C<fail_ok> is not
2412true, croaks.
2413
2414=cut
2415*/
2416
560a288e
GS		 2417bool
2418Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2419{
2420 if (SvPOK(sv) && SvUTF8(sv)) {
fa301091
JH		 2421 if (SvCUR(sv)) {
2422 char *c = SvPVX(sv);
2423 STRLEN len = SvCUR(sv);
2424
2425 if (!utf8_to_bytes((U8*)c, &len)) {
2426 if (fail_ok)
2427 return FALSE;
2428 else {
2429 if (PL_op)
2430 Perl_croak(aTHX_ "Wide character in %s",
2431 PL_op_desc[PL_op->op_type]);
2432 else
2433 Perl_croak(aTHX_ "Wide character");
2434 }
4b3603a4 2435 }
fa301091 2436 SvCUR(sv) = len;
67e989fb 2437 }
9f9ab905 2438 SvUTF8_off(sv);
560a288e 2439 }
fa301091 2440
560a288e
GS		 2441 return TRUE;
2442}
2443
c461cf8f
JH		 2444/*
2445=for apidoc sv_utf8_encode
2446
2447Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
1c846c1f 2448flag so that it looks like bytes again. Nothing calls this.
c461cf8f
JH		 2449
2450=cut
2451*/
2452
560a288e
GS		 2453void
2454Perl_sv_utf8_encode(pTHX_ register SV *sv)
2455{
2456 sv_utf8_upgrade(sv);
2457 SvUTF8_off(sv);
2458}
2459
2460bool
2461Perl_sv_utf8_decode(pTHX_ register SV *sv)
2462{
2463 if (SvPOK(sv)) {
2464 char *c;
2465 bool has_utf = FALSE;
2466 if (!sv_utf8_downgrade(sv, TRUE))
2467 return FALSE;
2468
2469 /* it is actually just a matter of turning the utf8 flag on, but
2470 * we want to make sure everything inside is valid utf8 first.
2471 */
2472 c = SvPVX(sv);
00df9076 2473 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
67e989fb
JH		 2474 return FALSE;
2475
560a288e 2476 while (c < SvEND(sv)) {
67e989fb
JH		 2477 if (*c++ & 0x80) {
2478 SvUTF8_on(sv);
2479 break;
2480 }
560a288e 2481 }
560a288e
GS		 2482 }
2483 return TRUE;
2484}
2485
2486
79072805 2487/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 2488 * to be reused, since it may destroy the source string if it is marked
79072805
LW		 2489 * as temporary.
2490 */
2491
954c1994
GS		 2492/*
2493=for apidoc sv_setsv
2494
2495Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2496The source SV may be destroyed if it is mortal. Does not handle 'set'
2497magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2498C<sv_setsv_mg>.
2499
2500=cut
2501*/
2502
79072805 2503void
864dbfa3 2504Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 2505{
8990e307
LW		 2506 register U32 sflags;
2507 register int dtype;
2508 register int stype;
463ee0b2 2509
79072805
LW		 2510 if (sstr == dstr)
2511 return;
2213622d 2512 SV_CHECK_THINKFIRST(dstr);
79072805 2513 if (!sstr)
3280af22 2514 sstr = &PL_sv_undef;
8990e307
LW		 2515 stype = SvTYPE(sstr);
2516 dtype = SvTYPE(dstr);
79072805 2517
a0d0e21e 2518 SvAMAGIC_off(dstr);
9e7bc3e8 2519
463ee0b2 2520 /* There's a lot of redundancy below but we're going for speed here */
79072805 2521
8990e307 2522 switch (stype) {
79072805 2523 case SVt_NULL:
aece5585 2524 undef_sstr:
20408e3c
GS		 2525 if (dtype != SVt_PVGV) {
2526 (void)SvOK_off(dstr);
2527 return;
2528 }
2529 break;
463ee0b2 2530 case SVt_IV:
aece5585
GA		 2531 if (SvIOK(sstr)) {
2532 switch (dtype) {
2533 case SVt_NULL:
8990e307 2534 sv_upgrade(dstr, SVt_IV);
aece5585
GA		 2535 break;
2536 case SVt_NV:
8990e307 2537 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 2538 break;
2539 case SVt_RV:
2540 case SVt_PV:
a0d0e21e 2541 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA		 2542 break;
2543 }
2544 (void)SvIOK_only(dstr);
2545 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 2546 if (SvIsUV(sstr))
2547 SvIsUV_on(dstr);
27c9684d
AP		 2548 if (SvTAINTED(sstr))
2549 SvTAINT(dstr);
aece5585 2550 return;
8990e307 2551 }
aece5585
GA		 2552 goto undef_sstr;
2553
463ee0b2 2554 case SVt_NV:
aece5585
GA		 2555 if (SvNOK(sstr)) {
2556 switch (dtype) {
2557 case SVt_NULL:
2558 case SVt_IV:
8990e307 2559 sv_upgrade(dstr, SVt_NV);
aece5585
GA		 2560 break;
2561 case SVt_RV:
2562 case SVt_PV:
2563 case SVt_PVIV:
a0d0e21e 2564 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 2565 break;
2566 }
2567 SvNVX(dstr) = SvNVX(sstr);
2568 (void)SvNOK_only(dstr);
27c9684d
AP		 2569 if (SvTAINTED(sstr))
2570 SvTAINT(dstr);
aece5585 2571 return;
8990e307 2572 }
aece5585
GA		 2573 goto undef_sstr;
2574
ed6116ce 2575 case SVt_RV:
8990e307 2576 if (dtype < SVt_RV)
ed6116ce 2577 sv_upgrade(dstr, SVt_RV);
c07a80fd 2578 else if (dtype == SVt_PVGV &&
2579 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2580 sstr = SvRV(sstr);
a5f75d66 2581 if (sstr == dstr) {
1d7c1841
GS		 2582 if (GvIMPORTED(dstr) != GVf_IMPORTED
2583 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2584 {
a5f75d66 2585 GvIMPORTED_on(dstr);
1d7c1841 2586 }
a5f75d66
AD		 2587 GvMULTI_on(dstr);
2588 return;
2589 }
c07a80fd 2590 goto glob_assign;
2591 }
ed6116ce 2592 break;
463ee0b2 2593 case SVt_PV:
fc36a67e 2594 case SVt_PVFM:
8990e307 2595 if (dtype < SVt_PV)
463ee0b2 2596 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW		 2597 break;
2598 case SVt_PVIV:
8990e307 2599 if (dtype < SVt_PVIV)
463ee0b2 2600 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW		 2601 break;
2602 case SVt_PVNV:
8990e307 2603 if (dtype < SVt_PVNV)
463ee0b2 2604 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 2605 break;
4633a7c4
LW		 2606 case SVt_PVAV:
2607 case SVt_PVHV:
2608 case SVt_PVCV:
4633a7c4 2609 case SVt_PVIO:
533c011a 2610 if (PL_op)
cea2e8a9 2611 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 2612 PL_op_name[PL_op->op_type]);
4633a7c4 2613 else
cea2e8a9 2614 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW		 2615 break;
2616
79072805 2617 case SVt_PVGV:
8990e307 2618 if (dtype <= SVt_PVGV) {
c07a80fd 2619 glob_assign:
a5f75d66 2620 if (dtype != SVt_PVGV) {
a0d0e21e
LW		 2621 char *name = GvNAME(sstr);
2622 STRLEN len = GvNAMELEN(sstr);
463ee0b2 2623 sv_upgrade(dstr, SVt_PVGV);
6662521e 2624 sv_magic(dstr, dstr, '*', Nullch, 0);
85aff577 2625 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW		 2626 GvNAME(dstr) = savepvn(name, len);
2627 GvNAMELEN(dstr) = len;
2628 SvFAKE_on(dstr); /* can coerce to non-glob */
2629 }
7bac28a0 2630 /* ahem, death to those who redefine active sort subs */
3280af22
NIS		 2631 else if (PL_curstackinfo->si_type == PERLSI_SORT
2632 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 2633 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 2634 GvNAME(dstr));
a0d0e21e 2635 (void)SvOK_off(dstr);
a5f75d66 2636 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 2637 gp_free((GV*)dstr);
79072805 2638 GvGP(dstr) = gp_ref(GvGP(sstr));
27c9684d
AP		 2639 if (SvTAINTED(sstr))
2640 SvTAINT(dstr);
1d7c1841
GS		 2641 if (GvIMPORTED(dstr) != GVf_IMPORTED
2642 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2643 {
a5f75d66 2644 GvIMPORTED_on(dstr);
1d7c1841 2645 }
a5f75d66 2646 GvMULTI_on(dstr);
79072805
LW		 2647 return;
2648 }
2649 /* FALL THROUGH */
2650
2651 default:
973f89ab
CS		 2652 if (SvGMAGICAL(sstr)) {
2653 mg_get(sstr);
2654 if (SvTYPE(sstr) != stype) {
2655 stype = SvTYPE(sstr);
2656 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2657 goto glob_assign;
2658 }
2659 }
ded42b9f 2660 if (stype == SVt_PVLV)
6fc92669 2661 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 2662 else
6fc92669 2663 (void)SvUPGRADE(dstr, stype);
79072805
LW		 2664 }
2665
8990e307
LW		 2666 sflags = SvFLAGS(sstr);
2667
2668 if (sflags & SVf_ROK) {
2669 if (dtype >= SVt_PV) {
2670 if (dtype == SVt_PVGV) {
2671 SV *sref = SvREFCNT_inc(SvRV(sstr));
2672 SV *dref = 0;
a5f75d66 2673 int intro = GvINTRO(dstr);
a0d0e21e
LW		 2674
2675 if (intro) {
2676 GP *gp;
1d7c1841 2677 gp_free((GV*)dstr);
a5f75d66 2678 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 2679 Newz(602,gp, 1, GP);
44a8e56a 2680 GvGP(dstr) = gp_ref(gp);
a0d0e21e 2681 GvSV(dstr) = NEWSV(72,0);
1d7c1841 2682 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 2683 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 2684 }
a5f75d66 2685 GvMULTI_on(dstr);
8990e307
LW		 2686 switch (SvTYPE(sref)) {
2687 case SVt_PVAV:
a0d0e21e
LW		 2688 if (intro)
2689 SAVESPTR(GvAV(dstr));
2690 else
2691 dref = (SV*)GvAV(dstr);
8990e307 2692 GvAV(dstr) = (AV*)sref;
39bac7f7 2693 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS		 2694 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2695 {
a5f75d66 2696 GvIMPORTED_AV_on(dstr);
1d7c1841 2697 }
8990e307
LW		 2698 break;
2699 case SVt_PVHV:
a0d0e21e
LW		 2700 if (intro)
2701 SAVESPTR(GvHV(dstr));
2702 else
2703 dref = (SV*)GvHV(dstr);
8990e307 2704 GvHV(dstr) = (HV*)sref;
39bac7f7 2705 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS		 2706 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2707 {
a5f75d66 2708 GvIMPORTED_HV_on(dstr);
1d7c1841 2709 }
8990e307
LW		 2710 break;
2711 case SVt_PVCV:
8ebc5c01 2712 if (intro) {
2713 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2714 SvREFCNT_dec(GvCV(dstr));
2715 GvCV(dstr) = Nullcv;
68dc0745 2716 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 2717 PL_sub_generation++;
8ebc5c01 2718 }
a0d0e21e 2719 SAVESPTR(GvCV(dstr));
8ebc5c01 2720 }
68dc0745 2721 else
2722 dref = (SV*)GvCV(dstr);
2723 if (GvCV(dstr) != (CV*)sref) {
748a9306 2724 CV* cv = GvCV(dstr);
4633a7c4 2725 if (cv) {
68dc0745 2726 if (!GvCVGEN((GV*)dstr) &&
2727 (CvROOT(cv) || CvXSUB(cv)))
2728 {
beab0874 2729 SV *const_sv;
7bac28a0 2730 /* ahem, death to those who redefine
2731 * active sort subs */
3280af22
NIS		 2732 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2733 PL_sortcop == CvSTART(cv))
1c846c1f 2734 Perl_croak(aTHX_
7bac28a0 2735 "Can't redefine active sort subroutine %s",
2736 GvENAME((GV*)dstr));
beab0874
JT		 2737 /* Redefining a sub - warning is mandatory if
2738 it was a const and its value changed. */
2739 if (ckWARN(WARN_REDEFINE)
2740 || (CvCONST(cv)
2741 && (!CvCONST((CV*)sref)
2742 || sv_cmp(cv_const_sv(cv),
2743 cv_const_sv((CV*)sref)))))
2744 {
2745 Perl_warner(aTHX_ WARN_REDEFINE,
2746 CvCONST(cv)
2747 ? "Constant subroutine %s redefined"
47deb5e7 2748 : "Subroutine %s redefined",
beab0874
JT		 2749 GvENAME((GV*)dstr));
2750 }
9607fc9c 2751 }
3fe9a6f1 2752 cv_ckproto(cv, (GV*)dstr,
2753 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 2754 }
a5f75d66 2755 GvCV(dstr) = (CV*)sref;
7a4c00b4 2756 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 2757 GvASSUMECV_on(dstr);
3280af22 2758 PL_sub_generation++;
a5f75d66 2759 }
39bac7f7 2760 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS		 2761 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2762 {
a5f75d66 2763 GvIMPORTED_CV_on(dstr);
1d7c1841 2764 }
8990e307 2765 break;
91bba347
LW		 2766 case SVt_PVIO:
2767 if (intro)
2768 SAVESPTR(GvIOp(dstr));
2769 else
2770 dref = (SV*)GvIOp(dstr);
2771 GvIOp(dstr) = (IO*)sref;
2772 break;
f4d13ee9
JH		 2773 case SVt_PVFM:
2774 if (intro)
2775 SAVESPTR(GvFORM(dstr));
2776 else
2777 dref = (SV*)GvFORM(dstr);
2778 GvFORM(dstr) = (CV*)sref;
2779 break;
8990e307 2780 default:
a0d0e21e
LW		 2781 if (intro)
2782 SAVESPTR(GvSV(dstr));
2783 else
2784 dref = (SV*)GvSV(dstr);
8990e307 2785 GvSV(dstr) = sref;
39bac7f7 2786 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS		 2787 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2788 {
a5f75d66 2789 GvIMPORTED_SV_on(dstr);
1d7c1841 2790 }
8990e307
LW		 2791 break;
2792 }
2793 if (dref)
2794 SvREFCNT_dec(dref);
a0d0e21e
LW		 2795 if (intro)
2796 SAVEFREESV(sref);
27c9684d
AP		 2797 if (SvTAINTED(sstr))
2798 SvTAINT(dstr);
8990e307
LW		 2799 return;
2800 }
a0d0e21e 2801 if (SvPVX(dstr)) {
760ac839 2802 (void)SvOOK_off(dstr); /* backoff */
50483b2c
JD		 2803 if (SvLEN(dstr))
2804 Safefree(SvPVX(dstr));
a0d0e21e
LW		 2805 SvLEN(dstr)=SvCUR(dstr)=0;
2806 }
8990e307 2807 }
a0d0e21e 2808 (void)SvOK_off(dstr);
8990e307 2809 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 2810 SvROK_on(dstr);
8990e307 2811 if (sflags & SVp_NOK) {
ed6116ce
LW		 2812 SvNOK_on(dstr);
2813 SvNVX(dstr) = SvNVX(sstr);
2814 }
8990e307 2815 if (sflags & SVp_IOK) {
a0d0e21e 2816 (void)SvIOK_on(dstr);
ed6116ce 2817 SvIVX(dstr) = SvIVX(sstr);
2b1c7e3e 2818 if (sflags & SVf_IVisUV)
25da4f38 2819 SvIsUV_on(dstr);
ed6116ce 2820 }
a0d0e21e
LW		 2821 if (SvAMAGIC(sstr)) {
2822 SvAMAGIC_on(dstr);
2823 }
ed6116ce 2824 }
8990e307 2825 else if (sflags & SVp_POK) {
79072805
LW		 2826
2827 /*
2828 * Check to see if we can just swipe the string. If so, it's a
2829 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW		 2830 * It might even be a win on short strings if SvPVX(dstr)
2831 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW		 2832 */
2833
ff68c719 2834 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 2835 SvREFCNT(sstr) == 1 && /* and no other references to it? */
1c846c1f 2836 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4c8f17b9
BH		 2837 SvLEN(sstr) && /* and really is a string */
2838 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
a5f75d66 2839 {
adbc6bb1 2840 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD		 2841 if (SvOOK(dstr)) {
2842 SvFLAGS(dstr) &= ~SVf_OOK;
2843 Safefree(SvPVX(dstr) - SvIVX(dstr));
2844 }
50483b2c 2845 else if (SvLEN(dstr))
a5f75d66 2846 Safefree(SvPVX(dstr));
79072805 2847 }
a5f75d66 2848 (void)SvPOK_only(dstr);
463ee0b2 2849 SvPV_set(dstr, SvPVX(sstr));
79072805
LW		 2850 SvLEN_set(dstr, SvLEN(sstr));
2851 SvCUR_set(dstr, SvCUR(sstr));
f4e86e0f 2852
79072805 2853 SvTEMP_off(dstr);
2b1c7e3e 2854 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
79072805
LW		 2855 SvPV_set(sstr, Nullch);
2856 SvLEN_set(sstr, 0);
a5f75d66
AD		 2857 SvCUR_set(sstr, 0);
2858 SvTEMP_off(sstr);
79072805
LW		 2859 }
2860 else { /* have to copy actual string */
8990e307
LW		 2861 STRLEN len = SvCUR(sstr);
2862
2863 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2864 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2865 SvCUR_set(dstr, len);
2866 *SvEND(dstr) = '\0';
a0d0e21e 2867 (void)SvPOK_only(dstr);
79072805 2868 }
3aa33fe5 2869 if ((sflags & SVf_UTF8) && !IN_BYTE)
a7cb1f99 2870 SvUTF8_on(dstr);
79072805 2871 /*SUPPRESS 560*/
8990e307 2872 if (sflags & SVp_NOK) {
79072805 2873 SvNOK_on(dstr);
463ee0b2 2874 SvNVX(dstr) = SvNVX(sstr);
79072805 2875 }
8990e307 2876 if (sflags & SVp_IOK) {
a0d0e21e 2877 (void)SvIOK_on(dstr);
463ee0b2 2878 SvIVX(dstr) = SvIVX(sstr);
2b1c7e3e 2879 if (sflags & SVf_IVisUV)
25da4f38 2880 SvIsUV_on(dstr);
79072805
LW		 2881 }
2882 }
8990e307 2883 else if (sflags & SVp_NOK) {
463ee0b2 2884 SvNVX(dstr) = SvNVX(sstr);
a0d0e21e 2885 (void)SvNOK_only(dstr);
2b1c7e3e 2886 if (sflags & SVf_IOK) {
a0d0e21e 2887 (void)SvIOK_on(dstr);
463ee0b2 2888 SvIVX(dstr) = SvIVX(sstr);
25da4f38 2889 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2b1c7e3e 2890 if (sflags & SVf_IVisUV)
25da4f38 2891 SvIsUV_on(dstr);
79072805
LW		 2892 }
2893 }
8990e307 2894 else if (sflags & SVp_IOK) {
a0d0e21e 2895 (void)SvIOK_only(dstr);
463ee0b2 2896 SvIVX(dstr) = SvIVX(sstr);
2b1c7e3e 2897 if (sflags & SVf_IVisUV)
25da4f38 2898 SvIsUV_on(dstr);
79072805
LW		 2899 }
2900 else {
20408e3c 2901 if (dtype == SVt_PVGV) {
e476b1b5
GS		 2902 if (ckWARN(WARN_MISC))
2903 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
20408e3c
GS		 2904 }
2905 else
2906 (void)SvOK_off(dstr);
a0d0e21e 2907 }
27c9684d
AP		 2908 if (SvTAINTED(sstr))
2909 SvTAINT(dstr);
79072805
LW		 2910}
2911
954c1994
GS		 2912/*
2913=for apidoc sv_setsv_mg
2914
2915Like C<sv_setsv>, but also handles 'set' magic.
2916
2917=cut
2918*/
2919
79072805 2920void
864dbfa3 2921Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 2922{
2923 sv_setsv(dstr,sstr);
2924 SvSETMAGIC(dstr);
2925}
2926
954c1994
GS		 2927/*
2928=for apidoc sv_setpvn
2929
2930Copies a string into an SV. The C<len> parameter indicates the number of
2931bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2932
2933=cut
2934*/
2935
ef50df4b 2936void
864dbfa3 2937Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 2938{
c6f8c383 2939 register char *dptr;
793db0cb
JH		 2940 {
2941 /* len is STRLEN which is unsigned, need to copy to signed */
2942 IV iv = len;
2943 assert(iv >= 0);
2944 }
2213622d 2945 SV_CHECK_THINKFIRST(sv);
463ee0b2 2946 if (!ptr) {
a0d0e21e 2947 (void)SvOK_off(sv);
463ee0b2
LW		 2948 return;
2949 }
6fc92669 2950 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 2951
79072805 2952 SvGROW(sv, len + 1);
c6f8c383
GA		 2953 dptr = SvPVX(sv);
2954 Move(ptr,dptr,len,char);
2955 dptr[len] = '\0';
79072805 2956 SvCUR_set(sv, len);
a0d0e21e 2957 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 2958 SvTAINT(sv);
79072805
LW		 2959}
2960
954c1994
GS		 2961/*
2962=for apidoc sv_setpvn_mg
2963
2964Like C<sv_setpvn>, but also handles 'set' magic.
2965
2966=cut
2967*/
2968
79072805 2969void
864dbfa3 2970Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 2971{
2972 sv_setpvn(sv,ptr,len);
2973 SvSETMAGIC(sv);
2974}
2975
954c1994
GS		 2976/*
2977=for apidoc sv_setpv
2978
2979Copies a string into an SV. The string must be null-terminated. Does not
2980handle 'set' magic. See C<sv_setpv_mg>.
2981
2982=cut
2983*/
2984
ef50df4b 2985void
864dbfa3 2986Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 2987{
2988 register STRLEN len;
2989
2213622d 2990 SV_CHECK_THINKFIRST(sv);
463ee0b2 2991 if (!ptr) {
a0d0e21e 2992 (void)SvOK_off(sv);
463ee0b2
LW		 2993 return;
2994 }
79072805 2995 len = strlen(ptr);
6fc92669 2996 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 2997
79072805 2998 SvGROW(sv, len + 1);
463ee0b2 2999 Move(ptr,SvPVX(sv),len+1,char);
79072805 3000 SvCUR_set(sv, len);
a0d0e21e 3001 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2
LW		 3002 SvTAINT(sv);
3003}
3004
954c1994
GS		 3005/*
3006=for apidoc sv_setpv_mg
3007
3008Like C<sv_setpv>, but also handles 'set' magic.
3009
3010=cut
3011*/
3012
463ee0b2 3013void
864dbfa3 3014Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS		 3015{
3016 sv_setpv(sv,ptr);
3017 SvSETMAGIC(sv);
3018}
3019
954c1994
GS		 3020/*
3021=for apidoc sv_usepvn
3022
3023Tells an SV to use C<ptr> to find its string value. Normally the string is
1c846c1f 3024stored inside the SV but sv_usepvn allows the SV to use an outside string.
954c1994
GS		 3025The C<ptr> should point to memory that was allocated by C<malloc>. The
3026string length, C<len>, must be supplied. This function will realloc the
3027memory pointed to by C<ptr>, so that pointer should not be freed or used by
3028the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3029See C<sv_usepvn_mg>.
3030
3031=cut
3032*/
3033
ef50df4b 3034void
864dbfa3 3035Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 3036{
2213622d 3037 SV_CHECK_THINKFIRST(sv);
c6f8c383 3038 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 3039 if (!ptr) {
a0d0e21e 3040 (void)SvOK_off(sv);
463ee0b2
LW		 3041 return;
3042 }
a0ed51b3 3043 (void)SvOOK_off(sv);
50483b2c 3044 if (SvPVX(sv) && SvLEN(sv))
463ee0b2
LW		 3045 Safefree(SvPVX(sv));
3046 Renew(ptr, len+1, char);
3047 SvPVX(sv) = ptr;
3048 SvCUR_set(sv, len);
3049 SvLEN_set(sv, len+1);
3050 *SvEND(sv) = '\0';
a0d0e21e 3051 (void)SvPOK_only(sv); /* validate pointer */
463ee0b2 3052 SvTAINT(sv);
79072805
LW		 3053}
3054
954c1994
GS		 3055/*
3056=for apidoc sv_usepvn_mg
3057
3058Like C<sv_usepvn>, but also handles 'set' magic.
3059
3060=cut
3061*/
3062
ef50df4b 3063void
864dbfa3 3064Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 3065{
51c1089b 3066 sv_usepvn(sv,ptr,len);
ef50df4b
GS		 3067 SvSETMAGIC(sv);
3068}
3069
6fc92669 3070void
840a7b70 3071Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
0f15f207 3072{
2213622d 3073 if (SvREADONLY(sv)) {
1c846c1f
NIS		 3074 if (SvFAKE(sv)) {
3075 char *pvx = SvPVX(sv);
3076 STRLEN len = SvCUR(sv);
3077 U32 hash = SvUVX(sv);
3078 SvGROW(sv, len + 1);
3079 Move(pvx,SvPVX(sv),len,char);
3080 *SvEND(sv) = '\0';
3081 SvFAKE_off(sv);
3082 SvREADONLY_off(sv);
3083 unsharepvn(pvx,len,hash);
3084 }
3085 else if (PL_curcop != &PL_compiling)
cea2e8a9 3086 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3087 }
2213622d 3088 if (SvROK(sv))
840a7b70 3089 sv_unref_flags(sv, flags);
6fc92669
GS		 3090 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3091 sv_unglob(sv);
0f15f207 3092}
1c846c1f 3093
840a7b70
IZ		 3094void
3095Perl_sv_force_normal(pTHX_ register SV *sv)
3096{
3097 sv_force_normal_flags(sv, 0);
3098}
3099
954c1994
GS		 3100/*
3101=for apidoc sv_chop
3102
1c846c1f 3103Efficient removal of characters from the beginning of the string buffer.
954c1994
GS		 3104SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3105the string buffer. The C<ptr> becomes the first character of the adjusted
3106string.
3107
3108=cut
3109*/
3110
79072805 3111void
864dbfa3 3112Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
1c846c1f
NIS		 3113
3114
79072805
LW		 3115{
3116 register STRLEN delta;
3117
a0d0e21e 3118 if (!ptr || !SvPOKp(sv))
79072805 3119 return;
2213622d 3120 SV_CHECK_THINKFIRST(sv);
79072805
LW		 3121 if (SvTYPE(sv) < SVt_PVIV)
3122 sv_upgrade(sv,SVt_PVIV);
3123
3124 if (!SvOOK(sv)) {
50483b2c
JD		 3125 if (!SvLEN(sv)) { /* make copy of shared string */
3126 char *pvx = SvPVX(sv);
3127 STRLEN len = SvCUR(sv);
3128 SvGROW(sv, len + 1);
3129 Move(pvx,SvPVX(sv),len,char);
3130 *SvEND(sv) = '\0';
3131 }
463ee0b2 3132 SvIVX(sv) = 0;
79072805
LW		 3133 SvFLAGS(sv) |= SVf_OOK;
3134 }
25da4f38 3135 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
463ee0b2 3136 delta = ptr - SvPVX(sv);
79072805
LW		 3137 SvLEN(sv) -= delta;
3138 SvCUR(sv) -= delta;
463ee0b2
LW		 3139 SvPVX(sv) += delta;
3140 SvIVX(sv) += delta;
79072805
LW		 3141}
3142
954c1994
GS		 3143/*
3144=for apidoc sv_catpvn
3145
3146Concatenates the string onto the end of the string which is in the SV. The
3147C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3148'set' magic. See C<sv_catpvn_mg>.
3149
3150=cut
3151*/
3152
79072805 3153void
864dbfa3 3154Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3155{
463ee0b2 3156 STRLEN tlen;
748a9306 3157 char *junk;
a0d0e21e 3158
748a9306 3159 junk = SvPV_force(sv, tlen);
463ee0b2 3160 SvGROW(sv, tlen + len + 1);
4633a7c4
LW		 3161 if (ptr == junk)
3162 ptr = SvPVX(sv);
463ee0b2 3163 Move(ptr,SvPVX(sv)+tlen,len,char);
79072805
LW		 3164 SvCUR(sv) += len;
3165 *SvEND(sv) = '\0';
d41ff1b8 3166 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3167 SvTAINT(sv);
79072805
LW		 3168}
3169
954c1994
GS		 3170/*
3171=for apidoc sv_catpvn_mg
3172
3173Like C<sv_catpvn>, but also handles 'set' magic.
3174
3175=cut
3176*/
3177
79072805 3178void
864dbfa3 3179Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3180{
3181 sv_catpvn(sv,ptr,len);
3182 SvSETMAGIC(sv);
3183}
3184
954c1994
GS		 3185/*
3186=for apidoc sv_catsv
3187
3188Concatenates the string from SV C<ssv> onto the end of the string in SV
3189C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3190
3191=cut
3192*/
3193
ef50df4b 3194void
864dbfa3 3195Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
79072805
LW		 3196{
3197 char *s;
463ee0b2 3198 STRLEN len;
79072805
LW		 3199 if (!sstr)
3200 return;
155aba94 3201 if ((s = SvPV(sstr, len))) {
e84ff256 3202 if (DO_UTF8(sstr)) {
560a288e 3203 sv_utf8_upgrade(dstr);
e84ff256 3204 sv_catpvn(dstr,s,len);
560a288e 3205 SvUTF8_on(dstr);
e84ff256
GS		 3206 }
3207 else
3208 sv_catpvn(dstr,s,len);
560a288e 3209 }
79072805
LW		 3210}
3211
954c1994
GS		 3212/*
3213=for apidoc sv_catsv_mg
3214
3215Like C<sv_catsv>, but also handles 'set' magic.
3216
3217=cut
3218*/
3219
79072805 3220void
864dbfa3 3221Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 3222{
3223 sv_catsv(dstr,sstr);
3224 SvSETMAGIC(dstr);
3225}
3226
954c1994
GS		 3227/*
3228=for apidoc sv_catpv
3229
3230Concatenates the string onto the end of the string which is in the SV.
3231Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3232
3233=cut
3234*/
3235
ef50df4b 3236void
864dbfa3 3237Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 3238{
3239 register STRLEN len;
463ee0b2 3240 STRLEN tlen;
748a9306 3241 char *junk;
79072805 3242
79072805
LW		 3243 if (!ptr)
3244 return;
748a9306 3245 junk = SvPV_force(sv, tlen);
79072805 3246 len = strlen(ptr);
463ee0b2 3247 SvGROW(sv, tlen + len + 1);
4633a7c4
LW		 3248 if (ptr == junk)
3249 ptr = SvPVX(sv);
463ee0b2 3250 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 3251 SvCUR(sv) += len;
d41ff1b8 3252 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3253 SvTAINT(sv);
79072805
LW		 3254}
3255
954c1994
GS		 3256/*
3257=for apidoc sv_catpv_mg
3258
3259Like C<sv_catpv>, but also handles 'set' magic.
3260
3261=cut
3262*/
3263
ef50df4b 3264void
864dbfa3 3265Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b 3266{
51c1089b 3267 sv_catpv(sv,ptr);
ef50df4b
GS		 3268 SvSETMAGIC(sv);
3269}
3270
79072805 3271SV *
864dbfa3 3272Perl_newSV(pTHX_ STRLEN len)
79072805
LW		 3273{
3274 register SV *sv;
1c846c1f 3275
4561caa4 3276 new_SV(sv);
79072805
LW		 3277 if (len) {
3278 sv_upgrade(sv, SVt_PV);
3279 SvGROW(sv, len + 1);
3280 }
3281 return sv;
3282}
3283
1edc1566 3284/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3285
954c1994
GS		 3286/*
3287=for apidoc sv_magic
3288
3289Adds magic to an SV.
3290
3291=cut
3292*/
3293
79072805 3294void
864dbfa3 3295Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
79072805
LW		 3296{
3297 MAGIC* mg;
1c846c1f 3298
0f15f207 3299 if (SvREADONLY(sv)) {
3280af22 3300 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
cea2e8a9 3301 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3302 }
4633a7c4 3303 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
748a9306
LW		 3304 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3305 if (how == 't')
565764a8 3306 mg->mg_len |= 1;
463ee0b2 3307 return;
748a9306 3308 }
463ee0b2
LW		 3309 }
3310 else {
c6f8c383 3311 (void)SvUPGRADE(sv, SVt_PVMG);
463ee0b2 3312 }
79072805
LW		 3313 Newz(702,mg, 1, MAGIC);
3314 mg->mg_moremagic = SvMAGIC(sv);
463ee0b2 3315
79072805 3316 SvMAGIC(sv) = mg;
c277df42 3317 if (!obj || obj == sv || how == '#' || how == 'r')
8990e307 3318 mg->mg_obj = obj;
85e6fe83 3319 else {
8990e307 3320 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW		 3321 mg->mg_flags |= MGf_REFCOUNTED;
3322 }
79072805 3323 mg->mg_type = how;
565764a8 3324 mg->mg_len = namlen;
1edc1566 3325 if (name)
3326 if (namlen >= 0)
3327 mg->mg_ptr = savepvn(name, namlen);
c6ee37c5 3328 else if (namlen == HEf_SVKEY)
1edc1566 3329 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
1c846c1f 3330
79072805
LW		 3331 switch (how) {
3332 case 0:
22c35a8c 3333 mg->mg_virtual = &PL_vtbl_sv;
79072805 3334 break;
a0d0e21e 3335 case 'A':
22c35a8c 3336 mg->mg_virtual = &PL_vtbl_amagic;
a0d0e21e
LW		 3337 break;
3338 case 'a':
22c35a8c 3339 mg->mg_virtual = &PL_vtbl_amagicelem;
a0d0e21e
LW		 3340 break;
3341 case 'c':
3342 mg->mg_virtual = 0;
3343 break;
79072805 3344 case 'B':
22c35a8c 3345 mg->mg_virtual = &PL_vtbl_bm;
79072805 3346 break;
6cef1e77 3347 case 'D':
22c35a8c 3348 mg->mg_virtual = &PL_vtbl_regdata;
6cef1e77
IZ		 3349 break;
3350 case 'd':
22c35a8c 3351 mg->mg_virtual = &PL_vtbl_regdatum;
6cef1e77 3352 break;
79072805 3353 case 'E':
22c35a8c 3354 mg->mg_virtual = &PL_vtbl_env;
79072805 3355 break;
55497cff 3356 case 'f':
22c35a8c 3357 mg->mg_virtual = &PL_vtbl_fm;
55497cff 3358 break;
79072805 3359 case 'e':
22c35a8c 3360 mg->mg_virtual = &PL_vtbl_envelem;
79072805 3361 break;
93a17b20 3362 case 'g':
22c35a8c 3363 mg->mg_virtual = &PL_vtbl_mglob;
93a17b20 3364 break;
463ee0b2 3365 case 'I':
22c35a8c 3366 mg->mg_virtual = &PL_vtbl_isa;
463ee0b2
LW		 3367 break;
3368 case 'i':
22c35a8c 3369 mg->mg_virtual = &PL_vtbl_isaelem;
463ee0b2 3370 break;
16660edb 3371 case 'k':
22c35a8c 3372 mg->mg_virtual = &PL_vtbl_nkeys;
16660edb 3373 break;
79072805 3374 case 'L':
a0d0e21e 3375 SvRMAGICAL_on(sv);
93a17b20
LW		 3376 mg->mg_virtual = 0;
3377 break;
3378 case 'l':
22c35a8c 3379 mg->mg_virtual = &PL_vtbl_dbline;
79072805 3380 break;
f93b4edd
MB		 3381#ifdef USE_THREADS
3382 case 'm':
22c35a8c 3383 mg->mg_virtual = &PL_vtbl_mutex;
f93b4edd
MB		 3384 break;
3385#endif /* USE_THREADS */
36477c24 3386#ifdef USE_LOCALE_COLLATE
bbce6d69 3387 case 'o':
22c35a8c 3388 mg->mg_virtual = &PL_vtbl_collxfrm;
bbce6d69 3389 break;
36477c24 3390#endif /* USE_LOCALE_COLLATE */
463ee0b2 3391 case 'P':
22c35a8c 3392 mg->mg_virtual = &PL_vtbl_pack;
463ee0b2
LW		 3393 break;
3394 case 'p':
a0d0e21e 3395 case 'q':
22c35a8c 3396 mg->mg_virtual = &PL_vtbl_packelem;
463ee0b2 3397 break;
c277df42 3398 case 'r':
22c35a8c 3399 mg->mg_virtual = &PL_vtbl_regexp;
c277df42 3400 break;
79072805 3401 case 'S':
22c35a8c 3402 mg->mg_virtual = &PL_vtbl_sig;
79072805
LW		 3403 break;
3404 case 's':
22c35a8c 3405 mg->mg_virtual = &PL_vtbl_sigelem;
79072805 3406 break;
463ee0b2 3407 case 't':
22c35a8c 3408 mg->mg_virtual = &PL_vtbl_taint;
565764a8 3409 mg->mg_len = 1;
463ee0b2 3410 break;
79072805 3411 case 'U':
22c35a8c 3412 mg->mg_virtual = &PL_vtbl_uvar;
79072805
LW		 3413 break;
3414 case 'v':
22c35a8c 3415 mg->mg_virtual = &PL_vtbl_vec;
79072805
LW		 3416 break;
3417 case 'x':
22c35a8c 3418 mg->mg_virtual = &PL_vtbl_substr;
79072805 3419 break;
5f05dabc 3420 case 'y':
22c35a8c 3421 mg->mg_virtual = &PL_vtbl_defelem;
5f05dabc 3422 break;
79072805 3423 case '*':
22c35a8c 3424 mg->mg_virtual = &PL_vtbl_glob;
79072805
LW		 3425 break;
3426 case '#':
22c35a8c 3427 mg->mg_virtual = &PL_vtbl_arylen;
79072805 3428 break;
a0d0e21e 3429 case '.':
22c35a8c 3430 mg->mg_virtual = &PL_vtbl_pos;
a0d0e21e 3431 break;
810b8aa5
GS		 3432 case '<':
3433 mg->mg_virtual = &PL_vtbl_backref;
3434 break;
4633a7c4
LW		 3435 case '~': /* Reserved for use by extensions not perl internals. */
3436 /* Useful for attaching extension internal data to perl vars. */
3437 /* Note that multiple extensions may clash if magical scalars */
3438 /* etc holding private data from one are passed to another. */
3439 SvRMAGICAL_on(sv);
a0d0e21e 3440 break;
79072805 3441 default:
cea2e8a9 3442 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
463ee0b2 3443 }
8990e307
LW		 3444 mg_magical(sv);
3445 if (SvGMAGICAL(sv))
3446 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW		 3447}
3448
c461cf8f
JH		 3449/*
3450=for apidoc sv_unmagic
3451
3452Removes magic from an SV.
3453
3454=cut
3455*/
3456
463ee0b2 3457int
864dbfa3 3458Perl_sv_unmagic(pTHX_ SV *sv, int type)
463ee0b2
LW		 3459{
3460 MAGIC* mg;
3461 MAGIC** mgp;
91bba347 3462 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW		 3463 return 0;
3464 mgp = &SvMAGIC(sv);
3465 for (mg = *mgp; mg; mg = *mgp) {
3466 if (mg->mg_type == type) {
3467 MGVTBL* vtbl = mg->mg_virtual;
3468 *mgp = mg->mg_moremagic;
1d7c1841 3469 if (vtbl && vtbl->svt_free)
fc0dc3b3 3470 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
463ee0b2 3471 if (mg->mg_ptr && mg->mg_type != 'g')
565764a8 3472 if (mg->mg_len >= 0)
1edc1566 3473 Safefree(mg->mg_ptr);
565764a8 3474 else if (mg->mg_len == HEf_SVKEY)
1edc1566 3475 SvREFCNT_dec((SV*)mg->mg_ptr);
a0d0e21e
LW		 3476 if (mg->mg_flags & MGf_REFCOUNTED)
3477 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW		 3478 Safefree(mg);
3479 }
3480 else
3481 mgp = &mg->mg_moremagic;
79072805 3482 }
91bba347 3483 if (!SvMAGIC(sv)) {
463ee0b2 3484 SvMAGICAL_off(sv);
8990e307 3485 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW		 3486 }
3487
3488 return 0;
79072805
LW		 3489}
3490
c461cf8f
JH		 3491/*
3492=for apidoc sv_rvweaken
3493
3494Weaken a reference.
3495
3496=cut
3497*/
3498
810b8aa5 3499SV *
864dbfa3 3500Perl_sv_rvweaken(pTHX_ SV *sv)
810b8aa5
GS		 3501{
3502 SV *tsv;
3503 if (!SvOK(sv)) /* let undefs pass */
3504 return sv;
3505 if (!SvROK(sv))
cea2e8a9 3506 Perl_croak(aTHX_ "Can't weaken a nonreference");
810b8aa5 3507 else if (SvWEAKREF(sv)) {
810b8aa5 3508 if (ckWARN(WARN_MISC))
cea2e8a9 3509 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
810b8aa5
GS		 3510 return sv;
3511 }
3512 tsv = SvRV(sv);
3513 sv_add_backref(tsv, sv);
3514 SvWEAKREF_on(sv);
1c846c1f 3515 SvREFCNT_dec(tsv);
810b8aa5
GS		 3516 return sv;
3517}
3518
3519STATIC void
cea2e8a9 3520S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
810b8aa5
GS		 3521{
3522 AV *av;
3523 MAGIC *mg;
3524 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3525 av = (AV*)mg->mg_obj;
3526 else {
3527 av = newAV();
3528 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3529 SvREFCNT_dec(av); /* for sv_magic */
3530 }
3531 av_push(av,sv);
3532}
3533
1c846c1f 3534STATIC void
cea2e8a9 3535S_sv_del_backref(pTHX_ SV *sv)
810b8aa5
GS		 3536{
3537 AV *av;
3538 SV **svp;
3539 I32 i;
3540 SV *tsv = SvRV(sv);
3541 MAGIC *mg;
3542 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
cea2e8a9 3543 Perl_croak(aTHX_ "panic: del_backref");
810b8aa5
GS		 3544 av = (AV *)mg->mg_obj;
3545 svp = AvARRAY(av);
3546 i = AvFILLp(av);
3547 while (i >= 0) {
3548 if (svp[i] == sv) {
3549 svp[i] = &PL_sv_undef; /* XXX */
3550 }
3551 i--;
3552 }
3553}
3554
954c1994
GS		 3555/*
3556=for apidoc sv_insert
3557
3558Inserts a string at the specified offset/length within the SV. Similar to
3559the Perl substr() function.
3560
3561=cut
3562*/
3563
79072805 3564void
864dbfa3 3565Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
79072805
LW		 3566{
3567 register char *big;
3568 register char *mid;
3569 register char *midend;
3570 register char *bigend;
3571 register I32 i;
6ff81951 3572 STRLEN curlen;
1c846c1f 3573
79072805 3574
8990e307 3575 if (!bigstr)
cea2e8a9 3576 Perl_croak(aTHX_ "Can't modify non-existent substring");
6ff81951 3577 SvPV_force(bigstr, curlen);
60fa28ff 3578 (void)SvPOK_only_UTF8(bigstr);
6ff81951
GS		 3579 if (offset + len > curlen) {
3580 SvGROW(bigstr, offset+len+1);
3581 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3582 SvCUR_set(bigstr, offset+len);
3583 }
79072805 3584
69b47968 3585 SvTAINT(bigstr);
79072805
LW		 3586 i = littlelen - len;
3587 if (i > 0) { /* string might grow */
a0d0e21e 3588 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW		 3589 mid = big + offset + len;
3590 midend = bigend = big + SvCUR(bigstr);
3591 bigend += i;
3592 *bigend = '\0';
3593 while (midend > mid) /* shove everything down */
3594 *--bigend = *--midend;
3595 Move(little,big+offset,littlelen,char);
3596 SvCUR(bigstr) += i;
3597 SvSETMAGIC(bigstr);
3598 return;
3599 }
3600 else if (i == 0) {
463ee0b2 3601 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW		 3602 SvSETMAGIC(bigstr);
3603 return;
3604 }
3605
463ee0b2 3606 big = SvPVX(bigstr);
79072805
LW		 3607 mid = big + offset;
3608 midend = mid + len;
3609 bigend = big + SvCUR(bigstr);
3610
3611 if (midend > bigend)
cea2e8a9 3612 Perl_croak(aTHX_ "panic: sv_insert");
79072805
LW		 3613
3614 if (mid - big > bigend - midend) { /* faster to shorten from end */
3615 if (littlelen) {
3616 Move(little, mid, littlelen,char);
3617 mid += littlelen;
3618 }
3619 i = bigend - midend;
3620 if (i > 0) {
3621 Move(midend, mid, i,char);
3622 mid += i;
3623 }
3624 *mid = '\0';
3625 SvCUR_set(bigstr, mid - big);
3626 }
3627 /*SUPPRESS 560*/
155aba94 3628 else if ((i = mid - big)) { /* faster from front */
79072805
LW		 3629 midend -= littlelen;
3630 mid = midend;
3631 sv_chop(bigstr,midend-i);
3632 big += i;
3633 while (i--)
3634 *--midend = *--big;
3635 if (littlelen)
3636 Move(little, mid, littlelen,char);
3637 }
3638 else if (littlelen) {
3639 midend -= littlelen;
3640 sv_chop(bigstr,midend);
3641 Move(little,midend,littlelen,char);
3642 }
3643 else {
3644 sv_chop(bigstr,midend);
3645 }
3646 SvSETMAGIC(bigstr);
3647}
3648
c461cf8f
JH		 3649/*
3650=for apidoc sv_replace
3651
3652Make the first argument a copy of the second, then delete the original.
3653
3654=cut
3655*/
79072805
LW		 3656
3657void
864dbfa3 3658Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
79072805
LW		 3659{
3660 U32 refcnt = SvREFCNT(sv);
2213622d 3661 SV_CHECK_THINKFIRST(sv);
0453d815
PM		 3662 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3663 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
93a17b20 3664 if (SvMAGICAL(sv)) {
a0d0e21e
LW		 3665 if (SvMAGICAL(nsv))
3666 mg_free(nsv);
3667 else
3668 sv_upgrade(nsv, SVt_PVMG);
93a17b20 3669 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 3670 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW		 3671 SvMAGICAL_off(sv);
3672 SvMAGIC(sv) = 0;
3673 }
79072805
LW		 3674 SvREFCNT(sv) = 0;
3675 sv_clear(sv);
477f5d66 3676 assert(!SvREFCNT(sv));
79072805
LW		 3677 StructCopy(nsv,sv,SV);
3678 SvREFCNT(sv) = refcnt;
1edc1566 3679 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 3680 del_SV(nsv);
79072805
LW		 3681}
3682
c461cf8f
JH		 3683/*
3684=for apidoc sv_clear
3685
3686Clear an SV, making it empty. Does not free the memory used by the SV
3687itself.
3688
3689=cut
3690*/
3691
79072805 3692void
864dbfa3 3693Perl_sv_clear(pTHX_ register SV *sv)
79072805 3694{
ec12f114 3695 HV* stash;
79072805
LW		 3696 assert(sv);
3697 assert(SvREFCNT(sv) == 0);
3698
ed6116ce 3699 if (SvOBJECT(sv)) {
3280af22 3700 if (PL_defstash) { /* Still have a symbol table? */
4e35701f 3701 djSP;
8ebc5c01 3702 GV* destructor;
837485b6 3703 SV tmpref;
a0d0e21e 3704
837485b6
GS		 3705 Zero(&tmpref, 1, SV);
3706 sv_upgrade(&tmpref, SVt_RV);
3707 SvROK_on(&tmpref);
3708 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3709 SvREFCNT(&tmpref) = 1;
8ebc5c01 3710
4e8e7886
GS		 3711 do {
3712 stash = SvSTASH(sv);
3713 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3714 if (destructor) {
3715 ENTER;
e788e7d3 3716 PUSHSTACKi(PERLSI_DESTROY);
837485b6 3717 SvRV(&tmpref) = SvREFCNT_inc(sv);
4e8e7886
GS		 3718 EXTEND(SP, 2);
3719 PUSHMARK(SP);
837485b6 3720 PUSHs(&tmpref);
4e8e7886 3721 PUTBACK;
864dbfa3
GS		 3722 call_sv((SV*)GvCV(destructor),
3723 G_DISCARD|G_EVAL|G_KEEPERR);
4e8e7886 3724 SvREFCNT(sv)--;
d3acc0f7 3725 POPSTACK;
3095d977 3726 SPAGAIN;
4e8e7886
GS		 3727 LEAVE;
3728 }
3729 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
8ebc5c01 3730
837485b6 3731 del_XRV(SvANY(&tmpref));
6f44e0a4
JP		 3732
3733 if (SvREFCNT(sv)) {
3734 if (PL_in_clean_objs)
cea2e8a9 3735 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
6f44e0a4
JP		 3736 HvNAME(stash));
3737 /* DESTROY gave object new lease on life */
3738 return;
3739 }
a0d0e21e 3740 }
4e8e7886 3741
a0d0e21e 3742 if (SvOBJECT(sv)) {
4e8e7886 3743 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
a0d0e21e
LW		 3744 SvOBJECT_off(sv); /* Curse the object. */
3745 if (SvTYPE(sv) != SVt_PVIO)
3280af22 3746 --PL_sv_objcount; /* XXX Might want something more general */
a0d0e21e 3747 }
463ee0b2 3748 }
c07a80fd 3749 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 3750 mg_free(sv);
ec12f114 3751 stash = NULL;
79072805 3752 switch (SvTYPE(sv)) {
8990e307 3753 case SVt_PVIO:
df0bd2f4
GS		 3754 if (IoIFP(sv) &&
3755 IoIFP(sv) != PerlIO_stdin() &&
5f05dabc 3756 IoIFP(sv) != PerlIO_stdout() &&
3757 IoIFP(sv) != PerlIO_stderr())
93578b34 3758 {
f2b5be74 3759 io_close((IO*)sv, FALSE);
93578b34 3760 }
1d7c1841 3761 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
1236053a 3762 PerlDir_close(IoDIRP(sv));
1d7c1841 3763 IoDIRP(sv) = (DIR*)NULL;
8990e307
LW		 3764 Safefree(IoTOP_NAME(sv));
3765 Safefree(IoFMT_NAME(sv));
3766 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 3767 /* FALL THROUGH */
79072805 3768 case SVt_PVBM:
a0d0e21e 3769 goto freescalar;
79072805 3770 case SVt_PVCV:
748a9306 3771 case SVt_PVFM:
85e6fe83 3772 cv_undef((CV*)sv);
a0d0e21e 3773 goto freescalar;
79072805 3774 case SVt_PVHV:
85e6fe83 3775 hv_undef((HV*)sv);
a0d0e21e 3776 break;
79072805 3777 case SVt_PVAV:
85e6fe83 3778 av_undef((AV*)sv);
a0d0e21e 3779 break;
02270b4e
GS		 3780 case SVt_PVLV:
3781 SvREFCNT_dec(LvTARG(sv));
3782 goto freescalar;
a0d0e21e 3783 case SVt_PVGV:
1edc1566 3784 gp_free((GV*)sv);
a0d0e21e 3785 Safefree(GvNAME(sv));
ec12f114
JPC		 3786 /* cannot decrease stash refcount yet, as we might recursively delete
3787 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3788 of stash until current sv is completely gone.
3789 -- JohnPC, 27 Mar 1998 */
3790 stash = GvSTASH(sv);
a0d0e21e 3791 /* FALL THROUGH */
79072805 3792 case SVt_PVMG:
79072805
LW		 3793 case SVt_PVNV:
3794 case SVt_PVIV:
a0d0e21e
LW		 3795 freescalar:
3796 (void)SvOOK_off(sv);
79072805
LW		 3797 /* FALL THROUGH */
3798 case SVt_PV:
a0d0e21e 3799 case SVt_RV:
810b8aa5
GS		 3800 if (SvROK(sv)) {
3801 if (SvWEAKREF(sv))
3802 sv_del_backref(sv);
3803 else
3804 SvREFCNT_dec(SvRV(sv));
3805 }
1edc1566 3806 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 3807 Safefree(SvPVX(sv));
1c846c1f
NIS		 3808 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
3809 unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
3810 SvFAKE_off(sv);
3811 }
79072805 3812 break;
a0d0e21e 3813/*
79072805 3814 case SVt_NV:
79072805 3815 case SVt_IV:
79072805
LW		 3816 case SVt_NULL:
3817 break;
a0d0e21e 3818*/
79072805
LW		 3819 }
3820
3821 switch (SvTYPE(sv)) {
3822 case SVt_NULL:
3823 break;
79072805
LW		 3824 case SVt_IV:
3825 del_XIV(SvANY(sv));
3826 break;
3827 case SVt_NV:
3828 del_XNV(SvANY(sv));
3829 break;
ed6116ce
LW		 3830 case SVt_RV:
3831 del_XRV(SvANY(sv));
3832 break;
79072805
LW		 3833 case SVt_PV:
3834 del_XPV(SvANY(sv));
3835 break;
3836 case SVt_PVIV:
3837 del_XPVIV(SvANY(sv));
3838 break;
3839 case SVt_PVNV:
3840 del_XPVNV(SvANY(sv));
3841 break;
3842 case SVt_PVMG:
3843 del_XPVMG(SvANY(sv));
3844 break;
3845 case SVt_PVLV:
3846 del_XPVLV(SvANY(sv));
3847 break;
3848 case SVt_PVAV:
3849 del_XPVAV(SvANY(sv));
3850 break;
3851 case SVt_PVHV:
3852 del_XPVHV(SvANY(sv));
3853 break;
3854 case SVt_PVCV:
3855 del_XPVCV(SvANY(sv));
3856 break;
3857 case SVt_PVGV:
3858 del_XPVGV(SvANY(sv));
ec12f114
JPC		 3859 /* code duplication for increased performance. */
3860 SvFLAGS(sv) &= SVf_BREAK;
3861 SvFLAGS(sv) |= SVTYPEMASK;
3862 /* decrease refcount of the stash that owns this GV, if any */
3863 if (stash)
3864 SvREFCNT_dec(stash);
3865 return; /* not break, SvFLAGS reset already happened */
79072805
LW		 3866 case SVt_PVBM:
3867 del_XPVBM(SvANY(sv));
3868 break;
3869 case SVt_PVFM:
3870 del_XPVFM(SvANY(sv));
3871 break;
8990e307
LW		 3872 case SVt_PVIO:
3873 del_XPVIO(SvANY(sv));
3874 break;
79072805 3875 }
a0d0e21e 3876 SvFLAGS(sv) &= SVf_BREAK;
8990e307 3877 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW		 3878}
3879
3880SV *
864dbfa3 3881Perl_sv_newref(pTHX_ SV *sv)
79072805 3882{
463ee0b2 3883 if (sv)
dce16143 3884 ATOMIC_INC(SvREFCNT(sv));
79072805
LW		 3885 return sv;
3886}
3887
c461cf8f
JH		 3888/*
3889=for apidoc sv_free
3890
3891Free the memory used by an SV.
3892
3893=cut
3894*/
3895
79072805 3896void
864dbfa3 3897Perl_sv_free(pTHX_ SV *sv)
79072805 3898{
dce16143
MB		 3899 int refcount_is_zero;
3900
79072805
LW		 3901 if (!sv)
3902 return;
a0d0e21e
LW		 3903 if (SvREFCNT(sv) == 0) {
3904 if (SvFLAGS(sv) & SVf_BREAK)
3905 return;
3280af22 3906 if (PL_in_clean_all) /* All is fair */
1edc1566 3907 return;
d689ffdd
JP		 3908 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3909 /* make sure SvREFCNT(sv)==0 happens very seldom */
3910 SvREFCNT(sv) = (~(U32)0)/2;
3911 return;
3912 }
0453d815
PM		 3913 if (ckWARN_d(WARN_INTERNAL))
3914 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
79072805
LW		 3915 return;
3916 }
dce16143
MB		 3917 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3918 if (!refcount_is_zero)
8990e307 3919 return;
463ee0b2
LW		 3920#ifdef DEBUGGING
3921 if (SvTEMP(sv)) {
0453d815 3922 if (ckWARN_d(WARN_DEBUGGING))
f248d071 3923 Perl_warner(aTHX_ WARN_DEBUGGING,
1d7c1841
GS		 3924 "Attempt to free temp prematurely: SV 0x%"UVxf,
3925 PTR2UV(sv));
79072805 3926 return;
79072805 3927 }
463ee0b2 3928#endif
d689ffdd
JP		 3929 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3930 /* make sure SvREFCNT(sv)==0 happens very seldom */
3931 SvREFCNT(sv) = (~(U32)0)/2;
3932 return;
3933 }
79072805 3934 sv_clear(sv);
477f5d66
CS		 3935 if (! SvREFCNT(sv))
3936 del_SV(sv);
79072805
LW		 3937}
3938
954c1994
GS		 3939/*
3940=for apidoc sv_len
3941
3942Returns the length of the string in the SV. See also C<SvCUR>.
3943
3944=cut
3945*/
3946
79072805 3947STRLEN
864dbfa3 3948Perl_sv_len(pTHX_ register SV *sv)
79072805 3949{
748a9306 3950 char *junk;
463ee0b2 3951 STRLEN len;
79072805
LW		 3952
3953 if (!sv)
3954 return 0;
3955
8990e307 3956 if (SvGMAGICAL(sv))
565764a8 3957 len = mg_length(sv);
8990e307 3958 else
748a9306 3959 junk = SvPV(sv, len);
463ee0b2 3960 return len;
79072805
LW		 3961}
3962
c461cf8f
JH		 3963/*
3964=for apidoc sv_len_utf8
3965
3966Returns the number of characters in the string in an SV, counting wide
3967UTF8 bytes as a single character.
3968
3969=cut
3970*/
3971
a0ed51b3 3972STRLEN
864dbfa3 3973Perl_sv_len_utf8(pTHX_ register SV *sv)
a0ed51b3 3974{
a0ed51b3
LW		 3975 if (!sv)
3976 return 0;
3977
3978#ifdef NOTYET
3979 if (SvGMAGICAL(sv))
b76347f2 3980 return mg_length(sv);
a0ed51b3
LW		 3981 else
3982#endif
b76347f2
JH		 3983 {
3984 STRLEN len;
3985 U8 *s = (U8*)SvPV(sv, len);
3986
d6efbbad 3987 return Perl_utf8_length(aTHX_ s, s + len);
a0ed51b3 3988 }
a0ed51b3
LW		 3989}
3990
3991void
864dbfa3 3992Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
a0ed51b3 3993{
dfe13c55
GS		 3994 U8 *start;
3995 U8 *s;
3996 U8 *send;
a0ed51b3
LW		 3997 I32 uoffset = *offsetp;
3998 STRLEN len;
3999
4000 if (!sv)
4001 return;
4002
dfe13c55 4003 start = s = (U8*)SvPV(sv, len);
a0ed51b3
LW		 4004 send = s + len;
4005 while (s < send && uoffset--)
4006 s += UTF8SKIP(s);
bb40f870
GA		 4007 if (s >= send)
4008 s = send;
a0ed51b3
LW		 4009 *offsetp = s - start;
4010 if (lenp) {
4011 I32 ulen = *lenp;
4012 start = s;
4013 while (s < send && ulen--)
4014 s += UTF8SKIP(s);
bb40f870
GA		 4015 if (s >= send)
4016 s = send;
a0ed51b3
LW		 4017 *lenp = s - start;
4018 }
4019 return;
4020}
4021
4022void
864dbfa3 4023Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
a0ed51b3 4024{
dfe13c55
GS		 4025 U8 *s;
4026 U8 *send;
a0ed51b3
LW		 4027 STRLEN len;
4028
4029 if (!sv)
4030 return;
4031
dfe13c55 4032 s = (U8*)SvPV(sv, len);
a0ed51b3 4033 if (len < *offsetp)
cea2e8a9 4034 Perl_croak(aTHX_ "panic: bad byte offset");
a0ed51b3
LW		 4035 send = s + *offsetp;
4036 len = 0;
4037 while (s < send) {
4038 s += UTF8SKIP(s);
4039 ++len;
4040 }
4041 if (s != send) {
1c846c1f 4042 if (ckWARN_d(WARN_UTF8))
0453d815 4043 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
a0ed51b3
LW		 4044 --len;
4045 }
4046 *offsetp = len;
4047 return;
4048}
4049
954c1994
GS		 4050/*
4051=for apidoc sv_eq
4052
4053Returns a boolean indicating whether the strings in the two SVs are
4054identical.
4055
4056=cut
4057*/
4058
79072805 4059I32
e01b9e88 4060Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
79072805
LW		 4061{
4062 char *pv1;
463ee0b2 4063 STRLEN cur1;
79072805 4064 char *pv2;
463ee0b2 4065 STRLEN cur2;
e01b9e88
SC		 4066 I32 eq = 0;
4067 bool pv1tmp = FALSE;
4068 bool pv2tmp = FALSE;
79072805 4069
e01b9e88 4070 if (!sv1) {
79072805
LW		 4071 pv1 = "";
4072 cur1 = 0;
4073 }
463ee0b2 4074 else
e01b9e88 4075 pv1 = SvPV(sv1, cur1);
79072805 4076
e01b9e88
SC		 4077 if (!sv2){
4078 pv2 = "";
4079 cur2 = 0;
92d29cee 4080 }
e01b9e88
SC		 4081 else
4082 pv2 = SvPV(sv2, cur2);
79072805 4083
e01b9e88 4084 /* do not utf8ize the comparands as a side-effect */
7bbb0251 4085 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
e01b9e88
SC		 4086 if (SvUTF8(sv1)) {
4087 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4088 pv2tmp = TRUE;
4089 }
4090 else {
4091 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4092 pv1tmp = TRUE;
4093 }
4094 }
79072805 4095
e01b9e88
SC		 4096 if (cur1 == cur2)
4097 eq = memEQ(pv1, pv2, cur1);
4098
4099 if (pv1tmp)
4100 Safefree(pv1);
4101 if (pv2tmp)
4102 Safefree(pv2);
4103
4104 return eq;
79072805
LW		 4105}
4106
954c1994
GS		 4107/*
4108=for apidoc sv_cmp
4109
4110Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4111string in C<sv1> is less than, equal to, or greater than the string in
4112C<sv2>.
4113
4114=cut
4115*/
4116
79072805 4117I32
e01b9e88 4118Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
79072805 4119{
560a288e
GS		 4120 STRLEN cur1, cur2;
4121 char *pv1, *pv2;
1c846c1f 4122 I32 cmp;
e01b9e88
SC		 4123 bool pv1tmp = FALSE;
4124 bool pv2tmp = FALSE;
560a288e 4125
e01b9e88
SC		 4126 if (!sv1) {
4127 pv1 = "";
560a288e
GS		 4128 cur1 = 0;
4129 }
e01b9e88
SC		 4130 else
4131 pv1 = SvPV(sv1, cur1);
560a288e 4132
e01b9e88
SC		 4133 if (!sv2){
4134 pv2 = "";
560a288e
GS		 4135 cur2 = 0;
4136 }
e01b9e88
SC		 4137 else
4138 pv2 = SvPV(sv2, cur2);
79072805 4139
e01b9e88
SC		 4140 /* do not utf8ize the comparands as a side-effect */
4141 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4142 if (SvUTF8(sv1)) {
4143 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4144 pv2tmp = TRUE;
4145 }
4146 else {
4147 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4148 pv1tmp = TRUE;
4149 }
4150 }
79072805 4151
e01b9e88
SC		 4152 if (!cur1) {
4153 cmp = cur2 ? -1 : 0;
4154 } else if (!cur2) {
4155 cmp = 1;
4156 } else {
4157 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4158
4159 if (retval) {
4160 cmp = retval < 0 ? -1 : 1;
4161 } else if (cur1 == cur2) {
4162 cmp = 0;
4163 } else {
4164 cmp = cur1 < cur2 ? -1 : 1;
4165 }
4166 }
16660edb 4167
e01b9e88
SC		 4168 if (pv1tmp)
4169 Safefree(pv1);
4170 if (pv2tmp)
4171 Safefree(pv2);
16660edb 4172
e01b9e88 4173 return cmp;
bbce6d69 4174}
16660edb 4175
c461cf8f
JH		 4176/*
4177=for apidoc sv_cmp_locale
4178
4179Compares the strings in two SVs in a locale-aware manner. See
4180L</sv_cmp_locale>
4181
4182=cut
4183*/
4184
bbce6d69 4185I32
864dbfa3 4186Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
bbce6d69 4187{
36477c24 4188#ifdef USE_LOCALE_COLLATE
16660edb 4189
bbce6d69 4190 char *pv1, *pv2;
4191 STRLEN len1, len2;
4192 I32 retval;
16660edb 4193
3280af22 4194 if (PL_collation_standard)
bbce6d69 4195 goto raw_compare;
16660edb 4196
bbce6d69 4197 len1 = 0;
8ac85365 4198 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
bbce6d69 4199 len2 = 0;
8ac85365 4200 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
16660edb 4201
bbce6d69 4202 if (!pv1 || !len1) {
4203 if (pv2 && len2)
4204 return -1;
4205 else
4206 goto raw_compare;
4207 }
4208 else {
4209 if (!pv2 || !len2)
4210 return 1;
4211 }
16660edb 4212
bbce6d69 4213 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 4214
bbce6d69 4215 if (retval)
16660edb 4216 return retval < 0 ? -1 : 1;
4217
bbce6d69 4218 /*
4219 * When the result of collation is equality, that doesn't mean
4220 * that there are no differences -- some locales exclude some
4221 * characters from consideration. So to avoid false equalities,
4222 * we use the raw string as a tiebreaker.
4223 */
16660edb 4224
bbce6d69 4225 raw_compare:
4226 /* FALL THROUGH */
16660edb 4227
36477c24 4228#endif /* USE_LOCALE_COLLATE */
16660edb 4229
bbce6d69 4230 return sv_cmp(sv1, sv2);
4231}
79072805 4232
36477c24 4233#ifdef USE_LOCALE_COLLATE
7a4c00b4 4234/*
4235 * Any scalar variable may carry an 'o' magic that contains the
4236 * scalar data of the variable transformed to such a format that
4237 * a normal memory comparison can be used to compare the data
4238 * according to the locale settings.
4239 */
bbce6d69 4240char *
864dbfa3 4241Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
bbce6d69 4242{
7a4c00b4 4243 MAGIC *mg;
16660edb 4244
8ac85365 4245 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3280af22 4246 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
bbce6d69 4247 char *s, *xf;
4248 STRLEN len, xlen;
4249
7a4c00b4 4250 if (mg)
4251 Safefree(mg->mg_ptr);
bbce6d69 4252 s = SvPV(sv, len);
4253 if ((xf = mem_collxfrm(s, len, &xlen))) {
ff0cee69 4254 if (SvREADONLY(sv)) {
4255 SAVEFREEPV(xf);
4256 *nxp = xlen;
3280af22 4257 return xf + sizeof(PL_collation_ix);
ff0cee69 4258 }
7a4c00b4 4259 if (! mg) {
4260 sv_magic(sv, 0, 'o', 0, 0);
4261 mg = mg_find(sv, 'o');
4262 assert(mg);
bbce6d69 4263 }
7a4c00b4 4264 mg->mg_ptr = xf;
565764a8 4265 mg->mg_len = xlen;
7a4c00b4 4266 }
4267 else {
ff0cee69 4268 if (mg) {
4269 mg->mg_ptr = NULL;
565764a8 4270 mg->mg_len = -1;
ff0cee69 4271 }
bbce6d69 4272 }
4273 }
7a4c00b4 4274 if (mg && mg->mg_ptr) {
565764a8 4275 *nxp = mg->mg_len;
3280af22 4276 return mg->mg_ptr + sizeof(PL_collation_ix);
bbce6d69 4277 }
4278 else {
4279 *nxp = 0;
4280 return NULL;
16660edb 4281 }
79072805
LW		 4282}
4283
36477c24 4284#endif /* USE_LOCALE_COLLATE */
bbce6d69 4285
c461cf8f
JH		 4286/*
4287=for apidoc sv_gets
4288
4289Get a line from the filehandle and store it into the SV, optionally
4290appending to the currently-stored string.
4291
4292=cut
4293*/
4294
79072805 4295char *
864dbfa3 4296Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
79072805 4297{
c07a80fd 4298 char *rsptr;
4299 STRLEN rslen;
4300 register STDCHAR rslast;
4301 register STDCHAR *bp;
4302 register I32 cnt;
4303 I32 i;
4304
2213622d 4305 SV_CHECK_THINKFIRST(sv);
6fc92669 4306 (void)SvUPGRADE(sv, SVt_PV);
99491443 4307
ff68c719 4308 SvSCREAM_off(sv);
c07a80fd 4309
3280af22 4310 if (RsSNARF(PL_rs)) {
c07a80fd 4311 rsptr = NULL;
4312 rslen = 0;
4313 }
3280af22 4314 else if (RsRECORD(PL_rs)) {
5b2b9c68
HM		 4315 I32 recsize, bytesread;
4316 char *buffer;
4317
4318 /* Grab the size of the record we're getting */
3280af22 4319 recsize = SvIV(SvRV(PL_rs));
5b2b9c68 4320 (void)SvPOK_only(sv); /* Validate pointer */
e670df4e 4321 buffer = SvGROW(sv, recsize + 1);
5b2b9c68
HM		 4322 /* Go yank in */
4323#ifdef VMS
4324 /* VMS wants read instead of fread, because fread doesn't respect */
4325 /* RMS record boundaries. This is not necessarily a good thing to be */
4326 /* doing, but we've got no other real choice */
4327 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4328#else
4329 bytesread = PerlIO_read(fp, buffer, recsize);
4330#endif
4331 SvCUR_set(sv, bytesread);
e670df4e 4332 buffer[bytesread] = '\0';
5b2b9c68
HM		 4333 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4334 }
3280af22 4335 else if (RsPARA(PL_rs)) {
c07a80fd 4336 rsptr = "\n\n";
4337 rslen = 2;
4338 }
4339 else
3280af22 4340 rsptr = SvPV(PL_rs, rslen);
c07a80fd 4341 rslast = rslen ? rsptr[rslen - 1] : '\0';
4342
3280af22 4343 if (RsPARA(PL_rs)) { /* have to do this both before and after */
79072805 4344 do { /* to make sure file boundaries work right */
760ac839 4345 if (PerlIO_eof(fp))
a0d0e21e 4346 return 0;
760ac839 4347 i = PerlIO_getc(fp);
79072805 4348 if (i != '\n') {
a0d0e21e
LW		 4349 if (i == -1)
4350 return 0;
760ac839 4351 PerlIO_ungetc(fp,i);
79072805
LW		 4352 break;
4353 }
4354 } while (i != EOF);
4355 }
c07a80fd 4356
760ac839
LW		 4357 /* See if we know enough about I/O mechanism to cheat it ! */
4358
4359 /* This used to be #ifdef test - it is made run-time test for ease
1c846c1f 4360 of abstracting out stdio interface. One call should be cheap
760ac839
LW		 4361 enough here - and may even be a macro allowing compile
4362 time optimization.
4363 */
4364
4365 if (PerlIO_fast_gets(fp)) {
4366
4367 /*
4368 * We're going to steal some values from the stdio struct
4369 * and put EVERYTHING in the innermost loop into registers.
4370 */
4371 register STDCHAR *ptr;
4372 STRLEN bpx;
4373 I32 shortbuffered;
4374
16660edb 4375#if defined(VMS) && defined(PERLIO_IS_STDIO)
4376 /* An ungetc()d char is handled separately from the regular
4377 * buffer, so we getc() it back out and stuff it in the buffer.
4378 */
4379 i = PerlIO_getc(fp);
4380 if (i == EOF) return 0;
4381 *(--((*fp)->_ptr)) = (unsigned char) i;
4382 (*fp)->_cnt++;
4383#endif
c07a80fd 4384
c2960299 4385 /* Here is some breathtakingly efficient cheating */
c07a80fd 4386
a20bf0c3 4387 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 4388 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW		 4389 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4390 if (cnt > 80 && SvLEN(sv) > append) {
4391 shortbuffered = cnt - SvLEN(sv) + append + 1;
4392 cnt -= shortbuffered;
4393 }
4394 else {
4395 shortbuffered = 0;
bbce6d69 4396 /* remember that cnt can be negative */
4397 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW		 4398 }
4399 }
4400 else
4401 shortbuffered = 0;
c07a80fd 4402 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
a20bf0c3 4403 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb 4404 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4405 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
16660edb 4406 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4407 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 4408 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 4409 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
79072805
LW		 4410 for (;;) {
4411 screamer:
93a17b20 4412 if (cnt > 0) {
c07a80fd 4413 if (rslen) {
760ac839
LW		 4414 while (cnt > 0) { /* this | eat */
4415 cnt--;
c07a80fd 4416 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4417 goto thats_all_folks; /* screams | sed :-) */
4418 }
4419 }
4420 else {
1c846c1f
NIS		 4421 Copy(ptr, bp, cnt, char); /* this | eat */
4422 bp += cnt; /* screams | dust */
c07a80fd 4423 ptr += cnt; /* louder | sed :-) */
a5f75d66 4424 cnt = 0;
93a17b20 4425 }
79072805
LW		 4426 }
4427
748a9306 4428 if (shortbuffered) { /* oh well, must extend */
79072805
LW		 4429 cnt = shortbuffered;
4430 shortbuffered = 0;
c07a80fd 4431 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 4432 SvCUR_set(sv, bpx);
4433 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 4434 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW		 4435 continue;
4436 }
4437
16660edb 4438 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 4439 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4440 PTR2UV(ptr),(long)cnt));
a20bf0c3 4441 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb 4442 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4443 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 4444 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 4445 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
1c846c1f 4446 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b 4447 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4448 another abstraction. */
760ac839 4449 i = PerlIO_getc(fp); /* get more characters */
16660edb 4450 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4451 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 4452 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 4453 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
a20bf0c3
JH		 4454 cnt = PerlIO_get_cnt(fp);
4455 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb 4456 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4457 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
79072805 4458
748a9306
LW		 4459 if (i == EOF) /* all done for ever? */
4460 goto thats_really_all_folks;
4461
c07a80fd 4462 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 4463 SvCUR_set(sv, bpx);
4464 SvGROW(sv, bpx + cnt + 2);
c07a80fd 4465 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4466
760ac839 4467 *bp++ = i; /* store character from PerlIO_getc */
79072805 4468
c07a80fd 4469 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 4470 goto thats_all_folks;
79072805
LW		 4471 }
4472
4473thats_all_folks:
c07a80fd 4474 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 4475 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 4476 goto screamer; /* go back to the fray */
79072805
LW		 4477thats_really_all_folks:
4478 if (shortbuffered)
4479 cnt += shortbuffered;
16660edb 4480 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4481 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
a20bf0c3 4482 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb 4483 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 4484 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 4485 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 4486 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
79072805 4487 *bp = '\0';
760ac839 4488 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb 4489 DEBUG_P(PerlIO_printf(Perl_debug_log,
fb73857a 4490 "Screamer: done, len=%ld, string=|%.*s|\n",
4491 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
760ac839
LW		 4492 }
4493 else
79072805 4494 {
4d2c4e07 4495#ifndef EPOC
760ac839 4496 /*The big, slow, and stupid way */
c07a80fd 4497 STDCHAR buf[8192];
4d2c4e07
OF		 4498#else
4499 /* Need to work around EPOC SDK features */
4500 /* On WINS: MS VC5 generates calls to _chkstk, */
4501 /* if a `large' stack frame is allocated */
4502 /* gcc on MARM does not generate calls like these */
4503 STDCHAR buf[1024];
4504#endif
79072805 4505
760ac839 4506screamer2:
c07a80fd 4507 if (rslen) {
760ac839
LW		 4508 register STDCHAR *bpe = buf + sizeof(buf);
4509 bp = buf;
4510 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4511 ; /* keep reading */
4512 cnt = bp - buf;
c07a80fd 4513 }
4514 else {
760ac839 4515 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb 4516 /* Accomodate broken VAXC compiler, which applies U8 cast to
4517 * both args of ?: operator, causing EOF to change into 255
4518 */
4519 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 4520 }
79072805
LW		 4521
4522 if (append)
760ac839 4523 sv_catpvn(sv, (char *) buf, cnt);
79072805 4524 else
760ac839 4525 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd 4526
4527 if (i != EOF && /* joy */
4528 (!rslen ||
4529 SvCUR(sv) < rslen ||
36477c24 4530 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW		 4531 {
4532 append = -1;
63e4d877
CS		 4533 /*
4534 * If we're reading from a TTY and we get a short read,
4535 * indicating that the user hit his EOF character, we need
4536 * to notice it now, because if we try to read from the TTY
4537 * again, the EOF condition will disappear.
4538 *
4539 * The comparison of cnt to sizeof(buf) is an optimization
4540 * that prevents unnecessary calls to feof().
4541 *
4542 * - jik 9/25/96
4543 */
4544 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4545 goto screamer2;
79072805
LW		 4546 }
4547 }
4548
1c846c1f 4549 if (RsPARA(PL_rs)) { /* have to do this both before and after */
c07a80fd 4550 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 4551 i = PerlIO_getc(fp);
79072805 4552 if (i != '\n') {
760ac839 4553 PerlIO_ungetc(fp,i);
79072805
LW		 4554 break;
4555 }
4556 }
4557 }
c07a80fd 4558
4559 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW		 4560}
4561
760ac839 4562
954c1994
GS		 4563/*
4564=for apidoc sv_inc
4565
4566Auto-increment of the value in the SV.
4567
4568=cut
4569*/
4570
79072805 4571void
864dbfa3 4572Perl_sv_inc(pTHX_ register SV *sv)
79072805
LW		 4573{
4574 register char *d;
463ee0b2 4575 int flags;
79072805
LW		 4576
4577 if (!sv)
4578 return;
b23a5f78
GB		 4579 if (SvGMAGICAL(sv))
4580 mg_get(sv);
ed6116ce 4581 if (SvTHINKFIRST(sv)) {
0f15f207 4582 if (SvREADONLY(sv)) {
3280af22 4583 if (PL_curcop != &PL_compiling)
cea2e8a9 4584 Perl_croak(aTHX_ PL_no_modify);
0f15f207 4585 }
a0d0e21e 4586 if (SvROK(sv)) {
b5be31e9 4587 IV i;
9e7bc3e8
JD		 4588 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4589 return;
56431972 4590 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 4591 sv_unref(sv);
4592 sv_setiv(sv, i);
a0d0e21e 4593 }
ed6116ce 4594 }
8990e307 4595 flags = SvFLAGS(sv);
8990e307 4596 if (flags & SVp_NOK) {
a0d0e21e 4597 (void)SvNOK_only(sv);
55497cff 4598 SvNVX(sv) += 1.0;
4599 return;
4600 }
4601 if (flags & SVp_IOK) {
25da4f38
IZ		 4602 if (SvIsUV(sv)) {
4603 if (SvUVX(sv) == UV_MAX)
65202027 4604 sv_setnv(sv, (NV)UV_MAX + 1.0);
25da4f38
IZ		 4605 else
4606 (void)SvIOK_only_UV(sv);
4607 ++SvUVX(sv);
4608 } else {
4609 if (SvIVX(sv) == IV_MAX)
65202027 4610 sv_setnv(sv, (NV)IV_MAX + 1.0);
25da4f38
IZ		 4611 else {
4612 (void)SvIOK_only(sv);
4613 ++SvIVX(sv);
1c846c1f 4614 }
55497cff 4615 }
79072805
LW		 4616 return;
4617 }
8990e307 4618 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4633a7c4 4619 if ((flags & SVTYPEMASK) < SVt_PVNV)
db332f3b
NC		 4620 sv_upgrade(sv, SVt_IV);
4621 (void)SvIOK_only(sv);
4622 SvIVX(sv) = 1;
79072805
LW		 4623 return;
4624 }
463ee0b2 4625 d = SvPVX(sv);
79072805
LW		 4626 while (isALPHA(*d)) d++;
4627 while (isDIGIT(*d)) d++;
4628 if (*d) {
097ee67d 4629 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
79072805
LW		 4630 return;
4631 }
4632 d--;
463ee0b2 4633 while (d >= SvPVX(sv)) {
79072805
LW		 4634 if (isDIGIT(*d)) {
4635 if (++*d <= '9')
4636 return;
4637 *(d--) = '0';
4638 }
4639 else {
9d116dd7
JH		 4640#ifdef EBCDIC
4641 /* MKS: The original code here died if letters weren't consecutive.
4642 * at least it didn't have to worry about non-C locales. The
4643 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
1c846c1f 4644 * arranged in order (although not consecutively) and that only
9d116dd7
JH		 4645 * [A-Za-z] are accepted by isALPHA in the C locale.
4646 */
4647 if (*d != 'z' && *d != 'Z') {
4648 do { ++*d; } while (!isALPHA(*d));
4649 return;
4650 }
4651 *(d--) -= 'z' - 'a';
4652#else
79072805
LW		 4653 ++*d;
4654 if (isALPHA(*d))
4655 return;
4656 *(d--) -= 'z' - 'a' + 1;
9d116dd7 4657#endif
79072805
LW		 4658 }
4659 }
4660 /* oh,oh, the number grew */
4661 SvGROW(sv, SvCUR(sv) + 2);
4662 SvCUR(sv)++;
463ee0b2 4663 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW		 4664 *d = d[-1];
4665 if (isDIGIT(d[1]))
4666 *d = '1';
4667 else
4668 *d = d[1];
4669}
4670
954c1994
GS		 4671/*
4672=for apidoc sv_dec
4673
4674Auto-decrement of the value in the SV.
4675
4676=cut
4677*/
4678
79072805 4679void
864dbfa3 4680Perl_sv_dec(pTHX_ register SV *sv)
79072805 4681{
463ee0b2
LW		 4682 int flags;
4683
79072805
LW		 4684 if (!sv)
4685 return;
b23a5f78
GB		 4686 if (SvGMAGICAL(sv))
4687 mg_get(sv);
ed6116ce 4688 if (SvTHINKFIRST(sv)) {
0f15f207 4689 if (SvREADONLY(sv)) {
3280af22 4690 if (PL_curcop != &PL_compiling)
cea2e8a9 4691 Perl_croak(aTHX_ PL_no_modify);
0f15f207 4692 }
a0d0e21e 4693 if (SvROK(sv)) {
b5be31e9 4694 IV i;
9e7bc3e8
JD		 4695 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4696 return;
56431972 4697 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 4698 sv_unref(sv);
4699 sv_setiv(sv, i);
a0d0e21e 4700 }
ed6116ce 4701 }
8990e307 4702 flags = SvFLAGS(sv);
8990e307 4703 if (flags & SVp_NOK) {
463ee0b2 4704 SvNVX(sv) -= 1.0;
a0d0e21e 4705 (void)SvNOK_only(sv);
79072805
LW		 4706 return;
4707 }
55497cff 4708 if (flags & SVp_IOK) {
25da4f38
IZ		 4709 if (SvIsUV(sv)) {
4710 if (SvUVX(sv) == 0) {
4711 (void)SvIOK_only(sv);
4712 SvIVX(sv) = -1;
4713 }
4714 else {
4715 (void)SvIOK_only_UV(sv);
4716 --SvUVX(sv);
1c846c1f 4717 }
25da4f38
IZ		 4718 } else {
4719 if (SvIVX(sv) == IV_MIN)
65202027 4720 sv_setnv(sv, (NV)IV_MIN - 1.0);
25da4f38
IZ		 4721 else {
4722 (void)SvIOK_only(sv);
4723 --SvIVX(sv);
1c846c1f 4724 }
55497cff 4725 }
4726 return;
4727 }
8990e307 4728 if (!(flags & SVp_POK)) {
4633a7c4
LW		 4729 if ((flags & SVTYPEMASK) < SVt_PVNV)
4730 sv_upgrade(sv, SVt_NV);
463ee0b2 4731 SvNVX(sv) = -1.0;
a0d0e21e 4732 (void)SvNOK_only(sv);
79072805
LW		 4733 return;
4734 }
097ee67d 4735 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW		 4736}
4737
954c1994
GS		 4738/*
4739=for apidoc sv_mortalcopy
4740
4741Creates a new SV which is a copy of the original SV. The new SV is marked
4742as mortal.
4743
4744=cut
4745*/
4746
79072805
LW		 4747/* Make a string that will exist for the duration of the expression
4748 * evaluation. Actually, it may have to last longer than that, but
4749 * hopefully we won't free it until it has been assigned to a
4750 * permanent location. */
4751
4752SV *
864dbfa3 4753Perl_sv_mortalcopy(pTHX_ SV *oldstr)
79072805 4754{
463ee0b2 4755 register SV *sv;
79072805 4756
4561caa4 4757 new_SV(sv);
79072805 4758 sv_setsv(sv,oldstr);
677b06e3
GS		 4759 EXTEND_MORTAL(1);
4760 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307
LW		 4761 SvTEMP_on(sv);
4762 return sv;
4763}
4764
954c1994
GS		 4765/*
4766=for apidoc sv_newmortal
4767
4768Creates a new SV which is mortal. The reference count of the SV is set to 1.
4769
4770=cut
4771*/
4772
8990e307 4773SV *
864dbfa3 4774Perl_sv_newmortal(pTHX)
8990e307
LW		 4775{
4776 register SV *sv;
4777
4561caa4 4778 new_SV(sv);
8990e307 4779 SvFLAGS(sv) = SVs_TEMP;
677b06e3
GS		 4780 EXTEND_MORTAL(1);
4781 PL_tmps_stack[++PL_tmps_ix] = sv;
79072805
LW		 4782 return sv;
4783}
4784
954c1994
GS		 4785/*
4786=for apidoc sv_2mortal
4787
4788Marks an SV as mortal. The SV will be destroyed when the current context
4789ends.
4790
4791=cut
4792*/
4793
79072805
LW		 4794/* same thing without the copying */
4795
4796SV *
864dbfa3 4797Perl_sv_2mortal(pTHX_ register SV *sv)
79072805
LW		 4798{
4799 if (!sv)
4800 return sv;
d689ffdd 4801 if (SvREADONLY(sv) && SvIMMORTAL(sv))
11162842 4802 return sv;
677b06e3
GS		 4803 EXTEND_MORTAL(1);
4804 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307 4805 SvTEMP_on(sv);
79072805
LW		 4806 return sv;
4807}
4808
954c1994
GS		 4809/*
4810=for apidoc newSVpv
4811
4812Creates a new SV and copies a string into it. The reference count for the
4813SV is set to 1. If C<len> is zero, Perl will compute the length using
4814strlen(). For efficiency, consider using C<newSVpvn> instead.
4815
4816=cut
4817*/
4818
79072805 4819SV *
864dbfa3 4820Perl_newSVpv(pTHX_ const char *s, STRLEN len)
79072805 4821{
463ee0b2 4822 register SV *sv;
79072805 4823
4561caa4 4824 new_SV(sv);
79072805
LW		 4825 if (!len)
4826 len = strlen(s);
4827 sv_setpvn(sv,s,len);
4828 return sv;
4829}
4830
954c1994
GS		 4831/*
4832=for apidoc newSVpvn
4833
4834Creates a new SV and copies a string into it. The reference count for the
1c846c1f 4835SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
954c1994
GS		 4836string. You are responsible for ensuring that the source string is at least
4837C<len> bytes long.
4838
4839=cut
4840*/
4841
9da1e3b5 4842SV *
864dbfa3 4843Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
9da1e3b5
MUN		 4844{
4845 register SV *sv;
4846
4847 new_SV(sv);
9da1e3b5
MUN		 4848 sv_setpvn(sv,s,len);
4849 return sv;
4850}
4851
1c846c1f
NIS		 4852/*
4853=for apidoc newSVpvn_share
4854
4855Creates a new SV and populates it with a string from
4856the string table. Turns on READONLY and FAKE.
4857The idea here is that as string table is used for shared hash
4858keys these strings will have SvPVX == HeKEY and hash lookup
4859will avoid string compare.
4860
4861=cut
4862*/
4863
4864SV *
4865Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
4866{
4867 register SV *sv;
4868 if (!hash)
4869 PERL_HASH(hash, src, len);
4870 new_SV(sv);
4871 sv_upgrade(sv, SVt_PVIV);
4872 SvPVX(sv) = sharepvn(src, len, hash);
4873 SvCUR(sv) = len;
4874 SvUVX(sv) = hash;
4875 SvLEN(sv) = 0;
4876 SvREADONLY_on(sv);
4877 SvFAKE_on(sv);
4878 SvPOK_on(sv);
4879 return sv;
4880}
4881
cea2e8a9 4882#if defined(PERL_IMPLICIT_CONTEXT)
46fc3d4c 4883SV *
cea2e8a9 4884Perl_newSVpvf_nocontext(const char* pat, ...)
46fc3d4c 4885{
cea2e8a9 4886 dTHX;
46fc3d4c 4887 register SV *sv;
4888 va_list args;
46fc3d4c 4889 va_start(args, pat);
c5be433b 4890 sv = vnewSVpvf(pat, &args);
46fc3d4c 4891 va_end(args);
4892 return sv;
4893}
cea2e8a9 4894#endif
46fc3d4c 4895
954c1994
GS		 4896/*
4897=for apidoc newSVpvf
4898
4899Creates a new SV an initialize it with the string formatted like
4900C<sprintf>.
4901
4902=cut
4903*/
4904
cea2e8a9
GS		 4905SV *
4906Perl_newSVpvf(pTHX_ const char* pat, ...)
4907{
4908 register SV *sv;
4909 va_list args;
cea2e8a9 4910 va_start(args, pat);
c5be433b 4911 sv = vnewSVpvf(pat, &args);
cea2e8a9
GS		 4912 va_end(args);
4913 return sv;
4914}
46fc3d4c 4915
79072805 4916SV *
c5be433b
GS		 4917Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4918{
4919 register SV *sv;
4920 new_SV(sv);
4921 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4922 return sv;
4923}
4924
954c1994
GS		 4925/*
4926=for apidoc newSVnv
4927
4928Creates a new SV and copies a floating point value into it.
4929The reference count for the SV is set to 1.
4930
4931=cut
4932*/
4933
c5be433b 4934SV *
65202027 4935Perl_newSVnv(pTHX_ NV n)
79072805 4936{
463ee0b2 4937 register SV *sv;
79072805 4938
4561caa4 4939 new_SV(sv);
79072805
LW		 4940 sv_setnv(sv,n);
4941 return sv;
4942}
4943
954c1994
GS		 4944/*
4945=for apidoc newSViv
4946
4947Creates a new SV and copies an integer into it. The reference count for the
4948SV is set to 1.
4949
4950=cut
4951*/
4952
79072805 4953SV *
864dbfa3 4954Perl_newSViv(pTHX_ IV i)
79072805 4955{
463ee0b2 4956 register SV *sv;
79072805 4957
4561caa4 4958 new_SV(sv);
79072805
LW		 4959 sv_setiv(sv,i);
4960 return sv;
4961}
4962
954c1994 4963/*
1a3327fb
JH		 4964=for apidoc newSVuv
4965
4966Creates a new SV and copies an unsigned integer into it.
4967The reference count for the SV is set to 1.
4968
4969=cut
4970*/
4971
4972SV *
4973Perl_newSVuv(pTHX_ UV u)
4974{
4975 register SV *sv;
4976
4977 new_SV(sv);
4978 sv_setuv(sv,u);
4979 return sv;
4980}
4981
4982/*
954c1994
GS		 4983=for apidoc newRV_noinc
4984
4985Creates an RV wrapper for an SV. The reference count for the original
4986SV is B<not> incremented.
4987
4988=cut
4989*/
4990
2304df62 4991SV *
864dbfa3 4992Perl_newRV_noinc(pTHX_ SV *tmpRef)
2304df62
AD		 4993{
4994 register SV *sv;
4995
4561caa4 4996 new_SV(sv);
2304df62 4997 sv_upgrade(sv, SVt_RV);
76e3520e 4998 SvTEMP_off(tmpRef);
d689ffdd 4999 SvRV(sv) = tmpRef;
2304df62 5000 SvROK_on(sv);
2304df62
AD		 5001 return sv;
5002}
5003
954c1994 5004/* newRV_inc is #defined to newRV in sv.h */
5f05dabc 5005SV *
864dbfa3 5006Perl_newRV(pTHX_ SV *tmpRef)
5f05dabc 5007{
5f6447b6 5008 return newRV_noinc(SvREFCNT_inc(tmpRef));
5f05dabc 5009}
5f05dabc 5010
954c1994
GS		 5011/*
5012=for apidoc newSVsv
5013
5014Creates a new SV which is an exact duplicate of the original SV.
5015
5016=cut
5017*/
5018
79072805
LW		 5019/* make an exact duplicate of old */
5020
5021SV *
864dbfa3 5022Perl_newSVsv(pTHX_ register SV *old)
79072805 5023{
463ee0b2 5024 register SV *sv;
79072805
LW		 5025
5026 if (!old)
5027 return Nullsv;
8990e307 5028 if (SvTYPE(old) == SVTYPEMASK) {
0453d815
PM		 5029 if (ckWARN_d(WARN_INTERNAL))
5030 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
79072805
LW		 5031 return Nullsv;
5032 }
4561caa4 5033 new_SV(sv);
ff68c719 5034 if (SvTEMP(old)) {
5035 SvTEMP_off(old);
463ee0b2 5036 sv_setsv(sv,old);
ff68c719 5037 SvTEMP_on(old);
79072805
LW		 5038 }
5039 else
463ee0b2
LW		 5040 sv_setsv(sv,old);
5041 return sv;
79072805
LW		 5042}
5043
5044void
864dbfa3 5045Perl_sv_reset(pTHX_ register char *s, HV *stash)
79072805
LW		 5046{
5047 register HE *entry;
5048 register GV *gv;
5049 register SV *sv;
5050 register I32 i;
5051 register PMOP *pm;
5052 register I32 max;
4802d5d7 5053 char todo[PERL_UCHAR_MAX+1];
79072805 5054
49d8d3a1
MB		 5055 if (!stash)
5056 return;
5057
79072805
LW		 5058 if (!*s) { /* reset ?? searches */
5059 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
48c036b1 5060 pm->op_pmdynflags &= ~PMdf_USED;
79072805
LW		 5061 }
5062 return;
5063 }
5064
5065 /* reset variables */
5066
5067 if (!HvARRAY(stash))
5068 return;
463ee0b2
LW		 5069
5070 Zero(todo, 256, char);
79072805 5071 while (*s) {
4802d5d7 5072 i = (unsigned char)*s;
79072805
LW		 5073 if (s[1] == '-') {
5074 s += 2;
5075 }
4802d5d7 5076 max = (unsigned char)*s++;
79072805 5077 for ( ; i <= max; i++) {
463ee0b2
LW		 5078 todo[i] = 1;
5079 }
a0d0e21e 5080 for (i = 0; i <= (I32) HvMAX(stash); i++) {
79072805 5081 for (entry = HvARRAY(stash)[i];
9e35f4b3
GS		 5082 entry;
5083 entry = HeNEXT(entry))
5084 {
1edc1566 5085 if (!todo[(U8)*HeKEY(entry)])
463ee0b2 5086 continue;
1edc1566 5087 gv = (GV*)HeVAL(entry);
79072805 5088 sv = GvSV(gv);
9e35f4b3
GS		 5089 if (SvTHINKFIRST(sv)) {
5090 if (!SvREADONLY(sv) && SvROK(sv))
5091 sv_unref(sv);
5092 continue;
5093 }
a0d0e21e 5094 (void)SvOK_off(sv);
79072805
LW		 5095 if (SvTYPE(sv) >= SVt_PV) {
5096 SvCUR_set(sv, 0);
463ee0b2
LW		 5097 if (SvPVX(sv) != Nullch)
5098 *SvPVX(sv) = '\0';
44a8e56a 5099 SvTAINT(sv);
79072805
LW		 5100 }
5101 if (GvAV(gv)) {
5102 av_clear(GvAV(gv));
5103 }
44a8e56a 5104 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
463ee0b2 5105 hv_clear(GvHV(gv));
fa6a1c44 5106#ifdef USE_ENVIRON_ARRAY
3280af22 5107 if (gv == PL_envgv)
79072805 5108 environ[0] = Nullch;
a0d0e21e 5109#endif
79072805
LW		 5110 }
5111 }
5112 }
5113 }
5114}
5115
46fc3d4c 5116IO*
864dbfa3 5117Perl_sv_2io(pTHX_ SV *sv)
46fc3d4c 5118{
5119 IO* io;
5120 GV* gv;
2d8e6c8d 5121 STRLEN n_a;
46fc3d4c 5122
5123 switch (SvTYPE(sv)) {
5124 case SVt_PVIO:
5125 io = (IO*)sv;
5126 break;
5127 case SVt_PVGV:
5128 gv = (GV*)sv;
5129 io = GvIO(gv);
5130 if (!io)
cea2e8a9 5131 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
46fc3d4c 5132 break;
5133 default:
5134 if (!SvOK(sv))
cea2e8a9 5135 Perl_croak(aTHX_ PL_no_usym, "filehandle");
46fc3d4c 5136 if (SvROK(sv))
5137 return sv_2io(SvRV(sv));
2d8e6c8d 5138 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
46fc3d4c 5139 if (gv)
5140 io = GvIO(gv);
5141 else
5142 io = 0;
5143 if (!io)
cea2e8a9 5144 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
46fc3d4c 5145 break;
5146 }
5147 return io;
5148}
5149
79072805 5150CV *
864dbfa3 5151Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
79072805
LW		 5152{
5153 GV *gv;
5154 CV *cv;
2d8e6c8d 5155 STRLEN n_a;
79072805
LW		 5156
5157 if (!sv)
93a17b20 5158 return *gvp = Nullgv, Nullcv;
79072805 5159 switch (SvTYPE(sv)) {
79072805
LW		 5160 case SVt_PVCV:
5161 *st = CvSTASH(sv);
5162 *gvp = Nullgv;
5163 return (CV*)sv;
5164 case SVt_PVHV:
5165 case SVt_PVAV:
5166 *gvp = Nullgv;
5167 return Nullcv;
8990e307
LW		 5168 case SVt_PVGV:
5169 gv = (GV*)sv;
a0d0e21e 5170 *gvp = gv;
8990e307
LW		 5171 *st = GvESTASH(gv);
5172 goto fix_gv;
5173
79072805 5174 default:
a0d0e21e
LW		 5175 if (SvGMAGICAL(sv))
5176 mg_get(sv);
5177 if (SvROK(sv)) {
f5284f61
IZ		 5178 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5179 tryAMAGICunDEREF(to_cv);
5180
62f274bf
GS		 5181 sv = SvRV(sv);
5182 if (SvTYPE(sv) == SVt_PVCV) {
5183 cv = (CV*)sv;
5184 *gvp = Nullgv;
5185 *st = CvSTASH(cv);
5186 return cv;
5187 }
5188 else if(isGV(sv))
5189 gv = (GV*)sv;
5190 else
cea2e8a9 5191 Perl_croak(aTHX_ "Not a subroutine reference");
a0d0e21e 5192 }
62f274bf 5193 else if (isGV(sv))
79072805
LW		 5194 gv = (GV*)sv;
5195 else
2d8e6c8d 5196 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
79072805
LW		 5197 *gvp = gv;
5198 if (!gv)
5199 return Nullcv;
5200 *st = GvESTASH(gv);
8990e307 5201 fix_gv:
8ebc5c01 5202 if (lref && !GvCVu(gv)) {
4633a7c4 5203 SV *tmpsv;
748a9306 5204 ENTER;
4633a7c4 5205 tmpsv = NEWSV(704,0);
16660edb 5206 gv_efullname3(tmpsv, gv, Nullch);
f6ec51f7
GS		 5207 /* XXX this is probably not what they think they're getting.
5208 * It has the same effect as "sub name;", i.e. just a forward
5209 * declaration! */
774d564b 5210 newSUB(start_subparse(FALSE, 0),
4633a7c4
LW		 5211 newSVOP(OP_CONST, 0, tmpsv),
5212 Nullop,
8990e307 5213 Nullop);
748a9306 5214 LEAVE;
8ebc5c01 5215 if (!GvCVu(gv))
cea2e8a9 5216 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
8990e307 5217 }
8ebc5c01 5218 return GvCVu(gv);
79072805
LW		 5219 }
5220}
5221
c461cf8f
JH		 5222/*
5223=for apidoc sv_true
5224
5225Returns true if the SV has a true value by Perl's rules.
5226
5227=cut
5228*/
5229
79072805 5230I32
864dbfa3 5231Perl_sv_true(pTHX_ register SV *sv)
79072805 5232{
8990e307
LW		 5233 if (!sv)
5234 return 0;
79072805 5235 if (SvPOK(sv)) {
4e35701f
NIS		 5236 register XPV* tXpv;
5237 if ((tXpv = (XPV*)SvANY(sv)) &&
c2f1de04 5238 (tXpv->xpv_cur > 1 ||
4e35701f 5239 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
79072805
LW		 5240 return 1;
5241 else
5242 return 0;
5243 }
5244 else {
5245 if (SvIOK(sv))
463ee0b2 5246 return SvIVX(sv) != 0;
79072805
LW		 5247 else {
5248 if (SvNOK(sv))
463ee0b2 5249 return SvNVX(sv) != 0.0;
79072805 5250 else
463ee0b2 5251 return sv_2bool(sv);
79072805
LW		 5252 }
5253 }
5254}
79072805 5255
ff68c719 5256IV
864dbfa3 5257Perl_sv_iv(pTHX_ register SV *sv)
85e6fe83 5258{
25da4f38
IZ		 5259 if (SvIOK(sv)) {
5260 if (SvIsUV(sv))
5261 return (IV)SvUVX(sv);
ff68c719 5262 return SvIVX(sv);
25da4f38 5263 }
ff68c719 5264 return sv_2iv(sv);
85e6fe83 5265}
85e6fe83 5266
ff68c719 5267UV
864dbfa3 5268Perl_sv_uv(pTHX_ register SV *sv)
ff68c719 5269{
25da4f38
IZ		 5270 if (SvIOK(sv)) {
5271 if (SvIsUV(sv))
5272 return SvUVX(sv);
5273 return (UV)SvIVX(sv);
5274 }
ff68c719 5275 return sv_2uv(sv);
5276}
85e6fe83 5277
65202027 5278NV
864dbfa3 5279Perl_sv_nv(pTHX_ register SV *sv)
79072805 5280{
ff68c719 5281 if (SvNOK(sv))
5282 return SvNVX(sv);
5283 return sv_2nv(sv);
79072805 5284}
79072805 5285
79072805 5286char *
864dbfa3 5287Perl_sv_pv(pTHX_ SV *sv)
1fa8b10d
JD		 5288{
5289 STRLEN n_a;
5290
5291 if (SvPOK(sv))
5292 return SvPVX(sv);
5293
5294 return sv_2pv(sv, &n_a);
5295}
5296
5297char *
864dbfa3 5298Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
79072805 5299{
85e6fe83
LW		 5300 if (SvPOK(sv)) {
5301 *lp = SvCUR(sv);
a0d0e21e 5302 return SvPVX(sv);
85e6fe83 5303 }
463ee0b2 5304 return sv_2pv(sv, lp);
79072805 5305}
79072805 5306
c461cf8f
JH		 5307/*
5308=for apidoc sv_pvn_force
5309
5310Get a sensible string out of the SV somehow.
5311
5312=cut
5313*/
5314
a0d0e21e 5315char *
864dbfa3 5316Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
a0d0e21e
LW		 5317{
5318 char *s;
5319
6fc92669
GS		 5320 if (SvTHINKFIRST(sv) && !SvROK(sv))
5321 sv_force_normal(sv);
1c846c1f 5322
a0d0e21e
LW		 5323 if (SvPOK(sv)) {
5324 *lp = SvCUR(sv);
5325 }
5326 else {
748a9306 5327 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
cea2e8a9 5328 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6fc92669 5329 PL_op_name[PL_op->op_type]);
a0d0e21e 5330 }
4633a7c4
LW		 5331 else
5332 s = sv_2pv(sv, lp);
a0d0e21e
LW		 5333 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5334 STRLEN len = *lp;
1c846c1f 5335
a0d0e21e
LW		 5336 if (SvROK(sv))
5337 sv_unref(sv);
5338 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5339 SvGROW(sv, len + 1);
5340 Move(s,SvPVX(sv),len,char);
5341 SvCUR_set(sv, len);
5342 *SvEND(sv) = '\0';
5343 }
5344 if (!SvPOK(sv)) {
5345 SvPOK_on(sv); /* validate pointer */
5346 SvTAINT(sv);
1d7c1841
GS		 5347 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5348 PTR2UV(sv),SvPVX(sv)));
a0d0e21e
LW		 5349 }
5350 }
5351 return SvPVX(sv);
5352}
5353
5354char *
7340a771
GS		 5355Perl_sv_pvbyte(pTHX_ SV *sv)
5356{
5357 return sv_pv(sv);
5358}
5359
5360char *
5361Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5362{
5363 return sv_pvn(sv,lp);
5364}
5365
5366char *
5367Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5368{
5369 return sv_pvn_force(sv,lp);
5370}
5371
5372char *
5373Perl_sv_pvutf8(pTHX_ SV *sv)
5374{
560a288e 5375 sv_utf8_upgrade(sv);
7340a771
GS		 5376 return sv_pv(sv);
5377}
5378
5379char *
5380Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5381{
560a288e 5382 sv_utf8_upgrade(sv);
7340a771
GS		 5383 return sv_pvn(sv,lp);
5384}
5385
c461cf8f
JH		 5386/*
5387=for apidoc sv_pvutf8n_force
5388
5389Get a sensible UTF8-encoded string out of the SV somehow. See
5390L</sv_pvn_force>.
5391
5392=cut
5393*/
5394
7340a771
GS		 5395char *
5396Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5397{
560a288e 5398 sv_utf8_upgrade(sv);
7340a771
GS		 5399 return sv_pvn_force(sv,lp);
5400}
5401
c461cf8f
JH		 5402/*
5403=for apidoc sv_reftype
5404
5405Returns a string describing what the SV is a reference to.
5406
5407=cut
5408*/
5409
7340a771 5410char *
864dbfa3 5411Perl_sv_reftype(pTHX_ SV *sv, int ob)
a0d0e21e
LW		 5412{
5413 if (ob && SvOBJECT(sv))
5414 return HvNAME(SvSTASH(sv));
5415 else {
5416 switch (SvTYPE(sv)) {
5417 case SVt_NULL:
5418 case SVt_IV:
5419 case SVt_NV:
5420 case SVt_RV:
5421 case SVt_PV:
5422 case SVt_PVIV:
5423 case SVt_PVNV:
5424 case SVt_PVMG:
5425 case SVt_PVBM:
5426 if (SvROK(sv))
5427 return "REF";
5428 else
5429 return "SCALAR";
5430 case SVt_PVLV: return "LVALUE";
5431 case SVt_PVAV: return "ARRAY";
5432 case SVt_PVHV: return "HASH";
5433 case SVt_PVCV: return "CODE";
5434 case SVt_PVGV: return "GLOB";
1d2dff63 5435 case SVt_PVFM: return "FORMAT";
27f9d8f3 5436 case SVt_PVIO: return "IO";
a0d0e21e
LW		 5437 default: return "UNKNOWN";
5438 }
5439 }
5440}
5441
954c1994
GS		 5442/*
5443=for apidoc sv_isobject
5444
5445Returns a boolean indicating whether the SV is an RV pointing to a blessed
5446object. If the SV is not an RV, or if the object is not blessed, then this
5447will return false.
5448
5449=cut
5450*/
5451
463ee0b2 5452int
864dbfa3 5453Perl_sv_isobject(pTHX_ SV *sv)
85e6fe83 5454{
68dc0745 5455 if (!sv)
5456 return 0;
5457 if (SvGMAGICAL(sv))
5458 mg_get(sv);
85e6fe83
LW		 5459 if (!SvROK(sv))
5460 return 0;
5461 sv = (SV*)SvRV(sv);
5462 if (!SvOBJECT(sv))
5463 return 0;
5464 return 1;
5465}
5466
954c1994
GS		 5467/*
5468=for apidoc sv_isa
5469
5470Returns a boolean indicating whether the SV is blessed into the specified
5471class. This does not check for subtypes; use C<sv_derived_from> to verify
5472an inheritance relationship.
5473
5474=cut
5475*/
5476
85e6fe83 5477int
864dbfa3 5478Perl_sv_isa(pTHX_ SV *sv, const char *name)
463ee0b2 5479{
68dc0745 5480 if (!sv)
5481 return 0;
5482 if (SvGMAGICAL(sv))
5483 mg_get(sv);
ed6116ce 5484 if (!SvROK(sv))
463ee0b2 5485 return 0;
ed6116ce
LW		 5486 sv = (SV*)SvRV(sv);
5487 if (!SvOBJECT(sv))
463ee0b2
LW		 5488 return 0;
5489
5490 return strEQ(HvNAME(SvSTASH(sv)), name);
5491}
5492
954c1994
GS		 5493/*
5494=for apidoc newSVrv
5495
5496Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5497it will be upgraded to one. If C<classname> is non-null then the new SV will
5498be blessed in the specified package. The new SV is returned and its
5499reference count is 1.
5500
5501=cut
5502*/
5503
463ee0b2 5504SV*
864dbfa3 5505Perl_newSVrv(pTHX_ SV *rv, const char *classname)
463ee0b2 5506{
463ee0b2
LW		 5507 SV *sv;
5508
4561caa4 5509 new_SV(sv);
51cf62d8 5510
2213622d 5511 SV_CHECK_THINKFIRST(rv);
51cf62d8 5512 SvAMAGIC_off(rv);
51cf62d8 5513
0199fce9
JD		 5514 if (SvTYPE(rv) >= SVt_PVMG) {
5515 U32 refcnt = SvREFCNT(rv);
5516 SvREFCNT(rv) = 0;
5517 sv_clear(rv);
5518 SvFLAGS(rv) = 0;
5519 SvREFCNT(rv) = refcnt;
5520 }
5521
51cf62d8 5522 if (SvTYPE(rv) < SVt_RV)
0199fce9
JD		 5523 sv_upgrade(rv, SVt_RV);
5524 else if (SvTYPE(rv) > SVt_RV) {
5525 (void)SvOOK_off(rv);
5526 if (SvPVX(rv) && SvLEN(rv))
5527 Safefree(SvPVX(rv));
5528 SvCUR_set(rv, 0);
5529 SvLEN_set(rv, 0);
5530 }
51cf62d8
OT		 5531
5532 (void)SvOK_off(rv);
053fc874 5533 SvRV(rv) = sv;
ed6116ce 5534 SvROK_on(rv);
463ee0b2 5535
a0d0e21e
LW		 5536 if (classname) {
5537 HV* stash = gv_stashpv(classname, TRUE);
5538 (void)sv_bless(rv, stash);
5539 }
5540 return sv;
5541}
5542
954c1994
GS		 5543/*
5544=for apidoc sv_setref_pv
5545
5546Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5547argument will be upgraded to an RV. That RV will be modified to point to
5548the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5549into the SV. The C<classname> argument indicates the package for the
5550blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5551will be returned and will have a reference count of 1.
5552
5553Do not use with other Perl types such as HV, AV, SV, CV, because those
5554objects will become corrupted by the pointer copy process.
5555
5556Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5557
5558=cut
5559*/
5560
a0d0e21e 5561SV*
864dbfa3 5562Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
a0d0e21e 5563{
189b2af5 5564 if (!pv) {
3280af22 5565 sv_setsv(rv, &PL_sv_undef);
189b2af5
GS		 5566 SvSETMAGIC(rv);
5567 }
a0d0e21e 5568 else
56431972 5569 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
a0d0e21e
LW		 5570 return rv;
5571}
5572
954c1994
GS		 5573/*
5574=for apidoc sv_setref_iv
5575
5576Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5577argument will be upgraded to an RV. That RV will be modified to point to
5578the new SV. The C<classname> argument indicates the package for the
5579blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5580will be returned and will have a reference count of 1.
5581
5582=cut
5583*/
5584
a0d0e21e 5585SV*
864dbfa3 5586Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
a0d0e21e
LW		 5587{
5588 sv_setiv(newSVrv(rv,classname), iv);
5589 return rv;
5590}
5591
954c1994
GS		 5592/*
5593=for apidoc sv_setref_nv
5594
5595Copies a double into a new SV, optionally blessing the SV. The C<rv>
5596argument will be upgraded to an RV. That RV will be modified to point to
5597the new SV. The C<classname> argument indicates the package for the
5598blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5599will be returned and will have a reference count of 1.
5600
5601=cut
5602*/
5603
a0d0e21e 5604SV*
65202027 5605Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
a0d0e21e
LW		 5606{
5607 sv_setnv(newSVrv(rv,classname), nv);
5608 return rv;
5609}
463ee0b2 5610
954c1994
GS		 5611/*
5612=for apidoc sv_setref_pvn
5613
5614Copies a string into a new SV, optionally blessing the SV. The length of the
5615string must be specified with C<n>. The C<rv> argument will be upgraded to
5616an RV. That RV will be modified to point to the new SV. The C<classname>
5617argument indicates the package for the blessing. Set C<classname> to
5618C<Nullch> to avoid the blessing. The new SV will be returned and will have
5619a reference count of 1.
5620
5621Note that C<sv_setref_pv> copies the pointer while this copies the string.
5622
5623=cut
5624*/
5625
a0d0e21e 5626SV*
864dbfa3 5627Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
a0d0e21e
LW		 5628{
5629 sv_setpvn(newSVrv(rv,classname), pv, n);
463ee0b2
LW		 5630 return rv;
5631}
5632
954c1994
GS		 5633/*
5634=for apidoc sv_bless
5635
5636Blesses an SV into a specified package. The SV must be an RV. The package
5637must be designated by its stash (see C<gv_stashpv()>). The reference count
5638of the SV is unaffected.
5639
5640=cut
5641*/
5642
a0d0e21e 5643SV*
864dbfa3 5644Perl_sv_bless(pTHX_ SV *sv, HV *stash)
a0d0e21e 5645{
76e3520e 5646 SV *tmpRef;
a0d0e21e 5647 if (!SvROK(sv))
cea2e8a9 5648 Perl_croak(aTHX_ "Can't bless non-reference value");
76e3520e
GS		 5649 tmpRef = SvRV(sv);
5650 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5651 if (SvREADONLY(tmpRef))
cea2e8a9 5652 Perl_croak(aTHX_ PL_no_modify);
76e3520e
GS		 5653 if (SvOBJECT(tmpRef)) {
5654 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 5655 --PL_sv_objcount;
76e3520e 5656 SvREFCNT_dec(SvSTASH(tmpRef));
2e3febc6 5657 }
a0d0e21e 5658 }
76e3520e
GS		 5659 SvOBJECT_on(tmpRef);
5660 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 5661 ++PL_sv_objcount;
76e3520e
GS		 5662 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5663 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 5664
2e3febc6
CS		 5665 if (Gv_AMG(stash))
5666 SvAMAGIC_on(sv);
5667 else
5668 SvAMAGIC_off(sv);
a0d0e21e
LW		 5669
5670 return sv;
5671}
5672
76e3520e 5673STATIC void
cea2e8a9 5674S_sv_unglob(pTHX_ SV *sv)
a0d0e21e 5675{
850fabdf
GS		 5676 void *xpvmg;
5677
a0d0e21e
LW		 5678 assert(SvTYPE(sv) == SVt_PVGV);
5679 SvFAKE_off(sv);
5680 if (GvGP(sv))
1edc1566 5681 gp_free((GV*)sv);
e826b3c7
GS		 5682 if (GvSTASH(sv)) {
5683 SvREFCNT_dec(GvSTASH(sv));
5684 GvSTASH(sv) = Nullhv;
5685 }
a0d0e21e
LW		 5686 sv_unmagic(sv, '*');
5687 Safefree(GvNAME(sv));
a5f75d66 5688 GvMULTI_off(sv);
850fabdf
GS		 5689
5690 /* need to keep SvANY(sv) in the right arena */
5691 xpvmg = new_XPVMG();
5692 StructCopy(SvANY(sv), xpvmg, XPVMG);
5693 del_XPVGV(SvANY(sv));
5694 SvANY(sv) = xpvmg;
5695
a0d0e21e
LW		 5696 SvFLAGS(sv) &= ~SVTYPEMASK;
5697 SvFLAGS(sv) |= SVt_PVMG;
5698}
5699
954c1994 5700/*
840a7b70 5701=for apidoc sv_unref_flags
954c1994
GS		 5702
5703Unsets the RV status of the SV, and decrements the reference count of
5704whatever was being referenced by the RV. This can almost be thought of
840a7b70
IZ		 5705as a reversal of C<newSVrv>. The C<cflags> argument can contain
5706C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
5707(otherwise the decrementing is conditional on the reference count being
5708different from one or the reference being a readonly SV).
5709See C<SvROK_off>.
954c1994
GS		 5710
5711=cut
5712*/
5713
ed6116ce 5714void
840a7b70 5715Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
ed6116ce 5716{
a0d0e21e 5717 SV* rv = SvRV(sv);
810b8aa5
GS		 5718
5719 if (SvWEAKREF(sv)) {
5720 sv_del_backref(sv);
5721 SvWEAKREF_off(sv);
5722 SvRV(sv) = 0;
5723 return;
5724 }
ed6116ce
LW		 5725 SvRV(sv) = 0;
5726 SvROK_off(sv);
840a7b70 5727 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
4633a7c4 5728 SvREFCNT_dec(rv);
840a7b70 5729 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
4633a7c4 5730 sv_2mortal(rv); /* Schedule for freeing later */
ed6116ce 5731}
8990e307 5732
840a7b70
IZ		 5733/*
5734=for apidoc sv_unref
5735
5736Unsets the RV status of the SV, and decrements the reference count of
5737whatever was being referenced by the RV. This can almost be thought of
5738as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
5739being zero. See C<SvROK_off>.
5740
5741=cut
5742*/
5743
5744void
5745Perl_sv_unref(pTHX_ SV *sv)
5746{
5747 sv_unref_flags(sv, 0);
5748}
5749
bbce6d69 5750void
864dbfa3 5751Perl_sv_taint(pTHX_ SV *sv)
bbce6d69 5752{
5753 sv_magic((sv), Nullsv, 't', Nullch, 0);
5754}
5755
5756void
864dbfa3 5757Perl_sv_untaint(pTHX_ SV *sv)
bbce6d69 5758{
13f57bf8 5759 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
36477c24 5760 MAGIC *mg = mg_find(sv, 't');
5761 if (mg)
565764a8 5762 mg->mg_len &= ~1;
36477c24 5763 }
bbce6d69 5764}
5765
5766bool
864dbfa3 5767Perl_sv_tainted(pTHX_ SV *sv)
bbce6d69 5768{
13f57bf8 5769 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
36477c24 5770 MAGIC *mg = mg_find(sv, 't');
155aba94 5771 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
36477c24 5772 return TRUE;
5773 }
5774 return FALSE;
bbce6d69 5775}
5776
954c1994
GS		 5777/*
5778=for apidoc sv_setpviv
5779
5780Copies an integer into the given SV, also updating its string value.
5781Does not handle 'set' magic. See C<sv_setpviv_mg>.
5782
5783=cut
5784*/
5785
84902520 5786void
864dbfa3 5787Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
84902520 5788{
25da4f38
IZ		 5789 char buf[TYPE_CHARS(UV)];
5790 char *ebuf;
5791 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
84902520 5792
25da4f38 5793 sv_setpvn(sv, ptr, ebuf - ptr);
84902520
TB		 5794}
5795
ef50df4b 5796
954c1994
GS		 5797/*
5798=for apidoc sv_setpviv_mg
5799
5800Like C<sv_setpviv>, but also handles 'set' magic.
5801
5802=cut
5803*/
5804
ef50df4b 5805void
864dbfa3 5806Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
ef50df4b 5807{
25da4f38
IZ		 5808 char buf[TYPE_CHARS(UV)];
5809 char *ebuf;
5810 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5811
5812 sv_setpvn(sv, ptr, ebuf - ptr);
ef50df4b
GS		 5813 SvSETMAGIC(sv);
5814}
5815
cea2e8a9
GS		 5816#if defined(PERL_IMPLICIT_CONTEXT)
5817void
5818Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5819{
5820 dTHX;
5821 va_list args;
5822 va_start(args, pat);
c5be433b 5823 sv_vsetpvf(sv, pat, &args);
cea2e8a9
GS		 5824 va_end(args);
5825}
5826
5827
5828void
5829Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5830{
5831 dTHX;
5832 va_list args;
5833 va_start(args, pat);
c5be433b 5834 sv_vsetpvf_mg(sv, pat, &args);
cea2e8a9 5835 va_end(args);
cea2e8a9
GS		 5836}
5837#endif
5838
954c1994
GS		 5839/*
5840=for apidoc sv_setpvf
5841
5842Processes its arguments like C<sprintf> and sets an SV to the formatted
5843output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5844
5845=cut
5846*/
5847
46fc3d4c 5848void
864dbfa3 5849Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 5850{
5851 va_list args;
46fc3d4c 5852 va_start(args, pat);
c5be433b 5853 sv_vsetpvf(sv, pat, &args);
46fc3d4c 5854 va_end(args);
5855}
5856
c5be433b
GS		 5857void
5858Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5859{
5860 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5861}
ef50df4b 5862
954c1994
GS		 5863/*
5864=for apidoc sv_setpvf_mg
5865
5866Like C<sv_setpvf>, but also handles 'set' magic.
5867
5868=cut
5869*/
5870
ef50df4b 5871void
864dbfa3 5872Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 5873{
5874 va_list args;
ef50df4b 5875 va_start(args, pat);
c5be433b 5876 sv_vsetpvf_mg(sv, pat, &args);
ef50df4b 5877 va_end(args);
c5be433b
GS		 5878}
5879
5880void
5881Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5882{
5883 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 5884 SvSETMAGIC(sv);
5885}
5886
cea2e8a9
GS		 5887#if defined(PERL_IMPLICIT_CONTEXT)
5888void
5889Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5890{
5891 dTHX;
5892 va_list args;
5893 va_start(args, pat);
c5be433b 5894 sv_vcatpvf(sv, pat, &args);
cea2e8a9
GS		 5895 va_end(args);
5896}
5897
5898void
5899Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5900{
5901 dTHX;
5902 va_list args;
5903 va_start(args, pat);
c5be433b 5904 sv_vcatpvf_mg(sv, pat, &args);
cea2e8a9 5905 va_end(args);
cea2e8a9
GS		 5906}
5907#endif
5908
954c1994
GS		 5909/*
5910=for apidoc sv_catpvf
5911
5912Processes its arguments like C<sprintf> and appends the formatted output
5913to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5914typically be called after calling this function to handle 'set' magic.
5915
5916=cut
5917*/
5918
46fc3d4c 5919void
864dbfa3 5920Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 5921{
5922 va_list args;
46fc3d4c 5923 va_start(args, pat);
c5be433b 5924 sv_vcatpvf(sv, pat, &args);
46fc3d4c 5925 va_end(args);
5926}
5927
ef50df4b 5928void
c5be433b
GS		 5929Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5930{
5931 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5932}
5933
954c1994
GS		 5934/*
5935=for apidoc sv_catpvf_mg
5936
5937Like C<sv_catpvf>, but also handles 'set' magic.
5938
5939=cut
5940*/
5941
c5be433b 5942void
864dbfa3 5943Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 5944{
5945 va_list args;
ef50df4b 5946 va_start(args, pat);
c5be433b 5947 sv_vcatpvf_mg(sv, pat, &args);
ef50df4b 5948 va_end(args);
c5be433b
GS		 5949}
5950
5951void
5952Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5953{
5954 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 5955 SvSETMAGIC(sv);
5956}
5957
954c1994
GS		 5958/*
5959=for apidoc sv_vsetpvfn
5960
5961Works like C<vcatpvfn> but copies the text into the SV instead of
5962appending it.
5963
5964=cut
5965*/
5966
46fc3d4c 5967void
7d5ea4e7 5968Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 5969{
5970 sv_setpvn(sv, "", 0);
7d5ea4e7 5971 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
46fc3d4c 5972}
5973
954c1994
GS		 5974/*
5975=for apidoc sv_vcatpvfn
5976
5977Processes its arguments like C<vsprintf> and appends the formatted output
5978to an SV. Uses an array of SVs if the C style variable argument list is
5979missing (NULL). When running with taint checks enabled, indicates via
5980C<maybe_tainted> if results are untrustworthy (often due to the use of
5981locales).
5982
5983=cut
5984*/
5985
46fc3d4c 5986void
7d5ea4e7 5987Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 5988{
5989 char *p;
5990 char *q;
5991 char *patend;
fc36a67e 5992 STRLEN origlen;
46fc3d4c 5993 I32 svix = 0;
c635e13b 5994 static char nullstr[] = "(null)";
7e2040f0 5995 SV *argsv;
46fc3d4c 5996
5997 /* no matter what, this is a string now */
fc36a67e 5998 (void)SvPV_force(sv, origlen);
46fc3d4c 5999
fc36a67e 6000 /* special-case "", "%s", and "%_" */
46fc3d4c 6001 if (patlen == 0)
6002 return;
fc36a67e 6003 if (patlen == 2 && pat[0] == '%') {
6004 switch (pat[1]) {
6005 case 's':
c635e13b 6006 if (args) {
6007 char *s = va_arg(*args, char*);
6008 sv_catpv(sv, s ? s : nullstr);
6009 }
7e2040f0 6010 else if (svix < svmax) {
fc36a67e 6011 sv_catsv(sv, *svargs);
7e2040f0
GS		 6012 if (DO_UTF8(*svargs))
6013 SvUTF8_on(sv);
6014 }
fc36a67e 6015 return;
6016 case '_':
6017 if (args) {
7e2040f0
GS		 6018 argsv = va_arg(*args, SV*);
6019 sv_catsv(sv, argsv);
6020 if (DO_UTF8(argsv))
6021 SvUTF8_on(sv);
fc36a67e 6022 return;
6023 }
6024 /* See comment on '_' below */
6025 break;
6026 }
46fc3d4c 6027 }
6028
6029 patend = (char*)pat + patlen;
6030 for (p = (char*)pat; p < patend; p = q) {
6031 bool alt = FALSE;
6032 bool left = FALSE;
b22c7a20
GS		 6033 bool vectorize = FALSE;
6034 bool utf = FALSE;
46fc3d4c 6035 char fill = ' ';
6036 char plus = 0;
6037 char intsize = 0;
6038 STRLEN width = 0;
fc36a67e 6039 STRLEN zeros = 0;
46fc3d4c 6040 bool has_precis = FALSE;
6041 STRLEN precis = 0;
7e2040f0 6042 bool is_utf = FALSE;
eb3fce90 6043
46fc3d4c 6044 char esignbuf[4];
ad391ad9 6045 U8 utf8buf[UTF8_MAXLEN+1];
46fc3d4c 6046 STRLEN esignlen = 0;
6047
6048 char *eptr = Nullch;
fc36a67e 6049 STRLEN elen = 0;
089c015b
JH		 6050 /* Times 4: a decimal digit takes more than 3 binary digits.
6051 * NV_DIG: mantissa takes than many decimal digits.
6052 * Plus 32: Playing safe. */
6053 char ebuf[IV_DIG * 4 + NV_DIG + 32];
2d4389e4
JH		 6054 /* large enough for "%#.#f" --chip */
6055 /* what about long double NVs? --jhi */
b22c7a20
GS		 6056
6057 SV *vecsv;
a05b299f 6058 U8 *vecstr = Null(U8*);
b22c7a20 6059 STRLEN veclen = 0;
46fc3d4c 6060 char c;
6061 int i;
6062 unsigned base;
6063 IV iv;
6064 UV uv;
65202027 6065 NV nv;
46fc3d4c 6066 STRLEN have;
6067 STRLEN need;
6068 STRLEN gap;
b22c7a20
GS		 6069 char *dotstr = ".";
6070 STRLEN dotstrlen = 1;
eb3fce90
JH		 6071 I32 epix = 0; /* explicit parameter index */
6072 I32 ewix = 0; /* explicit width index */
6073 bool asterisk = FALSE;
46fc3d4c 6074
6075 for (q = p; q < patend && *q != '%'; ++q) ;
6076 if (q > p) {
6077 sv_catpvn(sv, p, q - p);
6078 p = q;
6079 }
6080 if (q++ >= patend)
6081 break;
6082
fc36a67e 6083 /* FLAGS */
6084
46fc3d4c 6085 while (*q) {
6086 switch (*q) {
6087 case ' ':
6088 case '+':
6089 plus = *q++;
6090 continue;
6091
6092 case '-':
6093 left = TRUE;
6094 q++;
6095 continue;
6096
6097 case '0':
6098 fill = *q++;
6099 continue;
6100
6101 case '#':
6102 alt = TRUE;
6103 q++;
6104 continue;
6105
b22c7a20
GS		 6106 case '*': /* printf("%*vX",":",$ipv6addr) */
6107 if (q[1] != 'v')
6108 break;
6109 q++;
6110 if (args)
6111 vecsv = va_arg(*args, SV*);
6112 else if (svix < svmax)
6113 vecsv = svargs[svix++];
9c3dd3fe
GS		 6114 else
6115 continue;
b22c7a20
GS		 6116 dotstr = SvPVx(vecsv,dotstrlen);
6117 if (DO_UTF8(vecsv))
6118 is_utf = TRUE;
6119 /* FALL THROUGH */
6120
6121 case 'v':
6122 vectorize = TRUE;
6123 q++;
b22c7a20
GS		 6124 continue;
6125
fc36a67e 6126 default:
6127 break;
6128 }
6129 break;
6130 }
46fc3d4c 6131
fc36a67e 6132 /* WIDTH */
6133
eb3fce90
JH		 6134 scanwidth:
6135
6136 if (*q == '*') {
6137 if (asterisk)
6138 goto unknown;
6139 asterisk = TRUE;
6140 q++;
6141 }
6142
fc36a67e 6143 switch (*q) {
6144 case '1': case '2': case '3':
6145 case '4': case '5': case '6':
6146 case '7': case '8': case '9':
6147 width = 0;
6148 while (isDIGIT(*q))
6149 width = width * 10 + (*q++ - '0');
eb3fce90
JH		 6150 if (*q == '$') {
6151 if (asterisk && ewix == 0) {
6152 ewix = width;
6153 width = 0;
6154 q++;
6155 goto scanwidth;
6156 } else if (epix == 0) {
6157 epix = width;
6158 width = 0;
6159 q++;
6160 goto scanwidth;
6161 } else
6162 goto unknown;
6163 }
6164 }
fc36a67e 6165
eb3fce90 6166 if (asterisk) {
fc36a67e 6167 if (args)
6168 i = va_arg(*args, int);
6169 else
eb3fce90
JH		 6170 i = (ewix ? ewix <= svmax : svix < svmax) ?
6171 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
fc36a67e 6172 left |= (i < 0);
6173 width = (i < 0) ? -i : i;
fc36a67e 6174 }
6175
6176 /* PRECISION */
46fc3d4c 6177
fc36a67e 6178 if (*q == '.') {
6179 q++;
6180 if (*q == '*') {
46fc3d4c 6181 if (args)
6182 i = va_arg(*args, int);
6183 else
eb3fce90
JH		 6184 i = (ewix ? ewix <= svmax : svix < svmax)
6185 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
fc36a67e 6186 precis = (i < 0) ? 0 : i;
46fc3d4c 6187 q++;
fc36a67e 6188 }
6189 else {
6190 precis = 0;
6191 while (isDIGIT(*q))
6192 precis = precis * 10 + (*q++ - '0');
6193 }
6194 has_precis = TRUE;
6195 }
46fc3d4c 6196
bb2899ba
GS		 6197 if (vectorize) {
6198 if (args) {
6199 vecsv = va_arg(*args, SV*);
6200 vecstr = (U8*)SvPVx(vecsv,veclen);
6201 utf = DO_UTF8(vecsv);
6202 }
eb3fce90
JH		 6203 else if (epix ? epix <= svmax : svix < svmax) {
6204 vecsv = svargs[epix ? epix-1 : svix++];
bb2899ba
GS		 6205 vecstr = (U8*)SvPVx(vecsv,veclen);
6206 utf = DO_UTF8(vecsv);
6207 }
6208 else {
6209 vecstr = (U8*)"";
6210 veclen = 0;
6211 }
6212 }
6213
fc36a67e 6214 /* SIZE */
46fc3d4c 6215
fc36a67e 6216 switch (*q) {
e5c81feb 6217#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6f9bb7fd 6218 case 'L': /* Ld */
e5c81feb
JH		 6219 /* FALL THROUGH */
6220#endif
6221#ifdef HAS_QUAD
6f9bb7fd
GS		 6222 case 'q': /* qd */
6223 intsize = 'q';
6224 q++;
6225 break;
6226#endif
fc36a67e 6227 case 'l':
e5c81feb
JH		 6228#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6229 if (*(q + 1) == 'l') { /* lld, llf */
fc36a67e 6230 intsize = 'q';
6231 q += 2;
46fc3d4c 6232 break;
cf2093f6 6233 }
fc36a67e 6234#endif
6f9bb7fd 6235 /* FALL THROUGH */
fc36a67e 6236 case 'h':
cf2093f6 6237 /* FALL THROUGH */
fc36a67e 6238 case 'V':
6239 intsize = *q++;
46fc3d4c 6240 break;
6241 }
6242
fc36a67e 6243 /* CONVERSION */
6244
46fc3d4c 6245 switch (c = *q++) {
6246
6247 /* STRINGS */
6248
6249 case '%':
6250 eptr = q - 1;
6251 elen = 1;
6252 goto string;
6253
6254 case 'c':
7e2040f0
GS		 6255 if (args)
6256 uv = va_arg(*args, int);
6257 else
eb3fce90
JH		 6258 uv = (epix ? epix <= svmax : svix < svmax) ?
6259 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
3969a896 6260 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
dfe13c55
GS		 6261 eptr = (char*)utf8buf;
6262 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
7e2040f0
GS		 6263 is_utf = TRUE;
6264 }
6265 else {
6266 c = (char)uv;
6267 eptr = &c;
6268 elen = 1;
a0ed51b3 6269 }
46fc3d4c 6270 goto string;
6271
46fc3d4c 6272 case 's':
6273 if (args) {
fc36a67e 6274 eptr = va_arg(*args, char*);
c635e13b 6275 if (eptr)
1d7c1841
GS		 6276#ifdef MACOS_TRADITIONAL
6277 /* On MacOS, %#s format is used for Pascal strings */
6278 if (alt)
6279 elen = *eptr++;
6280 else
6281#endif
c635e13b 6282 elen = strlen(eptr);
6283 else {
6284 eptr = nullstr;
6285 elen = sizeof nullstr - 1;
6286 }
46fc3d4c 6287 }
eb3fce90
JH		 6288 else if (epix ? epix <= svmax : svix < svmax) {
6289 argsv = svargs[epix ? epix-1 : svix++];
7e2040f0
GS		 6290 eptr = SvPVx(argsv, elen);
6291 if (DO_UTF8(argsv)) {
a0ed51b3
LW		 6292 if (has_precis && precis < elen) {
6293 I32 p = precis;
7e2040f0 6294 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
a0ed51b3
LW		 6295 precis = p;
6296 }
6297 if (width) { /* fudge width (can't fudge elen) */
7e2040f0 6298 width += elen - sv_len_utf8(argsv);
a0ed51b3 6299 }
7e2040f0 6300 is_utf = TRUE;
a0ed51b3
LW		 6301 }
6302 }
46fc3d4c 6303 goto string;
6304
fc36a67e 6305 case '_':
6306 /*
6307 * The "%_" hack might have to be changed someday,
6308 * if ISO or ANSI decide to use '_' for something.
6309 * So we keep it hidden from users' code.
6310 */
6311 if (!args)
6312 goto unknown;
7e2040f0
GS		 6313 argsv = va_arg(*args,SV*);
6314 eptr = SvPVx(argsv, elen);
6315 if (DO_UTF8(argsv))
6316 is_utf = TRUE;
fc36a67e 6317
46fc3d4c 6318 string:
b22c7a20 6319 vectorize = FALSE;
46fc3d4c 6320 if (has_precis && elen > precis)
6321 elen = precis;
6322 break;
6323
6324 /* INTEGERS */
6325
fc36a67e 6326 case 'p':
c2e66d9e
GS		 6327 if (alt)
6328 goto unknown;
fc36a67e 6329 if (args)
56431972 6330 uv = PTR2UV(va_arg(*args, void*));
fc36a67e 6331 else
eb3fce90
JH		 6332 uv = (epix ? epix <= svmax : svix < svmax) ?
6333 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
fc36a67e 6334 base = 16;
6335 goto integer;
6336
46fc3d4c 6337 case 'D':
29fe7a80 6338#ifdef IV_IS_QUAD
22f3ae8c 6339 intsize = 'q';
29fe7a80 6340#else
46fc3d4c 6341 intsize = 'l';
29fe7a80 6342#endif
46fc3d4c 6343 /* FALL THROUGH */
6344 case 'd':
6345 case 'i':
b22c7a20 6346 if (vectorize) {
ba210ebe 6347 STRLEN ulen;
b22c7a20
GS		 6348 if (!veclen) {
6349 vectorize = FALSE;
6350 break;
6351 }
6352 if (utf)
dcad2880 6353 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
b22c7a20 6354 else {
a05b299f 6355 iv = *vecstr;
b22c7a20
GS		 6356 ulen = 1;
6357 }
6358 vecstr += ulen;
6359 veclen -= ulen;
6360 }
6361 else if (args) {
46fc3d4c 6362 switch (intsize) {
6363 case 'h': iv = (short)va_arg(*args, int); break;
6364 default: iv = va_arg(*args, int); break;
6365 case 'l': iv = va_arg(*args, long); break;
fc36a67e 6366 case 'V': iv = va_arg(*args, IV); break;
cf2093f6
JH		 6367#ifdef HAS_QUAD
6368 case 'q': iv = va_arg(*args, Quad_t); break;
6369#endif
46fc3d4c 6370 }
6371 }
6372 else {
eb3fce90
JH		 6373 iv = (epix ? epix <= svmax : svix < svmax) ?
6374 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
46fc3d4c 6375 switch (intsize) {
6376 case 'h': iv = (short)iv; break;
be28567c 6377 default: break;
46fc3d4c 6378 case 'l': iv = (long)iv; break;
fc36a67e 6379 case 'V': break;
cf2093f6
JH		 6380#ifdef HAS_QUAD
6381 case 'q': iv = (Quad_t)iv; break;
6382#endif
46fc3d4c 6383 }
6384 }
6385 if (iv >= 0) {
6386 uv = iv;
6387 if (plus)
6388 esignbuf[esignlen++] = plus;
6389 }
6390 else {
6391 uv = -iv;
6392 esignbuf[esignlen++] = '-';
6393 }
6394 base = 10;
6395 goto integer;
6396
fc36a67e 6397 case 'U':
29fe7a80 6398#ifdef IV_IS_QUAD
22f3ae8c 6399 intsize = 'q';
29fe7a80 6400#else
fc36a67e 6401 intsize = 'l';
29fe7a80 6402#endif
fc36a67e 6403 /* FALL THROUGH */
6404 case 'u':
6405 base = 10;
6406 goto uns_integer;
6407
4f19785b
WSI		 6408 case 'b':
6409 base = 2;
6410 goto uns_integer;
6411
46fc3d4c 6412 case 'O':
29fe7a80 6413#ifdef IV_IS_QUAD
22f3ae8c 6414 intsize = 'q';
29fe7a80 6415#else
46fc3d4c 6416 intsize = 'l';
29fe7a80 6417#endif
46fc3d4c 6418 /* FALL THROUGH */
6419 case 'o':
6420 base = 8;
6421 goto uns_integer;
6422
6423 case 'X':
46fc3d4c 6424 case 'x':
6425 base = 16;
46fc3d4c 6426
6427 uns_integer:
b22c7a20 6428 if (vectorize) {
ba210ebe 6429 STRLEN ulen;
b22c7a20
GS		 6430 vector:
6431 if (!veclen) {
6432 vectorize = FALSE;
6433 break;
6434 }
6435 if (utf)
dcad2880 6436 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
b22c7a20 6437 else {
a05b299f 6438 uv = *vecstr;
b22c7a20
GS		 6439 ulen = 1;
6440 }
6441 vecstr += ulen;
6442 veclen -= ulen;
6443 }
6444 else if (args) {
46fc3d4c 6445 switch (intsize) {
6446 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6447 default: uv = va_arg(*args, unsigned); break;
6448 case 'l': uv = va_arg(*args, unsigned long); break;
fc36a67e 6449 case 'V': uv = va_arg(*args, UV); break;
cf2093f6
JH		 6450#ifdef HAS_QUAD
6451 case 'q': uv = va_arg(*args, Quad_t); break;
6452#endif
46fc3d4c 6453 }
6454 }
6455 else {
eb3fce90
JH		 6456 uv = (epix ? epix <= svmax : svix < svmax) ?
6457 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
46fc3d4c 6458 switch (intsize) {
6459 case 'h': uv = (unsigned short)uv; break;
be28567c 6460 default: break;
46fc3d4c 6461 case 'l': uv = (unsigned long)uv; break;
fc36a67e 6462 case 'V': break;
cf2093f6
JH		 6463#ifdef HAS_QUAD
6464 case 'q': uv = (Quad_t)uv; break;
6465#endif
46fc3d4c 6466 }
6467 }
6468
6469 integer:
46fc3d4c 6470 eptr = ebuf + sizeof ebuf;
fc36a67e 6471 switch (base) {
6472 unsigned dig;
6473 case 16:
c10ed8b9
HS		 6474 if (!uv)
6475 alt = FALSE;
1d7c1841
GS		 6476 p = (char*)((c == 'X')
6477 ? "0123456789ABCDEF" : "0123456789abcdef");
fc36a67e 6478 do {
6479 dig = uv & 15;
6480 *--eptr = p[dig];
6481 } while (uv >>= 4);
6482 if (alt) {
46fc3d4c 6483 esignbuf[esignlen++] = '0';
fc36a67e 6484 esignbuf[esignlen++] = c; /* 'x' or 'X' */
46fc3d4c 6485 }
fc36a67e 6486 break;
6487 case 8:
6488 do {
6489 dig = uv & 7;
6490 *--eptr = '0' + dig;
6491 } while (uv >>= 3);
6492 if (alt && *eptr != '0')
6493 *--eptr = '0';
6494 break;
4f19785b
WSI		 6495 case 2:
6496 do {
6497 dig = uv & 1;
6498 *--eptr = '0' + dig;
6499 } while (uv >>= 1);
eda88b6d
JH		 6500 if (alt) {
6501 esignbuf[esignlen++] = '0';
7481bb52 6502 esignbuf[esignlen++] = 'b';
eda88b6d 6503 }
4f19785b 6504 break;
fc36a67e 6505 default: /* it had better be ten or less */
6bc102ca 6506#if defined(PERL_Y2KWARN)
e476b1b5 6507 if (ckWARN(WARN_Y2K)) {
6bc102ca
GS		 6508 STRLEN n;
6509 char *s = SvPV(sv,n);
6510 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6511 && (n == 2 || !isDIGIT(s[n-3])))
6512 {
e476b1b5 6513 Perl_warner(aTHX_ WARN_Y2K,
6bc102ca
GS		 6514 "Possible Y2K bug: %%%c %s",
6515 c, "format string following '19'");
6516 }
6517 }
6518#endif
fc36a67e 6519 do {
6520 dig = uv % base;
6521 *--eptr = '0' + dig;
6522 } while (uv /= base);
6523 break;
46fc3d4c 6524 }
6525 elen = (ebuf + sizeof ebuf) - eptr;
c10ed8b9
HS		 6526 if (has_precis) {
6527 if (precis > elen)
6528 zeros = precis - elen;
6529 else if (precis == 0 && elen == 1 && *eptr == '0')
6530 elen = 0;
6531 }
46fc3d4c 6532 break;
6533
6534 /* FLOATING POINT */
6535
fc36a67e 6536 case 'F':
6537 c = 'f'; /* maybe %F isn't supported here */
6538 /* FALL THROUGH */
46fc3d4c 6539 case 'e': case 'E':
fc36a67e 6540 case 'f':
46fc3d4c 6541 case 'g': case 'G':
6542
6543 /* This is evil, but floating point is even more evil */
6544
b22c7a20 6545 vectorize = FALSE;
fc36a67e 6546 if (args)
65202027 6547 nv = va_arg(*args, NV);
fc36a67e 6548 else
eb3fce90
JH		 6549 nv = (epix ? epix <= svmax : svix < svmax) ?
6550 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
fc36a67e 6551
6552 need = 0;
6553 if (c != 'e' && c != 'E') {
6554 i = PERL_INT_MIN;
73b309ea 6555 (void)Perl_frexp(nv, &i);
fc36a67e 6556 if (i == PERL_INT_MIN)
cea2e8a9 6557 Perl_die(aTHX_ "panic: frexp");
c635e13b 6558 if (i > 0)
fc36a67e 6559 need = BIT_DIGITS(i);
6560 }
6561 need += has_precis ? precis : 6; /* known default */
6562 if (need < width)
6563 need = width;
6564
46fc3d4c 6565 need += 20; /* fudge factor */
80252599
GS		 6566 if (PL_efloatsize < need) {
6567 Safefree(PL_efloatbuf);
6568 PL_efloatsize = need + 20; /* more fudge */
6569 New(906, PL_efloatbuf, PL_efloatsize, char);
7d5ea4e7 6570 PL_efloatbuf[0] = '\0';
46fc3d4c 6571 }
6572
6573 eptr = ebuf + sizeof ebuf;
6574 *--eptr = '\0';
6575 *--eptr = c;
e5c81feb 6576#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
cf2093f6 6577 {
e5c81feb
JH		 6578 /* Copy the one or more characters in a long double
6579 * format before the 'base' ([efgEFG]) character to
6580 * the format string. */
6581 static char const prifldbl[] = PERL_PRIfldbl;
6582 char const *p = prifldbl + sizeof(prifldbl) - 3;
6583 while (p >= prifldbl) { *--eptr = *p--; }
cf2093f6 6584 }
65202027 6585#endif
46fc3d4c 6586 if (has_precis) {
6587 base = precis;
6588 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6589 *--eptr = '.';
6590 }
6591 if (width) {
6592 base = width;
6593 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6594 }
6595 if (fill == '0')
6596 *--eptr = fill;
84902520
TB		 6597 if (left)
6598 *--eptr = '-';
46fc3d4c 6599 if (plus)
6600 *--eptr = plus;
6601 if (alt)
6602 *--eptr = '#';
6603 *--eptr = '%';
6604
ff9121f8
JH		 6605 /* No taint. Otherwise we are in the strange situation
6606 * where printf() taints but print($float) doesn't.
bda0f7a5 6607 * --jhi */
dd8482fc 6608 (void)sprintf(PL_efloatbuf, eptr, nv);
8af02333 6609
80252599
GS		 6610 eptr = PL_efloatbuf;
6611 elen = strlen(PL_efloatbuf);
46fc3d4c 6612 break;
6613
fc36a67e 6614 /* SPECIAL */
6615
6616 case 'n':
b22c7a20 6617 vectorize = FALSE;
fc36a67e 6618 i = SvCUR(sv) - origlen;
6619 if (args) {
c635e13b 6620 switch (intsize) {
6621 case 'h': *(va_arg(*args, short*)) = i; break;
6622 default: *(va_arg(*args, int*)) = i; break;
6623 case 'l': *(va_arg(*args, long*)) = i; break;
6624 case 'V': *(va_arg(*args, IV*)) = i; break;
cf2093f6
JH		 6625#ifdef HAS_QUAD
6626 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6627#endif
c635e13b 6628 }
fc36a67e 6629 }
eb3fce90
JH		 6630 else if (epix ? epix <= svmax : svix < svmax)
6631 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
fc36a67e 6632 continue; /* not "break" */
6633
6634 /* UNKNOWN */
6635
46fc3d4c 6636 default:
fc36a67e 6637 unknown:
b22c7a20 6638 vectorize = FALSE;
599cee73 6639 if (!args && ckWARN(WARN_PRINTF) &&
533c011a 6640 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
c635e13b 6641 SV *msg = sv_newmortal();
cea2e8a9 6642 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
533c011a 6643 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
0f4b6630 6644 if (c) {
0f4b6630 6645 if (isPRINT(c))
1c846c1f 6646 Perl_sv_catpvf(aTHX_ msg,
0f4b6630
JH		 6647 "\"%%%c\"", c & 0xFF);
6648 else
6649 Perl_sv_catpvf(aTHX_ msg,
57def98f 6650 "\"%%\\%03"UVof"\"",
0f4b6630 6651 (UV)c & 0xFF);
0f4b6630 6652 } else
c635e13b 6653 sv_catpv(msg, "end of string");
894356b3 6654 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
c635e13b 6655 }
fb73857a 6656
6657 /* output mangled stuff ... */
6658 if (c == '\0')
6659 --q;
46fc3d4c 6660 eptr = p;
6661 elen = q - p;
fb73857a 6662
6663 /* ... right here, because formatting flags should not apply */
6664 SvGROW(sv, SvCUR(sv) + elen + 1);
6665 p = SvEND(sv);
6666 memcpy(p, eptr, elen);
6667 p += elen;
6668 *p = '\0';
6669 SvCUR(sv) = p - SvPVX(sv);
6670 continue; /* not "break" */
46fc3d4c 6671 }
6672
fc36a67e 6673 have = esignlen + zeros + elen;
46fc3d4c 6674 need = (have > width ? have : width);
6675 gap = need - have;
6676
b22c7a20 6677 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
46fc3d4c 6678 p = SvEND(sv);
6679 if (esignlen && fill == '0') {
6680 for (i = 0; i < esignlen; i++)
6681 *p++ = esignbuf[i];
6682 }
6683 if (gap && !left) {
6684 memset(p, fill, gap);
6685 p += gap;
6686 }
6687 if (esignlen && fill != '0') {
6688 for (i = 0; i < esignlen; i++)
6689 *p++ = esignbuf[i];
6690 }
fc36a67e 6691 if (zeros) {
6692 for (i = zeros; i; i--)
6693 *p++ = '0';
6694 }
46fc3d4c 6695 if (elen) {
6696 memcpy(p, eptr, elen);
6697 p += elen;
6698 }
6699 if (gap && left) {
6700 memset(p, ' ', gap);
6701 p += gap;
6702 }
b22c7a20
GS		 6703 if (vectorize) {
6704 if (veclen) {
6705 memcpy(p, dotstr, dotstrlen);
6706 p += dotstrlen;
6707 }
6708 else
6709 vectorize = FALSE; /* done iterating over vecstr */
6710 }
7e2040f0
GS		 6711 if (is_utf)
6712 SvUTF8_on(sv);
46fc3d4c 6713 *p = '\0';
6714 SvCUR(sv) = p - SvPVX(sv);
b22c7a20
GS		 6715 if (vectorize) {
6716 esignlen = 0;
6717 goto vector;
6718 }
46fc3d4c 6719 }
6720}
51371543 6721
1d7c1841
GS		 6722#if defined(USE_ITHREADS)
6723
6724#if defined(USE_THREADS)
6725# include "error: USE_THREADS and USE_ITHREADS are incompatible"
6726#endif
6727
1d7c1841
GS		 6728#ifndef GpREFCNT_inc
6729# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6730#endif
6731
6732
6733#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6734#define av_dup(s) (AV*)sv_dup((SV*)s)
6735#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6736#define hv_dup(s) (HV*)sv_dup((SV*)s)
6737#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6738#define cv_dup(s) (CV*)sv_dup((SV*)s)
6739#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6740#define io_dup(s) (IO*)sv_dup((SV*)s)
6741#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6742#define gv_dup(s) (GV*)sv_dup((SV*)s)
6743#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6744#define SAVEPV(p) (p ? savepv(p) : Nullch)
6745#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6746
6747REGEXP *
6748Perl_re_dup(pTHX_ REGEXP *r)
6749{
6750 /* XXX fix when pmop->op_pmregexp becomes shared */
6751 return ReREFCNT_inc(r);
6752}
6753
6754PerlIO *
6755Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6756{
6757 PerlIO *ret;
6758 if (!fp)
6759 return (PerlIO*)NULL;
6760
6761 /* look for it in the table first */
6762 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6763 if (ret)
6764 return ret;
6765
6766 /* create anew and remember what it is */
5f1a76d0 6767 ret = PerlIO_fdupopen(aTHX_ fp);
1d7c1841
GS		 6768 ptr_table_store(PL_ptr_table, fp, ret);
6769 return ret;
6770}
6771
6772DIR *
6773Perl_dirp_dup(pTHX_ DIR *dp)
6774{
6775 if (!dp)
6776 return (DIR*)NULL;
6777 /* XXX TODO */
6778 return dp;
6779}
6780
6781GP *
6782Perl_gp_dup(pTHX_ GP *gp)
6783{
6784 GP *ret;
6785 if (!gp)
6786 return (GP*)NULL;
6787 /* look for it in the table first */
6788 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6789 if (ret)
6790 return ret;
6791
6792 /* create anew and remember what it is */
6793 Newz(0, ret, 1, GP);
6794 ptr_table_store(PL_ptr_table, gp, ret);
6795
6796 /* clone */
6797 ret->gp_refcnt = 0; /* must be before any other dups! */
6798 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6799 ret->gp_io = io_dup_inc(gp->gp_io);
6800 ret->gp_form = cv_dup_inc(gp->gp_form);
6801 ret->gp_av = av_dup_inc(gp->gp_av);
6802 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6803 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6804 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6805 ret->gp_cvgen = gp->gp_cvgen;
6806 ret->gp_flags = gp->gp_flags;
6807 ret->gp_line = gp->gp_line;
6808 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6809 return ret;
6810}
6811
6812MAGIC *
6813Perl_mg_dup(pTHX_ MAGIC *mg)
6814{
6815 MAGIC *mgret = (MAGIC*)NULL;
6816 MAGIC *mgprev;
6817 if (!mg)
6818 return (MAGIC*)NULL;
6819 /* look for it in the table first */
6820 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6821 if (mgret)
6822 return mgret;
6823
6824 for (; mg; mg = mg->mg_moremagic) {
6825 MAGIC *nmg;
6826 Newz(0, nmg, 1, MAGIC);
6827 if (!mgret)
6828 mgret = nmg;
6829 else
6830 mgprev->mg_moremagic = nmg;
6831 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6832 nmg->mg_private = mg->mg_private;
6833 nmg->mg_type = mg->mg_type;
6834 nmg->mg_flags = mg->mg_flags;
6835 if (mg->mg_type == 'r') {
6836 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6837 }
6838 else {
6839 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6840 ? sv_dup_inc(mg->mg_obj)
6841 : sv_dup(mg->mg_obj);
6842 }
6843 nmg->mg_len = mg->mg_len;
6844 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6845 if (mg->mg_ptr && mg->mg_type != 'g') {
6846 if (mg->mg_len >= 0) {
6847 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6848 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6849 AMT *amtp = (AMT*)mg->mg_ptr;
6850 AMT *namtp = (AMT*)nmg->mg_ptr;
6851 I32 i;
6852 for (i = 1; i < NofAMmeth; i++) {
6853 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6854 }
6855 }
6856 }
6857 else if (mg->mg_len == HEf_SVKEY)
6858 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6859 }
6860 mgprev = nmg;
6861 }
6862 return mgret;
6863}
6864
6865PTR_TBL_t *
6866Perl_ptr_table_new(pTHX)
6867{
6868 PTR_TBL_t *tbl;
6869 Newz(0, tbl, 1, PTR_TBL_t);
6870 tbl->tbl_max = 511;
6871 tbl->tbl_items = 0;
6872 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6873 return tbl;
6874}
6875
6876void *
6877Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6878{
6879 PTR_TBL_ENT_t *tblent;
d2a79402 6880 UV hash = PTR2UV(sv);
1d7c1841
GS		 6881 assert(tbl);
6882 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6883 for (; tblent; tblent = tblent->next) {
6884 if (tblent->oldval == sv)
6885 return tblent->newval;
6886 }
6887 return (void*)NULL;
6888}
6889
6890void
6891Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6892{
6893 PTR_TBL_ENT_t *tblent, **otblent;
6894 /* XXX this may be pessimal on platforms where pointers aren't good
6895 * hash values e.g. if they grow faster in the most significant
6896 * bits */
d2a79402 6897 UV hash = PTR2UV(oldv);
1d7c1841
GS		 6898 bool i = 1;
6899
6900 assert(tbl);
6901 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6902 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6903 if (tblent->oldval == oldv) {
6904 tblent->newval = newv;
6905 tbl->tbl_items++;
6906 return;
6907 }
6908 }
6909 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6910 tblent->oldval = oldv;
6911 tblent->newval = newv;
6912 tblent->next = *otblent;
6913 *otblent = tblent;
6914 tbl->tbl_items++;
6915 if (i && tbl->tbl_items > tbl->tbl_max)
6916 ptr_table_split(tbl);
6917}
6918
6919void
6920Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6921{
6922 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6923 UV oldsize = tbl->tbl_max + 1;
6924 UV newsize = oldsize * 2;
6925 UV i;
6926
6927 Renew(ary, newsize, PTR_TBL_ENT_t*);
6928 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6929 tbl->tbl_max = --newsize;
6930 tbl->tbl_ary = ary;
6931 for (i=0; i < oldsize; i++, ary++) {
6932 PTR_TBL_ENT_t **curentp, **entp, *ent;
6933 if (!*ary)
6934 continue;
6935 curentp = ary + oldsize;
6936 for (entp = ary, ent = *ary; ent; ent = *entp) {
d2a79402 6937 if ((newsize & PTR2UV(ent->oldval)) != i) {
1d7c1841
GS		 6938 *entp = ent->next;
6939 ent->next = *curentp;
6940 *curentp = ent;
6941 continue;
6942 }
6943 else
6944 entp = &ent->next;
6945 }
6946 }
6947}
6948
6949#ifdef DEBUGGING
6950char *PL_watch_pvx;
6951#endif
6952
6953SV *
6954Perl_sv_dup(pTHX_ SV *sstr)
6955{
1d7c1841
GS		 6956 SV *dstr;
6957
6958 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6959 return Nullsv;
6960 /* look for it in the table first */
6961 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6962 if (dstr)
6963 return dstr;
6964
6965 /* create anew and remember what it is */
6966 new_SV(dstr);
6967 ptr_table_store(PL_ptr_table, sstr, dstr);
6968
6969 /* clone */
6970 SvFLAGS(dstr) = SvFLAGS(sstr);
6971 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6972 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6973
6974#ifdef DEBUGGING
6975 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6976 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6977 PL_watch_pvx, SvPVX(sstr));
6978#endif
6979
6980 switch (SvTYPE(sstr)) {
6981 case SVt_NULL:
6982 SvANY(dstr) = NULL;
6983 break;
6984 case SVt_IV:
6985 SvANY(dstr) = new_XIV();
6986 SvIVX(dstr) = SvIVX(sstr);
6987 break;
6988 case SVt_NV:
6989 SvANY(dstr) = new_XNV();
6990 SvNVX(dstr) = SvNVX(sstr);
6991 break;
6992 case SVt_RV:
6993 SvANY(dstr) = new_XRV();
6994 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6995 break;
6996 case SVt_PV:
6997 SvANY(dstr) = new_XPV();
6998 SvCUR(dstr) = SvCUR(sstr);
6999 SvLEN(dstr) = SvLEN(sstr);
7000 if (SvROK(sstr))
7001 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7002 else if (SvPVX(sstr) && SvLEN(sstr))
7003 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7004 else
7005 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7006 break;
7007 case SVt_PVIV:
7008 SvANY(dstr) = new_XPVIV();
7009 SvCUR(dstr) = SvCUR(sstr);
7010 SvLEN(dstr) = SvLEN(sstr);
7011 SvIVX(dstr) = SvIVX(sstr);
7012 if (SvROK(sstr))
7013 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7014 else if (SvPVX(sstr) && SvLEN(sstr))
7015 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7016 else
7017 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7018 break;
7019 case SVt_PVNV:
7020 SvANY(dstr) = new_XPVNV();
7021 SvCUR(dstr) = SvCUR(sstr);
7022 SvLEN(dstr) = SvLEN(sstr);
7023 SvIVX(dstr) = SvIVX(sstr);
7024 SvNVX(dstr) = SvNVX(sstr);
7025 if (SvROK(sstr))
7026 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7027 else if (SvPVX(sstr) && SvLEN(sstr))
7028 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7029 else
7030 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7031 break;
7032 case SVt_PVMG:
7033 SvANY(dstr) = new_XPVMG();
7034 SvCUR(dstr) = SvCUR(sstr);
7035 SvLEN(dstr) = SvLEN(sstr);
7036 SvIVX(dstr) = SvIVX(sstr);
7037 SvNVX(dstr) = SvNVX(sstr);
7038 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7039 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7040 if (SvROK(sstr))
7041 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7042 else if (SvPVX(sstr) && SvLEN(sstr))
7043 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7044 else
7045 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7046 break;
7047 case SVt_PVBM:
7048 SvANY(dstr) = new_XPVBM();
7049 SvCUR(dstr) = SvCUR(sstr);
7050 SvLEN(dstr) = SvLEN(sstr);
7051 SvIVX(dstr) = SvIVX(sstr);
7052 SvNVX(dstr) = SvNVX(sstr);
7053 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7054 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7055 if (SvROK(sstr))
7056 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7057 else if (SvPVX(sstr) && SvLEN(sstr))
7058 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7059 else
7060 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7061 BmRARE(dstr) = BmRARE(sstr);
7062 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7063 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7064 break;
7065 case SVt_PVLV:
7066 SvANY(dstr) = new_XPVLV();
7067 SvCUR(dstr) = SvCUR(sstr);
7068 SvLEN(dstr) = SvLEN(sstr);
7069 SvIVX(dstr) = SvIVX(sstr);
7070 SvNVX(dstr) = SvNVX(sstr);
7071 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7072 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7073 if (SvROK(sstr))
7074 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7075 else if (SvPVX(sstr) && SvLEN(sstr))
7076 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7077 else
7078 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7079 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7080 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7081 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7082 LvTYPE(dstr) = LvTYPE(sstr);
7083 break;
7084 case SVt_PVGV:
7085 SvANY(dstr) = new_XPVGV();
7086 SvCUR(dstr) = SvCUR(sstr);
7087 SvLEN(dstr) = SvLEN(sstr);
7088 SvIVX(dstr) = SvIVX(sstr);
7089 SvNVX(dstr) = SvNVX(sstr);
7090 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7091 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7092 if (SvROK(sstr))
7093 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7094 else if (SvPVX(sstr) && SvLEN(sstr))
7095 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7096 else
7097 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7098 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7099 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7100 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7101 GvFLAGS(dstr) = GvFLAGS(sstr);
7102 GvGP(dstr) = gp_dup(GvGP(sstr));
7103 (void)GpREFCNT_inc(GvGP(dstr));
7104 break;
7105 case SVt_PVIO:
7106 SvANY(dstr) = new_XPVIO();
7107 SvCUR(dstr) = SvCUR(sstr);
7108 SvLEN(dstr) = SvLEN(sstr);
7109 SvIVX(dstr) = SvIVX(sstr);
7110 SvNVX(dstr) = SvNVX(sstr);
7111 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7112 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7113 if (SvROK(sstr))
7114 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7115 else if (SvPVX(sstr) && SvLEN(sstr))
7116 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7117 else
7118 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7119 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7120 if (IoOFP(sstr) == IoIFP(sstr))
7121 IoOFP(dstr) = IoIFP(dstr);
7122 else
7123 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7124 /* PL_rsfp_filters entries have fake IoDIRP() */
7125 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7126 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7127 else
7128 IoDIRP(dstr) = IoDIRP(sstr);
7129 IoLINES(dstr) = IoLINES(sstr);
7130 IoPAGE(dstr) = IoPAGE(sstr);
7131 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7132 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7133 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7134 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7135 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7136 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7137 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7138 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7139 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7140 IoTYPE(dstr) = IoTYPE(sstr);
7141 IoFLAGS(dstr) = IoFLAGS(sstr);
7142 break;
7143 case SVt_PVAV:
7144 SvANY(dstr) = new_XPVAV();
7145 SvCUR(dstr) = SvCUR(sstr);
7146 SvLEN(dstr) = SvLEN(sstr);
7147 SvIVX(dstr) = SvIVX(sstr);
7148 SvNVX(dstr) = SvNVX(sstr);
7149 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7150 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7151 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7152 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7153 if (AvARRAY((AV*)sstr)) {
7154 SV **dst_ary, **src_ary;
7155 SSize_t items = AvFILLp((AV*)sstr) + 1;
7156
7157 src_ary = AvARRAY((AV*)sstr);
7158 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7159 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7160 SvPVX(dstr) = (char*)dst_ary;
7161 AvALLOC((AV*)dstr) = dst_ary;
7162 if (AvREAL((AV*)sstr)) {
7163 while (items-- > 0)
7164 *dst_ary++ = sv_dup_inc(*src_ary++);
7165 }
7166 else {
7167 while (items-- > 0)
7168 *dst_ary++ = sv_dup(*src_ary++);
7169 }
7170 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7171 while (items-- > 0) {
7172 *dst_ary++ = &PL_sv_undef;
7173 }
7174 }
7175 else {
7176 SvPVX(dstr) = Nullch;
7177 AvALLOC((AV*)dstr) = (SV**)NULL;
7178 }
7179 break;
7180 case SVt_PVHV:
7181 SvANY(dstr) = new_XPVHV();
7182 SvCUR(dstr) = SvCUR(sstr);
7183 SvLEN(dstr) = SvLEN(sstr);
7184 SvIVX(dstr) = SvIVX(sstr);
7185 SvNVX(dstr) = SvNVX(sstr);
7186 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7187 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7188 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7189 if (HvARRAY((HV*)sstr)) {
1d7c1841
GS		 7190 STRLEN i = 0;
7191 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7192 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7193 Newz(0, dxhv->xhv_array,
7194 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7195 while (i <= sxhv->xhv_max) {
7196 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7197 !!HvSHAREKEYS(sstr));
7198 ++i;
7199 }
7200 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7201 }
7202 else {
7203 SvPVX(dstr) = Nullch;
7204 HvEITER((HV*)dstr) = (HE*)NULL;
7205 }
7206 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7207 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7208 break;
7209 case SVt_PVFM:
7210 SvANY(dstr) = new_XPVFM();
7211 FmLINES(dstr) = FmLINES(sstr);
7212 goto dup_pvcv;
7213 /* NOTREACHED */
7214 case SVt_PVCV:
7215 SvANY(dstr) = new_XPVCV();
7216dup_pvcv:
7217 SvCUR(dstr) = SvCUR(sstr);
7218 SvLEN(dstr) = SvLEN(sstr);
7219 SvIVX(dstr) = SvIVX(sstr);
7220 SvNVX(dstr) = SvNVX(sstr);
7221 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7222 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7223 if (SvPVX(sstr) && SvLEN(sstr))
7224 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7225 else
7226 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7227 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7228 CvSTART(dstr) = CvSTART(sstr);
7229 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7230 CvXSUB(dstr) = CvXSUB(sstr);
7231 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7232 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7233 CvDEPTH(dstr) = CvDEPTH(sstr);
7234 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7235 /* XXX padlists are real, but pretend to be not */
7236 AvREAL_on(CvPADLIST(sstr));
7237 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7238 AvREAL_off(CvPADLIST(sstr));
7239 AvREAL_off(CvPADLIST(dstr));
7240 }
7241 else
7242 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7243 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7244 CvFLAGS(dstr) = CvFLAGS(sstr);
7245 break;
7246 default:
7247 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7248 break;
7249 }
7250
7251 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7252 ++PL_sv_objcount;
7253
7254 return dstr;
7255}
7256
7257PERL_CONTEXT *
7258Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7259{
7260 PERL_CONTEXT *ncxs;
7261
7262 if (!cxs)
7263 return (PERL_CONTEXT*)NULL;
7264
7265 /* look for it in the table first */
7266 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7267 if (ncxs)
7268 return ncxs;
7269
7270 /* create anew and remember what it is */
7271 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7272 ptr_table_store(PL_ptr_table, cxs, ncxs);
7273
7274 while (ix >= 0) {
7275 PERL_CONTEXT *cx = &cxs[ix];
7276 PERL_CONTEXT *ncx = &ncxs[ix];
7277 ncx->cx_type = cx->cx_type;
7278 if (CxTYPE(cx) == CXt_SUBST) {
7279 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7280 }
7281 else {
7282 ncx->blk_oldsp = cx->blk_oldsp;
7283 ncx->blk_oldcop = cx->blk_oldcop;
7284 ncx->blk_oldretsp = cx->blk_oldretsp;
7285 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7286 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7287 ncx->blk_oldpm = cx->blk_oldpm;
7288 ncx->blk_gimme = cx->blk_gimme;
7289 switch (CxTYPE(cx)) {
7290 case CXt_SUB:
7291 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7292 ? cv_dup_inc(cx->blk_sub.cv)
7293 : cv_dup(cx->blk_sub.cv));
7294 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7295 ? av_dup_inc(cx->blk_sub.argarray)
7296 : Nullav);
7297 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7298 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7299 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7300 ncx->blk_sub.lval = cx->blk_sub.lval;
7301 break;
7302 case CXt_EVAL:
7303 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7304 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
0f79a09d 7305 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
1d7c1841
GS		 7306 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7307 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7308 break;
7309 case CXt_LOOP:
7310 ncx->blk_loop.label = cx->blk_loop.label;
7311 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7312 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7313 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7314 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7315 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7316 ? cx->blk_loop.iterdata
7317 : gv_dup((GV*)cx->blk_loop.iterdata));
a4b82a6f
GS		 7318 ncx->blk_loop.oldcurpad
7319 = (SV**)ptr_table_fetch(PL_ptr_table,
7320 cx->blk_loop.oldcurpad);
1d7c1841
GS		 7321 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7322 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7323 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7324 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7325 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7326 break;
7327 case CXt_FORMAT:
7328 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7329 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7330 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7331 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7332 break;
7333 case CXt_BLOCK:
7334 case CXt_NULL:
7335 break;
7336 }
7337 }
7338 --ix;
7339 }
7340 return ncxs;
7341}
7342
7343PERL_SI *
7344Perl_si_dup(pTHX_ PERL_SI *si)
7345{
7346 PERL_SI *nsi;
7347
7348 if (!si)
7349 return (PERL_SI*)NULL;
7350
7351 /* look for it in the table first */
7352 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7353 if (nsi)
7354 return nsi;
7355
7356 /* create anew and remember what it is */
7357 Newz(56, nsi, 1, PERL_SI);
7358 ptr_table_store(PL_ptr_table, si, nsi);
7359
7360 nsi->si_stack = av_dup_inc(si->si_stack);
7361 nsi->si_cxix = si->si_cxix;
7362 nsi->si_cxmax = si->si_cxmax;
7363 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7364 nsi->si_type = si->si_type;
7365 nsi->si_prev = si_dup(si->si_prev);
7366 nsi->si_next = si_dup(si->si_next);
7367 nsi->si_markoff = si->si_markoff;
7368
7369 return nsi;
7370}
7371
7372#define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7373#define TOPINT(ss,ix) ((ss)[ix].any_i32)
7374#define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7375#define TOPLONG(ss,ix) ((ss)[ix].any_long)
7376#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7377#define TOPIV(ss,ix) ((ss)[ix].any_iv)
7378#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7379#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7380#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7381#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7382#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7383#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7384
7385/* XXXXX todo */
7386#define pv_dup_inc(p) SAVEPV(p)
7387#define pv_dup(p) SAVEPV(p)
7388#define svp_dup_inc(p,pp) any_dup(p,pp)
7389
7390void *
7391Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7392{
7393 void *ret;
7394
7395 if (!v)
7396 return (void*)NULL;
7397
7398 /* look for it in the table first */
7399 ret = ptr_table_fetch(PL_ptr_table, v);
7400 if (ret)
7401 return ret;
7402
7403 /* see if it is part of the interpreter structure */
7404 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7405 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7406 else
7407 ret = v;
7408
7409 return ret;
7410}
7411
7412ANY *
7413Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7414{
7415 ANY *ss = proto_perl->Tsavestack;
7416 I32 ix = proto_perl->Tsavestack_ix;
7417 I32 max = proto_perl->Tsavestack_max;
7418 ANY *nss;
7419 SV *sv;
7420 GV *gv;
7421 AV *av;
7422 HV *hv;
7423 void* ptr;
7424 int intval;
7425 long longval;
7426 GP *gp;
7427 IV iv;
7428 I32 i;
7429 char *c;
7430 void (*dptr) (void*);
7431 void (*dxptr) (pTHXo_ void*);
e977893f 7432 OP *o;
1d7c1841
GS		 7433
7434 Newz(54, nss, max, ANY);
7435
7436 while (ix > 0) {
7437 i = POPINT(ss,ix);
7438 TOPINT(nss,ix) = i;
7439 switch (i) {
7440 case SAVEt_ITEM: /* normal string */
7441 sv = (SV*)POPPTR(ss,ix);
7442 TOPPTR(nss,ix) = sv_dup_inc(sv);
7443 sv = (SV*)POPPTR(ss,ix);
7444 TOPPTR(nss,ix) = sv_dup_inc(sv);
7445 break;
7446 case SAVEt_SV: /* scalar reference */
7447 sv = (SV*)POPPTR(ss,ix);
7448 TOPPTR(nss,ix) = sv_dup_inc(sv);
7449 gv = (GV*)POPPTR(ss,ix);
7450 TOPPTR(nss,ix) = gv_dup_inc(gv);
7451 break;
f4dd75d9
GS		 7452 case SAVEt_GENERIC_PVREF: /* generic char* */
7453 c = (char*)POPPTR(ss,ix);
7454 TOPPTR(nss,ix) = pv_dup(c);
7455 ptr = POPPTR(ss,ix);
7456 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7457 break;
1d7c1841
GS		 7458 case SAVEt_GENERIC_SVREF: /* generic sv */
7459 case SAVEt_SVREF: /* scalar reference */
7460 sv = (SV*)POPPTR(ss,ix);
7461 TOPPTR(nss,ix) = sv_dup_inc(sv);
7462 ptr = POPPTR(ss,ix);
7463 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7464 break;
7465 case SAVEt_AV: /* array reference */
7466 av = (AV*)POPPTR(ss,ix);
7467 TOPPTR(nss,ix) = av_dup_inc(av);
7468 gv = (GV*)POPPTR(ss,ix);
7469 TOPPTR(nss,ix) = gv_dup(gv);
7470 break;
7471 case SAVEt_HV: /* hash reference */
7472 hv = (HV*)POPPTR(ss,ix);
7473 TOPPTR(nss,ix) = hv_dup_inc(hv);
7474 gv = (GV*)POPPTR(ss,ix);
7475 TOPPTR(nss,ix) = gv_dup(gv);
7476 break;
7477 case SAVEt_INT: /* int reference */
7478 ptr = POPPTR(ss,ix);
7479 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7480 intval = (int)POPINT(ss,ix);
7481 TOPINT(nss,ix) = intval;
7482 break;
7483 case SAVEt_LONG: /* long reference */
7484 ptr = POPPTR(ss,ix);
7485 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7486 longval = (long)POPLONG(ss,ix);
7487 TOPLONG(nss,ix) = longval;
7488 break;
7489 case SAVEt_I32: /* I32 reference */
7490 case SAVEt_I16: /* I16 reference */
7491 case SAVEt_I8: /* I8 reference */
7492 ptr = POPPTR(ss,ix);
7493 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7494 i = POPINT(ss,ix);
7495 TOPINT(nss,ix) = i;
7496 break;
7497 case SAVEt_IV: /* IV reference */
7498 ptr = POPPTR(ss,ix);
7499 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7500 iv = POPIV(ss,ix);
7501 TOPIV(nss,ix) = iv;
7502 break;
7503 case SAVEt_SPTR: /* SV* reference */
7504 ptr = POPPTR(ss,ix);
7505 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7506 sv = (SV*)POPPTR(ss,ix);
7507 TOPPTR(nss,ix) = sv_dup(sv);
7508 break;
7509 case SAVEt_VPTR: /* random* reference */
7510 ptr = POPPTR(ss,ix);
7511 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7512 ptr = POPPTR(ss,ix);
7513 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7514 break;
7515 case SAVEt_PPTR: /* char* reference */
7516 ptr = POPPTR(ss,ix);
7517 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7518 c = (char*)POPPTR(ss,ix);
7519 TOPPTR(nss,ix) = pv_dup(c);
7520 break;
7521 case SAVEt_HPTR: /* HV* reference */
7522 ptr = POPPTR(ss,ix);
7523 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7524 hv = (HV*)POPPTR(ss,ix);
7525 TOPPTR(nss,ix) = hv_dup(hv);
7526 break;
7527 case SAVEt_APTR: /* AV* reference */
7528 ptr = POPPTR(ss,ix);
7529 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7530 av = (AV*)POPPTR(ss,ix);
7531 TOPPTR(nss,ix) = av_dup(av);
7532 break;
7533 case SAVEt_NSTAB:
7534 gv = (GV*)POPPTR(ss,ix);
7535 TOPPTR(nss,ix) = gv_dup(gv);
7536 break;
7537 case SAVEt_GP: /* scalar reference */
7538 gp = (GP*)POPPTR(ss,ix);
7539 TOPPTR(nss,ix) = gp = gp_dup(gp);
7540 (void)GpREFCNT_inc(gp);
7541 gv = (GV*)POPPTR(ss,ix);
7542 TOPPTR(nss,ix) = gv_dup_inc(c);
7543 c = (char*)POPPTR(ss,ix);
7544 TOPPTR(nss,ix) = pv_dup(c);
7545 iv = POPIV(ss,ix);
7546 TOPIV(nss,ix) = iv;
7547 iv = POPIV(ss,ix);
7548 TOPIV(nss,ix) = iv;
7549 break;
7550 case SAVEt_FREESV:
7551 sv = (SV*)POPPTR(ss,ix);
7552 TOPPTR(nss,ix) = sv_dup_inc(sv);
7553 break;
7554 case SAVEt_FREEOP:
7555 ptr = POPPTR(ss,ix);
7556 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7557 /* these are assumed to be refcounted properly */
7558 switch (((OP*)ptr)->op_type) {
7559 case OP_LEAVESUB:
7560 case OP_LEAVESUBLV:
7561 case OP_LEAVEEVAL:
7562 case OP_LEAVE:
7563 case OP_SCOPE:
7564 case OP_LEAVEWRITE:
e977893f
GS		 7565 TOPPTR(nss,ix) = ptr;
7566 o = (OP*)ptr;
7567 OpREFCNT_inc(o);
1d7c1841
GS		 7568 break;
7569 default:
7570 TOPPTR(nss,ix) = Nullop;
7571 break;
7572 }
7573 }
7574 else
7575 TOPPTR(nss,ix) = Nullop;
7576 break;
7577 case SAVEt_FREEPV:
7578 c = (char*)POPPTR(ss,ix);
7579 TOPPTR(nss,ix) = pv_dup_inc(c);
7580 break;
7581 case SAVEt_CLEARSV:
7582 longval = POPLONG(ss,ix);
7583 TOPLONG(nss,ix) = longval;
7584 break;
7585 case SAVEt_DELETE:
7586 hv = (HV*)POPPTR(ss,ix);
7587 TOPPTR(nss,ix) = hv_dup_inc(hv);
7588 c = (char*)POPPTR(ss,ix);
7589 TOPPTR(nss,ix) = pv_dup_inc(c);
7590 i = POPINT(ss,ix);
7591 TOPINT(nss,ix) = i;
7592 break;
7593 case SAVEt_DESTRUCTOR:
7594 ptr = POPPTR(ss,ix);
7595 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7596 dptr = POPDPTR(ss,ix);
ef75a179 7597 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
1d7c1841
GS		 7598 break;
7599 case SAVEt_DESTRUCTOR_X:
7600 ptr = POPPTR(ss,ix);
7601 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7602 dxptr = POPDXPTR(ss,ix);
ef75a179 7603 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
1d7c1841
GS		 7604 break;
7605 case SAVEt_REGCONTEXT:
7606 case SAVEt_ALLOC:
7607 i = POPINT(ss,ix);
7608 TOPINT(nss,ix) = i;
7609 ix -= i;
7610 break;
7611 case SAVEt_STACK_POS: /* Position on Perl stack */
7612 i = POPINT(ss,ix);
7613 TOPINT(nss,ix) = i;
7614 break;
7615 case SAVEt_AELEM: /* array element */
7616 sv = (SV*)POPPTR(ss,ix);
7617 TOPPTR(nss,ix) = sv_dup_inc(sv);
7618 i = POPINT(ss,ix);
7619 TOPINT(nss,ix) = i;
7620 av = (AV*)POPPTR(ss,ix);
7621 TOPPTR(nss,ix) = av_dup_inc(av);
7622 break;
7623 case SAVEt_HELEM: /* hash element */
7624 sv = (SV*)POPPTR(ss,ix);
7625 TOPPTR(nss,ix) = sv_dup_inc(sv);
7626 sv = (SV*)POPPTR(ss,ix);
7627 TOPPTR(nss,ix) = sv_dup_inc(sv);
7628 hv = (HV*)POPPTR(ss,ix);
7629 TOPPTR(nss,ix) = hv_dup_inc(hv);
7630 break;
7631 case SAVEt_OP:
7632 ptr = POPPTR(ss,ix);
7633 TOPPTR(nss,ix) = ptr;
7634 break;
7635 case SAVEt_HINTS:
7636 i = POPINT(ss,ix);
7637 TOPINT(nss,ix) = i;
7638 break;
c4410b1b
GS		 7639 case SAVEt_COMPPAD:
7640 av = (AV*)POPPTR(ss,ix);
7641 TOPPTR(nss,ix) = av_dup(av);
7642 break;
c3564e5c
GS		 7643 case SAVEt_PADSV:
7644 longval = (long)POPLONG(ss,ix);
7645 TOPLONG(nss,ix) = longval;
7646 ptr = POPPTR(ss,ix);
7647 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7648 sv = (SV*)POPPTR(ss,ix);
7649 TOPPTR(nss,ix) = sv_dup(sv);
7650 break;
1d7c1841
GS		 7651 default:
7652 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7653 }
7654 }
7655
7656 return nss;
7657}
7658
7659#ifdef PERL_OBJECT
7660#include "XSUB.h"
7661#endif
7662
7663PerlInterpreter *
7664perl_clone(PerlInterpreter *proto_perl, UV flags)
7665{
7666#ifdef PERL_OBJECT
7667 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7668#endif
7669
7670#ifdef PERL_IMPLICIT_SYS
7671 return perl_clone_using(proto_perl, flags,
7672 proto_perl->IMem,
7673 proto_perl->IMemShared,
7674 proto_perl->IMemParse,
7675 proto_perl->IEnv,
7676 proto_perl->IStdIO,
7677 proto_perl->ILIO,
7678 proto_perl->IDir,
7679 proto_perl->ISock,
7680 proto_perl->IProc);
7681}
7682
7683PerlInterpreter *
7684perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7685 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7686 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7687 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7688 struct IPerlDir* ipD, struct IPerlSock* ipS,
7689 struct IPerlProc* ipP)
7690{
7691 /* XXX many of the string copies here can be optimized if they're
7692 * constants; they need to be allocated as common memory and just
7693 * their pointers copied. */
7694
7695 IV i;
1d7c1841
GS		 7696# ifdef PERL_OBJECT
7697 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7698 ipD, ipS, ipP);
ba869deb 7699 PERL_SET_THX(pPerl);
1d7c1841
GS		 7700# else /* !PERL_OBJECT */
7701 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
ba869deb 7702 PERL_SET_THX(my_perl);
1d7c1841
GS		 7703
7704# ifdef DEBUGGING
7705 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7706 PL_markstack = 0;
7707 PL_scopestack = 0;
7708 PL_savestack = 0;
7709 PL_retstack = 0;
7710# else /* !DEBUGGING */
7711 Zero(my_perl, 1, PerlInterpreter);
7712# endif /* DEBUGGING */
7713
7714 /* host pointers */
7715 PL_Mem = ipM;
7716 PL_MemShared = ipMS;
7717 PL_MemParse = ipMP;
7718 PL_Env = ipE;
7719 PL_StdIO = ipStd;
7720 PL_LIO = ipLIO;
7721 PL_Dir = ipD;
7722 PL_Sock = ipS;
7723 PL_Proc = ipP;
7724# endif /* PERL_OBJECT */
7725#else /* !PERL_IMPLICIT_SYS */
7726 IV i;
1d7c1841 7727 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 7728 PERL_SET_THX(my_perl);
1d7c1841
GS		 7729
7730# ifdef DEBUGGING
7731 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7732 PL_markstack = 0;
7733 PL_scopestack = 0;
7734 PL_savestack = 0;
7735 PL_retstack = 0;
7736# else /* !DEBUGGING */
7737 Zero(my_perl, 1, PerlInterpreter);
7738# endif /* DEBUGGING */
7739#endif /* PERL_IMPLICIT_SYS */
7740
7741 /* arena roots */
7742 PL_xiv_arenaroot = NULL;
7743 PL_xiv_root = NULL;
612f20c3 7744 PL_xnv_arenaroot = NULL;
1d7c1841 7745 PL_xnv_root = NULL;
612f20c3 7746 PL_xrv_arenaroot = NULL;
1d7c1841 7747 PL_xrv_root = NULL;
612f20c3 7748 PL_xpv_arenaroot = NULL;
1d7c1841 7749 PL_xpv_root = NULL;
612f20c3 7750 PL_xpviv_arenaroot = NULL;
1d7c1841 7751 PL_xpviv_root = NULL;
612f20c3 7752 PL_xpvnv_arenaroot = NULL;
1d7c1841 7753 PL_xpvnv_root = NULL;
612f20c3 7754 PL_xpvcv_arenaroot = NULL;
1d7c1841 7755 PL_xpvcv_root = NULL;
612f20c3 7756 PL_xpvav_arenaroot = NULL;
1d7c1841 7757 PL_xpvav_root = NULL;
612f20c3 7758 PL_xpvhv_arenaroot = NULL;
1d7c1841 7759 PL_xpvhv_root = NULL;
612f20c3 7760 PL_xpvmg_arenaroot = NULL;
1d7c1841 7761 PL_xpvmg_root = NULL;
612f20c3 7762 PL_xpvlv_arenaroot = NULL;
1d7c1841 7763 PL_xpvlv_root = NULL;
612f20c3 7764 PL_xpvbm_arenaroot = NULL;
1d7c1841 7765 PL_xpvbm_root = NULL;
612f20c3 7766 PL_he_arenaroot = NULL;
1d7c1841
GS		 7767 PL_he_root = NULL;
7768 PL_nice_chunk = NULL;
7769 PL_nice_chunk_size = 0;
7770 PL_sv_count = 0;
7771 PL_sv_objcount = 0;
7772 PL_sv_root = Nullsv;
7773 PL_sv_arenaroot = Nullsv;
7774
7775 PL_debug = proto_perl->Idebug;
7776
7777 /* create SV map for pointer relocation */
7778 PL_ptr_table = ptr_table_new();
7779
7780 /* initialize these special pointers as early as possible */
7781 SvANY(&PL_sv_undef) = NULL;
7782 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7783 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7784 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7785
7786#ifdef PERL_OBJECT
7787 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7788#else
7789 SvANY(&PL_sv_no) = new_XPVNV();
7790#endif
7791 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7792 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7793 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7794 SvCUR(&PL_sv_no) = 0;
7795 SvLEN(&PL_sv_no) = 1;
7796 SvNVX(&PL_sv_no) = 0;
7797 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7798
7799#ifdef PERL_OBJECT
7800 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7801#else
7802 SvANY(&PL_sv_yes) = new_XPVNV();
7803#endif
7804 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7805 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7806 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7807 SvCUR(&PL_sv_yes) = 1;
7808 SvLEN(&PL_sv_yes) = 2;
7809 SvNVX(&PL_sv_yes) = 1;
7810 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7811
7812 /* create shared string table */
7813 PL_strtab = newHV();
7814 HvSHAREKEYS_off(PL_strtab);
7815 hv_ksplit(PL_strtab, 512);
7816 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7817
7818 PL_compiling = proto_perl->Icompiling;
7819 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7820 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7821 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7822 if (!specialWARN(PL_compiling.cop_warnings))
7823 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
ac27b0f5
NIS		 7824 if (!specialCopIO(PL_compiling.cop_io))
7825 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
1d7c1841
GS		 7826 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7827
7828 /* pseudo environmental stuff */
7829 PL_origargc = proto_perl->Iorigargc;
7830 i = PL_origargc;
7831 New(0, PL_origargv, i+1, char*);
7832 PL_origargv[i] = '\0';
7833 while (i-- > 0) {
7834 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7835 }
7836 PL_envgv = gv_dup(proto_perl->Ienvgv);
7837 PL_incgv = gv_dup(proto_perl->Iincgv);
7838 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7839 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7840 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7841 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7842
7843 /* switches */
7844 PL_minus_c = proto_perl->Iminus_c;
a7cb1f99 7845 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
1d7c1841
GS		 7846 PL_localpatches = proto_perl->Ilocalpatches;
7847 PL_splitstr = proto_perl->Isplitstr;
7848 PL_preprocess = proto_perl->Ipreprocess;
7849 PL_minus_n = proto_perl->Iminus_n;
7850 PL_minus_p = proto_perl->Iminus_p;
7851 PL_minus_l = proto_perl->Iminus_l;
7852 PL_minus_a = proto_perl->Iminus_a;
7853 PL_minus_F = proto_perl->Iminus_F;
7854 PL_doswitches = proto_perl->Idoswitches;
7855 PL_dowarn = proto_perl->Idowarn;
7856 PL_doextract = proto_perl->Idoextract;
7857 PL_sawampersand = proto_perl->Isawampersand;
7858 PL_unsafe = proto_perl->Iunsafe;
7859 PL_inplace = SAVEPV(proto_perl->Iinplace);
7860 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7861 PL_perldb = proto_perl->Iperldb;
7862 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7863
7864 /* magical thingies */
7865 /* XXX time(&PL_basetime) when asked for? */
7866 PL_basetime = proto_perl->Ibasetime;
7867 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7868
7869 PL_maxsysfd = proto_perl->Imaxsysfd;
7870 PL_multiline = proto_perl->Imultiline;
7871 PL_statusvalue = proto_perl->Istatusvalue;
7872#ifdef VMS
7873 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7874#endif
7875
7876 /* shortcuts to various I/O objects */
7877 PL_stdingv = gv_dup(proto_perl->Istdingv);
7878 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7879 PL_defgv = gv_dup(proto_perl->Idefgv);
7880 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7881 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7882 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7883
7884 /* shortcuts to regexp stuff */
7885 PL_replgv = gv_dup(proto_perl->Ireplgv);
7886
7887 /* shortcuts to misc objects */
7888 PL_errgv = gv_dup(proto_perl->Ierrgv);
7889
7890 /* shortcuts to debugging objects */
7891 PL_DBgv = gv_dup(proto_perl->IDBgv);
7892 PL_DBline = gv_dup(proto_perl->IDBline);
7893 PL_DBsub = gv_dup(proto_perl->IDBsub);
7894 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7895 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7896 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7897 PL_lineary = av_dup(proto_perl->Ilineary);
7898 PL_dbargs = av_dup(proto_perl->Idbargs);
7899
7900 /* symbol tables */
7901 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7902 PL_curstash = hv_dup(proto_perl->Tcurstash);
7903 PL_debstash = hv_dup(proto_perl->Idebstash);
7904 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7905 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7906
7907 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7908 PL_endav = av_dup_inc(proto_perl->Iendav);
7d30b5c4 7909 PL_checkav = av_dup_inc(proto_perl->Icheckav);
1d7c1841
GS		 7910 PL_initav = av_dup_inc(proto_perl->Iinitav);
7911
7912 PL_sub_generation = proto_perl->Isub_generation;
7913
7914 /* funky return mechanisms */
7915 PL_forkprocess = proto_perl->Iforkprocess;
7916
7917 /* subprocess state */
7918 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7919
7920 /* internal state */
7921 PL_tainting = proto_perl->Itainting;
7922 PL_maxo = proto_perl->Imaxo;
7923 if (proto_perl->Iop_mask)
7924 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7925 else
7926 PL_op_mask = Nullch;
7927
7928 /* current interpreter roots */
7929 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7930 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7931 PL_main_start = proto_perl->Imain_start;
e977893f 7932 PL_eval_root = proto_perl->Ieval_root;
1d7c1841
GS		 7933 PL_eval_start = proto_perl->Ieval_start;
7934
7935 /* runtime control stuff */
7936 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7937 PL_copline = proto_perl->Icopline;
7938
7939 PL_filemode = proto_perl->Ifilemode;
7940 PL_lastfd = proto_perl->Ilastfd;
7941 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7942 PL_Argv = NULL;
7943 PL_Cmd = Nullch;
7944 PL_gensym = proto_perl->Igensym;
7945 PL_preambled = proto_perl->Ipreambled;
7946 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7947 PL_laststatval = proto_perl->Ilaststatval;
7948 PL_laststype = proto_perl->Ilaststype;
7949 PL_mess_sv = Nullsv;
7950
7951 PL_orslen = proto_perl->Iorslen;
7952 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7953 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7954
7955 /* interpreter atexit processing */
7956 PL_exitlistlen = proto_perl->Iexitlistlen;
7957 if (PL_exitlistlen) {
7958 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7959 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7960 }
7961 else
7962 PL_exitlist = (PerlExitListEntry*)NULL;
7963 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7964
7965 PL_profiledata = NULL;
7966 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7967 /* PL_rsfp_filters entries have fake IoDIRP() */
7968 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7969
7970 PL_compcv = cv_dup(proto_perl->Icompcv);
7971 PL_comppad = av_dup(proto_perl->Icomppad);
7972 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7973 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7974 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7975 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7976 proto_perl->Tcurpad);
7977
7978#ifdef HAVE_INTERP_INTERN
7979 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7980#endif
7981
7982 /* more statics moved here */
7983 PL_generation = proto_perl->Igeneration;
7984 PL_DBcv = cv_dup(proto_perl->IDBcv);
1d7c1841
GS		 7985
7986 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7987 PL_in_clean_all = proto_perl->Iin_clean_all;
7988
7989 PL_uid = proto_perl->Iuid;
7990 PL_euid = proto_perl->Ieuid;
7991 PL_gid = proto_perl->Igid;
7992 PL_egid = proto_perl->Iegid;
7993 PL_nomemok = proto_perl->Inomemok;
7994 PL_an = proto_perl->Ian;
7995 PL_cop_seqmax = proto_perl->Icop_seqmax;
7996 PL_op_seqmax = proto_perl->Iop_seqmax;
7997 PL_evalseq = proto_perl->Ievalseq;
7998 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7999 PL_origalen = proto_perl->Iorigalen;
8000 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8001 PL_osname = SAVEPV(proto_perl->Iosname);
8002 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8003 PL_sighandlerp = proto_perl->Isighandlerp;
8004
8005
8006 PL_runops = proto_perl->Irunops;
8007
8008 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8009
8010#ifdef CSH
8011 PL_cshlen = proto_perl->Icshlen;
8012 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8013#endif
8014
8015 PL_lex_state = proto_perl->Ilex_state;
8016 PL_lex_defer = proto_perl->Ilex_defer;
8017 PL_lex_expect = proto_perl->Ilex_expect;
8018 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8019 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8020 PL_lex_starts = proto_perl->Ilex_starts;
8021 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8022 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8023 PL_lex_op = proto_perl->Ilex_op;
8024 PL_lex_inpat = proto_perl->Ilex_inpat;
8025 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8026 PL_lex_brackets = proto_perl->Ilex_brackets;
8027 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8028 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8029 PL_lex_casemods = proto_perl->Ilex_casemods;
8030 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8031 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8032
8033 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8034 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8035 PL_nexttoke = proto_perl->Inexttoke;
8036
8037 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8038 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8039 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8040 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8041 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8042 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8043 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8044 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8045 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8046 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8047 PL_pending_ident = proto_perl->Ipending_ident;
8048 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8049
8050 PL_expect = proto_perl->Iexpect;
8051
8052 PL_multi_start = proto_perl->Imulti_start;
8053 PL_multi_end = proto_perl->Imulti_end;
8054 PL_multi_open = proto_perl->Imulti_open;
8055 PL_multi_close = proto_perl->Imulti_close;
8056
8057 PL_error_count = proto_perl->Ierror_count;
8058 PL_subline = proto_perl->Isubline;
8059 PL_subname = sv_dup_inc(proto_perl->Isubname);
8060
8061 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8062 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8063 PL_padix = proto_perl->Ipadix;
8064 PL_padix_floor = proto_perl->Ipadix_floor;
8065 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8066
8067 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8068 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8069 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8070 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8071 PL_last_lop_op = proto_perl->Ilast_lop_op;
8072 PL_in_my = proto_perl->Iin_my;
8073 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8074#ifdef FCRYPT
8075 PL_cryptseen = proto_perl->Icryptseen;
8076#endif
8077
8078 PL_hints = proto_perl->Ihints;
8079
8080 PL_amagic_generation = proto_perl->Iamagic_generation;
8081
8082#ifdef USE_LOCALE_COLLATE
8083 PL_collation_ix = proto_perl->Icollation_ix;
8084 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8085 PL_collation_standard = proto_perl->Icollation_standard;
8086 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8087 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8088#endif /* USE_LOCALE_COLLATE */
8089
8090#ifdef USE_LOCALE_NUMERIC
8091 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8092 PL_numeric_standard = proto_perl->Inumeric_standard;
8093 PL_numeric_local = proto_perl->Inumeric_local;
8094 PL_numeric_radix = proto_perl->Inumeric_radix;
8095#endif /* !USE_LOCALE_NUMERIC */
8096
8097 /* utf8 character classes */
8098 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8099 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8100 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8101 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8102 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8103 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8104 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8105 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8106 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8107 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8108 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8109 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8110 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8111 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8112 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8113 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8114 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8115
8116 /* swatch cache */
8117 PL_last_swash_hv = Nullhv; /* reinits on demand */
8118 PL_last_swash_klen = 0;
8119 PL_last_swash_key[0]= '\0';
8120 PL_last_swash_tmps = (U8*)NULL;
8121 PL_last_swash_slen = 0;
8122
8123 /* perly.c globals */
8124 PL_yydebug = proto_perl->Iyydebug;
8125 PL_yynerrs = proto_perl->Iyynerrs;
8126 PL_yyerrflag = proto_perl->Iyyerrflag;
8127 PL_yychar = proto_perl->Iyychar;
8128 PL_yyval = proto_perl->Iyyval;
8129 PL_yylval = proto_perl->Iyylval;
8130
8131 PL_glob_index = proto_perl->Iglob_index;
8132 PL_srand_called = proto_perl->Isrand_called;
8133 PL_uudmap['M'] = 0; /* reinits on demand */
8134 PL_bitcount = Nullch; /* reinits on demand */
8135
8136 if (proto_perl->Ipsig_ptr) {
8137 int sig_num[] = { SIG_NUM };
8138 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8139 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8140 for (i = 1; PL_sig_name[i]; i++) {
8141 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8142 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8143 }
8144 }
8145 else {
8146 PL_psig_ptr = (SV**)NULL;
8147 PL_psig_name = (SV**)NULL;
8148 }
8149
8150 /* thrdvar.h stuff */
8151
8152 if (flags & 1) {
8153 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8154 PL_tmps_ix = proto_perl->Ttmps_ix;
8155 PL_tmps_max = proto_perl->Ttmps_max;
8156 PL_tmps_floor = proto_perl->Ttmps_floor;
8157 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8158 i = 0;
8159 while (i <= PL_tmps_ix) {
8160 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8161 ++i;
8162 }
8163
8164 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8165 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8166 Newz(54, PL_markstack, i, I32);
8167 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8168 - proto_perl->Tmarkstack);
8169 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8170 - proto_perl->Tmarkstack);
8171 Copy(proto_perl->Tmarkstack, PL_markstack,
8172 PL_markstack_ptr - PL_markstack + 1, I32);
8173
8174 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8175 * NOTE: unlike the others! */
8176 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8177 PL_scopestack_max = proto_perl->Tscopestack_max;
8178 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8179 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8180
8181 /* next push_return() sets PL_retstack[PL_retstack_ix]
8182 * NOTE: unlike the others! */
8183 PL_retstack_ix = proto_perl->Tretstack_ix;
8184 PL_retstack_max = proto_perl->Tretstack_max;
8185 Newz(54, PL_retstack, PL_retstack_max, OP*);
8186 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8187
8188 /* NOTE: si_dup() looks at PL_markstack */
8189 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8190
8191 /* PL_curstack = PL_curstackinfo->si_stack; */
8192 PL_curstack = av_dup(proto_perl->Tcurstack);
8193 PL_mainstack = av_dup(proto_perl->Tmainstack);
8194
8195 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8196 PL_stack_base = AvARRAY(PL_curstack);
8197 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8198 - proto_perl->Tstack_base);
8199 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8200
8201 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8202 * NOTE: unlike the others! */
8203 PL_savestack_ix = proto_perl->Tsavestack_ix;
8204 PL_savestack_max = proto_perl->Tsavestack_max;
8205 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8206 PL_savestack = ss_dup(proto_perl);
8207 }
8208 else {
8209 init_stacks();
985e7056 8210 ENTER; /* perl_destruct() wants to LEAVE; */
1d7c1841
GS		 8211 }
8212
8213 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8214 PL_top_env = &PL_start_env;
8215
8216 PL_op = proto_perl->Top;
8217
8218 PL_Sv = Nullsv;
8219 PL_Xpv = (XPV*)NULL;
8220 PL_na = proto_perl->Tna;
8221
8222 PL_statbuf = proto_perl->Tstatbuf;
8223 PL_statcache = proto_perl->Tstatcache;
8224 PL_statgv = gv_dup(proto_perl->Tstatgv);
8225 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8226#ifdef HAS_TIMES
8227 PL_timesbuf = proto_perl->Ttimesbuf;
8228#endif
8229
8230 PL_tainted = proto_perl->Ttainted;
8231 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8232 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8233 PL_rs = sv_dup_inc(proto_perl->Trs);
8234 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8235 PL_ofslen = proto_perl->Tofslen;
8236 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8237 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8238 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8239 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8240 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8241 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8242
8243 PL_restartop = proto_perl->Trestartop;
8244 PL_in_eval = proto_perl->Tin_eval;
8245 PL_delaymagic = proto_perl->Tdelaymagic;
8246 PL_dirty = proto_perl->Tdirty;
8247 PL_localizing = proto_perl->Tlocalizing;
8248
14dd3ad8 8249#ifdef PERL_FLEXIBLE_EXCEPTIONS
1d7c1841 8250 PL_protect = proto_perl->Tprotect;
14dd3ad8 8251#endif
1d7c1841
GS		 8252 PL_errors = sv_dup_inc(proto_perl->Terrors);
8253 PL_av_fetch_sv = Nullsv;
8254 PL_hv_fetch_sv = Nullsv;
8255 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8256 PL_modcount = proto_perl->Tmodcount;
8257 PL_lastgotoprobe = Nullop;
8258 PL_dumpindent = proto_perl->Tdumpindent;
8259
8260 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8261 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8262 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8263 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8264 PL_sortcxix = proto_perl->Tsortcxix;
8265 PL_efloatbuf = Nullch; /* reinits on demand */
8266 PL_efloatsize = 0; /* reinits on demand */
8267
8268 /* regex stuff */
8269
8270 PL_screamfirst = NULL;
8271 PL_screamnext = NULL;
8272 PL_maxscream = -1; /* reinits on demand */
8273 PL_lastscream = Nullsv;
8274
8275 PL_watchaddr = NULL;
8276 PL_watchok = Nullch;
8277
8278 PL_regdummy = proto_perl->Tregdummy;
8279 PL_regcomp_parse = Nullch;
8280 PL_regxend = Nullch;
8281 PL_regcode = (regnode*)NULL;
8282 PL_regnaughty = 0;
8283 PL_regsawback = 0;
8284 PL_regprecomp = Nullch;
8285 PL_regnpar = 0;
8286 PL_regsize = 0;
8287 PL_regflags = 0;
8288 PL_regseen = 0;
8289 PL_seen_zerolen = 0;
8290 PL_seen_evals = 0;
8291 PL_regcomp_rx = (regexp*)NULL;
8292 PL_extralen = 0;
8293 PL_colorset = 0; /* reinits PL_colors[] */
8294 /*PL_colors[6] = {0,0,0,0,0,0};*/
8295 PL_reg_whilem_seen = 0;
8296 PL_reginput = Nullch;
8297 PL_regbol = Nullch;
8298 PL_regeol = Nullch;
8299 PL_regstartp = (I32*)NULL;
8300 PL_regendp = (I32*)NULL;
8301 PL_reglastparen = (U32*)NULL;
8302 PL_regtill = Nullch;
8303 PL_regprev = '\n';
8304 PL_reg_start_tmp = (char**)NULL;
8305 PL_reg_start_tmpl = 0;
8306 PL_regdata = (struct reg_data*)NULL;
8307 PL_bostr = Nullch;
8308 PL_reg_flags = 0;
8309 PL_reg_eval_set = 0;
8310 PL_regnarrate = 0;
8311 PL_regprogram = (regnode*)NULL;
8312 PL_regindent = 0;
8313 PL_regcc = (CURCUR*)NULL;
8314 PL_reg_call_cc = (struct re_cc_state*)NULL;
8315 PL_reg_re = (regexp*)NULL;
8316 PL_reg_ganch = Nullch;
8317 PL_reg_sv = Nullsv;
8318 PL_reg_magic = (MAGIC*)NULL;
8319 PL_reg_oldpos = 0;
8320 PL_reg_oldcurpm = (PMOP*)NULL;
8321 PL_reg_curpm = (PMOP*)NULL;
8322 PL_reg_oldsaved = Nullch;
8323 PL_reg_oldsavedlen = 0;
8324 PL_reg_maxiter = 0;
8325 PL_reg_leftiter = 0;
8326 PL_reg_poscache = Nullch;
8327 PL_reg_poscache_size= 0;
8328
8329 /* RE engine - function pointers */
8330 PL_regcompp = proto_perl->Tregcompp;
8331 PL_regexecp = proto_perl->Tregexecp;
8332 PL_regint_start = proto_perl->Tregint_start;
8333 PL_regint_string = proto_perl->Tregint_string;
8334 PL_regfree = proto_perl->Tregfree;
8335
8336 PL_reginterp_cnt = 0;
8337 PL_reg_starttry = 0;
8338
8339#ifdef PERL_OBJECT
8340 return (PerlInterpreter*)pPerl;
8341#else
8342 return my_perl;
8343#endif
8344}
8345
8346#else /* !USE_ITHREADS */
51371543
GS		 8347
8348#ifdef PERL_OBJECT
51371543
GS		 8349#include "XSUB.h"
8350#endif
8351
1d7c1841
GS		 8352#endif /* USE_ITHREADS */
8353
51371543
GS		 8354static void
8355do_report_used(pTHXo_ SV *sv)
8356{
8357 if (SvTYPE(sv) != SVTYPEMASK) {
bf49b057 8358 PerlIO_printf(Perl_debug_log, "****\n");
51371543
GS		 8359 sv_dump(sv);
8360 }
8361}
8362
8363static void
8364do_clean_objs(pTHXo_ SV *sv)
8365{
8366 SV* rv;
8367
8368 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8369 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8b6e653b
HS		 8370 if (SvWEAKREF(sv)) {
8371 sv_del_backref(sv);
8372 SvWEAKREF_off(sv);
8373 SvRV(sv) = 0;
8374 } else {
8375 SvROK_off(sv);
8376 SvRV(sv) = 0;
8377 SvREFCNT_dec(rv);
8378 }
51371543
GS		 8379 }
8380
8381 /* XXX Might want to check arrays, etc. */
8382}
8383
8384#ifndef DISABLE_DESTRUCTOR_KLUDGE
8385static void
8386do_clean_named_objs(pTHXo_ SV *sv)
8387{
f472eb5c 8388 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
51371543 8389 if ( SvOBJECT(GvSV(sv)) ||
155aba94
GS		 8390 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8391 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8392 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8393 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
51371543
GS		 8394 {
8395 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8396 SvREFCNT_dec(sv);
8397 }
8398 }
8399}
8400#endif
8401
8402static void
8403do_clean_all(pTHXo_ SV *sv)
8404{
1d7c1841 8405 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
51371543
GS		 8406 SvFLAGS(sv) |= SVf_BREAK;
8407 SvREFCNT_dec(sv);
8408}
8af02333 8409
Unnamed repository; edit this file 'description' to name the repository.