3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
27 #ifdef PERL_UTF8_CACHE_ASSERT
28 /* The cache element 0 is the Unicode offset;
29 * the cache element 1 is the byte offset of the element 0;
30 * the cache element 2 is the Unicode length of the substring;
31 * the cache element 3 is the byte length of the substring;
32 * The checking of the substring side would be good
33 * but substr() has enough code paths to make my head spin;
34 * if adding more checks watch out for the following tests:
35 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
36 * lib/utf8.t lib/Unicode/Collate/t/index.t
39 #define ASSERT_UTF8_CACHE(cache) \
40 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
42 #define ASSERT_UTF8_CACHE(cache) NOOP
45 #ifdef PERL_COPY_ON_WRITE
46 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
47 #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
48 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
52 /* ============================================================================
54 =head1 Allocation and deallocation of SVs.
56 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
57 av, hv...) contains type and reference count information, as well as a
58 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
59 specific to each type.
61 Normally, this allocation is done using arenas, which are approximately
62 1K chunks of memory parcelled up into N heads or bodies. The first slot
63 in each arena is reserved, and is used to hold a link to the next arena.
64 In the case of heads, the unused first slot also contains some flags and
65 a note of the number of slots. Snaked through each arena chain is a
66 linked list of free items; when this becomes empty, an extra arena is
67 allocated and divided up into N items which are threaded into the free
70 The following global variables are associated with arenas:
72 PL_sv_arenaroot pointer to list of SV arenas
73 PL_sv_root pointer to list of free SV structures
75 PL_foo_arenaroot pointer to list of foo arenas,
76 PL_foo_root pointer to list of free foo bodies
77 ... for foo in xiv, xnv, xrv, xpv etc.
79 Note that some of the larger and more rarely used body types (eg xpvio)
80 are not allocated using arenas, but are instead just malloc()/free()ed as
81 required. Also, if PURIFY is defined, arenas are abandoned altogether,
82 with all items individually malloc()ed. In addition, a few SV heads are
83 not allocated from an arena, but are instead directly created as static
84 or auto variables, eg PL_sv_undef.
86 The SV arena serves the secondary purpose of allowing still-live SVs
87 to be located and destroyed during final cleanup.
89 At the lowest level, the macros new_SV() and del_SV() grab and free
90 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
91 to return the SV to the free list with error checking.) new_SV() calls
92 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
93 SVs in the free list have their SvTYPE field set to all ones.
95 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
96 that allocate and return individual body types. Normally these are mapped
97 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
98 instead mapped directly to malloc()/free() if PURIFY is defined. The
99 new/del functions remove from, or add to, the appropriate PL_foo_root
100 list, and call more_xiv() etc to add a new arena if the list is empty.
102 At the time of very final cleanup, sv_free_arenas() is called from
103 perl_destruct() to physically free all the arenas allocated since the
104 start of the interpreter. Note that this also clears PL_he_arenaroot,
105 which is otherwise dealt with in hv.c.
107 Manipulation of any of the PL_*root pointers is protected by enclosing
108 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
109 if threads are enabled.
111 The function visit() scans the SV arenas list, and calls a specified
112 function for each SV it finds which is still live - ie which has an SvTYPE
113 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
114 following functions (specified as [function that calls visit()] / [function
115 called by visit() for each SV]):
117 sv_report_used() / do_report_used()
118 dump all remaining SVs (debugging aid)
120 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
121 Attempt to free all objects pointed to by RVs,
122 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
123 try to do the same for all objects indirectly
124 referenced by typeglobs too. Called once from
125 perl_destruct(), prior to calling sv_clean_all()
128 sv_clean_all() / do_clean_all()
129 SvREFCNT_dec(sv) each remaining SV, possibly
130 triggering an sv_free(). It also sets the
131 SVf_BREAK flag on the SV to indicate that the
132 refcnt has been artificially lowered, and thus
133 stopping sv_free() from giving spurious warnings
134 about SVs which unexpectedly have a refcnt
135 of zero. called repeatedly from perl_destruct()
136 until there are no SVs left.
140 Private API to rest of sv.c
144 new_XIV(), del_XIV(),
145 new_XNV(), del_XNV(),
150 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
155 ============================================================================ */
160 * "A time to plant, and a time to uproot what was planted..."
163 #define plant_SV(p) \
165 SvANY(p) = (void *)PL_sv_root; \
166 SvFLAGS(p) = SVTYPEMASK; \
171 /* sv_mutex must be held while calling uproot_SV() */
172 #define uproot_SV(p) \
175 PL_sv_root = (SV*)SvANY(p); \
180 /* new_SV(): return a new, empty SV head */
182 #ifdef DEBUG_LEAKING_SCALARS
183 /* provide a real function for a debugger to play with */
200 # define new_SV(p) (p)=S_new_SV(aTHX)
218 /* del_SV(): return an empty SV head to the free list */
233 S_del_sv(pTHX_ SV *p)
240 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
242 svend = &sva[SvREFCNT(sva)];
243 if (p >= sv && p < svend)
247 if (ckWARN_d(WARN_INTERNAL))
248 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
249 "Attempt to free non-arena SV: 0x%"UVxf,
257 #else /* ! DEBUGGING */
259 #define del_SV(p) plant_SV(p)
261 #endif /* DEBUGGING */
265 =head1 SV Manipulation Functions
267 =for apidoc sv_add_arena
269 Given a chunk of memory, link it to the head of the list of arenas,
270 and split it into a list of free SVs.
276 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
281 Zero(ptr, size, char);
283 /* The first SV in an arena isn't an SV. */
284 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
285 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
286 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
288 PL_sv_arenaroot = sva;
289 PL_sv_root = sva + 1;
291 svend = &sva[SvREFCNT(sva) - 1];
294 SvANY(sv) = (void *)(SV*)(sv + 1);
295 SvFLAGS(sv) = SVTYPEMASK;
299 SvFLAGS(sv) = SVTYPEMASK;
302 /* make some more SVs by adding another arena */
304 /* sv_mutex must be held while calling more_sv() */
311 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
312 PL_nice_chunk = Nullch;
313 PL_nice_chunk_size = 0;
316 char *chunk; /* must use New here to match call to */
317 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
318 sv_add_arena(chunk, 1008, 0);
324 /* visit(): call the named function for each non-free SV in the arenas. */
327 S_visit(pTHX_ SVFUNC_t f)
334 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
335 svend = &sva[SvREFCNT(sva)];
336 for (sv = sva + 1; sv < svend; ++sv) {
337 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
348 /* called by sv_report_used() for each live SV */
351 do_report_used(pTHX_ SV *sv)
353 if (SvTYPE(sv) != SVTYPEMASK) {
354 PerlIO_printf(Perl_debug_log, "****\n");
361 =for apidoc sv_report_used
363 Dump the contents of all SVs not yet freed. (Debugging aid).
369 Perl_sv_report_used(pTHX)
372 visit(do_report_used);
376 /* called by sv_clean_objs() for each live SV */
379 do_clean_objs(pTHX_ SV *sv)
383 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
384 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
396 /* XXX Might want to check arrays, etc. */
399 /* called by sv_clean_objs() for each live SV */
401 #ifndef DISABLE_DESTRUCTOR_KLUDGE
403 do_clean_named_objs(pTHX_ SV *sv)
405 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
406 if ( SvOBJECT(GvSV(sv)) ||
407 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
408 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
409 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
410 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
412 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
420 =for apidoc sv_clean_objs
422 Attempt to destroy all objects not yet freed
428 Perl_sv_clean_objs(pTHX)
430 PL_in_clean_objs = TRUE;
431 visit(do_clean_objs);
432 #ifndef DISABLE_DESTRUCTOR_KLUDGE
433 /* some barnacles may yet remain, clinging to typeglobs */
434 visit(do_clean_named_objs);
436 PL_in_clean_objs = FALSE;
439 /* called by sv_clean_all() for each live SV */
442 do_clean_all(pTHX_ SV *sv)
444 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
445 SvFLAGS(sv) |= SVf_BREAK;
450 =for apidoc sv_clean_all
452 Decrement the refcnt of each remaining SV, possibly triggering a
453 cleanup. This function may have to be called multiple times to free
454 SVs which are in complex self-referential hierarchies.
460 Perl_sv_clean_all(pTHX)
463 PL_in_clean_all = TRUE;
464 cleaned = visit(do_clean_all);
465 PL_in_clean_all = FALSE;
470 =for apidoc sv_free_arenas
472 Deallocate the memory used by all arenas. Note that all the individual SV
473 heads and bodies within the arenas must already have been freed.
479 Perl_sv_free_arenas(pTHX)
483 XPV *arena, *arenanext;
485 /* Free arenas here, but be careful about fake ones. (We assume
486 contiguity of the fake ones with the corresponding real ones.) */
488 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
489 svanext = (SV*) SvANY(sva);
490 while (svanext && SvFAKE(svanext))
491 svanext = (SV*) SvANY(svanext);
494 Safefree((void *)sva);
497 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
498 arenanext = (XPV*)arena->xpv_pv;
501 PL_xiv_arenaroot = 0;
503 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
504 arenanext = (XPV*)arena->xpv_pv;
507 PL_xnv_arenaroot = 0;
509 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
510 arenanext = (XPV*)arena->xpv_pv;
513 PL_xrv_arenaroot = 0;
515 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
516 arenanext = (XPV*)arena->xpv_pv;
519 PL_xpv_arenaroot = 0;
521 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
522 arenanext = (XPV*)arena->xpv_pv;
525 PL_xpviv_arenaroot = 0;
527 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
528 arenanext = (XPV*)arena->xpv_pv;
531 PL_xpvnv_arenaroot = 0;
533 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
534 arenanext = (XPV*)arena->xpv_pv;
537 PL_xpvcv_arenaroot = 0;
539 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
540 arenanext = (XPV*)arena->xpv_pv;
543 PL_xpvav_arenaroot = 0;
545 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
546 arenanext = (XPV*)arena->xpv_pv;
549 PL_xpvhv_arenaroot = 0;
551 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
552 arenanext = (XPV*)arena->xpv_pv;
555 PL_xpvmg_arenaroot = 0;
557 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
558 arenanext = (XPV*)arena->xpv_pv;
561 PL_xpvlv_arenaroot = 0;
563 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
564 arenanext = (XPV*)arena->xpv_pv;
567 PL_xpvbm_arenaroot = 0;
569 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
570 arenanext = (XPV*)arena->xpv_pv;
576 Safefree(PL_nice_chunk);
577 PL_nice_chunk = Nullch;
578 PL_nice_chunk_size = 0;
584 =for apidoc report_uninit
586 Print appropriate "Use of uninitialized variable" warning
592 Perl_report_uninit(pTHX)
595 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
596 " in ", OP_DESC(PL_op));
598 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
601 /* grab a new IV body from the free list, allocating more if necessary */
612 * See comment in more_xiv() -- RAM.
614 PL_xiv_root = *(IV**)xiv;
616 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
619 /* return an IV body to the free list */
622 S_del_xiv(pTHX_ XPVIV *p)
624 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
626 *(IV**)xiv = PL_xiv_root;
631 /* allocate another arena's worth of IV bodies */
639 New(705, ptr, 1008/sizeof(XPV), XPV);
640 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
641 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
644 xivend = &xiv[1008 / sizeof(IV) - 1];
645 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
647 while (xiv < xivend) {
648 *(IV**)xiv = (IV *)(xiv + 1);
654 /* grab a new NV body from the free list, allocating more if necessary */
664 PL_xnv_root = *(NV**)xnv;
666 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
669 /* return an NV body to the free list */
672 S_del_xnv(pTHX_ XPVNV *p)
674 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
676 *(NV**)xnv = PL_xnv_root;
681 /* allocate another arena's worth of NV bodies */
689 New(711, ptr, 1008/sizeof(XPV), XPV);
690 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
691 PL_xnv_arenaroot = ptr;
694 xnvend = &xnv[1008 / sizeof(NV) - 1];
695 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
697 while (xnv < xnvend) {
698 *(NV**)xnv = (NV*)(xnv + 1);
704 /* grab a new struct xrv from the free list, allocating more if necessary */
714 PL_xrv_root = (XRV*)xrv->xrv_rv;
719 /* return a struct xrv to the free list */
722 S_del_xrv(pTHX_ XRV *p)
725 p->xrv_rv = (SV*)PL_xrv_root;
730 /* allocate another arena's worth of struct xrv */
736 register XRV* xrvend;
738 New(712, ptr, 1008/sizeof(XPV), XPV);
739 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
740 PL_xrv_arenaroot = ptr;
743 xrvend = &xrv[1008 / sizeof(XRV) - 1];
744 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
746 while (xrv < xrvend) {
747 xrv->xrv_rv = (SV*)(xrv + 1);
753 /* grab a new struct xpv from the free list, allocating more if necessary */
763 PL_xpv_root = (XPV*)xpv->xpv_pv;
768 /* return a struct xpv to the free list */
771 S_del_xpv(pTHX_ XPV *p)
774 p->xpv_pv = (char*)PL_xpv_root;
779 /* allocate another arena's worth of struct xpv */
785 register XPV* xpvend;
786 New(713, xpv, 1008/sizeof(XPV), XPV);
787 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
788 PL_xpv_arenaroot = xpv;
790 xpvend = &xpv[1008 / sizeof(XPV) - 1];
792 while (xpv < xpvend) {
793 xpv->xpv_pv = (char*)(xpv + 1);
799 /* grab a new struct xpviv from the free list, allocating more if necessary */
808 xpviv = PL_xpviv_root;
809 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
814 /* return a struct xpviv to the free list */
817 S_del_xpviv(pTHX_ XPVIV *p)
820 p->xpv_pv = (char*)PL_xpviv_root;
825 /* allocate another arena's worth of struct xpviv */
830 register XPVIV* xpviv;
831 register XPVIV* xpvivend;
832 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
833 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
834 PL_xpviv_arenaroot = xpviv;
836 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
837 PL_xpviv_root = ++xpviv;
838 while (xpviv < xpvivend) {
839 xpviv->xpv_pv = (char*)(xpviv + 1);
845 /* grab a new struct xpvnv from the free list, allocating more if necessary */
854 xpvnv = PL_xpvnv_root;
855 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
860 /* return a struct xpvnv to the free list */
863 S_del_xpvnv(pTHX_ XPVNV *p)
866 p->xpv_pv = (char*)PL_xpvnv_root;
871 /* allocate another arena's worth of struct xpvnv */
876 register XPVNV* xpvnv;
877 register XPVNV* xpvnvend;
878 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
879 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
880 PL_xpvnv_arenaroot = xpvnv;
882 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
883 PL_xpvnv_root = ++xpvnv;
884 while (xpvnv < xpvnvend) {
885 xpvnv->xpv_pv = (char*)(xpvnv + 1);
891 /* grab a new struct xpvcv from the free list, allocating more if necessary */
900 xpvcv = PL_xpvcv_root;
901 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
906 /* return a struct xpvcv to the free list */
909 S_del_xpvcv(pTHX_ XPVCV *p)
912 p->xpv_pv = (char*)PL_xpvcv_root;
917 /* allocate another arena's worth of struct xpvcv */
922 register XPVCV* xpvcv;
923 register XPVCV* xpvcvend;
924 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
925 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
926 PL_xpvcv_arenaroot = xpvcv;
928 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
929 PL_xpvcv_root = ++xpvcv;
930 while (xpvcv < xpvcvend) {
931 xpvcv->xpv_pv = (char*)(xpvcv + 1);
937 /* grab a new struct xpvav from the free list, allocating more if necessary */
946 xpvav = PL_xpvav_root;
947 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
952 /* return a struct xpvav to the free list */
955 S_del_xpvav(pTHX_ XPVAV *p)
958 p->xav_array = (char*)PL_xpvav_root;
963 /* allocate another arena's worth of struct xpvav */
968 register XPVAV* xpvav;
969 register XPVAV* xpvavend;
970 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
971 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
972 PL_xpvav_arenaroot = xpvav;
974 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
975 PL_xpvav_root = ++xpvav;
976 while (xpvav < xpvavend) {
977 xpvav->xav_array = (char*)(xpvav + 1);
980 xpvav->xav_array = 0;
983 /* grab a new struct xpvhv from the free list, allocating more if necessary */
992 xpvhv = PL_xpvhv_root;
993 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
998 /* return a struct xpvhv to the free list */
1001 S_del_xpvhv(pTHX_ XPVHV *p)
1004 p->xhv_array = (char*)PL_xpvhv_root;
1009 /* allocate another arena's worth of struct xpvhv */
1014 register XPVHV* xpvhv;
1015 register XPVHV* xpvhvend;
1016 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1017 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1018 PL_xpvhv_arenaroot = xpvhv;
1020 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1021 PL_xpvhv_root = ++xpvhv;
1022 while (xpvhv < xpvhvend) {
1023 xpvhv->xhv_array = (char*)(xpvhv + 1);
1026 xpvhv->xhv_array = 0;
1029 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1038 xpvmg = PL_xpvmg_root;
1039 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1044 /* return a struct xpvmg to the free list */
1047 S_del_xpvmg(pTHX_ XPVMG *p)
1050 p->xpv_pv = (char*)PL_xpvmg_root;
1055 /* allocate another arena's worth of struct xpvmg */
1060 register XPVMG* xpvmg;
1061 register XPVMG* xpvmgend;
1062 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1063 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1064 PL_xpvmg_arenaroot = xpvmg;
1066 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1067 PL_xpvmg_root = ++xpvmg;
1068 while (xpvmg < xpvmgend) {
1069 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1075 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1084 xpvlv = PL_xpvlv_root;
1085 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1090 /* return a struct xpvlv to the free list */
1093 S_del_xpvlv(pTHX_ XPVLV *p)
1096 p->xpv_pv = (char*)PL_xpvlv_root;
1101 /* allocate another arena's worth of struct xpvlv */
1106 register XPVLV* xpvlv;
1107 register XPVLV* xpvlvend;
1108 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1109 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1110 PL_xpvlv_arenaroot = xpvlv;
1112 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1113 PL_xpvlv_root = ++xpvlv;
1114 while (xpvlv < xpvlvend) {
1115 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1121 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1130 xpvbm = PL_xpvbm_root;
1131 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1136 /* return a struct xpvbm to the free list */
1139 S_del_xpvbm(pTHX_ XPVBM *p)
1142 p->xpv_pv = (char*)PL_xpvbm_root;
1147 /* allocate another arena's worth of struct xpvbm */
1152 register XPVBM* xpvbm;
1153 register XPVBM* xpvbmend;
1154 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1155 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1156 PL_xpvbm_arenaroot = xpvbm;
1158 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1159 PL_xpvbm_root = ++xpvbm;
1160 while (xpvbm < xpvbmend) {
1161 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1167 #define my_safemalloc(s) (void*)safemalloc(s)
1168 #define my_safefree(p) safefree((char*)p)
1172 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1173 #define del_XIV(p) my_safefree(p)
1175 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1176 #define del_XNV(p) my_safefree(p)
1178 #define new_XRV() my_safemalloc(sizeof(XRV))
1179 #define del_XRV(p) my_safefree(p)
1181 #define new_XPV() my_safemalloc(sizeof(XPV))
1182 #define del_XPV(p) my_safefree(p)
1184 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1185 #define del_XPVIV(p) my_safefree(p)
1187 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1188 #define del_XPVNV(p) my_safefree(p)
1190 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1191 #define del_XPVCV(p) my_safefree(p)
1193 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1194 #define del_XPVAV(p) my_safefree(p)
1196 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1197 #define del_XPVHV(p) my_safefree(p)
1199 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1200 #define del_XPVMG(p) my_safefree(p)
1202 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1203 #define del_XPVLV(p) my_safefree(p)
1205 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1206 #define del_XPVBM(p) my_safefree(p)
1210 #define new_XIV() (void*)new_xiv()
1211 #define del_XIV(p) del_xiv((XPVIV*) p)
1213 #define new_XNV() (void*)new_xnv()
1214 #define del_XNV(p) del_xnv((XPVNV*) p)
1216 #define new_XRV() (void*)new_xrv()
1217 #define del_XRV(p) del_xrv((XRV*) p)
1219 #define new_XPV() (void*)new_xpv()
1220 #define del_XPV(p) del_xpv((XPV *)p)
1222 #define new_XPVIV() (void*)new_xpviv()
1223 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1225 #define new_XPVNV() (void*)new_xpvnv()
1226 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1228 #define new_XPVCV() (void*)new_xpvcv()
1229 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1231 #define new_XPVAV() (void*)new_xpvav()
1232 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1234 #define new_XPVHV() (void*)new_xpvhv()
1235 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1237 #define new_XPVMG() (void*)new_xpvmg()
1238 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1240 #define new_XPVLV() (void*)new_xpvlv()
1241 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1243 #define new_XPVBM() (void*)new_xpvbm()
1244 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1248 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1249 #define del_XPVGV(p) my_safefree(p)
1251 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1252 #define del_XPVFM(p) my_safefree(p)
1254 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1255 #define del_XPVIO(p) my_safefree(p)
1258 =for apidoc sv_upgrade
1260 Upgrade an SV to a more complex form. Generally adds a new body type to the
1261 SV, then copies across as much information as possible from the old body.
1262 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1268 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1275 MAGIC* magic = NULL;
1278 if (mt != SVt_PV && SvIsCOW(sv)) {
1279 sv_force_normal_flags(sv, 0);
1282 if (SvTYPE(sv) == mt)
1286 (void)SvOOK_off(sv);
1288 switch (SvTYPE(sv)) {
1309 else if (mt < SVt_PVIV)
1326 pv = (char*)SvRV(sv);
1346 else if (mt == SVt_NV)
1357 del_XPVIV(SvANY(sv));
1367 del_XPVNV(SvANY(sv));
1375 magic = SvMAGIC(sv);
1376 stash = SvSTASH(sv);
1377 del_XPVMG(SvANY(sv));
1380 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1385 Perl_croak(aTHX_ "Can't upgrade to undef");
1387 SvANY(sv) = new_XIV();
1391 SvANY(sv) = new_XNV();
1395 SvANY(sv) = new_XRV();
1399 SvANY(sv) = new_XPV();
1405 SvANY(sv) = new_XPVIV();
1415 SvANY(sv) = new_XPVNV();
1423 SvANY(sv) = new_XPVMG();
1429 SvMAGIC(sv) = magic;
1430 SvSTASH(sv) = stash;
1433 SvANY(sv) = new_XPVLV();
1439 SvMAGIC(sv) = magic;
1440 SvSTASH(sv) = stash;
1447 SvANY(sv) = new_XPVAV();
1455 SvMAGIC(sv) = magic;
1456 SvSTASH(sv) = stash;
1462 SvANY(sv) = new_XPVHV();
1468 HvTOTALKEYS(sv) = 0;
1469 HvPLACEHOLDERS(sv) = 0;
1470 SvMAGIC(sv) = magic;
1471 SvSTASH(sv) = stash;
1478 SvANY(sv) = new_XPVCV();
1479 Zero(SvANY(sv), 1, XPVCV);
1485 SvMAGIC(sv) = magic;
1486 SvSTASH(sv) = stash;
1489 SvANY(sv) = new_XPVGV();
1495 SvMAGIC(sv) = magic;
1496 SvSTASH(sv) = stash;
1504 SvANY(sv) = new_XPVBM();
1510 SvMAGIC(sv) = magic;
1511 SvSTASH(sv) = stash;
1517 SvANY(sv) = new_XPVFM();
1518 Zero(SvANY(sv), 1, XPVFM);
1524 SvMAGIC(sv) = magic;
1525 SvSTASH(sv) = stash;
1528 SvANY(sv) = new_XPVIO();
1529 Zero(SvANY(sv), 1, XPVIO);
1535 SvMAGIC(sv) = magic;
1536 SvSTASH(sv) = stash;
1537 IoPAGE_LEN(sv) = 60;
1540 SvFLAGS(sv) &= ~SVTYPEMASK;
1546 =for apidoc sv_backoff
1548 Remove any string offset. You should normally use the C<SvOOK_off> macro
1555 Perl_sv_backoff(pTHX_ register SV *sv)
1559 char *s = SvPVX(sv);
1560 SvLEN(sv) += SvIVX(sv);
1561 SvPVX(sv) -= SvIVX(sv);
1563 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1565 SvFLAGS(sv) &= ~SVf_OOK;
1572 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1573 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1574 Use the C<SvGROW> wrapper instead.
1580 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1584 #ifdef HAS_64K_LIMIT
1585 if (newlen >= 0x10000) {
1586 PerlIO_printf(Perl_debug_log,
1587 "Allocation too large: %"UVxf"\n", (UV)newlen);
1590 #endif /* HAS_64K_LIMIT */
1593 if (SvTYPE(sv) < SVt_PV) {
1594 sv_upgrade(sv, SVt_PV);
1597 else if (SvOOK(sv)) { /* pv is offset? */
1600 if (newlen > SvLEN(sv))
1601 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1602 #ifdef HAS_64K_LIMIT
1603 if (newlen >= 0x10000)
1610 if (newlen > SvLEN(sv)) { /* need more room? */
1611 if (SvLEN(sv) && s) {
1613 STRLEN l = malloced_size((void*)SvPVX(sv));
1619 Renew(s,newlen,char);
1622 New(703, s, newlen, char);
1623 if (SvPVX(sv) && SvCUR(sv)) {
1624 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1628 SvLEN_set(sv, newlen);
1634 =for apidoc sv_setiv
1636 Copies an integer into the given SV, upgrading first if necessary.
1637 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1643 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1645 SV_CHECK_THINKFIRST_COW_DROP(sv);
1646 switch (SvTYPE(sv)) {
1648 sv_upgrade(sv, SVt_IV);
1651 sv_upgrade(sv, SVt_PVNV);
1655 sv_upgrade(sv, SVt_PVIV);
1664 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1667 (void)SvIOK_only(sv); /* validate number */
1673 =for apidoc sv_setiv_mg
1675 Like C<sv_setiv>, but also handles 'set' magic.
1681 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1688 =for apidoc sv_setuv
1690 Copies an unsigned integer into the given SV, upgrading first if necessary.
1691 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1697 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1699 /* With these two if statements:
1700 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1703 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1705 If you wish to remove them, please benchmark to see what the effect is
1707 if (u <= (UV)IV_MAX) {
1708 sv_setiv(sv, (IV)u);
1717 =for apidoc sv_setuv_mg
1719 Like C<sv_setuv>, but also handles 'set' magic.
1725 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1727 /* With these two if statements:
1728 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1731 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1733 If you wish to remove them, please benchmark to see what the effect is
1735 if (u <= (UV)IV_MAX) {
1736 sv_setiv(sv, (IV)u);
1746 =for apidoc sv_setnv
1748 Copies a double into the given SV, upgrading first if necessary.
1749 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1755 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1757 SV_CHECK_THINKFIRST_COW_DROP(sv);
1758 switch (SvTYPE(sv)) {
1761 sv_upgrade(sv, SVt_NV);
1766 sv_upgrade(sv, SVt_PVNV);
1775 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1779 (void)SvNOK_only(sv); /* validate number */
1784 =for apidoc sv_setnv_mg
1786 Like C<sv_setnv>, but also handles 'set' magic.
1792 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1798 /* Print an "isn't numeric" warning, using a cleaned-up,
1799 * printable version of the offending string
1803 S_not_a_number(pTHX_ SV *sv)
1810 dsv = sv_2mortal(newSVpv("", 0));
1811 pv = sv_uni_display(dsv, sv, 10, 0);
1814 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1815 /* each *s can expand to 4 chars + "...\0",
1816 i.e. need room for 8 chars */
1819 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1821 if (ch & 128 && !isPRINT_LC(ch)) {
1830 else if (ch == '\r') {
1834 else if (ch == '\f') {
1838 else if (ch == '\\') {
1842 else if (ch == '\0') {
1846 else if (isPRINT_LC(ch))
1863 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1864 "Argument \"%s\" isn't numeric in %s", pv,
1867 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1868 "Argument \"%s\" isn't numeric", pv);
1872 =for apidoc looks_like_number
1874 Test if the content of an SV looks like a number (or is a number).
1875 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1876 non-numeric warning), even if your atof() doesn't grok them.
1882 Perl_looks_like_number(pTHX_ SV *sv)
1884 register char *sbegin;
1891 else if (SvPOKp(sv))
1892 sbegin = SvPV(sv, len);
1894 return 1; /* Historic. Wrong? */
1895 return grok_number(sbegin, len, NULL);
1898 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1899 until proven guilty, assume that things are not that bad... */
1904 As 64 bit platforms often have an NV that doesn't preserve all bits of
1905 an IV (an assumption perl has been based on to date) it becomes necessary
1906 to remove the assumption that the NV always carries enough precision to
1907 recreate the IV whenever needed, and that the NV is the canonical form.
1908 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1909 precision as a side effect of conversion (which would lead to insanity
1910 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1911 1) to distinguish between IV/UV/NV slots that have cached a valid
1912 conversion where precision was lost and IV/UV/NV slots that have a
1913 valid conversion which has lost no precision
1914 2) to ensure that if a numeric conversion to one form is requested that
1915 would lose precision, the precise conversion (or differently
1916 imprecise conversion) is also performed and cached, to prevent
1917 requests for different numeric formats on the same SV causing
1918 lossy conversion chains. (lossless conversion chains are perfectly
1923 SvIOKp is true if the IV slot contains a valid value
1924 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1925 SvNOKp is true if the NV slot contains a valid value
1926 SvNOK is true only if the NV value is accurate
1929 while converting from PV to NV, check to see if converting that NV to an
1930 IV(or UV) would lose accuracy over a direct conversion from PV to
1931 IV(or UV). If it would, cache both conversions, return NV, but mark
1932 SV as IOK NOKp (ie not NOK).
1934 While converting from PV to IV, check to see if converting that IV to an
1935 NV would lose accuracy over a direct conversion from PV to NV. If it
1936 would, cache both conversions, flag similarly.
1938 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1939 correctly because if IV & NV were set NV *always* overruled.
1940 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1941 changes - now IV and NV together means that the two are interchangeable:
1942 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1944 The benefit of this is that operations such as pp_add know that if
1945 SvIOK is true for both left and right operands, then integer addition
1946 can be used instead of floating point (for cases where the result won't
1947 overflow). Before, floating point was always used, which could lead to
1948 loss of precision compared with integer addition.
1950 * making IV and NV equal status should make maths accurate on 64 bit
1952 * may speed up maths somewhat if pp_add and friends start to use
1953 integers when possible instead of fp. (Hopefully the overhead in
1954 looking for SvIOK and checking for overflow will not outweigh the
1955 fp to integer speedup)
1956 * will slow down integer operations (callers of SvIV) on "inaccurate"
1957 values, as the change from SvIOK to SvIOKp will cause a call into
1958 sv_2iv each time rather than a macro access direct to the IV slot
1959 * should speed up number->string conversion on integers as IV is
1960 favoured when IV and NV are equally accurate
1962 ####################################################################
1963 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1964 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1965 On the other hand, SvUOK is true iff UV.
1966 ####################################################################
1968 Your mileage will vary depending your CPU's relative fp to integer
1972 #ifndef NV_PRESERVES_UV
1973 # define IS_NUMBER_UNDERFLOW_IV 1
1974 # define IS_NUMBER_UNDERFLOW_UV 2
1975 # define IS_NUMBER_IV_AND_UV 2
1976 # define IS_NUMBER_OVERFLOW_IV 4
1977 # define IS_NUMBER_OVERFLOW_UV 5
1979 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1981 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1983 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1985 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1986 if (SvNVX(sv) < (NV)IV_MIN) {
1987 (void)SvIOKp_on(sv);
1990 return IS_NUMBER_UNDERFLOW_IV;
1992 if (SvNVX(sv) > (NV)UV_MAX) {
1993 (void)SvIOKp_on(sv);
1997 return IS_NUMBER_OVERFLOW_UV;
1999 (void)SvIOKp_on(sv);
2001 /* Can't use strtol etc to convert this string. (See truth table in
2003 if (SvNVX(sv) <= (UV)IV_MAX) {
2004 SvIVX(sv) = I_V(SvNVX(sv));
2005 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2006 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2008 /* Integer is imprecise. NOK, IOKp */
2010 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2013 SvUVX(sv) = U_V(SvNVX(sv));
2014 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2015 if (SvUVX(sv) == UV_MAX) {
2016 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2017 possibly be preserved by NV. Hence, it must be overflow.
2019 return IS_NUMBER_OVERFLOW_UV;
2021 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2023 /* Integer is imprecise. NOK, IOKp */
2025 return IS_NUMBER_OVERFLOW_IV;
2027 #endif /* !NV_PRESERVES_UV*/
2032 Return the integer value of an SV, doing any necessary string conversion,
2033 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2039 Perl_sv_2iv(pTHX_ register SV *sv)
2043 if (SvGMAGICAL(sv)) {
2048 return I_V(SvNVX(sv));
2050 if (SvPOKp(sv) && SvLEN(sv))
2053 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2054 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2060 if (SvTHINKFIRST(sv)) {
2063 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2064 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2065 return SvIV(tmpstr);
2066 return PTR2IV(SvRV(sv));
2069 sv_force_normal_flags(sv, 0);
2071 if (SvREADONLY(sv) && !SvOK(sv)) {
2072 if (ckWARN(WARN_UNINITIALIZED))
2079 return (IV)(SvUVX(sv));
2086 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2087 * without also getting a cached IV/UV from it at the same time
2088 * (ie PV->NV conversion should detect loss of accuracy and cache
2089 * IV or UV at same time to avoid this. NWC */
2091 if (SvTYPE(sv) == SVt_NV)
2092 sv_upgrade(sv, SVt_PVNV);
2094 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2095 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2096 certainly cast into the IV range at IV_MAX, whereas the correct
2097 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2099 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2100 SvIVX(sv) = I_V(SvNVX(sv));
2101 if (SvNVX(sv) == (NV) SvIVX(sv)
2102 #ifndef NV_PRESERVES_UV
2103 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2104 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2105 /* Don't flag it as "accurately an integer" if the number
2106 came from a (by definition imprecise) NV operation, and
2107 we're outside the range of NV integer precision */
2110 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2111 DEBUG_c(PerlIO_printf(Perl_debug_log,
2112 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2118 /* IV not precise. No need to convert from PV, as NV
2119 conversion would already have cached IV if it detected
2120 that PV->IV would be better than PV->NV->IV
2121 flags already correct - don't set public IOK. */
2122 DEBUG_c(PerlIO_printf(Perl_debug_log,
2123 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2128 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2129 but the cast (NV)IV_MIN rounds to a the value less (more
2130 negative) than IV_MIN which happens to be equal to SvNVX ??
2131 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2132 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2133 (NV)UVX == NVX are both true, but the values differ. :-(
2134 Hopefully for 2s complement IV_MIN is something like
2135 0x8000000000000000 which will be exact. NWC */
2138 SvUVX(sv) = U_V(SvNVX(sv));
2140 (SvNVX(sv) == (NV) SvUVX(sv))
2141 #ifndef NV_PRESERVES_UV
2142 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2143 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2144 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2145 /* Don't flag it as "accurately an integer" if the number
2146 came from a (by definition imprecise) NV operation, and
2147 we're outside the range of NV integer precision */
2153 DEBUG_c(PerlIO_printf(Perl_debug_log,
2154 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2158 return (IV)SvUVX(sv);
2161 else if (SvPOKp(sv) && SvLEN(sv)) {
2163 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2164 /* We want to avoid a possible problem when we cache an IV which
2165 may be later translated to an NV, and the resulting NV is not
2166 the same as the direct translation of the initial string
2167 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2168 be careful to ensure that the value with the .456 is around if the
2169 NV value is requested in the future).
2171 This means that if we cache such an IV, we need to cache the
2172 NV as well. Moreover, we trade speed for space, and do not
2173 cache the NV if we are sure it's not needed.
2176 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2177 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2178 == IS_NUMBER_IN_UV) {
2179 /* It's definitely an integer, only upgrade to PVIV */
2180 if (SvTYPE(sv) < SVt_PVIV)
2181 sv_upgrade(sv, SVt_PVIV);
2183 } else if (SvTYPE(sv) < SVt_PVNV)
2184 sv_upgrade(sv, SVt_PVNV);
2186 /* If NV preserves UV then we only use the UV value if we know that
2187 we aren't going to call atof() below. If NVs don't preserve UVs
2188 then the value returned may have more precision than atof() will
2189 return, even though value isn't perfectly accurate. */
2190 if ((numtype & (IS_NUMBER_IN_UV
2191 #ifdef NV_PRESERVES_UV
2194 )) == IS_NUMBER_IN_UV) {
2195 /* This won't turn off the public IOK flag if it was set above */
2196 (void)SvIOKp_on(sv);
2198 if (!(numtype & IS_NUMBER_NEG)) {
2200 if (value <= (UV)IV_MAX) {
2201 SvIVX(sv) = (IV)value;
2207 /* 2s complement assumption */
2208 if (value <= (UV)IV_MIN) {
2209 SvIVX(sv) = -(IV)value;
2211 /* Too negative for an IV. This is a double upgrade, but
2212 I'm assuming it will be rare. */
2213 if (SvTYPE(sv) < SVt_PVNV)
2214 sv_upgrade(sv, SVt_PVNV);
2218 SvNVX(sv) = -(NV)value;
2223 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2224 will be in the previous block to set the IV slot, and the next
2225 block to set the NV slot. So no else here. */
2227 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2228 != IS_NUMBER_IN_UV) {
2229 /* It wasn't an (integer that doesn't overflow the UV). */
2230 SvNVX(sv) = Atof(SvPVX(sv));
2232 if (! numtype && ckWARN(WARN_NUMERIC))
2235 #if defined(USE_LONG_DOUBLE)
2236 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2237 PTR2UV(sv), SvNVX(sv)));
2239 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2240 PTR2UV(sv), SvNVX(sv)));
2244 #ifdef NV_PRESERVES_UV
2245 (void)SvIOKp_on(sv);
2247 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2248 SvIVX(sv) = I_V(SvNVX(sv));
2249 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2252 /* Integer is imprecise. NOK, IOKp */
2254 /* UV will not work better than IV */
2256 if (SvNVX(sv) > (NV)UV_MAX) {
2258 /* Integer is inaccurate. NOK, IOKp, is UV */
2262 SvUVX(sv) = U_V(SvNVX(sv));
2263 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2264 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2268 /* Integer is imprecise. NOK, IOKp, is UV */
2274 #else /* NV_PRESERVES_UV */
2275 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2276 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2277 /* The IV slot will have been set from value returned by
2278 grok_number above. The NV slot has just been set using
2281 assert (SvIOKp(sv));
2283 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2284 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2285 /* Small enough to preserve all bits. */
2286 (void)SvIOKp_on(sv);
2288 SvIVX(sv) = I_V(SvNVX(sv));
2289 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2291 /* Assumption: first non-preserved integer is < IV_MAX,
2292 this NV is in the preserved range, therefore: */
2293 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2295 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2299 0 0 already failed to read UV.
2300 0 1 already failed to read UV.
2301 1 0 you won't get here in this case. IV/UV
2302 slot set, public IOK, Atof() unneeded.
2303 1 1 already read UV.
2304 so there's no point in sv_2iuv_non_preserve() attempting
2305 to use atol, strtol, strtoul etc. */
2306 if (sv_2iuv_non_preserve (sv, numtype)
2307 >= IS_NUMBER_OVERFLOW_IV)
2311 #endif /* NV_PRESERVES_UV */
2314 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2316 if (SvTYPE(sv) < SVt_IV)
2317 /* Typically the caller expects that sv_any is not NULL now. */
2318 sv_upgrade(sv, SVt_IV);
2321 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2322 PTR2UV(sv),SvIVX(sv)));
2323 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2329 Return the unsigned integer value of an SV, doing any necessary string
2330 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2337 Perl_sv_2uv(pTHX_ register SV *sv)
2341 if (SvGMAGICAL(sv)) {
2346 return U_V(SvNVX(sv));
2347 if (SvPOKp(sv) && SvLEN(sv))
2350 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2351 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2357 if (SvTHINKFIRST(sv)) {
2360 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2361 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2362 return SvUV(tmpstr);
2363 return PTR2UV(SvRV(sv));
2366 sv_force_normal_flags(sv, 0);
2368 if (SvREADONLY(sv) && !SvOK(sv)) {
2369 if (ckWARN(WARN_UNINITIALIZED))
2379 return (UV)SvIVX(sv);
2383 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2384 * without also getting a cached IV/UV from it at the same time
2385 * (ie PV->NV conversion should detect loss of accuracy and cache
2386 * IV or UV at same time to avoid this. */
2387 /* IV-over-UV optimisation - choose to cache IV if possible */
2389 if (SvTYPE(sv) == SVt_NV)
2390 sv_upgrade(sv, SVt_PVNV);
2392 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2393 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2394 SvIVX(sv) = I_V(SvNVX(sv));
2395 if (SvNVX(sv) == (NV) SvIVX(sv)
2396 #ifndef NV_PRESERVES_UV
2397 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2398 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2399 /* Don't flag it as "accurately an integer" if the number
2400 came from a (by definition imprecise) NV operation, and
2401 we're outside the range of NV integer precision */
2404 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2405 DEBUG_c(PerlIO_printf(Perl_debug_log,
2406 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2412 /* IV not precise. No need to convert from PV, as NV
2413 conversion would already have cached IV if it detected
2414 that PV->IV would be better than PV->NV->IV
2415 flags already correct - don't set public IOK. */
2416 DEBUG_c(PerlIO_printf(Perl_debug_log,
2417 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2422 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2423 but the cast (NV)IV_MIN rounds to a the value less (more
2424 negative) than IV_MIN which happens to be equal to SvNVX ??
2425 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2426 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2427 (NV)UVX == NVX are both true, but the values differ. :-(
2428 Hopefully for 2s complement IV_MIN is something like
2429 0x8000000000000000 which will be exact. NWC */
2432 SvUVX(sv) = U_V(SvNVX(sv));
2434 (SvNVX(sv) == (NV) SvUVX(sv))
2435 #ifndef NV_PRESERVES_UV
2436 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2437 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2438 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2439 /* Don't flag it as "accurately an integer" if the number
2440 came from a (by definition imprecise) NV operation, and
2441 we're outside the range of NV integer precision */
2446 DEBUG_c(PerlIO_printf(Perl_debug_log,
2447 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2453 else if (SvPOKp(sv) && SvLEN(sv)) {
2455 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2457 /* We want to avoid a possible problem when we cache a UV which
2458 may be later translated to an NV, and the resulting NV is not
2459 the translation of the initial data.
2461 This means that if we cache such a UV, we need to cache the
2462 NV as well. Moreover, we trade speed for space, and do not
2463 cache the NV if not needed.
2466 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2467 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2468 == IS_NUMBER_IN_UV) {
2469 /* It's definitely an integer, only upgrade to PVIV */
2470 if (SvTYPE(sv) < SVt_PVIV)
2471 sv_upgrade(sv, SVt_PVIV);
2473 } else if (SvTYPE(sv) < SVt_PVNV)
2474 sv_upgrade(sv, SVt_PVNV);
2476 /* If NV preserves UV then we only use the UV value if we know that
2477 we aren't going to call atof() below. If NVs don't preserve UVs
2478 then the value returned may have more precision than atof() will
2479 return, even though it isn't accurate. */
2480 if ((numtype & (IS_NUMBER_IN_UV
2481 #ifdef NV_PRESERVES_UV
2484 )) == IS_NUMBER_IN_UV) {
2485 /* This won't turn off the public IOK flag if it was set above */
2486 (void)SvIOKp_on(sv);
2488 if (!(numtype & IS_NUMBER_NEG)) {
2490 if (value <= (UV)IV_MAX) {
2491 SvIVX(sv) = (IV)value;
2493 /* it didn't overflow, and it was positive. */
2498 /* 2s complement assumption */
2499 if (value <= (UV)IV_MIN) {
2500 SvIVX(sv) = -(IV)value;
2502 /* Too negative for an IV. This is a double upgrade, but
2503 I'm assuming it will be rare. */
2504 if (SvTYPE(sv) < SVt_PVNV)
2505 sv_upgrade(sv, SVt_PVNV);
2509 SvNVX(sv) = -(NV)value;
2515 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2516 != IS_NUMBER_IN_UV) {
2517 /* It wasn't an integer, or it overflowed the UV. */
2518 SvNVX(sv) = Atof(SvPVX(sv));
2520 if (! numtype && ckWARN(WARN_NUMERIC))
2523 #if defined(USE_LONG_DOUBLE)
2524 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2525 PTR2UV(sv), SvNVX(sv)));
2527 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2528 PTR2UV(sv), SvNVX(sv)));
2531 #ifdef NV_PRESERVES_UV
2532 (void)SvIOKp_on(sv);
2534 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2535 SvIVX(sv) = I_V(SvNVX(sv));
2536 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2539 /* Integer is imprecise. NOK, IOKp */
2541 /* UV will not work better than IV */
2543 if (SvNVX(sv) > (NV)UV_MAX) {
2545 /* Integer is inaccurate. NOK, IOKp, is UV */
2549 SvUVX(sv) = U_V(SvNVX(sv));
2550 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2551 NV preservse UV so can do correct comparison. */
2552 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2556 /* Integer is imprecise. NOK, IOKp, is UV */
2561 #else /* NV_PRESERVES_UV */
2562 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2563 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2564 /* The UV slot will have been set from value returned by
2565 grok_number above. The NV slot has just been set using
2568 assert (SvIOKp(sv));
2570 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2571 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2572 /* Small enough to preserve all bits. */
2573 (void)SvIOKp_on(sv);
2575 SvIVX(sv) = I_V(SvNVX(sv));
2576 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2578 /* Assumption: first non-preserved integer is < IV_MAX,
2579 this NV is in the preserved range, therefore: */
2580 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2582 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2585 sv_2iuv_non_preserve (sv, numtype);
2587 #endif /* NV_PRESERVES_UV */
2591 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2592 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2595 if (SvTYPE(sv) < SVt_IV)
2596 /* Typically the caller expects that sv_any is not NULL now. */
2597 sv_upgrade(sv, SVt_IV);
2601 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2602 PTR2UV(sv),SvUVX(sv)));
2603 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2609 Return the num value of an SV, doing any necessary string or integer
2610 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2617 Perl_sv_2nv(pTHX_ register SV *sv)
2621 if (SvGMAGICAL(sv)) {
2625 if (SvPOKp(sv) && SvLEN(sv)) {
2626 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2627 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2629 return Atof(SvPVX(sv));
2633 return (NV)SvUVX(sv);
2635 return (NV)SvIVX(sv);
2638 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2639 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2645 if (SvTHINKFIRST(sv)) {
2648 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2649 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2650 return SvNV(tmpstr);
2651 return PTR2NV(SvRV(sv));
2654 sv_force_normal_flags(sv, 0);
2656 if (SvREADONLY(sv) && !SvOK(sv)) {
2657 if (ckWARN(WARN_UNINITIALIZED))
2662 if (SvTYPE(sv) < SVt_NV) {
2663 if (SvTYPE(sv) == SVt_IV)
2664 sv_upgrade(sv, SVt_PVNV);
2666 sv_upgrade(sv, SVt_NV);
2667 #ifdef USE_LONG_DOUBLE
2669 STORE_NUMERIC_LOCAL_SET_STANDARD();
2670 PerlIO_printf(Perl_debug_log,
2671 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2672 PTR2UV(sv), SvNVX(sv));
2673 RESTORE_NUMERIC_LOCAL();
2677 STORE_NUMERIC_LOCAL_SET_STANDARD();
2678 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2679 PTR2UV(sv), SvNVX(sv));
2680 RESTORE_NUMERIC_LOCAL();
2684 else if (SvTYPE(sv) < SVt_PVNV)
2685 sv_upgrade(sv, SVt_PVNV);
2690 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2691 #ifdef NV_PRESERVES_UV
2694 /* Only set the public NV OK flag if this NV preserves the IV */
2695 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2696 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2697 : (SvIVX(sv) == I_V(SvNVX(sv))))
2703 else if (SvPOKp(sv) && SvLEN(sv)) {
2705 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2706 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2708 #ifdef NV_PRESERVES_UV
2709 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2710 == IS_NUMBER_IN_UV) {
2711 /* It's definitely an integer */
2712 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2714 SvNVX(sv) = Atof(SvPVX(sv));
2717 SvNVX(sv) = Atof(SvPVX(sv));
2718 /* Only set the public NV OK flag if this NV preserves the value in
2719 the PV at least as well as an IV/UV would.
2720 Not sure how to do this 100% reliably. */
2721 /* if that shift count is out of range then Configure's test is
2722 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2724 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2725 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2726 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2727 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2728 /* Can't use strtol etc to convert this string, so don't try.
2729 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2732 /* value has been set. It may not be precise. */
2733 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2734 /* 2s complement assumption for (UV)IV_MIN */
2735 SvNOK_on(sv); /* Integer is too negative. */
2740 if (numtype & IS_NUMBER_NEG) {
2741 SvIVX(sv) = -(IV)value;
2742 } else if (value <= (UV)IV_MAX) {
2743 SvIVX(sv) = (IV)value;
2749 if (numtype & IS_NUMBER_NOT_INT) {
2750 /* I believe that even if the original PV had decimals,
2751 they are lost beyond the limit of the FP precision.
2752 However, neither is canonical, so both only get p
2753 flags. NWC, 2000/11/25 */
2754 /* Both already have p flags, so do nothing */
2757 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2758 if (SvIVX(sv) == I_V(nv)) {
2763 /* It had no "." so it must be integer. */
2766 /* between IV_MAX and NV(UV_MAX).
2767 Could be slightly > UV_MAX */
2769 if (numtype & IS_NUMBER_NOT_INT) {
2770 /* UV and NV both imprecise. */
2772 UV nv_as_uv = U_V(nv);
2774 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2785 #endif /* NV_PRESERVES_UV */
2788 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2790 if (SvTYPE(sv) < SVt_NV)
2791 /* Typically the caller expects that sv_any is not NULL now. */
2792 /* XXX Ilya implies that this is a bug in callers that assume this
2793 and ideally should be fixed. */
2794 sv_upgrade(sv, SVt_NV);
2797 #if defined(USE_LONG_DOUBLE)
2799 STORE_NUMERIC_LOCAL_SET_STANDARD();
2800 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2801 PTR2UV(sv), SvNVX(sv));
2802 RESTORE_NUMERIC_LOCAL();
2806 STORE_NUMERIC_LOCAL_SET_STANDARD();
2807 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2808 PTR2UV(sv), SvNVX(sv));
2809 RESTORE_NUMERIC_LOCAL();
2815 /* asIV(): extract an integer from the string value of an SV.
2816 * Caller must validate PVX */
2819 S_asIV(pTHX_ SV *sv)
2822 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2824 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2825 == IS_NUMBER_IN_UV) {
2826 /* It's definitely an integer */
2827 if (numtype & IS_NUMBER_NEG) {
2828 if (value < (UV)IV_MIN)
2831 if (value < (UV)IV_MAX)
2836 if (ckWARN(WARN_NUMERIC))
2839 return I_V(Atof(SvPVX(sv)));
2842 /* asUV(): extract an unsigned integer from the string value of an SV
2843 * Caller must validate PVX */
2846 S_asUV(pTHX_ SV *sv)
2849 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2851 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2852 == IS_NUMBER_IN_UV) {
2853 /* It's definitely an integer */
2854 if (!(numtype & IS_NUMBER_NEG))
2858 if (ckWARN(WARN_NUMERIC))
2861 return U_V(Atof(SvPVX(sv)));
2865 =for apidoc sv_2pv_nolen
2867 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2868 use the macro wrapper C<SvPV_nolen(sv)> instead.
2873 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2876 return sv_2pv(sv, &n_a);
2879 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2880 * UV as a string towards the end of buf, and return pointers to start and
2883 * We assume that buf is at least TYPE_CHARS(UV) long.
2887 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2889 char *ptr = buf + TYPE_CHARS(UV);
2903 *--ptr = '0' + (char)(uv % 10);
2911 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2912 * this function provided for binary compatibility only
2916 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2918 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2922 =for apidoc sv_2pv_flags
2924 Returns a pointer to the string value of an SV, and sets *lp to its length.
2925 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2927 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2928 usually end up here too.
2934 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2939 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2940 char *tmpbuf = tbuf;
2946 if (SvGMAGICAL(sv)) {
2947 if (flags & SV_GMAGIC)
2955 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2957 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2962 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2967 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2968 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2975 if (SvTHINKFIRST(sv)) {
2978 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2979 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2980 char *pv = SvPV(tmpstr, *lp);
2994 switch (SvTYPE(sv)) {
2996 if ( ((SvFLAGS(sv) &
2997 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2998 == (SVs_OBJECT|SVs_SMG))
2999 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3000 regexp *re = (regexp *)mg->mg_obj;
3003 char *fptr = "msix";
3008 char need_newline = 0;
3009 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3011 while((ch = *fptr++)) {
3013 reflags[left++] = ch;
3016 reflags[right--] = ch;
3021 reflags[left] = '-';
3025 mg->mg_len = re->prelen + 4 + left;
3027 * If /x was used, we have to worry about a regex
3028 * ending with a comment later being embedded
3029 * within another regex. If so, we don't want this
3030 * regex's "commentization" to leak out to the
3031 * right part of the enclosing regex, we must cap
3032 * it with a newline.
3034 * So, if /x was used, we scan backwards from the
3035 * end of the regex. If we find a '#' before we
3036 * find a newline, we need to add a newline
3037 * ourself. If we find a '\n' first (or if we
3038 * don't find '#' or '\n'), we don't need to add
3039 * anything. -jfriedl
3041 if (PMf_EXTENDED & re->reganch)
3043 char *endptr = re->precomp + re->prelen;
3044 while (endptr >= re->precomp)
3046 char c = *(endptr--);
3048 break; /* don't need another */
3050 /* we end while in a comment, so we
3052 mg->mg_len++; /* save space for it */
3053 need_newline = 1; /* note to add it */
3059 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3060 Copy("(?", mg->mg_ptr, 2, char);
3061 Copy(reflags, mg->mg_ptr+2, left, char);
3062 Copy(":", mg->mg_ptr+left+2, 1, char);
3063 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3065 mg->mg_ptr[mg->mg_len - 2] = '\n';
3066 mg->mg_ptr[mg->mg_len - 1] = ')';
3067 mg->mg_ptr[mg->mg_len] = 0;
3069 PL_reginterp_cnt += re->program[0].next_off;
3071 if (re->reganch & ROPT_UTF8)
3086 case SVt_PVBM: if (SvROK(sv))
3089 s = "SCALAR"; break;
3090 case SVt_PVLV: s = SvROK(sv) ? "REF"
3091 /* tied lvalues should appear to be
3092 * scalars for backwards compatitbility */
3093 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3094 ? "SCALAR" : "LVALUE"; break;
3095 case SVt_PVAV: s = "ARRAY"; break;
3096 case SVt_PVHV: s = "HASH"; break;
3097 case SVt_PVCV: s = "CODE"; break;
3098 case SVt_PVGV: s = "GLOB"; break;
3099 case SVt_PVFM: s = "FORMAT"; break;
3100 case SVt_PVIO: s = "IO"; break;
3101 default: s = "UNKNOWN"; break;
3105 if (HvNAME(SvSTASH(sv)))
3106 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3108 Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
3111 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3117 if (SvREADONLY(sv) && !SvOK(sv)) {
3118 if (ckWARN(WARN_UNINITIALIZED))
3124 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3125 /* I'm assuming that if both IV and NV are equally valid then
3126 converting the IV is going to be more efficient */
3127 U32 isIOK = SvIOK(sv);
3128 U32 isUIOK = SvIsUV(sv);
3129 char buf[TYPE_CHARS(UV)];
3132 if (SvTYPE(sv) < SVt_PVIV)
3133 sv_upgrade(sv, SVt_PVIV);
3135 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3137 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3138 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3139 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3140 SvCUR_set(sv, ebuf - ptr);
3150 else if (SvNOKp(sv)) {
3151 if (SvTYPE(sv) < SVt_PVNV)
3152 sv_upgrade(sv, SVt_PVNV);
3153 /* The +20 is pure guesswork. Configure test needed. --jhi */
3154 SvGROW(sv, NV_DIG + 20);
3156 olderrno = errno; /* some Xenix systems wipe out errno here */
3158 if (SvNVX(sv) == 0.0)
3159 (void)strcpy(s,"0");
3163 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3166 #ifdef FIXNEGATIVEZERO
3167 if (*s == '-' && s[1] == '0' && !s[2])
3177 if (ckWARN(WARN_UNINITIALIZED)
3178 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3181 if (SvTYPE(sv) < SVt_PV)
3182 /* Typically the caller expects that sv_any is not NULL now. */
3183 sv_upgrade(sv, SVt_PV);
3186 *lp = s - SvPVX(sv);
3189 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3190 PTR2UV(sv),SvPVX(sv)));
3194 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3195 /* Sneaky stuff here */
3199 tsv = newSVpv(tmpbuf, 0);
3215 len = strlen(tmpbuf);
3217 #ifdef FIXNEGATIVEZERO
3218 if (len == 2 && t[0] == '-' && t[1] == '0') {
3223 (void)SvUPGRADE(sv, SVt_PV);
3225 s = SvGROW(sv, len + 1);
3234 =for apidoc sv_copypv
3236 Copies a stringified representation of the source SV into the
3237 destination SV. Automatically performs any necessary mg_get and
3238 coercion of numeric values into strings. Guaranteed to preserve
3239 UTF-8 flag even from overloaded objects. Similar in nature to
3240 sv_2pv[_flags] but operates directly on an SV instead of just the
3241 string. Mostly uses sv_2pv_flags to do its work, except when that
3242 would lose the UTF-8'ness of the PV.
3248 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3253 sv_setpvn(dsv,s,len);
3261 =for apidoc sv_2pvbyte_nolen
3263 Return a pointer to the byte-encoded representation of the SV.
3264 May cause the SV to be downgraded from UTF8 as a side-effect.
3266 Usually accessed via the C<SvPVbyte_nolen> macro.
3272 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3275 return sv_2pvbyte(sv, &n_a);
3279 =for apidoc sv_2pvbyte
3281 Return a pointer to the byte-encoded representation of the SV, and set *lp
3282 to its length. May cause the SV to be downgraded from UTF8 as a
3285 Usually accessed via the C<SvPVbyte> macro.
3291 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3293 sv_utf8_downgrade(sv,0);
3294 return SvPV(sv,*lp);
3298 =for apidoc sv_2pvutf8_nolen
3300 Return a pointer to the UTF8-encoded representation of the SV.
3301 May cause the SV to be upgraded to UTF8 as a side-effect.
3303 Usually accessed via the C<SvPVutf8_nolen> macro.
3309 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3312 return sv_2pvutf8(sv, &n_a);
3316 =for apidoc sv_2pvutf8
3318 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3319 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3321 Usually accessed via the C<SvPVutf8> macro.
3327 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3329 sv_utf8_upgrade(sv);
3330 return SvPV(sv,*lp);
3334 =for apidoc sv_2bool
3336 This function is only called on magical items, and is only used by
3337 sv_true() or its macro equivalent.
3343 Perl_sv_2bool(pTHX_ register SV *sv)
3352 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3353 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3354 return (bool)SvTRUE(tmpsv);
3355 return SvRV(sv) != 0;
3358 register XPV* Xpvtmp;
3359 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3360 (*Xpvtmp->xpv_pv > '0' ||
3361 Xpvtmp->xpv_cur > 1 ||
3362 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3369 return SvIVX(sv) != 0;
3372 return SvNVX(sv) != 0.0;
3379 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3380 * this function provided for binary compatibility only
3385 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3387 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3391 =for apidoc sv_utf8_upgrade
3393 Convert the PV of an SV to its UTF8-encoded form.
3394 Forces the SV to string form if it is not already.
3395 Always sets the SvUTF8 flag to avoid future validity checks even
3396 if all the bytes have hibit clear.
3398 This is not as a general purpose byte encoding to Unicode interface:
3399 use the Encode extension for that.
3401 =for apidoc sv_utf8_upgrade_flags
3403 Convert the PV of an SV to its UTF8-encoded form.
3404 Forces the SV to string form if it is not already.
3405 Always sets the SvUTF8 flag to avoid future validity checks even
3406 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3407 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3408 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3410 This is not as a general purpose byte encoding to Unicode interface:
3411 use the Encode extension for that.
3417 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3427 (void) sv_2pv_flags(sv,&len, flags);
3436 sv_force_normal_flags(sv, 0);
3439 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3440 sv_recode_to_utf8(sv, PL_encoding);
3441 else { /* Assume Latin-1/EBCDIC */
3442 /* This function could be much more efficient if we
3443 * had a FLAG in SVs to signal if there are any hibit
3444 * chars in the PV. Given that there isn't such a flag
3445 * make the loop as fast as possible. */
3446 s = (U8 *) SvPVX(sv);
3447 e = (U8 *) SvEND(sv);
3451 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3457 len = SvCUR(sv) + 1; /* Plus the \0 */
3458 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3459 SvCUR(sv) = len - 1;
3461 Safefree(s); /* No longer using what was there before. */
3462 SvLEN(sv) = len; /* No longer know the real size. */
3464 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3471 =for apidoc sv_utf8_downgrade
3473 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3474 This may not be possible if the PV contains non-byte encoding characters;
3475 if this is the case, either returns false or, if C<fail_ok> is not
3478 This is not as a general purpose Unicode to byte encoding interface:
3479 use the Encode extension for that.
3485 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3487 if (SvPOK(sv) && SvUTF8(sv)) {
3493 sv_force_normal_flags(sv, 0);
3495 s = (U8 *) SvPV(sv, len);
3496 if (!utf8_to_bytes(s, &len)) {
3501 Perl_croak(aTHX_ "Wide character in %s",
3504 Perl_croak(aTHX_ "Wide character");
3515 =for apidoc sv_utf8_encode
3517 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3518 flag so that it looks like octets again. Used as a building block
3519 for encode_utf8 in Encode.xs
3525 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3527 (void) sv_utf8_upgrade(sv);
3532 =for apidoc sv_utf8_decode
3534 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3535 turn off SvUTF8 if needed so that we see characters. Used as a building block
3536 for decode_utf8 in Encode.xs
3542 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3548 /* The octets may have got themselves encoded - get them back as
3551 if (!sv_utf8_downgrade(sv, TRUE))
3554 /* it is actually just a matter of turning the utf8 flag on, but
3555 * we want to make sure everything inside is valid utf8 first.
3557 c = (U8 *) SvPVX(sv);
3558 if (!is_utf8_string(c, SvCUR(sv)+1))
3560 e = (U8 *) SvEND(sv);
3563 if (!UTF8_IS_INVARIANT(ch)) {
3572 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3573 * this function provided for binary compatibility only
3577 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3579 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3583 =for apidoc sv_setsv
3585 Copies the contents of the source SV C<ssv> into the destination SV
3586 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3587 function if the source SV needs to be reused. Does not handle 'set' magic.
3588 Loosely speaking, it performs a copy-by-value, obliterating any previous
3589 content of the destination.
3591 You probably want to use one of the assortment of wrappers, such as
3592 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3593 C<SvSetMagicSV_nosteal>.
3595 =for apidoc sv_setsv_flags
3597 Copies the contents of the source SV C<ssv> into the destination SV
3598 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3599 function if the source SV needs to be reused. Does not handle 'set' magic.
3600 Loosely speaking, it performs a copy-by-value, obliterating any previous
3601 content of the destination.
3602 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3603 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3604 implemented in terms of this function.
3606 You probably want to use one of the assortment of wrappers, such as
3607 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3608 C<SvSetMagicSV_nosteal>.
3610 This is the primary function for copying scalars, and most other
3611 copy-ish functions and macros use this underneath.
3617 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3619 register U32 sflags;
3625 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3627 sstr = &PL_sv_undef;
3628 stype = SvTYPE(sstr);
3629 dtype = SvTYPE(dstr);
3634 /* need to nuke the magic */
3636 SvRMAGICAL_off(dstr);
3639 /* There's a lot of redundancy below but we're going for speed here */
3644 if (dtype != SVt_PVGV) {
3645 (void)SvOK_off(dstr);
3653 sv_upgrade(dstr, SVt_IV);
3656 sv_upgrade(dstr, SVt_PVNV);
3660 sv_upgrade(dstr, SVt_PVIV);
3663 (void)SvIOK_only(dstr);
3664 SvIVX(dstr) = SvIVX(sstr);
3667 if (SvTAINTED(sstr))
3678 sv_upgrade(dstr, SVt_NV);
3683 sv_upgrade(dstr, SVt_PVNV);
3686 SvNVX(dstr) = SvNVX(sstr);
3687 (void)SvNOK_only(dstr);
3688 if (SvTAINTED(sstr))
3696 sv_upgrade(dstr, SVt_RV);
3697 else if (dtype == SVt_PVGV &&
3698 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3701 if (GvIMPORTED(dstr) != GVf_IMPORTED
3702 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3704 GvIMPORTED_on(dstr);
3713 #ifdef PERL_COPY_ON_WRITE
3714 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3715 if (dtype < SVt_PVIV)
3716 sv_upgrade(dstr, SVt_PVIV);
3723 sv_upgrade(dstr, SVt_PV);
3726 if (dtype < SVt_PVIV)
3727 sv_upgrade(dstr, SVt_PVIV);
3730 if (dtype < SVt_PVNV)
3731 sv_upgrade(dstr, SVt_PVNV);
3738 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3741 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3745 if (dtype <= SVt_PVGV) {
3747 if (dtype != SVt_PVGV) {
3748 char *name = GvNAME(sstr);
3749 STRLEN len = GvNAMELEN(sstr);
3750 sv_upgrade(dstr, SVt_PVGV);
3751 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3752 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3753 GvNAME(dstr) = savepvn(name, len);
3754 GvNAMELEN(dstr) = len;
3755 SvFAKE_on(dstr); /* can coerce to non-glob */
3757 /* ahem, death to those who redefine active sort subs */
3758 else if (PL_curstackinfo->si_type == PERLSI_SORT
3759 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3760 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3763 #ifdef GV_UNIQUE_CHECK
3764 if (GvUNIQUE((GV*)dstr)) {
3765 Perl_croak(aTHX_ PL_no_modify);
3769 (void)SvOK_off(dstr);
3770 GvINTRO_off(dstr); /* one-shot flag */
3772 GvGP(dstr) = gp_ref(GvGP(sstr));
3773 if (SvTAINTED(sstr))
3775 if (GvIMPORTED(dstr) != GVf_IMPORTED
3776 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3778 GvIMPORTED_on(dstr);
3786 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3788 if ((int)SvTYPE(sstr) != stype) {
3789 stype = SvTYPE(sstr);
3790 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3794 if (stype == SVt_PVLV)
3795 (void)SvUPGRADE(dstr, SVt_PVNV);
3797 (void)SvUPGRADE(dstr, (U32)stype);
3800 sflags = SvFLAGS(sstr);
3802 if (sflags & SVf_ROK) {
3803 if (dtype >= SVt_PV) {
3804 if (dtype == SVt_PVGV) {
3805 SV *sref = SvREFCNT_inc(SvRV(sstr));
3807 int intro = GvINTRO(dstr);
3809 #ifdef GV_UNIQUE_CHECK
3810 if (GvUNIQUE((GV*)dstr)) {
3811 Perl_croak(aTHX_ PL_no_modify);
3816 GvINTRO_off(dstr); /* one-shot flag */
3817 GvLINE(dstr) = CopLINE(PL_curcop);
3818 GvEGV(dstr) = (GV*)dstr;
3821 switch (SvTYPE(sref)) {
3824 SAVEGENERICSV(GvAV(dstr));
3826 dref = (SV*)GvAV(dstr);
3827 GvAV(dstr) = (AV*)sref;
3828 if (!GvIMPORTED_AV(dstr)
3829 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3831 GvIMPORTED_AV_on(dstr);
3836 SAVEGENERICSV(GvHV(dstr));
3838 dref = (SV*)GvHV(dstr);
3839 GvHV(dstr) = (HV*)sref;
3840 if (!GvIMPORTED_HV(dstr)
3841 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3843 GvIMPORTED_HV_on(dstr);
3848 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3849 SvREFCNT_dec(GvCV(dstr));
3850 GvCV(dstr) = Nullcv;
3851 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3852 PL_sub_generation++;
3854 SAVEGENERICSV(GvCV(dstr));
3857 dref = (SV*)GvCV(dstr);
3858 if (GvCV(dstr) != (CV*)sref) {
3859 CV* cv = GvCV(dstr);
3861 if (!GvCVGEN((GV*)dstr) &&
3862 (CvROOT(cv) || CvXSUB(cv)))
3864 /* ahem, death to those who redefine
3865 * active sort subs */
3866 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3867 PL_sortcop == CvSTART(cv))
3869 "Can't redefine active sort subroutine %s",
3870 GvENAME((GV*)dstr));
3871 /* Redefining a sub - warning is mandatory if
3872 it was a const and its value changed. */
3873 if (ckWARN(WARN_REDEFINE)
3875 && (!CvCONST((CV*)sref)
3876 || sv_cmp(cv_const_sv(cv),
3877 cv_const_sv((CV*)sref)))))
3879 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3881 ? "Constant subroutine %s::%s redefined"
3882 : "Subroutine %s::%s redefined",
3883 HvNAME(GvSTASH((GV*)dstr)),
3884 GvENAME((GV*)dstr));
3888 cv_ckproto(cv, (GV*)dstr,
3889 SvPOK(sref) ? SvPVX(sref) : Nullch);
3891 GvCV(dstr) = (CV*)sref;
3892 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3893 GvASSUMECV_on(dstr);
3894 PL_sub_generation++;
3896 if (!GvIMPORTED_CV(dstr)
3897 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3899 GvIMPORTED_CV_on(dstr);
3904 SAVEGENERICSV(GvIOp(dstr));
3906 dref = (SV*)GvIOp(dstr);
3907 GvIOp(dstr) = (IO*)sref;
3911 SAVEGENERICSV(GvFORM(dstr));
3913 dref = (SV*)GvFORM(dstr);
3914 GvFORM(dstr) = (CV*)sref;
3918 SAVEGENERICSV(GvSV(dstr));
3920 dref = (SV*)GvSV(dstr);
3922 if (!GvIMPORTED_SV(dstr)
3923 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3925 GvIMPORTED_SV_on(dstr);
3931 if (SvTAINTED(sstr))
3936 (void)SvOOK_off(dstr); /* backoff */
3938 Safefree(SvPVX(dstr));
3939 SvLEN(dstr)=SvCUR(dstr)=0;
3942 (void)SvOK_off(dstr);
3943 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3945 if (sflags & SVp_NOK) {
3947 /* Only set the public OK flag if the source has public OK. */
3948 if (sflags & SVf_NOK)
3949 SvFLAGS(dstr) |= SVf_NOK;
3950 SvNVX(dstr) = SvNVX(sstr);
3952 if (sflags & SVp_IOK) {
3953 (void)SvIOKp_on(dstr);
3954 if (sflags & SVf_IOK)
3955 SvFLAGS(dstr) |= SVf_IOK;
3956 if (sflags & SVf_IVisUV)
3958 SvIVX(dstr) = SvIVX(sstr);
3960 if (SvAMAGIC(sstr)) {
3964 else if (sflags & SVp_POK) {
3968 * Check to see if we can just swipe the string. If so, it's a
3969 * possible small lose on short strings, but a big win on long ones.
3970 * It might even be a win on short strings if SvPVX(dstr)
3971 * has to be allocated and SvPVX(sstr) has to be freed.
3975 #ifdef PERL_COPY_ON_WRITE
3976 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3980 (sflags & SVs_TEMP) && /* slated for free anyway? */
3981 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3982 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3983 SvLEN(sstr) && /* and really is a string */
3984 /* and won't be needed again, potentially */
3985 !(PL_op && PL_op->op_type == OP_AASSIGN))
3986 #ifdef PERL_COPY_ON_WRITE
3987 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3988 && SvTYPE(sstr) >= SVt_PVIV)
3991 /* Failed the swipe test, and it's not a shared hash key either.
3992 Have to copy the string. */
3993 STRLEN len = SvCUR(sstr);
3994 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3995 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3996 SvCUR_set(dstr, len);
3997 *SvEND(dstr) = '\0';
3998 (void)SvPOK_only(dstr);
4000 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
4002 #ifdef PERL_COPY_ON_WRITE
4003 /* Either it's a shared hash key, or it's suitable for
4004 copy-on-write or we can swipe the string. */
4006 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4011 /* I believe I should acquire a global SV mutex if
4012 it's a COW sv (not a shared hash key) to stop
4013 it going un copy-on-write.
4014 If the source SV has gone un copy on write between up there
4015 and down here, then (assert() that) it is of the correct
4016 form to make it copy on write again */
4017 if ((sflags & (SVf_FAKE | SVf_READONLY))
4018 != (SVf_FAKE | SVf_READONLY)) {
4019 SvREADONLY_on(sstr);
4021 /* Make the source SV into a loop of 1.
4022 (about to become 2) */
4023 SV_COW_NEXT_SV_SET(sstr, sstr);
4027 /* Initial code is common. */
4028 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
4030 SvFLAGS(dstr) &= ~SVf_OOK;
4031 Safefree(SvPVX(dstr) - SvIVX(dstr));
4033 else if (SvLEN(dstr))
4034 Safefree(SvPVX(dstr));
4036 (void)SvPOK_only(dstr);
4038 #ifdef PERL_COPY_ON_WRITE
4040 /* making another shared SV. */
4041 STRLEN cur = SvCUR(sstr);
4042 STRLEN len = SvLEN(sstr);
4043 assert (SvTYPE(dstr) >= SVt_PVIV);
4045 /* SvIsCOW_normal */
4046 /* splice us in between source and next-after-source. */
4047 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4048 SV_COW_NEXT_SV_SET(sstr, dstr);
4049 SvPV_set(dstr, SvPVX(sstr));
4051 /* SvIsCOW_shared_hash */
4052 UV hash = SvUVX(sstr);
4053 DEBUG_C(PerlIO_printf(Perl_debug_log,
4054 "Copy on write: Sharing hash\n"));
4056 sharepvn(SvPVX(sstr),
4057 (sflags & SVf_UTF8?-cur:cur), hash));
4062 SvREADONLY_on(dstr);
4064 /* Relesase a global SV mutex. */
4068 { /* Passes the swipe test. */
4069 SvPV_set(dstr, SvPVX(sstr));
4070 SvLEN_set(dstr, SvLEN(sstr));
4071 SvCUR_set(dstr, SvCUR(sstr));
4074 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4075 SvPV_set(sstr, Nullch);
4081 if (sflags & SVf_UTF8)
4084 if (sflags & SVp_NOK) {
4086 if (sflags & SVf_NOK)
4087 SvFLAGS(dstr) |= SVf_NOK;
4088 SvNVX(dstr) = SvNVX(sstr);
4090 if (sflags & SVp_IOK) {
4091 (void)SvIOKp_on(dstr);
4092 if (sflags & SVf_IOK)
4093 SvFLAGS(dstr) |= SVf_IOK;
4094 if (sflags & SVf_IVisUV)
4096 SvIVX(dstr) = SvIVX(sstr);
4099 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4100 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4101 smg->mg_ptr, smg->mg_len);
4102 SvRMAGICAL_on(dstr);
4105 else if (sflags & SVp_IOK) {
4106 if (sflags & SVf_IOK)
4107 (void)SvIOK_only(dstr);
4109 (void)SvOK_off(dstr);
4110 (void)SvIOKp_on(dstr);
4112 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4113 if (sflags & SVf_IVisUV)
4115 SvIVX(dstr) = SvIVX(sstr);
4116 if (sflags & SVp_NOK) {
4117 if (sflags & SVf_NOK)
4118 (void)SvNOK_on(dstr);
4120 (void)SvNOKp_on(dstr);
4121 SvNVX(dstr) = SvNVX(sstr);
4124 else if (sflags & SVp_NOK) {
4125 if (sflags & SVf_NOK)
4126 (void)SvNOK_only(dstr);
4128 (void)SvOK_off(dstr);
4131 SvNVX(dstr) = SvNVX(sstr);
4134 if (dtype == SVt_PVGV) {
4135 if (ckWARN(WARN_MISC))
4136 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4139 (void)SvOK_off(dstr);
4141 if (SvTAINTED(sstr))
4146 =for apidoc sv_setsv_mg
4148 Like C<sv_setsv>, but also handles 'set' magic.
4154 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4156 sv_setsv(dstr,sstr);
4160 #ifdef PERL_COPY_ON_WRITE
4162 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4164 STRLEN cur = SvCUR(sstr);
4165 STRLEN len = SvLEN(sstr);
4166 register char *new_pv;
4169 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4177 if (SvTHINKFIRST(dstr))
4178 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4179 else if (SvPVX(dstr))
4180 Safefree(SvPVX(dstr));
4184 SvUPGRADE (dstr, SVt_PVIV);
4186 assert (SvPOK(sstr));
4187 assert (SvPOKp(sstr));
4188 assert (!SvIOK(sstr));
4189 assert (!SvIOKp(sstr));
4190 assert (!SvNOK(sstr));
4191 assert (!SvNOKp(sstr));
4193 if (SvIsCOW(sstr)) {
4195 if (SvLEN(sstr) == 0) {
4196 /* source is a COW shared hash key. */
4197 UV hash = SvUVX(sstr);
4198 DEBUG_C(PerlIO_printf(Perl_debug_log,
4199 "Fast copy on write: Sharing hash\n"));
4201 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4204 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4206 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4207 SvUPGRADE (sstr, SVt_PVIV);
4208 SvREADONLY_on(sstr);
4210 DEBUG_C(PerlIO_printf(Perl_debug_log,
4211 "Fast copy on write: Converting sstr to COW\n"));
4212 SV_COW_NEXT_SV_SET(dstr, sstr);
4214 SV_COW_NEXT_SV_SET(sstr, dstr);
4215 new_pv = SvPVX(sstr);
4218 SvPV_set(dstr, new_pv);
4219 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4232 =for apidoc sv_setpvn
4234 Copies a string into an SV. The C<len> parameter indicates the number of
4235 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4241 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4243 register char *dptr;
4245 SV_CHECK_THINKFIRST_COW_DROP(sv);
4251 /* len is STRLEN which is unsigned, need to copy to signed */
4254 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4256 (void)SvUPGRADE(sv, SVt_PV);
4258 SvGROW(sv, len + 1);
4260 Move(ptr,dptr,len,char);
4263 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4268 =for apidoc sv_setpvn_mg
4270 Like C<sv_setpvn>, but also handles 'set' magic.
4276 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4278 sv_setpvn(sv,ptr,len);
4283 =for apidoc sv_setpv
4285 Copies a string into an SV. The string must be null-terminated. Does not
4286 handle 'set' magic. See C<sv_setpv_mg>.
4292 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4294 register STRLEN len;
4296 SV_CHECK_THINKFIRST_COW_DROP(sv);
4302 (void)SvUPGRADE(sv, SVt_PV);
4304 SvGROW(sv, len + 1);
4305 Move(ptr,SvPVX(sv),len+1,char);
4307 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4312 =for apidoc sv_setpv_mg
4314 Like C<sv_setpv>, but also handles 'set' magic.
4320 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4327 =for apidoc sv_usepvn
4329 Tells an SV to use C<ptr> to find its string value. Normally the string is
4330 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4331 The C<ptr> should point to memory that was allocated by C<malloc>. The
4332 string length, C<len>, must be supplied. This function will realloc the
4333 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4334 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4335 See C<sv_usepvn_mg>.
4341 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4343 SV_CHECK_THINKFIRST_COW_DROP(sv);
4344 (void)SvUPGRADE(sv, SVt_PV);
4349 (void)SvOOK_off(sv);
4350 if (SvPVX(sv) && SvLEN(sv))
4351 Safefree(SvPVX(sv));
4352 Renew(ptr, len+1, char);
4355 SvLEN_set(sv, len+1);
4357 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4362 =for apidoc sv_usepvn_mg
4364 Like C<sv_usepvn>, but also handles 'set' magic.
4370 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4372 sv_usepvn(sv,ptr,len);
4376 #ifdef PERL_COPY_ON_WRITE
4377 /* Need to do this *after* making the SV normal, as we need the buffer
4378 pointer to remain valid until after we've copied it. If we let go too early,
4379 another thread could invalidate it by unsharing last of the same hash key
4380 (which it can do by means other than releasing copy-on-write Svs)
4381 or by changing the other copy-on-write SVs in the loop. */
4383 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4384 U32 hash, SV *after)
4386 if (len) { /* this SV was SvIsCOW_normal(sv) */
4387 /* we need to find the SV pointing to us. */
4388 SV *current = SV_COW_NEXT_SV(after);
4390 if (current == sv) {
4391 /* The SV we point to points back to us (there were only two of us
4393 Hence other SV is no longer copy on write either. */
4395 SvREADONLY_off(after);
4397 /* We need to follow the pointers around the loop. */
4399 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4402 /* don't loop forever if the structure is bust, and we have
4403 a pointer into a closed loop. */
4404 assert (current != after);
4405 assert (SvPVX(current) == pvx);
4407 /* Make the SV before us point to the SV after us. */
4408 SV_COW_NEXT_SV_SET(current, after);
4411 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4416 Perl_sv_release_IVX(pTHX_ register SV *sv)
4419 sv_force_normal_flags(sv, 0);
4420 return SvOOK_off(sv);
4424 =for apidoc sv_force_normal_flags
4426 Undo various types of fakery on an SV: if the PV is a shared string, make
4427 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4428 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4429 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4430 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4431 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4432 set to some other value.) In addition, the C<flags> parameter gets passed to
4433 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4434 with flags set to 0.
4440 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4442 #ifdef PERL_COPY_ON_WRITE
4443 if (SvREADONLY(sv)) {
4444 /* At this point I believe I should acquire a global SV mutex. */
4446 char *pvx = SvPVX(sv);
4447 STRLEN len = SvLEN(sv);
4448 STRLEN cur = SvCUR(sv);
4449 U32 hash = SvUVX(sv);
4450 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4452 PerlIO_printf(Perl_debug_log,
4453 "Copy on write: Force normal %ld\n",
4459 /* This SV doesn't own the buffer, so need to New() a new one: */
4462 if (flags & SV_COW_DROP_PV) {
4463 /* OK, so we don't need to copy our buffer. */
4466 SvGROW(sv, cur + 1);
4467 Move(pvx,SvPVX(sv),cur,char);
4471 sv_release_COW(sv, pvx, cur, len, hash, next);
4476 else if (PL_curcop != &PL_compiling)
4477 Perl_croak(aTHX_ PL_no_modify);
4478 /* At this point I believe that I can drop the global SV mutex. */
4481 if (SvREADONLY(sv)) {
4483 char *pvx = SvPVX(sv);
4484 STRLEN len = SvCUR(sv);
4485 U32 hash = SvUVX(sv);
4488 SvGROW(sv, len + 1);
4489 Move(pvx,SvPVX(sv),len,char);
4491 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4493 else if (PL_curcop != &PL_compiling)
4494 Perl_croak(aTHX_ PL_no_modify);
4498 sv_unref_flags(sv, flags);
4499 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4504 =for apidoc sv_force_normal
4506 Undo various types of fakery on an SV: if the PV is a shared string, make
4507 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4508 an xpvmg. See also C<sv_force_normal_flags>.
4514 Perl_sv_force_normal(pTHX_ register SV *sv)
4516 sv_force_normal_flags(sv, 0);
4522 Efficient removal of characters from the beginning of the string buffer.
4523 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4524 the string buffer. The C<ptr> becomes the first character of the adjusted
4525 string. Uses the "OOK hack".
4526 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
4527 refer to the same chunk of data.
4533 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4535 register STRLEN delta;
4536 if (!ptr || !SvPOKp(sv))
4538 delta = ptr - SvPVX(sv);
4539 SV_CHECK_THINKFIRST(sv);
4540 if (SvTYPE(sv) < SVt_PVIV)
4541 sv_upgrade(sv,SVt_PVIV);
4544 if (!SvLEN(sv)) { /* make copy of shared string */
4545 char *pvx = SvPVX(sv);
4546 STRLEN len = SvCUR(sv);
4547 SvGROW(sv, len + 1);
4548 Move(pvx,SvPVX(sv),len,char);
4552 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4553 and we do that anyway inside the SvNIOK_off
4555 SvFLAGS(sv) |= SVf_OOK;
4564 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4565 * this function provided for binary compatibility only
4569 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4571 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4575 =for apidoc sv_catpvn
4577 Concatenates the string onto the end of the string which is in the SV. The
4578 C<len> indicates number of bytes to copy. If the SV has the UTF8
4579 status set, then the bytes appended should be valid UTF8.
4580 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4582 =for apidoc sv_catpvn_flags
4584 Concatenates the string onto the end of the string which is in the SV. The
4585 C<len> indicates number of bytes to copy. If the SV has the UTF8
4586 status set, then the bytes appended should be valid UTF8.
4587 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4588 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4589 in terms of this function.
4595 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4600 dstr = SvPV_force_flags(dsv, dlen, flags);
4601 SvGROW(dsv, dlen + slen + 1);
4604 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4607 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4612 =for apidoc sv_catpvn_mg
4614 Like C<sv_catpvn>, but also handles 'set' magic.
4620 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4622 sv_catpvn(sv,ptr,len);
4626 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4627 * this function provided for binary compatibility only
4631 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4633 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4637 =for apidoc sv_catsv
4639 Concatenates the string from SV C<ssv> onto the end of the string in
4640 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4641 not 'set' magic. See C<sv_catsv_mg>.
4643 =for apidoc sv_catsv_flags
4645 Concatenates the string from SV C<ssv> onto the end of the string in
4646 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4647 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4648 and C<sv_catsv_nomg> are implemented in terms of this function.
4653 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4659 if ((spv = SvPV(ssv, slen))) {
4660 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4661 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4662 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4663 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4664 dsv->sv_flags doesn't have that bit set.
4665 Andy Dougherty 12 Oct 2001
4667 I32 sutf8 = DO_UTF8(ssv);
4670 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4672 dutf8 = DO_UTF8(dsv);
4674 if (dutf8 != sutf8) {
4676 /* Not modifying source SV, so taking a temporary copy. */
4677 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4679 sv_utf8_upgrade(csv);
4680 spv = SvPV(csv, slen);
4683 sv_utf8_upgrade_nomg(dsv);
4685 sv_catpvn_nomg(dsv, spv, slen);
4690 =for apidoc sv_catsv_mg
4692 Like C<sv_catsv>, but also handles 'set' magic.
4698 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4705 =for apidoc sv_catpv
4707 Concatenates the string onto the end of the string which is in the SV.
4708 If the SV has the UTF8 status set, then the bytes appended should be
4709 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4714 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4716 register STRLEN len;
4722 junk = SvPV_force(sv, tlen);
4724 SvGROW(sv, tlen + len + 1);
4727 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4729 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4734 =for apidoc sv_catpv_mg
4736 Like C<sv_catpv>, but also handles 'set' magic.
4742 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4751 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4752 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4759 Perl_newSV(pTHX_ STRLEN len)
4765 sv_upgrade(sv, SVt_PV);
4766 SvGROW(sv, len + 1);
4771 =for apidoc sv_magicext
4773 Adds magic to an SV, upgrading it if necessary. Applies the
4774 supplied vtable and returns pointer to the magic added.
4776 Note that sv_magicext will allow things that sv_magic will not.
4777 In particular you can add magic to SvREADONLY SVs and and more than
4778 one instance of the same 'how'
4780 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4781 if C<namelen> is zero then C<name> is stored as-is and - as another special
4782 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4783 an C<SV*> and has its REFCNT incremented
4785 (This is now used as a subroutine by sv_magic.)
4790 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4791 const char* name, I32 namlen)
4795 if (SvTYPE(sv) < SVt_PVMG) {
4796 (void)SvUPGRADE(sv, SVt_PVMG);
4798 Newz(702,mg, 1, MAGIC);
4799 mg->mg_moremagic = SvMAGIC(sv);
4802 /* Some magic sontains a reference loop, where the sv and object refer to
4803 each other. To prevent a reference loop that would prevent such
4804 objects being freed, we look for such loops and if we find one we
4805 avoid incrementing the object refcount.
4807 Note we cannot do this to avoid self-tie loops as intervening RV must
4808 have its REFCNT incremented to keep it in existence.
4811 if (!obj || obj == sv ||
4812 how == PERL_MAGIC_arylen ||
4813 how == PERL_MAGIC_qr ||
4814 (SvTYPE(obj) == SVt_PVGV &&
4815 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4816 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4817 GvFORM(obj) == (CV*)sv)))
4822 mg->mg_obj = SvREFCNT_inc(obj);
4823 mg->mg_flags |= MGf_REFCOUNTED;
4826 /* Normal self-ties simply pass a null object, and instead of
4827 using mg_obj directly, use the SvTIED_obj macro to produce a
4828 new RV as needed. For glob "self-ties", we are tieing the PVIO
4829 with an RV obj pointing to the glob containing the PVIO. In
4830 this case, to avoid a reference loop, we need to weaken the
4834 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4835 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4841 mg->mg_len = namlen;
4844 mg->mg_ptr = savepvn(name, namlen);
4845 else if (namlen == HEf_SVKEY)
4846 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4848 mg->mg_ptr = (char *) name;
4850 mg->mg_virtual = vtable;
4854 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4859 =for apidoc sv_magic
4861 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4862 then adds a new magic item of type C<how> to the head of the magic list.
4868 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4873 #ifdef PERL_COPY_ON_WRITE
4875 sv_force_normal_flags(sv, 0);
4877 if (SvREADONLY(sv)) {
4878 if (PL_curcop != &PL_compiling
4879 && how != PERL_MAGIC_regex_global
4880 && how != PERL_MAGIC_bm
4881 && how != PERL_MAGIC_fm
4882 && how != PERL_MAGIC_sv
4885 Perl_croak(aTHX_ PL_no_modify);
4888 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4889 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4890 /* sv_magic() refuses to add a magic of the same 'how' as an
4893 if (how == PERL_MAGIC_taint)
4901 vtable = &PL_vtbl_sv;
4903 case PERL_MAGIC_overload:
4904 vtable = &PL_vtbl_amagic;
4906 case PERL_MAGIC_overload_elem:
4907 vtable = &PL_vtbl_amagicelem;
4909 case PERL_MAGIC_overload_table:
4910 vtable = &PL_vtbl_ovrld;
4913 vtable = &PL_vtbl_bm;
4915 case PERL_MAGIC_regdata:
4916 vtable = &PL_vtbl_regdata;
4918 case PERL_MAGIC_regdatum:
4919 vtable = &PL_vtbl_regdatum;
4921 case PERL_MAGIC_env:
4922 vtable = &PL_vtbl_env;
4925 vtable = &PL_vtbl_fm;
4927 case PERL_MAGIC_envelem:
4928 vtable = &PL_vtbl_envelem;
4930 case PERL_MAGIC_regex_global:
4931 vtable = &PL_vtbl_mglob;
4933 case PERL_MAGIC_isa:
4934 vtable = &PL_vtbl_isa;
4936 case PERL_MAGIC_isaelem:
4937 vtable = &PL_vtbl_isaelem;
4939 case PERL_MAGIC_nkeys:
4940 vtable = &PL_vtbl_nkeys;
4942 case PERL_MAGIC_dbfile:
4945 case PERL_MAGIC_dbline:
4946 vtable = &PL_vtbl_dbline;
4948 #ifdef USE_LOCALE_COLLATE
4949 case PERL_MAGIC_collxfrm:
4950 vtable = &PL_vtbl_collxfrm;
4952 #endif /* USE_LOCALE_COLLATE */
4953 case PERL_MAGIC_tied:
4954 vtable = &PL_vtbl_pack;
4956 case PERL_MAGIC_tiedelem:
4957 case PERL_MAGIC_tiedscalar:
4958 vtable = &PL_vtbl_packelem;
4961 vtable = &PL_vtbl_regexp;
4963 case PERL_MAGIC_sig:
4964 vtable = &PL_vtbl_sig;
4966 case PERL_MAGIC_sigelem:
4967 vtable = &PL_vtbl_sigelem;
4969 case PERL_MAGIC_taint:
4970 vtable = &PL_vtbl_taint;
4972 case PERL_MAGIC_uvar:
4973 vtable = &PL_vtbl_uvar;
4975 case PERL_MAGIC_vec:
4976 vtable = &PL_vtbl_vec;
4978 case PERL_MAGIC_vstring:
4981 case PERL_MAGIC_utf8:
4982 vtable = &PL_vtbl_utf8;
4984 case PERL_MAGIC_substr:
4985 vtable = &PL_vtbl_substr;
4987 case PERL_MAGIC_defelem:
4988 vtable = &PL_vtbl_defelem;
4990 case PERL_MAGIC_glob:
4991 vtable = &PL_vtbl_glob;
4993 case PERL_MAGIC_arylen:
4994 vtable = &PL_vtbl_arylen;
4996 case PERL_MAGIC_pos:
4997 vtable = &PL_vtbl_pos;
4999 case PERL_MAGIC_backref:
5000 vtable = &PL_vtbl_backref;
5002 case PERL_MAGIC_ext:
5003 /* Reserved for use by extensions not perl internals. */
5004 /* Useful for attaching extension internal data to perl vars. */
5005 /* Note that multiple extensions may clash if magical scalars */
5006 /* etc holding private data from one are passed to another. */
5009 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
5012 /* Rest of work is done else where */
5013 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
5016 case PERL_MAGIC_taint:
5019 case PERL_MAGIC_ext:
5020 case PERL_MAGIC_dbfile:
5027 =for apidoc sv_unmagic
5029 Removes all magic of type C<type> from an SV.
5035 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5039 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5042 for (mg = *mgp; mg; mg = *mgp) {
5043 if (mg->mg_type == type) {
5044 MGVTBL* vtbl = mg->mg_virtual;
5045 *mgp = mg->mg_moremagic;
5046 if (vtbl && vtbl->svt_free)
5047 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5048 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5050 Safefree(mg->mg_ptr);
5051 else if (mg->mg_len == HEf_SVKEY)
5052 SvREFCNT_dec((SV*)mg->mg_ptr);
5053 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5054 Safefree(mg->mg_ptr);
5056 if (mg->mg_flags & MGf_REFCOUNTED)
5057 SvREFCNT_dec(mg->mg_obj);
5061 mgp = &mg->mg_moremagic;
5065 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5072 =for apidoc sv_rvweaken
5074 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5075 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5076 push a back-reference to this RV onto the array of backreferences
5077 associated with that magic.
5083 Perl_sv_rvweaken(pTHX_ SV *sv)
5086 if (!SvOK(sv)) /* let undefs pass */
5089 Perl_croak(aTHX_ "Can't weaken a nonreference");
5090 else if (SvWEAKREF(sv)) {
5091 if (ckWARN(WARN_MISC))
5092 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5096 sv_add_backref(tsv, sv);
5102 /* Give tsv backref magic if it hasn't already got it, then push a
5103 * back-reference to sv onto the array associated with the backref magic.
5107 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5111 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5112 av = (AV*)mg->mg_obj;
5115 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5116 /* av now has a refcnt of 2, which avoids it getting freed
5117 * before us during global cleanup. The extra ref is removed
5118 * by magic_killbackrefs() when tsv is being freed */
5120 if (AvFILLp(av) >= AvMAX(av)) {
5121 SV **svp = AvARRAY(av);
5122 I32 i = AvFILLp(av);
5124 if (svp[i] == &PL_sv_undef) {
5125 svp[i] = sv; /* reuse the slot */
5130 av_extend(av, AvFILLp(av)+1);
5132 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5135 /* delete a back-reference to ourselves from the backref magic associated
5136 * with the SV we point to.
5140 S_sv_del_backref(pTHX_ SV *sv)
5147 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5148 Perl_croak(aTHX_ "panic: del_backref");
5149 av = (AV *)mg->mg_obj;
5154 svp[i] = &PL_sv_undef; /* XXX */
5161 =for apidoc sv_insert
5163 Inserts a string at the specified offset/length within the SV. Similar to
5164 the Perl substr() function.
5170 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
5174 register char *midend;
5175 register char *bigend;
5181 Perl_croak(aTHX_ "Can't modify non-existent substring");
5182 SvPV_force(bigstr, curlen);
5183 (void)SvPOK_only_UTF8(bigstr);
5184 if (offset + len > curlen) {
5185 SvGROW(bigstr, offset+len+1);
5186 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5187 SvCUR_set(bigstr, offset+len);
5191 i = littlelen - len;
5192 if (i > 0) { /* string might grow */
5193 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5194 mid = big + offset + len;
5195 midend = bigend = big + SvCUR(bigstr);
5198 while (midend > mid) /* shove everything down */
5199 *--bigend = *--midend;
5200 Move(little,big+offset,littlelen,char);
5206 Move(little,SvPVX(bigstr)+offset,len,char);
5211 big = SvPVX(bigstr);
5214 bigend = big + SvCUR(bigstr);
5216 if (midend > bigend)
5217 Perl_croak(aTHX_ "panic: sv_insert");
5219 if (mid - big > bigend - midend) { /* faster to shorten from end */
5221 Move(little, mid, littlelen,char);
5224 i = bigend - midend;
5226 Move(midend, mid, i,char);
5230 SvCUR_set(bigstr, mid - big);
5233 else if ((i = mid - big)) { /* faster from front */
5234 midend -= littlelen;
5236 sv_chop(bigstr,midend-i);
5241 Move(little, mid, littlelen,char);
5243 else if (littlelen) {
5244 midend -= littlelen;
5245 sv_chop(bigstr,midend);
5246 Move(little,midend,littlelen,char);
5249 sv_chop(bigstr,midend);
5255 =for apidoc sv_replace
5257 Make the first argument a copy of the second, then delete the original.
5258 The target SV physically takes over ownership of the body of the source SV
5259 and inherits its flags; however, the target keeps any magic it owns,
5260 and any magic in the source is discarded.
5261 Note that this is a rather specialist SV copying operation; most of the
5262 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5268 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5270 U32 refcnt = SvREFCNT(sv);
5271 SV_CHECK_THINKFIRST_COW_DROP(sv);
5272 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5273 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5274 if (SvMAGICAL(sv)) {
5278 sv_upgrade(nsv, SVt_PVMG);
5279 SvMAGIC(nsv) = SvMAGIC(sv);
5280 SvFLAGS(nsv) |= SvMAGICAL(sv);
5286 assert(!SvREFCNT(sv));
5287 StructCopy(nsv,sv,SV);
5288 #ifdef PERL_COPY_ON_WRITE
5289 if (SvIsCOW_normal(nsv)) {
5290 /* We need to follow the pointers around the loop to make the
5291 previous SV point to sv, rather than nsv. */
5294 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5297 assert(SvPVX(current) == SvPVX(nsv));
5299 /* Make the SV before us point to the SV after us. */
5301 PerlIO_printf(Perl_debug_log, "previous is\n");
5303 PerlIO_printf(Perl_debug_log,
5304 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5305 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5307 SV_COW_NEXT_SV_SET(current, sv);
5310 SvREFCNT(sv) = refcnt;
5311 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5316 =for apidoc sv_clear
5318 Clear an SV: call any destructors, free up any memory used by the body,
5319 and free the body itself. The SV's head is I<not> freed, although
5320 its type is set to all 1's so that it won't inadvertently be assumed
5321 to be live during global destruction etc.
5322 This function should only be called when REFCNT is zero. Most of the time
5323 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5330 Perl_sv_clear(pTHX_ register SV *sv)
5334 assert(SvREFCNT(sv) == 0);
5337 if (PL_defstash) { /* Still have a symbol table? */
5344 stash = SvSTASH(sv);
5345 destructor = StashHANDLER(stash,DESTROY);
5347 SV* tmpref = newRV(sv);
5348 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5350 PUSHSTACKi(PERLSI_DESTROY);
5355 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5361 if(SvREFCNT(tmpref) < 2) {
5362 /* tmpref is not kept alive! */
5367 SvREFCNT_dec(tmpref);
5369 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5373 if (PL_in_clean_objs)
5374 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5376 /* DESTROY gave object new lease on life */
5382 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5383 SvOBJECT_off(sv); /* Curse the object. */
5384 if (SvTYPE(sv) != SVt_PVIO)
5385 --PL_sv_objcount; /* XXX Might want something more general */
5388 if (SvTYPE(sv) >= SVt_PVMG) {
5391 if (SvFLAGS(sv) & SVpad_TYPED)
5392 SvREFCNT_dec(SvSTASH(sv));
5395 switch (SvTYPE(sv)) {
5398 IoIFP(sv) != PerlIO_stdin() &&
5399 IoIFP(sv) != PerlIO_stdout() &&
5400 IoIFP(sv) != PerlIO_stderr())
5402 io_close((IO*)sv, FALSE);
5404 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5405 PerlDir_close(IoDIRP(sv));
5406 IoDIRP(sv) = (DIR*)NULL;
5407 Safefree(IoTOP_NAME(sv));
5408 Safefree(IoFMT_NAME(sv));
5409 Safefree(IoBOTTOM_NAME(sv));
5424 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5425 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5426 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5427 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5429 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5430 SvREFCNT_dec(LvTARG(sv));
5434 Safefree(GvNAME(sv));
5435 /* cannot decrease stash refcount yet, as we might recursively delete
5436 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5437 of stash until current sv is completely gone.
5438 -- JohnPC, 27 Mar 1998 */
5439 stash = GvSTASH(sv);
5445 (void)SvOOK_off(sv);
5453 SvREFCNT_dec(SvRV(sv));
5455 #ifdef PERL_COPY_ON_WRITE
5456 else if (SvPVX(sv)) {
5458 /* I believe I need to grab the global SV mutex here and
5459 then recheck the COW status. */
5461 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5464 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5465 SvUVX(sv), SV_COW_NEXT_SV(sv));
5466 /* And drop it here. */
5468 } else if (SvLEN(sv)) {
5469 Safefree(SvPVX(sv));
5473 else if (SvPVX(sv) && SvLEN(sv))
5474 Safefree(SvPVX(sv));
5475 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5476 unsharepvn(SvPVX(sv),
5477 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5491 switch (SvTYPE(sv)) {
5507 del_XPVIV(SvANY(sv));
5510 del_XPVNV(SvANY(sv));
5513 del_XPVMG(SvANY(sv));
5516 del_XPVLV(SvANY(sv));
5519 del_XPVAV(SvANY(sv));
5522 del_XPVHV(SvANY(sv));
5525 del_XPVCV(SvANY(sv));
5528 del_XPVGV(SvANY(sv));
5529 /* code duplication for increased performance. */
5530 SvFLAGS(sv) &= SVf_BREAK;
5531 SvFLAGS(sv) |= SVTYPEMASK;
5532 /* decrease refcount of the stash that owns this GV, if any */
5534 SvREFCNT_dec(stash);
5535 return; /* not break, SvFLAGS reset already happened */
5537 del_XPVBM(SvANY(sv));
5540 del_XPVFM(SvANY(sv));
5543 del_XPVIO(SvANY(sv));
5546 SvFLAGS(sv) &= SVf_BREAK;
5547 SvFLAGS(sv) |= SVTYPEMASK;
5551 =for apidoc sv_newref
5553 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5560 Perl_sv_newref(pTHX_ SV *sv)
5570 Decrement an SV's reference count, and if it drops to zero, call
5571 C<sv_clear> to invoke destructors and free up any memory used by
5572 the body; finally, deallocate the SV's head itself.
5573 Normally called via a wrapper macro C<SvREFCNT_dec>.
5579 Perl_sv_free(pTHX_ SV *sv)
5583 if (SvREFCNT(sv) == 0) {
5584 if (SvFLAGS(sv) & SVf_BREAK)
5585 /* this SV's refcnt has been artificially decremented to
5586 * trigger cleanup */
5588 if (PL_in_clean_all) /* All is fair */
5590 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5591 /* make sure SvREFCNT(sv)==0 happens very seldom */
5592 SvREFCNT(sv) = (~(U32)0)/2;
5595 if (ckWARN_d(WARN_INTERNAL))
5596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
5599 if (--(SvREFCNT(sv)) > 0)
5601 Perl_sv_free2(aTHX_ sv);
5605 Perl_sv_free2(pTHX_ SV *sv)
5609 if (ckWARN_d(WARN_DEBUGGING))
5610 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5611 "Attempt to free temp prematurely: SV 0x%"UVxf,
5616 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5617 /* make sure SvREFCNT(sv)==0 happens very seldom */
5618 SvREFCNT(sv) = (~(U32)0)/2;
5629 Returns the length of the string in the SV. Handles magic and type
5630 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5636 Perl_sv_len(pTHX_ register SV *sv)
5644 len = mg_length(sv);
5646 (void)SvPV(sv, len);
5651 =for apidoc sv_len_utf8
5653 Returns the number of characters in the string in an SV, counting wide
5654 UTF8 bytes as a single character. Handles magic and type coercion.
5660 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5661 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5662 * (Note that the mg_len is not the length of the mg_ptr field.)
5667 Perl_sv_len_utf8(pTHX_ register SV *sv)
5673 return mg_length(sv);
5677 U8 *s = (U8*)SvPV(sv, len);
5678 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5680 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5682 #ifdef PERL_UTF8_CACHE_ASSERT
5683 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5687 ulen = Perl_utf8_length(aTHX_ s, s + len);
5688 if (!mg && !SvREADONLY(sv)) {
5689 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5690 mg = mg_find(sv, PERL_MAGIC_utf8);
5700 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5701 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5702 * between UTF-8 and byte offsets. There are two (substr offset and substr
5703 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5704 * and byte offset) cache positions.
5706 * The mg_len field is used by sv_len_utf8(), see its comments.
5707 * Note that the mg_len is not the length of the mg_ptr field.
5711 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
5715 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5717 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5718 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5723 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5725 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5726 (*mgp)->mg_ptr = (char *) *cachep;
5730 (*cachep)[i] = *offsetp;
5731 (*cachep)[i+1] = s - start;
5739 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5740 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5741 * between UTF-8 and byte offsets. See also the comments of
5742 * S_utf8_mg_pos_init().
5746 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
5750 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5752 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5753 if (*mgp && (*mgp)->mg_ptr) {
5754 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5755 ASSERT_UTF8_CACHE(*cachep);
5756 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5758 else { /* We will skip to the right spot. */
5763 /* The assumption is that going backward is half
5764 * the speed of going forward (that's where the
5765 * 2 * backw in the below comes from). (The real
5766 * figure of course depends on the UTF-8 data.) */
5768 if ((*cachep)[i] > (STRLEN)uoff) {
5770 backw = (*cachep)[i] - (STRLEN)uoff;
5772 if (forw < 2 * backw)
5775 p = start + (*cachep)[i+1];
5777 /* Try this only for the substr offset (i == 0),
5778 * not for the substr length (i == 2). */
5779 else if (i == 0) { /* (*cachep)[i] < uoff */
5780 STRLEN ulen = sv_len_utf8(sv);
5782 if ((STRLEN)uoff < ulen) {
5783 forw = (STRLEN)uoff - (*cachep)[i];
5784 backw = ulen - (STRLEN)uoff;
5786 if (forw < 2 * backw)
5787 p = start + (*cachep)[i+1];
5792 /* If the string is not long enough for uoff,
5793 * we could extend it, but not at this low a level. */
5797 if (forw < 2 * backw) {
5804 while (UTF8_IS_CONTINUATION(*p))
5809 /* Update the cache. */
5810 (*cachep)[i] = (STRLEN)uoff;
5811 (*cachep)[i+1] = p - start;
5816 if (found) { /* Setup the return values. */
5817 *offsetp = (*cachep)[i+1];
5818 *sp = start + *offsetp;
5821 *offsetp = send - start;
5823 else if (*sp < start) {
5829 #ifdef PERL_UTF8_CACHE_ASSERT
5834 while (n-- && s < send)
5838 assert(*offsetp == s - start);
5839 assert((*cachep)[0] == (STRLEN)uoff);
5840 assert((*cachep)[1] == *offsetp);
5842 ASSERT_UTF8_CACHE(*cachep);
5851 =for apidoc sv_pos_u2b
5853 Converts the value pointed to by offsetp from a count of UTF8 chars from
5854 the start of the string, to a count of the equivalent number of bytes; if
5855 lenp is non-zero, it does the same to lenp, but this time starting from
5856 the offset, rather than from the start of the string. Handles magic and
5863 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5864 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5865 * byte offsets. See also the comments of S_utf8_mg_pos().
5870 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5881 start = s = (U8*)SvPV(sv, len);
5883 I32 uoffset = *offsetp;
5888 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5890 if (!found && uoffset > 0) {
5891 while (s < send && uoffset--)
5895 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
5897 *offsetp = s - start;
5902 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
5906 if (!found && *lenp > 0) {
5909 while (s < send && ulen--)
5913 if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
5914 cache[2] += *offsetp;
5918 ASSERT_UTF8_CACHE(cache);
5930 =for apidoc sv_pos_b2u
5932 Converts the value pointed to by offsetp from a count of bytes from the
5933 start of the string, to a count of the equivalent number of UTF8 chars.
5934 Handles magic and type coercion.
5940 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5941 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5942 * byte offsets. See also the comments of S_utf8_mg_pos().
5947 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5955 s = (U8*)SvPV(sv, len);
5956 if ((I32)len < *offsetp)
5957 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5959 U8* send = s + *offsetp;
5961 STRLEN *cache = NULL;
5965 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5966 mg = mg_find(sv, PERL_MAGIC_utf8);
5967 if (mg && mg->mg_ptr) {
5968 cache = (STRLEN *) mg->mg_ptr;
5969 if (cache[1] == (STRLEN)*offsetp) {
5970 /* An exact match. */
5971 *offsetp = cache[0];
5975 else if (cache[1] < (STRLEN)*offsetp) {
5976 /* We already know part of the way. */
5979 /* Let the below loop do the rest. */
5981 else { /* cache[1] > *offsetp */
5982 /* We already know all of the way, now we may
5983 * be able to walk back. The same assumption
5984 * is made as in S_utf8_mg_pos(), namely that
5985 * walking backward is twice slower than
5986 * walking forward. */
5987 STRLEN forw = *offsetp;
5988 STRLEN backw = cache[1] - *offsetp;
5990 if (!(forw < 2 * backw)) {
5991 U8 *p = s + cache[1];
5998 while (UTF8_IS_CONTINUATION(*p)) {
6006 *offsetp = cache[0];
6011 ASSERT_UTF8_CACHE(cache);
6017 /* Call utf8n_to_uvchr() to validate the sequence
6018 * (unless a simple non-UTF character) */
6019 if (!UTF8_IS_INVARIANT(*s))
6020 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
6029 if (!SvREADONLY(sv)) {
6031 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
6032 mg = mg_find(sv, PERL_MAGIC_utf8);
6037 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
6038 mg->mg_ptr = (char *) cache;
6043 cache[1] = *offsetp;
6054 Returns a boolean indicating whether the strings in the two SVs are
6055 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6056 coerce its args to strings if necessary.
6062 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6070 SV* svrecode = Nullsv;
6077 pv1 = SvPV(sv1, cur1);
6084 pv2 = SvPV(sv2, cur2);
6086 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6087 /* Differing utf8ness.
6088 * Do not UTF8size the comparands as a side-effect. */
6091 svrecode = newSVpvn(pv2, cur2);
6092 sv_recode_to_utf8(svrecode, PL_encoding);
6093 pv2 = SvPV(svrecode, cur2);
6096 svrecode = newSVpvn(pv1, cur1);
6097 sv_recode_to_utf8(svrecode, PL_encoding);
6098 pv1 = SvPV(svrecode, cur1);
6100 /* Now both are in UTF-8. */
6105 bool is_utf8 = TRUE;
6108 /* sv1 is the UTF-8 one,
6109 * if is equal it must be downgrade-able */
6110 char *pv = (char*)bytes_from_utf8((U8*)pv1,
6116 /* sv2 is the UTF-8 one,
6117 * if is equal it must be downgrade-able */
6118 char *pv = (char *)bytes_from_utf8((U8*)pv2,
6124 /* Downgrade not possible - cannot be eq */
6131 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6134 SvREFCNT_dec(svrecode);
6145 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6146 string in C<sv1> is less than, equal to, or greater than the string in
6147 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6148 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6154 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6157 char *pv1, *pv2, *tpv = Nullch;
6159 SV *svrecode = Nullsv;
6166 pv1 = SvPV(sv1, cur1);
6173 pv2 = SvPV(sv2, cur2);
6175 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6176 /* Differing utf8ness.
6177 * Do not UTF8size the comparands as a side-effect. */
6180 svrecode = newSVpvn(pv2, cur2);
6181 sv_recode_to_utf8(svrecode, PL_encoding);
6182 pv2 = SvPV(svrecode, cur2);
6185 pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
6190 svrecode = newSVpvn(pv1, cur1);
6191 sv_recode_to_utf8(svrecode, PL_encoding);
6192 pv1 = SvPV(svrecode, cur1);
6195 pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
6201 cmp = cur2 ? -1 : 0;
6205 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
6208 cmp = retval < 0 ? -1 : 1;
6209 } else if (cur1 == cur2) {
6212 cmp = cur1 < cur2 ? -1 : 1;
6217 SvREFCNT_dec(svrecode);
6226 =for apidoc sv_cmp_locale
6228 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6229 'use bytes' aware, handles get magic, and will coerce its args to strings
6230 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6236 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6238 #ifdef USE_LOCALE_COLLATE
6244 if (PL_collation_standard)
6248 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6250 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6252 if (!pv1 || !len1) {
6263 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6266 return retval < 0 ? -1 : 1;
6269 * When the result of collation is equality, that doesn't mean
6270 * that there are no differences -- some locales exclude some
6271 * characters from consideration. So to avoid false equalities,
6272 * we use the raw string as a tiebreaker.
6278 #endif /* USE_LOCALE_COLLATE */
6280 return sv_cmp(sv1, sv2);
6284 #ifdef USE_LOCALE_COLLATE
6287 =for apidoc sv_collxfrm
6289 Add Collate Transform magic to an SV if it doesn't already have it.
6291 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6292 scalar data of the variable, but transformed to such a format that a normal
6293 memory comparison can be used to compare the data according to the locale
6300 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6304 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6305 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6310 Safefree(mg->mg_ptr);
6312 if ((xf = mem_collxfrm(s, len, &xlen))) {
6313 if (SvREADONLY(sv)) {
6316 return xf + sizeof(PL_collation_ix);
6319 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6320 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6333 if (mg && mg->mg_ptr) {
6335 return mg->mg_ptr + sizeof(PL_collation_ix);
6343 #endif /* USE_LOCALE_COLLATE */
6348 Get a line from the filehandle and store it into the SV, optionally
6349 appending to the currently-stored string.
6355 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6359 register STDCHAR rslast;
6360 register STDCHAR *bp;
6366 if (SvTHINKFIRST(sv))
6367 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6368 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6370 However, perlbench says it's slower, because the existing swipe code
6371 is faster than copy on write.
6372 Swings and roundabouts. */
6373 (void)SvUPGRADE(sv, SVt_PV);
6378 if (PerlIO_isutf8(fp)) {
6380 sv_utf8_upgrade_nomg(sv);
6381 sv_pos_u2b(sv,&append,0);
6383 } else if (SvUTF8(sv)) {
6384 SV *tsv = NEWSV(0,0);
6385 sv_gets(tsv, fp, 0);
6386 sv_utf8_upgrade_nomg(tsv);
6387 SvCUR_set(sv,append);
6390 goto return_string_or_null;
6395 if (PerlIO_isutf8(fp))
6398 if (PL_curcop == &PL_compiling) {
6399 /* we always read code in line mode */
6403 else if (RsSNARF(PL_rs)) {
6404 /* If it is a regular disk file use size from stat() as estimate
6405 of amount we are going to read - may result in malloc-ing
6406 more memory than we realy need if layers bellow reduce
6407 size we read (e.g. CRLF or a gzip layer)
6410 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6411 Off_t offset = PerlIO_tell(fp);
6412 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6413 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6419 else if (RsRECORD(PL_rs)) {
6423 /* Grab the size of the record we're getting */
6424 recsize = SvIV(SvRV(PL_rs));
6425 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6428 /* VMS wants read instead of fread, because fread doesn't respect */
6429 /* RMS record boundaries. This is not necessarily a good thing to be */
6430 /* doing, but we've got no other real choice - except avoid stdio
6431 as implementation - perhaps write a :vms layer ?
6433 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6435 bytesread = PerlIO_read(fp, buffer, recsize);
6439 SvCUR_set(sv, bytesread += append);
6440 buffer[bytesread] = '\0';
6441 goto return_string_or_null;
6443 else if (RsPARA(PL_rs)) {
6449 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6450 if (PerlIO_isutf8(fp)) {
6451 rsptr = SvPVutf8(PL_rs, rslen);
6454 if (SvUTF8(PL_rs)) {
6455 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6456 Perl_croak(aTHX_ "Wide character in $/");
6459 rsptr = SvPV(PL_rs, rslen);
6463 rslast = rslen ? rsptr[rslen - 1] : '\0';
6465 if (rspara) { /* have to do this both before and after */
6466 do { /* to make sure file boundaries work right */
6469 i = PerlIO_getc(fp);
6473 PerlIO_ungetc(fp,i);
6479 /* See if we know enough about I/O mechanism to cheat it ! */
6481 /* This used to be #ifdef test - it is made run-time test for ease
6482 of abstracting out stdio interface. One call should be cheap
6483 enough here - and may even be a macro allowing compile
6487 if (PerlIO_fast_gets(fp)) {
6490 * We're going to steal some values from the stdio struct
6491 * and put EVERYTHING in the innermost loop into registers.
6493 register STDCHAR *ptr;
6497 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6498 /* An ungetc()d char is handled separately from the regular
6499 * buffer, so we getc() it back out and stuff it in the buffer.
6501 i = PerlIO_getc(fp);
6502 if (i == EOF) return 0;
6503 *(--((*fp)->_ptr)) = (unsigned char) i;
6507 /* Here is some breathtakingly efficient cheating */
6509 cnt = PerlIO_get_cnt(fp); /* get count into register */
6510 /* make sure we have the room */
6511 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6512 /* Not room for all of it
6513 if we are looking for a separator and room for some
6515 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6516 /* just process what we have room for */
6517 shortbuffered = cnt - SvLEN(sv) + append + 1;
6518 cnt -= shortbuffered;
6522 /* remember that cnt can be negative */
6523 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6528 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
6529 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6530 DEBUG_P(PerlIO_printf(Perl_debug_log,
6531 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6532 DEBUG_P(PerlIO_printf(Perl_debug_log,
6533 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6534 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6535 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6540 while (cnt > 0) { /* this | eat */
6542 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6543 goto thats_all_folks; /* screams | sed :-) */
6547 Copy(ptr, bp, cnt, char); /* this | eat */
6548 bp += cnt; /* screams | dust */
6549 ptr += cnt; /* louder | sed :-) */
6554 if (shortbuffered) { /* oh well, must extend */
6555 cnt = shortbuffered;
6557 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6559 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6560 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6564 DEBUG_P(PerlIO_printf(Perl_debug_log,
6565 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6566 PTR2UV(ptr),(long)cnt));
6567 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6569 DEBUG_P(PerlIO_printf(Perl_debug_log,
6570 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6571 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6572 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6574 /* This used to call 'filbuf' in stdio form, but as that behaves like
6575 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6576 another abstraction. */
6577 i = PerlIO_getc(fp); /* get more characters */
6579 DEBUG_P(PerlIO_printf(Perl_debug_log,
6580 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6581 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6582 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6584 cnt = PerlIO_get_cnt(fp);
6585 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6586 DEBUG_P(PerlIO_printf(Perl_debug_log,
6587 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6589 if (i == EOF) /* all done for ever? */
6590 goto thats_really_all_folks;
6592 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6594 SvGROW(sv, bpx + cnt + 2);
6595 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6597 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6599 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6600 goto thats_all_folks;
6604 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6605 memNE((char*)bp - rslen, rsptr, rslen))
6606 goto screamer; /* go back to the fray */
6607 thats_really_all_folks:
6609 cnt += shortbuffered;
6610 DEBUG_P(PerlIO_printf(Perl_debug_log,
6611 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6612 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6613 DEBUG_P(PerlIO_printf(Perl_debug_log,
6614 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6615 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6616 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6618 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
6619 DEBUG_P(PerlIO_printf(Perl_debug_log,
6620 "Screamer: done, len=%ld, string=|%.*s|\n",
6621 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6626 /*The big, slow, and stupid way */
6629 /* Need to work around EPOC SDK features */
6630 /* On WINS: MS VC5 generates calls to _chkstk, */
6631 /* if a `large' stack frame is allocated */
6632 /* gcc on MARM does not generate calls like these */
6638 register STDCHAR *bpe = buf + sizeof(buf);
6640 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6641 ; /* keep reading */
6645 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6646 /* Accomodate broken VAXC compiler, which applies U8 cast to
6647 * both args of ?: operator, causing EOF to change into 255
6650 i = (U8)buf[cnt - 1];
6656 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6658 sv_catpvn(sv, (char *) buf, cnt);
6660 sv_setpvn(sv, (char *) buf, cnt);
6662 if (i != EOF && /* joy */
6664 SvCUR(sv) < rslen ||
6665 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6669 * If we're reading from a TTY and we get a short read,
6670 * indicating that the user hit his EOF character, we need
6671 * to notice it now, because if we try to read from the TTY
6672 * again, the EOF condition will disappear.
6674 * The comparison of cnt to sizeof(buf) is an optimization
6675 * that prevents unnecessary calls to feof().
6679 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6684 if (rspara) { /* have to do this both before and after */
6685 while (i != EOF) { /* to make sure file boundaries work right */
6686 i = PerlIO_getc(fp);
6688 PerlIO_ungetc(fp,i);
6694 return_string_or_null:
6695 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6701 Auto-increment of the value in the SV, doing string to numeric conversion
6702 if necessary. Handles 'get' magic.
6708 Perl_sv_inc(pTHX_ register SV *sv)
6717 if (SvTHINKFIRST(sv)) {
6719 sv_force_normal_flags(sv, 0);
6720 if (SvREADONLY(sv)) {
6721 if (PL_curcop != &PL_compiling)
6722 Perl_croak(aTHX_ PL_no_modify);
6726 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6728 i = PTR2IV(SvRV(sv));
6733 flags = SvFLAGS(sv);
6734 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6735 /* It's (privately or publicly) a float, but not tested as an
6736 integer, so test it to see. */
6738 flags = SvFLAGS(sv);
6740 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6741 /* It's publicly an integer, or privately an integer-not-float */
6742 #ifdef PERL_PRESERVE_IVUV
6746 if (SvUVX(sv) == UV_MAX)
6747 sv_setnv(sv, UV_MAX_P1);
6749 (void)SvIOK_only_UV(sv);
6752 if (SvIVX(sv) == IV_MAX)
6753 sv_setuv(sv, (UV)IV_MAX + 1);
6755 (void)SvIOK_only(sv);
6761 if (flags & SVp_NOK) {
6762 (void)SvNOK_only(sv);
6767 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6768 if ((flags & SVTYPEMASK) < SVt_PVIV)
6769 sv_upgrade(sv, SVt_IV);
6770 (void)SvIOK_only(sv);
6775 while (isALPHA(*d)) d++;
6776 while (isDIGIT(*d)) d++;
6778 #ifdef PERL_PRESERVE_IVUV
6779 /* Got to punt this as an integer if needs be, but we don't issue
6780 warnings. Probably ought to make the sv_iv_please() that does
6781 the conversion if possible, and silently. */
6782 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6783 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6784 /* Need to try really hard to see if it's an integer.
6785 9.22337203685478e+18 is an integer.
6786 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6787 so $a="9.22337203685478e+18"; $a+0; $a++
6788 needs to be the same as $a="9.22337203685478e+18"; $a++
6795 /* sv_2iv *should* have made this an NV */
6796 if (flags & SVp_NOK) {
6797 (void)SvNOK_only(sv);
6801 /* I don't think we can get here. Maybe I should assert this
6802 And if we do get here I suspect that sv_setnv will croak. NWC
6804 #if defined(USE_LONG_DOUBLE)
6805 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
6806 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6808 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6809 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6812 #endif /* PERL_PRESERVE_IVUV */
6813 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6817 while (d >= SvPVX(sv)) {
6825 /* MKS: The original code here died if letters weren't consecutive.
6826 * at least it didn't have to worry about non-C locales. The
6827 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6828 * arranged in order (although not consecutively) and that only
6829 * [A-Za-z] are accepted by isALPHA in the C locale.
6831 if (*d != 'z' && *d != 'Z') {
6832 do { ++*d; } while (!isALPHA(*d));
6835 *(d--) -= 'z' - 'a';
6840 *(d--) -= 'z' - 'a' + 1;
6844 /* oh,oh, the number grew */
6845 SvGROW(sv, SvCUR(sv) + 2);
6847 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6858 Auto-decrement of the value in the SV, doing string to numeric conversion
6859 if necessary. Handles 'get' magic.
6865 Perl_sv_dec(pTHX_ register SV *sv)
6873 if (SvTHINKFIRST(sv)) {
6875 sv_force_normal_flags(sv, 0);
6876 if (SvREADONLY(sv)) {
6877 if (PL_curcop != &PL_compiling)
6878 Perl_croak(aTHX_ PL_no_modify);
6882 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6884 i = PTR2IV(SvRV(sv));
6889 /* Unlike sv_inc we don't have to worry about string-never-numbers
6890 and keeping them magic. But we mustn't warn on punting */
6891 flags = SvFLAGS(sv);
6892 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6893 /* It's publicly an integer, or privately an integer-not-float */
6894 #ifdef PERL_PRESERVE_IVUV
6898 if (SvUVX(sv) == 0) {
6899 (void)SvIOK_only(sv);
6903 (void)SvIOK_only_UV(sv);
6907 if (SvIVX(sv) == IV_MIN)
6908 sv_setnv(sv, (NV)IV_MIN - 1.0);
6910 (void)SvIOK_only(sv);
6916 if (flags & SVp_NOK) {
6918 (void)SvNOK_only(sv);
6921 if (!(flags & SVp_POK)) {
6922 if ((flags & SVTYPEMASK) < SVt_PVNV)
6923 sv_upgrade(sv, SVt_NV);
6925 (void)SvNOK_only(sv);
6928 #ifdef PERL_PRESERVE_IVUV
6930 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6931 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6932 /* Need to try really hard to see if it's an integer.
6933 9.22337203685478e+18 is an integer.
6934 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6935 so $a="9.22337203685478e+18"; $a+0; $a--
6936 needs to be the same as $a="9.22337203685478e+18"; $a--
6943 /* sv_2iv *should* have made this an NV */
6944 if (flags & SVp_NOK) {
6945 (void)SvNOK_only(sv);
6949 /* I don't think we can get here. Maybe I should assert this
6950 And if we do get here I suspect that sv_setnv will croak. NWC
6952 #if defined(USE_LONG_DOUBLE)
6953 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
6954 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6956 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6957 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6961 #endif /* PERL_PRESERVE_IVUV */
6962 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6966 =for apidoc sv_mortalcopy
6968 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6969 The new SV is marked as mortal. It will be destroyed "soon", either by an
6970 explicit call to FREETMPS, or by an implicit call at places such as
6971 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6976 /* Make a string that will exist for the duration of the expression
6977 * evaluation. Actually, it may have to last longer than that, but
6978 * hopefully we won't free it until it has been assigned to a
6979 * permanent location. */
6982 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6987 sv_setsv(sv,oldstr);
6989 PL_tmps_stack[++PL_tmps_ix] = sv;
6995 =for apidoc sv_newmortal
6997 Creates a new null SV which is mortal. The reference count of the SV is
6998 set to 1. It will be destroyed "soon", either by an explicit call to
6999 FREETMPS, or by an implicit call at places such as statement boundaries.
7000 See also C<sv_mortalcopy> and C<sv_2mortal>.
7006 Perl_sv_newmortal(pTHX)
7011 SvFLAGS(sv) = SVs_TEMP;
7013 PL_tmps_stack[++PL_tmps_ix] = sv;
7018 =for apidoc sv_2mortal
7020 Marks an existing SV as mortal. The SV will be destroyed "soon", either
7021 by an explicit call to FREETMPS, or by an implicit call at places such as
7022 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
7028 Perl_sv_2mortal(pTHX_ register SV *sv)
7032 if (SvREADONLY(sv) && SvIMMORTAL(sv))
7035 PL_tmps_stack[++PL_tmps_ix] = sv;
7043 Creates a new SV and copies a string into it. The reference count for the
7044 SV is set to 1. If C<len> is zero, Perl will compute the length using
7045 strlen(). For efficiency, consider using C<newSVpvn> instead.
7051 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7058 sv_setpvn(sv,s,len);
7063 =for apidoc newSVpvn
7065 Creates a new SV and copies a string into it. The reference count for the
7066 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7067 string. You are responsible for ensuring that the source string is at least
7074 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7079 sv_setpvn(sv,s,len);
7084 =for apidoc newSVpvn_share
7086 Creates a new SV with its SvPVX pointing to a shared string in the string
7087 table. If the string does not already exist in the table, it is created
7088 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7089 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7090 otherwise the hash is computed. The idea here is that as the string table
7091 is used for shared hash keys these strings will have SvPVX == HeKEY and
7092 hash lookup will avoid string compare.
7098 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7101 bool is_utf8 = FALSE;
7103 STRLEN tmplen = -len;
7105 /* See the note in hv.c:hv_fetch() --jhi */
7106 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
7110 PERL_HASH(hash, src, len);
7112 sv_upgrade(sv, SVt_PVIV);
7113 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
7126 #if defined(PERL_IMPLICIT_CONTEXT)
7128 /* pTHX_ magic can't cope with varargs, so this is a no-context
7129 * version of the main function, (which may itself be aliased to us).
7130 * Don't access this version directly.
7134 Perl_newSVpvf_nocontext(const char* pat, ...)
7139 va_start(args, pat);
7140 sv = vnewSVpvf(pat, &args);
7147 =for apidoc newSVpvf
7149 Creates a new SV and initializes it with the string formatted like
7156 Perl_newSVpvf(pTHX_ const char* pat, ...)
7160 va_start(args, pat);
7161 sv = vnewSVpvf(pat, &args);
7166 /* backend for newSVpvf() and newSVpvf_nocontext() */
7169 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7173 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7180 Creates a new SV and copies a floating point value into it.
7181 The reference count for the SV is set to 1.
7187 Perl_newSVnv(pTHX_ NV n)
7199 Creates a new SV and copies an integer into it. The reference count for the
7206 Perl_newSViv(pTHX_ IV i)
7218 Creates a new SV and copies an unsigned integer into it.
7219 The reference count for the SV is set to 1.
7225 Perl_newSVuv(pTHX_ UV u)
7235 =for apidoc newRV_noinc
7237 Creates an RV wrapper for an SV. The reference count for the original
7238 SV is B<not> incremented.
7244 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7249 sv_upgrade(sv, SVt_RV);
7256 /* newRV_inc is the official function name to use now.
7257 * newRV_inc is in fact #defined to newRV in sv.h
7261 Perl_newRV(pTHX_ SV *tmpRef)
7263 return newRV_noinc(SvREFCNT_inc(tmpRef));
7269 Creates a new SV which is an exact duplicate of the original SV.
7276 Perl_newSVsv(pTHX_ register SV *old)
7282 if (SvTYPE(old) == SVTYPEMASK) {
7283 if (ckWARN_d(WARN_INTERNAL))
7284 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7299 =for apidoc sv_reset
7301 Underlying implementation for the C<reset> Perl function.
7302 Note that the perl-level function is vaguely deprecated.
7308 Perl_sv_reset(pTHX_ register char *s, HV *stash)
7316 char todo[PERL_UCHAR_MAX+1];
7321 if (!*s) { /* reset ?? searches */
7322 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7323 pm->op_pmdynflags &= ~PMdf_USED;
7328 /* reset variables */
7330 if (!HvARRAY(stash))
7333 Zero(todo, 256, char);
7335 i = (unsigned char)*s;
7339 max = (unsigned char)*s++;
7340 for ( ; i <= max; i++) {
7343 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7344 for (entry = HvARRAY(stash)[i];
7346 entry = HeNEXT(entry))
7348 if (!todo[(U8)*HeKEY(entry)])
7350 gv = (GV*)HeVAL(entry);
7352 if (SvTHINKFIRST(sv)) {
7353 if (!SvREADONLY(sv) && SvROK(sv))
7358 if (SvTYPE(sv) >= SVt_PV) {
7360 if (SvPVX(sv) != Nullch)
7367 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7369 #ifdef USE_ENVIRON_ARRAY
7371 # ifdef USE_ITHREADS
7372 && PL_curinterp == aTHX
7376 environ[0] = Nullch;
7388 Using various gambits, try to get an IO from an SV: the IO slot if its a
7389 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7390 named after the PV if we're a string.
7396 Perl_sv_2io(pTHX_ SV *sv)
7402 switch (SvTYPE(sv)) {
7410 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7414 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7416 return sv_2io(SvRV(sv));
7417 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
7423 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7432 Using various gambits, try to get a CV from an SV; in addition, try if
7433 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7439 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7446 return *gvp = Nullgv, Nullcv;
7447 switch (SvTYPE(sv)) {
7466 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7467 tryAMAGICunDEREF(to_cv);
7470 if (SvTYPE(sv) == SVt_PVCV) {
7479 Perl_croak(aTHX_ "Not a subroutine reference");
7484 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
7490 if (lref && !GvCVu(gv)) {
7493 tmpsv = NEWSV(704,0);
7494 gv_efullname3(tmpsv, gv, Nullch);
7495 /* XXX this is probably not what they think they're getting.
7496 * It has the same effect as "sub name;", i.e. just a forward
7498 newSUB(start_subparse(FALSE, 0),
7499 newSVOP(OP_CONST, 0, tmpsv),
7504 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7514 Returns true if the SV has a true value by Perl's rules.
7515 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7516 instead use an in-line version.
7522 Perl_sv_true(pTHX_ register SV *sv)
7528 if ((tXpv = (XPV*)SvANY(sv)) &&
7529 (tXpv->xpv_cur > 1 ||
7530 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
7537 return SvIVX(sv) != 0;
7540 return SvNVX(sv) != 0.0;
7542 return sv_2bool(sv);
7550 A private implementation of the C<SvIVx> macro for compilers which can't
7551 cope with complex macro expressions. Always use the macro instead.
7557 Perl_sv_iv(pTHX_ register SV *sv)
7561 return (IV)SvUVX(sv);
7570 A private implementation of the C<SvUVx> macro for compilers which can't
7571 cope with complex macro expressions. Always use the macro instead.
7577 Perl_sv_uv(pTHX_ register SV *sv)
7582 return (UV)SvIVX(sv);
7590 A private implementation of the C<SvNVx> macro for compilers which can't
7591 cope with complex macro expressions. Always use the macro instead.
7597 Perl_sv_nv(pTHX_ register SV *sv)
7604 /* sv_pv() is now a macro using SvPV_nolen();
7605 * this function provided for binary compatibility only
7609 Perl_sv_pv(pTHX_ SV *sv)
7616 return sv_2pv(sv, &n_a);
7622 Use the C<SvPV_nolen> macro instead
7626 A private implementation of the C<SvPV> macro for compilers which can't
7627 cope with complex macro expressions. Always use the macro instead.
7633 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7639 return sv_2pv(sv, lp);
7644 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7650 return sv_2pv_flags(sv, lp, 0);
7653 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7654 * this function provided for binary compatibility only
7658 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7660 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7664 =for apidoc sv_pvn_force
7666 Get a sensible string out of the SV somehow.
7667 A private implementation of the C<SvPV_force> macro for compilers which
7668 can't cope with complex macro expressions. Always use the macro instead.
7670 =for apidoc sv_pvn_force_flags
7672 Get a sensible string out of the SV somehow.
7673 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7674 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7675 implemented in terms of this function.
7676 You normally want to use the various wrapper macros instead: see
7677 C<SvPV_force> and C<SvPV_force_nomg>
7683 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7687 if (SvTHINKFIRST(sv) && !SvROK(sv))
7688 sv_force_normal_flags(sv, 0);
7694 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7695 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7699 s = sv_2pv_flags(sv, lp, flags);
7700 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
7705 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7706 SvGROW(sv, len + 1);
7707 Move(s,SvPVX(sv),len,char);
7712 SvPOK_on(sv); /* validate pointer */
7714 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7715 PTR2UV(sv),SvPVX(sv)));
7721 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
7722 * this function provided for binary compatibility only
7726 Perl_sv_pvbyte(pTHX_ SV *sv)
7728 sv_utf8_downgrade(sv,0);
7733 =for apidoc sv_pvbyte
7735 Use C<SvPVbyte_nolen> instead.
7737 =for apidoc sv_pvbyten
7739 A private implementation of the C<SvPVbyte> macro for compilers
7740 which can't cope with complex macro expressions. Always use the macro
7747 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7749 sv_utf8_downgrade(sv,0);
7750 return sv_pvn(sv,lp);
7754 =for apidoc sv_pvbyten_force
7756 A private implementation of the C<SvPVbytex_force> macro for compilers
7757 which can't cope with complex macro expressions. Always use the macro
7764 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7766 sv_utf8_downgrade(sv,0);
7767 return sv_pvn_force(sv,lp);
7770 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
7771 * this function provided for binary compatibility only
7775 Perl_sv_pvutf8(pTHX_ SV *sv)
7777 sv_utf8_upgrade(sv);
7782 =for apidoc sv_pvutf8
7784 Use the C<SvPVutf8_nolen> macro instead
7786 =for apidoc sv_pvutf8n
7788 A private implementation of the C<SvPVutf8> macro for compilers
7789 which can't cope with complex macro expressions. Always use the macro
7796 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7798 sv_utf8_upgrade(sv);
7799 return sv_pvn(sv,lp);
7803 =for apidoc sv_pvutf8n_force
7805 A private implementation of the C<SvPVutf8_force> macro for compilers
7806 which can't cope with complex macro expressions. Always use the macro
7813 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7815 sv_utf8_upgrade(sv);
7816 return sv_pvn_force(sv,lp);
7820 =for apidoc sv_reftype
7822 Returns a string describing what the SV is a reference to.
7828 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7830 if (ob && SvOBJECT(sv)) {
7831 if (HvNAME(SvSTASH(sv)))
7832 return HvNAME(SvSTASH(sv));
7837 switch (SvTYPE(sv)) {
7854 case SVt_PVLV: return SvROK(sv) ? "REF"
7855 /* tied lvalues should appear to be
7856 * scalars for backwards compatitbility */
7857 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7858 ? "SCALAR" : "LVALUE";
7859 case SVt_PVAV: return "ARRAY";
7860 case SVt_PVHV: return "HASH";
7861 case SVt_PVCV: return "CODE";
7862 case SVt_PVGV: return "GLOB";
7863 case SVt_PVFM: return "FORMAT";
7864 case SVt_PVIO: return "IO";
7865 default: return "UNKNOWN";
7871 =for apidoc sv_isobject
7873 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7874 object. If the SV is not an RV, or if the object is not blessed, then this
7881 Perl_sv_isobject(pTHX_ SV *sv)
7898 Returns a boolean indicating whether the SV is blessed into the specified
7899 class. This does not check for subtypes; use C<sv_derived_from> to verify
7900 an inheritance relationship.
7906 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7917 if (!HvNAME(SvSTASH(sv)))
7920 return strEQ(HvNAME(SvSTASH(sv)), name);
7926 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7927 it will be upgraded to one. If C<classname> is non-null then the new SV will
7928 be blessed in the specified package. The new SV is returned and its
7929 reference count is 1.
7935 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7941 SV_CHECK_THINKFIRST_COW_DROP(rv);
7944 if (SvTYPE(rv) >= SVt_PVMG) {
7945 U32 refcnt = SvREFCNT(rv);
7949 SvREFCNT(rv) = refcnt;
7952 if (SvTYPE(rv) < SVt_RV)
7953 sv_upgrade(rv, SVt_RV);
7954 else if (SvTYPE(rv) > SVt_RV) {
7955 (void)SvOOK_off(rv);
7956 if (SvPVX(rv) && SvLEN(rv))
7957 Safefree(SvPVX(rv));
7967 HV* stash = gv_stashpv(classname, TRUE);
7968 (void)sv_bless(rv, stash);
7974 =for apidoc sv_setref_pv
7976 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7977 argument will be upgraded to an RV. That RV will be modified to point to
7978 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7979 into the SV. The C<classname> argument indicates the package for the
7980 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7981 will be returned and will have a reference count of 1.
7983 Do not use with other Perl types such as HV, AV, SV, CV, because those
7984 objects will become corrupted by the pointer copy process.
7986 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7992 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7995 sv_setsv(rv, &PL_sv_undef);
7999 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
8004 =for apidoc sv_setref_iv
8006 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
8007 argument will be upgraded to an RV. That RV will be modified to point to
8008 the new SV. The C<classname> argument indicates the package for the
8009 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8010 will be returned and will have a reference count of 1.
8016 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
8018 sv_setiv(newSVrv(rv,classname), iv);
8023 =for apidoc sv_setref_uv
8025 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
8026 argument will be upgraded to an RV. That RV will be modified to point to
8027 the new SV. The C<classname> argument indicates the package for the
8028 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8029 will be returned and will have a reference count of 1.
8035 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
8037 sv_setuv(newSVrv(rv,classname), uv);
8042 =for apidoc sv_setref_nv
8044 Copies a double into a new SV, optionally blessing the SV. The C<rv>
8045 argument will be upgraded to an RV. That RV will be modified to point to
8046 the new SV. The C<classname> argument indicates the package for the
8047 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
8048 will be returned and will have a reference count of 1.
8054 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
8056 sv_setnv(newSVrv(rv,classname), nv);
8061 =for apidoc sv_setref_pvn
8063 Copies a string into a new SV, optionally blessing the SV. The length of the
8064 string must be specified with C<n>. The C<rv> argument will be upgraded to
8065 an RV. That RV will be modified to point to the new SV. The C<classname>
8066 argument indicates the package for the blessing. Set C<classname> to
8067 C<Nullch> to avoid the blessing. The new SV will be returned and will have
8068 a reference count of 1.
8070 Note that C<sv_setref_pv> copies the pointer while this copies the string.
8076 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
8078 sv_setpvn(newSVrv(rv,classname), pv, n);
8083 =for apidoc sv_bless
8085 Blesses an SV into a specified package. The SV must be an RV. The package
8086 must be designated by its stash (see C<gv_stashpv()>). The reference count
8087 of the SV is unaffected.
8093 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8097 Perl_croak(aTHX_ "Can't bless non-reference value");
8099 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8100 if (SvREADONLY(tmpRef))
8101 Perl_croak(aTHX_ PL_no_modify);
8102 if (SvOBJECT(tmpRef)) {
8103 if (SvTYPE(tmpRef) != SVt_PVIO)
8105 SvREFCNT_dec(SvSTASH(tmpRef));
8108 SvOBJECT_on(tmpRef);
8109 if (SvTYPE(tmpRef) != SVt_PVIO)
8111 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8112 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8119 if(SvSMAGICAL(tmpRef))
8120 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8128 /* Downgrades a PVGV to a PVMG.
8132 S_sv_unglob(pTHX_ SV *sv)
8136 assert(SvTYPE(sv) == SVt_PVGV);
8141 SvREFCNT_dec(GvSTASH(sv));
8142 GvSTASH(sv) = Nullhv;
8144 sv_unmagic(sv, PERL_MAGIC_glob);
8145 Safefree(GvNAME(sv));
8148 /* need to keep SvANY(sv) in the right arena */
8149 xpvmg = new_XPVMG();
8150 StructCopy(SvANY(sv), xpvmg, XPVMG);
8151 del_XPVGV(SvANY(sv));
8154 SvFLAGS(sv) &= ~SVTYPEMASK;
8155 SvFLAGS(sv) |= SVt_PVMG;
8159 =for apidoc sv_unref_flags
8161 Unsets the RV status of the SV, and decrements the reference count of
8162 whatever was being referenced by the RV. This can almost be thought of
8163 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8164 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8165 (otherwise the decrementing is conditional on the reference count being
8166 different from one or the reference being a readonly SV).
8173 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8177 if (SvWEAKREF(sv)) {
8185 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8186 assigned to as BEGIN {$a = \"Foo"} will fail. */
8187 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8189 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8190 sv_2mortal(rv); /* Schedule for freeing later */
8194 =for apidoc sv_unref
8196 Unsets the RV status of the SV, and decrements the reference count of
8197 whatever was being referenced by the RV. This can almost be thought of
8198 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8199 being zero. See C<SvROK_off>.
8205 Perl_sv_unref(pTHX_ SV *sv)
8207 sv_unref_flags(sv, 0);
8211 =for apidoc sv_taint
8213 Taint an SV. Use C<SvTAINTED_on> instead.
8218 Perl_sv_taint(pTHX_ SV *sv)
8220 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8224 =for apidoc sv_untaint
8226 Untaint an SV. Use C<SvTAINTED_off> instead.
8231 Perl_sv_untaint(pTHX_ SV *sv)
8233 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8234 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8241 =for apidoc sv_tainted
8243 Test an SV for taintedness. Use C<SvTAINTED> instead.
8248 Perl_sv_tainted(pTHX_ SV *sv)
8250 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8251 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8252 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8259 =for apidoc sv_setpviv
8261 Copies an integer into the given SV, also updating its string value.
8262 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8268 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8270 char buf[TYPE_CHARS(UV)];
8272 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8274 sv_setpvn(sv, ptr, ebuf - ptr);
8278 =for apidoc sv_setpviv_mg
8280 Like C<sv_setpviv>, but also handles 'set' magic.
8286 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8288 char buf[TYPE_CHARS(UV)];
8290 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8292 sv_setpvn(sv, ptr, ebuf - ptr);
8296 #if defined(PERL_IMPLICIT_CONTEXT)
8298 /* pTHX_ magic can't cope with varargs, so this is a no-context
8299 * version of the main function, (which may itself be aliased to us).
8300 * Don't access this version directly.
8304 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8308 va_start(args, pat);
8309 sv_vsetpvf(sv, pat, &args);
8313 /* pTHX_ magic can't cope with varargs, so this is a no-context
8314 * version of the main function, (which may itself be aliased to us).
8315 * Don't access this version directly.
8319 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8323 va_start(args, pat);
8324 sv_vsetpvf_mg(sv, pat, &args);
8330 =for apidoc sv_setpvf
8332 Processes its arguments like C<sprintf> and sets an SV to the formatted
8333 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8339 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8342 va_start(args, pat);
8343 sv_vsetpvf(sv, pat, &args);
8347 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8350 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8352 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8356 =for apidoc sv_setpvf_mg
8358 Like C<sv_setpvf>, but also handles 'set' magic.
8364 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8367 va_start(args, pat);
8368 sv_vsetpvf_mg(sv, pat, &args);
8372 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8375 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8377 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8381 #if defined(PERL_IMPLICIT_CONTEXT)
8383 /* pTHX_ magic can't cope with varargs, so this is a no-context
8384 * version of the main function, (which may itself be aliased to us).
8385 * Don't access this version directly.
8389 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8393 va_start(args, pat);
8394 sv_vcatpvf(sv, pat, &args);
8398 /* pTHX_ magic can't cope with varargs, so this is a no-context
8399 * version of the main function, (which may itself be aliased to us).
8400 * Don't access this version directly.
8404 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8408 va_start(args, pat);
8409 sv_vcatpvf_mg(sv, pat, &args);
8415 =for apidoc sv_catpvf
8417 Processes its arguments like C<sprintf> and appends the formatted
8418 output to an SV. If the appended data contains "wide" characters
8419 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8420 and characters >255 formatted with %c), the original SV might get
8421 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
8422 C<SvSETMAGIC()> must typically be called after calling this function
8423 to handle 'set' magic.
8428 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8431 va_start(args, pat);
8432 sv_vcatpvf(sv, pat, &args);
8436 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8439 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8441 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8445 =for apidoc sv_catpvf_mg
8447 Like C<sv_catpvf>, but also handles 'set' magic.
8453 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8456 va_start(args, pat);
8457 sv_vcatpvf_mg(sv, pat, &args);
8461 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
8464 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8466 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8471 =for apidoc sv_vsetpvfn
8473 Works like C<vcatpvfn> but copies the text into the SV instead of
8476 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
8482 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8484 sv_setpvn(sv, "", 0);
8485 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8488 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8491 S_expect_number(pTHX_ char** pattern)
8494 switch (**pattern) {
8495 case '1': case '2': case '3':
8496 case '4': case '5': case '6':
8497 case '7': case '8': case '9':
8498 while (isDIGIT(**pattern))
8499 var = var * 10 + (*(*pattern)++ - '0');
8503 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8506 =for apidoc sv_vcatpvfn
8508 Processes its arguments like C<vsprintf> and appends the formatted output
8509 to an SV. Uses an array of SVs if the C style variable argument list is
8510 missing (NULL). When running with taint checks enabled, indicates via
8511 C<maybe_tainted> if results are untrustworthy (often due to the use of
8514 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
8520 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8527 static char nullstr[] = "(null)";
8529 bool has_utf8; /* has the result utf8? */
8530 bool pat_utf8; /* the pattern is in utf8? */
8533 has_utf8 = pat_utf8 = DO_UTF8(sv);
8535 /* no matter what, this is a string now */
8536 (void)SvPV_force(sv, origlen);
8538 /* special-case "", "%s", and "%_" */
8541 if (patlen == 2 && pat[0] == '%') {
8545 char *s = va_arg(*args, char*);
8546 sv_catpv(sv, s ? s : nullstr);
8548 else if (svix < svmax) {
8549 sv_catsv(sv, *svargs);
8550 if (DO_UTF8(*svargs))
8556 argsv = va_arg(*args, SV*);
8557 sv_catsv(sv, argsv);
8562 /* See comment on '_' below */
8567 if (!args && svix < svmax && DO_UTF8(*svargs))
8570 patend = (char*)pat + patlen;
8571 for (p = (char*)pat; p < patend; p = q) {
8574 bool vectorize = FALSE;
8575 bool vectorarg = FALSE;
8576 bool vec_utf8 = FALSE;
8582 bool has_precis = FALSE;
8585 bool is_utf8 = FALSE; /* is this item utf8? */
8586 #ifdef HAS_LDBL_SPRINTF_BUG
8587 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8588 with sfio - Allen <allens@cpan.org> */
8589 bool fix_ldbl_sprintf_bug = FALSE;
8593 U8 utf8buf[UTF8_MAXLEN+1];
8594 STRLEN esignlen = 0;
8596 char *eptr = Nullch;
8598 /* Times 4: a decimal digit takes more than 3 binary digits.
8599 * NV_DIG: mantissa takes than many decimal digits.
8600 * Plus 32: Playing safe. */
8601 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8602 /* large enough for "%#.#f" --chip */
8603 /* what about long double NVs? --jhi */
8606 U8 *vecstr = Null(U8*);
8613 /* we need a long double target in case HAS_LONG_DOUBLE but
8616 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8625 STRLEN dotstrlen = 1;
8626 I32 efix = 0; /* explicit format parameter index */
8627 I32 ewix = 0; /* explicit width index */
8628 I32 epix = 0; /* explicit precision index */
8629 I32 evix = 0; /* explicit vector index */
8630 bool asterisk = FALSE;
8632 /* echo everything up to the next format specification */
8633 for (q = p; q < patend && *q != '%'; ++q) ;
8635 if (has_utf8 && !pat_utf8)
8636 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8638 sv_catpvn(sv, p, q - p);
8645 We allow format specification elements in this order:
8646 \d+\$ explicit format parameter index
8648 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8649 0 flag (as above): repeated to allow "v02"
8650 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8651 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8653 [%bcdefginopsux_DFOUX] format (mandatory)
8655 if (EXPECT_NUMBER(q, width)) {
8696 if (EXPECT_NUMBER(q, ewix))
8705 if ((vectorarg = asterisk)) {
8717 EXPECT_NUMBER(q, width);
8722 vecsv = va_arg(*args, SV*);
8724 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8725 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8726 dotstr = SvPVx(vecsv, dotstrlen);
8731 vecsv = va_arg(*args, SV*);
8732 vecstr = (U8*)SvPVx(vecsv,veclen);
8733 vec_utf8 = DO_UTF8(vecsv);
8735 else if (efix ? efix <= svmax : svix < svmax) {
8736 vecsv = svargs[efix ? efix-1 : svix++];
8737 vecstr = (U8*)SvPVx(vecsv,veclen);
8738 vec_utf8 = DO_UTF8(vecsv);
8748 i = va_arg(*args, int);
8750 i = (ewix ? ewix <= svmax : svix < svmax) ?
8751 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8753 width = (i < 0) ? -i : i;
8763 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8765 /* XXX: todo, support specified precision parameter */
8769 i = va_arg(*args, int);
8771 i = (ewix ? ewix <= svmax : svix < svmax)
8772 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8773 precis = (i < 0) ? 0 : i;
8778 precis = precis * 10 + (*q++ - '0');
8787 case 'I': /* Ix, I32x, and I64x */
8789 if (q[1] == '6' && q[2] == '4') {
8795 if (q[1] == '3' && q[2] == '2') {
8805 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8816 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8817 if (*(q + 1) == 'l') { /* lld, llf */
8842 argsv = (efix ? efix <= svmax : svix < svmax) ?
8843 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8850 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8852 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8854 eptr = (char*)utf8buf;
8855 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8866 if (args && !vectorize) {
8867 eptr = va_arg(*args, char*);
8869 #ifdef MACOS_TRADITIONAL
8870 /* On MacOS, %#s format is used for Pascal strings */
8875 elen = strlen(eptr);
8878 elen = sizeof nullstr - 1;
8882 eptr = SvPVx(argsv, elen);
8883 if (DO_UTF8(argsv)) {
8884 if (has_precis && precis < elen) {
8886 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8889 if (width) { /* fudge width (can't fudge elen) */
8890 width += elen - sv_len_utf8(argsv);
8899 * The "%_" hack might have to be changed someday,
8900 * if ISO or ANSI decide to use '_' for something.
8901 * So we keep it hidden from users' code.
8903 if (!args || vectorize)
8905 argsv = va_arg(*args, SV*);
8906 eptr = SvPVx(argsv, elen);
8912 if (has_precis && elen > precis)
8919 if (alt || vectorize)
8921 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8939 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8948 esignbuf[esignlen++] = plus;
8952 case 'h': iv = (short)va_arg(*args, int); break;
8953 default: iv = va_arg(*args, int); break;
8954 case 'l': iv = va_arg(*args, long); break;
8955 case 'V': iv = va_arg(*args, IV); break;
8957 case 'q': iv = va_arg(*args, Quad_t); break;
8964 case 'h': iv = (short)iv; break;
8966 case 'l': iv = (long)iv; break;
8969 case 'q': iv = (Quad_t)iv; break;
8973 if ( !vectorize ) /* we already set uv above */
8978 esignbuf[esignlen++] = plus;
8982 esignbuf[esignlen++] = '-';
9025 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9036 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9037 default: uv = va_arg(*args, unsigned); break;
9038 case 'l': uv = va_arg(*args, unsigned long); break;
9039 case 'V': uv = va_arg(*args, UV); break;
9041 case 'q': uv = va_arg(*args, Quad_t); break;
9048 case 'h': uv = (unsigned short)uv; break;
9050 case 'l': uv = (unsigned long)uv; break;
9053 case 'q': uv = (Quad_t)uv; break;
9059 eptr = ebuf + sizeof ebuf;
9065 p = (char*)((c == 'X')
9066 ? "0123456789ABCDEF" : "0123456789abcdef");
9072 esignbuf[esignlen++] = '0';
9073 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9079 *--eptr = '0' + dig;
9081 if (alt && *eptr != '0')
9087 *--eptr = '0' + dig;
9090 esignbuf[esignlen++] = '0';
9091 esignbuf[esignlen++] = 'b';
9094 default: /* it had better be ten or less */
9095 #if defined(PERL_Y2KWARN)
9096 if (ckWARN(WARN_Y2K)) {
9098 char *s = SvPV(sv,n);
9099 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9100 && (n == 2 || !isDIGIT(s[n-3])))
9102 Perl_warner(aTHX_ packWARN(WARN_Y2K),
9103 "Possible Y2K bug: %%%c %s",
9104 c, "format string following '19'");
9110 *--eptr = '0' + dig;
9111 } while (uv /= base);
9114 elen = (ebuf + sizeof ebuf) - eptr;
9117 zeros = precis - elen;
9118 else if (precis == 0 && elen == 1 && *eptr == '0')
9123 /* FLOATING POINT */
9126 c = 'f'; /* maybe %F isn't supported here */
9132 /* This is evil, but floating point is even more evil */
9134 /* for SV-style calling, we can only get NV
9135 for C-style calling, we assume %f is double;
9136 for simplicity we allow any of %Lf, %llf, %qf for long double
9140 #if defined(USE_LONG_DOUBLE)
9144 /* [perl #20339] - we should accept and ignore %lf rather than die */
9148 #if defined(USE_LONG_DOUBLE)
9149 intsize = args ? 0 : 'q';
9153 #if defined(HAS_LONG_DOUBLE)
9162 /* now we need (long double) if intsize == 'q', else (double) */
9163 nv = (args && !vectorize) ?
9164 #if LONG_DOUBLESIZE > DOUBLESIZE
9166 va_arg(*args, long double) :
9167 va_arg(*args, double)
9169 va_arg(*args, double)
9175 if (c != 'e' && c != 'E') {
9177 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9178 will cast our (long double) to (double) */
9179 (void)Perl_frexp(nv, &i);
9180 if (i == PERL_INT_MIN)
9181 Perl_die(aTHX_ "panic: frexp");
9183 need = BIT_DIGITS(i);
9185 need += has_precis ? precis : 6; /* known default */
9190 #ifdef HAS_LDBL_SPRINTF_BUG
9191 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9192 with sfio - Allen <allens@cpan.org> */
9195 # define MY_DBL_MAX DBL_MAX
9196 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9197 # if DOUBLESIZE >= 8
9198 # define MY_DBL_MAX 1.7976931348623157E+308L
9200 # define MY_DBL_MAX 3.40282347E+38L
9204 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9205 # define MY_DBL_MAX_BUG 1L
9207 # define MY_DBL_MAX_BUG MY_DBL_MAX
9211 # define MY_DBL_MIN DBL_MIN
9212 # else /* XXX guessing! -Allen */
9213 # if DOUBLESIZE >= 8
9214 # define MY_DBL_MIN 2.2250738585072014E-308L
9216 # define MY_DBL_MIN 1.17549435E-38L
9220 if ((intsize == 'q') && (c == 'f') &&
9221 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9223 /* it's going to be short enough that
9224 * long double precision is not needed */
9226 if ((nv <= 0L) && (nv >= -0L))
9227 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9229 /* would use Perl_fp_class as a double-check but not
9230 * functional on IRIX - see perl.h comments */
9232 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9233 /* It's within the range that a double can represent */
9234 #if defined(DBL_MAX) && !defined(DBL_MIN)
9235 if ((nv >= ((long double)1/DBL_MAX)) ||
9236 (nv <= (-(long double)1/DBL_MAX)))
9238 fix_ldbl_sprintf_bug = TRUE;
9241 if (fix_ldbl_sprintf_bug == TRUE) {
9251 # undef MY_DBL_MAX_BUG
9254 #endif /* HAS_LDBL_SPRINTF_BUG */
9256 need += 20; /* fudge factor */
9257 if (PL_efloatsize < need) {
9258 Safefree(PL_efloatbuf);
9259 PL_efloatsize = need + 20; /* more fudge */
9260 New(906, PL_efloatbuf, PL_efloatsize, char);
9261 PL_efloatbuf[0] = '\0';
9264 eptr = ebuf + sizeof ebuf;
9267 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9268 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9269 if (intsize == 'q') {
9270 /* Copy the one or more characters in a long double
9271 * format before the 'base' ([efgEFG]) character to
9272 * the format string. */
9273 static char const prifldbl[] = PERL_PRIfldbl;
9274 char const *p = prifldbl + sizeof(prifldbl) - 3;
9275 while (p >= prifldbl) { *--eptr = *p--; }
9280 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9285 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9297 /* No taint. Otherwise we are in the strange situation
9298 * where printf() taints but print($float) doesn't.
9300 #if defined(HAS_LONG_DOUBLE)
9302 (void)sprintf(PL_efloatbuf, eptr, nv);
9304 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9306 (void)sprintf(PL_efloatbuf, eptr, nv);
9308 eptr = PL_efloatbuf;
9309 elen = strlen(PL_efloatbuf);
9315 i = SvCUR(sv) - origlen;
9316 if (args && !vectorize) {
9318 case 'h': *(va_arg(*args, short*)) = i; break;
9319 default: *(va_arg(*args, int*)) = i; break;
9320 case 'l': *(va_arg(*args, long*)) = i; break;
9321 case 'V': *(va_arg(*args, IV*)) = i; break;
9323 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9328 sv_setuv_mg(argsv, (UV)i);
9330 continue; /* not "break" */
9336 if (!args && ckWARN(WARN_PRINTF) &&
9337 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9338 SV *msg = sv_newmortal();
9339 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9340 (PL_op->op_type == OP_PRTF) ? "" : "s");
9343 Perl_sv_catpvf(aTHX_ msg,
9344 "\"%%%c\"", c & 0xFF);
9346 Perl_sv_catpvf(aTHX_ msg,
9347 "\"%%\\%03"UVof"\"",
9350 sv_catpv(msg, "end of string");
9351 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9354 /* output mangled stuff ... */
9360 /* ... right here, because formatting flags should not apply */
9361 SvGROW(sv, SvCUR(sv) + elen + 1);
9363 Copy(eptr, p, elen, char);
9366 SvCUR(sv) = p - SvPVX(sv);
9368 continue; /* not "break" */
9371 if (is_utf8 != has_utf8) {
9374 sv_utf8_upgrade(sv);
9377 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9378 sv_utf8_upgrade(nsv);
9382 SvGROW(sv, SvCUR(sv) + elen + 1);
9386 /* Use memchr() instead of strchr(), as eptr is not guaranteed */
9387 /* to point to a null-terminated string. */
9388 if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
9389 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
9390 Perl_warner(aTHX_ packWARN(WARN_PRINTF),
9391 "Newline in left-justified string for %sprintf",
9392 (PL_op->op_type == OP_PRTF) ? "" : "s");
9394 have = esignlen + zeros + elen;
9395 need = (have > width ? have : width);
9398 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9400 if (esignlen && fill == '0') {
9401 for (i = 0; i < (int)esignlen; i++)
9405 memset(p, fill, gap);
9408 if (esignlen && fill != '0') {
9409 for (i = 0; i < (int)esignlen; i++)
9413 for (i = zeros; i; i--)
9417 Copy(eptr, p, elen, char);
9421 memset(p, ' ', gap);
9426 Copy(dotstr, p, dotstrlen, char);
9430 vectorize = FALSE; /* done iterating over vecstr */
9437 SvCUR(sv) = p - SvPVX(sv);
9445 /* =========================================================================
9447 =head1 Cloning an interpreter
9449 All the macros and functions in this section are for the private use of
9450 the main function, perl_clone().
9452 The foo_dup() functions make an exact copy of an existing foo thinngy.
9453 During the course of a cloning, a hash table is used to map old addresses
9454 to new addresses. The table is created and manipulated with the
9455 ptr_table_* functions.
9459 ============================================================================*/
9462 #if defined(USE_ITHREADS)
9464 #ifndef GpREFCNT_inc
9465 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9469 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9470 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9471 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9472 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9473 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9474 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9475 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9476 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9477 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9478 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9479 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9480 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9481 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9484 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9485 regcomp.c. AMS 20010712 */
9488 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
9492 struct reg_substr_datum *s;
9495 return (REGEXP *)NULL;
9497 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9500 len = r->offsets[0];
9501 npar = r->nparens+1;
9503 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9504 Copy(r->program, ret->program, len+1, regnode);
9506 New(0, ret->startp, npar, I32);
9507 Copy(r->startp, ret->startp, npar, I32);
9508 New(0, ret->endp, npar, I32);
9509 Copy(r->startp, ret->startp, npar, I32);
9511 New(0, ret->substrs, 1, struct reg_substr_data);
9512 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9513 s->min_offset = r->substrs->data[i].min_offset;
9514 s->max_offset = r->substrs->data[i].max_offset;
9515 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9516 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9519 ret->regstclass = NULL;
9522 int count = r->data->count;
9524 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9525 char, struct reg_data);
9526 New(0, d->what, count, U8);
9529 for (i = 0; i < count; i++) {
9530 d->what[i] = r->data->what[i];
9531 switch (d->what[i]) {
9533 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9536 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9539 /* This is cheating. */
9540 New(0, d->data[i], 1, struct regnode_charclass_class);
9541 StructCopy(r->data->data[i], d->data[i],
9542 struct regnode_charclass_class);
9543 ret->regstclass = (regnode*)d->data[i];
9546 /* Compiled op trees are readonly, and can thus be
9547 shared without duplication. */
9548 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9551 d->data[i] = r->data->data[i];
9561 New(0, ret->offsets, 2*len+1, U32);
9562 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9564 ret->precomp = SAVEPV(r->precomp);
9565 ret->refcnt = r->refcnt;
9566 ret->minlen = r->minlen;
9567 ret->prelen = r->prelen;
9568 ret->nparens = r->nparens;
9569 ret->lastparen = r->lastparen;
9570 ret->lastcloseparen = r->lastcloseparen;
9571 ret->reganch = r->reganch;
9573 ret->sublen = r->sublen;
9575 if (RX_MATCH_COPIED(ret))
9576 ret->subbeg = SAVEPV(r->subbeg);
9578 ret->subbeg = Nullch;
9579 #ifdef PERL_COPY_ON_WRITE
9580 ret->saved_copy = Nullsv;
9583 ptr_table_store(PL_ptr_table, r, ret);
9587 /* duplicate a file handle */
9590 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9594 return (PerlIO*)NULL;
9596 /* look for it in the table first */
9597 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9601 /* create anew and remember what it is */
9602 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9603 ptr_table_store(PL_ptr_table, fp, ret);
9607 /* duplicate a directory handle */
9610 Perl_dirp_dup(pTHX_ DIR *dp)
9618 /* duplicate a typeglob */
9621 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9626 /* look for it in the table first */
9627 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9631 /* create anew and remember what it is */
9632 Newz(0, ret, 1, GP);
9633 ptr_table_store(PL_ptr_table, gp, ret);
9636 ret->gp_refcnt = 0; /* must be before any other dups! */
9637 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9638 ret->gp_io = io_dup_inc(gp->gp_io, param);
9639 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9640 ret->gp_av = av_dup_inc(gp->gp_av, param);
9641 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9642 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9643 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9644 ret->gp_cvgen = gp->gp_cvgen;
9645 ret->gp_flags = gp->gp_flags;
9646 ret->gp_line = gp->gp_line;
9647 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9651 /* duplicate a chain of magic */
9654 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9656 MAGIC *mgprev = (MAGIC*)NULL;
9659 return (MAGIC*)NULL;
9660 /* look for it in the table first */
9661 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9665 for (; mg; mg = mg->mg_moremagic) {
9667 Newz(0, nmg, 1, MAGIC);
9669 mgprev->mg_moremagic = nmg;
9672 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9673 nmg->mg_private = mg->mg_private;
9674 nmg->mg_type = mg->mg_type;
9675 nmg->mg_flags = mg->mg_flags;
9676 if (mg->mg_type == PERL_MAGIC_qr) {
9677 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9679 else if(mg->mg_type == PERL_MAGIC_backref) {
9680 AV *av = (AV*) mg->mg_obj;
9683 nmg->mg_obj = (SV*)newAV();
9687 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9692 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9693 ? sv_dup_inc(mg->mg_obj, param)
9694 : sv_dup(mg->mg_obj, param);
9696 nmg->mg_len = mg->mg_len;
9697 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9698 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9699 if (mg->mg_len > 0) {
9700 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9701 if (mg->mg_type == PERL_MAGIC_overload_table &&
9702 AMT_AMAGIC((AMT*)mg->mg_ptr))
9704 AMT *amtp = (AMT*)mg->mg_ptr;
9705 AMT *namtp = (AMT*)nmg->mg_ptr;
9707 for (i = 1; i < NofAMmeth; i++) {
9708 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9712 else if (mg->mg_len == HEf_SVKEY)
9713 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9715 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9716 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9723 /* create a new pointer-mapping table */
9726 Perl_ptr_table_new(pTHX)
9729 Newz(0, tbl, 1, PTR_TBL_t);
9732 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9736 /* map an existing pointer using a table */
9739 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9741 PTR_TBL_ENT_t *tblent;
9742 UV hash = PTR2UV(sv);
9744 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9745 for (; tblent; tblent = tblent->next) {
9746 if (tblent->oldval == sv)
9747 return tblent->newval;
9752 /* add a new entry to a pointer-mapping table */
9755 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9757 PTR_TBL_ENT_t *tblent, **otblent;
9758 /* XXX this may be pessimal on platforms where pointers aren't good
9759 * hash values e.g. if they grow faster in the most significant
9761 UV hash = PTR2UV(oldv);
9765 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9766 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9767 if (tblent->oldval == oldv) {
9768 tblent->newval = newv;
9772 Newz(0, tblent, 1, PTR_TBL_ENT_t);
9773 tblent->oldval = oldv;
9774 tblent->newval = newv;
9775 tblent->next = *otblent;
9778 if (i && tbl->tbl_items > tbl->tbl_max)
9779 ptr_table_split(tbl);
9782 /* double the hash bucket size of an existing ptr table */
9785 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9787 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9788 UV oldsize = tbl->tbl_max + 1;
9789 UV newsize = oldsize * 2;
9792 Renew(ary, newsize, PTR_TBL_ENT_t*);
9793 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9794 tbl->tbl_max = --newsize;
9796 for (i=0; i < oldsize; i++, ary++) {
9797 PTR_TBL_ENT_t **curentp, **entp, *ent;
9800 curentp = ary + oldsize;
9801 for (entp = ary, ent = *ary; ent; ent = *entp) {
9802 if ((newsize & PTR2UV(ent->oldval)) != i) {
9804 ent->next = *curentp;
9814 /* remove all the entries from a ptr table */
9817 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9819 register PTR_TBL_ENT_t **array;
9820 register PTR_TBL_ENT_t *entry;
9821 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9825 if (!tbl || !tbl->tbl_items) {
9829 array = tbl->tbl_ary;
9836 entry = entry->next;
9840 if (++riter > max) {
9843 entry = array[riter];
9850 /* clear and free a ptr table */
9853 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9858 ptr_table_clear(tbl);
9859 Safefree(tbl->tbl_ary);
9867 /* attempt to make everything in the typeglob readonly */
9870 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9873 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9875 if (GvIO(gv) || GvFORM(gv)) {
9876 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9878 else if (!GvCV(gv)) {
9882 /* CvPADLISTs cannot be shared */
9883 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9888 if (!GvUNIQUE(gv)) {
9890 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9891 HvNAME(GvSTASH(gv)), GvNAME(gv));
9897 * write attempts will die with
9898 * "Modification of a read-only value attempted"
9904 SvREADONLY_on(GvSV(gv));
9911 SvREADONLY_on(GvAV(gv));
9918 SvREADONLY_on(GvAV(gv));
9921 return sstr; /* he_dup() will SvREFCNT_inc() */
9924 /* duplicate an SV of any type (including AV, HV etc) */
9927 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9930 SvRV(dstr) = SvWEAKREF(sstr)
9931 ? sv_dup(SvRV(sstr), param)
9932 : sv_dup_inc(SvRV(sstr), param);
9934 else if (SvPVX(sstr)) {
9935 /* Has something there */
9937 /* Normal PV - clone whole allocated space */
9938 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9939 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9940 /* Not that normal - actually sstr is copy on write.
9941 But we are a true, independant SV, so: */
9942 SvREADONLY_off(dstr);
9947 /* Special case - not normally malloced for some reason */
9948 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9949 /* A "shared" PV - clone it as unshared string */
9950 if(SvPADTMP(sstr)) {
9951 /* However, some of them live in the pad
9952 and they should not have these flags
9955 SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
9957 SvUVX(dstr) = SvUVX(sstr);
9960 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9962 SvREADONLY_off(dstr);
9966 /* Some other special case - random pointer */
9967 SvPVX(dstr) = SvPVX(sstr);
9973 SvPVX(dstr) = SvPVX(sstr);
9978 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9982 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9984 /* look for it in the table first */
9985 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9989 if(param->flags & CLONEf_JOIN_IN) {
9990 /** We are joining here so we don't want do clone
9991 something that is bad **/
9993 if(SvTYPE(sstr) == SVt_PVHV &&
9995 /** don't clone stashes if they already exist **/
9996 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
9997 return (SV*) old_stash;
10001 /* create anew and remember what it is */
10003 ptr_table_store(PL_ptr_table, sstr, dstr);
10006 SvFLAGS(dstr) = SvFLAGS(sstr);
10007 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
10008 SvREFCNT(dstr) = 0; /* must be before any other dups! */
10011 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
10012 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
10013 PL_watch_pvx, SvPVX(sstr));
10016 switch (SvTYPE(sstr)) {
10018 SvANY(dstr) = NULL;
10021 SvANY(dstr) = new_XIV();
10022 SvIVX(dstr) = SvIVX(sstr);
10025 SvANY(dstr) = new_XNV();
10026 SvNVX(dstr) = SvNVX(sstr);
10029 SvANY(dstr) = new_XRV();
10030 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10033 SvANY(dstr) = new_XPV();
10034 SvCUR(dstr) = SvCUR(sstr);
10035 SvLEN(dstr) = SvLEN(sstr);
10036 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10039 SvANY(dstr) = new_XPVIV();
10040 SvCUR(dstr) = SvCUR(sstr);
10041 SvLEN(dstr) = SvLEN(sstr);
10042 SvIVX(dstr) = SvIVX(sstr);
10043 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10046 SvANY(dstr) = new_XPVNV();
10047 SvCUR(dstr) = SvCUR(sstr);
10048 SvLEN(dstr) = SvLEN(sstr);
10049 SvIVX(dstr) = SvIVX(sstr);
10050 SvNVX(dstr) = SvNVX(sstr);
10051 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10054 SvANY(dstr) = new_XPVMG();
10055 SvCUR(dstr) = SvCUR(sstr);
10056 SvLEN(dstr) = SvLEN(sstr);
10057 SvIVX(dstr) = SvIVX(sstr);
10058 SvNVX(dstr) = SvNVX(sstr);
10059 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10060 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10061 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10064 SvANY(dstr) = new_XPVBM();
10065 SvCUR(dstr) = SvCUR(sstr);
10066 SvLEN(dstr) = SvLEN(sstr);
10067 SvIVX(dstr) = SvIVX(sstr);
10068 SvNVX(dstr) = SvNVX(sstr);
10069 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10070 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10071 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10072 BmRARE(dstr) = BmRARE(sstr);
10073 BmUSEFUL(dstr) = BmUSEFUL(sstr);
10074 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
10077 SvANY(dstr) = new_XPVLV();
10078 SvCUR(dstr) = SvCUR(sstr);
10079 SvLEN(dstr) = SvLEN(sstr);
10080 SvIVX(dstr) = SvIVX(sstr);
10081 SvNVX(dstr) = SvNVX(sstr);
10082 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10083 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10084 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10085 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
10086 LvTARGLEN(dstr) = LvTARGLEN(sstr);
10087 if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
10088 LvTARG(dstr) = dstr;
10089 else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
10090 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
10092 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
10093 LvTYPE(dstr) = LvTYPE(sstr);
10096 if (GvUNIQUE((GV*)sstr)) {
10098 if ((share = gv_share(sstr, param))) {
10101 ptr_table_store(PL_ptr_table, sstr, dstr);
10103 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
10104 HvNAME(GvSTASH(share)), GvNAME(share));
10109 SvANY(dstr) = new_XPVGV();
10110 SvCUR(dstr) = SvCUR(sstr);
10111 SvLEN(dstr) = SvLEN(sstr);
10112 SvIVX(dstr) = SvIVX(sstr);
10113 SvNVX(dstr) = SvNVX(sstr);
10114 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10115 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10116 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10117 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10118 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10119 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10120 GvFLAGS(dstr) = GvFLAGS(sstr);
10121 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10122 (void)GpREFCNT_inc(GvGP(dstr));
10125 SvANY(dstr) = new_XPVIO();
10126 SvCUR(dstr) = SvCUR(sstr);
10127 SvLEN(dstr) = SvLEN(sstr);
10128 SvIVX(dstr) = SvIVX(sstr);
10129 SvNVX(dstr) = SvNVX(sstr);
10130 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10131 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10132 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10133 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10134 if (IoOFP(sstr) == IoIFP(sstr))
10135 IoOFP(dstr) = IoIFP(dstr);
10137 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10138 /* PL_rsfp_filters entries have fake IoDIRP() */
10139 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10140 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10142 IoDIRP(dstr) = IoDIRP(sstr);
10143 IoLINES(dstr) = IoLINES(sstr);
10144 IoPAGE(dstr) = IoPAGE(sstr);
10145 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10146 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10147 if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10148 /* I have no idea why fake dirp (rsfps)
10149 should be treaded differently but otherwise
10150 we end up with leaks -- sky*/
10151 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
10152 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
10153 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10155 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10156 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10157 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10159 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10160 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10161 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10162 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10163 IoTYPE(dstr) = IoTYPE(sstr);
10164 IoFLAGS(dstr) = IoFLAGS(sstr);
10167 SvANY(dstr) = new_XPVAV();
10168 SvCUR(dstr) = SvCUR(sstr);
10169 SvLEN(dstr) = SvLEN(sstr);
10170 SvIVX(dstr) = SvIVX(sstr);
10171 SvNVX(dstr) = SvNVX(sstr);
10172 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10173 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10174 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10175 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10176 if (AvARRAY((AV*)sstr)) {
10177 SV **dst_ary, **src_ary;
10178 SSize_t items = AvFILLp((AV*)sstr) + 1;
10180 src_ary = AvARRAY((AV*)sstr);
10181 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10182 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10183 SvPVX(dstr) = (char*)dst_ary;
10184 AvALLOC((AV*)dstr) = dst_ary;
10185 if (AvREAL((AV*)sstr)) {
10186 while (items-- > 0)
10187 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10190 while (items-- > 0)
10191 *dst_ary++ = sv_dup(*src_ary++, param);
10193 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10194 while (items-- > 0) {
10195 *dst_ary++ = &PL_sv_undef;
10199 SvPVX(dstr) = Nullch;
10200 AvALLOC((AV*)dstr) = (SV**)NULL;
10204 SvANY(dstr) = new_XPVHV();
10205 SvCUR(dstr) = SvCUR(sstr);
10206 SvLEN(dstr) = SvLEN(sstr);
10207 SvIVX(dstr) = SvIVX(sstr);
10208 SvNVX(dstr) = SvNVX(sstr);
10209 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10210 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10211 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10212 if (HvARRAY((HV*)sstr)) {
10214 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10215 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10216 Newz(0, dxhv->xhv_array,
10217 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10218 while (i <= sxhv->xhv_max) {
10219 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10220 (bool)!!HvSHAREKEYS(sstr),
10224 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10225 (bool)!!HvSHAREKEYS(sstr), param);
10228 SvPVX(dstr) = Nullch;
10229 HvEITER((HV*)dstr) = (HE*)NULL;
10231 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
10232 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
10233 /* Record stashes for possible cloning in Perl_clone(). */
10234 if(HvNAME((HV*)dstr))
10235 av_push(param->stashes, dstr);
10238 SvANY(dstr) = new_XPVFM();
10239 FmLINES(dstr) = FmLINES(sstr);
10243 SvANY(dstr) = new_XPVCV();
10245 SvCUR(dstr) = SvCUR(sstr);
10246 SvLEN(dstr) = SvLEN(sstr);
10247 SvIVX(dstr) = SvIVX(sstr);
10248 SvNVX(dstr) = SvNVX(sstr);
10249 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10250 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10251 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10252 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10253 CvSTART(dstr) = CvSTART(sstr);
10254 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
10255 CvXSUB(dstr) = CvXSUB(sstr);
10256 CvXSUBANY(dstr) = CvXSUBANY(sstr);
10257 if (CvCONST(sstr)) {
10258 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10259 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10260 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
10262 CvGV(dstr) = gv_dup(CvGV(sstr), param);
10263 if (param->flags & CLONEf_COPY_STACKS) {
10264 CvDEPTH(dstr) = CvDEPTH(sstr);
10268 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10269 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10271 CvWEAKOUTSIDE(sstr)
10272 ? cv_dup( CvOUTSIDE(sstr), param)
10273 : cv_dup_inc(CvOUTSIDE(sstr), param);
10274 CvFLAGS(dstr) = CvFLAGS(sstr);
10275 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10278 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10282 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10288 /* duplicate a context */
10291 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10293 PERL_CONTEXT *ncxs;
10296 return (PERL_CONTEXT*)NULL;
10298 /* look for it in the table first */
10299 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10303 /* create anew and remember what it is */
10304 Newz(56, ncxs, max + 1, PERL_CONTEXT);
10305 ptr_table_store(PL_ptr_table, cxs, ncxs);
10308 PERL_CONTEXT *cx = &cxs[ix];
10309 PERL_CONTEXT *ncx = &ncxs[ix];
10310 ncx->cx_type = cx->cx_type;
10311 if (CxTYPE(cx) == CXt_SUBST) {
10312 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10315 ncx->blk_oldsp = cx->blk_oldsp;
10316 ncx->blk_oldcop = cx->blk_oldcop;
10317 ncx->blk_oldretsp = cx->blk_oldretsp;
10318 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10319 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10320 ncx->blk_oldpm = cx->blk_oldpm;
10321 ncx->blk_gimme = cx->blk_gimme;
10322 switch (CxTYPE(cx)) {
10324 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10325 ? cv_dup_inc(cx->blk_sub.cv, param)
10326 : cv_dup(cx->blk_sub.cv,param));
10327 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10328 ? av_dup_inc(cx->blk_sub.argarray, param)
10330 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10331 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10332 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10333 ncx->blk_sub.lval = cx->blk_sub.lval;
10336 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10337 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10338 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10339 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10340 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10343 ncx->blk_loop.label = cx->blk_loop.label;
10344 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10345 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10346 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10347 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10348 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10349 ? cx->blk_loop.iterdata
10350 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10351 ncx->blk_loop.oldcomppad
10352 = (PAD*)ptr_table_fetch(PL_ptr_table,
10353 cx->blk_loop.oldcomppad);
10354 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10355 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10356 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10357 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10358 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10361 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10362 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10363 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10364 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10376 /* duplicate a stack info structure */
10379 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10384 return (PERL_SI*)NULL;
10386 /* look for it in the table first */
10387 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10391 /* create anew and remember what it is */
10392 Newz(56, nsi, 1, PERL_SI);
10393 ptr_table_store(PL_ptr_table, si, nsi);
10395 nsi->si_stack = av_dup_inc(si->si_stack, param);
10396 nsi->si_cxix = si->si_cxix;
10397 nsi->si_cxmax = si->si_cxmax;
10398 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10399 nsi->si_type = si->si_type;
10400 nsi->si_prev = si_dup(si->si_prev, param);
10401 nsi->si_next = si_dup(si->si_next, param);
10402 nsi->si_markoff = si->si_markoff;
10407 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10408 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10409 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10410 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10411 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10412 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10413 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10414 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10415 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10416 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10417 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10418 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10419 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10420 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10423 #define pv_dup_inc(p) SAVEPV(p)
10424 #define pv_dup(p) SAVEPV(p)
10425 #define svp_dup_inc(p,pp) any_dup(p,pp)
10427 /* map any object to the new equivent - either something in the
10428 * ptr table, or something in the interpreter structure
10432 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
10437 return (void*)NULL;
10439 /* look for it in the table first */
10440 ret = ptr_table_fetch(PL_ptr_table, v);
10444 /* see if it is part of the interpreter structure */
10445 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10446 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10454 /* duplicate the save stack */
10457 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10459 ANY *ss = proto_perl->Tsavestack;
10460 I32 ix = proto_perl->Tsavestack_ix;
10461 I32 max = proto_perl->Tsavestack_max;
10474 void (*dptr) (void*);
10475 void (*dxptr) (pTHX_ void*);
10478 Newz(54, nss, max, ANY);
10482 TOPINT(nss,ix) = i;
10484 case SAVEt_ITEM: /* normal string */
10485 sv = (SV*)POPPTR(ss,ix);
10486 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10487 sv = (SV*)POPPTR(ss,ix);
10488 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10490 case SAVEt_SV: /* scalar reference */
10491 sv = (SV*)POPPTR(ss,ix);
10492 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10493 gv = (GV*)POPPTR(ss,ix);
10494 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10496 case SAVEt_GENERIC_PVREF: /* generic char* */
10497 c = (char*)POPPTR(ss,ix);
10498 TOPPTR(nss,ix) = pv_dup(c);
10499 ptr = POPPTR(ss,ix);
10500 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10502 case SAVEt_SHARED_PVREF: /* char* in shared space */
10503 c = (char*)POPPTR(ss,ix);
10504 TOPPTR(nss,ix) = savesharedpv(c);
10505 ptr = POPPTR(ss,ix);
10506 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10508 case SAVEt_GENERIC_SVREF: /* generic sv */
10509 case SAVEt_SVREF: /* scalar reference */
10510 sv = (SV*)POPPTR(ss,ix);
10511 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10512 ptr = POPPTR(ss,ix);
10513 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10515 case SAVEt_AV: /* array reference */
10516 av = (AV*)POPPTR(ss,ix);
10517 TOPPTR(nss,ix) = av_dup_inc(av, param);
10518 gv = (GV*)POPPTR(ss,ix);
10519 TOPPTR(nss,ix) = gv_dup(gv, param);
10521 case SAVEt_HV: /* hash reference */
10522 hv = (HV*)POPPTR(ss,ix);
10523 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10524 gv = (GV*)POPPTR(ss,ix);
10525 TOPPTR(nss,ix) = gv_dup(gv, param);
10527 case SAVEt_INT: /* int reference */
10528 ptr = POPPTR(ss,ix);
10529 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10530 intval = (int)POPINT(ss,ix);
10531 TOPINT(nss,ix) = intval;
10533 case SAVEt_LONG: /* long reference */
10534 ptr = POPPTR(ss,ix);
10535 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10536 longval = (long)POPLONG(ss,ix);
10537 TOPLONG(nss,ix) = longval;
10539 case SAVEt_I32: /* I32 reference */
10540 case SAVEt_I16: /* I16 reference */
10541 case SAVEt_I8: /* I8 reference */
10542 ptr = POPPTR(ss,ix);
10543 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10545 TOPINT(nss,ix) = i;
10547 case SAVEt_IV: /* IV reference */
10548 ptr = POPPTR(ss,ix);
10549 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10551 TOPIV(nss,ix) = iv;
10553 case SAVEt_SPTR: /* SV* reference */
10554 ptr = POPPTR(ss,ix);
10555 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10556 sv = (SV*)POPPTR(ss,ix);
10557 TOPPTR(nss,ix) = sv_dup(sv, param);
10559 case SAVEt_VPTR: /* random* reference */
10560 ptr = POPPTR(ss,ix);
10561 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10562 ptr = POPPTR(ss,ix);
10563 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10565 case SAVEt_PPTR: /* char* reference */
10566 ptr = POPPTR(ss,ix);
10567 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10568 c = (char*)POPPTR(ss,ix);
10569 TOPPTR(nss,ix) = pv_dup(c);
10571 case SAVEt_HPTR: /* HV* reference */
10572 ptr = POPPTR(ss,ix);
10573 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10574 hv = (HV*)POPPTR(ss,ix);
10575 TOPPTR(nss,ix) = hv_dup(hv, param);
10577 case SAVEt_APTR: /* AV* reference */
10578 ptr = POPPTR(ss,ix);
10579 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10580 av = (AV*)POPPTR(ss,ix);
10581 TOPPTR(nss,ix) = av_dup(av, param);
10584 gv = (GV*)POPPTR(ss,ix);
10585 TOPPTR(nss,ix) = gv_dup(gv, param);
10587 case SAVEt_GP: /* scalar reference */
10588 gp = (GP*)POPPTR(ss,ix);
10589 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10590 (void)GpREFCNT_inc(gp);
10591 gv = (GV*)POPPTR(ss,ix);
10592 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10593 c = (char*)POPPTR(ss,ix);
10594 TOPPTR(nss,ix) = pv_dup(c);
10596 TOPIV(nss,ix) = iv;
10598 TOPIV(nss,ix) = iv;
10601 case SAVEt_MORTALIZESV:
10602 sv = (SV*)POPPTR(ss,ix);
10603 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10606 ptr = POPPTR(ss,ix);
10607 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10608 /* these are assumed to be refcounted properly */
10609 switch (((OP*)ptr)->op_type) {
10611 case OP_LEAVESUBLV:
10615 case OP_LEAVEWRITE:
10616 TOPPTR(nss,ix) = ptr;
10621 TOPPTR(nss,ix) = Nullop;
10626 TOPPTR(nss,ix) = Nullop;
10629 c = (char*)POPPTR(ss,ix);
10630 TOPPTR(nss,ix) = pv_dup_inc(c);
10632 case SAVEt_CLEARSV:
10633 longval = POPLONG(ss,ix);
10634 TOPLONG(nss,ix) = longval;
10637 hv = (HV*)POPPTR(ss,ix);
10638 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10639 c = (char*)POPPTR(ss,ix);
10640 TOPPTR(nss,ix) = pv_dup_inc(c);
10642 TOPINT(nss,ix) = i;
10644 case SAVEt_DESTRUCTOR:
10645 ptr = POPPTR(ss,ix);
10646 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10647 dptr = POPDPTR(ss,ix);
10648 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
10650 case SAVEt_DESTRUCTOR_X:
10651 ptr = POPPTR(ss,ix);
10652 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10653 dxptr = POPDXPTR(ss,ix);
10654 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
10656 case SAVEt_REGCONTEXT:
10659 TOPINT(nss,ix) = i;
10662 case SAVEt_STACK_POS: /* Position on Perl stack */
10664 TOPINT(nss,ix) = i;
10666 case SAVEt_AELEM: /* array element */
10667 sv = (SV*)POPPTR(ss,ix);
10668 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10670 TOPINT(nss,ix) = i;
10671 av = (AV*)POPPTR(ss,ix);
10672 TOPPTR(nss,ix) = av_dup_inc(av, param);
10674 case SAVEt_HELEM: /* hash element */
10675 sv = (SV*)POPPTR(ss,ix);
10676 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10677 sv = (SV*)POPPTR(ss,ix);
10678 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10679 hv = (HV*)POPPTR(ss,ix);
10680 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10683 ptr = POPPTR(ss,ix);
10684 TOPPTR(nss,ix) = ptr;
10688 TOPINT(nss,ix) = i;
10690 case SAVEt_COMPPAD:
10691 av = (AV*)POPPTR(ss,ix);
10692 TOPPTR(nss,ix) = av_dup(av, param);
10695 longval = (long)POPLONG(ss,ix);
10696 TOPLONG(nss,ix) = longval;
10697 ptr = POPPTR(ss,ix);
10698 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10699 sv = (SV*)POPPTR(ss,ix);
10700 TOPPTR(nss,ix) = sv_dup(sv, param);
10703 ptr = POPPTR(ss,ix);
10704 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10705 longval = (long)POPBOOL(ss,ix);
10706 TOPBOOL(nss,ix) = (bool)longval;
10709 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10717 =for apidoc perl_clone
10719 Create and return a new interpreter by cloning the current one.
10721 perl_clone takes these flags as parameters:
10723 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10724 without it we only clone the data and zero the stacks,
10725 with it we copy the stacks and the new perl interpreter is
10726 ready to run at the exact same point as the previous one.
10727 The pseudo-fork code uses COPY_STACKS while the
10728 threads->new doesn't.
10730 CLONEf_KEEP_PTR_TABLE
10731 perl_clone keeps a ptr_table with the pointer of the old
10732 variable as a key and the new variable as a value,
10733 this allows it to check if something has been cloned and not
10734 clone it again but rather just use the value and increase the
10735 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10736 the ptr_table using the function
10737 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10738 reason to keep it around is if you want to dup some of your own
10739 variable who are outside the graph perl scans, example of this
10740 code is in threads.xs create
10743 This is a win32 thing, it is ignored on unix, it tells perls
10744 win32host code (which is c++) to clone itself, this is needed on
10745 win32 if you want to run two threads at the same time,
10746 if you just want to do some stuff in a separate perl interpreter
10747 and then throw it away and return to the original one,
10748 you don't need to do anything.
10753 /* XXX the above needs expanding by someone who actually understands it ! */
10754 EXTERN_C PerlInterpreter *
10755 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10758 perl_clone(PerlInterpreter *proto_perl, UV flags)
10760 #ifdef PERL_IMPLICIT_SYS
10762 /* perlhost.h so we need to call into it
10763 to clone the host, CPerlHost should have a c interface, sky */
10765 if (flags & CLONEf_CLONE_HOST) {
10766 return perl_clone_host(proto_perl,flags);
10768 return perl_clone_using(proto_perl, flags,
10770 proto_perl->IMemShared,
10771 proto_perl->IMemParse,
10773 proto_perl->IStdIO,
10777 proto_perl->IProc);
10781 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10782 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10783 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10784 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10785 struct IPerlDir* ipD, struct IPerlSock* ipS,
10786 struct IPerlProc* ipP)
10788 /* XXX many of the string copies here can be optimized if they're
10789 * constants; they need to be allocated as common memory and just
10790 * their pointers copied. */
10793 CLONE_PARAMS clone_params;
10794 CLONE_PARAMS* param = &clone_params;
10796 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10797 PERL_SET_THX(my_perl);
10800 Poison(my_perl, 1, PerlInterpreter);
10804 PL_savestack_ix = 0;
10805 PL_savestack_max = -1;
10807 PL_sig_pending = 0;
10808 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10809 # else /* !DEBUGGING */
10810 Zero(my_perl, 1, PerlInterpreter);
10811 # endif /* DEBUGGING */
10813 /* host pointers */
10815 PL_MemShared = ipMS;
10816 PL_MemParse = ipMP;
10823 #else /* !PERL_IMPLICIT_SYS */
10825 CLONE_PARAMS clone_params;
10826 CLONE_PARAMS* param = &clone_params;
10827 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10828 PERL_SET_THX(my_perl);
10833 Poison(my_perl, 1, PerlInterpreter);
10837 PL_savestack_ix = 0;
10838 PL_savestack_max = -1;
10840 PL_sig_pending = 0;
10841 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10842 # else /* !DEBUGGING */
10843 Zero(my_perl, 1, PerlInterpreter);
10844 # endif /* DEBUGGING */
10845 #endif /* PERL_IMPLICIT_SYS */
10846 param->flags = flags;
10847 param->proto_perl = proto_perl;
10850 PL_xiv_arenaroot = NULL;
10851 PL_xiv_root = NULL;
10852 PL_xnv_arenaroot = NULL;
10853 PL_xnv_root = NULL;
10854 PL_xrv_arenaroot = NULL;
10855 PL_xrv_root = NULL;
10856 PL_xpv_arenaroot = NULL;
10857 PL_xpv_root = NULL;
10858 PL_xpviv_arenaroot = NULL;
10859 PL_xpviv_root = NULL;
10860 PL_xpvnv_arenaroot = NULL;
10861 PL_xpvnv_root = NULL;
10862 PL_xpvcv_arenaroot = NULL;
10863 PL_xpvcv_root = NULL;
10864 PL_xpvav_arenaroot = NULL;
10865 PL_xpvav_root = NULL;
10866 PL_xpvhv_arenaroot = NULL;
10867 PL_xpvhv_root = NULL;
10868 PL_xpvmg_arenaroot = NULL;
10869 PL_xpvmg_root = NULL;
10870 PL_xpvlv_arenaroot = NULL;
10871 PL_xpvlv_root = NULL;
10872 PL_xpvbm_arenaroot = NULL;
10873 PL_xpvbm_root = NULL;
10874 PL_he_arenaroot = NULL;
10876 PL_nice_chunk = NULL;
10877 PL_nice_chunk_size = 0;
10879 PL_sv_objcount = 0;
10880 PL_sv_root = Nullsv;
10881 PL_sv_arenaroot = Nullsv;
10883 PL_debug = proto_perl->Idebug;
10885 #ifdef USE_REENTRANT_API
10886 Perl_reentrant_init(aTHX);
10889 /* create SV map for pointer relocation */
10890 PL_ptr_table = ptr_table_new();
10892 /* initialize these special pointers as early as possible */
10893 SvANY(&PL_sv_undef) = NULL;
10894 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10895 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10896 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10898 SvANY(&PL_sv_no) = new_XPVNV();
10899 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10900 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10901 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
10902 SvCUR(&PL_sv_no) = 0;
10903 SvLEN(&PL_sv_no) = 1;
10904 SvNVX(&PL_sv_no) = 0;
10905 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10907 SvANY(&PL_sv_yes) = new_XPVNV();
10908 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10909 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10910 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
10911 SvCUR(&PL_sv_yes) = 1;
10912 SvLEN(&PL_sv_yes) = 2;
10913 SvNVX(&PL_sv_yes) = 1;
10914 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10916 /* create (a non-shared!) shared string table */
10917 PL_strtab = newHV();
10918 HvSHAREKEYS_off(PL_strtab);
10919 hv_ksplit(PL_strtab, 512);
10920 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10922 PL_compiling = proto_perl->Icompiling;
10924 /* These two PVs will be free'd special way so must set them same way op.c does */
10925 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10926 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10928 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10929 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10931 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10932 if (!specialWARN(PL_compiling.cop_warnings))
10933 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10934 if (!specialCopIO(PL_compiling.cop_io))
10935 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10936 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10938 /* pseudo environmental stuff */
10939 PL_origargc = proto_perl->Iorigargc;
10940 PL_origargv = proto_perl->Iorigargv;
10942 param->stashes = newAV(); /* Setup array of objects to call clone on */
10944 #ifdef PERLIO_LAYERS
10945 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10946 PerlIO_clone(aTHX_ proto_perl, param);
10949 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10950 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10951 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10952 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10953 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10954 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10957 PL_minus_c = proto_perl->Iminus_c;
10958 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10959 PL_localpatches = proto_perl->Ilocalpatches;
10960 PL_splitstr = proto_perl->Isplitstr;
10961 PL_preprocess = proto_perl->Ipreprocess;
10962 PL_minus_n = proto_perl->Iminus_n;
10963 PL_minus_p = proto_perl->Iminus_p;
10964 PL_minus_l = proto_perl->Iminus_l;
10965 PL_minus_a = proto_perl->Iminus_a;
10966 PL_minus_F = proto_perl->Iminus_F;
10967 PL_doswitches = proto_perl->Idoswitches;
10968 PL_dowarn = proto_perl->Idowarn;
10969 PL_doextract = proto_perl->Idoextract;
10970 PL_sawampersand = proto_perl->Isawampersand;
10971 PL_unsafe = proto_perl->Iunsafe;
10972 PL_inplace = SAVEPV(proto_perl->Iinplace);
10973 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10974 PL_perldb = proto_perl->Iperldb;
10975 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10976 PL_exit_flags = proto_perl->Iexit_flags;
10978 /* magical thingies */
10979 /* XXX time(&PL_basetime) when asked for? */
10980 PL_basetime = proto_perl->Ibasetime;
10981 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10983 PL_maxsysfd = proto_perl->Imaxsysfd;
10984 PL_multiline = proto_perl->Imultiline;
10985 PL_statusvalue = proto_perl->Istatusvalue;
10987 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10989 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10991 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10992 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10993 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10995 /* Clone the regex array */
10996 PL_regex_padav = newAV();
10998 I32 len = av_len((AV*)proto_perl->Iregex_padav);
10999 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
11000 av_push(PL_regex_padav,
11001 sv_dup_inc(regexen[0],param));
11002 for(i = 1; i <= len; i++) {
11003 if(SvREPADTMP(regexen[i])) {
11004 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
11006 av_push(PL_regex_padav,
11008 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
11009 SvIVX(regexen[i])), param)))
11014 PL_regex_pad = AvARRAY(PL_regex_padav);
11016 /* shortcuts to various I/O objects */
11017 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
11018 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
11019 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11020 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11021 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11022 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11024 /* shortcuts to regexp stuff */
11025 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11027 /* shortcuts to misc objects */
11028 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11030 /* shortcuts to debugging objects */
11031 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11032 PL_DBline = gv_dup(proto_perl->IDBline, param);
11033 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11034 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11035 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11036 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11037 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11038 PL_lineary = av_dup(proto_perl->Ilineary, param);
11039 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11041 /* symbol tables */
11042 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11043 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11044 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11045 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11046 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11048 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11049 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11050 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11051 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11052 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11053 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11055 PL_sub_generation = proto_perl->Isub_generation;
11057 /* funky return mechanisms */
11058 PL_forkprocess = proto_perl->Iforkprocess;
11060 /* subprocess state */
11061 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11063 /* internal state */
11064 PL_tainting = proto_perl->Itainting;
11065 PL_taint_warn = proto_perl->Itaint_warn;
11066 PL_maxo = proto_perl->Imaxo;
11067 if (proto_perl->Iop_mask)
11068 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11070 PL_op_mask = Nullch;
11071 /* PL_asserting = proto_perl->Iasserting; */
11073 /* current interpreter roots */
11074 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11075 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11076 PL_main_start = proto_perl->Imain_start;
11077 PL_eval_root = proto_perl->Ieval_root;
11078 PL_eval_start = proto_perl->Ieval_start;
11080 /* runtime control stuff */
11081 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11082 PL_copline = proto_perl->Icopline;
11084 PL_filemode = proto_perl->Ifilemode;
11085 PL_lastfd = proto_perl->Ilastfd;
11086 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11089 PL_gensym = proto_perl->Igensym;
11090 PL_preambled = proto_perl->Ipreambled;
11091 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11092 PL_laststatval = proto_perl->Ilaststatval;
11093 PL_laststype = proto_perl->Ilaststype;
11094 PL_mess_sv = Nullsv;
11096 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11097 PL_ofmt = SAVEPV(proto_perl->Iofmt);
11099 /* interpreter atexit processing */
11100 PL_exitlistlen = proto_perl->Iexitlistlen;
11101 if (PL_exitlistlen) {
11102 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11103 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11106 PL_exitlist = (PerlExitListEntry*)NULL;
11107 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11108 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11109 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11111 PL_profiledata = NULL;
11112 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11113 /* PL_rsfp_filters entries have fake IoDIRP() */
11114 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11116 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11118 PAD_CLONE_VARS(proto_perl, param);
11120 #ifdef HAVE_INTERP_INTERN
11121 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11124 /* more statics moved here */
11125 PL_generation = proto_perl->Igeneration;
11126 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11128 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11129 PL_in_clean_all = proto_perl->Iin_clean_all;
11131 PL_uid = proto_perl->Iuid;
11132 PL_euid = proto_perl->Ieuid;
11133 PL_gid = proto_perl->Igid;
11134 PL_egid = proto_perl->Iegid;
11135 PL_nomemok = proto_perl->Inomemok;
11136 PL_an = proto_perl->Ian;
11137 PL_op_seqmax = proto_perl->Iop_seqmax;
11138 PL_evalseq = proto_perl->Ievalseq;
11139 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11140 PL_origalen = proto_perl->Iorigalen;
11141 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11142 PL_osname = SAVEPV(proto_perl->Iosname);
11143 PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
11144 PL_sighandlerp = proto_perl->Isighandlerp;
11147 PL_runops = proto_perl->Irunops;
11149 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11152 PL_cshlen = proto_perl->Icshlen;
11153 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11156 PL_lex_state = proto_perl->Ilex_state;
11157 PL_lex_defer = proto_perl->Ilex_defer;
11158 PL_lex_expect = proto_perl->Ilex_expect;
11159 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11160 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11161 PL_lex_starts = proto_perl->Ilex_starts;
11162 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11163 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11164 PL_lex_op = proto_perl->Ilex_op;
11165 PL_lex_inpat = proto_perl->Ilex_inpat;
11166 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11167 PL_lex_brackets = proto_perl->Ilex_brackets;
11168 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11169 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11170 PL_lex_casemods = proto_perl->Ilex_casemods;
11171 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11172 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11174 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11175 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11176 PL_nexttoke = proto_perl->Inexttoke;
11178 /* XXX This is probably masking the deeper issue of why
11179 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11180 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11181 * (A little debugging with a watchpoint on it may help.)
11183 if (SvANY(proto_perl->Ilinestr)) {
11184 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11185 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11186 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11187 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11188 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11189 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11190 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11191 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11192 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11195 PL_linestr = NEWSV(65,79);
11196 sv_upgrade(PL_linestr,SVt_PVIV);
11197 sv_setpvn(PL_linestr,"",0);
11198 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11200 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11201 PL_pending_ident = proto_perl->Ipending_ident;
11202 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11204 PL_expect = proto_perl->Iexpect;
11206 PL_multi_start = proto_perl->Imulti_start;
11207 PL_multi_end = proto_perl->Imulti_end;
11208 PL_multi_open = proto_perl->Imulti_open;
11209 PL_multi_close = proto_perl->Imulti_close;
11211 PL_error_count = proto_perl->Ierror_count;
11212 PL_subline = proto_perl->Isubline;
11213 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11215 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11216 if (SvANY(proto_perl->Ilinestr)) {
11217 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11218 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11219 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11220 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11221 PL_last_lop_op = proto_perl->Ilast_lop_op;
11224 PL_last_uni = SvPVX(PL_linestr);
11225 PL_last_lop = SvPVX(PL_linestr);
11226 PL_last_lop_op = 0;
11228 PL_in_my = proto_perl->Iin_my;
11229 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11231 PL_cryptseen = proto_perl->Icryptseen;
11234 PL_hints = proto_perl->Ihints;
11236 PL_amagic_generation = proto_perl->Iamagic_generation;
11238 #ifdef USE_LOCALE_COLLATE
11239 PL_collation_ix = proto_perl->Icollation_ix;
11240 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11241 PL_collation_standard = proto_perl->Icollation_standard;
11242 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11243 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11244 #endif /* USE_LOCALE_COLLATE */
11246 #ifdef USE_LOCALE_NUMERIC
11247 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11248 PL_numeric_standard = proto_perl->Inumeric_standard;
11249 PL_numeric_local = proto_perl->Inumeric_local;
11250 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11251 #endif /* !USE_LOCALE_NUMERIC */
11253 /* utf8 character classes */
11254 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11255 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11256 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11257 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11258 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11259 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11260 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11261 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11262 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11263 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11264 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11265 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11266 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11267 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11268 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11269 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11270 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11271 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11272 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11273 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11275 /* Did the locale setup indicate UTF-8? */
11276 PL_utf8locale = proto_perl->Iutf8locale;
11277 /* Unicode features (see perlrun/-C) */
11278 PL_unicode = proto_perl->Iunicode;
11280 /* Pre-5.8 signals control */
11281 PL_signals = proto_perl->Isignals;
11283 /* times() ticks per second */
11284 PL_clocktick = proto_perl->Iclocktick;
11286 /* Recursion stopper for PerlIO_find_layer */
11287 PL_in_load_module = proto_perl->Iin_load_module;
11289 /* sort() routine */
11290 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11292 /* Not really needed/useful since the reenrant_retint is "volatile",
11293 * but do it for consistency's sake. */
11294 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11296 /* Hooks to shared SVs and locks. */
11297 PL_sharehook = proto_perl->Isharehook;
11298 PL_lockhook = proto_perl->Ilockhook;
11299 PL_unlockhook = proto_perl->Iunlockhook;
11300 PL_threadhook = proto_perl->Ithreadhook;
11302 PL_runops_std = proto_perl->Irunops_std;
11303 PL_runops_dbg = proto_perl->Irunops_dbg;
11305 #ifdef THREADS_HAVE_PIDS
11306 PL_ppid = proto_perl->Ippid;
11310 PL_last_swash_hv = Nullhv; /* reinits on demand */
11311 PL_last_swash_klen = 0;
11312 PL_last_swash_key[0]= '\0';
11313 PL_last_swash_tmps = (U8*)NULL;
11314 PL_last_swash_slen = 0;
11316 /* perly.c globals */
11317 PL_yydebug = proto_perl->Iyydebug;
11318 PL_yynerrs = proto_perl->Iyynerrs;
11319 PL_yyerrflag = proto_perl->Iyyerrflag;
11320 PL_yychar = proto_perl->Iyychar;
11321 PL_yyval = proto_perl->Iyyval;
11322 PL_yylval = proto_perl->Iyylval;
11324 PL_glob_index = proto_perl->Iglob_index;
11325 PL_srand_called = proto_perl->Isrand_called;
11326 PL_hash_seed = proto_perl->Ihash_seed;
11327 PL_uudmap['M'] = 0; /* reinits on demand */
11328 PL_bitcount = Nullch; /* reinits on demand */
11330 if (proto_perl->Ipsig_pend) {
11331 Newz(0, PL_psig_pend, SIG_SIZE, int);
11334 PL_psig_pend = (int*)NULL;
11337 if (proto_perl->Ipsig_ptr) {
11338 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
11339 Newz(0, PL_psig_name, SIG_SIZE, SV*);
11340 for (i = 1; i < SIG_SIZE; i++) {
11341 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11342 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11346 PL_psig_ptr = (SV**)NULL;
11347 PL_psig_name = (SV**)NULL;
11350 /* thrdvar.h stuff */
11352 if (flags & CLONEf_COPY_STACKS) {
11353 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11354 PL_tmps_ix = proto_perl->Ttmps_ix;
11355 PL_tmps_max = proto_perl->Ttmps_max;
11356 PL_tmps_floor = proto_perl->Ttmps_floor;
11357 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11359 while (i <= PL_tmps_ix) {
11360 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11364 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11365 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11366 Newz(54, PL_markstack, i, I32);
11367 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11368 - proto_perl->Tmarkstack);
11369 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11370 - proto_perl->Tmarkstack);
11371 Copy(proto_perl->Tmarkstack, PL_markstack,
11372 PL_markstack_ptr - PL_markstack + 1, I32);
11374 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11375 * NOTE: unlike the others! */
11376 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11377 PL_scopestack_max = proto_perl->Tscopestack_max;
11378 Newz(54, PL_scopestack, PL_scopestack_max, I32);
11379 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11381 /* next push_return() sets PL_retstack[PL_retstack_ix]
11382 * NOTE: unlike the others! */
11383 PL_retstack_ix = proto_perl->Tretstack_ix;
11384 PL_retstack_max = proto_perl->Tretstack_max;
11385 Newz(54, PL_retstack, PL_retstack_max, OP*);
11386 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
11388 /* NOTE: si_dup() looks at PL_markstack */
11389 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11391 /* PL_curstack = PL_curstackinfo->si_stack; */
11392 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11393 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11395 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11396 PL_stack_base = AvARRAY(PL_curstack);
11397 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11398 - proto_perl->Tstack_base);
11399 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11401 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11402 * NOTE: unlike the others! */
11403 PL_savestack_ix = proto_perl->Tsavestack_ix;
11404 PL_savestack_max = proto_perl->Tsavestack_max;
11405 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11406 PL_savestack = ss_dup(proto_perl, param);
11410 ENTER; /* perl_destruct() wants to LEAVE; */
11413 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11414 PL_top_env = &PL_start_env;
11416 PL_op = proto_perl->Top;
11419 PL_Xpv = (XPV*)NULL;
11420 PL_na = proto_perl->Tna;
11422 PL_statbuf = proto_perl->Tstatbuf;
11423 PL_statcache = proto_perl->Tstatcache;
11424 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11425 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11427 PL_timesbuf = proto_perl->Ttimesbuf;
11430 PL_tainted = proto_perl->Ttainted;
11431 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11432 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11433 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11434 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11435 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11436 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11437 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11438 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11439 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11441 PL_restartop = proto_perl->Trestartop;
11442 PL_in_eval = proto_perl->Tin_eval;
11443 PL_delaymagic = proto_perl->Tdelaymagic;
11444 PL_dirty = proto_perl->Tdirty;
11445 PL_localizing = proto_perl->Tlocalizing;
11447 #ifdef PERL_FLEXIBLE_EXCEPTIONS
11448 PL_protect = proto_perl->Tprotect;
11450 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11451 PL_hv_fetch_ent_mh = Nullhe;
11452 PL_modcount = proto_perl->Tmodcount;
11453 PL_lastgotoprobe = Nullop;
11454 PL_dumpindent = proto_perl->Tdumpindent;
11456 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11457 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11458 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11459 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11460 PL_sortcxix = proto_perl->Tsortcxix;
11461 PL_efloatbuf = Nullch; /* reinits on demand */
11462 PL_efloatsize = 0; /* reinits on demand */
11466 PL_screamfirst = NULL;
11467 PL_screamnext = NULL;
11468 PL_maxscream = -1; /* reinits on demand */
11469 PL_lastscream = Nullsv;
11471 PL_watchaddr = NULL;
11472 PL_watchok = Nullch;
11474 PL_regdummy = proto_perl->Tregdummy;
11475 PL_regprecomp = Nullch;
11478 PL_colorset = 0; /* reinits PL_colors[] */
11479 /*PL_colors[6] = {0,0,0,0,0,0};*/
11480 PL_reginput = Nullch;
11481 PL_regbol = Nullch;
11482 PL_regeol = Nullch;
11483 PL_regstartp = (I32*)NULL;
11484 PL_regendp = (I32*)NULL;
11485 PL_reglastparen = (U32*)NULL;
11486 PL_reglastcloseparen = (U32*)NULL;
11487 PL_regtill = Nullch;
11488 PL_reg_start_tmp = (char**)NULL;
11489 PL_reg_start_tmpl = 0;
11490 PL_regdata = (struct reg_data*)NULL;
11493 PL_reg_eval_set = 0;
11495 PL_regprogram = (regnode*)NULL;
11497 PL_regcc = (CURCUR*)NULL;
11498 PL_reg_call_cc = (struct re_cc_state*)NULL;
11499 PL_reg_re = (regexp*)NULL;
11500 PL_reg_ganch = Nullch;
11501 PL_reg_sv = Nullsv;
11502 PL_reg_match_utf8 = FALSE;
11503 PL_reg_magic = (MAGIC*)NULL;
11505 PL_reg_oldcurpm = (PMOP*)NULL;
11506 PL_reg_curpm = (PMOP*)NULL;
11507 PL_reg_oldsaved = Nullch;
11508 PL_reg_oldsavedlen = 0;
11509 #ifdef PERL_COPY_ON_WRITE
11512 PL_reg_maxiter = 0;
11513 PL_reg_leftiter = 0;
11514 PL_reg_poscache = Nullch;
11515 PL_reg_poscache_size= 0;
11517 /* RE engine - function pointers */
11518 PL_regcompp = proto_perl->Tregcompp;
11519 PL_regexecp = proto_perl->Tregexecp;
11520 PL_regint_start = proto_perl->Tregint_start;
11521 PL_regint_string = proto_perl->Tregint_string;
11522 PL_regfree = proto_perl->Tregfree;
11524 PL_reginterp_cnt = 0;
11525 PL_reg_starttry = 0;
11527 /* Pluggable optimizer */
11528 PL_peepp = proto_perl->Tpeepp;
11530 PL_stashcache = newHV();
11532 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11533 ptr_table_free(PL_ptr_table);
11534 PL_ptr_table = NULL;
11537 /* Call the ->CLONE method, if it exists, for each of the stashes
11538 identified by sv_dup() above.
11540 while(av_len(param->stashes) != -1) {
11541 HV* stash = (HV*) av_shift(param->stashes);
11542 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11543 if (cloner && GvCV(cloner)) {
11548 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
11550 call_sv((SV*)GvCV(cloner), G_DISCARD);
11556 SvREFCNT_dec(param->stashes);
11561 #endif /* USE_ITHREADS */
11564 =head1 Unicode Support
11566 =for apidoc sv_recode_to_utf8
11568 The encoding is assumed to be an Encode object, on entry the PV
11569 of the sv is assumed to be octets in that encoding, and the sv
11570 will be converted into Unicode (and UTF-8).
11572 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11573 is not a reference, nothing is done to the sv. If the encoding is not
11574 an C<Encode::XS> Encoding object, bad things will happen.
11575 (See F<lib/encoding.pm> and L<Encode>).
11577 The PV of the sv is returned.
11582 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11584 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11598 Passing sv_yes is wrong - it needs to be or'ed set of constants
11599 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11600 remove converted chars from source.
11602 Both will default the value - let them.
11604 XPUSHs(&PL_sv_yes);
11607 call_method("decode", G_SCALAR);
11611 s = SvPV(uni, len);
11612 if (s != SvPVX(sv)) {
11613 SvGROW(sv, len + 1);
11614 Move(s, SvPVX(sv), len, char);
11615 SvCUR_set(sv, len);
11616 SvPVX(sv)[len] = 0;
11626 =for apidoc sv_cat_decode
11628 The encoding is assumed to be an Encode object, the PV of the ssv is
11629 assumed to be octets in that encoding and decoding the input starts
11630 from the position which (PV + *offset) pointed to. The dsv will be
11631 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11632 when the string tstr appears in decoding output or the input ends on
11633 the PV of the ssv. The value which the offset points will be modified
11634 to the last input position on the ssv.
11636 Returns TRUE if the terminator was found, else returns FALSE.
11641 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11642 SV *ssv, int *offset, char *tstr, int tlen)
11645 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11656 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11657 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11659 call_method("cat_decode", G_SCALAR);
11661 ret = SvTRUE(TOPs);
11662 *offset = SvIV(offsv);
11668 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");