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)) {
298 /* called by sv_report_used() for each live SV */
301 do_report_used(pTHXo_ SV *sv)
303 if (SvTYPE(sv) != SVTYPEMASK) {
304 PerlIO_printf(Perl_debug_log, "****\n");
310 =for apidoc sv_report_used
312 Dump the contents of all SVs not yet freed. (Debugging aid).
318 Perl_sv_report_used(pTHX)
320 visit(do_report_used);
323 /* called by sv_clean_objs() for each live SV */
326 do_clean_objs(pTHXo_ SV *sv)
330 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
331 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
343 /* XXX Might want to check arrays, etc. */
346 /* called by sv_clean_objs() for each live SV */
348 #ifndef DISABLE_DESTRUCTOR_KLUDGE
350 do_clean_named_objs(pTHXo_ SV *sv)
352 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
353 if ( SvOBJECT(GvSV(sv)) ||
354 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
355 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
356 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
357 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
359 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
367 =for apidoc sv_clean_objs
369 Attempt to destroy all objects not yet freed
375 Perl_sv_clean_objs(pTHX)
377 PL_in_clean_objs = TRUE;
378 visit(do_clean_objs);
379 #ifndef DISABLE_DESTRUCTOR_KLUDGE
380 /* some barnacles may yet remain, clinging to typeglobs */
381 visit(do_clean_named_objs);
383 PL_in_clean_objs = FALSE;
386 /* called by sv_clean_all() for each live SV */
389 do_clean_all(pTHXo_ SV *sv)
391 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
392 SvFLAGS(sv) |= SVf_BREAK;
397 =for apidoc sv_clean_all
399 Decrement the refcnt of each remaining SV, possibly triggering a
400 cleanup. This function may have to be called multiple times to free
401 SVs which are in complex self-referential hierarchies.
407 Perl_sv_clean_all(pTHX)
410 PL_in_clean_all = TRUE;
411 cleaned = visit(do_clean_all);
412 PL_in_clean_all = FALSE;
417 =for apidoc sv_free_arenas
419 Deallocate the memory used by all arenas. Note that all the individual SV
420 heads and bodies within the arenas must already have been freed.
426 Perl_sv_free_arenas(pTHX)
430 XPV *arena, *arenanext;
432 /* Free arenas here, but be careful about fake ones. (We assume
433 contiguity of the fake ones with the corresponding real ones.) */
435 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
436 svanext = (SV*) SvANY(sva);
437 while (svanext && SvFAKE(svanext))
438 svanext = (SV*) SvANY(svanext);
441 Safefree((void *)sva);
444 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
445 arenanext = (XPV*)arena->xpv_pv;
448 PL_xiv_arenaroot = 0;
450 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
451 arenanext = (XPV*)arena->xpv_pv;
454 PL_xnv_arenaroot = 0;
456 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
457 arenanext = (XPV*)arena->xpv_pv;
460 PL_xrv_arenaroot = 0;
462 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
463 arenanext = (XPV*)arena->xpv_pv;
466 PL_xpv_arenaroot = 0;
468 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
469 arenanext = (XPV*)arena->xpv_pv;
472 PL_xpviv_arenaroot = 0;
474 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
475 arenanext = (XPV*)arena->xpv_pv;
478 PL_xpvnv_arenaroot = 0;
480 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
481 arenanext = (XPV*)arena->xpv_pv;
484 PL_xpvcv_arenaroot = 0;
486 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
487 arenanext = (XPV*)arena->xpv_pv;
490 PL_xpvav_arenaroot = 0;
492 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
493 arenanext = (XPV*)arena->xpv_pv;
496 PL_xpvhv_arenaroot = 0;
498 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
499 arenanext = (XPV*)arena->xpv_pv;
502 PL_xpvmg_arenaroot = 0;
504 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
505 arenanext = (XPV*)arena->xpv_pv;
508 PL_xpvlv_arenaroot = 0;
510 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
511 arenanext = (XPV*)arena->xpv_pv;
514 PL_xpvbm_arenaroot = 0;
516 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
517 arenanext = (XPV*)arena->xpv_pv;
523 Safefree(PL_nice_chunk);
524 PL_nice_chunk = Nullch;
525 PL_nice_chunk_size = 0;
531 =for apidoc report_uninit
533 Print appropriate "Use of uninitialized variable" warning
539 Perl_report_uninit(pTHX)
542 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
543 " in ", PL_op_desc[PL_op->op_type]);
545 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
548 /* grab a new IV body from the free list, allocating more if necessary */
559 * See comment in more_xiv() -- RAM.
561 PL_xiv_root = *(IV**)xiv;
563 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
566 /* return an IV body to the free list */
569 S_del_xiv(pTHX_ XPVIV *p)
571 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
573 *(IV**)xiv = PL_xiv_root;
578 /* allocate another arena's worth of IV bodies */
586 New(705, ptr, 1008/sizeof(XPV), XPV);
587 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
588 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
591 xivend = &xiv[1008 / sizeof(IV) - 1];
592 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
594 while (xiv < xivend) {
595 *(IV**)xiv = (IV *)(xiv + 1);
601 /* grab a new NV body from the free list, allocating more if necessary */
611 PL_xnv_root = *(NV**)xnv;
613 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
616 /* return an NV body to the free list */
619 S_del_xnv(pTHX_ XPVNV *p)
621 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
623 *(NV**)xnv = PL_xnv_root;
628 /* allocate another arena's worth of NV bodies */
636 New(711, ptr, 1008/sizeof(XPV), XPV);
637 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
638 PL_xnv_arenaroot = ptr;
641 xnvend = &xnv[1008 / sizeof(NV) - 1];
642 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
644 while (xnv < xnvend) {
645 *(NV**)xnv = (NV*)(xnv + 1);
651 /* grab a new struct xrv from the free list, allocating more if necessary */
661 PL_xrv_root = (XRV*)xrv->xrv_rv;
666 /* return a struct xrv to the free list */
669 S_del_xrv(pTHX_ XRV *p)
672 p->xrv_rv = (SV*)PL_xrv_root;
677 /* allocate another arena's worth of struct xrv */
683 register XRV* xrvend;
685 New(712, ptr, 1008/sizeof(XPV), XPV);
686 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
687 PL_xrv_arenaroot = ptr;
690 xrvend = &xrv[1008 / sizeof(XRV) - 1];
691 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
693 while (xrv < xrvend) {
694 xrv->xrv_rv = (SV*)(xrv + 1);
700 /* grab a new struct xpv from the free list, allocating more if necessary */
710 PL_xpv_root = (XPV*)xpv->xpv_pv;
715 /* return a struct xpv to the free list */
718 S_del_xpv(pTHX_ XPV *p)
721 p->xpv_pv = (char*)PL_xpv_root;
726 /* allocate another arena's worth of struct xpv */
732 register XPV* xpvend;
733 New(713, xpv, 1008/sizeof(XPV), XPV);
734 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
735 PL_xpv_arenaroot = xpv;
737 xpvend = &xpv[1008 / sizeof(XPV) - 1];
739 while (xpv < xpvend) {
740 xpv->xpv_pv = (char*)(xpv + 1);
746 /* grab a new struct xpviv from the free list, allocating more if necessary */
755 xpviv = PL_xpviv_root;
756 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
761 /* return a struct xpviv to the free list */
764 S_del_xpviv(pTHX_ XPVIV *p)
767 p->xpv_pv = (char*)PL_xpviv_root;
772 /* allocate another arena's worth of struct xpviv */
777 register XPVIV* xpviv;
778 register XPVIV* xpvivend;
779 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
780 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
781 PL_xpviv_arenaroot = xpviv;
783 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
784 PL_xpviv_root = ++xpviv;
785 while (xpviv < xpvivend) {
786 xpviv->xpv_pv = (char*)(xpviv + 1);
792 /* grab a new struct xpvnv from the free list, allocating more if necessary */
801 xpvnv = PL_xpvnv_root;
802 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
807 /* return a struct xpvnv to the free list */
810 S_del_xpvnv(pTHX_ XPVNV *p)
813 p->xpv_pv = (char*)PL_xpvnv_root;
818 /* allocate another arena's worth of struct xpvnv */
823 register XPVNV* xpvnv;
824 register XPVNV* xpvnvend;
825 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
826 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
827 PL_xpvnv_arenaroot = xpvnv;
829 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
830 PL_xpvnv_root = ++xpvnv;
831 while (xpvnv < xpvnvend) {
832 xpvnv->xpv_pv = (char*)(xpvnv + 1);
838 /* grab a new struct xpvcv from the free list, allocating more if necessary */
847 xpvcv = PL_xpvcv_root;
848 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
853 /* return a struct xpvcv to the free list */
856 S_del_xpvcv(pTHX_ XPVCV *p)
859 p->xpv_pv = (char*)PL_xpvcv_root;
864 /* allocate another arena's worth of struct xpvcv */
869 register XPVCV* xpvcv;
870 register XPVCV* xpvcvend;
871 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
872 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
873 PL_xpvcv_arenaroot = xpvcv;
875 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
876 PL_xpvcv_root = ++xpvcv;
877 while (xpvcv < xpvcvend) {
878 xpvcv->xpv_pv = (char*)(xpvcv + 1);
884 /* grab a new struct xpvav from the free list, allocating more if necessary */
893 xpvav = PL_xpvav_root;
894 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
899 /* return a struct xpvav to the free list */
902 S_del_xpvav(pTHX_ XPVAV *p)
905 p->xav_array = (char*)PL_xpvav_root;
910 /* allocate another arena's worth of struct xpvav */
915 register XPVAV* xpvav;
916 register XPVAV* xpvavend;
917 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
918 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
919 PL_xpvav_arenaroot = xpvav;
921 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
922 PL_xpvav_root = ++xpvav;
923 while (xpvav < xpvavend) {
924 xpvav->xav_array = (char*)(xpvav + 1);
927 xpvav->xav_array = 0;
930 /* grab a new struct xpvhv from the free list, allocating more if necessary */
939 xpvhv = PL_xpvhv_root;
940 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
945 /* return a struct xpvhv to the free list */
948 S_del_xpvhv(pTHX_ XPVHV *p)
951 p->xhv_array = (char*)PL_xpvhv_root;
956 /* allocate another arena's worth of struct xpvhv */
961 register XPVHV* xpvhv;
962 register XPVHV* xpvhvend;
963 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
964 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
965 PL_xpvhv_arenaroot = xpvhv;
967 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
968 PL_xpvhv_root = ++xpvhv;
969 while (xpvhv < xpvhvend) {
970 xpvhv->xhv_array = (char*)(xpvhv + 1);
973 xpvhv->xhv_array = 0;
976 /* grab a new struct xpvmg from the free list, allocating more if necessary */
985 xpvmg = PL_xpvmg_root;
986 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
991 /* return a struct xpvmg to the free list */
994 S_del_xpvmg(pTHX_ XPVMG *p)
997 p->xpv_pv = (char*)PL_xpvmg_root;
1002 /* allocate another arena's worth of struct xpvmg */
1007 register XPVMG* xpvmg;
1008 register XPVMG* xpvmgend;
1009 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1010 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1011 PL_xpvmg_arenaroot = xpvmg;
1013 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1014 PL_xpvmg_root = ++xpvmg;
1015 while (xpvmg < xpvmgend) {
1016 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1022 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1031 xpvlv = PL_xpvlv_root;
1032 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1037 /* return a struct xpvlv to the free list */
1040 S_del_xpvlv(pTHX_ XPVLV *p)
1043 p->xpv_pv = (char*)PL_xpvlv_root;
1048 /* allocate another arena's worth of struct xpvlv */
1053 register XPVLV* xpvlv;
1054 register XPVLV* xpvlvend;
1055 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1056 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1057 PL_xpvlv_arenaroot = xpvlv;
1059 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1060 PL_xpvlv_root = ++xpvlv;
1061 while (xpvlv < xpvlvend) {
1062 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1068 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1077 xpvbm = PL_xpvbm_root;
1078 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1083 /* return a struct xpvbm to the free list */
1086 S_del_xpvbm(pTHX_ XPVBM *p)
1089 p->xpv_pv = (char*)PL_xpvbm_root;
1094 /* allocate another arena's worth of struct xpvbm */
1099 register XPVBM* xpvbm;
1100 register XPVBM* xpvbmend;
1101 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1102 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1103 PL_xpvbm_arenaroot = xpvbm;
1105 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1106 PL_xpvbm_root = ++xpvbm;
1107 while (xpvbm < xpvbmend) {
1108 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1115 # define my_safemalloc(s) (void*)safexmalloc(717,s)
1116 # define my_safefree(p) safexfree((char*)p)
1118 # define my_safemalloc(s) (void*)safemalloc(s)
1119 # define my_safefree(p) safefree((char*)p)
1124 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1125 #define del_XIV(p) my_safefree(p)
1127 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1128 #define del_XNV(p) my_safefree(p)
1130 #define new_XRV() my_safemalloc(sizeof(XRV))
1131 #define del_XRV(p) my_safefree(p)
1133 #define new_XPV() my_safemalloc(sizeof(XPV))
1134 #define del_XPV(p) my_safefree(p)
1136 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1137 #define del_XPVIV(p) my_safefree(p)
1139 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1140 #define del_XPVNV(p) my_safefree(p)
1142 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1143 #define del_XPVCV(p) my_safefree(p)
1145 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1146 #define del_XPVAV(p) my_safefree(p)
1148 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1149 #define del_XPVHV(p) my_safefree(p)
1151 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1152 #define del_XPVMG(p) my_safefree(p)
1154 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1155 #define del_XPVLV(p) my_safefree(p)
1157 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1158 #define del_XPVBM(p) my_safefree(p)
1162 #define new_XIV() (void*)new_xiv()
1163 #define del_XIV(p) del_xiv((XPVIV*) p)
1165 #define new_XNV() (void*)new_xnv()
1166 #define del_XNV(p) del_xnv((XPVNV*) p)
1168 #define new_XRV() (void*)new_xrv()
1169 #define del_XRV(p) del_xrv((XRV*) p)
1171 #define new_XPV() (void*)new_xpv()
1172 #define del_XPV(p) del_xpv((XPV *)p)
1174 #define new_XPVIV() (void*)new_xpviv()
1175 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1177 #define new_XPVNV() (void*)new_xpvnv()
1178 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1180 #define new_XPVCV() (void*)new_xpvcv()
1181 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1183 #define new_XPVAV() (void*)new_xpvav()
1184 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1186 #define new_XPVHV() (void*)new_xpvhv()
1187 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1189 #define new_XPVMG() (void*)new_xpvmg()
1190 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1192 #define new_XPVLV() (void*)new_xpvlv()
1193 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1195 #define new_XPVBM() (void*)new_xpvbm()
1196 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1200 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1201 #define del_XPVGV(p) my_safefree(p)
1203 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1204 #define del_XPVFM(p) my_safefree(p)
1206 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1207 #define del_XPVIO(p) my_safefree(p)
1210 =for apidoc sv_upgrade
1212 Upgrade an SV to a more complex form. Generally adds a new body type to the
1213 SV, then copies across as much information as possible from the old body.
1214 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1220 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1230 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
1231 sv_force_normal(sv);
1234 if (SvTYPE(sv) == mt)
1238 (void)SvOOK_off(sv);
1240 switch (SvTYPE(sv)) {
1261 else if (mt < SVt_PVIV)
1278 pv = (char*)SvRV(sv);
1298 else if (mt == SVt_NV)
1309 del_XPVIV(SvANY(sv));
1319 del_XPVNV(SvANY(sv));
1327 magic = SvMAGIC(sv);
1328 stash = SvSTASH(sv);
1329 del_XPVMG(SvANY(sv));
1332 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1337 Perl_croak(aTHX_ "Can't upgrade to undef");
1339 SvANY(sv) = new_XIV();
1343 SvANY(sv) = new_XNV();
1347 SvANY(sv) = new_XRV();
1351 SvANY(sv) = new_XPV();
1357 SvANY(sv) = new_XPVIV();
1367 SvANY(sv) = new_XPVNV();
1375 SvANY(sv) = new_XPVMG();
1381 SvMAGIC(sv) = magic;
1382 SvSTASH(sv) = stash;
1385 SvANY(sv) = new_XPVLV();
1391 SvMAGIC(sv) = magic;
1392 SvSTASH(sv) = stash;
1399 SvANY(sv) = new_XPVAV();
1407 SvMAGIC(sv) = magic;
1408 SvSTASH(sv) = stash;
1414 SvANY(sv) = new_XPVHV();
1422 SvMAGIC(sv) = magic;
1423 SvSTASH(sv) = stash;
1430 SvANY(sv) = new_XPVCV();
1431 Zero(SvANY(sv), 1, XPVCV);
1437 SvMAGIC(sv) = magic;
1438 SvSTASH(sv) = stash;
1441 SvANY(sv) = new_XPVGV();
1447 SvMAGIC(sv) = magic;
1448 SvSTASH(sv) = stash;
1456 SvANY(sv) = new_XPVBM();
1462 SvMAGIC(sv) = magic;
1463 SvSTASH(sv) = stash;
1469 SvANY(sv) = new_XPVFM();
1470 Zero(SvANY(sv), 1, XPVFM);
1476 SvMAGIC(sv) = magic;
1477 SvSTASH(sv) = stash;
1480 SvANY(sv) = new_XPVIO();
1481 Zero(SvANY(sv), 1, XPVIO);
1487 SvMAGIC(sv) = magic;
1488 SvSTASH(sv) = stash;
1489 IoPAGE_LEN(sv) = 60;
1492 SvFLAGS(sv) &= ~SVTYPEMASK;
1498 =for apidoc sv_backoff
1500 Remove any string offset. You should normally use the C<SvOOK_off> macro
1507 Perl_sv_backoff(pTHX_ register SV *sv)
1511 char *s = SvPVX(sv);
1512 SvLEN(sv) += SvIVX(sv);
1513 SvPVX(sv) -= SvIVX(sv);
1515 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1517 SvFLAGS(sv) &= ~SVf_OOK;
1524 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1525 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1526 Use the C<SvGROW> wrapper instead.
1532 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1536 #ifdef HAS_64K_LIMIT
1537 if (newlen >= 0x10000) {
1538 PerlIO_printf(Perl_debug_log,
1539 "Allocation too large: %"UVxf"\n", (UV)newlen);
1542 #endif /* HAS_64K_LIMIT */
1545 if (SvTYPE(sv) < SVt_PV) {
1546 sv_upgrade(sv, SVt_PV);
1549 else if (SvOOK(sv)) { /* pv is offset? */
1552 if (newlen > SvLEN(sv))
1553 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1554 #ifdef HAS_64K_LIMIT
1555 if (newlen >= 0x10000)
1561 if (newlen > SvLEN(sv)) { /* need more room? */
1562 if (SvLEN(sv) && s) {
1563 #if defined(MYMALLOC) && !defined(LEAKTEST)
1564 STRLEN l = malloced_size((void*)SvPVX(sv));
1570 Renew(s,newlen,char);
1573 /* sv_force_normal_flags() must not try to unshare the new
1574 PVX we allocate below. AMS 20010713 */
1575 if (SvREADONLY(sv) && SvFAKE(sv)) {
1579 New(703, s, newlen, char);
1582 SvLEN_set(sv, newlen);
1588 =for apidoc sv_setiv
1590 Copies an integer into the given SV, upgrading first if necessary.
1591 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1597 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1599 SV_CHECK_THINKFIRST(sv);
1600 switch (SvTYPE(sv)) {
1602 sv_upgrade(sv, SVt_IV);
1605 sv_upgrade(sv, SVt_PVNV);
1609 sv_upgrade(sv, SVt_PVIV);
1618 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1619 PL_op_desc[PL_op->op_type]);
1621 (void)SvIOK_only(sv); /* validate number */
1627 =for apidoc sv_setiv_mg
1629 Like C<sv_setiv>, but also handles 'set' magic.
1635 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1642 =for apidoc sv_setuv
1644 Copies an unsigned integer into the given SV, upgrading first if necessary.
1645 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1651 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1653 /* With these two if statements:
1654 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1657 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1659 If you wish to remove them, please benchmark to see what the effect is
1661 if (u <= (UV)IV_MAX) {
1662 sv_setiv(sv, (IV)u);
1671 =for apidoc sv_setuv_mg
1673 Like C<sv_setuv>, but also handles 'set' magic.
1679 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1681 /* With these two if statements:
1682 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1685 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1687 If you wish to remove them, please benchmark to see what the effect is
1689 if (u <= (UV)IV_MAX) {
1690 sv_setiv(sv, (IV)u);
1700 =for apidoc sv_setnv
1702 Copies a double into the given SV, upgrading first if necessary.
1703 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1709 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1711 SV_CHECK_THINKFIRST(sv);
1712 switch (SvTYPE(sv)) {
1715 sv_upgrade(sv, SVt_NV);
1720 sv_upgrade(sv, SVt_PVNV);
1729 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1730 PL_op_name[PL_op->op_type]);
1733 (void)SvNOK_only(sv); /* validate number */
1738 =for apidoc sv_setnv_mg
1740 Like C<sv_setnv>, but also handles 'set' magic.
1746 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1752 /* Print an "isn't numeric" warning, using a cleaned-up,
1753 * printable version of the offending string
1757 S_not_a_number(pTHX_ SV *sv)
1761 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1762 /* each *s can expand to 4 chars + "...\0",
1763 i.e. need room for 8 chars */
1766 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1768 if (ch & 128 && !isPRINT_LC(ch)) {
1777 else if (ch == '\r') {
1781 else if (ch == '\f') {
1785 else if (ch == '\\') {
1789 else if (ch == '\0') {
1793 else if (isPRINT_LC(ch))
1808 Perl_warner(aTHX_ WARN_NUMERIC,
1809 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1810 PL_op_desc[PL_op->op_type]);
1812 Perl_warner(aTHX_ WARN_NUMERIC,
1813 "Argument \"%s\" isn't numeric", tmpbuf);
1817 =for apidoc looks_like_number
1819 Test if the content of an SV looks like a number (or is a number).
1820 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1821 non-numeric warning), even if your atof() doesn't grok them.
1827 Perl_looks_like_number(pTHX_ SV *sv)
1829 register char *sbegin;
1836 else if (SvPOKp(sv))
1837 sbegin = SvPV(sv, len);
1839 return 1; /* Historic. Wrong? */
1840 return grok_number(sbegin, len, NULL);
1843 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1844 until proven guilty, assume that things are not that bad... */
1849 As 64 bit platforms often have an NV that doesn't preserve all bits of
1850 an IV (an assumption perl has been based on to date) it becomes necessary
1851 to remove the assumption that the NV always carries enough precision to
1852 recreate the IV whenever needed, and that the NV is the canonical form.
1853 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1854 precision as a side effect of conversion (which would lead to insanity
1855 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1856 1) to distinguish between IV/UV/NV slots that have cached a valid
1857 conversion where precision was lost and IV/UV/NV slots that have a
1858 valid conversion which has lost no precision
1859 2) to ensure that if a numeric conversion to one form is requested that
1860 would lose precision, the precise conversion (or differently
1861 imprecise conversion) is also performed and cached, to prevent
1862 requests for different numeric formats on the same SV causing
1863 lossy conversion chains. (lossless conversion chains are perfectly
1868 SvIOKp is true if the IV slot contains a valid value
1869 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1870 SvNOKp is true if the NV slot contains a valid value
1871 SvNOK is true only if the NV value is accurate
1874 while converting from PV to NV, check to see if converting that NV to an
1875 IV(or UV) would lose accuracy over a direct conversion from PV to
1876 IV(or UV). If it would, cache both conversions, return NV, but mark
1877 SV as IOK NOKp (ie not NOK).
1879 While converting from PV to IV, check to see if converting that IV to an
1880 NV would lose accuracy over a direct conversion from PV to NV. If it
1881 would, cache both conversions, flag similarly.
1883 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1884 correctly because if IV & NV were set NV *always* overruled.
1885 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1886 changes - now IV and NV together means that the two are interchangeable:
1887 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1889 The benefit of this is that operations such as pp_add know that if
1890 SvIOK is true for both left and right operands, then integer addition
1891 can be used instead of floating point (for cases where the result won't
1892 overflow). Before, floating point was always used, which could lead to
1893 loss of precision compared with integer addition.
1895 * making IV and NV equal status should make maths accurate on 64 bit
1897 * may speed up maths somewhat if pp_add and friends start to use
1898 integers when possible instead of fp. (Hopefully the overhead in
1899 looking for SvIOK and checking for overflow will not outweigh the
1900 fp to integer speedup)
1901 * will slow down integer operations (callers of SvIV) on "inaccurate"
1902 values, as the change from SvIOK to SvIOKp will cause a call into
1903 sv_2iv each time rather than a macro access direct to the IV slot
1904 * should speed up number->string conversion on integers as IV is
1905 favoured when IV and NV are equally accurate
1907 ####################################################################
1908 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1909 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1910 On the other hand, SvUOK is true iff UV.
1911 ####################################################################
1913 Your mileage will vary depending your CPU's relative fp to integer
1917 #ifndef NV_PRESERVES_UV
1918 # define IS_NUMBER_UNDERFLOW_IV 1
1919 # define IS_NUMBER_UNDERFLOW_UV 2
1920 # define IS_NUMBER_IV_AND_UV 2
1921 # define IS_NUMBER_OVERFLOW_IV 4
1922 # define IS_NUMBER_OVERFLOW_UV 5
1924 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1926 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1928 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1930 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1931 if (SvNVX(sv) < (NV)IV_MIN) {
1932 (void)SvIOKp_on(sv);
1935 return IS_NUMBER_UNDERFLOW_IV;
1937 if (SvNVX(sv) > (NV)UV_MAX) {
1938 (void)SvIOKp_on(sv);
1942 return IS_NUMBER_OVERFLOW_UV;
1944 (void)SvIOKp_on(sv);
1946 /* Can't use strtol etc to convert this string. (See truth table in
1948 if (SvNVX(sv) <= (UV)IV_MAX) {
1949 SvIVX(sv) = I_V(SvNVX(sv));
1950 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1951 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1953 /* Integer is imprecise. NOK, IOKp */
1955 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1958 SvUVX(sv) = U_V(SvNVX(sv));
1959 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1960 if (SvUVX(sv) == UV_MAX) {
1961 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1962 possibly be preserved by NV. Hence, it must be overflow.
1964 return IS_NUMBER_OVERFLOW_UV;
1966 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1968 /* Integer is imprecise. NOK, IOKp */
1970 return IS_NUMBER_OVERFLOW_IV;
1972 #endif /* !NV_PRESERVES_UV*/
1977 Return the integer value of an SV, doing any necessary string conversion,
1978 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1984 Perl_sv_2iv(pTHX_ register SV *sv)
1988 if (SvGMAGICAL(sv)) {
1993 return I_V(SvNVX(sv));
1995 if (SvPOKp(sv) && SvLEN(sv))
1998 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1999 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2005 if (SvTHINKFIRST(sv)) {
2008 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2009 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2010 return SvIV(tmpstr);
2011 return PTR2IV(SvRV(sv));
2013 if (SvREADONLY(sv) && SvFAKE(sv)) {
2014 sv_force_normal(sv);
2016 if (SvREADONLY(sv) && !SvOK(sv)) {
2017 if (ckWARN(WARN_UNINITIALIZED))
2024 return (IV)(SvUVX(sv));
2031 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2032 * without also getting a cached IV/UV from it at the same time
2033 * (ie PV->NV conversion should detect loss of accuracy and cache
2034 * IV or UV at same time to avoid this. NWC */
2036 if (SvTYPE(sv) == SVt_NV)
2037 sv_upgrade(sv, SVt_PVNV);
2039 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2040 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2041 certainly cast into the IV range at IV_MAX, whereas the correct
2042 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2044 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2045 SvIVX(sv) = I_V(SvNVX(sv));
2046 if (SvNVX(sv) == (NV) SvIVX(sv)
2047 #ifndef NV_PRESERVES_UV
2048 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2049 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2050 /* Don't flag it as "accurately an integer" if the number
2051 came from a (by definition imprecise) NV operation, and
2052 we're outside the range of NV integer precision */
2055 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2056 DEBUG_c(PerlIO_printf(Perl_debug_log,
2057 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2063 /* IV not precise. No need to convert from PV, as NV
2064 conversion would already have cached IV if it detected
2065 that PV->IV would be better than PV->NV->IV
2066 flags already correct - don't set public IOK. */
2067 DEBUG_c(PerlIO_printf(Perl_debug_log,
2068 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2073 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2074 but the cast (NV)IV_MIN rounds to a the value less (more
2075 negative) than IV_MIN which happens to be equal to SvNVX ??
2076 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2077 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2078 (NV)UVX == NVX are both true, but the values differ. :-(
2079 Hopefully for 2s complement IV_MIN is something like
2080 0x8000000000000000 which will be exact. NWC */
2083 SvUVX(sv) = U_V(SvNVX(sv));
2085 (SvNVX(sv) == (NV) SvUVX(sv))
2086 #ifndef NV_PRESERVES_UV
2087 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2088 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2089 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2090 /* Don't flag it as "accurately an integer" if the number
2091 came from a (by definition imprecise) NV operation, and
2092 we're outside the range of NV integer precision */
2098 DEBUG_c(PerlIO_printf(Perl_debug_log,
2099 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2103 return (IV)SvUVX(sv);
2106 else if (SvPOKp(sv) && SvLEN(sv)) {
2108 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2109 /* We want to avoid a possible problem when we cache an IV which
2110 may be later translated to an NV, and the resulting NV is not
2111 the same as the direct translation of the initial string
2112 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2113 be careful to ensure that the value with the .456 is around if the
2114 NV value is requested in the future).
2116 This means that if we cache such an IV, we need to cache the
2117 NV as well. Moreover, we trade speed for space, and do not
2118 cache the NV if we are sure it's not needed.
2121 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123 == IS_NUMBER_IN_UV) {
2124 /* It's definitely an integer, only upgrade to PVIV */
2125 if (SvTYPE(sv) < SVt_PVIV)
2126 sv_upgrade(sv, SVt_PVIV);
2128 } else if (SvTYPE(sv) < SVt_PVNV)
2129 sv_upgrade(sv, SVt_PVNV);
2131 /* If NV preserves UV then we only use the UV value if we know that
2132 we aren't going to call atof() below. If NVs don't preserve UVs
2133 then the value returned may have more precision than atof() will
2134 return, even though value isn't perfectly accurate. */
2135 if ((numtype & (IS_NUMBER_IN_UV
2136 #ifdef NV_PRESERVES_UV
2139 )) == IS_NUMBER_IN_UV) {
2140 /* This won't turn off the public IOK flag if it was set above */
2141 (void)SvIOKp_on(sv);
2143 if (!(numtype & IS_NUMBER_NEG)) {
2145 if (value <= (UV)IV_MAX) {
2146 SvIVX(sv) = (IV)value;
2152 /* 2s complement assumption */
2153 if (value <= (UV)IV_MIN) {
2154 SvIVX(sv) = -(IV)value;
2156 /* Too negative for an IV. This is a double upgrade, but
2157 I'm assuming it will be be rare. */
2158 if (SvTYPE(sv) < SVt_PVNV)
2159 sv_upgrade(sv, SVt_PVNV);
2163 SvNVX(sv) = -(NV)value;
2168 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2169 will be in the previous block to set the IV slot, and the next
2170 block to set the NV slot. So no else here. */
2172 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2173 != IS_NUMBER_IN_UV) {
2174 /* It wasn't an (integer that doesn't overflow the UV). */
2175 SvNVX(sv) = Atof(SvPVX(sv));
2177 if (! numtype && ckWARN(WARN_NUMERIC))
2180 #if defined(USE_LONG_DOUBLE)
2181 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2182 PTR2UV(sv), SvNVX(sv)));
2184 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2185 PTR2UV(sv), SvNVX(sv)));
2189 #ifdef NV_PRESERVES_UV
2190 (void)SvIOKp_on(sv);
2192 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2193 SvIVX(sv) = I_V(SvNVX(sv));
2194 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2197 /* Integer is imprecise. NOK, IOKp */
2199 /* UV will not work better than IV */
2201 if (SvNVX(sv) > (NV)UV_MAX) {
2203 /* Integer is inaccurate. NOK, IOKp, is UV */
2207 SvUVX(sv) = U_V(SvNVX(sv));
2208 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2209 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2213 /* Integer is imprecise. NOK, IOKp, is UV */
2219 #else /* NV_PRESERVES_UV */
2220 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2221 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2222 /* The IV slot will have been set from value returned by
2223 grok_number above. The NV slot has just been set using
2226 assert (SvIOKp(sv));
2228 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2229 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2230 /* Small enough to preserve all bits. */
2231 (void)SvIOKp_on(sv);
2233 SvIVX(sv) = I_V(SvNVX(sv));
2234 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2236 /* Assumption: first non-preserved integer is < IV_MAX,
2237 this NV is in the preserved range, therefore: */
2238 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2240 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2244 0 0 already failed to read UV.
2245 0 1 already failed to read UV.
2246 1 0 you won't get here in this case. IV/UV
2247 slot set, public IOK, Atof() unneeded.
2248 1 1 already read UV.
2249 so there's no point in sv_2iuv_non_preserve() attempting
2250 to use atol, strtol, strtoul etc. */
2251 if (sv_2iuv_non_preserve (sv, numtype)
2252 >= IS_NUMBER_OVERFLOW_IV)
2256 #endif /* NV_PRESERVES_UV */
2259 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2261 if (SvTYPE(sv) < SVt_IV)
2262 /* Typically the caller expects that sv_any is not NULL now. */
2263 sv_upgrade(sv, SVt_IV);
2266 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2267 PTR2UV(sv),SvIVX(sv)));
2268 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2274 Return the unsigned integer value of an SV, doing any necessary string
2275 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2282 Perl_sv_2uv(pTHX_ register SV *sv)
2286 if (SvGMAGICAL(sv)) {
2291 return U_V(SvNVX(sv));
2292 if (SvPOKp(sv) && SvLEN(sv))
2295 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2296 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2302 if (SvTHINKFIRST(sv)) {
2305 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2306 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2307 return SvUV(tmpstr);
2308 return PTR2UV(SvRV(sv));
2310 if (SvREADONLY(sv) && SvFAKE(sv)) {
2311 sv_force_normal(sv);
2313 if (SvREADONLY(sv) && !SvOK(sv)) {
2314 if (ckWARN(WARN_UNINITIALIZED))
2324 return (UV)SvIVX(sv);
2328 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2329 * without also getting a cached IV/UV from it at the same time
2330 * (ie PV->NV conversion should detect loss of accuracy and cache
2331 * IV or UV at same time to avoid this. */
2332 /* IV-over-UV optimisation - choose to cache IV if possible */
2334 if (SvTYPE(sv) == SVt_NV)
2335 sv_upgrade(sv, SVt_PVNV);
2337 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2338 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2339 SvIVX(sv) = I_V(SvNVX(sv));
2340 if (SvNVX(sv) == (NV) SvIVX(sv)
2341 #ifndef NV_PRESERVES_UV
2342 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2343 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2344 /* Don't flag it as "accurately an integer" if the number
2345 came from a (by definition imprecise) NV operation, and
2346 we're outside the range of NV integer precision */
2349 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2350 DEBUG_c(PerlIO_printf(Perl_debug_log,
2351 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2357 /* IV not precise. No need to convert from PV, as NV
2358 conversion would already have cached IV if it detected
2359 that PV->IV would be better than PV->NV->IV
2360 flags already correct - don't set public IOK. */
2361 DEBUG_c(PerlIO_printf(Perl_debug_log,
2362 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2367 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2368 but the cast (NV)IV_MIN rounds to a the value less (more
2369 negative) than IV_MIN which happens to be equal to SvNVX ??
2370 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2371 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2372 (NV)UVX == NVX are both true, but the values differ. :-(
2373 Hopefully for 2s complement IV_MIN is something like
2374 0x8000000000000000 which will be exact. NWC */
2377 SvUVX(sv) = U_V(SvNVX(sv));
2379 (SvNVX(sv) == (NV) SvUVX(sv))
2380 #ifndef NV_PRESERVES_UV
2381 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2382 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2383 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2384 /* Don't flag it as "accurately an integer" if the number
2385 came from a (by definition imprecise) NV operation, and
2386 we're outside the range of NV integer precision */
2391 DEBUG_c(PerlIO_printf(Perl_debug_log,
2392 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2398 else if (SvPOKp(sv) && SvLEN(sv)) {
2400 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2402 /* We want to avoid a possible problem when we cache a UV which
2403 may be later translated to an NV, and the resulting NV is not
2404 the translation of the initial data.
2406 This means that if we cache such a UV, we need to cache the
2407 NV as well. Moreover, we trade speed for space, and do not
2408 cache the NV if not needed.
2411 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2412 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2413 == IS_NUMBER_IN_UV) {
2414 /* It's definitely an integer, only upgrade to PVIV */
2415 if (SvTYPE(sv) < SVt_PVIV)
2416 sv_upgrade(sv, SVt_PVIV);
2418 } else if (SvTYPE(sv) < SVt_PVNV)
2419 sv_upgrade(sv, SVt_PVNV);
2421 /* If NV preserves UV then we only use the UV value if we know that
2422 we aren't going to call atof() below. If NVs don't preserve UVs
2423 then the value returned may have more precision than atof() will
2424 return, even though it isn't accurate. */
2425 if ((numtype & (IS_NUMBER_IN_UV
2426 #ifdef NV_PRESERVES_UV
2429 )) == IS_NUMBER_IN_UV) {
2430 /* This won't turn off the public IOK flag if it was set above */
2431 (void)SvIOKp_on(sv);
2433 if (!(numtype & IS_NUMBER_NEG)) {
2435 if (value <= (UV)IV_MAX) {
2436 SvIVX(sv) = (IV)value;
2438 /* it didn't overflow, and it was positive. */
2443 /* 2s complement assumption */
2444 if (value <= (UV)IV_MIN) {
2445 SvIVX(sv) = -(IV)value;
2447 /* Too negative for an IV. This is a double upgrade, but
2448 I'm assuming it will be be rare. */
2449 if (SvTYPE(sv) < SVt_PVNV)
2450 sv_upgrade(sv, SVt_PVNV);
2454 SvNVX(sv) = -(NV)value;
2460 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2461 != IS_NUMBER_IN_UV) {
2462 /* It wasn't an integer, or it overflowed the UV. */
2463 SvNVX(sv) = Atof(SvPVX(sv));
2465 if (! numtype && ckWARN(WARN_NUMERIC))
2468 #if defined(USE_LONG_DOUBLE)
2469 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2470 PTR2UV(sv), SvNVX(sv)));
2472 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2473 PTR2UV(sv), SvNVX(sv)));
2476 #ifdef NV_PRESERVES_UV
2477 (void)SvIOKp_on(sv);
2479 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2480 SvIVX(sv) = I_V(SvNVX(sv));
2481 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2484 /* Integer is imprecise. NOK, IOKp */
2486 /* UV will not work better than IV */
2488 if (SvNVX(sv) > (NV)UV_MAX) {
2490 /* Integer is inaccurate. NOK, IOKp, is UV */
2494 SvUVX(sv) = U_V(SvNVX(sv));
2495 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2496 NV preservse UV so can do correct comparison. */
2497 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2501 /* Integer is imprecise. NOK, IOKp, is UV */
2506 #else /* NV_PRESERVES_UV */
2507 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2508 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2509 /* The UV slot will have been set from value returned by
2510 grok_number above. The NV slot has just been set using
2513 assert (SvIOKp(sv));
2515 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2516 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2517 /* Small enough to preserve all bits. */
2518 (void)SvIOKp_on(sv);
2520 SvIVX(sv) = I_V(SvNVX(sv));
2521 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2523 /* Assumption: first non-preserved integer is < IV_MAX,
2524 this NV is in the preserved range, therefore: */
2525 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2527 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2530 sv_2iuv_non_preserve (sv, numtype);
2532 #endif /* NV_PRESERVES_UV */
2536 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2537 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2540 if (SvTYPE(sv) < SVt_IV)
2541 /* Typically the caller expects that sv_any is not NULL now. */
2542 sv_upgrade(sv, SVt_IV);
2546 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2547 PTR2UV(sv),SvUVX(sv)));
2548 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2554 Return the num value of an SV, doing any necessary string or integer
2555 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2562 Perl_sv_2nv(pTHX_ register SV *sv)
2566 if (SvGMAGICAL(sv)) {
2570 if (SvPOKp(sv) && SvLEN(sv)) {
2571 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2572 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2574 return Atof(SvPVX(sv));
2578 return (NV)SvUVX(sv);
2580 return (NV)SvIVX(sv);
2583 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2584 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2590 if (SvTHINKFIRST(sv)) {
2593 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2594 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2595 return SvNV(tmpstr);
2596 return PTR2NV(SvRV(sv));
2598 if (SvREADONLY(sv) && SvFAKE(sv)) {
2599 sv_force_normal(sv);
2601 if (SvREADONLY(sv) && !SvOK(sv)) {
2602 if (ckWARN(WARN_UNINITIALIZED))
2607 if (SvTYPE(sv) < SVt_NV) {
2608 if (SvTYPE(sv) == SVt_IV)
2609 sv_upgrade(sv, SVt_PVNV);
2611 sv_upgrade(sv, SVt_NV);
2612 #ifdef USE_LONG_DOUBLE
2614 STORE_NUMERIC_LOCAL_SET_STANDARD();
2615 PerlIO_printf(Perl_debug_log,
2616 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2617 PTR2UV(sv), SvNVX(sv));
2618 RESTORE_NUMERIC_LOCAL();
2622 STORE_NUMERIC_LOCAL_SET_STANDARD();
2623 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2624 PTR2UV(sv), SvNVX(sv));
2625 RESTORE_NUMERIC_LOCAL();
2629 else if (SvTYPE(sv) < SVt_PVNV)
2630 sv_upgrade(sv, SVt_PVNV);
2631 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2634 else if (SvIOKp(sv)) {
2635 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2636 #ifdef NV_PRESERVES_UV
2639 /* Only set the public NV OK flag if this NV preserves the IV */
2640 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2641 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2642 : (SvIVX(sv) == I_V(SvNVX(sv))))
2648 else if (SvPOKp(sv) && SvLEN(sv)) {
2650 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2651 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2653 #ifdef NV_PRESERVES_UV
2654 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2655 == IS_NUMBER_IN_UV) {
2656 /* It's definitely an integer */
2657 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2659 SvNVX(sv) = Atof(SvPVX(sv));
2662 SvNVX(sv) = Atof(SvPVX(sv));
2663 /* Only set the public NV OK flag if this NV preserves the value in
2664 the PV at least as well as an IV/UV would.
2665 Not sure how to do this 100% reliably. */
2666 /* if that shift count is out of range then Configure's test is
2667 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2669 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2670 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2671 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2672 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2673 /* Can't use strtol etc to convert this string, so don't try.
2674 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2677 /* value has been set. It may not be precise. */
2678 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2679 /* 2s complement assumption for (UV)IV_MIN */
2680 SvNOK_on(sv); /* Integer is too negative. */
2685 if (numtype & IS_NUMBER_NEG) {
2686 SvIVX(sv) = -(IV)value;
2687 } else if (value <= (UV)IV_MAX) {
2688 SvIVX(sv) = (IV)value;
2694 if (numtype & IS_NUMBER_NOT_INT) {
2695 /* I believe that even if the original PV had decimals,
2696 they are lost beyond the limit of the FP precision.
2697 However, neither is canonical, so both only get p
2698 flags. NWC, 2000/11/25 */
2699 /* Both already have p flags, so do nothing */
2702 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2703 if (SvIVX(sv) == I_V(nv)) {
2708 /* It had no "." so it must be integer. */
2711 /* between IV_MAX and NV(UV_MAX).
2712 Could be slightly > UV_MAX */
2714 if (numtype & IS_NUMBER_NOT_INT) {
2715 /* UV and NV both imprecise. */
2717 UV nv_as_uv = U_V(nv);
2719 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2730 #endif /* NV_PRESERVES_UV */
2733 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2735 if (SvTYPE(sv) < SVt_NV)
2736 /* Typically the caller expects that sv_any is not NULL now. */
2737 /* XXX Ilya implies that this is a bug in callers that assume this
2738 and ideally should be fixed. */
2739 sv_upgrade(sv, SVt_NV);
2742 #if defined(USE_LONG_DOUBLE)
2744 STORE_NUMERIC_LOCAL_SET_STANDARD();
2745 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2746 PTR2UV(sv), SvNVX(sv));
2747 RESTORE_NUMERIC_LOCAL();
2751 STORE_NUMERIC_LOCAL_SET_STANDARD();
2752 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2753 PTR2UV(sv), SvNVX(sv));
2754 RESTORE_NUMERIC_LOCAL();
2760 /* asIV(): extract an integer from the string value of an SV.
2761 * Caller must validate PVX */
2764 S_asIV(pTHX_ SV *sv)
2767 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2769 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2770 == IS_NUMBER_IN_UV) {
2771 /* It's definitely an integer */
2772 if (numtype & IS_NUMBER_NEG) {
2773 if (value < (UV)IV_MIN)
2776 if (value < (UV)IV_MAX)
2781 if (ckWARN(WARN_NUMERIC))
2784 return I_V(Atof(SvPVX(sv)));
2787 /* asUV(): extract an unsigned integer from the string value of an SV
2788 * Caller must validate PVX */
2791 S_asUV(pTHX_ SV *sv)
2794 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2796 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2797 == IS_NUMBER_IN_UV) {
2798 /* It's definitely an integer */
2799 if (!(numtype & IS_NUMBER_NEG))
2803 if (ckWARN(WARN_NUMERIC))
2806 return U_V(Atof(SvPVX(sv)));
2810 =for apidoc sv_2pv_nolen
2812 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2813 use the macro wrapper C<SvPV_nolen(sv)> instead.
2818 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2821 return sv_2pv(sv, &n_a);
2824 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2825 * UV as a string towards the end of buf, and return pointers to start and
2828 * We assume that buf is at least TYPE_CHARS(UV) long.
2832 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2834 char *ptr = buf + TYPE_CHARS(UV);
2848 *--ptr = '0' + (uv % 10);
2856 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2857 * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2861 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2863 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2867 =for apidoc sv_2pv_flags
2869 Returns a pointer to the string value of an SV, and sets *lp to its length.
2870 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2872 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2873 usually end up here too.
2879 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2884 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2885 char *tmpbuf = tbuf;
2891 if (SvGMAGICAL(sv)) {
2892 if (flags & SV_GMAGIC)
2900 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2902 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2907 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2912 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2913 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2920 if (SvTHINKFIRST(sv)) {
2923 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2924 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2925 return SvPV(tmpstr,*lp);
2932 switch (SvTYPE(sv)) {
2934 if ( ((SvFLAGS(sv) &
2935 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2936 == (SVs_OBJECT|SVs_RMG))
2937 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2938 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2939 regexp *re = (regexp *)mg->mg_obj;
2942 char *fptr = "msix";
2947 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2949 while((ch = *fptr++)) {
2951 reflags[left++] = ch;
2954 reflags[right--] = ch;
2959 reflags[left] = '-';
2963 mg->mg_len = re->prelen + 4 + left;
2964 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2965 Copy("(?", mg->mg_ptr, 2, char);
2966 Copy(reflags, mg->mg_ptr+2, left, char);
2967 Copy(":", mg->mg_ptr+left+2, 1, char);
2968 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2969 mg->mg_ptr[mg->mg_len - 1] = ')';
2970 mg->mg_ptr[mg->mg_len] = 0;
2972 PL_reginterp_cnt += re->program[0].next_off;
2984 case SVt_PVBM: if (SvROK(sv))
2987 s = "SCALAR"; break;
2988 case SVt_PVLV: s = "LVALUE"; break;
2989 case SVt_PVAV: s = "ARRAY"; break;
2990 case SVt_PVHV: s = "HASH"; break;
2991 case SVt_PVCV: s = "CODE"; break;
2992 case SVt_PVGV: s = "GLOB"; break;
2993 case SVt_PVFM: s = "FORMAT"; break;
2994 case SVt_PVIO: s = "IO"; break;
2995 default: s = "UNKNOWN"; break;
2999 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3002 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3008 if (SvREADONLY(sv) && !SvOK(sv)) {
3009 if (ckWARN(WARN_UNINITIALIZED))
3015 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3016 /* I'm assuming that if both IV and NV are equally valid then
3017 converting the IV is going to be more efficient */
3018 U32 isIOK = SvIOK(sv);
3019 U32 isUIOK = SvIsUV(sv);
3020 char buf[TYPE_CHARS(UV)];
3023 if (SvTYPE(sv) < SVt_PVIV)
3024 sv_upgrade(sv, SVt_PVIV);
3026 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3028 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3029 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
3030 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3031 SvCUR_set(sv, ebuf - ptr);
3041 else if (SvNOKp(sv)) {
3042 if (SvTYPE(sv) < SVt_PVNV)
3043 sv_upgrade(sv, SVt_PVNV);
3044 /* The +20 is pure guesswork. Configure test needed. --jhi */
3045 SvGROW(sv, NV_DIG + 20);
3047 olderrno = errno; /* some Xenix systems wipe out errno here */
3049 if (SvNVX(sv) == 0.0)
3050 (void)strcpy(s,"0");
3054 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3057 #ifdef FIXNEGATIVEZERO
3058 if (*s == '-' && s[1] == '0' && !s[2])
3068 if (ckWARN(WARN_UNINITIALIZED)
3069 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3072 if (SvTYPE(sv) < SVt_PV)
3073 /* Typically the caller expects that sv_any is not NULL now. */
3074 sv_upgrade(sv, SVt_PV);
3077 *lp = s - SvPVX(sv);
3080 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3081 PTR2UV(sv),SvPVX(sv)));
3085 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3086 /* Sneaky stuff here */
3090 tsv = newSVpv(tmpbuf, 0);
3106 len = strlen(tmpbuf);
3108 #ifdef FIXNEGATIVEZERO
3109 if (len == 2 && t[0] == '-' && t[1] == '0') {
3114 (void)SvUPGRADE(sv, SVt_PV);
3116 s = SvGROW(sv, len + 1);
3125 =for apidoc sv_2pvbyte_nolen
3127 Return a pointer to the byte-encoded representation of the SV.
3128 May cause the SV to be downgraded from UTF8 as a side-effect.
3130 Usually accessed via the C<SvPVbyte_nolen> macro.
3136 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3139 return sv_2pvbyte(sv, &n_a);
3143 =for apidoc sv_2pvbyte
3145 Return a pointer to the byte-encoded representation of the SV, and set *lp
3146 to its length. May cause the SV to be downgraded from UTF8 as a
3149 Usually accessed via the C<SvPVbyte> macro.
3155 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3157 sv_utf8_downgrade(sv,0);
3158 return SvPV(sv,*lp);
3162 =for apidoc sv_2pvutf8_nolen
3164 Return a pointer to the UTF8-encoded representation of the SV.
3165 May cause the SV to be upgraded to UTF8 as a side-effect.
3167 Usually accessed via the C<SvPVutf8_nolen> macro.
3173 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3176 return sv_2pvutf8(sv, &n_a);
3180 =for apidoc sv_2pvutf8
3182 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3183 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3185 Usually accessed via the C<SvPVutf8> macro.
3191 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3193 sv_utf8_upgrade(sv);
3194 return SvPV(sv,*lp);
3198 =for apidoc sv_2bool
3200 This function is only called on magical items, and is only used by
3201 sv_true() or its macro equivalent.
3207 Perl_sv_2bool(pTHX_ register SV *sv)
3216 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3217 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
3218 return SvTRUE(tmpsv);
3219 return SvRV(sv) != 0;
3222 register XPV* Xpvtmp;
3223 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3224 (*Xpvtmp->xpv_pv > '0' ||
3225 Xpvtmp->xpv_cur > 1 ||
3226 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3233 return SvIVX(sv) != 0;
3236 return SvNVX(sv) != 0.0;
3244 =for apidoc sv_utf8_upgrade
3246 Convert the PV of an SV to its UTF8-encoded form.
3247 Forces the SV to string form if it is not already.
3248 Always sets the SvUTF8 flag to avoid future validity checks even
3249 if all the bytes have hibit clear.
3255 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3257 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3261 =for apidoc sv_utf8_upgrade_flags
3263 Convert the PV of an SV to its UTF8-encoded form.
3264 Forces the SV to string form if it is not already.
3265 Always sets the SvUTF8 flag to avoid future validity checks even
3266 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3267 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3268 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3274 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3284 (void) sv_2pv_flags(sv,&len, flags);
3292 if (SvREADONLY(sv) && SvFAKE(sv)) {
3293 sv_force_normal(sv);
3296 /* This function could be much more efficient if we had a FLAG in SVs
3297 * to signal if there are any hibit chars in the PV.
3298 * Given that there isn't make loop fast as possible
3300 s = (U8 *) SvPVX(sv);
3301 e = (U8 *) SvEND(sv);
3305 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3311 len = SvCUR(sv) + 1; /* Plus the \0 */
3312 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3313 SvCUR(sv) = len - 1;
3315 Safefree(s); /* No longer using what was there before. */
3316 SvLEN(sv) = len; /* No longer know the real size. */
3318 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3324 =for apidoc sv_utf8_downgrade
3326 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3327 This may not be possible if the PV contains non-byte encoding characters;
3328 if this is the case, either returns false or, if C<fail_ok> is not
3335 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3337 if (SvPOK(sv) && SvUTF8(sv)) {
3342 if (SvREADONLY(sv) && SvFAKE(sv))
3343 sv_force_normal(sv);
3344 s = (U8 *) SvPV(sv, len);
3345 if (!utf8_to_bytes(s, &len)) {
3348 #ifdef USE_BYTES_DOWNGRADES
3349 else if (IN_BYTES) {
3351 U8 *e = (U8 *) SvEND(sv);
3354 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3355 if (first && ch > 255) {
3357 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3358 PL_op_desc[PL_op->op_type]);
3360 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3367 len = (d - (U8 *) SvPVX(sv));
3372 Perl_croak(aTHX_ "Wide character in %s",
3373 PL_op_desc[PL_op->op_type]);
3375 Perl_croak(aTHX_ "Wide character");
3386 =for apidoc sv_utf8_encode
3388 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3389 flag so that it looks like octets again. Used as a building block
3390 for encode_utf8 in Encode.xs
3396 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3398 (void) sv_utf8_upgrade(sv);
3403 =for apidoc sv_utf8_decode
3405 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3406 turn off SvUTF8 if needed so that we see characters. Used as a building block
3407 for decode_utf8 in Encode.xs
3413 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3419 /* The octets may have got themselves encoded - get them back as
3422 if (!sv_utf8_downgrade(sv, TRUE))
3425 /* it is actually just a matter of turning the utf8 flag on, but
3426 * we want to make sure everything inside is valid utf8 first.
3428 c = (U8 *) SvPVX(sv);
3429 if (!is_utf8_string(c, SvCUR(sv)+1))
3431 e = (U8 *) SvEND(sv);
3434 if (!UTF8_IS_INVARIANT(ch)) {
3444 =for apidoc sv_setsv
3446 Copies the contents of the source SV C<ssv> into the destination SV
3447 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3448 function if the source SV needs to be reused. Does not handle 'set' magic.
3449 Loosely speaking, it performs a copy-by-value, obliterating any previous
3450 content of the destination.
3452 You probably want to use one of the assortment of wrappers, such as
3453 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3454 C<SvSetMagicSV_nosteal>.
3460 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3461 for binary compatibility only
3464 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3466 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3470 =for apidoc sv_setsv_flags
3472 Copies the contents of the source SV C<ssv> into the destination SV
3473 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3474 function if the source SV needs to be reused. Does not handle 'set' magic.
3475 Loosely speaking, it performs a copy-by-value, obliterating any previous
3476 content of the destination.
3477 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3478 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3479 implemented in terms of this function.
3481 You probably want to use one of the assortment of wrappers, such as
3482 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3483 C<SvSetMagicSV_nosteal>.
3485 This is the primary function for copying scalars, and most other
3486 copy-ish functions and macros use this underneath.
3492 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3494 register U32 sflags;
3500 SV_CHECK_THINKFIRST(dstr);
3502 sstr = &PL_sv_undef;
3503 stype = SvTYPE(sstr);
3504 dtype = SvTYPE(dstr);
3508 /* There's a lot of redundancy below but we're going for speed here */
3513 if (dtype != SVt_PVGV) {
3514 (void)SvOK_off(dstr);
3522 sv_upgrade(dstr, SVt_IV);
3525 sv_upgrade(dstr, SVt_PVNV);
3529 sv_upgrade(dstr, SVt_PVIV);
3532 (void)SvIOK_only(dstr);
3533 SvIVX(dstr) = SvIVX(sstr);
3536 if (SvTAINTED(sstr))
3547 sv_upgrade(dstr, SVt_NV);
3552 sv_upgrade(dstr, SVt_PVNV);
3555 SvNVX(dstr) = SvNVX(sstr);
3556 (void)SvNOK_only(dstr);
3557 if (SvTAINTED(sstr))
3565 sv_upgrade(dstr, SVt_RV);
3566 else if (dtype == SVt_PVGV &&
3567 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3570 if (GvIMPORTED(dstr) != GVf_IMPORTED
3571 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3573 GvIMPORTED_on(dstr);
3584 sv_upgrade(dstr, SVt_PV);
3587 if (dtype < SVt_PVIV)
3588 sv_upgrade(dstr, SVt_PVIV);
3591 if (dtype < SVt_PVNV)
3592 sv_upgrade(dstr, SVt_PVNV);
3599 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3600 PL_op_name[PL_op->op_type]);
3602 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3606 if (dtype <= SVt_PVGV) {
3608 if (dtype != SVt_PVGV) {
3609 char *name = GvNAME(sstr);
3610 STRLEN len = GvNAMELEN(sstr);
3611 sv_upgrade(dstr, SVt_PVGV);
3612 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3613 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3614 GvNAME(dstr) = savepvn(name, len);
3615 GvNAMELEN(dstr) = len;
3616 SvFAKE_on(dstr); /* can coerce to non-glob */
3618 /* ahem, death to those who redefine active sort subs */
3619 else if (PL_curstackinfo->si_type == PERLSI_SORT
3620 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3621 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3624 #ifdef GV_UNIQUE_CHECK
3625 if (GvUNIQUE((GV*)dstr)) {
3626 Perl_croak(aTHX_ PL_no_modify);
3630 (void)SvOK_off(dstr);
3631 GvINTRO_off(dstr); /* one-shot flag */
3633 GvGP(dstr) = gp_ref(GvGP(sstr));
3634 if (SvTAINTED(sstr))
3636 if (GvIMPORTED(dstr) != GVf_IMPORTED
3637 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3639 GvIMPORTED_on(dstr);
3647 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3649 if (SvTYPE(sstr) != stype) {
3650 stype = SvTYPE(sstr);
3651 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3655 if (stype == SVt_PVLV)
3656 (void)SvUPGRADE(dstr, SVt_PVNV);
3658 (void)SvUPGRADE(dstr, stype);
3661 sflags = SvFLAGS(sstr);
3663 if (sflags & SVf_ROK) {
3664 if (dtype >= SVt_PV) {
3665 if (dtype == SVt_PVGV) {
3666 SV *sref = SvREFCNT_inc(SvRV(sstr));
3668 int intro = GvINTRO(dstr);
3670 #ifdef GV_UNIQUE_CHECK
3671 if (GvUNIQUE((GV*)dstr)) {
3672 Perl_croak(aTHX_ PL_no_modify);
3677 GvINTRO_off(dstr); /* one-shot flag */
3678 GvLINE(dstr) = CopLINE(PL_curcop);
3679 GvEGV(dstr) = (GV*)dstr;
3682 switch (SvTYPE(sref)) {
3685 SAVESPTR(GvAV(dstr));
3687 dref = (SV*)GvAV(dstr);
3688 GvAV(dstr) = (AV*)sref;
3689 if (!GvIMPORTED_AV(dstr)
3690 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3692 GvIMPORTED_AV_on(dstr);
3697 SAVESPTR(GvHV(dstr));
3699 dref = (SV*)GvHV(dstr);
3700 GvHV(dstr) = (HV*)sref;
3701 if (!GvIMPORTED_HV(dstr)
3702 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3704 GvIMPORTED_HV_on(dstr);
3709 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3710 SvREFCNT_dec(GvCV(dstr));
3711 GvCV(dstr) = Nullcv;
3712 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3713 PL_sub_generation++;
3715 SAVESPTR(GvCV(dstr));
3718 dref = (SV*)GvCV(dstr);
3719 if (GvCV(dstr) != (CV*)sref) {
3720 CV* cv = GvCV(dstr);
3722 if (!GvCVGEN((GV*)dstr) &&
3723 (CvROOT(cv) || CvXSUB(cv)))
3725 /* ahem, death to those who redefine
3726 * active sort subs */
3727 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3728 PL_sortcop == CvSTART(cv))
3730 "Can't redefine active sort subroutine %s",
3731 GvENAME((GV*)dstr));
3732 /* Redefining a sub - warning is mandatory if
3733 it was a const and its value changed. */
3734 if (ckWARN(WARN_REDEFINE)
3736 && (!CvCONST((CV*)sref)
3737 || sv_cmp(cv_const_sv(cv),
3738 cv_const_sv((CV*)sref)))))
3740 Perl_warner(aTHX_ WARN_REDEFINE,
3742 ? "Constant subroutine %s redefined"
3743 : "Subroutine %s redefined",
3744 GvENAME((GV*)dstr));
3747 cv_ckproto(cv, (GV*)dstr,
3748 SvPOK(sref) ? SvPVX(sref) : Nullch);
3750 GvCV(dstr) = (CV*)sref;
3751 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3752 GvASSUMECV_on(dstr);
3753 PL_sub_generation++;
3755 if (!GvIMPORTED_CV(dstr)
3756 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3758 GvIMPORTED_CV_on(dstr);
3763 SAVESPTR(GvIOp(dstr));
3765 dref = (SV*)GvIOp(dstr);
3766 GvIOp(dstr) = (IO*)sref;
3770 SAVESPTR(GvFORM(dstr));
3772 dref = (SV*)GvFORM(dstr);
3773 GvFORM(dstr) = (CV*)sref;
3777 SAVESPTR(GvSV(dstr));
3779 dref = (SV*)GvSV(dstr);
3781 if (!GvIMPORTED_SV(dstr)
3782 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3784 GvIMPORTED_SV_on(dstr);
3792 if (SvTAINTED(sstr))
3797 (void)SvOOK_off(dstr); /* backoff */
3799 Safefree(SvPVX(dstr));
3800 SvLEN(dstr)=SvCUR(dstr)=0;
3803 (void)SvOK_off(dstr);
3804 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3806 if (sflags & SVp_NOK) {
3808 /* Only set the public OK flag if the source has public OK. */
3809 if (sflags & SVf_NOK)
3810 SvFLAGS(dstr) |= SVf_NOK;
3811 SvNVX(dstr) = SvNVX(sstr);
3813 if (sflags & SVp_IOK) {
3814 (void)SvIOKp_on(dstr);
3815 if (sflags & SVf_IOK)
3816 SvFLAGS(dstr) |= SVf_IOK;
3817 if (sflags & SVf_IVisUV)
3819 SvIVX(dstr) = SvIVX(sstr);
3821 if (SvAMAGIC(sstr)) {
3825 else if (sflags & SVp_POK) {
3828 * Check to see if we can just swipe the string. If so, it's a
3829 * possible small lose on short strings, but a big win on long ones.
3830 * It might even be a win on short strings if SvPVX(dstr)
3831 * has to be allocated and SvPVX(sstr) has to be freed.
3834 if (SvTEMP(sstr) && /* slated for free anyway? */
3835 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3836 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3837 SvLEN(sstr) && /* and really is a string */
3838 /* and won't be needed again, potentially */
3839 !(PL_op && PL_op->op_type == OP_AASSIGN))
3841 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3843 SvFLAGS(dstr) &= ~SVf_OOK;
3844 Safefree(SvPVX(dstr) - SvIVX(dstr));
3846 else if (SvLEN(dstr))
3847 Safefree(SvPVX(dstr));
3849 (void)SvPOK_only(dstr);
3850 SvPV_set(dstr, SvPVX(sstr));
3851 SvLEN_set(dstr, SvLEN(sstr));
3852 SvCUR_set(dstr, SvCUR(sstr));
3855 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3856 SvPV_set(sstr, Nullch);
3861 else { /* have to copy actual string */
3862 STRLEN len = SvCUR(sstr);
3864 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3865 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3866 SvCUR_set(dstr, len);
3867 *SvEND(dstr) = '\0';
3868 (void)SvPOK_only(dstr);
3870 if (sflags & SVf_UTF8)
3873 if (sflags & SVp_NOK) {
3875 if (sflags & SVf_NOK)
3876 SvFLAGS(dstr) |= SVf_NOK;
3877 SvNVX(dstr) = SvNVX(sstr);
3879 if (sflags & SVp_IOK) {
3880 (void)SvIOKp_on(dstr);
3881 if (sflags & SVf_IOK)
3882 SvFLAGS(dstr) |= SVf_IOK;
3883 if (sflags & SVf_IVisUV)
3885 SvIVX(dstr) = SvIVX(sstr);
3888 else if (sflags & SVp_IOK) {
3889 if (sflags & SVf_IOK)
3890 (void)SvIOK_only(dstr);
3892 (void)SvOK_off(dstr);
3893 (void)SvIOKp_on(dstr);
3895 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3896 if (sflags & SVf_IVisUV)
3898 SvIVX(dstr) = SvIVX(sstr);
3899 if (sflags & SVp_NOK) {
3900 if (sflags & SVf_NOK)
3901 (void)SvNOK_on(dstr);
3903 (void)SvNOKp_on(dstr);
3904 SvNVX(dstr) = SvNVX(sstr);
3907 else if (sflags & SVp_NOK) {
3908 if (sflags & SVf_NOK)
3909 (void)SvNOK_only(dstr);
3911 (void)SvOK_off(dstr);
3914 SvNVX(dstr) = SvNVX(sstr);
3917 if (dtype == SVt_PVGV) {
3918 if (ckWARN(WARN_MISC))
3919 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3922 (void)SvOK_off(dstr);
3924 if (SvTAINTED(sstr))
3929 =for apidoc sv_setsv_mg
3931 Like C<sv_setsv>, but also handles 'set' magic.
3937 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3939 sv_setsv(dstr,sstr);
3944 =for apidoc sv_setpvn
3946 Copies a string into an SV. The C<len> parameter indicates the number of
3947 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3953 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3955 register char *dptr;
3957 SV_CHECK_THINKFIRST(sv);
3963 /* len is STRLEN which is unsigned, need to copy to signed */
3966 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3968 (void)SvUPGRADE(sv, SVt_PV);
3970 SvGROW(sv, len + 1);
3972 Move(ptr,dptr,len,char);
3975 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3980 =for apidoc sv_setpvn_mg
3982 Like C<sv_setpvn>, but also handles 'set' magic.
3988 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3990 sv_setpvn(sv,ptr,len);
3995 =for apidoc sv_setpv
3997 Copies a string into an SV. The string must be null-terminated. Does not
3998 handle 'set' magic. See C<sv_setpv_mg>.
4004 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4006 register STRLEN len;
4008 SV_CHECK_THINKFIRST(sv);
4014 (void)SvUPGRADE(sv, SVt_PV);
4016 SvGROW(sv, len + 1);
4017 Move(ptr,SvPVX(sv),len+1,char);
4019 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4024 =for apidoc sv_setpv_mg
4026 Like C<sv_setpv>, but also handles 'set' magic.
4032 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4039 =for apidoc sv_usepvn
4041 Tells an SV to use C<ptr> to find its string value. Normally the string is
4042 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4043 The C<ptr> should point to memory that was allocated by C<malloc>. The
4044 string length, C<len>, must be supplied. This function will realloc the
4045 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4046 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4047 See C<sv_usepvn_mg>.
4053 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4055 SV_CHECK_THINKFIRST(sv);
4056 (void)SvUPGRADE(sv, SVt_PV);
4061 (void)SvOOK_off(sv);
4062 if (SvPVX(sv) && SvLEN(sv))
4063 Safefree(SvPVX(sv));
4064 Renew(ptr, len+1, char);
4067 SvLEN_set(sv, len+1);
4069 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4074 =for apidoc sv_usepvn_mg
4076 Like C<sv_usepvn>, but also handles 'set' magic.
4082 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4084 sv_usepvn(sv,ptr,len);
4089 =for apidoc sv_force_normal_flags
4091 Undo various types of fakery on an SV: if the PV is a shared string, make
4092 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4093 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4094 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4100 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4102 if (SvREADONLY(sv)) {
4104 char *pvx = SvPVX(sv);
4105 STRLEN len = SvCUR(sv);
4106 U32 hash = SvUVX(sv);
4107 SvGROW(sv, len + 1);
4108 Move(pvx,SvPVX(sv),len,char);
4112 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4114 else if (PL_curcop != &PL_compiling)
4115 Perl_croak(aTHX_ PL_no_modify);
4118 sv_unref_flags(sv, flags);
4119 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4124 =for apidoc sv_force_normal
4126 Undo various types of fakery on an SV: if the PV is a shared string, make
4127 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4128 an xpvmg. See also C<sv_force_normal_flags>.
4134 Perl_sv_force_normal(pTHX_ register SV *sv)
4136 sv_force_normal_flags(sv, 0);
4142 Efficient removal of characters from the beginning of the string buffer.
4143 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4144 the string buffer. The C<ptr> becomes the first character of the adjusted
4145 string. Uses the "OOK hack".
4151 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4153 register STRLEN delta;
4155 if (!ptr || !SvPOKp(sv))
4157 SV_CHECK_THINKFIRST(sv);
4158 if (SvTYPE(sv) < SVt_PVIV)
4159 sv_upgrade(sv,SVt_PVIV);
4162 if (!SvLEN(sv)) { /* make copy of shared string */
4163 char *pvx = SvPVX(sv);
4164 STRLEN len = SvCUR(sv);
4165 SvGROW(sv, len + 1);
4166 Move(pvx,SvPVX(sv),len,char);
4170 SvFLAGS(sv) |= SVf_OOK;
4172 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4173 delta = ptr - SvPVX(sv);
4181 =for apidoc sv_catpvn
4183 Concatenates the string onto the end of the string which is in the SV. The
4184 C<len> indicates number of bytes to copy. If the SV has the UTF8
4185 status set, then the bytes appended should be valid UTF8.
4186 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4191 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4192 for binary compatibility only
4195 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4197 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4201 =for apidoc sv_catpvn_flags
4203 Concatenates the string onto the end of the string which is in the SV. The
4204 C<len> indicates number of bytes to copy. If the SV has the UTF8
4205 status set, then the bytes appended should be valid UTF8.
4206 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4207 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4208 in terms of this function.
4214 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4219 dstr = SvPV_force_flags(dsv, dlen, flags);
4220 SvGROW(dsv, dlen + slen + 1);
4223 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4226 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4231 =for apidoc sv_catpvn_mg
4233 Like C<sv_catpvn>, but also handles 'set' magic.
4239 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4241 sv_catpvn(sv,ptr,len);
4246 =for apidoc sv_catsv
4248 Concatenates the string from SV C<ssv> onto the end of the string in
4249 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4250 not 'set' magic. See C<sv_catsv_mg>.
4254 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4255 for binary compatibility only
4258 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4260 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4264 =for apidoc sv_catsv_flags
4266 Concatenates the string from SV C<ssv> onto the end of the string in
4267 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4268 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4269 and C<sv_catsv_nomg> are implemented in terms of this function.
4274 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4280 if ((spv = SvPV(ssv, slen))) {
4281 bool sutf8 = DO_UTF8(ssv);
4284 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4286 dutf8 = DO_UTF8(dsv);
4288 if (dutf8 != sutf8) {
4290 /* Not modifying source SV, so taking a temporary copy. */
4291 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4293 sv_utf8_upgrade(csv);
4294 spv = SvPV(csv, slen);
4297 sv_utf8_upgrade_nomg(dsv);
4299 sv_catpvn_nomg(dsv, spv, slen);
4304 =for apidoc sv_catsv_mg
4306 Like C<sv_catsv>, but also handles 'set' magic.
4312 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4319 =for apidoc sv_catpv
4321 Concatenates the string onto the end of the string which is in the SV.
4322 If the SV has the UTF8 status set, then the bytes appended should be
4323 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4328 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4330 register STRLEN len;
4336 junk = SvPV_force(sv, tlen);
4338 SvGROW(sv, tlen + len + 1);
4341 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4343 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4348 =for apidoc sv_catpv_mg
4350 Like C<sv_catpv>, but also handles 'set' magic.
4356 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4365 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4366 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4373 Perl_newSV(pTHX_ STRLEN len)
4379 sv_upgrade(sv, SVt_PV);
4380 SvGROW(sv, len + 1);
4386 =for apidoc sv_magic
4388 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4389 then adds a new magic item of type C<how> to the head of the magic list.
4391 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4397 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4401 if (SvREADONLY(sv)) {
4402 if (PL_curcop != &PL_compiling
4403 && how != PERL_MAGIC_regex_global
4404 && how != PERL_MAGIC_bm
4405 && how != PERL_MAGIC_fm
4406 && how != PERL_MAGIC_sv
4409 Perl_croak(aTHX_ PL_no_modify);
4412 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4413 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4414 if (how == PERL_MAGIC_taint)
4420 (void)SvUPGRADE(sv, SVt_PVMG);
4422 Newz(702,mg, 1, MAGIC);
4423 mg->mg_moremagic = SvMAGIC(sv);
4426 /* Some magic contains a reference loop, where the sv and object refer to
4427 each other. To avoid a reference loop that would prevent such objects
4428 being freed, we look for such loops and if we find one we avoid
4429 incrementing the object refcount. */
4430 if (!obj || obj == sv ||
4431 how == PERL_MAGIC_arylen ||
4432 how == PERL_MAGIC_qr ||
4433 (SvTYPE(obj) == SVt_PVGV &&
4434 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4435 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4436 GvFORM(obj) == (CV*)sv)))
4441 mg->mg_obj = SvREFCNT_inc(obj);
4442 mg->mg_flags |= MGf_REFCOUNTED;
4445 mg->mg_len = namlen;
4448 mg->mg_ptr = savepvn(name, namlen);
4449 else if (namlen == HEf_SVKEY)
4450 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4455 mg->mg_virtual = &PL_vtbl_sv;
4457 case PERL_MAGIC_overload:
4458 mg->mg_virtual = &PL_vtbl_amagic;
4460 case PERL_MAGIC_overload_elem:
4461 mg->mg_virtual = &PL_vtbl_amagicelem;
4463 case PERL_MAGIC_overload_table:
4464 mg->mg_virtual = &PL_vtbl_ovrld;
4467 mg->mg_virtual = &PL_vtbl_bm;
4469 case PERL_MAGIC_regdata:
4470 mg->mg_virtual = &PL_vtbl_regdata;
4472 case PERL_MAGIC_regdatum:
4473 mg->mg_virtual = &PL_vtbl_regdatum;
4475 case PERL_MAGIC_env:
4476 mg->mg_virtual = &PL_vtbl_env;
4479 mg->mg_virtual = &PL_vtbl_fm;
4481 case PERL_MAGIC_envelem:
4482 mg->mg_virtual = &PL_vtbl_envelem;
4484 case PERL_MAGIC_regex_global:
4485 mg->mg_virtual = &PL_vtbl_mglob;
4487 case PERL_MAGIC_isa:
4488 mg->mg_virtual = &PL_vtbl_isa;
4490 case PERL_MAGIC_isaelem:
4491 mg->mg_virtual = &PL_vtbl_isaelem;
4493 case PERL_MAGIC_nkeys:
4494 mg->mg_virtual = &PL_vtbl_nkeys;
4496 case PERL_MAGIC_dbfile:
4500 case PERL_MAGIC_dbline:
4501 mg->mg_virtual = &PL_vtbl_dbline;
4504 case PERL_MAGIC_mutex:
4505 mg->mg_virtual = &PL_vtbl_mutex;
4507 #endif /* USE_THREADS */
4508 #ifdef USE_LOCALE_COLLATE
4509 case PERL_MAGIC_collxfrm:
4510 mg->mg_virtual = &PL_vtbl_collxfrm;
4512 #endif /* USE_LOCALE_COLLATE */
4513 case PERL_MAGIC_tied:
4514 mg->mg_virtual = &PL_vtbl_pack;
4516 case PERL_MAGIC_tiedelem:
4517 case PERL_MAGIC_tiedscalar:
4518 mg->mg_virtual = &PL_vtbl_packelem;
4521 mg->mg_virtual = &PL_vtbl_regexp;
4523 case PERL_MAGIC_sig:
4524 mg->mg_virtual = &PL_vtbl_sig;
4526 case PERL_MAGIC_sigelem:
4527 mg->mg_virtual = &PL_vtbl_sigelem;
4529 case PERL_MAGIC_taint:
4530 mg->mg_virtual = &PL_vtbl_taint;
4533 case PERL_MAGIC_uvar:
4534 mg->mg_virtual = &PL_vtbl_uvar;
4536 case PERL_MAGIC_vec:
4537 mg->mg_virtual = &PL_vtbl_vec;
4539 case PERL_MAGIC_substr:
4540 mg->mg_virtual = &PL_vtbl_substr;
4542 case PERL_MAGIC_defelem:
4543 mg->mg_virtual = &PL_vtbl_defelem;
4545 case PERL_MAGIC_glob:
4546 mg->mg_virtual = &PL_vtbl_glob;
4548 case PERL_MAGIC_arylen:
4549 mg->mg_virtual = &PL_vtbl_arylen;
4551 case PERL_MAGIC_pos:
4552 mg->mg_virtual = &PL_vtbl_pos;
4554 case PERL_MAGIC_backref:
4555 mg->mg_virtual = &PL_vtbl_backref;
4557 case PERL_MAGIC_ext:
4558 /* Reserved for use by extensions not perl internals. */
4559 /* Useful for attaching extension internal data to perl vars. */
4560 /* Note that multiple extensions may clash if magical scalars */
4561 /* etc holding private data from one are passed to another. */
4565 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4569 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4573 =for apidoc sv_unmagic
4575 Removes all magic of type C<type> from an SV.
4581 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4585 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4588 for (mg = *mgp; mg; mg = *mgp) {
4589 if (mg->mg_type == type) {
4590 MGVTBL* vtbl = mg->mg_virtual;
4591 *mgp = mg->mg_moremagic;
4592 if (vtbl && vtbl->svt_free)
4593 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4594 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4595 if (mg->mg_len >= 0)
4596 Safefree(mg->mg_ptr);
4597 else if (mg->mg_len == HEf_SVKEY)
4598 SvREFCNT_dec((SV*)mg->mg_ptr);
4600 if (mg->mg_flags & MGf_REFCOUNTED)
4601 SvREFCNT_dec(mg->mg_obj);
4605 mgp = &mg->mg_moremagic;
4609 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4616 =for apidoc sv_rvweaken
4618 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4619 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4620 push a back-reference to this RV onto the array of backreferences
4621 associated with that magic.
4627 Perl_sv_rvweaken(pTHX_ SV *sv)
4630 if (!SvOK(sv)) /* let undefs pass */
4633 Perl_croak(aTHX_ "Can't weaken a nonreference");
4634 else if (SvWEAKREF(sv)) {
4635 if (ckWARN(WARN_MISC))
4636 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4640 sv_add_backref(tsv, sv);
4646 /* Give tsv backref magic if it hasn't already got it, then push a
4647 * back-reference to sv onto the array associated with the backref magic.
4651 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4655 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4656 av = (AV*)mg->mg_obj;
4659 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4660 SvREFCNT_dec(av); /* for sv_magic */
4665 /* delete a back-reference to ourselves from the backref magic associated
4666 * with the SV we point to.
4670 S_sv_del_backref(pTHX_ SV *sv)
4677 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4678 Perl_croak(aTHX_ "panic: del_backref");
4679 av = (AV *)mg->mg_obj;
4684 svp[i] = &PL_sv_undef; /* XXX */
4691 =for apidoc sv_insert
4693 Inserts a string at the specified offset/length within the SV. Similar to
4694 the Perl substr() function.
4700 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4704 register char *midend;
4705 register char *bigend;
4711 Perl_croak(aTHX_ "Can't modify non-existent substring");
4712 SvPV_force(bigstr, curlen);
4713 (void)SvPOK_only_UTF8(bigstr);
4714 if (offset + len > curlen) {
4715 SvGROW(bigstr, offset+len+1);
4716 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4717 SvCUR_set(bigstr, offset+len);
4721 i = littlelen - len;
4722 if (i > 0) { /* string might grow */
4723 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4724 mid = big + offset + len;
4725 midend = bigend = big + SvCUR(bigstr);
4728 while (midend > mid) /* shove everything down */
4729 *--bigend = *--midend;
4730 Move(little,big+offset,littlelen,char);
4736 Move(little,SvPVX(bigstr)+offset,len,char);
4741 big = SvPVX(bigstr);
4744 bigend = big + SvCUR(bigstr);
4746 if (midend > bigend)
4747 Perl_croak(aTHX_ "panic: sv_insert");
4749 if (mid - big > bigend - midend) { /* faster to shorten from end */
4751 Move(little, mid, littlelen,char);
4754 i = bigend - midend;
4756 Move(midend, mid, i,char);
4760 SvCUR_set(bigstr, mid - big);
4763 else if ((i = mid - big)) { /* faster from front */
4764 midend -= littlelen;
4766 sv_chop(bigstr,midend-i);
4771 Move(little, mid, littlelen,char);
4773 else if (littlelen) {
4774 midend -= littlelen;
4775 sv_chop(bigstr,midend);
4776 Move(little,midend,littlelen,char);
4779 sv_chop(bigstr,midend);
4785 =for apidoc sv_replace
4787 Make the first argument a copy of the second, then delete the original.
4788 The target SV physically takes over ownership of the body of the source SV
4789 and inherits its flags; however, the target keeps any magic it owns,
4790 and any magic in the source is discarded.
4791 Note that this is a rather specialist SV copying operation; most of the
4792 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4798 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4800 U32 refcnt = SvREFCNT(sv);
4801 SV_CHECK_THINKFIRST(sv);
4802 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4803 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4804 if (SvMAGICAL(sv)) {
4808 sv_upgrade(nsv, SVt_PVMG);
4809 SvMAGIC(nsv) = SvMAGIC(sv);
4810 SvFLAGS(nsv) |= SvMAGICAL(sv);
4816 assert(!SvREFCNT(sv));
4817 StructCopy(nsv,sv,SV);
4818 SvREFCNT(sv) = refcnt;
4819 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4824 =for apidoc sv_clear
4826 Clear an SV: call any destructors, free up any memory used by the body,
4827 and free the body itself. The SV's head is I<not> freed, although
4828 its type is set to all 1's so that it won't inadvertently be assumed
4829 to be live during global destruction etc.
4830 This function should only be called when REFCNT is zero. Most of the time
4831 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4838 Perl_sv_clear(pTHX_ register SV *sv)
4842 assert(SvREFCNT(sv) == 0);
4845 if (PL_defstash) { /* Still have a symbol table? */
4850 Zero(&tmpref, 1, SV);
4851 sv_upgrade(&tmpref, SVt_RV);
4853 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4854 SvREFCNT(&tmpref) = 1;
4857 stash = SvSTASH(sv);
4858 destructor = StashHANDLER(stash,DESTROY);
4861 PUSHSTACKi(PERLSI_DESTROY);
4862 SvRV(&tmpref) = SvREFCNT_inc(sv);
4867 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4873 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4875 del_XRV(SvANY(&tmpref));
4878 if (PL_in_clean_objs)
4879 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4881 /* DESTROY gave object new lease on life */
4887 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4888 SvOBJECT_off(sv); /* Curse the object. */
4889 if (SvTYPE(sv) != SVt_PVIO)
4890 --PL_sv_objcount; /* XXX Might want something more general */
4893 if (SvTYPE(sv) >= SVt_PVMG) {
4896 if (SvFLAGS(sv) & SVpad_TYPED)
4897 SvREFCNT_dec(SvSTASH(sv));
4900 switch (SvTYPE(sv)) {
4903 IoIFP(sv) != PerlIO_stdin() &&
4904 IoIFP(sv) != PerlIO_stdout() &&
4905 IoIFP(sv) != PerlIO_stderr())
4907 io_close((IO*)sv, FALSE);
4909 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4910 PerlDir_close(IoDIRP(sv));
4911 IoDIRP(sv) = (DIR*)NULL;
4912 Safefree(IoTOP_NAME(sv));
4913 Safefree(IoFMT_NAME(sv));
4914 Safefree(IoBOTTOM_NAME(sv));
4929 SvREFCNT_dec(LvTARG(sv));
4933 Safefree(GvNAME(sv));
4934 /* cannot decrease stash refcount yet, as we might recursively delete
4935 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4936 of stash until current sv is completely gone.
4937 -- JohnPC, 27 Mar 1998 */
4938 stash = GvSTASH(sv);
4944 (void)SvOOK_off(sv);
4952 SvREFCNT_dec(SvRV(sv));
4954 else if (SvPVX(sv) && SvLEN(sv))
4955 Safefree(SvPVX(sv));
4956 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4957 unsharepvn(SvPVX(sv),
4958 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
4971 switch (SvTYPE(sv)) {
4987 del_XPVIV(SvANY(sv));
4990 del_XPVNV(SvANY(sv));
4993 del_XPVMG(SvANY(sv));
4996 del_XPVLV(SvANY(sv));
4999 del_XPVAV(SvANY(sv));
5002 del_XPVHV(SvANY(sv));
5005 del_XPVCV(SvANY(sv));
5008 del_XPVGV(SvANY(sv));
5009 /* code duplication for increased performance. */
5010 SvFLAGS(sv) &= SVf_BREAK;
5011 SvFLAGS(sv) |= SVTYPEMASK;
5012 /* decrease refcount of the stash that owns this GV, if any */
5014 SvREFCNT_dec(stash);
5015 return; /* not break, SvFLAGS reset already happened */
5017 del_XPVBM(SvANY(sv));
5020 del_XPVFM(SvANY(sv));
5023 del_XPVIO(SvANY(sv));
5026 SvFLAGS(sv) &= SVf_BREAK;
5027 SvFLAGS(sv) |= SVTYPEMASK;
5031 =for apidoc sv_newref
5033 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5040 Perl_sv_newref(pTHX_ SV *sv)
5043 ATOMIC_INC(SvREFCNT(sv));
5050 Decrement an SV's reference count, and if it drops to zero, call
5051 C<sv_clear> to invoke destructors and free up any memory used by
5052 the body; finally, deallocate the SV's head itself.
5053 Normally called via a wrapper macro C<SvREFCNT_dec>.
5059 Perl_sv_free(pTHX_ SV *sv)
5061 int refcount_is_zero;
5065 if (SvREFCNT(sv) == 0) {
5066 if (SvFLAGS(sv) & SVf_BREAK)
5067 /* this SV's refcnt has been artificially decremented to
5068 * trigger cleanup */
5070 if (PL_in_clean_all) /* All is fair */
5072 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5073 /* make sure SvREFCNT(sv)==0 happens very seldom */
5074 SvREFCNT(sv) = (~(U32)0)/2;
5077 if (ckWARN_d(WARN_INTERNAL))
5078 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5081 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5082 if (!refcount_is_zero)
5086 if (ckWARN_d(WARN_DEBUGGING))
5087 Perl_warner(aTHX_ WARN_DEBUGGING,
5088 "Attempt to free temp prematurely: SV 0x%"UVxf,
5093 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5094 /* make sure SvREFCNT(sv)==0 happens very seldom */
5095 SvREFCNT(sv) = (~(U32)0)/2;
5106 Returns the length of the string in the SV. Handles magic and type
5107 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5113 Perl_sv_len(pTHX_ register SV *sv)
5121 len = mg_length(sv);
5123 (void)SvPV(sv, len);
5128 =for apidoc sv_len_utf8
5130 Returns the number of characters in the string in an SV, counting wide
5131 UTF8 bytes as a single character. Handles magic and type coercion.
5137 Perl_sv_len_utf8(pTHX_ register SV *sv)
5143 return mg_length(sv);
5147 U8 *s = (U8*)SvPV(sv, len);
5149 return Perl_utf8_length(aTHX_ s, s + len);
5154 =for apidoc sv_pos_u2b
5156 Converts the value pointed to by offsetp from a count of UTF8 chars from
5157 the start of the string, to a count of the equivalent number of bytes; if
5158 lenp is non-zero, it does the same to lenp, but this time starting from
5159 the offset, rather than from the start of the string. Handles magic and
5166 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5171 I32 uoffset = *offsetp;
5177 start = s = (U8*)SvPV(sv, len);
5179 while (s < send && uoffset--)
5183 *offsetp = s - start;
5187 while (s < send && ulen--)
5197 =for apidoc sv_pos_b2u
5199 Converts the value pointed to by offsetp from a count of bytes from the
5200 start of the string, to a count of the equivalent number of UTF8 chars.
5201 Handles magic and type coercion.
5207 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5216 s = (U8*)SvPV(sv, len);
5218 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5219 send = s + *offsetp;
5223 /* Call utf8n_to_uvchr() to validate the sequence */
5224 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5239 Returns a boolean indicating whether the strings in the two SVs are
5240 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5241 coerce its args to strings if necessary.
5247 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5261 pv1 = SvPV(sv1, cur1);
5268 pv2 = SvPV(sv2, cur2);
5270 /* do not utf8ize the comparands as a side-effect */
5271 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5272 bool is_utf8 = TRUE;
5273 /* UTF-8ness differs */
5276 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5277 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5282 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5283 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5288 /* Downgrade not possible - cannot be eq */
5294 eq = memEQ(pv1, pv2, cur1);
5305 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5306 string in C<sv1> is less than, equal to, or greater than the string in
5307 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5308 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5314 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5319 bool pv1tmp = FALSE;
5320 bool pv2tmp = FALSE;
5327 pv1 = SvPV(sv1, cur1);
5334 pv2 = SvPV(sv2, cur2);
5336 /* do not utf8ize the comparands as a side-effect */
5337 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5339 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5343 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5349 cmp = cur2 ? -1 : 0;
5353 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5356 cmp = retval < 0 ? -1 : 1;
5357 } else if (cur1 == cur2) {
5360 cmp = cur1 < cur2 ? -1 : 1;
5373 =for apidoc sv_cmp_locale
5375 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5376 'use bytes' aware, handles get magic, and will coerce its args to strings
5377 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5383 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5385 #ifdef USE_LOCALE_COLLATE
5391 if (PL_collation_standard)
5395 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5397 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5399 if (!pv1 || !len1) {
5410 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5413 return retval < 0 ? -1 : 1;
5416 * When the result of collation is equality, that doesn't mean
5417 * that there are no differences -- some locales exclude some
5418 * characters from consideration. So to avoid false equalities,
5419 * we use the raw string as a tiebreaker.
5425 #endif /* USE_LOCALE_COLLATE */
5427 return sv_cmp(sv1, sv2);
5431 #ifdef USE_LOCALE_COLLATE
5434 =for apidoc sv_collxfrm
5436 Add Collate Transform magic to an SV if it doesn't already have it.
5438 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5439 scalar data of the variable, but transformed to such a format that a normal
5440 memory comparison can be used to compare the data according to the locale
5447 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5451 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5452 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5457 Safefree(mg->mg_ptr);
5459 if ((xf = mem_collxfrm(s, len, &xlen))) {
5460 if (SvREADONLY(sv)) {
5463 return xf + sizeof(PL_collation_ix);
5466 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5467 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5480 if (mg && mg->mg_ptr) {
5482 return mg->mg_ptr + sizeof(PL_collation_ix);
5490 #endif /* USE_LOCALE_COLLATE */
5495 Get a line from the filehandle and store it into the SV, optionally
5496 appending to the currently-stored string.
5502 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5506 register STDCHAR rslast;
5507 register STDCHAR *bp;
5511 SV_CHECK_THINKFIRST(sv);
5512 (void)SvUPGRADE(sv, SVt_PV);
5516 if (RsSNARF(PL_rs)) {
5520 else if (RsRECORD(PL_rs)) {
5521 I32 recsize, bytesread;
5524 /* Grab the size of the record we're getting */
5525 recsize = SvIV(SvRV(PL_rs));
5526 (void)SvPOK_only(sv); /* Validate pointer */
5527 buffer = SvGROW(sv, recsize + 1);
5530 /* VMS wants read instead of fread, because fread doesn't respect */
5531 /* RMS record boundaries. This is not necessarily a good thing to be */
5532 /* doing, but we've got no other real choice */
5533 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5535 bytesread = PerlIO_read(fp, buffer, recsize);
5537 SvCUR_set(sv, bytesread);
5538 buffer[bytesread] = '\0';
5539 if (PerlIO_isutf8(fp))
5543 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5545 else if (RsPARA(PL_rs)) {
5550 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5551 if (PerlIO_isutf8(fp)) {
5552 rsptr = SvPVutf8(PL_rs, rslen);
5555 if (SvUTF8(PL_rs)) {
5556 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5557 Perl_croak(aTHX_ "Wide character in $/");
5560 rsptr = SvPV(PL_rs, rslen);
5564 rslast = rslen ? rsptr[rslen - 1] : '\0';
5566 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5567 do { /* to make sure file boundaries work right */
5570 i = PerlIO_getc(fp);
5574 PerlIO_ungetc(fp,i);
5580 /* See if we know enough about I/O mechanism to cheat it ! */
5582 /* This used to be #ifdef test - it is made run-time test for ease
5583 of abstracting out stdio interface. One call should be cheap
5584 enough here - and may even be a macro allowing compile
5588 if (PerlIO_fast_gets(fp)) {
5591 * We're going to steal some values from the stdio struct
5592 * and put EVERYTHING in the innermost loop into registers.
5594 register STDCHAR *ptr;
5598 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5599 /* An ungetc()d char is handled separately from the regular
5600 * buffer, so we getc() it back out and stuff it in the buffer.
5602 i = PerlIO_getc(fp);
5603 if (i == EOF) return 0;
5604 *(--((*fp)->_ptr)) = (unsigned char) i;
5608 /* Here is some breathtakingly efficient cheating */
5610 cnt = PerlIO_get_cnt(fp); /* get count into register */
5611 (void)SvPOK_only(sv); /* validate pointer */
5612 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5613 if (cnt > 80 && SvLEN(sv) > append) {
5614 shortbuffered = cnt - SvLEN(sv) + append + 1;
5615 cnt -= shortbuffered;
5619 /* remember that cnt can be negative */
5620 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5625 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5626 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5627 DEBUG_P(PerlIO_printf(Perl_debug_log,
5628 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5629 DEBUG_P(PerlIO_printf(Perl_debug_log,
5630 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5631 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5632 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5637 while (cnt > 0) { /* this | eat */
5639 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5640 goto thats_all_folks; /* screams | sed :-) */
5644 Copy(ptr, bp, cnt, char); /* this | eat */
5645 bp += cnt; /* screams | dust */
5646 ptr += cnt; /* louder | sed :-) */
5651 if (shortbuffered) { /* oh well, must extend */
5652 cnt = shortbuffered;
5654 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5656 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5657 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5661 DEBUG_P(PerlIO_printf(Perl_debug_log,
5662 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5663 PTR2UV(ptr),(long)cnt));
5664 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5665 DEBUG_P(PerlIO_printf(Perl_debug_log,
5666 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5667 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5668 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5669 /* This used to call 'filbuf' in stdio form, but as that behaves like
5670 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5671 another abstraction. */
5672 i = PerlIO_getc(fp); /* get more characters */
5673 DEBUG_P(PerlIO_printf(Perl_debug_log,
5674 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5675 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5676 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5677 cnt = PerlIO_get_cnt(fp);
5678 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5679 DEBUG_P(PerlIO_printf(Perl_debug_log,
5680 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5682 if (i == EOF) /* all done for ever? */
5683 goto thats_really_all_folks;
5685 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5687 SvGROW(sv, bpx + cnt + 2);
5688 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5690 *bp++ = i; /* store character from PerlIO_getc */
5692 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5693 goto thats_all_folks;
5697 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5698 memNE((char*)bp - rslen, rsptr, rslen))
5699 goto screamer; /* go back to the fray */
5700 thats_really_all_folks:
5702 cnt += shortbuffered;
5703 DEBUG_P(PerlIO_printf(Perl_debug_log,
5704 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5705 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5706 DEBUG_P(PerlIO_printf(Perl_debug_log,
5707 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5708 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5709 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5711 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5712 DEBUG_P(PerlIO_printf(Perl_debug_log,
5713 "Screamer: done, len=%ld, string=|%.*s|\n",
5714 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5719 /*The big, slow, and stupid way */
5722 /* Need to work around EPOC SDK features */
5723 /* On WINS: MS VC5 generates calls to _chkstk, */
5724 /* if a `large' stack frame is allocated */
5725 /* gcc on MARM does not generate calls like these */
5731 register STDCHAR *bpe = buf + sizeof(buf);
5733 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5734 ; /* keep reading */
5738 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5739 /* Accomodate broken VAXC compiler, which applies U8 cast to
5740 * both args of ?: operator, causing EOF to change into 255
5742 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5746 sv_catpvn(sv, (char *) buf, cnt);
5748 sv_setpvn(sv, (char *) buf, cnt);
5750 if (i != EOF && /* joy */
5752 SvCUR(sv) < rslen ||
5753 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5757 * If we're reading from a TTY and we get a short read,
5758 * indicating that the user hit his EOF character, we need
5759 * to notice it now, because if we try to read from the TTY
5760 * again, the EOF condition will disappear.
5762 * The comparison of cnt to sizeof(buf) is an optimization
5763 * that prevents unnecessary calls to feof().
5767 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5772 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5773 while (i != EOF) { /* to make sure file boundaries work right */
5774 i = PerlIO_getc(fp);
5776 PerlIO_ungetc(fp,i);
5782 if (PerlIO_isutf8(fp))
5787 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5793 Auto-increment of the value in the SV, doing string to numeric conversion
5794 if necessary. Handles 'get' magic.
5800 Perl_sv_inc(pTHX_ register SV *sv)
5809 if (SvTHINKFIRST(sv)) {
5810 if (SvREADONLY(sv)) {
5811 if (PL_curcop != &PL_compiling)
5812 Perl_croak(aTHX_ PL_no_modify);
5816 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5818 i = PTR2IV(SvRV(sv));
5823 flags = SvFLAGS(sv);
5824 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5825 /* It's (privately or publicly) a float, but not tested as an
5826 integer, so test it to see. */
5828 flags = SvFLAGS(sv);
5830 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5831 /* It's publicly an integer, or privately an integer-not-float */
5834 if (SvUVX(sv) == UV_MAX)
5835 sv_setnv(sv, (NV)UV_MAX + 1.0);
5837 (void)SvIOK_only_UV(sv);
5840 if (SvIVX(sv) == IV_MAX)
5841 sv_setuv(sv, (UV)IV_MAX + 1);
5843 (void)SvIOK_only(sv);
5849 if (flags & SVp_NOK) {
5850 (void)SvNOK_only(sv);
5855 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5856 if ((flags & SVTYPEMASK) < SVt_PVIV)
5857 sv_upgrade(sv, SVt_IV);
5858 (void)SvIOK_only(sv);
5863 while (isALPHA(*d)) d++;
5864 while (isDIGIT(*d)) d++;
5866 #ifdef PERL_PRESERVE_IVUV
5867 /* Got to punt this an an integer if needs be, but we don't issue
5868 warnings. Probably ought to make the sv_iv_please() that does
5869 the conversion if possible, and silently. */
5870 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5871 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5872 /* Need to try really hard to see if it's an integer.
5873 9.22337203685478e+18 is an integer.
5874 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5875 so $a="9.22337203685478e+18"; $a+0; $a++
5876 needs to be the same as $a="9.22337203685478e+18"; $a++
5883 /* sv_2iv *should* have made this an NV */
5884 if (flags & SVp_NOK) {
5885 (void)SvNOK_only(sv);
5889 /* I don't think we can get here. Maybe I should assert this
5890 And if we do get here I suspect that sv_setnv will croak. NWC
5892 #if defined(USE_LONG_DOUBLE)
5893 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",
5894 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5896 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5897 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5900 #endif /* PERL_PRESERVE_IVUV */
5901 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5905 while (d >= SvPVX(sv)) {
5913 /* MKS: The original code here died if letters weren't consecutive.
5914 * at least it didn't have to worry about non-C locales. The
5915 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5916 * arranged in order (although not consecutively) and that only
5917 * [A-Za-z] are accepted by isALPHA in the C locale.
5919 if (*d != 'z' && *d != 'Z') {
5920 do { ++*d; } while (!isALPHA(*d));
5923 *(d--) -= 'z' - 'a';
5928 *(d--) -= 'z' - 'a' + 1;
5932 /* oh,oh, the number grew */
5933 SvGROW(sv, SvCUR(sv) + 2);
5935 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5946 Auto-decrement of the value in the SV, doing string to numeric conversion
5947 if necessary. Handles 'get' magic.
5953 Perl_sv_dec(pTHX_ register SV *sv)
5961 if (SvTHINKFIRST(sv)) {
5962 if (SvREADONLY(sv)) {
5963 if (PL_curcop != &PL_compiling)
5964 Perl_croak(aTHX_ PL_no_modify);
5968 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5970 i = PTR2IV(SvRV(sv));
5975 /* Unlike sv_inc we don't have to worry about string-never-numbers
5976 and keeping them magic. But we mustn't warn on punting */
5977 flags = SvFLAGS(sv);
5978 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5979 /* It's publicly an integer, or privately an integer-not-float */
5982 if (SvUVX(sv) == 0) {
5983 (void)SvIOK_only(sv);
5987 (void)SvIOK_only_UV(sv);
5991 if (SvIVX(sv) == IV_MIN)
5992 sv_setnv(sv, (NV)IV_MIN - 1.0);
5994 (void)SvIOK_only(sv);
6000 if (flags & SVp_NOK) {
6002 (void)SvNOK_only(sv);
6005 if (!(flags & SVp_POK)) {
6006 if ((flags & SVTYPEMASK) < SVt_PVNV)
6007 sv_upgrade(sv, SVt_NV);
6009 (void)SvNOK_only(sv);
6012 #ifdef PERL_PRESERVE_IVUV
6014 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6015 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6016 /* Need to try really hard to see if it's an integer.
6017 9.22337203685478e+18 is an integer.
6018 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6019 so $a="9.22337203685478e+18"; $a+0; $a--
6020 needs to be the same as $a="9.22337203685478e+18"; $a--
6027 /* sv_2iv *should* have made this an NV */
6028 if (flags & SVp_NOK) {
6029 (void)SvNOK_only(sv);
6033 /* I don't think we can get here. Maybe I should assert this
6034 And if we do get here I suspect that sv_setnv will croak. NWC
6036 #if defined(USE_LONG_DOUBLE)
6037 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",
6038 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6040 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6041 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6045 #endif /* PERL_PRESERVE_IVUV */
6046 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6050 =for apidoc sv_mortalcopy
6052 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6053 The new SV is marked as mortal. It will be destroyed "soon", either by an
6054 explicit call to FREETMPS, or by an implicit call at places such as
6055 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6060 /* Make a string that will exist for the duration of the expression
6061 * evaluation. Actually, it may have to last longer than that, but
6062 * hopefully we won't free it until it has been assigned to a
6063 * permanent location. */
6066 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6071 sv_setsv(sv,oldstr);
6073 PL_tmps_stack[++PL_tmps_ix] = sv;
6079 =for apidoc sv_newmortal
6081 Creates a new null SV which is mortal. The reference count of the SV is
6082 set to 1. It will be destroyed "soon", either by an explicit call to
6083 FREETMPS, or by an implicit call at places such as statement boundaries.
6084 See also C<sv_mortalcopy> and C<sv_2mortal>.
6090 Perl_sv_newmortal(pTHX)
6095 SvFLAGS(sv) = SVs_TEMP;
6097 PL_tmps_stack[++PL_tmps_ix] = sv;
6102 =for apidoc sv_2mortal
6104 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6105 by an explicit call to FREETMPS, or by an implicit call at places such as
6106 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6112 Perl_sv_2mortal(pTHX_ register SV *sv)
6116 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6119 PL_tmps_stack[++PL_tmps_ix] = sv;
6127 Creates a new SV and copies a string into it. The reference count for the
6128 SV is set to 1. If C<len> is zero, Perl will compute the length using
6129 strlen(). For efficiency, consider using C<newSVpvn> instead.
6135 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6142 sv_setpvn(sv,s,len);
6147 =for apidoc newSVpvn
6149 Creates a new SV and copies a string into it. The reference count for the
6150 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6151 string. You are responsible for ensuring that the source string is at least
6158 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6163 sv_setpvn(sv,s,len);
6168 =for apidoc newSVpvn_share
6170 Creates a new SV with its SvPVX pointing to a shared string in the string
6171 table. If the string does not already exist in the table, it is created
6172 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6173 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6174 otherwise the hash is computed. The idea here is that as the string table
6175 is used for shared hash keys these strings will have SvPVX == HeKEY and
6176 hash lookup will avoid string compare.
6182 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6185 bool is_utf8 = FALSE;
6187 STRLEN tmplen = -len;
6189 /* See the note in hv.c:hv_fetch() --jhi */
6190 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6194 PERL_HASH(hash, src, len);
6196 sv_upgrade(sv, SVt_PVIV);
6197 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6210 #if defined(PERL_IMPLICIT_CONTEXT)
6212 /* pTHX_ magic can't cope with varargs, so this is a no-context
6213 * version of the main function, (which may itself be aliased to us).
6214 * Don't access this version directly.
6218 Perl_newSVpvf_nocontext(const char* pat, ...)
6223 va_start(args, pat);
6224 sv = vnewSVpvf(pat, &args);
6231 =for apidoc newSVpvf
6233 Creates a new SV and initializes it with the string formatted like
6240 Perl_newSVpvf(pTHX_ const char* pat, ...)
6244 va_start(args, pat);
6245 sv = vnewSVpvf(pat, &args);
6250 /* backend for newSVpvf() and newSVpvf_nocontext() */
6253 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6257 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6264 Creates a new SV and copies a floating point value into it.
6265 The reference count for the SV is set to 1.
6271 Perl_newSVnv(pTHX_ NV n)
6283 Creates a new SV and copies an integer into it. The reference count for the
6290 Perl_newSViv(pTHX_ IV i)
6302 Creates a new SV and copies an unsigned integer into it.
6303 The reference count for the SV is set to 1.
6309 Perl_newSVuv(pTHX_ UV u)
6319 =for apidoc newRV_noinc
6321 Creates an RV wrapper for an SV. The reference count for the original
6322 SV is B<not> incremented.
6328 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6333 sv_upgrade(sv, SVt_RV);
6340 /* newRV_inc is the official function name to use now.
6341 * newRV_inc is in fact #defined to newRV in sv.h
6345 Perl_newRV(pTHX_ SV *tmpRef)
6347 return newRV_noinc(SvREFCNT_inc(tmpRef));
6353 Creates a new SV which is an exact duplicate of the original SV.
6360 Perl_newSVsv(pTHX_ register SV *old)
6366 if (SvTYPE(old) == SVTYPEMASK) {
6367 if (ckWARN_d(WARN_INTERNAL))
6368 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6383 =for apidoc sv_reset
6385 Underlying implementation for the C<reset> Perl function.
6386 Note that the perl-level function is vaguely deprecated.
6392 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6400 char todo[PERL_UCHAR_MAX+1];
6405 if (!*s) { /* reset ?? searches */
6406 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6407 pm->op_pmdynflags &= ~PMdf_USED;
6412 /* reset variables */
6414 if (!HvARRAY(stash))
6417 Zero(todo, 256, char);
6419 i = (unsigned char)*s;
6423 max = (unsigned char)*s++;
6424 for ( ; i <= max; i++) {
6427 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6428 for (entry = HvARRAY(stash)[i];
6430 entry = HeNEXT(entry))
6432 if (!todo[(U8)*HeKEY(entry)])
6434 gv = (GV*)HeVAL(entry);
6436 if (SvTHINKFIRST(sv)) {
6437 if (!SvREADONLY(sv) && SvROK(sv))
6442 if (SvTYPE(sv) >= SVt_PV) {
6444 if (SvPVX(sv) != Nullch)
6451 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6453 #ifdef USE_ENVIRON_ARRAY
6455 environ[0] = Nullch;
6466 Using various gambits, try to get an IO from an SV: the IO slot if its a
6467 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6468 named after the PV if we're a string.
6474 Perl_sv_2io(pTHX_ SV *sv)
6480 switch (SvTYPE(sv)) {
6488 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6492 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6494 return sv_2io(SvRV(sv));
6495 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6501 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6510 Using various gambits, try to get a CV from an SV; in addition, try if
6511 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6517 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6524 return *gvp = Nullgv, Nullcv;
6525 switch (SvTYPE(sv)) {
6544 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6545 tryAMAGICunDEREF(to_cv);
6548 if (SvTYPE(sv) == SVt_PVCV) {
6557 Perl_croak(aTHX_ "Not a subroutine reference");
6562 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6568 if (lref && !GvCVu(gv)) {
6571 tmpsv = NEWSV(704,0);
6572 gv_efullname3(tmpsv, gv, Nullch);
6573 /* XXX this is probably not what they think they're getting.
6574 * It has the same effect as "sub name;", i.e. just a forward
6576 newSUB(start_subparse(FALSE, 0),
6577 newSVOP(OP_CONST, 0, tmpsv),
6582 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6591 Returns true if the SV has a true value by Perl's rules.
6592 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6593 instead use an in-line version.
6599 Perl_sv_true(pTHX_ register SV *sv)
6605 if ((tXpv = (XPV*)SvANY(sv)) &&
6606 (tXpv->xpv_cur > 1 ||
6607 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6614 return SvIVX(sv) != 0;
6617 return SvNVX(sv) != 0.0;
6619 return sv_2bool(sv);
6627 A private implementation of the C<SvIVx> macro for compilers which can't
6628 cope with complex macro expressions. Always use the macro instead.
6634 Perl_sv_iv(pTHX_ register SV *sv)
6638 return (IV)SvUVX(sv);
6647 A private implementation of the C<SvUVx> macro for compilers which can't
6648 cope with complex macro expressions. Always use the macro instead.
6654 Perl_sv_uv(pTHX_ register SV *sv)
6659 return (UV)SvIVX(sv);
6667 A private implementation of the C<SvNVx> macro for compilers which can't
6668 cope with complex macro expressions. Always use the macro instead.
6674 Perl_sv_nv(pTHX_ register SV *sv)
6684 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6685 cope with complex macro expressions. Always use the macro instead.
6691 Perl_sv_pv(pTHX_ SV *sv)
6698 return sv_2pv(sv, &n_a);
6704 A private implementation of the C<SvPV> macro for compilers which can't
6705 cope with complex macro expressions. Always use the macro instead.
6711 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6717 return sv_2pv(sv, lp);
6721 =for apidoc sv_pvn_force
6723 Get a sensible string out of the SV somehow.
6724 A private implementation of the C<SvPV_force> macro for compilers which
6725 can't cope with complex macro expressions. Always use the macro instead.
6731 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6733 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6737 =for apidoc sv_pvn_force_flags
6739 Get a sensible string out of the SV somehow.
6740 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6741 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6742 implemented in terms of this function.
6743 You normally want to use the various wrapper macros instead: see
6744 C<SvPV_force> and C<SvPV_force_nomg>
6750 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6754 if (SvTHINKFIRST(sv) && !SvROK(sv))
6755 sv_force_normal(sv);
6761 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6762 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6763 PL_op_name[PL_op->op_type]);
6766 s = sv_2pv_flags(sv, lp, flags);
6767 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6772 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6773 SvGROW(sv, len + 1);
6774 Move(s,SvPVX(sv),len,char);
6779 SvPOK_on(sv); /* validate pointer */
6781 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6782 PTR2UV(sv),SvPVX(sv)));
6789 =for apidoc sv_pvbyte
6791 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6792 which can't cope with complex macro expressions. Always use the macro
6799 Perl_sv_pvbyte(pTHX_ SV *sv)
6801 sv_utf8_downgrade(sv,0);
6806 =for apidoc sv_pvbyten
6808 A private implementation of the C<SvPVbyte> macro for compilers
6809 which can't cope with complex macro expressions. Always use the macro
6816 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6818 sv_utf8_downgrade(sv,0);
6819 return sv_pvn(sv,lp);
6823 =for apidoc sv_pvbyten_force
6825 A private implementation of the C<SvPVbytex_force> macro for compilers
6826 which can't cope with complex macro expressions. Always use the macro
6833 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6835 sv_utf8_downgrade(sv,0);
6836 return sv_pvn_force(sv,lp);
6840 =for apidoc sv_pvutf8
6842 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6843 which can't cope with complex macro expressions. Always use the macro
6850 Perl_sv_pvutf8(pTHX_ SV *sv)
6852 sv_utf8_upgrade(sv);
6857 =for apidoc sv_pvutf8n
6859 A private implementation of the C<SvPVutf8> macro for compilers
6860 which can't cope with complex macro expressions. Always use the macro
6867 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6869 sv_utf8_upgrade(sv);
6870 return sv_pvn(sv,lp);
6874 =for apidoc sv_pvutf8n_force
6876 A private implementation of the C<SvPVutf8_force> macro for compilers
6877 which can't cope with complex macro expressions. Always use the macro
6884 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6886 sv_utf8_upgrade(sv);
6887 return sv_pvn_force(sv,lp);
6891 =for apidoc sv_reftype
6893 Returns a string describing what the SV is a reference to.
6899 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6901 if (ob && SvOBJECT(sv))
6902 return HvNAME(SvSTASH(sv));
6904 switch (SvTYPE(sv)) {
6918 case SVt_PVLV: return "LVALUE";
6919 case SVt_PVAV: return "ARRAY";
6920 case SVt_PVHV: return "HASH";
6921 case SVt_PVCV: return "CODE";
6922 case SVt_PVGV: return "GLOB";
6923 case SVt_PVFM: return "FORMAT";
6924 case SVt_PVIO: return "IO";
6925 default: return "UNKNOWN";
6931 =for apidoc sv_isobject
6933 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6934 object. If the SV is not an RV, or if the object is not blessed, then this
6941 Perl_sv_isobject(pTHX_ SV *sv)
6958 Returns a boolean indicating whether the SV is blessed into the specified
6959 class. This does not check for subtypes; use C<sv_derived_from> to verify
6960 an inheritance relationship.
6966 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6978 return strEQ(HvNAME(SvSTASH(sv)), name);
6984 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6985 it will be upgraded to one. If C<classname> is non-null then the new SV will
6986 be blessed in the specified package. The new SV is returned and its
6987 reference count is 1.
6993 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6999 SV_CHECK_THINKFIRST(rv);
7002 if (SvTYPE(rv) >= SVt_PVMG) {
7003 U32 refcnt = SvREFCNT(rv);
7007 SvREFCNT(rv) = refcnt;
7010 if (SvTYPE(rv) < SVt_RV)
7011 sv_upgrade(rv, SVt_RV);
7012 else if (SvTYPE(rv) > SVt_RV) {
7013 (void)SvOOK_off(rv);
7014 if (SvPVX(rv) && SvLEN(rv))
7015 Safefree(SvPVX(rv));
7025 HV* stash = gv_stashpv(classname, TRUE);
7026 (void)sv_bless(rv, stash);
7032 =for apidoc sv_setref_pv
7034 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7035 argument will be upgraded to an RV. That RV will be modified to point to
7036 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7037 into the SV. The C<classname> argument indicates the package for the
7038 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7039 will be returned and will have a reference count of 1.
7041 Do not use with other Perl types such as HV, AV, SV, CV, because those
7042 objects will become corrupted by the pointer copy process.
7044 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7050 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7053 sv_setsv(rv, &PL_sv_undef);
7057 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7062 =for apidoc sv_setref_iv
7064 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7065 argument will be upgraded to an RV. That RV will be modified to point to
7066 the new SV. The C<classname> argument indicates the package for the
7067 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7068 will be returned and will have a reference count of 1.
7074 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7076 sv_setiv(newSVrv(rv,classname), iv);
7081 =for apidoc sv_setref_uv
7083 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7084 argument will be upgraded to an RV. That RV will be modified to point to
7085 the new SV. The C<classname> argument indicates the package for the
7086 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7087 will be returned and will have a reference count of 1.
7093 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7095 sv_setuv(newSVrv(rv,classname), uv);
7100 =for apidoc sv_setref_nv
7102 Copies a double 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. The C<classname> argument indicates the package for the
7105 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7106 will be returned and will have a reference count of 1.
7112 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7114 sv_setnv(newSVrv(rv,classname), nv);
7119 =for apidoc sv_setref_pvn
7121 Copies a string into a new SV, optionally blessing the SV. The length of the
7122 string must be specified with C<n>. The C<rv> argument will be upgraded to
7123 an RV. That RV will be modified to point to the new SV. The C<classname>
7124 argument indicates the package for the blessing. Set C<classname> to
7125 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7126 a reference count of 1.
7128 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7134 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7136 sv_setpvn(newSVrv(rv,classname), pv, n);
7141 =for apidoc sv_bless
7143 Blesses an SV into a specified package. The SV must be an RV. The package
7144 must be designated by its stash (see C<gv_stashpv()>). The reference count
7145 of the SV is unaffected.
7151 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7155 Perl_croak(aTHX_ "Can't bless non-reference value");
7157 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7158 if (SvREADONLY(tmpRef))
7159 Perl_croak(aTHX_ PL_no_modify);
7160 if (SvOBJECT(tmpRef)) {
7161 if (SvTYPE(tmpRef) != SVt_PVIO)
7163 SvREFCNT_dec(SvSTASH(tmpRef));
7166 SvOBJECT_on(tmpRef);
7167 if (SvTYPE(tmpRef) != SVt_PVIO)
7169 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7170 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7180 /* Downgrades a PVGV to a PVMG.
7182 * XXX This function doesn't actually appear to be used anywhere
7187 S_sv_unglob(pTHX_ SV *sv)
7191 assert(SvTYPE(sv) == SVt_PVGV);
7196 SvREFCNT_dec(GvSTASH(sv));
7197 GvSTASH(sv) = Nullhv;
7199 sv_unmagic(sv, PERL_MAGIC_glob);
7200 Safefree(GvNAME(sv));
7203 /* need to keep SvANY(sv) in the right arena */
7204 xpvmg = new_XPVMG();
7205 StructCopy(SvANY(sv), xpvmg, XPVMG);
7206 del_XPVGV(SvANY(sv));
7209 SvFLAGS(sv) &= ~SVTYPEMASK;
7210 SvFLAGS(sv) |= SVt_PVMG;
7214 =for apidoc sv_unref_flags
7216 Unsets the RV status of the SV, and decrements the reference count of
7217 whatever was being referenced by the RV. This can almost be thought of
7218 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7219 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7220 (otherwise the decrementing is conditional on the reference count being
7221 different from one or the reference being a readonly SV).
7228 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7232 if (SvWEAKREF(sv)) {
7240 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7242 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7243 sv_2mortal(rv); /* Schedule for freeing later */
7247 =for apidoc sv_unref
7249 Unsets the RV status of the SV, and decrements the reference count of
7250 whatever was being referenced by the RV. This can almost be thought of
7251 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7252 being zero. See C<SvROK_off>.
7258 Perl_sv_unref(pTHX_ SV *sv)
7260 sv_unref_flags(sv, 0);
7264 =for apidoc sv_taint
7266 Taint an SV. Use C<SvTAINTED_on> instead.
7271 Perl_sv_taint(pTHX_ SV *sv)
7273 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7277 =for apidoc sv_untaint
7279 Untaint an SV. Use C<SvTAINTED_off> instead.
7284 Perl_sv_untaint(pTHX_ SV *sv)
7286 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7287 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7294 =for apidoc sv_tainted
7296 Test an SV for taintedness. Use C<SvTAINTED> instead.
7301 Perl_sv_tainted(pTHX_ SV *sv)
7303 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7304 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7305 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7312 =for apidoc sv_setpviv
7314 Copies an integer into the given SV, also updating its string value.
7315 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7321 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7323 char buf[TYPE_CHARS(UV)];
7325 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7327 sv_setpvn(sv, ptr, ebuf - ptr);
7331 =for apidoc sv_setpviv_mg
7333 Like C<sv_setpviv>, but also handles 'set' magic.
7339 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7341 char buf[TYPE_CHARS(UV)];
7343 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7345 sv_setpvn(sv, ptr, ebuf - ptr);
7349 #if defined(PERL_IMPLICIT_CONTEXT)
7351 /* pTHX_ magic can't cope with varargs, so this is a no-context
7352 * version of the main function, (which may itself be aliased to us).
7353 * Don't access this version directly.
7357 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7361 va_start(args, pat);
7362 sv_vsetpvf(sv, pat, &args);
7366 /* pTHX_ magic can't cope with varargs, so this is a no-context
7367 * version of the main function, (which may itself be aliased to us).
7368 * Don't access this version directly.
7372 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7376 va_start(args, pat);
7377 sv_vsetpvf_mg(sv, pat, &args);
7383 =for apidoc sv_setpvf
7385 Processes its arguments like C<sprintf> and sets an SV to the formatted
7386 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7392 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7395 va_start(args, pat);
7396 sv_vsetpvf(sv, pat, &args);
7400 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7403 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7405 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7409 =for apidoc sv_setpvf_mg
7411 Like C<sv_setpvf>, but also handles 'set' magic.
7417 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7420 va_start(args, pat);
7421 sv_vsetpvf_mg(sv, pat, &args);
7425 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7428 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7430 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7434 #if defined(PERL_IMPLICIT_CONTEXT)
7436 /* pTHX_ magic can't cope with varargs, so this is a no-context
7437 * version of the main function, (which may itself be aliased to us).
7438 * Don't access this version directly.
7442 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7446 va_start(args, pat);
7447 sv_vcatpvf(sv, pat, &args);
7451 /* pTHX_ magic can't cope with varargs, so this is a no-context
7452 * version of the main function, (which may itself be aliased to us).
7453 * Don't access this version directly.
7457 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7461 va_start(args, pat);
7462 sv_vcatpvf_mg(sv, pat, &args);
7468 =for apidoc sv_catpvf
7470 Processes its arguments like C<sprintf> and appends the formatted
7471 output to an SV. If the appended data contains "wide" characters
7472 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7473 and characters >255 formatted with %c), the original SV might get
7474 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7475 C<SvSETMAGIC()> must typically be called after calling this function
7476 to handle 'set' magic.
7481 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7484 va_start(args, pat);
7485 sv_vcatpvf(sv, pat, &args);
7489 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7492 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7494 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7498 =for apidoc sv_catpvf_mg
7500 Like C<sv_catpvf>, but also handles 'set' magic.
7506 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7509 va_start(args, pat);
7510 sv_vcatpvf_mg(sv, pat, &args);
7514 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7517 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7519 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7524 =for apidoc sv_vsetpvfn
7526 Works like C<vcatpvfn> but copies the text into the SV instead of
7529 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7535 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7537 sv_setpvn(sv, "", 0);
7538 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7541 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7544 S_expect_number(pTHX_ char** pattern)
7547 switch (**pattern) {
7548 case '1': case '2': case '3':
7549 case '4': case '5': case '6':
7550 case '7': case '8': case '9':
7551 while (isDIGIT(**pattern))
7552 var = var * 10 + (*(*pattern)++ - '0');
7556 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7559 =for apidoc sv_vcatpvfn
7561 Processes its arguments like C<vsprintf> and appends the formatted output
7562 to an SV. Uses an array of SVs if the C style variable argument list is
7563 missing (NULL). When running with taint checks enabled, indicates via
7564 C<maybe_tainted> if results are untrustworthy (often due to the use of
7567 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7573 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7580 static char nullstr[] = "(null)";
7583 /* no matter what, this is a string now */
7584 (void)SvPV_force(sv, origlen);
7586 /* special-case "", "%s", and "%_" */
7589 if (patlen == 2 && pat[0] == '%') {
7593 char *s = va_arg(*args, char*);
7594 sv_catpv(sv, s ? s : nullstr);
7596 else if (svix < svmax) {
7597 sv_catsv(sv, *svargs);
7598 if (DO_UTF8(*svargs))
7604 argsv = va_arg(*args, SV*);
7605 sv_catsv(sv, argsv);
7610 /* See comment on '_' below */
7615 patend = (char*)pat + patlen;
7616 for (p = (char*)pat; p < patend; p = q) {
7619 bool vectorize = FALSE;
7620 bool vectorarg = FALSE;
7621 bool vec_utf = FALSE;
7627 bool has_precis = FALSE;
7629 bool is_utf = FALSE;
7632 U8 utf8buf[UTF8_MAXLEN+1];
7633 STRLEN esignlen = 0;
7635 char *eptr = Nullch;
7637 /* Times 4: a decimal digit takes more than 3 binary digits.
7638 * NV_DIG: mantissa takes than many decimal digits.
7639 * Plus 32: Playing safe. */
7640 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7641 /* large enough for "%#.#f" --chip */
7642 /* what about long double NVs? --jhi */
7645 U8 *vecstr = Null(U8*);
7657 STRLEN dotstrlen = 1;
7658 I32 efix = 0; /* explicit format parameter index */
7659 I32 ewix = 0; /* explicit width index */
7660 I32 epix = 0; /* explicit precision index */
7661 I32 evix = 0; /* explicit vector index */
7662 bool asterisk = FALSE;
7664 /* echo everything up to the next format specification */
7665 for (q = p; q < patend && *q != '%'; ++q) ;
7667 sv_catpvn(sv, p, q - p);
7674 We allow format specification elements in this order:
7675 \d+\$ explicit format parameter index
7677 \*?(\d+\$)?v vector with optional (optionally specified) arg
7678 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7679 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7681 [%bcdefginopsux_DFOUX] format (mandatory)
7683 if (EXPECT_NUMBER(q, width)) {
7724 if (EXPECT_NUMBER(q, ewix))
7733 if ((vectorarg = asterisk)) {
7743 EXPECT_NUMBER(q, width);
7748 vecsv = va_arg(*args, SV*);
7750 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7751 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7752 dotstr = SvPVx(vecsv, dotstrlen);
7757 vecsv = va_arg(*args, SV*);
7758 vecstr = (U8*)SvPVx(vecsv,veclen);
7759 vec_utf = DO_UTF8(vecsv);
7761 else if (efix ? efix <= svmax : svix < svmax) {
7762 vecsv = svargs[efix ? efix-1 : svix++];
7763 vecstr = (U8*)SvPVx(vecsv,veclen);
7764 vec_utf = DO_UTF8(vecsv);
7774 i = va_arg(*args, int);
7776 i = (ewix ? ewix <= svmax : svix < svmax) ?
7777 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7779 width = (i < 0) ? -i : i;
7789 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7792 i = va_arg(*args, int);
7794 i = (ewix ? ewix <= svmax : svix < svmax)
7795 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7796 precis = (i < 0) ? 0 : i;
7801 precis = precis * 10 + (*q++ - '0');
7809 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7820 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7821 if (*(q + 1) == 'l') { /* lld, llf */
7844 argsv = (efix ? efix <= svmax : svix < svmax) ?
7845 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7852 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7854 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7856 eptr = (char*)utf8buf;
7857 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7869 eptr = va_arg(*args, char*);
7871 #ifdef MACOS_TRADITIONAL
7872 /* On MacOS, %#s format is used for Pascal strings */
7877 elen = strlen(eptr);
7880 elen = sizeof nullstr - 1;
7884 eptr = SvPVx(argsv, elen);
7885 if (DO_UTF8(argsv)) {
7886 if (has_precis && precis < elen) {
7888 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7891 if (width) { /* fudge width (can't fudge elen) */
7892 width += elen - sv_len_utf8(argsv);
7901 * The "%_" hack might have to be changed someday,
7902 * if ISO or ANSI decide to use '_' for something.
7903 * So we keep it hidden from users' code.
7907 argsv = va_arg(*args, SV*);
7908 eptr = SvPVx(argsv, elen);
7914 if (has_precis && elen > precis)
7923 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7941 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7951 case 'h': iv = (short)va_arg(*args, int); break;
7952 default: iv = va_arg(*args, int); break;
7953 case 'l': iv = va_arg(*args, long); break;
7954 case 'V': iv = va_arg(*args, IV); break;
7956 case 'q': iv = va_arg(*args, Quad_t); break;
7963 case 'h': iv = (short)iv; break;
7965 case 'l': iv = (long)iv; break;
7968 case 'q': iv = (Quad_t)iv; break;
7975 esignbuf[esignlen++] = plus;
7979 esignbuf[esignlen++] = '-';
8021 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
8031 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8032 default: uv = va_arg(*args, unsigned); break;
8033 case 'l': uv = va_arg(*args, unsigned long); break;
8034 case 'V': uv = va_arg(*args, UV); break;
8036 case 'q': uv = va_arg(*args, Quad_t); break;
8043 case 'h': uv = (unsigned short)uv; break;
8045 case 'l': uv = (unsigned long)uv; break;
8048 case 'q': uv = (Quad_t)uv; break;
8054 eptr = ebuf + sizeof ebuf;
8060 p = (char*)((c == 'X')
8061 ? "0123456789ABCDEF" : "0123456789abcdef");
8067 esignbuf[esignlen++] = '0';
8068 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8074 *--eptr = '0' + dig;
8076 if (alt && *eptr != '0')
8082 *--eptr = '0' + dig;
8085 esignbuf[esignlen++] = '0';
8086 esignbuf[esignlen++] = 'b';
8089 default: /* it had better be ten or less */
8090 #if defined(PERL_Y2KWARN)
8091 if (ckWARN(WARN_Y2K)) {
8093 char *s = SvPV(sv,n);
8094 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8095 && (n == 2 || !isDIGIT(s[n-3])))
8097 Perl_warner(aTHX_ WARN_Y2K,
8098 "Possible Y2K bug: %%%c %s",
8099 c, "format string following '19'");
8105 *--eptr = '0' + dig;
8106 } while (uv /= base);
8109 elen = (ebuf + sizeof ebuf) - eptr;
8112 zeros = precis - elen;
8113 else if (precis == 0 && elen == 1 && *eptr == '0')
8118 /* FLOATING POINT */
8121 c = 'f'; /* maybe %F isn't supported here */
8127 /* This is evil, but floating point is even more evil */
8130 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8133 if (c != 'e' && c != 'E') {
8135 (void)Perl_frexp(nv, &i);
8136 if (i == PERL_INT_MIN)
8137 Perl_die(aTHX_ "panic: frexp");
8139 need = BIT_DIGITS(i);
8141 need += has_precis ? precis : 6; /* known default */
8145 need += 20; /* fudge factor */
8146 if (PL_efloatsize < need) {
8147 Safefree(PL_efloatbuf);
8148 PL_efloatsize = need + 20; /* more fudge */
8149 New(906, PL_efloatbuf, PL_efloatsize, char);
8150 PL_efloatbuf[0] = '\0';
8153 eptr = ebuf + sizeof ebuf;
8156 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8158 /* Copy the one or more characters in a long double
8159 * format before the 'base' ([efgEFG]) character to
8160 * the format string. */
8161 static char const prifldbl[] = PERL_PRIfldbl;
8162 char const *p = prifldbl + sizeof(prifldbl) - 3;
8163 while (p >= prifldbl) { *--eptr = *p--; }
8168 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8173 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8185 /* No taint. Otherwise we are in the strange situation
8186 * where printf() taints but print($float) doesn't.
8188 (void)sprintf(PL_efloatbuf, eptr, nv);
8190 eptr = PL_efloatbuf;
8191 elen = strlen(PL_efloatbuf);
8198 i = SvCUR(sv) - origlen;
8201 case 'h': *(va_arg(*args, short*)) = i; break;
8202 default: *(va_arg(*args, int*)) = i; break;
8203 case 'l': *(va_arg(*args, long*)) = i; break;
8204 case 'V': *(va_arg(*args, IV*)) = i; break;
8206 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8211 sv_setuv_mg(argsv, (UV)i);
8212 continue; /* not "break" */
8219 if (!args && ckWARN(WARN_PRINTF) &&
8220 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8221 SV *msg = sv_newmortal();
8222 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8223 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8226 Perl_sv_catpvf(aTHX_ msg,
8227 "\"%%%c\"", c & 0xFF);
8229 Perl_sv_catpvf(aTHX_ msg,
8230 "\"%%\\%03"UVof"\"",
8233 sv_catpv(msg, "end of string");
8234 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8237 /* output mangled stuff ... */
8243 /* ... right here, because formatting flags should not apply */
8244 SvGROW(sv, SvCUR(sv) + elen + 1);
8246 Copy(eptr, p, elen, char);
8249 SvCUR(sv) = p - SvPVX(sv);
8250 continue; /* not "break" */
8253 have = esignlen + zeros + elen;
8254 need = (have > width ? have : width);
8257 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8259 if (esignlen && fill == '0') {
8260 for (i = 0; i < esignlen; i++)
8264 memset(p, fill, gap);
8267 if (esignlen && fill != '0') {
8268 for (i = 0; i < esignlen; i++)
8272 for (i = zeros; i; i--)
8276 Copy(eptr, p, elen, char);
8280 memset(p, ' ', gap);
8285 Copy(dotstr, p, dotstrlen, char);
8289 vectorize = FALSE; /* done iterating over vecstr */
8294 SvCUR(sv) = p - SvPVX(sv);
8302 /* =========================================================================
8304 =head1 Cloning an interpreter
8306 All the macros and functions in this section are for the private use of
8307 the main function, perl_clone().
8309 The foo_dup() functions make an exact copy of an existing foo thinngy.
8310 During the course of a cloning, a hash table is used to map old addresses
8311 to new addresses. The table is created and manipulated with the
8312 ptr_table_* functions.
8316 ============================================================================*/
8319 #if defined(USE_ITHREADS)
8321 #if defined(USE_THREADS)
8322 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
8325 #ifndef GpREFCNT_inc
8326 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8330 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8331 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8332 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8333 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8334 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8335 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8336 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8337 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8338 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8339 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8340 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8341 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8342 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8345 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8346 regcomp.c. AMS 20010712 */
8349 Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
8353 struct reg_substr_datum *s;
8356 return (REGEXP *)NULL;
8358 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8361 len = r->offsets[0];
8362 npar = r->nparens+1;
8364 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8365 Copy(r->program, ret->program, len+1, regnode);
8367 New(0, ret->startp, npar, I32);
8368 Copy(r->startp, ret->startp, npar, I32);
8369 New(0, ret->endp, npar, I32);
8370 Copy(r->startp, ret->startp, npar, I32);
8372 New(0, ret->substrs, 1, struct reg_substr_data);
8373 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8374 s->min_offset = r->substrs->data[i].min_offset;
8375 s->max_offset = r->substrs->data[i].max_offset;
8376 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8379 ret->regstclass = NULL;
8382 int count = r->data->count;
8384 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8385 char, struct reg_data);
8386 New(0, d->what, count, U8);
8389 for (i = 0; i < count; i++) {
8390 d->what[i] = r->data->what[i];
8391 switch (d->what[i]) {
8393 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8396 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8399 /* This is cheating. */
8400 New(0, d->data[i], 1, struct regnode_charclass_class);
8401 StructCopy(r->data->data[i], d->data[i],
8402 struct regnode_charclass_class);
8403 ret->regstclass = (regnode*)d->data[i];
8406 /* Compiled op trees are readonly, and can thus be
8407 shared without duplication. */
8408 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8411 d->data[i] = r->data->data[i];
8421 New(0, ret->offsets, 2*len+1, U32);
8422 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8424 ret->precomp = SAVEPV(r->precomp);
8425 ret->refcnt = r->refcnt;
8426 ret->minlen = r->minlen;
8427 ret->prelen = r->prelen;
8428 ret->nparens = r->nparens;
8429 ret->lastparen = r->lastparen;
8430 ret->lastcloseparen = r->lastcloseparen;
8431 ret->reganch = r->reganch;
8433 ret->sublen = r->sublen;
8435 if (RX_MATCH_COPIED(ret))
8436 ret->subbeg = SAVEPV(r->subbeg);
8438 ret->subbeg = Nullch;
8440 ptr_table_store(PL_ptr_table, r, ret);
8444 /* duplicate a file handle */
8447 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
8451 return (PerlIO*)NULL;
8453 /* look for it in the table first */
8454 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8458 /* create anew and remember what it is */
8459 ret = PerlIO_fdupopen(aTHX_ fp);
8460 ptr_table_store(PL_ptr_table, fp, ret);
8464 /* duplicate a directory handle */
8467 Perl_dirp_dup(pTHX_ DIR *dp)
8475 /* duplicate a typeglob */
8478 Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
8483 /* look for it in the table first */
8484 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8488 /* create anew and remember what it is */
8489 Newz(0, ret, 1, GP);
8490 ptr_table_store(PL_ptr_table, gp, ret);
8493 ret->gp_refcnt = 0; /* must be before any other dups! */
8494 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8495 ret->gp_io = io_dup_inc(gp->gp_io, param);
8496 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8497 ret->gp_av = av_dup_inc(gp->gp_av, param);
8498 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8499 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8500 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8501 ret->gp_cvgen = gp->gp_cvgen;
8502 ret->gp_flags = gp->gp_flags;
8503 ret->gp_line = gp->gp_line;
8504 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8508 /* duplicate a chain of magic */
8511 Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
8513 MAGIC *mgprev = (MAGIC*)NULL;
8516 return (MAGIC*)NULL;
8517 /* look for it in the table first */
8518 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8522 for (; mg; mg = mg->mg_moremagic) {
8524 Newz(0, nmg, 1, MAGIC);
8526 mgprev->mg_moremagic = nmg;
8529 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8530 nmg->mg_private = mg->mg_private;
8531 nmg->mg_type = mg->mg_type;
8532 nmg->mg_flags = mg->mg_flags;
8533 if (mg->mg_type == PERL_MAGIC_qr) {
8534 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8536 else if(mg->mg_type == PERL_MAGIC_backref) {
8537 AV *av = (AV*) mg->mg_obj;
8540 nmg->mg_obj = (SV*)newAV();
8544 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8549 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8550 ? sv_dup_inc(mg->mg_obj, param)
8551 : sv_dup(mg->mg_obj, param);
8553 nmg->mg_len = mg->mg_len;
8554 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8555 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8556 if (mg->mg_len >= 0) {
8557 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8558 if (mg->mg_type == PERL_MAGIC_overload_table &&
8559 AMT_AMAGIC((AMT*)mg->mg_ptr))
8561 AMT *amtp = (AMT*)mg->mg_ptr;
8562 AMT *namtp = (AMT*)nmg->mg_ptr;
8564 for (i = 1; i < NofAMmeth; i++) {
8565 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8569 else if (mg->mg_len == HEf_SVKEY)
8570 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8577 /* create a new pointer-mapping table */
8580 Perl_ptr_table_new(pTHX)
8583 Newz(0, tbl, 1, PTR_TBL_t);
8586 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8590 /* map an existing pointer using a table */
8593 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8595 PTR_TBL_ENT_t *tblent;
8596 UV hash = PTR2UV(sv);
8598 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8599 for (; tblent; tblent = tblent->next) {
8600 if (tblent->oldval == sv)
8601 return tblent->newval;
8606 /* add a new entry to a pointer-mapping table */
8609 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8611 PTR_TBL_ENT_t *tblent, **otblent;
8612 /* XXX this may be pessimal on platforms where pointers aren't good
8613 * hash values e.g. if they grow faster in the most significant
8615 UV hash = PTR2UV(oldv);
8619 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8620 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8621 if (tblent->oldval == oldv) {
8622 tblent->newval = newv;
8627 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8628 tblent->oldval = oldv;
8629 tblent->newval = newv;
8630 tblent->next = *otblent;
8633 if (i && tbl->tbl_items > tbl->tbl_max)
8634 ptr_table_split(tbl);
8637 /* double the hash bucket size of an existing ptr table */
8640 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8642 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8643 UV oldsize = tbl->tbl_max + 1;
8644 UV newsize = oldsize * 2;
8647 Renew(ary, newsize, PTR_TBL_ENT_t*);
8648 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8649 tbl->tbl_max = --newsize;
8651 for (i=0; i < oldsize; i++, ary++) {
8652 PTR_TBL_ENT_t **curentp, **entp, *ent;
8655 curentp = ary + oldsize;
8656 for (entp = ary, ent = *ary; ent; ent = *entp) {
8657 if ((newsize & PTR2UV(ent->oldval)) != i) {
8659 ent->next = *curentp;
8669 /* remove all the entries from a ptr table */
8672 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8674 register PTR_TBL_ENT_t **array;
8675 register PTR_TBL_ENT_t *entry;
8676 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8680 if (!tbl || !tbl->tbl_items) {
8684 array = tbl->tbl_ary;
8691 entry = entry->next;
8695 if (++riter > max) {
8698 entry = array[riter];
8705 /* clear and free a ptr table */
8708 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8713 ptr_table_clear(tbl);
8714 Safefree(tbl->tbl_ary);
8722 /* attempt to make everything in the typeglob readonly */
8725 S_gv_share(pTHX_ SV *sstr)
8728 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8730 if (GvIO(gv) || GvFORM(gv)) {
8731 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8733 else if (!GvCV(gv)) {
8737 /* CvPADLISTs cannot be shared */
8738 if (!CvXSUB(GvCV(gv))) {
8743 if (!GvUNIQUE(gv)) {
8745 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8746 HvNAME(GvSTASH(gv)), GvNAME(gv));
8752 * write attempts will die with
8753 * "Modification of a read-only value attempted"
8759 SvREADONLY_on(GvSV(gv));
8766 SvREADONLY_on(GvAV(gv));
8773 SvREADONLY_on(GvAV(gv));
8776 return sstr; /* he_dup() will SvREFCNT_inc() */
8779 /* duplicate an SV of any type (including AV, HV etc) */
8782 Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
8786 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8788 /* look for it in the table first */
8789 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8793 /* create anew and remember what it is */
8795 ptr_table_store(PL_ptr_table, sstr, dstr);
8798 SvFLAGS(dstr) = SvFLAGS(sstr);
8799 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8800 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8803 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8804 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8805 PL_watch_pvx, SvPVX(sstr));
8808 switch (SvTYPE(sstr)) {
8813 SvANY(dstr) = new_XIV();
8814 SvIVX(dstr) = SvIVX(sstr);
8817 SvANY(dstr) = new_XNV();
8818 SvNVX(dstr) = SvNVX(sstr);
8821 SvANY(dstr) = new_XRV();
8822 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8823 ? sv_dup(SvRV(sstr), param)
8824 : sv_dup_inc(SvRV(sstr), param);
8827 SvANY(dstr) = new_XPV();
8828 SvCUR(dstr) = SvCUR(sstr);
8829 SvLEN(dstr) = SvLEN(sstr);
8831 SvRV(dstr) = SvWEAKREF(sstr)
8832 ? sv_dup(SvRV(sstr), param)
8833 : sv_dup_inc(SvRV(sstr), param);
8834 else if (SvPVX(sstr) && SvLEN(sstr))
8835 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8837 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8840 SvANY(dstr) = new_XPVIV();
8841 SvCUR(dstr) = SvCUR(sstr);
8842 SvLEN(dstr) = SvLEN(sstr);
8843 SvIVX(dstr) = SvIVX(sstr);
8845 SvRV(dstr) = SvWEAKREF(sstr)
8846 ? sv_dup(SvRV(sstr), param)
8847 : sv_dup_inc(SvRV(sstr), param);
8848 else if (SvPVX(sstr) && SvLEN(sstr))
8849 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8851 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8854 SvANY(dstr) = new_XPVNV();
8855 SvCUR(dstr) = SvCUR(sstr);
8856 SvLEN(dstr) = SvLEN(sstr);
8857 SvIVX(dstr) = SvIVX(sstr);
8858 SvNVX(dstr) = SvNVX(sstr);
8860 SvRV(dstr) = SvWEAKREF(sstr)
8861 ? sv_dup(SvRV(sstr), param)
8862 : sv_dup_inc(SvRV(sstr), param);
8863 else if (SvPVX(sstr) && SvLEN(sstr))
8864 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8866 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8869 SvANY(dstr) = new_XPVMG();
8870 SvCUR(dstr) = SvCUR(sstr);
8871 SvLEN(dstr) = SvLEN(sstr);
8872 SvIVX(dstr) = SvIVX(sstr);
8873 SvNVX(dstr) = SvNVX(sstr);
8874 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8875 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8877 SvRV(dstr) = SvWEAKREF(sstr)
8878 ? sv_dup(SvRV(sstr), param)
8879 : sv_dup_inc(SvRV(sstr), param);
8880 else if (SvPVX(sstr) && SvLEN(sstr))
8881 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8883 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8886 SvANY(dstr) = new_XPVBM();
8887 SvCUR(dstr) = SvCUR(sstr);
8888 SvLEN(dstr) = SvLEN(sstr);
8889 SvIVX(dstr) = SvIVX(sstr);
8890 SvNVX(dstr) = SvNVX(sstr);
8891 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8892 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8894 SvRV(dstr) = SvWEAKREF(sstr)
8895 ? sv_dup(SvRV(sstr), param)
8896 : sv_dup_inc(SvRV(sstr), param);
8897 else if (SvPVX(sstr) && SvLEN(sstr))
8898 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8900 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8901 BmRARE(dstr) = BmRARE(sstr);
8902 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8903 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8906 SvANY(dstr) = new_XPVLV();
8907 SvCUR(dstr) = SvCUR(sstr);
8908 SvLEN(dstr) = SvLEN(sstr);
8909 SvIVX(dstr) = SvIVX(sstr);
8910 SvNVX(dstr) = SvNVX(sstr);
8911 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8912 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8914 SvRV(dstr) = SvWEAKREF(sstr)
8915 ? sv_dup(SvRV(sstr), param)
8916 : sv_dup_inc(SvRV(sstr), param);
8917 else if (SvPVX(sstr) && SvLEN(sstr))
8918 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8920 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8921 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8922 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8923 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8924 LvTYPE(dstr) = LvTYPE(sstr);
8927 if (GvUNIQUE((GV*)sstr)) {
8929 if ((share = gv_share(sstr))) {
8933 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8934 HvNAME(GvSTASH(share)), GvNAME(share));
8939 SvANY(dstr) = new_XPVGV();
8940 SvCUR(dstr) = SvCUR(sstr);
8941 SvLEN(dstr) = SvLEN(sstr);
8942 SvIVX(dstr) = SvIVX(sstr);
8943 SvNVX(dstr) = SvNVX(sstr);
8944 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8945 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8947 SvRV(dstr) = SvWEAKREF(sstr)
8948 ? sv_dup(SvRV(sstr), param)
8949 : sv_dup_inc(SvRV(sstr), param);
8950 else if (SvPVX(sstr) && SvLEN(sstr))
8951 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8953 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8954 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8955 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8956 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
8957 GvFLAGS(dstr) = GvFLAGS(sstr);
8958 GvGP(dstr) = gp_dup(GvGP(sstr), param);
8959 (void)GpREFCNT_inc(GvGP(dstr));
8962 SvANY(dstr) = new_XPVIO();
8963 SvCUR(dstr) = SvCUR(sstr);
8964 SvLEN(dstr) = SvLEN(sstr);
8965 SvIVX(dstr) = SvIVX(sstr);
8966 SvNVX(dstr) = SvNVX(sstr);
8967 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8968 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8970 SvRV(dstr) = SvWEAKREF(sstr)
8971 ? sv_dup(SvRV(sstr), param)
8972 : sv_dup_inc(SvRV(sstr), param);
8973 else if (SvPVX(sstr) && SvLEN(sstr))
8974 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8976 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8977 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8978 if (IoOFP(sstr) == IoIFP(sstr))
8979 IoOFP(dstr) = IoIFP(dstr);
8981 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8982 /* PL_rsfp_filters entries have fake IoDIRP() */
8983 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8984 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8986 IoDIRP(dstr) = IoDIRP(sstr);
8987 IoLINES(dstr) = IoLINES(sstr);
8988 IoPAGE(dstr) = IoPAGE(sstr);
8989 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8990 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8991 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8992 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
8993 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8994 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
8995 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8996 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
8997 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8998 IoTYPE(dstr) = IoTYPE(sstr);
8999 IoFLAGS(dstr) = IoFLAGS(sstr);
9002 SvANY(dstr) = new_XPVAV();
9003 SvCUR(dstr) = SvCUR(sstr);
9004 SvLEN(dstr) = SvLEN(sstr);
9005 SvIVX(dstr) = SvIVX(sstr);
9006 SvNVX(dstr) = SvNVX(sstr);
9007 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9008 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9009 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9010 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9011 if (AvARRAY((AV*)sstr)) {
9012 SV **dst_ary, **src_ary;
9013 SSize_t items = AvFILLp((AV*)sstr) + 1;
9015 src_ary = AvARRAY((AV*)sstr);
9016 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9017 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9018 SvPVX(dstr) = (char*)dst_ary;
9019 AvALLOC((AV*)dstr) = dst_ary;
9020 if (AvREAL((AV*)sstr)) {
9022 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9026 *dst_ary++ = sv_dup(*src_ary++, param);
9028 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9029 while (items-- > 0) {
9030 *dst_ary++ = &PL_sv_undef;
9034 SvPVX(dstr) = Nullch;
9035 AvALLOC((AV*)dstr) = (SV**)NULL;
9039 SvANY(dstr) = new_XPVHV();
9040 SvCUR(dstr) = SvCUR(sstr);
9041 SvLEN(dstr) = SvLEN(sstr);
9042 SvIVX(dstr) = SvIVX(sstr);
9043 SvNVX(dstr) = SvNVX(sstr);
9044 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9045 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9046 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9047 if (HvARRAY((HV*)sstr)) {
9049 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9050 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9051 Newz(0, dxhv->xhv_array,
9052 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9053 while (i <= sxhv->xhv_max) {
9054 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9055 !!HvSHAREKEYS(sstr), param);
9058 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9061 SvPVX(dstr) = Nullch;
9062 HvEITER((HV*)dstr) = (HE*)NULL;
9064 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9065 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9066 /* Record stashes for possible cloning in Perl_clone(). */
9067 if(HvNAME((HV*)dstr))
9068 av_push(param->stashes, dstr);
9071 SvANY(dstr) = new_XPVFM();
9072 FmLINES(dstr) = FmLINES(sstr);
9076 SvANY(dstr) = new_XPVCV();
9078 SvCUR(dstr) = SvCUR(sstr);
9079 SvLEN(dstr) = SvLEN(sstr);
9080 SvIVX(dstr) = SvIVX(sstr);
9081 SvNVX(dstr) = SvNVX(sstr);
9082 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9083 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9084 if (SvPVX(sstr) && SvLEN(sstr))
9085 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9087 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9088 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9089 CvSTART(dstr) = CvSTART(sstr);
9090 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9091 CvXSUB(dstr) = CvXSUB(sstr);
9092 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9093 if (CvCONST(sstr)) {
9094 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9095 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9096 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9098 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9099 if (param->flags & CLONEf_COPY_STACKS) {
9100 CvDEPTH(dstr) = CvDEPTH(sstr);
9104 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9105 /* XXX padlists are real, but pretend to be not */
9106 AvREAL_on(CvPADLIST(sstr));
9107 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9108 AvREAL_off(CvPADLIST(sstr));
9109 AvREAL_off(CvPADLIST(dstr));
9112 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9113 if (!CvANON(sstr) || CvCLONED(sstr))
9114 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9116 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9117 CvFLAGS(dstr) = CvFLAGS(sstr);
9118 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9121 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9125 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9131 /* duplicate a context */
9134 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
9139 return (PERL_CONTEXT*)NULL;
9141 /* look for it in the table first */
9142 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9146 /* create anew and remember what it is */
9147 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9148 ptr_table_store(PL_ptr_table, cxs, ncxs);
9151 PERL_CONTEXT *cx = &cxs[ix];
9152 PERL_CONTEXT *ncx = &ncxs[ix];
9153 ncx->cx_type = cx->cx_type;
9154 if (CxTYPE(cx) == CXt_SUBST) {
9155 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9158 ncx->blk_oldsp = cx->blk_oldsp;
9159 ncx->blk_oldcop = cx->blk_oldcop;
9160 ncx->blk_oldretsp = cx->blk_oldretsp;
9161 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9162 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9163 ncx->blk_oldpm = cx->blk_oldpm;
9164 ncx->blk_gimme = cx->blk_gimme;
9165 switch (CxTYPE(cx)) {
9167 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9168 ? cv_dup_inc(cx->blk_sub.cv, param)
9169 : cv_dup(cx->blk_sub.cv,param));
9170 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9171 ? av_dup_inc(cx->blk_sub.argarray, param)
9173 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9174 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9175 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9176 ncx->blk_sub.lval = cx->blk_sub.lval;
9179 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9180 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9181 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9182 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9183 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9186 ncx->blk_loop.label = cx->blk_loop.label;
9187 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9188 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9189 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9190 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9191 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9192 ? cx->blk_loop.iterdata
9193 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9194 ncx->blk_loop.oldcurpad
9195 = (SV**)ptr_table_fetch(PL_ptr_table,
9196 cx->blk_loop.oldcurpad);
9197 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9198 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9199 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9200 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9201 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9204 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9205 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9206 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9207 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9219 /* duplicate a stack info structure */
9222 Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
9227 return (PERL_SI*)NULL;
9229 /* look for it in the table first */
9230 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9234 /* create anew and remember what it is */
9235 Newz(56, nsi, 1, PERL_SI);
9236 ptr_table_store(PL_ptr_table, si, nsi);
9238 nsi->si_stack = av_dup_inc(si->si_stack, param);
9239 nsi->si_cxix = si->si_cxix;
9240 nsi->si_cxmax = si->si_cxmax;
9241 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9242 nsi->si_type = si->si_type;
9243 nsi->si_prev = si_dup(si->si_prev, param);
9244 nsi->si_next = si_dup(si->si_next, param);
9245 nsi->si_markoff = si->si_markoff;
9250 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9251 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9252 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9253 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9254 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9255 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9256 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9257 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9258 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9259 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9260 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9261 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9264 #define pv_dup_inc(p) SAVEPV(p)
9265 #define pv_dup(p) SAVEPV(p)
9266 #define svp_dup_inc(p,pp) any_dup(p,pp)
9268 /* map any object to the new equivent - either something in the
9269 * ptr table, or something in the interpreter structure
9273 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9280 /* look for it in the table first */
9281 ret = ptr_table_fetch(PL_ptr_table, v);
9285 /* see if it is part of the interpreter structure */
9286 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9287 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
9294 /* duplicate the save stack */
9297 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
9299 ANY *ss = proto_perl->Tsavestack;
9300 I32 ix = proto_perl->Tsavestack_ix;
9301 I32 max = proto_perl->Tsavestack_max;
9314 void (*dptr) (void*);
9315 void (*dxptr) (pTHXo_ void*);
9318 Newz(54, nss, max, ANY);
9324 case SAVEt_ITEM: /* normal string */
9325 sv = (SV*)POPPTR(ss,ix);
9326 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9327 sv = (SV*)POPPTR(ss,ix);
9328 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9330 case SAVEt_SV: /* scalar reference */
9331 sv = (SV*)POPPTR(ss,ix);
9332 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9333 gv = (GV*)POPPTR(ss,ix);
9334 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9336 case SAVEt_GENERIC_PVREF: /* generic char* */
9337 c = (char*)POPPTR(ss,ix);
9338 TOPPTR(nss,ix) = pv_dup(c);
9339 ptr = POPPTR(ss,ix);
9340 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9342 case SAVEt_GENERIC_SVREF: /* generic sv */
9343 case SAVEt_SVREF: /* scalar reference */
9344 sv = (SV*)POPPTR(ss,ix);
9345 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9346 ptr = POPPTR(ss,ix);
9347 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9349 case SAVEt_AV: /* array reference */
9350 av = (AV*)POPPTR(ss,ix);
9351 TOPPTR(nss,ix) = av_dup_inc(av, param);
9352 gv = (GV*)POPPTR(ss,ix);
9353 TOPPTR(nss,ix) = gv_dup(gv, param);
9355 case SAVEt_HV: /* hash reference */
9356 hv = (HV*)POPPTR(ss,ix);
9357 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9358 gv = (GV*)POPPTR(ss,ix);
9359 TOPPTR(nss,ix) = gv_dup(gv, param);
9361 case SAVEt_INT: /* int reference */
9362 ptr = POPPTR(ss,ix);
9363 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9364 intval = (int)POPINT(ss,ix);
9365 TOPINT(nss,ix) = intval;
9367 case SAVEt_LONG: /* long reference */
9368 ptr = POPPTR(ss,ix);
9369 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9370 longval = (long)POPLONG(ss,ix);
9371 TOPLONG(nss,ix) = longval;
9373 case SAVEt_I32: /* I32 reference */
9374 case SAVEt_I16: /* I16 reference */
9375 case SAVEt_I8: /* I8 reference */
9376 ptr = POPPTR(ss,ix);
9377 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9381 case SAVEt_IV: /* IV reference */
9382 ptr = POPPTR(ss,ix);
9383 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9387 case SAVEt_SPTR: /* SV* reference */
9388 ptr = POPPTR(ss,ix);
9389 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9390 sv = (SV*)POPPTR(ss,ix);
9391 TOPPTR(nss,ix) = sv_dup(sv, param);
9393 case SAVEt_VPTR: /* random* reference */
9394 ptr = POPPTR(ss,ix);
9395 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9396 ptr = POPPTR(ss,ix);
9397 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9399 case SAVEt_PPTR: /* char* reference */
9400 ptr = POPPTR(ss,ix);
9401 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9402 c = (char*)POPPTR(ss,ix);
9403 TOPPTR(nss,ix) = pv_dup(c);
9405 case SAVEt_HPTR: /* HV* reference */
9406 ptr = POPPTR(ss,ix);
9407 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9408 hv = (HV*)POPPTR(ss,ix);
9409 TOPPTR(nss,ix) = hv_dup(hv, param);
9411 case SAVEt_APTR: /* AV* reference */
9412 ptr = POPPTR(ss,ix);
9413 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9414 av = (AV*)POPPTR(ss,ix);
9415 TOPPTR(nss,ix) = av_dup(av, param);
9418 gv = (GV*)POPPTR(ss,ix);
9419 TOPPTR(nss,ix) = gv_dup(gv, param);
9421 case SAVEt_GP: /* scalar reference */
9422 gp = (GP*)POPPTR(ss,ix);
9423 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9424 (void)GpREFCNT_inc(gp);
9425 gv = (GV*)POPPTR(ss,ix);
9426 TOPPTR(nss,ix) = gv_dup_inc(c, param);
9427 c = (char*)POPPTR(ss,ix);
9428 TOPPTR(nss,ix) = pv_dup(c);
9435 case SAVEt_MORTALIZESV:
9436 sv = (SV*)POPPTR(ss,ix);
9437 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9440 ptr = POPPTR(ss,ix);
9441 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9442 /* these are assumed to be refcounted properly */
9443 switch (((OP*)ptr)->op_type) {
9450 TOPPTR(nss,ix) = ptr;
9455 TOPPTR(nss,ix) = Nullop;
9460 TOPPTR(nss,ix) = Nullop;
9463 c = (char*)POPPTR(ss,ix);
9464 TOPPTR(nss,ix) = pv_dup_inc(c);
9467 longval = POPLONG(ss,ix);
9468 TOPLONG(nss,ix) = longval;
9471 hv = (HV*)POPPTR(ss,ix);
9472 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9473 c = (char*)POPPTR(ss,ix);
9474 TOPPTR(nss,ix) = pv_dup_inc(c);
9478 case SAVEt_DESTRUCTOR:
9479 ptr = POPPTR(ss,ix);
9480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9481 dptr = POPDPTR(ss,ix);
9482 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9484 case SAVEt_DESTRUCTOR_X:
9485 ptr = POPPTR(ss,ix);
9486 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9487 dxptr = POPDXPTR(ss,ix);
9488 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
9490 case SAVEt_REGCONTEXT:
9496 case SAVEt_STACK_POS: /* Position on Perl stack */
9500 case SAVEt_AELEM: /* array element */
9501 sv = (SV*)POPPTR(ss,ix);
9502 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9505 av = (AV*)POPPTR(ss,ix);
9506 TOPPTR(nss,ix) = av_dup_inc(av, param);
9508 case SAVEt_HELEM: /* hash element */
9509 sv = (SV*)POPPTR(ss,ix);
9510 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9511 sv = (SV*)POPPTR(ss,ix);
9512 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9513 hv = (HV*)POPPTR(ss,ix);
9514 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9517 ptr = POPPTR(ss,ix);
9518 TOPPTR(nss,ix) = ptr;
9525 av = (AV*)POPPTR(ss,ix);
9526 TOPPTR(nss,ix) = av_dup(av, param);
9529 longval = (long)POPLONG(ss,ix);
9530 TOPLONG(nss,ix) = longval;
9531 ptr = POPPTR(ss,ix);
9532 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9533 sv = (SV*)POPPTR(ss,ix);
9534 TOPPTR(nss,ix) = sv_dup(sv, param);
9537 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9549 =for apidoc perl_clone
9551 Create and return a new interpreter by cloning the current one.
9556 /* XXX the above needs expanding by someone who actually understands it ! */
9559 perl_clone(PerlInterpreter *proto_perl, UV flags)
9562 CPerlObj *pPerl = (CPerlObj*)proto_perl;
9565 #ifdef PERL_IMPLICIT_SYS
9567 /* perlhost.h so we need to call into it
9568 to clone the host, CPerlHost should have a c interface, sky */
9570 if (flags & CLONEf_CLONE_HOST) {
9571 return perl_clone_host(proto_perl,flags);
9573 return perl_clone_using(proto_perl, flags,
9575 proto_perl->IMemShared,
9576 proto_perl->IMemParse,
9586 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9587 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9588 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9589 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9590 struct IPerlDir* ipD, struct IPerlSock* ipS,
9591 struct IPerlProc* ipP)
9593 /* XXX many of the string copies here can be optimized if they're
9594 * constants; they need to be allocated as common memory and just
9595 * their pointers copied. */
9598 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9603 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
9605 PERL_SET_THX(pPerl);
9606 # else /* !PERL_OBJECT */
9607 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9608 PERL_SET_THX(my_perl);
9611 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9617 # else /* !DEBUGGING */
9618 Zero(my_perl, 1, PerlInterpreter);
9619 # endif /* DEBUGGING */
9623 PL_MemShared = ipMS;
9631 # endif /* PERL_OBJECT */
9632 #else /* !PERL_IMPLICIT_SYS */
9634 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9635 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9636 PERL_SET_THX(my_perl);
9641 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9647 # else /* !DEBUGGING */
9648 Zero(my_perl, 1, PerlInterpreter);
9649 # endif /* DEBUGGING */
9650 #endif /* PERL_IMPLICIT_SYS */
9651 param->flags = flags;
9654 PL_xiv_arenaroot = NULL;
9656 PL_xnv_arenaroot = NULL;
9658 PL_xrv_arenaroot = NULL;
9660 PL_xpv_arenaroot = NULL;
9662 PL_xpviv_arenaroot = NULL;
9663 PL_xpviv_root = NULL;
9664 PL_xpvnv_arenaroot = NULL;
9665 PL_xpvnv_root = NULL;
9666 PL_xpvcv_arenaroot = NULL;
9667 PL_xpvcv_root = NULL;
9668 PL_xpvav_arenaroot = NULL;
9669 PL_xpvav_root = NULL;
9670 PL_xpvhv_arenaroot = NULL;
9671 PL_xpvhv_root = NULL;
9672 PL_xpvmg_arenaroot = NULL;
9673 PL_xpvmg_root = NULL;
9674 PL_xpvlv_arenaroot = NULL;
9675 PL_xpvlv_root = NULL;
9676 PL_xpvbm_arenaroot = NULL;
9677 PL_xpvbm_root = NULL;
9678 PL_he_arenaroot = NULL;
9680 PL_nice_chunk = NULL;
9681 PL_nice_chunk_size = 0;
9684 PL_sv_root = Nullsv;
9685 PL_sv_arenaroot = Nullsv;
9687 PL_debug = proto_perl->Idebug;
9689 #ifdef USE_REENTRANT_API
9690 New(31337, PL_reentrant_buffer,1, REBUF);
9691 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9694 /* create SV map for pointer relocation */
9695 PL_ptr_table = ptr_table_new();
9697 /* initialize these special pointers as early as possible */
9698 SvANY(&PL_sv_undef) = NULL;
9699 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9700 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9701 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9704 SvUPGRADE(&PL_sv_no, SVt_PVNV);
9706 SvANY(&PL_sv_no) = new_XPVNV();
9708 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9709 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9710 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9711 SvCUR(&PL_sv_no) = 0;
9712 SvLEN(&PL_sv_no) = 1;
9713 SvNVX(&PL_sv_no) = 0;
9714 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9717 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
9719 SvANY(&PL_sv_yes) = new_XPVNV();
9721 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9722 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9723 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9724 SvCUR(&PL_sv_yes) = 1;
9725 SvLEN(&PL_sv_yes) = 2;
9726 SvNVX(&PL_sv_yes) = 1;
9727 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9729 /* create shared string table */
9730 PL_strtab = newHV();
9731 HvSHAREKEYS_off(PL_strtab);
9732 hv_ksplit(PL_strtab, 512);
9733 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9735 PL_compiling = proto_perl->Icompiling;
9736 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9737 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9738 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9739 if (!specialWARN(PL_compiling.cop_warnings))
9740 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9741 if (!specialCopIO(PL_compiling.cop_io))
9742 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9743 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9745 /* pseudo environmental stuff */
9746 PL_origargc = proto_perl->Iorigargc;
9748 New(0, PL_origargv, i+1, char*);
9749 PL_origargv[i] = '\0';
9751 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9755 param->stashes = newAV(); /* Setup array of objects to call clone on */
9758 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9759 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9760 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9761 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9762 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9763 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9766 PL_minus_c = proto_perl->Iminus_c;
9767 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9768 PL_localpatches = proto_perl->Ilocalpatches;
9769 PL_splitstr = proto_perl->Isplitstr;
9770 PL_preprocess = proto_perl->Ipreprocess;
9771 PL_minus_n = proto_perl->Iminus_n;
9772 PL_minus_p = proto_perl->Iminus_p;
9773 PL_minus_l = proto_perl->Iminus_l;
9774 PL_minus_a = proto_perl->Iminus_a;
9775 PL_minus_F = proto_perl->Iminus_F;
9776 PL_doswitches = proto_perl->Idoswitches;
9777 PL_dowarn = proto_perl->Idowarn;
9778 PL_doextract = proto_perl->Idoextract;
9779 PL_sawampersand = proto_perl->Isawampersand;
9780 PL_unsafe = proto_perl->Iunsafe;
9781 PL_inplace = SAVEPV(proto_perl->Iinplace);
9782 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9783 PL_perldb = proto_perl->Iperldb;
9784 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9786 /* magical thingies */
9787 /* XXX time(&PL_basetime) when asked for? */
9788 PL_basetime = proto_perl->Ibasetime;
9789 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9791 PL_maxsysfd = proto_perl->Imaxsysfd;
9792 PL_multiline = proto_perl->Imultiline;
9793 PL_statusvalue = proto_perl->Istatusvalue;
9795 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9798 /* Clone the regex array */
9799 PL_regex_padav = newAV();
9801 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9802 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9803 for(i = 0; i <= len; i++) {
9804 av_push(PL_regex_padav,
9806 newSViv((IV)re_dup((REGEXP *)
9807 SvIVX(regexen[i]), param))
9811 PL_regex_pad = AvARRAY(PL_regex_padav);
9813 /* shortcuts to various I/O objects */
9814 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9815 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9816 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9817 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9818 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9819 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9821 /* shortcuts to regexp stuff */
9822 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9824 /* shortcuts to misc objects */
9825 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9827 /* shortcuts to debugging objects */
9828 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9829 PL_DBline = gv_dup(proto_perl->IDBline, param);
9830 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9831 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9832 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9833 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9834 PL_lineary = av_dup(proto_perl->Ilineary, param);
9835 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9838 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9839 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9840 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9841 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9842 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9843 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9845 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9846 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9847 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9848 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9850 PL_sub_generation = proto_perl->Isub_generation;
9852 /* funky return mechanisms */
9853 PL_forkprocess = proto_perl->Iforkprocess;
9855 /* subprocess state */
9856 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9858 /* internal state */
9859 PL_tainting = proto_perl->Itainting;
9860 PL_maxo = proto_perl->Imaxo;
9861 if (proto_perl->Iop_mask)
9862 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9864 PL_op_mask = Nullch;
9866 /* current interpreter roots */
9867 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9868 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9869 PL_main_start = proto_perl->Imain_start;
9870 PL_eval_root = proto_perl->Ieval_root;
9871 PL_eval_start = proto_perl->Ieval_start;
9873 /* runtime control stuff */
9874 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9875 PL_copline = proto_perl->Icopline;
9877 PL_filemode = proto_perl->Ifilemode;
9878 PL_lastfd = proto_perl->Ilastfd;
9879 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9882 PL_gensym = proto_perl->Igensym;
9883 PL_preambled = proto_perl->Ipreambled;
9884 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9885 PL_laststatval = proto_perl->Ilaststatval;
9886 PL_laststype = proto_perl->Ilaststype;
9887 PL_mess_sv = Nullsv;
9889 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9890 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9892 /* interpreter atexit processing */
9893 PL_exitlistlen = proto_perl->Iexitlistlen;
9894 if (PL_exitlistlen) {
9895 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9896 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9899 PL_exitlist = (PerlExitListEntry*)NULL;
9900 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9902 PL_profiledata = NULL;
9903 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9904 /* PL_rsfp_filters entries have fake IoDIRP() */
9905 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9907 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9908 PL_comppad = av_dup(proto_perl->Icomppad, param);
9909 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9910 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9911 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9912 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9913 proto_perl->Tcurpad);
9915 #ifdef HAVE_INTERP_INTERN
9916 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9919 /* more statics moved here */
9920 PL_generation = proto_perl->Igeneration;
9921 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9923 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9924 PL_in_clean_all = proto_perl->Iin_clean_all;
9926 PL_uid = proto_perl->Iuid;
9927 PL_euid = proto_perl->Ieuid;
9928 PL_gid = proto_perl->Igid;
9929 PL_egid = proto_perl->Iegid;
9930 PL_nomemok = proto_perl->Inomemok;
9931 PL_an = proto_perl->Ian;
9932 PL_cop_seqmax = proto_perl->Icop_seqmax;
9933 PL_op_seqmax = proto_perl->Iop_seqmax;
9934 PL_evalseq = proto_perl->Ievalseq;
9935 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9936 PL_origalen = proto_perl->Iorigalen;
9937 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9938 PL_osname = SAVEPV(proto_perl->Iosname);
9939 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
9940 PL_sighandlerp = proto_perl->Isighandlerp;
9943 PL_runops = proto_perl->Irunops;
9945 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9948 PL_cshlen = proto_perl->Icshlen;
9949 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
9952 PL_lex_state = proto_perl->Ilex_state;
9953 PL_lex_defer = proto_perl->Ilex_defer;
9954 PL_lex_expect = proto_perl->Ilex_expect;
9955 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9956 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9957 PL_lex_starts = proto_perl->Ilex_starts;
9958 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
9959 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
9960 PL_lex_op = proto_perl->Ilex_op;
9961 PL_lex_inpat = proto_perl->Ilex_inpat;
9962 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9963 PL_lex_brackets = proto_perl->Ilex_brackets;
9964 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9965 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9966 PL_lex_casemods = proto_perl->Ilex_casemods;
9967 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9968 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9970 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9971 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9972 PL_nexttoke = proto_perl->Inexttoke;
9974 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
9975 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9976 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9977 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9978 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9979 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9980 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9981 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9982 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9983 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9984 PL_pending_ident = proto_perl->Ipending_ident;
9985 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9987 PL_expect = proto_perl->Iexpect;
9989 PL_multi_start = proto_perl->Imulti_start;
9990 PL_multi_end = proto_perl->Imulti_end;
9991 PL_multi_open = proto_perl->Imulti_open;
9992 PL_multi_close = proto_perl->Imulti_close;
9994 PL_error_count = proto_perl->Ierror_count;
9995 PL_subline = proto_perl->Isubline;
9996 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
9998 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9999 PL_max_intro_pending = proto_perl->Imax_intro_pending;
10000 PL_padix = proto_perl->Ipadix;
10001 PL_padix_floor = proto_perl->Ipadix_floor;
10002 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
10004 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10005 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10006 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10007 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10008 PL_last_lop_op = proto_perl->Ilast_lop_op;
10009 PL_in_my = proto_perl->Iin_my;
10010 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10012 PL_cryptseen = proto_perl->Icryptseen;
10015 PL_hints = proto_perl->Ihints;
10017 PL_amagic_generation = proto_perl->Iamagic_generation;
10019 #ifdef USE_LOCALE_COLLATE
10020 PL_collation_ix = proto_perl->Icollation_ix;
10021 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10022 PL_collation_standard = proto_perl->Icollation_standard;
10023 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10024 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10025 #endif /* USE_LOCALE_COLLATE */
10027 #ifdef USE_LOCALE_NUMERIC
10028 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10029 PL_numeric_standard = proto_perl->Inumeric_standard;
10030 PL_numeric_local = proto_perl->Inumeric_local;
10031 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10032 #endif /* !USE_LOCALE_NUMERIC */
10034 /* utf8 character classes */
10035 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10036 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10037 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10038 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10039 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10040 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10041 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10042 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10043 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10044 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10045 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10046 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10047 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10048 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10049 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10050 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10051 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10054 PL_last_swash_hv = Nullhv; /* reinits on demand */
10055 PL_last_swash_klen = 0;
10056 PL_last_swash_key[0]= '\0';
10057 PL_last_swash_tmps = (U8*)NULL;
10058 PL_last_swash_slen = 0;
10060 /* perly.c globals */
10061 PL_yydebug = proto_perl->Iyydebug;
10062 PL_yynerrs = proto_perl->Iyynerrs;
10063 PL_yyerrflag = proto_perl->Iyyerrflag;
10064 PL_yychar = proto_perl->Iyychar;
10065 PL_yyval = proto_perl->Iyyval;
10066 PL_yylval = proto_perl->Iyylval;
10068 PL_glob_index = proto_perl->Iglob_index;
10069 PL_srand_called = proto_perl->Isrand_called;
10070 PL_uudmap['M'] = 0; /* reinits on demand */
10071 PL_bitcount = Nullch; /* reinits on demand */
10073 if (proto_perl->Ipsig_pend) {
10074 Newz(0, PL_psig_pend, SIG_SIZE, int);
10077 PL_psig_pend = (int*)NULL;
10080 if (proto_perl->Ipsig_ptr) {
10081 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10082 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10083 for (i = 1; i < SIG_SIZE; i++) {
10084 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10085 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10089 PL_psig_ptr = (SV**)NULL;
10090 PL_psig_name = (SV**)NULL;
10093 /* thrdvar.h stuff */
10095 if (flags & CLONEf_COPY_STACKS) {
10096 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10097 PL_tmps_ix = proto_perl->Ttmps_ix;
10098 PL_tmps_max = proto_perl->Ttmps_max;
10099 PL_tmps_floor = proto_perl->Ttmps_floor;
10100 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10102 while (i <= PL_tmps_ix) {
10103 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10107 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10108 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10109 Newz(54, PL_markstack, i, I32);
10110 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10111 - proto_perl->Tmarkstack);
10112 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10113 - proto_perl->Tmarkstack);
10114 Copy(proto_perl->Tmarkstack, PL_markstack,
10115 PL_markstack_ptr - PL_markstack + 1, I32);
10117 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10118 * NOTE: unlike the others! */
10119 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10120 PL_scopestack_max = proto_perl->Tscopestack_max;
10121 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10122 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10124 /* next push_return() sets PL_retstack[PL_retstack_ix]
10125 * NOTE: unlike the others! */
10126 PL_retstack_ix = proto_perl->Tretstack_ix;
10127 PL_retstack_max = proto_perl->Tretstack_max;
10128 Newz(54, PL_retstack, PL_retstack_max, OP*);
10129 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10131 /* NOTE: si_dup() looks at PL_markstack */
10132 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10134 /* PL_curstack = PL_curstackinfo->si_stack; */
10135 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10136 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10138 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10139 PL_stack_base = AvARRAY(PL_curstack);
10140 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10141 - proto_perl->Tstack_base);
10142 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10144 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10145 * NOTE: unlike the others! */
10146 PL_savestack_ix = proto_perl->Tsavestack_ix;
10147 PL_savestack_max = proto_perl->Tsavestack_max;
10148 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10149 PL_savestack = ss_dup(proto_perl, param);
10153 ENTER; /* perl_destruct() wants to LEAVE; */
10156 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10157 PL_top_env = &PL_start_env;
10159 PL_op = proto_perl->Top;
10162 PL_Xpv = (XPV*)NULL;
10163 PL_na = proto_perl->Tna;
10165 PL_statbuf = proto_perl->Tstatbuf;
10166 PL_statcache = proto_perl->Tstatcache;
10167 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10168 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10170 PL_timesbuf = proto_perl->Ttimesbuf;
10173 PL_tainted = proto_perl->Ttainted;
10174 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10175 PL_nrs = sv_dup_inc(proto_perl->Tnrs, param);
10176 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10177 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10178 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10179 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10180 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10181 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10182 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10183 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10185 PL_restartop = proto_perl->Trestartop;
10186 PL_in_eval = proto_perl->Tin_eval;
10187 PL_delaymagic = proto_perl->Tdelaymagic;
10188 PL_dirty = proto_perl->Tdirty;
10189 PL_localizing = proto_perl->Tlocalizing;
10191 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10192 PL_protect = proto_perl->Tprotect;
10194 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10195 PL_av_fetch_sv = Nullsv;
10196 PL_hv_fetch_sv = Nullsv;
10197 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10198 PL_modcount = proto_perl->Tmodcount;
10199 PL_lastgotoprobe = Nullop;
10200 PL_dumpindent = proto_perl->Tdumpindent;
10202 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10203 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10204 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10205 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10206 PL_sortcxix = proto_perl->Tsortcxix;
10207 PL_efloatbuf = Nullch; /* reinits on demand */
10208 PL_efloatsize = 0; /* reinits on demand */
10212 PL_screamfirst = NULL;
10213 PL_screamnext = NULL;
10214 PL_maxscream = -1; /* reinits on demand */
10215 PL_lastscream = Nullsv;
10217 PL_watchaddr = NULL;
10218 PL_watchok = Nullch;
10220 PL_regdummy = proto_perl->Tregdummy;
10221 PL_regcomp_parse = Nullch;
10222 PL_regxend = Nullch;
10223 PL_regcode = (regnode*)NULL;
10226 PL_regprecomp = Nullch;
10231 PL_seen_zerolen = 0;
10233 PL_regcomp_rx = (regexp*)NULL;
10235 PL_colorset = 0; /* reinits PL_colors[] */
10236 /*PL_colors[6] = {0,0,0,0,0,0};*/
10237 PL_reg_whilem_seen = 0;
10238 PL_reginput = Nullch;
10239 PL_regbol = Nullch;
10240 PL_regeol = Nullch;
10241 PL_regstartp = (I32*)NULL;
10242 PL_regendp = (I32*)NULL;
10243 PL_reglastparen = (U32*)NULL;
10244 PL_regtill = Nullch;
10245 PL_reg_start_tmp = (char**)NULL;
10246 PL_reg_start_tmpl = 0;
10247 PL_regdata = (struct reg_data*)NULL;
10250 PL_reg_eval_set = 0;
10252 PL_regprogram = (regnode*)NULL;
10254 PL_regcc = (CURCUR*)NULL;
10255 PL_reg_call_cc = (struct re_cc_state*)NULL;
10256 PL_reg_re = (regexp*)NULL;
10257 PL_reg_ganch = Nullch;
10258 PL_reg_sv = Nullsv;
10259 PL_reg_magic = (MAGIC*)NULL;
10261 PL_reg_oldcurpm = (PMOP*)NULL;
10262 PL_reg_curpm = (PMOP*)NULL;
10263 PL_reg_oldsaved = Nullch;
10264 PL_reg_oldsavedlen = 0;
10265 PL_reg_maxiter = 0;
10266 PL_reg_leftiter = 0;
10267 PL_reg_poscache = Nullch;
10268 PL_reg_poscache_size= 0;
10270 /* RE engine - function pointers */
10271 PL_regcompp = proto_perl->Tregcompp;
10272 PL_regexecp = proto_perl->Tregexecp;
10273 PL_regint_start = proto_perl->Tregint_start;
10274 PL_regint_string = proto_perl->Tregint_string;
10275 PL_regfree = proto_perl->Tregfree;
10277 PL_reginterp_cnt = 0;
10278 PL_reg_starttry = 0;
10280 /* Pluggable optimizer */
10281 PL_peepp = proto_perl->Tpeepp;
10283 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10284 ptr_table_free(PL_ptr_table);
10285 PL_ptr_table = NULL;
10288 /* Call the ->CLONE method, if it exists, for each of the stashes
10289 identified by sv_dup() above.
10291 while(av_len(param->stashes) != -1) {
10292 HV* stash = (HV*) av_shift(param->stashes);
10293 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10294 if (cloner && GvCV(cloner)) {
10299 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10301 call_sv((SV*)GvCV(cloner), G_DISCARD);
10307 SvREFCNT_dec(param->stashes);
10311 return (PerlInterpreter*)pPerl;
10317 #else /* !USE_ITHREADS */
10323 #endif /* USE_ITHREADS */