3 * Copyright (c) 1991-2001, 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
25 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
28 /* ============================================================================
30 =head1 Allocation and deallocation of SVs.
32 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
33 av, hv...) contains type and reference count information, as well as a
34 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
35 specific to each type.
37 Normally, this allocation is done using arenas, which are approximately
38 1K chunks of memory parcelled up into N heads or bodies. The first slot
39 in each arena is reserved, and is used to hold a link to the next arena.
40 In the case of heads, the unused first slot also contains some flags and
41 a note of the number of slots. Snaked through each arena chain is a
42 linked list of free items; when this becomes empty, an extra arena is
43 allocated and divided up into N items which are threaded into the free
46 The following global variables are associated with arenas:
48 PL_sv_arenaroot pointer to list of SV arenas
49 PL_sv_root pointer to list of free SV structures
51 PL_foo_arenaroot pointer to list of foo arenas,
52 PL_foo_root pointer to list of free foo bodies
53 ... for foo in xiv, xnv, xrv, xpv etc.
55 Note that some of the larger and more rarely used body types (eg xpvio)
56 are not allocated using arenas, but are instead just malloc()/free()ed as
57 required. Also, if PURIFY is defined, arenas are abandoned altogether,
58 with all items individually malloc()ed. In addition, a few SV heads are
59 not allocated from an arena, but are instead directly created as static
60 or auto variables, eg PL_sv_undef.
62 The SV arena serves the secondary purpose of allowing still-live SVs
63 to be located and destroyed during final cleanup.
65 At the lowest level, the macros new_SV() and del_SV() grab and free
66 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
67 to return the SV to the free list with error checking.) new_SV() calls
68 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
69 SVs in the free list have their SvTYPE field set to all ones.
71 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
72 that allocate and return individual body types. Normally these are mapped
73 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
74 instead mapped directly to malloc()/free() if PURIFY is defined. The
75 new/del functions remove from, or add to, the appropriate PL_foo_root
76 list, and call more_xiv() etc to add a new arena if the list is empty.
78 At the time of very final cleanup, sv_free_arenas() is called from
79 perl_destruct() to physically free all the arenas allocated since the
80 start of the interpreter. Note that this also clears PL_he_arenaroot,
81 which is otherwise dealt with in hv.c.
83 Manipulation of any of the PL_*root pointers is protected by enclosing
84 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
85 if threads are enabled.
87 The function visit() scans the SV arenas list, and calls a specified
88 function for each SV it finds which is still live - ie which has an SvTYPE
89 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
90 following functions (specified as [function that calls visit()] / [function
91 called by visit() for each SV]):
93 sv_report_used() / do_report_used()
94 dump all remaining SVs (debugging aid)
96 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
97 Attempt to free all objects pointed to by RVs,
98 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
99 try to do the same for all objects indirectly
100 referenced by typeglobs too. Called once from
101 perl_destruct(), prior to calling sv_clean_all()
104 sv_clean_all() / do_clean_all()
105 SvREFCNT_dec(sv) each remaining SV, possibly
106 triggering an sv_free(). It also sets the
107 SVf_BREAK flag on the SV to indicate that the
108 refcnt has been artificially lowered, and thus
109 stopping sv_free() from giving spurious warnings
110 about SVs which unexpectedly have a refcnt
111 of zero. called repeatedly from perl_destruct()
112 until there are no SVs left.
116 Private API to rest of sv.c
120 new_XIV(), del_XIV(),
121 new_XNV(), del_XNV(),
126 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
131 ============================================================================ */
136 * "A time to plant, and a time to uproot what was planted..."
139 #define plant_SV(p) \
141 SvANY(p) = (void *)PL_sv_root; \
142 SvFLAGS(p) = SVTYPEMASK; \
147 /* sv_mutex must be held while calling uproot_SV() */
148 #define uproot_SV(p) \
151 PL_sv_root = (SV*)SvANY(p); \
156 /* new_SV(): return a new, empty SV head */
172 /* del_SV(): return an empty SV head to the free list */
187 S_del_sv(pTHX_ SV *p)
194 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
196 svend = &sva[SvREFCNT(sva)];
197 if (p >= sv && p < svend)
201 if (ckWARN_d(WARN_INTERNAL))
202 Perl_warner(aTHX_ WARN_INTERNAL,
203 "Attempt to free non-arena SV: 0x%"UVxf,
211 #else /* ! DEBUGGING */
213 #define del_SV(p) plant_SV(p)
215 #endif /* DEBUGGING */
219 =for apidoc sv_add_arena
221 Given a chunk of memory, link it to the head of the list of arenas,
222 and split it into a list of free SVs.
228 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
233 Zero(ptr, size, char);
235 /* The first SV in an arena isn't an SV. */
236 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
237 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
238 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
240 PL_sv_arenaroot = sva;
241 PL_sv_root = sva + 1;
243 svend = &sva[SvREFCNT(sva) - 1];
246 SvANY(sv) = (void *)(SV*)(sv + 1);
247 SvFLAGS(sv) = SVTYPEMASK;
251 SvFLAGS(sv) = SVTYPEMASK;
254 /* make some more SVs by adding another arena */
256 /* sv_mutex must be held while calling more_sv() */
263 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
264 PL_nice_chunk = Nullch;
265 PL_nice_chunk_size = 0;
268 char *chunk; /* must use New here to match call to */
269 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
270 sv_add_arena(chunk, 1008, 0);
276 /* visit(): call the named function for each non-free SV in the arenas. */
279 S_visit(pTHX_ SVFUNC_t f)
286 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
287 svend = &sva[SvREFCNT(sva)];
288 for (sv = sva + 1; sv < svend; ++sv) {
289 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
300 /* called by sv_report_used() for each live SV */
303 do_report_used(pTHX_ SV *sv)
305 if (SvTYPE(sv) != SVTYPEMASK) {
306 PerlIO_printf(Perl_debug_log, "****\n");
313 =for apidoc sv_report_used
315 Dump the contents of all SVs not yet freed. (Debugging aid).
321 Perl_sv_report_used(pTHX)
324 visit(do_report_used);
328 /* called by sv_clean_objs() for each live SV */
331 do_clean_objs(pTHX_ SV *sv)
335 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
336 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
348 /* XXX Might want to check arrays, etc. */
351 /* called by sv_clean_objs() for each live SV */
353 #ifndef DISABLE_DESTRUCTOR_KLUDGE
355 do_clean_named_objs(pTHX_ SV *sv)
357 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
358 if ( SvOBJECT(GvSV(sv)) ||
359 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
360 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
361 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
362 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
364 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
372 =for apidoc sv_clean_objs
374 Attempt to destroy all objects not yet freed
380 Perl_sv_clean_objs(pTHX)
382 PL_in_clean_objs = TRUE;
383 visit(do_clean_objs);
384 #ifndef DISABLE_DESTRUCTOR_KLUDGE
385 /* some barnacles may yet remain, clinging to typeglobs */
386 visit(do_clean_named_objs);
388 PL_in_clean_objs = FALSE;
391 /* called by sv_clean_all() for each live SV */
394 do_clean_all(pTHX_ SV *sv)
396 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
397 SvFLAGS(sv) |= SVf_BREAK;
402 =for apidoc sv_clean_all
404 Decrement the refcnt of each remaining SV, possibly triggering a
405 cleanup. This function may have to be called multiple times to free
406 SVs which are in complex self-referential hierarchies.
412 Perl_sv_clean_all(pTHX)
415 PL_in_clean_all = TRUE;
416 cleaned = visit(do_clean_all);
417 PL_in_clean_all = FALSE;
422 =for apidoc sv_free_arenas
424 Deallocate the memory used by all arenas. Note that all the individual SV
425 heads and bodies within the arenas must already have been freed.
431 Perl_sv_free_arenas(pTHX)
435 XPV *arena, *arenanext;
437 /* Free arenas here, but be careful about fake ones. (We assume
438 contiguity of the fake ones with the corresponding real ones.) */
440 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
441 svanext = (SV*) SvANY(sva);
442 while (svanext && SvFAKE(svanext))
443 svanext = (SV*) SvANY(svanext);
446 Safefree((void *)sva);
449 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
450 arenanext = (XPV*)arena->xpv_pv;
453 PL_xiv_arenaroot = 0;
455 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
456 arenanext = (XPV*)arena->xpv_pv;
459 PL_xnv_arenaroot = 0;
461 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
462 arenanext = (XPV*)arena->xpv_pv;
465 PL_xrv_arenaroot = 0;
467 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
468 arenanext = (XPV*)arena->xpv_pv;
471 PL_xpv_arenaroot = 0;
473 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
474 arenanext = (XPV*)arena->xpv_pv;
477 PL_xpviv_arenaroot = 0;
479 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
480 arenanext = (XPV*)arena->xpv_pv;
483 PL_xpvnv_arenaroot = 0;
485 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
486 arenanext = (XPV*)arena->xpv_pv;
489 PL_xpvcv_arenaroot = 0;
491 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
492 arenanext = (XPV*)arena->xpv_pv;
495 PL_xpvav_arenaroot = 0;
497 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
498 arenanext = (XPV*)arena->xpv_pv;
501 PL_xpvhv_arenaroot = 0;
503 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
504 arenanext = (XPV*)arena->xpv_pv;
507 PL_xpvmg_arenaroot = 0;
509 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
510 arenanext = (XPV*)arena->xpv_pv;
513 PL_xpvlv_arenaroot = 0;
515 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
516 arenanext = (XPV*)arena->xpv_pv;
519 PL_xpvbm_arenaroot = 0;
521 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
522 arenanext = (XPV*)arena->xpv_pv;
528 Safefree(PL_nice_chunk);
529 PL_nice_chunk = Nullch;
530 PL_nice_chunk_size = 0;
536 =for apidoc report_uninit
538 Print appropriate "Use of uninitialized variable" warning
544 Perl_report_uninit(pTHX)
547 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
548 " in ", OP_DESC(PL_op));
550 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
553 /* grab a new IV body from the free list, allocating more if necessary */
564 * See comment in more_xiv() -- RAM.
566 PL_xiv_root = *(IV**)xiv;
568 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
571 /* return an IV body to the free list */
574 S_del_xiv(pTHX_ XPVIV *p)
576 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
578 *(IV**)xiv = PL_xiv_root;
583 /* allocate another arena's worth of IV bodies */
591 New(705, ptr, 1008/sizeof(XPV), XPV);
592 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
593 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
596 xivend = &xiv[1008 / sizeof(IV) - 1];
597 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
599 while (xiv < xivend) {
600 *(IV**)xiv = (IV *)(xiv + 1);
606 /* grab a new NV body from the free list, allocating more if necessary */
616 PL_xnv_root = *(NV**)xnv;
618 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
621 /* return an NV body to the free list */
624 S_del_xnv(pTHX_ XPVNV *p)
626 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
628 *(NV**)xnv = PL_xnv_root;
633 /* allocate another arena's worth of NV bodies */
641 New(711, ptr, 1008/sizeof(XPV), XPV);
642 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
643 PL_xnv_arenaroot = ptr;
646 xnvend = &xnv[1008 / sizeof(NV) - 1];
647 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
649 while (xnv < xnvend) {
650 *(NV**)xnv = (NV*)(xnv + 1);
656 /* grab a new struct xrv from the free list, allocating more if necessary */
666 PL_xrv_root = (XRV*)xrv->xrv_rv;
671 /* return a struct xrv to the free list */
674 S_del_xrv(pTHX_ XRV *p)
677 p->xrv_rv = (SV*)PL_xrv_root;
682 /* allocate another arena's worth of struct xrv */
688 register XRV* xrvend;
690 New(712, ptr, 1008/sizeof(XPV), XPV);
691 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
692 PL_xrv_arenaroot = ptr;
695 xrvend = &xrv[1008 / sizeof(XRV) - 1];
696 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
698 while (xrv < xrvend) {
699 xrv->xrv_rv = (SV*)(xrv + 1);
705 /* grab a new struct xpv from the free list, allocating more if necessary */
715 PL_xpv_root = (XPV*)xpv->xpv_pv;
720 /* return a struct xpv to the free list */
723 S_del_xpv(pTHX_ XPV *p)
726 p->xpv_pv = (char*)PL_xpv_root;
731 /* allocate another arena's worth of struct xpv */
737 register XPV* xpvend;
738 New(713, xpv, 1008/sizeof(XPV), XPV);
739 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
740 PL_xpv_arenaroot = xpv;
742 xpvend = &xpv[1008 / sizeof(XPV) - 1];
744 while (xpv < xpvend) {
745 xpv->xpv_pv = (char*)(xpv + 1);
751 /* grab a new struct xpviv from the free list, allocating more if necessary */
760 xpviv = PL_xpviv_root;
761 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
766 /* return a struct xpviv to the free list */
769 S_del_xpviv(pTHX_ XPVIV *p)
772 p->xpv_pv = (char*)PL_xpviv_root;
777 /* allocate another arena's worth of struct xpviv */
782 register XPVIV* xpviv;
783 register XPVIV* xpvivend;
784 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
785 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
786 PL_xpviv_arenaroot = xpviv;
788 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
789 PL_xpviv_root = ++xpviv;
790 while (xpviv < xpvivend) {
791 xpviv->xpv_pv = (char*)(xpviv + 1);
797 /* grab a new struct xpvnv from the free list, allocating more if necessary */
806 xpvnv = PL_xpvnv_root;
807 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
812 /* return a struct xpvnv to the free list */
815 S_del_xpvnv(pTHX_ XPVNV *p)
818 p->xpv_pv = (char*)PL_xpvnv_root;
823 /* allocate another arena's worth of struct xpvnv */
828 register XPVNV* xpvnv;
829 register XPVNV* xpvnvend;
830 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
831 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
832 PL_xpvnv_arenaroot = xpvnv;
834 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
835 PL_xpvnv_root = ++xpvnv;
836 while (xpvnv < xpvnvend) {
837 xpvnv->xpv_pv = (char*)(xpvnv + 1);
843 /* grab a new struct xpvcv from the free list, allocating more if necessary */
852 xpvcv = PL_xpvcv_root;
853 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
858 /* return a struct xpvcv to the free list */
861 S_del_xpvcv(pTHX_ XPVCV *p)
864 p->xpv_pv = (char*)PL_xpvcv_root;
869 /* allocate another arena's worth of struct xpvcv */
874 register XPVCV* xpvcv;
875 register XPVCV* xpvcvend;
876 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
877 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
878 PL_xpvcv_arenaroot = xpvcv;
880 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
881 PL_xpvcv_root = ++xpvcv;
882 while (xpvcv < xpvcvend) {
883 xpvcv->xpv_pv = (char*)(xpvcv + 1);
889 /* grab a new struct xpvav from the free list, allocating more if necessary */
898 xpvav = PL_xpvav_root;
899 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
904 /* return a struct xpvav to the free list */
907 S_del_xpvav(pTHX_ XPVAV *p)
910 p->xav_array = (char*)PL_xpvav_root;
915 /* allocate another arena's worth of struct xpvav */
920 register XPVAV* xpvav;
921 register XPVAV* xpvavend;
922 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
923 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
924 PL_xpvav_arenaroot = xpvav;
926 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
927 PL_xpvav_root = ++xpvav;
928 while (xpvav < xpvavend) {
929 xpvav->xav_array = (char*)(xpvav + 1);
932 xpvav->xav_array = 0;
935 /* grab a new struct xpvhv from the free list, allocating more if necessary */
944 xpvhv = PL_xpvhv_root;
945 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
950 /* return a struct xpvhv to the free list */
953 S_del_xpvhv(pTHX_ XPVHV *p)
956 p->xhv_array = (char*)PL_xpvhv_root;
961 /* allocate another arena's worth of struct xpvhv */
966 register XPVHV* xpvhv;
967 register XPVHV* xpvhvend;
968 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
969 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
970 PL_xpvhv_arenaroot = xpvhv;
972 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
973 PL_xpvhv_root = ++xpvhv;
974 while (xpvhv < xpvhvend) {
975 xpvhv->xhv_array = (char*)(xpvhv + 1);
978 xpvhv->xhv_array = 0;
981 /* grab a new struct xpvmg from the free list, allocating more if necessary */
990 xpvmg = PL_xpvmg_root;
991 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
996 /* return a struct xpvmg to the free list */
999 S_del_xpvmg(pTHX_ XPVMG *p)
1002 p->xpv_pv = (char*)PL_xpvmg_root;
1007 /* allocate another arena's worth of struct xpvmg */
1012 register XPVMG* xpvmg;
1013 register XPVMG* xpvmgend;
1014 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1015 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1016 PL_xpvmg_arenaroot = xpvmg;
1018 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1019 PL_xpvmg_root = ++xpvmg;
1020 while (xpvmg < xpvmgend) {
1021 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1027 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1036 xpvlv = PL_xpvlv_root;
1037 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1042 /* return a struct xpvlv to the free list */
1045 S_del_xpvlv(pTHX_ XPVLV *p)
1048 p->xpv_pv = (char*)PL_xpvlv_root;
1053 /* allocate another arena's worth of struct xpvlv */
1058 register XPVLV* xpvlv;
1059 register XPVLV* xpvlvend;
1060 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1061 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1062 PL_xpvlv_arenaroot = xpvlv;
1064 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1065 PL_xpvlv_root = ++xpvlv;
1066 while (xpvlv < xpvlvend) {
1067 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1073 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1082 xpvbm = PL_xpvbm_root;
1083 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1088 /* return a struct xpvbm to the free list */
1091 S_del_xpvbm(pTHX_ XPVBM *p)
1094 p->xpv_pv = (char*)PL_xpvbm_root;
1099 /* allocate another arena's worth of struct xpvbm */
1104 register XPVBM* xpvbm;
1105 register XPVBM* xpvbmend;
1106 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1107 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1108 PL_xpvbm_arenaroot = xpvbm;
1110 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1111 PL_xpvbm_root = ++xpvbm;
1112 while (xpvbm < xpvbmend) {
1113 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1120 # define my_safemalloc(s) (void*)safexmalloc(717,s)
1121 # define my_safefree(p) safexfree((char*)p)
1123 # define my_safemalloc(s) (void*)safemalloc(s)
1124 # define my_safefree(p) safefree((char*)p)
1129 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1130 #define del_XIV(p) my_safefree(p)
1132 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1133 #define del_XNV(p) my_safefree(p)
1135 #define new_XRV() my_safemalloc(sizeof(XRV))
1136 #define del_XRV(p) my_safefree(p)
1138 #define new_XPV() my_safemalloc(sizeof(XPV))
1139 #define del_XPV(p) my_safefree(p)
1141 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1142 #define del_XPVIV(p) my_safefree(p)
1144 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1145 #define del_XPVNV(p) my_safefree(p)
1147 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1148 #define del_XPVCV(p) my_safefree(p)
1150 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1151 #define del_XPVAV(p) my_safefree(p)
1153 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1154 #define del_XPVHV(p) my_safefree(p)
1156 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1157 #define del_XPVMG(p) my_safefree(p)
1159 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1160 #define del_XPVLV(p) my_safefree(p)
1162 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1163 #define del_XPVBM(p) my_safefree(p)
1167 #define new_XIV() (void*)new_xiv()
1168 #define del_XIV(p) del_xiv((XPVIV*) p)
1170 #define new_XNV() (void*)new_xnv()
1171 #define del_XNV(p) del_xnv((XPVNV*) p)
1173 #define new_XRV() (void*)new_xrv()
1174 #define del_XRV(p) del_xrv((XRV*) p)
1176 #define new_XPV() (void*)new_xpv()
1177 #define del_XPV(p) del_xpv((XPV *)p)
1179 #define new_XPVIV() (void*)new_xpviv()
1180 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1182 #define new_XPVNV() (void*)new_xpvnv()
1183 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1185 #define new_XPVCV() (void*)new_xpvcv()
1186 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1188 #define new_XPVAV() (void*)new_xpvav()
1189 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1191 #define new_XPVHV() (void*)new_xpvhv()
1192 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1194 #define new_XPVMG() (void*)new_xpvmg()
1195 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1197 #define new_XPVLV() (void*)new_xpvlv()
1198 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1200 #define new_XPVBM() (void*)new_xpvbm()
1201 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1205 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1206 #define del_XPVGV(p) my_safefree(p)
1208 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1209 #define del_XPVFM(p) my_safefree(p)
1211 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1212 #define del_XPVIO(p) my_safefree(p)
1215 =for apidoc sv_upgrade
1217 Upgrade an SV to a more complex form. Generally adds a new body type to the
1218 SV, then copies across as much information as possible from the old body.
1219 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1225 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1235 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
1236 sv_force_normal(sv);
1239 if (SvTYPE(sv) == mt)
1243 (void)SvOOK_off(sv);
1245 switch (SvTYPE(sv)) {
1266 else if (mt < SVt_PVIV)
1283 pv = (char*)SvRV(sv);
1303 else if (mt == SVt_NV)
1314 del_XPVIV(SvANY(sv));
1324 del_XPVNV(SvANY(sv));
1332 magic = SvMAGIC(sv);
1333 stash = SvSTASH(sv);
1334 del_XPVMG(SvANY(sv));
1337 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1342 Perl_croak(aTHX_ "Can't upgrade to undef");
1344 SvANY(sv) = new_XIV();
1348 SvANY(sv) = new_XNV();
1352 SvANY(sv) = new_XRV();
1356 SvANY(sv) = new_XPV();
1362 SvANY(sv) = new_XPVIV();
1372 SvANY(sv) = new_XPVNV();
1380 SvANY(sv) = new_XPVMG();
1386 SvMAGIC(sv) = magic;
1387 SvSTASH(sv) = stash;
1390 SvANY(sv) = new_XPVLV();
1396 SvMAGIC(sv) = magic;
1397 SvSTASH(sv) = stash;
1404 SvANY(sv) = new_XPVAV();
1412 SvMAGIC(sv) = magic;
1413 SvSTASH(sv) = stash;
1419 SvANY(sv) = new_XPVHV();
1425 HvTOTALKEYS(sv) = 0;
1426 HvPLACEHOLDERS(sv) = 0;
1427 SvMAGIC(sv) = magic;
1428 SvSTASH(sv) = stash;
1435 SvANY(sv) = new_XPVCV();
1436 Zero(SvANY(sv), 1, XPVCV);
1442 SvMAGIC(sv) = magic;
1443 SvSTASH(sv) = stash;
1446 SvANY(sv) = new_XPVGV();
1452 SvMAGIC(sv) = magic;
1453 SvSTASH(sv) = stash;
1461 SvANY(sv) = new_XPVBM();
1467 SvMAGIC(sv) = magic;
1468 SvSTASH(sv) = stash;
1474 SvANY(sv) = new_XPVFM();
1475 Zero(SvANY(sv), 1, XPVFM);
1481 SvMAGIC(sv) = magic;
1482 SvSTASH(sv) = stash;
1485 SvANY(sv) = new_XPVIO();
1486 Zero(SvANY(sv), 1, XPVIO);
1492 SvMAGIC(sv) = magic;
1493 SvSTASH(sv) = stash;
1494 IoPAGE_LEN(sv) = 60;
1497 SvFLAGS(sv) &= ~SVTYPEMASK;
1503 =for apidoc sv_backoff
1505 Remove any string offset. You should normally use the C<SvOOK_off> macro
1512 Perl_sv_backoff(pTHX_ register SV *sv)
1516 char *s = SvPVX(sv);
1517 SvLEN(sv) += SvIVX(sv);
1518 SvPVX(sv) -= SvIVX(sv);
1520 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1522 SvFLAGS(sv) &= ~SVf_OOK;
1529 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1530 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1531 Use the C<SvGROW> wrapper instead.
1537 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1541 #ifdef HAS_64K_LIMIT
1542 if (newlen >= 0x10000) {
1543 PerlIO_printf(Perl_debug_log,
1544 "Allocation too large: %"UVxf"\n", (UV)newlen);
1547 #endif /* HAS_64K_LIMIT */
1550 if (SvTYPE(sv) < SVt_PV) {
1551 sv_upgrade(sv, SVt_PV);
1554 else if (SvOOK(sv)) { /* pv is offset? */
1557 if (newlen > SvLEN(sv))
1558 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1559 #ifdef HAS_64K_LIMIT
1560 if (newlen >= 0x10000)
1566 if (newlen > SvLEN(sv)) { /* need more room? */
1567 if (SvLEN(sv) && s) {
1568 #if defined(MYMALLOC) && !defined(LEAKTEST)
1569 STRLEN l = malloced_size((void*)SvPVX(sv));
1575 Renew(s,newlen,char);
1578 /* sv_force_normal_flags() must not try to unshare the new
1579 PVX we allocate below. AMS 20010713 */
1580 if (SvREADONLY(sv) && SvFAKE(sv)) {
1584 New(703, s, newlen, char);
1587 SvLEN_set(sv, newlen);
1593 =for apidoc sv_setiv
1595 Copies an integer into the given SV, upgrading first if necessary.
1596 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1602 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1604 SV_CHECK_THINKFIRST(sv);
1605 switch (SvTYPE(sv)) {
1607 sv_upgrade(sv, SVt_IV);
1610 sv_upgrade(sv, SVt_PVNV);
1614 sv_upgrade(sv, SVt_PVIV);
1623 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1626 (void)SvIOK_only(sv); /* validate number */
1632 =for apidoc sv_setiv_mg
1634 Like C<sv_setiv>, but also handles 'set' magic.
1640 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1647 =for apidoc sv_setuv
1649 Copies an unsigned integer into the given SV, upgrading first if necessary.
1650 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1656 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1658 /* With these two if statements:
1659 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1662 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1664 If you wish to remove them, please benchmark to see what the effect is
1666 if (u <= (UV)IV_MAX) {
1667 sv_setiv(sv, (IV)u);
1676 =for apidoc sv_setuv_mg
1678 Like C<sv_setuv>, but also handles 'set' magic.
1684 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1686 /* With these two if statements:
1687 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1690 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1692 If you wish to remove them, please benchmark to see what the effect is
1694 if (u <= (UV)IV_MAX) {
1695 sv_setiv(sv, (IV)u);
1705 =for apidoc sv_setnv
1707 Copies a double into the given SV, upgrading first if necessary.
1708 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1714 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1716 SV_CHECK_THINKFIRST(sv);
1717 switch (SvTYPE(sv)) {
1720 sv_upgrade(sv, SVt_NV);
1725 sv_upgrade(sv, SVt_PVNV);
1734 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1738 (void)SvNOK_only(sv); /* validate number */
1743 =for apidoc sv_setnv_mg
1745 Like C<sv_setnv>, but also handles 'set' magic.
1751 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1757 /* Print an "isn't numeric" warning, using a cleaned-up,
1758 * printable version of the offending string
1762 S_not_a_number(pTHX_ SV *sv)
1769 dsv = sv_2mortal(newSVpv("", 0));
1770 pv = sv_uni_display(dsv, sv, 10, 0);
1773 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1774 /* each *s can expand to 4 chars + "...\0",
1775 i.e. need room for 8 chars */
1778 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1780 if (ch & 128 && !isPRINT_LC(ch)) {
1789 else if (ch == '\r') {
1793 else if (ch == '\f') {
1797 else if (ch == '\\') {
1801 else if (ch == '\0') {
1805 else if (isPRINT_LC(ch))
1822 Perl_warner(aTHX_ WARN_NUMERIC,
1823 "Argument \"%s\" isn't numeric in %s", pv,
1826 Perl_warner(aTHX_ WARN_NUMERIC,
1827 "Argument \"%s\" isn't numeric", pv);
1831 =for apidoc looks_like_number
1833 Test if the content of an SV looks like a number (or is a number).
1834 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1835 non-numeric warning), even if your atof() doesn't grok them.
1841 Perl_looks_like_number(pTHX_ SV *sv)
1843 register char *sbegin;
1850 else if (SvPOKp(sv))
1851 sbegin = SvPV(sv, len);
1853 return 1; /* Historic. Wrong? */
1854 return grok_number(sbegin, len, NULL);
1857 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1858 until proven guilty, assume that things are not that bad... */
1863 As 64 bit platforms often have an NV that doesn't preserve all bits of
1864 an IV (an assumption perl has been based on to date) it becomes necessary
1865 to remove the assumption that the NV always carries enough precision to
1866 recreate the IV whenever needed, and that the NV is the canonical form.
1867 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1868 precision as a side effect of conversion (which would lead to insanity
1869 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1870 1) to distinguish between IV/UV/NV slots that have cached a valid
1871 conversion where precision was lost and IV/UV/NV slots that have a
1872 valid conversion which has lost no precision
1873 2) to ensure that if a numeric conversion to one form is requested that
1874 would lose precision, the precise conversion (or differently
1875 imprecise conversion) is also performed and cached, to prevent
1876 requests for different numeric formats on the same SV causing
1877 lossy conversion chains. (lossless conversion chains are perfectly
1882 SvIOKp is true if the IV slot contains a valid value
1883 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1884 SvNOKp is true if the NV slot contains a valid value
1885 SvNOK is true only if the NV value is accurate
1888 while converting from PV to NV, check to see if converting that NV to an
1889 IV(or UV) would lose accuracy over a direct conversion from PV to
1890 IV(or UV). If it would, cache both conversions, return NV, but mark
1891 SV as IOK NOKp (ie not NOK).
1893 While converting from PV to IV, check to see if converting that IV to an
1894 NV would lose accuracy over a direct conversion from PV to NV. If it
1895 would, cache both conversions, flag similarly.
1897 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1898 correctly because if IV & NV were set NV *always* overruled.
1899 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1900 changes - now IV and NV together means that the two are interchangeable:
1901 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1903 The benefit of this is that operations such as pp_add know that if
1904 SvIOK is true for both left and right operands, then integer addition
1905 can be used instead of floating point (for cases where the result won't
1906 overflow). Before, floating point was always used, which could lead to
1907 loss of precision compared with integer addition.
1909 * making IV and NV equal status should make maths accurate on 64 bit
1911 * may speed up maths somewhat if pp_add and friends start to use
1912 integers when possible instead of fp. (Hopefully the overhead in
1913 looking for SvIOK and checking for overflow will not outweigh the
1914 fp to integer speedup)
1915 * will slow down integer operations (callers of SvIV) on "inaccurate"
1916 values, as the change from SvIOK to SvIOKp will cause a call into
1917 sv_2iv each time rather than a macro access direct to the IV slot
1918 * should speed up number->string conversion on integers as IV is
1919 favoured when IV and NV are equally accurate
1921 ####################################################################
1922 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1923 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1924 On the other hand, SvUOK is true iff UV.
1925 ####################################################################
1927 Your mileage will vary depending your CPU's relative fp to integer
1931 #ifndef NV_PRESERVES_UV
1932 # define IS_NUMBER_UNDERFLOW_IV 1
1933 # define IS_NUMBER_UNDERFLOW_UV 2
1934 # define IS_NUMBER_IV_AND_UV 2
1935 # define IS_NUMBER_OVERFLOW_IV 4
1936 # define IS_NUMBER_OVERFLOW_UV 5
1938 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1940 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1942 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1944 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));
1945 if (SvNVX(sv) < (NV)IV_MIN) {
1946 (void)SvIOKp_on(sv);
1949 return IS_NUMBER_UNDERFLOW_IV;
1951 if (SvNVX(sv) > (NV)UV_MAX) {
1952 (void)SvIOKp_on(sv);
1956 return IS_NUMBER_OVERFLOW_UV;
1958 (void)SvIOKp_on(sv);
1960 /* Can't use strtol etc to convert this string. (See truth table in
1962 if (SvNVX(sv) <= (UV)IV_MAX) {
1963 SvIVX(sv) = I_V(SvNVX(sv));
1964 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1965 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1967 /* Integer is imprecise. NOK, IOKp */
1969 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1972 SvUVX(sv) = U_V(SvNVX(sv));
1973 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1974 if (SvUVX(sv) == UV_MAX) {
1975 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1976 possibly be preserved by NV. Hence, it must be overflow.
1978 return IS_NUMBER_OVERFLOW_UV;
1980 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1982 /* Integer is imprecise. NOK, IOKp */
1984 return IS_NUMBER_OVERFLOW_IV;
1986 #endif /* !NV_PRESERVES_UV*/
1991 Return the integer value of an SV, doing any necessary string conversion,
1992 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1998 Perl_sv_2iv(pTHX_ register SV *sv)
2002 if (SvGMAGICAL(sv)) {
2007 return I_V(SvNVX(sv));
2009 if (SvPOKp(sv) && SvLEN(sv))
2012 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2013 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2019 if (SvTHINKFIRST(sv)) {
2022 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2023 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2024 return SvIV(tmpstr);
2025 return PTR2IV(SvRV(sv));
2027 if (SvREADONLY(sv) && SvFAKE(sv)) {
2028 sv_force_normal(sv);
2030 if (SvREADONLY(sv) && !SvOK(sv)) {
2031 if (ckWARN(WARN_UNINITIALIZED))
2038 return (IV)(SvUVX(sv));
2045 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2046 * without also getting a cached IV/UV from it at the same time
2047 * (ie PV->NV conversion should detect loss of accuracy and cache
2048 * IV or UV at same time to avoid this. NWC */
2050 if (SvTYPE(sv) == SVt_NV)
2051 sv_upgrade(sv, SVt_PVNV);
2053 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2054 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2055 certainly cast into the IV range at IV_MAX, whereas the correct
2056 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2058 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2059 SvIVX(sv) = I_V(SvNVX(sv));
2060 if (SvNVX(sv) == (NV) SvIVX(sv)
2061 #ifndef NV_PRESERVES_UV
2062 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2063 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2064 /* Don't flag it as "accurately an integer" if the number
2065 came from a (by definition imprecise) NV operation, and
2066 we're outside the range of NV integer precision */
2069 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2070 DEBUG_c(PerlIO_printf(Perl_debug_log,
2071 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2077 /* IV not precise. No need to convert from PV, as NV
2078 conversion would already have cached IV if it detected
2079 that PV->IV would be better than PV->NV->IV
2080 flags already correct - don't set public IOK. */
2081 DEBUG_c(PerlIO_printf(Perl_debug_log,
2082 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2087 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2088 but the cast (NV)IV_MIN rounds to a the value less (more
2089 negative) than IV_MIN which happens to be equal to SvNVX ??
2090 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2091 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2092 (NV)UVX == NVX are both true, but the values differ. :-(
2093 Hopefully for 2s complement IV_MIN is something like
2094 0x8000000000000000 which will be exact. NWC */
2097 SvUVX(sv) = U_V(SvNVX(sv));
2099 (SvNVX(sv) == (NV) SvUVX(sv))
2100 #ifndef NV_PRESERVES_UV
2101 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2102 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2103 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2104 /* Don't flag it as "accurately an integer" if the number
2105 came from a (by definition imprecise) NV operation, and
2106 we're outside the range of NV integer precision */
2112 DEBUG_c(PerlIO_printf(Perl_debug_log,
2113 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2117 return (IV)SvUVX(sv);
2120 else if (SvPOKp(sv) && SvLEN(sv)) {
2122 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2123 /* We want to avoid a possible problem when we cache an IV which
2124 may be later translated to an NV, and the resulting NV is not
2125 the same as the direct translation of the initial string
2126 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2127 be careful to ensure that the value with the .456 is around if the
2128 NV value is requested in the future).
2130 This means that if we cache such an IV, we need to cache the
2131 NV as well. Moreover, we trade speed for space, and do not
2132 cache the NV if we are sure it's not needed.
2135 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2136 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2137 == IS_NUMBER_IN_UV) {
2138 /* It's definitely an integer, only upgrade to PVIV */
2139 if (SvTYPE(sv) < SVt_PVIV)
2140 sv_upgrade(sv, SVt_PVIV);
2142 } else if (SvTYPE(sv) < SVt_PVNV)
2143 sv_upgrade(sv, SVt_PVNV);
2145 /* If NV preserves UV then we only use the UV value if we know that
2146 we aren't going to call atof() below. If NVs don't preserve UVs
2147 then the value returned may have more precision than atof() will
2148 return, even though value isn't perfectly accurate. */
2149 if ((numtype & (IS_NUMBER_IN_UV
2150 #ifdef NV_PRESERVES_UV
2153 )) == IS_NUMBER_IN_UV) {
2154 /* This won't turn off the public IOK flag if it was set above */
2155 (void)SvIOKp_on(sv);
2157 if (!(numtype & IS_NUMBER_NEG)) {
2159 if (value <= (UV)IV_MAX) {
2160 SvIVX(sv) = (IV)value;
2166 /* 2s complement assumption */
2167 if (value <= (UV)IV_MIN) {
2168 SvIVX(sv) = -(IV)value;
2170 /* Too negative for an IV. This is a double upgrade, but
2171 I'm assuming it will be rare. */
2172 if (SvTYPE(sv) < SVt_PVNV)
2173 sv_upgrade(sv, SVt_PVNV);
2177 SvNVX(sv) = -(NV)value;
2182 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2183 will be in the previous block to set the IV slot, and the next
2184 block to set the NV slot. So no else here. */
2186 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2187 != IS_NUMBER_IN_UV) {
2188 /* It wasn't an (integer that doesn't overflow the UV). */
2189 SvNVX(sv) = Atof(SvPVX(sv));
2191 if (! numtype && ckWARN(WARN_NUMERIC))
2194 #if defined(USE_LONG_DOUBLE)
2195 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2196 PTR2UV(sv), SvNVX(sv)));
2198 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2199 PTR2UV(sv), SvNVX(sv)));
2203 #ifdef NV_PRESERVES_UV
2204 (void)SvIOKp_on(sv);
2206 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2207 SvIVX(sv) = I_V(SvNVX(sv));
2208 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2211 /* Integer is imprecise. NOK, IOKp */
2213 /* UV will not work better than IV */
2215 if (SvNVX(sv) > (NV)UV_MAX) {
2217 /* Integer is inaccurate. NOK, IOKp, is UV */
2221 SvUVX(sv) = U_V(SvNVX(sv));
2222 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2223 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2227 /* Integer is imprecise. NOK, IOKp, is UV */
2233 #else /* NV_PRESERVES_UV */
2234 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2235 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2236 /* The IV slot will have been set from value returned by
2237 grok_number above. The NV slot has just been set using
2240 assert (SvIOKp(sv));
2242 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2243 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2244 /* Small enough to preserve all bits. */
2245 (void)SvIOKp_on(sv);
2247 SvIVX(sv) = I_V(SvNVX(sv));
2248 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2250 /* Assumption: first non-preserved integer is < IV_MAX,
2251 this NV is in the preserved range, therefore: */
2252 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2254 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(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);
2258 0 0 already failed to read UV.
2259 0 1 already failed to read UV.
2260 1 0 you won't get here in this case. IV/UV
2261 slot set, public IOK, Atof() unneeded.
2262 1 1 already read UV.
2263 so there's no point in sv_2iuv_non_preserve() attempting
2264 to use atol, strtol, strtoul etc. */
2265 if (sv_2iuv_non_preserve (sv, numtype)
2266 >= IS_NUMBER_OVERFLOW_IV)
2270 #endif /* NV_PRESERVES_UV */
2273 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2275 if (SvTYPE(sv) < SVt_IV)
2276 /* Typically the caller expects that sv_any is not NULL now. */
2277 sv_upgrade(sv, SVt_IV);
2280 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2281 PTR2UV(sv),SvIVX(sv)));
2282 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2288 Return the unsigned integer value of an SV, doing any necessary string
2289 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2296 Perl_sv_2uv(pTHX_ register SV *sv)
2300 if (SvGMAGICAL(sv)) {
2305 return U_V(SvNVX(sv));
2306 if (SvPOKp(sv) && SvLEN(sv))
2309 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2310 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2316 if (SvTHINKFIRST(sv)) {
2319 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2320 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2321 return SvUV(tmpstr);
2322 return PTR2UV(SvRV(sv));
2324 if (SvREADONLY(sv) && SvFAKE(sv)) {
2325 sv_force_normal(sv);
2327 if (SvREADONLY(sv) && !SvOK(sv)) {
2328 if (ckWARN(WARN_UNINITIALIZED))
2338 return (UV)SvIVX(sv);
2342 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2343 * without also getting a cached IV/UV from it at the same time
2344 * (ie PV->NV conversion should detect loss of accuracy and cache
2345 * IV or UV at same time to avoid this. */
2346 /* IV-over-UV optimisation - choose to cache IV if possible */
2348 if (SvTYPE(sv) == SVt_NV)
2349 sv_upgrade(sv, SVt_PVNV);
2351 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2352 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2353 SvIVX(sv) = I_V(SvNVX(sv));
2354 if (SvNVX(sv) == (NV) SvIVX(sv)
2355 #ifndef NV_PRESERVES_UV
2356 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2357 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2358 /* Don't flag it as "accurately an integer" if the number
2359 came from a (by definition imprecise) NV operation, and
2360 we're outside the range of NV integer precision */
2363 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2364 DEBUG_c(PerlIO_printf(Perl_debug_log,
2365 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2371 /* IV not precise. No need to convert from PV, as NV
2372 conversion would already have cached IV if it detected
2373 that PV->IV would be better than PV->NV->IV
2374 flags already correct - don't set public IOK. */
2375 DEBUG_c(PerlIO_printf(Perl_debug_log,
2376 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2381 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2382 but the cast (NV)IV_MIN rounds to a the value less (more
2383 negative) than IV_MIN which happens to be equal to SvNVX ??
2384 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2385 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2386 (NV)UVX == NVX are both true, but the values differ. :-(
2387 Hopefully for 2s complement IV_MIN is something like
2388 0x8000000000000000 which will be exact. NWC */
2391 SvUVX(sv) = U_V(SvNVX(sv));
2393 (SvNVX(sv) == (NV) SvUVX(sv))
2394 #ifndef NV_PRESERVES_UV
2395 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2396 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2397 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2398 /* Don't flag it as "accurately an integer" if the number
2399 came from a (by definition imprecise) NV operation, and
2400 we're outside the range of NV integer precision */
2405 DEBUG_c(PerlIO_printf(Perl_debug_log,
2406 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2412 else if (SvPOKp(sv) && SvLEN(sv)) {
2414 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2416 /* We want to avoid a possible problem when we cache a UV which
2417 may be later translated to an NV, and the resulting NV is not
2418 the translation of the initial data.
2420 This means that if we cache such a UV, we need to cache the
2421 NV as well. Moreover, we trade speed for space, and do not
2422 cache the NV if not needed.
2425 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2426 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2427 == IS_NUMBER_IN_UV) {
2428 /* It's definitely an integer, only upgrade to PVIV */
2429 if (SvTYPE(sv) < SVt_PVIV)
2430 sv_upgrade(sv, SVt_PVIV);
2432 } else if (SvTYPE(sv) < SVt_PVNV)
2433 sv_upgrade(sv, SVt_PVNV);
2435 /* If NV preserves UV then we only use the UV value if we know that
2436 we aren't going to call atof() below. If NVs don't preserve UVs
2437 then the value returned may have more precision than atof() will
2438 return, even though it isn't accurate. */
2439 if ((numtype & (IS_NUMBER_IN_UV
2440 #ifdef NV_PRESERVES_UV
2443 )) == IS_NUMBER_IN_UV) {
2444 /* This won't turn off the public IOK flag if it was set above */
2445 (void)SvIOKp_on(sv);
2447 if (!(numtype & IS_NUMBER_NEG)) {
2449 if (value <= (UV)IV_MAX) {
2450 SvIVX(sv) = (IV)value;
2452 /* it didn't overflow, and it was positive. */
2457 /* 2s complement assumption */
2458 if (value <= (UV)IV_MIN) {
2459 SvIVX(sv) = -(IV)value;
2461 /* Too negative for an IV. This is a double upgrade, but
2462 I'm assuming it will be rare. */
2463 if (SvTYPE(sv) < SVt_PVNV)
2464 sv_upgrade(sv, SVt_PVNV);
2468 SvNVX(sv) = -(NV)value;
2474 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2475 != IS_NUMBER_IN_UV) {
2476 /* It wasn't an integer, or it overflowed the UV. */
2477 SvNVX(sv) = Atof(SvPVX(sv));
2479 if (! numtype && ckWARN(WARN_NUMERIC))
2482 #if defined(USE_LONG_DOUBLE)
2483 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2484 PTR2UV(sv), SvNVX(sv)));
2486 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2487 PTR2UV(sv), SvNVX(sv)));
2490 #ifdef NV_PRESERVES_UV
2491 (void)SvIOKp_on(sv);
2493 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2494 SvIVX(sv) = I_V(SvNVX(sv));
2495 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2498 /* Integer is imprecise. NOK, IOKp */
2500 /* UV will not work better than IV */
2502 if (SvNVX(sv) > (NV)UV_MAX) {
2504 /* Integer is inaccurate. NOK, IOKp, is UV */
2508 SvUVX(sv) = U_V(SvNVX(sv));
2509 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2510 NV preservse UV so can do correct comparison. */
2511 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2515 /* Integer is imprecise. NOK, IOKp, is UV */
2520 #else /* NV_PRESERVES_UV */
2521 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2522 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2523 /* The UV slot will have been set from value returned by
2524 grok_number above. The NV slot has just been set using
2527 assert (SvIOKp(sv));
2529 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2530 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2531 /* Small enough to preserve all bits. */
2532 (void)SvIOKp_on(sv);
2534 SvIVX(sv) = I_V(SvNVX(sv));
2535 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2537 /* Assumption: first non-preserved integer is < IV_MAX,
2538 this NV is in the preserved range, therefore: */
2539 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2541 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(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);
2544 sv_2iuv_non_preserve (sv, numtype);
2546 #endif /* NV_PRESERVES_UV */
2550 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2551 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2554 if (SvTYPE(sv) < SVt_IV)
2555 /* Typically the caller expects that sv_any is not NULL now. */
2556 sv_upgrade(sv, SVt_IV);
2560 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2561 PTR2UV(sv),SvUVX(sv)));
2562 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2568 Return the num value of an SV, doing any necessary string or integer
2569 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2576 Perl_sv_2nv(pTHX_ register SV *sv)
2580 if (SvGMAGICAL(sv)) {
2584 if (SvPOKp(sv) && SvLEN(sv)) {
2585 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2586 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2588 return Atof(SvPVX(sv));
2592 return (NV)SvUVX(sv);
2594 return (NV)SvIVX(sv);
2597 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2598 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2604 if (SvTHINKFIRST(sv)) {
2607 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2608 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2609 return SvNV(tmpstr);
2610 return PTR2NV(SvRV(sv));
2612 if (SvREADONLY(sv) && SvFAKE(sv)) {
2613 sv_force_normal(sv);
2615 if (SvREADONLY(sv) && !SvOK(sv)) {
2616 if (ckWARN(WARN_UNINITIALIZED))
2621 if (SvTYPE(sv) < SVt_NV) {
2622 if (SvTYPE(sv) == SVt_IV)
2623 sv_upgrade(sv, SVt_PVNV);
2625 sv_upgrade(sv, SVt_NV);
2626 #ifdef USE_LONG_DOUBLE
2628 STORE_NUMERIC_LOCAL_SET_STANDARD();
2629 PerlIO_printf(Perl_debug_log,
2630 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2631 PTR2UV(sv), SvNVX(sv));
2632 RESTORE_NUMERIC_LOCAL();
2636 STORE_NUMERIC_LOCAL_SET_STANDARD();
2637 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2638 PTR2UV(sv), SvNVX(sv));
2639 RESTORE_NUMERIC_LOCAL();
2643 else if (SvTYPE(sv) < SVt_PVNV)
2644 sv_upgrade(sv, SVt_PVNV);
2649 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2650 #ifdef NV_PRESERVES_UV
2653 /* Only set the public NV OK flag if this NV preserves the IV */
2654 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2655 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2656 : (SvIVX(sv) == I_V(SvNVX(sv))))
2662 else if (SvPOKp(sv) && SvLEN(sv)) {
2664 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2665 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2667 #ifdef NV_PRESERVES_UV
2668 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2669 == IS_NUMBER_IN_UV) {
2670 /* It's definitely an integer */
2671 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2673 SvNVX(sv) = Atof(SvPVX(sv));
2676 SvNVX(sv) = Atof(SvPVX(sv));
2677 /* Only set the public NV OK flag if this NV preserves the value in
2678 the PV at least as well as an IV/UV would.
2679 Not sure how to do this 100% reliably. */
2680 /* if that shift count is out of range then Configure's test is
2681 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2683 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2684 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2685 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2686 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2687 /* Can't use strtol etc to convert this string, so don't try.
2688 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2691 /* value has been set. It may not be precise. */
2692 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2693 /* 2s complement assumption for (UV)IV_MIN */
2694 SvNOK_on(sv); /* Integer is too negative. */
2699 if (numtype & IS_NUMBER_NEG) {
2700 SvIVX(sv) = -(IV)value;
2701 } else if (value <= (UV)IV_MAX) {
2702 SvIVX(sv) = (IV)value;
2708 if (numtype & IS_NUMBER_NOT_INT) {
2709 /* I believe that even if the original PV had decimals,
2710 they are lost beyond the limit of the FP precision.
2711 However, neither is canonical, so both only get p
2712 flags. NWC, 2000/11/25 */
2713 /* Both already have p flags, so do nothing */
2716 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2717 if (SvIVX(sv) == I_V(nv)) {
2722 /* It had no "." so it must be integer. */
2725 /* between IV_MAX and NV(UV_MAX).
2726 Could be slightly > UV_MAX */
2728 if (numtype & IS_NUMBER_NOT_INT) {
2729 /* UV and NV both imprecise. */
2731 UV nv_as_uv = U_V(nv);
2733 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2744 #endif /* NV_PRESERVES_UV */
2747 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2749 if (SvTYPE(sv) < SVt_NV)
2750 /* Typically the caller expects that sv_any is not NULL now. */
2751 /* XXX Ilya implies that this is a bug in callers that assume this
2752 and ideally should be fixed. */
2753 sv_upgrade(sv, SVt_NV);
2756 #if defined(USE_LONG_DOUBLE)
2758 STORE_NUMERIC_LOCAL_SET_STANDARD();
2759 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2760 PTR2UV(sv), SvNVX(sv));
2761 RESTORE_NUMERIC_LOCAL();
2765 STORE_NUMERIC_LOCAL_SET_STANDARD();
2766 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2767 PTR2UV(sv), SvNVX(sv));
2768 RESTORE_NUMERIC_LOCAL();
2774 /* asIV(): extract an integer from the string value of an SV.
2775 * Caller must validate PVX */
2778 S_asIV(pTHX_ SV *sv)
2781 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2783 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2784 == IS_NUMBER_IN_UV) {
2785 /* It's definitely an integer */
2786 if (numtype & IS_NUMBER_NEG) {
2787 if (value < (UV)IV_MIN)
2790 if (value < (UV)IV_MAX)
2795 if (ckWARN(WARN_NUMERIC))
2798 return I_V(Atof(SvPVX(sv)));
2801 /* asUV(): extract an unsigned integer from the string value of an SV
2802 * Caller must validate PVX */
2805 S_asUV(pTHX_ SV *sv)
2808 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2810 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2811 == IS_NUMBER_IN_UV) {
2812 /* It's definitely an integer */
2813 if (!(numtype & IS_NUMBER_NEG))
2817 if (ckWARN(WARN_NUMERIC))
2820 return U_V(Atof(SvPVX(sv)));
2824 =for apidoc sv_2pv_nolen
2826 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2827 use the macro wrapper C<SvPV_nolen(sv)> instead.
2832 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2835 return sv_2pv(sv, &n_a);
2838 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2839 * UV as a string towards the end of buf, and return pointers to start and
2842 * We assume that buf is at least TYPE_CHARS(UV) long.
2846 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2848 char *ptr = buf + TYPE_CHARS(UV);
2862 *--ptr = '0' + (uv % 10);
2870 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2871 * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2875 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2877 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2881 =for apidoc sv_2pv_flags
2883 Returns a pointer to the string value of an SV, and sets *lp to its length.
2884 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2886 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2887 usually end up here too.
2893 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2898 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2899 char *tmpbuf = tbuf;
2905 if (SvGMAGICAL(sv)) {
2906 if (flags & SV_GMAGIC)
2914 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2916 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2921 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2926 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2927 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2934 if (SvTHINKFIRST(sv)) {
2937 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2938 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2939 return SvPV(tmpstr,*lp);
2946 switch (SvTYPE(sv)) {
2948 if ( ((SvFLAGS(sv) &
2949 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2950 == (SVs_OBJECT|SVs_RMG))
2951 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2952 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2953 regexp *re = (regexp *)mg->mg_obj;
2956 char *fptr = "msix";
2961 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2963 while((ch = *fptr++)) {
2965 reflags[left++] = ch;
2968 reflags[right--] = ch;
2973 reflags[left] = '-';
2977 mg->mg_len = re->prelen + 4 + left;
2978 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2979 Copy("(?", mg->mg_ptr, 2, char);
2980 Copy(reflags, mg->mg_ptr+2, left, char);
2981 Copy(":", mg->mg_ptr+left+2, 1, char);
2982 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2983 mg->mg_ptr[mg->mg_len - 1] = ')';
2984 mg->mg_ptr[mg->mg_len] = 0;
2986 PL_reginterp_cnt += re->program[0].next_off;
2998 case SVt_PVBM: if (SvROK(sv))
3001 s = "SCALAR"; break;
3002 case SVt_PVLV: s = "LVALUE"; break;
3003 case SVt_PVAV: s = "ARRAY"; break;
3004 case SVt_PVHV: s = "HASH"; break;
3005 case SVt_PVCV: s = "CODE"; break;
3006 case SVt_PVGV: s = "GLOB"; break;
3007 case SVt_PVFM: s = "FORMAT"; break;
3008 case SVt_PVIO: s = "IO"; break;
3009 default: s = "UNKNOWN"; break;
3013 HV *svs = SvSTASH(sv);
3016 /* [20011101.072] This bandaid for C<package;>
3017 should eventually be removed. AMS 20011103 */
3018 (svs ? HvNAME(svs) : "<none>"), s
3023 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3029 if (SvREADONLY(sv) && !SvOK(sv)) {
3030 if (ckWARN(WARN_UNINITIALIZED))
3036 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3037 /* I'm assuming that if both IV and NV are equally valid then
3038 converting the IV is going to be more efficient */
3039 U32 isIOK = SvIOK(sv);
3040 U32 isUIOK = SvIsUV(sv);
3041 char buf[TYPE_CHARS(UV)];
3044 if (SvTYPE(sv) < SVt_PVIV)
3045 sv_upgrade(sv, SVt_PVIV);
3047 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3049 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3050 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
3051 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3052 SvCUR_set(sv, ebuf - ptr);
3062 else if (SvNOKp(sv)) {
3063 if (SvTYPE(sv) < SVt_PVNV)
3064 sv_upgrade(sv, SVt_PVNV);
3065 /* The +20 is pure guesswork. Configure test needed. --jhi */
3066 SvGROW(sv, NV_DIG + 20);
3068 olderrno = errno; /* some Xenix systems wipe out errno here */
3070 if (SvNVX(sv) == 0.0)
3071 (void)strcpy(s,"0");
3075 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3078 #ifdef FIXNEGATIVEZERO
3079 if (*s == '-' && s[1] == '0' && !s[2])
3089 if (ckWARN(WARN_UNINITIALIZED)
3090 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3093 if (SvTYPE(sv) < SVt_PV)
3094 /* Typically the caller expects that sv_any is not NULL now. */
3095 sv_upgrade(sv, SVt_PV);
3098 *lp = s - SvPVX(sv);
3101 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3102 PTR2UV(sv),SvPVX(sv)));
3106 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3107 /* Sneaky stuff here */
3111 tsv = newSVpv(tmpbuf, 0);
3127 len = strlen(tmpbuf);
3129 #ifdef FIXNEGATIVEZERO
3130 if (len == 2 && t[0] == '-' && t[1] == '0') {
3135 (void)SvUPGRADE(sv, SVt_PV);
3137 s = SvGROW(sv, len + 1);
3146 =for apidoc sv_2pvbyte_nolen
3148 Return a pointer to the byte-encoded representation of the SV.
3149 May cause the SV to be downgraded from UTF8 as a side-effect.
3151 Usually accessed via the C<SvPVbyte_nolen> macro.
3157 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3160 return sv_2pvbyte(sv, &n_a);
3164 =for apidoc sv_2pvbyte
3166 Return a pointer to the byte-encoded representation of the SV, and set *lp
3167 to its length. May cause the SV to be downgraded from UTF8 as a
3170 Usually accessed via the C<SvPVbyte> macro.
3176 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3178 sv_utf8_downgrade(sv,0);
3179 return SvPV(sv,*lp);
3183 =for apidoc sv_2pvutf8_nolen
3185 Return a pointer to the UTF8-encoded representation of the SV.
3186 May cause the SV to be upgraded to UTF8 as a side-effect.
3188 Usually accessed via the C<SvPVutf8_nolen> macro.
3194 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3197 return sv_2pvutf8(sv, &n_a);
3201 =for apidoc sv_2pvutf8
3203 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3204 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3206 Usually accessed via the C<SvPVutf8> macro.
3212 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3214 sv_utf8_upgrade(sv);
3215 return SvPV(sv,*lp);
3219 =for apidoc sv_2bool
3221 This function is only called on magical items, and is only used by
3222 sv_true() or its macro equivalent.
3228 Perl_sv_2bool(pTHX_ register SV *sv)
3237 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3238 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3239 return SvTRUE(tmpsv);
3240 return SvRV(sv) != 0;
3243 register XPV* Xpvtmp;
3244 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3245 (*Xpvtmp->xpv_pv > '0' ||
3246 Xpvtmp->xpv_cur > 1 ||
3247 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3254 return SvIVX(sv) != 0;
3257 return SvNVX(sv) != 0.0;
3265 =for apidoc sv_utf8_upgrade
3267 Convert the PV of an SV to its UTF8-encoded form.
3268 Forces the SV to string form if it is not already.
3269 Always sets the SvUTF8 flag to avoid future validity checks even
3270 if all the bytes have hibit clear.
3276 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3278 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3282 =for apidoc sv_utf8_upgrade_flags
3284 Convert the PV of an SV to its UTF8-encoded form.
3285 Forces the SV to string form if it is not already.
3286 Always sets the SvUTF8 flag to avoid future validity checks even
3287 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3288 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3289 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3295 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3305 (void) sv_2pv_flags(sv,&len, flags);
3313 if (SvREADONLY(sv) && SvFAKE(sv)) {
3314 sv_force_normal(sv);
3318 Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
3319 else { /* Assume Latin-1/EBCDIC */
3320 /* This function could be much more efficient if we
3321 * had a FLAG in SVs to signal if there are any hibit
3322 * chars in the PV. Given that there isn't such a flag
3323 * make the loop as fast as possible. */
3324 s = (U8 *) SvPVX(sv);
3325 e = (U8 *) SvEND(sv);
3329 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3335 len = SvCUR(sv) + 1; /* Plus the \0 */
3336 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3337 SvCUR(sv) = len - 1;
3339 Safefree(s); /* No longer using what was there before. */
3340 SvLEN(sv) = len; /* No longer know the real size. */
3342 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3349 =for apidoc sv_utf8_downgrade
3351 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3352 This may not be possible if the PV contains non-byte encoding characters;
3353 if this is the case, either returns false or, if C<fail_ok> is not
3360 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3362 if (SvPOK(sv) && SvUTF8(sv)) {
3367 if (SvREADONLY(sv) && SvFAKE(sv))
3368 sv_force_normal(sv);
3369 s = (U8 *) SvPV(sv, len);
3370 if (!utf8_to_bytes(s, &len)) {
3373 #ifdef USE_BYTES_DOWNGRADES
3374 else if (IN_BYTES) {
3376 U8 *e = (U8 *) SvEND(sv);
3379 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3380 if (first && ch > 255) {
3382 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3385 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3392 len = (d - (U8 *) SvPVX(sv));
3397 Perl_croak(aTHX_ "Wide character in %s",
3400 Perl_croak(aTHX_ "Wide character");
3411 =for apidoc sv_utf8_encode
3413 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3414 flag so that it looks like octets again. Used as a building block
3415 for encode_utf8 in Encode.xs
3421 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3423 (void) sv_utf8_upgrade(sv);
3428 =for apidoc sv_utf8_decode
3430 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3431 turn off SvUTF8 if needed so that we see characters. Used as a building block
3432 for decode_utf8 in Encode.xs
3438 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3444 /* The octets may have got themselves encoded - get them back as
3447 if (!sv_utf8_downgrade(sv, TRUE))
3450 /* it is actually just a matter of turning the utf8 flag on, but
3451 * we want to make sure everything inside is valid utf8 first.
3453 c = (U8 *) SvPVX(sv);
3454 if (!is_utf8_string(c, SvCUR(sv)+1))
3456 e = (U8 *) SvEND(sv);
3459 if (!UTF8_IS_INVARIANT(ch)) {
3469 =for apidoc sv_setsv
3471 Copies the contents of the source SV C<ssv> into the destination SV
3472 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3473 function if the source SV needs to be reused. Does not handle 'set' magic.
3474 Loosely speaking, it performs a copy-by-value, obliterating any previous
3475 content of the destination.
3477 You probably want to use one of the assortment of wrappers, such as
3478 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3479 C<SvSetMagicSV_nosteal>.
3485 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3486 for binary compatibility only
3489 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3491 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3495 =for apidoc sv_setsv_flags
3497 Copies the contents of the source SV C<ssv> into the destination SV
3498 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3499 function if the source SV needs to be reused. Does not handle 'set' magic.
3500 Loosely speaking, it performs a copy-by-value, obliterating any previous
3501 content of the destination.
3502 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3503 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3504 implemented in terms of this function.
3506 You probably want to use one of the assortment of wrappers, such as
3507 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3508 C<SvSetMagicSV_nosteal>.
3510 This is the primary function for copying scalars, and most other
3511 copy-ish functions and macros use this underneath.
3517 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3519 register U32 sflags;
3525 SV_CHECK_THINKFIRST(dstr);
3527 sstr = &PL_sv_undef;
3528 stype = SvTYPE(sstr);
3529 dtype = SvTYPE(dstr);
3533 /* There's a lot of redundancy below but we're going for speed here */
3538 if (dtype != SVt_PVGV) {
3539 (void)SvOK_off(dstr);
3547 sv_upgrade(dstr, SVt_IV);
3550 sv_upgrade(dstr, SVt_PVNV);
3554 sv_upgrade(dstr, SVt_PVIV);
3557 (void)SvIOK_only(dstr);
3558 SvIVX(dstr) = SvIVX(sstr);
3561 if (SvTAINTED(sstr))
3572 sv_upgrade(dstr, SVt_NV);
3577 sv_upgrade(dstr, SVt_PVNV);
3580 SvNVX(dstr) = SvNVX(sstr);
3581 (void)SvNOK_only(dstr);
3582 if (SvTAINTED(sstr))
3590 sv_upgrade(dstr, SVt_RV);
3591 else if (dtype == SVt_PVGV &&
3592 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3595 if (GvIMPORTED(dstr) != GVf_IMPORTED
3596 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3598 GvIMPORTED_on(dstr);
3609 sv_upgrade(dstr, SVt_PV);
3612 if (dtype < SVt_PVIV)
3613 sv_upgrade(dstr, SVt_PVIV);
3616 if (dtype < SVt_PVNV)
3617 sv_upgrade(dstr, SVt_PVNV);
3624 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3627 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3631 if (dtype <= SVt_PVGV) {
3633 if (dtype != SVt_PVGV) {
3634 char *name = GvNAME(sstr);
3635 STRLEN len = GvNAMELEN(sstr);
3636 sv_upgrade(dstr, SVt_PVGV);
3637 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3638 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3639 GvNAME(dstr) = savepvn(name, len);
3640 GvNAMELEN(dstr) = len;
3641 SvFAKE_on(dstr); /* can coerce to non-glob */
3643 /* ahem, death to those who redefine active sort subs */
3644 else if (PL_curstackinfo->si_type == PERLSI_SORT
3645 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3646 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3649 #ifdef GV_UNIQUE_CHECK
3650 if (GvUNIQUE((GV*)dstr)) {
3651 Perl_croak(aTHX_ PL_no_modify);
3655 (void)SvOK_off(dstr);
3656 GvINTRO_off(dstr); /* one-shot flag */
3658 GvGP(dstr) = gp_ref(GvGP(sstr));
3659 if (SvTAINTED(sstr))
3661 if (GvIMPORTED(dstr) != GVf_IMPORTED
3662 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3664 GvIMPORTED_on(dstr);
3672 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3674 if (SvTYPE(sstr) != stype) {
3675 stype = SvTYPE(sstr);
3676 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3680 if (stype == SVt_PVLV)
3681 (void)SvUPGRADE(dstr, SVt_PVNV);
3683 (void)SvUPGRADE(dstr, stype);
3686 sflags = SvFLAGS(sstr);
3688 if (sflags & SVf_ROK) {
3689 if (dtype >= SVt_PV) {
3690 if (dtype == SVt_PVGV) {
3691 SV *sref = SvREFCNT_inc(SvRV(sstr));
3693 int intro = GvINTRO(dstr);
3695 #ifdef GV_UNIQUE_CHECK
3696 if (GvUNIQUE((GV*)dstr)) {
3697 Perl_croak(aTHX_ PL_no_modify);
3702 GvINTRO_off(dstr); /* one-shot flag */
3703 GvLINE(dstr) = CopLINE(PL_curcop);
3704 GvEGV(dstr) = (GV*)dstr;
3707 switch (SvTYPE(sref)) {
3710 SAVESPTR(GvAV(dstr));
3712 dref = (SV*)GvAV(dstr);
3713 GvAV(dstr) = (AV*)sref;
3714 if (!GvIMPORTED_AV(dstr)
3715 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3717 GvIMPORTED_AV_on(dstr);
3722 SAVESPTR(GvHV(dstr));
3724 dref = (SV*)GvHV(dstr);
3725 GvHV(dstr) = (HV*)sref;
3726 if (!GvIMPORTED_HV(dstr)
3727 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3729 GvIMPORTED_HV_on(dstr);
3734 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3735 SvREFCNT_dec(GvCV(dstr));
3736 GvCV(dstr) = Nullcv;
3737 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3738 PL_sub_generation++;
3740 SAVESPTR(GvCV(dstr));
3743 dref = (SV*)GvCV(dstr);
3744 if (GvCV(dstr) != (CV*)sref) {
3745 CV* cv = GvCV(dstr);
3747 if (!GvCVGEN((GV*)dstr) &&
3748 (CvROOT(cv) || CvXSUB(cv)))
3750 /* ahem, death to those who redefine
3751 * active sort subs */
3752 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3753 PL_sortcop == CvSTART(cv))
3755 "Can't redefine active sort subroutine %s",
3756 GvENAME((GV*)dstr));
3757 /* Redefining a sub - warning is mandatory if
3758 it was a const and its value changed. */
3759 if (ckWARN(WARN_REDEFINE)
3761 && (!CvCONST((CV*)sref)
3762 || sv_cmp(cv_const_sv(cv),
3763 cv_const_sv((CV*)sref)))))
3765 Perl_warner(aTHX_ WARN_REDEFINE,
3767 ? "Constant subroutine %s redefined"
3768 : "Subroutine %s redefined",
3769 GvENAME((GV*)dstr));
3772 cv_ckproto(cv, (GV*)dstr,
3773 SvPOK(sref) ? SvPVX(sref) : Nullch);
3775 GvCV(dstr) = (CV*)sref;
3776 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3777 GvASSUMECV_on(dstr);
3778 PL_sub_generation++;
3780 if (!GvIMPORTED_CV(dstr)
3781 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3783 GvIMPORTED_CV_on(dstr);
3788 SAVESPTR(GvIOp(dstr));
3790 dref = (SV*)GvIOp(dstr);
3791 GvIOp(dstr) = (IO*)sref;
3795 SAVESPTR(GvFORM(dstr));
3797 dref = (SV*)GvFORM(dstr);
3798 GvFORM(dstr) = (CV*)sref;
3802 SAVESPTR(GvSV(dstr));
3804 dref = (SV*)GvSV(dstr);
3806 if (!GvIMPORTED_SV(dstr)
3807 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3809 GvIMPORTED_SV_on(dstr);
3817 if (SvTAINTED(sstr))
3822 (void)SvOOK_off(dstr); /* backoff */
3824 Safefree(SvPVX(dstr));
3825 SvLEN(dstr)=SvCUR(dstr)=0;
3828 (void)SvOK_off(dstr);
3829 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3831 if (sflags & SVp_NOK) {
3833 /* Only set the public OK flag if the source has public OK. */
3834 if (sflags & SVf_NOK)
3835 SvFLAGS(dstr) |= SVf_NOK;
3836 SvNVX(dstr) = SvNVX(sstr);
3838 if (sflags & SVp_IOK) {
3839 (void)SvIOKp_on(dstr);
3840 if (sflags & SVf_IOK)
3841 SvFLAGS(dstr) |= SVf_IOK;
3842 if (sflags & SVf_IVisUV)
3844 SvIVX(dstr) = SvIVX(sstr);
3846 if (SvAMAGIC(sstr)) {
3850 else if (sflags & SVp_POK) {
3853 * Check to see if we can just swipe the string. If so, it's a
3854 * possible small lose on short strings, but a big win on long ones.
3855 * It might even be a win on short strings if SvPVX(dstr)
3856 * has to be allocated and SvPVX(sstr) has to be freed.
3859 if (SvTEMP(sstr) && /* slated for free anyway? */
3860 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3861 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3862 SvLEN(sstr) && /* and really is a string */
3863 /* and won't be needed again, potentially */
3864 !(PL_op && PL_op->op_type == OP_AASSIGN))
3866 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3868 SvFLAGS(dstr) &= ~SVf_OOK;
3869 Safefree(SvPVX(dstr) - SvIVX(dstr));
3871 else if (SvLEN(dstr))
3872 Safefree(SvPVX(dstr));
3874 (void)SvPOK_only(dstr);
3875 SvPV_set(dstr, SvPVX(sstr));
3876 SvLEN_set(dstr, SvLEN(sstr));
3877 SvCUR_set(dstr, SvCUR(sstr));
3880 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3881 SvPV_set(sstr, Nullch);
3886 else { /* have to copy actual string */
3887 STRLEN len = SvCUR(sstr);
3889 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3890 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3891 SvCUR_set(dstr, len);
3892 *SvEND(dstr) = '\0';
3893 (void)SvPOK_only(dstr);
3895 if (sflags & SVf_UTF8)
3898 if (sflags & SVp_NOK) {
3900 if (sflags & SVf_NOK)
3901 SvFLAGS(dstr) |= SVf_NOK;
3902 SvNVX(dstr) = SvNVX(sstr);
3904 if (sflags & SVp_IOK) {
3905 (void)SvIOKp_on(dstr);
3906 if (sflags & SVf_IOK)
3907 SvFLAGS(dstr) |= SVf_IOK;
3908 if (sflags & SVf_IVisUV)
3910 SvIVX(dstr) = SvIVX(sstr);
3913 else if (sflags & SVp_IOK) {
3914 if (sflags & SVf_IOK)
3915 (void)SvIOK_only(dstr);
3917 (void)SvOK_off(dstr);
3918 (void)SvIOKp_on(dstr);
3920 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3921 if (sflags & SVf_IVisUV)
3923 SvIVX(dstr) = SvIVX(sstr);
3924 if (sflags & SVp_NOK) {
3925 if (sflags & SVf_NOK)
3926 (void)SvNOK_on(dstr);
3928 (void)SvNOKp_on(dstr);
3929 SvNVX(dstr) = SvNVX(sstr);
3932 else if (sflags & SVp_NOK) {
3933 if (sflags & SVf_NOK)
3934 (void)SvNOK_only(dstr);
3936 (void)SvOK_off(dstr);
3939 SvNVX(dstr) = SvNVX(sstr);
3942 if (dtype == SVt_PVGV) {
3943 if (ckWARN(WARN_MISC))
3944 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3947 (void)SvOK_off(dstr);
3949 if (SvTAINTED(sstr))
3954 =for apidoc sv_setsv_mg
3956 Like C<sv_setsv>, but also handles 'set' magic.
3962 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3964 sv_setsv(dstr,sstr);
3969 =for apidoc sv_setpvn
3971 Copies a string into an SV. The C<len> parameter indicates the number of
3972 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3978 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3980 register char *dptr;
3982 SV_CHECK_THINKFIRST(sv);
3988 /* len is STRLEN which is unsigned, need to copy to signed */
3991 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3993 (void)SvUPGRADE(sv, SVt_PV);
3995 SvGROW(sv, len + 1);
3997 Move(ptr,dptr,len,char);
4000 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4005 =for apidoc sv_setpvn_mg
4007 Like C<sv_setpvn>, but also handles 'set' magic.
4013 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4015 sv_setpvn(sv,ptr,len);
4020 =for apidoc sv_setpv
4022 Copies a string into an SV. The string must be null-terminated. Does not
4023 handle 'set' magic. See C<sv_setpv_mg>.
4029 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4031 register STRLEN len;
4033 SV_CHECK_THINKFIRST(sv);
4039 (void)SvUPGRADE(sv, SVt_PV);
4041 SvGROW(sv, len + 1);
4042 Move(ptr,SvPVX(sv),len+1,char);
4044 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4049 =for apidoc sv_setpv_mg
4051 Like C<sv_setpv>, but also handles 'set' magic.
4057 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4064 =for apidoc sv_usepvn
4066 Tells an SV to use C<ptr> to find its string value. Normally the string is
4067 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4068 The C<ptr> should point to memory that was allocated by C<malloc>. The
4069 string length, C<len>, must be supplied. This function will realloc the
4070 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4071 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4072 See C<sv_usepvn_mg>.
4078 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4080 SV_CHECK_THINKFIRST(sv);
4081 (void)SvUPGRADE(sv, SVt_PV);
4086 (void)SvOOK_off(sv);
4087 if (SvPVX(sv) && SvLEN(sv))
4088 Safefree(SvPVX(sv));
4089 Renew(ptr, len+1, char);
4092 SvLEN_set(sv, len+1);
4094 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4099 =for apidoc sv_usepvn_mg
4101 Like C<sv_usepvn>, but also handles 'set' magic.
4107 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4109 sv_usepvn(sv,ptr,len);
4114 =for apidoc sv_force_normal_flags
4116 Undo various types of fakery on an SV: if the PV is a shared string, make
4117 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4118 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4119 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4125 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4127 if (SvREADONLY(sv)) {
4129 char *pvx = SvPVX(sv);
4130 STRLEN len = SvCUR(sv);
4131 U32 hash = SvUVX(sv);
4132 SvGROW(sv, len + 1);
4133 Move(pvx,SvPVX(sv),len,char);
4137 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4139 else if (PL_curcop != &PL_compiling)
4140 Perl_croak(aTHX_ PL_no_modify);
4143 sv_unref_flags(sv, flags);
4144 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4149 =for apidoc sv_force_normal
4151 Undo various types of fakery on an SV: if the PV is a shared string, make
4152 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4153 an xpvmg. See also C<sv_force_normal_flags>.
4159 Perl_sv_force_normal(pTHX_ register SV *sv)
4161 sv_force_normal_flags(sv, 0);
4167 Efficient removal of characters from the beginning of the string buffer.
4168 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4169 the string buffer. The C<ptr> becomes the first character of the adjusted
4170 string. Uses the "OOK hack".
4176 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4178 register STRLEN delta;
4180 if (!ptr || !SvPOKp(sv))
4182 SV_CHECK_THINKFIRST(sv);
4183 if (SvTYPE(sv) < SVt_PVIV)
4184 sv_upgrade(sv,SVt_PVIV);
4187 if (!SvLEN(sv)) { /* make copy of shared string */
4188 char *pvx = SvPVX(sv);
4189 STRLEN len = SvCUR(sv);
4190 SvGROW(sv, len + 1);
4191 Move(pvx,SvPVX(sv),len,char);
4195 SvFLAGS(sv) |= SVf_OOK;
4197 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4198 delta = ptr - SvPVX(sv);
4206 =for apidoc sv_catpvn
4208 Concatenates the string onto the end of the string which is in the SV. The
4209 C<len> indicates number of bytes to copy. If the SV has the UTF8
4210 status set, then the bytes appended should be valid UTF8.
4211 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4216 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4217 for binary compatibility only
4220 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4222 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4226 =for apidoc sv_catpvn_flags
4228 Concatenates the string onto the end of the string which is in the SV. The
4229 C<len> indicates number of bytes to copy. If the SV has the UTF8
4230 status set, then the bytes appended should be valid UTF8.
4231 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4232 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4233 in terms of this function.
4239 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4244 dstr = SvPV_force_flags(dsv, dlen, flags);
4245 SvGROW(dsv, dlen + slen + 1);
4248 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4251 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4256 =for apidoc sv_catpvn_mg
4258 Like C<sv_catpvn>, but also handles 'set' magic.
4264 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4266 sv_catpvn(sv,ptr,len);
4271 =for apidoc sv_catsv
4273 Concatenates the string from SV C<ssv> onto the end of the string in
4274 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4275 not 'set' magic. See C<sv_catsv_mg>.
4279 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4280 for binary compatibility only
4283 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4285 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4289 =for apidoc sv_catsv_flags
4291 Concatenates the string from SV C<ssv> onto the end of the string in
4292 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4293 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4294 and C<sv_catsv_nomg> are implemented in terms of this function.
4299 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4305 if ((spv = SvPV(ssv, slen))) {
4306 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4307 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4308 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4309 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4310 dsv->sv_flags doesn't have that bit set.
4311 Andy Dougherty 12 Oct 2001
4313 I32 sutf8 = DO_UTF8(ssv);
4316 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4318 dutf8 = DO_UTF8(dsv);
4320 if (dutf8 != sutf8) {
4322 /* Not modifying source SV, so taking a temporary copy. */
4323 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4325 sv_utf8_upgrade(csv);
4326 spv = SvPV(csv, slen);
4329 sv_utf8_upgrade_nomg(dsv);
4331 sv_catpvn_nomg(dsv, spv, slen);
4336 =for apidoc sv_catsv_mg
4338 Like C<sv_catsv>, but also handles 'set' magic.
4344 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4351 =for apidoc sv_catpv
4353 Concatenates the string onto the end of the string which is in the SV.
4354 If the SV has the UTF8 status set, then the bytes appended should be
4355 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4360 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4362 register STRLEN len;
4368 junk = SvPV_force(sv, tlen);
4370 SvGROW(sv, tlen + len + 1);
4373 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4375 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4380 =for apidoc sv_catpv_mg
4382 Like C<sv_catpv>, but also handles 'set' magic.
4388 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4397 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4398 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4405 Perl_newSV(pTHX_ STRLEN len)
4411 sv_upgrade(sv, SVt_PV);
4412 SvGROW(sv, len + 1);
4418 =for apidoc sv_magic
4420 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4421 then adds a new magic item of type C<how> to the head of the magic list.
4423 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4429 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4433 if (SvREADONLY(sv)) {
4434 if (PL_curcop != &PL_compiling
4435 && how != PERL_MAGIC_regex_global
4436 && how != PERL_MAGIC_bm
4437 && how != PERL_MAGIC_fm
4438 && how != PERL_MAGIC_sv
4441 Perl_croak(aTHX_ PL_no_modify);
4444 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4445 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4446 if (how == PERL_MAGIC_taint)
4452 (void)SvUPGRADE(sv, SVt_PVMG);
4454 Newz(702,mg, 1, MAGIC);
4455 mg->mg_moremagic = SvMAGIC(sv);
4458 /* Some magic sontains a reference loop, where the sv and object refer to
4459 each other. To prevent a reference loop that would prevent such
4460 objects being freed, we look for such loops and if we find one we
4461 avoid incrementing the object refcount. */
4462 if (!obj || obj == sv ||
4463 how == PERL_MAGIC_arylen ||
4464 how == PERL_MAGIC_qr ||
4465 (SvTYPE(obj) == SVt_PVGV &&
4466 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4467 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4468 GvFORM(obj) == (CV*)sv)))
4473 mg->mg_obj = SvREFCNT_inc(obj);
4474 mg->mg_flags |= MGf_REFCOUNTED;
4477 mg->mg_len = namlen;
4480 mg->mg_ptr = savepvn(name, namlen);
4481 else if (namlen == HEf_SVKEY)
4482 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4487 mg->mg_virtual = &PL_vtbl_sv;
4489 case PERL_MAGIC_overload:
4490 mg->mg_virtual = &PL_vtbl_amagic;
4492 case PERL_MAGIC_overload_elem:
4493 mg->mg_virtual = &PL_vtbl_amagicelem;
4495 case PERL_MAGIC_overload_table:
4496 mg->mg_virtual = &PL_vtbl_ovrld;
4499 mg->mg_virtual = &PL_vtbl_bm;
4501 case PERL_MAGIC_regdata:
4502 mg->mg_virtual = &PL_vtbl_regdata;
4504 case PERL_MAGIC_regdatum:
4505 mg->mg_virtual = &PL_vtbl_regdatum;
4507 case PERL_MAGIC_env:
4508 mg->mg_virtual = &PL_vtbl_env;
4511 mg->mg_virtual = &PL_vtbl_fm;
4513 case PERL_MAGIC_envelem:
4514 mg->mg_virtual = &PL_vtbl_envelem;
4516 case PERL_MAGIC_regex_global:
4517 mg->mg_virtual = &PL_vtbl_mglob;
4519 case PERL_MAGIC_isa:
4520 mg->mg_virtual = &PL_vtbl_isa;
4522 case PERL_MAGIC_isaelem:
4523 mg->mg_virtual = &PL_vtbl_isaelem;
4525 case PERL_MAGIC_nkeys:
4526 mg->mg_virtual = &PL_vtbl_nkeys;
4528 case PERL_MAGIC_dbfile:
4532 case PERL_MAGIC_dbline:
4533 mg->mg_virtual = &PL_vtbl_dbline;
4535 #ifdef USE_5005THREADS
4536 case PERL_MAGIC_mutex:
4537 mg->mg_virtual = &PL_vtbl_mutex;
4539 #endif /* USE_5005THREADS */
4540 #ifdef USE_LOCALE_COLLATE
4541 case PERL_MAGIC_collxfrm:
4542 mg->mg_virtual = &PL_vtbl_collxfrm;
4544 #endif /* USE_LOCALE_COLLATE */
4545 case PERL_MAGIC_tied:
4546 mg->mg_virtual = &PL_vtbl_pack;
4548 case PERL_MAGIC_tiedelem:
4549 case PERL_MAGIC_tiedscalar:
4550 mg->mg_virtual = &PL_vtbl_packelem;
4553 mg->mg_virtual = &PL_vtbl_regexp;
4555 case PERL_MAGIC_sig:
4556 mg->mg_virtual = &PL_vtbl_sig;
4558 case PERL_MAGIC_sigelem:
4559 mg->mg_virtual = &PL_vtbl_sigelem;
4561 case PERL_MAGIC_taint:
4562 mg->mg_virtual = &PL_vtbl_taint;
4565 case PERL_MAGIC_uvar:
4566 mg->mg_virtual = &PL_vtbl_uvar;
4568 case PERL_MAGIC_vec:
4569 mg->mg_virtual = &PL_vtbl_vec;
4571 case PERL_MAGIC_substr:
4572 mg->mg_virtual = &PL_vtbl_substr;
4574 case PERL_MAGIC_defelem:
4575 mg->mg_virtual = &PL_vtbl_defelem;
4577 case PERL_MAGIC_glob:
4578 mg->mg_virtual = &PL_vtbl_glob;
4580 case PERL_MAGIC_arylen:
4581 mg->mg_virtual = &PL_vtbl_arylen;
4583 case PERL_MAGIC_pos:
4584 mg->mg_virtual = &PL_vtbl_pos;
4586 case PERL_MAGIC_backref:
4587 mg->mg_virtual = &PL_vtbl_backref;
4589 case PERL_MAGIC_ext:
4590 /* Reserved for use by extensions not perl internals. */
4591 /* Useful for attaching extension internal data to perl vars. */
4592 /* Note that multiple extensions may clash if magical scalars */
4593 /* etc holding private data from one are passed to another. */
4597 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4601 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4605 =for apidoc sv_unmagic
4607 Removes all magic of type C<type> from an SV.
4613 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4617 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4620 for (mg = *mgp; mg; mg = *mgp) {
4621 if (mg->mg_type == type) {
4622 MGVTBL* vtbl = mg->mg_virtual;
4623 *mgp = mg->mg_moremagic;
4624 if (vtbl && vtbl->svt_free)
4625 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4626 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4627 if (mg->mg_len >= 0)
4628 Safefree(mg->mg_ptr);
4629 else if (mg->mg_len == HEf_SVKEY)
4630 SvREFCNT_dec((SV*)mg->mg_ptr);
4632 if (mg->mg_flags & MGf_REFCOUNTED)
4633 SvREFCNT_dec(mg->mg_obj);
4637 mgp = &mg->mg_moremagic;
4641 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4648 =for apidoc sv_rvweaken
4650 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4651 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4652 push a back-reference to this RV onto the array of backreferences
4653 associated with that magic.
4659 Perl_sv_rvweaken(pTHX_ SV *sv)
4662 if (!SvOK(sv)) /* let undefs pass */
4665 Perl_croak(aTHX_ "Can't weaken a nonreference");
4666 else if (SvWEAKREF(sv)) {
4667 if (ckWARN(WARN_MISC))
4668 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4672 sv_add_backref(tsv, sv);
4678 /* Give tsv backref magic if it hasn't already got it, then push a
4679 * back-reference to sv onto the array associated with the backref magic.
4683 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4687 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4688 av = (AV*)mg->mg_obj;
4691 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4692 SvREFCNT_dec(av); /* for sv_magic */
4697 /* delete a back-reference to ourselves from the backref magic associated
4698 * with the SV we point to.
4702 S_sv_del_backref(pTHX_ SV *sv)
4709 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4710 Perl_croak(aTHX_ "panic: del_backref");
4711 av = (AV *)mg->mg_obj;
4716 svp[i] = &PL_sv_undef; /* XXX */
4723 =for apidoc sv_insert
4725 Inserts a string at the specified offset/length within the SV. Similar to
4726 the Perl substr() function.
4732 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4736 register char *midend;
4737 register char *bigend;
4743 Perl_croak(aTHX_ "Can't modify non-existent substring");
4744 SvPV_force(bigstr, curlen);
4745 (void)SvPOK_only_UTF8(bigstr);
4746 if (offset + len > curlen) {
4747 SvGROW(bigstr, offset+len+1);
4748 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4749 SvCUR_set(bigstr, offset+len);
4753 i = littlelen - len;
4754 if (i > 0) { /* string might grow */
4755 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4756 mid = big + offset + len;
4757 midend = bigend = big + SvCUR(bigstr);
4760 while (midend > mid) /* shove everything down */
4761 *--bigend = *--midend;
4762 Move(little,big+offset,littlelen,char);
4768 Move(little,SvPVX(bigstr)+offset,len,char);
4773 big = SvPVX(bigstr);
4776 bigend = big + SvCUR(bigstr);
4778 if (midend > bigend)
4779 Perl_croak(aTHX_ "panic: sv_insert");
4781 if (mid - big > bigend - midend) { /* faster to shorten from end */
4783 Move(little, mid, littlelen,char);
4786 i = bigend - midend;
4788 Move(midend, mid, i,char);
4792 SvCUR_set(bigstr, mid - big);
4795 else if ((i = mid - big)) { /* faster from front */
4796 midend -= littlelen;
4798 sv_chop(bigstr,midend-i);
4803 Move(little, mid, littlelen,char);
4805 else if (littlelen) {
4806 midend -= littlelen;
4807 sv_chop(bigstr,midend);
4808 Move(little,midend,littlelen,char);
4811 sv_chop(bigstr,midend);
4817 =for apidoc sv_replace
4819 Make the first argument a copy of the second, then delete the original.
4820 The target SV physically takes over ownership of the body of the source SV
4821 and inherits its flags; however, the target keeps any magic it owns,
4822 and any magic in the source is discarded.
4823 Note that this is a rather specialist SV copying operation; most of the
4824 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4830 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4832 U32 refcnt = SvREFCNT(sv);
4833 SV_CHECK_THINKFIRST(sv);
4834 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4835 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4836 if (SvMAGICAL(sv)) {
4840 sv_upgrade(nsv, SVt_PVMG);
4841 SvMAGIC(nsv) = SvMAGIC(sv);
4842 SvFLAGS(nsv) |= SvMAGICAL(sv);
4848 assert(!SvREFCNT(sv));
4849 StructCopy(nsv,sv,SV);
4850 SvREFCNT(sv) = refcnt;
4851 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4856 =for apidoc sv_clear
4858 Clear an SV: call any destructors, free up any memory used by the body,
4859 and free the body itself. The SV's head is I<not> freed, although
4860 its type is set to all 1's so that it won't inadvertently be assumed
4861 to be live during global destruction etc.
4862 This function should only be called when REFCNT is zero. Most of the time
4863 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4870 Perl_sv_clear(pTHX_ register SV *sv)
4874 assert(SvREFCNT(sv) == 0);
4877 if (PL_defstash) { /* Still have a symbol table? */
4882 Zero(&tmpref, 1, SV);
4883 sv_upgrade(&tmpref, SVt_RV);
4885 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4886 SvREFCNT(&tmpref) = 1;
4889 stash = SvSTASH(sv);
4890 destructor = StashHANDLER(stash,DESTROY);
4893 PUSHSTACKi(PERLSI_DESTROY);
4894 SvRV(&tmpref) = SvREFCNT_inc(sv);
4899 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4905 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4907 del_XRV(SvANY(&tmpref));
4910 if (PL_in_clean_objs)
4911 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4913 /* DESTROY gave object new lease on life */
4919 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4920 SvOBJECT_off(sv); /* Curse the object. */
4921 if (SvTYPE(sv) != SVt_PVIO)
4922 --PL_sv_objcount; /* XXX Might want something more general */
4925 if (SvTYPE(sv) >= SVt_PVMG) {
4928 if (SvFLAGS(sv) & SVpad_TYPED)
4929 SvREFCNT_dec(SvSTASH(sv));
4932 switch (SvTYPE(sv)) {
4935 IoIFP(sv) != PerlIO_stdin() &&
4936 IoIFP(sv) != PerlIO_stdout() &&
4937 IoIFP(sv) != PerlIO_stderr())
4939 io_close((IO*)sv, FALSE);
4941 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4942 PerlDir_close(IoDIRP(sv));
4943 IoDIRP(sv) = (DIR*)NULL;
4944 Safefree(IoTOP_NAME(sv));
4945 Safefree(IoFMT_NAME(sv));
4946 Safefree(IoBOTTOM_NAME(sv));
4961 SvREFCNT_dec(LvTARG(sv));
4965 Safefree(GvNAME(sv));
4966 /* cannot decrease stash refcount yet, as we might recursively delete
4967 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4968 of stash until current sv is completely gone.
4969 -- JohnPC, 27 Mar 1998 */
4970 stash = GvSTASH(sv);
4976 (void)SvOOK_off(sv);
4984 SvREFCNT_dec(SvRV(sv));
4986 else if (SvPVX(sv) && SvLEN(sv))
4987 Safefree(SvPVX(sv));
4988 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4989 unsharepvn(SvPVX(sv),
4990 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5003 switch (SvTYPE(sv)) {
5019 del_XPVIV(SvANY(sv));
5022 del_XPVNV(SvANY(sv));
5025 del_XPVMG(SvANY(sv));
5028 del_XPVLV(SvANY(sv));
5031 del_XPVAV(SvANY(sv));
5034 del_XPVHV(SvANY(sv));
5037 del_XPVCV(SvANY(sv));
5040 del_XPVGV(SvANY(sv));
5041 /* code duplication for increased performance. */
5042 SvFLAGS(sv) &= SVf_BREAK;
5043 SvFLAGS(sv) |= SVTYPEMASK;
5044 /* decrease refcount of the stash that owns this GV, if any */
5046 SvREFCNT_dec(stash);
5047 return; /* not break, SvFLAGS reset already happened */
5049 del_XPVBM(SvANY(sv));
5052 del_XPVFM(SvANY(sv));
5055 del_XPVIO(SvANY(sv));
5058 SvFLAGS(sv) &= SVf_BREAK;
5059 SvFLAGS(sv) |= SVTYPEMASK;
5063 =for apidoc sv_newref
5065 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5072 Perl_sv_newref(pTHX_ SV *sv)
5075 ATOMIC_INC(SvREFCNT(sv));
5082 Decrement an SV's reference count, and if it drops to zero, call
5083 C<sv_clear> to invoke destructors and free up any memory used by
5084 the body; finally, deallocate the SV's head itself.
5085 Normally called via a wrapper macro C<SvREFCNT_dec>.
5091 Perl_sv_free(pTHX_ SV *sv)
5093 int refcount_is_zero;
5097 if (SvREFCNT(sv) == 0) {
5098 if (SvFLAGS(sv) & SVf_BREAK)
5099 /* this SV's refcnt has been artificially decremented to
5100 * trigger cleanup */
5102 if (PL_in_clean_all) /* All is fair */
5104 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5105 /* make sure SvREFCNT(sv)==0 happens very seldom */
5106 SvREFCNT(sv) = (~(U32)0)/2;
5109 if (ckWARN_d(WARN_INTERNAL))
5110 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5113 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5114 if (!refcount_is_zero)
5118 if (ckWARN_d(WARN_DEBUGGING))
5119 Perl_warner(aTHX_ WARN_DEBUGGING,
5120 "Attempt to free temp prematurely: SV 0x%"UVxf,
5125 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5126 /* make sure SvREFCNT(sv)==0 happens very seldom */
5127 SvREFCNT(sv) = (~(U32)0)/2;
5138 Returns the length of the string in the SV. Handles magic and type
5139 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5145 Perl_sv_len(pTHX_ register SV *sv)
5153 len = mg_length(sv);
5155 (void)SvPV(sv, len);
5160 =for apidoc sv_len_utf8
5162 Returns the number of characters in the string in an SV, counting wide
5163 UTF8 bytes as a single character. Handles magic and type coercion.
5169 Perl_sv_len_utf8(pTHX_ register SV *sv)
5175 return mg_length(sv);
5179 U8 *s = (U8*)SvPV(sv, len);
5181 return Perl_utf8_length(aTHX_ s, s + len);
5186 =for apidoc sv_pos_u2b
5188 Converts the value pointed to by offsetp from a count of UTF8 chars from
5189 the start of the string, to a count of the equivalent number of bytes; if
5190 lenp is non-zero, it does the same to lenp, but this time starting from
5191 the offset, rather than from the start of the string. Handles magic and
5198 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5203 I32 uoffset = *offsetp;
5209 start = s = (U8*)SvPV(sv, len);
5211 while (s < send && uoffset--)
5215 *offsetp = s - start;
5219 while (s < send && ulen--)
5229 =for apidoc sv_pos_b2u
5231 Converts the value pointed to by offsetp from a count of bytes from the
5232 start of the string, to a count of the equivalent number of UTF8 chars.
5233 Handles magic and type coercion.
5239 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5248 s = (U8*)SvPV(sv, len);
5250 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5251 send = s + *offsetp;
5255 /* Call utf8n_to_uvchr() to validate the sequence */
5256 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5271 Returns a boolean indicating whether the strings in the two SVs are
5272 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5273 coerce its args to strings if necessary.
5279 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5293 pv1 = SvPV(sv1, cur1);
5300 pv2 = SvPV(sv2, cur2);
5302 /* do not utf8ize the comparands as a side-effect */
5303 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5304 bool is_utf8 = TRUE;
5305 /* UTF-8ness differs */
5308 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5309 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5314 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5315 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5320 /* Downgrade not possible - cannot be eq */
5326 eq = memEQ(pv1, pv2, cur1);
5337 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5338 string in C<sv1> is less than, equal to, or greater than the string in
5339 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5340 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5346 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5351 bool pv1tmp = FALSE;
5352 bool pv2tmp = FALSE;
5359 pv1 = SvPV(sv1, cur1);
5366 pv2 = SvPV(sv2, cur2);
5368 /* do not utf8ize the comparands as a side-effect */
5369 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5371 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5375 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5381 cmp = cur2 ? -1 : 0;
5385 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5388 cmp = retval < 0 ? -1 : 1;
5389 } else if (cur1 == cur2) {
5392 cmp = cur1 < cur2 ? -1 : 1;
5405 =for apidoc sv_cmp_locale
5407 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5408 'use bytes' aware, handles get magic, and will coerce its args to strings
5409 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5415 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5417 #ifdef USE_LOCALE_COLLATE
5423 if (PL_collation_standard)
5427 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5429 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5431 if (!pv1 || !len1) {
5442 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5445 return retval < 0 ? -1 : 1;
5448 * When the result of collation is equality, that doesn't mean
5449 * that there are no differences -- some locales exclude some
5450 * characters from consideration. So to avoid false equalities,
5451 * we use the raw string as a tiebreaker.
5457 #endif /* USE_LOCALE_COLLATE */
5459 return sv_cmp(sv1, sv2);
5463 #ifdef USE_LOCALE_COLLATE
5466 =for apidoc sv_collxfrm
5468 Add Collate Transform magic to an SV if it doesn't already have it.
5470 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5471 scalar data of the variable, but transformed to such a format that a normal
5472 memory comparison can be used to compare the data according to the locale
5479 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5483 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5484 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5489 Safefree(mg->mg_ptr);
5491 if ((xf = mem_collxfrm(s, len, &xlen))) {
5492 if (SvREADONLY(sv)) {
5495 return xf + sizeof(PL_collation_ix);
5498 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5499 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5512 if (mg && mg->mg_ptr) {
5514 return mg->mg_ptr + sizeof(PL_collation_ix);
5522 #endif /* USE_LOCALE_COLLATE */
5527 Get a line from the filehandle and store it into the SV, optionally
5528 appending to the currently-stored string.
5534 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5538 register STDCHAR rslast;
5539 register STDCHAR *bp;
5544 SV_CHECK_THINKFIRST(sv);
5545 (void)SvUPGRADE(sv, SVt_PV);
5549 if (PL_curcop == &PL_compiling) {
5550 /* we always read code in line mode */
5554 else if (RsSNARF(PL_rs)) {
5558 else if (RsRECORD(PL_rs)) {
5559 I32 recsize, bytesread;
5562 /* Grab the size of the record we're getting */
5563 recsize = SvIV(SvRV(PL_rs));
5564 (void)SvPOK_only(sv); /* Validate pointer */
5565 buffer = SvGROW(sv, recsize + 1);
5568 /* VMS wants read instead of fread, because fread doesn't respect */
5569 /* RMS record boundaries. This is not necessarily a good thing to be */
5570 /* doing, but we've got no other real choice */
5571 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5573 bytesread = PerlIO_read(fp, buffer, recsize);
5575 SvCUR_set(sv, bytesread);
5576 buffer[bytesread] = '\0';
5577 if (PerlIO_isutf8(fp))
5581 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5583 else if (RsPARA(PL_rs)) {
5589 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5590 if (PerlIO_isutf8(fp)) {
5591 rsptr = SvPVutf8(PL_rs, rslen);
5594 if (SvUTF8(PL_rs)) {
5595 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5596 Perl_croak(aTHX_ "Wide character in $/");
5599 rsptr = SvPV(PL_rs, rslen);
5603 rslast = rslen ? rsptr[rslen - 1] : '\0';
5605 if (rspara) { /* have to do this both before and after */
5606 do { /* to make sure file boundaries work right */
5609 i = PerlIO_getc(fp);
5613 PerlIO_ungetc(fp,i);
5619 /* See if we know enough about I/O mechanism to cheat it ! */
5621 /* This used to be #ifdef test - it is made run-time test for ease
5622 of abstracting out stdio interface. One call should be cheap
5623 enough here - and may even be a macro allowing compile
5627 if (PerlIO_fast_gets(fp)) {
5630 * We're going to steal some values from the stdio struct
5631 * and put EVERYTHING in the innermost loop into registers.
5633 register STDCHAR *ptr;
5637 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5638 /* An ungetc()d char is handled separately from the regular
5639 * buffer, so we getc() it back out and stuff it in the buffer.
5641 i = PerlIO_getc(fp);
5642 if (i == EOF) return 0;
5643 *(--((*fp)->_ptr)) = (unsigned char) i;
5647 /* Here is some breathtakingly efficient cheating */
5649 cnt = PerlIO_get_cnt(fp); /* get count into register */
5650 (void)SvPOK_only(sv); /* validate pointer */
5651 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5652 if (cnt > 80 && SvLEN(sv) > append) {
5653 shortbuffered = cnt - SvLEN(sv) + append + 1;
5654 cnt -= shortbuffered;
5658 /* remember that cnt can be negative */
5659 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5664 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5665 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5666 DEBUG_P(PerlIO_printf(Perl_debug_log,
5667 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5668 DEBUG_P(PerlIO_printf(Perl_debug_log,
5669 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5670 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5671 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5676 while (cnt > 0) { /* this | eat */
5678 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5679 goto thats_all_folks; /* screams | sed :-) */
5683 Copy(ptr, bp, cnt, char); /* this | eat */
5684 bp += cnt; /* screams | dust */
5685 ptr += cnt; /* louder | sed :-) */
5690 if (shortbuffered) { /* oh well, must extend */
5691 cnt = shortbuffered;
5693 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5695 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5696 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5700 DEBUG_P(PerlIO_printf(Perl_debug_log,
5701 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5702 PTR2UV(ptr),(long)cnt));
5703 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
5705 DEBUG_P(PerlIO_printf(Perl_debug_log,
5706 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5707 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5708 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5710 /* This used to call 'filbuf' in stdio form, but as that behaves like
5711 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5712 another abstraction. */
5713 i = PerlIO_getc(fp); /* get more characters */
5715 DEBUG_P(PerlIO_printf(Perl_debug_log,
5716 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5717 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5718 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5720 cnt = PerlIO_get_cnt(fp);
5721 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5722 DEBUG_P(PerlIO_printf(Perl_debug_log,
5723 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5725 if (i == EOF) /* all done for ever? */
5726 goto thats_really_all_folks;
5728 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5730 SvGROW(sv, bpx + cnt + 2);
5731 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5733 *bp++ = i; /* store character from PerlIO_getc */
5735 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5736 goto thats_all_folks;
5740 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5741 memNE((char*)bp - rslen, rsptr, rslen))
5742 goto screamer; /* go back to the fray */
5743 thats_really_all_folks:
5745 cnt += shortbuffered;
5746 DEBUG_P(PerlIO_printf(Perl_debug_log,
5747 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5748 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
5749 DEBUG_P(PerlIO_printf(Perl_debug_log,
5750 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5751 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5752 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5754 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5755 DEBUG_P(PerlIO_printf(Perl_debug_log,
5756 "Screamer: done, len=%ld, string=|%.*s|\n",
5757 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5762 /*The big, slow, and stupid way */
5765 /* Need to work around EPOC SDK features */
5766 /* On WINS: MS VC5 generates calls to _chkstk, */
5767 /* if a `large' stack frame is allocated */
5768 /* gcc on MARM does not generate calls like these */
5774 register STDCHAR *bpe = buf + sizeof(buf);
5776 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5777 ; /* keep reading */
5781 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5782 /* Accomodate broken VAXC compiler, which applies U8 cast to
5783 * both args of ?: operator, causing EOF to change into 255
5785 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5789 sv_catpvn(sv, (char *) buf, cnt);
5791 sv_setpvn(sv, (char *) buf, cnt);
5793 if (i != EOF && /* joy */
5795 SvCUR(sv) < rslen ||
5796 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5800 * If we're reading from a TTY and we get a short read,
5801 * indicating that the user hit his EOF character, we need
5802 * to notice it now, because if we try to read from the TTY
5803 * again, the EOF condition will disappear.
5805 * The comparison of cnt to sizeof(buf) is an optimization
5806 * that prevents unnecessary calls to feof().
5810 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5815 if (rspara) { /* have to do this both before and after */
5816 while (i != EOF) { /* to make sure file boundaries work right */
5817 i = PerlIO_getc(fp);
5819 PerlIO_ungetc(fp,i);
5825 if (PerlIO_isutf8(fp))
5830 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5836 Auto-increment of the value in the SV, doing string to numeric conversion
5837 if necessary. Handles 'get' magic.
5843 Perl_sv_inc(pTHX_ register SV *sv)
5852 if (SvTHINKFIRST(sv)) {
5853 if (SvREADONLY(sv) && SvFAKE(sv))
5854 sv_force_normal(sv);
5855 if (SvREADONLY(sv)) {
5856 if (PL_curcop != &PL_compiling)
5857 Perl_croak(aTHX_ PL_no_modify);
5861 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5863 i = PTR2IV(SvRV(sv));
5868 flags = SvFLAGS(sv);
5869 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5870 /* It's (privately or publicly) a float, but not tested as an
5871 integer, so test it to see. */
5873 flags = SvFLAGS(sv);
5875 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5876 /* It's publicly an integer, or privately an integer-not-float */
5877 #ifdef PERL_PRESERVE_IVUV
5881 if (SvUVX(sv) == UV_MAX)
5882 sv_setnv(sv, UV_MAX_P1);
5884 (void)SvIOK_only_UV(sv);
5887 if (SvIVX(sv) == IV_MAX)
5888 sv_setuv(sv, (UV)IV_MAX + 1);
5890 (void)SvIOK_only(sv);
5896 if (flags & SVp_NOK) {
5897 (void)SvNOK_only(sv);
5902 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5903 if ((flags & SVTYPEMASK) < SVt_PVIV)
5904 sv_upgrade(sv, SVt_IV);
5905 (void)SvIOK_only(sv);
5910 while (isALPHA(*d)) d++;
5911 while (isDIGIT(*d)) d++;
5913 #ifdef PERL_PRESERVE_IVUV
5914 /* Got to punt this as an integer if needs be, but we don't issue
5915 warnings. Probably ought to make the sv_iv_please() that does
5916 the conversion if possible, and silently. */
5917 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5918 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5919 /* Need to try really hard to see if it's an integer.
5920 9.22337203685478e+18 is an integer.
5921 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5922 so $a="9.22337203685478e+18"; $a+0; $a++
5923 needs to be the same as $a="9.22337203685478e+18"; $a++
5930 /* sv_2iv *should* have made this an NV */
5931 if (flags & SVp_NOK) {
5932 (void)SvNOK_only(sv);
5936 /* I don't think we can get here. Maybe I should assert this
5937 And if we do get here I suspect that sv_setnv will croak. NWC
5939 #if defined(USE_LONG_DOUBLE)
5940 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",
5941 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5943 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
5944 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5947 #endif /* PERL_PRESERVE_IVUV */
5948 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5952 while (d >= SvPVX(sv)) {
5960 /* MKS: The original code here died if letters weren't consecutive.
5961 * at least it didn't have to worry about non-C locales. The
5962 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5963 * arranged in order (although not consecutively) and that only
5964 * [A-Za-z] are accepted by isALPHA in the C locale.
5966 if (*d != 'z' && *d != 'Z') {
5967 do { ++*d; } while (!isALPHA(*d));
5970 *(d--) -= 'z' - 'a';
5975 *(d--) -= 'z' - 'a' + 1;
5979 /* oh,oh, the number grew */
5980 SvGROW(sv, SvCUR(sv) + 2);
5982 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5993 Auto-decrement of the value in the SV, doing string to numeric conversion
5994 if necessary. Handles 'get' magic.
6000 Perl_sv_dec(pTHX_ register SV *sv)
6008 if (SvTHINKFIRST(sv)) {
6009 if (SvREADONLY(sv) && SvFAKE(sv))
6010 sv_force_normal(sv);
6011 if (SvREADONLY(sv)) {
6012 if (PL_curcop != &PL_compiling)
6013 Perl_croak(aTHX_ PL_no_modify);
6017 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6019 i = PTR2IV(SvRV(sv));
6024 /* Unlike sv_inc we don't have to worry about string-never-numbers
6025 and keeping them magic. But we mustn't warn on punting */
6026 flags = SvFLAGS(sv);
6027 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6028 /* It's publicly an integer, or privately an integer-not-float */
6029 #ifdef PERL_PRESERVE_IVUV
6033 if (SvUVX(sv) == 0) {
6034 (void)SvIOK_only(sv);
6038 (void)SvIOK_only_UV(sv);
6042 if (SvIVX(sv) == IV_MIN)
6043 sv_setnv(sv, (NV)IV_MIN - 1.0);
6045 (void)SvIOK_only(sv);
6051 if (flags & SVp_NOK) {
6053 (void)SvNOK_only(sv);
6056 if (!(flags & SVp_POK)) {
6057 if ((flags & SVTYPEMASK) < SVt_PVNV)
6058 sv_upgrade(sv, SVt_NV);
6060 (void)SvNOK_only(sv);
6063 #ifdef PERL_PRESERVE_IVUV
6065 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6066 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6067 /* Need to try really hard to see if it's an integer.
6068 9.22337203685478e+18 is an integer.
6069 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6070 so $a="9.22337203685478e+18"; $a+0; $a--
6071 needs to be the same as $a="9.22337203685478e+18"; $a--
6078 /* sv_2iv *should* have made this an NV */
6079 if (flags & SVp_NOK) {
6080 (void)SvNOK_only(sv);
6084 /* I don't think we can get here. Maybe I should assert this
6085 And if we do get here I suspect that sv_setnv will croak. NWC
6087 #if defined(USE_LONG_DOUBLE)
6088 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",
6089 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6091 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6092 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6096 #endif /* PERL_PRESERVE_IVUV */
6097 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6101 =for apidoc sv_mortalcopy
6103 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6104 The new SV is marked as mortal. It will be destroyed "soon", either by an
6105 explicit call to FREETMPS, or by an implicit call at places such as
6106 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6111 /* Make a string that will exist for the duration of the expression
6112 * evaluation. Actually, it may have to last longer than that, but
6113 * hopefully we won't free it until it has been assigned to a
6114 * permanent location. */
6117 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6122 sv_setsv(sv,oldstr);
6124 PL_tmps_stack[++PL_tmps_ix] = sv;
6130 =for apidoc sv_newmortal
6132 Creates a new null SV which is mortal. The reference count of the SV is
6133 set to 1. It will be destroyed "soon", either by an explicit call to
6134 FREETMPS, or by an implicit call at places such as statement boundaries.
6135 See also C<sv_mortalcopy> and C<sv_2mortal>.
6141 Perl_sv_newmortal(pTHX)
6146 SvFLAGS(sv) = SVs_TEMP;
6148 PL_tmps_stack[++PL_tmps_ix] = sv;
6153 =for apidoc sv_2mortal
6155 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6156 by an explicit call to FREETMPS, or by an implicit call at places such as
6157 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6163 Perl_sv_2mortal(pTHX_ register SV *sv)
6167 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6170 PL_tmps_stack[++PL_tmps_ix] = sv;
6178 Creates a new SV and copies a string into it. The reference count for the
6179 SV is set to 1. If C<len> is zero, Perl will compute the length using
6180 strlen(). For efficiency, consider using C<newSVpvn> instead.
6186 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6193 sv_setpvn(sv,s,len);
6198 =for apidoc newSVpvn
6200 Creates a new SV and copies a string into it. The reference count for the
6201 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6202 string. You are responsible for ensuring that the source string is at least
6209 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6214 sv_setpvn(sv,s,len);
6219 =for apidoc newSVpvn_share
6221 Creates a new SV with its SvPVX pointing to a shared string in the string
6222 table. If the string does not already exist in the table, it is created
6223 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6224 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6225 otherwise the hash is computed. The idea here is that as the string table
6226 is used for shared hash keys these strings will have SvPVX == HeKEY and
6227 hash lookup will avoid string compare.
6233 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6236 bool is_utf8 = FALSE;
6238 STRLEN tmplen = -len;
6240 /* See the note in hv.c:hv_fetch() --jhi */
6241 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6245 PERL_HASH(hash, src, len);
6247 sv_upgrade(sv, SVt_PVIV);
6248 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6261 #if defined(PERL_IMPLICIT_CONTEXT)
6263 /* pTHX_ magic can't cope with varargs, so this is a no-context
6264 * version of the main function, (which may itself be aliased to us).
6265 * Don't access this version directly.
6269 Perl_newSVpvf_nocontext(const char* pat, ...)
6274 va_start(args, pat);
6275 sv = vnewSVpvf(pat, &args);
6282 =for apidoc newSVpvf
6284 Creates a new SV and initializes it with the string formatted like
6291 Perl_newSVpvf(pTHX_ const char* pat, ...)
6295 va_start(args, pat);
6296 sv = vnewSVpvf(pat, &args);
6301 /* backend for newSVpvf() and newSVpvf_nocontext() */
6304 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6308 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6315 Creates a new SV and copies a floating point value into it.
6316 The reference count for the SV is set to 1.
6322 Perl_newSVnv(pTHX_ NV n)
6334 Creates a new SV and copies an integer into it. The reference count for the
6341 Perl_newSViv(pTHX_ IV i)
6353 Creates a new SV and copies an unsigned integer into it.
6354 The reference count for the SV is set to 1.
6360 Perl_newSVuv(pTHX_ UV u)
6370 =for apidoc newRV_noinc
6372 Creates an RV wrapper for an SV. The reference count for the original
6373 SV is B<not> incremented.
6379 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6384 sv_upgrade(sv, SVt_RV);
6391 /* newRV_inc is the official function name to use now.
6392 * newRV_inc is in fact #defined to newRV in sv.h
6396 Perl_newRV(pTHX_ SV *tmpRef)
6398 return newRV_noinc(SvREFCNT_inc(tmpRef));
6404 Creates a new SV which is an exact duplicate of the original SV.
6411 Perl_newSVsv(pTHX_ register SV *old)
6417 if (SvTYPE(old) == SVTYPEMASK) {
6418 if (ckWARN_d(WARN_INTERNAL))
6419 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6434 =for apidoc sv_reset
6436 Underlying implementation for the C<reset> Perl function.
6437 Note that the perl-level function is vaguely deprecated.
6443 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6451 char todo[PERL_UCHAR_MAX+1];
6456 if (!*s) { /* reset ?? searches */
6457 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6458 pm->op_pmdynflags &= ~PMdf_USED;
6463 /* reset variables */
6465 if (!HvARRAY(stash))
6468 Zero(todo, 256, char);
6470 i = (unsigned char)*s;
6474 max = (unsigned char)*s++;
6475 for ( ; i <= max; i++) {
6478 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6479 for (entry = HvARRAY(stash)[i];
6481 entry = HeNEXT(entry))
6483 if (!todo[(U8)*HeKEY(entry)])
6485 gv = (GV*)HeVAL(entry);
6487 if (SvTHINKFIRST(sv)) {
6488 if (!SvREADONLY(sv) && SvROK(sv))
6493 if (SvTYPE(sv) >= SVt_PV) {
6495 if (SvPVX(sv) != Nullch)
6502 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6504 #ifdef USE_ENVIRON_ARRAY
6506 environ[0] = Nullch;
6517 Using various gambits, try to get an IO from an SV: the IO slot if its a
6518 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6519 named after the PV if we're a string.
6525 Perl_sv_2io(pTHX_ SV *sv)
6531 switch (SvTYPE(sv)) {
6539 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6543 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6545 return sv_2io(SvRV(sv));
6546 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6552 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6561 Using various gambits, try to get a CV from an SV; in addition, try if
6562 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6568 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6575 return *gvp = Nullgv, Nullcv;
6576 switch (SvTYPE(sv)) {
6595 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6596 tryAMAGICunDEREF(to_cv);
6599 if (SvTYPE(sv) == SVt_PVCV) {
6608 Perl_croak(aTHX_ "Not a subroutine reference");
6613 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6619 if (lref && !GvCVu(gv)) {
6622 tmpsv = NEWSV(704,0);
6623 gv_efullname3(tmpsv, gv, Nullch);
6624 /* XXX this is probably not what they think they're getting.
6625 * It has the same effect as "sub name;", i.e. just a forward
6627 newSUB(start_subparse(FALSE, 0),
6628 newSVOP(OP_CONST, 0, tmpsv),
6633 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6642 Returns true if the SV has a true value by Perl's rules.
6643 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6644 instead use an in-line version.
6650 Perl_sv_true(pTHX_ register SV *sv)
6656 if ((tXpv = (XPV*)SvANY(sv)) &&
6657 (tXpv->xpv_cur > 1 ||
6658 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6665 return SvIVX(sv) != 0;
6668 return SvNVX(sv) != 0.0;
6670 return sv_2bool(sv);
6678 A private implementation of the C<SvIVx> macro for compilers which can't
6679 cope with complex macro expressions. Always use the macro instead.
6685 Perl_sv_iv(pTHX_ register SV *sv)
6689 return (IV)SvUVX(sv);
6698 A private implementation of the C<SvUVx> macro for compilers which can't
6699 cope with complex macro expressions. Always use the macro instead.
6705 Perl_sv_uv(pTHX_ register SV *sv)
6710 return (UV)SvIVX(sv);
6718 A private implementation of the C<SvNVx> macro for compilers which can't
6719 cope with complex macro expressions. Always use the macro instead.
6725 Perl_sv_nv(pTHX_ register SV *sv)
6735 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6736 cope with complex macro expressions. Always use the macro instead.
6742 Perl_sv_pv(pTHX_ SV *sv)
6749 return sv_2pv(sv, &n_a);
6755 A private implementation of the C<SvPV> macro for compilers which can't
6756 cope with complex macro expressions. Always use the macro instead.
6762 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6768 return sv_2pv(sv, lp);
6771 /* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
6775 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
6781 return sv_2pv_flags(sv, lp, 0);
6785 =for apidoc sv_pvn_force
6787 Get a sensible string out of the SV somehow.
6788 A private implementation of the C<SvPV_force> macro for compilers which
6789 can't cope with complex macro expressions. Always use the macro instead.
6795 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6797 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6801 =for apidoc sv_pvn_force_flags
6803 Get a sensible string out of the SV somehow.
6804 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6805 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6806 implemented in terms of this function.
6807 You normally want to use the various wrapper macros instead: see
6808 C<SvPV_force> and C<SvPV_force_nomg>
6814 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6818 if (SvTHINKFIRST(sv) && !SvROK(sv))
6819 sv_force_normal(sv);
6825 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6826 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6830 s = sv_2pv_flags(sv, lp, flags);
6831 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6836 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6837 SvGROW(sv, len + 1);
6838 Move(s,SvPVX(sv),len,char);
6843 SvPOK_on(sv); /* validate pointer */
6845 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6846 PTR2UV(sv),SvPVX(sv)));
6853 =for apidoc sv_pvbyte
6855 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6856 which can't cope with complex macro expressions. Always use the macro
6863 Perl_sv_pvbyte(pTHX_ SV *sv)
6865 sv_utf8_downgrade(sv,0);
6870 =for apidoc sv_pvbyten
6872 A private implementation of the C<SvPVbyte> macro for compilers
6873 which can't cope with complex macro expressions. Always use the macro
6880 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6882 sv_utf8_downgrade(sv,0);
6883 return sv_pvn(sv,lp);
6887 =for apidoc sv_pvbyten_force
6889 A private implementation of the C<SvPVbytex_force> macro for compilers
6890 which can't cope with complex macro expressions. Always use the macro
6897 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6899 sv_utf8_downgrade(sv,0);
6900 return sv_pvn_force(sv,lp);
6904 =for apidoc sv_pvutf8
6906 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6907 which can't cope with complex macro expressions. Always use the macro
6914 Perl_sv_pvutf8(pTHX_ SV *sv)
6916 sv_utf8_upgrade(sv);
6921 =for apidoc sv_pvutf8n
6923 A private implementation of the C<SvPVutf8> macro for compilers
6924 which can't cope with complex macro expressions. Always use the macro
6931 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6933 sv_utf8_upgrade(sv);
6934 return sv_pvn(sv,lp);
6938 =for apidoc sv_pvutf8n_force
6940 A private implementation of the C<SvPVutf8_force> macro for compilers
6941 which can't cope with complex macro expressions. Always use the macro
6948 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6950 sv_utf8_upgrade(sv);
6951 return sv_pvn_force(sv,lp);
6955 =for apidoc sv_reftype
6957 Returns a string describing what the SV is a reference to.
6963 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6965 if (ob && SvOBJECT(sv)) {
6966 HV *svs = SvSTASH(sv);
6967 /* [20011101.072] This bandaid for C<package;> should eventually
6968 be removed. AMS 20011103 */
6969 return (svs ? HvNAME(svs) : "<none>");
6972 switch (SvTYPE(sv)) {
6986 case SVt_PVLV: return "LVALUE";
6987 case SVt_PVAV: return "ARRAY";
6988 case SVt_PVHV: return "HASH";
6989 case SVt_PVCV: return "CODE";
6990 case SVt_PVGV: return "GLOB";
6991 case SVt_PVFM: return "FORMAT";
6992 case SVt_PVIO: return "IO";
6993 default: return "UNKNOWN";
6999 =for apidoc sv_isobject
7001 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7002 object. If the SV is not an RV, or if the object is not blessed, then this
7009 Perl_sv_isobject(pTHX_ SV *sv)
7026 Returns a boolean indicating whether the SV is blessed into the specified
7027 class. This does not check for subtypes; use C<sv_derived_from> to verify
7028 an inheritance relationship.
7034 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7046 return strEQ(HvNAME(SvSTASH(sv)), name);
7052 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7053 it will be upgraded to one. If C<classname> is non-null then the new SV will
7054 be blessed in the specified package. The new SV is returned and its
7055 reference count is 1.
7061 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7067 SV_CHECK_THINKFIRST(rv);
7070 if (SvTYPE(rv) >= SVt_PVMG) {
7071 U32 refcnt = SvREFCNT(rv);
7075 SvREFCNT(rv) = refcnt;
7078 if (SvTYPE(rv) < SVt_RV)
7079 sv_upgrade(rv, SVt_RV);
7080 else if (SvTYPE(rv) > SVt_RV) {
7081 (void)SvOOK_off(rv);
7082 if (SvPVX(rv) && SvLEN(rv))
7083 Safefree(SvPVX(rv));
7093 HV* stash = gv_stashpv(classname, TRUE);
7094 (void)sv_bless(rv, stash);
7100 =for apidoc sv_setref_pv
7102 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7103 argument will be upgraded to an RV. That RV will be modified to point to
7104 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7105 into the SV. The C<classname> argument indicates the package for the
7106 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7107 will be returned and will have a reference count of 1.
7109 Do not use with other Perl types such as HV, AV, SV, CV, because those
7110 objects will become corrupted by the pointer copy process.
7112 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7118 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7121 sv_setsv(rv, &PL_sv_undef);
7125 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7130 =for apidoc sv_setref_iv
7132 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7133 argument will be upgraded to an RV. That RV will be modified to point to
7134 the new SV. The C<classname> argument indicates the package for the
7135 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7136 will be returned and will have a reference count of 1.
7142 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7144 sv_setiv(newSVrv(rv,classname), iv);
7149 =for apidoc sv_setref_uv
7151 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7152 argument will be upgraded to an RV. That RV will be modified to point to
7153 the new SV. The C<classname> argument indicates the package for the
7154 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7155 will be returned and will have a reference count of 1.
7161 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7163 sv_setuv(newSVrv(rv,classname), uv);
7168 =for apidoc sv_setref_nv
7170 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7171 argument will be upgraded to an RV. That RV will be modified to point to
7172 the new SV. The C<classname> argument indicates the package for the
7173 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7174 will be returned and will have a reference count of 1.
7180 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7182 sv_setnv(newSVrv(rv,classname), nv);
7187 =for apidoc sv_setref_pvn
7189 Copies a string into a new SV, optionally blessing the SV. The length of the
7190 string must be specified with C<n>. The C<rv> argument will be upgraded to
7191 an RV. That RV will be modified to point to the new SV. The C<classname>
7192 argument indicates the package for the blessing. Set C<classname> to
7193 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7194 a reference count of 1.
7196 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7202 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7204 sv_setpvn(newSVrv(rv,classname), pv, n);
7209 =for apidoc sv_bless
7211 Blesses an SV into a specified package. The SV must be an RV. The package
7212 must be designated by its stash (see C<gv_stashpv()>). The reference count
7213 of the SV is unaffected.
7219 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7223 Perl_croak(aTHX_ "Can't bless non-reference value");
7225 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7226 if (SvREADONLY(tmpRef))
7227 Perl_croak(aTHX_ PL_no_modify);
7228 if (SvOBJECT(tmpRef)) {
7229 if (SvTYPE(tmpRef) != SVt_PVIO)
7231 SvREFCNT_dec(SvSTASH(tmpRef));
7234 SvOBJECT_on(tmpRef);
7235 if (SvTYPE(tmpRef) != SVt_PVIO)
7237 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7238 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7245 if(SvSMAGICAL(tmpRef))
7246 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7254 /* Downgrades a PVGV to a PVMG.
7256 * XXX This function doesn't actually appear to be used anywhere
7261 S_sv_unglob(pTHX_ SV *sv)
7265 assert(SvTYPE(sv) == SVt_PVGV);
7270 SvREFCNT_dec(GvSTASH(sv));
7271 GvSTASH(sv) = Nullhv;
7273 sv_unmagic(sv, PERL_MAGIC_glob);
7274 Safefree(GvNAME(sv));
7277 /* need to keep SvANY(sv) in the right arena */
7278 xpvmg = new_XPVMG();
7279 StructCopy(SvANY(sv), xpvmg, XPVMG);
7280 del_XPVGV(SvANY(sv));
7283 SvFLAGS(sv) &= ~SVTYPEMASK;
7284 SvFLAGS(sv) |= SVt_PVMG;
7288 =for apidoc sv_unref_flags
7290 Unsets the RV status of the SV, and decrements the reference count of
7291 whatever was being referenced by the RV. This can almost be thought of
7292 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7293 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7294 (otherwise the decrementing is conditional on the reference count being
7295 different from one or the reference being a readonly SV).
7302 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7306 if (SvWEAKREF(sv)) {
7314 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7316 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7317 sv_2mortal(rv); /* Schedule for freeing later */
7321 =for apidoc sv_unref
7323 Unsets the RV status of the SV, and decrements the reference count of
7324 whatever was being referenced by the RV. This can almost be thought of
7325 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7326 being zero. See C<SvROK_off>.
7332 Perl_sv_unref(pTHX_ SV *sv)
7334 sv_unref_flags(sv, 0);
7338 =for apidoc sv_taint
7340 Taint an SV. Use C<SvTAINTED_on> instead.
7345 Perl_sv_taint(pTHX_ SV *sv)
7347 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7351 =for apidoc sv_untaint
7353 Untaint an SV. Use C<SvTAINTED_off> instead.
7358 Perl_sv_untaint(pTHX_ SV *sv)
7360 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7361 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7368 =for apidoc sv_tainted
7370 Test an SV for taintedness. Use C<SvTAINTED> instead.
7375 Perl_sv_tainted(pTHX_ SV *sv)
7377 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7378 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7379 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7386 =for apidoc sv_setpviv
7388 Copies an integer into the given SV, also updating its string value.
7389 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7395 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7397 char buf[TYPE_CHARS(UV)];
7399 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7401 sv_setpvn(sv, ptr, ebuf - ptr);
7405 =for apidoc sv_setpviv_mg
7407 Like C<sv_setpviv>, but also handles 'set' magic.
7413 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7415 char buf[TYPE_CHARS(UV)];
7417 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7419 sv_setpvn(sv, ptr, ebuf - ptr);
7423 #if defined(PERL_IMPLICIT_CONTEXT)
7425 /* pTHX_ magic can't cope with varargs, so this is a no-context
7426 * version of the main function, (which may itself be aliased to us).
7427 * Don't access this version directly.
7431 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7435 va_start(args, pat);
7436 sv_vsetpvf(sv, pat, &args);
7440 /* pTHX_ magic can't cope with varargs, so this is a no-context
7441 * version of the main function, (which may itself be aliased to us).
7442 * Don't access this version directly.
7446 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7450 va_start(args, pat);
7451 sv_vsetpvf_mg(sv, pat, &args);
7457 =for apidoc sv_setpvf
7459 Processes its arguments like C<sprintf> and sets an SV to the formatted
7460 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7466 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7469 va_start(args, pat);
7470 sv_vsetpvf(sv, pat, &args);
7474 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7477 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7479 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7483 =for apidoc sv_setpvf_mg
7485 Like C<sv_setpvf>, but also handles 'set' magic.
7491 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7494 va_start(args, pat);
7495 sv_vsetpvf_mg(sv, pat, &args);
7499 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7502 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7504 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7508 #if defined(PERL_IMPLICIT_CONTEXT)
7510 /* pTHX_ magic can't cope with varargs, so this is a no-context
7511 * version of the main function, (which may itself be aliased to us).
7512 * Don't access this version directly.
7516 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7520 va_start(args, pat);
7521 sv_vcatpvf(sv, pat, &args);
7525 /* pTHX_ magic can't cope with varargs, so this is a no-context
7526 * version of the main function, (which may itself be aliased to us).
7527 * Don't access this version directly.
7531 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7535 va_start(args, pat);
7536 sv_vcatpvf_mg(sv, pat, &args);
7542 =for apidoc sv_catpvf
7544 Processes its arguments like C<sprintf> and appends the formatted
7545 output to an SV. If the appended data contains "wide" characters
7546 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7547 and characters >255 formatted with %c), the original SV might get
7548 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7549 C<SvSETMAGIC()> must typically be called after calling this function
7550 to handle 'set' magic.
7555 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7558 va_start(args, pat);
7559 sv_vcatpvf(sv, pat, &args);
7563 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7566 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7568 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7572 =for apidoc sv_catpvf_mg
7574 Like C<sv_catpvf>, but also handles 'set' magic.
7580 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7583 va_start(args, pat);
7584 sv_vcatpvf_mg(sv, pat, &args);
7588 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7591 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7593 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7598 =for apidoc sv_vsetpvfn
7600 Works like C<vcatpvfn> but copies the text into the SV instead of
7603 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7609 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7611 sv_setpvn(sv, "", 0);
7612 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7615 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7618 S_expect_number(pTHX_ char** pattern)
7621 switch (**pattern) {
7622 case '1': case '2': case '3':
7623 case '4': case '5': case '6':
7624 case '7': case '8': case '9':
7625 while (isDIGIT(**pattern))
7626 var = var * 10 + (*(*pattern)++ - '0');
7630 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7633 =for apidoc sv_vcatpvfn
7635 Processes its arguments like C<vsprintf> and appends the formatted output
7636 to an SV. Uses an array of SVs if the C style variable argument list is
7637 missing (NULL). When running with taint checks enabled, indicates via
7638 C<maybe_tainted> if results are untrustworthy (often due to the use of
7641 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7647 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7654 static char nullstr[] = "(null)";
7657 /* no matter what, this is a string now */
7658 (void)SvPV_force(sv, origlen);
7660 /* special-case "", "%s", and "%_" */
7663 if (patlen == 2 && pat[0] == '%') {
7667 char *s = va_arg(*args, char*);
7668 sv_catpv(sv, s ? s : nullstr);
7670 else if (svix < svmax) {
7671 sv_catsv(sv, *svargs);
7672 if (DO_UTF8(*svargs))
7678 argsv = va_arg(*args, SV*);
7679 sv_catsv(sv, argsv);
7684 /* See comment on '_' below */
7689 patend = (char*)pat + patlen;
7690 for (p = (char*)pat; p < patend; p = q) {
7693 bool vectorize = FALSE;
7694 bool vectorarg = FALSE;
7695 bool vec_utf = FALSE;
7701 bool has_precis = FALSE;
7703 bool is_utf = FALSE;
7706 U8 utf8buf[UTF8_MAXLEN+1];
7707 STRLEN esignlen = 0;
7709 char *eptr = Nullch;
7711 /* Times 4: a decimal digit takes more than 3 binary digits.
7712 * NV_DIG: mantissa takes than many decimal digits.
7713 * Plus 32: Playing safe. */
7714 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7715 /* large enough for "%#.#f" --chip */
7716 /* what about long double NVs? --jhi */
7719 U8 *vecstr = Null(U8*);
7731 STRLEN dotstrlen = 1;
7732 I32 efix = 0; /* explicit format parameter index */
7733 I32 ewix = 0; /* explicit width index */
7734 I32 epix = 0; /* explicit precision index */
7735 I32 evix = 0; /* explicit vector index */
7736 bool asterisk = FALSE;
7738 /* echo everything up to the next format specification */
7739 for (q = p; q < patend && *q != '%'; ++q) ;
7741 sv_catpvn(sv, p, q - p);
7748 We allow format specification elements in this order:
7749 \d+\$ explicit format parameter index
7751 \*?(\d+\$)?v vector with optional (optionally specified) arg
7752 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7753 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7755 [%bcdefginopsux_DFOUX] format (mandatory)
7757 if (EXPECT_NUMBER(q, width)) {
7798 if (EXPECT_NUMBER(q, ewix))
7807 if ((vectorarg = asterisk)) {
7817 EXPECT_NUMBER(q, width);
7822 vecsv = va_arg(*args, SV*);
7824 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7825 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7826 dotstr = SvPVx(vecsv, dotstrlen);
7831 vecsv = va_arg(*args, SV*);
7832 vecstr = (U8*)SvPVx(vecsv,veclen);
7833 vec_utf = DO_UTF8(vecsv);
7835 else if (efix ? efix <= svmax : svix < svmax) {
7836 vecsv = svargs[efix ? efix-1 : svix++];
7837 vecstr = (U8*)SvPVx(vecsv,veclen);
7838 vec_utf = DO_UTF8(vecsv);
7848 i = va_arg(*args, int);
7850 i = (ewix ? ewix <= svmax : svix < svmax) ?
7851 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7853 width = (i < 0) ? -i : i;
7863 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7866 i = va_arg(*args, int);
7868 i = (ewix ? ewix <= svmax : svix < svmax)
7869 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7870 precis = (i < 0) ? 0 : i;
7875 precis = precis * 10 + (*q++ - '0');
7883 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7894 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7895 if (*(q + 1) == 'l') { /* lld, llf */
7918 argsv = (efix ? efix <= svmax : svix < svmax) ?
7919 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7926 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7928 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7930 eptr = (char*)utf8buf;
7931 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7943 eptr = va_arg(*args, char*);
7945 #ifdef MACOS_TRADITIONAL
7946 /* On MacOS, %#s format is used for Pascal strings */
7951 elen = strlen(eptr);
7954 elen = sizeof nullstr - 1;
7958 eptr = SvPVx(argsv, elen);
7959 if (DO_UTF8(argsv)) {
7960 if (has_precis && precis < elen) {
7962 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7965 if (width) { /* fudge width (can't fudge elen) */
7966 width += elen - sv_len_utf8(argsv);
7975 * The "%_" hack might have to be changed someday,
7976 * if ISO or ANSI decide to use '_' for something.
7977 * So we keep it hidden from users' code.
7981 argsv = va_arg(*args, SV*);
7982 eptr = SvPVx(argsv, elen);
7988 if (has_precis && elen > precis)
7997 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8015 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8023 esignbuf[esignlen++] = plus;
8027 case 'h': iv = (short)va_arg(*args, int); break;
8028 default: iv = va_arg(*args, int); break;
8029 case 'l': iv = va_arg(*args, long); break;
8030 case 'V': iv = va_arg(*args, IV); break;
8032 case 'q': iv = va_arg(*args, Quad_t); break;
8039 case 'h': iv = (short)iv; break;
8041 case 'l': iv = (long)iv; break;
8044 case 'q': iv = (Quad_t)iv; break;
8048 if ( !vectorize ) /* we already set uv above */
8053 esignbuf[esignlen++] = plus;
8057 esignbuf[esignlen++] = '-';
8100 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8110 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8111 default: uv = va_arg(*args, unsigned); break;
8112 case 'l': uv = va_arg(*args, unsigned long); break;
8113 case 'V': uv = va_arg(*args, UV); break;
8115 case 'q': uv = va_arg(*args, Quad_t); break;
8122 case 'h': uv = (unsigned short)uv; break;
8124 case 'l': uv = (unsigned long)uv; break;
8127 case 'q': uv = (Quad_t)uv; break;
8133 eptr = ebuf + sizeof ebuf;
8139 p = (char*)((c == 'X')
8140 ? "0123456789ABCDEF" : "0123456789abcdef");
8146 esignbuf[esignlen++] = '0';
8147 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8153 *--eptr = '0' + dig;
8155 if (alt && *eptr != '0')
8161 *--eptr = '0' + dig;
8164 esignbuf[esignlen++] = '0';
8165 esignbuf[esignlen++] = 'b';
8168 default: /* it had better be ten or less */
8169 #if defined(PERL_Y2KWARN)
8170 if (ckWARN(WARN_Y2K)) {
8172 char *s = SvPV(sv,n);
8173 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8174 && (n == 2 || !isDIGIT(s[n-3])))
8176 Perl_warner(aTHX_ WARN_Y2K,
8177 "Possible Y2K bug: %%%c %s",
8178 c, "format string following '19'");
8184 *--eptr = '0' + dig;
8185 } while (uv /= base);
8188 elen = (ebuf + sizeof ebuf) - eptr;
8191 zeros = precis - elen;
8192 else if (precis == 0 && elen == 1 && *eptr == '0')
8197 /* FLOATING POINT */
8200 c = 'f'; /* maybe %F isn't supported here */
8206 /* This is evil, but floating point is even more evil */
8209 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8212 if (c != 'e' && c != 'E') {
8214 (void)Perl_frexp(nv, &i);
8215 if (i == PERL_INT_MIN)
8216 Perl_die(aTHX_ "panic: frexp");
8218 need = BIT_DIGITS(i);
8220 need += has_precis ? precis : 6; /* known default */
8224 need += 20; /* fudge factor */
8225 if (PL_efloatsize < need) {
8226 Safefree(PL_efloatbuf);
8227 PL_efloatsize = need + 20; /* more fudge */
8228 New(906, PL_efloatbuf, PL_efloatsize, char);
8229 PL_efloatbuf[0] = '\0';
8232 eptr = ebuf + sizeof ebuf;
8235 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8237 /* Copy the one or more characters in a long double
8238 * format before the 'base' ([efgEFG]) character to
8239 * the format string. */
8240 static char const prifldbl[] = PERL_PRIfldbl;
8241 char const *p = prifldbl + sizeof(prifldbl) - 3;
8242 while (p >= prifldbl) { *--eptr = *p--; }
8247 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8252 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8264 /* No taint. Otherwise we are in the strange situation
8265 * where printf() taints but print($float) doesn't.
8267 (void)sprintf(PL_efloatbuf, eptr, nv);
8269 eptr = PL_efloatbuf;
8270 elen = strlen(PL_efloatbuf);
8277 i = SvCUR(sv) - origlen;
8280 case 'h': *(va_arg(*args, short*)) = i; break;
8281 default: *(va_arg(*args, int*)) = i; break;
8282 case 'l': *(va_arg(*args, long*)) = i; break;
8283 case 'V': *(va_arg(*args, IV*)) = i; break;
8285 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8290 sv_setuv_mg(argsv, (UV)i);
8291 continue; /* not "break" */
8298 if (!args && ckWARN(WARN_PRINTF) &&
8299 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8300 SV *msg = sv_newmortal();
8301 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8302 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8305 Perl_sv_catpvf(aTHX_ msg,
8306 "\"%%%c\"", c & 0xFF);
8308 Perl_sv_catpvf(aTHX_ msg,
8309 "\"%%\\%03"UVof"\"",
8312 sv_catpv(msg, "end of string");
8313 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8316 /* output mangled stuff ... */
8322 /* ... right here, because formatting flags should not apply */
8323 SvGROW(sv, SvCUR(sv) + elen + 1);
8325 Copy(eptr, p, elen, char);
8328 SvCUR(sv) = p - SvPVX(sv);
8329 continue; /* not "break" */
8332 have = esignlen + zeros + elen;
8333 need = (have > width ? have : width);
8336 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8338 if (esignlen && fill == '0') {
8339 for (i = 0; i < esignlen; i++)
8343 memset(p, fill, gap);
8346 if (esignlen && fill != '0') {
8347 for (i = 0; i < esignlen; i++)
8351 for (i = zeros; i; i--)
8355 Copy(eptr, p, elen, char);
8359 memset(p, ' ', gap);
8364 Copy(dotstr, p, dotstrlen, char);
8368 vectorize = FALSE; /* done iterating over vecstr */
8373 SvCUR(sv) = p - SvPVX(sv);
8381 /* =========================================================================
8383 =head1 Cloning an interpreter
8385 All the macros and functions in this section are for the private use of
8386 the main function, perl_clone().
8388 The foo_dup() functions make an exact copy of an existing foo thinngy.
8389 During the course of a cloning, a hash table is used to map old addresses
8390 to new addresses. The table is created and manipulated with the
8391 ptr_table_* functions.
8395 ============================================================================*/
8398 #if defined(USE_ITHREADS)
8400 #if defined(USE_5005THREADS)
8401 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8404 #ifndef GpREFCNT_inc
8405 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8409 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8410 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8411 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8412 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8413 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8414 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8415 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8416 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8417 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8418 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8419 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8420 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8421 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8424 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8425 regcomp.c. AMS 20010712 */
8428 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8432 struct reg_substr_datum *s;
8435 return (REGEXP *)NULL;
8437 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8440 len = r->offsets[0];
8441 npar = r->nparens+1;
8443 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8444 Copy(r->program, ret->program, len+1, regnode);
8446 New(0, ret->startp, npar, I32);
8447 Copy(r->startp, ret->startp, npar, I32);
8448 New(0, ret->endp, npar, I32);
8449 Copy(r->startp, ret->startp, npar, I32);
8451 New(0, ret->substrs, 1, struct reg_substr_data);
8452 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8453 s->min_offset = r->substrs->data[i].min_offset;
8454 s->max_offset = r->substrs->data[i].max_offset;
8455 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8458 ret->regstclass = NULL;
8461 int count = r->data->count;
8463 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8464 char, struct reg_data);
8465 New(0, d->what, count, U8);
8468 for (i = 0; i < count; i++) {
8469 d->what[i] = r->data->what[i];
8470 switch (d->what[i]) {
8472 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8475 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8478 /* This is cheating. */
8479 New(0, d->data[i], 1, struct regnode_charclass_class);
8480 StructCopy(r->data->data[i], d->data[i],
8481 struct regnode_charclass_class);
8482 ret->regstclass = (regnode*)d->data[i];
8485 /* Compiled op trees are readonly, and can thus be
8486 shared without duplication. */
8487 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8490 d->data[i] = r->data->data[i];
8500 New(0, ret->offsets, 2*len+1, U32);
8501 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8503 ret->precomp = SAVEPV(r->precomp);
8504 ret->refcnt = r->refcnt;
8505 ret->minlen = r->minlen;
8506 ret->prelen = r->prelen;
8507 ret->nparens = r->nparens;
8508 ret->lastparen = r->lastparen;
8509 ret->lastcloseparen = r->lastcloseparen;
8510 ret->reganch = r->reganch;
8512 ret->sublen = r->sublen;
8514 if (RX_MATCH_COPIED(ret))
8515 ret->subbeg = SAVEPV(r->subbeg);
8517 ret->subbeg = Nullch;
8519 ptr_table_store(PL_ptr_table, r, ret);
8523 /* duplicate a file handle */
8526 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8530 return (PerlIO*)NULL;
8532 /* look for it in the table first */
8533 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8537 /* create anew and remember what it is */
8538 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
8539 ptr_table_store(PL_ptr_table, fp, ret);
8543 /* duplicate a directory handle */
8546 Perl_dirp_dup(pTHX_ DIR *dp)
8554 /* duplicate a typeglob */
8557 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8562 /* look for it in the table first */
8563 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8567 /* create anew and remember what it is */
8568 Newz(0, ret, 1, GP);
8569 ptr_table_store(PL_ptr_table, gp, ret);
8572 ret->gp_refcnt = 0; /* must be before any other dups! */
8573 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8574 ret->gp_io = io_dup_inc(gp->gp_io, param);
8575 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8576 ret->gp_av = av_dup_inc(gp->gp_av, param);
8577 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8578 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8579 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8580 ret->gp_cvgen = gp->gp_cvgen;
8581 ret->gp_flags = gp->gp_flags;
8582 ret->gp_line = gp->gp_line;
8583 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8587 /* duplicate a chain of magic */
8590 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8592 MAGIC *mgprev = (MAGIC*)NULL;
8595 return (MAGIC*)NULL;
8596 /* look for it in the table first */
8597 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8601 for (; mg; mg = mg->mg_moremagic) {
8603 Newz(0, nmg, 1, MAGIC);
8605 mgprev->mg_moremagic = nmg;
8608 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8609 nmg->mg_private = mg->mg_private;
8610 nmg->mg_type = mg->mg_type;
8611 nmg->mg_flags = mg->mg_flags;
8612 if (mg->mg_type == PERL_MAGIC_qr) {
8613 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8615 else if(mg->mg_type == PERL_MAGIC_backref) {
8616 AV *av = (AV*) mg->mg_obj;
8619 nmg->mg_obj = (SV*)newAV();
8623 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8628 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8629 ? sv_dup_inc(mg->mg_obj, param)
8630 : sv_dup(mg->mg_obj, param);
8632 nmg->mg_len = mg->mg_len;
8633 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8634 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8635 if (mg->mg_len >= 0) {
8636 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8637 if (mg->mg_type == PERL_MAGIC_overload_table &&
8638 AMT_AMAGIC((AMT*)mg->mg_ptr))
8640 AMT *amtp = (AMT*)mg->mg_ptr;
8641 AMT *namtp = (AMT*)nmg->mg_ptr;
8643 for (i = 1; i < NofAMmeth; i++) {
8644 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8648 else if (mg->mg_len == HEf_SVKEY)
8649 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8656 /* create a new pointer-mapping table */
8659 Perl_ptr_table_new(pTHX)
8662 Newz(0, tbl, 1, PTR_TBL_t);
8665 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8669 /* map an existing pointer using a table */
8672 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8674 PTR_TBL_ENT_t *tblent;
8675 UV hash = PTR2UV(sv);
8677 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8678 for (; tblent; tblent = tblent->next) {
8679 if (tblent->oldval == sv)
8680 return tblent->newval;
8685 /* add a new entry to a pointer-mapping table */
8688 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8690 PTR_TBL_ENT_t *tblent, **otblent;
8691 /* XXX this may be pessimal on platforms where pointers aren't good
8692 * hash values e.g. if they grow faster in the most significant
8694 UV hash = PTR2UV(oldv);
8698 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8699 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8700 if (tblent->oldval == oldv) {
8701 tblent->newval = newv;
8706 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8707 tblent->oldval = oldv;
8708 tblent->newval = newv;
8709 tblent->next = *otblent;
8712 if (i && tbl->tbl_items > tbl->tbl_max)
8713 ptr_table_split(tbl);
8716 /* double the hash bucket size of an existing ptr table */
8719 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8721 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8722 UV oldsize = tbl->tbl_max + 1;
8723 UV newsize = oldsize * 2;
8726 Renew(ary, newsize, PTR_TBL_ENT_t*);
8727 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8728 tbl->tbl_max = --newsize;
8730 for (i=0; i < oldsize; i++, ary++) {
8731 PTR_TBL_ENT_t **curentp, **entp, *ent;
8734 curentp = ary + oldsize;
8735 for (entp = ary, ent = *ary; ent; ent = *entp) {
8736 if ((newsize & PTR2UV(ent->oldval)) != i) {
8738 ent->next = *curentp;
8748 /* remove all the entries from a ptr table */
8751 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8753 register PTR_TBL_ENT_t **array;
8754 register PTR_TBL_ENT_t *entry;
8755 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8759 if (!tbl || !tbl->tbl_items) {
8763 array = tbl->tbl_ary;
8770 entry = entry->next;
8774 if (++riter > max) {
8777 entry = array[riter];
8784 /* clear and free a ptr table */
8787 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8792 ptr_table_clear(tbl);
8793 Safefree(tbl->tbl_ary);
8801 /* attempt to make everything in the typeglob readonly */
8804 S_gv_share(pTHX_ SV *sstr)
8807 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8809 if (GvIO(gv) || GvFORM(gv)) {
8810 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8812 else if (!GvCV(gv)) {
8816 /* CvPADLISTs cannot be shared */
8817 if (!CvXSUB(GvCV(gv))) {
8822 if (!GvUNIQUE(gv)) {
8824 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8825 HvNAME(GvSTASH(gv)), GvNAME(gv));
8831 * write attempts will die with
8832 * "Modification of a read-only value attempted"
8838 SvREADONLY_on(GvSV(gv));
8845 SvREADONLY_on(GvAV(gv));
8852 SvREADONLY_on(GvAV(gv));
8855 return sstr; /* he_dup() will SvREFCNT_inc() */
8858 /* duplicate an SV of any type (including AV, HV etc) */
8861 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
8865 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8867 /* look for it in the table first */
8868 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8872 /* create anew and remember what it is */
8874 ptr_table_store(PL_ptr_table, sstr, dstr);
8877 SvFLAGS(dstr) = SvFLAGS(sstr);
8878 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8879 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8882 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8883 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8884 PL_watch_pvx, SvPVX(sstr));
8887 switch (SvTYPE(sstr)) {
8892 SvANY(dstr) = new_XIV();
8893 SvIVX(dstr) = SvIVX(sstr);
8896 SvANY(dstr) = new_XNV();
8897 SvNVX(dstr) = SvNVX(sstr);
8900 SvANY(dstr) = new_XRV();
8901 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8902 ? sv_dup(SvRV(sstr), param)
8903 : sv_dup_inc(SvRV(sstr), param);
8906 SvANY(dstr) = new_XPV();
8907 SvCUR(dstr) = SvCUR(sstr);
8908 SvLEN(dstr) = SvLEN(sstr);
8910 SvRV(dstr) = SvWEAKREF(sstr)
8911 ? sv_dup(SvRV(sstr), param)
8912 : sv_dup_inc(SvRV(sstr), param);
8913 else if (SvPVX(sstr) && SvLEN(sstr))
8914 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8916 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8919 SvANY(dstr) = new_XPVIV();
8920 SvCUR(dstr) = SvCUR(sstr);
8921 SvLEN(dstr) = SvLEN(sstr);
8922 SvIVX(dstr) = SvIVX(sstr);
8924 SvRV(dstr) = SvWEAKREF(sstr)
8925 ? sv_dup(SvRV(sstr), param)
8926 : sv_dup_inc(SvRV(sstr), param);
8927 else if (SvPVX(sstr) && SvLEN(sstr))
8928 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8930 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8933 SvANY(dstr) = new_XPVNV();
8934 SvCUR(dstr) = SvCUR(sstr);
8935 SvLEN(dstr) = SvLEN(sstr);
8936 SvIVX(dstr) = SvIVX(sstr);
8937 SvNVX(dstr) = SvNVX(sstr);
8939 SvRV(dstr) = SvWEAKREF(sstr)
8940 ? sv_dup(SvRV(sstr), param)
8941 : sv_dup_inc(SvRV(sstr), param);
8942 else if (SvPVX(sstr) && SvLEN(sstr))
8943 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8945 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8948 SvANY(dstr) = new_XPVMG();
8949 SvCUR(dstr) = SvCUR(sstr);
8950 SvLEN(dstr) = SvLEN(sstr);
8951 SvIVX(dstr) = SvIVX(sstr);
8952 SvNVX(dstr) = SvNVX(sstr);
8953 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8954 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8956 SvRV(dstr) = SvWEAKREF(sstr)
8957 ? sv_dup(SvRV(sstr), param)
8958 : sv_dup_inc(SvRV(sstr), param);
8959 else if (SvPVX(sstr) && SvLEN(sstr))
8960 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8962 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8965 SvANY(dstr) = new_XPVBM();
8966 SvCUR(dstr) = SvCUR(sstr);
8967 SvLEN(dstr) = SvLEN(sstr);
8968 SvIVX(dstr) = SvIVX(sstr);
8969 SvNVX(dstr) = SvNVX(sstr);
8970 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8971 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8973 SvRV(dstr) = SvWEAKREF(sstr)
8974 ? sv_dup(SvRV(sstr), param)
8975 : sv_dup_inc(SvRV(sstr), param);
8976 else if (SvPVX(sstr) && SvLEN(sstr))
8977 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8979 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8980 BmRARE(dstr) = BmRARE(sstr);
8981 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8982 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8985 SvANY(dstr) = new_XPVLV();
8986 SvCUR(dstr) = SvCUR(sstr);
8987 SvLEN(dstr) = SvLEN(sstr);
8988 SvIVX(dstr) = SvIVX(sstr);
8989 SvNVX(dstr) = SvNVX(sstr);
8990 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8991 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8993 SvRV(dstr) = SvWEAKREF(sstr)
8994 ? sv_dup(SvRV(sstr), param)
8995 : sv_dup_inc(SvRV(sstr), param);
8996 else if (SvPVX(sstr) && SvLEN(sstr))
8997 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8999 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9000 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
9001 LvTARGLEN(dstr) = LvTARGLEN(sstr);
9002 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
9003 LvTYPE(dstr) = LvTYPE(sstr);
9006 if (GvUNIQUE((GV*)sstr)) {
9008 if ((share = gv_share(sstr))) {
9012 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9013 HvNAME(GvSTASH(share)), GvNAME(share));
9018 SvANY(dstr) = new_XPVGV();
9019 SvCUR(dstr) = SvCUR(sstr);
9020 SvLEN(dstr) = SvLEN(sstr);
9021 SvIVX(dstr) = SvIVX(sstr);
9022 SvNVX(dstr) = SvNVX(sstr);
9023 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9024 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9026 SvRV(dstr) = SvWEAKREF(sstr)
9027 ? sv_dup(SvRV(sstr), param)
9028 : sv_dup_inc(SvRV(sstr), param);
9029 else if (SvPVX(sstr) && SvLEN(sstr))
9030 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9032 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9033 GvNAMELEN(dstr) = GvNAMELEN(sstr);
9034 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9035 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
9036 GvFLAGS(dstr) = GvFLAGS(sstr);
9037 GvGP(dstr) = gp_dup(GvGP(sstr), param);
9038 (void)GpREFCNT_inc(GvGP(dstr));
9041 SvANY(dstr) = new_XPVIO();
9042 SvCUR(dstr) = SvCUR(sstr);
9043 SvLEN(dstr) = SvLEN(sstr);
9044 SvIVX(dstr) = SvIVX(sstr);
9045 SvNVX(dstr) = SvNVX(sstr);
9046 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9047 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9049 SvRV(dstr) = SvWEAKREF(sstr)
9050 ? sv_dup(SvRV(sstr), param)
9051 : sv_dup_inc(SvRV(sstr), param);
9052 else if (SvPVX(sstr) && SvLEN(sstr))
9053 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9055 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9056 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9057 if (IoOFP(sstr) == IoIFP(sstr))
9058 IoOFP(dstr) = IoIFP(dstr);
9060 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9061 /* PL_rsfp_filters entries have fake IoDIRP() */
9062 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9063 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
9065 IoDIRP(dstr) = IoDIRP(sstr);
9066 IoLINES(dstr) = IoLINES(sstr);
9067 IoPAGE(dstr) = IoPAGE(sstr);
9068 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
9069 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
9070 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
9071 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
9072 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
9073 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
9074 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
9075 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
9076 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
9077 IoTYPE(dstr) = IoTYPE(sstr);
9078 IoFLAGS(dstr) = IoFLAGS(sstr);
9081 SvANY(dstr) = new_XPVAV();
9082 SvCUR(dstr) = SvCUR(sstr);
9083 SvLEN(dstr) = SvLEN(sstr);
9084 SvIVX(dstr) = SvIVX(sstr);
9085 SvNVX(dstr) = SvNVX(sstr);
9086 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9087 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9088 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9089 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9090 if (AvARRAY((AV*)sstr)) {
9091 SV **dst_ary, **src_ary;
9092 SSize_t items = AvFILLp((AV*)sstr) + 1;
9094 src_ary = AvARRAY((AV*)sstr);
9095 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9096 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9097 SvPVX(dstr) = (char*)dst_ary;
9098 AvALLOC((AV*)dstr) = dst_ary;
9099 if (AvREAL((AV*)sstr)) {
9101 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9105 *dst_ary++ = sv_dup(*src_ary++, param);
9107 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9108 while (items-- > 0) {
9109 *dst_ary++ = &PL_sv_undef;
9113 SvPVX(dstr) = Nullch;
9114 AvALLOC((AV*)dstr) = (SV**)NULL;
9118 SvANY(dstr) = new_XPVHV();
9119 SvCUR(dstr) = SvCUR(sstr);
9120 SvLEN(dstr) = SvLEN(sstr);
9121 SvIVX(dstr) = SvIVX(sstr);
9122 SvNVX(dstr) = SvNVX(sstr);
9123 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9124 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9125 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9126 if (HvARRAY((HV*)sstr)) {
9128 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9129 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9130 Newz(0, dxhv->xhv_array,
9131 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9132 while (i <= sxhv->xhv_max) {
9133 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9134 !!HvSHAREKEYS(sstr), param);
9137 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9140 SvPVX(dstr) = Nullch;
9141 HvEITER((HV*)dstr) = (HE*)NULL;
9143 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9144 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9145 /* Record stashes for possible cloning in Perl_clone(). */
9146 if(HvNAME((HV*)dstr))
9147 av_push(param->stashes, dstr);
9150 SvANY(dstr) = new_XPVFM();
9151 FmLINES(dstr) = FmLINES(sstr);
9155 SvANY(dstr) = new_XPVCV();
9157 SvCUR(dstr) = SvCUR(sstr);
9158 SvLEN(dstr) = SvLEN(sstr);
9159 SvIVX(dstr) = SvIVX(sstr);
9160 SvNVX(dstr) = SvNVX(sstr);
9161 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9162 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9163 if (SvPVX(sstr) && SvLEN(sstr))
9164 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9166 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9167 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9168 CvSTART(dstr) = CvSTART(sstr);
9169 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9170 CvXSUB(dstr) = CvXSUB(sstr);
9171 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9172 if (CvCONST(sstr)) {
9173 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9174 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9175 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9177 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9178 if (param->flags & CLONEf_COPY_STACKS) {
9179 CvDEPTH(dstr) = CvDEPTH(sstr);
9183 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9184 /* XXX padlists are real, but pretend to be not */
9185 AvREAL_on(CvPADLIST(sstr));
9186 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9187 AvREAL_off(CvPADLIST(sstr));
9188 AvREAL_off(CvPADLIST(dstr));
9191 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9192 if (!CvANON(sstr) || CvCLONED(sstr))
9193 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9195 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9196 CvFLAGS(dstr) = CvFLAGS(sstr);
9197 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9200 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9204 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9210 /* duplicate a context */
9213 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9218 return (PERL_CONTEXT*)NULL;
9220 /* look for it in the table first */
9221 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9225 /* create anew and remember what it is */
9226 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9227 ptr_table_store(PL_ptr_table, cxs, ncxs);
9230 PERL_CONTEXT *cx = &cxs[ix];
9231 PERL_CONTEXT *ncx = &ncxs[ix];
9232 ncx->cx_type = cx->cx_type;
9233 if (CxTYPE(cx) == CXt_SUBST) {
9234 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9237 ncx->blk_oldsp = cx->blk_oldsp;
9238 ncx->blk_oldcop = cx->blk_oldcop;
9239 ncx->blk_oldretsp = cx->blk_oldretsp;
9240 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9241 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9242 ncx->blk_oldpm = cx->blk_oldpm;
9243 ncx->blk_gimme = cx->blk_gimme;
9244 switch (CxTYPE(cx)) {
9246 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9247 ? cv_dup_inc(cx->blk_sub.cv, param)
9248 : cv_dup(cx->blk_sub.cv,param));
9249 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9250 ? av_dup_inc(cx->blk_sub.argarray, param)
9252 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9253 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9254 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9255 ncx->blk_sub.lval = cx->blk_sub.lval;
9258 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9259 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9260 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9261 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9262 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9265 ncx->blk_loop.label = cx->blk_loop.label;
9266 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9267 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9268 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9269 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9270 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9271 ? cx->blk_loop.iterdata
9272 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9273 ncx->blk_loop.oldcurpad
9274 = (SV**)ptr_table_fetch(PL_ptr_table,
9275 cx->blk_loop.oldcurpad);
9276 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9277 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9278 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9279 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9280 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9283 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9284 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9285 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9286 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9298 /* duplicate a stack info structure */
9301 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9306 return (PERL_SI*)NULL;
9308 /* look for it in the table first */
9309 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9313 /* create anew and remember what it is */
9314 Newz(56, nsi, 1, PERL_SI);
9315 ptr_table_store(PL_ptr_table, si, nsi);
9317 nsi->si_stack = av_dup_inc(si->si_stack, param);
9318 nsi->si_cxix = si->si_cxix;
9319 nsi->si_cxmax = si->si_cxmax;
9320 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9321 nsi->si_type = si->si_type;
9322 nsi->si_prev = si_dup(si->si_prev, param);
9323 nsi->si_next = si_dup(si->si_next, param);
9324 nsi->si_markoff = si->si_markoff;
9329 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9330 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9331 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9332 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9333 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9334 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9335 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9336 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9337 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9338 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9339 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9340 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9343 #define pv_dup_inc(p) SAVEPV(p)
9344 #define pv_dup(p) SAVEPV(p)
9345 #define svp_dup_inc(p,pp) any_dup(p,pp)
9347 /* map any object to the new equivent - either something in the
9348 * ptr table, or something in the interpreter structure
9352 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9359 /* look for it in the table first */
9360 ret = ptr_table_fetch(PL_ptr_table, v);
9364 /* see if it is part of the interpreter structure */
9365 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9366 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9373 /* duplicate the save stack */
9376 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9378 ANY *ss = proto_perl->Tsavestack;
9379 I32 ix = proto_perl->Tsavestack_ix;
9380 I32 max = proto_perl->Tsavestack_max;
9393 void (*dptr) (void*);
9394 void (*dxptr) (pTHX_ void*);
9397 Newz(54, nss, max, ANY);
9403 case SAVEt_ITEM: /* normal string */
9404 sv = (SV*)POPPTR(ss,ix);
9405 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9406 sv = (SV*)POPPTR(ss,ix);
9407 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9409 case SAVEt_SV: /* scalar reference */
9410 sv = (SV*)POPPTR(ss,ix);
9411 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9412 gv = (GV*)POPPTR(ss,ix);
9413 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9415 case SAVEt_GENERIC_PVREF: /* generic char* */
9416 c = (char*)POPPTR(ss,ix);
9417 TOPPTR(nss,ix) = pv_dup(c);
9418 ptr = POPPTR(ss,ix);
9419 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9421 case SAVEt_GENERIC_SVREF: /* generic sv */
9422 case SAVEt_SVREF: /* scalar reference */
9423 sv = (SV*)POPPTR(ss,ix);
9424 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9425 ptr = POPPTR(ss,ix);
9426 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9428 case SAVEt_AV: /* array reference */
9429 av = (AV*)POPPTR(ss,ix);
9430 TOPPTR(nss,ix) = av_dup_inc(av, param);
9431 gv = (GV*)POPPTR(ss,ix);
9432 TOPPTR(nss,ix) = gv_dup(gv, param);
9434 case SAVEt_HV: /* hash reference */
9435 hv = (HV*)POPPTR(ss,ix);
9436 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9437 gv = (GV*)POPPTR(ss,ix);
9438 TOPPTR(nss,ix) = gv_dup(gv, param);
9440 case SAVEt_INT: /* int reference */
9441 ptr = POPPTR(ss,ix);
9442 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9443 intval = (int)POPINT(ss,ix);
9444 TOPINT(nss,ix) = intval;
9446 case SAVEt_LONG: /* long reference */
9447 ptr = POPPTR(ss,ix);
9448 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9449 longval = (long)POPLONG(ss,ix);
9450 TOPLONG(nss,ix) = longval;
9452 case SAVEt_I32: /* I32 reference */
9453 case SAVEt_I16: /* I16 reference */
9454 case SAVEt_I8: /* I8 reference */
9455 ptr = POPPTR(ss,ix);
9456 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9460 case SAVEt_IV: /* IV reference */
9461 ptr = POPPTR(ss,ix);
9462 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9466 case SAVEt_SPTR: /* SV* reference */
9467 ptr = POPPTR(ss,ix);
9468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9469 sv = (SV*)POPPTR(ss,ix);
9470 TOPPTR(nss,ix) = sv_dup(sv, param);
9472 case SAVEt_VPTR: /* random* reference */
9473 ptr = POPPTR(ss,ix);
9474 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9475 ptr = POPPTR(ss,ix);
9476 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9478 case SAVEt_PPTR: /* char* reference */
9479 ptr = POPPTR(ss,ix);
9480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9481 c = (char*)POPPTR(ss,ix);
9482 TOPPTR(nss,ix) = pv_dup(c);
9484 case SAVEt_HPTR: /* HV* reference */
9485 ptr = POPPTR(ss,ix);
9486 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9487 hv = (HV*)POPPTR(ss,ix);
9488 TOPPTR(nss,ix) = hv_dup(hv, param);
9490 case SAVEt_APTR: /* AV* reference */
9491 ptr = POPPTR(ss,ix);
9492 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9493 av = (AV*)POPPTR(ss,ix);
9494 TOPPTR(nss,ix) = av_dup(av, param);
9497 gv = (GV*)POPPTR(ss,ix);
9498 TOPPTR(nss,ix) = gv_dup(gv, param);
9500 case SAVEt_GP: /* scalar reference */
9501 gp = (GP*)POPPTR(ss,ix);
9502 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9503 (void)GpREFCNT_inc(gp);
9504 gv = (GV*)POPPTR(ss,ix);
9505 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9506 c = (char*)POPPTR(ss,ix);
9507 TOPPTR(nss,ix) = pv_dup(c);
9514 case SAVEt_MORTALIZESV:
9515 sv = (SV*)POPPTR(ss,ix);
9516 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9519 ptr = POPPTR(ss,ix);
9520 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9521 /* these are assumed to be refcounted properly */
9522 switch (((OP*)ptr)->op_type) {
9529 TOPPTR(nss,ix) = ptr;
9534 TOPPTR(nss,ix) = Nullop;
9539 TOPPTR(nss,ix) = Nullop;
9542 c = (char*)POPPTR(ss,ix);
9543 TOPPTR(nss,ix) = pv_dup_inc(c);
9546 longval = POPLONG(ss,ix);
9547 TOPLONG(nss,ix) = longval;
9550 hv = (HV*)POPPTR(ss,ix);
9551 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9552 c = (char*)POPPTR(ss,ix);
9553 TOPPTR(nss,ix) = pv_dup_inc(c);
9557 case SAVEt_DESTRUCTOR:
9558 ptr = POPPTR(ss,ix);
9559 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9560 dptr = POPDPTR(ss,ix);
9561 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9563 case SAVEt_DESTRUCTOR_X:
9564 ptr = POPPTR(ss,ix);
9565 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9566 dxptr = POPDXPTR(ss,ix);
9567 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9569 case SAVEt_REGCONTEXT:
9575 case SAVEt_STACK_POS: /* Position on Perl stack */
9579 case SAVEt_AELEM: /* array element */
9580 sv = (SV*)POPPTR(ss,ix);
9581 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9584 av = (AV*)POPPTR(ss,ix);
9585 TOPPTR(nss,ix) = av_dup_inc(av, param);
9587 case SAVEt_HELEM: /* hash element */
9588 sv = (SV*)POPPTR(ss,ix);
9589 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9590 sv = (SV*)POPPTR(ss,ix);
9591 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9592 hv = (HV*)POPPTR(ss,ix);
9593 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9596 ptr = POPPTR(ss,ix);
9597 TOPPTR(nss,ix) = ptr;
9604 av = (AV*)POPPTR(ss,ix);
9605 TOPPTR(nss,ix) = av_dup(av, param);
9608 longval = (long)POPLONG(ss,ix);
9609 TOPLONG(nss,ix) = longval;
9610 ptr = POPPTR(ss,ix);
9611 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9612 sv = (SV*)POPPTR(ss,ix);
9613 TOPPTR(nss,ix) = sv_dup(sv, param);
9616 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9624 =for apidoc perl_clone
9626 Create and return a new interpreter by cloning the current one.
9631 /* XXX the above needs expanding by someone who actually understands it ! */
9632 EXTERN_C PerlInterpreter *
9633 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
9636 perl_clone(PerlInterpreter *proto_perl, UV flags)
9638 #ifdef PERL_IMPLICIT_SYS
9640 /* perlhost.h so we need to call into it
9641 to clone the host, CPerlHost should have a c interface, sky */
9643 if (flags & CLONEf_CLONE_HOST) {
9644 return perl_clone_host(proto_perl,flags);
9646 return perl_clone_using(proto_perl, flags,
9648 proto_perl->IMemShared,
9649 proto_perl->IMemParse,
9659 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9660 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9661 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9662 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9663 struct IPerlDir* ipD, struct IPerlSock* ipS,
9664 struct IPerlProc* ipP)
9666 /* XXX many of the string copies here can be optimized if they're
9667 * constants; they need to be allocated as common memory and just
9668 * their pointers copied. */
9671 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9673 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9674 PERL_SET_THX(my_perl);
9677 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9683 # else /* !DEBUGGING */
9684 Zero(my_perl, 1, PerlInterpreter);
9685 # endif /* DEBUGGING */
9689 PL_MemShared = ipMS;
9697 #else /* !PERL_IMPLICIT_SYS */
9699 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9700 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9701 PERL_SET_THX(my_perl);
9706 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9712 # else /* !DEBUGGING */
9713 Zero(my_perl, 1, PerlInterpreter);
9714 # endif /* DEBUGGING */
9715 #endif /* PERL_IMPLICIT_SYS */
9716 param->flags = flags;
9719 PL_xiv_arenaroot = NULL;
9721 PL_xnv_arenaroot = NULL;
9723 PL_xrv_arenaroot = NULL;
9725 PL_xpv_arenaroot = NULL;
9727 PL_xpviv_arenaroot = NULL;
9728 PL_xpviv_root = NULL;
9729 PL_xpvnv_arenaroot = NULL;
9730 PL_xpvnv_root = NULL;
9731 PL_xpvcv_arenaroot = NULL;
9732 PL_xpvcv_root = NULL;
9733 PL_xpvav_arenaroot = NULL;
9734 PL_xpvav_root = NULL;
9735 PL_xpvhv_arenaroot = NULL;
9736 PL_xpvhv_root = NULL;
9737 PL_xpvmg_arenaroot = NULL;
9738 PL_xpvmg_root = NULL;
9739 PL_xpvlv_arenaroot = NULL;
9740 PL_xpvlv_root = NULL;
9741 PL_xpvbm_arenaroot = NULL;
9742 PL_xpvbm_root = NULL;
9743 PL_he_arenaroot = NULL;
9745 PL_nice_chunk = NULL;
9746 PL_nice_chunk_size = 0;
9749 PL_sv_root = Nullsv;
9750 PL_sv_arenaroot = Nullsv;
9752 PL_debug = proto_perl->Idebug;
9754 #ifdef USE_REENTRANT_API
9755 New(31337, PL_reentrant_buffer,1, REBUF);
9756 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9759 /* create SV map for pointer relocation */
9760 PL_ptr_table = ptr_table_new();
9762 /* initialize these special pointers as early as possible */
9763 SvANY(&PL_sv_undef) = NULL;
9764 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9765 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9766 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9768 SvANY(&PL_sv_no) = new_XPVNV();
9769 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9770 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9771 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9772 SvCUR(&PL_sv_no) = 0;
9773 SvLEN(&PL_sv_no) = 1;
9774 SvNVX(&PL_sv_no) = 0;
9775 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9777 SvANY(&PL_sv_yes) = new_XPVNV();
9778 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9779 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9780 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9781 SvCUR(&PL_sv_yes) = 1;
9782 SvLEN(&PL_sv_yes) = 2;
9783 SvNVX(&PL_sv_yes) = 1;
9784 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9786 /* create shared string table */
9787 PL_strtab = newHV();
9788 HvSHAREKEYS_off(PL_strtab);
9789 hv_ksplit(PL_strtab, 512);
9790 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9792 PL_compiling = proto_perl->Icompiling;
9793 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9794 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9795 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9796 if (!specialWARN(PL_compiling.cop_warnings))
9797 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9798 if (!specialCopIO(PL_compiling.cop_io))
9799 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9800 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9802 /* pseudo environmental stuff */
9803 PL_origargc = proto_perl->Iorigargc;
9805 New(0, PL_origargv, i+1, char*);
9806 PL_origargv[i] = '\0';
9808 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9811 param->stashes = newAV(); /* Setup array of objects to call clone on */
9813 #ifdef PERLIO_LAYERS
9814 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
9815 PerlIO_clone(aTHX_ proto_perl, param);
9818 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9819 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9820 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9821 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9822 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9823 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9826 PL_minus_c = proto_perl->Iminus_c;
9827 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9828 PL_localpatches = proto_perl->Ilocalpatches;
9829 PL_splitstr = proto_perl->Isplitstr;
9830 PL_preprocess = proto_perl->Ipreprocess;
9831 PL_minus_n = proto_perl->Iminus_n;
9832 PL_minus_p = proto_perl->Iminus_p;
9833 PL_minus_l = proto_perl->Iminus_l;
9834 PL_minus_a = proto_perl->Iminus_a;
9835 PL_minus_F = proto_perl->Iminus_F;
9836 PL_doswitches = proto_perl->Idoswitches;
9837 PL_dowarn = proto_perl->Idowarn;
9838 PL_doextract = proto_perl->Idoextract;
9839 PL_sawampersand = proto_perl->Isawampersand;
9840 PL_unsafe = proto_perl->Iunsafe;
9841 PL_inplace = SAVEPV(proto_perl->Iinplace);
9842 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9843 PL_perldb = proto_perl->Iperldb;
9844 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9845 PL_exit_flags = proto_perl->Iexit_flags;
9847 /* magical thingies */
9848 /* XXX time(&PL_basetime) when asked for? */
9849 PL_basetime = proto_perl->Ibasetime;
9850 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9852 PL_maxsysfd = proto_perl->Imaxsysfd;
9853 PL_multiline = proto_perl->Imultiline;
9854 PL_statusvalue = proto_perl->Istatusvalue;
9856 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9858 PL_encoding = sv_dup(proto_perl->Iencoding, param);
9860 /* Clone the regex array */
9861 PL_regex_padav = newAV();
9863 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9864 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9865 av_push(PL_regex_padav,
9866 sv_dup_inc(regexen[0],param));
9867 for(i = 1; i <= len; i++) {
9868 if(SvREPADTMP(regexen[i])) {
9869 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
9871 av_push(PL_regex_padav,
9873 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
9874 SvIVX(regexen[i])), param)))
9879 PL_regex_pad = AvARRAY(PL_regex_padav);
9881 /* shortcuts to various I/O objects */
9882 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9883 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9884 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9885 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9886 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9887 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9889 /* shortcuts to regexp stuff */
9890 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9892 /* shortcuts to misc objects */
9893 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9895 /* shortcuts to debugging objects */
9896 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9897 PL_DBline = gv_dup(proto_perl->IDBline, param);
9898 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9899 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9900 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9901 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9902 PL_lineary = av_dup(proto_perl->Ilineary, param);
9903 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9906 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9907 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9908 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9909 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9910 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9911 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9913 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9914 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
9915 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9916 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9917 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9919 PL_sub_generation = proto_perl->Isub_generation;
9921 /* funky return mechanisms */
9922 PL_forkprocess = proto_perl->Iforkprocess;
9924 /* subprocess state */
9925 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9927 /* internal state */
9928 PL_tainting = proto_perl->Itainting;
9929 PL_maxo = proto_perl->Imaxo;
9930 if (proto_perl->Iop_mask)
9931 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9933 PL_op_mask = Nullch;
9935 /* current interpreter roots */
9936 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9937 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9938 PL_main_start = proto_perl->Imain_start;
9939 PL_eval_root = proto_perl->Ieval_root;
9940 PL_eval_start = proto_perl->Ieval_start;
9942 /* runtime control stuff */
9943 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9944 PL_copline = proto_perl->Icopline;
9946 PL_filemode = proto_perl->Ifilemode;
9947 PL_lastfd = proto_perl->Ilastfd;
9948 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9951 PL_gensym = proto_perl->Igensym;
9952 PL_preambled = proto_perl->Ipreambled;
9953 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9954 PL_laststatval = proto_perl->Ilaststatval;
9955 PL_laststype = proto_perl->Ilaststype;
9956 PL_mess_sv = Nullsv;
9958 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9959 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9961 /* interpreter atexit processing */
9962 PL_exitlistlen = proto_perl->Iexitlistlen;
9963 if (PL_exitlistlen) {
9964 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9965 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9968 PL_exitlist = (PerlExitListEntry*)NULL;
9969 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9970 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
9971 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
9973 PL_profiledata = NULL;
9974 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
9975 /* PL_rsfp_filters entries have fake IoDIRP() */
9976 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9978 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9979 PL_comppad = av_dup(proto_perl->Icomppad, param);
9980 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9981 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9982 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9983 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9984 proto_perl->Tcurpad);
9986 #ifdef HAVE_INTERP_INTERN
9987 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9990 /* more statics moved here */
9991 PL_generation = proto_perl->Igeneration;
9992 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9994 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9995 PL_in_clean_all = proto_perl->Iin_clean_all;
9997 PL_uid = proto_perl->Iuid;
9998 PL_euid = proto_perl->Ieuid;
9999 PL_gid = proto_perl->Igid;
10000 PL_egid = proto_perl->Iegid;
10001 PL_nomemok = proto_perl->Inomemok;
10002 PL_an = proto_perl->Ian;
10003 PL_cop_seqmax = proto_perl->Icop_seqmax;
10004 PL_op_seqmax = proto_perl->Iop_seqmax;
10005 PL_evalseq = proto_perl->Ievalseq;
10006 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10007 PL_origalen = proto_perl->Iorigalen;
10008 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10009 PL_osname = SAVEPV(proto_perl->Iosname);
10010 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
10011 PL_sighandlerp = proto_perl->Isighandlerp;
10014 PL_runops = proto_perl->Irunops;
10016 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10019 PL_cshlen = proto_perl->Icshlen;
10020 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10023 PL_lex_state = proto_perl->Ilex_state;
10024 PL_lex_defer = proto_perl->Ilex_defer;
10025 PL_lex_expect = proto_perl->Ilex_expect;
10026 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10027 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10028 PL_lex_starts = proto_perl->Ilex_starts;
10029 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10030 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10031 PL_lex_op = proto_perl->Ilex_op;
10032 PL_lex_inpat = proto_perl->Ilex_inpat;
10033 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10034 PL_lex_brackets = proto_perl->Ilex_brackets;
10035 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10036 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10037 PL_lex_casemods = proto_perl->Ilex_casemods;
10038 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10039 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10041 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10042 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10043 PL_nexttoke = proto_perl->Inexttoke;
10045 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10046 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10047 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10048 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10049 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10050 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10051 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10052 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10053 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10054 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10055 PL_pending_ident = proto_perl->Ipending_ident;
10056 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10058 PL_expect = proto_perl->Iexpect;
10060 PL_multi_start = proto_perl->Imulti_start;
10061 PL_multi_end = proto_perl->Imulti_end;
10062 PL_multi_open = proto_perl->Imulti_open;
10063 PL_multi_close = proto_perl->Imulti_close;
10065 PL_error_count = proto_perl->Ierror_count;
10066 PL_subline = proto_perl->Isubline;
10067 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10069 PL_min_intro_pending = proto_perl->Imin_intro_pending;
10070 PL_max_intro_pending = proto_perl->Imax_intro_pending;
10071 PL_padix = proto_perl->Ipadix;
10072 PL_padix_floor = proto_perl->Ipadix_floor;
10073 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
10075 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10076 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10077 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10078 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10079 PL_last_lop_op = proto_perl->Ilast_lop_op;
10080 PL_in_my = proto_perl->Iin_my;
10081 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10083 PL_cryptseen = proto_perl->Icryptseen;
10086 PL_hints = proto_perl->Ihints;
10088 PL_amagic_generation = proto_perl->Iamagic_generation;
10090 #ifdef USE_LOCALE_COLLATE
10091 PL_collation_ix = proto_perl->Icollation_ix;
10092 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10093 PL_collation_standard = proto_perl->Icollation_standard;
10094 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10095 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10096 #endif /* USE_LOCALE_COLLATE */
10098 #ifdef USE_LOCALE_NUMERIC
10099 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10100 PL_numeric_standard = proto_perl->Inumeric_standard;
10101 PL_numeric_local = proto_perl->Inumeric_local;
10102 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10103 #endif /* !USE_LOCALE_NUMERIC */
10105 /* utf8 character classes */
10106 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10107 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10108 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10109 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10110 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10111 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10112 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10113 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10114 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10115 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10116 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10117 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10118 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10119 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10120 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10121 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10122 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10123 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
10126 PL_last_swash_hv = Nullhv; /* reinits on demand */
10127 PL_last_swash_klen = 0;
10128 PL_last_swash_key[0]= '\0';
10129 PL_last_swash_tmps = (U8*)NULL;
10130 PL_last_swash_slen = 0;
10132 /* perly.c globals */
10133 PL_yydebug = proto_perl->Iyydebug;
10134 PL_yynerrs = proto_perl->Iyynerrs;
10135 PL_yyerrflag = proto_perl->Iyyerrflag;
10136 PL_yychar = proto_perl->Iyychar;
10137 PL_yyval = proto_perl->Iyyval;
10138 PL_yylval = proto_perl->Iyylval;
10140 PL_glob_index = proto_perl->Iglob_index;
10141 PL_srand_called = proto_perl->Isrand_called;
10142 PL_uudmap['M'] = 0; /* reinits on demand */
10143 PL_bitcount = Nullch; /* reinits on demand */
10145 if (proto_perl->Ipsig_pend) {
10146 Newz(0, PL_psig_pend, SIG_SIZE, int);
10149 PL_psig_pend = (int*)NULL;
10152 if (proto_perl->Ipsig_ptr) {
10153 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10154 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10155 for (i = 1; i < SIG_SIZE; i++) {
10156 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10157 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10161 PL_psig_ptr = (SV**)NULL;
10162 PL_psig_name = (SV**)NULL;
10165 /* thrdvar.h stuff */
10167 if (flags & CLONEf_COPY_STACKS) {
10168 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10169 PL_tmps_ix = proto_perl->Ttmps_ix;
10170 PL_tmps_max = proto_perl->Ttmps_max;
10171 PL_tmps_floor = proto_perl->Ttmps_floor;
10172 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10174 while (i <= PL_tmps_ix) {
10175 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10179 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10180 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10181 Newz(54, PL_markstack, i, I32);
10182 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10183 - proto_perl->Tmarkstack);
10184 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10185 - proto_perl->Tmarkstack);
10186 Copy(proto_perl->Tmarkstack, PL_markstack,
10187 PL_markstack_ptr - PL_markstack + 1, I32);
10189 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10190 * NOTE: unlike the others! */
10191 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10192 PL_scopestack_max = proto_perl->Tscopestack_max;
10193 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10194 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10196 /* next push_return() sets PL_retstack[PL_retstack_ix]
10197 * NOTE: unlike the others! */
10198 PL_retstack_ix = proto_perl->Tretstack_ix;
10199 PL_retstack_max = proto_perl->Tretstack_max;
10200 Newz(54, PL_retstack, PL_retstack_max, OP*);
10201 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10203 /* NOTE: si_dup() looks at PL_markstack */
10204 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10206 /* PL_curstack = PL_curstackinfo->si_stack; */
10207 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10208 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10210 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10211 PL_stack_base = AvARRAY(PL_curstack);
10212 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10213 - proto_perl->Tstack_base);
10214 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10216 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10217 * NOTE: unlike the others! */
10218 PL_savestack_ix = proto_perl->Tsavestack_ix;
10219 PL_savestack_max = proto_perl->Tsavestack_max;
10220 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10221 PL_savestack = ss_dup(proto_perl, param);
10225 ENTER; /* perl_destruct() wants to LEAVE; */
10228 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10229 PL_top_env = &PL_start_env;
10231 PL_op = proto_perl->Top;
10234 PL_Xpv = (XPV*)NULL;
10235 PL_na = proto_perl->Tna;
10237 PL_statbuf = proto_perl->Tstatbuf;
10238 PL_statcache = proto_perl->Tstatcache;
10239 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10240 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10242 PL_timesbuf = proto_perl->Ttimesbuf;
10245 PL_tainted = proto_perl->Ttainted;
10246 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10247 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10248 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10249 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10250 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10251 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10252 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10253 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10254 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10256 PL_restartop = proto_perl->Trestartop;
10257 PL_in_eval = proto_perl->Tin_eval;
10258 PL_delaymagic = proto_perl->Tdelaymagic;
10259 PL_dirty = proto_perl->Tdirty;
10260 PL_localizing = proto_perl->Tlocalizing;
10262 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10263 PL_protect = proto_perl->Tprotect;
10265 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10266 PL_av_fetch_sv = Nullsv;
10267 PL_hv_fetch_sv = Nullsv;
10268 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10269 PL_modcount = proto_perl->Tmodcount;
10270 PL_lastgotoprobe = Nullop;
10271 PL_dumpindent = proto_perl->Tdumpindent;
10273 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10274 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10275 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10276 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10277 PL_sortcxix = proto_perl->Tsortcxix;
10278 PL_efloatbuf = Nullch; /* reinits on demand */
10279 PL_efloatsize = 0; /* reinits on demand */
10283 PL_screamfirst = NULL;
10284 PL_screamnext = NULL;
10285 PL_maxscream = -1; /* reinits on demand */
10286 PL_lastscream = Nullsv;
10288 PL_watchaddr = NULL;
10289 PL_watchok = Nullch;
10291 PL_regdummy = proto_perl->Tregdummy;
10292 PL_regcomp_parse = Nullch;
10293 PL_regxend = Nullch;
10294 PL_regcode = (regnode*)NULL;
10297 PL_regprecomp = Nullch;
10302 PL_seen_zerolen = 0;
10304 PL_regcomp_rx = (regexp*)NULL;
10306 PL_colorset = 0; /* reinits PL_colors[] */
10307 /*PL_colors[6] = {0,0,0,0,0,0};*/
10308 PL_reg_whilem_seen = 0;
10309 PL_reginput = Nullch;
10310 PL_regbol = Nullch;
10311 PL_regeol = Nullch;
10312 PL_regstartp = (I32*)NULL;
10313 PL_regendp = (I32*)NULL;
10314 PL_reglastparen = (U32*)NULL;
10315 PL_regtill = Nullch;
10316 PL_reg_start_tmp = (char**)NULL;
10317 PL_reg_start_tmpl = 0;
10318 PL_regdata = (struct reg_data*)NULL;
10321 PL_reg_eval_set = 0;
10323 PL_regprogram = (regnode*)NULL;
10325 PL_regcc = (CURCUR*)NULL;
10326 PL_reg_call_cc = (struct re_cc_state*)NULL;
10327 PL_reg_re = (regexp*)NULL;
10328 PL_reg_ganch = Nullch;
10329 PL_reg_sv = Nullsv;
10330 PL_reg_match_utf8 = FALSE;
10331 PL_reg_magic = (MAGIC*)NULL;
10333 PL_reg_oldcurpm = (PMOP*)NULL;
10334 PL_reg_curpm = (PMOP*)NULL;
10335 PL_reg_oldsaved = Nullch;
10336 PL_reg_oldsavedlen = 0;
10337 PL_reg_maxiter = 0;
10338 PL_reg_leftiter = 0;
10339 PL_reg_poscache = Nullch;
10340 PL_reg_poscache_size= 0;
10342 /* RE engine - function pointers */
10343 PL_regcompp = proto_perl->Tregcompp;
10344 PL_regexecp = proto_perl->Tregexecp;
10345 PL_regint_start = proto_perl->Tregint_start;
10346 PL_regint_string = proto_perl->Tregint_string;
10347 PL_regfree = proto_perl->Tregfree;
10349 PL_reginterp_cnt = 0;
10350 PL_reg_starttry = 0;
10352 /* Pluggable optimizer */
10353 PL_peepp = proto_perl->Tpeepp;
10355 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10356 ptr_table_free(PL_ptr_table);
10357 PL_ptr_table = NULL;
10360 /* Call the ->CLONE method, if it exists, for each of the stashes
10361 identified by sv_dup() above.
10363 while(av_len(param->stashes) != -1) {
10364 HV* stash = (HV*) av_shift(param->stashes);
10365 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10366 if (cloner && GvCV(cloner)) {
10371 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10373 call_sv((SV*)GvCV(cloner), G_DISCARD);
10379 SvREFCNT_dec(param->stashes);
10385 #endif /* USE_ITHREADS */
10388 =for apidoc sv_recode_to_utf8
10390 The encoding is assumed to be an Encode object, on entry the PV
10391 of the sv is assumed to be octets in that encoding, and the sv
10392 will be converted into Unicode (and UTF-8).
10394 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10395 is not a reference, nothing is done to the sv. If the encoding is not
10396 an C<Encode::XS> Encoding object, bad things will happen.
10397 (See F<lib/encoding.pm> and L<Encode>).
10399 The PV of the sv is returned.
10404 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10406 if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
10417 XPUSHs(&PL_sv_yes);
10419 call_method("decode", G_SCALAR);
10423 s = SvPV(uni, len);
10424 if (s != SvPVX(sv)) {
10426 Move(s, SvPVX(sv), len, char);
10427 SvCUR_set(sv, len);