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