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
More verbose failure.
[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);
61604483
HS		 2309 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2310 SvNOK_on(sv);
2311 }
2312 else if (SvIOKp(sv) &&
748a9306 2313 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
93a17b20 2314 {
65202027 2315 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
28e5dec8
JH		 2316#ifdef NV_PRESERVES_UV
2317 SvNOK_on(sv);
2318#else
2319 /* Only set the public NV OK flag if this NV preserves the IV */
2320 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2321 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2322 : (SvIVX(sv) == I_V(SvNVX(sv))))
2323 SvNOK_on(sv);
2324 else
2325 SvNOKp_on(sv);
2326#endif
93a17b20 2327 }
748a9306 2328 else if (SvPOKp(sv) && SvLEN(sv)) {
599cee73 2329 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
a0d0e21e 2330 not_a_number(sv);
097ee67d 2331 SvNVX(sv) = Atof(SvPVX(sv));
28e5dec8
JH		 2332#ifdef NV_PRESERVES_UV
2333 SvNOK_on(sv);
2334#else
2335 /* Only set the public NV OK flag if this NV preserves the value in
2336 the PV at least as well as an IV/UV would.
2337 Not sure how to do this 100% reliably. */
2338 /* if that shift count is out of range then Configure's test is
2339 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2340 UV_BITS */
2341 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2342 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2343 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2344 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2345 /* Definitely too large/small to fit in an integer, so no loss
2346 of precision going to integer in the future via NV */
2347 SvNOK_on(sv);
2348 } else {
2349 /* Is it something we can run through strtol etc (ie no
2350 trailing exponent part)? */
2351 int numtype = looks_like_number(sv);
2352 /* XXX probably should cache this if called above */
2353
2354 if (!(numtype &
2355 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2356 /* Can't use strtol etc to convert this string, so don't try */
2357 SvNOK_on(sv);
2358 } else
2359 sv_2inuv_non_preserve (sv, numtype);
2360 }
2361#endif /* NV_PRESERVES_UV */
93a17b20 2362 }
79072805 2363 else {
599cee73 2364 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2365 report_uninit();
25da4f38
IZ		 2366 if (SvTYPE(sv) < SVt_NV)
2367 /* Typically the caller expects that sv_any is not NULL now. */
28e5dec8
JH		 2368 /* XXX Ilya implies that this is a bug in callers that assume this
2369 and ideally should be fixed. */
25da4f38 2370 sv_upgrade(sv, SVt_NV);
a0d0e21e 2371 return 0.0;
79072805 2372 }
572bbb43 2373#if defined(USE_LONG_DOUBLE)
097ee67d 2374 DEBUG_c({
f93f4e46 2375 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2376 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2377 PTR2UV(sv), SvNVX(sv));
572bbb43
GS		 2378 RESTORE_NUMERIC_LOCAL();
2379 });
65202027 2380#else
572bbb43 2381 DEBUG_c({
f93f4e46 2382 STORE_NUMERIC_LOCAL_SET_STANDARD();
1d7c1841
GS		 2383 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2384 PTR2UV(sv), SvNVX(sv));
097ee67d
JH		 2385 RESTORE_NUMERIC_LOCAL();
2386 });
572bbb43 2387#endif
463ee0b2 2388 return SvNVX(sv);
79072805
LW		 2389}
2390
76e3520e 2391STATIC IV
cea2e8a9 2392S_asIV(pTHX_ SV *sv)
36477c24 2393{
2394 I32 numtype = looks_like_number(sv);
65202027 2395 NV d;
36477c24 2396
25da4f38 2397 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 2398 return Atol(SvPVX(sv));
d008e5eb 2399 if (!numtype) {
d008e5eb
GS		 2400 if (ckWARN(WARN_NUMERIC))
2401 not_a_number(sv);
2402 }
097ee67d 2403 d = Atof(SvPVX(sv));
25da4f38 2404 return I_V(d);
36477c24 2405}
2406
76e3520e 2407STATIC UV
cea2e8a9 2408S_asUV(pTHX_ SV *sv)
36477c24 2409{
2410 I32 numtype = looks_like_number(sv);
2411
84902520 2412#ifdef HAS_STRTOUL
25da4f38 2413 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
cf2093f6 2414 return Strtoul(SvPVX(sv), Null(char**), 10);
84902520 2415#endif
d008e5eb 2416 if (!numtype) {
d008e5eb
GS		 2417 if (ckWARN(WARN_NUMERIC))
2418 not_a_number(sv);
2419 }
097ee67d 2420 return U_V(Atof(SvPVX(sv)));
36477c24 2421}
2422
25da4f38
IZ		 2423/*
2424 * Returns a combination of (advisory only - can get false negatives)
28e5dec8
JH		 2425 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2426 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2427 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
25da4f38
IZ		 2428 * 0 if does not look like number.
2429 *
28e5dec8
JH		 2430 * (atol and strtol stop when they hit a decimal point. strtol will return
2431 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2432 * do this, and vendors have had 11 years to get it right.
2433 * However, will try to make it still work with only atol
d460ef45 2434 *
28e5dec8
JH		 2435 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2436 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2437 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2438 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2439 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2440 * IS_NUMBER_NOT_INT saw "." or "e"
2441 * IS_NUMBER_NEG
300aed98 2442 * IS_NUMBER_INFINITY
25da4f38
IZ		 2443 */
2444
954c1994
GS		 2445/*
2446=for apidoc looks_like_number
2447
2448Test if an the content of an SV looks like a number (or is a
28e5dec8
JH		 2449number). C<Inf> and C<Infinity> are treated as numbers (so will not
2450issue a non-numeric warning), even if your atof() doesn't grok them.
954c1994
GS		 2451
2452=cut
2453*/
2454
36477c24 2455I32
864dbfa3 2456Perl_looks_like_number(pTHX_ SV *sv)
36477c24 2457{
2458 register char *s;
2459 register char *send;
2460 register char *sbegin;
25da4f38
IZ		 2461 register char *nbegin;
2462 I32 numtype = 0;
300aed98 2463 I32 sawinf = 0;
36477c24 2464 STRLEN len;
9c7192ba 2465#ifdef USE_LOCALE_NUMERIC
eff180cd 2466 bool specialradix = FALSE;
9c7192ba 2467#endif
36477c24 2468
2469 if (SvPOK(sv)) {
1c846c1f 2470 sbegin = SvPVX(sv);
36477c24 2471 len = SvCUR(sv);
2472 }
2473 else if (SvPOKp(sv))
2474 sbegin = SvPV(sv, len);
2475 else
2476 return 1;
2477 send = sbegin + len;
2478
2479 s = sbegin;
2480 while (isSPACE(*s))
2481 s++;
25da4f38
IZ		 2482 if (*s == '-') {
2483 s++;
2484 numtype = IS_NUMBER_NEG;
2485 }
2486 else if (*s == '+')
36477c24 2487 s++;
ff0cee69 2488
25da4f38
IZ		 2489 nbegin = s;
2490 /*
d460ef45 2491 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
28e5dec8
JH		 2492 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2493 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2494 * will need (int)atof().
25da4f38
IZ		 2495 */
2496
300aed98 2497 /* next must be digit or the radix separator or beginning of infinity */
ff0cee69 2498 if (isDIGIT(*s)) {
2499 do {
2500 s++;
2501 } while (isDIGIT(*s));
25da4f38 2502
28e5dec8
JH		 2503 /* Aaargh. long long really is irritating.
2504 In the gospel according to ANSI 1989, it is an axiom that "long"
2505 is the longest integer type, and that if you don't know how long
2506 something is you can cast it to long, and nothing will be lost
2507 (except possibly speed of execution if long is slower than the
2508 type is was).
2509 Now, one can't be sure if the old rules apply, or long long
2510 (or some other newfangled thing) is actually longer than the
2511 (formerly) longest thing.
2512 */
2513 /* This lot will work for 64 bit *as long as* either
2514 either long is 64 bit
2515 or we can find both strtol/strtoq and strtoul/strtouq
2516 If not, we really should refuse to let the user use 64 bit IVs
2517 By "64 bit" I really mean IVs that don't get preserved by NVs
2518 It also should work for 128 bit IVs. Can any lend me a machine to
2519 test this?
2520 */
2521 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2522 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2523 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2524 ? sizeof(long) : sizeof (IV))*8-1))
f7bbb42a 2525 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
28e5dec8
JH		 2526 else
2527 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2528 digit less (IV_MAX= 9223372036854775807,
2529 UV_MAX= 18446744073709551615) so be cautious */
2530 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
25da4f38 2531
b1d91914 2532 if (
1c846c1f 2533#ifdef USE_LOCALE_NUMERIC
b1d91914 2534 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
097ee67d 2535#endif
b1d91914 2536 *s == '.') {
9c7192ba 2537#ifdef USE_LOCALE_NUMERIC
eff180cd 2538 if (specialradix)
a453c169 2539 s += SvCUR(PL_numeric_radix_sv);
eff180cd 2540 else
9c7192ba 2541#endif
eff180cd 2542 s++;
28e5dec8 2543 numtype |= IS_NUMBER_NOT_INT;
097ee67d 2544 while (isDIGIT(*s)) /* optional digits after the radix */
ff0cee69 2545 s++;
2546 }
36477c24 2547 }
b1d91914 2548 else if (
1c846c1f 2549#ifdef USE_LOCALE_NUMERIC
b1d91914 2550 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
097ee67d 2551#endif
b1d91914 2552 *s == '.'
097ee67d 2553 ) {
9c7192ba 2554#ifdef USE_LOCALE_NUMERIC
eff180cd 2555 if (specialradix)
a453c169 2556 s += SvCUR(PL_numeric_radix_sv);
eff180cd 2557 else
9c7192ba 2558#endif
eff180cd 2559 s++;
28e5dec8 2560 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
097ee67d 2561 /* no digits before the radix means we need digits after it */
ff0cee69 2562 if (isDIGIT(*s)) {
2563 do {
2564 s++;
2565 } while (isDIGIT(*s));
2566 }
2567 else
2568 return 0;
2569 }
300aed98
JH		 2570 else if (*s == 'I' || *s == 'i') {
2571 s++; if (*s != 'N' && *s != 'n') return 0;
2572 s++; if (*s != 'F' && *s != 'f') return 0;
2573 s++; if (*s == 'I' || *s == 'i') {
2574 s++; if (*s != 'N' && *s != 'n') return 0;
2575 s++; if (*s != 'I' && *s != 'i') return 0;
2576 s++; if (*s != 'T' && *s != 't') return 0;
2577 s++; if (*s != 'Y' && *s != 'y') return 0;
99938567 2578 s++;
300aed98
JH		 2579 }
2580 sawinf = 1;
2581 }
ff0cee69 2582 else
2583 return 0;
2584
300aed98 2585 if (sawinf)
28e5dec8
JH		 2586 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2587 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
300aed98
JH		 2588 else {
2589 /* we can have an optional exponent part */
2590 if (*s == 'e' || *s == 'E') {
28e5dec8
JH		 2591 numtype &= IS_NUMBER_NEG;
2592 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
36477c24 2593 s++;
300aed98
JH		 2594 if (*s == '+' || *s == '-')
2595 s++;
2596 if (isDIGIT(*s)) {
2597 do {
2598 s++;
2599 } while (isDIGIT(*s));
2600 }
2601 else
2602 return 0;
2603 }
36477c24 2604 }
2605 while (isSPACE(*s))
2606 s++;
80f3f388 2607 if (s >= send)
36477c24 2608 return numtype;
2609 if (len == 10 && memEQ(sbegin, "0 but true", 10))
25da4f38 2610 return IS_NUMBER_TO_INT_BY_ATOL;
36477c24 2611 return 0;
2612}
2613
79072805 2614char *
864dbfa3 2615Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1fa8b10d
JD		 2616{
2617 STRLEN n_a;
2618 return sv_2pv(sv, &n_a);
2619}
2620
25da4f38 2621/* We assume that buf is at least TYPE_CHARS(UV) long. */
864dbfa3 2622static char *
25da4f38
IZ		 2623uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2624{
25da4f38
IZ		 2625 char *ptr = buf + TYPE_CHARS(UV);
2626 char *ebuf = ptr;
2627 int sign;
25da4f38
IZ		 2628
2629 if (is_uv)
2630 sign = 0;
2631 else if (iv >= 0) {
2632 uv = iv;
2633 sign = 0;
2634 } else {
2635 uv = -iv;
2636 sign = 1;
2637 }
2638 do {
2639 *--ptr = '0' + (uv % 10);
2640 } while (uv /= 10);
2641 if (sign)
2642 *--ptr = '-';
2643 *peob = ebuf;
2644 return ptr;
2645}
2646
1fa8b10d 2647char *
864dbfa3 2648Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
79072805 2649{
36f65ada 2650 return sv_2pv_flags(sv, lp, SV_GMAGIC);
8d6d96c1
HS		 2651}
2652
2653char *
2654Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2655{
79072805
LW		 2656 register char *s;
2657 int olderrno;
46fc3d4c 2658 SV *tsv;
25da4f38
IZ		 2659 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2660 char *tmpbuf = tbuf;
79072805 2661
463ee0b2
LW		 2662 if (!sv) {
2663 *lp = 0;
2664 return "";
2665 }
8990e307 2666 if (SvGMAGICAL(sv)) {
8d6d96c1
HS		 2667 if (flags & SV_GMAGIC)
2668 mg_get(sv);
463ee0b2
LW		 2669 if (SvPOKp(sv)) {
2670 *lp = SvCUR(sv);
2671 return SvPVX(sv);
2672 }
cf2093f6 2673 if (SvIOKp(sv)) {
1c846c1f 2674 if (SvIsUV(sv))
57def98f 2675 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
cf2093f6 2676 else
57def98f 2677 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
46fc3d4c 2678 tsv = Nullsv;
a0d0e21e 2679 goto tokensave;
463ee0b2
LW		 2680 }
2681 if (SvNOKp(sv)) {
2d4389e4 2682 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
46fc3d4c 2683 tsv = Nullsv;
a0d0e21e 2684 goto tokensave;
463ee0b2 2685 }
16d20bd9 2686 if (!SvROK(sv)) {
d008e5eb 2687 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
d008e5eb 2688 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1d7c1841 2689 report_uninit();
c6ee37c5 2690 }
16d20bd9
AD		 2691 *lp = 0;
2692 return "";
2693 }
463ee0b2 2694 }
ed6116ce
LW		 2695 if (SvTHINKFIRST(sv)) {
2696 if (SvROK(sv)) {
a0d0e21e 2697 SV* tmpstr;
1554e226 2698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
1dc13c17 2699 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
9e7bc3e8 2700 return SvPV(tmpstr,*lp);
ed6116ce
LW		 2701 sv = (SV*)SvRV(sv);
2702 if (!sv)
2703 s = "NULLREF";
2704 else {
f9277f47
IZ		 2705 MAGIC *mg;
2706
ed6116ce 2707 switch (SvTYPE(sv)) {
f9277f47
IZ		 2708 case SVt_PVMG:
2709 if ( ((SvFLAGS(sv) &
1c846c1f 2710 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3149a8e4 2711 == (SVs_OBJECT|SVs_RMG))
57668c4d 2712 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
14befaf4 2713 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2cd61cdb 2714 regexp *re = (regexp *)mg->mg_obj;
1bd3ad17 2715
2cd61cdb 2716 if (!mg->mg_ptr) {
8782bef2
GB		 2717 char *fptr = "msix";
2718 char reflags[6];
2719 char ch;
2720 int left = 0;
2721 int right = 4;
2722 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2723
155aba94 2724 while((ch = *fptr++)) {
8782bef2
GB		 2725 if(reganch & 1) {
2726 reflags[left++] = ch;
2727 }
2728 else {
2729 reflags[right--] = ch;
2730 }
2731 reganch >>= 1;
2732 }
2733 if(left != 4) {
2734 reflags[left] = '-';
2735 left = 5;
2736 }
2737
2738 mg->mg_len = re->prelen + 4 + left;
2739 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2740 Copy("(?", mg->mg_ptr, 2, char);
2741 Copy(reflags, mg->mg_ptr+2, left, char);
2742 Copy(":", mg->mg_ptr+left+2, 1, char);
2743 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1bd3ad17
IZ		 2744 mg->mg_ptr[mg->mg_len - 1] = ')';
2745 mg->mg_ptr[mg->mg_len] = 0;
2746 }
3280af22 2747 PL_reginterp_cnt += re->program[0].next_off;
1bd3ad17
IZ		 2748 *lp = mg->mg_len;
2749 return mg->mg_ptr;
f9277f47
IZ		 2750 }
2751 /* Fall through */
ed6116ce
LW		 2752 case SVt_NULL:
2753 case SVt_IV:
2754 case SVt_NV:
2755 case SVt_RV:
2756 case SVt_PV:
2757 case SVt_PVIV:
2758 case SVt_PVNV:
81689caa
HS		 2759 case SVt_PVBM: if (SvROK(sv))
2760 s = "REF";
2761 else
2762 s = "SCALAR"; break;
ed6116ce
LW		 2763 case SVt_PVLV: s = "LVALUE"; break;
2764 case SVt_PVAV: s = "ARRAY"; break;
2765 case SVt_PVHV: s = "HASH"; break;
2766 case SVt_PVCV: s = "CODE"; break;
2767 case SVt_PVGV: s = "GLOB"; break;
1d2dff63 2768 case SVt_PVFM: s = "FORMAT"; break;
36477c24 2769 case SVt_PVIO: s = "IO"; break;
ed6116ce
LW		 2770 default: s = "UNKNOWN"; break;
2771 }
46fc3d4c 2772 tsv = NEWSV(0,0);
ed6116ce 2773 if (SvOBJECT(sv))
cea2e8a9 2774 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
ed6116ce 2775 else
46fc3d4c 2776 sv_setpv(tsv, s);
57def98f 2777 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
a0d0e21e 2778 goto tokensaveref;
463ee0b2 2779 }
ed6116ce
LW		 2780 *lp = strlen(s);
2781 return s;
79072805 2782 }
0336b60e 2783 if (SvREADONLY(sv) && !SvOK(sv)) {
0336b60e 2784 if (ckWARN(WARN_UNINITIALIZED))
1d7c1841 2785 report_uninit();
ed6116ce
LW		 2786 *lp = 0;
2787 return "";
79072805 2788 }
79072805 2789 }
28e5dec8
JH		 2790 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2791 /* I'm assuming that if both IV and NV are equally valid then
2792 converting the IV is going to be more efficient */
2793 U32 isIOK = SvIOK(sv);
2794 U32 isUIOK = SvIsUV(sv);
2795 char buf[TYPE_CHARS(UV)];
2796 char *ebuf, *ptr;
2797
2798 if (SvTYPE(sv) < SVt_PVIV)
2799 sv_upgrade(sv, SVt_PVIV);
2800 if (isUIOK)
2801 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2802 else
2803 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2804 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2805 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2806 SvCUR_set(sv, ebuf - ptr);
2807 s = SvEND(sv);
2808 *s = '\0';
2809 if (isIOK)
2810 SvIOK_on(sv);
2811 else
2812 SvIOKp_on(sv);
2813 if (isUIOK)
2814 SvIsUV_on(sv);
2815 }
2816 else if (SvNOKp(sv)) {
79072805
LW		 2817 if (SvTYPE(sv) < SVt_PVNV)
2818 sv_upgrade(sv, SVt_PVNV);
1c846c1f 2819 /* The +20 is pure guesswork. Configure test needed. --jhi */
59155cc0 2820 SvGROW(sv, NV_DIG + 20);
463ee0b2 2821 s = SvPVX(sv);
79072805 2822 olderrno = errno; /* some Xenix systems wipe out errno here */
79072805 2823#ifdef apollo
463ee0b2 2824 if (SvNVX(sv) == 0.0)
79072805
LW		 2825 (void)strcpy(s,"0");
2826 else
2827#endif /*apollo*/
bbce6d69 2828 {
2d4389e4 2829 Gconvert(SvNVX(sv), NV_DIG, 0, s);
bbce6d69 2830 }
79072805 2831 errno = olderrno;
a0d0e21e
LW		 2832#ifdef FIXNEGATIVEZERO
2833 if (*s == '-' && s[1] == '0' && !s[2])
2834 strcpy(s,"0");
2835#endif
79072805
LW		 2836 while (*s) s++;
2837#ifdef hcx
2838 if (s[-1] == '.')
46fc3d4c 2839 *--s = '\0';
79072805
LW		 2840#endif
2841 }
79072805 2842 else {
0336b60e
IZ		 2843 if (ckWARN(WARN_UNINITIALIZED)
2844 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1d7c1841 2845 report_uninit();
a0d0e21e 2846 *lp = 0;
25da4f38
IZ		 2847 if (SvTYPE(sv) < SVt_PV)
2848 /* Typically the caller expects that sv_any is not NULL now. */
2849 sv_upgrade(sv, SVt_PV);
a0d0e21e 2850 return "";
79072805 2851 }
463ee0b2
LW		 2852 *lp = s - SvPVX(sv);
2853 SvCUR_set(sv, *lp);
79072805 2854 SvPOK_on(sv);
1d7c1841
GS		 2855 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2856 PTR2UV(sv),SvPVX(sv)));
463ee0b2 2857 return SvPVX(sv);
a0d0e21e
LW		 2858
2859 tokensave:
2860 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2861 /* Sneaky stuff here */
2862
2863 tokensaveref:
46fc3d4c 2864 if (!tsv)
96827780 2865 tsv = newSVpv(tmpbuf, 0);
46fc3d4c 2866 sv_2mortal(tsv);
2867 *lp = SvCUR(tsv);
2868 return SvPVX(tsv);
a0d0e21e
LW		 2869 }
2870 else {
2871 STRLEN len;
46fc3d4c 2872 char *t;
2873
2874 if (tsv) {
2875 sv_2mortal(tsv);
2876 t = SvPVX(tsv);
2877 len = SvCUR(tsv);
2878 }
2879 else {
96827780
MB		 2880 t = tmpbuf;
2881 len = strlen(tmpbuf);
46fc3d4c 2882 }
a0d0e21e 2883#ifdef FIXNEGATIVEZERO
46fc3d4c 2884 if (len == 2 && t[0] == '-' && t[1] == '0') {
2885 t = "0";
2886 len = 1;
2887 }
a0d0e21e
LW		 2888#endif
2889 (void)SvUPGRADE(sv, SVt_PV);
46fc3d4c 2890 *lp = len;
a0d0e21e
LW		 2891 s = SvGROW(sv, len + 1);
2892 SvCUR_set(sv, len);
46fc3d4c 2893 (void)strcpy(s, t);
6bf554b4 2894 SvPOKp_on(sv);
a0d0e21e
LW		 2895 return s;
2896 }
463ee0b2
LW		 2897}
2898
7340a771
GS		 2899char *
2900Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2901{
560a288e
GS		 2902 STRLEN n_a;
2903 return sv_2pvbyte(sv, &n_a);
7340a771
GS		 2904}
2905
2906char *
2907Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2908{
0875d2fe
NIS		 2909 sv_utf8_downgrade(sv,0);
2910 return SvPV(sv,*lp);
7340a771
GS		 2911}
2912
2913char *
2914Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2915{
560a288e
GS		 2916 STRLEN n_a;
2917 return sv_2pvutf8(sv, &n_a);
7340a771
GS		 2918}
2919
2920char *
2921Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2922{
560a288e 2923 sv_utf8_upgrade(sv);
7d59b7e4 2924 return SvPV(sv,*lp);
7340a771 2925}
1c846c1f 2926
463ee0b2
LW		 2927/* This function is only called on magical items */
2928bool
864dbfa3 2929Perl_sv_2bool(pTHX_ register SV *sv)
463ee0b2 2930{
8990e307 2931 if (SvGMAGICAL(sv))
463ee0b2
LW		 2932 mg_get(sv);
2933
a0d0e21e
LW		 2934 if (!SvOK(sv))
2935 return 0;
2936 if (SvROK(sv)) {
a0d0e21e 2937 SV* tmpsv;
1554e226 2938 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
1dc13c17 2939 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
9e7bc3e8 2940 return SvTRUE(tmpsv);
a0d0e21e
LW		 2941 return SvRV(sv) != 0;
2942 }
463ee0b2 2943 if (SvPOKp(sv)) {
11343788
MB		 2944 register XPV* Xpvtmp;
2945 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2946 (*Xpvtmp->xpv_pv > '0' ||
2947 Xpvtmp->xpv_cur > 1 ||
2948 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
463ee0b2
LW		 2949 return 1;
2950 else
2951 return 0;
2952 }
2953 else {
2954 if (SvIOKp(sv))
2955 return SvIVX(sv) != 0;
2956 else {
2957 if (SvNOKp(sv))
2958 return SvNVX(sv) != 0.0;
2959 else
2960 return FALSE;
2961 }
2962 }
79072805
LW		 2963}
2964
c461cf8f
JH		 2965/*
2966=for apidoc sv_utf8_upgrade
2967
2968Convert the PV of an SV to its UTF8-encoded form.
4411f3b6
NIS		 2969Forces the SV to string form it it is not already.
2970Always sets the SvUTF8 flag to avoid future validity checks even
2971if all the bytes have hibit clear.
c461cf8f
JH		 2972
2973=cut
2974*/
2975
4411f3b6 2976STRLEN
560a288e
GS		 2977Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2978{
36f65ada 2979 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
8d6d96c1
HS		 2980}
2981
2982/*
2983=for apidoc sv_utf8_upgrade_flags
2984
2985Convert the PV of an SV to its UTF8-encoded form.
2986Forces the SV to string form it it is not already.
2987Always sets the SvUTF8 flag to avoid future validity checks even
2988if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2989will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2990C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2991
2992=cut
2993*/
2994
2995STRLEN
2996Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
2997{
db42d148 2998 U8 *s, *t, *e;
511c2ff0 2999 int hibit = 0;
560a288e 3000
4411f3b6
NIS		 3001 if (!sv)
3002 return 0;
3003
e0e62c2a
NIS		 3004 if (!SvPOK(sv)) {
3005 STRLEN len = 0;
8d6d96c1 3006 (void) sv_2pv_flags(sv,&len, flags);
e0e62c2a
NIS		 3007 if (!SvPOK(sv))
3008 return len;
3009 }
4411f3b6
NIS		 3010
3011 if (SvUTF8(sv))
3012 return SvCUR(sv);
560a288e 3013
db42d148
NIS		 3014 if (SvREADONLY(sv) && SvFAKE(sv)) {
3015 sv_force_normal(sv);
3016 }
3017
40826f67
JH		 3018 /* This function could be much more efficient if we had a FLAG in SVs
3019 * to signal if there are any hibit chars in the PV.
511c2ff0 3020 * Given that there isn't make loop fast as possible
560a288e 3021 */
db42d148
NIS		 3022 s = (U8 *) SvPVX(sv);
3023 e = (U8 *) SvEND(sv);
511c2ff0
NIS		 3024 t = s;
3025 while (t < e) {
c4d5f83a
NIS		 3026 U8 ch = *t++;
3027 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
8a818333 3028 break;
8a818333 3029 }
40826f67 3030 if (hibit) {
8a818333 3031 STRLEN len;
652088fc 3032
8a818333 3033 len = SvCUR(sv) + 1; /* Plus the \0 */
00df9076 3034 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
841d7a39 3035 SvCUR(sv) = len - 1;
511c2ff0
NIS		 3036 if (SvLEN(sv) != 0)
3037 Safefree(s); /* No longer using what was there before. */
841d7a39 3038 SvLEN(sv) = len; /* No longer know the real size. */
560a288e 3039 }
4411f3b6
NIS		 3040 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3041 SvUTF8_on(sv);
3042 return SvCUR(sv);
560a288e
GS		 3043}
3044
c461cf8f
JH		 3045/*
3046=for apidoc sv_utf8_downgrade
3047
3048Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3049This may not be possible if the PV contains non-byte encoding characters;
3050if this is the case, either returns false or, if C<fail_ok> is not
3051true, croaks.
3052
3053=cut
3054*/
3055
560a288e
GS		 3056bool
3057Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3058{
3059 if (SvPOK(sv) && SvUTF8(sv)) {
fa301091 3060 if (SvCUR(sv)) {
03cfe0ae 3061 U8 *s;
652088fc 3062 STRLEN len;
fa301091 3063
652088fc
JH		 3064 if (SvREADONLY(sv) && SvFAKE(sv))
3065 sv_force_normal(sv);
03cfe0ae
NIS		 3066 s = (U8 *) SvPV(sv, len);
3067 if (!utf8_to_bytes(s, &len)) {
fa301091
JH		 3068 if (fail_ok)
3069 return FALSE;
03cfe0ae 3070#ifdef USE_BYTES_DOWNGRADES
0064a8a9 3071 else if (IN_BYTES) {
03cfe0ae
NIS		 3072 U8 *d = s;
3073 U8 *e = (U8 *) SvEND(sv);
3074 int first = 1;
3075 while (s < e) {
3076 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3077 if (first && ch > 255) {
3078 if (PL_op)
3079 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3080 PL_op_desc[PL_op->op_type]);
3081 else
3082 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3083 first = 0;
3084 }
3085 *d++ = ch;
3086 s += len;
3087 }
3088 *d = '\0';
3089 len = (d - (U8 *) SvPVX(sv));
3090 }
3091#endif
fa301091
JH		 3092 else {
3093 if (PL_op)
3094 Perl_croak(aTHX_ "Wide character in %s",
3095 PL_op_desc[PL_op->op_type]);
3096 else
3097 Perl_croak(aTHX_ "Wide character");
3098 }
4b3603a4 3099 }
fa301091 3100 SvCUR(sv) = len;
67e989fb 3101 }
560a288e 3102 }
ffebcc3e 3103 SvUTF8_off(sv);
560a288e
GS		 3104 return TRUE;
3105}
3106
c461cf8f
JH		 3107/*
3108=for apidoc sv_utf8_encode
3109
3110Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
4411f3b6
NIS		 3111flag so that it looks like octets again. Used as a building block
3112for encode_utf8 in Encode.xs
c461cf8f
JH		 3113
3114=cut
3115*/
3116
560a288e
GS		 3117void
3118Perl_sv_utf8_encode(pTHX_ register SV *sv)
3119{
4411f3b6 3120 (void) sv_utf8_upgrade(sv);
560a288e
GS		 3121 SvUTF8_off(sv);
3122}
3123
4411f3b6
NIS		 3124/*
3125=for apidoc sv_utf8_decode
3126
3127Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3128turn of SvUTF8 if needed so that we see characters. Used as a building block
3129for decode_utf8 in Encode.xs
3130
3131=cut
3132*/
3133
3134
3135
560a288e
GS		 3136bool
3137Perl_sv_utf8_decode(pTHX_ register SV *sv)
3138{
3139 if (SvPOK(sv)) {
63cd0674
NIS		 3140 U8 *c;
3141 U8 *e;
9cbac4c7 3142
4411f3b6 3143 /* The octets may have got themselves encoded - get them back as bytes */
560a288e
GS		 3144 if (!sv_utf8_downgrade(sv, TRUE))
3145 return FALSE;
3146
3147 /* it is actually just a matter of turning the utf8 flag on, but
3148 * we want to make sure everything inside is valid utf8 first.
3149 */
63cd0674
NIS		 3150 c = (U8 *) SvPVX(sv);
3151 if (!is_utf8_string(c, SvCUR(sv)+1))
67e989fb 3152 return FALSE;
63cd0674 3153 e = (U8 *) SvEND(sv);
511c2ff0 3154 while (c < e) {
c4d5f83a
NIS		 3155 U8 ch = *c++;
3156 if (!UTF8_IS_INVARIANT(ch)) {
67e989fb
JH		 3157 SvUTF8_on(sv);
3158 break;
3159 }
560a288e 3160 }
560a288e
GS		 3161 }
3162 return TRUE;
3163}
3164
3165
79072805 3166/* Note: sv_setsv() should not be called with a source string that needs
463ee0b2 3167 * to be reused, since it may destroy the source string if it is marked
79072805
LW		 3168 * as temporary.
3169 */
3170
954c1994
GS		 3171/*
3172=for apidoc sv_setsv
3173
3174Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3175The source SV may be destroyed if it is mortal. Does not handle 'set'
3176magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3177C<sv_setsv_mg>.
3178
3179=cut
3180*/
3181
8d6d96c1
HS		 3182/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3183 for binary compatibility only
3184*/
79072805 3185void
864dbfa3 3186Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
79072805 3187{
8d6d96c1
HS		 3188 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3189}
3190
3191/*
3192=for apidoc sv_setsv_flags
3193
3194Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3195The source SV may be destroyed if it is mortal. Does not handle 'set'
3196magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3197appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3198in terms of this function.
3199
3200=cut
3201*/
3202
3203void
3204Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3205{
8990e307
LW		 3206 register U32 sflags;
3207 register int dtype;
3208 register int stype;
463ee0b2 3209
79072805
LW		 3210 if (sstr == dstr)
3211 return;
2213622d 3212 SV_CHECK_THINKFIRST(dstr);
79072805 3213 if (!sstr)
3280af22 3214 sstr = &PL_sv_undef;
8990e307
LW		 3215 stype = SvTYPE(sstr);
3216 dtype = SvTYPE(dstr);
79072805 3217
a0d0e21e 3218 SvAMAGIC_off(dstr);
9e7bc3e8 3219
463ee0b2 3220 /* There's a lot of redundancy below but we're going for speed here */
79072805 3221
8990e307 3222 switch (stype) {
79072805 3223 case SVt_NULL:
aece5585 3224 undef_sstr:
20408e3c
GS		 3225 if (dtype != SVt_PVGV) {
3226 (void)SvOK_off(dstr);
3227 return;
3228 }
3229 break;
463ee0b2 3230 case SVt_IV:
aece5585
GA		 3231 if (SvIOK(sstr)) {
3232 switch (dtype) {
3233 case SVt_NULL:
8990e307 3234 sv_upgrade(dstr, SVt_IV);
aece5585
GA		 3235 break;
3236 case SVt_NV:
8990e307 3237 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 3238 break;
3239 case SVt_RV:
3240 case SVt_PV:
a0d0e21e 3241 sv_upgrade(dstr, SVt_PVIV);
aece5585
GA		 3242 break;
3243 }
3244 (void)SvIOK_only(dstr);
3245 SvIVX(dstr) = SvIVX(sstr);
25da4f38
IZ		 3246 if (SvIsUV(sstr))
3247 SvIsUV_on(dstr);
27c9684d
AP		 3248 if (SvTAINTED(sstr))
3249 SvTAINT(dstr);
aece5585 3250 return;
8990e307 3251 }
aece5585
GA		 3252 goto undef_sstr;
3253
463ee0b2 3254 case SVt_NV:
aece5585
GA		 3255 if (SvNOK(sstr)) {
3256 switch (dtype) {
3257 case SVt_NULL:
3258 case SVt_IV:
8990e307 3259 sv_upgrade(dstr, SVt_NV);
aece5585
GA		 3260 break;
3261 case SVt_RV:
3262 case SVt_PV:
3263 case SVt_PVIV:
a0d0e21e 3264 sv_upgrade(dstr, SVt_PVNV);
aece5585
GA		 3265 break;
3266 }
3267 SvNVX(dstr) = SvNVX(sstr);
3268 (void)SvNOK_only(dstr);
27c9684d
AP		 3269 if (SvTAINTED(sstr))
3270 SvTAINT(dstr);
aece5585 3271 return;
8990e307 3272 }
aece5585
GA		 3273 goto undef_sstr;
3274
ed6116ce 3275 case SVt_RV:
8990e307 3276 if (dtype < SVt_RV)
ed6116ce 3277 sv_upgrade(dstr, SVt_RV);
c07a80fd 3278 else if (dtype == SVt_PVGV &&
3279 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3280 sstr = SvRV(sstr);
a5f75d66 3281 if (sstr == dstr) {
1d7c1841
GS		 3282 if (GvIMPORTED(dstr) != GVf_IMPORTED
3283 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3284 {
a5f75d66 3285 GvIMPORTED_on(dstr);
1d7c1841 3286 }
a5f75d66
AD		 3287 GvMULTI_on(dstr);
3288 return;
3289 }
c07a80fd 3290 goto glob_assign;
3291 }
ed6116ce 3292 break;
463ee0b2 3293 case SVt_PV:
fc36a67e 3294 case SVt_PVFM:
8990e307 3295 if (dtype < SVt_PV)
463ee0b2 3296 sv_upgrade(dstr, SVt_PV);
463ee0b2
LW		 3297 break;
3298 case SVt_PVIV:
8990e307 3299 if (dtype < SVt_PVIV)
463ee0b2 3300 sv_upgrade(dstr, SVt_PVIV);
463ee0b2
LW		 3301 break;
3302 case SVt_PVNV:
8990e307 3303 if (dtype < SVt_PVNV)
463ee0b2 3304 sv_upgrade(dstr, SVt_PVNV);
463ee0b2 3305 break;
4633a7c4
LW		 3306 case SVt_PVAV:
3307 case SVt_PVHV:
3308 case SVt_PVCV:
4633a7c4 3309 case SVt_PVIO:
533c011a 3310 if (PL_op)
cea2e8a9 3311 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
22c35a8c 3312 PL_op_name[PL_op->op_type]);
4633a7c4 3313 else
cea2e8a9 3314 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
4633a7c4
LW		 3315 break;
3316
79072805 3317 case SVt_PVGV:
8990e307 3318 if (dtype <= SVt_PVGV) {
c07a80fd 3319 glob_assign:
a5f75d66 3320 if (dtype != SVt_PVGV) {
a0d0e21e
LW		 3321 char *name = GvNAME(sstr);
3322 STRLEN len = GvNAMELEN(sstr);
463ee0b2 3323 sv_upgrade(dstr, SVt_PVGV);
14befaf4 3324 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
85aff577 3325 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
a0d0e21e
LW		 3326 GvNAME(dstr) = savepvn(name, len);
3327 GvNAMELEN(dstr) = len;
3328 SvFAKE_on(dstr); /* can coerce to non-glob */
3329 }
7bac28a0 3330 /* ahem, death to those who redefine active sort subs */
3280af22
NIS		 3331 else if (PL_curstackinfo->si_type == PERLSI_SORT
3332 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
cea2e8a9 3333 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
7bac28a0 3334 GvNAME(dstr));
5bd07a3d
DM		 3335
3336#ifdef GV_SHARED_CHECK
3337 if (GvSHARED((GV*)dstr)) {
3338 Perl_croak(aTHX_ PL_no_modify);
3339 }
3340#endif
3341
a0d0e21e 3342 (void)SvOK_off(dstr);
a5f75d66 3343 GvINTRO_off(dstr); /* one-shot flag */
1edc1566 3344 gp_free((GV*)dstr);
79072805 3345 GvGP(dstr) = gp_ref(GvGP(sstr));
27c9684d
AP		 3346 if (SvTAINTED(sstr))
3347 SvTAINT(dstr);
1d7c1841
GS		 3348 if (GvIMPORTED(dstr) != GVf_IMPORTED
3349 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3350 {
a5f75d66 3351 GvIMPORTED_on(dstr);
1d7c1841 3352 }
a5f75d66 3353 GvMULTI_on(dstr);
79072805
LW		 3354 return;
3355 }
3356 /* FALL THROUGH */
3357
3358 default:
8d6d96c1 3359 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
973f89ab
CS		 3360 mg_get(sstr);
3361 if (SvTYPE(sstr) != stype) {
3362 stype = SvTYPE(sstr);
3363 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3364 goto glob_assign;
3365 }
3366 }
ded42b9f 3367 if (stype == SVt_PVLV)
6fc92669 3368 (void)SvUPGRADE(dstr, SVt_PVNV);
ded42b9f 3369 else
6fc92669 3370 (void)SvUPGRADE(dstr, stype);
79072805
LW		 3371 }
3372
8990e307
LW		 3373 sflags = SvFLAGS(sstr);
3374
3375 if (sflags & SVf_ROK) {
3376 if (dtype >= SVt_PV) {
3377 if (dtype == SVt_PVGV) {
3378 SV *sref = SvREFCNT_inc(SvRV(sstr));
3379 SV *dref = 0;
a5f75d66 3380 int intro = GvINTRO(dstr);
a0d0e21e 3381
5bd07a3d
DM		 3382#ifdef GV_SHARED_CHECK
3383 if (GvSHARED((GV*)dstr)) {
3384 Perl_croak(aTHX_ PL_no_modify);
3385 }
3386#endif
3387
a0d0e21e
LW		 3388 if (intro) {
3389 GP *gp;
1d7c1841 3390 gp_free((GV*)dstr);
a5f75d66 3391 GvINTRO_off(dstr); /* one-shot flag */
a0d0e21e 3392 Newz(602,gp, 1, GP);
44a8e56a 3393 GvGP(dstr) = gp_ref(gp);
a0d0e21e 3394 GvSV(dstr) = NEWSV(72,0);
1d7c1841 3395 GvLINE(dstr) = CopLINE(PL_curcop);
1edc1566 3396 GvEGV(dstr) = (GV*)dstr;
a0d0e21e 3397 }
a5f75d66 3398 GvMULTI_on(dstr);
8990e307
LW		 3399 switch (SvTYPE(sref)) {
3400 case SVt_PVAV:
a0d0e21e
LW		 3401 if (intro)
3402 SAVESPTR(GvAV(dstr));
3403 else
3404 dref = (SV*)GvAV(dstr);
8990e307 3405 GvAV(dstr) = (AV*)sref;
39bac7f7 3406 if (!GvIMPORTED_AV(dstr)
1d7c1841
GS		 3407 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3408 {
a5f75d66 3409 GvIMPORTED_AV_on(dstr);
1d7c1841 3410 }
8990e307
LW		 3411 break;
3412 case SVt_PVHV:
a0d0e21e
LW		 3413 if (intro)
3414 SAVESPTR(GvHV(dstr));
3415 else
3416 dref = (SV*)GvHV(dstr);
8990e307 3417 GvHV(dstr) = (HV*)sref;
39bac7f7 3418 if (!GvIMPORTED_HV(dstr)
1d7c1841
GS		 3419 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3420 {
a5f75d66 3421 GvIMPORTED_HV_on(dstr);
1d7c1841 3422 }
8990e307
LW		 3423 break;
3424 case SVt_PVCV:
8ebc5c01 3425 if (intro) {
3426 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3427 SvREFCNT_dec(GvCV(dstr));
3428 GvCV(dstr) = Nullcv;
68dc0745 3429 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280af22 3430 PL_sub_generation++;
8ebc5c01 3431 }
a0d0e21e 3432 SAVESPTR(GvCV(dstr));
8ebc5c01 3433 }
68dc0745 3434 else
3435 dref = (SV*)GvCV(dstr);
3436 if (GvCV(dstr) != (CV*)sref) {
748a9306 3437 CV* cv = GvCV(dstr);
4633a7c4 3438 if (cv) {
68dc0745 3439 if (!GvCVGEN((GV*)dstr) &&
3440 (CvROOT(cv) || CvXSUB(cv)))
3441 {
7bac28a0 3442 /* ahem, death to those who redefine
3443 * active sort subs */
3280af22
NIS		 3444 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3445 PL_sortcop == CvSTART(cv))
1c846c1f 3446 Perl_croak(aTHX_
7bac28a0 3447 "Can't redefine active sort subroutine %s",
3448 GvENAME((GV*)dstr));
beab0874
JT		 3449 /* Redefining a sub - warning is mandatory if
3450 it was a const and its value changed. */
3451 if (ckWARN(WARN_REDEFINE)
3452 || (CvCONST(cv)
3453 && (!CvCONST((CV*)sref)
3454 || sv_cmp(cv_const_sv(cv),
3455 cv_const_sv((CV*)sref)))))
3456 {
3457 Perl_warner(aTHX_ WARN_REDEFINE,
3458 CvCONST(cv)
3459 ? "Constant subroutine %s redefined"
47deb5e7 3460 : "Subroutine %s redefined",
beab0874
JT		 3461 GvENAME((GV*)dstr));
3462 }
9607fc9c 3463 }
3fe9a6f1 3464 cv_ckproto(cv, (GV*)dstr,
3465 SvPOK(sref) ? SvPVX(sref) : Nullch);
4633a7c4 3466 }
a5f75d66 3467 GvCV(dstr) = (CV*)sref;
7a4c00b4 3468 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
a5f75d66 3469 GvASSUMECV_on(dstr);
3280af22 3470 PL_sub_generation++;
a5f75d66 3471 }
39bac7f7 3472 if (!GvIMPORTED_CV(dstr)
1d7c1841
GS		 3473 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3474 {
a5f75d66 3475 GvIMPORTED_CV_on(dstr);
1d7c1841 3476 }
8990e307 3477 break;
91bba347
LW		 3478 case SVt_PVIO:
3479 if (intro)
3480 SAVESPTR(GvIOp(dstr));
3481 else
3482 dref = (SV*)GvIOp(dstr);
3483 GvIOp(dstr) = (IO*)sref;
3484 break;
f4d13ee9
JH		 3485 case SVt_PVFM:
3486 if (intro)
3487 SAVESPTR(GvFORM(dstr));
3488 else
3489 dref = (SV*)GvFORM(dstr);
3490 GvFORM(dstr) = (CV*)sref;
3491 break;
8990e307 3492 default:
a0d0e21e
LW		 3493 if (intro)
3494 SAVESPTR(GvSV(dstr));
3495 else
3496 dref = (SV*)GvSV(dstr);
8990e307 3497 GvSV(dstr) = sref;
39bac7f7 3498 if (!GvIMPORTED_SV(dstr)
1d7c1841
GS		 3499 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3500 {
a5f75d66 3501 GvIMPORTED_SV_on(dstr);
1d7c1841 3502 }
8990e307
LW		 3503 break;
3504 }
3505 if (dref)
3506 SvREFCNT_dec(dref);
a0d0e21e
LW		 3507 if (intro)
3508 SAVEFREESV(sref);
27c9684d
AP		 3509 if (SvTAINTED(sstr))
3510 SvTAINT(dstr);
8990e307
LW		 3511 return;
3512 }
a0d0e21e 3513 if (SvPVX(dstr)) {
760ac839 3514 (void)SvOOK_off(dstr); /* backoff */
50483b2c
JD		 3515 if (SvLEN(dstr))
3516 Safefree(SvPVX(dstr));
a0d0e21e
LW		 3517 SvLEN(dstr)=SvCUR(dstr)=0;
3518 }
8990e307 3519 }
a0d0e21e 3520 (void)SvOK_off(dstr);
8990e307 3521 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
ed6116ce 3522 SvROK_on(dstr);
8990e307 3523 if (sflags & SVp_NOK) {
3332b3c1
JH		 3524 SvNOKp_on(dstr);
3525 /* Only set the public OK flag if the source has public OK. */
3526 if (sflags & SVf_NOK)
3527 SvFLAGS(dstr) |= SVf_NOK;
ed6116ce
LW		 3528 SvNVX(dstr) = SvNVX(sstr);
3529 }
8990e307 3530 if (sflags & SVp_IOK) {
3332b3c1
JH		 3531 (void)SvIOKp_on(dstr);
3532 if (sflags & SVf_IOK)
3533 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3534 if (sflags & SVf_IVisUV)
25da4f38 3535 SvIsUV_on(dstr);
3332b3c1 3536 SvIVX(dstr) = SvIVX(sstr);
ed6116ce 3537 }
a0d0e21e
LW		 3538 if (SvAMAGIC(sstr)) {
3539 SvAMAGIC_on(dstr);
3540 }
ed6116ce 3541 }
8990e307 3542 else if (sflags & SVp_POK) {
79072805
LW		 3543
3544 /*
3545 * Check to see if we can just swipe the string. If so, it's a
3546 * possible small lose on short strings, but a big win on long ones.
463ee0b2
LW		 3547 * It might even be a win on short strings if SvPVX(dstr)
3548 * has to be allocated and SvPVX(sstr) has to be freed.
79072805
LW		 3549 */
3550
ff68c719 3551 if (SvTEMP(sstr) && /* slated for free anyway? */
01b73108 3552 SvREFCNT(sstr) == 1 && /* and no other references to it? */
1c846c1f 3553 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
4c8f17b9
BH		 3554 SvLEN(sstr) && /* and really is a string */
3555 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
a5f75d66 3556 {
adbc6bb1 3557 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
a5f75d66
AD		 3558 if (SvOOK(dstr)) {
3559 SvFLAGS(dstr) &= ~SVf_OOK;
3560 Safefree(SvPVX(dstr) - SvIVX(dstr));
3561 }
50483b2c 3562 else if (SvLEN(dstr))
a5f75d66 3563 Safefree(SvPVX(dstr));
79072805 3564 }
a5f75d66 3565 (void)SvPOK_only(dstr);
463ee0b2 3566 SvPV_set(dstr, SvPVX(sstr));
79072805
LW		 3567 SvLEN_set(dstr, SvLEN(sstr));
3568 SvCUR_set(dstr, SvCUR(sstr));
f4e86e0f 3569
79072805 3570 SvTEMP_off(dstr);
2b1c7e3e 3571 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
79072805
LW		 3572 SvPV_set(sstr, Nullch);
3573 SvLEN_set(sstr, 0);
a5f75d66
AD		 3574 SvCUR_set(sstr, 0);
3575 SvTEMP_off(sstr);
79072805
LW		 3576 }
3577 else { /* have to copy actual string */
8990e307
LW		 3578 STRLEN len = SvCUR(sstr);
3579
3580 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3581 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3582 SvCUR_set(dstr, len);
3583 *SvEND(dstr) = '\0';
a0d0e21e 3584 (void)SvPOK_only(dstr);
79072805 3585 }
9aa983d2 3586 if (sflags & SVf_UTF8)
a7cb1f99 3587 SvUTF8_on(dstr);
79072805 3588 /*SUPPRESS 560*/
8990e307 3589 if (sflags & SVp_NOK) {
3332b3c1
JH		 3590 SvNOKp_on(dstr);
3591 if (sflags & SVf_NOK)
3592 SvFLAGS(dstr) |= SVf_NOK;
463ee0b2 3593 SvNVX(dstr) = SvNVX(sstr);
79072805 3594 }
8990e307 3595 if (sflags & SVp_IOK) {
3332b3c1
JH		 3596 (void)SvIOKp_on(dstr);
3597 if (sflags & SVf_IOK)
3598 SvFLAGS(dstr) |= SVf_IOK;
2b1c7e3e 3599 if (sflags & SVf_IVisUV)
25da4f38 3600 SvIsUV_on(dstr);
463ee0b2 3601 SvIVX(dstr) = SvIVX(sstr);
79072805
LW		 3602 }
3603 }
8990e307 3604 else if (sflags & SVp_IOK) {
3332b3c1
JH		 3605 if (sflags & SVf_IOK)
3606 (void)SvIOK_only(dstr);
3607 else {
9cbac4c7
DM		 3608 (void)SvOK_off(dstr);
3609 (void)SvIOKp_on(dstr);
3332b3c1
JH		 3610 }
3611 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2b1c7e3e 3612 if (sflags & SVf_IVisUV)
25da4f38 3613 SvIsUV_on(dstr);
3332b3c1
JH		 3614 SvIVX(dstr) = SvIVX(sstr);
3615 if (sflags & SVp_NOK) {
3616 if (sflags & SVf_NOK)
3617 (void)SvNOK_on(dstr);
3618 else
3619 (void)SvNOKp_on(dstr);
3620 SvNVX(dstr) = SvNVX(sstr);
3621 }
3622 }
3623 else if (sflags & SVp_NOK) {
3624 if (sflags & SVf_NOK)
3625 (void)SvNOK_only(dstr);
3626 else {
9cbac4c7 3627 (void)SvOK_off(dstr);
3332b3c1
JH		 3628 SvNOKp_on(dstr);
3629 }
3630 SvNVX(dstr) = SvNVX(sstr);
79072805
LW		 3631 }
3632 else {
20408e3c 3633 if (dtype == SVt_PVGV) {
e476b1b5
GS		 3634 if (ckWARN(WARN_MISC))
3635 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
20408e3c
GS		 3636 }
3637 else
3638 (void)SvOK_off(dstr);
a0d0e21e 3639 }
27c9684d
AP		 3640 if (SvTAINTED(sstr))
3641 SvTAINT(dstr);
79072805
LW		 3642}
3643
954c1994
GS		 3644/*
3645=for apidoc sv_setsv_mg
3646
3647Like C<sv_setsv>, but also handles 'set' magic.
3648
3649=cut
3650*/
3651
79072805 3652void
864dbfa3 3653Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
ef50df4b
GS		 3654{
3655 sv_setsv(dstr,sstr);
3656 SvSETMAGIC(dstr);
3657}
3658
954c1994
GS		 3659/*
3660=for apidoc sv_setpvn
3661
3662Copies a string into an SV. The C<len> parameter indicates the number of
3663bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3664
3665=cut
3666*/
3667
ef50df4b 3668void
864dbfa3 3669Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
79072805 3670{
c6f8c383 3671 register char *dptr;
22c522df 3672
2213622d 3673 SV_CHECK_THINKFIRST(sv);
463ee0b2 3674 if (!ptr) {
a0d0e21e 3675 (void)SvOK_off(sv);
463ee0b2
LW		 3676 return;
3677 }
22c522df
JH		 3678 else {
3679 /* len is STRLEN which is unsigned, need to copy to signed */
3680 IV iv = len;
9c5ffd7c
JH		 3681 if (iv < 0)
3682 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
22c522df 3683 }
6fc92669 3684 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 3685
79072805 3686 SvGROW(sv, len + 1);
c6f8c383
GA		 3687 dptr = SvPVX(sv);
3688 Move(ptr,dptr,len,char);
3689 dptr[len] = '\0';
79072805 3690 SvCUR_set(sv, len);
1aa99e6b 3691 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3692 SvTAINT(sv);
79072805
LW		 3693}
3694
954c1994
GS		 3695/*
3696=for apidoc sv_setpvn_mg
3697
3698Like C<sv_setpvn>, but also handles 'set' magic.
3699
3700=cut
3701*/
3702
79072805 3703void
864dbfa3 3704Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3705{
3706 sv_setpvn(sv,ptr,len);
3707 SvSETMAGIC(sv);
3708}
3709
954c1994
GS		 3710/*
3711=for apidoc sv_setpv
3712
3713Copies a string into an SV. The string must be null-terminated. Does not
3714handle 'set' magic. See C<sv_setpv_mg>.
3715
3716=cut
3717*/
3718
ef50df4b 3719void
864dbfa3 3720Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 3721{
3722 register STRLEN len;
3723
2213622d 3724 SV_CHECK_THINKFIRST(sv);
463ee0b2 3725 if (!ptr) {
a0d0e21e 3726 (void)SvOK_off(sv);
463ee0b2
LW		 3727 return;
3728 }
79072805 3729 len = strlen(ptr);
6fc92669 3730 (void)SvUPGRADE(sv, SVt_PV);
c6f8c383 3731
79072805 3732 SvGROW(sv, len + 1);
463ee0b2 3733 Move(ptr,SvPVX(sv),len+1,char);
79072805 3734 SvCUR_set(sv, len);
1aa99e6b 3735 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2
LW		 3736 SvTAINT(sv);
3737}
3738
954c1994
GS		 3739/*
3740=for apidoc sv_setpv_mg
3741
3742Like C<sv_setpv>, but also handles 'set' magic.
3743
3744=cut
3745*/
3746
463ee0b2 3747void
864dbfa3 3748Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b
GS		 3749{
3750 sv_setpv(sv,ptr);
3751 SvSETMAGIC(sv);
3752}
3753
954c1994
GS		 3754/*
3755=for apidoc sv_usepvn
3756
3757Tells an SV to use C<ptr> to find its string value. Normally the string is
1c846c1f 3758stored inside the SV but sv_usepvn allows the SV to use an outside string.
954c1994
GS		 3759The C<ptr> should point to memory that was allocated by C<malloc>. The
3760string length, C<len>, must be supplied. This function will realloc the
3761memory pointed to by C<ptr>, so that pointer should not be freed or used by
3762the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3763See C<sv_usepvn_mg>.
3764
3765=cut
3766*/
3767
ef50df4b 3768void
864dbfa3 3769Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
463ee0b2 3770{
2213622d 3771 SV_CHECK_THINKFIRST(sv);
c6f8c383 3772 (void)SvUPGRADE(sv, SVt_PV);
463ee0b2 3773 if (!ptr) {
a0d0e21e 3774 (void)SvOK_off(sv);
463ee0b2
LW		 3775 return;
3776 }
a0ed51b3 3777 (void)SvOOK_off(sv);
50483b2c 3778 if (SvPVX(sv) && SvLEN(sv))
463ee0b2
LW		 3779 Safefree(SvPVX(sv));
3780 Renew(ptr, len+1, char);
3781 SvPVX(sv) = ptr;
3782 SvCUR_set(sv, len);
3783 SvLEN_set(sv, len+1);
3784 *SvEND(sv) = '\0';
1aa99e6b 3785 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 3786 SvTAINT(sv);
79072805
LW		 3787}
3788
954c1994
GS		 3789/*
3790=for apidoc sv_usepvn_mg
3791
3792Like C<sv_usepvn>, but also handles 'set' magic.
3793
3794=cut
3795*/
3796
ef50df4b 3797void
864dbfa3 3798Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
ef50df4b 3799{
51c1089b 3800 sv_usepvn(sv,ptr,len);
ef50df4b
GS		 3801 SvSETMAGIC(sv);
3802}
3803
6fc92669 3804void
840a7b70 3805Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
0f15f207 3806{
2213622d 3807 if (SvREADONLY(sv)) {
1c846c1f
NIS		 3808 if (SvFAKE(sv)) {
3809 char *pvx = SvPVX(sv);
3810 STRLEN len = SvCUR(sv);
3811 U32 hash = SvUVX(sv);
3812 SvGROW(sv, len + 1);
3813 Move(pvx,SvPVX(sv),len,char);
3814 *SvEND(sv) = '\0';
3815 SvFAKE_off(sv);
3816 SvREADONLY_off(sv);
c3654f1a 3817 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
1c846c1f
NIS		 3818 }
3819 else if (PL_curcop != &PL_compiling)
cea2e8a9 3820 Perl_croak(aTHX_ PL_no_modify);
0f15f207 3821 }
2213622d 3822 if (SvROK(sv))
840a7b70 3823 sv_unref_flags(sv, flags);
6fc92669
GS		 3824 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3825 sv_unglob(sv);
0f15f207 3826}
1c846c1f 3827
840a7b70
IZ		 3828void
3829Perl_sv_force_normal(pTHX_ register SV *sv)
3830{
3831 sv_force_normal_flags(sv, 0);
3832}
3833
954c1994
GS		 3834/*
3835=for apidoc sv_chop
3836
1c846c1f 3837Efficient removal of characters from the beginning of the string buffer.
954c1994
GS		 3838SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3839the string buffer. The C<ptr> becomes the first character of the adjusted
3840string.
3841
3842=cut
3843*/
3844
79072805 3845void
864dbfa3 3846Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
1c846c1f
NIS		 3847
3848
79072805
LW		 3849{
3850 register STRLEN delta;
3851
a0d0e21e 3852 if (!ptr || !SvPOKp(sv))
79072805 3853 return;
2213622d 3854 SV_CHECK_THINKFIRST(sv);
79072805
LW		 3855 if (SvTYPE(sv) < SVt_PVIV)
3856 sv_upgrade(sv,SVt_PVIV);
3857
3858 if (!SvOOK(sv)) {
50483b2c
JD		 3859 if (!SvLEN(sv)) { /* make copy of shared string */
3860 char *pvx = SvPVX(sv);
3861 STRLEN len = SvCUR(sv);
3862 SvGROW(sv, len + 1);
3863 Move(pvx,SvPVX(sv),len,char);
3864 *SvEND(sv) = '\0';
3865 }
463ee0b2 3866 SvIVX(sv) = 0;
79072805
LW		 3867 SvFLAGS(sv) |= SVf_OOK;
3868 }
25da4f38 3869 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
463ee0b2 3870 delta = ptr - SvPVX(sv);
79072805
LW		 3871 SvLEN(sv) -= delta;
3872 SvCUR(sv) -= delta;
463ee0b2
LW		 3873 SvPVX(sv) += delta;
3874 SvIVX(sv) += delta;
79072805
LW		 3875}
3876
954c1994
GS		 3877/*
3878=for apidoc sv_catpvn
3879
3880Concatenates the string onto the end of the string which is in the SV. The
d5ce4a7c
GA		 3881C<len> indicates number of bytes to copy. If the SV has the UTF8
3882status set, then the bytes appended should be valid UTF8.
3883Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
954c1994
GS		 3884
3885=cut
3886*/
3887
8d6d96c1
HS		 3888/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3889 for binary compatibility only
3890*/
79072805 3891void
8d6d96c1 3892Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
79072805 3893{
8d6d96c1
HS		 3894 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3895}
a0d0e21e 3896
8d6d96c1
HS		 3897/*
3898=for apidoc sv_catpvn_flags
3899
3900Concatenates the string onto the end of the string which is in the SV. The
3901C<len> indicates number of bytes to copy. If the SV has the UTF8
3902status set, then the bytes appended should be valid UTF8.
3903If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3904appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3905in terms of this function.
3906
3907=cut
3908*/
3909
3910void
3911Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3912{
3913 STRLEN dlen;
3914 char *dstr;
3915
3916 dstr = SvPV_force_flags(dsv, dlen, flags);
3917 SvGROW(dsv, dlen + slen + 1);
3918 if (sstr == dstr)
3919 sstr = SvPVX(dsv);
3920 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3921 SvCUR(dsv) += slen;
3922 *SvEND(dsv) = '\0';
3923 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3924 SvTAINT(dsv);
79072805
LW		 3925}
3926
954c1994
GS		 3927/*
3928=for apidoc sv_catpvn_mg
3929
3930Like C<sv_catpvn>, but also handles 'set' magic.
3931
3932=cut
3933*/
3934
79072805 3935void
864dbfa3 3936Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
ef50df4b
GS		 3937{
3938 sv_catpvn(sv,ptr,len);
3939 SvSETMAGIC(sv);
3940}
3941
954c1994
GS		 3942/*
3943=for apidoc sv_catsv
3944
13e8c8e3
JH		 3945Concatenates the string from SV C<ssv> onto the end of the string in
3946SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3947not 'set' magic. See C<sv_catsv_mg>.
954c1994 3948
13e8c8e3 3949=cut */
954c1994 3950
8d6d96c1
HS		 3951/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3952 for binary compatibility only
3953*/
3954void
3955Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3956{
3957 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3958}
3959
3960/*
3961=for apidoc sv_catsv_flags
3962
3963Concatenates the string from SV C<ssv> onto the end of the string in
3964SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3965bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3966and C<sv_catsv_nomg> are implemented in terms of this function.
3967
3968=cut */
3969
ef50df4b 3970void
8d6d96c1 3971Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
79072805 3972{
13e8c8e3
JH		 3973 char *spv;
3974 STRLEN slen;
46199a12 3975 if (!ssv)
79072805 3976 return;
46199a12 3977 if ((spv = SvPV(ssv, slen))) {
46199a12 3978 bool sutf8 = DO_UTF8(ssv);
8d6d96c1 3979 bool dutf8;
13e8c8e3 3980
8d6d96c1
HS		 3981 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3982 mg_get(dsv);
3983 dutf8 = DO_UTF8(dsv);
3984
3985 if (dutf8 != sutf8) {
13e8c8e3 3986 if (dutf8) {
46199a12 3987 /* Not modifying source SV, so taking a temporary copy. */
8d6d96c1 3988 SV* csv = sv_2mortal(newSVpvn(spv, slen));
13e8c8e3 3989
46199a12 3990 sv_utf8_upgrade(csv);
8d6d96c1 3991 spv = SvPV(csv, slen);
13e8c8e3 3992 }
8d6d96c1
HS		 3993 else
3994 sv_utf8_upgrade_nomg(dsv);
e84ff256 3995 }
8d6d96c1 3996 sv_catpvn_nomg(dsv, spv, slen);
560a288e 3997 }
79072805
LW		 3998}
3999
954c1994
GS		 4000/*
4001=for apidoc sv_catsv_mg
4002
4003Like C<sv_catsv>, but also handles 'set' magic.
4004
4005=cut
4006*/
4007
79072805 4008void
46199a12 4009Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
ef50df4b 4010{
46199a12
JH		 4011 sv_catsv(dsv,ssv);
4012 SvSETMAGIC(dsv);
ef50df4b
GS		 4013}
4014
954c1994
GS		 4015/*
4016=for apidoc sv_catpv
4017
4018Concatenates the string onto the end of the string which is in the SV.
d5ce4a7c
GA		 4019If the SV has the UTF8 status set, then the bytes appended should be
4020valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
954c1994 4021
d5ce4a7c 4022=cut */
954c1994 4023
ef50df4b 4024void
0c981600 4025Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
79072805
LW		 4026{
4027 register STRLEN len;
463ee0b2 4028 STRLEN tlen;
748a9306 4029 char *junk;
79072805 4030
0c981600 4031 if (!ptr)
79072805 4032 return;
748a9306 4033 junk = SvPV_force(sv, tlen);
0c981600 4034 len = strlen(ptr);
463ee0b2 4035 SvGROW(sv, tlen + len + 1);
0c981600
JH		 4036 if (ptr == junk)
4037 ptr = SvPVX(sv);
4038 Move(ptr,SvPVX(sv)+tlen,len+1,char);
79072805 4039 SvCUR(sv) += len;
d41ff1b8 4040 (void)SvPOK_only_UTF8(sv); /* validate pointer */
463ee0b2 4041 SvTAINT(sv);
79072805
LW		 4042}
4043
954c1994
GS		 4044/*
4045=for apidoc sv_catpv_mg
4046
4047Like C<sv_catpv>, but also handles 'set' magic.
4048
4049=cut
4050*/
4051
ef50df4b 4052void
0c981600 4053Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
ef50df4b 4054{
0c981600 4055 sv_catpv(sv,ptr);
ef50df4b
GS		 4056 SvSETMAGIC(sv);
4057}
4058
79072805 4059SV *
864dbfa3 4060Perl_newSV(pTHX_ STRLEN len)
79072805
LW		 4061{
4062 register SV *sv;
1c846c1f 4063
4561caa4 4064 new_SV(sv);
79072805
LW		 4065 if (len) {
4066 sv_upgrade(sv, SVt_PV);
4067 SvGROW(sv, len + 1);
4068 }
4069 return sv;
4070}
4071
1edc1566 4072/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
4073
954c1994
GS		 4074/*
4075=for apidoc sv_magic
4076
4077Adds magic to an SV.
4078
4079=cut
4080*/
4081
79072805 4082void
864dbfa3 4083Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
79072805
LW		 4084{
4085 MAGIC* mg;
1c846c1f 4086
0f15f207 4087 if (SvREADONLY(sv)) {
14befaf4
DM		 4088 if (PL_curcop != &PL_compiling
4089 /* XXX this used to be !strchr("gBf", how), which seems to
4090 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4091 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4092 * to the list of things to check - DAPM 19-May-01 */
4093 && how != PERL_MAGIC_regex_global
4094 && how != PERL_MAGIC_bm
4095 && how != PERL_MAGIC_fm
4096 && how != PERL_MAGIC_sv
4097 )
4098 {
cea2e8a9 4099 Perl_croak(aTHX_ PL_no_modify);
14befaf4 4100 }
0f15f207 4101 }
14befaf4 4102 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
748a9306 4103 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
14befaf4 4104 if (how == PERL_MAGIC_taint)
565764a8 4105 mg->mg_len |= 1;
463ee0b2 4106 return;
748a9306 4107 }
463ee0b2
LW		 4108 }
4109 else {
c6f8c383 4110 (void)SvUPGRADE(sv, SVt_PVMG);
463ee0b2 4111 }
79072805
LW		 4112 Newz(702,mg, 1, MAGIC);
4113 mg->mg_moremagic = SvMAGIC(sv);
79072805 4114 SvMAGIC(sv) = mg;
75f9d97a
JH		 4115
4116 /* Some magic sontains a reference loop, where the sv and object refer to
4117 each other. To prevent a avoid a reference loop that would prevent such
4118 objects being freed, we look for such loops and if we find one we avoid
4119 incrementing the object refcount. */
14befaf4
DM		 4120 if (!obj || obj == sv ||
4121 how == PERL_MAGIC_arylen ||
4122 how == PERL_MAGIC_qr ||
75f9d97a
JH		 4123 (SvTYPE(obj) == SVt_PVGV &&
4124 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4125 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4126 GvFORM(obj) == (CV*)sv)))
4127 {
8990e307 4128 mg->mg_obj = obj;
75f9d97a 4129 }
85e6fe83 4130 else {
8990e307 4131 mg->mg_obj = SvREFCNT_inc(obj);
85e6fe83
LW		 4132 mg->mg_flags |= MGf_REFCOUNTED;
4133 }
79072805 4134 mg->mg_type = how;
565764a8 4135 mg->mg_len = namlen;
9cbac4c7 4136 if (name) {
1edc1566 4137 if (namlen >= 0)
4138 mg->mg_ptr = savepvn(name, namlen);
c6ee37c5 4139 else if (namlen == HEf_SVKEY)
1edc1566 4140 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
9cbac4c7 4141 }
1c846c1f 4142
79072805 4143 switch (how) {
14befaf4 4144 case PERL_MAGIC_sv:
22c35a8c 4145 mg->mg_virtual = &PL_vtbl_sv;
79072805 4146 break;
14befaf4 4147 case PERL_MAGIC_overload:
22c35a8c 4148 mg->mg_virtual = &PL_vtbl_amagic;
a0d0e21e 4149 break;
14befaf4 4150 case PERL_MAGIC_overload_elem:
22c35a8c 4151 mg->mg_virtual = &PL_vtbl_amagicelem;
a0d0e21e 4152 break;
14befaf4 4153 case PERL_MAGIC_overload_table:
d460ef45 4154 mg->mg_virtual = &PL_vtbl_ovrld;
a0d0e21e 4155 break;
14befaf4 4156 case PERL_MAGIC_bm:
22c35a8c 4157 mg->mg_virtual = &PL_vtbl_bm;
79072805 4158 break;
14befaf4 4159 case PERL_MAGIC_regdata:
22c35a8c 4160 mg->mg_virtual = &PL_vtbl_regdata;
6cef1e77 4161 break;
14befaf4 4162 case PERL_MAGIC_regdatum:
22c35a8c 4163 mg->mg_virtual = &PL_vtbl_regdatum;
6cef1e77 4164 break;
14befaf4 4165 case PERL_MAGIC_env:
22c35a8c 4166 mg->mg_virtual = &PL_vtbl_env;
79072805 4167 break;
14befaf4 4168 case PERL_MAGIC_fm:
22c35a8c 4169 mg->mg_virtual = &PL_vtbl_fm;
55497cff 4170 break;
14befaf4 4171 case PERL_MAGIC_envelem:
22c35a8c 4172 mg->mg_virtual = &PL_vtbl_envelem;
79072805 4173 break;
14befaf4 4174 case PERL_MAGIC_regex_global:
22c35a8c 4175 mg->mg_virtual = &PL_vtbl_mglob;
93a17b20 4176 break;
14befaf4 4177 case PERL_MAGIC_isa:
22c35a8c 4178 mg->mg_virtual = &PL_vtbl_isa;
463ee0b2 4179 break;
14befaf4 4180 case PERL_MAGIC_isaelem:
22c35a8c 4181 mg->mg_virtual = &PL_vtbl_isaelem;
463ee0b2 4182 break;
14befaf4 4183 case PERL_MAGIC_nkeys:
22c35a8c 4184 mg->mg_virtual = &PL_vtbl_nkeys;
16660edb 4185 break;
14befaf4 4186 case PERL_MAGIC_dbfile:
a0d0e21e 4187 SvRMAGICAL_on(sv);
93a17b20
LW		 4188 mg->mg_virtual = 0;
4189 break;
14befaf4 4190 case PERL_MAGIC_dbline:
22c35a8c 4191 mg->mg_virtual = &PL_vtbl_dbline;
79072805 4192 break;
f93b4edd 4193#ifdef USE_THREADS
14befaf4 4194 case PERL_MAGIC_mutex:
22c35a8c 4195 mg->mg_virtual = &PL_vtbl_mutex;
f93b4edd
MB		 4196 break;
4197#endif /* USE_THREADS */
36477c24 4198#ifdef USE_LOCALE_COLLATE
14befaf4 4199 case PERL_MAGIC_collxfrm:
22c35a8c 4200 mg->mg_virtual = &PL_vtbl_collxfrm;
bbce6d69 4201 break;
36477c24 4202#endif /* USE_LOCALE_COLLATE */
14befaf4 4203 case PERL_MAGIC_tied:
22c35a8c 4204 mg->mg_virtual = &PL_vtbl_pack;
463ee0b2 4205 break;
14befaf4
DM		 4206 case PERL_MAGIC_tiedelem:
4207 case PERL_MAGIC_tiedscalar:
22c35a8c 4208 mg->mg_virtual = &PL_vtbl_packelem;
463ee0b2 4209 break;
14befaf4 4210 case PERL_MAGIC_qr:
22c35a8c 4211 mg->mg_virtual = &PL_vtbl_regexp;
c277df42 4212 break;
14befaf4 4213 case PERL_MAGIC_sig:
22c35a8c 4214 mg->mg_virtual = &PL_vtbl_sig;
79072805 4215 break;
14befaf4 4216 case PERL_MAGIC_sigelem:
22c35a8c 4217 mg->mg_virtual = &PL_vtbl_sigelem;
79072805 4218 break;
14befaf4 4219 case PERL_MAGIC_taint:
22c35a8c 4220 mg->mg_virtual = &PL_vtbl_taint;
565764a8 4221 mg->mg_len = 1;
463ee0b2 4222 break;
14befaf4 4223 case PERL_MAGIC_uvar:
22c35a8c 4224 mg->mg_virtual = &PL_vtbl_uvar;
79072805 4225 break;
14befaf4 4226 case PERL_MAGIC_vec:
22c35a8c 4227 mg->mg_virtual = &PL_vtbl_vec;
79072805 4228 break;
14befaf4 4229 case PERL_MAGIC_substr:
22c35a8c 4230 mg->mg_virtual = &PL_vtbl_substr;
79072805 4231 break;
14befaf4 4232 case PERL_MAGIC_defelem:
22c35a8c 4233 mg->mg_virtual = &PL_vtbl_defelem;
5f05dabc 4234 break;
14befaf4 4235 case PERL_MAGIC_glob:
22c35a8c 4236 mg->mg_virtual = &PL_vtbl_glob;
79072805 4237 break;
14befaf4 4238 case PERL_MAGIC_arylen:
22c35a8c 4239 mg->mg_virtual = &PL_vtbl_arylen;
79072805 4240 break;
14befaf4 4241 case PERL_MAGIC_pos:
22c35a8c 4242 mg->mg_virtual = &PL_vtbl_pos;
a0d0e21e 4243 break;
14befaf4 4244 case PERL_MAGIC_backref:
810b8aa5
GS		 4245 mg->mg_virtual = &PL_vtbl_backref;
4246 break;
14befaf4
DM		 4247 case PERL_MAGIC_ext:
4248 /* Reserved for use by extensions not perl internals. */
4633a7c4
LW		 4249 /* Useful for attaching extension internal data to perl vars. */
4250 /* Note that multiple extensions may clash if magical scalars */
4251 /* etc holding private data from one are passed to another. */
4252 SvRMAGICAL_on(sv);
a0d0e21e 4253 break;
79072805 4254 default:
14befaf4 4255 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
463ee0b2 4256 }
8990e307
LW		 4257 mg_magical(sv);
4258 if (SvGMAGICAL(sv))
4259 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
463ee0b2
LW		 4260}
4261
c461cf8f
JH		 4262/*
4263=for apidoc sv_unmagic
4264
4265Removes magic from an SV.
4266
4267=cut
4268*/
4269
463ee0b2 4270int
864dbfa3 4271Perl_sv_unmagic(pTHX_ SV *sv, int type)
463ee0b2
LW		 4272{
4273 MAGIC* mg;
4274 MAGIC** mgp;
91bba347 4275 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
463ee0b2
LW		 4276 return 0;
4277 mgp = &SvMAGIC(sv);
4278 for (mg = *mgp; mg; mg = *mgp) {
4279 if (mg->mg_type == type) {
4280 MGVTBL* vtbl = mg->mg_virtual;
4281 *mgp = mg->mg_moremagic;
1d7c1841 4282 if (vtbl && vtbl->svt_free)
fc0dc3b3 4283 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
14befaf4 4284 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
565764a8 4285 if (mg->mg_len >= 0)
1edc1566 4286 Safefree(mg->mg_ptr);
565764a8 4287 else if (mg->mg_len == HEf_SVKEY)
1edc1566 4288 SvREFCNT_dec((SV*)mg->mg_ptr);
9cbac4c7 4289 }
a0d0e21e
LW		 4290 if (mg->mg_flags & MGf_REFCOUNTED)
4291 SvREFCNT_dec(mg->mg_obj);
463ee0b2
LW		 4292 Safefree(mg);
4293 }
4294 else
4295 mgp = &mg->mg_moremagic;
79072805 4296 }
91bba347 4297 if (!SvMAGIC(sv)) {
463ee0b2 4298 SvMAGICAL_off(sv);
06759ea0 4299 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
463ee0b2
LW		 4300 }
4301
4302 return 0;
79072805
LW		 4303}
4304
c461cf8f
JH		 4305/*
4306=for apidoc sv_rvweaken
4307
4308Weaken a reference.
4309
4310=cut
4311*/
4312
810b8aa5 4313SV *
864dbfa3 4314Perl_sv_rvweaken(pTHX_ SV *sv)
810b8aa5
GS		 4315{
4316 SV *tsv;
4317 if (!SvOK(sv)) /* let undefs pass */
4318 return sv;
4319 if (!SvROK(sv))
cea2e8a9 4320 Perl_croak(aTHX_ "Can't weaken a nonreference");
810b8aa5 4321 else if (SvWEAKREF(sv)) {
810b8aa5 4322 if (ckWARN(WARN_MISC))
cea2e8a9 4323 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
810b8aa5
GS		 4324 return sv;
4325 }
4326 tsv = SvRV(sv);
4327 sv_add_backref(tsv, sv);
4328 SvWEAKREF_on(sv);
1c846c1f 4329 SvREFCNT_dec(tsv);
810b8aa5
GS		 4330 return sv;
4331}
4332
4333STATIC void
cea2e8a9 4334S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
810b8aa5
GS		 4335{
4336 AV *av;
4337 MAGIC *mg;
14befaf4 4338 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
810b8aa5
GS		 4339 av = (AV*)mg->mg_obj;
4340 else {
4341 av = newAV();
14befaf4 4342 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
810b8aa5
GS		 4343 SvREFCNT_dec(av); /* for sv_magic */
4344 }
4345 av_push(av,sv);
4346}
4347
1c846c1f 4348STATIC void
cea2e8a9 4349S_sv_del_backref(pTHX_ SV *sv)
810b8aa5
GS		 4350{
4351 AV *av;
4352 SV **svp;
4353 I32 i;
4354 SV *tsv = SvRV(sv);
4355 MAGIC *mg;
14befaf4 4356 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
cea2e8a9 4357 Perl_croak(aTHX_ "panic: del_backref");
810b8aa5
GS		 4358 av = (AV *)mg->mg_obj;
4359 svp = AvARRAY(av);
4360 i = AvFILLp(av);
4361 while (i >= 0) {
4362 if (svp[i] == sv) {
4363 svp[i] = &PL_sv_undef; /* XXX */
4364 }
4365 i--;
4366 }
4367}
4368
954c1994
GS		 4369/*
4370=for apidoc sv_insert
4371
4372Inserts a string at the specified offset/length within the SV. Similar to
4373the Perl substr() function.
4374
4375=cut
4376*/
4377
79072805 4378void
864dbfa3 4379Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
79072805
LW		 4380{
4381 register char *big;
4382 register char *mid;
4383 register char *midend;
4384 register char *bigend;
4385 register I32 i;
6ff81951 4386 STRLEN curlen;
1c846c1f 4387
79072805 4388
8990e307 4389 if (!bigstr)
cea2e8a9 4390 Perl_croak(aTHX_ "Can't modify non-existent substring");
6ff81951 4391 SvPV_force(bigstr, curlen);
60fa28ff 4392 (void)SvPOK_only_UTF8(bigstr);
6ff81951
GS		 4393 if (offset + len > curlen) {
4394 SvGROW(bigstr, offset+len+1);
4395 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4396 SvCUR_set(bigstr, offset+len);
4397 }
79072805 4398
69b47968 4399 SvTAINT(bigstr);
79072805
LW		 4400 i = littlelen - len;
4401 if (i > 0) { /* string might grow */
a0d0e21e 4402 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
79072805
LW		 4403 mid = big + offset + len;
4404 midend = bigend = big + SvCUR(bigstr);
4405 bigend += i;
4406 *bigend = '\0';
4407 while (midend > mid) /* shove everything down */
4408 *--bigend = *--midend;
4409 Move(little,big+offset,littlelen,char);
4410 SvCUR(bigstr) += i;
4411 SvSETMAGIC(bigstr);
4412 return;
4413 }
4414 else if (i == 0) {
463ee0b2 4415 Move(little,SvPVX(bigstr)+offset,len,char);
79072805
LW		 4416 SvSETMAGIC(bigstr);
4417 return;
4418 }
4419
463ee0b2 4420 big = SvPVX(bigstr);
79072805
LW		 4421 mid = big + offset;
4422 midend = mid + len;
4423 bigend = big + SvCUR(bigstr);
4424
4425 if (midend > bigend)
cea2e8a9 4426 Perl_croak(aTHX_ "panic: sv_insert");
79072805
LW		 4427
4428 if (mid - big > bigend - midend) { /* faster to shorten from end */
4429 if (littlelen) {
4430 Move(little, mid, littlelen,char);
4431 mid += littlelen;
4432 }
4433 i = bigend - midend;
4434 if (i > 0) {
4435 Move(midend, mid, i,char);
4436 mid += i;
4437 }
4438 *mid = '\0';
4439 SvCUR_set(bigstr, mid - big);
4440 }
4441 /*SUPPRESS 560*/
155aba94 4442 else if ((i = mid - big)) { /* faster from front */
79072805
LW		 4443 midend -= littlelen;
4444 mid = midend;
4445 sv_chop(bigstr,midend-i);
4446 big += i;
4447 while (i--)
4448 *--midend = *--big;
4449 if (littlelen)
4450 Move(little, mid, littlelen,char);
4451 }
4452 else if (littlelen) {
4453 midend -= littlelen;
4454 sv_chop(bigstr,midend);
4455 Move(little,midend,littlelen,char);
4456 }
4457 else {
4458 sv_chop(bigstr,midend);
4459 }
4460 SvSETMAGIC(bigstr);
4461}
4462
c461cf8f
JH		 4463/*
4464=for apidoc sv_replace
4465
4466Make the first argument a copy of the second, then delete the original.
4467
4468=cut
4469*/
79072805
LW		 4470
4471void
864dbfa3 4472Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
79072805
LW		 4473{
4474 U32 refcnt = SvREFCNT(sv);
2213622d 4475 SV_CHECK_THINKFIRST(sv);
0453d815
PM		 4476 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4477 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
93a17b20 4478 if (SvMAGICAL(sv)) {
a0d0e21e
LW		 4479 if (SvMAGICAL(nsv))
4480 mg_free(nsv);
4481 else
4482 sv_upgrade(nsv, SVt_PVMG);
93a17b20 4483 SvMAGIC(nsv) = SvMAGIC(sv);
a0d0e21e 4484 SvFLAGS(nsv) |= SvMAGICAL(sv);
93a17b20
LW		 4485 SvMAGICAL_off(sv);
4486 SvMAGIC(sv) = 0;
4487 }
79072805
LW		 4488 SvREFCNT(sv) = 0;
4489 sv_clear(sv);
477f5d66 4490 assert(!SvREFCNT(sv));
79072805
LW		 4491 StructCopy(nsv,sv,SV);
4492 SvREFCNT(sv) = refcnt;
1edc1566 4493 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
463ee0b2 4494 del_SV(nsv);
79072805
LW		 4495}
4496
c461cf8f
JH		 4497/*
4498=for apidoc sv_clear
4499
4500Clear an SV, making it empty. Does not free the memory used by the SV
4501itself.
4502
4503=cut
4504*/
4505
79072805 4506void
864dbfa3 4507Perl_sv_clear(pTHX_ register SV *sv)
79072805 4508{
ec12f114 4509 HV* stash;
79072805
LW		 4510 assert(sv);
4511 assert(SvREFCNT(sv) == 0);
4512
ed6116ce 4513 if (SvOBJECT(sv)) {
3280af22 4514 if (PL_defstash) { /* Still have a symbol table? */
39644a26 4515 dSP;
32251b26 4516 CV* destructor;
837485b6 4517 SV tmpref;
a0d0e21e 4518
837485b6
GS		 4519 Zero(&tmpref, 1, SV);
4520 sv_upgrade(&tmpref, SVt_RV);
4521 SvROK_on(&tmpref);
4522 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4523 SvREFCNT(&tmpref) = 1;
8ebc5c01 4524
d460ef45 4525 do {
4e8e7886 4526 stash = SvSTASH(sv);
32251b26 4527 destructor = StashHANDLER(stash,DESTROY);
4e8e7886
GS		 4528 if (destructor) {
4529 ENTER;
e788e7d3 4530 PUSHSTACKi(PERLSI_DESTROY);
837485b6 4531 SvRV(&tmpref) = SvREFCNT_inc(sv);
4e8e7886
GS		 4532 EXTEND(SP, 2);
4533 PUSHMARK(SP);
837485b6 4534 PUSHs(&tmpref);
4e8e7886 4535 PUTBACK;
32251b26 4536 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4e8e7886 4537 SvREFCNT(sv)--;
d3acc0f7 4538 POPSTACK;
3095d977 4539 SPAGAIN;
4e8e7886
GS		 4540 LEAVE;
4541 }
4542 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
8ebc5c01 4543
837485b6 4544 del_XRV(SvANY(&tmpref));
6f44e0a4
JP		 4545
4546 if (SvREFCNT(sv)) {
4547 if (PL_in_clean_objs)
cea2e8a9 4548 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
6f44e0a4
JP		 4549 HvNAME(stash));
4550 /* DESTROY gave object new lease on life */
4551 return;
4552 }
a0d0e21e 4553 }
4e8e7886 4554
a0d0e21e 4555 if (SvOBJECT(sv)) {
4e8e7886 4556 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
a0d0e21e
LW		 4557 SvOBJECT_off(sv); /* Curse the object. */
4558 if (SvTYPE(sv) != SVt_PVIO)
3280af22 4559 --PL_sv_objcount; /* XXX Might want something more general */
a0d0e21e 4560 }
463ee0b2 4561 }
c07a80fd 4562 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
a0d0e21e 4563 mg_free(sv);
ec12f114 4564 stash = NULL;
79072805 4565 switch (SvTYPE(sv)) {
8990e307 4566 case SVt_PVIO:
df0bd2f4
GS		 4567 if (IoIFP(sv) &&
4568 IoIFP(sv) != PerlIO_stdin() &&
5f05dabc 4569 IoIFP(sv) != PerlIO_stdout() &&
4570 IoIFP(sv) != PerlIO_stderr())
93578b34 4571 {
f2b5be74 4572 io_close((IO*)sv, FALSE);
93578b34 4573 }
1d7c1841 4574 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
1236053a 4575 PerlDir_close(IoDIRP(sv));
1d7c1841 4576 IoDIRP(sv) = (DIR*)NULL;
8990e307
LW		 4577 Safefree(IoTOP_NAME(sv));
4578 Safefree(IoFMT_NAME(sv));
4579 Safefree(IoBOTTOM_NAME(sv));
a0d0e21e 4580 /* FALL THROUGH */
79072805 4581 case SVt_PVBM:
a0d0e21e 4582 goto freescalar;
79072805 4583 case SVt_PVCV:
748a9306 4584 case SVt_PVFM:
85e6fe83 4585 cv_undef((CV*)sv);
a0d0e21e 4586 goto freescalar;
79072805 4587 case SVt_PVHV:
85e6fe83 4588 hv_undef((HV*)sv);
a0d0e21e 4589 break;
79072805 4590 case SVt_PVAV:
85e6fe83 4591 av_undef((AV*)sv);
a0d0e21e 4592 break;
02270b4e
GS		 4593 case SVt_PVLV:
4594 SvREFCNT_dec(LvTARG(sv));
4595 goto freescalar;
a0d0e21e 4596 case SVt_PVGV:
1edc1566 4597 gp_free((GV*)sv);
a0d0e21e 4598 Safefree(GvNAME(sv));
ec12f114
JPC		 4599 /* cannot decrease stash refcount yet, as we might recursively delete
4600 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4601 of stash until current sv is completely gone.
4602 -- JohnPC, 27 Mar 1998 */
4603 stash = GvSTASH(sv);
a0d0e21e 4604 /* FALL THROUGH */
79072805 4605 case SVt_PVMG:
79072805
LW		 4606 case SVt_PVNV:
4607 case SVt_PVIV:
a0d0e21e
LW		 4608 freescalar:
4609 (void)SvOOK_off(sv);
79072805
LW		 4610 /* FALL THROUGH */
4611 case SVt_PV:
a0d0e21e 4612 case SVt_RV:
810b8aa5
GS		 4613 if (SvROK(sv)) {
4614 if (SvWEAKREF(sv))
4615 sv_del_backref(sv);
4616 else
4617 SvREFCNT_dec(SvRV(sv));
4618 }
1edc1566 4619 else if (SvPVX(sv) && SvLEN(sv))
463ee0b2 4620 Safefree(SvPVX(sv));
1c846c1f 4621 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
c3654f1a 4622 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
1c846c1f
NIS		 4623 SvFAKE_off(sv);
4624 }
79072805 4625 break;
a0d0e21e 4626/*
79072805 4627 case SVt_NV:
79072805 4628 case SVt_IV:
79072805
LW		 4629 case SVt_NULL:
4630 break;
a0d0e21e 4631*/
79072805
LW		 4632 }
4633
4634 switch (SvTYPE(sv)) {
4635 case SVt_NULL:
4636 break;
79072805
LW		 4637 case SVt_IV:
4638 del_XIV(SvANY(sv));
4639 break;
4640 case SVt_NV:
4641 del_XNV(SvANY(sv));
4642 break;
ed6116ce
LW		 4643 case SVt_RV:
4644 del_XRV(SvANY(sv));
4645 break;
79072805
LW		 4646 case SVt_PV:
4647 del_XPV(SvANY(sv));
4648 break;
4649 case SVt_PVIV:
4650 del_XPVIV(SvANY(sv));
4651 break;
4652 case SVt_PVNV:
4653 del_XPVNV(SvANY(sv));
4654 break;
4655 case SVt_PVMG:
4656 del_XPVMG(SvANY(sv));
4657 break;
4658 case SVt_PVLV:
4659 del_XPVLV(SvANY(sv));
4660 break;
4661 case SVt_PVAV:
4662 del_XPVAV(SvANY(sv));
4663 break;
4664 case SVt_PVHV:
4665 del_XPVHV(SvANY(sv));
4666 break;
4667 case SVt_PVCV:
4668 del_XPVCV(SvANY(sv));
4669 break;
4670 case SVt_PVGV:
4671 del_XPVGV(SvANY(sv));
ec12f114
JPC		 4672 /* code duplication for increased performance. */
4673 SvFLAGS(sv) &= SVf_BREAK;
4674 SvFLAGS(sv) |= SVTYPEMASK;
4675 /* decrease refcount of the stash that owns this GV, if any */
4676 if (stash)
4677 SvREFCNT_dec(stash);
4678 return; /* not break, SvFLAGS reset already happened */
79072805
LW		 4679 case SVt_PVBM:
4680 del_XPVBM(SvANY(sv));
4681 break;
4682 case SVt_PVFM:
4683 del_XPVFM(SvANY(sv));
4684 break;
8990e307
LW		 4685 case SVt_PVIO:
4686 del_XPVIO(SvANY(sv));
4687 break;
79072805 4688 }
a0d0e21e 4689 SvFLAGS(sv) &= SVf_BREAK;
8990e307 4690 SvFLAGS(sv) |= SVTYPEMASK;
79072805
LW		 4691}
4692
4693SV *
864dbfa3 4694Perl_sv_newref(pTHX_ SV *sv)
79072805 4695{
463ee0b2 4696 if (sv)
dce16143 4697 ATOMIC_INC(SvREFCNT(sv));
79072805
LW		 4698 return sv;
4699}
4700
c461cf8f
JH		 4701/*
4702=for apidoc sv_free
4703
4704Free the memory used by an SV.
4705
4706=cut
4707*/
4708
79072805 4709void
864dbfa3 4710Perl_sv_free(pTHX_ SV *sv)
79072805 4711{
dce16143
MB		 4712 int refcount_is_zero;
4713
79072805
LW		 4714 if (!sv)
4715 return;
a0d0e21e
LW		 4716 if (SvREFCNT(sv) == 0) {
4717 if (SvFLAGS(sv) & SVf_BREAK)
4718 return;
3280af22 4719 if (PL_in_clean_all) /* All is fair */
1edc1566 4720 return;
d689ffdd
JP		 4721 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4722 /* make sure SvREFCNT(sv)==0 happens very seldom */
4723 SvREFCNT(sv) = (~(U32)0)/2;
4724 return;
4725 }
0453d815
PM		 4726 if (ckWARN_d(WARN_INTERNAL))
4727 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
79072805
LW		 4728 return;
4729 }
dce16143
MB		 4730 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4731 if (!refcount_is_zero)
8990e307 4732 return;
463ee0b2
LW		 4733#ifdef DEBUGGING
4734 if (SvTEMP(sv)) {
0453d815 4735 if (ckWARN_d(WARN_DEBUGGING))
f248d071 4736 Perl_warner(aTHX_ WARN_DEBUGGING,
1d7c1841
GS		 4737 "Attempt to free temp prematurely: SV 0x%"UVxf,
4738 PTR2UV(sv));
79072805 4739 return;
79072805 4740 }
463ee0b2 4741#endif
d689ffdd
JP		 4742 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4743 /* make sure SvREFCNT(sv)==0 happens very seldom */
4744 SvREFCNT(sv) = (~(U32)0)/2;
4745 return;
4746 }
79072805 4747 sv_clear(sv);
477f5d66
CS		 4748 if (! SvREFCNT(sv))
4749 del_SV(sv);
79072805
LW		 4750}
4751
954c1994
GS		 4752/*
4753=for apidoc sv_len
4754
4755Returns the length of the string in the SV. See also C<SvCUR>.
4756
4757=cut
4758*/
4759
79072805 4760STRLEN
864dbfa3 4761Perl_sv_len(pTHX_ register SV *sv)
79072805 4762{
748a9306 4763 char *junk;
463ee0b2 4764 STRLEN len;
79072805
LW		 4765
4766 if (!sv)
4767 return 0;
4768
8990e307 4769 if (SvGMAGICAL(sv))
565764a8 4770 len = mg_length(sv);
8990e307 4771 else
748a9306 4772 junk = SvPV(sv, len);
463ee0b2 4773 return len;
79072805
LW		 4774}
4775
c461cf8f
JH		 4776/*
4777=for apidoc sv_len_utf8
4778
4779Returns the number of characters in the string in an SV, counting wide
4780UTF8 bytes as a single character.
4781
4782=cut
4783*/
4784
a0ed51b3 4785STRLEN
864dbfa3 4786Perl_sv_len_utf8(pTHX_ register SV *sv)
a0ed51b3 4787{
a0ed51b3
LW		 4788 if (!sv)
4789 return 0;
4790
a0ed51b3 4791 if (SvGMAGICAL(sv))
b76347f2 4792 return mg_length(sv);
a0ed51b3 4793 else
b76347f2
JH		 4794 {
4795 STRLEN len;
4796 U8 *s = (U8*)SvPV(sv, len);
4797
d6efbbad 4798 return Perl_utf8_length(aTHX_ s, s + len);
a0ed51b3 4799 }
a0ed51b3
LW		 4800}
4801
4802void
864dbfa3 4803Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
a0ed51b3 4804{
dfe13c55
GS		 4805 U8 *start;
4806 U8 *s;
4807 U8 *send;
a0ed51b3
LW		 4808 I32 uoffset = *offsetp;
4809 STRLEN len;
4810
4811 if (!sv)
4812 return;
4813
dfe13c55 4814 start = s = (U8*)SvPV(sv, len);
a0ed51b3
LW		 4815 send = s + len;
4816 while (s < send && uoffset--)
4817 s += UTF8SKIP(s);
bb40f870
GA		 4818 if (s >= send)
4819 s = send;
a0ed51b3
LW		 4820 *offsetp = s - start;
4821 if (lenp) {
4822 I32 ulen = *lenp;
4823 start = s;
4824 while (s < send && ulen--)
4825 s += UTF8SKIP(s);
bb40f870
GA		 4826 if (s >= send)
4827 s = send;
a0ed51b3
LW		 4828 *lenp = s - start;
4829 }
4830 return;
4831}
4832
4833void
864dbfa3 4834Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
a0ed51b3 4835{
dfe13c55
GS		 4836 U8 *s;
4837 U8 *send;
a0ed51b3
LW		 4838 STRLEN len;
4839
4840 if (!sv)
4841 return;
4842
dfe13c55 4843 s = (U8*)SvPV(sv, len);
a0ed51b3 4844 if (len < *offsetp)
a0dbb045 4845 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
a0ed51b3
LW		 4846 send = s + *offsetp;
4847 len = 0;
4848 while (s < send) {
a0dbb045 4849 STRLEN n;
2b9d42f0
NIS		 4850 /* Call utf8n_to_uvchr() to validate the sequence */
4851 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4852 if (n > 0) {
a0dbb045
JH		 4853 s += n;
4854 len++;
4855 }
4856 else
4857 break;
a0ed51b3
LW		 4858 }
4859 *offsetp = len;
4860 return;
4861}
4862
954c1994
GS		 4863/*
4864=for apidoc sv_eq
4865
4866Returns a boolean indicating whether the strings in the two SVs are
4867identical.
4868
4869=cut
4870*/
4871
79072805 4872I32
e01b9e88 4873Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
79072805
LW		 4874{
4875 char *pv1;
463ee0b2 4876 STRLEN cur1;
79072805 4877 char *pv2;
463ee0b2 4878 STRLEN cur2;
e01b9e88 4879 I32 eq = 0;
db42d148 4880 char *tpv = Nullch;
79072805 4881
e01b9e88 4882 if (!sv1) {
79072805
LW		 4883 pv1 = "";
4884 cur1 = 0;
4885 }
463ee0b2 4886 else
e01b9e88 4887 pv1 = SvPV(sv1, cur1);
79072805 4888
e01b9e88
SC		 4889 if (!sv2){
4890 pv2 = "";
4891 cur2 = 0;
92d29cee 4892 }
e01b9e88
SC		 4893 else
4894 pv2 = SvPV(sv2, cur2);
79072805 4895
e01b9e88 4896 /* do not utf8ize the comparands as a side-effect */
0064a8a9 4897 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
f9a63242 4898 bool is_utf8 = TRUE;
db42d148 4899 /* UTF-8ness differs */
1aa99e6b
IH		 4900 if (PL_hints & HINT_UTF8_DISTINCT)
4901 return FALSE;
4902
e01b9e88 4903 if (SvUTF8(sv1)) {
db42d148 4904 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
f34ff0a8 4905 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
db42d148
NIS		 4906 if (pv != pv1)
4907 pv1 = tpv = pv;
e01b9e88
SC		 4908 }
4909 else {
db42d148 4910 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
f34ff0a8 4911 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
db42d148
NIS		 4912 if (pv != pv2)
4913 pv2 = tpv = pv;
4914 }
4915 if (is_utf8) {
4916 /* Downgrade not possible - cannot be eq */
4917 return FALSE;
e01b9e88
SC		 4918 }
4919 }
79072805 4920
e01b9e88
SC		 4921 if (cur1 == cur2)
4922 eq = memEQ(pv1, pv2, cur1);
4923
db42d148
NIS		 4924 if (tpv != Nullch)
4925 Safefree(tpv);
e01b9e88
SC		 4926
4927 return eq;
79072805
LW		 4928}
4929
954c1994
GS		 4930/*
4931=for apidoc sv_cmp
4932
4933Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4934string in C<sv1> is less than, equal to, or greater than the string in
4935C<sv2>.
4936
4937=cut
4938*/
4939
79072805 4940I32
e01b9e88 4941Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
79072805 4942{
560a288e
GS		 4943 STRLEN cur1, cur2;
4944 char *pv1, *pv2;
1c846c1f 4945 I32 cmp;
e01b9e88
SC		 4946 bool pv1tmp = FALSE;
4947 bool pv2tmp = FALSE;
560a288e 4948
e01b9e88
SC		 4949 if (!sv1) {
4950 pv1 = "";
560a288e
GS		 4951 cur1 = 0;
4952 }
e01b9e88
SC		 4953 else
4954 pv1 = SvPV(sv1, cur1);
560a288e 4955
e01b9e88
SC		 4956 if (!sv2){
4957 pv2 = "";
560a288e
GS		 4958 cur2 = 0;
4959 }
e01b9e88
SC		 4960 else
4961 pv2 = SvPV(sv2, cur2);
79072805 4962
e01b9e88 4963 /* do not utf8ize the comparands as a side-effect */
0064a8a9 4964 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
1aa99e6b
IH		 4965 if (PL_hints & HINT_UTF8_DISTINCT)
4966 return SvUTF8(sv1) ? 1 : -1;
4967
e01b9e88
SC		 4968 if (SvUTF8(sv1)) {
4969 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4970 pv2tmp = TRUE;
4971 }
4972 else {
4973 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4974 pv1tmp = TRUE;
4975 }
4976 }
79072805 4977
e01b9e88
SC		 4978 if (!cur1) {
4979 cmp = cur2 ? -1 : 0;
4980 } else if (!cur2) {
4981 cmp = 1;
4982 } else {
4983 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4984
4985 if (retval) {
4986 cmp = retval < 0 ? -1 : 1;
4987 } else if (cur1 == cur2) {
4988 cmp = 0;
4989 } else {
4990 cmp = cur1 < cur2 ? -1 : 1;
4991 }
4992 }
16660edb 4993
e01b9e88
SC		 4994 if (pv1tmp)
4995 Safefree(pv1);
4996 if (pv2tmp)
4997 Safefree(pv2);
16660edb 4998
e01b9e88 4999 return cmp;
bbce6d69 5000}
16660edb 5001
c461cf8f
JH		 5002/*
5003=for apidoc sv_cmp_locale
5004
5005Compares the strings in two SVs in a locale-aware manner. See
5006L</sv_cmp_locale>
5007
5008=cut
5009*/
5010
bbce6d69 5011I32
864dbfa3 5012Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
bbce6d69 5013{
36477c24 5014#ifdef USE_LOCALE_COLLATE
16660edb 5015
bbce6d69 5016 char *pv1, *pv2;
5017 STRLEN len1, len2;
5018 I32 retval;
16660edb 5019
3280af22 5020 if (PL_collation_standard)
bbce6d69 5021 goto raw_compare;
16660edb 5022
bbce6d69 5023 len1 = 0;
8ac85365 5024 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
bbce6d69 5025 len2 = 0;
8ac85365 5026 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
16660edb 5027
bbce6d69 5028 if (!pv1 || !len1) {
5029 if (pv2 && len2)
5030 return -1;
5031 else
5032 goto raw_compare;
5033 }
5034 else {
5035 if (!pv2 || !len2)
5036 return 1;
5037 }
16660edb 5038
bbce6d69 5039 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
16660edb 5040
bbce6d69 5041 if (retval)
16660edb 5042 return retval < 0 ? -1 : 1;
5043
bbce6d69 5044 /*
5045 * When the result of collation is equality, that doesn't mean
5046 * that there are no differences -- some locales exclude some
5047 * characters from consideration. So to avoid false equalities,
5048 * we use the raw string as a tiebreaker.
5049 */
16660edb 5050
bbce6d69 5051 raw_compare:
5052 /* FALL THROUGH */
16660edb 5053
36477c24 5054#endif /* USE_LOCALE_COLLATE */
16660edb 5055
bbce6d69 5056 return sv_cmp(sv1, sv2);
5057}
79072805 5058
36477c24 5059#ifdef USE_LOCALE_COLLATE
7a4c00b4 5060/*
14befaf4 5061 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
7a4c00b4 5062 * scalar data of the variable transformed to such a format that
5063 * a normal memory comparison can be used to compare the data
5064 * according to the locale settings.
5065 */
bbce6d69 5066char *
864dbfa3 5067Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
bbce6d69 5068{
7a4c00b4 5069 MAGIC *mg;
16660edb 5070
14befaf4 5071 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
3280af22 5072 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
bbce6d69 5073 char *s, *xf;
5074 STRLEN len, xlen;
5075
7a4c00b4 5076 if (mg)
5077 Safefree(mg->mg_ptr);
bbce6d69 5078 s = SvPV(sv, len);
5079 if ((xf = mem_collxfrm(s, len, &xlen))) {
ff0cee69 5080 if (SvREADONLY(sv)) {
5081 SAVEFREEPV(xf);
5082 *nxp = xlen;
3280af22 5083 return xf + sizeof(PL_collation_ix);
ff0cee69 5084 }
7a4c00b4 5085 if (! mg) {
14befaf4
DM		 5086 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5087 mg = mg_find(sv, PERL_MAGIC_collxfrm);
7a4c00b4 5088 assert(mg);
bbce6d69 5089 }
7a4c00b4 5090 mg->mg_ptr = xf;
565764a8 5091 mg->mg_len = xlen;
7a4c00b4 5092 }
5093 else {
ff0cee69 5094 if (mg) {
5095 mg->mg_ptr = NULL;
565764a8 5096 mg->mg_len = -1;
ff0cee69 5097 }
bbce6d69 5098 }
5099 }
7a4c00b4 5100 if (mg && mg->mg_ptr) {
565764a8 5101 *nxp = mg->mg_len;
3280af22 5102 return mg->mg_ptr + sizeof(PL_collation_ix);
bbce6d69 5103 }
5104 else {
5105 *nxp = 0;
5106 return NULL;
16660edb 5107 }
79072805
LW		 5108}
5109
36477c24 5110#endif /* USE_LOCALE_COLLATE */
bbce6d69 5111
c461cf8f
JH		 5112/*
5113=for apidoc sv_gets
5114
5115Get a line from the filehandle and store it into the SV, optionally
5116appending to the currently-stored string.
5117
5118=cut
5119*/
5120
79072805 5121char *
864dbfa3 5122Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
79072805 5123{
c07a80fd 5124 char *rsptr;
5125 STRLEN rslen;
5126 register STDCHAR rslast;
5127 register STDCHAR *bp;
5128 register I32 cnt;
9c5ffd7c 5129 I32 i = 0;
c07a80fd 5130
2213622d 5131 SV_CHECK_THINKFIRST(sv);
6fc92669 5132 (void)SvUPGRADE(sv, SVt_PV);
99491443 5133
ff68c719 5134 SvSCREAM_off(sv);
c07a80fd 5135
3280af22 5136 if (RsSNARF(PL_rs)) {
c07a80fd 5137 rsptr = NULL;
5138 rslen = 0;
5139 }
3280af22 5140 else if (RsRECORD(PL_rs)) {
5b2b9c68
HM		 5141 I32 recsize, bytesread;
5142 char *buffer;
5143
5144 /* Grab the size of the record we're getting */
3280af22 5145 recsize = SvIV(SvRV(PL_rs));
5b2b9c68 5146 (void)SvPOK_only(sv); /* Validate pointer */
e670df4e 5147 buffer = SvGROW(sv, recsize + 1);
5b2b9c68
HM		 5148 /* Go yank in */
5149#ifdef VMS
5150 /* VMS wants read instead of fread, because fread doesn't respect */
5151 /* RMS record boundaries. This is not necessarily a good thing to be */
5152 /* doing, but we've got no other real choice */
5153 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5154#else
5155 bytesread = PerlIO_read(fp, buffer, recsize);
5156#endif
5157 SvCUR_set(sv, bytesread);
e670df4e 5158 buffer[bytesread] = '\0';
7d59b7e4
NIS		 5159 if (PerlIO_isutf8(fp))
5160 SvUTF8_on(sv);
5161 else
5162 SvUTF8_off(sv);
5b2b9c68
HM		 5163 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5164 }
3280af22 5165 else if (RsPARA(PL_rs)) {
c07a80fd 5166 rsptr = "\n\n";
5167 rslen = 2;
5168 }
7d59b7e4
NIS		 5169 else {
5170 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5171 if (PerlIO_isutf8(fp)) {
5172 rsptr = SvPVutf8(PL_rs, rslen);
5173 }
5174 else {
5175 if (SvUTF8(PL_rs)) {
5176 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5177 Perl_croak(aTHX_ "Wide character in $/");
5178 }
5179 }
5180 rsptr = SvPV(PL_rs, rslen);
5181 }
5182 }
5183
c07a80fd 5184 rslast = rslen ? rsptr[rslen - 1] : '\0';
5185
3280af22 5186 if (RsPARA(PL_rs)) { /* have to do this both before and after */
79072805 5187 do { /* to make sure file boundaries work right */
760ac839 5188 if (PerlIO_eof(fp))
a0d0e21e 5189 return 0;
760ac839 5190 i = PerlIO_getc(fp);
79072805 5191 if (i != '\n') {
a0d0e21e
LW		 5192 if (i == -1)
5193 return 0;
760ac839 5194 PerlIO_ungetc(fp,i);
79072805
LW		 5195 break;
5196 }
5197 } while (i != EOF);
5198 }
c07a80fd 5199
760ac839
LW		 5200 /* See if we know enough about I/O mechanism to cheat it ! */
5201
5202 /* This used to be #ifdef test - it is made run-time test for ease
1c846c1f 5203 of abstracting out stdio interface. One call should be cheap
760ac839
LW		 5204 enough here - and may even be a macro allowing compile
5205 time optimization.
5206 */
5207
5208 if (PerlIO_fast_gets(fp)) {
5209
5210 /*
5211 * We're going to steal some values from the stdio struct
5212 * and put EVERYTHING in the innermost loop into registers.
5213 */
5214 register STDCHAR *ptr;
5215 STRLEN bpx;
5216 I32 shortbuffered;
5217
16660edb 5218#if defined(VMS) && defined(PERLIO_IS_STDIO)
5219 /* An ungetc()d char is handled separately from the regular
5220 * buffer, so we getc() it back out and stuff it in the buffer.
5221 */
5222 i = PerlIO_getc(fp);
5223 if (i == EOF) return 0;
5224 *(--((*fp)->_ptr)) = (unsigned char) i;
5225 (*fp)->_cnt++;
5226#endif
c07a80fd 5227
c2960299 5228 /* Here is some breathtakingly efficient cheating */
c07a80fd 5229
a20bf0c3 5230 cnt = PerlIO_get_cnt(fp); /* get count into register */
a0d0e21e 5231 (void)SvPOK_only(sv); /* validate pointer */
79072805
LW		 5232 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5233 if (cnt > 80 && SvLEN(sv) > append) {
5234 shortbuffered = cnt - SvLEN(sv) + append + 1;
5235 cnt -= shortbuffered;
5236 }
5237 else {
5238 shortbuffered = 0;
bbce6d69 5239 /* remember that cnt can be negative */
5240 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
79072805
LW		 5241 }
5242 }
5243 else
5244 shortbuffered = 0;
c07a80fd 5245 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
a20bf0c3 5246 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
16660edb 5247 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5248 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
16660edb 5249 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5250 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5251 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5252 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
79072805
LW		 5253 for (;;) {
5254 screamer:
93a17b20 5255 if (cnt > 0) {
c07a80fd 5256 if (rslen) {
760ac839
LW		 5257 while (cnt > 0) { /* this | eat */
5258 cnt--;
c07a80fd 5259 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5260 goto thats_all_folks; /* screams | sed :-) */
5261 }
5262 }
5263 else {
1c846c1f
NIS		 5264 Copy(ptr, bp, cnt, char); /* this | eat */
5265 bp += cnt; /* screams | dust */
c07a80fd 5266 ptr += cnt; /* louder | sed :-) */
a5f75d66 5267 cnt = 0;
93a17b20 5268 }
79072805
LW		 5269 }
5270
748a9306 5271 if (shortbuffered) { /* oh well, must extend */
79072805
LW		 5272 cnt = shortbuffered;
5273 shortbuffered = 0;
c07a80fd 5274 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 5275 SvCUR_set(sv, bpx);
5276 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
c07a80fd 5277 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
79072805
LW		 5278 continue;
5279 }
5280
16660edb 5281 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841
GS		 5282 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5283 PTR2UV(ptr),(long)cnt));
a20bf0c3 5284 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
16660edb 5285 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5286 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5287 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5288 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
1c846c1f 5289 /* This used to call 'filbuf' in stdio form, but as that behaves like
774d564b 5290 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5291 another abstraction. */
760ac839 5292 i = PerlIO_getc(fp); /* get more characters */
16660edb 5293 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5294 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5295 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5296 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
a20bf0c3
JH		 5297 cnt = PerlIO_get_cnt(fp);
5298 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
16660edb 5299 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5300 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
79072805 5301
748a9306
LW		 5302 if (i == EOF) /* all done for ever? */
5303 goto thats_really_all_folks;
5304
c07a80fd 5305 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
79072805
LW		 5306 SvCUR_set(sv, bpx);
5307 SvGROW(sv, bpx + cnt + 2);
c07a80fd 5308 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5309
760ac839 5310 *bp++ = i; /* store character from PerlIO_getc */
79072805 5311
c07a80fd 5312 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
79072805 5313 goto thats_all_folks;
79072805
LW		 5314 }
5315
5316thats_all_folks:
c07a80fd 5317 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
36477c24 5318 memNE((char*)bp - rslen, rsptr, rslen))
760ac839 5319 goto screamer; /* go back to the fray */
79072805
LW		 5320thats_really_all_folks:
5321 if (shortbuffered)
5322 cnt += shortbuffered;
16660edb 5323 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5324 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
a20bf0c3 5325 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
16660edb 5326 DEBUG_P(PerlIO_printf(Perl_debug_log,
1d7c1841 5327 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
1c846c1f 5328 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
1d7c1841 5329 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
79072805 5330 *bp = '\0';
760ac839 5331 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
16660edb 5332 DEBUG_P(PerlIO_printf(Perl_debug_log,
fb73857a 5333 "Screamer: done, len=%ld, string=|%.*s|\n",
5334 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
760ac839
LW		 5335 }
5336 else
79072805 5337 {
4d2c4e07 5338#ifndef EPOC
760ac839 5339 /*The big, slow, and stupid way */
c07a80fd 5340 STDCHAR buf[8192];
4d2c4e07
OF		 5341#else
5342 /* Need to work around EPOC SDK features */
5343 /* On WINS: MS VC5 generates calls to _chkstk, */
5344 /* if a `large' stack frame is allocated */
5345 /* gcc on MARM does not generate calls like these */
5346 STDCHAR buf[1024];
5347#endif
79072805 5348
760ac839 5349screamer2:
c07a80fd 5350 if (rslen) {
760ac839
LW		 5351 register STDCHAR *bpe = buf + sizeof(buf);
5352 bp = buf;
5353 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5354 ; /* keep reading */
5355 cnt = bp - buf;
c07a80fd 5356 }
5357 else {
760ac839 5358 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
16660edb 5359 /* Accomodate broken VAXC compiler, which applies U8 cast to
5360 * both args of ?: operator, causing EOF to change into 255
5361 */
5362 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
c07a80fd 5363 }
79072805
LW		 5364
5365 if (append)
760ac839 5366 sv_catpvn(sv, (char *) buf, cnt);
79072805 5367 else
760ac839 5368 sv_setpvn(sv, (char *) buf, cnt);
c07a80fd 5369
5370 if (i != EOF && /* joy */
5371 (!rslen ||
5372 SvCUR(sv) < rslen ||
36477c24 5373 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
79072805
LW		 5374 {
5375 append = -1;
63e4d877
CS		 5376 /*
5377 * If we're reading from a TTY and we get a short read,
5378 * indicating that the user hit his EOF character, we need
5379 * to notice it now, because if we try to read from the TTY
5380 * again, the EOF condition will disappear.
5381 *
5382 * The comparison of cnt to sizeof(buf) is an optimization
5383 * that prevents unnecessary calls to feof().
5384 *
5385 * - jik 9/25/96
5386 */
5387 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5388 goto screamer2;
79072805
LW		 5389 }
5390 }
5391
1c846c1f 5392 if (RsPARA(PL_rs)) { /* have to do this both before and after */
c07a80fd 5393 while (i != EOF) { /* to make sure file boundaries work right */
760ac839 5394 i = PerlIO_getc(fp);
79072805 5395 if (i != '\n') {
760ac839 5396 PerlIO_ungetc(fp,i);
79072805
LW		 5397 break;
5398 }
5399 }
5400 }
c07a80fd 5401
7d59b7e4
NIS		 5402 if (PerlIO_isutf8(fp))
5403 SvUTF8_on(sv);
5404 else
5405 SvUTF8_off(sv);
5406
c07a80fd 5407 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
79072805
LW		 5408}
5409
760ac839 5410
954c1994
GS		 5411/*
5412=for apidoc sv_inc
5413
5414Auto-increment of the value in the SV.
5415
5416=cut
5417*/
5418
79072805 5419void
864dbfa3 5420Perl_sv_inc(pTHX_ register SV *sv)
79072805
LW		 5421{
5422 register char *d;
463ee0b2 5423 int flags;
79072805
LW		 5424
5425 if (!sv)
5426 return;
b23a5f78
GB		 5427 if (SvGMAGICAL(sv))
5428 mg_get(sv);
ed6116ce 5429 if (SvTHINKFIRST(sv)) {
0f15f207 5430 if (SvREADONLY(sv)) {
3280af22 5431 if (PL_curcop != &PL_compiling)
cea2e8a9 5432 Perl_croak(aTHX_ PL_no_modify);
0f15f207 5433 }
a0d0e21e 5434 if (SvROK(sv)) {
b5be31e9 5435 IV i;
9e7bc3e8
JD		 5436 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5437 return;
56431972 5438 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 5439 sv_unref(sv);
5440 sv_setiv(sv, i);
a0d0e21e 5441 }
ed6116ce 5442 }
8990e307 5443 flags = SvFLAGS(sv);
28e5dec8
JH		 5444 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5445 /* It's (privately or publicly) a float, but not tested as an
5446 integer, so test it to see. */
d460ef45 5447 (void) SvIV(sv);
28e5dec8
JH		 5448 flags = SvFLAGS(sv);
5449 }
5450 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5451 /* It's publicly an integer, or privately an integer-not-float */
5452 oops_its_int:
25da4f38
IZ		 5453 if (SvIsUV(sv)) {
5454 if (SvUVX(sv) == UV_MAX)
65202027 5455 sv_setnv(sv, (NV)UV_MAX + 1.0);
25da4f38
IZ		 5456 else
5457 (void)SvIOK_only_UV(sv);
5458 ++SvUVX(sv);
5459 } else {
5460 if (SvIVX(sv) == IV_MAX)
28e5dec8 5461 sv_setuv(sv, (UV)IV_MAX + 1);
25da4f38
IZ		 5462 else {
5463 (void)SvIOK_only(sv);
5464 ++SvIVX(sv);
1c846c1f 5465 }
55497cff 5466 }
79072805
LW		 5467 return;
5468 }
28e5dec8
JH		 5469 if (flags & SVp_NOK) {
5470 (void)SvNOK_only(sv);
5471 SvNVX(sv) += 1.0;
5472 return;
5473 }
5474
8990e307 5475 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
28e5dec8
JH		 5476 if ((flags & SVTYPEMASK) < SVt_PVIV)
5477 sv_upgrade(sv, SVt_IV);
5478 (void)SvIOK_only(sv);
5479 SvIVX(sv) = 1;
79072805
LW		 5480 return;
5481 }
463ee0b2 5482 d = SvPVX(sv);
79072805
LW		 5483 while (isALPHA(*d)) d++;
5484 while (isDIGIT(*d)) d++;
5485 if (*d) {
28e5dec8
JH		 5486#ifdef PERL_PRESERVE_IVUV
5487 /* Got to punt this an an integer if needs be, but we don't issue
5488 warnings. Probably ought to make the sv_iv_please() that does
5489 the conversion if possible, and silently. */
5490 I32 numtype = looks_like_number(sv);
5491 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5492 /* Need to try really hard to see if it's an integer.
5493 9.22337203685478e+18 is an integer.
5494 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5495 so $a="9.22337203685478e+18"; $a+0; $a++
5496 needs to be the same as $a="9.22337203685478e+18"; $a++
5497 or we go insane. */
d460ef45 5498
28e5dec8
JH		 5499 (void) sv_2iv(sv);
5500 if (SvIOK(sv))
5501 goto oops_its_int;
5502
5503 /* sv_2iv *should* have made this an NV */
5504 if (flags & SVp_NOK) {
5505 (void)SvNOK_only(sv);
5506 SvNVX(sv) += 1.0;
5507 return;
5508 }
5509 /* I don't think we can get here. Maybe I should assert this
5510 And if we do get here I suspect that sv_setnv will croak. NWC
5511 Fall through. */
5512#if defined(USE_LONG_DOUBLE)
5513 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",
5514 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5515#else
5516 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5517 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5518#endif
5519 }
5520#endif /* PERL_PRESERVE_IVUV */
5521 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
79072805
LW		 5522 return;
5523 }
5524 d--;
463ee0b2 5525 while (d >= SvPVX(sv)) {
79072805
LW		 5526 if (isDIGIT(*d)) {
5527 if (++*d <= '9')
5528 return;
5529 *(d--) = '0';
5530 }
5531 else {
9d116dd7
JH		 5532#ifdef EBCDIC
5533 /* MKS: The original code here died if letters weren't consecutive.
5534 * at least it didn't have to worry about non-C locales. The
5535 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
1c846c1f 5536 * arranged in order (although not consecutively) and that only
9d116dd7
JH		 5537 * [A-Za-z] are accepted by isALPHA in the C locale.
5538 */
5539 if (*d != 'z' && *d != 'Z') {
5540 do { ++*d; } while (!isALPHA(*d));
5541 return;
5542 }
5543 *(d--) -= 'z' - 'a';
5544#else
79072805
LW		 5545 ++*d;
5546 if (isALPHA(*d))
5547 return;
5548 *(d--) -= 'z' - 'a' + 1;
9d116dd7 5549#endif
79072805
LW		 5550 }
5551 }
5552 /* oh,oh, the number grew */
5553 SvGROW(sv, SvCUR(sv) + 2);
5554 SvCUR(sv)++;
463ee0b2 5555 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
79072805
LW		 5556 *d = d[-1];
5557 if (isDIGIT(d[1]))
5558 *d = '1';
5559 else
5560 *d = d[1];
5561}
5562
954c1994
GS		 5563/*
5564=for apidoc sv_dec
5565
5566Auto-decrement of the value in the SV.
5567
5568=cut
5569*/
5570
79072805 5571void
864dbfa3 5572Perl_sv_dec(pTHX_ register SV *sv)
79072805 5573{
463ee0b2
LW		 5574 int flags;
5575
79072805
LW		 5576 if (!sv)
5577 return;
b23a5f78
GB		 5578 if (SvGMAGICAL(sv))
5579 mg_get(sv);
ed6116ce 5580 if (SvTHINKFIRST(sv)) {
0f15f207 5581 if (SvREADONLY(sv)) {
3280af22 5582 if (PL_curcop != &PL_compiling)
cea2e8a9 5583 Perl_croak(aTHX_ PL_no_modify);
0f15f207 5584 }
a0d0e21e 5585 if (SvROK(sv)) {
b5be31e9 5586 IV i;
9e7bc3e8
JD		 5587 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5588 return;
56431972 5589 i = PTR2IV(SvRV(sv));
b5be31e9
SM		 5590 sv_unref(sv);
5591 sv_setiv(sv, i);
a0d0e21e 5592 }
ed6116ce 5593 }
28e5dec8
JH		 5594 /* Unlike sv_inc we don't have to worry about string-never-numbers
5595 and keeping them magic. But we mustn't warn on punting */
8990e307 5596 flags = SvFLAGS(sv);
28e5dec8
JH		 5597 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5598 /* It's publicly an integer, or privately an integer-not-float */
5599 oops_its_int:
25da4f38
IZ		 5600 if (SvIsUV(sv)) {
5601 if (SvUVX(sv) == 0) {
5602 (void)SvIOK_only(sv);
5603 SvIVX(sv) = -1;
5604 }
5605 else {
5606 (void)SvIOK_only_UV(sv);
5607 --SvUVX(sv);
1c846c1f 5608 }
25da4f38
IZ		 5609 } else {
5610 if (SvIVX(sv) == IV_MIN)
65202027 5611 sv_setnv(sv, (NV)IV_MIN - 1.0);
25da4f38
IZ		 5612 else {
5613 (void)SvIOK_only(sv);
5614 --SvIVX(sv);
1c846c1f 5615 }
55497cff 5616 }
5617 return;
5618 }
28e5dec8
JH		 5619 if (flags & SVp_NOK) {
5620 SvNVX(sv) -= 1.0;
5621 (void)SvNOK_only(sv);
5622 return;
5623 }
8990e307 5624 if (!(flags & SVp_POK)) {
4633a7c4
LW		 5625 if ((flags & SVTYPEMASK) < SVt_PVNV)
5626 sv_upgrade(sv, SVt_NV);
463ee0b2 5627 SvNVX(sv) = -1.0;
a0d0e21e 5628 (void)SvNOK_only(sv);
79072805
LW		 5629 return;
5630 }
28e5dec8
JH		 5631#ifdef PERL_PRESERVE_IVUV
5632 {
5633 I32 numtype = looks_like_number(sv);
5634 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5635 /* Need to try really hard to see if it's an integer.
5636 9.22337203685478e+18 is an integer.
5637 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5638 so $a="9.22337203685478e+18"; $a+0; $a--
5639 needs to be the same as $a="9.22337203685478e+18"; $a--
5640 or we go insane. */
d460ef45 5641
28e5dec8
JH		 5642 (void) sv_2iv(sv);
5643 if (SvIOK(sv))
5644 goto oops_its_int;
5645
5646 /* sv_2iv *should* have made this an NV */
5647 if (flags & SVp_NOK) {
5648 (void)SvNOK_only(sv);
5649 SvNVX(sv) -= 1.0;
5650 return;
5651 }
5652 /* I don't think we can get here. Maybe I should assert this
5653 And if we do get here I suspect that sv_setnv will croak. NWC
5654 Fall through. */
5655#if defined(USE_LONG_DOUBLE)
5656 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",
5657 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5658#else
5659 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5660 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5661#endif
5662 }
5663 }
5664#endif /* PERL_PRESERVE_IVUV */
097ee67d 5665 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
79072805
LW		 5666}
5667
954c1994
GS		 5668/*
5669=for apidoc sv_mortalcopy
5670
5671Creates a new SV which is a copy of the original SV. The new SV is marked
5672as mortal.
5673
5674=cut
5675*/
5676
79072805
LW		 5677/* Make a string that will exist for the duration of the expression
5678 * evaluation. Actually, it may have to last longer than that, but
5679 * hopefully we won't free it until it has been assigned to a
5680 * permanent location. */
5681
5682SV *
864dbfa3 5683Perl_sv_mortalcopy(pTHX_ SV *oldstr)
79072805 5684{
463ee0b2 5685 register SV *sv;
79072805 5686
4561caa4 5687 new_SV(sv);
79072805 5688 sv_setsv(sv,oldstr);
677b06e3
GS		 5689 EXTEND_MORTAL(1);
5690 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307
LW		 5691 SvTEMP_on(sv);
5692 return sv;
5693}
5694
954c1994
GS		 5695/*
5696=for apidoc sv_newmortal
5697
5698Creates a new SV which is mortal. The reference count of the SV is set to 1.
5699
5700=cut
5701*/
5702
8990e307 5703SV *
864dbfa3 5704Perl_sv_newmortal(pTHX)
8990e307
LW		 5705{
5706 register SV *sv;
5707
4561caa4 5708 new_SV(sv);
8990e307 5709 SvFLAGS(sv) = SVs_TEMP;
677b06e3
GS		 5710 EXTEND_MORTAL(1);
5711 PL_tmps_stack[++PL_tmps_ix] = sv;
79072805
LW		 5712 return sv;
5713}
5714
954c1994
GS		 5715/*
5716=for apidoc sv_2mortal
5717
5718Marks an SV as mortal. The SV will be destroyed when the current context
5719ends.
5720
5721=cut
5722*/
5723
79072805
LW		 5724/* same thing without the copying */
5725
5726SV *
864dbfa3 5727Perl_sv_2mortal(pTHX_ register SV *sv)
79072805
LW		 5728{
5729 if (!sv)
5730 return sv;
d689ffdd 5731 if (SvREADONLY(sv) && SvIMMORTAL(sv))
11162842 5732 return sv;
677b06e3
GS		 5733 EXTEND_MORTAL(1);
5734 PL_tmps_stack[++PL_tmps_ix] = sv;
8990e307 5735 SvTEMP_on(sv);
79072805
LW		 5736 return sv;
5737}
5738
954c1994
GS		 5739/*
5740=for apidoc newSVpv
5741
5742Creates a new SV and copies a string into it. The reference count for the
5743SV is set to 1. If C<len> is zero, Perl will compute the length using
5744strlen(). For efficiency, consider using C<newSVpvn> instead.
5745
5746=cut
5747*/
5748
79072805 5749SV *
864dbfa3 5750Perl_newSVpv(pTHX_ const char *s, STRLEN len)
79072805 5751{
463ee0b2 5752 register SV *sv;
79072805 5753
4561caa4 5754 new_SV(sv);
79072805
LW		 5755 if (!len)
5756 len = strlen(s);
5757 sv_setpvn(sv,s,len);
5758 return sv;
5759}
5760
954c1994
GS		 5761/*
5762=for apidoc newSVpvn
5763
5764Creates a new SV and copies a string into it. The reference count for the
1c846c1f 5765SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
954c1994
GS		 5766string. You are responsible for ensuring that the source string is at least
5767C<len> bytes long.
5768
5769=cut
5770*/
5771
9da1e3b5 5772SV *
864dbfa3 5773Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
9da1e3b5
MUN		 5774{
5775 register SV *sv;
5776
5777 new_SV(sv);
9da1e3b5
MUN		 5778 sv_setpvn(sv,s,len);
5779 return sv;
5780}
5781
1c846c1f
NIS		 5782/*
5783=for apidoc newSVpvn_share
5784
5785Creates a new SV and populates it with a string from
5786the string table. Turns on READONLY and FAKE.
5787The idea here is that as string table is used for shared hash
5788keys these strings will have SvPVX == HeKEY and hash lookup
5789will avoid string compare.
5790
5791=cut
5792*/
5793
5794SV *
c3654f1a 5795Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
1c846c1f
NIS		 5796{
5797 register SV *sv;
c3654f1a
IH		 5798 bool is_utf8 = FALSE;
5799 if (len < 0) {
5800 len = -len;
5801 is_utf8 = TRUE;
5802 }
75a54232
JH		 5803 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5804 STRLEN tmplen = len;
5805 /* See the note in hv.c:hv_fetch() --jhi */
5806 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5807 len = tmplen;
5808 }
1c846c1f
NIS		 5809 if (!hash)
5810 PERL_HASH(hash, src, len);
5811 new_SV(sv);
5812 sv_upgrade(sv, SVt_PVIV);
c3654f1a 5813 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
1c846c1f
NIS		 5814 SvCUR(sv) = len;
5815 SvUVX(sv) = hash;
5816 SvLEN(sv) = 0;
5817 SvREADONLY_on(sv);
5818 SvFAKE_on(sv);
5819 SvPOK_on(sv);
c3654f1a
IH		 5820 if (is_utf8)
5821 SvUTF8_on(sv);
1c846c1f
NIS		 5822 return sv;
5823}
5824
cea2e8a9 5825#if defined(PERL_IMPLICIT_CONTEXT)
46fc3d4c 5826SV *
cea2e8a9 5827Perl_newSVpvf_nocontext(const char* pat, ...)
46fc3d4c 5828{
cea2e8a9 5829 dTHX;
46fc3d4c 5830 register SV *sv;
5831 va_list args;
46fc3d4c 5832 va_start(args, pat);
c5be433b 5833 sv = vnewSVpvf(pat, &args);
46fc3d4c 5834 va_end(args);
5835 return sv;
5836}
cea2e8a9 5837#endif
46fc3d4c 5838
954c1994
GS		 5839/*
5840=for apidoc newSVpvf
5841
5842Creates a new SV an initialize it with the string formatted like
5843C<sprintf>.
5844
5845=cut
5846*/
5847
cea2e8a9
GS		 5848SV *
5849Perl_newSVpvf(pTHX_ const char* pat, ...)
5850{
5851 register SV *sv;
5852 va_list args;
cea2e8a9 5853 va_start(args, pat);
c5be433b 5854 sv = vnewSVpvf(pat, &args);
cea2e8a9
GS		 5855 va_end(args);
5856 return sv;
5857}
46fc3d4c 5858
79072805 5859SV *
c5be433b
GS		 5860Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5861{
5862 register SV *sv;
5863 new_SV(sv);
5864 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5865 return sv;
5866}
5867
954c1994
GS		 5868/*
5869=for apidoc newSVnv
5870
5871Creates a new SV and copies a floating point value into it.
5872The reference count for the SV is set to 1.
5873
5874=cut
5875*/
5876
c5be433b 5877SV *
65202027 5878Perl_newSVnv(pTHX_ NV n)
79072805 5879{
463ee0b2 5880 register SV *sv;
79072805 5881
4561caa4 5882 new_SV(sv);
79072805
LW		 5883 sv_setnv(sv,n);
5884 return sv;
5885}
5886
954c1994
GS		 5887/*
5888=for apidoc newSViv
5889
5890Creates a new SV and copies an integer into it. The reference count for the
5891SV is set to 1.
5892
5893=cut
5894*/
5895
79072805 5896SV *
864dbfa3 5897Perl_newSViv(pTHX_ IV i)
79072805 5898{
463ee0b2 5899 register SV *sv;
79072805 5900
4561caa4 5901 new_SV(sv);
79072805
LW		 5902 sv_setiv(sv,i);
5903 return sv;
5904}
5905
954c1994 5906/*
1a3327fb
JH		 5907=for apidoc newSVuv
5908
5909Creates a new SV and copies an unsigned integer into it.
5910The reference count for the SV is set to 1.
5911
5912=cut
5913*/
5914
5915SV *
5916Perl_newSVuv(pTHX_ UV u)
5917{
5918 register SV *sv;
5919
5920 new_SV(sv);
5921 sv_setuv(sv,u);
5922 return sv;
5923}
5924
5925/*
954c1994
GS		 5926=for apidoc newRV_noinc
5927
5928Creates an RV wrapper for an SV. The reference count for the original
5929SV is B<not> incremented.
5930
5931=cut
5932*/
5933
2304df62 5934SV *
864dbfa3 5935Perl_newRV_noinc(pTHX_ SV *tmpRef)
2304df62
AD		 5936{
5937 register SV *sv;
5938
4561caa4 5939 new_SV(sv);
2304df62 5940 sv_upgrade(sv, SVt_RV);
76e3520e 5941 SvTEMP_off(tmpRef);
d689ffdd 5942 SvRV(sv) = tmpRef;
2304df62 5943 SvROK_on(sv);
2304df62
AD		 5944 return sv;
5945}
5946
954c1994 5947/* newRV_inc is #defined to newRV in sv.h */
5f05dabc 5948SV *
864dbfa3 5949Perl_newRV(pTHX_ SV *tmpRef)
5f05dabc 5950{
5f6447b6 5951 return newRV_noinc(SvREFCNT_inc(tmpRef));
5f05dabc 5952}
5f05dabc 5953
954c1994
GS		 5954/*
5955=for apidoc newSVsv
5956
5957Creates a new SV which is an exact duplicate of the original SV.
5958
5959=cut
5960*/
5961
79072805
LW		 5962/* make an exact duplicate of old */
5963
5964SV *
864dbfa3 5965Perl_newSVsv(pTHX_ register SV *old)
79072805 5966{
463ee0b2 5967 register SV *sv;
79072805
LW		 5968
5969 if (!old)
5970 return Nullsv;
8990e307 5971 if (SvTYPE(old) == SVTYPEMASK) {
0453d815
PM		 5972 if (ckWARN_d(WARN_INTERNAL))
5973 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
79072805
LW		 5974 return Nullsv;
5975 }
4561caa4 5976 new_SV(sv);
ff68c719 5977 if (SvTEMP(old)) {
5978 SvTEMP_off(old);
463ee0b2 5979 sv_setsv(sv,old);
ff68c719 5980 SvTEMP_on(old);
79072805
LW		 5981 }
5982 else
463ee0b2
LW		 5983 sv_setsv(sv,old);
5984 return sv;
79072805
LW		 5985}
5986
5987void
864dbfa3 5988Perl_sv_reset(pTHX_ register char *s, HV *stash)
79072805
LW		 5989{
5990 register HE *entry;
5991 register GV *gv;
5992 register SV *sv;
5993 register I32 i;
5994 register PMOP *pm;
5995 register I32 max;
4802d5d7 5996 char todo[PERL_UCHAR_MAX+1];
79072805 5997
49d8d3a1
MB		 5998 if (!stash)
5999 return;
6000
79072805
LW		 6001 if (!*s) { /* reset ?? searches */
6002 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
48c036b1 6003 pm->op_pmdynflags &= ~PMdf_USED;
79072805
LW		 6004 }
6005 return;
6006 }
6007
6008 /* reset variables */
6009
6010 if (!HvARRAY(stash))
6011 return;
463ee0b2
LW		 6012
6013 Zero(todo, 256, char);
79072805 6014 while (*s) {
4802d5d7 6015 i = (unsigned char)*s;
79072805
LW		 6016 if (s[1] == '-') {
6017 s += 2;
6018 }
4802d5d7 6019 max = (unsigned char)*s++;
79072805 6020 for ( ; i <= max; i++) {
463ee0b2
LW		 6021 todo[i] = 1;
6022 }
a0d0e21e 6023 for (i = 0; i <= (I32) HvMAX(stash); i++) {
79072805 6024 for (entry = HvARRAY(stash)[i];
9e35f4b3
GS		 6025 entry;
6026 entry = HeNEXT(entry))
6027 {
1edc1566 6028 if (!todo[(U8)*HeKEY(entry)])
463ee0b2 6029 continue;
1edc1566 6030 gv = (GV*)HeVAL(entry);
79072805 6031 sv = GvSV(gv);
9e35f4b3
GS		 6032 if (SvTHINKFIRST(sv)) {
6033 if (!SvREADONLY(sv) && SvROK(sv))
6034 sv_unref(sv);
6035 continue;
6036 }
a0d0e21e 6037 (void)SvOK_off(sv);
79072805
LW		 6038 if (SvTYPE(sv) >= SVt_PV) {
6039 SvCUR_set(sv, 0);
463ee0b2
LW		 6040 if (SvPVX(sv) != Nullch)
6041 *SvPVX(sv) = '\0';
44a8e56a 6042 SvTAINT(sv);
79072805
LW		 6043 }
6044 if (GvAV(gv)) {
6045 av_clear(GvAV(gv));
6046 }
44a8e56a 6047 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
463ee0b2 6048 hv_clear(GvHV(gv));
fa6a1c44 6049#ifdef USE_ENVIRON_ARRAY
3280af22 6050 if (gv == PL_envgv)
79072805 6051 environ[0] = Nullch;
a0d0e21e 6052#endif
79072805
LW		 6053 }
6054 }
6055 }
6056 }
6057}
6058
46fc3d4c 6059IO*
864dbfa3 6060Perl_sv_2io(pTHX_ SV *sv)
46fc3d4c 6061{
6062 IO* io;
6063 GV* gv;
2d8e6c8d 6064 STRLEN n_a;
46fc3d4c 6065
6066 switch (SvTYPE(sv)) {
6067 case SVt_PVIO:
6068 io = (IO*)sv;
6069 break;
6070 case SVt_PVGV:
6071 gv = (GV*)sv;
6072 io = GvIO(gv);
6073 if (!io)
cea2e8a9 6074 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
46fc3d4c 6075 break;
6076 default:
6077 if (!SvOK(sv))
cea2e8a9 6078 Perl_croak(aTHX_ PL_no_usym, "filehandle");
46fc3d4c 6079 if (SvROK(sv))
6080 return sv_2io(SvRV(sv));
2d8e6c8d 6081 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
46fc3d4c 6082 if (gv)
6083 io = GvIO(gv);
6084 else
6085 io = 0;
6086 if (!io)
cea2e8a9 6087 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
46fc3d4c 6088 break;
6089 }
6090 return io;
6091}
6092
79072805 6093CV *
864dbfa3 6094Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
79072805
LW		 6095{
6096 GV *gv;
6097 CV *cv;
2d8e6c8d 6098 STRLEN n_a;
79072805
LW		 6099
6100 if (!sv)
93a17b20 6101 return *gvp = Nullgv, Nullcv;
79072805 6102 switch (SvTYPE(sv)) {
79072805
LW		 6103 case SVt_PVCV:
6104 *st = CvSTASH(sv);
6105 *gvp = Nullgv;
6106 return (CV*)sv;
6107 case SVt_PVHV:
6108 case SVt_PVAV:
6109 *gvp = Nullgv;
6110 return Nullcv;
8990e307
LW		 6111 case SVt_PVGV:
6112 gv = (GV*)sv;
a0d0e21e 6113 *gvp = gv;
8990e307
LW		 6114 *st = GvESTASH(gv);
6115 goto fix_gv;
6116
79072805 6117 default:
a0d0e21e
LW		 6118 if (SvGMAGICAL(sv))
6119 mg_get(sv);
6120 if (SvROK(sv)) {
f5284f61
IZ		 6121 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6122 tryAMAGICunDEREF(to_cv);
6123
62f274bf
GS		 6124 sv = SvRV(sv);
6125 if (SvTYPE(sv) == SVt_PVCV) {
6126 cv = (CV*)sv;
6127 *gvp = Nullgv;
6128 *st = CvSTASH(cv);
6129 return cv;
6130 }
6131 else if(isGV(sv))
6132 gv = (GV*)sv;
6133 else
cea2e8a9 6134 Perl_croak(aTHX_ "Not a subroutine reference");
a0d0e21e 6135 }
62f274bf 6136 else if (isGV(sv))
79072805
LW		 6137 gv = (GV*)sv;
6138 else
2d8e6c8d 6139 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
79072805
LW		 6140 *gvp = gv;
6141 if (!gv)
6142 return Nullcv;
6143 *st = GvESTASH(gv);
8990e307 6144 fix_gv:
8ebc5c01 6145 if (lref && !GvCVu(gv)) {
4633a7c4 6146 SV *tmpsv;
748a9306 6147 ENTER;
4633a7c4 6148 tmpsv = NEWSV(704,0);
16660edb 6149 gv_efullname3(tmpsv, gv, Nullch);
f6ec51f7
GS		 6150 /* XXX this is probably not what they think they're getting.
6151 * It has the same effect as "sub name;", i.e. just a forward
6152 * declaration! */
774d564b 6153 newSUB(start_subparse(FALSE, 0),
4633a7c4
LW		 6154 newSVOP(OP_CONST, 0, tmpsv),
6155 Nullop,
8990e307 6156 Nullop);
748a9306 6157 LEAVE;
8ebc5c01 6158 if (!GvCVu(gv))
cea2e8a9 6159 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
8990e307 6160 }
8ebc5c01 6161 return GvCVu(gv);
79072805
LW		 6162 }
6163}
6164
c461cf8f
JH		 6165/*
6166=for apidoc sv_true
6167
6168Returns true if the SV has a true value by Perl's rules.
6169
6170=cut
6171*/
6172
79072805 6173I32
864dbfa3 6174Perl_sv_true(pTHX_ register SV *sv)
79072805 6175{
8990e307
LW		 6176 if (!sv)
6177 return 0;
79072805 6178 if (SvPOK(sv)) {
4e35701f
NIS		 6179 register XPV* tXpv;
6180 if ((tXpv = (XPV*)SvANY(sv)) &&
c2f1de04 6181 (tXpv->xpv_cur > 1 ||
4e35701f 6182 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
79072805
LW		 6183 return 1;
6184 else
6185 return 0;
6186 }
6187 else {
6188 if (SvIOK(sv))
463ee0b2 6189 return SvIVX(sv) != 0;
79072805
LW		 6190 else {
6191 if (SvNOK(sv))
463ee0b2 6192 return SvNVX(sv) != 0.0;
79072805 6193 else
463ee0b2 6194 return sv_2bool(sv);
79072805
LW		 6195 }
6196 }
6197}
79072805 6198
ff68c719 6199IV
864dbfa3 6200Perl_sv_iv(pTHX_ register SV *sv)
85e6fe83 6201{
25da4f38
IZ		 6202 if (SvIOK(sv)) {
6203 if (SvIsUV(sv))
6204 return (IV)SvUVX(sv);
ff68c719 6205 return SvIVX(sv);
25da4f38 6206 }
ff68c719 6207 return sv_2iv(sv);
85e6fe83 6208}
85e6fe83 6209
ff68c719 6210UV
864dbfa3 6211Perl_sv_uv(pTHX_ register SV *sv)
ff68c719 6212{
25da4f38
IZ		 6213 if (SvIOK(sv)) {
6214 if (SvIsUV(sv))
6215 return SvUVX(sv);
6216 return (UV)SvIVX(sv);
6217 }
ff68c719 6218 return sv_2uv(sv);
6219}
85e6fe83 6220
65202027 6221NV
864dbfa3 6222Perl_sv_nv(pTHX_ register SV *sv)
79072805 6223{
ff68c719 6224 if (SvNOK(sv))
6225 return SvNVX(sv);
6226 return sv_2nv(sv);
79072805 6227}
79072805 6228
79072805 6229char *
864dbfa3 6230Perl_sv_pv(pTHX_ SV *sv)
1fa8b10d
JD		 6231{
6232 STRLEN n_a;
6233
6234 if (SvPOK(sv))
6235 return SvPVX(sv);
6236
6237 return sv_2pv(sv, &n_a);
6238}
6239
6240char *
864dbfa3 6241Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
79072805 6242{
85e6fe83
LW		 6243 if (SvPOK(sv)) {
6244 *lp = SvCUR(sv);
a0d0e21e 6245 return SvPVX(sv);
85e6fe83 6246 }
463ee0b2 6247 return sv_2pv(sv, lp);
79072805 6248}
79072805 6249
c461cf8f
JH		 6250/*
6251=for apidoc sv_pvn_force
6252
6253Get a sensible string out of the SV somehow.
6254
6255=cut
6256*/
6257
a0d0e21e 6258char *
864dbfa3 6259Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
a0d0e21e 6260{
36f65ada 6261 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
8d6d96c1
HS		 6262}
6263
6264/*
6265=for apidoc sv_pvn_force_flags
6266
6267Get a sensible string out of the SV somehow.
6268If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6269appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6270implemented in terms of this function.
6271
6272=cut
6273*/
6274
6275char *
6276Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6277{
a0d0e21e
LW		 6278 char *s;
6279
6fc92669
GS		 6280 if (SvTHINKFIRST(sv) && !SvROK(sv))
6281 sv_force_normal(sv);
1c846c1f 6282
a0d0e21e
LW		 6283 if (SvPOK(sv)) {
6284 *lp = SvCUR(sv);
6285 }
6286 else {
748a9306 6287 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
cea2e8a9 6288 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6fc92669 6289 PL_op_name[PL_op->op_type]);
a0d0e21e 6290 }
4633a7c4 6291 else
8d6d96c1 6292 s = sv_2pv_flags(sv, lp, flags);
a0d0e21e
LW		 6293 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6294 STRLEN len = *lp;
1c846c1f 6295
a0d0e21e
LW		 6296 if (SvROK(sv))
6297 sv_unref(sv);
6298 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6299 SvGROW(sv, len + 1);
6300 Move(s,SvPVX(sv),len,char);
6301 SvCUR_set(sv, len);
6302 *SvEND(sv) = '\0';
6303 }
6304 if (!SvPOK(sv)) {
6305 SvPOK_on(sv); /* validate pointer */
6306 SvTAINT(sv);
1d7c1841
GS		 6307 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6308 PTR2UV(sv),SvPVX(sv)));
a0d0e21e
LW		 6309 }
6310 }
6311 return SvPVX(sv);
6312}
6313
6314char *
7340a771
GS		 6315Perl_sv_pvbyte(pTHX_ SV *sv)
6316{
ffebcc3e 6317 sv_utf8_downgrade(sv,0);
7340a771
GS		 6318 return sv_pv(sv);
6319}
6320
6321char *
6322Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6323{
ffebcc3e 6324 sv_utf8_downgrade(sv,0);
7340a771
GS		 6325 return sv_pvn(sv,lp);
6326}
6327
6328char *
6329Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6330{
ffebcc3e 6331 sv_utf8_downgrade(sv,0);
7340a771
GS		 6332 return sv_pvn_force(sv,lp);
6333}
6334
6335char *
6336Perl_sv_pvutf8(pTHX_ SV *sv)
6337{
560a288e 6338 sv_utf8_upgrade(sv);
7340a771
GS		 6339 return sv_pv(sv);
6340}
6341
6342char *
6343Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6344{
560a288e 6345 sv_utf8_upgrade(sv);
7340a771
GS		 6346 return sv_pvn(sv,lp);
6347}
6348
c461cf8f
JH		 6349/*
6350=for apidoc sv_pvutf8n_force
6351
6352Get a sensible UTF8-encoded string out of the SV somehow. See
6353L</sv_pvn_force>.
6354
6355=cut
6356*/
6357
7340a771
GS		 6358char *
6359Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6360{
560a288e 6361 sv_utf8_upgrade(sv);
7340a771
GS		 6362 return sv_pvn_force(sv,lp);
6363}
6364
c461cf8f
JH		 6365/*
6366=for apidoc sv_reftype
6367
6368Returns a string describing what the SV is a reference to.
6369
6370=cut
6371*/
6372
7340a771 6373char *
864dbfa3 6374Perl_sv_reftype(pTHX_ SV *sv, int ob)
a0d0e21e
LW		 6375{
6376 if (ob && SvOBJECT(sv))
6377 return HvNAME(SvSTASH(sv));
6378 else {
6379 switch (SvTYPE(sv)) {
6380 case SVt_NULL:
6381 case SVt_IV:
6382 case SVt_NV:
6383 case SVt_RV:
6384 case SVt_PV:
6385 case SVt_PVIV:
6386 case SVt_PVNV:
6387 case SVt_PVMG:
6388 case SVt_PVBM:
6389 if (SvROK(sv))
6390 return "REF";
6391 else
6392 return "SCALAR";
6393 case SVt_PVLV: return "LVALUE";
6394 case SVt_PVAV: return "ARRAY";
6395 case SVt_PVHV: return "HASH";
6396 case SVt_PVCV: return "CODE";
6397 case SVt_PVGV: return "GLOB";
1d2dff63 6398 case SVt_PVFM: return "FORMAT";
27f9d8f3 6399 case SVt_PVIO: return "IO";
a0d0e21e
LW		 6400 default: return "UNKNOWN";
6401 }
6402 }
6403}
6404
954c1994
GS		 6405/*
6406=for apidoc sv_isobject
6407
6408Returns a boolean indicating whether the SV is an RV pointing to a blessed
6409object. If the SV is not an RV, or if the object is not blessed, then this
6410will return false.
6411
6412=cut
6413*/
6414
463ee0b2 6415int
864dbfa3 6416Perl_sv_isobject(pTHX_ SV *sv)
85e6fe83 6417{
68dc0745 6418 if (!sv)
6419 return 0;
6420 if (SvGMAGICAL(sv))
6421 mg_get(sv);
85e6fe83
LW		 6422 if (!SvROK(sv))
6423 return 0;
6424 sv = (SV*)SvRV(sv);
6425 if (!SvOBJECT(sv))
6426 return 0;
6427 return 1;
6428}
6429
954c1994
GS		 6430/*
6431=for apidoc sv_isa
6432
6433Returns a boolean indicating whether the SV is blessed into the specified
6434class. This does not check for subtypes; use C<sv_derived_from> to verify
6435an inheritance relationship.
6436
6437=cut
6438*/
6439
85e6fe83 6440int
864dbfa3 6441Perl_sv_isa(pTHX_ SV *sv, const char *name)
463ee0b2 6442{
68dc0745 6443 if (!sv)
6444 return 0;
6445 if (SvGMAGICAL(sv))
6446 mg_get(sv);
ed6116ce 6447 if (!SvROK(sv))
463ee0b2 6448 return 0;
ed6116ce
LW		 6449 sv = (SV*)SvRV(sv);
6450 if (!SvOBJECT(sv))
463ee0b2
LW		 6451 return 0;
6452
6453 return strEQ(HvNAME(SvSTASH(sv)), name);
6454}
6455
954c1994
GS		 6456/*
6457=for apidoc newSVrv
6458
6459Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6460it will be upgraded to one. If C<classname> is non-null then the new SV will
6461be blessed in the specified package. The new SV is returned and its
6462reference count is 1.
6463
6464=cut
6465*/
6466
463ee0b2 6467SV*
864dbfa3 6468Perl_newSVrv(pTHX_ SV *rv, const char *classname)
463ee0b2 6469{
463ee0b2
LW		 6470 SV *sv;
6471
4561caa4 6472 new_SV(sv);
51cf62d8 6473
2213622d 6474 SV_CHECK_THINKFIRST(rv);
51cf62d8 6475 SvAMAGIC_off(rv);
51cf62d8 6476
0199fce9
JD		 6477 if (SvTYPE(rv) >= SVt_PVMG) {
6478 U32 refcnt = SvREFCNT(rv);
6479 SvREFCNT(rv) = 0;
6480 sv_clear(rv);
6481 SvFLAGS(rv) = 0;
6482 SvREFCNT(rv) = refcnt;
6483 }
6484
51cf62d8 6485 if (SvTYPE(rv) < SVt_RV)
0199fce9
JD		 6486 sv_upgrade(rv, SVt_RV);
6487 else if (SvTYPE(rv) > SVt_RV) {
6488 (void)SvOOK_off(rv);
6489 if (SvPVX(rv) && SvLEN(rv))
6490 Safefree(SvPVX(rv));
6491 SvCUR_set(rv, 0);
6492 SvLEN_set(rv, 0);
6493 }
51cf62d8
OT		 6494
6495 (void)SvOK_off(rv);
053fc874 6496 SvRV(rv) = sv;
ed6116ce 6497 SvROK_on(rv);
463ee0b2 6498
a0d0e21e
LW		 6499 if (classname) {
6500 HV* stash = gv_stashpv(classname, TRUE);
6501 (void)sv_bless(rv, stash);
6502 }
6503 return sv;
6504}
6505
954c1994
GS		 6506/*
6507=for apidoc sv_setref_pv
6508
6509Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6510argument will be upgraded to an RV. That RV will be modified to point to
6511the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6512into the SV. The C<classname> argument indicates the package for the
6513blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6514will be returned and will have a reference count of 1.
6515
6516Do not use with other Perl types such as HV, AV, SV, CV, because those
6517objects will become corrupted by the pointer copy process.
6518
6519Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6520
6521=cut
6522*/
6523
a0d0e21e 6524SV*
864dbfa3 6525Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
a0d0e21e 6526{
189b2af5 6527 if (!pv) {
3280af22 6528 sv_setsv(rv, &PL_sv_undef);
189b2af5
GS		 6529 SvSETMAGIC(rv);
6530 }
a0d0e21e 6531 else
56431972 6532 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
a0d0e21e
LW		 6533 return rv;
6534}
6535
954c1994
GS		 6536/*
6537=for apidoc sv_setref_iv
6538
6539Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6540argument will be upgraded to an RV. That RV will be modified to point to
6541the new SV. The C<classname> argument indicates the package for the
6542blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6543will be returned and will have a reference count of 1.
6544
6545=cut
6546*/
6547
a0d0e21e 6548SV*
864dbfa3 6549Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
a0d0e21e
LW		 6550{
6551 sv_setiv(newSVrv(rv,classname), iv);
6552 return rv;
6553}
6554
954c1994 6555/*
e1c57cef
JH		 6556=for apidoc sv_setref_uv
6557
6558Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6559argument will be upgraded to an RV. That RV will be modified to point to
6560the new SV. The C<classname> argument indicates the package for the
6561blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6562will be returned and will have a reference count of 1.
6563
6564=cut
6565*/
6566
6567SV*
6568Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6569{
6570 sv_setuv(newSVrv(rv,classname), uv);
6571 return rv;
6572}
6573
6574/*
954c1994
GS		 6575=for apidoc sv_setref_nv
6576
6577Copies a double into a new SV, optionally blessing the SV. The C<rv>
6578argument will be upgraded to an RV. That RV will be modified to point to
6579the new SV. The C<classname> argument indicates the package for the
6580blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6581will be returned and will have a reference count of 1.
6582
6583=cut
6584*/
6585
a0d0e21e 6586SV*
65202027 6587Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
a0d0e21e
LW		 6588{
6589 sv_setnv(newSVrv(rv,classname), nv);
6590 return rv;
6591}
463ee0b2 6592
954c1994
GS		 6593/*
6594=for apidoc sv_setref_pvn
6595
6596Copies a string into a new SV, optionally blessing the SV. The length of the
6597string must be specified with C<n>. The C<rv> argument will be upgraded to
6598an RV. That RV will be modified to point to the new SV. The C<classname>
6599argument indicates the package for the blessing. Set C<classname> to
6600C<Nullch> to avoid the blessing. The new SV will be returned and will have
6601a reference count of 1.
6602
6603Note that C<sv_setref_pv> copies the pointer while this copies the string.
6604
6605=cut
6606*/
6607
a0d0e21e 6608SV*
864dbfa3 6609Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
a0d0e21e
LW		 6610{
6611 sv_setpvn(newSVrv(rv,classname), pv, n);
463ee0b2
LW		 6612 return rv;
6613}
6614
954c1994
GS		 6615/*
6616=for apidoc sv_bless
6617
6618Blesses an SV into a specified package. The SV must be an RV. The package
6619must be designated by its stash (see C<gv_stashpv()>). The reference count
6620of the SV is unaffected.
6621
6622=cut
6623*/
6624
a0d0e21e 6625SV*
864dbfa3 6626Perl_sv_bless(pTHX_ SV *sv, HV *stash)
a0d0e21e 6627{
76e3520e 6628 SV *tmpRef;
a0d0e21e 6629 if (!SvROK(sv))
cea2e8a9 6630 Perl_croak(aTHX_ "Can't bless non-reference value");
76e3520e
GS		 6631 tmpRef = SvRV(sv);
6632 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6633 if (SvREADONLY(tmpRef))
cea2e8a9 6634 Perl_croak(aTHX_ PL_no_modify);
76e3520e
GS		 6635 if (SvOBJECT(tmpRef)) {
6636 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 6637 --PL_sv_objcount;
76e3520e 6638 SvREFCNT_dec(SvSTASH(tmpRef));
2e3febc6 6639 }
a0d0e21e 6640 }
76e3520e
GS		 6641 SvOBJECT_on(tmpRef);
6642 if (SvTYPE(tmpRef) != SVt_PVIO)
3280af22 6643 ++PL_sv_objcount;
76e3520e
GS		 6644 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6645 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
a0d0e21e 6646
2e3febc6
CS		 6647 if (Gv_AMG(stash))
6648 SvAMAGIC_on(sv);
6649 else
6650 SvAMAGIC_off(sv);
a0d0e21e
LW		 6651
6652 return sv;
6653}
6654
76e3520e 6655STATIC void
cea2e8a9 6656S_sv_unglob(pTHX_ SV *sv)
a0d0e21e 6657{
850fabdf
GS		 6658 void *xpvmg;
6659
a0d0e21e
LW		 6660 assert(SvTYPE(sv) == SVt_PVGV);
6661 SvFAKE_off(sv);
6662 if (GvGP(sv))
1edc1566 6663 gp_free((GV*)sv);
e826b3c7
GS		 6664 if (GvSTASH(sv)) {
6665 SvREFCNT_dec(GvSTASH(sv));
6666 GvSTASH(sv) = Nullhv;
6667 }
14befaf4 6668 sv_unmagic(sv, PERL_MAGIC_glob);
a0d0e21e 6669 Safefree(GvNAME(sv));
a5f75d66 6670 GvMULTI_off(sv);
850fabdf
GS		 6671
6672 /* need to keep SvANY(sv) in the right arena */
6673 xpvmg = new_XPVMG();
6674 StructCopy(SvANY(sv), xpvmg, XPVMG);
6675 del_XPVGV(SvANY(sv));
6676 SvANY(sv) = xpvmg;
6677
a0d0e21e
LW		 6678 SvFLAGS(sv) &= ~SVTYPEMASK;
6679 SvFLAGS(sv) |= SVt_PVMG;
6680}
6681
954c1994 6682/*
840a7b70 6683=for apidoc sv_unref_flags
954c1994
GS		 6684
6685Unsets the RV status of the SV, and decrements the reference count of
6686whatever was being referenced by the RV. This can almost be thought of
840a7b70
IZ		 6687as a reversal of C<newSVrv>. The C<cflags> argument can contain
6688C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6689(otherwise the decrementing is conditional on the reference count being
6690different from one or the reference being a readonly SV).
7889fe52 6691See C<SvROK_off>.
954c1994
GS		 6692
6693=cut
6694*/
6695
ed6116ce 6696void
840a7b70 6697Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
ed6116ce 6698{
a0d0e21e 6699 SV* rv = SvRV(sv);
810b8aa5
GS		 6700
6701 if (SvWEAKREF(sv)) {
6702 sv_del_backref(sv);
6703 SvWEAKREF_off(sv);
6704 SvRV(sv) = 0;
6705 return;
6706 }
ed6116ce
LW		 6707 SvRV(sv) = 0;
6708 SvROK_off(sv);
840a7b70 6709 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
4633a7c4 6710 SvREFCNT_dec(rv);
840a7b70 6711 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
4633a7c4 6712 sv_2mortal(rv); /* Schedule for freeing later */
ed6116ce 6713}
8990e307 6714
840a7b70
IZ		 6715/*
6716=for apidoc sv_unref
6717
6718Unsets the RV status of the SV, and decrements the reference count of
6719whatever was being referenced by the RV. This can almost be thought of
6720as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7889fe52 6721being zero. See C<SvROK_off>.
840a7b70
IZ		 6722
6723=cut
6724*/
6725
6726void
6727Perl_sv_unref(pTHX_ SV *sv)
6728{
6729 sv_unref_flags(sv, 0);
6730}
6731
bbce6d69 6732void
864dbfa3 6733Perl_sv_taint(pTHX_ SV *sv)
bbce6d69 6734{
14befaf4 6735 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
bbce6d69 6736}
6737
6738void
864dbfa3 6739Perl_sv_untaint(pTHX_ SV *sv)
bbce6d69 6740{
13f57bf8 6741 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14befaf4 6742 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
36477c24 6743 if (mg)
565764a8 6744 mg->mg_len &= ~1;
36477c24 6745 }
bbce6d69 6746}
6747
6748bool
864dbfa3 6749Perl_sv_tainted(pTHX_ SV *sv)
bbce6d69 6750{
13f57bf8 6751 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
14befaf4 6752 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
155aba94 6753 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
36477c24 6754 return TRUE;
6755 }
6756 return FALSE;
bbce6d69 6757}
6758
954c1994
GS		 6759/*
6760=for apidoc sv_setpviv
6761
6762Copies an integer into the given SV, also updating its string value.
6763Does not handle 'set' magic. See C<sv_setpviv_mg>.
6764
6765=cut
6766*/
6767
84902520 6768void
864dbfa3 6769Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
84902520 6770{
25da4f38
IZ		 6771 char buf[TYPE_CHARS(UV)];
6772 char *ebuf;
6773 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
84902520 6774
25da4f38 6775 sv_setpvn(sv, ptr, ebuf - ptr);
84902520
TB		 6776}
6777
ef50df4b 6778
954c1994
GS		 6779/*
6780=for apidoc sv_setpviv_mg
6781
6782Like C<sv_setpviv>, but also handles 'set' magic.
6783
6784=cut
6785*/
6786
ef50df4b 6787void
864dbfa3 6788Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
ef50df4b 6789{
25da4f38
IZ		 6790 char buf[TYPE_CHARS(UV)];
6791 char *ebuf;
6792 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6793
6794 sv_setpvn(sv, ptr, ebuf - ptr);
ef50df4b
GS		 6795 SvSETMAGIC(sv);
6796}
6797
cea2e8a9
GS		 6798#if defined(PERL_IMPLICIT_CONTEXT)
6799void
6800Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6801{
6802 dTHX;
6803 va_list args;
6804 va_start(args, pat);
c5be433b 6805 sv_vsetpvf(sv, pat, &args);
cea2e8a9
GS		 6806 va_end(args);
6807}
6808
6809
6810void
6811Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6812{
6813 dTHX;
6814 va_list args;
6815 va_start(args, pat);
c5be433b 6816 sv_vsetpvf_mg(sv, pat, &args);
cea2e8a9 6817 va_end(args);
cea2e8a9
GS		 6818}
6819#endif
6820
954c1994
GS		 6821/*
6822=for apidoc sv_setpvf
6823
6824Processes its arguments like C<sprintf> and sets an SV to the formatted
6825output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6826
6827=cut
6828*/
6829
46fc3d4c 6830void
864dbfa3 6831Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 6832{
6833 va_list args;
46fc3d4c 6834 va_start(args, pat);
c5be433b 6835 sv_vsetpvf(sv, pat, &args);
46fc3d4c 6836 va_end(args);
6837}
6838
c5be433b
GS		 6839void
6840Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6841{
6842 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6843}
ef50df4b 6844
954c1994
GS		 6845/*
6846=for apidoc sv_setpvf_mg
6847
6848Like C<sv_setpvf>, but also handles 'set' magic.
6849
6850=cut
6851*/
6852
ef50df4b 6853void
864dbfa3 6854Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 6855{
6856 va_list args;
ef50df4b 6857 va_start(args, pat);
c5be433b 6858 sv_vsetpvf_mg(sv, pat, &args);
ef50df4b 6859 va_end(args);
c5be433b
GS		 6860}
6861
6862void
6863Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6864{
6865 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 6866 SvSETMAGIC(sv);
6867}
6868
cea2e8a9
GS		 6869#if defined(PERL_IMPLICIT_CONTEXT)
6870void
6871Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6872{
6873 dTHX;
6874 va_list args;
6875 va_start(args, pat);
c5be433b 6876 sv_vcatpvf(sv, pat, &args);
cea2e8a9
GS		 6877 va_end(args);
6878}
6879
6880void
6881Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6882{
6883 dTHX;
6884 va_list args;
6885 va_start(args, pat);
c5be433b 6886 sv_vcatpvf_mg(sv, pat, &args);
cea2e8a9 6887 va_end(args);
cea2e8a9
GS		 6888}
6889#endif
6890
954c1994
GS		 6891/*
6892=for apidoc sv_catpvf
6893
d5ce4a7c
GA		 6894Processes its arguments like C<sprintf> and appends the formatted
6895output to an SV. If the appended data contains "wide" characters
6896(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6897and characters >255 formatted with %c), the original SV might get
6898upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6899C<SvSETMAGIC()> must typically be called after calling this function
6900to handle 'set' magic.
954c1994 6901
d5ce4a7c 6902=cut */
954c1994 6903
46fc3d4c 6904void
864dbfa3 6905Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
46fc3d4c 6906{
6907 va_list args;
46fc3d4c 6908 va_start(args, pat);
c5be433b 6909 sv_vcatpvf(sv, pat, &args);
46fc3d4c 6910 va_end(args);
6911}
6912
ef50df4b 6913void
c5be433b
GS		 6914Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6915{
6916 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6917}
6918
954c1994
GS		 6919/*
6920=for apidoc sv_catpvf_mg
6921
6922Like C<sv_catpvf>, but also handles 'set' magic.
6923
6924=cut
6925*/
6926
c5be433b 6927void
864dbfa3 6928Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
ef50df4b
GS		 6929{
6930 va_list args;
ef50df4b 6931 va_start(args, pat);
c5be433b 6932 sv_vcatpvf_mg(sv, pat, &args);
ef50df4b 6933 va_end(args);
c5be433b
GS		 6934}
6935
6936void
6937Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6938{
6939 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
ef50df4b
GS		 6940 SvSETMAGIC(sv);
6941}
6942
954c1994
GS		 6943/*
6944=for apidoc sv_vsetpvfn
6945
6946Works like C<vcatpvfn> but copies the text into the SV instead of
6947appending it.
6948
6949=cut
6950*/
6951
46fc3d4c 6952void
7d5ea4e7 6953Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 6954{
6955 sv_setpvn(sv, "", 0);
7d5ea4e7 6956 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
46fc3d4c 6957}
6958
2d00ba3b 6959STATIC I32
9dd79c3f 6960S_expect_number(pTHX_ char** pattern)
211dfcf1
HS		 6961{
6962 I32 var = 0;
6963 switch (**pattern) {
6964 case '1': case '2': case '3':
6965 case '4': case '5': case '6':
6966 case '7': case '8': case '9':
6967 while (isDIGIT(**pattern))
6968 var = var * 10 + (*(*pattern)++ - '0');
6969 }
6970 return var;
6971}
9dd79c3f 6972#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
211dfcf1 6973
954c1994
GS		 6974/*
6975=for apidoc sv_vcatpvfn
6976
6977Processes its arguments like C<vsprintf> and appends the formatted output
6978to an SV. Uses an array of SVs if the C style variable argument list is
6979missing (NULL). When running with taint checks enabled, indicates via
6980C<maybe_tainted> if results are untrustworthy (often due to the use of
6981locales).
6982
6983=cut
6984*/
6985
46fc3d4c 6986void
7d5ea4e7 6987Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
46fc3d4c 6988{
6989 char *p;
6990 char *q;
6991 char *patend;
fc36a67e 6992 STRLEN origlen;
46fc3d4c 6993 I32 svix = 0;
c635e13b 6994 static char nullstr[] = "(null)";
9c5ffd7c 6995 SV *argsv = Nullsv;
46fc3d4c 6996
6997 /* no matter what, this is a string now */
fc36a67e 6998 (void)SvPV_force(sv, origlen);
46fc3d4c 6999
fc36a67e 7000 /* special-case "", "%s", and "%_" */
46fc3d4c 7001 if (patlen == 0)
7002 return;
fc36a67e 7003 if (patlen == 2 && pat[0] == '%') {
7004 switch (pat[1]) {
7005 case 's':
c635e13b 7006 if (args) {
7007 char *s = va_arg(*args, char*);
7008 sv_catpv(sv, s ? s : nullstr);
7009 }
7e2040f0 7010 else if (svix < svmax) {
fc36a67e 7011 sv_catsv(sv, *svargs);
7e2040f0
GS		 7012 if (DO_UTF8(*svargs))
7013 SvUTF8_on(sv);
7014 }
fc36a67e 7015 return;
7016 case '_':
7017 if (args) {
7e2040f0
GS		 7018 argsv = va_arg(*args, SV*);
7019 sv_catsv(sv, argsv);
7020 if (DO_UTF8(argsv))
7021 SvUTF8_on(sv);
fc36a67e 7022 return;
7023 }
7024 /* See comment on '_' below */
7025 break;
7026 }
46fc3d4c 7027 }
7028
7029 patend = (char*)pat + patlen;
7030 for (p = (char*)pat; p < patend; p = q) {
7031 bool alt = FALSE;
7032 bool left = FALSE;
b22c7a20 7033 bool vectorize = FALSE;
211dfcf1 7034 bool vectorarg = FALSE;
b2e23cf9 7035 bool vec_utf = FALSE;
46fc3d4c 7036 char fill = ' ';
7037 char plus = 0;
7038 char intsize = 0;
7039 STRLEN width = 0;
fc36a67e 7040 STRLEN zeros = 0;
46fc3d4c 7041 bool has_precis = FALSE;
7042 STRLEN precis = 0;
7e2040f0 7043 bool is_utf = FALSE;
eb3fce90 7044
46fc3d4c 7045 char esignbuf[4];
ad391ad9 7046 U8 utf8buf[UTF8_MAXLEN+1];
46fc3d4c 7047 STRLEN esignlen = 0;
7048
7049 char *eptr = Nullch;
fc36a67e 7050 STRLEN elen = 0;
089c015b
JH		 7051 /* Times 4: a decimal digit takes more than 3 binary digits.
7052 * NV_DIG: mantissa takes than many decimal digits.
7053 * Plus 32: Playing safe. */
7054 char ebuf[IV_DIG * 4 + NV_DIG + 32];
2d4389e4
JH		 7055 /* large enough for "%#.#f" --chip */
7056 /* what about long double NVs? --jhi */
b22c7a20
GS		 7057
7058 SV *vecsv;
a05b299f 7059 U8 *vecstr = Null(U8*);
b22c7a20 7060 STRLEN veclen = 0;
46fc3d4c 7061 char c;
7062 int i;
9c5ffd7c 7063 unsigned base = 0;
46fc3d4c 7064 IV iv;
7065 UV uv;
65202027 7066 NV nv;
46fc3d4c 7067 STRLEN have;
7068 STRLEN need;
7069 STRLEN gap;
b22c7a20
GS		 7070 char *dotstr = ".";
7071 STRLEN dotstrlen = 1;
211dfcf1 7072 I32 efix = 0; /* explicit format parameter index */
eb3fce90 7073 I32 ewix = 0; /* explicit width index */
211dfcf1
HS		 7074 I32 epix = 0; /* explicit precision index */
7075 I32 evix = 0; /* explicit vector index */
eb3fce90 7076 bool asterisk = FALSE;
46fc3d4c 7077
211dfcf1 7078 /* echo everything up to the next format specification */
46fc3d4c 7079 for (q = p; q < patend && *q != '%'; ++q) ;
7080 if (q > p) {
7081 sv_catpvn(sv, p, q - p);
7082 p = q;
7083 }
7084 if (q++ >= patend)
7085 break;
7086
211dfcf1
HS		 7087/*
7088 We allow format specification elements in this order:
7089 \d+\$ explicit format parameter index
7090 [-+ 0#]+ flags
7091 \*?(\d+\$)?v vector with optional (optionally specified) arg
7092 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7093 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7094 [hlqLV] size
7095 [%bcdefginopsux_DFOUX] format (mandatory)
7096*/
7097 if (EXPECT_NUMBER(q, width)) {
7098 if (*q == '$') {
7099 ++q;
7100 efix = width;
7101 } else {
7102 goto gotwidth;
7103 }
7104 }
7105
fc36a67e 7106 /* FLAGS */
7107
46fc3d4c 7108 while (*q) {
7109 switch (*q) {
7110 case ' ':
7111 case '+':
7112 plus = *q++;
7113 continue;
7114
7115 case '-':
7116 left = TRUE;
7117 q++;
7118 continue;
7119
7120 case '0':
7121 fill = *q++;
7122 continue;
7123
7124 case '#':
7125 alt = TRUE;
7126 q++;
7127 continue;
7128
fc36a67e 7129 default:
7130 break;
7131 }
7132 break;
7133 }
46fc3d4c 7134
211dfcf1 7135 tryasterisk:
eb3fce90 7136 if (*q == '*') {
211dfcf1
HS		 7137 q++;
7138 if (EXPECT_NUMBER(q, ewix))
7139 if (*q++ != '$')
7140 goto unknown;
eb3fce90 7141 asterisk = TRUE;
211dfcf1
HS		 7142 }
7143 if (*q == 'v') {
eb3fce90 7144 q++;
211dfcf1
HS		 7145 if (vectorize)
7146 goto unknown;
9cbac4c7 7147 if ((vectorarg = asterisk)) {
211dfcf1
HS		 7148 evix = ewix;
7149 ewix = 0;
7150 asterisk = FALSE;
7151 }
7152 vectorize = TRUE;
7153 goto tryasterisk;
eb3fce90
JH		 7154 }
7155
211dfcf1
HS		 7156 if (!asterisk)
7157 EXPECT_NUMBER(q, width);
7158
7159 if (vectorize) {
7160 if (vectorarg) {
7161 if (args)
7162 vecsv = va_arg(*args, SV*);
7163 else
7164 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7165 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
4459522c 7166 dotstr = SvPVx(vecsv, dotstrlen);
211dfcf1
HS		 7167 if (DO_UTF8(vecsv))
7168 is_utf = TRUE;
7169 }
7170 if (args) {
7171 vecsv = va_arg(*args, SV*);
7172 vecstr = (U8*)SvPVx(vecsv,veclen);
b2e23cf9 7173 vec_utf = DO_UTF8(vecsv);
eb3fce90 7174 }
211dfcf1
HS		 7175 else if (efix ? efix <= svmax : svix < svmax) {
7176 vecsv = svargs[efix ? efix-1 : svix++];
7177 vecstr = (U8*)SvPVx(vecsv,veclen);
b2e23cf9 7178 vec_utf = DO_UTF8(vecsv);
211dfcf1
HS		 7179 }
7180 else {
7181 vecstr = (U8*)"";
7182 veclen = 0;
7183 }
eb3fce90 7184 }
fc36a67e 7185
eb3fce90 7186 if (asterisk) {
fc36a67e 7187 if (args)
7188 i = va_arg(*args, int);
7189 else
eb3fce90
JH		 7190 i = (ewix ? ewix <= svmax : svix < svmax) ?
7191 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
fc36a67e 7192 left |= (i < 0);
7193 width = (i < 0) ? -i : i;
fc36a67e 7194 }
211dfcf1 7195 gotwidth:
fc36a67e 7196
7197 /* PRECISION */
46fc3d4c 7198
fc36a67e 7199 if (*q == '.') {
7200 q++;
7201 if (*q == '*') {
211dfcf1
HS		 7202 q++;
7203 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7204 goto unknown;
46fc3d4c 7205 if (args)
7206 i = va_arg(*args, int);
7207 else
eb3fce90
JH		 7208 i = (ewix ? ewix <= svmax : svix < svmax)
7209 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
fc36a67e 7210 precis = (i < 0) ? 0 : i;
fc36a67e 7211 }
7212 else {
7213 precis = 0;
7214 while (isDIGIT(*q))
7215 precis = precis * 10 + (*q++ - '0');
7216 }
7217 has_precis = TRUE;
7218 }
46fc3d4c 7219
fc36a67e 7220 /* SIZE */
46fc3d4c 7221
fc36a67e 7222 switch (*q) {
e5c81feb 7223#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6f9bb7fd 7224 case 'L': /* Ld */
e5c81feb
JH		 7225 /* FALL THROUGH */
7226#endif
7227#ifdef HAS_QUAD
6f9bb7fd
GS		 7228 case 'q': /* qd */
7229 intsize = 'q';
7230 q++;
7231 break;
7232#endif
fc36a67e 7233 case 'l':
e5c81feb
JH		 7234#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7235 if (*(q + 1) == 'l') { /* lld, llf */
fc36a67e 7236 intsize = 'q';
7237 q += 2;
46fc3d4c 7238 break;
cf2093f6 7239 }
fc36a67e 7240#endif
6f9bb7fd 7241 /* FALL THROUGH */
fc36a67e 7242 case 'h':
cf2093f6 7243 /* FALL THROUGH */
fc36a67e 7244 case 'V':
7245 intsize = *q++;
46fc3d4c 7246 break;
7247 }
7248
fc36a67e 7249 /* CONVERSION */
7250
211dfcf1
HS		 7251 if (*q == '%') {
7252 eptr = q++;
7253 elen = 1;
7254 goto string;
7255 }
7256
7257 if (!args)
7258 argsv = (efix ? efix <= svmax : svix < svmax) ?
7259 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7260
46fc3d4c 7261 switch (c = *q++) {
7262
7263 /* STRINGS */
7264
46fc3d4c 7265 case 'c':
211dfcf1 7266 uv = args ? va_arg(*args, int) : SvIVx(argsv);
1bd104fb
JH		 7267 if ((uv > 255 ||
7268 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
0064a8a9 7269 && !IN_BYTES) {
dfe13c55 7270 eptr = (char*)utf8buf;
9041c2e3 7271 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7e2040f0
GS		 7272 is_utf = TRUE;
7273 }
7274 else {
7275 c = (char)uv;
7276 eptr = &c;
7277 elen = 1;
a0ed51b3 7278 }
46fc3d4c 7279 goto string;
7280
46fc3d4c 7281 case 's':
7282 if (args) {
fc36a67e 7283 eptr = va_arg(*args, char*);
c635e13b 7284 if (eptr)
1d7c1841
GS		 7285#ifdef MACOS_TRADITIONAL
7286 /* On MacOS, %#s format is used for Pascal strings */
7287 if (alt)
7288 elen = *eptr++;
7289 else
7290#endif
c635e13b 7291 elen = strlen(eptr);
7292 else {
7293 eptr = nullstr;
7294 elen = sizeof nullstr - 1;
7295 }
46fc3d4c 7296 }
211dfcf1 7297 else {
7e2040f0
GS		 7298 eptr = SvPVx(argsv, elen);
7299 if (DO_UTF8(argsv)) {
a0ed51b3
LW		 7300 if (has_precis && precis < elen) {
7301 I32 p = precis;
7e2040f0 7302 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
a0ed51b3
LW		 7303 precis = p;
7304 }
7305 if (width) { /* fudge width (can't fudge elen) */
7e2040f0 7306 width += elen - sv_len_utf8(argsv);
a0ed51b3 7307 }
7e2040f0 7308 is_utf = TRUE;
a0ed51b3
LW		 7309 }
7310 }
46fc3d4c 7311 goto string;
7312
fc36a67e 7313 case '_':
7314 /*
7315 * The "%_" hack might have to be changed someday,
7316 * if ISO or ANSI decide to use '_' for something.
7317 * So we keep it hidden from users' code.
7318 */
7319 if (!args)
7320 goto unknown;
211dfcf1 7321 argsv = va_arg(*args, SV*);
7e2040f0
GS		 7322 eptr = SvPVx(argsv, elen);
7323 if (DO_UTF8(argsv))
7324 is_utf = TRUE;
fc36a67e 7325
46fc3d4c 7326 string:
b22c7a20 7327 vectorize = FALSE;
46fc3d4c 7328 if (has_precis && elen > precis)
7329 elen = precis;
7330 break;
7331
7332 /* INTEGERS */
7333
fc36a67e 7334 case 'p':
c2e66d9e
GS		 7335 if (alt)
7336 goto unknown;
211dfcf1 7337 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
fc36a67e 7338 base = 16;
7339 goto integer;
7340
46fc3d4c 7341 case 'D':
29fe7a80 7342#ifdef IV_IS_QUAD
22f3ae8c 7343 intsize = 'q';
29fe7a80 7344#else
46fc3d4c 7345 intsize = 'l';
29fe7a80 7346#endif
46fc3d4c 7347 /* FALL THROUGH */
7348 case 'd':
7349 case 'i':
b22c7a20 7350 if (vectorize) {
ba210ebe 7351 STRLEN ulen;
211dfcf1
HS		 7352 if (!veclen)
7353 continue;
b2e23cf9 7354 if (vec_utf)
9041c2e3 7355 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
b22c7a20 7356 else {
a05b299f 7357 iv = *vecstr;
b22c7a20
GS		 7358 ulen = 1;
7359 }
7360 vecstr += ulen;
7361 veclen -= ulen;
7362 }
7363 else if (args) {
46fc3d4c 7364 switch (intsize) {
7365 case 'h': iv = (short)va_arg(*args, int); break;
7366 default: iv = va_arg(*args, int); break;
7367 case 'l': iv = va_arg(*args, long); break;
fc36a67e 7368 case 'V': iv = va_arg(*args, IV); break;
cf2093f6
JH		 7369#ifdef HAS_QUAD
7370 case 'q': iv = va_arg(*args, Quad_t); break;
7371#endif
46fc3d4c 7372 }
7373 }
7374 else {
211dfcf1 7375 iv = SvIVx(argsv);
46fc3d4c 7376 switch (intsize) {
7377 case 'h': iv = (short)iv; break;
be28567c 7378 default: break;
46fc3d4c 7379 case 'l': iv = (long)iv; break;
fc36a67e 7380 case 'V': break;
cf2093f6
JH		 7381#ifdef HAS_QUAD
7382 case 'q': iv = (Quad_t)iv; break;
7383#endif
46fc3d4c 7384 }
7385 }
7386 if (iv >= 0) {
7387 uv = iv;
7388 if (plus)
7389 esignbuf[esignlen++] = plus;
7390 }
7391 else {
7392 uv = -iv;
7393 esignbuf[esignlen++] = '-';
7394 }
7395 base = 10;
7396 goto integer;
7397
fc36a67e 7398 case 'U':
29fe7a80 7399#ifdef IV_IS_QUAD
22f3ae8c 7400 intsize = 'q';
29fe7a80 7401#else
fc36a67e 7402 intsize = 'l';
29fe7a80 7403#endif
fc36a67e 7404 /* FALL THROUGH */
7405 case 'u':
7406 base = 10;
7407 goto uns_integer;
7408
4f19785b
WSI		 7409 case 'b':
7410 base = 2;
7411 goto uns_integer;
7412
46fc3d4c 7413 case 'O':
29fe7a80 7414#ifdef IV_IS_QUAD
22f3ae8c 7415 intsize = 'q';
29fe7a80 7416#else
46fc3d4c 7417 intsize = 'l';
29fe7a80 7418#endif
46fc3d4c 7419 /* FALL THROUGH */
7420 case 'o':
7421 base = 8;
7422 goto uns_integer;
7423
7424 case 'X':
46fc3d4c 7425 case 'x':
7426 base = 16;
46fc3d4c 7427
7428 uns_integer:
b22c7a20 7429 if (vectorize) {
ba210ebe 7430 STRLEN ulen;
b22c7a20 7431 vector:
211dfcf1
HS		 7432 if (!veclen)
7433 continue;
b2e23cf9 7434 if (vec_utf)
9041c2e3 7435 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
b22c7a20 7436 else {
a05b299f 7437 uv = *vecstr;
b22c7a20
GS		 7438 ulen = 1;
7439 }
7440 vecstr += ulen;
7441 veclen -= ulen;
7442 }
7443 else if (args) {
46fc3d4c 7444 switch (intsize) {
7445 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7446 default: uv = va_arg(*args, unsigned); break;
7447 case 'l': uv = va_arg(*args, unsigned long); break;
fc36a67e 7448 case 'V': uv = va_arg(*args, UV); break;
cf2093f6
JH		 7449#ifdef HAS_QUAD
7450 case 'q': uv = va_arg(*args, Quad_t); break;
7451#endif
46fc3d4c 7452 }
7453 }
7454 else {
211dfcf1 7455 uv = SvUVx(argsv);
46fc3d4c 7456 switch (intsize) {
7457 case 'h': uv = (unsigned short)uv; break;
be28567c 7458 default: break;
46fc3d4c 7459 case 'l': uv = (unsigned long)uv; break;
fc36a67e 7460 case 'V': break;
cf2093f6
JH		 7461#ifdef HAS_QUAD
7462 case 'q': uv = (Quad_t)uv; break;
7463#endif
46fc3d4c 7464 }
7465 }
7466
7467 integer:
46fc3d4c 7468 eptr = ebuf + sizeof ebuf;
fc36a67e 7469 switch (base) {
7470 unsigned dig;
7471 case 16:
c10ed8b9
HS		 7472 if (!uv)
7473 alt = FALSE;
1d7c1841
GS		 7474 p = (char*)((c == 'X')
7475 ? "0123456789ABCDEF" : "0123456789abcdef");
fc36a67e 7476 do {
7477 dig = uv & 15;
7478 *--eptr = p[dig];
7479 } while (uv >>= 4);
7480 if (alt) {
46fc3d4c 7481 esignbuf[esignlen++] = '0';
fc36a67e 7482 esignbuf[esignlen++] = c; /* 'x' or 'X' */
46fc3d4c 7483 }
fc36a67e 7484 break;
7485 case 8:
7486 do {
7487 dig = uv & 7;
7488 *--eptr = '0' + dig;
7489 } while (uv >>= 3);
7490 if (alt && *eptr != '0')
7491 *--eptr = '0';
7492 break;
4f19785b
WSI		 7493 case 2:
7494 do {
7495 dig = uv & 1;
7496 *--eptr = '0' + dig;
7497 } while (uv >>= 1);
eda88b6d
JH		 7498 if (alt) {
7499 esignbuf[esignlen++] = '0';
7481bb52 7500 esignbuf[esignlen++] = 'b';
eda88b6d 7501 }
4f19785b 7502 break;
fc36a67e 7503 default: /* it had better be ten or less */
6bc102ca 7504#if defined(PERL_Y2KWARN)
e476b1b5 7505 if (ckWARN(WARN_Y2K)) {
6bc102ca
GS		 7506 STRLEN n;
7507 char *s = SvPV(sv,n);
7508 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7509 && (n == 2 || !isDIGIT(s[n-3])))
7510 {
e476b1b5 7511 Perl_warner(aTHX_ WARN_Y2K,
6bc102ca
GS		 7512 "Possible Y2K bug: %%%c %s",
7513 c, "format string following '19'");
7514 }
7515 }
7516#endif
fc36a67e 7517 do {
7518 dig = uv % base;
7519 *--eptr = '0' + dig;
7520 } while (uv /= base);
7521 break;
46fc3d4c 7522 }
7523 elen = (ebuf + sizeof ebuf) - eptr;
c10ed8b9
HS		 7524 if (has_precis) {
7525 if (precis > elen)
7526 zeros = precis - elen;
7527 else if (precis == 0 && elen == 1 && *eptr == '0')
7528 elen = 0;
7529 }
46fc3d4c 7530 break;
7531
7532 /* FLOATING POINT */
7533
fc36a67e 7534 case 'F':
7535 c = 'f'; /* maybe %F isn't supported here */
7536 /* FALL THROUGH */
46fc3d4c 7537 case 'e': case 'E':
fc36a67e 7538 case 'f':
46fc3d4c 7539 case 'g': case 'G':
7540
7541 /* This is evil, but floating point is even more evil */
7542
b22c7a20 7543 vectorize = FALSE;
211dfcf1 7544 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
fc36a67e 7545
7546 need = 0;
7547 if (c != 'e' && c != 'E') {
7548 i = PERL_INT_MIN;
73b309ea 7549 (void)Perl_frexp(nv, &i);
fc36a67e 7550 if (i == PERL_INT_MIN)
cea2e8a9 7551 Perl_die(aTHX_ "panic: frexp");
c635e13b 7552 if (i > 0)
fc36a67e 7553 need = BIT_DIGITS(i);
7554 }
7555 need += has_precis ? precis : 6; /* known default */
7556 if (need < width)
7557 need = width;
7558
46fc3d4c 7559 need += 20; /* fudge factor */
80252599
GS		 7560 if (PL_efloatsize < need) {
7561 Safefree(PL_efloatbuf);
7562 PL_efloatsize = need + 20; /* more fudge */
7563 New(906, PL_efloatbuf, PL_efloatsize, char);
7d5ea4e7 7564 PL_efloatbuf[0] = '\0';
46fc3d4c 7565 }
7566
7567 eptr = ebuf + sizeof ebuf;
7568 *--eptr = '\0';
7569 *--eptr = c;
e5c81feb 7570#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
cf2093f6 7571 {
e5c81feb
JH		 7572 /* Copy the one or more characters in a long double
7573 * format before the 'base' ([efgEFG]) character to
7574 * the format string. */
7575 static char const prifldbl[] = PERL_PRIfldbl;
7576 char const *p = prifldbl + sizeof(prifldbl) - 3;
7577 while (p >= prifldbl) { *--eptr = *p--; }
cf2093f6 7578 }
65202027 7579#endif
46fc3d4c 7580 if (has_precis) {
7581 base = precis;
7582 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7583 *--eptr = '.';
7584 }
7585 if (width) {
7586 base = width;
7587 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7588 }
7589 if (fill == '0')
7590 *--eptr = fill;
84902520
TB		 7591 if (left)
7592 *--eptr = '-';
46fc3d4c 7593 if (plus)
7594 *--eptr = plus;
7595 if (alt)
7596 *--eptr = '#';
7597 *--eptr = '%';
7598
ff9121f8
JH		 7599 /* No taint. Otherwise we are in the strange situation
7600 * where printf() taints but print($float) doesn't.
bda0f7a5 7601 * --jhi */
dd8482fc 7602 (void)sprintf(PL_efloatbuf, eptr, nv);
8af02333 7603
80252599
GS		 7604 eptr = PL_efloatbuf;
7605 elen = strlen(PL_efloatbuf);
46fc3d4c 7606 break;
7607
fc36a67e 7608 /* SPECIAL */
7609
7610 case 'n':
b22c7a20 7611 vectorize = FALSE;
fc36a67e 7612 i = SvCUR(sv) - origlen;
7613 if (args) {
c635e13b 7614 switch (intsize) {
7615 case 'h': *(va_arg(*args, short*)) = i; break;
7616 default: *(va_arg(*args, int*)) = i; break;
7617 case 'l': *(va_arg(*args, long*)) = i; break;
7618 case 'V': *(va_arg(*args, IV*)) = i; break;
cf2093f6
JH		 7619#ifdef HAS_QUAD
7620 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7621#endif
c635e13b 7622 }
fc36a67e 7623 }
9dd79c3f 7624 else
211dfcf1 7625 sv_setuv_mg(argsv, (UV)i);
fc36a67e 7626 continue; /* not "break" */
7627
7628 /* UNKNOWN */
7629
46fc3d4c 7630 default:
fc36a67e 7631 unknown:
b22c7a20 7632 vectorize = FALSE;
599cee73 7633 if (!args && ckWARN(WARN_PRINTF) &&
533c011a 7634 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
c635e13b 7635 SV *msg = sv_newmortal();
cea2e8a9 7636 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
533c011a 7637 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
0f4b6630 7638 if (c) {
0f4b6630 7639 if (isPRINT(c))
1c846c1f 7640 Perl_sv_catpvf(aTHX_ msg,
0f4b6630
JH		 7641 "\"%%%c\"", c & 0xFF);
7642 else
7643 Perl_sv_catpvf(aTHX_ msg,
57def98f 7644 "\"%%\\%03"UVof"\"",
0f4b6630 7645 (UV)c & 0xFF);
0f4b6630 7646 } else
c635e13b 7647 sv_catpv(msg, "end of string");
894356b3 7648 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
c635e13b 7649 }
fb73857a 7650
7651 /* output mangled stuff ... */
7652 if (c == '\0')
7653 --q;
46fc3d4c 7654 eptr = p;
7655 elen = q - p;
fb73857a 7656
7657 /* ... right here, because formatting flags should not apply */
7658 SvGROW(sv, SvCUR(sv) + elen + 1);
7659 p = SvEND(sv);
4459522c 7660 Copy(eptr, p, elen, char);
fb73857a 7661 p += elen;
7662 *p = '\0';
7663 SvCUR(sv) = p - SvPVX(sv);
7664 continue; /* not "break" */
46fc3d4c 7665 }
7666
fc36a67e 7667 have = esignlen + zeros + elen;
46fc3d4c 7668 need = (have > width ? have : width);
7669 gap = need - have;
7670
b22c7a20 7671 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
46fc3d4c 7672 p = SvEND(sv);
7673 if (esignlen && fill == '0') {
7674 for (i = 0; i < esignlen; i++)
7675 *p++ = esignbuf[i];
7676 }
7677 if (gap && !left) {
7678 memset(p, fill, gap);
7679 p += gap;
7680 }
7681 if (esignlen && fill != '0') {
7682 for (i = 0; i < esignlen; i++)
7683 *p++ = esignbuf[i];
7684 }
fc36a67e 7685 if (zeros) {
7686 for (i = zeros; i; i--)
7687 *p++ = '0';
7688 }
46fc3d4c 7689 if (elen) {
4459522c 7690 Copy(eptr, p, elen, char);
46fc3d4c 7691 p += elen;
7692 }
7693 if (gap && left) {
7694 memset(p, ' ', gap);
7695 p += gap;
7696 }
b22c7a20
GS		 7697 if (vectorize) {
7698 if (veclen) {
4459522c 7699 Copy(dotstr, p, dotstrlen, char);
b22c7a20
GS		 7700 p += dotstrlen;
7701 }
7702 else
7703 vectorize = FALSE; /* done iterating over vecstr */
7704 }
7e2040f0
GS		 7705 if (is_utf)
7706 SvUTF8_on(sv);
46fc3d4c 7707 *p = '\0';
7708 SvCUR(sv) = p - SvPVX(sv);
b22c7a20
GS		 7709 if (vectorize) {
7710 esignlen = 0;
7711 goto vector;
7712 }
46fc3d4c 7713 }
7714}
51371543 7715
1d7c1841
GS		 7716#if defined(USE_ITHREADS)
7717
7718#if defined(USE_THREADS)
7719# include "error: USE_THREADS and USE_ITHREADS are incompatible"
7720#endif
7721
1d7c1841
GS		 7722#ifndef GpREFCNT_inc
7723# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7724#endif
7725
7726
7727#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7728#define av_dup(s) (AV*)sv_dup((SV*)s)
7729#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7730#define hv_dup(s) (HV*)sv_dup((SV*)s)
7731#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7732#define cv_dup(s) (CV*)sv_dup((SV*)s)
7733#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7734#define io_dup(s) (IO*)sv_dup((SV*)s)
7735#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7736#define gv_dup(s) (GV*)sv_dup((SV*)s)
7737#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7738#define SAVEPV(p) (p ? savepv(p) : Nullch)
7739#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7740
7741REGEXP *
7742Perl_re_dup(pTHX_ REGEXP *r)
7743{
7744 /* XXX fix when pmop->op_pmregexp becomes shared */
7745 return ReREFCNT_inc(r);
7746}
7747
7748PerlIO *
7749Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7750{
7751 PerlIO *ret;
7752 if (!fp)
7753 return (PerlIO*)NULL;
7754
7755 /* look for it in the table first */
7756 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7757 if (ret)
7758 return ret;
7759
7760 /* create anew and remember what it is */
5f1a76d0 7761 ret = PerlIO_fdupopen(aTHX_ fp);
1d7c1841
GS		 7762 ptr_table_store(PL_ptr_table, fp, ret);
7763 return ret;
7764}
7765
7766DIR *
7767Perl_dirp_dup(pTHX_ DIR *dp)
7768{
7769 if (!dp)
7770 return (DIR*)NULL;
7771 /* XXX TODO */
7772 return dp;
7773}
7774
7775GP *
7776Perl_gp_dup(pTHX_ GP *gp)
7777{
7778 GP *ret;
7779 if (!gp)
7780 return (GP*)NULL;
7781 /* look for it in the table first */
7782 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7783 if (ret)
7784 return ret;
7785
7786 /* create anew and remember what it is */
7787 Newz(0, ret, 1, GP);
7788 ptr_table_store(PL_ptr_table, gp, ret);
7789
7790 /* clone */
7791 ret->gp_refcnt = 0; /* must be before any other dups! */
7792 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7793 ret->gp_io = io_dup_inc(gp->gp_io);
7794 ret->gp_form = cv_dup_inc(gp->gp_form);
7795 ret->gp_av = av_dup_inc(gp->gp_av);
7796 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7797 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7798 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7799 ret->gp_cvgen = gp->gp_cvgen;
7800 ret->gp_flags = gp->gp_flags;
7801 ret->gp_line = gp->gp_line;
7802 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7803 return ret;
7804}
7805
7806MAGIC *
7807Perl_mg_dup(pTHX_ MAGIC *mg)
7808{
cb359b41
JH		 7809 MAGIC *mgprev = (MAGIC*)NULL;
7810 MAGIC *mgret;
1d7c1841
GS		 7811 if (!mg)
7812 return (MAGIC*)NULL;
7813 /* look for it in the table first */
7814 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7815 if (mgret)
7816 return mgret;
7817
7818 for (; mg; mg = mg->mg_moremagic) {
7819 MAGIC *nmg;
7820 Newz(0, nmg, 1, MAGIC);
cb359b41 7821 if (mgprev)
1d7c1841 7822 mgprev->mg_moremagic = nmg;
cb359b41
JH		 7823 else
7824 mgret = nmg;
1d7c1841
GS		 7825 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7826 nmg->mg_private = mg->mg_private;
7827 nmg->mg_type = mg->mg_type;
7828 nmg->mg_flags = mg->mg_flags;
14befaf4 7829 if (mg->mg_type == PERL_MAGIC_qr) {
1d7c1841
GS		 7830 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7831 }
7832 else {
7833 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7834 ? sv_dup_inc(mg->mg_obj)
7835 : sv_dup(mg->mg_obj);
7836 }
7837 nmg->mg_len = mg->mg_len;
7838 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
14befaf4 7839 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
1d7c1841
GS		 7840 if (mg->mg_len >= 0) {
7841 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
14befaf4
DM		 7842 if (mg->mg_type == PERL_MAGIC_overload_table &&
7843 AMT_AMAGIC((AMT*)mg->mg_ptr))
7844 {
1d7c1841
GS		 7845 AMT *amtp = (AMT*)mg->mg_ptr;
7846 AMT *namtp = (AMT*)nmg->mg_ptr;
7847 I32 i;
7848 for (i = 1; i < NofAMmeth; i++) {
7849 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7850 }
7851 }
7852 }
7853 else if (mg->mg_len == HEf_SVKEY)
7854 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7855 }
7856 mgprev = nmg;
7857 }
7858 return mgret;
7859}
7860
7861PTR_TBL_t *
7862Perl_ptr_table_new(pTHX)
7863{
7864 PTR_TBL_t *tbl;
7865 Newz(0, tbl, 1, PTR_TBL_t);
7866 tbl->tbl_max = 511;
7867 tbl->tbl_items = 0;
7868 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7869 return tbl;
7870}
7871
7872void *
7873Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7874{
7875 PTR_TBL_ENT_t *tblent;
d2a79402 7876 UV hash = PTR2UV(sv);
1d7c1841
GS		 7877 assert(tbl);
7878 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7879 for (; tblent; tblent = tblent->next) {
7880 if (tblent->oldval == sv)
7881 return tblent->newval;
7882 }
7883 return (void*)NULL;
7884}
7885
7886void
7887Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7888{
7889 PTR_TBL_ENT_t *tblent, **otblent;
7890 /* XXX this may be pessimal on platforms where pointers aren't good
7891 * hash values e.g. if they grow faster in the most significant
7892 * bits */
d2a79402 7893 UV hash = PTR2UV(oldv);
1d7c1841
GS		 7894 bool i = 1;
7895
7896 assert(tbl);
7897 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7898 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7899 if (tblent->oldval == oldv) {
7900 tblent->newval = newv;
7901 tbl->tbl_items++;
7902 return;
7903 }
7904 }
7905 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7906 tblent->oldval = oldv;
7907 tblent->newval = newv;
7908 tblent->next = *otblent;
7909 *otblent = tblent;
7910 tbl->tbl_items++;
7911 if (i && tbl->tbl_items > tbl->tbl_max)
7912 ptr_table_split(tbl);
7913}
7914
7915void
7916Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7917{
7918 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7919 UV oldsize = tbl->tbl_max + 1;
7920 UV newsize = oldsize * 2;
7921 UV i;
7922
7923 Renew(ary, newsize, PTR_TBL_ENT_t*);
7924 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7925 tbl->tbl_max = --newsize;
7926 tbl->tbl_ary = ary;
7927 for (i=0; i < oldsize; i++, ary++) {
7928 PTR_TBL_ENT_t **curentp, **entp, *ent;
7929 if (!*ary)
7930 continue;
7931 curentp = ary + oldsize;
7932 for (entp = ary, ent = *ary; ent; ent = *entp) {
d2a79402 7933 if ((newsize & PTR2UV(ent->oldval)) != i) {
1d7c1841
GS		 7934 *entp = ent->next;
7935 ent->next = *curentp;
7936 *curentp = ent;
7937 continue;
7938 }
7939 else
7940 entp = &ent->next;
7941 }
7942 }
7943}
7944
a0739874
DM		 7945void
7946Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7947{
7948 register PTR_TBL_ENT_t **array;
7949 register PTR_TBL_ENT_t *entry;
7950 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7951 UV riter = 0;
7952 UV max;
7953
7954 if (!tbl || !tbl->tbl_items) {
7955 return;
7956 }
7957
7958 array = tbl->tbl_ary;
7959 entry = array[0];
7960 max = tbl->tbl_max;
7961
7962 for (;;) {
7963 if (entry) {
7964 oentry = entry;
7965 entry = entry->next;
7966 Safefree(oentry);
7967 }
7968 if (!entry) {
7969 if (++riter > max) {
7970 break;
7971 }
7972 entry = array[riter];
7973 }
7974 }
7975
7976 tbl->tbl_items = 0;
7977}
7978
7979void
7980Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7981{
7982 if (!tbl) {
7983 return;
7984 }
7985 ptr_table_clear(tbl);
7986 Safefree(tbl->tbl_ary);
7987 Safefree(tbl);
7988}
7989
1d7c1841
GS		 7990#ifdef DEBUGGING
7991char *PL_watch_pvx;
7992#endif
7993
5bd07a3d
DM		 7994STATIC SV *
7995S_gv_share(pTHX_ SV *sstr)
7996{
7997 GV *gv = (GV*)sstr;
7998 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7999
8000 if (GvIO(gv) || GvFORM(gv)) {
8001 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8002 }
8003 else if (!GvCV(gv)) {
8004 GvCV(gv) = (CV*)sv;
8005 }
8006 else {
8007 /* CvPADLISTs cannot be shared */
8008 if (!CvXSUB(GvCV(gv))) {
8009 GvSHARED_off(gv);
8010 }
8011 }
8012
8013 if (!GvSHARED(gv)) {
8014#if 0
8015 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8016 HvNAME(GvSTASH(gv)), GvNAME(gv));
8017#endif
8018 return Nullsv;
8019 }
8020
4411f3b6 8021 /*
5bd07a3d
DM		 8022 * write attempts will die with
8023 * "Modification of a read-only value attempted"
8024 */
8025 if (!GvSV(gv)) {
8026 GvSV(gv) = sv;
8027 }
8028 else {
8029 SvREADONLY_on(GvSV(gv));
8030 }
8031
8032 if (!GvAV(gv)) {
8033 GvAV(gv) = (AV*)sv;
8034 }
8035 else {
8036 SvREADONLY_on(GvAV(gv));
8037 }
8038
8039 if (!GvHV(gv)) {
8040 GvHV(gv) = (HV*)sv;
8041 }
8042 else {
8043 SvREADONLY_on(GvAV(gv));
8044 }
8045
8046 return sstr; /* he_dup() will SvREFCNT_inc() */
8047}
8048
1d7c1841
GS		 8049SV *
8050Perl_sv_dup(pTHX_ SV *sstr)
8051{
1d7c1841
GS		 8052 SV *dstr;
8053
8054 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8055 return Nullsv;
8056 /* look for it in the table first */
8057 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8058 if (dstr)
8059 return dstr;
8060
8061 /* create anew and remember what it is */
8062 new_SV(dstr);
8063 ptr_table_store(PL_ptr_table, sstr, dstr);
8064
8065 /* clone */
8066 SvFLAGS(dstr) = SvFLAGS(sstr);
8067 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8068 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8069
8070#ifdef DEBUGGING
8071 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8072 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8073 PL_watch_pvx, SvPVX(sstr));
8074#endif
8075
8076 switch (SvTYPE(sstr)) {
8077 case SVt_NULL:
8078 SvANY(dstr) = NULL;
8079 break;
8080 case SVt_IV:
8081 SvANY(dstr) = new_XIV();
8082 SvIVX(dstr) = SvIVX(sstr);
8083 break;
8084 case SVt_NV:
8085 SvANY(dstr) = new_XNV();
8086 SvNVX(dstr) = SvNVX(sstr);
8087 break;
8088 case SVt_RV:
8089 SvANY(dstr) = new_XRV();
89cd1aa3
DM		 8090 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8091 ? sv_dup(SvRV(sstr))
8092 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8093 break;
8094 case SVt_PV:
8095 SvANY(dstr) = new_XPV();
8096 SvCUR(dstr) = SvCUR(sstr);
8097 SvLEN(dstr) = SvLEN(sstr);
8098 if (SvROK(sstr))
ce4ad881 8099 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8100 ? sv_dup(SvRV(sstr))
8101 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8102 else if (SvPVX(sstr) && SvLEN(sstr))
8103 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8104 else
8105 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8106 break;
8107 case SVt_PVIV:
8108 SvANY(dstr) = new_XPVIV();
8109 SvCUR(dstr) = SvCUR(sstr);
8110 SvLEN(dstr) = SvLEN(sstr);
8111 SvIVX(dstr) = SvIVX(sstr);
8112 if (SvROK(sstr))
ce4ad881 8113 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8114 ? sv_dup(SvRV(sstr))
8115 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8116 else if (SvPVX(sstr) && SvLEN(sstr))
8117 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8118 else
8119 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8120 break;
8121 case SVt_PVNV:
8122 SvANY(dstr) = new_XPVNV();
8123 SvCUR(dstr) = SvCUR(sstr);
8124 SvLEN(dstr) = SvLEN(sstr);
8125 SvIVX(dstr) = SvIVX(sstr);
8126 SvNVX(dstr) = SvNVX(sstr);
8127 if (SvROK(sstr))
ce4ad881 8128 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8129 ? sv_dup(SvRV(sstr))
8130 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8131 else if (SvPVX(sstr) && SvLEN(sstr))
8132 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8133 else
8134 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8135 break;
8136 case SVt_PVMG:
8137 SvANY(dstr) = new_XPVMG();
8138 SvCUR(dstr) = SvCUR(sstr);
8139 SvLEN(dstr) = SvLEN(sstr);
8140 SvIVX(dstr) = SvIVX(sstr);
8141 SvNVX(dstr) = SvNVX(sstr);
8142 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8143 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8144 if (SvROK(sstr))
ce4ad881 8145 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8146 ? sv_dup(SvRV(sstr))
8147 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8148 else if (SvPVX(sstr) && SvLEN(sstr))
8149 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8150 else
8151 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8152 break;
8153 case SVt_PVBM:
8154 SvANY(dstr) = new_XPVBM();
8155 SvCUR(dstr) = SvCUR(sstr);
8156 SvLEN(dstr) = SvLEN(sstr);
8157 SvIVX(dstr) = SvIVX(sstr);
8158 SvNVX(dstr) = SvNVX(sstr);
8159 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8160 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8161 if (SvROK(sstr))
ce4ad881 8162 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8163 ? sv_dup(SvRV(sstr))
8164 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8165 else if (SvPVX(sstr) && SvLEN(sstr))
8166 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8167 else
8168 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8169 BmRARE(dstr) = BmRARE(sstr);
8170 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8171 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8172 break;
8173 case SVt_PVLV:
8174 SvANY(dstr) = new_XPVLV();
8175 SvCUR(dstr) = SvCUR(sstr);
8176 SvLEN(dstr) = SvLEN(sstr);
8177 SvIVX(dstr) = SvIVX(sstr);
8178 SvNVX(dstr) = SvNVX(sstr);
8179 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8180 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8181 if (SvROK(sstr))
ce4ad881 8182 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8183 ? sv_dup(SvRV(sstr))
8184 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8185 else if (SvPVX(sstr) && SvLEN(sstr))
8186 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8187 else
8188 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8189 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8190 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8191 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8192 LvTYPE(dstr) = LvTYPE(sstr);
8193 break;
8194 case SVt_PVGV:
5bd07a3d
DM		 8195 if (GvSHARED((GV*)sstr)) {
8196 SV *share;
8197 if ((share = gv_share(sstr))) {
8198 del_SV(dstr);
8199 dstr = share;
8200#if 0
8201 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8202 HvNAME(GvSTASH(share)), GvNAME(share));
8203#endif
8204 break;
8205 }
8206 }
1d7c1841
GS		 8207 SvANY(dstr) = new_XPVGV();
8208 SvCUR(dstr) = SvCUR(sstr);
8209 SvLEN(dstr) = SvLEN(sstr);
8210 SvIVX(dstr) = SvIVX(sstr);
8211 SvNVX(dstr) = SvNVX(sstr);
8212 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8213 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8214 if (SvROK(sstr))
ce4ad881 8215 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8216 ? sv_dup(SvRV(sstr))
8217 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8218 else if (SvPVX(sstr) && SvLEN(sstr))
8219 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8220 else
8221 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8222 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8223 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8224 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8225 GvFLAGS(dstr) = GvFLAGS(sstr);
8226 GvGP(dstr) = gp_dup(GvGP(sstr));
8227 (void)GpREFCNT_inc(GvGP(dstr));
8228 break;
8229 case SVt_PVIO:
8230 SvANY(dstr) = new_XPVIO();
8231 SvCUR(dstr) = SvCUR(sstr);
8232 SvLEN(dstr) = SvLEN(sstr);
8233 SvIVX(dstr) = SvIVX(sstr);
8234 SvNVX(dstr) = SvNVX(sstr);
8235 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8236 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8237 if (SvROK(sstr))
ce4ad881 8238 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
89cd1aa3
DM		 8239 ? sv_dup(SvRV(sstr))
8240 : sv_dup_inc(SvRV(sstr));
1d7c1841
GS		 8241 else if (SvPVX(sstr) && SvLEN(sstr))
8242 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8243 else
8244 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8245 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8246 if (IoOFP(sstr) == IoIFP(sstr))
8247 IoOFP(dstr) = IoIFP(dstr);
8248 else
8249 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8250 /* PL_rsfp_filters entries have fake IoDIRP() */
8251 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8252 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8253 else
8254 IoDIRP(dstr) = IoDIRP(sstr);
8255 IoLINES(dstr) = IoLINES(sstr);
8256 IoPAGE(dstr) = IoPAGE(sstr);
8257 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8258 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8259 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8260 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8261 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8262 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8263 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8264 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8265 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8266 IoTYPE(dstr) = IoTYPE(sstr);
8267 IoFLAGS(dstr) = IoFLAGS(sstr);
8268 break;
8269 case SVt_PVAV:
8270 SvANY(dstr) = new_XPVAV();
8271 SvCUR(dstr) = SvCUR(sstr);
8272 SvLEN(dstr) = SvLEN(sstr);
8273 SvIVX(dstr) = SvIVX(sstr);
8274 SvNVX(dstr) = SvNVX(sstr);
8275 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8276 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8277 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8278 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8279 if (AvARRAY((AV*)sstr)) {
8280 SV **dst_ary, **src_ary;
8281 SSize_t items = AvFILLp((AV*)sstr) + 1;
8282
8283 src_ary = AvARRAY((AV*)sstr);
8284 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8285 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8286 SvPVX(dstr) = (char*)dst_ary;
8287 AvALLOC((AV*)dstr) = dst_ary;
8288 if (AvREAL((AV*)sstr)) {
8289 while (items-- > 0)
8290 *dst_ary++ = sv_dup_inc(*src_ary++);
8291 }
8292 else {
8293 while (items-- > 0)
8294 *dst_ary++ = sv_dup(*src_ary++);
8295 }
8296 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8297 while (items-- > 0) {
8298 *dst_ary++ = &PL_sv_undef;
8299 }
8300 }
8301 else {
8302 SvPVX(dstr) = Nullch;
8303 AvALLOC((AV*)dstr) = (SV**)NULL;
8304 }
8305 break;
8306 case SVt_PVHV:
8307 SvANY(dstr) = new_XPVHV();
8308 SvCUR(dstr) = SvCUR(sstr);
8309 SvLEN(dstr) = SvLEN(sstr);
8310 SvIVX(dstr) = SvIVX(sstr);
8311 SvNVX(dstr) = SvNVX(sstr);
8312 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8313 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8314 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8315 if (HvARRAY((HV*)sstr)) {
1d7c1841
GS		 8316 STRLEN i = 0;
8317 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8318 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8319 Newz(0, dxhv->xhv_array,
8320 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8321 while (i <= sxhv->xhv_max) {
8322 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8323 !!HvSHAREKEYS(sstr));
8324 ++i;
8325 }
8326 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8327 }
8328 else {
8329 SvPVX(dstr) = Nullch;
8330 HvEITER((HV*)dstr) = (HE*)NULL;
8331 }
8332 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8333 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8334 break;
8335 case SVt_PVFM:
8336 SvANY(dstr) = new_XPVFM();
8337 FmLINES(dstr) = FmLINES(sstr);
8338 goto dup_pvcv;
8339 /* NOTREACHED */
8340 case SVt_PVCV:
8341 SvANY(dstr) = new_XPVCV();
8342dup_pvcv:
8343 SvCUR(dstr) = SvCUR(sstr);
8344 SvLEN(dstr) = SvLEN(sstr);
8345 SvIVX(dstr) = SvIVX(sstr);
8346 SvNVX(dstr) = SvNVX(sstr);
8347 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8348 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8349 if (SvPVX(sstr) && SvLEN(sstr))
8350 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8351 else
8352 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8353 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8354 CvSTART(dstr) = CvSTART(sstr);
8355 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8356 CvXSUB(dstr) = CvXSUB(sstr);
8357 CvXSUBANY(dstr) = CvXSUBANY(sstr);
f25c30a3 8358 CvGV(dstr) = gv_dup(CvGV(sstr));
1d7c1841
GS		 8359 CvDEPTH(dstr) = CvDEPTH(sstr);
8360 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8361 /* XXX padlists are real, but pretend to be not */
8362 AvREAL_on(CvPADLIST(sstr));
8363 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8364 AvREAL_off(CvPADLIST(sstr));
8365 AvREAL_off(CvPADLIST(dstr));
8366 }
8367 else
8368 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
282f25c9
JH		 8369 if (!CvANON(sstr) || CvCLONED(sstr))
8370 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8371 else
8372 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
1d7c1841
GS		 8373 CvFLAGS(dstr) = CvFLAGS(sstr);
8374 break;
8375 default:
8376 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8377 break;
8378 }
8379
8380 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8381 ++PL_sv_objcount;
8382
8383 return dstr;
8384}
8385
8386PERL_CONTEXT *
8387Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8388{
8389 PERL_CONTEXT *ncxs;
8390
8391 if (!cxs)
8392 return (PERL_CONTEXT*)NULL;
8393
8394 /* look for it in the table first */
8395 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8396 if (ncxs)
8397 return ncxs;
8398
8399 /* create anew and remember what it is */
8400 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8401 ptr_table_store(PL_ptr_table, cxs, ncxs);
8402
8403 while (ix >= 0) {
8404 PERL_CONTEXT *cx = &cxs[ix];
8405 PERL_CONTEXT *ncx = &ncxs[ix];
8406 ncx->cx_type = cx->cx_type;
8407 if (CxTYPE(cx) == CXt_SUBST) {
8408 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8409 }
8410 else {
8411 ncx->blk_oldsp = cx->blk_oldsp;
8412 ncx->blk_oldcop = cx->blk_oldcop;
8413 ncx->blk_oldretsp = cx->blk_oldretsp;
8414 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8415 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8416 ncx->blk_oldpm = cx->blk_oldpm;
8417 ncx->blk_gimme = cx->blk_gimme;
8418 switch (CxTYPE(cx)) {
8419 case CXt_SUB:
8420 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8421 ? cv_dup_inc(cx->blk_sub.cv)
8422 : cv_dup(cx->blk_sub.cv));
8423 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8424 ? av_dup_inc(cx->blk_sub.argarray)
8425 : Nullav);
f25c30a3 8426 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
1d7c1841
GS		 8427 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8428 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8429 ncx->blk_sub.lval = cx->blk_sub.lval;
8430 break;
8431 case CXt_EVAL:
8432 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8433 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
0f79a09d 8434 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
1d7c1841
GS		 8435 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8436 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8437 break;
8438 case CXt_LOOP:
8439 ncx->blk_loop.label = cx->blk_loop.label;
8440 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8441 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8442 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8443 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8444 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8445 ? cx->blk_loop.iterdata
8446 : gv_dup((GV*)cx->blk_loop.iterdata));
a4b82a6f
GS		 8447 ncx->blk_loop.oldcurpad
8448 = (SV**)ptr_table_fetch(PL_ptr_table,
8449 cx->blk_loop.oldcurpad);
1d7c1841
GS		 8450 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8451 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8452 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8453 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8454 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8455 break;
8456 case CXt_FORMAT:
8457 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8458 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8459 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8460 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8461 break;
8462 case CXt_BLOCK:
8463 case CXt_NULL:
8464 break;
8465 }
8466 }
8467 --ix;
8468 }
8469 return ncxs;
8470}
8471
8472PERL_SI *
8473Perl_si_dup(pTHX_ PERL_SI *si)
8474{
8475 PERL_SI *nsi;
8476
8477 if (!si)
8478 return (PERL_SI*)NULL;
8479
8480 /* look for it in the table first */
8481 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8482 if (nsi)
8483 return nsi;
8484
8485 /* create anew and remember what it is */
8486 Newz(56, nsi, 1, PERL_SI);
8487 ptr_table_store(PL_ptr_table, si, nsi);
8488
8489 nsi->si_stack = av_dup_inc(si->si_stack);
8490 nsi->si_cxix = si->si_cxix;
8491 nsi->si_cxmax = si->si_cxmax;
8492 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8493 nsi->si_type = si->si_type;
8494 nsi->si_prev = si_dup(si->si_prev);
8495 nsi->si_next = si_dup(si->si_next);
8496 nsi->si_markoff = si->si_markoff;
8497
8498 return nsi;
8499}
8500
8501#define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8502#define TOPINT(ss,ix) ((ss)[ix].any_i32)
8503#define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8504#define TOPLONG(ss,ix) ((ss)[ix].any_long)
8505#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8506#define TOPIV(ss,ix) ((ss)[ix].any_iv)
8507#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8508#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8509#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8510#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8511#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8512#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8513
8514/* XXXXX todo */
8515#define pv_dup_inc(p) SAVEPV(p)
8516#define pv_dup(p) SAVEPV(p)
8517#define svp_dup_inc(p,pp) any_dup(p,pp)
8518
8519void *
8520Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8521{
8522 void *ret;
8523
8524 if (!v)
8525 return (void*)NULL;
8526
8527 /* look for it in the table first */
8528 ret = ptr_table_fetch(PL_ptr_table, v);
8529 if (ret)
8530 return ret;
8531
8532 /* see if it is part of the interpreter structure */
8533 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8534 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8535 else
8536 ret = v;
8537
8538 return ret;
8539}
8540
8541ANY *
8542Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8543{
8544 ANY *ss = proto_perl->Tsavestack;
8545 I32 ix = proto_perl->Tsavestack_ix;
8546 I32 max = proto_perl->Tsavestack_max;
8547 ANY *nss;
8548 SV *sv;
8549 GV *gv;
8550 AV *av;
8551 HV *hv;
8552 void* ptr;
8553 int intval;
8554 long longval;
8555 GP *gp;
8556 IV iv;
8557 I32 i;
8558 char *c;
8559 void (*dptr) (void*);
8560 void (*dxptr) (pTHXo_ void*);
e977893f 8561 OP *o;
1d7c1841
GS		 8562
8563 Newz(54, nss, max, ANY);
8564
8565 while (ix > 0) {
8566 i = POPINT(ss,ix);
8567 TOPINT(nss,ix) = i;
8568 switch (i) {
8569 case SAVEt_ITEM: /* normal string */
8570 sv = (SV*)POPPTR(ss,ix);
8571 TOPPTR(nss,ix) = sv_dup_inc(sv);
8572 sv = (SV*)POPPTR(ss,ix);
8573 TOPPTR(nss,ix) = sv_dup_inc(sv);
8574 break;
8575 case SAVEt_SV: /* scalar reference */
8576 sv = (SV*)POPPTR(ss,ix);
8577 TOPPTR(nss,ix) = sv_dup_inc(sv);
8578 gv = (GV*)POPPTR(ss,ix);
8579 TOPPTR(nss,ix) = gv_dup_inc(gv);
8580 break;
f4dd75d9
GS		 8581 case SAVEt_GENERIC_PVREF: /* generic char* */
8582 c = (char*)POPPTR(ss,ix);
8583 TOPPTR(nss,ix) = pv_dup(c);
8584 ptr = POPPTR(ss,ix);
8585 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8586 break;
1d7c1841
GS		 8587 case SAVEt_GENERIC_SVREF: /* generic sv */
8588 case SAVEt_SVREF: /* scalar reference */
8589 sv = (SV*)POPPTR(ss,ix);
8590 TOPPTR(nss,ix) = sv_dup_inc(sv);
8591 ptr = POPPTR(ss,ix);
8592 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8593 break;
8594 case SAVEt_AV: /* array reference */
8595 av = (AV*)POPPTR(ss,ix);
8596 TOPPTR(nss,ix) = av_dup_inc(av);
8597 gv = (GV*)POPPTR(ss,ix);
8598 TOPPTR(nss,ix) = gv_dup(gv);
8599 break;
8600 case SAVEt_HV: /* hash reference */
8601 hv = (HV*)POPPTR(ss,ix);
8602 TOPPTR(nss,ix) = hv_dup_inc(hv);
8603 gv = (GV*)POPPTR(ss,ix);
8604 TOPPTR(nss,ix) = gv_dup(gv);
8605 break;
8606 case SAVEt_INT: /* int reference */
8607 ptr = POPPTR(ss,ix);
8608 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8609 intval = (int)POPINT(ss,ix);
8610 TOPINT(nss,ix) = intval;
8611 break;
8612 case SAVEt_LONG: /* long reference */
8613 ptr = POPPTR(ss,ix);
8614 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8615 longval = (long)POPLONG(ss,ix);
8616 TOPLONG(nss,ix) = longval;
8617 break;
8618 case SAVEt_I32: /* I32 reference */
8619 case SAVEt_I16: /* I16 reference */
8620 case SAVEt_I8: /* I8 reference */
8621 ptr = POPPTR(ss,ix);
8622 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8623 i = POPINT(ss,ix);
8624 TOPINT(nss,ix) = i;
8625 break;
8626 case SAVEt_IV: /* IV reference */
8627 ptr = POPPTR(ss,ix);
8628 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8629 iv = POPIV(ss,ix);
8630 TOPIV(nss,ix) = iv;
8631 break;
8632 case SAVEt_SPTR: /* SV* reference */
8633 ptr = POPPTR(ss,ix);
8634 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8635 sv = (SV*)POPPTR(ss,ix);
8636 TOPPTR(nss,ix) = sv_dup(sv);
8637 break;
8638 case SAVEt_VPTR: /* random* reference */
8639 ptr = POPPTR(ss,ix);
8640 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8641 ptr = POPPTR(ss,ix);
8642 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8643 break;
8644 case SAVEt_PPTR: /* char* reference */
8645 ptr = POPPTR(ss,ix);
8646 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8647 c = (char*)POPPTR(ss,ix);
8648 TOPPTR(nss,ix) = pv_dup(c);
8649 break;
8650 case SAVEt_HPTR: /* HV* reference */
8651 ptr = POPPTR(ss,ix);
8652 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8653 hv = (HV*)POPPTR(ss,ix);
8654 TOPPTR(nss,ix) = hv_dup(hv);
8655 break;
8656 case SAVEt_APTR: /* AV* reference */
8657 ptr = POPPTR(ss,ix);
8658 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8659 av = (AV*)POPPTR(ss,ix);
8660 TOPPTR(nss,ix) = av_dup(av);
8661 break;
8662 case SAVEt_NSTAB:
8663 gv = (GV*)POPPTR(ss,ix);
8664 TOPPTR(nss,ix) = gv_dup(gv);
8665 break;
8666 case SAVEt_GP: /* scalar reference */
8667 gp = (GP*)POPPTR(ss,ix);
8668 TOPPTR(nss,ix) = gp = gp_dup(gp);
8669 (void)GpREFCNT_inc(gp);
8670 gv = (GV*)POPPTR(ss,ix);
8671 TOPPTR(nss,ix) = gv_dup_inc(c);
8672 c = (char*)POPPTR(ss,ix);
8673 TOPPTR(nss,ix) = pv_dup(c);
8674 iv = POPIV(ss,ix);
8675 TOPIV(nss,ix) = iv;
8676 iv = POPIV(ss,ix);
8677 TOPIV(nss,ix) = iv;
8678 break;
8679 case SAVEt_FREESV:
26d9b02f 8680 case SAVEt_MORTALIZESV:
1d7c1841
GS		 8681 sv = (SV*)POPPTR(ss,ix);
8682 TOPPTR(nss,ix) = sv_dup_inc(sv);
8683 break;
8684 case SAVEt_FREEOP:
8685 ptr = POPPTR(ss,ix);
8686 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8687 /* these are assumed to be refcounted properly */
8688 switch (((OP*)ptr)->op_type) {
8689 case OP_LEAVESUB:
8690 case OP_LEAVESUBLV:
8691 case OP_LEAVEEVAL:
8692 case OP_LEAVE:
8693 case OP_SCOPE:
8694 case OP_LEAVEWRITE:
e977893f
GS		 8695 TOPPTR(nss,ix) = ptr;
8696 o = (OP*)ptr;
8697 OpREFCNT_inc(o);
1d7c1841
GS		 8698 break;
8699 default:
8700 TOPPTR(nss,ix) = Nullop;
8701 break;
8702 }
8703 }
8704 else
8705 TOPPTR(nss,ix) = Nullop;
8706 break;
8707 case SAVEt_FREEPV:
8708 c = (char*)POPPTR(ss,ix);
8709 TOPPTR(nss,ix) = pv_dup_inc(c);
8710 break;
8711 case SAVEt_CLEARSV:
8712 longval = POPLONG(ss,ix);
8713 TOPLONG(nss,ix) = longval;
8714 break;
8715 case SAVEt_DELETE:
8716 hv = (HV*)POPPTR(ss,ix);
8717 TOPPTR(nss,ix) = hv_dup_inc(hv);
8718 c = (char*)POPPTR(ss,ix);
8719 TOPPTR(nss,ix) = pv_dup_inc(c);
8720 i = POPINT(ss,ix);
8721 TOPINT(nss,ix) = i;
8722 break;
8723 case SAVEt_DESTRUCTOR:
8724 ptr = POPPTR(ss,ix);
8725 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8726 dptr = POPDPTR(ss,ix);
ef75a179 8727 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
1d7c1841
GS		 8728 break;
8729 case SAVEt_DESTRUCTOR_X:
8730 ptr = POPPTR(ss,ix);
8731 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8732 dxptr = POPDXPTR(ss,ix);
ef75a179 8733 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
1d7c1841
GS		 8734 break;
8735 case SAVEt_REGCONTEXT:
8736 case SAVEt_ALLOC:
8737 i = POPINT(ss,ix);
8738 TOPINT(nss,ix) = i;
8739 ix -= i;
8740 break;
8741 case SAVEt_STACK_POS: /* Position on Perl stack */
8742 i = POPINT(ss,ix);
8743 TOPINT(nss,ix) = i;
8744 break;
8745 case SAVEt_AELEM: /* array element */
8746 sv = (SV*)POPPTR(ss,ix);
8747 TOPPTR(nss,ix) = sv_dup_inc(sv);
8748 i = POPINT(ss,ix);
8749 TOPINT(nss,ix) = i;
8750 av = (AV*)POPPTR(ss,ix);
8751 TOPPTR(nss,ix) = av_dup_inc(av);
8752 break;
8753 case SAVEt_HELEM: /* hash element */
8754 sv = (SV*)POPPTR(ss,ix);
8755 TOPPTR(nss,ix) = sv_dup_inc(sv);
8756 sv = (SV*)POPPTR(ss,ix);
8757 TOPPTR(nss,ix) = sv_dup_inc(sv);
8758 hv = (HV*)POPPTR(ss,ix);
8759 TOPPTR(nss,ix) = hv_dup_inc(hv);
8760 break;
8761 case SAVEt_OP:
8762 ptr = POPPTR(ss,ix);
8763 TOPPTR(nss,ix) = ptr;
8764 break;
8765 case SAVEt_HINTS:
8766 i = POPINT(ss,ix);
8767 TOPINT(nss,ix) = i;
8768 break;
c4410b1b
GS		 8769 case SAVEt_COMPPAD:
8770 av = (AV*)POPPTR(ss,ix);
8771 TOPPTR(nss,ix) = av_dup(av);
8772 break;
c3564e5c
GS		 8773 case SAVEt_PADSV:
8774 longval = (long)POPLONG(ss,ix);
8775 TOPLONG(nss,ix) = longval;
8776 ptr = POPPTR(ss,ix);
8777 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8778 sv = (SV*)POPPTR(ss,ix);
8779 TOPPTR(nss,ix) = sv_dup(sv);
8780 break;
1d7c1841
GS		 8781 default:
8782 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8783 }
8784 }
8785
8786 return nss;
8787}
8788
8789#ifdef PERL_OBJECT
8790#include "XSUB.h"
8791#endif
8792
8793PerlInterpreter *
8794perl_clone(PerlInterpreter *proto_perl, UV flags)
8795{
8796#ifdef PERL_OBJECT
8797 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8798#endif
8799
8800#ifdef PERL_IMPLICIT_SYS
8801 return perl_clone_using(proto_perl, flags,
8802 proto_perl->IMem,
8803 proto_perl->IMemShared,
8804 proto_perl->IMemParse,
8805 proto_perl->IEnv,
8806 proto_perl->IStdIO,
8807 proto_perl->ILIO,
8808 proto_perl->IDir,
8809 proto_perl->ISock,
8810 proto_perl->IProc);
8811}
8812
8813PerlInterpreter *
8814perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8815 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8816 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8817 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8818 struct IPerlDir* ipD, struct IPerlSock* ipS,
8819 struct IPerlProc* ipP)
8820{
8821 /* XXX many of the string copies here can be optimized if they're
8822 * constants; they need to be allocated as common memory and just
8823 * their pointers copied. */
8824
8825 IV i;
1d7c1841
GS		 8826# ifdef PERL_OBJECT
8827 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8828 ipD, ipS, ipP);
ba869deb 8829 PERL_SET_THX(pPerl);
1d7c1841
GS		 8830# else /* !PERL_OBJECT */
8831 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
ba869deb 8832 PERL_SET_THX(my_perl);
1d7c1841
GS		 8833
8834# ifdef DEBUGGING
8835 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8836 PL_markstack = 0;
8837 PL_scopestack = 0;
8838 PL_savestack = 0;
8839 PL_retstack = 0;
66fe0623 8840 PL_sig_pending = 0;
1d7c1841
GS		 8841# else /* !DEBUGGING */
8842 Zero(my_perl, 1, PerlInterpreter);
8843# endif /* DEBUGGING */
8844
8845 /* host pointers */
8846 PL_Mem = ipM;
8847 PL_MemShared = ipMS;
8848 PL_MemParse = ipMP;
8849 PL_Env = ipE;
8850 PL_StdIO = ipStd;
8851 PL_LIO = ipLIO;
8852 PL_Dir = ipD;
8853 PL_Sock = ipS;
8854 PL_Proc = ipP;
8855# endif /* PERL_OBJECT */
8856#else /* !PERL_IMPLICIT_SYS */
8857 IV i;
1d7c1841 8858 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 8859 PERL_SET_THX(my_perl);
1d7c1841
GS		 8860
8861# ifdef DEBUGGING
8862 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8863 PL_markstack = 0;
8864 PL_scopestack = 0;
8865 PL_savestack = 0;
8866 PL_retstack = 0;
66fe0623 8867 PL_sig_pending = 0;
1d7c1841
GS		 8868# else /* !DEBUGGING */
8869 Zero(my_perl, 1, PerlInterpreter);
8870# endif /* DEBUGGING */
8871#endif /* PERL_IMPLICIT_SYS */
8872
8873 /* arena roots */
8874 PL_xiv_arenaroot = NULL;
8875 PL_xiv_root = NULL;
612f20c3 8876 PL_xnv_arenaroot = NULL;
1d7c1841 8877 PL_xnv_root = NULL;
612f20c3 8878 PL_xrv_arenaroot = NULL;
1d7c1841 8879 PL_xrv_root = NULL;
612f20c3 8880 PL_xpv_arenaroot = NULL;
1d7c1841 8881 PL_xpv_root = NULL;
612f20c3 8882 PL_xpviv_arenaroot = NULL;
1d7c1841 8883 PL_xpviv_root = NULL;
612f20c3 8884 PL_xpvnv_arenaroot = NULL;
1d7c1841 8885 PL_xpvnv_root = NULL;
612f20c3 8886 PL_xpvcv_arenaroot = NULL;
1d7c1841 8887 PL_xpvcv_root = NULL;
612f20c3 8888 PL_xpvav_arenaroot = NULL;
1d7c1841 8889 PL_xpvav_root = NULL;
612f20c3 8890 PL_xpvhv_arenaroot = NULL;
1d7c1841 8891 PL_xpvhv_root = NULL;
612f20c3 8892 PL_xpvmg_arenaroot = NULL;
1d7c1841 8893 PL_xpvmg_root = NULL;
612f20c3 8894 PL_xpvlv_arenaroot = NULL;
1d7c1841 8895 PL_xpvlv_root = NULL;
612f20c3 8896 PL_xpvbm_arenaroot = NULL;
1d7c1841 8897 PL_xpvbm_root = NULL;
612f20c3 8898 PL_he_arenaroot = NULL;
1d7c1841
GS		 8899 PL_he_root = NULL;
8900 PL_nice_chunk = NULL;
8901 PL_nice_chunk_size = 0;
8902 PL_sv_count = 0;
8903 PL_sv_objcount = 0;
8904 PL_sv_root = Nullsv;
8905 PL_sv_arenaroot = Nullsv;
8906
8907 PL_debug = proto_perl->Idebug;
8908
8909 /* create SV map for pointer relocation */
8910 PL_ptr_table = ptr_table_new();
8911
8912 /* initialize these special pointers as early as possible */
8913 SvANY(&PL_sv_undef) = NULL;
8914 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8915 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8916 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8917
8918#ifdef PERL_OBJECT
8919 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8920#else
8921 SvANY(&PL_sv_no) = new_XPVNV();
8922#endif
8923 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8924 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8925 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8926 SvCUR(&PL_sv_no) = 0;
8927 SvLEN(&PL_sv_no) = 1;
8928 SvNVX(&PL_sv_no) = 0;
8929 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8930
8931#ifdef PERL_OBJECT
8932 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8933#else
8934 SvANY(&PL_sv_yes) = new_XPVNV();
8935#endif
8936 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8937 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8938 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8939 SvCUR(&PL_sv_yes) = 1;
8940 SvLEN(&PL_sv_yes) = 2;
8941 SvNVX(&PL_sv_yes) = 1;
8942 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8943
8944 /* create shared string table */
8945 PL_strtab = newHV();
8946 HvSHAREKEYS_off(PL_strtab);
8947 hv_ksplit(PL_strtab, 512);
8948 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8949
8950 PL_compiling = proto_perl->Icompiling;
8951 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8952 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8953 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8954 if (!specialWARN(PL_compiling.cop_warnings))
8955 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
ac27b0f5
NIS		 8956 if (!specialCopIO(PL_compiling.cop_io))
8957 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
1d7c1841
GS		 8958 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8959
8960 /* pseudo environmental stuff */
8961 PL_origargc = proto_perl->Iorigargc;
8962 i = PL_origargc;
8963 New(0, PL_origargv, i+1, char*);
8964 PL_origargv[i] = '\0';
8965 while (i-- > 0) {
8966 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8967 }
8968 PL_envgv = gv_dup(proto_perl->Ienvgv);
8969 PL_incgv = gv_dup(proto_perl->Iincgv);
8970 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8971 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8972 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8973 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8974
8975 /* switches */
8976 PL_minus_c = proto_perl->Iminus_c;
a7cb1f99 8977 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
1d7c1841
GS		 8978 PL_localpatches = proto_perl->Ilocalpatches;
8979 PL_splitstr = proto_perl->Isplitstr;
8980 PL_preprocess = proto_perl->Ipreprocess;
8981 PL_minus_n = proto_perl->Iminus_n;
8982 PL_minus_p = proto_perl->Iminus_p;
8983 PL_minus_l = proto_perl->Iminus_l;
8984 PL_minus_a = proto_perl->Iminus_a;
8985 PL_minus_F = proto_perl->Iminus_F;
8986 PL_doswitches = proto_perl->Idoswitches;
8987 PL_dowarn = proto_perl->Idowarn;
8988 PL_doextract = proto_perl->Idoextract;
8989 PL_sawampersand = proto_perl->Isawampersand;
8990 PL_unsafe = proto_perl->Iunsafe;
8991 PL_inplace = SAVEPV(proto_perl->Iinplace);
8992 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8993 PL_perldb = proto_perl->Iperldb;
8994 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8995
8996 /* magical thingies */
8997 /* XXX time(&PL_basetime) when asked for? */
8998 PL_basetime = proto_perl->Ibasetime;
8999 PL_formfeed = sv_dup(proto_perl->Iformfeed);
9000
9001 PL_maxsysfd = proto_perl->Imaxsysfd;
9002 PL_multiline = proto_perl->Imultiline;
9003 PL_statusvalue = proto_perl->Istatusvalue;
9004#ifdef VMS
9005 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9006#endif
9007
9008 /* shortcuts to various I/O objects */
9009 PL_stdingv = gv_dup(proto_perl->Istdingv);
9010 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
9011 PL_defgv = gv_dup(proto_perl->Idefgv);
9012 PL_argvgv = gv_dup(proto_perl->Iargvgv);
9013 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
f25c30a3 9014 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
1d7c1841
GS		 9015
9016 /* shortcuts to regexp stuff */
9017 PL_replgv = gv_dup(proto_perl->Ireplgv);
9018
9019 /* shortcuts to misc objects */
9020 PL_errgv = gv_dup(proto_perl->Ierrgv);
9021
9022 /* shortcuts to debugging objects */
9023 PL_DBgv = gv_dup(proto_perl->IDBgv);
9024 PL_DBline = gv_dup(proto_perl->IDBline);
9025 PL_DBsub = gv_dup(proto_perl->IDBsub);
9026 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
9027 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
9028 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
9029 PL_lineary = av_dup(proto_perl->Ilineary);
9030 PL_dbargs = av_dup(proto_perl->Idbargs);
9031
9032 /* symbol tables */
9033 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
9034 PL_curstash = hv_dup(proto_perl->Tcurstash);
9035 PL_debstash = hv_dup(proto_perl->Idebstash);
9036 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
9037 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
9038
9039 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
9040 PL_endav = av_dup_inc(proto_perl->Iendav);
7d30b5c4 9041 PL_checkav = av_dup_inc(proto_perl->Icheckav);
1d7c1841
GS		 9042 PL_initav = av_dup_inc(proto_perl->Iinitav);
9043
9044 PL_sub_generation = proto_perl->Isub_generation;
9045
9046 /* funky return mechanisms */
9047 PL_forkprocess = proto_perl->Iforkprocess;
9048
9049 /* subprocess state */
9050 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
9051
9052 /* internal state */
9053 PL_tainting = proto_perl->Itainting;
9054 PL_maxo = proto_perl->Imaxo;
9055 if (proto_perl->Iop_mask)
9056 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9057 else
9058 PL_op_mask = Nullch;
9059
9060 /* current interpreter roots */
9061 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
9062 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9063 PL_main_start = proto_perl->Imain_start;
e977893f 9064 PL_eval_root = proto_perl->Ieval_root;
1d7c1841
GS		 9065 PL_eval_start = proto_perl->Ieval_start;
9066
9067 /* runtime control stuff */
9068 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9069 PL_copline = proto_perl->Icopline;
9070
9071 PL_filemode = proto_perl->Ifilemode;
9072 PL_lastfd = proto_perl->Ilastfd;
9073 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9074 PL_Argv = NULL;
9075 PL_Cmd = Nullch;
9076 PL_gensym = proto_perl->Igensym;
9077 PL_preambled = proto_perl->Ipreambled;
9078 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
9079 PL_laststatval = proto_perl->Ilaststatval;
9080 PL_laststype = proto_perl->Ilaststype;
9081 PL_mess_sv = Nullsv;
9082
7889fe52 9083 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
1d7c1841
GS		 9084 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9085
9086 /* interpreter atexit processing */
9087 PL_exitlistlen = proto_perl->Iexitlistlen;
9088 if (PL_exitlistlen) {
9089 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9090 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9091 }
9092 else
9093 PL_exitlist = (PerlExitListEntry*)NULL;
9094 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
9095
9096 PL_profiledata = NULL;
9097 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9098 /* PL_rsfp_filters entries have fake IoDIRP() */
9099 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
9100
9101 PL_compcv = cv_dup(proto_perl->Icompcv);
9102 PL_comppad = av_dup(proto_perl->Icomppad);
9103 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
9104 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9105 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9106 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9107 proto_perl->Tcurpad);
9108
9109#ifdef HAVE_INTERP_INTERN
9110 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9111#endif
9112
9113 /* more statics moved here */
9114 PL_generation = proto_perl->Igeneration;
9115 PL_DBcv = cv_dup(proto_perl->IDBcv);
1d7c1841
GS		 9116
9117 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9118 PL_in_clean_all = proto_perl->Iin_clean_all;
9119
9120 PL_uid = proto_perl->Iuid;
9121 PL_euid = proto_perl->Ieuid;
9122 PL_gid = proto_perl->Igid;
9123 PL_egid = proto_perl->Iegid;
9124 PL_nomemok = proto_perl->Inomemok;
9125 PL_an = proto_perl->Ian;
9126 PL_cop_seqmax = proto_perl->Icop_seqmax;
9127 PL_op_seqmax = proto_perl->Iop_seqmax;
9128 PL_evalseq = proto_perl->Ievalseq;
9129 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9130 PL_origalen = proto_perl->Iorigalen;
9131 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9132 PL_osname = SAVEPV(proto_perl->Iosname);
9133 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9134 PL_sighandlerp = proto_perl->Isighandlerp;
9135
9136
9137 PL_runops = proto_perl->Irunops;
9138
9139 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9140
9141#ifdef CSH
9142 PL_cshlen = proto_perl->Icshlen;
9143 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9144#endif
9145
9146 PL_lex_state = proto_perl->Ilex_state;
9147 PL_lex_defer = proto_perl->Ilex_defer;
9148 PL_lex_expect = proto_perl->Ilex_expect;
9149 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9150 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9151 PL_lex_starts = proto_perl->Ilex_starts;
9152 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9153 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9154 PL_lex_op = proto_perl->Ilex_op;
9155 PL_lex_inpat = proto_perl->Ilex_inpat;
9156 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9157 PL_lex_brackets = proto_perl->Ilex_brackets;
9158 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9159 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9160 PL_lex_casemods = proto_perl->Ilex_casemods;
9161 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9162 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9163
9164 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9165 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9166 PL_nexttoke = proto_perl->Inexttoke;
9167
9168 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9169 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9170 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9171 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9172 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9173 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9174 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9175 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9176 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9177 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9178 PL_pending_ident = proto_perl->Ipending_ident;
9179 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9180
9181 PL_expect = proto_perl->Iexpect;
9182
9183 PL_multi_start = proto_perl->Imulti_start;
9184 PL_multi_end = proto_perl->Imulti_end;
9185 PL_multi_open = proto_perl->Imulti_open;
9186 PL_multi_close = proto_perl->Imulti_close;
9187
9188 PL_error_count = proto_perl->Ierror_count;
9189 PL_subline = proto_perl->Isubline;
9190 PL_subname = sv_dup_inc(proto_perl->Isubname);
9191
9192 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9193 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9194 PL_padix = proto_perl->Ipadix;
9195 PL_padix_floor = proto_perl->Ipadix_floor;
9196 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9197
9198 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9199 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9200 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9201 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9202 PL_last_lop_op = proto_perl->Ilast_lop_op;
9203 PL_in_my = proto_perl->Iin_my;
9204 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9205#ifdef FCRYPT
9206 PL_cryptseen = proto_perl->Icryptseen;
9207#endif
9208
9209 PL_hints = proto_perl->Ihints;
9210
9211 PL_amagic_generation = proto_perl->Iamagic_generation;
9212
9213#ifdef USE_LOCALE_COLLATE
9214 PL_collation_ix = proto_perl->Icollation_ix;
9215 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9216 PL_collation_standard = proto_perl->Icollation_standard;
9217 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9218 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9219#endif /* USE_LOCALE_COLLATE */
9220
9221#ifdef USE_LOCALE_NUMERIC
9222 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9223 PL_numeric_standard = proto_perl->Inumeric_standard;
9224 PL_numeric_local = proto_perl->Inumeric_local;
a453c169 9225 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
1d7c1841
GS		 9226#endif /* !USE_LOCALE_NUMERIC */
9227
9228 /* utf8 character classes */
9229 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9230 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9231 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9232 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9233 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9234 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9235 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9236 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9237 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9238 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9239 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9240 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9241 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9242 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9243 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9244 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9245 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9246
9247 /* swatch cache */
9248 PL_last_swash_hv = Nullhv; /* reinits on demand */
9249 PL_last_swash_klen = 0;
9250 PL_last_swash_key[0]= '\0';
9251 PL_last_swash_tmps = (U8*)NULL;
9252 PL_last_swash_slen = 0;
9253
9254 /* perly.c globals */
9255 PL_yydebug = proto_perl->Iyydebug;
9256 PL_yynerrs = proto_perl->Iyynerrs;
9257 PL_yyerrflag = proto_perl->Iyyerrflag;
9258 PL_yychar = proto_perl->Iyychar;
9259 PL_yyval = proto_perl->Iyyval;
9260 PL_yylval = proto_perl->Iyylval;
9261
9262 PL_glob_index = proto_perl->Iglob_index;
9263 PL_srand_called = proto_perl->Isrand_called;
9264 PL_uudmap['M'] = 0; /* reinits on demand */
9265 PL_bitcount = Nullch; /* reinits on demand */
9266
66fe0623
NIS		 9267 if (proto_perl->Ipsig_pend) {
9268 Newz(0, PL_psig_pend, SIG_SIZE, int);
9dd79c3f 9269 }
66fe0623
NIS		 9270 else {
9271 PL_psig_pend = (int*)NULL;
9272 }
9273
1d7c1841 9274 if (proto_perl->Ipsig_ptr) {
76d3c696
JH		 9275 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9276 Newz(0, PL_psig_name, SIG_SIZE, SV*);
76d3c696
JH		 9277 for (i = 1; i < SIG_SIZE; i++) {
9278 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
1d7c1841
GS		 9279 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9280 }
9281 }
9282 else {
9283 PL_psig_ptr = (SV**)NULL;
9284 PL_psig_name = (SV**)NULL;
9285 }
9286
9287 /* thrdvar.h stuff */
9288
a0739874 9289 if (flags & CLONEf_COPY_STACKS) {
1d7c1841
GS		 9290 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9291 PL_tmps_ix = proto_perl->Ttmps_ix;
9292 PL_tmps_max = proto_perl->Ttmps_max;
9293 PL_tmps_floor = proto_perl->Ttmps_floor;
9294 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9295 i = 0;
9296 while (i <= PL_tmps_ix) {
9297 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9298 ++i;
9299 }
9300
9301 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9302 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9303 Newz(54, PL_markstack, i, I32);
9304 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9305 - proto_perl->Tmarkstack);
9306 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9307 - proto_perl->Tmarkstack);
9308 Copy(proto_perl->Tmarkstack, PL_markstack,
9309 PL_markstack_ptr - PL_markstack + 1, I32);
9310
9311 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9312 * NOTE: unlike the others! */
9313 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9314 PL_scopestack_max = proto_perl->Tscopestack_max;
9315 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9316 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9317
9318 /* next push_return() sets PL_retstack[PL_retstack_ix]
9319 * NOTE: unlike the others! */
9320 PL_retstack_ix = proto_perl->Tretstack_ix;
9321 PL_retstack_max = proto_perl->Tretstack_max;
9322 Newz(54, PL_retstack, PL_retstack_max, OP*);
9323 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9324
9325 /* NOTE: si_dup() looks at PL_markstack */
9326 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9327
9328 /* PL_curstack = PL_curstackinfo->si_stack; */
9329 PL_curstack = av_dup(proto_perl->Tcurstack);
9330 PL_mainstack = av_dup(proto_perl->Tmainstack);
9331
9332 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9333 PL_stack_base = AvARRAY(PL_curstack);
9334 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9335 - proto_perl->Tstack_base);
9336 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9337
9338 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9339 * NOTE: unlike the others! */
9340 PL_savestack_ix = proto_perl->Tsavestack_ix;
9341 PL_savestack_max = proto_perl->Tsavestack_max;
9342 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9343 PL_savestack = ss_dup(proto_perl);
9344 }
9345 else {
9346 init_stacks();
985e7056 9347 ENTER; /* perl_destruct() wants to LEAVE; */
1d7c1841
GS		 9348 }
9349
9350 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9351 PL_top_env = &PL_start_env;
9352
9353 PL_op = proto_perl->Top;
9354
9355 PL_Sv = Nullsv;
9356 PL_Xpv = (XPV*)NULL;
9357 PL_na = proto_perl->Tna;
9358
9359 PL_statbuf = proto_perl->Tstatbuf;
9360 PL_statcache = proto_perl->Tstatcache;
9361 PL_statgv = gv_dup(proto_perl->Tstatgv);
9362 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9363#ifdef HAS_TIMES
9364 PL_timesbuf = proto_perl->Ttimesbuf;
9365#endif
9366
9367 PL_tainted = proto_perl->Ttainted;
9368 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9369 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9370 PL_rs = sv_dup_inc(proto_perl->Trs);
9371 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7889fe52 9372 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
1d7c1841
GS		 9373 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9374 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9375 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9376 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9377 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9378
9379 PL_restartop = proto_perl->Trestartop;
9380 PL_in_eval = proto_perl->Tin_eval;
9381 PL_delaymagic = proto_perl->Tdelaymagic;
9382 PL_dirty = proto_perl->Tdirty;
9383 PL_localizing = proto_perl->Tlocalizing;
9384
14dd3ad8 9385#ifdef PERL_FLEXIBLE_EXCEPTIONS
1d7c1841 9386 PL_protect = proto_perl->Tprotect;
14dd3ad8 9387#endif
1d7c1841
GS		 9388 PL_errors = sv_dup_inc(proto_perl->Terrors);
9389 PL_av_fetch_sv = Nullsv;
9390 PL_hv_fetch_sv = Nullsv;
9391 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9392 PL_modcount = proto_perl->Tmodcount;
9393 PL_lastgotoprobe = Nullop;
9394 PL_dumpindent = proto_perl->Tdumpindent;
9395
9396 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9397 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9398 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9399 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9400 PL_sortcxix = proto_perl->Tsortcxix;
9401 PL_efloatbuf = Nullch; /* reinits on demand */
9402 PL_efloatsize = 0; /* reinits on demand */
9403
9404 /* regex stuff */
9405
9406 PL_screamfirst = NULL;
9407 PL_screamnext = NULL;
9408 PL_maxscream = -1; /* reinits on demand */
9409 PL_lastscream = Nullsv;
9410
9411 PL_watchaddr = NULL;
9412 PL_watchok = Nullch;
9413
9414 PL_regdummy = proto_perl->Tregdummy;
9415 PL_regcomp_parse = Nullch;
9416 PL_regxend = Nullch;
9417 PL_regcode = (regnode*)NULL;
9418 PL_regnaughty = 0;
9419 PL_regsawback = 0;
9420 PL_regprecomp = Nullch;
9421 PL_regnpar = 0;
9422 PL_regsize = 0;
9423 PL_regflags = 0;
9424 PL_regseen = 0;
9425 PL_seen_zerolen = 0;
9426 PL_seen_evals = 0;
9427 PL_regcomp_rx = (regexp*)NULL;
9428 PL_extralen = 0;
9429 PL_colorset = 0; /* reinits PL_colors[] */
9430 /*PL_colors[6] = {0,0,0,0,0,0};*/
9431 PL_reg_whilem_seen = 0;
9432 PL_reginput = Nullch;
9433 PL_regbol = Nullch;
9434 PL_regeol = Nullch;
9435 PL_regstartp = (I32*)NULL;
9436 PL_regendp = (I32*)NULL;
9437 PL_reglastparen = (U32*)NULL;
9438 PL_regtill = Nullch;
1d7c1841
GS		 9439 PL_reg_start_tmp = (char**)NULL;
9440 PL_reg_start_tmpl = 0;
9441 PL_regdata = (struct reg_data*)NULL;
9442 PL_bostr = Nullch;
9443 PL_reg_flags = 0;
9444 PL_reg_eval_set = 0;
9445 PL_regnarrate = 0;
9446 PL_regprogram = (regnode*)NULL;
9447 PL_regindent = 0;
9448 PL_regcc = (CURCUR*)NULL;
9449 PL_reg_call_cc = (struct re_cc_state*)NULL;
9450 PL_reg_re = (regexp*)NULL;
9451 PL_reg_ganch = Nullch;
9452 PL_reg_sv = Nullsv;
9453 PL_reg_magic = (MAGIC*)NULL;
9454 PL_reg_oldpos = 0;
9455 PL_reg_oldcurpm = (PMOP*)NULL;
9456 PL_reg_curpm = (PMOP*)NULL;
9457 PL_reg_oldsaved = Nullch;
9458 PL_reg_oldsavedlen = 0;
9459 PL_reg_maxiter = 0;
9460 PL_reg_leftiter = 0;
9461 PL_reg_poscache = Nullch;
9462 PL_reg_poscache_size= 0;
9463
9464 /* RE engine - function pointers */
9465 PL_regcompp = proto_perl->Tregcompp;
9466 PL_regexecp = proto_perl->Tregexecp;
9467 PL_regint_start = proto_perl->Tregint_start;
9468 PL_regint_string = proto_perl->Tregint_string;
9469 PL_regfree = proto_perl->Tregfree;
9470
9471 PL_reginterp_cnt = 0;
9472 PL_reg_starttry = 0;
9473
a0739874
DM		 9474 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9475 ptr_table_free(PL_ptr_table);
9476 PL_ptr_table = NULL;
9477 }
9478
1d7c1841
GS		 9479#ifdef PERL_OBJECT
9480 return (PerlInterpreter*)pPerl;
9481#else
9482 return my_perl;
9483#endif
9484}
9485
9486#else /* !USE_ITHREADS */
51371543
GS		 9487
9488#ifdef PERL_OBJECT
51371543
GS		 9489#include "XSUB.h"
9490#endif
9491
1d7c1841
GS		 9492#endif /* USE_ITHREADS */
9493
51371543
GS		 9494static void
9495do_report_used(pTHXo_ SV *sv)
9496{
9497 if (SvTYPE(sv) != SVTYPEMASK) {
bf49b057 9498 PerlIO_printf(Perl_debug_log, "****\n");
51371543
GS		 9499 sv_dump(sv);
9500 }
9501}
9502
9503static void
9504do_clean_objs(pTHXo_ SV *sv)
9505{
9506 SV* rv;
9507
9508 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5f80b19c 9509 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
8b6e653b
HS		 9510 if (SvWEAKREF(sv)) {
9511 sv_del_backref(sv);
9512 SvWEAKREF_off(sv);
9513 SvRV(sv) = 0;
9514 } else {
9515 SvROK_off(sv);
9516 SvRV(sv) = 0;
9517 SvREFCNT_dec(rv);
9518 }
51371543
GS		 9519 }
9520
9521 /* XXX Might want to check arrays, etc. */
9522}
9523
9524#ifndef DISABLE_DESTRUCTOR_KLUDGE
9525static void
9526do_clean_named_objs(pTHXo_ SV *sv)
9527{
f472eb5c 9528 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
51371543 9529 if ( SvOBJECT(GvSV(sv)) ||
155aba94
GS		 9530 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9531 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9532 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9533 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
51371543 9534 {
5f80b19c 9535 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
51371543
GS		 9536 SvREFCNT_dec(sv);
9537 }
9538 }
9539}
9540#endif
9541
9542static void
9543do_clean_all(pTHXo_ SV *sv)
9544{
5f80b19c 9545 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
51371543
GS		 9546 SvFLAGS(sv) |= SVf_BREAK;
9547 SvREFCNT_dec(sv);
9548}
8af02333 9549
Unnamed repository; edit this file 'description' to name the repository.