3 * Copyright (c) 1991-2003, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
8 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
11 * This file contains the code that creates, manipulates and destroys
12 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
13 * structure of an SV, so their creation and destruction is handled
14 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
15 * level functions (eg. substr, split, join) for each of the types are
26 #ifdef PERL_COPY_ON_WRITE
27 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
28 #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
29 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
33 /* ============================================================================
35 =head1 Allocation and deallocation of SVs.
37 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
38 av, hv...) contains type and reference count information, as well as a
39 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
40 specific to each type.
42 Normally, this allocation is done using arenas, which are approximately
43 1K chunks of memory parcelled up into N heads or bodies. The first slot
44 in each arena is reserved, and is used to hold a link to the next arena.
45 In the case of heads, the unused first slot also contains some flags and
46 a note of the number of slots. Snaked through each arena chain is a
47 linked list of free items; when this becomes empty, an extra arena is
48 allocated and divided up into N items which are threaded into the free
51 The following global variables are associated with arenas:
53 PL_sv_arenaroot pointer to list of SV arenas
54 PL_sv_root pointer to list of free SV structures
56 PL_foo_arenaroot pointer to list of foo arenas,
57 PL_foo_root pointer to list of free foo bodies
58 ... for foo in xiv, xnv, xrv, xpv etc.
60 Note that some of the larger and more rarely used body types (eg xpvio)
61 are not allocated using arenas, but are instead just malloc()/free()ed as
62 required. Also, if PURIFY is defined, arenas are abandoned altogether,
63 with all items individually malloc()ed. In addition, a few SV heads are
64 not allocated from an arena, but are instead directly created as static
65 or auto variables, eg PL_sv_undef.
67 The SV arena serves the secondary purpose of allowing still-live SVs
68 to be located and destroyed during final cleanup.
70 At the lowest level, the macros new_SV() and del_SV() grab and free
71 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
72 to return the SV to the free list with error checking.) new_SV() calls
73 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
74 SVs in the free list have their SvTYPE field set to all ones.
76 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
77 that allocate and return individual body types. Normally these are mapped
78 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
79 instead mapped directly to malloc()/free() if PURIFY is defined. The
80 new/del functions remove from, or add to, the appropriate PL_foo_root
81 list, and call more_xiv() etc to add a new arena if the list is empty.
83 At the time of very final cleanup, sv_free_arenas() is called from
84 perl_destruct() to physically free all the arenas allocated since the
85 start of the interpreter. Note that this also clears PL_he_arenaroot,
86 which is otherwise dealt with in hv.c.
88 Manipulation of any of the PL_*root pointers is protected by enclosing
89 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
90 if threads are enabled.
92 The function visit() scans the SV arenas list, and calls a specified
93 function for each SV it finds which is still live - ie which has an SvTYPE
94 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
95 following functions (specified as [function that calls visit()] / [function
96 called by visit() for each SV]):
98 sv_report_used() / do_report_used()
99 dump all remaining SVs (debugging aid)
101 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
102 Attempt to free all objects pointed to by RVs,
103 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
104 try to do the same for all objects indirectly
105 referenced by typeglobs too. Called once from
106 perl_destruct(), prior to calling sv_clean_all()
109 sv_clean_all() / do_clean_all()
110 SvREFCNT_dec(sv) each remaining SV, possibly
111 triggering an sv_free(). It also sets the
112 SVf_BREAK flag on the SV to indicate that the
113 refcnt has been artificially lowered, and thus
114 stopping sv_free() from giving spurious warnings
115 about SVs which unexpectedly have a refcnt
116 of zero. called repeatedly from perl_destruct()
117 until there are no SVs left.
121 Private API to rest of sv.c
125 new_XIV(), del_XIV(),
126 new_XNV(), del_XNV(),
131 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
136 ============================================================================ */
141 * "A time to plant, and a time to uproot what was planted..."
144 #define plant_SV(p) \
146 SvANY(p) = (void *)PL_sv_root; \
147 SvFLAGS(p) = SVTYPEMASK; \
152 /* sv_mutex must be held while calling uproot_SV() */
153 #define uproot_SV(p) \
156 PL_sv_root = (SV*)SvANY(p); \
161 /* new_SV(): return a new, empty SV head */
163 #ifdef DEBUG_LEAKING_SCALARS
164 /* provide a real function for a debugger to play with */
181 # define new_SV(p) (p)=S_new_SV(aTHX)
199 /* del_SV(): return an empty SV head to the free list */
214 S_del_sv(pTHX_ SV *p)
221 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
223 svend = &sva[SvREFCNT(sva)];
224 if (p >= sv && p < svend)
228 if (ckWARN_d(WARN_INTERNAL))
229 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
230 "Attempt to free non-arena SV: 0x%"UVxf,
238 #else /* ! DEBUGGING */
240 #define del_SV(p) plant_SV(p)
242 #endif /* DEBUGGING */
246 =head1 SV Manipulation Functions
248 =for apidoc sv_add_arena
250 Given a chunk of memory, link it to the head of the list of arenas,
251 and split it into a list of free SVs.
257 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
262 Zero(ptr, size, char);
264 /* The first SV in an arena isn't an SV. */
265 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
266 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
267 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
269 PL_sv_arenaroot = sva;
270 PL_sv_root = sva + 1;
272 svend = &sva[SvREFCNT(sva) - 1];
275 SvANY(sv) = (void *)(SV*)(sv + 1);
276 SvFLAGS(sv) = SVTYPEMASK;
280 SvFLAGS(sv) = SVTYPEMASK;
283 /* make some more SVs by adding another arena */
285 /* sv_mutex must be held while calling more_sv() */
292 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
293 PL_nice_chunk = Nullch;
294 PL_nice_chunk_size = 0;
297 char *chunk; /* must use New here to match call to */
298 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
299 sv_add_arena(chunk, 1008, 0);
305 /* visit(): call the named function for each non-free SV in the arenas. */
308 S_visit(pTHX_ SVFUNC_t f)
315 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
316 svend = &sva[SvREFCNT(sva)];
317 for (sv = sva + 1; sv < svend; ++sv) {
318 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
329 /* called by sv_report_used() for each live SV */
332 do_report_used(pTHX_ SV *sv)
334 if (SvTYPE(sv) != SVTYPEMASK) {
335 PerlIO_printf(Perl_debug_log, "****\n");
342 =for apidoc sv_report_used
344 Dump the contents of all SVs not yet freed. (Debugging aid).
350 Perl_sv_report_used(pTHX)
353 visit(do_report_used);
357 /* called by sv_clean_objs() for each live SV */
360 do_clean_objs(pTHX_ SV *sv)
364 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
365 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
377 /* XXX Might want to check arrays, etc. */
380 /* called by sv_clean_objs() for each live SV */
382 #ifndef DISABLE_DESTRUCTOR_KLUDGE
384 do_clean_named_objs(pTHX_ SV *sv)
386 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
387 if ( SvOBJECT(GvSV(sv)) ||
388 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
389 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
390 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
391 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
393 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
401 =for apidoc sv_clean_objs
403 Attempt to destroy all objects not yet freed
409 Perl_sv_clean_objs(pTHX)
411 PL_in_clean_objs = TRUE;
412 visit(do_clean_objs);
413 #ifndef DISABLE_DESTRUCTOR_KLUDGE
414 /* some barnacles may yet remain, clinging to typeglobs */
415 visit(do_clean_named_objs);
417 PL_in_clean_objs = FALSE;
420 /* called by sv_clean_all() for each live SV */
423 do_clean_all(pTHX_ SV *sv)
425 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
426 SvFLAGS(sv) |= SVf_BREAK;
431 =for apidoc sv_clean_all
433 Decrement the refcnt of each remaining SV, possibly triggering a
434 cleanup. This function may have to be called multiple times to free
435 SVs which are in complex self-referential hierarchies.
441 Perl_sv_clean_all(pTHX)
444 PL_in_clean_all = TRUE;
445 cleaned = visit(do_clean_all);
446 PL_in_clean_all = FALSE;
451 =for apidoc sv_free_arenas
453 Deallocate the memory used by all arenas. Note that all the individual SV
454 heads and bodies within the arenas must already have been freed.
460 Perl_sv_free_arenas(pTHX)
464 XPV *arena, *arenanext;
466 /* Free arenas here, but be careful about fake ones. (We assume
467 contiguity of the fake ones with the corresponding real ones.) */
469 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
470 svanext = (SV*) SvANY(sva);
471 while (svanext && SvFAKE(svanext))
472 svanext = (SV*) SvANY(svanext);
475 Safefree((void *)sva);
478 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
479 arenanext = (XPV*)arena->xpv_pv;
482 PL_xiv_arenaroot = 0;
484 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
485 arenanext = (XPV*)arena->xpv_pv;
488 PL_xnv_arenaroot = 0;
490 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
491 arenanext = (XPV*)arena->xpv_pv;
494 PL_xrv_arenaroot = 0;
496 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
497 arenanext = (XPV*)arena->xpv_pv;
500 PL_xpv_arenaroot = 0;
502 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
503 arenanext = (XPV*)arena->xpv_pv;
506 PL_xpviv_arenaroot = 0;
508 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
509 arenanext = (XPV*)arena->xpv_pv;
512 PL_xpvnv_arenaroot = 0;
514 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
515 arenanext = (XPV*)arena->xpv_pv;
518 PL_xpvcv_arenaroot = 0;
520 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
521 arenanext = (XPV*)arena->xpv_pv;
524 PL_xpvav_arenaroot = 0;
526 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
527 arenanext = (XPV*)arena->xpv_pv;
530 PL_xpvhv_arenaroot = 0;
532 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
533 arenanext = (XPV*)arena->xpv_pv;
536 PL_xpvmg_arenaroot = 0;
538 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
539 arenanext = (XPV*)arena->xpv_pv;
542 PL_xpvlv_arenaroot = 0;
544 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
545 arenanext = (XPV*)arena->xpv_pv;
548 PL_xpvbm_arenaroot = 0;
550 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
551 arenanext = (XPV*)arena->xpv_pv;
557 Safefree(PL_nice_chunk);
558 PL_nice_chunk = Nullch;
559 PL_nice_chunk_size = 0;
565 =for apidoc report_uninit
567 Print appropriate "Use of uninitialized variable" warning
573 Perl_report_uninit(pTHX)
576 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
577 " in ", OP_DESC(PL_op));
579 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
582 /* grab a new IV body from the free list, allocating more if necessary */
593 * See comment in more_xiv() -- RAM.
595 PL_xiv_root = *(IV**)xiv;
597 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
600 /* return an IV body to the free list */
603 S_del_xiv(pTHX_ XPVIV *p)
605 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
607 *(IV**)xiv = PL_xiv_root;
612 /* allocate another arena's worth of IV bodies */
620 New(705, ptr, 1008/sizeof(XPV), XPV);
621 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
622 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
625 xivend = &xiv[1008 / sizeof(IV) - 1];
626 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
628 while (xiv < xivend) {
629 *(IV**)xiv = (IV *)(xiv + 1);
635 /* grab a new NV body from the free list, allocating more if necessary */
645 PL_xnv_root = *(NV**)xnv;
647 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
650 /* return an NV body to the free list */
653 S_del_xnv(pTHX_ XPVNV *p)
655 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
657 *(NV**)xnv = PL_xnv_root;
662 /* allocate another arena's worth of NV bodies */
670 New(711, ptr, 1008/sizeof(XPV), XPV);
671 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
672 PL_xnv_arenaroot = ptr;
675 xnvend = &xnv[1008 / sizeof(NV) - 1];
676 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
678 while (xnv < xnvend) {
679 *(NV**)xnv = (NV*)(xnv + 1);
685 /* grab a new struct xrv from the free list, allocating more if necessary */
695 PL_xrv_root = (XRV*)xrv->xrv_rv;
700 /* return a struct xrv to the free list */
703 S_del_xrv(pTHX_ XRV *p)
706 p->xrv_rv = (SV*)PL_xrv_root;
711 /* allocate another arena's worth of struct xrv */
717 register XRV* xrvend;
719 New(712, ptr, 1008/sizeof(XPV), XPV);
720 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
721 PL_xrv_arenaroot = ptr;
724 xrvend = &xrv[1008 / sizeof(XRV) - 1];
725 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
727 while (xrv < xrvend) {
728 xrv->xrv_rv = (SV*)(xrv + 1);
734 /* grab a new struct xpv from the free list, allocating more if necessary */
744 PL_xpv_root = (XPV*)xpv->xpv_pv;
749 /* return a struct xpv to the free list */
752 S_del_xpv(pTHX_ XPV *p)
755 p->xpv_pv = (char*)PL_xpv_root;
760 /* allocate another arena's worth of struct xpv */
766 register XPV* xpvend;
767 New(713, xpv, 1008/sizeof(XPV), XPV);
768 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
769 PL_xpv_arenaroot = xpv;
771 xpvend = &xpv[1008 / sizeof(XPV) - 1];
773 while (xpv < xpvend) {
774 xpv->xpv_pv = (char*)(xpv + 1);
780 /* grab a new struct xpviv from the free list, allocating more if necessary */
789 xpviv = PL_xpviv_root;
790 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
795 /* return a struct xpviv to the free list */
798 S_del_xpviv(pTHX_ XPVIV *p)
801 p->xpv_pv = (char*)PL_xpviv_root;
806 /* allocate another arena's worth of struct xpviv */
811 register XPVIV* xpviv;
812 register XPVIV* xpvivend;
813 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
814 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
815 PL_xpviv_arenaroot = xpviv;
817 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
818 PL_xpviv_root = ++xpviv;
819 while (xpviv < xpvivend) {
820 xpviv->xpv_pv = (char*)(xpviv + 1);
826 /* grab a new struct xpvnv from the free list, allocating more if necessary */
835 xpvnv = PL_xpvnv_root;
836 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
841 /* return a struct xpvnv to the free list */
844 S_del_xpvnv(pTHX_ XPVNV *p)
847 p->xpv_pv = (char*)PL_xpvnv_root;
852 /* allocate another arena's worth of struct xpvnv */
857 register XPVNV* xpvnv;
858 register XPVNV* xpvnvend;
859 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
860 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
861 PL_xpvnv_arenaroot = xpvnv;
863 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
864 PL_xpvnv_root = ++xpvnv;
865 while (xpvnv < xpvnvend) {
866 xpvnv->xpv_pv = (char*)(xpvnv + 1);
872 /* grab a new struct xpvcv from the free list, allocating more if necessary */
881 xpvcv = PL_xpvcv_root;
882 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
887 /* return a struct xpvcv to the free list */
890 S_del_xpvcv(pTHX_ XPVCV *p)
893 p->xpv_pv = (char*)PL_xpvcv_root;
898 /* allocate another arena's worth of struct xpvcv */
903 register XPVCV* xpvcv;
904 register XPVCV* xpvcvend;
905 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
906 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
907 PL_xpvcv_arenaroot = xpvcv;
909 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
910 PL_xpvcv_root = ++xpvcv;
911 while (xpvcv < xpvcvend) {
912 xpvcv->xpv_pv = (char*)(xpvcv + 1);
918 /* grab a new struct xpvav from the free list, allocating more if necessary */
927 xpvav = PL_xpvav_root;
928 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
933 /* return a struct xpvav to the free list */
936 S_del_xpvav(pTHX_ XPVAV *p)
939 p->xav_array = (char*)PL_xpvav_root;
944 /* allocate another arena's worth of struct xpvav */
949 register XPVAV* xpvav;
950 register XPVAV* xpvavend;
951 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
952 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
953 PL_xpvav_arenaroot = xpvav;
955 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
956 PL_xpvav_root = ++xpvav;
957 while (xpvav < xpvavend) {
958 xpvav->xav_array = (char*)(xpvav + 1);
961 xpvav->xav_array = 0;
964 /* grab a new struct xpvhv from the free list, allocating more if necessary */
973 xpvhv = PL_xpvhv_root;
974 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
979 /* return a struct xpvhv to the free list */
982 S_del_xpvhv(pTHX_ XPVHV *p)
985 p->xhv_array = (char*)PL_xpvhv_root;
990 /* allocate another arena's worth of struct xpvhv */
995 register XPVHV* xpvhv;
996 register XPVHV* xpvhvend;
997 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
998 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
999 PL_xpvhv_arenaroot = xpvhv;
1001 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1002 PL_xpvhv_root = ++xpvhv;
1003 while (xpvhv < xpvhvend) {
1004 xpvhv->xhv_array = (char*)(xpvhv + 1);
1007 xpvhv->xhv_array = 0;
1010 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1019 xpvmg = PL_xpvmg_root;
1020 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1025 /* return a struct xpvmg to the free list */
1028 S_del_xpvmg(pTHX_ XPVMG *p)
1031 p->xpv_pv = (char*)PL_xpvmg_root;
1036 /* allocate another arena's worth of struct xpvmg */
1041 register XPVMG* xpvmg;
1042 register XPVMG* xpvmgend;
1043 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1044 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1045 PL_xpvmg_arenaroot = xpvmg;
1047 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1048 PL_xpvmg_root = ++xpvmg;
1049 while (xpvmg < xpvmgend) {
1050 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1056 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1065 xpvlv = PL_xpvlv_root;
1066 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1071 /* return a struct xpvlv to the free list */
1074 S_del_xpvlv(pTHX_ XPVLV *p)
1077 p->xpv_pv = (char*)PL_xpvlv_root;
1082 /* allocate another arena's worth of struct xpvlv */
1087 register XPVLV* xpvlv;
1088 register XPVLV* xpvlvend;
1089 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1090 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1091 PL_xpvlv_arenaroot = xpvlv;
1093 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1094 PL_xpvlv_root = ++xpvlv;
1095 while (xpvlv < xpvlvend) {
1096 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1102 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1111 xpvbm = PL_xpvbm_root;
1112 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1117 /* return a struct xpvbm to the free list */
1120 S_del_xpvbm(pTHX_ XPVBM *p)
1123 p->xpv_pv = (char*)PL_xpvbm_root;
1128 /* allocate another arena's worth of struct xpvbm */
1133 register XPVBM* xpvbm;
1134 register XPVBM* xpvbmend;
1135 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1136 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1137 PL_xpvbm_arenaroot = xpvbm;
1139 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1140 PL_xpvbm_root = ++xpvbm;
1141 while (xpvbm < xpvbmend) {
1142 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1148 #define my_safemalloc(s) (void*)safemalloc(s)
1149 #define my_safefree(p) safefree((char*)p)
1153 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1154 #define del_XIV(p) my_safefree(p)
1156 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1157 #define del_XNV(p) my_safefree(p)
1159 #define new_XRV() my_safemalloc(sizeof(XRV))
1160 #define del_XRV(p) my_safefree(p)
1162 #define new_XPV() my_safemalloc(sizeof(XPV))
1163 #define del_XPV(p) my_safefree(p)
1165 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1166 #define del_XPVIV(p) my_safefree(p)
1168 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1169 #define del_XPVNV(p) my_safefree(p)
1171 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1172 #define del_XPVCV(p) my_safefree(p)
1174 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1175 #define del_XPVAV(p) my_safefree(p)
1177 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1178 #define del_XPVHV(p) my_safefree(p)
1180 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1181 #define del_XPVMG(p) my_safefree(p)
1183 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1184 #define del_XPVLV(p) my_safefree(p)
1186 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1187 #define del_XPVBM(p) my_safefree(p)
1191 #define new_XIV() (void*)new_xiv()
1192 #define del_XIV(p) del_xiv((XPVIV*) p)
1194 #define new_XNV() (void*)new_xnv()
1195 #define del_XNV(p) del_xnv((XPVNV*) p)
1197 #define new_XRV() (void*)new_xrv()
1198 #define del_XRV(p) del_xrv((XRV*) p)
1200 #define new_XPV() (void*)new_xpv()
1201 #define del_XPV(p) del_xpv((XPV *)p)
1203 #define new_XPVIV() (void*)new_xpviv()
1204 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1206 #define new_XPVNV() (void*)new_xpvnv()
1207 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1209 #define new_XPVCV() (void*)new_xpvcv()
1210 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1212 #define new_XPVAV() (void*)new_xpvav()
1213 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1215 #define new_XPVHV() (void*)new_xpvhv()
1216 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1218 #define new_XPVMG() (void*)new_xpvmg()
1219 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1221 #define new_XPVLV() (void*)new_xpvlv()
1222 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1224 #define new_XPVBM() (void*)new_xpvbm()
1225 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1229 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1230 #define del_XPVGV(p) my_safefree(p)
1232 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1233 #define del_XPVFM(p) my_safefree(p)
1235 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1236 #define del_XPVIO(p) my_safefree(p)
1239 =for apidoc sv_upgrade
1241 Upgrade an SV to a more complex form. Generally adds a new body type to the
1242 SV, then copies across as much information as possible from the old body.
1243 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1249 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1256 MAGIC* magic = NULL;
1259 if (mt != SVt_PV && SvIsCOW(sv)) {
1260 sv_force_normal_flags(sv, 0);
1263 if (SvTYPE(sv) == mt)
1267 (void)SvOOK_off(sv);
1269 switch (SvTYPE(sv)) {
1290 else if (mt < SVt_PVIV)
1307 pv = (char*)SvRV(sv);
1327 else if (mt == SVt_NV)
1338 del_XPVIV(SvANY(sv));
1348 del_XPVNV(SvANY(sv));
1356 magic = SvMAGIC(sv);
1357 stash = SvSTASH(sv);
1358 del_XPVMG(SvANY(sv));
1361 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1366 Perl_croak(aTHX_ "Can't upgrade to undef");
1368 SvANY(sv) = new_XIV();
1372 SvANY(sv) = new_XNV();
1376 SvANY(sv) = new_XRV();
1380 SvANY(sv) = new_XPV();
1386 SvANY(sv) = new_XPVIV();
1396 SvANY(sv) = new_XPVNV();
1404 SvANY(sv) = new_XPVMG();
1410 SvMAGIC(sv) = magic;
1411 SvSTASH(sv) = stash;
1414 SvANY(sv) = new_XPVLV();
1420 SvMAGIC(sv) = magic;
1421 SvSTASH(sv) = stash;
1428 SvANY(sv) = new_XPVAV();
1436 SvMAGIC(sv) = magic;
1437 SvSTASH(sv) = stash;
1443 SvANY(sv) = new_XPVHV();
1449 HvTOTALKEYS(sv) = 0;
1450 HvPLACEHOLDERS(sv) = 0;
1451 SvMAGIC(sv) = magic;
1452 SvSTASH(sv) = stash;
1459 SvANY(sv) = new_XPVCV();
1460 Zero(SvANY(sv), 1, XPVCV);
1466 SvMAGIC(sv) = magic;
1467 SvSTASH(sv) = stash;
1470 SvANY(sv) = new_XPVGV();
1476 SvMAGIC(sv) = magic;
1477 SvSTASH(sv) = stash;
1485 SvANY(sv) = new_XPVBM();
1491 SvMAGIC(sv) = magic;
1492 SvSTASH(sv) = stash;
1498 SvANY(sv) = new_XPVFM();
1499 Zero(SvANY(sv), 1, XPVFM);
1505 SvMAGIC(sv) = magic;
1506 SvSTASH(sv) = stash;
1509 SvANY(sv) = new_XPVIO();
1510 Zero(SvANY(sv), 1, XPVIO);
1516 SvMAGIC(sv) = magic;
1517 SvSTASH(sv) = stash;
1518 IoPAGE_LEN(sv) = 60;
1521 SvFLAGS(sv) &= ~SVTYPEMASK;
1527 =for apidoc sv_backoff
1529 Remove any string offset. You should normally use the C<SvOOK_off> macro
1536 Perl_sv_backoff(pTHX_ register SV *sv)
1540 char *s = SvPVX(sv);
1541 SvLEN(sv) += SvIVX(sv);
1542 SvPVX(sv) -= SvIVX(sv);
1544 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1546 SvFLAGS(sv) &= ~SVf_OOK;
1553 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1554 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1555 Use the C<SvGROW> wrapper instead.
1561 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1565 #ifdef HAS_64K_LIMIT
1566 if (newlen >= 0x10000) {
1567 PerlIO_printf(Perl_debug_log,
1568 "Allocation too large: %"UVxf"\n", (UV)newlen);
1571 #endif /* HAS_64K_LIMIT */
1574 if (SvTYPE(sv) < SVt_PV) {
1575 sv_upgrade(sv, SVt_PV);
1578 else if (SvOOK(sv)) { /* pv is offset? */
1581 if (newlen > SvLEN(sv))
1582 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1583 #ifdef HAS_64K_LIMIT
1584 if (newlen >= 0x10000)
1591 if (newlen > SvLEN(sv)) { /* need more room? */
1592 if (SvLEN(sv) && s) {
1594 STRLEN l = malloced_size((void*)SvPVX(sv));
1600 Renew(s,newlen,char);
1603 New(703, s, newlen, char);
1604 if (SvPVX(sv) && SvCUR(sv)) {
1605 Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1609 SvLEN_set(sv, newlen);
1615 =for apidoc sv_setiv
1617 Copies an integer into the given SV, upgrading first if necessary.
1618 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1624 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1626 SV_CHECK_THINKFIRST_COW_DROP(sv);
1627 switch (SvTYPE(sv)) {
1629 sv_upgrade(sv, SVt_IV);
1632 sv_upgrade(sv, SVt_PVNV);
1636 sv_upgrade(sv, SVt_PVIV);
1645 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1648 (void)SvIOK_only(sv); /* validate number */
1654 =for apidoc sv_setiv_mg
1656 Like C<sv_setiv>, but also handles 'set' magic.
1662 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1669 =for apidoc sv_setuv
1671 Copies an unsigned integer into the given SV, upgrading first if necessary.
1672 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1678 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1680 /* With these two if statements:
1681 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1684 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1686 If you wish to remove them, please benchmark to see what the effect is
1688 if (u <= (UV)IV_MAX) {
1689 sv_setiv(sv, (IV)u);
1698 =for apidoc sv_setuv_mg
1700 Like C<sv_setuv>, but also handles 'set' magic.
1706 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1708 /* With these two if statements:
1709 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1712 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1714 If you wish to remove them, please benchmark to see what the effect is
1716 if (u <= (UV)IV_MAX) {
1717 sv_setiv(sv, (IV)u);
1727 =for apidoc sv_setnv
1729 Copies a double into the given SV, upgrading first if necessary.
1730 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1736 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1738 SV_CHECK_THINKFIRST_COW_DROP(sv);
1739 switch (SvTYPE(sv)) {
1742 sv_upgrade(sv, SVt_NV);
1747 sv_upgrade(sv, SVt_PVNV);
1756 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1760 (void)SvNOK_only(sv); /* validate number */
1765 =for apidoc sv_setnv_mg
1767 Like C<sv_setnv>, but also handles 'set' magic.
1773 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1779 /* Print an "isn't numeric" warning, using a cleaned-up,
1780 * printable version of the offending string
1784 S_not_a_number(pTHX_ SV *sv)
1791 dsv = sv_2mortal(newSVpv("", 0));
1792 pv = sv_uni_display(dsv, sv, 10, 0);
1795 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1796 /* each *s can expand to 4 chars + "...\0",
1797 i.e. need room for 8 chars */
1800 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1802 if (ch & 128 && !isPRINT_LC(ch)) {
1811 else if (ch == '\r') {
1815 else if (ch == '\f') {
1819 else if (ch == '\\') {
1823 else if (ch == '\0') {
1827 else if (isPRINT_LC(ch))
1844 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1845 "Argument \"%s\" isn't numeric in %s", pv,
1848 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1849 "Argument \"%s\" isn't numeric", pv);
1853 =for apidoc looks_like_number
1855 Test if the content of an SV looks like a number (or is a number).
1856 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1857 non-numeric warning), even if your atof() doesn't grok them.
1863 Perl_looks_like_number(pTHX_ SV *sv)
1865 register char *sbegin;
1872 else if (SvPOKp(sv))
1873 sbegin = SvPV(sv, len);
1875 return 1; /* Historic. Wrong? */
1876 return grok_number(sbegin, len, NULL);
1879 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1880 until proven guilty, assume that things are not that bad... */
1885 As 64 bit platforms often have an NV that doesn't preserve all bits of
1886 an IV (an assumption perl has been based on to date) it becomes necessary
1887 to remove the assumption that the NV always carries enough precision to
1888 recreate the IV whenever needed, and that the NV is the canonical form.
1889 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1890 precision as a side effect of conversion (which would lead to insanity
1891 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1892 1) to distinguish between IV/UV/NV slots that have cached a valid
1893 conversion where precision was lost and IV/UV/NV slots that have a
1894 valid conversion which has lost no precision
1895 2) to ensure that if a numeric conversion to one form is requested that
1896 would lose precision, the precise conversion (or differently
1897 imprecise conversion) is also performed and cached, to prevent
1898 requests for different numeric formats on the same SV causing
1899 lossy conversion chains. (lossless conversion chains are perfectly
1904 SvIOKp is true if the IV slot contains a valid value
1905 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1906 SvNOKp is true if the NV slot contains a valid value
1907 SvNOK is true only if the NV value is accurate
1910 while converting from PV to NV, check to see if converting that NV to an
1911 IV(or UV) would lose accuracy over a direct conversion from PV to
1912 IV(or UV). If it would, cache both conversions, return NV, but mark
1913 SV as IOK NOKp (ie not NOK).
1915 While converting from PV to IV, check to see if converting that IV to an
1916 NV would lose accuracy over a direct conversion from PV to NV. If it
1917 would, cache both conversions, flag similarly.
1919 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1920 correctly because if IV & NV were set NV *always* overruled.
1921 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1922 changes - now IV and NV together means that the two are interchangeable:
1923 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1925 The benefit of this is that operations such as pp_add know that if
1926 SvIOK is true for both left and right operands, then integer addition
1927 can be used instead of floating point (for cases where the result won't
1928 overflow). Before, floating point was always used, which could lead to
1929 loss of precision compared with integer addition.
1931 * making IV and NV equal status should make maths accurate on 64 bit
1933 * may speed up maths somewhat if pp_add and friends start to use
1934 integers when possible instead of fp. (Hopefully the overhead in
1935 looking for SvIOK and checking for overflow will not outweigh the
1936 fp to integer speedup)
1937 * will slow down integer operations (callers of SvIV) on "inaccurate"
1938 values, as the change from SvIOK to SvIOKp will cause a call into
1939 sv_2iv each time rather than a macro access direct to the IV slot
1940 * should speed up number->string conversion on integers as IV is
1941 favoured when IV and NV are equally accurate
1943 ####################################################################
1944 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1945 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1946 On the other hand, SvUOK is true iff UV.
1947 ####################################################################
1949 Your mileage will vary depending your CPU's relative fp to integer
1953 #ifndef NV_PRESERVES_UV
1954 # define IS_NUMBER_UNDERFLOW_IV 1
1955 # define IS_NUMBER_UNDERFLOW_UV 2
1956 # define IS_NUMBER_IV_AND_UV 2
1957 # define IS_NUMBER_OVERFLOW_IV 4
1958 # define IS_NUMBER_OVERFLOW_UV 5
1960 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1962 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1964 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1966 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));
1967 if (SvNVX(sv) < (NV)IV_MIN) {
1968 (void)SvIOKp_on(sv);
1971 return IS_NUMBER_UNDERFLOW_IV;
1973 if (SvNVX(sv) > (NV)UV_MAX) {
1974 (void)SvIOKp_on(sv);
1978 return IS_NUMBER_OVERFLOW_UV;
1980 (void)SvIOKp_on(sv);
1982 /* Can't use strtol etc to convert this string. (See truth table in
1984 if (SvNVX(sv) <= (UV)IV_MAX) {
1985 SvIVX(sv) = I_V(SvNVX(sv));
1986 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1987 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1989 /* Integer is imprecise. NOK, IOKp */
1991 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1994 SvUVX(sv) = U_V(SvNVX(sv));
1995 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1996 if (SvUVX(sv) == UV_MAX) {
1997 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1998 possibly be preserved by NV. Hence, it must be overflow.
2000 return IS_NUMBER_OVERFLOW_UV;
2002 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2004 /* Integer is imprecise. NOK, IOKp */
2006 return IS_NUMBER_OVERFLOW_IV;
2008 #endif /* !NV_PRESERVES_UV*/
2013 Return the integer value of an SV, doing any necessary string conversion,
2014 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2020 Perl_sv_2iv(pTHX_ register SV *sv)
2024 if (SvGMAGICAL(sv)) {
2029 return I_V(SvNVX(sv));
2031 if (SvPOKp(sv) && SvLEN(sv))
2034 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2035 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2041 if (SvTHINKFIRST(sv)) {
2044 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2045 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2046 return SvIV(tmpstr);
2047 return PTR2IV(SvRV(sv));
2050 sv_force_normal_flags(sv, 0);
2052 if (SvREADONLY(sv) && !SvOK(sv)) {
2053 if (ckWARN(WARN_UNINITIALIZED))
2060 return (IV)(SvUVX(sv));
2067 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2068 * without also getting a cached IV/UV from it at the same time
2069 * (ie PV->NV conversion should detect loss of accuracy and cache
2070 * IV or UV at same time to avoid this. NWC */
2072 if (SvTYPE(sv) == SVt_NV)
2073 sv_upgrade(sv, SVt_PVNV);
2075 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2076 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2077 certainly cast into the IV range at IV_MAX, whereas the correct
2078 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2080 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2081 SvIVX(sv) = I_V(SvNVX(sv));
2082 if (SvNVX(sv) == (NV) SvIVX(sv)
2083 #ifndef NV_PRESERVES_UV
2084 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2085 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2086 /* Don't flag it as "accurately an integer" if the number
2087 came from a (by definition imprecise) NV operation, and
2088 we're outside the range of NV integer precision */
2091 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2092 DEBUG_c(PerlIO_printf(Perl_debug_log,
2093 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2099 /* IV not precise. No need to convert from PV, as NV
2100 conversion would already have cached IV if it detected
2101 that PV->IV would be better than PV->NV->IV
2102 flags already correct - don't set public IOK. */
2103 DEBUG_c(PerlIO_printf(Perl_debug_log,
2104 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2109 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2110 but the cast (NV)IV_MIN rounds to a the value less (more
2111 negative) than IV_MIN which happens to be equal to SvNVX ??
2112 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2113 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2114 (NV)UVX == NVX are both true, but the values differ. :-(
2115 Hopefully for 2s complement IV_MIN is something like
2116 0x8000000000000000 which will be exact. NWC */
2119 SvUVX(sv) = U_V(SvNVX(sv));
2121 (SvNVX(sv) == (NV) SvUVX(sv))
2122 #ifndef NV_PRESERVES_UV
2123 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2124 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2125 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2126 /* Don't flag it as "accurately an integer" if the number
2127 came from a (by definition imprecise) NV operation, and
2128 we're outside the range of NV integer precision */
2134 DEBUG_c(PerlIO_printf(Perl_debug_log,
2135 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2139 return (IV)SvUVX(sv);
2142 else if (SvPOKp(sv) && SvLEN(sv)) {
2144 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2145 /* We want to avoid a possible problem when we cache an IV which
2146 may be later translated to an NV, and the resulting NV is not
2147 the same as the direct translation of the initial string
2148 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2149 be careful to ensure that the value with the .456 is around if the
2150 NV value is requested in the future).
2152 This means that if we cache such an IV, we need to cache the
2153 NV as well. Moreover, we trade speed for space, and do not
2154 cache the NV if we are sure it's not needed.
2157 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2158 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2159 == IS_NUMBER_IN_UV) {
2160 /* It's definitely an integer, only upgrade to PVIV */
2161 if (SvTYPE(sv) < SVt_PVIV)
2162 sv_upgrade(sv, SVt_PVIV);
2164 } else if (SvTYPE(sv) < SVt_PVNV)
2165 sv_upgrade(sv, SVt_PVNV);
2167 /* If NV preserves UV then we only use the UV value if we know that
2168 we aren't going to call atof() below. If NVs don't preserve UVs
2169 then the value returned may have more precision than atof() will
2170 return, even though value isn't perfectly accurate. */
2171 if ((numtype & (IS_NUMBER_IN_UV
2172 #ifdef NV_PRESERVES_UV
2175 )) == IS_NUMBER_IN_UV) {
2176 /* This won't turn off the public IOK flag if it was set above */
2177 (void)SvIOKp_on(sv);
2179 if (!(numtype & IS_NUMBER_NEG)) {
2181 if (value <= (UV)IV_MAX) {
2182 SvIVX(sv) = (IV)value;
2188 /* 2s complement assumption */
2189 if (value <= (UV)IV_MIN) {
2190 SvIVX(sv) = -(IV)value;
2192 /* Too negative for an IV. This is a double upgrade, but
2193 I'm assuming it will be rare. */
2194 if (SvTYPE(sv) < SVt_PVNV)
2195 sv_upgrade(sv, SVt_PVNV);
2199 SvNVX(sv) = -(NV)value;
2204 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2205 will be in the previous block to set the IV slot, and the next
2206 block to set the NV slot. So no else here. */
2208 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2209 != IS_NUMBER_IN_UV) {
2210 /* It wasn't an (integer that doesn't overflow the UV). */
2211 SvNVX(sv) = Atof(SvPVX(sv));
2213 if (! numtype && ckWARN(WARN_NUMERIC))
2216 #if defined(USE_LONG_DOUBLE)
2217 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2218 PTR2UV(sv), SvNVX(sv)));
2220 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2221 PTR2UV(sv), SvNVX(sv)));
2225 #ifdef NV_PRESERVES_UV
2226 (void)SvIOKp_on(sv);
2228 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2229 SvIVX(sv) = I_V(SvNVX(sv));
2230 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2233 /* Integer is imprecise. NOK, IOKp */
2235 /* UV will not work better than IV */
2237 if (SvNVX(sv) > (NV)UV_MAX) {
2239 /* Integer is inaccurate. NOK, IOKp, is UV */
2243 SvUVX(sv) = U_V(SvNVX(sv));
2244 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2245 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2249 /* Integer is imprecise. NOK, IOKp, is UV */
2255 #else /* NV_PRESERVES_UV */
2256 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2257 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2258 /* The IV slot will have been set from value returned by
2259 grok_number above. The NV slot has just been set using
2262 assert (SvIOKp(sv));
2264 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2265 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2266 /* Small enough to preserve all bits. */
2267 (void)SvIOKp_on(sv);
2269 SvIVX(sv) = I_V(SvNVX(sv));
2270 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2272 /* Assumption: first non-preserved integer is < IV_MAX,
2273 this NV is in the preserved range, therefore: */
2274 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2276 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);
2280 0 0 already failed to read UV.
2281 0 1 already failed to read UV.
2282 1 0 you won't get here in this case. IV/UV
2283 slot set, public IOK, Atof() unneeded.
2284 1 1 already read UV.
2285 so there's no point in sv_2iuv_non_preserve() attempting
2286 to use atol, strtol, strtoul etc. */
2287 if (sv_2iuv_non_preserve (sv, numtype)
2288 >= IS_NUMBER_OVERFLOW_IV)
2292 #endif /* NV_PRESERVES_UV */
2295 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2297 if (SvTYPE(sv) < SVt_IV)
2298 /* Typically the caller expects that sv_any is not NULL now. */
2299 sv_upgrade(sv, SVt_IV);
2302 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2303 PTR2UV(sv),SvIVX(sv)));
2304 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2310 Return the unsigned integer value of an SV, doing any necessary string
2311 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2318 Perl_sv_2uv(pTHX_ register SV *sv)
2322 if (SvGMAGICAL(sv)) {
2327 return U_V(SvNVX(sv));
2328 if (SvPOKp(sv) && SvLEN(sv))
2331 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2332 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2338 if (SvTHINKFIRST(sv)) {
2341 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2342 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2343 return SvUV(tmpstr);
2344 return PTR2UV(SvRV(sv));
2347 sv_force_normal_flags(sv, 0);
2349 if (SvREADONLY(sv) && !SvOK(sv)) {
2350 if (ckWARN(WARN_UNINITIALIZED))
2360 return (UV)SvIVX(sv);
2364 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2365 * without also getting a cached IV/UV from it at the same time
2366 * (ie PV->NV conversion should detect loss of accuracy and cache
2367 * IV or UV at same time to avoid this. */
2368 /* IV-over-UV optimisation - choose to cache IV if possible */
2370 if (SvTYPE(sv) == SVt_NV)
2371 sv_upgrade(sv, SVt_PVNV);
2373 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2374 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2375 SvIVX(sv) = I_V(SvNVX(sv));
2376 if (SvNVX(sv) == (NV) SvIVX(sv)
2377 #ifndef NV_PRESERVES_UV
2378 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2379 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2380 /* Don't flag it as "accurately an integer" if the number
2381 came from a (by definition imprecise) NV operation, and
2382 we're outside the range of NV integer precision */
2385 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2386 DEBUG_c(PerlIO_printf(Perl_debug_log,
2387 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2393 /* IV not precise. No need to convert from PV, as NV
2394 conversion would already have cached IV if it detected
2395 that PV->IV would be better than PV->NV->IV
2396 flags already correct - don't set public IOK. */
2397 DEBUG_c(PerlIO_printf(Perl_debug_log,
2398 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2403 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2404 but the cast (NV)IV_MIN rounds to a the value less (more
2405 negative) than IV_MIN which happens to be equal to SvNVX ??
2406 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2407 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2408 (NV)UVX == NVX are both true, but the values differ. :-(
2409 Hopefully for 2s complement IV_MIN is something like
2410 0x8000000000000000 which will be exact. NWC */
2413 SvUVX(sv) = U_V(SvNVX(sv));
2415 (SvNVX(sv) == (NV) SvUVX(sv))
2416 #ifndef NV_PRESERVES_UV
2417 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2418 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2419 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2420 /* Don't flag it as "accurately an integer" if the number
2421 came from a (by definition imprecise) NV operation, and
2422 we're outside the range of NV integer precision */
2427 DEBUG_c(PerlIO_printf(Perl_debug_log,
2428 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2434 else if (SvPOKp(sv) && SvLEN(sv)) {
2436 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2438 /* We want to avoid a possible problem when we cache a UV which
2439 may be later translated to an NV, and the resulting NV is not
2440 the translation of the initial data.
2442 This means that if we cache such a UV, we need to cache the
2443 NV as well. Moreover, we trade speed for space, and do not
2444 cache the NV if not needed.
2447 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2448 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2449 == IS_NUMBER_IN_UV) {
2450 /* It's definitely an integer, only upgrade to PVIV */
2451 if (SvTYPE(sv) < SVt_PVIV)
2452 sv_upgrade(sv, SVt_PVIV);
2454 } else if (SvTYPE(sv) < SVt_PVNV)
2455 sv_upgrade(sv, SVt_PVNV);
2457 /* If NV preserves UV then we only use the UV value if we know that
2458 we aren't going to call atof() below. If NVs don't preserve UVs
2459 then the value returned may have more precision than atof() will
2460 return, even though it isn't accurate. */
2461 if ((numtype & (IS_NUMBER_IN_UV
2462 #ifdef NV_PRESERVES_UV
2465 )) == IS_NUMBER_IN_UV) {
2466 /* This won't turn off the public IOK flag if it was set above */
2467 (void)SvIOKp_on(sv);
2469 if (!(numtype & IS_NUMBER_NEG)) {
2471 if (value <= (UV)IV_MAX) {
2472 SvIVX(sv) = (IV)value;
2474 /* it didn't overflow, and it was positive. */
2479 /* 2s complement assumption */
2480 if (value <= (UV)IV_MIN) {
2481 SvIVX(sv) = -(IV)value;
2483 /* Too negative for an IV. This is a double upgrade, but
2484 I'm assuming it will be rare. */
2485 if (SvTYPE(sv) < SVt_PVNV)
2486 sv_upgrade(sv, SVt_PVNV);
2490 SvNVX(sv) = -(NV)value;
2496 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2497 != IS_NUMBER_IN_UV) {
2498 /* It wasn't an integer, or it overflowed the UV. */
2499 SvNVX(sv) = Atof(SvPVX(sv));
2501 if (! numtype && ckWARN(WARN_NUMERIC))
2504 #if defined(USE_LONG_DOUBLE)
2505 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2506 PTR2UV(sv), SvNVX(sv)));
2508 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2509 PTR2UV(sv), SvNVX(sv)));
2512 #ifdef NV_PRESERVES_UV
2513 (void)SvIOKp_on(sv);
2515 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2516 SvIVX(sv) = I_V(SvNVX(sv));
2517 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2520 /* Integer is imprecise. NOK, IOKp */
2522 /* UV will not work better than IV */
2524 if (SvNVX(sv) > (NV)UV_MAX) {
2526 /* Integer is inaccurate. NOK, IOKp, is UV */
2530 SvUVX(sv) = U_V(SvNVX(sv));
2531 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2532 NV preservse UV so can do correct comparison. */
2533 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2537 /* Integer is imprecise. NOK, IOKp, is UV */
2542 #else /* NV_PRESERVES_UV */
2543 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2544 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2545 /* The UV slot will have been set from value returned by
2546 grok_number above. The NV slot has just been set using
2549 assert (SvIOKp(sv));
2551 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2552 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2553 /* Small enough to preserve all bits. */
2554 (void)SvIOKp_on(sv);
2556 SvIVX(sv) = I_V(SvNVX(sv));
2557 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2559 /* Assumption: first non-preserved integer is < IV_MAX,
2560 this NV is in the preserved range, therefore: */
2561 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2563 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);
2566 sv_2iuv_non_preserve (sv, numtype);
2568 #endif /* NV_PRESERVES_UV */
2572 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2573 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2576 if (SvTYPE(sv) < SVt_IV)
2577 /* Typically the caller expects that sv_any is not NULL now. */
2578 sv_upgrade(sv, SVt_IV);
2582 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2583 PTR2UV(sv),SvUVX(sv)));
2584 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2590 Return the num value of an SV, doing any necessary string or integer
2591 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2598 Perl_sv_2nv(pTHX_ register SV *sv)
2602 if (SvGMAGICAL(sv)) {
2606 if (SvPOKp(sv) && SvLEN(sv)) {
2607 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2608 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2610 return Atof(SvPVX(sv));
2614 return (NV)SvUVX(sv);
2616 return (NV)SvIVX(sv);
2619 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2620 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2626 if (SvTHINKFIRST(sv)) {
2629 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2630 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2631 return SvNV(tmpstr);
2632 return PTR2NV(SvRV(sv));
2635 sv_force_normal_flags(sv, 0);
2637 if (SvREADONLY(sv) && !SvOK(sv)) {
2638 if (ckWARN(WARN_UNINITIALIZED))
2643 if (SvTYPE(sv) < SVt_NV) {
2644 if (SvTYPE(sv) == SVt_IV)
2645 sv_upgrade(sv, SVt_PVNV);
2647 sv_upgrade(sv, SVt_NV);
2648 #ifdef USE_LONG_DOUBLE
2650 STORE_NUMERIC_LOCAL_SET_STANDARD();
2651 PerlIO_printf(Perl_debug_log,
2652 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2653 PTR2UV(sv), SvNVX(sv));
2654 RESTORE_NUMERIC_LOCAL();
2658 STORE_NUMERIC_LOCAL_SET_STANDARD();
2659 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2660 PTR2UV(sv), SvNVX(sv));
2661 RESTORE_NUMERIC_LOCAL();
2665 else if (SvTYPE(sv) < SVt_PVNV)
2666 sv_upgrade(sv, SVt_PVNV);
2671 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2672 #ifdef NV_PRESERVES_UV
2675 /* Only set the public NV OK flag if this NV preserves the IV */
2676 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2677 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2678 : (SvIVX(sv) == I_V(SvNVX(sv))))
2684 else if (SvPOKp(sv) && SvLEN(sv)) {
2686 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2687 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2689 #ifdef NV_PRESERVES_UV
2690 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2691 == IS_NUMBER_IN_UV) {
2692 /* It's definitely an integer */
2693 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2695 SvNVX(sv) = Atof(SvPVX(sv));
2698 SvNVX(sv) = Atof(SvPVX(sv));
2699 /* Only set the public NV OK flag if this NV preserves the value in
2700 the PV at least as well as an IV/UV would.
2701 Not sure how to do this 100% reliably. */
2702 /* if that shift count is out of range then Configure's test is
2703 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2705 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2706 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2707 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2708 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2709 /* Can't use strtol etc to convert this string, so don't try.
2710 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2713 /* value has been set. It may not be precise. */
2714 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2715 /* 2s complement assumption for (UV)IV_MIN */
2716 SvNOK_on(sv); /* Integer is too negative. */
2721 if (numtype & IS_NUMBER_NEG) {
2722 SvIVX(sv) = -(IV)value;
2723 } else if (value <= (UV)IV_MAX) {
2724 SvIVX(sv) = (IV)value;
2730 if (numtype & IS_NUMBER_NOT_INT) {
2731 /* I believe that even if the original PV had decimals,
2732 they are lost beyond the limit of the FP precision.
2733 However, neither is canonical, so both only get p
2734 flags. NWC, 2000/11/25 */
2735 /* Both already have p flags, so do nothing */
2738 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2739 if (SvIVX(sv) == I_V(nv)) {
2744 /* It had no "." so it must be integer. */
2747 /* between IV_MAX and NV(UV_MAX).
2748 Could be slightly > UV_MAX */
2750 if (numtype & IS_NUMBER_NOT_INT) {
2751 /* UV and NV both imprecise. */
2753 UV nv_as_uv = U_V(nv);
2755 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2766 #endif /* NV_PRESERVES_UV */
2769 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2771 if (SvTYPE(sv) < SVt_NV)
2772 /* Typically the caller expects that sv_any is not NULL now. */
2773 /* XXX Ilya implies that this is a bug in callers that assume this
2774 and ideally should be fixed. */
2775 sv_upgrade(sv, SVt_NV);
2778 #if defined(USE_LONG_DOUBLE)
2780 STORE_NUMERIC_LOCAL_SET_STANDARD();
2781 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2782 PTR2UV(sv), SvNVX(sv));
2783 RESTORE_NUMERIC_LOCAL();
2787 STORE_NUMERIC_LOCAL_SET_STANDARD();
2788 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2789 PTR2UV(sv), SvNVX(sv));
2790 RESTORE_NUMERIC_LOCAL();
2796 /* asIV(): extract an integer from the string value of an SV.
2797 * Caller must validate PVX */
2800 S_asIV(pTHX_ SV *sv)
2803 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2805 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2806 == IS_NUMBER_IN_UV) {
2807 /* It's definitely an integer */
2808 if (numtype & IS_NUMBER_NEG) {
2809 if (value < (UV)IV_MIN)
2812 if (value < (UV)IV_MAX)
2817 if (ckWARN(WARN_NUMERIC))
2820 return I_V(Atof(SvPVX(sv)));
2823 /* asUV(): extract an unsigned integer from the string value of an SV
2824 * Caller must validate PVX */
2827 S_asUV(pTHX_ SV *sv)
2830 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2832 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2833 == IS_NUMBER_IN_UV) {
2834 /* It's definitely an integer */
2835 if (!(numtype & IS_NUMBER_NEG))
2839 if (ckWARN(WARN_NUMERIC))
2842 return U_V(Atof(SvPVX(sv)));
2846 =for apidoc sv_2pv_nolen
2848 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2849 use the macro wrapper C<SvPV_nolen(sv)> instead.
2854 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2857 return sv_2pv(sv, &n_a);
2860 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2861 * UV as a string towards the end of buf, and return pointers to start and
2864 * We assume that buf is at least TYPE_CHARS(UV) long.
2868 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2870 char *ptr = buf + TYPE_CHARS(UV);
2884 *--ptr = '0' + (char)(uv % 10);
2892 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2893 * this function provided for binary compatibility only
2897 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2899 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2903 =for apidoc sv_2pv_flags
2905 Returns a pointer to the string value of an SV, and sets *lp to its length.
2906 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2908 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2909 usually end up here too.
2915 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2920 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2921 char *tmpbuf = tbuf;
2927 if (SvGMAGICAL(sv)) {
2928 if (flags & SV_GMAGIC)
2936 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2938 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2943 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2948 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2949 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2956 if (SvTHINKFIRST(sv)) {
2959 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2960 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2961 char *pv = SvPV(tmpstr, *lp);
2975 switch (SvTYPE(sv)) {
2977 if ( ((SvFLAGS(sv) &
2978 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2979 == (SVs_OBJECT|SVs_SMG))
2980 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2981 regexp *re = (regexp *)mg->mg_obj;
2984 char *fptr = "msix";
2989 char need_newline = 0;
2990 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
2992 while((ch = *fptr++)) {
2994 reflags[left++] = ch;
2997 reflags[right--] = ch;
3002 reflags[left] = '-';
3006 mg->mg_len = re->prelen + 4 + left;
3008 * If /x was used, we have to worry about a regex
3009 * ending with a comment later being embedded
3010 * within another regex. If so, we don't want this
3011 * regex's "commentization" to leak out to the
3012 * right part of the enclosing regex, we must cap
3013 * it with a newline.
3015 * So, if /x was used, we scan backwards from the
3016 * end of the regex. If we find a '#' before we
3017 * find a newline, we need to add a newline
3018 * ourself. If we find a '\n' first (or if we
3019 * don't find '#' or '\n'), we don't need to add
3020 * anything. -jfriedl
3022 if (PMf_EXTENDED & re->reganch)
3024 char *endptr = re->precomp + re->prelen;
3025 while (endptr >= re->precomp)
3027 char c = *(endptr--);
3029 break; /* don't need another */
3031 /* we end while in a comment, so we
3033 mg->mg_len++; /* save space for it */
3034 need_newline = 1; /* note to add it */
3040 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3041 Copy("(?", mg->mg_ptr, 2, char);
3042 Copy(reflags, mg->mg_ptr+2, left, char);
3043 Copy(":", mg->mg_ptr+left+2, 1, char);
3044 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3046 mg->mg_ptr[mg->mg_len - 2] = '\n';
3047 mg->mg_ptr[mg->mg_len - 1] = ')';
3048 mg->mg_ptr[mg->mg_len] = 0;
3050 PL_reginterp_cnt += re->program[0].next_off;
3052 if (re->reganch & ROPT_UTF8)
3067 case SVt_PVBM: if (SvROK(sv))
3070 s = "SCALAR"; break;
3071 case SVt_PVLV: s = "LVALUE"; break;
3072 case SVt_PVAV: s = "ARRAY"; break;
3073 case SVt_PVHV: s = "HASH"; break;
3074 case SVt_PVCV: s = "CODE"; break;
3075 case SVt_PVGV: s = "GLOB"; break;
3076 case SVt_PVFM: s = "FORMAT"; break;
3077 case SVt_PVIO: s = "IO"; break;
3078 default: s = "UNKNOWN"; break;
3082 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3085 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3091 if (SvREADONLY(sv) && !SvOK(sv)) {
3092 if (ckWARN(WARN_UNINITIALIZED))
3098 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3099 /* I'm assuming that if both IV and NV are equally valid then
3100 converting the IV is going to be more efficient */
3101 U32 isIOK = SvIOK(sv);
3102 U32 isUIOK = SvIsUV(sv);
3103 char buf[TYPE_CHARS(UV)];
3106 if (SvTYPE(sv) < SVt_PVIV)
3107 sv_upgrade(sv, SVt_PVIV);
3109 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3111 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3112 SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */
3113 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3114 SvCUR_set(sv, ebuf - ptr);
3124 else if (SvNOKp(sv)) {
3125 if (SvTYPE(sv) < SVt_PVNV)
3126 sv_upgrade(sv, SVt_PVNV);
3127 /* The +20 is pure guesswork. Configure test needed. --jhi */
3128 SvGROW(sv, NV_DIG + 20);
3130 olderrno = errno; /* some Xenix systems wipe out errno here */
3132 if (SvNVX(sv) == 0.0)
3133 (void)strcpy(s,"0");
3137 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3140 #ifdef FIXNEGATIVEZERO
3141 if (*s == '-' && s[1] == '0' && !s[2])
3151 if (ckWARN(WARN_UNINITIALIZED)
3152 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3155 if (SvTYPE(sv) < SVt_PV)
3156 /* Typically the caller expects that sv_any is not NULL now. */
3157 sv_upgrade(sv, SVt_PV);
3160 *lp = s - SvPVX(sv);
3163 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3164 PTR2UV(sv),SvPVX(sv)));
3168 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3169 /* Sneaky stuff here */
3173 tsv = newSVpv(tmpbuf, 0);
3189 len = strlen(tmpbuf);
3191 #ifdef FIXNEGATIVEZERO
3192 if (len == 2 && t[0] == '-' && t[1] == '0') {
3197 (void)SvUPGRADE(sv, SVt_PV);
3199 s = SvGROW(sv, len + 1);
3208 =for apidoc sv_copypv
3210 Copies a stringified representation of the source SV into the
3211 destination SV. Automatically performs any necessary mg_get and
3212 coercion of numeric values into strings. Guaranteed to preserve
3213 UTF-8 flag even from overloaded objects. Similar in nature to
3214 sv_2pv[_flags] but operates directly on an SV instead of just the
3215 string. Mostly uses sv_2pv_flags to do its work, except when that
3216 would lose the UTF-8'ness of the PV.
3222 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3227 sv_setpvn(dsv,s,len);
3235 =for apidoc sv_2pvbyte_nolen
3237 Return a pointer to the byte-encoded representation of the SV.
3238 May cause the SV to be downgraded from UTF8 as a side-effect.
3240 Usually accessed via the C<SvPVbyte_nolen> macro.
3246 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3249 return sv_2pvbyte(sv, &n_a);
3253 =for apidoc sv_2pvbyte
3255 Return a pointer to the byte-encoded representation of the SV, and set *lp
3256 to its length. May cause the SV to be downgraded from UTF8 as a
3259 Usually accessed via the C<SvPVbyte> macro.
3265 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3267 sv_utf8_downgrade(sv,0);
3268 return SvPV(sv,*lp);
3272 =for apidoc sv_2pvutf8_nolen
3274 Return a pointer to the UTF8-encoded representation of the SV.
3275 May cause the SV to be upgraded to UTF8 as a side-effect.
3277 Usually accessed via the C<SvPVutf8_nolen> macro.
3283 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3286 return sv_2pvutf8(sv, &n_a);
3290 =for apidoc sv_2pvutf8
3292 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3293 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3295 Usually accessed via the C<SvPVutf8> macro.
3301 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3303 sv_utf8_upgrade(sv);
3304 return SvPV(sv,*lp);
3308 =for apidoc sv_2bool
3310 This function is only called on magical items, and is only used by
3311 sv_true() or its macro equivalent.
3317 Perl_sv_2bool(pTHX_ register SV *sv)
3326 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3327 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3328 return (bool)SvTRUE(tmpsv);
3329 return SvRV(sv) != 0;
3332 register XPV* Xpvtmp;
3333 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3334 (*Xpvtmp->xpv_pv > '0' ||
3335 Xpvtmp->xpv_cur > 1 ||
3336 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3343 return SvIVX(sv) != 0;
3346 return SvNVX(sv) != 0.0;
3353 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3354 * this function provided for binary compatibility only
3359 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3361 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3365 =for apidoc sv_utf8_upgrade
3367 Convert the PV of an SV to its UTF8-encoded form.
3368 Forces the SV to string form if it is not already.
3369 Always sets the SvUTF8 flag to avoid future validity checks even
3370 if all the bytes have hibit clear.
3372 This is not as a general purpose byte encoding to Unicode interface:
3373 use the Encode extension for that.
3375 =for apidoc sv_utf8_upgrade_flags
3377 Convert the PV of an SV to its UTF8-encoded form.
3378 Forces the SV to string form if it is not already.
3379 Always sets the SvUTF8 flag to avoid future validity checks even
3380 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3381 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3382 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3384 This is not as a general purpose byte encoding to Unicode interface:
3385 use the Encode extension for that.
3391 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3401 (void) sv_2pv_flags(sv,&len, flags);
3410 sv_force_normal_flags(sv, 0);
3413 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3414 sv_recode_to_utf8(sv, PL_encoding);
3415 else { /* Assume Latin-1/EBCDIC */
3416 /* This function could be much more efficient if we
3417 * had a FLAG in SVs to signal if there are any hibit
3418 * chars in the PV. Given that there isn't such a flag
3419 * make the loop as fast as possible. */
3420 s = (U8 *) SvPVX(sv);
3421 e = (U8 *) SvEND(sv);
3425 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3431 len = SvCUR(sv) + 1; /* Plus the \0 */
3432 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3433 SvCUR(sv) = len - 1;
3435 Safefree(s); /* No longer using what was there before. */
3436 SvLEN(sv) = len; /* No longer know the real size. */
3438 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3445 =for apidoc sv_utf8_downgrade
3447 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3448 This may not be possible if the PV contains non-byte encoding characters;
3449 if this is the case, either returns false or, if C<fail_ok> is not
3452 This is not as a general purpose Unicode to byte encoding interface:
3453 use the Encode extension for that.
3459 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3461 if (SvPOK(sv) && SvUTF8(sv)) {
3467 sv_force_normal_flags(sv, 0);
3469 s = (U8 *) SvPV(sv, len);
3470 if (!utf8_to_bytes(s, &len)) {
3475 Perl_croak(aTHX_ "Wide character in %s",
3478 Perl_croak(aTHX_ "Wide character");
3489 =for apidoc sv_utf8_encode
3491 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3492 flag so that it looks like octets again. Used as a building block
3493 for encode_utf8 in Encode.xs
3499 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3501 (void) sv_utf8_upgrade(sv);
3506 =for apidoc sv_utf8_decode
3508 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3509 turn off SvUTF8 if needed so that we see characters. Used as a building block
3510 for decode_utf8 in Encode.xs
3516 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3522 /* The octets may have got themselves encoded - get them back as
3525 if (!sv_utf8_downgrade(sv, TRUE))
3528 /* it is actually just a matter of turning the utf8 flag on, but
3529 * we want to make sure everything inside is valid utf8 first.
3531 c = (U8 *) SvPVX(sv);
3532 if (!is_utf8_string(c, SvCUR(sv)+1))
3534 e = (U8 *) SvEND(sv);
3537 if (!UTF8_IS_INVARIANT(ch)) {
3546 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3547 * this function provided for binary compatibility only
3551 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3553 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3557 =for apidoc sv_setsv
3559 Copies the contents of the source SV C<ssv> into the destination SV
3560 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3561 function if the source SV needs to be reused. Does not handle 'set' magic.
3562 Loosely speaking, it performs a copy-by-value, obliterating any previous
3563 content of the destination.
3565 You probably want to use one of the assortment of wrappers, such as
3566 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3567 C<SvSetMagicSV_nosteal>.
3569 =for apidoc sv_setsv_flags
3571 Copies the contents of the source SV C<ssv> into the destination SV
3572 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3573 function if the source SV needs to be reused. Does not handle 'set' magic.
3574 Loosely speaking, it performs a copy-by-value, obliterating any previous
3575 content of the destination.
3576 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3577 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3578 implemented in terms of this function.
3580 You probably want to use one of the assortment of wrappers, such as
3581 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3582 C<SvSetMagicSV_nosteal>.
3584 This is the primary function for copying scalars, and most other
3585 copy-ish functions and macros use this underneath.
3591 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3593 register U32 sflags;
3599 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3601 sstr = &PL_sv_undef;
3602 stype = SvTYPE(sstr);
3603 dtype = SvTYPE(dstr);
3608 /* need to nuke the magic */
3610 SvRMAGICAL_off(dstr);
3613 /* There's a lot of redundancy below but we're going for speed here */
3618 if (dtype != SVt_PVGV) {
3619 (void)SvOK_off(dstr);
3627 sv_upgrade(dstr, SVt_IV);
3630 sv_upgrade(dstr, SVt_PVNV);
3634 sv_upgrade(dstr, SVt_PVIV);
3637 (void)SvIOK_only(dstr);
3638 SvIVX(dstr) = SvIVX(sstr);
3641 if (SvTAINTED(sstr))
3652 sv_upgrade(dstr, SVt_NV);
3657 sv_upgrade(dstr, SVt_PVNV);
3660 SvNVX(dstr) = SvNVX(sstr);
3661 (void)SvNOK_only(dstr);
3662 if (SvTAINTED(sstr))
3670 sv_upgrade(dstr, SVt_RV);
3671 else if (dtype == SVt_PVGV &&
3672 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3675 if (GvIMPORTED(dstr) != GVf_IMPORTED
3676 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3678 GvIMPORTED_on(dstr);
3689 sv_upgrade(dstr, SVt_PV);
3692 if (dtype < SVt_PVIV)
3693 sv_upgrade(dstr, SVt_PVIV);
3696 if (dtype < SVt_PVNV)
3697 sv_upgrade(dstr, SVt_PVNV);
3704 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3707 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3711 if (dtype <= SVt_PVGV) {
3713 if (dtype != SVt_PVGV) {
3714 char *name = GvNAME(sstr);
3715 STRLEN len = GvNAMELEN(sstr);
3716 sv_upgrade(dstr, SVt_PVGV);
3717 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3718 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3719 GvNAME(dstr) = savepvn(name, len);
3720 GvNAMELEN(dstr) = len;
3721 SvFAKE_on(dstr); /* can coerce to non-glob */
3723 /* ahem, death to those who redefine active sort subs */
3724 else if (PL_curstackinfo->si_type == PERLSI_SORT
3725 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3726 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3729 #ifdef GV_UNIQUE_CHECK
3730 if (GvUNIQUE((GV*)dstr)) {
3731 Perl_croak(aTHX_ PL_no_modify);
3735 (void)SvOK_off(dstr);
3736 GvINTRO_off(dstr); /* one-shot flag */
3738 GvGP(dstr) = gp_ref(GvGP(sstr));
3739 if (SvTAINTED(sstr))
3741 if (GvIMPORTED(dstr) != GVf_IMPORTED
3742 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3744 GvIMPORTED_on(dstr);
3752 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3754 if ((int)SvTYPE(sstr) != stype) {
3755 stype = SvTYPE(sstr);
3756 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3760 if (stype == SVt_PVLV)
3761 (void)SvUPGRADE(dstr, SVt_PVNV);
3763 (void)SvUPGRADE(dstr, (U32)stype);
3766 sflags = SvFLAGS(sstr);
3768 if (sflags & SVf_ROK) {
3769 if (dtype >= SVt_PV) {
3770 if (dtype == SVt_PVGV) {
3771 SV *sref = SvREFCNT_inc(SvRV(sstr));
3773 int intro = GvINTRO(dstr);
3775 #ifdef GV_UNIQUE_CHECK
3776 if (GvUNIQUE((GV*)dstr)) {
3777 Perl_croak(aTHX_ PL_no_modify);
3782 GvINTRO_off(dstr); /* one-shot flag */
3783 GvLINE(dstr) = CopLINE(PL_curcop);
3784 GvEGV(dstr) = (GV*)dstr;
3787 switch (SvTYPE(sref)) {
3790 SAVEGENERICSV(GvAV(dstr));
3792 dref = (SV*)GvAV(dstr);
3793 GvAV(dstr) = (AV*)sref;
3794 if (!GvIMPORTED_AV(dstr)
3795 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3797 GvIMPORTED_AV_on(dstr);
3802 SAVEGENERICSV(GvHV(dstr));
3804 dref = (SV*)GvHV(dstr);
3805 GvHV(dstr) = (HV*)sref;
3806 if (!GvIMPORTED_HV(dstr)
3807 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3809 GvIMPORTED_HV_on(dstr);
3814 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3815 SvREFCNT_dec(GvCV(dstr));
3816 GvCV(dstr) = Nullcv;
3817 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3818 PL_sub_generation++;
3820 SAVEGENERICSV(GvCV(dstr));
3823 dref = (SV*)GvCV(dstr);
3824 if (GvCV(dstr) != (CV*)sref) {
3825 CV* cv = GvCV(dstr);
3827 if (!GvCVGEN((GV*)dstr) &&
3828 (CvROOT(cv) || CvXSUB(cv)))
3830 /* ahem, death to those who redefine
3831 * active sort subs */
3832 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3833 PL_sortcop == CvSTART(cv))
3835 "Can't redefine active sort subroutine %s",
3836 GvENAME((GV*)dstr));
3837 /* Redefining a sub - warning is mandatory if
3838 it was a const and its value changed. */
3839 if (ckWARN(WARN_REDEFINE)
3841 && (!CvCONST((CV*)sref)
3842 || sv_cmp(cv_const_sv(cv),
3843 cv_const_sv((CV*)sref)))))
3845 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3847 ? "Constant subroutine %s::%s redefined"
3848 : "Subroutine %s::%s redefined",
3849 HvNAME(GvSTASH((GV*)dstr)),
3850 GvENAME((GV*)dstr));
3854 cv_ckproto(cv, (GV*)dstr,
3855 SvPOK(sref) ? SvPVX(sref) : Nullch);
3857 GvCV(dstr) = (CV*)sref;
3858 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3859 GvASSUMECV_on(dstr);
3860 PL_sub_generation++;
3862 if (!GvIMPORTED_CV(dstr)
3863 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3865 GvIMPORTED_CV_on(dstr);
3870 SAVEGENERICSV(GvIOp(dstr));
3872 dref = (SV*)GvIOp(dstr);
3873 GvIOp(dstr) = (IO*)sref;
3877 SAVEGENERICSV(GvFORM(dstr));
3879 dref = (SV*)GvFORM(dstr);
3880 GvFORM(dstr) = (CV*)sref;
3884 SAVEGENERICSV(GvSV(dstr));
3886 dref = (SV*)GvSV(dstr);
3888 if (!GvIMPORTED_SV(dstr)
3889 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3891 GvIMPORTED_SV_on(dstr);
3897 if (SvTAINTED(sstr))
3902 (void)SvOOK_off(dstr); /* backoff */
3904 Safefree(SvPVX(dstr));
3905 SvLEN(dstr)=SvCUR(dstr)=0;
3908 (void)SvOK_off(dstr);
3909 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3911 if (sflags & SVp_NOK) {
3913 /* Only set the public OK flag if the source has public OK. */
3914 if (sflags & SVf_NOK)
3915 SvFLAGS(dstr) |= SVf_NOK;
3916 SvNVX(dstr) = SvNVX(sstr);
3918 if (sflags & SVp_IOK) {
3919 (void)SvIOKp_on(dstr);
3920 if (sflags & SVf_IOK)
3921 SvFLAGS(dstr) |= SVf_IOK;
3922 if (sflags & SVf_IVisUV)
3924 SvIVX(dstr) = SvIVX(sstr);
3926 if (SvAMAGIC(sstr)) {
3930 else if (sflags & SVp_POK) {
3934 * Check to see if we can just swipe the string. If so, it's a
3935 * possible small lose on short strings, but a big win on long ones.
3936 * It might even be a win on short strings if SvPVX(dstr)
3937 * has to be allocated and SvPVX(sstr) has to be freed.
3941 #ifdef PERL_COPY_ON_WRITE
3942 (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3946 (sflags & SVs_TEMP) && /* slated for free anyway? */
3947 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3948 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3949 SvLEN(sstr) && /* and really is a string */
3950 /* and won't be needed again, potentially */
3951 !(PL_op && PL_op->op_type == OP_AASSIGN))
3952 #ifdef PERL_COPY_ON_WRITE
3953 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
3954 && SvTYPE(sstr) >= SVt_PVIV)
3957 /* Failed the swipe test, and it's not a shared hash key either.
3958 Have to copy the string. */
3959 STRLEN len = SvCUR(sstr);
3960 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3961 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3962 SvCUR_set(dstr, len);
3963 *SvEND(dstr) = '\0';
3964 (void)SvPOK_only(dstr);
3966 /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
3968 #ifdef PERL_COPY_ON_WRITE
3969 /* Either it's a shared hash key, or it's suitable for
3970 copy-on-write or we can swipe the string. */
3972 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
3977 /* I believe I should acquire a global SV mutex if
3978 it's a COW sv (not a shared hash key) to stop
3979 it going un copy-on-write.
3980 If the source SV has gone un copy on write between up there
3981 and down here, then (assert() that) it is of the correct
3982 form to make it copy on write again */
3983 if ((sflags & (SVf_FAKE | SVf_READONLY))
3984 != (SVf_FAKE | SVf_READONLY)) {
3985 SvREADONLY_on(sstr);
3987 /* Make the source SV into a loop of 1.
3988 (about to become 2) */
3989 SV_COW_NEXT_SV_SET(sstr, sstr);
3993 /* Initial code is common. */
3994 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3996 SvFLAGS(dstr) &= ~SVf_OOK;
3997 Safefree(SvPVX(dstr) - SvIVX(dstr));
3999 else if (SvLEN(dstr))
4000 Safefree(SvPVX(dstr));
4002 (void)SvPOK_only(dstr);
4004 #ifdef PERL_COPY_ON_WRITE
4006 /* making another shared SV. */
4007 STRLEN cur = SvCUR(sstr);
4008 STRLEN len = SvLEN(sstr);
4010 /* SvIsCOW_normal */
4011 /* splice us in between source and next-after-source. */
4012 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4013 SV_COW_NEXT_SV_SET(sstr, dstr);
4014 SvPV_set(dstr, SvPVX(sstr));
4016 /* SvIsCOW_shared_hash */
4017 UV hash = SvUVX(sstr);
4018 DEBUG_C(PerlIO_printf(Perl_debug_log,
4019 "Copy on write: Sharing hash\n"));
4021 sharepvn(SvPVX(sstr),
4022 (sflags & SVf_UTF8?-cur:cur), hash));
4027 SvREADONLY_on(dstr);
4029 /* Relesase a global SV mutex. */
4033 { /* Passes the swipe test. */
4034 SvPV_set(dstr, SvPVX(sstr));
4035 SvLEN_set(dstr, SvLEN(sstr));
4036 SvCUR_set(dstr, SvCUR(sstr));
4039 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4040 SvPV_set(sstr, Nullch);
4046 if (sflags & SVf_UTF8)
4049 if (sflags & SVp_NOK) {
4051 if (sflags & SVf_NOK)
4052 SvFLAGS(dstr) |= SVf_NOK;
4053 SvNVX(dstr) = SvNVX(sstr);
4055 if (sflags & SVp_IOK) {
4056 (void)SvIOKp_on(dstr);
4057 if (sflags & SVf_IOK)
4058 SvFLAGS(dstr) |= SVf_IOK;
4059 if (sflags & SVf_IVisUV)
4061 SvIVX(dstr) = SvIVX(sstr);
4064 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4065 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4066 smg->mg_ptr, smg->mg_len);
4067 SvRMAGICAL_on(dstr);
4070 else if (sflags & SVp_IOK) {
4071 if (sflags & SVf_IOK)
4072 (void)SvIOK_only(dstr);
4074 (void)SvOK_off(dstr);
4075 (void)SvIOKp_on(dstr);
4077 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4078 if (sflags & SVf_IVisUV)
4080 SvIVX(dstr) = SvIVX(sstr);
4081 if (sflags & SVp_NOK) {
4082 if (sflags & SVf_NOK)
4083 (void)SvNOK_on(dstr);
4085 (void)SvNOKp_on(dstr);
4086 SvNVX(dstr) = SvNVX(sstr);
4089 else if (sflags & SVp_NOK) {
4090 if (sflags & SVf_NOK)
4091 (void)SvNOK_only(dstr);
4093 (void)SvOK_off(dstr);
4096 SvNVX(dstr) = SvNVX(sstr);
4099 if (dtype == SVt_PVGV) {
4100 if (ckWARN(WARN_MISC))
4101 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4104 (void)SvOK_off(dstr);
4106 if (SvTAINTED(sstr))
4111 =for apidoc sv_setsv_mg
4113 Like C<sv_setsv>, but also handles 'set' magic.
4119 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4121 sv_setsv(dstr,sstr);
4125 #ifdef PERL_COPY_ON_WRITE
4127 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4129 STRLEN cur = SvCUR(sstr);
4130 STRLEN len = SvLEN(sstr);
4131 register char *new_pv;
4134 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4142 if (SvTHINKFIRST(dstr))
4143 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4144 else if (SvPVX(dstr))
4145 Safefree(SvPVX(dstr));
4149 SvUPGRADE (dstr, SVt_PVIV);
4151 assert (SvPOK(sstr));
4152 assert (SvPOKp(sstr));
4153 assert (!SvIOK(sstr));
4154 assert (!SvIOKp(sstr));
4155 assert (!SvNOK(sstr));
4156 assert (!SvNOKp(sstr));
4158 if (SvIsCOW(sstr)) {
4160 if (SvLEN(sstr) == 0) {
4161 /* source is a COW shared hash key. */
4162 UV hash = SvUVX(sstr);
4163 DEBUG_C(PerlIO_printf(Perl_debug_log,
4164 "Fast copy on write: Sharing hash\n"));
4166 new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
4169 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4171 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4172 SvUPGRADE (sstr, SVt_PVIV);
4173 SvREADONLY_on(sstr);
4175 DEBUG_C(PerlIO_printf(Perl_debug_log,
4176 "Fast copy on write: Converting sstr to COW\n"));
4177 SV_COW_NEXT_SV_SET(dstr, sstr);
4179 SV_COW_NEXT_SV_SET(sstr, dstr);
4180 new_pv = SvPVX(sstr);
4183 SvPV_set(dstr, new_pv);
4184 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4197 =for apidoc sv_setpvn
4199 Copies a string into an SV. The C<len> parameter indicates the number of
4200 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4206 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4208 register char *dptr;
4210 SV_CHECK_THINKFIRST_COW_DROP(sv);
4216 /* len is STRLEN which is unsigned, need to copy to signed */
4219 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4221 (void)SvUPGRADE(sv, SVt_PV);
4223 SvGROW(sv, len + 1);
4225 Move(ptr,dptr,len,char);
4228 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4233 =for apidoc sv_setpvn_mg
4235 Like C<sv_setpvn>, but also handles 'set' magic.
4241 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4243 sv_setpvn(sv,ptr,len);
4248 =for apidoc sv_setpv
4250 Copies a string into an SV. The string must be null-terminated. Does not
4251 handle 'set' magic. See C<sv_setpv_mg>.
4257 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4259 register STRLEN len;
4261 SV_CHECK_THINKFIRST_COW_DROP(sv);
4267 (void)SvUPGRADE(sv, SVt_PV);
4269 SvGROW(sv, len + 1);
4270 Move(ptr,SvPVX(sv),len+1,char);
4272 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4277 =for apidoc sv_setpv_mg
4279 Like C<sv_setpv>, but also handles 'set' magic.
4285 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4292 =for apidoc sv_usepvn
4294 Tells an SV to use C<ptr> to find its string value. Normally the string is
4295 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4296 The C<ptr> should point to memory that was allocated by C<malloc>. The
4297 string length, C<len>, must be supplied. This function will realloc the
4298 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4299 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4300 See C<sv_usepvn_mg>.
4306 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4308 SV_CHECK_THINKFIRST_COW_DROP(sv);
4309 (void)SvUPGRADE(sv, SVt_PV);
4314 (void)SvOOK_off(sv);
4315 if (SvPVX(sv) && SvLEN(sv))
4316 Safefree(SvPVX(sv));
4317 Renew(ptr, len+1, char);
4320 SvLEN_set(sv, len+1);
4322 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4327 =for apidoc sv_usepvn_mg
4329 Like C<sv_usepvn>, but also handles 'set' magic.
4335 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4337 sv_usepvn(sv,ptr,len);
4341 #ifdef PERL_COPY_ON_WRITE
4342 /* Need to do this *after* making the SV normal, as we need the buffer
4343 pointer to remain valid until after we've copied it. If we let go too early,
4344 another thread could invalidate it by unsharing last of the same hash key
4345 (which it can do by means other than releasing copy-on-write Svs)
4346 or by changing the other copy-on-write SVs in the loop. */
4348 S_sv_release_COW(pTHX_ register SV *sv, char *pvx, STRLEN cur, STRLEN len,
4349 U32 hash, SV *after)
4351 if (len) { /* this SV was SvIsCOW_normal(sv) */
4352 /* we need to find the SV pointing to us. */
4353 SV *current = SV_COW_NEXT_SV(after);
4355 if (current == sv) {
4356 /* The SV we point to points back to us (there were only two of us
4358 Hence other SV is no longer copy on write either. */
4360 SvREADONLY_off(after);
4362 /* We need to follow the pointers around the loop. */
4364 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4367 /* don't loop forever if the structure is bust, and we have
4368 a pointer into a closed loop. */
4369 assert (current != after);
4370 assert (SvPVX(current) == pvx);
4372 /* Make the SV before us point to the SV after us. */
4373 SV_COW_NEXT_SV_SET(current, after);
4376 unsharepvn(pvx, SvUTF8(sv) ? -(I32)cur : cur, hash);
4381 Perl_sv_release_IVX(pTHX_ register SV *sv)
4384 sv_force_normal_flags(sv, 0);
4385 return SvOOK_off(sv);
4389 =for apidoc sv_force_normal_flags
4391 Undo various types of fakery on an SV: if the PV is a shared string, make
4392 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4393 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4394 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4395 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4396 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4397 set to some other value.) In addition, the C<flags> parameter gets passed to
4398 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4399 with flags set to 0.
4405 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4407 #ifdef PERL_COPY_ON_WRITE
4408 if (SvREADONLY(sv)) {
4409 /* At this point I believe I should acquire a global SV mutex. */
4411 char *pvx = SvPVX(sv);
4412 STRLEN len = SvLEN(sv);
4413 STRLEN cur = SvCUR(sv);
4414 U32 hash = SvUVX(sv);
4415 SV *next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4417 PerlIO_printf(Perl_debug_log,
4418 "Copy on write: Force normal %ld\n",
4424 /* This SV doesn't own the buffer, so need to New() a new one: */
4427 if (flags & SV_COW_DROP_PV) {
4428 /* OK, so we don't need to copy our buffer. */
4431 SvGROW(sv, cur + 1);
4432 Move(pvx,SvPVX(sv),cur,char);
4436 sv_release_COW(sv, pvx, cur, len, hash, next);
4441 else if (PL_curcop != &PL_compiling)
4442 Perl_croak(aTHX_ PL_no_modify);
4443 /* At this point I believe that I can drop the global SV mutex. */
4446 if (SvREADONLY(sv)) {
4448 char *pvx = SvPVX(sv);
4449 STRLEN len = SvCUR(sv);
4450 U32 hash = SvUVX(sv);
4451 SvGROW(sv, len + 1);
4452 Move(pvx,SvPVX(sv),len,char);
4456 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4458 else if (PL_curcop != &PL_compiling)
4459 Perl_croak(aTHX_ PL_no_modify);
4463 sv_unref_flags(sv, flags);
4464 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4469 =for apidoc sv_force_normal
4471 Undo various types of fakery on an SV: if the PV is a shared string, make
4472 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4473 an xpvmg. See also C<sv_force_normal_flags>.
4479 Perl_sv_force_normal(pTHX_ register SV *sv)
4481 sv_force_normal_flags(sv, 0);
4487 Efficient removal of characters from the beginning of the string buffer.
4488 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4489 the string buffer. The C<ptr> becomes the first character of the adjusted
4490 string. Uses the "OOK hack".
4496 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4498 register STRLEN delta;
4500 if (!ptr || !SvPOKp(sv))
4502 SV_CHECK_THINKFIRST(sv);
4503 if (SvTYPE(sv) < SVt_PVIV)
4504 sv_upgrade(sv,SVt_PVIV);
4507 if (!SvLEN(sv)) { /* make copy of shared string */
4508 char *pvx = SvPVX(sv);
4509 STRLEN len = SvCUR(sv);
4510 SvGROW(sv, len + 1);
4511 Move(pvx,SvPVX(sv),len,char);
4515 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4516 and we do that anyway inside the SvNIOK_off
4518 SvFLAGS(sv) |= SVf_OOK;
4521 delta = ptr - SvPVX(sv);
4528 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4529 * this function provided for binary compatibility only
4533 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4535 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4539 =for apidoc sv_catpvn
4541 Concatenates the string onto the end of the string which is in the SV. The
4542 C<len> indicates number of bytes to copy. If the SV has the UTF8
4543 status set, then the bytes appended should be valid UTF8.
4544 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4546 =for apidoc sv_catpvn_flags
4548 Concatenates the string onto the end of the string which is in the SV. The
4549 C<len> indicates number of bytes to copy. If the SV has the UTF8
4550 status set, then the bytes appended should be valid UTF8.
4551 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4552 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4553 in terms of this function.
4559 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4564 dstr = SvPV_force_flags(dsv, dlen, flags);
4565 SvGROW(dsv, dlen + slen + 1);
4568 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4571 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4576 =for apidoc sv_catpvn_mg
4578 Like C<sv_catpvn>, but also handles 'set' magic.
4584 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4586 sv_catpvn(sv,ptr,len);
4590 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4591 * this function provided for binary compatibility only
4595 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4597 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4601 =for apidoc sv_catsv
4603 Concatenates the string from SV C<ssv> onto the end of the string in
4604 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4605 not 'set' magic. See C<sv_catsv_mg>.
4607 =for apidoc sv_catsv_flags
4609 Concatenates the string from SV C<ssv> onto the end of the string in
4610 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4611 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4612 and C<sv_catsv_nomg> are implemented in terms of this function.
4617 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4623 if ((spv = SvPV(ssv, slen))) {
4624 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4625 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4626 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4627 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4628 dsv->sv_flags doesn't have that bit set.
4629 Andy Dougherty 12 Oct 2001
4631 I32 sutf8 = DO_UTF8(ssv);
4634 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4636 dutf8 = DO_UTF8(dsv);
4638 if (dutf8 != sutf8) {
4640 /* Not modifying source SV, so taking a temporary copy. */
4641 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4643 sv_utf8_upgrade(csv);
4644 spv = SvPV(csv, slen);
4647 sv_utf8_upgrade_nomg(dsv);
4649 sv_catpvn_nomg(dsv, spv, slen);
4654 =for apidoc sv_catsv_mg
4656 Like C<sv_catsv>, but also handles 'set' magic.
4662 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4669 =for apidoc sv_catpv
4671 Concatenates the string onto the end of the string which is in the SV.
4672 If the SV has the UTF8 status set, then the bytes appended should be
4673 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4678 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4680 register STRLEN len;
4686 junk = SvPV_force(sv, tlen);
4688 SvGROW(sv, tlen + len + 1);
4691 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4693 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4698 =for apidoc sv_catpv_mg
4700 Like C<sv_catpv>, but also handles 'set' magic.
4706 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4715 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4716 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4723 Perl_newSV(pTHX_ STRLEN len)
4729 sv_upgrade(sv, SVt_PV);
4730 SvGROW(sv, len + 1);
4735 =for apidoc sv_magicext
4737 Adds magic to an SV, upgrading it if necessary. Applies the
4738 supplied vtable and returns pointer to the magic added.
4740 Note that sv_magicext will allow things that sv_magic will not.
4741 In particular you can add magic to SvREADONLY SVs and and more than
4742 one instance of the same 'how'
4744 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4745 if C<namelen> is zero then C<name> is stored as-is and - as another special
4746 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4747 an C<SV*> and has its REFCNT incremented
4749 (This is now used as a subroutine by sv_magic.)
4754 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4755 const char* name, I32 namlen)
4759 if (SvTYPE(sv) < SVt_PVMG) {
4760 (void)SvUPGRADE(sv, SVt_PVMG);
4762 Newz(702,mg, 1, MAGIC);
4763 mg->mg_moremagic = SvMAGIC(sv);
4766 /* Some magic sontains a reference loop, where the sv and object refer to
4767 each other. To prevent a reference loop that would prevent such
4768 objects being freed, we look for such loops and if we find one we
4769 avoid incrementing the object refcount.
4771 Note we cannot do this to avoid self-tie loops as intervening RV must
4772 have its REFCNT incremented to keep it in existence.
4775 if (!obj || obj == sv ||
4776 how == PERL_MAGIC_arylen ||
4777 how == PERL_MAGIC_qr ||
4778 (SvTYPE(obj) == SVt_PVGV &&
4779 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4780 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4781 GvFORM(obj) == (CV*)sv)))
4786 mg->mg_obj = SvREFCNT_inc(obj);
4787 mg->mg_flags |= MGf_REFCOUNTED;
4790 /* Normal self-ties simply pass a null object, and instead of
4791 using mg_obj directly, use the SvTIED_obj macro to produce a
4792 new RV as needed. For glob "self-ties", we are tieing the PVIO
4793 with an RV obj pointing to the glob containing the PVIO. In
4794 this case, to avoid a reference loop, we need to weaken the
4798 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4799 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4805 mg->mg_len = namlen;
4808 mg->mg_ptr = savepvn(name, namlen);
4809 else if (namlen == HEf_SVKEY)
4810 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4812 mg->mg_ptr = (char *) name;
4814 mg->mg_virtual = vtable;
4818 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4823 =for apidoc sv_magic
4825 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4826 then adds a new magic item of type C<how> to the head of the magic list.
4832 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4837 #ifdef PERL_COPY_ON_WRITE
4839 sv_force_normal_flags(sv, 0);
4841 if (SvREADONLY(sv)) {
4842 if (PL_curcop != &PL_compiling
4843 && how != PERL_MAGIC_regex_global
4844 && how != PERL_MAGIC_bm
4845 && how != PERL_MAGIC_fm
4846 && how != PERL_MAGIC_sv
4849 Perl_croak(aTHX_ PL_no_modify);
4852 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4853 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4854 /* sv_magic() refuses to add a magic of the same 'how' as an
4857 if (how == PERL_MAGIC_taint)
4865 vtable = &PL_vtbl_sv;
4867 case PERL_MAGIC_overload:
4868 vtable = &PL_vtbl_amagic;
4870 case PERL_MAGIC_overload_elem:
4871 vtable = &PL_vtbl_amagicelem;
4873 case PERL_MAGIC_overload_table:
4874 vtable = &PL_vtbl_ovrld;
4877 vtable = &PL_vtbl_bm;
4879 case PERL_MAGIC_regdata:
4880 vtable = &PL_vtbl_regdata;
4882 case PERL_MAGIC_regdatum:
4883 vtable = &PL_vtbl_regdatum;
4885 case PERL_MAGIC_env:
4886 vtable = &PL_vtbl_env;
4889 vtable = &PL_vtbl_fm;
4891 case PERL_MAGIC_envelem:
4892 vtable = &PL_vtbl_envelem;
4894 case PERL_MAGIC_regex_global:
4895 vtable = &PL_vtbl_mglob;
4897 case PERL_MAGIC_isa:
4898 vtable = &PL_vtbl_isa;
4900 case PERL_MAGIC_isaelem:
4901 vtable = &PL_vtbl_isaelem;
4903 case PERL_MAGIC_nkeys:
4904 vtable = &PL_vtbl_nkeys;
4906 case PERL_MAGIC_dbfile:
4909 case PERL_MAGIC_dbline:
4910 vtable = &PL_vtbl_dbline;
4912 #ifdef USE_LOCALE_COLLATE
4913 case PERL_MAGIC_collxfrm:
4914 vtable = &PL_vtbl_collxfrm;
4916 #endif /* USE_LOCALE_COLLATE */
4917 case PERL_MAGIC_tied:
4918 vtable = &PL_vtbl_pack;
4920 case PERL_MAGIC_tiedelem:
4921 case PERL_MAGIC_tiedscalar:
4922 vtable = &PL_vtbl_packelem;
4925 vtable = &PL_vtbl_regexp;
4927 case PERL_MAGIC_sig:
4928 vtable = &PL_vtbl_sig;
4930 case PERL_MAGIC_sigelem:
4931 vtable = &PL_vtbl_sigelem;
4933 case PERL_MAGIC_taint:
4934 vtable = &PL_vtbl_taint;
4936 case PERL_MAGIC_uvar:
4937 vtable = &PL_vtbl_uvar;
4939 case PERL_MAGIC_vec:
4940 vtable = &PL_vtbl_vec;
4942 case PERL_MAGIC_vstring:
4945 case PERL_MAGIC_utf8:
4946 vtable = &PL_vtbl_utf8;
4948 case PERL_MAGIC_substr:
4949 vtable = &PL_vtbl_substr;
4951 case PERL_MAGIC_defelem:
4952 vtable = &PL_vtbl_defelem;
4954 case PERL_MAGIC_glob:
4955 vtable = &PL_vtbl_glob;
4957 case PERL_MAGIC_arylen:
4958 vtable = &PL_vtbl_arylen;
4960 case PERL_MAGIC_pos:
4961 vtable = &PL_vtbl_pos;
4963 case PERL_MAGIC_backref:
4964 vtable = &PL_vtbl_backref;
4966 case PERL_MAGIC_ext:
4967 /* Reserved for use by extensions not perl internals. */
4968 /* Useful for attaching extension internal data to perl vars. */
4969 /* Note that multiple extensions may clash if magical scalars */
4970 /* etc holding private data from one are passed to another. */
4973 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4976 /* Rest of work is done else where */
4977 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4980 case PERL_MAGIC_taint:
4983 case PERL_MAGIC_ext:
4984 case PERL_MAGIC_dbfile:
4991 =for apidoc sv_unmagic
4993 Removes all magic of type C<type> from an SV.
4999 Perl_sv_unmagic(pTHX_ SV *sv, int type)
5003 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5006 for (mg = *mgp; mg; mg = *mgp) {
5007 if (mg->mg_type == type) {
5008 MGVTBL* vtbl = mg->mg_virtual;
5009 *mgp = mg->mg_moremagic;
5010 if (vtbl && vtbl->svt_free)
5011 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5012 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5014 Safefree(mg->mg_ptr);
5015 else if (mg->mg_len == HEf_SVKEY)
5016 SvREFCNT_dec((SV*)mg->mg_ptr);
5017 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5018 Safefree(mg->mg_ptr);
5020 if (mg->mg_flags & MGf_REFCOUNTED)
5021 SvREFCNT_dec(mg->mg_obj);
5025 mgp = &mg->mg_moremagic;
5029 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5036 =for apidoc sv_rvweaken
5038 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5039 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5040 push a back-reference to this RV onto the array of backreferences
5041 associated with that magic.
5047 Perl_sv_rvweaken(pTHX_ SV *sv)
5050 if (!SvOK(sv)) /* let undefs pass */
5053 Perl_croak(aTHX_ "Can't weaken a nonreference");
5054 else if (SvWEAKREF(sv)) {
5055 if (ckWARN(WARN_MISC))
5056 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5060 sv_add_backref(tsv, sv);
5066 /* Give tsv backref magic if it hasn't already got it, then push a
5067 * back-reference to sv onto the array associated with the backref magic.
5071 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5075 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5076 av = (AV*)mg->mg_obj;
5079 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5080 SvREFCNT_dec(av); /* for sv_magic */
5082 if (AvFILLp(av) >= AvMAX(av)) {
5083 SV **svp = AvARRAY(av);
5084 I32 i = AvFILLp(av);
5086 if (svp[i] == &PL_sv_undef) {
5087 svp[i] = sv; /* reuse the slot */
5092 av_extend(av, AvFILLp(av)+1);
5094 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5097 /* delete a back-reference to ourselves from the backref magic associated
5098 * with the SV we point to.
5102 S_sv_del_backref(pTHX_ SV *sv)
5109 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5110 Perl_croak(aTHX_ "panic: del_backref");
5111 av = (AV *)mg->mg_obj;
5116 svp[i] = &PL_sv_undef; /* XXX */
5123 =for apidoc sv_insert
5125 Inserts a string at the specified offset/length within the SV. Similar to
5126 the Perl substr() function.
5132 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
5136 register char *midend;
5137 register char *bigend;
5143 Perl_croak(aTHX_ "Can't modify non-existent substring");
5144 SvPV_force(bigstr, curlen);
5145 (void)SvPOK_only_UTF8(bigstr);
5146 if (offset + len > curlen) {
5147 SvGROW(bigstr, offset+len+1);
5148 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5149 SvCUR_set(bigstr, offset+len);
5153 i = littlelen - len;
5154 if (i > 0) { /* string might grow */
5155 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5156 mid = big + offset + len;
5157 midend = bigend = big + SvCUR(bigstr);
5160 while (midend > mid) /* shove everything down */
5161 *--bigend = *--midend;
5162 Move(little,big+offset,littlelen,char);
5168 Move(little,SvPVX(bigstr)+offset,len,char);
5173 big = SvPVX(bigstr);
5176 bigend = big + SvCUR(bigstr);
5178 if (midend > bigend)
5179 Perl_croak(aTHX_ "panic: sv_insert");
5181 if (mid - big > bigend - midend) { /* faster to shorten from end */
5183 Move(little, mid, littlelen,char);
5186 i = bigend - midend;
5188 Move(midend, mid, i,char);
5192 SvCUR_set(bigstr, mid - big);
5195 else if ((i = mid - big)) { /* faster from front */
5196 midend -= littlelen;
5198 sv_chop(bigstr,midend-i);
5203 Move(little, mid, littlelen,char);
5205 else if (littlelen) {
5206 midend -= littlelen;
5207 sv_chop(bigstr,midend);
5208 Move(little,midend,littlelen,char);
5211 sv_chop(bigstr,midend);
5217 =for apidoc sv_replace
5219 Make the first argument a copy of the second, then delete the original.
5220 The target SV physically takes over ownership of the body of the source SV
5221 and inherits its flags; however, the target keeps any magic it owns,
5222 and any magic in the source is discarded.
5223 Note that this is a rather specialist SV copying operation; most of the
5224 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5230 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5232 U32 refcnt = SvREFCNT(sv);
5233 SV_CHECK_THINKFIRST_COW_DROP(sv);
5234 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5235 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5236 if (SvMAGICAL(sv)) {
5240 sv_upgrade(nsv, SVt_PVMG);
5241 SvMAGIC(nsv) = SvMAGIC(sv);
5242 SvFLAGS(nsv) |= SvMAGICAL(sv);
5248 assert(!SvREFCNT(sv));
5249 StructCopy(nsv,sv,SV);
5250 #ifdef PERL_COPY_ON_WRITE
5251 if (SvIsCOW_normal(nsv)) {
5252 /* We need to follow the pointers around the loop to make the
5253 previous SV point to sv, rather than nsv. */
5256 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5259 assert(SvPVX(current) == SvPVX(nsv));
5261 /* Make the SV before us point to the SV after us. */
5263 PerlIO_printf(Perl_debug_log, "previous is\n");
5265 PerlIO_printf(Perl_debug_log,
5266 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5267 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5269 SV_COW_NEXT_SV_SET(current, sv);
5272 SvREFCNT(sv) = refcnt;
5273 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5278 =for apidoc sv_clear
5280 Clear an SV: call any destructors, free up any memory used by the body,
5281 and free the body itself. The SV's head is I<not> freed, although
5282 its type is set to all 1's so that it won't inadvertently be assumed
5283 to be live during global destruction etc.
5284 This function should only be called when REFCNT is zero. Most of the time
5285 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5292 Perl_sv_clear(pTHX_ register SV *sv)
5296 assert(SvREFCNT(sv) == 0);
5299 if (PL_defstash) { /* Still have a symbol table? */
5304 Zero(&tmpref, 1, SV);
5305 sv_upgrade(&tmpref, SVt_RV);
5307 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
5308 SvREFCNT(&tmpref) = 1;
5311 stash = SvSTASH(sv);
5312 destructor = StashHANDLER(stash,DESTROY);
5315 PUSHSTACKi(PERLSI_DESTROY);
5316 SvRV(&tmpref) = SvREFCNT_inc(sv);
5321 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5327 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5329 del_XRV(SvANY(&tmpref));
5332 if (PL_in_clean_objs)
5333 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5335 /* DESTROY gave object new lease on life */
5341 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5342 SvOBJECT_off(sv); /* Curse the object. */
5343 if (SvTYPE(sv) != SVt_PVIO)
5344 --PL_sv_objcount; /* XXX Might want something more general */
5347 if (SvTYPE(sv) >= SVt_PVMG) {
5350 if (SvFLAGS(sv) & SVpad_TYPED)
5351 SvREFCNT_dec(SvSTASH(sv));
5354 switch (SvTYPE(sv)) {
5357 IoIFP(sv) != PerlIO_stdin() &&
5358 IoIFP(sv) != PerlIO_stdout() &&
5359 IoIFP(sv) != PerlIO_stderr())
5361 io_close((IO*)sv, FALSE);
5363 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5364 PerlDir_close(IoDIRP(sv));
5365 IoDIRP(sv) = (DIR*)NULL;
5366 Safefree(IoTOP_NAME(sv));
5367 Safefree(IoFMT_NAME(sv));
5368 Safefree(IoBOTTOM_NAME(sv));
5383 SvREFCNT_dec(LvTARG(sv));
5387 Safefree(GvNAME(sv));
5388 /* cannot decrease stash refcount yet, as we might recursively delete
5389 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5390 of stash until current sv is completely gone.
5391 -- JohnPC, 27 Mar 1998 */
5392 stash = GvSTASH(sv);
5398 (void)SvOOK_off(sv);
5406 SvREFCNT_dec(SvRV(sv));
5408 #ifdef PERL_COPY_ON_WRITE
5409 else if (SvPVX(sv)) {
5411 /* I believe I need to grab the global SV mutex here and
5412 then recheck the COW status. */
5414 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5417 sv_release_COW(sv, SvPVX(sv), SvCUR(sv), SvLEN(sv),
5418 SvUVX(sv), SV_COW_NEXT_SV(sv));
5419 /* And drop it here. */
5421 } else if (SvLEN(sv)) {
5422 Safefree(SvPVX(sv));
5426 else if (SvPVX(sv) && SvLEN(sv))
5427 Safefree(SvPVX(sv));
5428 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5429 unsharepvn(SvPVX(sv),
5430 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5444 switch (SvTYPE(sv)) {
5460 del_XPVIV(SvANY(sv));
5463 del_XPVNV(SvANY(sv));
5466 del_XPVMG(SvANY(sv));
5469 del_XPVLV(SvANY(sv));
5472 del_XPVAV(SvANY(sv));
5475 del_XPVHV(SvANY(sv));
5478 del_XPVCV(SvANY(sv));
5481 del_XPVGV(SvANY(sv));
5482 /* code duplication for increased performance. */
5483 SvFLAGS(sv) &= SVf_BREAK;
5484 SvFLAGS(sv) |= SVTYPEMASK;
5485 /* decrease refcount of the stash that owns this GV, if any */
5487 SvREFCNT_dec(stash);
5488 return; /* not break, SvFLAGS reset already happened */
5490 del_XPVBM(SvANY(sv));
5493 del_XPVFM(SvANY(sv));
5496 del_XPVIO(SvANY(sv));
5499 SvFLAGS(sv) &= SVf_BREAK;
5500 SvFLAGS(sv) |= SVTYPEMASK;
5504 =for apidoc sv_newref
5506 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5513 Perl_sv_newref(pTHX_ SV *sv)
5523 Decrement an SV's reference count, and if it drops to zero, call
5524 C<sv_clear> to invoke destructors and free up any memory used by
5525 the body; finally, deallocate the SV's head itself.
5526 Normally called via a wrapper macro C<SvREFCNT_dec>.
5532 Perl_sv_free(pTHX_ SV *sv)
5536 if (SvREFCNT(sv) == 0) {
5537 if (SvFLAGS(sv) & SVf_BREAK)
5538 /* this SV's refcnt has been artificially decremented to
5539 * trigger cleanup */
5541 if (PL_in_clean_all) /* All is fair */
5543 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5544 /* make sure SvREFCNT(sv)==0 happens very seldom */
5545 SvREFCNT(sv) = (~(U32)0)/2;
5548 if (ckWARN_d(WARN_INTERNAL))
5549 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
5552 if (--(SvREFCNT(sv)) > 0)
5554 Perl_sv_free2(aTHX_ sv);
5558 Perl_sv_free2(pTHX_ SV *sv)
5562 if (ckWARN_d(WARN_DEBUGGING))
5563 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5564 "Attempt to free temp prematurely: SV 0x%"UVxf,
5569 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5570 /* make sure SvREFCNT(sv)==0 happens very seldom */
5571 SvREFCNT(sv) = (~(U32)0)/2;
5582 Returns the length of the string in the SV. Handles magic and type
5583 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5589 Perl_sv_len(pTHX_ register SV *sv)
5597 len = mg_length(sv);
5599 (void)SvPV(sv, len);
5604 =for apidoc sv_len_utf8
5606 Returns the number of characters in the string in an SV, counting wide
5607 UTF8 bytes as a single character. Handles magic and type coercion.
5613 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5614 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5615 * (Note that the mg_len is not the length of the mg_ptr field.)
5620 Perl_sv_len_utf8(pTHX_ register SV *sv)
5626 return mg_length(sv);
5630 U8 *s = (U8*)SvPV(sv, len);
5631 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5633 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0))
5636 ulen = Perl_utf8_length(aTHX_ s, s + len);
5637 if (!mg && !SvREADONLY(sv)) {
5638 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5639 mg = mg_find(sv, PERL_MAGIC_utf8);
5649 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5650 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5651 * between UTF-8 and byte offsets. There are two (substr offset and substr
5652 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5653 * and byte offset) cache positions.
5655 * The mg_len field is used by sv_len_utf8(), see its comments.
5656 * Note that the mg_len is not the length of the mg_ptr field.
5660 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
5664 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5666 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5667 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5672 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5674 Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5675 (*mgp)->mg_ptr = (char *) *cachep;
5679 (*cachep)[i] = *offsetp;
5680 (*cachep)[i+1] = s - start;
5688 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5689 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5690 * between UTF-8 and byte offsets. See also the comments of
5691 * S_utf8_mg_pos_init().
5695 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
5699 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5701 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5702 if (*mgp && (*mgp)->mg_ptr) {
5703 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5704 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5706 else { /* We will skip to the right spot. */
5711 /* The assumption is that going backward is half
5712 * the speed of going forward (that's where the
5713 * 2 * backw in the below comes from). (The real
5714 * figure of course depends on the UTF-8 data.) */
5716 if ((*cachep)[i] > (STRLEN)uoff) {
5718 backw = (*cachep)[i] - (STRLEN)uoff;
5720 if (forw < 2 * backw)
5723 p = start + (*cachep)[i+1];
5725 /* Try this only for the substr offset (i == 0),
5726 * not for the substr length (i == 2). */
5727 else if (i == 0) { /* (*cachep)[i] < uoff */
5728 STRLEN ulen = sv_len_utf8(sv);
5730 if ((STRLEN)uoff < ulen) {
5731 forw = (STRLEN)uoff - (*cachep)[i];
5732 backw = ulen - (STRLEN)uoff;
5734 if (forw < 2 * backw)
5735 p = start + (*cachep)[i+1];
5740 /* If the string is not long enough for uoff,
5741 * we could extend it, but not at this low a level. */
5745 if (forw < 2 * backw) {
5752 while (UTF8_IS_CONTINUATION(*p))
5757 /* Update the cache. */
5758 (*cachep)[i] = (STRLEN)uoff;
5759 (*cachep)[i+1] = p - start;
5764 if (found) { /* Setup the return values. */
5765 *offsetp = (*cachep)[i+1];
5766 *sp = start + *offsetp;
5769 *offsetp = send - start;
5771 else if (*sp < start) {
5782 =for apidoc sv_pos_u2b
5784 Converts the value pointed to by offsetp from a count of UTF8 chars from
5785 the start of the string, to a count of the equivalent number of bytes; if
5786 lenp is non-zero, it does the same to lenp, but this time starting from
5787 the offset, rather than from the start of the string. Handles magic and
5794 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5795 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5796 * byte offsets. See also the comments of S_utf8_mg_pos().
5801 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5812 start = s = (U8*)SvPV(sv, len);
5814 I32 uoffset = *offsetp;
5819 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5821 if (!found && uoffset > 0) {
5822 while (s < send && uoffset--)
5826 if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
5828 *offsetp = s - start;
5833 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
5837 if (!found && *lenp > 0) {
5840 while (s < send && ulen--)
5844 if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
5845 cache[2] += *offsetp;
5859 =for apidoc sv_pos_b2u
5861 Converts the value pointed to by offsetp from a count of bytes from the
5862 start of the string, to a count of the equivalent number of UTF8 chars.
5863 Handles magic and type coercion.
5869 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5870 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5871 * byte offsets. See also the comments of S_utf8_mg_pos().
5876 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5884 s = (U8*)SvPV(sv, len);
5885 if ((I32)len < *offsetp)
5886 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5888 U8* send = s + *offsetp;
5890 STRLEN *cache = NULL;
5894 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5895 mg = mg_find(sv, PERL_MAGIC_utf8);
5896 if (mg && mg->mg_ptr) {
5897 cache = (STRLEN *) mg->mg_ptr;
5898 if (cache[1] == *offsetp) {
5899 /* An exact match. */
5900 *offsetp = cache[0];
5904 else if (cache[1] < *offsetp) {
5905 /* We already know part of the way. */
5908 /* Let the below loop do the rest. */
5910 else { /* cache[1] > *offsetp */
5911 /* We already know all of the way, now we may
5912 * be able to walk back. The same assumption
5913 * is made as in S_utf8_mg_pos(), namely that
5914 * walking backward is twice slower than
5915 * walking forward. */
5916 STRLEN forw = *offsetp;
5917 STRLEN backw = cache[1] - *offsetp;
5919 if (!(forw < 2 * backw)) {
5920 U8 *p = s + cache[1];
5927 while (UTF8_IS_CONTINUATION(*p))
5943 /* Call utf8n_to_uvchr() to validate the sequence
5944 * (unless a simple non-UTF character) */
5945 if (!UTF8_IS_INVARIANT(*s))
5946 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5955 if (!SvREADONLY(sv)) {
5957 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5958 mg = mg_find(sv, PERL_MAGIC_utf8);
5963 Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5964 mg->mg_ptr = (char *) cache;
5969 cache[1] = *offsetp;
5980 Returns a boolean indicating whether the strings in the two SVs are
5981 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5982 coerce its args to strings if necessary.
5988 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5996 SV* svrecode = Nullsv;
6003 pv1 = SvPV(sv1, cur1);
6010 pv2 = SvPV(sv2, cur2);
6012 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6013 /* Differing utf8ness.
6014 * Do not UTF8size the comparands as a side-effect. */
6017 svrecode = newSVpvn(pv2, cur2);
6018 sv_recode_to_utf8(svrecode, PL_encoding);
6019 pv2 = SvPV(svrecode, cur2);
6022 svrecode = newSVpvn(pv1, cur1);
6023 sv_recode_to_utf8(svrecode, PL_encoding);
6024 pv1 = SvPV(svrecode, cur1);
6026 /* Now both are in UTF-8. */
6031 bool is_utf8 = TRUE;
6034 /* sv1 is the UTF-8 one,
6035 * if is equal it must be downgrade-able */
6036 char *pv = (char*)bytes_from_utf8((U8*)pv1,
6042 /* sv2 is the UTF-8 one,
6043 * if is equal it must be downgrade-able */
6044 char *pv = (char *)bytes_from_utf8((U8*)pv2,
6050 /* Downgrade not possible - cannot be eq */
6057 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6060 SvREFCNT_dec(svrecode);
6071 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6072 string in C<sv1> is less than, equal to, or greater than the string in
6073 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6074 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6080 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6083 char *pv1, *pv2, *tpv = Nullch;
6085 SV *svrecode = Nullsv;
6092 pv1 = SvPV(sv1, cur1);
6099 pv2 = SvPV(sv2, cur2);
6101 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6102 /* Differing utf8ness.
6103 * Do not UTF8size the comparands as a side-effect. */
6106 svrecode = newSVpvn(pv2, cur2);
6107 sv_recode_to_utf8(svrecode, PL_encoding);
6108 pv2 = SvPV(svrecode, cur2);
6111 pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
6116 svrecode = newSVpvn(pv1, cur1);
6117 sv_recode_to_utf8(svrecode, PL_encoding);
6118 pv1 = SvPV(svrecode, cur1);
6121 pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
6127 cmp = cur2 ? -1 : 0;
6131 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
6134 cmp = retval < 0 ? -1 : 1;
6135 } else if (cur1 == cur2) {
6138 cmp = cur1 < cur2 ? -1 : 1;
6143 SvREFCNT_dec(svrecode);
6152 =for apidoc sv_cmp_locale
6154 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6155 'use bytes' aware, handles get magic, and will coerce its args to strings
6156 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6162 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6164 #ifdef USE_LOCALE_COLLATE
6170 if (PL_collation_standard)
6174 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6176 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6178 if (!pv1 || !len1) {
6189 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6192 return retval < 0 ? -1 : 1;
6195 * When the result of collation is equality, that doesn't mean
6196 * that there are no differences -- some locales exclude some
6197 * characters from consideration. So to avoid false equalities,
6198 * we use the raw string as a tiebreaker.
6204 #endif /* USE_LOCALE_COLLATE */
6206 return sv_cmp(sv1, sv2);
6210 #ifdef USE_LOCALE_COLLATE
6213 =for apidoc sv_collxfrm
6215 Add Collate Transform magic to an SV if it doesn't already have it.
6217 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6218 scalar data of the variable, but transformed to such a format that a normal
6219 memory comparison can be used to compare the data according to the locale
6226 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6230 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6231 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6236 Safefree(mg->mg_ptr);
6238 if ((xf = mem_collxfrm(s, len, &xlen))) {
6239 if (SvREADONLY(sv)) {
6242 return xf + sizeof(PL_collation_ix);
6245 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6246 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6259 if (mg && mg->mg_ptr) {
6261 return mg->mg_ptr + sizeof(PL_collation_ix);
6269 #endif /* USE_LOCALE_COLLATE */
6274 Get a line from the filehandle and store it into the SV, optionally
6275 appending to the currently-stored string.
6281 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6285 register STDCHAR rslast;
6286 register STDCHAR *bp;
6292 SV_CHECK_THINKFIRST_COW_DROP(sv);
6293 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6295 However, perlbench says it's slower, because the existing swipe code
6296 is faster than copy on write.
6297 Swings and roundabouts. */
6298 (void)SvUPGRADE(sv, SVt_PV);
6303 if (PerlIO_isutf8(fp)) {
6305 sv_utf8_upgrade_nomg(sv);
6306 sv_pos_u2b(sv,&append,0);
6308 } else if (SvUTF8(sv)) {
6309 SV *tsv = NEWSV(0,0);
6310 sv_gets(tsv, fp, 0);
6311 sv_utf8_upgrade_nomg(tsv);
6312 SvCUR_set(sv,append);
6315 goto return_string_or_null;
6320 if (PerlIO_isutf8(fp))
6323 if (PL_curcop == &PL_compiling) {
6324 /* we always read code in line mode */
6328 else if (RsSNARF(PL_rs)) {
6329 /* If it is a regular disk file use size from stat() as estimate
6330 of amount we are going to read - may result in malloc-ing
6331 more memory than we realy need if layers bellow reduce
6332 size we read (e.g. CRLF or a gzip layer)
6335 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6336 Off_t offset = PerlIO_tell(fp);
6337 if (offset != (Off_t) -1) {
6338 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6344 else if (RsRECORD(PL_rs)) {
6348 /* Grab the size of the record we're getting */
6349 recsize = SvIV(SvRV(PL_rs));
6350 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6353 /* VMS wants read instead of fread, because fread doesn't respect */
6354 /* RMS record boundaries. This is not necessarily a good thing to be */
6355 /* doing, but we've got no other real choice - except avoid stdio
6356 as implementation - perhaps write a :vms layer ?
6358 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6360 bytesread = PerlIO_read(fp, buffer, recsize);
6362 SvCUR_set(sv, bytesread += append);
6363 buffer[bytesread] = '\0';
6364 goto return_string_or_null;
6366 else if (RsPARA(PL_rs)) {
6372 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6373 if (PerlIO_isutf8(fp)) {
6374 rsptr = SvPVutf8(PL_rs, rslen);
6377 if (SvUTF8(PL_rs)) {
6378 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6379 Perl_croak(aTHX_ "Wide character in $/");
6382 rsptr = SvPV(PL_rs, rslen);
6386 rslast = rslen ? rsptr[rslen - 1] : '\0';
6388 if (rspara) { /* have to do this both before and after */
6389 do { /* to make sure file boundaries work right */
6392 i = PerlIO_getc(fp);
6396 PerlIO_ungetc(fp,i);
6402 /* See if we know enough about I/O mechanism to cheat it ! */
6404 /* This used to be #ifdef test - it is made run-time test for ease
6405 of abstracting out stdio interface. One call should be cheap
6406 enough here - and may even be a macro allowing compile
6410 if (PerlIO_fast_gets(fp)) {
6413 * We're going to steal some values from the stdio struct
6414 * and put EVERYTHING in the innermost loop into registers.
6416 register STDCHAR *ptr;
6420 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6421 /* An ungetc()d char is handled separately from the regular
6422 * buffer, so we getc() it back out and stuff it in the buffer.
6424 i = PerlIO_getc(fp);
6425 if (i == EOF) return 0;
6426 *(--((*fp)->_ptr)) = (unsigned char) i;
6430 /* Here is some breathtakingly efficient cheating */
6432 cnt = PerlIO_get_cnt(fp); /* get count into register */
6433 /* make sure we have the room */
6434 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6435 /* Not room for all of it
6436 if we are looking for a separator and room for some
6438 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6439 /* just process what we have room for */
6440 shortbuffered = cnt - SvLEN(sv) + append + 1;
6441 cnt -= shortbuffered;
6445 /* remember that cnt can be negative */
6446 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6451 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
6452 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6453 DEBUG_P(PerlIO_printf(Perl_debug_log,
6454 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6455 DEBUG_P(PerlIO_printf(Perl_debug_log,
6456 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6457 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6458 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6463 while (cnt > 0) { /* this | eat */
6465 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6466 goto thats_all_folks; /* screams | sed :-) */
6470 Copy(ptr, bp, cnt, char); /* this | eat */
6471 bp += cnt; /* screams | dust */
6472 ptr += cnt; /* louder | sed :-) */
6477 if (shortbuffered) { /* oh well, must extend */
6478 cnt = shortbuffered;
6480 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6482 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6483 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6487 DEBUG_P(PerlIO_printf(Perl_debug_log,
6488 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6489 PTR2UV(ptr),(long)cnt));
6490 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6492 DEBUG_P(PerlIO_printf(Perl_debug_log,
6493 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6494 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6495 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6497 /* This used to call 'filbuf' in stdio form, but as that behaves like
6498 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6499 another abstraction. */
6500 i = PerlIO_getc(fp); /* get more characters */
6502 DEBUG_P(PerlIO_printf(Perl_debug_log,
6503 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6504 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6505 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6507 cnt = PerlIO_get_cnt(fp);
6508 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6509 DEBUG_P(PerlIO_printf(Perl_debug_log,
6510 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6512 if (i == EOF) /* all done for ever? */
6513 goto thats_really_all_folks;
6515 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6517 SvGROW(sv, bpx + cnt + 2);
6518 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6520 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6522 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6523 goto thats_all_folks;
6527 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6528 memNE((char*)bp - rslen, rsptr, rslen))
6529 goto screamer; /* go back to the fray */
6530 thats_really_all_folks:
6532 cnt += shortbuffered;
6533 DEBUG_P(PerlIO_printf(Perl_debug_log,
6534 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6535 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6536 DEBUG_P(PerlIO_printf(Perl_debug_log,
6537 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6538 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6539 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6541 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
6542 DEBUG_P(PerlIO_printf(Perl_debug_log,
6543 "Screamer: done, len=%ld, string=|%.*s|\n",
6544 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6549 /*The big, slow, and stupid way */
6552 /* Need to work around EPOC SDK features */
6553 /* On WINS: MS VC5 generates calls to _chkstk, */
6554 /* if a `large' stack frame is allocated */
6555 /* gcc on MARM does not generate calls like these */
6561 register STDCHAR *bpe = buf + sizeof(buf);
6563 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6564 ; /* keep reading */
6568 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6569 /* Accomodate broken VAXC compiler, which applies U8 cast to
6570 * both args of ?: operator, causing EOF to change into 255
6573 i = (U8)buf[cnt - 1];
6579 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6581 sv_catpvn(sv, (char *) buf, cnt);
6583 sv_setpvn(sv, (char *) buf, cnt);
6585 if (i != EOF && /* joy */
6587 SvCUR(sv) < rslen ||
6588 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6592 * If we're reading from a TTY and we get a short read,
6593 * indicating that the user hit his EOF character, we need
6594 * to notice it now, because if we try to read from the TTY
6595 * again, the EOF condition will disappear.
6597 * The comparison of cnt to sizeof(buf) is an optimization
6598 * that prevents unnecessary calls to feof().
6602 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6607 if (rspara) { /* have to do this both before and after */
6608 while (i != EOF) { /* to make sure file boundaries work right */
6609 i = PerlIO_getc(fp);
6611 PerlIO_ungetc(fp,i);
6617 return_string_or_null:
6618 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6624 Auto-increment of the value in the SV, doing string to numeric conversion
6625 if necessary. Handles 'get' magic.
6631 Perl_sv_inc(pTHX_ register SV *sv)
6640 if (SvTHINKFIRST(sv)) {
6642 sv_force_normal_flags(sv, 0);
6643 if (SvREADONLY(sv)) {
6644 if (PL_curcop != &PL_compiling)
6645 Perl_croak(aTHX_ PL_no_modify);
6649 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6651 i = PTR2IV(SvRV(sv));
6656 flags = SvFLAGS(sv);
6657 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6658 /* It's (privately or publicly) a float, but not tested as an
6659 integer, so test it to see. */
6661 flags = SvFLAGS(sv);
6663 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6664 /* It's publicly an integer, or privately an integer-not-float */
6665 #ifdef PERL_PRESERVE_IVUV
6669 if (SvUVX(sv) == UV_MAX)
6670 sv_setnv(sv, UV_MAX_P1);
6672 (void)SvIOK_only_UV(sv);
6675 if (SvIVX(sv) == IV_MAX)
6676 sv_setuv(sv, (UV)IV_MAX + 1);
6678 (void)SvIOK_only(sv);
6684 if (flags & SVp_NOK) {
6685 (void)SvNOK_only(sv);
6690 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6691 if ((flags & SVTYPEMASK) < SVt_PVIV)
6692 sv_upgrade(sv, SVt_IV);
6693 (void)SvIOK_only(sv);
6698 while (isALPHA(*d)) d++;
6699 while (isDIGIT(*d)) d++;
6701 #ifdef PERL_PRESERVE_IVUV
6702 /* Got to punt this as an integer if needs be, but we don't issue
6703 warnings. Probably ought to make the sv_iv_please() that does
6704 the conversion if possible, and silently. */
6705 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6706 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6707 /* Need to try really hard to see if it's an integer.
6708 9.22337203685478e+18 is an integer.
6709 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6710 so $a="9.22337203685478e+18"; $a+0; $a++
6711 needs to be the same as $a="9.22337203685478e+18"; $a++
6718 /* sv_2iv *should* have made this an NV */
6719 if (flags & SVp_NOK) {
6720 (void)SvNOK_only(sv);
6724 /* I don't think we can get here. Maybe I should assert this
6725 And if we do get here I suspect that sv_setnv will croak. NWC
6727 #if defined(USE_LONG_DOUBLE)
6728 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",
6729 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6731 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6732 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6735 #endif /* PERL_PRESERVE_IVUV */
6736 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6740 while (d >= SvPVX(sv)) {
6748 /* MKS: The original code here died if letters weren't consecutive.
6749 * at least it didn't have to worry about non-C locales. The
6750 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6751 * arranged in order (although not consecutively) and that only
6752 * [A-Za-z] are accepted by isALPHA in the C locale.
6754 if (*d != 'z' && *d != 'Z') {
6755 do { ++*d; } while (!isALPHA(*d));
6758 *(d--) -= 'z' - 'a';
6763 *(d--) -= 'z' - 'a' + 1;
6767 /* oh,oh, the number grew */
6768 SvGROW(sv, SvCUR(sv) + 2);
6770 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6781 Auto-decrement of the value in the SV, doing string to numeric conversion
6782 if necessary. Handles 'get' magic.
6788 Perl_sv_dec(pTHX_ register SV *sv)
6796 if (SvTHINKFIRST(sv)) {
6798 sv_force_normal_flags(sv, 0);
6799 if (SvREADONLY(sv)) {
6800 if (PL_curcop != &PL_compiling)
6801 Perl_croak(aTHX_ PL_no_modify);
6805 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6807 i = PTR2IV(SvRV(sv));
6812 /* Unlike sv_inc we don't have to worry about string-never-numbers
6813 and keeping them magic. But we mustn't warn on punting */
6814 flags = SvFLAGS(sv);
6815 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6816 /* It's publicly an integer, or privately an integer-not-float */
6817 #ifdef PERL_PRESERVE_IVUV
6821 if (SvUVX(sv) == 0) {
6822 (void)SvIOK_only(sv);
6826 (void)SvIOK_only_UV(sv);
6830 if (SvIVX(sv) == IV_MIN)
6831 sv_setnv(sv, (NV)IV_MIN - 1.0);
6833 (void)SvIOK_only(sv);
6839 if (flags & SVp_NOK) {
6841 (void)SvNOK_only(sv);
6844 if (!(flags & SVp_POK)) {
6845 if ((flags & SVTYPEMASK) < SVt_PVNV)
6846 sv_upgrade(sv, SVt_NV);
6848 (void)SvNOK_only(sv);
6851 #ifdef PERL_PRESERVE_IVUV
6853 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6854 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6855 /* Need to try really hard to see if it's an integer.
6856 9.22337203685478e+18 is an integer.
6857 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6858 so $a="9.22337203685478e+18"; $a+0; $a--
6859 needs to be the same as $a="9.22337203685478e+18"; $a--
6866 /* sv_2iv *should* have made this an NV */
6867 if (flags & SVp_NOK) {
6868 (void)SvNOK_only(sv);
6872 /* I don't think we can get here. Maybe I should assert this
6873 And if we do get here I suspect that sv_setnv will croak. NWC
6875 #if defined(USE_LONG_DOUBLE)
6876 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",
6877 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6879 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6880 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6884 #endif /* PERL_PRESERVE_IVUV */
6885 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6889 =for apidoc sv_mortalcopy
6891 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6892 The new SV is marked as mortal. It will be destroyed "soon", either by an
6893 explicit call to FREETMPS, or by an implicit call at places such as
6894 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6899 /* Make a string that will exist for the duration of the expression
6900 * evaluation. Actually, it may have to last longer than that, but
6901 * hopefully we won't free it until it has been assigned to a
6902 * permanent location. */
6905 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6910 sv_setsv(sv,oldstr);
6912 PL_tmps_stack[++PL_tmps_ix] = sv;
6918 =for apidoc sv_newmortal
6920 Creates a new null SV which is mortal. The reference count of the SV is
6921 set to 1. It will be destroyed "soon", either by an explicit call to
6922 FREETMPS, or by an implicit call at places such as statement boundaries.
6923 See also C<sv_mortalcopy> and C<sv_2mortal>.
6929 Perl_sv_newmortal(pTHX)
6934 SvFLAGS(sv) = SVs_TEMP;
6936 PL_tmps_stack[++PL_tmps_ix] = sv;
6941 =for apidoc sv_2mortal
6943 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6944 by an explicit call to FREETMPS, or by an implicit call at places such as
6945 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6951 Perl_sv_2mortal(pTHX_ register SV *sv)
6955 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6958 PL_tmps_stack[++PL_tmps_ix] = sv;
6966 Creates a new SV and copies a string into it. The reference count for the
6967 SV is set to 1. If C<len> is zero, Perl will compute the length using
6968 strlen(). For efficiency, consider using C<newSVpvn> instead.
6974 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6981 sv_setpvn(sv,s,len);
6986 =for apidoc newSVpvn
6988 Creates a new SV and copies a string into it. The reference count for the
6989 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6990 string. You are responsible for ensuring that the source string is at least
6997 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7002 sv_setpvn(sv,s,len);
7007 =for apidoc newSVpvn_share
7009 Creates a new SV with its SvPVX pointing to a shared string in the string
7010 table. If the string does not already exist in the table, it is created
7011 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7012 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7013 otherwise the hash is computed. The idea here is that as the string table
7014 is used for shared hash keys these strings will have SvPVX == HeKEY and
7015 hash lookup will avoid string compare.
7021 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7024 bool is_utf8 = FALSE;
7026 STRLEN tmplen = -len;
7028 /* See the note in hv.c:hv_fetch() --jhi */
7029 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
7033 PERL_HASH(hash, src, len);
7035 sv_upgrade(sv, SVt_PVIV);
7036 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
7049 #if defined(PERL_IMPLICIT_CONTEXT)
7051 /* pTHX_ magic can't cope with varargs, so this is a no-context
7052 * version of the main function, (which may itself be aliased to us).
7053 * Don't access this version directly.
7057 Perl_newSVpvf_nocontext(const char* pat, ...)
7062 va_start(args, pat);
7063 sv = vnewSVpvf(pat, &args);
7070 =for apidoc newSVpvf
7072 Creates a new SV and initializes it with the string formatted like
7079 Perl_newSVpvf(pTHX_ const char* pat, ...)
7083 va_start(args, pat);
7084 sv = vnewSVpvf(pat, &args);
7089 /* backend for newSVpvf() and newSVpvf_nocontext() */
7092 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7096 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7103 Creates a new SV and copies a floating point value into it.
7104 The reference count for the SV is set to 1.
7110 Perl_newSVnv(pTHX_ NV n)
7122 Creates a new SV and copies an integer into it. The reference count for the
7129 Perl_newSViv(pTHX_ IV i)
7141 Creates a new SV and copies an unsigned integer into it.
7142 The reference count for the SV is set to 1.
7148 Perl_newSVuv(pTHX_ UV u)
7158 =for apidoc newRV_noinc
7160 Creates an RV wrapper for an SV. The reference count for the original
7161 SV is B<not> incremented.
7167 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7172 sv_upgrade(sv, SVt_RV);
7179 /* newRV_inc is the official function name to use now.
7180 * newRV_inc is in fact #defined to newRV in sv.h
7184 Perl_newRV(pTHX_ SV *tmpRef)
7186 return newRV_noinc(SvREFCNT_inc(tmpRef));
7192 Creates a new SV which is an exact duplicate of the original SV.
7199 Perl_newSVsv(pTHX_ register SV *old)
7205 if (SvTYPE(old) == SVTYPEMASK) {
7206 if (ckWARN_d(WARN_INTERNAL))
7207 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7222 =for apidoc sv_reset
7224 Underlying implementation for the C<reset> Perl function.
7225 Note that the perl-level function is vaguely deprecated.
7231 Perl_sv_reset(pTHX_ register char *s, HV *stash)
7239 char todo[PERL_UCHAR_MAX+1];
7244 if (!*s) { /* reset ?? searches */
7245 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7246 pm->op_pmdynflags &= ~PMdf_USED;
7251 /* reset variables */
7253 if (!HvARRAY(stash))
7256 Zero(todo, 256, char);
7258 i = (unsigned char)*s;
7262 max = (unsigned char)*s++;
7263 for ( ; i <= max; i++) {
7266 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7267 for (entry = HvARRAY(stash)[i];
7269 entry = HeNEXT(entry))
7271 if (!todo[(U8)*HeKEY(entry)])
7273 gv = (GV*)HeVAL(entry);
7275 if (SvTHINKFIRST(sv)) {
7276 if (!SvREADONLY(sv) && SvROK(sv))
7281 if (SvTYPE(sv) >= SVt_PV) {
7283 if (SvPVX(sv) != Nullch)
7290 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7292 #ifdef USE_ENVIRON_ARRAY
7294 # ifdef USE_ITHREADS
7295 && PL_curinterp == aTHX
7299 environ[0] = Nullch;
7311 Using various gambits, try to get an IO from an SV: the IO slot if its a
7312 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7313 named after the PV if we're a string.
7319 Perl_sv_2io(pTHX_ SV *sv)
7325 switch (SvTYPE(sv)) {
7333 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7337 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7339 return sv_2io(SvRV(sv));
7340 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
7346 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7355 Using various gambits, try to get a CV from an SV; in addition, try if
7356 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7362 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7369 return *gvp = Nullgv, Nullcv;
7370 switch (SvTYPE(sv)) {
7389 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7390 tryAMAGICunDEREF(to_cv);
7393 if (SvTYPE(sv) == SVt_PVCV) {
7402 Perl_croak(aTHX_ "Not a subroutine reference");
7407 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
7413 if (lref && !GvCVu(gv)) {
7416 tmpsv = NEWSV(704,0);
7417 gv_efullname3(tmpsv, gv, Nullch);
7418 /* XXX this is probably not what they think they're getting.
7419 * It has the same effect as "sub name;", i.e. just a forward
7421 newSUB(start_subparse(FALSE, 0),
7422 newSVOP(OP_CONST, 0, tmpsv),
7427 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7437 Returns true if the SV has a true value by Perl's rules.
7438 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7439 instead use an in-line version.
7445 Perl_sv_true(pTHX_ register SV *sv)
7451 if ((tXpv = (XPV*)SvANY(sv)) &&
7452 (tXpv->xpv_cur > 1 ||
7453 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
7460 return SvIVX(sv) != 0;
7463 return SvNVX(sv) != 0.0;
7465 return sv_2bool(sv);
7473 A private implementation of the C<SvIVx> macro for compilers which can't
7474 cope with complex macro expressions. Always use the macro instead.
7480 Perl_sv_iv(pTHX_ register SV *sv)
7484 return (IV)SvUVX(sv);
7493 A private implementation of the C<SvUVx> macro for compilers which can't
7494 cope with complex macro expressions. Always use the macro instead.
7500 Perl_sv_uv(pTHX_ register SV *sv)
7505 return (UV)SvIVX(sv);
7513 A private implementation of the C<SvNVx> macro for compilers which can't
7514 cope with complex macro expressions. Always use the macro instead.
7520 Perl_sv_nv(pTHX_ register SV *sv)
7527 /* sv_pv() is now a macro using SvPV_nolen();
7528 * this function provided for binary compatibility only
7532 Perl_sv_pv(pTHX_ SV *sv)
7539 return sv_2pv(sv, &n_a);
7545 Use the C<SvPV_nolen> macro instead
7549 A private implementation of the C<SvPV> macro for compilers which can't
7550 cope with complex macro expressions. Always use the macro instead.
7556 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7562 return sv_2pv(sv, lp);
7567 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7573 return sv_2pv_flags(sv, lp, 0);
7576 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7577 * this function provided for binary compatibility only
7581 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7583 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7587 =for apidoc sv_pvn_force
7589 Get a sensible string out of the SV somehow.
7590 A private implementation of the C<SvPV_force> macro for compilers which
7591 can't cope with complex macro expressions. Always use the macro instead.
7593 =for apidoc sv_pvn_force_flags
7595 Get a sensible string out of the SV somehow.
7596 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7597 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7598 implemented in terms of this function.
7599 You normally want to use the various wrapper macros instead: see
7600 C<SvPV_force> and C<SvPV_force_nomg>
7606 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7610 if (SvTHINKFIRST(sv) && !SvROK(sv))
7611 sv_force_normal_flags(sv, 0);
7617 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7618 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7622 s = sv_2pv_flags(sv, lp, flags);
7623 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
7628 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7629 SvGROW(sv, len + 1);
7630 Move(s,SvPVX(sv),len,char);
7635 SvPOK_on(sv); /* validate pointer */
7637 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7638 PTR2UV(sv),SvPVX(sv)));
7644 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
7645 * this function provided for binary compatibility only
7649 Perl_sv_pvbyte(pTHX_ SV *sv)
7651 sv_utf8_downgrade(sv,0);
7656 =for apidoc sv_pvbyte
7658 Use C<SvPVbyte_nolen> instead.
7660 =for apidoc sv_pvbyten
7662 A private implementation of the C<SvPVbyte> macro for compilers
7663 which can't cope with complex macro expressions. Always use the macro
7670 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7672 sv_utf8_downgrade(sv,0);
7673 return sv_pvn(sv,lp);
7677 =for apidoc sv_pvbyten_force
7679 A private implementation of the C<SvPVbytex_force> macro for compilers
7680 which can't cope with complex macro expressions. Always use the macro
7687 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7689 sv_utf8_downgrade(sv,0);
7690 return sv_pvn_force(sv,lp);
7693 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
7694 * this function provided for binary compatibility only
7698 Perl_sv_pvutf8(pTHX_ SV *sv)
7700 sv_utf8_upgrade(sv);
7705 =for apidoc sv_pvutf8
7707 Use the C<SvPVutf8_nolen> macro instead
7709 =for apidoc sv_pvutf8n
7711 A private implementation of the C<SvPVutf8> macro for compilers
7712 which can't cope with complex macro expressions. Always use the macro
7719 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7721 sv_utf8_upgrade(sv);
7722 return sv_pvn(sv,lp);
7726 =for apidoc sv_pvutf8n_force
7728 A private implementation of the C<SvPVutf8_force> macro for compilers
7729 which can't cope with complex macro expressions. Always use the macro
7736 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7738 sv_utf8_upgrade(sv);
7739 return sv_pvn_force(sv,lp);
7743 =for apidoc sv_reftype
7745 Returns a string describing what the SV is a reference to.
7751 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7753 if (ob && SvOBJECT(sv)) {
7754 return HvNAME(SvSTASH(sv));
7757 switch (SvTYPE(sv)) {
7773 case SVt_PVLV: return "LVALUE";
7774 case SVt_PVAV: return "ARRAY";
7775 case SVt_PVHV: return "HASH";
7776 case SVt_PVCV: return "CODE";
7777 case SVt_PVGV: return "GLOB";
7778 case SVt_PVFM: return "FORMAT";
7779 case SVt_PVIO: return "IO";
7780 default: return "UNKNOWN";
7786 =for apidoc sv_isobject
7788 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7789 object. If the SV is not an RV, or if the object is not blessed, then this
7796 Perl_sv_isobject(pTHX_ SV *sv)
7813 Returns a boolean indicating whether the SV is blessed into the specified
7814 class. This does not check for subtypes; use C<sv_derived_from> to verify
7815 an inheritance relationship.
7821 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7833 return strEQ(HvNAME(SvSTASH(sv)), name);
7839 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7840 it will be upgraded to one. If C<classname> is non-null then the new SV will
7841 be blessed in the specified package. The new SV is returned and its
7842 reference count is 1.
7848 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7854 SV_CHECK_THINKFIRST_COW_DROP(rv);
7857 if (SvTYPE(rv) >= SVt_PVMG) {
7858 U32 refcnt = SvREFCNT(rv);
7862 SvREFCNT(rv) = refcnt;
7865 if (SvTYPE(rv) < SVt_RV)
7866 sv_upgrade(rv, SVt_RV);
7867 else if (SvTYPE(rv) > SVt_RV) {
7868 (void)SvOOK_off(rv);
7869 if (SvPVX(rv) && SvLEN(rv))
7870 Safefree(SvPVX(rv));
7880 HV* stash = gv_stashpv(classname, TRUE);
7881 (void)sv_bless(rv, stash);
7887 =for apidoc sv_setref_pv
7889 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7890 argument will be upgraded to an RV. That RV will be modified to point to
7891 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7892 into the SV. The C<classname> argument indicates the package for the
7893 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7894 will be returned and will have a reference count of 1.
7896 Do not use with other Perl types such as HV, AV, SV, CV, because those
7897 objects will become corrupted by the pointer copy process.
7899 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7905 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7908 sv_setsv(rv, &PL_sv_undef);
7912 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7917 =for apidoc sv_setref_iv
7919 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7920 argument will be upgraded to an RV. That RV will be modified to point to
7921 the new SV. The C<classname> argument indicates the package for the
7922 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7923 will be returned and will have a reference count of 1.
7929 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7931 sv_setiv(newSVrv(rv,classname), iv);
7936 =for apidoc sv_setref_uv
7938 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7939 argument will be upgraded to an RV. That RV will be modified to point to
7940 the new SV. The C<classname> argument indicates the package for the
7941 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7942 will be returned and will have a reference count of 1.
7948 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7950 sv_setuv(newSVrv(rv,classname), uv);
7955 =for apidoc sv_setref_nv
7957 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7958 argument will be upgraded to an RV. That RV will be modified to point to
7959 the new SV. The C<classname> argument indicates the package for the
7960 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7961 will be returned and will have a reference count of 1.
7967 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7969 sv_setnv(newSVrv(rv,classname), nv);
7974 =for apidoc sv_setref_pvn
7976 Copies a string into a new SV, optionally blessing the SV. The length of the
7977 string must be specified with C<n>. The C<rv> argument will be upgraded to
7978 an RV. That RV will be modified to point to the new SV. The C<classname>
7979 argument indicates the package for the blessing. Set C<classname> to
7980 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7981 a reference count of 1.
7983 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7989 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7991 sv_setpvn(newSVrv(rv,classname), pv, n);
7996 =for apidoc sv_bless
7998 Blesses an SV into a specified package. The SV must be an RV. The package
7999 must be designated by its stash (see C<gv_stashpv()>). The reference count
8000 of the SV is unaffected.
8006 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
8010 Perl_croak(aTHX_ "Can't bless non-reference value");
8012 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
8013 if (SvREADONLY(tmpRef))
8014 Perl_croak(aTHX_ PL_no_modify);
8015 if (SvOBJECT(tmpRef)) {
8016 if (SvTYPE(tmpRef) != SVt_PVIO)
8018 SvREFCNT_dec(SvSTASH(tmpRef));
8021 SvOBJECT_on(tmpRef);
8022 if (SvTYPE(tmpRef) != SVt_PVIO)
8024 (void)SvUPGRADE(tmpRef, SVt_PVMG);
8025 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
8032 if(SvSMAGICAL(tmpRef))
8033 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
8041 /* Downgrades a PVGV to a PVMG.
8045 S_sv_unglob(pTHX_ SV *sv)
8049 assert(SvTYPE(sv) == SVt_PVGV);
8054 SvREFCNT_dec(GvSTASH(sv));
8055 GvSTASH(sv) = Nullhv;
8057 sv_unmagic(sv, PERL_MAGIC_glob);
8058 Safefree(GvNAME(sv));
8061 /* need to keep SvANY(sv) in the right arena */
8062 xpvmg = new_XPVMG();
8063 StructCopy(SvANY(sv), xpvmg, XPVMG);
8064 del_XPVGV(SvANY(sv));
8067 SvFLAGS(sv) &= ~SVTYPEMASK;
8068 SvFLAGS(sv) |= SVt_PVMG;
8072 =for apidoc sv_unref_flags
8074 Unsets the RV status of the SV, and decrements the reference count of
8075 whatever was being referenced by the RV. This can almost be thought of
8076 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8077 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8078 (otherwise the decrementing is conditional on the reference count being
8079 different from one or the reference being a readonly SV).
8086 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
8090 if (SvWEAKREF(sv)) {
8098 /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
8099 assigned to as BEGIN {$a = \"Foo"} will fail. */
8100 if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
8102 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8103 sv_2mortal(rv); /* Schedule for freeing later */
8107 =for apidoc sv_unref
8109 Unsets the RV status of the SV, and decrements the reference count of
8110 whatever was being referenced by the RV. This can almost be thought of
8111 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
8112 being zero. See C<SvROK_off>.
8118 Perl_sv_unref(pTHX_ SV *sv)
8120 sv_unref_flags(sv, 0);
8124 =for apidoc sv_taint
8126 Taint an SV. Use C<SvTAINTED_on> instead.
8131 Perl_sv_taint(pTHX_ SV *sv)
8133 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
8137 =for apidoc sv_untaint
8139 Untaint an SV. Use C<SvTAINTED_off> instead.
8144 Perl_sv_untaint(pTHX_ SV *sv)
8146 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8147 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8154 =for apidoc sv_tainted
8156 Test an SV for taintedness. Use C<SvTAINTED> instead.
8161 Perl_sv_tainted(pTHX_ SV *sv)
8163 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8164 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8165 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8172 =for apidoc sv_setpviv
8174 Copies an integer into the given SV, also updating its string value.
8175 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8181 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8183 char buf[TYPE_CHARS(UV)];
8185 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8187 sv_setpvn(sv, ptr, ebuf - ptr);
8191 =for apidoc sv_setpviv_mg
8193 Like C<sv_setpviv>, but also handles 'set' magic.
8199 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8201 char buf[TYPE_CHARS(UV)];
8203 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8205 sv_setpvn(sv, ptr, ebuf - ptr);
8209 #if defined(PERL_IMPLICIT_CONTEXT)
8211 /* pTHX_ magic can't cope with varargs, so this is a no-context
8212 * version of the main function, (which may itself be aliased to us).
8213 * Don't access this version directly.
8217 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8221 va_start(args, pat);
8222 sv_vsetpvf(sv, pat, &args);
8226 /* pTHX_ magic can't cope with varargs, so this is a no-context
8227 * version of the main function, (which may itself be aliased to us).
8228 * Don't access this version directly.
8232 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8236 va_start(args, pat);
8237 sv_vsetpvf_mg(sv, pat, &args);
8243 =for apidoc sv_setpvf
8245 Processes its arguments like C<sprintf> and sets an SV to the formatted
8246 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8252 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8255 va_start(args, pat);
8256 sv_vsetpvf(sv, pat, &args);
8260 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8263 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8265 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8269 =for apidoc sv_setpvf_mg
8271 Like C<sv_setpvf>, but also handles 'set' magic.
8277 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8280 va_start(args, pat);
8281 sv_vsetpvf_mg(sv, pat, &args);
8285 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8288 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8290 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8294 #if defined(PERL_IMPLICIT_CONTEXT)
8296 /* pTHX_ magic can't cope with varargs, so this is a no-context
8297 * version of the main function, (which may itself be aliased to us).
8298 * Don't access this version directly.
8302 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8306 va_start(args, pat);
8307 sv_vcatpvf(sv, pat, &args);
8311 /* pTHX_ magic can't cope with varargs, so this is a no-context
8312 * version of the main function, (which may itself be aliased to us).
8313 * Don't access this version directly.
8317 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8321 va_start(args, pat);
8322 sv_vcatpvf_mg(sv, pat, &args);
8328 =for apidoc sv_catpvf
8330 Processes its arguments like C<sprintf> and appends the formatted
8331 output to an SV. If the appended data contains "wide" characters
8332 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8333 and characters >255 formatted with %c), the original SV might get
8334 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
8335 C<SvSETMAGIC()> must typically be called after calling this function
8336 to handle 'set' magic.
8341 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8344 va_start(args, pat);
8345 sv_vcatpvf(sv, pat, &args);
8349 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8352 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8354 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8358 =for apidoc sv_catpvf_mg
8360 Like C<sv_catpvf>, but also handles 'set' magic.
8366 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8369 va_start(args, pat);
8370 sv_vcatpvf_mg(sv, pat, &args);
8374 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
8377 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8379 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8384 =for apidoc sv_vsetpvfn
8386 Works like C<vcatpvfn> but copies the text into the SV instead of
8389 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
8395 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8397 sv_setpvn(sv, "", 0);
8398 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8401 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8404 S_expect_number(pTHX_ char** pattern)
8407 switch (**pattern) {
8408 case '1': case '2': case '3':
8409 case '4': case '5': case '6':
8410 case '7': case '8': case '9':
8411 while (isDIGIT(**pattern))
8412 var = var * 10 + (*(*pattern)++ - '0');
8416 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8419 =for apidoc sv_vcatpvfn
8421 Processes its arguments like C<vsprintf> and appends the formatted output
8422 to an SV. Uses an array of SVs if the C style variable argument list is
8423 missing (NULL). When running with taint checks enabled, indicates via
8424 C<maybe_tainted> if results are untrustworthy (often due to the use of
8427 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
8433 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8440 static char nullstr[] = "(null)";
8442 bool has_utf8; /* has the result utf8? */
8443 bool pat_utf8; /* the pattern is in utf8? */
8446 has_utf8 = pat_utf8 = DO_UTF8(sv);
8448 /* no matter what, this is a string now */
8449 (void)SvPV_force(sv, origlen);
8451 /* special-case "", "%s", and "%_" */
8454 if (patlen == 2 && pat[0] == '%') {
8458 char *s = va_arg(*args, char*);
8459 sv_catpv(sv, s ? s : nullstr);
8461 else if (svix < svmax) {
8462 sv_catsv(sv, *svargs);
8463 if (DO_UTF8(*svargs))
8469 argsv = va_arg(*args, SV*);
8470 sv_catsv(sv, argsv);
8475 /* See comment on '_' below */
8480 if (!args && svix < svmax && DO_UTF8(*svargs))
8483 patend = (char*)pat + patlen;
8484 for (p = (char*)pat; p < patend; p = q) {
8487 bool vectorize = FALSE;
8488 bool vectorarg = FALSE;
8489 bool vec_utf8 = FALSE;
8495 bool has_precis = FALSE;
8498 bool is_utf8 = FALSE; /* is this item utf8? */
8499 #ifdef HAS_LDBL_SPRINTF_BUG
8500 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8501 with sfio - Allen <allens@cpan.org> */
8502 bool fix_ldbl_sprintf_bug = FALSE;
8506 U8 utf8buf[UTF8_MAXLEN+1];
8507 STRLEN esignlen = 0;
8509 char *eptr = Nullch;
8511 /* Times 4: a decimal digit takes more than 3 binary digits.
8512 * NV_DIG: mantissa takes than many decimal digits.
8513 * Plus 32: Playing safe. */
8514 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8515 /* large enough for "%#.#f" --chip */
8516 /* what about long double NVs? --jhi */
8519 U8 *vecstr = Null(U8*);
8526 /* we need a long double target in case HAS_LONG_DOUBLE but
8529 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8538 STRLEN dotstrlen = 1;
8539 I32 efix = 0; /* explicit format parameter index */
8540 I32 ewix = 0; /* explicit width index */
8541 I32 epix = 0; /* explicit precision index */
8542 I32 evix = 0; /* explicit vector index */
8543 bool asterisk = FALSE;
8545 /* echo everything up to the next format specification */
8546 for (q = p; q < patend && *q != '%'; ++q) ;
8548 if (has_utf8 && !pat_utf8)
8549 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8551 sv_catpvn(sv, p, q - p);
8558 We allow format specification elements in this order:
8559 \d+\$ explicit format parameter index
8561 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8562 0 flag (as above): repeated to allow "v02"
8563 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8564 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8566 [%bcdefginopsux_DFOUX] format (mandatory)
8568 if (EXPECT_NUMBER(q, width)) {
8609 if (EXPECT_NUMBER(q, ewix))
8618 if ((vectorarg = asterisk)) {
8630 EXPECT_NUMBER(q, width);
8635 vecsv = va_arg(*args, SV*);
8637 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8638 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
8639 dotstr = SvPVx(vecsv, dotstrlen);
8644 vecsv = va_arg(*args, SV*);
8645 vecstr = (U8*)SvPVx(vecsv,veclen);
8646 vec_utf8 = DO_UTF8(vecsv);
8648 else if (efix ? efix <= svmax : svix < svmax) {
8649 vecsv = svargs[efix ? efix-1 : svix++];
8650 vecstr = (U8*)SvPVx(vecsv,veclen);
8651 vec_utf8 = DO_UTF8(vecsv);
8661 i = va_arg(*args, int);
8663 i = (ewix ? ewix <= svmax : svix < svmax) ?
8664 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8666 width = (i < 0) ? -i : i;
8676 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8678 /* XXX: todo, support specified precision parameter */
8682 i = va_arg(*args, int);
8684 i = (ewix ? ewix <= svmax : svix < svmax)
8685 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8686 precis = (i < 0) ? 0 : i;
8691 precis = precis * 10 + (*q++ - '0');
8700 case 'I': /* Ix, I32x, and I64x */
8702 if (q[1] == '6' && q[2] == '4') {
8708 if (q[1] == '3' && q[2] == '2') {
8718 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8729 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8730 if (*(q + 1) == 'l') { /* lld, llf */
8755 argsv = (efix ? efix <= svmax : svix < svmax) ?
8756 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8763 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8765 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8767 eptr = (char*)utf8buf;
8768 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8779 if (args && !vectorize) {
8780 eptr = va_arg(*args, char*);
8782 #ifdef MACOS_TRADITIONAL
8783 /* On MacOS, %#s format is used for Pascal strings */
8788 elen = strlen(eptr);
8791 elen = sizeof nullstr - 1;
8795 eptr = SvPVx(argsv, elen);
8796 if (DO_UTF8(argsv)) {
8797 if (has_precis && precis < elen) {
8799 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8802 if (width) { /* fudge width (can't fudge elen) */
8803 width += elen - sv_len_utf8(argsv);
8812 * The "%_" hack might have to be changed someday,
8813 * if ISO or ANSI decide to use '_' for something.
8814 * So we keep it hidden from users' code.
8816 if (!args || vectorize)
8818 argsv = va_arg(*args, SV*);
8819 eptr = SvPVx(argsv, elen);
8825 if (has_precis && elen > precis)
8832 if (alt || vectorize)
8834 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8852 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8861 esignbuf[esignlen++] = plus;
8865 case 'h': iv = (short)va_arg(*args, int); break;
8866 default: iv = va_arg(*args, int); break;
8867 case 'l': iv = va_arg(*args, long); break;
8868 case 'V': iv = va_arg(*args, IV); break;
8870 case 'q': iv = va_arg(*args, Quad_t); break;
8877 case 'h': iv = (short)iv; break;
8879 case 'l': iv = (long)iv; break;
8882 case 'q': iv = (Quad_t)iv; break;
8886 if ( !vectorize ) /* we already set uv above */
8891 esignbuf[esignlen++] = plus;
8895 esignbuf[esignlen++] = '-';
8938 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8949 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8950 default: uv = va_arg(*args, unsigned); break;
8951 case 'l': uv = va_arg(*args, unsigned long); break;
8952 case 'V': uv = va_arg(*args, UV); break;
8954 case 'q': uv = va_arg(*args, Quad_t); break;
8961 case 'h': uv = (unsigned short)uv; break;
8963 case 'l': uv = (unsigned long)uv; break;
8966 case 'q': uv = (Quad_t)uv; break;
8972 eptr = ebuf + sizeof ebuf;
8978 p = (char*)((c == 'X')
8979 ? "0123456789ABCDEF" : "0123456789abcdef");
8985 esignbuf[esignlen++] = '0';
8986 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8992 *--eptr = '0' + dig;
8994 if (alt && *eptr != '0')
9000 *--eptr = '0' + dig;
9003 esignbuf[esignlen++] = '0';
9004 esignbuf[esignlen++] = 'b';
9007 default: /* it had better be ten or less */
9008 #if defined(PERL_Y2KWARN)
9009 if (ckWARN(WARN_Y2K)) {
9011 char *s = SvPV(sv,n);
9012 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
9013 && (n == 2 || !isDIGIT(s[n-3])))
9015 Perl_warner(aTHX_ packWARN(WARN_Y2K),
9016 "Possible Y2K bug: %%%c %s",
9017 c, "format string following '19'");
9023 *--eptr = '0' + dig;
9024 } while (uv /= base);
9027 elen = (ebuf + sizeof ebuf) - eptr;
9030 zeros = precis - elen;
9031 else if (precis == 0 && elen == 1 && *eptr == '0')
9036 /* FLOATING POINT */
9039 c = 'f'; /* maybe %F isn't supported here */
9045 /* This is evil, but floating point is even more evil */
9047 /* for SV-style calling, we can only get NV
9048 for C-style calling, we assume %f is double;
9049 for simplicity we allow any of %Lf, %llf, %qf for long double
9053 #if defined(USE_LONG_DOUBLE)
9057 /* [perl #20339] - we should accept and ignore %lf rather than die */
9061 #if defined(USE_LONG_DOUBLE)
9062 intsize = args ? 0 : 'q';
9066 #if defined(HAS_LONG_DOUBLE)
9075 /* now we need (long double) if intsize == 'q', else (double) */
9076 nv = (args && !vectorize) ?
9077 #if LONG_DOUBLESIZE > DOUBLESIZE
9079 va_arg(*args, long double) :
9080 va_arg(*args, double)
9082 va_arg(*args, double)
9088 if (c != 'e' && c != 'E') {
9090 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9091 will cast our (long double) to (double) */
9092 (void)Perl_frexp(nv, &i);
9093 if (i == PERL_INT_MIN)
9094 Perl_die(aTHX_ "panic: frexp");
9096 need = BIT_DIGITS(i);
9098 need += has_precis ? precis : 6; /* known default */
9103 #ifdef HAS_LDBL_SPRINTF_BUG
9104 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9105 with sfio - Allen <allens@cpan.org> */
9108 # define MY_DBL_MAX DBL_MAX
9109 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9110 # if DOUBLESIZE >= 8
9111 # define MY_DBL_MAX 1.7976931348623157E+308L
9113 # define MY_DBL_MAX 3.40282347E+38L
9117 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9118 # define MY_DBL_MAX_BUG 1L
9120 # define MY_DBL_MAX_BUG MY_DBL_MAX
9124 # define MY_DBL_MIN DBL_MIN
9125 # else /* XXX guessing! -Allen */
9126 # if DOUBLESIZE >= 8
9127 # define MY_DBL_MIN 2.2250738585072014E-308L
9129 # define MY_DBL_MIN 1.17549435E-38L
9133 if ((intsize == 'q') && (c == 'f') &&
9134 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9136 /* it's going to be short enough that
9137 * long double precision is not needed */
9139 if ((nv <= 0L) && (nv >= -0L))
9140 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9142 /* would use Perl_fp_class as a double-check but not
9143 * functional on IRIX - see perl.h comments */
9145 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9146 /* It's within the range that a double can represent */
9147 #if defined(DBL_MAX) && !defined(DBL_MIN)
9148 if ((nv >= ((long double)1/DBL_MAX)) ||
9149 (nv <= (-(long double)1/DBL_MAX)))
9151 fix_ldbl_sprintf_bug = TRUE;
9154 if (fix_ldbl_sprintf_bug == TRUE) {
9164 # undef MY_DBL_MAX_BUG
9167 #endif /* HAS_LDBL_SPRINTF_BUG */
9169 need += 20; /* fudge factor */
9170 if (PL_efloatsize < need) {
9171 Safefree(PL_efloatbuf);
9172 PL_efloatsize = need + 20; /* more fudge */
9173 New(906, PL_efloatbuf, PL_efloatsize, char);
9174 PL_efloatbuf[0] = '\0';
9177 eptr = ebuf + sizeof ebuf;
9180 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9181 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9182 if (intsize == 'q') {
9183 /* Copy the one or more characters in a long double
9184 * format before the 'base' ([efgEFG]) character to
9185 * the format string. */
9186 static char const prifldbl[] = PERL_PRIfldbl;
9187 char const *p = prifldbl + sizeof(prifldbl) - 3;
9188 while (p >= prifldbl) { *--eptr = *p--; }
9193 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9198 do { *--eptr = '0' + (base % 10); } while (base /= 10);
9210 /* No taint. Otherwise we are in the strange situation
9211 * where printf() taints but print($float) doesn't.
9213 #if defined(HAS_LONG_DOUBLE)
9215 (void)sprintf(PL_efloatbuf, eptr, nv);
9217 (void)sprintf(PL_efloatbuf, eptr, (double)nv);
9219 (void)sprintf(PL_efloatbuf, eptr, nv);
9221 eptr = PL_efloatbuf;
9222 elen = strlen(PL_efloatbuf);
9228 i = SvCUR(sv) - origlen;
9229 if (args && !vectorize) {
9231 case 'h': *(va_arg(*args, short*)) = i; break;
9232 default: *(va_arg(*args, int*)) = i; break;
9233 case 'l': *(va_arg(*args, long*)) = i; break;
9234 case 'V': *(va_arg(*args, IV*)) = i; break;
9236 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9241 sv_setuv_mg(argsv, (UV)i);
9243 continue; /* not "break" */
9249 if (!args && ckWARN(WARN_PRINTF) &&
9250 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9251 SV *msg = sv_newmortal();
9252 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9253 (PL_op->op_type == OP_PRTF) ? "" : "s");
9256 Perl_sv_catpvf(aTHX_ msg,
9257 "\"%%%c\"", c & 0xFF);
9259 Perl_sv_catpvf(aTHX_ msg,
9260 "\"%%\\%03"UVof"\"",
9263 sv_catpv(msg, "end of string");
9264 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9267 /* output mangled stuff ... */
9273 /* ... right here, because formatting flags should not apply */
9274 SvGROW(sv, SvCUR(sv) + elen + 1);
9276 Copy(eptr, p, elen, char);
9279 SvCUR(sv) = p - SvPVX(sv);
9281 continue; /* not "break" */
9284 if (is_utf8 != has_utf8) {
9287 sv_utf8_upgrade(sv);
9290 SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9291 sv_utf8_upgrade(nsv);
9295 SvGROW(sv, SvCUR(sv) + elen + 1);
9300 have = esignlen + zeros + elen;
9301 need = (have > width ? have : width);
9304 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9306 if (esignlen && fill == '0') {
9307 for (i = 0; i < (int)esignlen; i++)
9311 memset(p, fill, gap);
9314 if (esignlen && fill != '0') {
9315 for (i = 0; i < (int)esignlen; i++)
9319 for (i = zeros; i; i--)
9323 Copy(eptr, p, elen, char);
9327 memset(p, ' ', gap);
9332 Copy(dotstr, p, dotstrlen, char);
9336 vectorize = FALSE; /* done iterating over vecstr */
9343 SvCUR(sv) = p - SvPVX(sv);
9351 /* =========================================================================
9353 =head1 Cloning an interpreter
9355 All the macros and functions in this section are for the private use of
9356 the main function, perl_clone().
9358 The foo_dup() functions make an exact copy of an existing foo thinngy.
9359 During the course of a cloning, a hash table is used to map old addresses
9360 to new addresses. The table is created and manipulated with the
9361 ptr_table_* functions.
9365 ============================================================================*/
9368 #if defined(USE_ITHREADS)
9370 #ifndef GpREFCNT_inc
9371 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9375 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9376 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9377 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9378 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9379 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9380 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9381 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9382 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9383 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9384 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9385 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9386 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9387 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9390 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9391 regcomp.c. AMS 20010712 */
9394 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
9398 struct reg_substr_datum *s;
9401 return (REGEXP *)NULL;
9403 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9406 len = r->offsets[0];
9407 npar = r->nparens+1;
9409 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9410 Copy(r->program, ret->program, len+1, regnode);
9412 New(0, ret->startp, npar, I32);
9413 Copy(r->startp, ret->startp, npar, I32);
9414 New(0, ret->endp, npar, I32);
9415 Copy(r->startp, ret->startp, npar, I32);
9417 New(0, ret->substrs, 1, struct reg_substr_data);
9418 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9419 s->min_offset = r->substrs->data[i].min_offset;
9420 s->max_offset = r->substrs->data[i].max_offset;
9421 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9422 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9425 ret->regstclass = NULL;
9428 int count = r->data->count;
9430 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9431 char, struct reg_data);
9432 New(0, d->what, count, U8);
9435 for (i = 0; i < count; i++) {
9436 d->what[i] = r->data->what[i];
9437 switch (d->what[i]) {
9439 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9442 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9445 /* This is cheating. */
9446 New(0, d->data[i], 1, struct regnode_charclass_class);
9447 StructCopy(r->data->data[i], d->data[i],
9448 struct regnode_charclass_class);
9449 ret->regstclass = (regnode*)d->data[i];
9452 /* Compiled op trees are readonly, and can thus be
9453 shared without duplication. */
9454 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9457 d->data[i] = r->data->data[i];
9467 New(0, ret->offsets, 2*len+1, U32);
9468 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9470 ret->precomp = SAVEPV(r->precomp);
9471 ret->refcnt = r->refcnt;
9472 ret->minlen = r->minlen;
9473 ret->prelen = r->prelen;
9474 ret->nparens = r->nparens;
9475 ret->lastparen = r->lastparen;
9476 ret->lastcloseparen = r->lastcloseparen;
9477 ret->reganch = r->reganch;
9479 ret->sublen = r->sublen;
9481 if (RX_MATCH_COPIED(ret))
9482 ret->subbeg = SAVEPV(r->subbeg);
9484 ret->subbeg = Nullch;
9485 #ifdef PERL_COPY_ON_WRITE
9486 ret->saved_copy = Nullsv;
9489 ptr_table_store(PL_ptr_table, r, ret);
9493 /* duplicate a file handle */
9496 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9500 return (PerlIO*)NULL;
9502 /* look for it in the table first */
9503 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9507 /* create anew and remember what it is */
9508 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9509 ptr_table_store(PL_ptr_table, fp, ret);
9513 /* duplicate a directory handle */
9516 Perl_dirp_dup(pTHX_ DIR *dp)
9524 /* duplicate a typeglob */
9527 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9532 /* look for it in the table first */
9533 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9537 /* create anew and remember what it is */
9538 Newz(0, ret, 1, GP);
9539 ptr_table_store(PL_ptr_table, gp, ret);
9542 ret->gp_refcnt = 0; /* must be before any other dups! */
9543 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9544 ret->gp_io = io_dup_inc(gp->gp_io, param);
9545 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9546 ret->gp_av = av_dup_inc(gp->gp_av, param);
9547 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9548 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9549 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9550 ret->gp_cvgen = gp->gp_cvgen;
9551 ret->gp_flags = gp->gp_flags;
9552 ret->gp_line = gp->gp_line;
9553 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9557 /* duplicate a chain of magic */
9560 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9562 MAGIC *mgprev = (MAGIC*)NULL;
9565 return (MAGIC*)NULL;
9566 /* look for it in the table first */
9567 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9571 for (; mg; mg = mg->mg_moremagic) {
9573 Newz(0, nmg, 1, MAGIC);
9575 mgprev->mg_moremagic = nmg;
9578 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9579 nmg->mg_private = mg->mg_private;
9580 nmg->mg_type = mg->mg_type;
9581 nmg->mg_flags = mg->mg_flags;
9582 if (mg->mg_type == PERL_MAGIC_qr) {
9583 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9585 else if(mg->mg_type == PERL_MAGIC_backref) {
9586 AV *av = (AV*) mg->mg_obj;
9589 nmg->mg_obj = (SV*)newAV();
9593 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9598 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9599 ? sv_dup_inc(mg->mg_obj, param)
9600 : sv_dup(mg->mg_obj, param);
9602 nmg->mg_len = mg->mg_len;
9603 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9604 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9605 if (mg->mg_len > 0) {
9606 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9607 if (mg->mg_type == PERL_MAGIC_overload_table &&
9608 AMT_AMAGIC((AMT*)mg->mg_ptr))
9610 AMT *amtp = (AMT*)mg->mg_ptr;
9611 AMT *namtp = (AMT*)nmg->mg_ptr;
9613 for (i = 1; i < NofAMmeth; i++) {
9614 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9618 else if (mg->mg_len == HEf_SVKEY)
9619 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9621 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9622 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9629 /* create a new pointer-mapping table */
9632 Perl_ptr_table_new(pTHX)
9635 Newz(0, tbl, 1, PTR_TBL_t);
9638 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9642 /* map an existing pointer using a table */
9645 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9647 PTR_TBL_ENT_t *tblent;
9648 UV hash = PTR2UV(sv);
9650 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9651 for (; tblent; tblent = tblent->next) {
9652 if (tblent->oldval == sv)
9653 return tblent->newval;
9658 /* add a new entry to a pointer-mapping table */
9661 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9663 PTR_TBL_ENT_t *tblent, **otblent;
9664 /* XXX this may be pessimal on platforms where pointers aren't good
9665 * hash values e.g. if they grow faster in the most significant
9667 UV hash = PTR2UV(oldv);
9671 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9672 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
9673 if (tblent->oldval == oldv) {
9674 tblent->newval = newv;
9678 Newz(0, tblent, 1, PTR_TBL_ENT_t);
9679 tblent->oldval = oldv;
9680 tblent->newval = newv;
9681 tblent->next = *otblent;
9684 if (i && tbl->tbl_items > tbl->tbl_max)
9685 ptr_table_split(tbl);
9688 /* double the hash bucket size of an existing ptr table */
9691 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9693 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9694 UV oldsize = tbl->tbl_max + 1;
9695 UV newsize = oldsize * 2;
9698 Renew(ary, newsize, PTR_TBL_ENT_t*);
9699 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9700 tbl->tbl_max = --newsize;
9702 for (i=0; i < oldsize; i++, ary++) {
9703 PTR_TBL_ENT_t **curentp, **entp, *ent;
9706 curentp = ary + oldsize;
9707 for (entp = ary, ent = *ary; ent; ent = *entp) {
9708 if ((newsize & PTR2UV(ent->oldval)) != i) {
9710 ent->next = *curentp;
9720 /* remove all the entries from a ptr table */
9723 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9725 register PTR_TBL_ENT_t **array;
9726 register PTR_TBL_ENT_t *entry;
9727 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9731 if (!tbl || !tbl->tbl_items) {
9735 array = tbl->tbl_ary;
9742 entry = entry->next;
9746 if (++riter > max) {
9749 entry = array[riter];
9756 /* clear and free a ptr table */
9759 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9764 ptr_table_clear(tbl);
9765 Safefree(tbl->tbl_ary);
9773 /* attempt to make everything in the typeglob readonly */
9776 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9779 SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9781 if (GvIO(gv) || GvFORM(gv)) {
9782 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9784 else if (!GvCV(gv)) {
9788 /* CvPADLISTs cannot be shared */
9789 if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9794 if (!GvUNIQUE(gv)) {
9796 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9797 HvNAME(GvSTASH(gv)), GvNAME(gv));
9803 * write attempts will die with
9804 * "Modification of a read-only value attempted"
9810 SvREADONLY_on(GvSV(gv));
9817 SvREADONLY_on(GvAV(gv));
9824 SvREADONLY_on(GvAV(gv));
9827 return sstr; /* he_dup() will SvREFCNT_inc() */
9830 /* duplicate an SV of any type (including AV, HV etc) */
9833 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9836 SvRV(dstr) = SvWEAKREF(sstr)
9837 ? sv_dup(SvRV(sstr), param)
9838 : sv_dup_inc(SvRV(sstr), param);
9840 else if (SvPVX(sstr)) {
9841 /* Has something there */
9843 /* Normal PV - clone whole allocated space */
9844 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9845 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9846 /* Not that normal - actually sstr is copy on write.
9847 But we are a true, independant SV, so: */
9848 SvREADONLY_off(dstr);
9853 /* Special case - not normally malloced for some reason */
9854 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9855 /* A "shared" PV - clone it as unshared string */
9857 SvREADONLY_off(dstr);
9858 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9861 /* Some other special case - random pointer */
9862 SvPVX(dstr) = SvPVX(sstr);
9868 SvPVX(dstr) = SvPVX(sstr);
9873 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9877 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9879 /* look for it in the table first */
9880 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9884 if(param->flags & CLONEf_JOIN_IN) {
9885 /** We are joining here so we don't want do clone
9886 something that is bad **/
9888 if(SvTYPE(sstr) == SVt_PVHV &&
9890 /** don't clone stashes if they already exist **/
9891 HV* old_stash = gv_stashpv(HvNAME(sstr),0);
9892 return (SV*) old_stash;
9896 /* create anew and remember what it is */
9898 ptr_table_store(PL_ptr_table, sstr, dstr);
9901 SvFLAGS(dstr) = SvFLAGS(sstr);
9902 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9903 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9906 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
9907 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9908 PL_watch_pvx, SvPVX(sstr));
9911 switch (SvTYPE(sstr)) {
9916 SvANY(dstr) = new_XIV();
9917 SvIVX(dstr) = SvIVX(sstr);
9920 SvANY(dstr) = new_XNV();
9921 SvNVX(dstr) = SvNVX(sstr);
9924 SvANY(dstr) = new_XRV();
9925 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9928 SvANY(dstr) = new_XPV();
9929 SvCUR(dstr) = SvCUR(sstr);
9930 SvLEN(dstr) = SvLEN(sstr);
9931 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9934 SvANY(dstr) = new_XPVIV();
9935 SvCUR(dstr) = SvCUR(sstr);
9936 SvLEN(dstr) = SvLEN(sstr);
9937 SvIVX(dstr) = SvIVX(sstr);
9938 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9941 SvANY(dstr) = new_XPVNV();
9942 SvCUR(dstr) = SvCUR(sstr);
9943 SvLEN(dstr) = SvLEN(sstr);
9944 SvIVX(dstr) = SvIVX(sstr);
9945 SvNVX(dstr) = SvNVX(sstr);
9946 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9949 SvANY(dstr) = new_XPVMG();
9950 SvCUR(dstr) = SvCUR(sstr);
9951 SvLEN(dstr) = SvLEN(sstr);
9952 SvIVX(dstr) = SvIVX(sstr);
9953 SvNVX(dstr) = SvNVX(sstr);
9954 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9955 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9956 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9959 SvANY(dstr) = new_XPVBM();
9960 SvCUR(dstr) = SvCUR(sstr);
9961 SvLEN(dstr) = SvLEN(sstr);
9962 SvIVX(dstr) = SvIVX(sstr);
9963 SvNVX(dstr) = SvNVX(sstr);
9964 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9965 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9966 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9967 BmRARE(dstr) = BmRARE(sstr);
9968 BmUSEFUL(dstr) = BmUSEFUL(sstr);
9969 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
9972 SvANY(dstr) = new_XPVLV();
9973 SvCUR(dstr) = SvCUR(sstr);
9974 SvLEN(dstr) = SvLEN(sstr);
9975 SvIVX(dstr) = SvIVX(sstr);
9976 SvNVX(dstr) = SvNVX(sstr);
9977 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9978 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9979 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9980 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
9981 LvTARGLEN(dstr) = LvTARGLEN(sstr);
9982 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
9983 LvTYPE(dstr) = LvTYPE(sstr);
9986 if (GvUNIQUE((GV*)sstr)) {
9988 if ((share = gv_share(sstr, param))) {
9991 ptr_table_store(PL_ptr_table, sstr, dstr);
9993 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9994 HvNAME(GvSTASH(share)), GvNAME(share));
9999 SvANY(dstr) = new_XPVGV();
10000 SvCUR(dstr) = SvCUR(sstr);
10001 SvLEN(dstr) = SvLEN(sstr);
10002 SvIVX(dstr) = SvIVX(sstr);
10003 SvNVX(dstr) = SvNVX(sstr);
10004 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10005 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10006 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10007 GvNAMELEN(dstr) = GvNAMELEN(sstr);
10008 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
10009 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
10010 GvFLAGS(dstr) = GvFLAGS(sstr);
10011 GvGP(dstr) = gp_dup(GvGP(sstr), param);
10012 (void)GpREFCNT_inc(GvGP(dstr));
10015 SvANY(dstr) = new_XPVIO();
10016 SvCUR(dstr) = SvCUR(sstr);
10017 SvLEN(dstr) = SvLEN(sstr);
10018 SvIVX(dstr) = SvIVX(sstr);
10019 SvNVX(dstr) = SvNVX(sstr);
10020 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10021 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10022 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10023 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10024 if (IoOFP(sstr) == IoIFP(sstr))
10025 IoOFP(dstr) = IoIFP(dstr);
10027 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10028 /* PL_rsfp_filters entries have fake IoDIRP() */
10029 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10030 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
10032 IoDIRP(dstr) = IoDIRP(sstr);
10033 IoLINES(dstr) = IoLINES(sstr);
10034 IoPAGE(dstr) = IoPAGE(sstr);
10035 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
10036 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
10037 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
10038 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
10039 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
10040 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
10041 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
10042 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
10043 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
10044 IoTYPE(dstr) = IoTYPE(sstr);
10045 IoFLAGS(dstr) = IoFLAGS(sstr);
10048 SvANY(dstr) = new_XPVAV();
10049 SvCUR(dstr) = SvCUR(sstr);
10050 SvLEN(dstr) = SvLEN(sstr);
10051 SvIVX(dstr) = SvIVX(sstr);
10052 SvNVX(dstr) = SvNVX(sstr);
10053 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10054 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10055 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10056 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10057 if (AvARRAY((AV*)sstr)) {
10058 SV **dst_ary, **src_ary;
10059 SSize_t items = AvFILLp((AV*)sstr) + 1;
10061 src_ary = AvARRAY((AV*)sstr);
10062 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10063 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10064 SvPVX(dstr) = (char*)dst_ary;
10065 AvALLOC((AV*)dstr) = dst_ary;
10066 if (AvREAL((AV*)sstr)) {
10067 while (items-- > 0)
10068 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10071 while (items-- > 0)
10072 *dst_ary++ = sv_dup(*src_ary++, param);
10074 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10075 while (items-- > 0) {
10076 *dst_ary++ = &PL_sv_undef;
10080 SvPVX(dstr) = Nullch;
10081 AvALLOC((AV*)dstr) = (SV**)NULL;
10085 SvANY(dstr) = new_XPVHV();
10086 SvCUR(dstr) = SvCUR(sstr);
10087 SvLEN(dstr) = SvLEN(sstr);
10088 SvIVX(dstr) = SvIVX(sstr);
10089 SvNVX(dstr) = SvNVX(sstr);
10090 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
10091 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
10092 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
10093 if (HvARRAY((HV*)sstr)) {
10095 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10096 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10097 Newz(0, dxhv->xhv_array,
10098 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10099 while (i <= sxhv->xhv_max) {
10100 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10101 (bool)!!HvSHAREKEYS(sstr),
10105 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10106 (bool)!!HvSHAREKEYS(sstr), param);
10109 SvPVX(dstr) = Nullch;
10110 HvEITER((HV*)dstr) = (HE*)NULL;
10112 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
10113 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
10114 /* Record stashes for possible cloning in Perl_clone(). */
10115 if(HvNAME((HV*)dstr))
10116 av_push(param->stashes, dstr);
10119 SvANY(dstr) = new_XPVFM();
10120 FmLINES(dstr) = FmLINES(sstr);
10124 SvANY(dstr) = new_XPVCV();
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 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10134 CvSTART(dstr) = CvSTART(sstr);
10135 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
10136 CvXSUB(dstr) = CvXSUB(sstr);
10137 CvXSUBANY(dstr) = CvXSUBANY(sstr);
10138 if (CvCONST(sstr)) {
10139 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10140 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10141 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
10143 CvGV(dstr) = gv_dup(CvGV(sstr), param);
10144 if (param->flags & CLONEf_COPY_STACKS) {
10145 CvDEPTH(dstr) = CvDEPTH(sstr);
10149 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10150 CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10152 CvWEAKOUTSIDE(sstr)
10153 ? cv_dup( CvOUTSIDE(sstr), param)
10154 : cv_dup_inc(CvOUTSIDE(sstr), param);
10155 CvFLAGS(dstr) = CvFLAGS(sstr);
10156 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10159 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10163 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10169 /* duplicate a context */
10172 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10174 PERL_CONTEXT *ncxs;
10177 return (PERL_CONTEXT*)NULL;
10179 /* look for it in the table first */
10180 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10184 /* create anew and remember what it is */
10185 Newz(56, ncxs, max + 1, PERL_CONTEXT);
10186 ptr_table_store(PL_ptr_table, cxs, ncxs);
10189 PERL_CONTEXT *cx = &cxs[ix];
10190 PERL_CONTEXT *ncx = &ncxs[ix];
10191 ncx->cx_type = cx->cx_type;
10192 if (CxTYPE(cx) == CXt_SUBST) {
10193 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10196 ncx->blk_oldsp = cx->blk_oldsp;
10197 ncx->blk_oldcop = cx->blk_oldcop;
10198 ncx->blk_oldretsp = cx->blk_oldretsp;
10199 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10200 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10201 ncx->blk_oldpm = cx->blk_oldpm;
10202 ncx->blk_gimme = cx->blk_gimme;
10203 switch (CxTYPE(cx)) {
10205 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10206 ? cv_dup_inc(cx->blk_sub.cv, param)
10207 : cv_dup(cx->blk_sub.cv,param));
10208 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10209 ? av_dup_inc(cx->blk_sub.argarray, param)
10211 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10212 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10213 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10214 ncx->blk_sub.lval = cx->blk_sub.lval;
10217 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10218 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10219 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10220 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10221 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10224 ncx->blk_loop.label = cx->blk_loop.label;
10225 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10226 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10227 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10228 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10229 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10230 ? cx->blk_loop.iterdata
10231 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10232 ncx->blk_loop.oldcomppad
10233 = (PAD*)ptr_table_fetch(PL_ptr_table,
10234 cx->blk_loop.oldcomppad);
10235 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10236 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10237 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10238 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10239 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10242 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10243 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10244 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10245 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10257 /* duplicate a stack info structure */
10260 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10265 return (PERL_SI*)NULL;
10267 /* look for it in the table first */
10268 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10272 /* create anew and remember what it is */
10273 Newz(56, nsi, 1, PERL_SI);
10274 ptr_table_store(PL_ptr_table, si, nsi);
10276 nsi->si_stack = av_dup_inc(si->si_stack, param);
10277 nsi->si_cxix = si->si_cxix;
10278 nsi->si_cxmax = si->si_cxmax;
10279 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10280 nsi->si_type = si->si_type;
10281 nsi->si_prev = si_dup(si->si_prev, param);
10282 nsi->si_next = si_dup(si->si_next, param);
10283 nsi->si_markoff = si->si_markoff;
10288 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10289 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10290 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10291 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10292 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10293 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10294 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10295 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10296 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10297 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10298 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10299 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10300 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10301 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10304 #define pv_dup_inc(p) SAVEPV(p)
10305 #define pv_dup(p) SAVEPV(p)
10306 #define svp_dup_inc(p,pp) any_dup(p,pp)
10308 /* map any object to the new equivent - either something in the
10309 * ptr table, or something in the interpreter structure
10313 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
10318 return (void*)NULL;
10320 /* look for it in the table first */
10321 ret = ptr_table_fetch(PL_ptr_table, v);
10325 /* see if it is part of the interpreter structure */
10326 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10327 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10335 /* duplicate the save stack */
10338 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10340 ANY *ss = proto_perl->Tsavestack;
10341 I32 ix = proto_perl->Tsavestack_ix;
10342 I32 max = proto_perl->Tsavestack_max;
10355 void (*dptr) (void*);
10356 void (*dxptr) (pTHX_ void*);
10359 Newz(54, nss, max, ANY);
10363 TOPINT(nss,ix) = i;
10365 case SAVEt_ITEM: /* normal string */
10366 sv = (SV*)POPPTR(ss,ix);
10367 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10368 sv = (SV*)POPPTR(ss,ix);
10369 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10371 case SAVEt_SV: /* scalar reference */
10372 sv = (SV*)POPPTR(ss,ix);
10373 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10374 gv = (GV*)POPPTR(ss,ix);
10375 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10377 case SAVEt_GENERIC_PVREF: /* generic char* */
10378 c = (char*)POPPTR(ss,ix);
10379 TOPPTR(nss,ix) = pv_dup(c);
10380 ptr = POPPTR(ss,ix);
10381 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10383 case SAVEt_SHARED_PVREF: /* char* in shared space */
10384 c = (char*)POPPTR(ss,ix);
10385 TOPPTR(nss,ix) = savesharedpv(c);
10386 ptr = POPPTR(ss,ix);
10387 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10389 case SAVEt_GENERIC_SVREF: /* generic sv */
10390 case SAVEt_SVREF: /* scalar reference */
10391 sv = (SV*)POPPTR(ss,ix);
10392 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10393 ptr = POPPTR(ss,ix);
10394 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10396 case SAVEt_AV: /* array reference */
10397 av = (AV*)POPPTR(ss,ix);
10398 TOPPTR(nss,ix) = av_dup_inc(av, param);
10399 gv = (GV*)POPPTR(ss,ix);
10400 TOPPTR(nss,ix) = gv_dup(gv, param);
10402 case SAVEt_HV: /* hash reference */
10403 hv = (HV*)POPPTR(ss,ix);
10404 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10405 gv = (GV*)POPPTR(ss,ix);
10406 TOPPTR(nss,ix) = gv_dup(gv, param);
10408 case SAVEt_INT: /* int reference */
10409 ptr = POPPTR(ss,ix);
10410 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10411 intval = (int)POPINT(ss,ix);
10412 TOPINT(nss,ix) = intval;
10414 case SAVEt_LONG: /* long reference */
10415 ptr = POPPTR(ss,ix);
10416 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10417 longval = (long)POPLONG(ss,ix);
10418 TOPLONG(nss,ix) = longval;
10420 case SAVEt_I32: /* I32 reference */
10421 case SAVEt_I16: /* I16 reference */
10422 case SAVEt_I8: /* I8 reference */
10423 ptr = POPPTR(ss,ix);
10424 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10426 TOPINT(nss,ix) = i;
10428 case SAVEt_IV: /* IV reference */
10429 ptr = POPPTR(ss,ix);
10430 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10432 TOPIV(nss,ix) = iv;
10434 case SAVEt_SPTR: /* SV* reference */
10435 ptr = POPPTR(ss,ix);
10436 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10437 sv = (SV*)POPPTR(ss,ix);
10438 TOPPTR(nss,ix) = sv_dup(sv, param);
10440 case SAVEt_VPTR: /* random* reference */
10441 ptr = POPPTR(ss,ix);
10442 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10443 ptr = POPPTR(ss,ix);
10444 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10446 case SAVEt_PPTR: /* char* reference */
10447 ptr = POPPTR(ss,ix);
10448 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10449 c = (char*)POPPTR(ss,ix);
10450 TOPPTR(nss,ix) = pv_dup(c);
10452 case SAVEt_HPTR: /* HV* reference */
10453 ptr = POPPTR(ss,ix);
10454 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10455 hv = (HV*)POPPTR(ss,ix);
10456 TOPPTR(nss,ix) = hv_dup(hv, param);
10458 case SAVEt_APTR: /* AV* reference */
10459 ptr = POPPTR(ss,ix);
10460 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10461 av = (AV*)POPPTR(ss,ix);
10462 TOPPTR(nss,ix) = av_dup(av, param);
10465 gv = (GV*)POPPTR(ss,ix);
10466 TOPPTR(nss,ix) = gv_dup(gv, param);
10468 case SAVEt_GP: /* scalar reference */
10469 gp = (GP*)POPPTR(ss,ix);
10470 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10471 (void)GpREFCNT_inc(gp);
10472 gv = (GV*)POPPTR(ss,ix);
10473 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10474 c = (char*)POPPTR(ss,ix);
10475 TOPPTR(nss,ix) = pv_dup(c);
10477 TOPIV(nss,ix) = iv;
10479 TOPIV(nss,ix) = iv;
10482 case SAVEt_MORTALIZESV:
10483 sv = (SV*)POPPTR(ss,ix);
10484 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10487 ptr = POPPTR(ss,ix);
10488 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10489 /* these are assumed to be refcounted properly */
10490 switch (((OP*)ptr)->op_type) {
10492 case OP_LEAVESUBLV:
10496 case OP_LEAVEWRITE:
10497 TOPPTR(nss,ix) = ptr;
10502 TOPPTR(nss,ix) = Nullop;
10507 TOPPTR(nss,ix) = Nullop;
10510 c = (char*)POPPTR(ss,ix);
10511 TOPPTR(nss,ix) = pv_dup_inc(c);
10513 case SAVEt_CLEARSV:
10514 longval = POPLONG(ss,ix);
10515 TOPLONG(nss,ix) = longval;
10518 hv = (HV*)POPPTR(ss,ix);
10519 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10520 c = (char*)POPPTR(ss,ix);
10521 TOPPTR(nss,ix) = pv_dup_inc(c);
10523 TOPINT(nss,ix) = i;
10525 case SAVEt_DESTRUCTOR:
10526 ptr = POPPTR(ss,ix);
10527 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10528 dptr = POPDPTR(ss,ix);
10529 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
10531 case SAVEt_DESTRUCTOR_X:
10532 ptr = POPPTR(ss,ix);
10533 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10534 dxptr = POPDXPTR(ss,ix);
10535 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
10537 case SAVEt_REGCONTEXT:
10540 TOPINT(nss,ix) = i;
10543 case SAVEt_STACK_POS: /* Position on Perl stack */
10545 TOPINT(nss,ix) = i;
10547 case SAVEt_AELEM: /* array element */
10548 sv = (SV*)POPPTR(ss,ix);
10549 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10551 TOPINT(nss,ix) = i;
10552 av = (AV*)POPPTR(ss,ix);
10553 TOPPTR(nss,ix) = av_dup_inc(av, param);
10555 case SAVEt_HELEM: /* hash element */
10556 sv = (SV*)POPPTR(ss,ix);
10557 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10558 sv = (SV*)POPPTR(ss,ix);
10559 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10560 hv = (HV*)POPPTR(ss,ix);
10561 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10564 ptr = POPPTR(ss,ix);
10565 TOPPTR(nss,ix) = ptr;
10569 TOPINT(nss,ix) = i;
10571 case SAVEt_COMPPAD:
10572 av = (AV*)POPPTR(ss,ix);
10573 TOPPTR(nss,ix) = av_dup(av, param);
10576 longval = (long)POPLONG(ss,ix);
10577 TOPLONG(nss,ix) = longval;
10578 ptr = POPPTR(ss,ix);
10579 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10580 sv = (SV*)POPPTR(ss,ix);
10581 TOPPTR(nss,ix) = sv_dup(sv, param);
10584 ptr = POPPTR(ss,ix);
10585 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10586 longval = (long)POPBOOL(ss,ix);
10587 TOPBOOL(nss,ix) = (bool)longval;
10590 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10598 =for apidoc perl_clone
10600 Create and return a new interpreter by cloning the current one.
10602 perl_clone takes these flags as paramters:
10604 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10605 without it we only clone the data and zero the stacks,
10606 with it we copy the stacks and the new perl interpreter is
10607 ready to run at the exact same point as the previous one.
10608 The pseudo-fork code uses COPY_STACKS while the
10609 threads->new doesn't.
10611 CLONEf_KEEP_PTR_TABLE
10612 perl_clone keeps a ptr_table with the pointer of the old
10613 variable as a key and the new variable as a value,
10614 this allows it to check if something has been cloned and not
10615 clone it again but rather just use the value and increase the
10616 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10617 the ptr_table using the function
10618 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10619 reason to keep it around is if you want to dup some of your own
10620 variable who are outside the graph perl scans, example of this
10621 code is in threads.xs create
10624 This is a win32 thing, it is ignored on unix, it tells perls
10625 win32host code (which is c++) to clone itself, this is needed on
10626 win32 if you want to run two threads at the same time,
10627 if you just want to do some stuff in a separate perl interpreter
10628 and then throw it away and return to the original one,
10629 you don't need to do anything.
10634 /* XXX the above needs expanding by someone who actually understands it ! */
10635 EXTERN_C PerlInterpreter *
10636 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10639 perl_clone(PerlInterpreter *proto_perl, UV flags)
10641 #ifdef PERL_IMPLICIT_SYS
10643 /* perlhost.h so we need to call into it
10644 to clone the host, CPerlHost should have a c interface, sky */
10646 if (flags & CLONEf_CLONE_HOST) {
10647 return perl_clone_host(proto_perl,flags);
10649 return perl_clone_using(proto_perl, flags,
10651 proto_perl->IMemShared,
10652 proto_perl->IMemParse,
10654 proto_perl->IStdIO,
10658 proto_perl->IProc);
10662 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10663 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10664 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10665 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10666 struct IPerlDir* ipD, struct IPerlSock* ipS,
10667 struct IPerlProc* ipP)
10669 /* XXX many of the string copies here can be optimized if they're
10670 * constants; they need to be allocated as common memory and just
10671 * their pointers copied. */
10674 CLONE_PARAMS clone_params;
10675 CLONE_PARAMS* param = &clone_params;
10677 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10678 PERL_SET_THX(my_perl);
10681 Poison(my_perl, 1, PerlInterpreter);
10686 PL_sig_pending = 0;
10687 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10688 # else /* !DEBUGGING */
10689 Zero(my_perl, 1, PerlInterpreter);
10690 # endif /* DEBUGGING */
10692 /* host pointers */
10694 PL_MemShared = ipMS;
10695 PL_MemParse = ipMP;
10702 #else /* !PERL_IMPLICIT_SYS */
10704 CLONE_PARAMS clone_params;
10705 CLONE_PARAMS* param = &clone_params;
10706 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10707 PERL_SET_THX(my_perl);
10712 Poison(my_perl, 1, PerlInterpreter);
10717 PL_sig_pending = 0;
10718 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10719 # else /* !DEBUGGING */
10720 Zero(my_perl, 1, PerlInterpreter);
10721 # endif /* DEBUGGING */
10722 #endif /* PERL_IMPLICIT_SYS */
10723 param->flags = flags;
10724 param->proto_perl = proto_perl;
10727 PL_xiv_arenaroot = NULL;
10728 PL_xiv_root = NULL;
10729 PL_xnv_arenaroot = NULL;
10730 PL_xnv_root = NULL;
10731 PL_xrv_arenaroot = NULL;
10732 PL_xrv_root = NULL;
10733 PL_xpv_arenaroot = NULL;
10734 PL_xpv_root = NULL;
10735 PL_xpviv_arenaroot = NULL;
10736 PL_xpviv_root = NULL;
10737 PL_xpvnv_arenaroot = NULL;
10738 PL_xpvnv_root = NULL;
10739 PL_xpvcv_arenaroot = NULL;
10740 PL_xpvcv_root = NULL;
10741 PL_xpvav_arenaroot = NULL;
10742 PL_xpvav_root = NULL;
10743 PL_xpvhv_arenaroot = NULL;
10744 PL_xpvhv_root = NULL;
10745 PL_xpvmg_arenaroot = NULL;
10746 PL_xpvmg_root = NULL;
10747 PL_xpvlv_arenaroot = NULL;
10748 PL_xpvlv_root = NULL;
10749 PL_xpvbm_arenaroot = NULL;
10750 PL_xpvbm_root = NULL;
10751 PL_he_arenaroot = NULL;
10753 PL_nice_chunk = NULL;
10754 PL_nice_chunk_size = 0;
10756 PL_sv_objcount = 0;
10757 PL_sv_root = Nullsv;
10758 PL_sv_arenaroot = Nullsv;
10760 PL_debug = proto_perl->Idebug;
10762 #ifdef USE_REENTRANT_API
10763 Perl_reentrant_init(aTHX);
10766 /* create SV map for pointer relocation */
10767 PL_ptr_table = ptr_table_new();
10769 /* initialize these special pointers as early as possible */
10770 SvANY(&PL_sv_undef) = NULL;
10771 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10772 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10773 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10775 SvANY(&PL_sv_no) = new_XPVNV();
10776 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10777 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10778 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
10779 SvCUR(&PL_sv_no) = 0;
10780 SvLEN(&PL_sv_no) = 1;
10781 SvNVX(&PL_sv_no) = 0;
10782 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10784 SvANY(&PL_sv_yes) = new_XPVNV();
10785 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10786 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10787 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
10788 SvCUR(&PL_sv_yes) = 1;
10789 SvLEN(&PL_sv_yes) = 2;
10790 SvNVX(&PL_sv_yes) = 1;
10791 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10793 /* create (a non-shared!) shared string table */
10794 PL_strtab = newHV();
10795 HvSHAREKEYS_off(PL_strtab);
10796 hv_ksplit(PL_strtab, 512);
10797 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10799 PL_compiling = proto_perl->Icompiling;
10801 /* These two PVs will be free'd special way so must set them same way op.c does */
10802 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10803 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10805 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10806 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10808 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10809 if (!specialWARN(PL_compiling.cop_warnings))
10810 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10811 if (!specialCopIO(PL_compiling.cop_io))
10812 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10813 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10815 /* pseudo environmental stuff */
10816 PL_origargc = proto_perl->Iorigargc;
10817 PL_origargv = proto_perl->Iorigargv;
10819 param->stashes = newAV(); /* Setup array of objects to call clone on */
10821 #ifdef PERLIO_LAYERS
10822 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10823 PerlIO_clone(aTHX_ proto_perl, param);
10826 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10827 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10828 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10829 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10830 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10831 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10834 PL_minus_c = proto_perl->Iminus_c;
10835 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10836 PL_localpatches = proto_perl->Ilocalpatches;
10837 PL_splitstr = proto_perl->Isplitstr;
10838 PL_preprocess = proto_perl->Ipreprocess;
10839 PL_minus_n = proto_perl->Iminus_n;
10840 PL_minus_p = proto_perl->Iminus_p;
10841 PL_minus_l = proto_perl->Iminus_l;
10842 PL_minus_a = proto_perl->Iminus_a;
10843 PL_minus_F = proto_perl->Iminus_F;
10844 PL_doswitches = proto_perl->Idoswitches;
10845 PL_dowarn = proto_perl->Idowarn;
10846 PL_doextract = proto_perl->Idoextract;
10847 PL_sawampersand = proto_perl->Isawampersand;
10848 PL_unsafe = proto_perl->Iunsafe;
10849 PL_inplace = SAVEPV(proto_perl->Iinplace);
10850 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10851 PL_perldb = proto_perl->Iperldb;
10852 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10853 PL_exit_flags = proto_perl->Iexit_flags;
10855 /* magical thingies */
10856 /* XXX time(&PL_basetime) when asked for? */
10857 PL_basetime = proto_perl->Ibasetime;
10858 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10860 PL_maxsysfd = proto_perl->Imaxsysfd;
10861 PL_multiline = proto_perl->Imultiline;
10862 PL_statusvalue = proto_perl->Istatusvalue;
10864 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10866 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10868 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10869 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10870 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10872 /* Clone the regex array */
10873 PL_regex_padav = newAV();
10875 I32 len = av_len((AV*)proto_perl->Iregex_padav);
10876 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10877 av_push(PL_regex_padav,
10878 sv_dup_inc(regexen[0],param));
10879 for(i = 1; i <= len; i++) {
10880 if(SvREPADTMP(regexen[i])) {
10881 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10883 av_push(PL_regex_padav,
10885 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10886 SvIVX(regexen[i])), param)))
10891 PL_regex_pad = AvARRAY(PL_regex_padav);
10893 /* shortcuts to various I/O objects */
10894 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10895 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10896 PL_defgv = gv_dup(proto_perl->Idefgv, param);
10897 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
10898 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
10899 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
10901 /* shortcuts to regexp stuff */
10902 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
10904 /* shortcuts to misc objects */
10905 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
10907 /* shortcuts to debugging objects */
10908 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
10909 PL_DBline = gv_dup(proto_perl->IDBline, param);
10910 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
10911 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
10912 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
10913 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
10914 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
10915 PL_lineary = av_dup(proto_perl->Ilineary, param);
10916 PL_dbargs = av_dup(proto_perl->Idbargs, param);
10918 /* symbol tables */
10919 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
10920 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
10921 PL_debstash = hv_dup(proto_perl->Idebstash, param);
10922 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
10923 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
10925 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
10926 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
10927 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
10928 PL_endav = av_dup_inc(proto_perl->Iendav, param);
10929 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
10930 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
10932 PL_sub_generation = proto_perl->Isub_generation;
10934 /* funky return mechanisms */
10935 PL_forkprocess = proto_perl->Iforkprocess;
10937 /* subprocess state */
10938 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
10940 /* internal state */
10941 PL_tainting = proto_perl->Itainting;
10942 PL_maxo = proto_perl->Imaxo;
10943 if (proto_perl->Iop_mask)
10944 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10946 PL_op_mask = Nullch;
10947 /* PL_asserting = proto_perl->Iasserting; */
10949 /* current interpreter roots */
10950 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
10951 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
10952 PL_main_start = proto_perl->Imain_start;
10953 PL_eval_root = proto_perl->Ieval_root;
10954 PL_eval_start = proto_perl->Ieval_start;
10956 /* runtime control stuff */
10957 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10958 PL_copline = proto_perl->Icopline;
10960 PL_filemode = proto_perl->Ifilemode;
10961 PL_lastfd = proto_perl->Ilastfd;
10962 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
10965 PL_gensym = proto_perl->Igensym;
10966 PL_preambled = proto_perl->Ipreambled;
10967 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
10968 PL_laststatval = proto_perl->Ilaststatval;
10969 PL_laststype = proto_perl->Ilaststype;
10970 PL_mess_sv = Nullsv;
10972 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
10973 PL_ofmt = SAVEPV(proto_perl->Iofmt);
10975 /* interpreter atexit processing */
10976 PL_exitlistlen = proto_perl->Iexitlistlen;
10977 if (PL_exitlistlen) {
10978 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10979 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10982 PL_exitlist = (PerlExitListEntry*)NULL;
10983 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
10984 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
10985 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10987 PL_profiledata = NULL;
10988 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
10989 /* PL_rsfp_filters entries have fake IoDIRP() */
10990 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
10992 PL_compcv = cv_dup(proto_perl->Icompcv, param);
10994 PAD_CLONE_VARS(proto_perl, param);
10996 #ifdef HAVE_INTERP_INTERN
10997 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11000 /* more statics moved here */
11001 PL_generation = proto_perl->Igeneration;
11002 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11004 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11005 PL_in_clean_all = proto_perl->Iin_clean_all;
11007 PL_uid = proto_perl->Iuid;
11008 PL_euid = proto_perl->Ieuid;
11009 PL_gid = proto_perl->Igid;
11010 PL_egid = proto_perl->Iegid;
11011 PL_nomemok = proto_perl->Inomemok;
11012 PL_an = proto_perl->Ian;
11013 PL_op_seqmax = proto_perl->Iop_seqmax;
11014 PL_evalseq = proto_perl->Ievalseq;
11015 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11016 PL_origalen = proto_perl->Iorigalen;
11017 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11018 PL_osname = SAVEPV(proto_perl->Iosname);
11019 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
11020 PL_sighandlerp = proto_perl->Isighandlerp;
11023 PL_runops = proto_perl->Irunops;
11025 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11028 PL_cshlen = proto_perl->Icshlen;
11029 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11032 PL_lex_state = proto_perl->Ilex_state;
11033 PL_lex_defer = proto_perl->Ilex_defer;
11034 PL_lex_expect = proto_perl->Ilex_expect;
11035 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11036 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11037 PL_lex_starts = proto_perl->Ilex_starts;
11038 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11039 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11040 PL_lex_op = proto_perl->Ilex_op;
11041 PL_lex_inpat = proto_perl->Ilex_inpat;
11042 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11043 PL_lex_brackets = proto_perl->Ilex_brackets;
11044 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11045 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11046 PL_lex_casemods = proto_perl->Ilex_casemods;
11047 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11048 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11050 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11051 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11052 PL_nexttoke = proto_perl->Inexttoke;
11054 /* XXX This is probably masking the deeper issue of why
11055 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11056 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11057 * (A little debugging with a watchpoint on it may help.)
11059 if (SvANY(proto_perl->Ilinestr)) {
11060 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11061 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11062 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11063 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11064 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11065 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11066 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11067 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11068 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11071 PL_linestr = NEWSV(65,79);
11072 sv_upgrade(PL_linestr,SVt_PVIV);
11073 sv_setpvn(PL_linestr,"",0);
11074 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11076 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11077 PL_pending_ident = proto_perl->Ipending_ident;
11078 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11080 PL_expect = proto_perl->Iexpect;
11082 PL_multi_start = proto_perl->Imulti_start;
11083 PL_multi_end = proto_perl->Imulti_end;
11084 PL_multi_open = proto_perl->Imulti_open;
11085 PL_multi_close = proto_perl->Imulti_close;
11087 PL_error_count = proto_perl->Ierror_count;
11088 PL_subline = proto_perl->Isubline;
11089 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11091 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11092 if (SvANY(proto_perl->Ilinestr)) {
11093 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11094 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11095 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11096 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11097 PL_last_lop_op = proto_perl->Ilast_lop_op;
11100 PL_last_uni = SvPVX(PL_linestr);
11101 PL_last_lop = SvPVX(PL_linestr);
11102 PL_last_lop_op = 0;
11104 PL_in_my = proto_perl->Iin_my;
11105 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11107 PL_cryptseen = proto_perl->Icryptseen;
11110 PL_hints = proto_perl->Ihints;
11112 PL_amagic_generation = proto_perl->Iamagic_generation;
11114 #ifdef USE_LOCALE_COLLATE
11115 PL_collation_ix = proto_perl->Icollation_ix;
11116 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11117 PL_collation_standard = proto_perl->Icollation_standard;
11118 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11119 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11120 #endif /* USE_LOCALE_COLLATE */
11122 #ifdef USE_LOCALE_NUMERIC
11123 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11124 PL_numeric_standard = proto_perl->Inumeric_standard;
11125 PL_numeric_local = proto_perl->Inumeric_local;
11126 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11127 #endif /* !USE_LOCALE_NUMERIC */
11129 /* utf8 character classes */
11130 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11131 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11132 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11133 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11134 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11135 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11136 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11137 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11138 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11139 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11140 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11141 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11142 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11143 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11144 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11145 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11146 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11147 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11148 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11149 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11152 PL_last_swash_hv = Nullhv; /* reinits on demand */
11153 PL_last_swash_klen = 0;
11154 PL_last_swash_key[0]= '\0';
11155 PL_last_swash_tmps = (U8*)NULL;
11156 PL_last_swash_slen = 0;
11158 /* perly.c globals */
11159 PL_yydebug = proto_perl->Iyydebug;
11160 PL_yynerrs = proto_perl->Iyynerrs;
11161 PL_yyerrflag = proto_perl->Iyyerrflag;
11162 PL_yychar = proto_perl->Iyychar;
11163 PL_yyval = proto_perl->Iyyval;
11164 PL_yylval = proto_perl->Iyylval;
11166 PL_glob_index = proto_perl->Iglob_index;
11167 PL_srand_called = proto_perl->Isrand_called;
11168 PL_uudmap['M'] = 0; /* reinits on demand */
11169 PL_bitcount = Nullch; /* reinits on demand */
11171 if (proto_perl->Ipsig_pend) {
11172 Newz(0, PL_psig_pend, SIG_SIZE, int);
11175 PL_psig_pend = (int*)NULL;
11178 if (proto_perl->Ipsig_ptr) {
11179 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
11180 Newz(0, PL_psig_name, SIG_SIZE, SV*);
11181 for (i = 1; i < SIG_SIZE; i++) {
11182 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11183 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11187 PL_psig_ptr = (SV**)NULL;
11188 PL_psig_name = (SV**)NULL;
11191 /* thrdvar.h stuff */
11193 if (flags & CLONEf_COPY_STACKS) {
11194 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11195 PL_tmps_ix = proto_perl->Ttmps_ix;
11196 PL_tmps_max = proto_perl->Ttmps_max;
11197 PL_tmps_floor = proto_perl->Ttmps_floor;
11198 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11200 while (i <= PL_tmps_ix) {
11201 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11205 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11206 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11207 Newz(54, PL_markstack, i, I32);
11208 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11209 - proto_perl->Tmarkstack);
11210 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11211 - proto_perl->Tmarkstack);
11212 Copy(proto_perl->Tmarkstack, PL_markstack,
11213 PL_markstack_ptr - PL_markstack + 1, I32);
11215 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11216 * NOTE: unlike the others! */
11217 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11218 PL_scopestack_max = proto_perl->Tscopestack_max;
11219 Newz(54, PL_scopestack, PL_scopestack_max, I32);
11220 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11222 /* next push_return() sets PL_retstack[PL_retstack_ix]
11223 * NOTE: unlike the others! */
11224 PL_retstack_ix = proto_perl->Tretstack_ix;
11225 PL_retstack_max = proto_perl->Tretstack_max;
11226 Newz(54, PL_retstack, PL_retstack_max, OP*);
11227 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
11229 /* NOTE: si_dup() looks at PL_markstack */
11230 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11232 /* PL_curstack = PL_curstackinfo->si_stack; */
11233 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11234 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11236 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11237 PL_stack_base = AvARRAY(PL_curstack);
11238 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11239 - proto_perl->Tstack_base);
11240 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11242 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11243 * NOTE: unlike the others! */
11244 PL_savestack_ix = proto_perl->Tsavestack_ix;
11245 PL_savestack_max = proto_perl->Tsavestack_max;
11246 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11247 PL_savestack = ss_dup(proto_perl, param);
11251 ENTER; /* perl_destruct() wants to LEAVE; */
11254 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11255 PL_top_env = &PL_start_env;
11257 PL_op = proto_perl->Top;
11260 PL_Xpv = (XPV*)NULL;
11261 PL_na = proto_perl->Tna;
11263 PL_statbuf = proto_perl->Tstatbuf;
11264 PL_statcache = proto_perl->Tstatcache;
11265 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11266 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11268 PL_timesbuf = proto_perl->Ttimesbuf;
11271 PL_tainted = proto_perl->Ttainted;
11272 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11273 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11274 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11275 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11276 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11277 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11278 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11279 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11280 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11282 PL_restartop = proto_perl->Trestartop;
11283 PL_in_eval = proto_perl->Tin_eval;
11284 PL_delaymagic = proto_perl->Tdelaymagic;
11285 PL_dirty = proto_perl->Tdirty;
11286 PL_localizing = proto_perl->Tlocalizing;
11288 #ifdef PERL_FLEXIBLE_EXCEPTIONS
11289 PL_protect = proto_perl->Tprotect;
11291 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11292 PL_av_fetch_sv = Nullsv;
11293 PL_hv_fetch_sv = Nullsv;
11294 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
11295 PL_modcount = proto_perl->Tmodcount;
11296 PL_lastgotoprobe = Nullop;
11297 PL_dumpindent = proto_perl->Tdumpindent;
11299 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11300 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11301 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11302 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11303 PL_sortcxix = proto_perl->Tsortcxix;
11304 PL_efloatbuf = Nullch; /* reinits on demand */
11305 PL_efloatsize = 0; /* reinits on demand */
11309 PL_screamfirst = NULL;
11310 PL_screamnext = NULL;
11311 PL_maxscream = -1; /* reinits on demand */
11312 PL_lastscream = Nullsv;
11314 PL_watchaddr = NULL;
11315 PL_watchok = Nullch;
11317 PL_regdummy = proto_perl->Tregdummy;
11318 PL_regprecomp = Nullch;
11321 PL_colorset = 0; /* reinits PL_colors[] */
11322 /*PL_colors[6] = {0,0,0,0,0,0};*/
11323 PL_reginput = Nullch;
11324 PL_regbol = Nullch;
11325 PL_regeol = Nullch;
11326 PL_regstartp = (I32*)NULL;
11327 PL_regendp = (I32*)NULL;
11328 PL_reglastparen = (U32*)NULL;
11329 PL_regtill = Nullch;
11330 PL_reg_start_tmp = (char**)NULL;
11331 PL_reg_start_tmpl = 0;
11332 PL_regdata = (struct reg_data*)NULL;
11335 PL_reg_eval_set = 0;
11337 PL_regprogram = (regnode*)NULL;
11339 PL_regcc = (CURCUR*)NULL;
11340 PL_reg_call_cc = (struct re_cc_state*)NULL;
11341 PL_reg_re = (regexp*)NULL;
11342 PL_reg_ganch = Nullch;
11343 PL_reg_sv = Nullsv;
11344 PL_reg_match_utf8 = FALSE;
11345 PL_reg_magic = (MAGIC*)NULL;
11347 PL_reg_oldcurpm = (PMOP*)NULL;
11348 PL_reg_curpm = (PMOP*)NULL;
11349 PL_reg_oldsaved = Nullch;
11350 PL_reg_oldsavedlen = 0;
11351 #ifdef PERL_COPY_ON_WRITE
11354 PL_reg_maxiter = 0;
11355 PL_reg_leftiter = 0;
11356 PL_reg_poscache = Nullch;
11357 PL_reg_poscache_size= 0;
11359 /* RE engine - function pointers */
11360 PL_regcompp = proto_perl->Tregcompp;
11361 PL_regexecp = proto_perl->Tregexecp;
11362 PL_regint_start = proto_perl->Tregint_start;
11363 PL_regint_string = proto_perl->Tregint_string;
11364 PL_regfree = proto_perl->Tregfree;
11366 PL_reginterp_cnt = 0;
11367 PL_reg_starttry = 0;
11369 /* Pluggable optimizer */
11370 PL_peepp = proto_perl->Tpeepp;
11372 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11373 ptr_table_free(PL_ptr_table);
11374 PL_ptr_table = NULL;
11377 /* Call the ->CLONE method, if it exists, for each of the stashes
11378 identified by sv_dup() above.
11380 while(av_len(param->stashes) != -1) {
11381 HV* stash = (HV*) av_shift(param->stashes);
11382 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11383 if (cloner && GvCV(cloner)) {
11388 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
11390 call_sv((SV*)GvCV(cloner), G_DISCARD);
11396 SvREFCNT_dec(param->stashes);
11401 #endif /* USE_ITHREADS */
11404 =head1 Unicode Support
11406 =for apidoc sv_recode_to_utf8
11408 The encoding is assumed to be an Encode object, on entry the PV
11409 of the sv is assumed to be octets in that encoding, and the sv
11410 will be converted into Unicode (and UTF-8).
11412 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11413 is not a reference, nothing is done to the sv. If the encoding is not
11414 an C<Encode::XS> Encoding object, bad things will happen.
11415 (See F<lib/encoding.pm> and L<Encode>).
11417 The PV of the sv is returned.
11422 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11424 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11438 Passing sv_yes is wrong - it needs to be or'ed set of constants
11439 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11440 remove converted chars from source.
11442 Both will default the value - let them.
11444 XPUSHs(&PL_sv_yes);
11447 call_method("decode", G_SCALAR);
11451 s = SvPV(uni, len);
11452 if (s != SvPVX(sv)) {
11453 SvGROW(sv, len + 1);
11454 Move(s, SvPVX(sv), len, char);
11455 SvCUR_set(sv, len);
11456 SvPVX(sv)[len] = 0;
11466 =for apidoc sv_cat_decode
11468 The encoding is assumed to be an Encode object, the PV of the ssv is
11469 assumed to be octets in that encoding and decoding the input starts
11470 from the position which (PV + *offset) pointed to. The dsv will be
11471 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11472 when the string tstr appears in decoding output or the input ends on
11473 the PV of the ssv. The value which the offset points will be modified
11474 to the last input position on the ssv.
11476 Returns TRUE if the terminator was found, else returns FALSE.
11481 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11482 SV *ssv, int *offset, char *tstr, int tlen)
11484 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11496 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11497 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11499 call_method("cat_decode", G_SCALAR);
11501 ret = SvTRUE(TOPs);
11502 *offset = SvIV(offsv);
11508 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode.");