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(%g => %"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(%g => %"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(%g => %"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(%g => %"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 when the current
6054 context ends. See also C<sv_newmortal> and C<sv_2mortal>.
6059 /* Make a string that will exist for the duration of the expression
6060 * evaluation. Actually, it may have to last longer than that, but
6061 * hopefully we won't free it until it has been assigned to a
6062 * permanent location. */
6065 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6070 sv_setsv(sv,oldstr);
6072 PL_tmps_stack[++PL_tmps_ix] = sv;
6078 =for apidoc sv_newmortal
6080 Creates a new null SV which is mortal. The reference count of the SV is
6081 set to 1. It will be destroyed when the current context ends. See
6082 also C<sv_mortalcopy> and C<sv_2mortal>.
6088 Perl_sv_newmortal(pTHX)
6093 SvFLAGS(sv) = SVs_TEMP;
6095 PL_tmps_stack[++PL_tmps_ix] = sv;
6100 =for apidoc sv_2mortal
6102 Marks an existing SV as mortal. The SV will be destroyed when the current
6103 context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
6109 Perl_sv_2mortal(pTHX_ register SV *sv)
6113 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6116 PL_tmps_stack[++PL_tmps_ix] = sv;
6124 Creates a new SV and copies a string into it. The reference count for the
6125 SV is set to 1. If C<len> is zero, Perl will compute the length using
6126 strlen(). For efficiency, consider using C<newSVpvn> instead.
6132 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6139 sv_setpvn(sv,s,len);
6144 =for apidoc newSVpvn
6146 Creates a new SV and copies a string into it. The reference count for the
6147 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6148 string. You are responsible for ensuring that the source string is at least
6155 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6160 sv_setpvn(sv,s,len);
6165 =for apidoc newSVpvn_share
6167 Creates a new SV with its SvPVX pointing to a shared string in the string
6168 table. If the string does not already exist in the table, it is created
6169 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6170 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6171 otherwise the hash is computed. The idea here is that as the string table
6172 is used for shared hash keys these strings will have SvPVX == HeKEY and
6173 hash lookup will avoid string compare.
6179 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6182 bool is_utf8 = FALSE;
6184 STRLEN tmplen = -len;
6186 /* See the note in hv.c:hv_fetch() --jhi */
6187 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6191 PERL_HASH(hash, src, len);
6193 sv_upgrade(sv, SVt_PVIV);
6194 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6207 #if defined(PERL_IMPLICIT_CONTEXT)
6209 /* pTHX_ magic can't cope with varargs, so this is a no-context
6210 * version of the main function, (which may itself be aliased to us).
6211 * Don't access this version directly.
6215 Perl_newSVpvf_nocontext(const char* pat, ...)
6220 va_start(args, pat);
6221 sv = vnewSVpvf(pat, &args);
6228 =for apidoc newSVpvf
6230 Creates a new SV and initializes it with the string formatted like
6237 Perl_newSVpvf(pTHX_ const char* pat, ...)
6241 va_start(args, pat);
6242 sv = vnewSVpvf(pat, &args);
6247 /* backend for newSVpvf() and newSVpvf_nocontext() */
6250 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6254 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6261 Creates a new SV and copies a floating point value into it.
6262 The reference count for the SV is set to 1.
6268 Perl_newSVnv(pTHX_ NV n)
6280 Creates a new SV and copies an integer into it. The reference count for the
6287 Perl_newSViv(pTHX_ IV i)
6299 Creates a new SV and copies an unsigned integer into it.
6300 The reference count for the SV is set to 1.
6306 Perl_newSVuv(pTHX_ UV u)
6316 =for apidoc newRV_noinc
6318 Creates an RV wrapper for an SV. The reference count for the original
6319 SV is B<not> incremented.
6325 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6330 sv_upgrade(sv, SVt_RV);
6337 /* newRV_inc is the official function name to use now.
6338 * newRV_inc is in fact #defined to newRV in sv.h
6342 Perl_newRV(pTHX_ SV *tmpRef)
6344 return newRV_noinc(SvREFCNT_inc(tmpRef));
6350 Creates a new SV which is an exact duplicate of the original SV.
6357 Perl_newSVsv(pTHX_ register SV *old)
6363 if (SvTYPE(old) == SVTYPEMASK) {
6364 if (ckWARN_d(WARN_INTERNAL))
6365 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6380 =for apidoc sv_reset
6382 Underlying implementation for the C<reset> Perl function.
6383 Note that the perl-level function is vaguely deprecated.
6389 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6397 char todo[PERL_UCHAR_MAX+1];
6402 if (!*s) { /* reset ?? searches */
6403 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6404 pm->op_pmdynflags &= ~PMdf_USED;
6409 /* reset variables */
6411 if (!HvARRAY(stash))
6414 Zero(todo, 256, char);
6416 i = (unsigned char)*s;
6420 max = (unsigned char)*s++;
6421 for ( ; i <= max; i++) {
6424 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6425 for (entry = HvARRAY(stash)[i];
6427 entry = HeNEXT(entry))
6429 if (!todo[(U8)*HeKEY(entry)])
6431 gv = (GV*)HeVAL(entry);
6433 if (SvTHINKFIRST(sv)) {
6434 if (!SvREADONLY(sv) && SvROK(sv))
6439 if (SvTYPE(sv) >= SVt_PV) {
6441 if (SvPVX(sv) != Nullch)
6448 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6450 #ifdef USE_ENVIRON_ARRAY
6452 environ[0] = Nullch;
6463 Using various gambits, try to get an IO from an SV: the IO slot if its a
6464 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6465 named after the PV if we're a string.
6471 Perl_sv_2io(pTHX_ SV *sv)
6477 switch (SvTYPE(sv)) {
6485 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6489 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6491 return sv_2io(SvRV(sv));
6492 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6498 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6507 Using various gambits, try to get a CV from an SV; in addition, try if
6508 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6514 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6521 return *gvp = Nullgv, Nullcv;
6522 switch (SvTYPE(sv)) {
6541 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6542 tryAMAGICunDEREF(to_cv);
6545 if (SvTYPE(sv) == SVt_PVCV) {
6554 Perl_croak(aTHX_ "Not a subroutine reference");
6559 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6565 if (lref && !GvCVu(gv)) {
6568 tmpsv = NEWSV(704,0);
6569 gv_efullname3(tmpsv, gv, Nullch);
6570 /* XXX this is probably not what they think they're getting.
6571 * It has the same effect as "sub name;", i.e. just a forward
6573 newSUB(start_subparse(FALSE, 0),
6574 newSVOP(OP_CONST, 0, tmpsv),
6579 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6588 Returns true if the SV has a true value by Perl's rules.
6589 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6590 instead use an in-line version.
6596 Perl_sv_true(pTHX_ register SV *sv)
6602 if ((tXpv = (XPV*)SvANY(sv)) &&
6603 (tXpv->xpv_cur > 1 ||
6604 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6611 return SvIVX(sv) != 0;
6614 return SvNVX(sv) != 0.0;
6616 return sv_2bool(sv);
6624 A private implementation of the C<SvIVx> macro for compilers which can't
6625 cope with complex macro expressions. Always use the macro instead.
6631 Perl_sv_iv(pTHX_ register SV *sv)
6635 return (IV)SvUVX(sv);
6644 A private implementation of the C<SvUVx> macro for compilers which can't
6645 cope with complex macro expressions. Always use the macro instead.
6651 Perl_sv_uv(pTHX_ register SV *sv)
6656 return (UV)SvIVX(sv);
6664 A private implementation of the C<SvNVx> macro for compilers which can't
6665 cope with complex macro expressions. Always use the macro instead.
6671 Perl_sv_nv(pTHX_ register SV *sv)
6681 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6682 cope with complex macro expressions. Always use the macro instead.
6688 Perl_sv_pv(pTHX_ SV *sv)
6695 return sv_2pv(sv, &n_a);
6701 A private implementation of the C<SvPV> macro for compilers which can't
6702 cope with complex macro expressions. Always use the macro instead.
6708 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6714 return sv_2pv(sv, lp);
6718 =for apidoc sv_pvn_force
6720 Get a sensible string out of the SV somehow.
6721 A private implementation of the C<SvPV_force> macro for compilers which
6722 can't cope with complex macro expressions. Always use the macro instead.
6728 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6730 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6734 =for apidoc sv_pvn_force_flags
6736 Get a sensible string out of the SV somehow.
6737 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6738 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6739 implemented in terms of this function.
6740 You normally want to use the various wrapper macros instead: see
6741 C<SvPV_force> and C<SvPV_force_nomg>
6747 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6751 if (SvTHINKFIRST(sv) && !SvROK(sv))
6752 sv_force_normal(sv);
6758 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6759 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6760 PL_op_name[PL_op->op_type]);
6763 s = sv_2pv_flags(sv, lp, flags);
6764 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6769 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6770 SvGROW(sv, len + 1);
6771 Move(s,SvPVX(sv),len,char);
6776 SvPOK_on(sv); /* validate pointer */
6778 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6779 PTR2UV(sv),SvPVX(sv)));
6786 =for apidoc sv_pvbyte
6788 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6789 which can't cope with complex macro expressions. Always use the macro
6796 Perl_sv_pvbyte(pTHX_ SV *sv)
6798 sv_utf8_downgrade(sv,0);
6803 =for apidoc sv_pvbyten
6805 A private implementation of the C<SvPVbyte> macro for compilers
6806 which can't cope with complex macro expressions. Always use the macro
6813 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6815 sv_utf8_downgrade(sv,0);
6816 return sv_pvn(sv,lp);
6820 =for apidoc sv_pvbyten_force
6822 A private implementation of the C<SvPVbytex_force> macro for compilers
6823 which can't cope with complex macro expressions. Always use the macro
6830 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6832 sv_utf8_downgrade(sv,0);
6833 return sv_pvn_force(sv,lp);
6837 =for apidoc sv_pvutf8
6839 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6840 which can't cope with complex macro expressions. Always use the macro
6847 Perl_sv_pvutf8(pTHX_ SV *sv)
6849 sv_utf8_upgrade(sv);
6854 =for apidoc sv_pvutf8n
6856 A private implementation of the C<SvPVutf8> macro for compilers
6857 which can't cope with complex macro expressions. Always use the macro
6864 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6866 sv_utf8_upgrade(sv);
6867 return sv_pvn(sv,lp);
6871 =for apidoc sv_pvutf8n_force
6873 A private implementation of the C<SvPVutf8_force> macro for compilers
6874 which can't cope with complex macro expressions. Always use the macro
6881 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6883 sv_utf8_upgrade(sv);
6884 return sv_pvn_force(sv,lp);
6888 =for apidoc sv_reftype
6890 Returns a string describing what the SV is a reference to.
6896 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6898 if (ob && SvOBJECT(sv))
6899 return HvNAME(SvSTASH(sv));
6901 switch (SvTYPE(sv)) {
6915 case SVt_PVLV: return "LVALUE";
6916 case SVt_PVAV: return "ARRAY";
6917 case SVt_PVHV: return "HASH";
6918 case SVt_PVCV: return "CODE";
6919 case SVt_PVGV: return "GLOB";
6920 case SVt_PVFM: return "FORMAT";
6921 case SVt_PVIO: return "IO";
6922 default: return "UNKNOWN";
6928 =for apidoc sv_isobject
6930 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6931 object. If the SV is not an RV, or if the object is not blessed, then this
6938 Perl_sv_isobject(pTHX_ SV *sv)
6955 Returns a boolean indicating whether the SV is blessed into the specified
6956 class. This does not check for subtypes; use C<sv_derived_from> to verify
6957 an inheritance relationship.
6963 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6975 return strEQ(HvNAME(SvSTASH(sv)), name);
6981 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6982 it will be upgraded to one. If C<classname> is non-null then the new SV will
6983 be blessed in the specified package. The new SV is returned and its
6984 reference count is 1.
6990 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6996 SV_CHECK_THINKFIRST(rv);
6999 if (SvTYPE(rv) >= SVt_PVMG) {
7000 U32 refcnt = SvREFCNT(rv);
7004 SvREFCNT(rv) = refcnt;
7007 if (SvTYPE(rv) < SVt_RV)
7008 sv_upgrade(rv, SVt_RV);
7009 else if (SvTYPE(rv) > SVt_RV) {
7010 (void)SvOOK_off(rv);
7011 if (SvPVX(rv) && SvLEN(rv))
7012 Safefree(SvPVX(rv));
7022 HV* stash = gv_stashpv(classname, TRUE);
7023 (void)sv_bless(rv, stash);
7029 =for apidoc sv_setref_pv
7031 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7032 argument will be upgraded to an RV. That RV will be modified to point to
7033 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7034 into the SV. The C<classname> argument indicates the package for the
7035 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7036 will be returned and will have a reference count of 1.
7038 Do not use with other Perl types such as HV, AV, SV, CV, because those
7039 objects will become corrupted by the pointer copy process.
7041 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7047 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7050 sv_setsv(rv, &PL_sv_undef);
7054 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7059 =for apidoc sv_setref_iv
7061 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7062 argument will be upgraded to an RV. That RV will be modified to point to
7063 the new SV. The C<classname> argument indicates the package for the
7064 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7065 will be returned and will have a reference count of 1.
7071 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7073 sv_setiv(newSVrv(rv,classname), iv);
7078 =for apidoc sv_setref_uv
7080 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7081 argument will be upgraded to an RV. That RV will be modified to point to
7082 the new SV. The C<classname> argument indicates the package for the
7083 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7084 will be returned and will have a reference count of 1.
7090 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7092 sv_setuv(newSVrv(rv,classname), uv);
7097 =for apidoc sv_setref_nv
7099 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7100 argument will be upgraded to an RV. That RV will be modified to point to
7101 the new SV. The C<classname> argument indicates the package for the
7102 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7103 will be returned and will have a reference count of 1.
7109 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7111 sv_setnv(newSVrv(rv,classname), nv);
7116 =for apidoc sv_setref_pvn
7118 Copies a string into a new SV, optionally blessing the SV. The length of the
7119 string must be specified with C<n>. The C<rv> argument will be upgraded to
7120 an RV. That RV will be modified to point to the new SV. The C<classname>
7121 argument indicates the package for the blessing. Set C<classname> to
7122 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7123 a reference count of 1.
7125 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7131 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7133 sv_setpvn(newSVrv(rv,classname), pv, n);
7138 =for apidoc sv_bless
7140 Blesses an SV into a specified package. The SV must be an RV. The package
7141 must be designated by its stash (see C<gv_stashpv()>). The reference count
7142 of the SV is unaffected.
7148 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7152 Perl_croak(aTHX_ "Can't bless non-reference value");
7154 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7155 if (SvREADONLY(tmpRef))
7156 Perl_croak(aTHX_ PL_no_modify);
7157 if (SvOBJECT(tmpRef)) {
7158 if (SvTYPE(tmpRef) != SVt_PVIO)
7160 SvREFCNT_dec(SvSTASH(tmpRef));
7163 SvOBJECT_on(tmpRef);
7164 if (SvTYPE(tmpRef) != SVt_PVIO)
7166 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7167 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7177 /* Downgrades a PVGV to a PVMG.
7179 * XXX This function doesn't actually appear to be used anywhere
7184 S_sv_unglob(pTHX_ SV *sv)
7188 assert(SvTYPE(sv) == SVt_PVGV);
7193 SvREFCNT_dec(GvSTASH(sv));
7194 GvSTASH(sv) = Nullhv;
7196 sv_unmagic(sv, PERL_MAGIC_glob);
7197 Safefree(GvNAME(sv));
7200 /* need to keep SvANY(sv) in the right arena */
7201 xpvmg = new_XPVMG();
7202 StructCopy(SvANY(sv), xpvmg, XPVMG);
7203 del_XPVGV(SvANY(sv));
7206 SvFLAGS(sv) &= ~SVTYPEMASK;
7207 SvFLAGS(sv) |= SVt_PVMG;
7211 =for apidoc sv_unref_flags
7213 Unsets the RV status of the SV, and decrements the reference count of
7214 whatever was being referenced by the RV. This can almost be thought of
7215 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7216 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7217 (otherwise the decrementing is conditional on the reference count being
7218 different from one or the reference being a readonly SV).
7225 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7229 if (SvWEAKREF(sv)) {
7237 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7239 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7240 sv_2mortal(rv); /* Schedule for freeing later */
7244 =for apidoc sv_unref
7246 Unsets the RV status of the SV, and decrements the reference count of
7247 whatever was being referenced by the RV. This can almost be thought of
7248 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7249 being zero. See C<SvROK_off>.
7255 Perl_sv_unref(pTHX_ SV *sv)
7257 sv_unref_flags(sv, 0);
7261 =for apidoc sv_taint
7263 Taint an SV. Use C<SvTAINTED_on> instead.
7268 Perl_sv_taint(pTHX_ SV *sv)
7270 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7274 =for apidoc sv_untaint
7276 Untaint an SV. Use C<SvTAINTED_off> instead.
7281 Perl_sv_untaint(pTHX_ SV *sv)
7283 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7284 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7291 =for apidoc sv_tainted
7293 Test an SV for taintedness. Use C<SvTAINTED> instead.
7298 Perl_sv_tainted(pTHX_ SV *sv)
7300 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7301 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7302 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7309 =for apidoc sv_setpviv
7311 Copies an integer into the given SV, also updating its string value.
7312 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7318 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7320 char buf[TYPE_CHARS(UV)];
7322 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7324 sv_setpvn(sv, ptr, ebuf - ptr);
7328 =for apidoc sv_setpviv_mg
7330 Like C<sv_setpviv>, but also handles 'set' magic.
7336 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7338 char buf[TYPE_CHARS(UV)];
7340 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7342 sv_setpvn(sv, ptr, ebuf - ptr);
7346 #if defined(PERL_IMPLICIT_CONTEXT)
7348 /* pTHX_ magic can't cope with varargs, so this is a no-context
7349 * version of the main function, (which may itself be aliased to us).
7350 * Don't access this version directly.
7354 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7358 va_start(args, pat);
7359 sv_vsetpvf(sv, pat, &args);
7363 /* pTHX_ magic can't cope with varargs, so this is a no-context
7364 * version of the main function, (which may itself be aliased to us).
7365 * Don't access this version directly.
7369 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7373 va_start(args, pat);
7374 sv_vsetpvf_mg(sv, pat, &args);
7380 =for apidoc sv_setpvf
7382 Processes its arguments like C<sprintf> and sets an SV to the formatted
7383 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7389 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7392 va_start(args, pat);
7393 sv_vsetpvf(sv, pat, &args);
7397 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7400 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7402 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7406 =for apidoc sv_setpvf_mg
7408 Like C<sv_setpvf>, but also handles 'set' magic.
7414 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7417 va_start(args, pat);
7418 sv_vsetpvf_mg(sv, pat, &args);
7422 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7425 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7427 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7431 #if defined(PERL_IMPLICIT_CONTEXT)
7433 /* pTHX_ magic can't cope with varargs, so this is a no-context
7434 * version of the main function, (which may itself be aliased to us).
7435 * Don't access this version directly.
7439 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7443 va_start(args, pat);
7444 sv_vcatpvf(sv, pat, &args);
7448 /* pTHX_ magic can't cope with varargs, so this is a no-context
7449 * version of the main function, (which may itself be aliased to us).
7450 * Don't access this version directly.
7454 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7458 va_start(args, pat);
7459 sv_vcatpvf_mg(sv, pat, &args);
7465 =for apidoc sv_catpvf
7467 Processes its arguments like C<sprintf> and appends the formatted
7468 output to an SV. If the appended data contains "wide" characters
7469 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7470 and characters >255 formatted with %c), the original SV might get
7471 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7472 C<SvSETMAGIC()> must typically be called after calling this function
7473 to handle 'set' magic.
7478 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7481 va_start(args, pat);
7482 sv_vcatpvf(sv, pat, &args);
7486 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7489 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7491 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7495 =for apidoc sv_catpvf_mg
7497 Like C<sv_catpvf>, but also handles 'set' magic.
7503 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7506 va_start(args, pat);
7507 sv_vcatpvf_mg(sv, pat, &args);
7511 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7514 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7516 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7521 =for apidoc sv_vsetpvfn
7523 Works like C<vcatpvfn> but copies the text into the SV instead of
7526 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7532 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7534 sv_setpvn(sv, "", 0);
7535 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7538 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7541 S_expect_number(pTHX_ char** pattern)
7544 switch (**pattern) {
7545 case '1': case '2': case '3':
7546 case '4': case '5': case '6':
7547 case '7': case '8': case '9':
7548 while (isDIGIT(**pattern))
7549 var = var * 10 + (*(*pattern)++ - '0');
7553 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7556 =for apidoc sv_vcatpvfn
7558 Processes its arguments like C<vsprintf> and appends the formatted output
7559 to an SV. Uses an array of SVs if the C style variable argument list is
7560 missing (NULL). When running with taint checks enabled, indicates via
7561 C<maybe_tainted> if results are untrustworthy (often due to the use of
7564 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7570 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7577 static char nullstr[] = "(null)";
7580 /* no matter what, this is a string now */
7581 (void)SvPV_force(sv, origlen);
7583 /* special-case "", "%s", and "%_" */
7586 if (patlen == 2 && pat[0] == '%') {
7590 char *s = va_arg(*args, char*);
7591 sv_catpv(sv, s ? s : nullstr);
7593 else if (svix < svmax) {
7594 sv_catsv(sv, *svargs);
7595 if (DO_UTF8(*svargs))
7601 argsv = va_arg(*args, SV*);
7602 sv_catsv(sv, argsv);
7607 /* See comment on '_' below */
7612 patend = (char*)pat + patlen;
7613 for (p = (char*)pat; p < patend; p = q) {
7616 bool vectorize = FALSE;
7617 bool vectorarg = FALSE;
7618 bool vec_utf = FALSE;
7624 bool has_precis = FALSE;
7626 bool is_utf = FALSE;
7629 U8 utf8buf[UTF8_MAXLEN+1];
7630 STRLEN esignlen = 0;
7632 char *eptr = Nullch;
7634 /* Times 4: a decimal digit takes more than 3 binary digits.
7635 * NV_DIG: mantissa takes than many decimal digits.
7636 * Plus 32: Playing safe. */
7637 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7638 /* large enough for "%#.#f" --chip */
7639 /* what about long double NVs? --jhi */
7642 U8 *vecstr = Null(U8*);
7654 STRLEN dotstrlen = 1;
7655 I32 efix = 0; /* explicit format parameter index */
7656 I32 ewix = 0; /* explicit width index */
7657 I32 epix = 0; /* explicit precision index */
7658 I32 evix = 0; /* explicit vector index */
7659 bool asterisk = FALSE;
7661 /* echo everything up to the next format specification */
7662 for (q = p; q < patend && *q != '%'; ++q) ;
7664 sv_catpvn(sv, p, q - p);
7671 We allow format specification elements in this order:
7672 \d+\$ explicit format parameter index
7674 \*?(\d+\$)?v vector with optional (optionally specified) arg
7675 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7676 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7678 [%bcdefginopsux_DFOUX] format (mandatory)
7680 if (EXPECT_NUMBER(q, width)) {
7721 if (EXPECT_NUMBER(q, ewix))
7730 if ((vectorarg = asterisk)) {
7740 EXPECT_NUMBER(q, width);
7745 vecsv = va_arg(*args, SV*);
7747 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7748 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7749 dotstr = SvPVx(vecsv, dotstrlen);
7754 vecsv = va_arg(*args, SV*);
7755 vecstr = (U8*)SvPVx(vecsv,veclen);
7756 vec_utf = DO_UTF8(vecsv);
7758 else if (efix ? efix <= svmax : svix < svmax) {
7759 vecsv = svargs[efix ? efix-1 : svix++];
7760 vecstr = (U8*)SvPVx(vecsv,veclen);
7761 vec_utf = DO_UTF8(vecsv);
7771 i = va_arg(*args, int);
7773 i = (ewix ? ewix <= svmax : svix < svmax) ?
7774 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7776 width = (i < 0) ? -i : i;
7786 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7789 i = va_arg(*args, int);
7791 i = (ewix ? ewix <= svmax : svix < svmax)
7792 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7793 precis = (i < 0) ? 0 : i;
7798 precis = precis * 10 + (*q++ - '0');
7806 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7817 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7818 if (*(q + 1) == 'l') { /* lld, llf */
7841 argsv = (efix ? efix <= svmax : svix < svmax) ?
7842 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7849 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7851 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7853 eptr = (char*)utf8buf;
7854 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7866 eptr = va_arg(*args, char*);
7868 #ifdef MACOS_TRADITIONAL
7869 /* On MacOS, %#s format is used for Pascal strings */
7874 elen = strlen(eptr);
7877 elen = sizeof nullstr - 1;
7881 eptr = SvPVx(argsv, elen);
7882 if (DO_UTF8(argsv)) {
7883 if (has_precis && precis < elen) {
7885 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7888 if (width) { /* fudge width (can't fudge elen) */
7889 width += elen - sv_len_utf8(argsv);
7898 * The "%_" hack might have to be changed someday,
7899 * if ISO or ANSI decide to use '_' for something.
7900 * So we keep it hidden from users' code.
7904 argsv = va_arg(*args, SV*);
7905 eptr = SvPVx(argsv, elen);
7911 if (has_precis && elen > precis)
7920 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7938 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7948 case 'h': iv = (short)va_arg(*args, int); break;
7949 default: iv = va_arg(*args, int); break;
7950 case 'l': iv = va_arg(*args, long); break;
7951 case 'V': iv = va_arg(*args, IV); break;
7953 case 'q': iv = va_arg(*args, Quad_t); break;
7960 case 'h': iv = (short)iv; break;
7962 case 'l': iv = (long)iv; break;
7965 case 'q': iv = (Quad_t)iv; break;
7972 esignbuf[esignlen++] = plus;
7976 esignbuf[esignlen++] = '-';
8018 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
8028 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8029 default: uv = va_arg(*args, unsigned); break;
8030 case 'l': uv = va_arg(*args, unsigned long); break;
8031 case 'V': uv = va_arg(*args, UV); break;
8033 case 'q': uv = va_arg(*args, Quad_t); break;
8040 case 'h': uv = (unsigned short)uv; break;
8042 case 'l': uv = (unsigned long)uv; break;
8045 case 'q': uv = (Quad_t)uv; break;
8051 eptr = ebuf + sizeof ebuf;
8057 p = (char*)((c == 'X')
8058 ? "0123456789ABCDEF" : "0123456789abcdef");
8064 esignbuf[esignlen++] = '0';
8065 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8071 *--eptr = '0' + dig;
8073 if (alt && *eptr != '0')
8079 *--eptr = '0' + dig;
8082 esignbuf[esignlen++] = '0';
8083 esignbuf[esignlen++] = 'b';
8086 default: /* it had better be ten or less */
8087 #if defined(PERL_Y2KWARN)
8088 if (ckWARN(WARN_Y2K)) {
8090 char *s = SvPV(sv,n);
8091 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8092 && (n == 2 || !isDIGIT(s[n-3])))
8094 Perl_warner(aTHX_ WARN_Y2K,
8095 "Possible Y2K bug: %%%c %s",
8096 c, "format string following '19'");
8102 *--eptr = '0' + dig;
8103 } while (uv /= base);
8106 elen = (ebuf + sizeof ebuf) - eptr;
8109 zeros = precis - elen;
8110 else if (precis == 0 && elen == 1 && *eptr == '0')
8115 /* FLOATING POINT */
8118 c = 'f'; /* maybe %F isn't supported here */
8124 /* This is evil, but floating point is even more evil */
8127 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8130 if (c != 'e' && c != 'E') {
8132 (void)Perl_frexp(nv, &i);
8133 if (i == PERL_INT_MIN)
8134 Perl_die(aTHX_ "panic: frexp");
8136 need = BIT_DIGITS(i);
8138 need += has_precis ? precis : 6; /* known default */
8142 need += 20; /* fudge factor */
8143 if (PL_efloatsize < need) {
8144 Safefree(PL_efloatbuf);
8145 PL_efloatsize = need + 20; /* more fudge */
8146 New(906, PL_efloatbuf, PL_efloatsize, char);
8147 PL_efloatbuf[0] = '\0';
8150 eptr = ebuf + sizeof ebuf;
8153 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8155 /* Copy the one or more characters in a long double
8156 * format before the 'base' ([efgEFG]) character to
8157 * the format string. */
8158 static char const prifldbl[] = PERL_PRIfldbl;
8159 char const *p = prifldbl + sizeof(prifldbl) - 3;
8160 while (p >= prifldbl) { *--eptr = *p--; }
8165 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8170 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8182 /* No taint. Otherwise we are in the strange situation
8183 * where printf() taints but print($float) doesn't.
8185 (void)sprintf(PL_efloatbuf, eptr, nv);
8187 eptr = PL_efloatbuf;
8188 elen = strlen(PL_efloatbuf);
8195 i = SvCUR(sv) - origlen;
8198 case 'h': *(va_arg(*args, short*)) = i; break;
8199 default: *(va_arg(*args, int*)) = i; break;
8200 case 'l': *(va_arg(*args, long*)) = i; break;
8201 case 'V': *(va_arg(*args, IV*)) = i; break;
8203 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8208 sv_setuv_mg(argsv, (UV)i);
8209 continue; /* not "break" */
8216 if (!args && ckWARN(WARN_PRINTF) &&
8217 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8218 SV *msg = sv_newmortal();
8219 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8220 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8223 Perl_sv_catpvf(aTHX_ msg,
8224 "\"%%%c\"", c & 0xFF);
8226 Perl_sv_catpvf(aTHX_ msg,
8227 "\"%%\\%03"UVof"\"",
8230 sv_catpv(msg, "end of string");
8231 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8234 /* output mangled stuff ... */
8240 /* ... right here, because formatting flags should not apply */
8241 SvGROW(sv, SvCUR(sv) + elen + 1);
8243 Copy(eptr, p, elen, char);
8246 SvCUR(sv) = p - SvPVX(sv);
8247 continue; /* not "break" */
8250 have = esignlen + zeros + elen;
8251 need = (have > width ? have : width);
8254 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8256 if (esignlen && fill == '0') {
8257 for (i = 0; i < esignlen; i++)
8261 memset(p, fill, gap);
8264 if (esignlen && fill != '0') {
8265 for (i = 0; i < esignlen; i++)
8269 for (i = zeros; i; i--)
8273 Copy(eptr, p, elen, char);
8277 memset(p, ' ', gap);
8282 Copy(dotstr, p, dotstrlen, char);
8286 vectorize = FALSE; /* done iterating over vecstr */
8291 SvCUR(sv) = p - SvPVX(sv);
8299 /* =========================================================================
8301 =head1 Cloning an interpreter
8303 All the macros and functions in this section are for the private use of
8304 the main function, perl_clone().
8306 The foo_dup() functions make an exact copy of an existing foo thinngy.
8307 During the course of a cloning, a hash table is used to map old addresses
8308 to new addresses. The table is created and manipulated with the
8309 ptr_table_* functions.
8313 ============================================================================*/
8316 #if defined(USE_ITHREADS)
8318 #if defined(USE_THREADS)
8319 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
8322 #ifndef GpREFCNT_inc
8323 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8327 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8328 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8329 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8330 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8331 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8332 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8333 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8334 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8335 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8336 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8337 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8338 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8339 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8342 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8343 regcomp.c. AMS 20010712 */
8346 Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
8350 struct reg_substr_datum *s;
8353 return (REGEXP *)NULL;
8355 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8358 len = r->offsets[0];
8359 npar = r->nparens+1;
8361 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8362 Copy(r->program, ret->program, len+1, regnode);
8364 New(0, ret->startp, npar, I32);
8365 Copy(r->startp, ret->startp, npar, I32);
8366 New(0, ret->endp, npar, I32);
8367 Copy(r->startp, ret->startp, npar, I32);
8369 if (r->regstclass) {
8370 New(0, ret->regstclass, 1, regnode);
8371 StructCopy(r->regstclass, ret->regstclass, regnode);
8374 ret->regstclass = NULL;
8376 New(0, ret->substrs, 1, struct reg_substr_data);
8377 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8378 s->min_offset = r->substrs->data[i].min_offset;
8379 s->max_offset = r->substrs->data[i].max_offset;
8380 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8385 int count = r->data->count;
8387 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8388 char, struct reg_data);
8389 New(0, d->what, count, U8);
8392 for (i = 0; i < count; i++) {
8393 d->what[i] = r->data->what[i];
8394 switch (d->what[i]) {
8396 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8399 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8402 /* This is cheating. */
8403 New(0, d->data[i], 1, struct regnode_charclass_class);
8404 StructCopy(r->data->data[i], d->data[i],
8405 struct regnode_charclass_class);
8409 d->data[i] = r->data->data[i];
8419 New(0, ret->offsets, 2*len+1, U32);
8420 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8422 ret->precomp = SAVEPV(r->precomp);
8423 ret->subbeg = SAVEPV(r->subbeg);
8424 ret->sublen = r->sublen;
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 ptr_table_store(PL_ptr_table, r, ret);
8437 /* duplicate a file handle */
8440 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
8444 return (PerlIO*)NULL;
8446 /* look for it in the table first */
8447 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8451 /* create anew and remember what it is */
8452 ret = PerlIO_fdupopen(aTHX_ fp);
8453 ptr_table_store(PL_ptr_table, fp, ret);
8457 /* duplicate a directory handle */
8460 Perl_dirp_dup(pTHX_ DIR *dp)
8468 /* duplicate a typeglob */
8471 Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
8476 /* look for it in the table first */
8477 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8481 /* create anew and remember what it is */
8482 Newz(0, ret, 1, GP);
8483 ptr_table_store(PL_ptr_table, gp, ret);
8486 ret->gp_refcnt = 0; /* must be before any other dups! */
8487 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8488 ret->gp_io = io_dup_inc(gp->gp_io, param);
8489 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8490 ret->gp_av = av_dup_inc(gp->gp_av, param);
8491 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8492 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8493 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8494 ret->gp_cvgen = gp->gp_cvgen;
8495 ret->gp_flags = gp->gp_flags;
8496 ret->gp_line = gp->gp_line;
8497 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8501 /* duplicate a chain of magic */
8504 Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
8506 MAGIC *mgprev = (MAGIC*)NULL;
8509 return (MAGIC*)NULL;
8510 /* look for it in the table first */
8511 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8515 for (; mg; mg = mg->mg_moremagic) {
8517 Newz(0, nmg, 1, MAGIC);
8519 mgprev->mg_moremagic = nmg;
8522 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8523 nmg->mg_private = mg->mg_private;
8524 nmg->mg_type = mg->mg_type;
8525 nmg->mg_flags = mg->mg_flags;
8526 if (mg->mg_type == PERL_MAGIC_qr) {
8527 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8529 else if(mg->mg_type == PERL_MAGIC_backref) {
8530 AV *av = (AV*) mg->mg_obj;
8533 nmg->mg_obj = (SV*)newAV();
8537 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8542 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8543 ? sv_dup_inc(mg->mg_obj, param)
8544 : sv_dup(mg->mg_obj, param);
8546 nmg->mg_len = mg->mg_len;
8547 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8548 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8549 if (mg->mg_len >= 0) {
8550 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8551 if (mg->mg_type == PERL_MAGIC_overload_table &&
8552 AMT_AMAGIC((AMT*)mg->mg_ptr))
8554 AMT *amtp = (AMT*)mg->mg_ptr;
8555 AMT *namtp = (AMT*)nmg->mg_ptr;
8557 for (i = 1; i < NofAMmeth; i++) {
8558 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8562 else if (mg->mg_len == HEf_SVKEY)
8563 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8570 /* create a new pointer-mapping table */
8573 Perl_ptr_table_new(pTHX)
8576 Newz(0, tbl, 1, PTR_TBL_t);
8579 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8583 /* map an existing pointer using a table */
8586 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8588 PTR_TBL_ENT_t *tblent;
8589 UV hash = PTR2UV(sv);
8591 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8592 for (; tblent; tblent = tblent->next) {
8593 if (tblent->oldval == sv)
8594 return tblent->newval;
8599 /* add a new entry to a pointer-mapping table */
8602 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8604 PTR_TBL_ENT_t *tblent, **otblent;
8605 /* XXX this may be pessimal on platforms where pointers aren't good
8606 * hash values e.g. if they grow faster in the most significant
8608 UV hash = PTR2UV(oldv);
8612 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8613 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8614 if (tblent->oldval == oldv) {
8615 tblent->newval = newv;
8620 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8621 tblent->oldval = oldv;
8622 tblent->newval = newv;
8623 tblent->next = *otblent;
8626 if (i && tbl->tbl_items > tbl->tbl_max)
8627 ptr_table_split(tbl);
8630 /* double the hash bucket size of an existing ptr table */
8633 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8635 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8636 UV oldsize = tbl->tbl_max + 1;
8637 UV newsize = oldsize * 2;
8640 Renew(ary, newsize, PTR_TBL_ENT_t*);
8641 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8642 tbl->tbl_max = --newsize;
8644 for (i=0; i < oldsize; i++, ary++) {
8645 PTR_TBL_ENT_t **curentp, **entp, *ent;
8648 curentp = ary + oldsize;
8649 for (entp = ary, ent = *ary; ent; ent = *entp) {
8650 if ((newsize & PTR2UV(ent->oldval)) != i) {
8652 ent->next = *curentp;
8662 /* remove all the entries from a ptr table */
8665 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8667 register PTR_TBL_ENT_t **array;
8668 register PTR_TBL_ENT_t *entry;
8669 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8673 if (!tbl || !tbl->tbl_items) {
8677 array = tbl->tbl_ary;
8684 entry = entry->next;
8688 if (++riter > max) {
8691 entry = array[riter];
8698 /* clear and free a ptr table */
8701 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8706 ptr_table_clear(tbl);
8707 Safefree(tbl->tbl_ary);
8715 /* attempt to make everything in the typeglob readonly */
8718 S_gv_share(pTHX_ SV *sstr)
8721 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8723 if (GvIO(gv) || GvFORM(gv)) {
8724 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8726 else if (!GvCV(gv)) {
8730 /* CvPADLISTs cannot be shared */
8731 if (!CvXSUB(GvCV(gv))) {
8736 if (!GvUNIQUE(gv)) {
8738 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8739 HvNAME(GvSTASH(gv)), GvNAME(gv));
8745 * write attempts will die with
8746 * "Modification of a read-only value attempted"
8752 SvREADONLY_on(GvSV(gv));
8759 SvREADONLY_on(GvAV(gv));
8766 SvREADONLY_on(GvAV(gv));
8769 return sstr; /* he_dup() will SvREFCNT_inc() */
8772 /* duplicate an SV of any type (including AV, HV etc) */
8775 Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
8779 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8781 /* look for it in the table first */
8782 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8786 /* create anew and remember what it is */
8788 ptr_table_store(PL_ptr_table, sstr, dstr);
8791 SvFLAGS(dstr) = SvFLAGS(sstr);
8792 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8793 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8796 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8797 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8798 PL_watch_pvx, SvPVX(sstr));
8801 switch (SvTYPE(sstr)) {
8806 SvANY(dstr) = new_XIV();
8807 SvIVX(dstr) = SvIVX(sstr);
8810 SvANY(dstr) = new_XNV();
8811 SvNVX(dstr) = SvNVX(sstr);
8814 SvANY(dstr) = new_XRV();
8815 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8816 ? sv_dup(SvRV(sstr), param)
8817 : sv_dup_inc(SvRV(sstr), param);
8820 SvANY(dstr) = new_XPV();
8821 SvCUR(dstr) = SvCUR(sstr);
8822 SvLEN(dstr) = SvLEN(sstr);
8824 SvRV(dstr) = SvWEAKREF(sstr)
8825 ? sv_dup(SvRV(sstr), param)
8826 : sv_dup_inc(SvRV(sstr), param);
8827 else if (SvPVX(sstr) && SvLEN(sstr))
8828 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8830 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8833 SvANY(dstr) = new_XPVIV();
8834 SvCUR(dstr) = SvCUR(sstr);
8835 SvLEN(dstr) = SvLEN(sstr);
8836 SvIVX(dstr) = SvIVX(sstr);
8838 SvRV(dstr) = SvWEAKREF(sstr)
8839 ? sv_dup(SvRV(sstr), param)
8840 : sv_dup_inc(SvRV(sstr), param);
8841 else if (SvPVX(sstr) && SvLEN(sstr))
8842 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8844 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8847 SvANY(dstr) = new_XPVNV();
8848 SvCUR(dstr) = SvCUR(sstr);
8849 SvLEN(dstr) = SvLEN(sstr);
8850 SvIVX(dstr) = SvIVX(sstr);
8851 SvNVX(dstr) = SvNVX(sstr);
8853 SvRV(dstr) = SvWEAKREF(sstr)
8854 ? sv_dup(SvRV(sstr), param)
8855 : sv_dup_inc(SvRV(sstr), param);
8856 else if (SvPVX(sstr) && SvLEN(sstr))
8857 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8859 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8862 SvANY(dstr) = new_XPVMG();
8863 SvCUR(dstr) = SvCUR(sstr);
8864 SvLEN(dstr) = SvLEN(sstr);
8865 SvIVX(dstr) = SvIVX(sstr);
8866 SvNVX(dstr) = SvNVX(sstr);
8867 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8868 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8870 SvRV(dstr) = SvWEAKREF(sstr)
8871 ? sv_dup(SvRV(sstr), param)
8872 : sv_dup_inc(SvRV(sstr), param);
8873 else if (SvPVX(sstr) && SvLEN(sstr))
8874 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8876 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8879 SvANY(dstr) = new_XPVBM();
8880 SvCUR(dstr) = SvCUR(sstr);
8881 SvLEN(dstr) = SvLEN(sstr);
8882 SvIVX(dstr) = SvIVX(sstr);
8883 SvNVX(dstr) = SvNVX(sstr);
8884 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8885 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8887 SvRV(dstr) = SvWEAKREF(sstr)
8888 ? sv_dup(SvRV(sstr), param)
8889 : sv_dup_inc(SvRV(sstr), param);
8890 else if (SvPVX(sstr) && SvLEN(sstr))
8891 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8893 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8894 BmRARE(dstr) = BmRARE(sstr);
8895 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8896 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8899 SvANY(dstr) = new_XPVLV();
8900 SvCUR(dstr) = SvCUR(sstr);
8901 SvLEN(dstr) = SvLEN(sstr);
8902 SvIVX(dstr) = SvIVX(sstr);
8903 SvNVX(dstr) = SvNVX(sstr);
8904 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8905 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8907 SvRV(dstr) = SvWEAKREF(sstr)
8908 ? sv_dup(SvRV(sstr), param)
8909 : sv_dup_inc(SvRV(sstr), param);
8910 else if (SvPVX(sstr) && SvLEN(sstr))
8911 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8913 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8914 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8915 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8916 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8917 LvTYPE(dstr) = LvTYPE(sstr);
8920 if (GvUNIQUE((GV*)sstr)) {
8922 if ((share = gv_share(sstr))) {
8926 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8927 HvNAME(GvSTASH(share)), GvNAME(share));
8932 SvANY(dstr) = new_XPVGV();
8933 SvCUR(dstr) = SvCUR(sstr);
8934 SvLEN(dstr) = SvLEN(sstr);
8935 SvIVX(dstr) = SvIVX(sstr);
8936 SvNVX(dstr) = SvNVX(sstr);
8937 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8938 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8940 SvRV(dstr) = SvWEAKREF(sstr)
8941 ? sv_dup(SvRV(sstr), param)
8942 : sv_dup_inc(SvRV(sstr), param);
8943 else if (SvPVX(sstr) && SvLEN(sstr))
8944 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8946 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8947 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8948 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8949 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
8950 GvFLAGS(dstr) = GvFLAGS(sstr);
8951 GvGP(dstr) = gp_dup(GvGP(sstr), param);
8952 (void)GpREFCNT_inc(GvGP(dstr));
8955 SvANY(dstr) = new_XPVIO();
8956 SvCUR(dstr) = SvCUR(sstr);
8957 SvLEN(dstr) = SvLEN(sstr);
8958 SvIVX(dstr) = SvIVX(sstr);
8959 SvNVX(dstr) = SvNVX(sstr);
8960 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8961 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8963 SvRV(dstr) = SvWEAKREF(sstr)
8964 ? sv_dup(SvRV(sstr), param)
8965 : sv_dup_inc(SvRV(sstr), param);
8966 else if (SvPVX(sstr) && SvLEN(sstr))
8967 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8969 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8970 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8971 if (IoOFP(sstr) == IoIFP(sstr))
8972 IoOFP(dstr) = IoIFP(dstr);
8974 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8975 /* PL_rsfp_filters entries have fake IoDIRP() */
8976 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8977 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8979 IoDIRP(dstr) = IoDIRP(sstr);
8980 IoLINES(dstr) = IoLINES(sstr);
8981 IoPAGE(dstr) = IoPAGE(sstr);
8982 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8983 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8984 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8985 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
8986 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8987 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
8988 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8989 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
8990 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8991 IoTYPE(dstr) = IoTYPE(sstr);
8992 IoFLAGS(dstr) = IoFLAGS(sstr);
8995 SvANY(dstr) = new_XPVAV();
8996 SvCUR(dstr) = SvCUR(sstr);
8997 SvLEN(dstr) = SvLEN(sstr);
8998 SvIVX(dstr) = SvIVX(sstr);
8999 SvNVX(dstr) = SvNVX(sstr);
9000 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9001 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9002 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9003 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9004 if (AvARRAY((AV*)sstr)) {
9005 SV **dst_ary, **src_ary;
9006 SSize_t items = AvFILLp((AV*)sstr) + 1;
9008 src_ary = AvARRAY((AV*)sstr);
9009 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9010 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9011 SvPVX(dstr) = (char*)dst_ary;
9012 AvALLOC((AV*)dstr) = dst_ary;
9013 if (AvREAL((AV*)sstr)) {
9015 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9019 *dst_ary++ = sv_dup(*src_ary++, param);
9021 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9022 while (items-- > 0) {
9023 *dst_ary++ = &PL_sv_undef;
9027 SvPVX(dstr) = Nullch;
9028 AvALLOC((AV*)dstr) = (SV**)NULL;
9032 SvANY(dstr) = new_XPVHV();
9033 SvCUR(dstr) = SvCUR(sstr);
9034 SvLEN(dstr) = SvLEN(sstr);
9035 SvIVX(dstr) = SvIVX(sstr);
9036 SvNVX(dstr) = SvNVX(sstr);
9037 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9038 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9039 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9040 if (HvARRAY((HV*)sstr)) {
9042 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9043 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9044 Newz(0, dxhv->xhv_array,
9045 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9046 while (i <= sxhv->xhv_max) {
9047 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9048 !!HvSHAREKEYS(sstr), param);
9051 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9054 SvPVX(dstr) = Nullch;
9055 HvEITER((HV*)dstr) = (HE*)NULL;
9057 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9058 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9059 /* Record stashes for possible cloning in Perl_clone(). */
9060 if(HvNAME((HV*)dstr))
9061 av_push(param->stashes, dstr);
9064 SvANY(dstr) = new_XPVFM();
9065 FmLINES(dstr) = FmLINES(sstr);
9069 SvANY(dstr) = new_XPVCV();
9071 SvCUR(dstr) = SvCUR(sstr);
9072 SvLEN(dstr) = SvLEN(sstr);
9073 SvIVX(dstr) = SvIVX(sstr);
9074 SvNVX(dstr) = SvNVX(sstr);
9075 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9076 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9077 if (SvPVX(sstr) && SvLEN(sstr))
9078 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9080 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9081 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9082 CvSTART(dstr) = CvSTART(sstr);
9083 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9084 CvXSUB(dstr) = CvXSUB(sstr);
9085 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9086 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9087 if (param->flags & CLONEf_COPY_STACKS) {
9088 CvDEPTH(dstr) = CvDEPTH(sstr);
9092 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9093 /* XXX padlists are real, but pretend to be not */
9094 AvREAL_on(CvPADLIST(sstr));
9095 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9096 AvREAL_off(CvPADLIST(sstr));
9097 AvREAL_off(CvPADLIST(dstr));
9100 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9101 if (!CvANON(sstr) || CvCLONED(sstr))
9102 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9104 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9105 CvFLAGS(dstr) = CvFLAGS(sstr);
9106 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9109 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9113 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9119 /* duplicate a context */
9122 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
9127 return (PERL_CONTEXT*)NULL;
9129 /* look for it in the table first */
9130 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9134 /* create anew and remember what it is */
9135 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9136 ptr_table_store(PL_ptr_table, cxs, ncxs);
9139 PERL_CONTEXT *cx = &cxs[ix];
9140 PERL_CONTEXT *ncx = &ncxs[ix];
9141 ncx->cx_type = cx->cx_type;
9142 if (CxTYPE(cx) == CXt_SUBST) {
9143 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9146 ncx->blk_oldsp = cx->blk_oldsp;
9147 ncx->blk_oldcop = cx->blk_oldcop;
9148 ncx->blk_oldretsp = cx->blk_oldretsp;
9149 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9150 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9151 ncx->blk_oldpm = cx->blk_oldpm;
9152 ncx->blk_gimme = cx->blk_gimme;
9153 switch (CxTYPE(cx)) {
9155 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9156 ? cv_dup_inc(cx->blk_sub.cv, param)
9157 : cv_dup(cx->blk_sub.cv,param));
9158 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9159 ? av_dup_inc(cx->blk_sub.argarray, param)
9161 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9162 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9163 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9164 ncx->blk_sub.lval = cx->blk_sub.lval;
9167 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9168 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9169 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9170 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9171 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9174 ncx->blk_loop.label = cx->blk_loop.label;
9175 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9176 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9177 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9178 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9179 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9180 ? cx->blk_loop.iterdata
9181 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9182 ncx->blk_loop.oldcurpad
9183 = (SV**)ptr_table_fetch(PL_ptr_table,
9184 cx->blk_loop.oldcurpad);
9185 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9186 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9187 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9188 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9189 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9192 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9193 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9194 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9195 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9207 /* duplicate a stack info structure */
9210 Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
9215 return (PERL_SI*)NULL;
9217 /* look for it in the table first */
9218 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9222 /* create anew and remember what it is */
9223 Newz(56, nsi, 1, PERL_SI);
9224 ptr_table_store(PL_ptr_table, si, nsi);
9226 nsi->si_stack = av_dup_inc(si->si_stack, param);
9227 nsi->si_cxix = si->si_cxix;
9228 nsi->si_cxmax = si->si_cxmax;
9229 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9230 nsi->si_type = si->si_type;
9231 nsi->si_prev = si_dup(si->si_prev, param);
9232 nsi->si_next = si_dup(si->si_next, param);
9233 nsi->si_markoff = si->si_markoff;
9238 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9239 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9240 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9241 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9242 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9243 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9244 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9245 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9246 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9247 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9248 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9249 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9252 #define pv_dup_inc(p) SAVEPV(p)
9253 #define pv_dup(p) SAVEPV(p)
9254 #define svp_dup_inc(p,pp) any_dup(p,pp)
9256 /* map any object to the new equivent - either something in the
9257 * ptr table, or something in the interpreter structure
9261 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9268 /* look for it in the table first */
9269 ret = ptr_table_fetch(PL_ptr_table, v);
9273 /* see if it is part of the interpreter structure */
9274 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9275 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
9282 /* duplicate the save stack */
9285 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
9287 ANY *ss = proto_perl->Tsavestack;
9288 I32 ix = proto_perl->Tsavestack_ix;
9289 I32 max = proto_perl->Tsavestack_max;
9302 void (*dptr) (void*);
9303 void (*dxptr) (pTHXo_ void*);
9306 Newz(54, nss, max, ANY);
9312 case SAVEt_ITEM: /* normal string */
9313 sv = (SV*)POPPTR(ss,ix);
9314 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9315 sv = (SV*)POPPTR(ss,ix);
9316 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9318 case SAVEt_SV: /* scalar reference */
9319 sv = (SV*)POPPTR(ss,ix);
9320 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9321 gv = (GV*)POPPTR(ss,ix);
9322 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9324 case SAVEt_GENERIC_PVREF: /* generic char* */
9325 c = (char*)POPPTR(ss,ix);
9326 TOPPTR(nss,ix) = pv_dup(c);
9327 ptr = POPPTR(ss,ix);
9328 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9330 case SAVEt_GENERIC_SVREF: /* generic sv */
9331 case SAVEt_SVREF: /* scalar reference */
9332 sv = (SV*)POPPTR(ss,ix);
9333 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9334 ptr = POPPTR(ss,ix);
9335 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9337 case SAVEt_AV: /* array reference */
9338 av = (AV*)POPPTR(ss,ix);
9339 TOPPTR(nss,ix) = av_dup_inc(av, param);
9340 gv = (GV*)POPPTR(ss,ix);
9341 TOPPTR(nss,ix) = gv_dup(gv, param);
9343 case SAVEt_HV: /* hash reference */
9344 hv = (HV*)POPPTR(ss,ix);
9345 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9346 gv = (GV*)POPPTR(ss,ix);
9347 TOPPTR(nss,ix) = gv_dup(gv, param);
9349 case SAVEt_INT: /* int reference */
9350 ptr = POPPTR(ss,ix);
9351 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9352 intval = (int)POPINT(ss,ix);
9353 TOPINT(nss,ix) = intval;
9355 case SAVEt_LONG: /* long reference */
9356 ptr = POPPTR(ss,ix);
9357 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9358 longval = (long)POPLONG(ss,ix);
9359 TOPLONG(nss,ix) = longval;
9361 case SAVEt_I32: /* I32 reference */
9362 case SAVEt_I16: /* I16 reference */
9363 case SAVEt_I8: /* I8 reference */
9364 ptr = POPPTR(ss,ix);
9365 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9369 case SAVEt_IV: /* IV reference */
9370 ptr = POPPTR(ss,ix);
9371 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9375 case SAVEt_SPTR: /* SV* reference */
9376 ptr = POPPTR(ss,ix);
9377 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9378 sv = (SV*)POPPTR(ss,ix);
9379 TOPPTR(nss,ix) = sv_dup(sv, param);
9381 case SAVEt_VPTR: /* random* reference */
9382 ptr = POPPTR(ss,ix);
9383 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9384 ptr = POPPTR(ss,ix);
9385 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9387 case SAVEt_PPTR: /* char* reference */
9388 ptr = POPPTR(ss,ix);
9389 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9390 c = (char*)POPPTR(ss,ix);
9391 TOPPTR(nss,ix) = pv_dup(c);
9393 case SAVEt_HPTR: /* HV* reference */
9394 ptr = POPPTR(ss,ix);
9395 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9396 hv = (HV*)POPPTR(ss,ix);
9397 TOPPTR(nss,ix) = hv_dup(hv, param);
9399 case SAVEt_APTR: /* AV* reference */
9400 ptr = POPPTR(ss,ix);
9401 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9402 av = (AV*)POPPTR(ss,ix);
9403 TOPPTR(nss,ix) = av_dup(av, param);
9406 gv = (GV*)POPPTR(ss,ix);
9407 TOPPTR(nss,ix) = gv_dup(gv, param);
9409 case SAVEt_GP: /* scalar reference */
9410 gp = (GP*)POPPTR(ss,ix);
9411 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9412 (void)GpREFCNT_inc(gp);
9413 gv = (GV*)POPPTR(ss,ix);
9414 TOPPTR(nss,ix) = gv_dup_inc(c, param);
9415 c = (char*)POPPTR(ss,ix);
9416 TOPPTR(nss,ix) = pv_dup(c);
9423 case SAVEt_MORTALIZESV:
9424 sv = (SV*)POPPTR(ss,ix);
9425 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9428 ptr = POPPTR(ss,ix);
9429 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9430 /* these are assumed to be refcounted properly */
9431 switch (((OP*)ptr)->op_type) {
9438 TOPPTR(nss,ix) = ptr;
9443 TOPPTR(nss,ix) = Nullop;
9448 TOPPTR(nss,ix) = Nullop;
9451 c = (char*)POPPTR(ss,ix);
9452 TOPPTR(nss,ix) = pv_dup_inc(c);
9455 longval = POPLONG(ss,ix);
9456 TOPLONG(nss,ix) = longval;
9459 hv = (HV*)POPPTR(ss,ix);
9460 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9461 c = (char*)POPPTR(ss,ix);
9462 TOPPTR(nss,ix) = pv_dup_inc(c);
9466 case SAVEt_DESTRUCTOR:
9467 ptr = POPPTR(ss,ix);
9468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9469 dptr = POPDPTR(ss,ix);
9470 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9472 case SAVEt_DESTRUCTOR_X:
9473 ptr = POPPTR(ss,ix);
9474 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9475 dxptr = POPDXPTR(ss,ix);
9476 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
9478 case SAVEt_REGCONTEXT:
9484 case SAVEt_STACK_POS: /* Position on Perl stack */
9488 case SAVEt_AELEM: /* array element */
9489 sv = (SV*)POPPTR(ss,ix);
9490 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9493 av = (AV*)POPPTR(ss,ix);
9494 TOPPTR(nss,ix) = av_dup_inc(av, param);
9496 case SAVEt_HELEM: /* hash element */
9497 sv = (SV*)POPPTR(ss,ix);
9498 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9499 sv = (SV*)POPPTR(ss,ix);
9500 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9501 hv = (HV*)POPPTR(ss,ix);
9502 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9505 ptr = POPPTR(ss,ix);
9506 TOPPTR(nss,ix) = ptr;
9513 av = (AV*)POPPTR(ss,ix);
9514 TOPPTR(nss,ix) = av_dup(av, param);
9517 longval = (long)POPLONG(ss,ix);
9518 TOPLONG(nss,ix) = longval;
9519 ptr = POPPTR(ss,ix);
9520 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9521 sv = (SV*)POPPTR(ss,ix);
9522 TOPPTR(nss,ix) = sv_dup(sv, param);
9525 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9537 =for apidoc perl_clone
9539 Create and return a new interpreter by cloning the current one.
9544 /* XXX the above needs expanding by someone who actually understands it ! */
9547 perl_clone(PerlInterpreter *proto_perl, UV flags)
9550 CPerlObj *pPerl = (CPerlObj*)proto_perl;
9553 #ifdef PERL_IMPLICIT_SYS
9555 /* perlhost.h so we need to call into it
9556 to clone the host, CPerlHost should have a c interface, sky */
9558 if (flags & CLONEf_CLONE_HOST) {
9559 return perl_clone_host(proto_perl,flags);
9561 return perl_clone_using(proto_perl, flags,
9563 proto_perl->IMemShared,
9564 proto_perl->IMemParse,
9574 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9575 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9576 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9577 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9578 struct IPerlDir* ipD, struct IPerlSock* ipS,
9579 struct IPerlProc* ipP)
9581 /* XXX many of the string copies here can be optimized if they're
9582 * constants; they need to be allocated as common memory and just
9583 * their pointers copied. */
9586 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9591 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
9593 PERL_SET_THX(pPerl);
9594 # else /* !PERL_OBJECT */
9595 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9596 PERL_SET_THX(my_perl);
9599 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9605 # else /* !DEBUGGING */
9606 Zero(my_perl, 1, PerlInterpreter);
9607 # endif /* DEBUGGING */
9611 PL_MemShared = ipMS;
9619 # endif /* PERL_OBJECT */
9620 #else /* !PERL_IMPLICIT_SYS */
9622 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9623 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9624 PERL_SET_THX(my_perl);
9629 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9635 # else /* !DEBUGGING */
9636 Zero(my_perl, 1, PerlInterpreter);
9637 # endif /* DEBUGGING */
9638 #endif /* PERL_IMPLICIT_SYS */
9639 param->flags = flags;
9642 PL_xiv_arenaroot = NULL;
9644 PL_xnv_arenaroot = NULL;
9646 PL_xrv_arenaroot = NULL;
9648 PL_xpv_arenaroot = NULL;
9650 PL_xpviv_arenaroot = NULL;
9651 PL_xpviv_root = NULL;
9652 PL_xpvnv_arenaroot = NULL;
9653 PL_xpvnv_root = NULL;
9654 PL_xpvcv_arenaroot = NULL;
9655 PL_xpvcv_root = NULL;
9656 PL_xpvav_arenaroot = NULL;
9657 PL_xpvav_root = NULL;
9658 PL_xpvhv_arenaroot = NULL;
9659 PL_xpvhv_root = NULL;
9660 PL_xpvmg_arenaroot = NULL;
9661 PL_xpvmg_root = NULL;
9662 PL_xpvlv_arenaroot = NULL;
9663 PL_xpvlv_root = NULL;
9664 PL_xpvbm_arenaroot = NULL;
9665 PL_xpvbm_root = NULL;
9666 PL_he_arenaroot = NULL;
9668 PL_nice_chunk = NULL;
9669 PL_nice_chunk_size = 0;
9672 PL_sv_root = Nullsv;
9673 PL_sv_arenaroot = Nullsv;
9675 PL_debug = proto_perl->Idebug;
9677 #ifdef USE_REENTRANT_API
9678 New(31337, PL_reentrant_buffer,1, REBUF);
9679 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9682 /* create SV map for pointer relocation */
9683 PL_ptr_table = ptr_table_new();
9685 /* initialize these special pointers as early as possible */
9686 SvANY(&PL_sv_undef) = NULL;
9687 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9688 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9689 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9692 SvUPGRADE(&PL_sv_no, SVt_PVNV);
9694 SvANY(&PL_sv_no) = new_XPVNV();
9696 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9697 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9698 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9699 SvCUR(&PL_sv_no) = 0;
9700 SvLEN(&PL_sv_no) = 1;
9701 SvNVX(&PL_sv_no) = 0;
9702 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9705 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
9707 SvANY(&PL_sv_yes) = new_XPVNV();
9709 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9710 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9711 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9712 SvCUR(&PL_sv_yes) = 1;
9713 SvLEN(&PL_sv_yes) = 2;
9714 SvNVX(&PL_sv_yes) = 1;
9715 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9717 /* create shared string table */
9718 PL_strtab = newHV();
9719 HvSHAREKEYS_off(PL_strtab);
9720 hv_ksplit(PL_strtab, 512);
9721 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9723 PL_compiling = proto_perl->Icompiling;
9724 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9725 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9726 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9727 if (!specialWARN(PL_compiling.cop_warnings))
9728 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9729 if (!specialCopIO(PL_compiling.cop_io))
9730 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9731 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9733 /* pseudo environmental stuff */
9734 PL_origargc = proto_perl->Iorigargc;
9736 New(0, PL_origargv, i+1, char*);
9737 PL_origargv[i] = '\0';
9739 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9743 param->stashes = newAV(); /* Setup array of objects to call clone on */
9746 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9747 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9748 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9749 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9750 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9751 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9754 PL_minus_c = proto_perl->Iminus_c;
9755 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9756 PL_localpatches = proto_perl->Ilocalpatches;
9757 PL_splitstr = proto_perl->Isplitstr;
9758 PL_preprocess = proto_perl->Ipreprocess;
9759 PL_minus_n = proto_perl->Iminus_n;
9760 PL_minus_p = proto_perl->Iminus_p;
9761 PL_minus_l = proto_perl->Iminus_l;
9762 PL_minus_a = proto_perl->Iminus_a;
9763 PL_minus_F = proto_perl->Iminus_F;
9764 PL_doswitches = proto_perl->Idoswitches;
9765 PL_dowarn = proto_perl->Idowarn;
9766 PL_doextract = proto_perl->Idoextract;
9767 PL_sawampersand = proto_perl->Isawampersand;
9768 PL_unsafe = proto_perl->Iunsafe;
9769 PL_inplace = SAVEPV(proto_perl->Iinplace);
9770 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9771 PL_perldb = proto_perl->Iperldb;
9772 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9774 /* magical thingies */
9775 /* XXX time(&PL_basetime) when asked for? */
9776 PL_basetime = proto_perl->Ibasetime;
9777 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9779 PL_maxsysfd = proto_perl->Imaxsysfd;
9780 PL_multiline = proto_perl->Imultiline;
9781 PL_statusvalue = proto_perl->Istatusvalue;
9783 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9786 /* Clone the regex array */
9787 PL_regex_padav = newAV();
9789 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9790 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9791 for(i = 0; i <= len; i++) {
9792 av_push(PL_regex_padav,
9794 newSViv((IV)re_dup((REGEXP *)
9795 SvIVX(regexen[i]), param))
9799 PL_regex_pad = AvARRAY(PL_regex_padav);
9801 /* shortcuts to various I/O objects */
9802 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9803 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9804 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9805 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9806 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9807 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9809 /* shortcuts to regexp stuff */
9810 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9812 /* shortcuts to misc objects */
9813 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9815 /* shortcuts to debugging objects */
9816 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9817 PL_DBline = gv_dup(proto_perl->IDBline, param);
9818 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9819 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9820 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9821 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9822 PL_lineary = av_dup(proto_perl->Ilineary, param);
9823 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9826 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9827 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9828 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9829 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9830 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9831 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9833 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9834 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9835 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9836 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9838 PL_sub_generation = proto_perl->Isub_generation;
9840 /* funky return mechanisms */
9841 PL_forkprocess = proto_perl->Iforkprocess;
9843 /* subprocess state */
9844 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9846 /* internal state */
9847 PL_tainting = proto_perl->Itainting;
9848 PL_maxo = proto_perl->Imaxo;
9849 if (proto_perl->Iop_mask)
9850 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9852 PL_op_mask = Nullch;
9854 /* current interpreter roots */
9855 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9856 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9857 PL_main_start = proto_perl->Imain_start;
9858 PL_eval_root = proto_perl->Ieval_root;
9859 PL_eval_start = proto_perl->Ieval_start;
9861 /* runtime control stuff */
9862 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9863 PL_copline = proto_perl->Icopline;
9865 PL_filemode = proto_perl->Ifilemode;
9866 PL_lastfd = proto_perl->Ilastfd;
9867 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9870 PL_gensym = proto_perl->Igensym;
9871 PL_preambled = proto_perl->Ipreambled;
9872 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9873 PL_laststatval = proto_perl->Ilaststatval;
9874 PL_laststype = proto_perl->Ilaststype;
9875 PL_mess_sv = Nullsv;
9877 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9878 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9880 /* interpreter atexit processing */
9881 PL_exitlistlen = proto_perl->Iexitlistlen;
9882 if (PL_exitlistlen) {
9883 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9884 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9887 PL_exitlist = (PerlExitListEntry*)NULL;
9888 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9890 PL_profiledata = NULL;
9891 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9892 /* PL_rsfp_filters entries have fake IoDIRP() */
9893 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9895 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9896 PL_comppad = av_dup(proto_perl->Icomppad, param);
9897 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9898 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9899 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9900 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9901 proto_perl->Tcurpad);
9903 #ifdef HAVE_INTERP_INTERN
9904 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9907 /* more statics moved here */
9908 PL_generation = proto_perl->Igeneration;
9909 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9911 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9912 PL_in_clean_all = proto_perl->Iin_clean_all;
9914 PL_uid = proto_perl->Iuid;
9915 PL_euid = proto_perl->Ieuid;
9916 PL_gid = proto_perl->Igid;
9917 PL_egid = proto_perl->Iegid;
9918 PL_nomemok = proto_perl->Inomemok;
9919 PL_an = proto_perl->Ian;
9920 PL_cop_seqmax = proto_perl->Icop_seqmax;
9921 PL_op_seqmax = proto_perl->Iop_seqmax;
9922 PL_evalseq = proto_perl->Ievalseq;
9923 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9924 PL_origalen = proto_perl->Iorigalen;
9925 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9926 PL_osname = SAVEPV(proto_perl->Iosname);
9927 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9928 PL_sighandlerp = proto_perl->Isighandlerp;
9931 PL_runops = proto_perl->Irunops;
9933 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9936 PL_cshlen = proto_perl->Icshlen;
9937 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9940 PL_lex_state = proto_perl->Ilex_state;
9941 PL_lex_defer = proto_perl->Ilex_defer;
9942 PL_lex_expect = proto_perl->Ilex_expect;
9943 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9944 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9945 PL_lex_starts = proto_perl->Ilex_starts;
9946 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
9947 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
9948 PL_lex_op = proto_perl->Ilex_op;
9949 PL_lex_inpat = proto_perl->Ilex_inpat;
9950 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9951 PL_lex_brackets = proto_perl->Ilex_brackets;
9952 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9953 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9954 PL_lex_casemods = proto_perl->Ilex_casemods;
9955 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9956 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9958 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9959 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9960 PL_nexttoke = proto_perl->Inexttoke;
9962 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
9963 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9964 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9965 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9966 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9967 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9968 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9969 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9970 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9971 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9972 PL_pending_ident = proto_perl->Ipending_ident;
9973 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9975 PL_expect = proto_perl->Iexpect;
9977 PL_multi_start = proto_perl->Imulti_start;
9978 PL_multi_end = proto_perl->Imulti_end;
9979 PL_multi_open = proto_perl->Imulti_open;
9980 PL_multi_close = proto_perl->Imulti_close;
9982 PL_error_count = proto_perl->Ierror_count;
9983 PL_subline = proto_perl->Isubline;
9984 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
9986 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9987 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9988 PL_padix = proto_perl->Ipadix;
9989 PL_padix_floor = proto_perl->Ipadix_floor;
9990 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9992 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9993 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9994 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9995 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9996 PL_last_lop_op = proto_perl->Ilast_lop_op;
9997 PL_in_my = proto_perl->Iin_my;
9998 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10000 PL_cryptseen = proto_perl->Icryptseen;
10003 PL_hints = proto_perl->Ihints;
10005 PL_amagic_generation = proto_perl->Iamagic_generation;
10007 #ifdef USE_LOCALE_COLLATE
10008 PL_collation_ix = proto_perl->Icollation_ix;
10009 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10010 PL_collation_standard = proto_perl->Icollation_standard;
10011 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10012 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10013 #endif /* USE_LOCALE_COLLATE */
10015 #ifdef USE_LOCALE_NUMERIC
10016 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10017 PL_numeric_standard = proto_perl->Inumeric_standard;
10018 PL_numeric_local = proto_perl->Inumeric_local;
10019 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10020 #endif /* !USE_LOCALE_NUMERIC */
10022 /* utf8 character classes */
10023 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10024 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10025 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10026 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10027 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10028 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10029 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10030 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10031 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10032 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10033 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10034 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10035 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10036 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10037 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10038 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10039 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10042 PL_last_swash_hv = Nullhv; /* reinits on demand */
10043 PL_last_swash_klen = 0;
10044 PL_last_swash_key[0]= '\0';
10045 PL_last_swash_tmps = (U8*)NULL;
10046 PL_last_swash_slen = 0;
10048 /* perly.c globals */
10049 PL_yydebug = proto_perl->Iyydebug;
10050 PL_yynerrs = proto_perl->Iyynerrs;
10051 PL_yyerrflag = proto_perl->Iyyerrflag;
10052 PL_yychar = proto_perl->Iyychar;
10053 PL_yyval = proto_perl->Iyyval;
10054 PL_yylval = proto_perl->Iyylval;
10056 PL_glob_index = proto_perl->Iglob_index;
10057 PL_srand_called = proto_perl->Isrand_called;
10058 PL_uudmap['M'] = 0; /* reinits on demand */
10059 PL_bitcount = Nullch; /* reinits on demand */
10061 if (proto_perl->Ipsig_pend) {
10062 Newz(0, PL_psig_pend, SIG_SIZE, int);
10065 PL_psig_pend = (int*)NULL;
10068 if (proto_perl->Ipsig_ptr) {
10069 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10070 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10071 for (i = 1; i < SIG_SIZE; i++) {
10072 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10073 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10077 PL_psig_ptr = (SV**)NULL;
10078 PL_psig_name = (SV**)NULL;
10081 /* thrdvar.h stuff */
10083 if (flags & CLONEf_COPY_STACKS) {
10084 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10085 PL_tmps_ix = proto_perl->Ttmps_ix;
10086 PL_tmps_max = proto_perl->Ttmps_max;
10087 PL_tmps_floor = proto_perl->Ttmps_floor;
10088 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10090 while (i <= PL_tmps_ix) {
10091 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10095 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10096 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10097 Newz(54, PL_markstack, i, I32);
10098 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10099 - proto_perl->Tmarkstack);
10100 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10101 - proto_perl->Tmarkstack);
10102 Copy(proto_perl->Tmarkstack, PL_markstack,
10103 PL_markstack_ptr - PL_markstack + 1, I32);
10105 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10106 * NOTE: unlike the others! */
10107 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10108 PL_scopestack_max = proto_perl->Tscopestack_max;
10109 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10110 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10112 /* next push_return() sets PL_retstack[PL_retstack_ix]
10113 * NOTE: unlike the others! */
10114 PL_retstack_ix = proto_perl->Tretstack_ix;
10115 PL_retstack_max = proto_perl->Tretstack_max;
10116 Newz(54, PL_retstack, PL_retstack_max, OP*);
10117 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10119 /* NOTE: si_dup() looks at PL_markstack */
10120 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10122 /* PL_curstack = PL_curstackinfo->si_stack; */
10123 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10124 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10126 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10127 PL_stack_base = AvARRAY(PL_curstack);
10128 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10129 - proto_perl->Tstack_base);
10130 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10132 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10133 * NOTE: unlike the others! */
10134 PL_savestack_ix = proto_perl->Tsavestack_ix;
10135 PL_savestack_max = proto_perl->Tsavestack_max;
10136 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10137 PL_savestack = ss_dup(proto_perl, param);
10141 ENTER; /* perl_destruct() wants to LEAVE; */
10144 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10145 PL_top_env = &PL_start_env;
10147 PL_op = proto_perl->Top;
10150 PL_Xpv = (XPV*)NULL;
10151 PL_na = proto_perl->Tna;
10153 PL_statbuf = proto_perl->Tstatbuf;
10154 PL_statcache = proto_perl->Tstatcache;
10155 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10156 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10158 PL_timesbuf = proto_perl->Ttimesbuf;
10161 PL_tainted = proto_perl->Ttainted;
10162 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10163 PL_nrs = sv_dup_inc(proto_perl->Tnrs, param);
10164 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10165 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10166 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10167 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10168 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10169 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10170 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10171 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10173 PL_restartop = proto_perl->Trestartop;
10174 PL_in_eval = proto_perl->Tin_eval;
10175 PL_delaymagic = proto_perl->Tdelaymagic;
10176 PL_dirty = proto_perl->Tdirty;
10177 PL_localizing = proto_perl->Tlocalizing;
10179 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10180 PL_protect = proto_perl->Tprotect;
10182 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10183 PL_av_fetch_sv = Nullsv;
10184 PL_hv_fetch_sv = Nullsv;
10185 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10186 PL_modcount = proto_perl->Tmodcount;
10187 PL_lastgotoprobe = Nullop;
10188 PL_dumpindent = proto_perl->Tdumpindent;
10190 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10191 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10192 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10193 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10194 PL_sortcxix = proto_perl->Tsortcxix;
10195 PL_efloatbuf = Nullch; /* reinits on demand */
10196 PL_efloatsize = 0; /* reinits on demand */
10200 PL_screamfirst = NULL;
10201 PL_screamnext = NULL;
10202 PL_maxscream = -1; /* reinits on demand */
10203 PL_lastscream = Nullsv;
10205 PL_watchaddr = NULL;
10206 PL_watchok = Nullch;
10208 PL_regdummy = proto_perl->Tregdummy;
10209 PL_regcomp_parse = Nullch;
10210 PL_regxend = Nullch;
10211 PL_regcode = (regnode*)NULL;
10214 PL_regprecomp = Nullch;
10219 PL_seen_zerolen = 0;
10221 PL_regcomp_rx = (regexp*)NULL;
10223 PL_colorset = 0; /* reinits PL_colors[] */
10224 /*PL_colors[6] = {0,0,0,0,0,0};*/
10225 PL_reg_whilem_seen = 0;
10226 PL_reginput = Nullch;
10227 PL_regbol = Nullch;
10228 PL_regeol = Nullch;
10229 PL_regstartp = (I32*)NULL;
10230 PL_regendp = (I32*)NULL;
10231 PL_reglastparen = (U32*)NULL;
10232 PL_regtill = Nullch;
10233 PL_reg_start_tmp = (char**)NULL;
10234 PL_reg_start_tmpl = 0;
10235 PL_regdata = (struct reg_data*)NULL;
10238 PL_reg_eval_set = 0;
10240 PL_regprogram = (regnode*)NULL;
10242 PL_regcc = (CURCUR*)NULL;
10243 PL_reg_call_cc = (struct re_cc_state*)NULL;
10244 PL_reg_re = (regexp*)NULL;
10245 PL_reg_ganch = Nullch;
10246 PL_reg_sv = Nullsv;
10247 PL_reg_magic = (MAGIC*)NULL;
10249 PL_reg_oldcurpm = (PMOP*)NULL;
10250 PL_reg_curpm = (PMOP*)NULL;
10251 PL_reg_oldsaved = Nullch;
10252 PL_reg_oldsavedlen = 0;
10253 PL_reg_maxiter = 0;
10254 PL_reg_leftiter = 0;
10255 PL_reg_poscache = Nullch;
10256 PL_reg_poscache_size= 0;
10258 /* RE engine - function pointers */
10259 PL_regcompp = proto_perl->Tregcompp;
10260 PL_regexecp = proto_perl->Tregexecp;
10261 PL_regint_start = proto_perl->Tregint_start;
10262 PL_regint_string = proto_perl->Tregint_string;
10263 PL_regfree = proto_perl->Tregfree;
10265 PL_reginterp_cnt = 0;
10266 PL_reg_starttry = 0;
10268 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10269 ptr_table_free(PL_ptr_table);
10270 PL_ptr_table = NULL;
10273 /* Call the ->CLONE method, if it exists, for each of the stashes
10274 identified by sv_dup() above.
10276 while(av_len(param->stashes) != -1) {
10277 HV* stash = (HV*) av_shift(param->stashes);
10278 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10279 if (cloner && GvCV(cloner)) {
10284 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10286 call_sv((SV*)GvCV(cloner), G_DISCARD);
10292 SvREFCNT_dec(param->stashes);
10296 return (PerlInterpreter*)pPerl;
10302 #else /* !USE_ITHREADS */
10308 #endif /* USE_ITHREADS */