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