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