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