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