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 New(703,s,newlen,char);
1575 SvLEN_set(sv, newlen);
1581 =for apidoc sv_setiv
1583 Copies an integer into the given SV, upgrading first if necessary.
1584 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1590 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1592 SV_CHECK_THINKFIRST(sv);
1593 switch (SvTYPE(sv)) {
1595 sv_upgrade(sv, SVt_IV);
1598 sv_upgrade(sv, SVt_PVNV);
1602 sv_upgrade(sv, SVt_PVIV);
1611 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1612 PL_op_desc[PL_op->op_type]);
1614 (void)SvIOK_only(sv); /* validate number */
1620 =for apidoc sv_setiv_mg
1622 Like C<sv_setiv>, but also handles 'set' magic.
1628 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1635 =for apidoc sv_setuv
1637 Copies an unsigned integer into the given SV, upgrading first if necessary.
1638 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1644 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1646 /* With these two if statements:
1647 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1650 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1652 If you wish to remove them, please benchmark to see what the effect is
1654 if (u <= (UV)IV_MAX) {
1655 sv_setiv(sv, (IV)u);
1664 =for apidoc sv_setuv_mg
1666 Like C<sv_setuv>, but also handles 'set' magic.
1672 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1674 /* With these two if statements:
1675 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1678 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1680 If you wish to remove them, please benchmark to see what the effect is
1682 if (u <= (UV)IV_MAX) {
1683 sv_setiv(sv, (IV)u);
1693 =for apidoc sv_setnv
1695 Copies a double into the given SV, upgrading first if necessary.
1696 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1702 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1704 SV_CHECK_THINKFIRST(sv);
1705 switch (SvTYPE(sv)) {
1708 sv_upgrade(sv, SVt_NV);
1713 sv_upgrade(sv, SVt_PVNV);
1722 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1723 PL_op_name[PL_op->op_type]);
1726 (void)SvNOK_only(sv); /* validate number */
1731 =for apidoc sv_setnv_mg
1733 Like C<sv_setnv>, but also handles 'set' magic.
1739 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1745 /* Print an "isn't numeric" warning, using a cleaned-up,
1746 * printable version of the offending string
1750 S_not_a_number(pTHX_ SV *sv)
1754 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1755 /* each *s can expand to 4 chars + "...\0",
1756 i.e. need room for 8 chars */
1759 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1761 if (ch & 128 && !isPRINT_LC(ch)) {
1770 else if (ch == '\r') {
1774 else if (ch == '\f') {
1778 else if (ch == '\\') {
1782 else if (ch == '\0') {
1786 else if (isPRINT_LC(ch))
1801 Perl_warner(aTHX_ WARN_NUMERIC,
1802 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1803 PL_op_desc[PL_op->op_type]);
1805 Perl_warner(aTHX_ WARN_NUMERIC,
1806 "Argument \"%s\" isn't numeric", tmpbuf);
1810 =for apidoc looks_like_number
1812 Test if the content of an SV looks like a number (or is a number).
1813 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1814 non-numeric warning), even if your atof() doesn't grok them.
1820 Perl_looks_like_number(pTHX_ SV *sv)
1822 register char *sbegin;
1829 else if (SvPOKp(sv))
1830 sbegin = SvPV(sv, len);
1832 return 1; /* Historic. Wrong? */
1833 return grok_number(sbegin, len, NULL);
1836 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1837 until proven guilty, assume that things are not that bad... */
1842 As 64 bit platforms often have an NV that doesn't preserve all bits of
1843 an IV (an assumption perl has been based on to date) it becomes necessary
1844 to remove the assumption that the NV always carries enough precision to
1845 recreate the IV whenever needed, and that the NV is the canonical form.
1846 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1847 precision as a side effect of conversion (which would lead to insanity
1848 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1849 1) to distinguish between IV/UV/NV slots that have cached a valid
1850 conversion where precision was lost and IV/UV/NV slots that have a
1851 valid conversion which has lost no precision
1852 2) to ensure that if a numeric conversion to one form is requested that
1853 would lose precision, the precise conversion (or differently
1854 imprecise conversion) is also performed and cached, to prevent
1855 requests for different numeric formats on the same SV causing
1856 lossy conversion chains. (lossless conversion chains are perfectly
1861 SvIOKp is true if the IV slot contains a valid value
1862 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1863 SvNOKp is true if the NV slot contains a valid value
1864 SvNOK is true only if the NV value is accurate
1867 while converting from PV to NV, check to see if converting that NV to an
1868 IV(or UV) would lose accuracy over a direct conversion from PV to
1869 IV(or UV). If it would, cache both conversions, return NV, but mark
1870 SV as IOK NOKp (ie not NOK).
1872 While converting from PV to IV, check to see if converting that IV to an
1873 NV would lose accuracy over a direct conversion from PV to NV. If it
1874 would, cache both conversions, flag similarly.
1876 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1877 correctly because if IV & NV were set NV *always* overruled.
1878 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1879 changes - now IV and NV together means that the two are interchangeable:
1880 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1882 The benefit of this is that operations such as pp_add know that if
1883 SvIOK is true for both left and right operands, then integer addition
1884 can be used instead of floating point (for cases where the result won't
1885 overflow). Before, floating point was always used, which could lead to
1886 loss of precision compared with integer addition.
1888 * making IV and NV equal status should make maths accurate on 64 bit
1890 * may speed up maths somewhat if pp_add and friends start to use
1891 integers when possible instead of fp. (Hopefully the overhead in
1892 looking for SvIOK and checking for overflow will not outweigh the
1893 fp to integer speedup)
1894 * will slow down integer operations (callers of SvIV) on "inaccurate"
1895 values, as the change from SvIOK to SvIOKp will cause a call into
1896 sv_2iv each time rather than a macro access direct to the IV slot
1897 * should speed up number->string conversion on integers as IV is
1898 favoured when IV and NV are equally accurate
1900 ####################################################################
1901 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1902 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1903 On the other hand, SvUOK is true iff UV.
1904 ####################################################################
1906 Your mileage will vary depending your CPU's relative fp to integer
1910 #ifndef NV_PRESERVES_UV
1911 # define IS_NUMBER_UNDERFLOW_IV 1
1912 # define IS_NUMBER_UNDERFLOW_UV 2
1913 # define IS_NUMBER_IV_AND_UV 2
1914 # define IS_NUMBER_OVERFLOW_IV 4
1915 # define IS_NUMBER_OVERFLOW_UV 5
1917 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1919 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1921 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1923 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));
1924 if (SvNVX(sv) < (NV)IV_MIN) {
1925 (void)SvIOKp_on(sv);
1928 return IS_NUMBER_UNDERFLOW_IV;
1930 if (SvNVX(sv) > (NV)UV_MAX) {
1931 (void)SvIOKp_on(sv);
1935 return IS_NUMBER_OVERFLOW_UV;
1937 (void)SvIOKp_on(sv);
1939 /* Can't use strtol etc to convert this string. (See truth table in
1941 if (SvNVX(sv) <= (UV)IV_MAX) {
1942 SvIVX(sv) = I_V(SvNVX(sv));
1943 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1944 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1946 /* Integer is imprecise. NOK, IOKp */
1948 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1951 SvUVX(sv) = U_V(SvNVX(sv));
1952 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1953 if (SvUVX(sv) == UV_MAX) {
1954 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1955 possibly be preserved by NV. Hence, it must be overflow.
1957 return IS_NUMBER_OVERFLOW_UV;
1959 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1961 /* Integer is imprecise. NOK, IOKp */
1963 return IS_NUMBER_OVERFLOW_IV;
1965 #endif /* !NV_PRESERVES_UV*/
1970 Return the integer value of an SV, doing any necessary string conversion,
1971 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1977 Perl_sv_2iv(pTHX_ register SV *sv)
1981 if (SvGMAGICAL(sv)) {
1986 return I_V(SvNVX(sv));
1988 if (SvPOKp(sv) && SvLEN(sv))
1991 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1992 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1998 if (SvTHINKFIRST(sv)) {
2001 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2002 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2003 return SvIV(tmpstr);
2004 return PTR2IV(SvRV(sv));
2006 if (SvREADONLY(sv) && SvFAKE(sv)) {
2007 sv_force_normal(sv);
2009 if (SvREADONLY(sv) && !SvOK(sv)) {
2010 if (ckWARN(WARN_UNINITIALIZED))
2017 return (IV)(SvUVX(sv));
2024 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2025 * without also getting a cached IV/UV from it at the same time
2026 * (ie PV->NV conversion should detect loss of accuracy and cache
2027 * IV or UV at same time to avoid this. NWC */
2029 if (SvTYPE(sv) == SVt_NV)
2030 sv_upgrade(sv, SVt_PVNV);
2032 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2033 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2034 certainly cast into the IV range at IV_MAX, whereas the correct
2035 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2037 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2038 SvIVX(sv) = I_V(SvNVX(sv));
2039 if (SvNVX(sv) == (NV) SvIVX(sv)
2040 #ifndef NV_PRESERVES_UV
2041 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2042 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2043 /* Don't flag it as "accurately an integer" if the number
2044 came from a (by definition imprecise) NV operation, and
2045 we're outside the range of NV integer precision */
2048 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2049 DEBUG_c(PerlIO_printf(Perl_debug_log,
2050 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
2056 /* IV not precise. No need to convert from PV, as NV
2057 conversion would already have cached IV if it detected
2058 that PV->IV would be better than PV->NV->IV
2059 flags already correct - don't set public IOK. */
2060 DEBUG_c(PerlIO_printf(Perl_debug_log,
2061 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
2066 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2067 but the cast (NV)IV_MIN rounds to a the value less (more
2068 negative) than IV_MIN which happens to be equal to SvNVX ??
2069 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2070 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2071 (NV)UVX == NVX are both true, but the values differ. :-(
2072 Hopefully for 2s complement IV_MIN is something like
2073 0x8000000000000000 which will be exact. NWC */
2076 SvUVX(sv) = U_V(SvNVX(sv));
2078 (SvNVX(sv) == (NV) SvUVX(sv))
2079 #ifndef NV_PRESERVES_UV
2080 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2081 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2082 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2083 /* Don't flag it as "accurately an integer" if the number
2084 came from a (by definition imprecise) NV operation, and
2085 we're outside the range of NV integer precision */
2091 DEBUG_c(PerlIO_printf(Perl_debug_log,
2092 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2096 return (IV)SvUVX(sv);
2099 else if (SvPOKp(sv) && SvLEN(sv)) {
2101 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2102 /* We want to avoid a possible problem when we cache an IV which
2103 may be later translated to an NV, and the resulting NV is not
2104 the same as the direct translation of the initial string
2105 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2106 be careful to ensure that the value with the .456 is around if the
2107 NV value is requested in the future).
2109 This means that if we cache such an IV, we need to cache the
2110 NV as well. Moreover, we trade speed for space, and do not
2111 cache the NV if we are sure it's not needed.
2114 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2115 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2116 == IS_NUMBER_IN_UV) {
2117 /* It's definitely an integer, only upgrade to PVIV */
2118 if (SvTYPE(sv) < SVt_PVIV)
2119 sv_upgrade(sv, SVt_PVIV);
2121 } else if (SvTYPE(sv) < SVt_PVNV)
2122 sv_upgrade(sv, SVt_PVNV);
2124 /* If NV preserves UV then we only use the UV value if we know that
2125 we aren't going to call atof() below. If NVs don't preserve UVs
2126 then the value returned may have more precision than atof() will
2127 return, even though value isn't perfectly accurate. */
2128 if ((numtype & (IS_NUMBER_IN_UV
2129 #ifdef NV_PRESERVES_UV
2132 )) == IS_NUMBER_IN_UV) {
2133 /* This won't turn off the public IOK flag if it was set above */
2134 (void)SvIOKp_on(sv);
2136 if (!(numtype & IS_NUMBER_NEG)) {
2138 if (value <= (UV)IV_MAX) {
2139 SvIVX(sv) = (IV)value;
2145 /* 2s complement assumption */
2146 if (value <= (UV)IV_MIN) {
2147 SvIVX(sv) = -(IV)value;
2149 /* Too negative for an IV. This is a double upgrade, but
2150 I'm assuming it will be be rare. */
2151 if (SvTYPE(sv) < SVt_PVNV)
2152 sv_upgrade(sv, SVt_PVNV);
2156 SvNVX(sv) = -(NV)value;
2161 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2162 will be in the previous block to set the IV slot, and the next
2163 block to set the NV slot. So no else here. */
2165 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2166 != IS_NUMBER_IN_UV) {
2167 /* It wasn't an (integer that doesn't overflow the UV). */
2168 SvNVX(sv) = Atof(SvPVX(sv));
2170 if (! numtype && ckWARN(WARN_NUMERIC))
2173 #if defined(USE_LONG_DOUBLE)
2174 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2175 PTR2UV(sv), SvNVX(sv)));
2177 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2178 PTR2UV(sv), SvNVX(sv)));
2182 #ifdef NV_PRESERVES_UV
2183 (void)SvIOKp_on(sv);
2185 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2186 SvIVX(sv) = I_V(SvNVX(sv));
2187 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2190 /* Integer is imprecise. NOK, IOKp */
2192 /* UV will not work better than IV */
2194 if (SvNVX(sv) > (NV)UV_MAX) {
2196 /* Integer is inaccurate. NOK, IOKp, is UV */
2200 SvUVX(sv) = U_V(SvNVX(sv));
2201 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2202 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2206 /* Integer is imprecise. NOK, IOKp, is UV */
2212 #else /* NV_PRESERVES_UV */
2213 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2214 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2215 /* The IV slot will have been set from value returned by
2216 grok_number above. The NV slot has just been set using
2219 assert (SvIOKp(sv));
2221 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2222 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2223 /* Small enough to preserve all bits. */
2224 (void)SvIOKp_on(sv);
2226 SvIVX(sv) = I_V(SvNVX(sv));
2227 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2229 /* Assumption: first non-preserved integer is < IV_MAX,
2230 this NV is in the preserved range, therefore: */
2231 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2233 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);
2237 0 0 already failed to read UV.
2238 0 1 already failed to read UV.
2239 1 0 you won't get here in this case. IV/UV
2240 slot set, public IOK, Atof() unneeded.
2241 1 1 already read UV.
2242 so there's no point in sv_2iuv_non_preserve() attempting
2243 to use atol, strtol, strtoul etc. */
2244 if (sv_2iuv_non_preserve (sv, numtype)
2245 >= IS_NUMBER_OVERFLOW_IV)
2249 #endif /* NV_PRESERVES_UV */
2252 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2254 if (SvTYPE(sv) < SVt_IV)
2255 /* Typically the caller expects that sv_any is not NULL now. */
2256 sv_upgrade(sv, SVt_IV);
2259 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2260 PTR2UV(sv),SvIVX(sv)));
2261 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2267 Return the unsigned integer value of an SV, doing any necessary string
2268 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2275 Perl_sv_2uv(pTHX_ register SV *sv)
2279 if (SvGMAGICAL(sv)) {
2284 return U_V(SvNVX(sv));
2285 if (SvPOKp(sv) && SvLEN(sv))
2288 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2289 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2295 if (SvTHINKFIRST(sv)) {
2298 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2299 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2300 return SvUV(tmpstr);
2301 return PTR2UV(SvRV(sv));
2303 if (SvREADONLY(sv) && SvFAKE(sv)) {
2304 sv_force_normal(sv);
2306 if (SvREADONLY(sv) && !SvOK(sv)) {
2307 if (ckWARN(WARN_UNINITIALIZED))
2317 return (UV)SvIVX(sv);
2321 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2322 * without also getting a cached IV/UV from it at the same time
2323 * (ie PV->NV conversion should detect loss of accuracy and cache
2324 * IV or UV at same time to avoid this. */
2325 /* IV-over-UV optimisation - choose to cache IV if possible */
2327 if (SvTYPE(sv) == SVt_NV)
2328 sv_upgrade(sv, SVt_PVNV);
2330 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2331 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2332 SvIVX(sv) = I_V(SvNVX(sv));
2333 if (SvNVX(sv) == (NV) SvIVX(sv)
2334 #ifndef NV_PRESERVES_UV
2335 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2336 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2337 /* Don't flag it as "accurately an integer" if the number
2338 came from a (by definition imprecise) NV operation, and
2339 we're outside the range of NV integer precision */
2342 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2343 DEBUG_c(PerlIO_printf(Perl_debug_log,
2344 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2350 /* IV not precise. No need to convert from PV, as NV
2351 conversion would already have cached IV if it detected
2352 that PV->IV would be better than PV->NV->IV
2353 flags already correct - don't set public IOK. */
2354 DEBUG_c(PerlIO_printf(Perl_debug_log,
2355 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2360 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2361 but the cast (NV)IV_MIN rounds to a the value less (more
2362 negative) than IV_MIN which happens to be equal to SvNVX ??
2363 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2364 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2365 (NV)UVX == NVX are both true, but the values differ. :-(
2366 Hopefully for 2s complement IV_MIN is something like
2367 0x8000000000000000 which will be exact. NWC */
2370 SvUVX(sv) = U_V(SvNVX(sv));
2372 (SvNVX(sv) == (NV) SvUVX(sv))
2373 #ifndef NV_PRESERVES_UV
2374 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2375 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2376 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2377 /* Don't flag it as "accurately an integer" if the number
2378 came from a (by definition imprecise) NV operation, and
2379 we're outside the range of NV integer precision */
2384 DEBUG_c(PerlIO_printf(Perl_debug_log,
2385 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2391 else if (SvPOKp(sv) && SvLEN(sv)) {
2393 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2395 /* We want to avoid a possible problem when we cache a UV which
2396 may be later translated to an NV, and the resulting NV is not
2397 the translation of the initial data.
2399 This means that if we cache such a UV, we need to cache the
2400 NV as well. Moreover, we trade speed for space, and do not
2401 cache the NV if not needed.
2404 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2405 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2406 == IS_NUMBER_IN_UV) {
2407 /* It's definitely an integer, only upgrade to PVIV */
2408 if (SvTYPE(sv) < SVt_PVIV)
2409 sv_upgrade(sv, SVt_PVIV);
2411 } else if (SvTYPE(sv) < SVt_PVNV)
2412 sv_upgrade(sv, SVt_PVNV);
2414 /* If NV preserves UV then we only use the UV value if we know that
2415 we aren't going to call atof() below. If NVs don't preserve UVs
2416 then the value returned may have more precision than atof() will
2417 return, even though it isn't accurate. */
2418 if ((numtype & (IS_NUMBER_IN_UV
2419 #ifdef NV_PRESERVES_UV
2422 )) == IS_NUMBER_IN_UV) {
2423 /* This won't turn off the public IOK flag if it was set above */
2424 (void)SvIOKp_on(sv);
2426 if (!(numtype & IS_NUMBER_NEG)) {
2428 if (value <= (UV)IV_MAX) {
2429 SvIVX(sv) = (IV)value;
2431 /* it didn't overflow, and it was positive. */
2436 /* 2s complement assumption */
2437 if (value <= (UV)IV_MIN) {
2438 SvIVX(sv) = -(IV)value;
2440 /* Too negative for an IV. This is a double upgrade, but
2441 I'm assuming it will be be rare. */
2442 if (SvTYPE(sv) < SVt_PVNV)
2443 sv_upgrade(sv, SVt_PVNV);
2447 SvNVX(sv) = -(NV)value;
2453 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2454 != IS_NUMBER_IN_UV) {
2455 /* It wasn't an integer, or it overflowed the UV. */
2456 SvNVX(sv) = Atof(SvPVX(sv));
2458 if (! numtype && ckWARN(WARN_NUMERIC))
2461 #if defined(USE_LONG_DOUBLE)
2462 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2463 PTR2UV(sv), SvNVX(sv)));
2465 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2466 PTR2UV(sv), SvNVX(sv)));
2469 #ifdef NV_PRESERVES_UV
2470 (void)SvIOKp_on(sv);
2472 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2473 SvIVX(sv) = I_V(SvNVX(sv));
2474 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2477 /* Integer is imprecise. NOK, IOKp */
2479 /* UV will not work better than IV */
2481 if (SvNVX(sv) > (NV)UV_MAX) {
2483 /* Integer is inaccurate. NOK, IOKp, is UV */
2487 SvUVX(sv) = U_V(SvNVX(sv));
2488 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2489 NV preservse UV so can do correct comparison. */
2490 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2494 /* Integer is imprecise. NOK, IOKp, is UV */
2499 #else /* NV_PRESERVES_UV */
2500 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2501 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2502 /* The UV slot will have been set from value returned by
2503 grok_number above. The NV slot has just been set using
2506 assert (SvIOKp(sv));
2508 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2509 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2510 /* Small enough to preserve all bits. */
2511 (void)SvIOKp_on(sv);
2513 SvIVX(sv) = I_V(SvNVX(sv));
2514 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2516 /* Assumption: first non-preserved integer is < IV_MAX,
2517 this NV is in the preserved range, therefore: */
2518 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2520 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);
2523 sv_2iuv_non_preserve (sv, numtype);
2525 #endif /* NV_PRESERVES_UV */
2529 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2530 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2533 if (SvTYPE(sv) < SVt_IV)
2534 /* Typically the caller expects that sv_any is not NULL now. */
2535 sv_upgrade(sv, SVt_IV);
2539 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2540 PTR2UV(sv),SvUVX(sv)));
2541 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2547 Return the num value of an SV, doing any necessary string or integer
2548 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2555 Perl_sv_2nv(pTHX_ register SV *sv)
2559 if (SvGMAGICAL(sv)) {
2563 if (SvPOKp(sv) && SvLEN(sv)) {
2564 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2565 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2567 return Atof(SvPVX(sv));
2571 return (NV)SvUVX(sv);
2573 return (NV)SvIVX(sv);
2576 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2577 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2583 if (SvTHINKFIRST(sv)) {
2586 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2587 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2588 return SvNV(tmpstr);
2589 return PTR2NV(SvRV(sv));
2591 if (SvREADONLY(sv) && SvFAKE(sv)) {
2592 sv_force_normal(sv);
2594 if (SvREADONLY(sv) && !SvOK(sv)) {
2595 if (ckWARN(WARN_UNINITIALIZED))
2600 if (SvTYPE(sv) < SVt_NV) {
2601 if (SvTYPE(sv) == SVt_IV)
2602 sv_upgrade(sv, SVt_PVNV);
2604 sv_upgrade(sv, SVt_NV);
2605 #ifdef USE_LONG_DOUBLE
2607 STORE_NUMERIC_LOCAL_SET_STANDARD();
2608 PerlIO_printf(Perl_debug_log,
2609 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2610 PTR2UV(sv), SvNVX(sv));
2611 RESTORE_NUMERIC_LOCAL();
2615 STORE_NUMERIC_LOCAL_SET_STANDARD();
2616 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2617 PTR2UV(sv), SvNVX(sv));
2618 RESTORE_NUMERIC_LOCAL();
2622 else if (SvTYPE(sv) < SVt_PVNV)
2623 sv_upgrade(sv, SVt_PVNV);
2624 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2627 else if (SvIOKp(sv)) {
2628 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2629 #ifdef NV_PRESERVES_UV
2632 /* Only set the public NV OK flag if this NV preserves the IV */
2633 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2634 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2635 : (SvIVX(sv) == I_V(SvNVX(sv))))
2641 else if (SvPOKp(sv) && SvLEN(sv)) {
2643 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2644 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2646 #ifdef NV_PRESERVES_UV
2647 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2648 == IS_NUMBER_IN_UV) {
2649 /* It's definitely an integer */
2650 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2652 SvNVX(sv) = Atof(SvPVX(sv));
2655 SvNVX(sv) = Atof(SvPVX(sv));
2656 /* Only set the public NV OK flag if this NV preserves the value in
2657 the PV at least as well as an IV/UV would.
2658 Not sure how to do this 100% reliably. */
2659 /* if that shift count is out of range then Configure's test is
2660 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2662 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2663 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2664 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2665 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2666 /* Can't use strtol etc to convert this string, so don't try.
2667 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2670 /* value has been set. It may not be precise. */
2671 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2672 /* 2s complement assumption for (UV)IV_MIN */
2673 SvNOK_on(sv); /* Integer is too negative. */
2678 if (numtype & IS_NUMBER_NEG) {
2679 SvIVX(sv) = -(IV)value;
2680 } else if (value <= (UV)IV_MAX) {
2681 SvIVX(sv) = (IV)value;
2687 if (numtype & IS_NUMBER_NOT_INT) {
2688 /* I believe that even if the original PV had decimals,
2689 they are lost beyond the limit of the FP precision.
2690 However, neither is canonical, so both only get p
2691 flags. NWC, 2000/11/25 */
2692 /* Both already have p flags, so do nothing */
2695 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2696 if (SvIVX(sv) == I_V(nv)) {
2701 /* It had no "." so it must be integer. */
2704 /* between IV_MAX and NV(UV_MAX).
2705 Could be slightly > UV_MAX */
2707 if (numtype & IS_NUMBER_NOT_INT) {
2708 /* UV and NV both imprecise. */
2710 UV nv_as_uv = U_V(nv);
2712 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2723 #endif /* NV_PRESERVES_UV */
2726 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2728 if (SvTYPE(sv) < SVt_NV)
2729 /* Typically the caller expects that sv_any is not NULL now. */
2730 /* XXX Ilya implies that this is a bug in callers that assume this
2731 and ideally should be fixed. */
2732 sv_upgrade(sv, SVt_NV);
2735 #if defined(USE_LONG_DOUBLE)
2737 STORE_NUMERIC_LOCAL_SET_STANDARD();
2738 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2739 PTR2UV(sv), SvNVX(sv));
2740 RESTORE_NUMERIC_LOCAL();
2744 STORE_NUMERIC_LOCAL_SET_STANDARD();
2745 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2746 PTR2UV(sv), SvNVX(sv));
2747 RESTORE_NUMERIC_LOCAL();
2753 /* asIV(): extract an integer from the string value of an SV.
2754 * Caller must validate PVX */
2757 S_asIV(pTHX_ SV *sv)
2760 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2762 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2763 == IS_NUMBER_IN_UV) {
2764 /* It's definitely an integer */
2765 if (numtype & IS_NUMBER_NEG) {
2766 if (value < (UV)IV_MIN)
2769 if (value < (UV)IV_MAX)
2774 if (ckWARN(WARN_NUMERIC))
2777 return I_V(Atof(SvPVX(sv)));
2780 /* asUV(): extract an unsigned integer from the string value of an SV
2781 * Caller must validate PVX */
2784 S_asUV(pTHX_ SV *sv)
2787 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2789 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2790 == IS_NUMBER_IN_UV) {
2791 /* It's definitely an integer */
2792 if (!(numtype & IS_NUMBER_NEG))
2796 if (ckWARN(WARN_NUMERIC))
2799 return U_V(Atof(SvPVX(sv)));
2803 =for apidoc sv_2pv_nolen
2805 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2806 use the macro wrapper C<SvPV_nolen(sv)> instead.
2811 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2814 return sv_2pv(sv, &n_a);
2817 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2818 * UV as a string towards the end of buf, and return pointers to start and
2821 * We assume that buf is at least TYPE_CHARS(UV) long.
2825 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2827 char *ptr = buf + TYPE_CHARS(UV);
2841 *--ptr = '0' + (uv % 10);
2849 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2850 * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2854 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2856 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2860 =for apidoc sv_2pv_flags
2862 Returns a pointer to the string value of an SV, and sets *lp to its length.
2863 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2865 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2866 usually end up here too.
2872 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2877 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2878 char *tmpbuf = tbuf;
2884 if (SvGMAGICAL(sv)) {
2885 if (flags & SV_GMAGIC)
2893 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2895 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2900 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2905 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2906 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2913 if (SvTHINKFIRST(sv)) {
2916 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2917 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2918 return SvPV(tmpstr,*lp);
2925 switch (SvTYPE(sv)) {
2927 if ( ((SvFLAGS(sv) &
2928 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2929 == (SVs_OBJECT|SVs_RMG))
2930 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2931 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2932 regexp *re = (regexp *)mg->mg_obj;
2935 char *fptr = "msix";
2940 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2942 while((ch = *fptr++)) {
2944 reflags[left++] = ch;
2947 reflags[right--] = ch;
2952 reflags[left] = '-';
2956 mg->mg_len = re->prelen + 4 + left;
2957 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2958 Copy("(?", mg->mg_ptr, 2, char);
2959 Copy(reflags, mg->mg_ptr+2, left, char);
2960 Copy(":", mg->mg_ptr+left+2, 1, char);
2961 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2962 mg->mg_ptr[mg->mg_len - 1] = ')';
2963 mg->mg_ptr[mg->mg_len] = 0;
2965 PL_reginterp_cnt += re->program[0].next_off;
2977 case SVt_PVBM: if (SvROK(sv))
2980 s = "SCALAR"; break;
2981 case SVt_PVLV: s = "LVALUE"; break;
2982 case SVt_PVAV: s = "ARRAY"; break;
2983 case SVt_PVHV: s = "HASH"; break;
2984 case SVt_PVCV: s = "CODE"; break;
2985 case SVt_PVGV: s = "GLOB"; break;
2986 case SVt_PVFM: s = "FORMAT"; break;
2987 case SVt_PVIO: s = "IO"; break;
2988 default: s = "UNKNOWN"; break;
2992 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2995 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3001 if (SvREADONLY(sv) && !SvOK(sv)) {
3002 if (ckWARN(WARN_UNINITIALIZED))
3008 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3009 /* I'm assuming that if both IV and NV are equally valid then
3010 converting the IV is going to be more efficient */
3011 U32 isIOK = SvIOK(sv);
3012 U32 isUIOK = SvIsUV(sv);
3013 char buf[TYPE_CHARS(UV)];
3016 if (SvTYPE(sv) < SVt_PVIV)
3017 sv_upgrade(sv, SVt_PVIV);
3019 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3021 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3022 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
3023 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3024 SvCUR_set(sv, ebuf - ptr);
3034 else if (SvNOKp(sv)) {
3035 if (SvTYPE(sv) < SVt_PVNV)
3036 sv_upgrade(sv, SVt_PVNV);
3037 /* The +20 is pure guesswork. Configure test needed. --jhi */
3038 SvGROW(sv, NV_DIG + 20);
3040 olderrno = errno; /* some Xenix systems wipe out errno here */
3042 if (SvNVX(sv) == 0.0)
3043 (void)strcpy(s,"0");
3047 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3050 #ifdef FIXNEGATIVEZERO
3051 if (*s == '-' && s[1] == '0' && !s[2])
3061 if (ckWARN(WARN_UNINITIALIZED)
3062 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3065 if (SvTYPE(sv) < SVt_PV)
3066 /* Typically the caller expects that sv_any is not NULL now. */
3067 sv_upgrade(sv, SVt_PV);
3070 *lp = s - SvPVX(sv);
3073 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3074 PTR2UV(sv),SvPVX(sv)));
3078 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3079 /* Sneaky stuff here */
3083 tsv = newSVpv(tmpbuf, 0);
3099 len = strlen(tmpbuf);
3101 #ifdef FIXNEGATIVEZERO
3102 if (len == 2 && t[0] == '-' && t[1] == '0') {
3107 (void)SvUPGRADE(sv, SVt_PV);
3109 s = SvGROW(sv, len + 1);
3118 =for apidoc sv_2pvbyte_nolen
3120 Return a pointer to the byte-encoded representation of the SV.
3121 May cause the SV to be downgraded from UTF8 as a side-effect.
3123 Usually accessed via the C<SvPVbyte_nolen> macro.
3129 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3132 return sv_2pvbyte(sv, &n_a);
3136 =for apidoc sv_2pvbyte
3138 Return a pointer to the byte-encoded representation of the SV, and set *lp
3139 to its length. May cause the SV to be downgraded from UTF8 as a
3142 Usually accessed via the C<SvPVbyte> macro.
3148 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3150 sv_utf8_downgrade(sv,0);
3151 return SvPV(sv,*lp);
3155 =for apidoc sv_2pvutf8_nolen
3157 Return a pointer to the UTF8-encoded representation of the SV.
3158 May cause the SV to be upgraded to UTF8 as a side-effect.
3160 Usually accessed via the C<SvPVutf8_nolen> macro.
3166 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3169 return sv_2pvutf8(sv, &n_a);
3173 =for apidoc sv_2pvutf8
3175 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3176 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3178 Usually accessed via the C<SvPVutf8> macro.
3184 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3186 sv_utf8_upgrade(sv);
3187 return SvPV(sv,*lp);
3191 =for apidoc sv_2bool
3193 This function is only called on magical items, and is only used by
3194 sv_true() or its macro equivalent.
3200 Perl_sv_2bool(pTHX_ register SV *sv)
3209 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3210 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
3211 return SvTRUE(tmpsv);
3212 return SvRV(sv) != 0;
3215 register XPV* Xpvtmp;
3216 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3217 (*Xpvtmp->xpv_pv > '0' ||
3218 Xpvtmp->xpv_cur > 1 ||
3219 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3226 return SvIVX(sv) != 0;
3229 return SvNVX(sv) != 0.0;
3237 =for apidoc sv_utf8_upgrade
3239 Convert the PV of an SV to its UTF8-encoded form.
3240 Forces the SV to string form if it is not already.
3241 Always sets the SvUTF8 flag to avoid future validity checks even
3242 if all the bytes have hibit clear.
3248 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3250 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3254 =for apidoc sv_utf8_upgrade_flags
3256 Convert the PV of an SV to its UTF8-encoded form.
3257 Forces the SV to string form if it is not already.
3258 Always sets the SvUTF8 flag to avoid future validity checks even
3259 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3260 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3261 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3267 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3277 (void) sv_2pv_flags(sv,&len, flags);
3285 if (SvREADONLY(sv) && SvFAKE(sv)) {
3286 sv_force_normal(sv);
3289 /* This function could be much more efficient if we had a FLAG in SVs
3290 * to signal if there are any hibit chars in the PV.
3291 * Given that there isn't make loop fast as possible
3293 s = (U8 *) SvPVX(sv);
3294 e = (U8 *) SvEND(sv);
3298 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3304 len = SvCUR(sv) + 1; /* Plus the \0 */
3305 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3306 SvCUR(sv) = len - 1;
3308 Safefree(s); /* No longer using what was there before. */
3309 SvLEN(sv) = len; /* No longer know the real size. */
3311 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3317 =for apidoc sv_utf8_downgrade
3319 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3320 This may not be possible if the PV contains non-byte encoding characters;
3321 if this is the case, either returns false or, if C<fail_ok> is not
3328 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3330 if (SvPOK(sv) && SvUTF8(sv)) {
3335 if (SvREADONLY(sv) && SvFAKE(sv))
3336 sv_force_normal(sv);
3337 s = (U8 *) SvPV(sv, len);
3338 if (!utf8_to_bytes(s, &len)) {
3341 #ifdef USE_BYTES_DOWNGRADES
3342 else if (IN_BYTES) {
3344 U8 *e = (U8 *) SvEND(sv);
3347 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3348 if (first && ch > 255) {
3350 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3351 PL_op_desc[PL_op->op_type]);
3353 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3360 len = (d - (U8 *) SvPVX(sv));
3365 Perl_croak(aTHX_ "Wide character in %s",
3366 PL_op_desc[PL_op->op_type]);
3368 Perl_croak(aTHX_ "Wide character");
3379 =for apidoc sv_utf8_encode
3381 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3382 flag so that it looks like octets again. Used as a building block
3383 for encode_utf8 in Encode.xs
3389 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3391 (void) sv_utf8_upgrade(sv);
3396 =for apidoc sv_utf8_decode
3398 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3399 turn off SvUTF8 if needed so that we see characters. Used as a building block
3400 for decode_utf8 in Encode.xs
3406 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3412 /* The octets may have got themselves encoded - get them back as
3415 if (!sv_utf8_downgrade(sv, TRUE))
3418 /* it is actually just a matter of turning the utf8 flag on, but
3419 * we want to make sure everything inside is valid utf8 first.
3421 c = (U8 *) SvPVX(sv);
3422 if (!is_utf8_string(c, SvCUR(sv)+1))
3424 e = (U8 *) SvEND(sv);
3427 if (!UTF8_IS_INVARIANT(ch)) {
3437 =for apidoc sv_setsv
3439 Copies the contents of the source SV C<ssv> into the destination SV
3440 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3441 function if the source SV needs to be reused. Does not handle 'set' magic.
3442 Loosely speaking, it performs a copy-by-value, obliterating any previous
3443 content of the destination.
3445 You probably want to use one of the assortment of wrappers, such as
3446 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3447 C<SvSetMagicSV_nosteal>.
3453 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3454 for binary compatibility only
3457 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3459 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3463 =for apidoc sv_setsv_flags
3465 Copies the contents of the source SV C<ssv> into the destination SV
3466 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3467 function if the source SV needs to be reused. Does not handle 'set' magic.
3468 Loosely speaking, it performs a copy-by-value, obliterating any previous
3469 content of the destination.
3470 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3471 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3472 implemented in terms of this function.
3474 You probably want to use one of the assortment of wrappers, such as
3475 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3476 C<SvSetMagicSV_nosteal>.
3478 This is the primary function for copying scalars, and most other
3479 copy-ish functions and macros use this underneath.
3485 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3487 register U32 sflags;
3493 SV_CHECK_THINKFIRST(dstr);
3495 sstr = &PL_sv_undef;
3496 stype = SvTYPE(sstr);
3497 dtype = SvTYPE(dstr);
3501 /* There's a lot of redundancy below but we're going for speed here */
3506 if (dtype != SVt_PVGV) {
3507 (void)SvOK_off(dstr);
3515 sv_upgrade(dstr, SVt_IV);
3518 sv_upgrade(dstr, SVt_PVNV);
3522 sv_upgrade(dstr, SVt_PVIV);
3525 (void)SvIOK_only(dstr);
3526 SvIVX(dstr) = SvIVX(sstr);
3529 if (SvTAINTED(sstr))
3540 sv_upgrade(dstr, SVt_NV);
3545 sv_upgrade(dstr, SVt_PVNV);
3548 SvNVX(dstr) = SvNVX(sstr);
3549 (void)SvNOK_only(dstr);
3550 if (SvTAINTED(sstr))
3558 sv_upgrade(dstr, SVt_RV);
3559 else if (dtype == SVt_PVGV &&
3560 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3563 if (GvIMPORTED(dstr) != GVf_IMPORTED
3564 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3566 GvIMPORTED_on(dstr);
3577 sv_upgrade(dstr, SVt_PV);
3580 if (dtype < SVt_PVIV)
3581 sv_upgrade(dstr, SVt_PVIV);
3584 if (dtype < SVt_PVNV)
3585 sv_upgrade(dstr, SVt_PVNV);
3592 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3593 PL_op_name[PL_op->op_type]);
3595 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3599 if (dtype <= SVt_PVGV) {
3601 if (dtype != SVt_PVGV) {
3602 char *name = GvNAME(sstr);
3603 STRLEN len = GvNAMELEN(sstr);
3604 sv_upgrade(dstr, SVt_PVGV);
3605 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3606 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3607 GvNAME(dstr) = savepvn(name, len);
3608 GvNAMELEN(dstr) = len;
3609 SvFAKE_on(dstr); /* can coerce to non-glob */
3611 /* ahem, death to those who redefine active sort subs */
3612 else if (PL_curstackinfo->si_type == PERLSI_SORT
3613 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3614 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3617 #ifdef GV_UNIQUE_CHECK
3618 if (GvUNIQUE((GV*)dstr)) {
3619 Perl_croak(aTHX_ PL_no_modify);
3623 (void)SvOK_off(dstr);
3624 GvINTRO_off(dstr); /* one-shot flag */
3626 GvGP(dstr) = gp_ref(GvGP(sstr));
3627 if (SvTAINTED(sstr))
3629 if (GvIMPORTED(dstr) != GVf_IMPORTED
3630 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3632 GvIMPORTED_on(dstr);
3640 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3642 if (SvTYPE(sstr) != stype) {
3643 stype = SvTYPE(sstr);
3644 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3648 if (stype == SVt_PVLV)
3649 (void)SvUPGRADE(dstr, SVt_PVNV);
3651 (void)SvUPGRADE(dstr, stype);
3654 sflags = SvFLAGS(sstr);
3656 if (sflags & SVf_ROK) {
3657 if (dtype >= SVt_PV) {
3658 if (dtype == SVt_PVGV) {
3659 SV *sref = SvREFCNT_inc(SvRV(sstr));
3661 int intro = GvINTRO(dstr);
3663 #ifdef GV_UNIQUE_CHECK
3664 if (GvUNIQUE((GV*)dstr)) {
3665 Perl_croak(aTHX_ PL_no_modify);
3670 GvINTRO_off(dstr); /* one-shot flag */
3671 GvLINE(dstr) = CopLINE(PL_curcop);
3672 GvEGV(dstr) = (GV*)dstr;
3675 switch (SvTYPE(sref)) {
3678 SAVESPTR(GvAV(dstr));
3680 dref = (SV*)GvAV(dstr);
3681 GvAV(dstr) = (AV*)sref;
3682 if (!GvIMPORTED_AV(dstr)
3683 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3685 GvIMPORTED_AV_on(dstr);
3690 SAVESPTR(GvHV(dstr));
3692 dref = (SV*)GvHV(dstr);
3693 GvHV(dstr) = (HV*)sref;
3694 if (!GvIMPORTED_HV(dstr)
3695 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3697 GvIMPORTED_HV_on(dstr);
3702 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3703 SvREFCNT_dec(GvCV(dstr));
3704 GvCV(dstr) = Nullcv;
3705 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3706 PL_sub_generation++;
3708 SAVESPTR(GvCV(dstr));
3711 dref = (SV*)GvCV(dstr);
3712 if (GvCV(dstr) != (CV*)sref) {
3713 CV* cv = GvCV(dstr);
3715 if (!GvCVGEN((GV*)dstr) &&
3716 (CvROOT(cv) || CvXSUB(cv)))
3718 /* ahem, death to those who redefine
3719 * active sort subs */
3720 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3721 PL_sortcop == CvSTART(cv))
3723 "Can't redefine active sort subroutine %s",
3724 GvENAME((GV*)dstr));
3725 /* Redefining a sub - warning is mandatory if
3726 it was a const and its value changed. */
3727 if (ckWARN(WARN_REDEFINE)
3729 && (!CvCONST((CV*)sref)
3730 || sv_cmp(cv_const_sv(cv),
3731 cv_const_sv((CV*)sref)))))
3733 Perl_warner(aTHX_ WARN_REDEFINE,
3735 ? "Constant subroutine %s redefined"
3736 : "Subroutine %s redefined",
3737 GvENAME((GV*)dstr));
3740 cv_ckproto(cv, (GV*)dstr,
3741 SvPOK(sref) ? SvPVX(sref) : Nullch);
3743 GvCV(dstr) = (CV*)sref;
3744 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3745 GvASSUMECV_on(dstr);
3746 PL_sub_generation++;
3748 if (!GvIMPORTED_CV(dstr)
3749 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3751 GvIMPORTED_CV_on(dstr);
3756 SAVESPTR(GvIOp(dstr));
3758 dref = (SV*)GvIOp(dstr);
3759 GvIOp(dstr) = (IO*)sref;
3763 SAVESPTR(GvFORM(dstr));
3765 dref = (SV*)GvFORM(dstr);
3766 GvFORM(dstr) = (CV*)sref;
3770 SAVESPTR(GvSV(dstr));
3772 dref = (SV*)GvSV(dstr);
3774 if (!GvIMPORTED_SV(dstr)
3775 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3777 GvIMPORTED_SV_on(dstr);
3785 if (SvTAINTED(sstr))
3790 (void)SvOOK_off(dstr); /* backoff */
3792 Safefree(SvPVX(dstr));
3793 SvLEN(dstr)=SvCUR(dstr)=0;
3796 (void)SvOK_off(dstr);
3797 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3799 if (sflags & SVp_NOK) {
3801 /* Only set the public OK flag if the source has public OK. */
3802 if (sflags & SVf_NOK)
3803 SvFLAGS(dstr) |= SVf_NOK;
3804 SvNVX(dstr) = SvNVX(sstr);
3806 if (sflags & SVp_IOK) {
3807 (void)SvIOKp_on(dstr);
3808 if (sflags & SVf_IOK)
3809 SvFLAGS(dstr) |= SVf_IOK;
3810 if (sflags & SVf_IVisUV)
3812 SvIVX(dstr) = SvIVX(sstr);
3814 if (SvAMAGIC(sstr)) {
3818 else if (sflags & SVp_POK) {
3821 * Check to see if we can just swipe the string. If so, it's a
3822 * possible small lose on short strings, but a big win on long ones.
3823 * It might even be a win on short strings if SvPVX(dstr)
3824 * has to be allocated and SvPVX(sstr) has to be freed.
3827 if (SvTEMP(sstr) && /* slated for free anyway? */
3828 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3829 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3830 SvLEN(sstr) && /* and really is a string */
3831 /* and won't be needed again, potentially */
3832 !(PL_op && PL_op->op_type == OP_AASSIGN))
3834 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3836 SvFLAGS(dstr) &= ~SVf_OOK;
3837 Safefree(SvPVX(dstr) - SvIVX(dstr));
3839 else if (SvLEN(dstr))
3840 Safefree(SvPVX(dstr));
3842 (void)SvPOK_only(dstr);
3843 SvPV_set(dstr, SvPVX(sstr));
3844 SvLEN_set(dstr, SvLEN(sstr));
3845 SvCUR_set(dstr, SvCUR(sstr));
3848 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3849 SvPV_set(sstr, Nullch);
3854 else { /* have to copy actual string */
3855 STRLEN len = SvCUR(sstr);
3857 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3858 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3859 SvCUR_set(dstr, len);
3860 *SvEND(dstr) = '\0';
3861 (void)SvPOK_only(dstr);
3863 if (sflags & SVf_UTF8)
3866 if (sflags & SVp_NOK) {
3868 if (sflags & SVf_NOK)
3869 SvFLAGS(dstr) |= SVf_NOK;
3870 SvNVX(dstr) = SvNVX(sstr);
3872 if (sflags & SVp_IOK) {
3873 (void)SvIOKp_on(dstr);
3874 if (sflags & SVf_IOK)
3875 SvFLAGS(dstr) |= SVf_IOK;
3876 if (sflags & SVf_IVisUV)
3878 SvIVX(dstr) = SvIVX(sstr);
3881 else if (sflags & SVp_IOK) {
3882 if (sflags & SVf_IOK)
3883 (void)SvIOK_only(dstr);
3885 (void)SvOK_off(dstr);
3886 (void)SvIOKp_on(dstr);
3888 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3889 if (sflags & SVf_IVisUV)
3891 SvIVX(dstr) = SvIVX(sstr);
3892 if (sflags & SVp_NOK) {
3893 if (sflags & SVf_NOK)
3894 (void)SvNOK_on(dstr);
3896 (void)SvNOKp_on(dstr);
3897 SvNVX(dstr) = SvNVX(sstr);
3900 else if (sflags & SVp_NOK) {
3901 if (sflags & SVf_NOK)
3902 (void)SvNOK_only(dstr);
3904 (void)SvOK_off(dstr);
3907 SvNVX(dstr) = SvNVX(sstr);
3910 if (dtype == SVt_PVGV) {
3911 if (ckWARN(WARN_MISC))
3912 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3915 (void)SvOK_off(dstr);
3917 if (SvTAINTED(sstr))
3922 =for apidoc sv_setsv_mg
3924 Like C<sv_setsv>, but also handles 'set' magic.
3930 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3932 sv_setsv(dstr,sstr);
3937 =for apidoc sv_setpvn
3939 Copies a string into an SV. The C<len> parameter indicates the number of
3940 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3946 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3948 register char *dptr;
3950 SV_CHECK_THINKFIRST(sv);
3956 /* len is STRLEN which is unsigned, need to copy to signed */
3959 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3961 (void)SvUPGRADE(sv, SVt_PV);
3963 SvGROW(sv, len + 1);
3965 Move(ptr,dptr,len,char);
3968 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3973 =for apidoc sv_setpvn_mg
3975 Like C<sv_setpvn>, but also handles 'set' magic.
3981 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3983 sv_setpvn(sv,ptr,len);
3988 =for apidoc sv_setpv
3990 Copies a string into an SV. The string must be null-terminated. Does not
3991 handle 'set' magic. See C<sv_setpv_mg>.
3997 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3999 register STRLEN len;
4001 SV_CHECK_THINKFIRST(sv);
4007 (void)SvUPGRADE(sv, SVt_PV);
4009 SvGROW(sv, len + 1);
4010 Move(ptr,SvPVX(sv),len+1,char);
4012 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4017 =for apidoc sv_setpv_mg
4019 Like C<sv_setpv>, but also handles 'set' magic.
4025 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4032 =for apidoc sv_usepvn
4034 Tells an SV to use C<ptr> to find its string value. Normally the string is
4035 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4036 The C<ptr> should point to memory that was allocated by C<malloc>. The
4037 string length, C<len>, must be supplied. This function will realloc the
4038 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4039 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4040 See C<sv_usepvn_mg>.
4046 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4048 SV_CHECK_THINKFIRST(sv);
4049 (void)SvUPGRADE(sv, SVt_PV);
4054 (void)SvOOK_off(sv);
4055 if (SvPVX(sv) && SvLEN(sv))
4056 Safefree(SvPVX(sv));
4057 Renew(ptr, len+1, char);
4060 SvLEN_set(sv, len+1);
4062 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4067 =for apidoc sv_usepvn_mg
4069 Like C<sv_usepvn>, but also handles 'set' magic.
4075 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4077 sv_usepvn(sv,ptr,len);
4082 =for apidoc sv_force_normal_flags
4084 Undo various types of fakery on an SV: if the PV is a shared string, make
4085 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4086 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4087 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4093 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4095 if (SvREADONLY(sv)) {
4097 char *pvx = SvPVX(sv);
4098 STRLEN len = SvCUR(sv);
4099 U32 hash = SvUVX(sv);
4100 SvGROW(sv, len + 1);
4101 Move(pvx,SvPVX(sv),len,char);
4105 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4107 else if (PL_curcop != &PL_compiling)
4108 Perl_croak(aTHX_ PL_no_modify);
4111 sv_unref_flags(sv, flags);
4112 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4117 =for apidoc sv_force_normal
4119 Undo various types of fakery on an SV: if the PV is a shared string, make
4120 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4121 an xpvmg. See also C<sv_force_normal_flags>.
4127 Perl_sv_force_normal(pTHX_ register SV *sv)
4129 sv_force_normal_flags(sv, 0);
4135 Efficient removal of characters from the beginning of the string buffer.
4136 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4137 the string buffer. The C<ptr> becomes the first character of the adjusted
4138 string. Uses the "OOK hack".
4144 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4146 register STRLEN delta;
4148 if (!ptr || !SvPOKp(sv))
4150 SV_CHECK_THINKFIRST(sv);
4151 if (SvTYPE(sv) < SVt_PVIV)
4152 sv_upgrade(sv,SVt_PVIV);
4155 if (!SvLEN(sv)) { /* make copy of shared string */
4156 char *pvx = SvPVX(sv);
4157 STRLEN len = SvCUR(sv);
4158 SvGROW(sv, len + 1);
4159 Move(pvx,SvPVX(sv),len,char);
4163 SvFLAGS(sv) |= SVf_OOK;
4165 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4166 delta = ptr - SvPVX(sv);
4174 =for apidoc sv_catpvn
4176 Concatenates the string onto the end of the string which is in the SV. The
4177 C<len> indicates number of bytes to copy. If the SV has the UTF8
4178 status set, then the bytes appended should be valid UTF8.
4179 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4184 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4185 for binary compatibility only
4188 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4190 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4194 =for apidoc sv_catpvn_flags
4196 Concatenates the string onto the end of the string which is in the SV. The
4197 C<len> indicates number of bytes to copy. If the SV has the UTF8
4198 status set, then the bytes appended should be valid UTF8.
4199 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4200 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4201 in terms of this function.
4207 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4212 dstr = SvPV_force_flags(dsv, dlen, flags);
4213 SvGROW(dsv, dlen + slen + 1);
4216 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4219 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4224 =for apidoc sv_catpvn_mg
4226 Like C<sv_catpvn>, but also handles 'set' magic.
4232 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4234 sv_catpvn(sv,ptr,len);
4239 =for apidoc sv_catsv
4241 Concatenates the string from SV C<ssv> onto the end of the string in
4242 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4243 not 'set' magic. See C<sv_catsv_mg>.
4247 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4248 for binary compatibility only
4251 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4253 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4257 =for apidoc sv_catsv_flags
4259 Concatenates the string from SV C<ssv> onto the end of the string in
4260 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4261 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4262 and C<sv_catsv_nomg> are implemented in terms of this function.
4267 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4273 if ((spv = SvPV(ssv, slen))) {
4274 bool sutf8 = DO_UTF8(ssv);
4277 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4279 dutf8 = DO_UTF8(dsv);
4281 if (dutf8 != sutf8) {
4283 /* Not modifying source SV, so taking a temporary copy. */
4284 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4286 sv_utf8_upgrade(csv);
4287 spv = SvPV(csv, slen);
4290 sv_utf8_upgrade_nomg(dsv);
4292 sv_catpvn_nomg(dsv, spv, slen);
4297 =for apidoc sv_catsv_mg
4299 Like C<sv_catsv>, but also handles 'set' magic.
4305 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4312 =for apidoc sv_catpv
4314 Concatenates the string onto the end of the string which is in the SV.
4315 If the SV has the UTF8 status set, then the bytes appended should be
4316 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4321 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4323 register STRLEN len;
4329 junk = SvPV_force(sv, tlen);
4331 SvGROW(sv, tlen + len + 1);
4334 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4336 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4341 =for apidoc sv_catpv_mg
4343 Like C<sv_catpv>, but also handles 'set' magic.
4349 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4358 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4359 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4366 Perl_newSV(pTHX_ STRLEN len)
4372 sv_upgrade(sv, SVt_PV);
4373 SvGROW(sv, len + 1);
4379 =for apidoc sv_magic
4381 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4382 then adds a new magic item of type C<how> to the head of the magic list.
4384 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4390 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4394 if (SvREADONLY(sv)) {
4395 if (PL_curcop != &PL_compiling
4396 && how != PERL_MAGIC_regex_global
4397 && how != PERL_MAGIC_bm
4398 && how != PERL_MAGIC_fm
4399 && how != PERL_MAGIC_sv
4402 Perl_croak(aTHX_ PL_no_modify);
4405 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4406 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4407 if (how == PERL_MAGIC_taint)
4413 (void)SvUPGRADE(sv, SVt_PVMG);
4415 Newz(702,mg, 1, MAGIC);
4416 mg->mg_moremagic = SvMAGIC(sv);
4419 /* Some magic contains a reference loop, where the sv and object refer to
4420 each other. To avoid a reference loop that would prevent such objects
4421 being freed, we look for such loops and if we find one we avoid
4422 incrementing the object refcount. */
4423 if (!obj || obj == sv ||
4424 how == PERL_MAGIC_arylen ||
4425 how == PERL_MAGIC_qr ||
4426 (SvTYPE(obj) == SVt_PVGV &&
4427 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4428 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4429 GvFORM(obj) == (CV*)sv)))
4434 mg->mg_obj = SvREFCNT_inc(obj);
4435 mg->mg_flags |= MGf_REFCOUNTED;
4438 mg->mg_len = namlen;
4441 mg->mg_ptr = savepvn(name, namlen);
4442 else if (namlen == HEf_SVKEY)
4443 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4448 mg->mg_virtual = &PL_vtbl_sv;
4450 case PERL_MAGIC_overload:
4451 mg->mg_virtual = &PL_vtbl_amagic;
4453 case PERL_MAGIC_overload_elem:
4454 mg->mg_virtual = &PL_vtbl_amagicelem;
4456 case PERL_MAGIC_overload_table:
4457 mg->mg_virtual = &PL_vtbl_ovrld;
4460 mg->mg_virtual = &PL_vtbl_bm;
4462 case PERL_MAGIC_regdata:
4463 mg->mg_virtual = &PL_vtbl_regdata;
4465 case PERL_MAGIC_regdatum:
4466 mg->mg_virtual = &PL_vtbl_regdatum;
4468 case PERL_MAGIC_env:
4469 mg->mg_virtual = &PL_vtbl_env;
4472 mg->mg_virtual = &PL_vtbl_fm;
4474 case PERL_MAGIC_envelem:
4475 mg->mg_virtual = &PL_vtbl_envelem;
4477 case PERL_MAGIC_regex_global:
4478 mg->mg_virtual = &PL_vtbl_mglob;
4480 case PERL_MAGIC_isa:
4481 mg->mg_virtual = &PL_vtbl_isa;
4483 case PERL_MAGIC_isaelem:
4484 mg->mg_virtual = &PL_vtbl_isaelem;
4486 case PERL_MAGIC_nkeys:
4487 mg->mg_virtual = &PL_vtbl_nkeys;
4489 case PERL_MAGIC_dbfile:
4493 case PERL_MAGIC_dbline:
4494 mg->mg_virtual = &PL_vtbl_dbline;
4497 case PERL_MAGIC_mutex:
4498 mg->mg_virtual = &PL_vtbl_mutex;
4500 #endif /* USE_THREADS */
4501 #ifdef USE_LOCALE_COLLATE
4502 case PERL_MAGIC_collxfrm:
4503 mg->mg_virtual = &PL_vtbl_collxfrm;
4505 #endif /* USE_LOCALE_COLLATE */
4506 case PERL_MAGIC_tied:
4507 mg->mg_virtual = &PL_vtbl_pack;
4509 case PERL_MAGIC_tiedelem:
4510 case PERL_MAGIC_tiedscalar:
4511 mg->mg_virtual = &PL_vtbl_packelem;
4514 mg->mg_virtual = &PL_vtbl_regexp;
4516 case PERL_MAGIC_sig:
4517 mg->mg_virtual = &PL_vtbl_sig;
4519 case PERL_MAGIC_sigelem:
4520 mg->mg_virtual = &PL_vtbl_sigelem;
4522 case PERL_MAGIC_taint:
4523 mg->mg_virtual = &PL_vtbl_taint;
4526 case PERL_MAGIC_uvar:
4527 mg->mg_virtual = &PL_vtbl_uvar;
4529 case PERL_MAGIC_vec:
4530 mg->mg_virtual = &PL_vtbl_vec;
4532 case PERL_MAGIC_substr:
4533 mg->mg_virtual = &PL_vtbl_substr;
4535 case PERL_MAGIC_defelem:
4536 mg->mg_virtual = &PL_vtbl_defelem;
4538 case PERL_MAGIC_glob:
4539 mg->mg_virtual = &PL_vtbl_glob;
4541 case PERL_MAGIC_arylen:
4542 mg->mg_virtual = &PL_vtbl_arylen;
4544 case PERL_MAGIC_pos:
4545 mg->mg_virtual = &PL_vtbl_pos;
4547 case PERL_MAGIC_backref:
4548 mg->mg_virtual = &PL_vtbl_backref;
4550 case PERL_MAGIC_ext:
4551 /* Reserved for use by extensions not perl internals. */
4552 /* Useful for attaching extension internal data to perl vars. */
4553 /* Note that multiple extensions may clash if magical scalars */
4554 /* etc holding private data from one are passed to another. */
4558 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4562 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4566 =for apidoc sv_unmagic
4568 Removes all magic of type C<type> from an SV.
4574 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4578 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4581 for (mg = *mgp; mg; mg = *mgp) {
4582 if (mg->mg_type == type) {
4583 MGVTBL* vtbl = mg->mg_virtual;
4584 *mgp = mg->mg_moremagic;
4585 if (vtbl && vtbl->svt_free)
4586 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4587 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4588 if (mg->mg_len >= 0)
4589 Safefree(mg->mg_ptr);
4590 else if (mg->mg_len == HEf_SVKEY)
4591 SvREFCNT_dec((SV*)mg->mg_ptr);
4593 if (mg->mg_flags & MGf_REFCOUNTED)
4594 SvREFCNT_dec(mg->mg_obj);
4598 mgp = &mg->mg_moremagic;
4602 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4609 =for apidoc sv_rvweaken
4611 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4612 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4613 push a back-reference to this RV onto the array of backreferences
4614 associated with that magic.
4620 Perl_sv_rvweaken(pTHX_ SV *sv)
4623 if (!SvOK(sv)) /* let undefs pass */
4626 Perl_croak(aTHX_ "Can't weaken a nonreference");
4627 else if (SvWEAKREF(sv)) {
4628 if (ckWARN(WARN_MISC))
4629 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4633 sv_add_backref(tsv, sv);
4639 /* Give tsv backref magic if it hasn't already got it, then push a
4640 * back-reference to sv onto the array associated with the backref magic.
4644 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4648 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4649 av = (AV*)mg->mg_obj;
4652 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4653 SvREFCNT_dec(av); /* for sv_magic */
4658 /* delete a back-reference to ourselves from the backref magic associated
4659 * with the SV we point to.
4663 S_sv_del_backref(pTHX_ SV *sv)
4670 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4671 Perl_croak(aTHX_ "panic: del_backref");
4672 av = (AV *)mg->mg_obj;
4677 svp[i] = &PL_sv_undef; /* XXX */
4684 =for apidoc sv_insert
4686 Inserts a string at the specified offset/length within the SV. Similar to
4687 the Perl substr() function.
4693 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4697 register char *midend;
4698 register char *bigend;
4704 Perl_croak(aTHX_ "Can't modify non-existent substring");
4705 SvPV_force(bigstr, curlen);
4706 (void)SvPOK_only_UTF8(bigstr);
4707 if (offset + len > curlen) {
4708 SvGROW(bigstr, offset+len+1);
4709 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4710 SvCUR_set(bigstr, offset+len);
4714 i = littlelen - len;
4715 if (i > 0) { /* string might grow */
4716 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4717 mid = big + offset + len;
4718 midend = bigend = big + SvCUR(bigstr);
4721 while (midend > mid) /* shove everything down */
4722 *--bigend = *--midend;
4723 Move(little,big+offset,littlelen,char);
4729 Move(little,SvPVX(bigstr)+offset,len,char);
4734 big = SvPVX(bigstr);
4737 bigend = big + SvCUR(bigstr);
4739 if (midend > bigend)
4740 Perl_croak(aTHX_ "panic: sv_insert");
4742 if (mid - big > bigend - midend) { /* faster to shorten from end */
4744 Move(little, mid, littlelen,char);
4747 i = bigend - midend;
4749 Move(midend, mid, i,char);
4753 SvCUR_set(bigstr, mid - big);
4756 else if ((i = mid - big)) { /* faster from front */
4757 midend -= littlelen;
4759 sv_chop(bigstr,midend-i);
4764 Move(little, mid, littlelen,char);
4766 else if (littlelen) {
4767 midend -= littlelen;
4768 sv_chop(bigstr,midend);
4769 Move(little,midend,littlelen,char);
4772 sv_chop(bigstr,midend);
4778 =for apidoc sv_replace
4780 Make the first argument a copy of the second, then delete the original.
4781 The target SV physically takes over ownership of the body of the source SV
4782 and inherits its flags; however, the target keeps any magic it owns,
4783 and any magic in the source is discarded.
4784 Note that this is a rather specialist SV copying operation; most of the
4785 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4791 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4793 U32 refcnt = SvREFCNT(sv);
4794 SV_CHECK_THINKFIRST(sv);
4795 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4796 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4797 if (SvMAGICAL(sv)) {
4801 sv_upgrade(nsv, SVt_PVMG);
4802 SvMAGIC(nsv) = SvMAGIC(sv);
4803 SvFLAGS(nsv) |= SvMAGICAL(sv);
4809 assert(!SvREFCNT(sv));
4810 StructCopy(nsv,sv,SV);
4811 SvREFCNT(sv) = refcnt;
4812 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4817 =for apidoc sv_clear
4819 Clear an SV: call any destructors, free up any memory used by the body,
4820 and free the body itself. The SV's head is I<not> freed, although
4821 its type is set to all 1's so that it won't inadvertently be assumed
4822 to be live during global destruction etc.
4823 This function should only be called when REFCNT is zero. Most of the time
4824 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4831 Perl_sv_clear(pTHX_ register SV *sv)
4835 assert(SvREFCNT(sv) == 0);
4838 if (PL_defstash) { /* Still have a symbol table? */
4843 Zero(&tmpref, 1, SV);
4844 sv_upgrade(&tmpref, SVt_RV);
4846 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4847 SvREFCNT(&tmpref) = 1;
4850 stash = SvSTASH(sv);
4851 destructor = StashHANDLER(stash,DESTROY);
4854 PUSHSTACKi(PERLSI_DESTROY);
4855 SvRV(&tmpref) = SvREFCNT_inc(sv);
4860 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4866 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4868 del_XRV(SvANY(&tmpref));
4871 if (PL_in_clean_objs)
4872 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4874 /* DESTROY gave object new lease on life */
4880 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4881 SvOBJECT_off(sv); /* Curse the object. */
4882 if (SvTYPE(sv) != SVt_PVIO)
4883 --PL_sv_objcount; /* XXX Might want something more general */
4886 if (SvTYPE(sv) >= SVt_PVMG) {
4889 if (SvFLAGS(sv) & SVpad_TYPED)
4890 SvREFCNT_dec(SvSTASH(sv));
4893 switch (SvTYPE(sv)) {
4896 IoIFP(sv) != PerlIO_stdin() &&
4897 IoIFP(sv) != PerlIO_stdout() &&
4898 IoIFP(sv) != PerlIO_stderr())
4900 io_close((IO*)sv, FALSE);
4902 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4903 PerlDir_close(IoDIRP(sv));
4904 IoDIRP(sv) = (DIR*)NULL;
4905 Safefree(IoTOP_NAME(sv));
4906 Safefree(IoFMT_NAME(sv));
4907 Safefree(IoBOTTOM_NAME(sv));
4922 SvREFCNT_dec(LvTARG(sv));
4926 Safefree(GvNAME(sv));
4927 /* cannot decrease stash refcount yet, as we might recursively delete
4928 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4929 of stash until current sv is completely gone.
4930 -- JohnPC, 27 Mar 1998 */
4931 stash = GvSTASH(sv);
4937 (void)SvOOK_off(sv);
4945 SvREFCNT_dec(SvRV(sv));
4947 else if (SvPVX(sv) && SvLEN(sv))
4948 Safefree(SvPVX(sv));
4949 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4950 unsharepvn(SvPVX(sv),
4951 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
4964 switch (SvTYPE(sv)) {
4980 del_XPVIV(SvANY(sv));
4983 del_XPVNV(SvANY(sv));
4986 del_XPVMG(SvANY(sv));
4989 del_XPVLV(SvANY(sv));
4992 del_XPVAV(SvANY(sv));
4995 del_XPVHV(SvANY(sv));
4998 del_XPVCV(SvANY(sv));
5001 del_XPVGV(SvANY(sv));
5002 /* code duplication for increased performance. */
5003 SvFLAGS(sv) &= SVf_BREAK;
5004 SvFLAGS(sv) |= SVTYPEMASK;
5005 /* decrease refcount of the stash that owns this GV, if any */
5007 SvREFCNT_dec(stash);
5008 return; /* not break, SvFLAGS reset already happened */
5010 del_XPVBM(SvANY(sv));
5013 del_XPVFM(SvANY(sv));
5016 del_XPVIO(SvANY(sv));
5019 SvFLAGS(sv) &= SVf_BREAK;
5020 SvFLAGS(sv) |= SVTYPEMASK;
5024 =for apidoc sv_newref
5026 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5033 Perl_sv_newref(pTHX_ SV *sv)
5036 ATOMIC_INC(SvREFCNT(sv));
5043 Decrement an SV's reference count, and if it drops to zero, call
5044 C<sv_clear> to invoke destructors and free up any memory used by
5045 the body; finally, deallocate the SV's head itself.
5046 Normally called via a wrapper macro C<SvREFCNT_dec>.
5052 Perl_sv_free(pTHX_ SV *sv)
5054 int refcount_is_zero;
5058 if (SvREFCNT(sv) == 0) {
5059 if (SvFLAGS(sv) & SVf_BREAK)
5060 /* this SV's refcnt has been artificially decremented to
5061 * trigger cleanup */
5063 if (PL_in_clean_all) /* All is fair */
5065 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5066 /* make sure SvREFCNT(sv)==0 happens very seldom */
5067 SvREFCNT(sv) = (~(U32)0)/2;
5070 if (ckWARN_d(WARN_INTERNAL))
5071 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5074 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5075 if (!refcount_is_zero)
5079 if (ckWARN_d(WARN_DEBUGGING))
5080 Perl_warner(aTHX_ WARN_DEBUGGING,
5081 "Attempt to free temp prematurely: SV 0x%"UVxf,
5086 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5087 /* make sure SvREFCNT(sv)==0 happens very seldom */
5088 SvREFCNT(sv) = (~(U32)0)/2;
5099 Returns the length of the string in the SV. Handles magic and type
5100 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5106 Perl_sv_len(pTHX_ register SV *sv)
5114 len = mg_length(sv);
5116 (void)SvPV(sv, len);
5121 =for apidoc sv_len_utf8
5123 Returns the number of characters in the string in an SV, counting wide
5124 UTF8 bytes as a single character. Handles magic and type coercion.
5130 Perl_sv_len_utf8(pTHX_ register SV *sv)
5136 return mg_length(sv);
5140 U8 *s = (U8*)SvPV(sv, len);
5142 return Perl_utf8_length(aTHX_ s, s + len);
5147 =for apidoc sv_pos_u2b
5149 Converts the value pointed to by offsetp from a count of UTF8 chars from
5150 the start of the string, to a count of the equivalent number of bytes; if
5151 lenp is non-zero, it does the same to lenp, but this time starting from
5152 the offset, rather than from the start of the string. Handles magic and
5159 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5164 I32 uoffset = *offsetp;
5170 start = s = (U8*)SvPV(sv, len);
5172 while (s < send && uoffset--)
5176 *offsetp = s - start;
5180 while (s < send && ulen--)
5190 =for apidoc sv_pos_b2u
5192 Converts the value pointed to by offsetp from a count of bytes from the
5193 start of the string, to a count of the equivalent number of UTF8 chars.
5194 Handles magic and type coercion.
5200 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5209 s = (U8*)SvPV(sv, len);
5211 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5212 send = s + *offsetp;
5216 /* Call utf8n_to_uvchr() to validate the sequence */
5217 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5232 Returns a boolean indicating whether the strings in the two SVs are
5233 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5234 coerce its args to strings if necessary.
5240 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5254 pv1 = SvPV(sv1, cur1);
5261 pv2 = SvPV(sv2, cur2);
5263 /* do not utf8ize the comparands as a side-effect */
5264 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5265 bool is_utf8 = TRUE;
5266 /* UTF-8ness differs */
5267 if (PL_hints & HINT_UTF8_DISTINCT)
5271 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5272 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5277 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5278 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5283 /* Downgrade not possible - cannot be eq */
5289 eq = memEQ(pv1, pv2, cur1);
5300 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5301 string in C<sv1> is less than, equal to, or greater than the string in
5302 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5303 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5309 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5314 bool pv1tmp = FALSE;
5315 bool pv2tmp = FALSE;
5322 pv1 = SvPV(sv1, cur1);
5329 pv2 = SvPV(sv2, cur2);
5331 /* do not utf8ize the comparands as a side-effect */
5332 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5333 if (PL_hints & HINT_UTF8_DISTINCT)
5334 return SvUTF8(sv1) ? 1 : -1;
5337 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5341 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5347 cmp = cur2 ? -1 : 0;
5351 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5354 cmp = retval < 0 ? -1 : 1;
5355 } else if (cur1 == cur2) {
5358 cmp = cur1 < cur2 ? -1 : 1;
5371 =for apidoc sv_cmp_locale
5373 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5374 'use bytes' aware, handles get magic, and will coerce its args to strings
5375 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5381 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5383 #ifdef USE_LOCALE_COLLATE
5389 if (PL_collation_standard)
5393 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5395 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5397 if (!pv1 || !len1) {
5408 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5411 return retval < 0 ? -1 : 1;
5414 * When the result of collation is equality, that doesn't mean
5415 * that there are no differences -- some locales exclude some
5416 * characters from consideration. So to avoid false equalities,
5417 * we use the raw string as a tiebreaker.
5423 #endif /* USE_LOCALE_COLLATE */
5425 return sv_cmp(sv1, sv2);
5429 #ifdef USE_LOCALE_COLLATE
5432 =for apidoc sv_collxfrm
5434 Add Collate Transform magic to an SV if it doesn't already have it.
5436 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5437 scalar data of the variable, but transformed to such a format that a normal
5438 memory comparison can be used to compare the data according to the locale
5445 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5449 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5450 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5455 Safefree(mg->mg_ptr);
5457 if ((xf = mem_collxfrm(s, len, &xlen))) {
5458 if (SvREADONLY(sv)) {
5461 return xf + sizeof(PL_collation_ix);
5464 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5465 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5478 if (mg && mg->mg_ptr) {
5480 return mg->mg_ptr + sizeof(PL_collation_ix);
5488 #endif /* USE_LOCALE_COLLATE */
5493 Get a line from the filehandle and store it into the SV, optionally
5494 appending to the currently-stored string.
5500 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5504 register STDCHAR rslast;
5505 register STDCHAR *bp;
5509 SV_CHECK_THINKFIRST(sv);
5510 (void)SvUPGRADE(sv, SVt_PV);
5514 if (RsSNARF(PL_rs)) {
5518 else if (RsRECORD(PL_rs)) {
5519 I32 recsize, bytesread;
5522 /* Grab the size of the record we're getting */
5523 recsize = SvIV(SvRV(PL_rs));
5524 (void)SvPOK_only(sv); /* Validate pointer */
5525 buffer = SvGROW(sv, recsize + 1);
5528 /* VMS wants read instead of fread, because fread doesn't respect */
5529 /* RMS record boundaries. This is not necessarily a good thing to be */
5530 /* doing, but we've got no other real choice */
5531 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5533 bytesread = PerlIO_read(fp, buffer, recsize);
5535 SvCUR_set(sv, bytesread);
5536 buffer[bytesread] = '\0';
5537 if (PerlIO_isutf8(fp))
5541 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5543 else if (RsPARA(PL_rs)) {
5548 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5549 if (PerlIO_isutf8(fp)) {
5550 rsptr = SvPVutf8(PL_rs, rslen);
5553 if (SvUTF8(PL_rs)) {
5554 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5555 Perl_croak(aTHX_ "Wide character in $/");
5558 rsptr = SvPV(PL_rs, rslen);
5562 rslast = rslen ? rsptr[rslen - 1] : '\0';
5564 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5565 do { /* to make sure file boundaries work right */
5568 i = PerlIO_getc(fp);
5572 PerlIO_ungetc(fp,i);
5578 /* See if we know enough about I/O mechanism to cheat it ! */
5580 /* This used to be #ifdef test - it is made run-time test for ease
5581 of abstracting out stdio interface. One call should be cheap
5582 enough here - and may even be a macro allowing compile
5586 if (PerlIO_fast_gets(fp)) {
5589 * We're going to steal some values from the stdio struct
5590 * and put EVERYTHING in the innermost loop into registers.
5592 register STDCHAR *ptr;
5596 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5597 /* An ungetc()d char is handled separately from the regular
5598 * buffer, so we getc() it back out and stuff it in the buffer.
5600 i = PerlIO_getc(fp);
5601 if (i == EOF) return 0;
5602 *(--((*fp)->_ptr)) = (unsigned char) i;
5606 /* Here is some breathtakingly efficient cheating */
5608 cnt = PerlIO_get_cnt(fp); /* get count into register */
5609 (void)SvPOK_only(sv); /* validate pointer */
5610 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5611 if (cnt > 80 && SvLEN(sv) > append) {
5612 shortbuffered = cnt - SvLEN(sv) + append + 1;
5613 cnt -= shortbuffered;
5617 /* remember that cnt can be negative */
5618 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5623 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5624 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5625 DEBUG_P(PerlIO_printf(Perl_debug_log,
5626 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5627 DEBUG_P(PerlIO_printf(Perl_debug_log,
5628 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5629 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5630 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5635 while (cnt > 0) { /* this | eat */
5637 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5638 goto thats_all_folks; /* screams | sed :-) */
5642 Copy(ptr, bp, cnt, char); /* this | eat */
5643 bp += cnt; /* screams | dust */
5644 ptr += cnt; /* louder | sed :-) */
5649 if (shortbuffered) { /* oh well, must extend */
5650 cnt = shortbuffered;
5652 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5654 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5655 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5659 DEBUG_P(PerlIO_printf(Perl_debug_log,
5660 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5661 PTR2UV(ptr),(long)cnt));
5662 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5663 DEBUG_P(PerlIO_printf(Perl_debug_log,
5664 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5665 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5666 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5667 /* This used to call 'filbuf' in stdio form, but as that behaves like
5668 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5669 another abstraction. */
5670 i = PerlIO_getc(fp); /* get more characters */
5671 DEBUG_P(PerlIO_printf(Perl_debug_log,
5672 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5673 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5674 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5675 cnt = PerlIO_get_cnt(fp);
5676 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5677 DEBUG_P(PerlIO_printf(Perl_debug_log,
5678 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5680 if (i == EOF) /* all done for ever? */
5681 goto thats_really_all_folks;
5683 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5685 SvGROW(sv, bpx + cnt + 2);
5686 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5688 *bp++ = i; /* store character from PerlIO_getc */
5690 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5691 goto thats_all_folks;
5695 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5696 memNE((char*)bp - rslen, rsptr, rslen))
5697 goto screamer; /* go back to the fray */
5698 thats_really_all_folks:
5700 cnt += shortbuffered;
5701 DEBUG_P(PerlIO_printf(Perl_debug_log,
5702 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5703 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5704 DEBUG_P(PerlIO_printf(Perl_debug_log,
5705 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5706 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5707 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5709 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5710 DEBUG_P(PerlIO_printf(Perl_debug_log,
5711 "Screamer: done, len=%ld, string=|%.*s|\n",
5712 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5717 /*The big, slow, and stupid way */
5720 /* Need to work around EPOC SDK features */
5721 /* On WINS: MS VC5 generates calls to _chkstk, */
5722 /* if a `large' stack frame is allocated */
5723 /* gcc on MARM does not generate calls like these */
5729 register STDCHAR *bpe = buf + sizeof(buf);
5731 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5732 ; /* keep reading */
5736 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5737 /* Accomodate broken VAXC compiler, which applies U8 cast to
5738 * both args of ?: operator, causing EOF to change into 255
5740 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5744 sv_catpvn(sv, (char *) buf, cnt);
5746 sv_setpvn(sv, (char *) buf, cnt);
5748 if (i != EOF && /* joy */
5750 SvCUR(sv) < rslen ||
5751 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5755 * If we're reading from a TTY and we get a short read,
5756 * indicating that the user hit his EOF character, we need
5757 * to notice it now, because if we try to read from the TTY
5758 * again, the EOF condition will disappear.
5760 * The comparison of cnt to sizeof(buf) is an optimization
5761 * that prevents unnecessary calls to feof().
5765 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5770 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5771 while (i != EOF) { /* to make sure file boundaries work right */
5772 i = PerlIO_getc(fp);
5774 PerlIO_ungetc(fp,i);
5780 if (PerlIO_isutf8(fp))
5785 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5791 Auto-increment of the value in the SV, doing string to numeric conversion
5792 if necessary. Handles 'get' magic.
5798 Perl_sv_inc(pTHX_ register SV *sv)
5807 if (SvTHINKFIRST(sv)) {
5808 if (SvREADONLY(sv)) {
5809 if (PL_curcop != &PL_compiling)
5810 Perl_croak(aTHX_ PL_no_modify);
5814 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5816 i = PTR2IV(SvRV(sv));
5821 flags = SvFLAGS(sv);
5822 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5823 /* It's (privately or publicly) a float, but not tested as an
5824 integer, so test it to see. */
5826 flags = SvFLAGS(sv);
5828 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5829 /* It's publicly an integer, or privately an integer-not-float */
5832 if (SvUVX(sv) == UV_MAX)
5833 sv_setnv(sv, (NV)UV_MAX + 1.0);
5835 (void)SvIOK_only_UV(sv);
5838 if (SvIVX(sv) == IV_MAX)
5839 sv_setuv(sv, (UV)IV_MAX + 1);
5841 (void)SvIOK_only(sv);
5847 if (flags & SVp_NOK) {
5848 (void)SvNOK_only(sv);
5853 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5854 if ((flags & SVTYPEMASK) < SVt_PVIV)
5855 sv_upgrade(sv, SVt_IV);
5856 (void)SvIOK_only(sv);
5861 while (isALPHA(*d)) d++;
5862 while (isDIGIT(*d)) d++;
5864 #ifdef PERL_PRESERVE_IVUV
5865 /* Got to punt this an an integer if needs be, but we don't issue
5866 warnings. Probably ought to make the sv_iv_please() that does
5867 the conversion if possible, and silently. */
5868 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5869 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5870 /* Need to try really hard to see if it's an integer.
5871 9.22337203685478e+18 is an integer.
5872 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5873 so $a="9.22337203685478e+18"; $a+0; $a++
5874 needs to be the same as $a="9.22337203685478e+18"; $a++
5881 /* sv_2iv *should* have made this an NV */
5882 if (flags & SVp_NOK) {
5883 (void)SvNOK_only(sv);
5887 /* I don't think we can get here. Maybe I should assert this
5888 And if we do get here I suspect that sv_setnv will croak. NWC
5890 #if defined(USE_LONG_DOUBLE)
5891 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",
5892 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5894 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5895 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5898 #endif /* PERL_PRESERVE_IVUV */
5899 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5903 while (d >= SvPVX(sv)) {
5911 /* MKS: The original code here died if letters weren't consecutive.
5912 * at least it didn't have to worry about non-C locales. The
5913 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5914 * arranged in order (although not consecutively) and that only
5915 * [A-Za-z] are accepted by isALPHA in the C locale.
5917 if (*d != 'z' && *d != 'Z') {
5918 do { ++*d; } while (!isALPHA(*d));
5921 *(d--) -= 'z' - 'a';
5926 *(d--) -= 'z' - 'a' + 1;
5930 /* oh,oh, the number grew */
5931 SvGROW(sv, SvCUR(sv) + 2);
5933 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5944 Auto-decrement of the value in the SV, doing string to numeric conversion
5945 if necessary. Handles 'get' magic.
5951 Perl_sv_dec(pTHX_ register SV *sv)
5959 if (SvTHINKFIRST(sv)) {
5960 if (SvREADONLY(sv)) {
5961 if (PL_curcop != &PL_compiling)
5962 Perl_croak(aTHX_ PL_no_modify);
5966 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5968 i = PTR2IV(SvRV(sv));
5973 /* Unlike sv_inc we don't have to worry about string-never-numbers
5974 and keeping them magic. But we mustn't warn on punting */
5975 flags = SvFLAGS(sv);
5976 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5977 /* It's publicly an integer, or privately an integer-not-float */
5980 if (SvUVX(sv) == 0) {
5981 (void)SvIOK_only(sv);
5985 (void)SvIOK_only_UV(sv);
5989 if (SvIVX(sv) == IV_MIN)
5990 sv_setnv(sv, (NV)IV_MIN - 1.0);
5992 (void)SvIOK_only(sv);
5998 if (flags & SVp_NOK) {
6000 (void)SvNOK_only(sv);
6003 if (!(flags & SVp_POK)) {
6004 if ((flags & SVTYPEMASK) < SVt_PVNV)
6005 sv_upgrade(sv, SVt_NV);
6007 (void)SvNOK_only(sv);
6010 #ifdef PERL_PRESERVE_IVUV
6012 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6013 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6014 /* Need to try really hard to see if it's an integer.
6015 9.22337203685478e+18 is an integer.
6016 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6017 so $a="9.22337203685478e+18"; $a+0; $a--
6018 needs to be the same as $a="9.22337203685478e+18"; $a--
6025 /* sv_2iv *should* have made this an NV */
6026 if (flags & SVp_NOK) {
6027 (void)SvNOK_only(sv);
6031 /* I don't think we can get here. Maybe I should assert this
6032 And if we do get here I suspect that sv_setnv will croak. NWC
6034 #if defined(USE_LONG_DOUBLE)
6035 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",
6036 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6038 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6039 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6043 #endif /* PERL_PRESERVE_IVUV */
6044 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6048 =for apidoc sv_mortalcopy
6050 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6051 The new SV is marked as mortal. It will be destroyed when the current
6052 context ends. See also C<sv_newmortal> and C<sv_2mortal>.
6057 /* Make a string that will exist for the duration of the expression
6058 * evaluation. Actually, it may have to last longer than that, but
6059 * hopefully we won't free it until it has been assigned to a
6060 * permanent location. */
6063 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6068 sv_setsv(sv,oldstr);
6070 PL_tmps_stack[++PL_tmps_ix] = sv;
6076 =for apidoc sv_newmortal
6078 Creates a new null SV which is mortal. The reference count of the SV is
6079 set to 1. It will be destroyed when the current context ends. See
6080 also C<sv_mortalcopy> and C<sv_2mortal>.
6086 Perl_sv_newmortal(pTHX)
6091 SvFLAGS(sv) = SVs_TEMP;
6093 PL_tmps_stack[++PL_tmps_ix] = sv;
6098 =for apidoc sv_2mortal
6100 Marks an existing SV as mortal. The SV will be destroyed when the current
6101 context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
6107 Perl_sv_2mortal(pTHX_ register SV *sv)
6111 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6114 PL_tmps_stack[++PL_tmps_ix] = sv;
6122 Creates a new SV and copies a string into it. The reference count for the
6123 SV is set to 1. If C<len> is zero, Perl will compute the length using
6124 strlen(). For efficiency, consider using C<newSVpvn> instead.
6130 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6137 sv_setpvn(sv,s,len);
6142 =for apidoc newSVpvn
6144 Creates a new SV and copies a string into it. The reference count for the
6145 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6146 string. You are responsible for ensuring that the source string is at least
6153 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6158 sv_setpvn(sv,s,len);
6163 =for apidoc newSVpvn_share
6165 Creates a new SV with its SvPVX pointing to a shared string in the string
6166 table. If the string does not already exist in the table, it is created
6167 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6168 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6169 otherwise the hash is computed. The idea here is that as the string table
6170 is used for shared hash keys these strings will have SvPVX == HeKEY and
6171 hash lookup will avoid string compare.
6177 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6180 bool is_utf8 = FALSE;
6185 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
6186 STRLEN tmplen = len;
6187 /* See the note in hv.c:hv_fetch() --jhi */
6188 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6192 PERL_HASH(hash, src, len);
6194 sv_upgrade(sv, SVt_PVIV);
6195 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6208 #if defined(PERL_IMPLICIT_CONTEXT)
6210 /* pTHX_ magic can't cope with varargs, so this is a no-context
6211 * version of the main function, (which may itself be aliased to us).
6212 * Don't access this version directly.
6216 Perl_newSVpvf_nocontext(const char* pat, ...)
6221 va_start(args, pat);
6222 sv = vnewSVpvf(pat, &args);
6229 =for apidoc newSVpvf
6231 Creates a new SV and initializes it with the string formatted like
6238 Perl_newSVpvf(pTHX_ const char* pat, ...)
6242 va_start(args, pat);
6243 sv = vnewSVpvf(pat, &args);
6248 /* backend for newSVpvf() and newSVpvf_nocontext() */
6251 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6255 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6262 Creates a new SV and copies a floating point value into it.
6263 The reference count for the SV is set to 1.
6269 Perl_newSVnv(pTHX_ NV n)
6281 Creates a new SV and copies an integer into it. The reference count for the
6288 Perl_newSViv(pTHX_ IV i)
6300 Creates a new SV and copies an unsigned integer into it.
6301 The reference count for the SV is set to 1.
6307 Perl_newSVuv(pTHX_ UV u)
6317 =for apidoc newRV_noinc
6319 Creates an RV wrapper for an SV. The reference count for the original
6320 SV is B<not> incremented.
6326 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6331 sv_upgrade(sv, SVt_RV);
6338 /* newRV_inc is the official function name to use now.
6339 * newRV_inc is in fact #defined to newRV in sv.h
6343 Perl_newRV(pTHX_ SV *tmpRef)
6345 return newRV_noinc(SvREFCNT_inc(tmpRef));
6351 Creates a new SV which is an exact duplicate of the original SV.
6358 Perl_newSVsv(pTHX_ register SV *old)
6364 if (SvTYPE(old) == SVTYPEMASK) {
6365 if (ckWARN_d(WARN_INTERNAL))
6366 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6381 =for apidoc sv_reset
6383 Underlying implementation for the C<reset> Perl function.
6384 Note that the perl-level function is vaguely deprecated.
6390 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6398 char todo[PERL_UCHAR_MAX+1];
6403 if (!*s) { /* reset ?? searches */
6404 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6405 pm->op_pmdynflags &= ~PMdf_USED;
6410 /* reset variables */
6412 if (!HvARRAY(stash))
6415 Zero(todo, 256, char);
6417 i = (unsigned char)*s;
6421 max = (unsigned char)*s++;
6422 for ( ; i <= max; i++) {
6425 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6426 for (entry = HvARRAY(stash)[i];
6428 entry = HeNEXT(entry))
6430 if (!todo[(U8)*HeKEY(entry)])
6432 gv = (GV*)HeVAL(entry);
6434 if (SvTHINKFIRST(sv)) {
6435 if (!SvREADONLY(sv) && SvROK(sv))
6440 if (SvTYPE(sv) >= SVt_PV) {
6442 if (SvPVX(sv) != Nullch)
6449 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6451 #ifdef USE_ENVIRON_ARRAY
6453 environ[0] = Nullch;
6464 Using various gambits, try to get an IO from an SV: the IO slot if its a
6465 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6466 named after the PV if we're a string.
6472 Perl_sv_2io(pTHX_ SV *sv)
6478 switch (SvTYPE(sv)) {
6486 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6490 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6492 return sv_2io(SvRV(sv));
6493 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6499 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6508 Using various gambits, try to get a CV from an SV; in addition, try if
6509 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6515 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6522 return *gvp = Nullgv, Nullcv;
6523 switch (SvTYPE(sv)) {
6542 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6543 tryAMAGICunDEREF(to_cv);
6546 if (SvTYPE(sv) == SVt_PVCV) {
6555 Perl_croak(aTHX_ "Not a subroutine reference");
6560 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6566 if (lref && !GvCVu(gv)) {
6569 tmpsv = NEWSV(704,0);
6570 gv_efullname3(tmpsv, gv, Nullch);
6571 /* XXX this is probably not what they think they're getting.
6572 * It has the same effect as "sub name;", i.e. just a forward
6574 newSUB(start_subparse(FALSE, 0),
6575 newSVOP(OP_CONST, 0, tmpsv),
6580 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6589 Returns true if the SV has a true value by Perl's rules.
6590 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6591 instead use an in-line version.
6597 Perl_sv_true(pTHX_ register SV *sv)
6603 if ((tXpv = (XPV*)SvANY(sv)) &&
6604 (tXpv->xpv_cur > 1 ||
6605 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6612 return SvIVX(sv) != 0;
6615 return SvNVX(sv) != 0.0;
6617 return sv_2bool(sv);
6625 A private implementation of the C<SvIVx> macro for compilers which can't
6626 cope with complex macro expressions. Always use the macro instead.
6632 Perl_sv_iv(pTHX_ register SV *sv)
6636 return (IV)SvUVX(sv);
6645 A private implementation of the C<SvUVx> macro for compilers which can't
6646 cope with complex macro expressions. Always use the macro instead.
6652 Perl_sv_uv(pTHX_ register SV *sv)
6657 return (UV)SvIVX(sv);
6665 A private implementation of the C<SvNVx> macro for compilers which can't
6666 cope with complex macro expressions. Always use the macro instead.
6672 Perl_sv_nv(pTHX_ register SV *sv)
6682 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6683 cope with complex macro expressions. Always use the macro instead.
6689 Perl_sv_pv(pTHX_ SV *sv)
6696 return sv_2pv(sv, &n_a);
6702 A private implementation of the C<SvPV> macro for compilers which can't
6703 cope with complex macro expressions. Always use the macro instead.
6709 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6715 return sv_2pv(sv, lp);
6719 =for apidoc sv_pvn_force
6721 Get a sensible string out of the SV somehow.
6722 A private implementation of the C<SvPV_force> macro for compilers which
6723 can't cope with complex macro expressions. Always use the macro instead.
6729 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6731 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6735 =for apidoc sv_pvn_force_flags
6737 Get a sensible string out of the SV somehow.
6738 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6739 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6740 implemented in terms of this function.
6741 You normally want to use the various wrapper macros instead: see
6742 C<SvPV_force> and C<SvPV_force_nomg>
6748 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6752 if (SvTHINKFIRST(sv) && !SvROK(sv))
6753 sv_force_normal(sv);
6759 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6760 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6761 PL_op_name[PL_op->op_type]);
6764 s = sv_2pv_flags(sv, lp, flags);
6765 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6770 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6771 SvGROW(sv, len + 1);
6772 Move(s,SvPVX(sv),len,char);
6777 SvPOK_on(sv); /* validate pointer */
6779 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6780 PTR2UV(sv),SvPVX(sv)));
6787 =for apidoc sv_pvbyte
6789 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6790 which can't cope with complex macro expressions. Always use the macro
6797 Perl_sv_pvbyte(pTHX_ SV *sv)
6799 sv_utf8_downgrade(sv,0);
6804 =for apidoc sv_pvbyten
6806 A private implementation of the C<SvPVbyte> macro for compilers
6807 which can't cope with complex macro expressions. Always use the macro
6814 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6816 sv_utf8_downgrade(sv,0);
6817 return sv_pvn(sv,lp);
6821 =for apidoc sv_pvbyten_force
6823 A private implementation of the C<SvPVbytex_force> macro for compilers
6824 which can't cope with complex macro expressions. Always use the macro
6831 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6833 sv_utf8_downgrade(sv,0);
6834 return sv_pvn_force(sv,lp);
6838 =for apidoc sv_pvutf8
6840 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6841 which can't cope with complex macro expressions. Always use the macro
6848 Perl_sv_pvutf8(pTHX_ SV *sv)
6850 sv_utf8_upgrade(sv);
6855 =for apidoc sv_pvutf8n
6857 A private implementation of the C<SvPVutf8> macro for compilers
6858 which can't cope with complex macro expressions. Always use the macro
6865 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6867 sv_utf8_upgrade(sv);
6868 return sv_pvn(sv,lp);
6872 =for apidoc sv_pvutf8n_force
6874 A private implementation of the C<SvPVutf8_force> macro for compilers
6875 which can't cope with complex macro expressions. Always use the macro
6882 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6884 sv_utf8_upgrade(sv);
6885 return sv_pvn_force(sv,lp);
6889 =for apidoc sv_reftype
6891 Returns a string describing what the SV is a reference to.
6897 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6899 if (ob && SvOBJECT(sv))
6900 return HvNAME(SvSTASH(sv));
6902 switch (SvTYPE(sv)) {
6916 case SVt_PVLV: return "LVALUE";
6917 case SVt_PVAV: return "ARRAY";
6918 case SVt_PVHV: return "HASH";
6919 case SVt_PVCV: return "CODE";
6920 case SVt_PVGV: return "GLOB";
6921 case SVt_PVFM: return "FORMAT";
6922 case SVt_PVIO: return "IO";
6923 default: return "UNKNOWN";
6929 =for apidoc sv_isobject
6931 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6932 object. If the SV is not an RV, or if the object is not blessed, then this
6939 Perl_sv_isobject(pTHX_ SV *sv)
6956 Returns a boolean indicating whether the SV is blessed into the specified
6957 class. This does not check for subtypes; use C<sv_derived_from> to verify
6958 an inheritance relationship.
6964 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6976 return strEQ(HvNAME(SvSTASH(sv)), name);
6982 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6983 it will be upgraded to one. If C<classname> is non-null then the new SV will
6984 be blessed in the specified package. The new SV is returned and its
6985 reference count is 1.
6991 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6997 SV_CHECK_THINKFIRST(rv);
7000 if (SvTYPE(rv) >= SVt_PVMG) {
7001 U32 refcnt = SvREFCNT(rv);
7005 SvREFCNT(rv) = refcnt;
7008 if (SvTYPE(rv) < SVt_RV)
7009 sv_upgrade(rv, SVt_RV);
7010 else if (SvTYPE(rv) > SVt_RV) {
7011 (void)SvOOK_off(rv);
7012 if (SvPVX(rv) && SvLEN(rv))
7013 Safefree(SvPVX(rv));
7023 HV* stash = gv_stashpv(classname, TRUE);
7024 (void)sv_bless(rv, stash);
7030 =for apidoc sv_setref_pv
7032 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7033 argument will be upgraded to an RV. That RV will be modified to point to
7034 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7035 into the SV. The C<classname> argument indicates the package for the
7036 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7037 will be returned and will have a reference count of 1.
7039 Do not use with other Perl types such as HV, AV, SV, CV, because those
7040 objects will become corrupted by the pointer copy process.
7042 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7048 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7051 sv_setsv(rv, &PL_sv_undef);
7055 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7060 =for apidoc sv_setref_iv
7062 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7063 argument will be upgraded to an RV. That RV will be modified to point to
7064 the new SV. The C<classname> argument indicates the package for the
7065 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7066 will be returned and will have a reference count of 1.
7072 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7074 sv_setiv(newSVrv(rv,classname), iv);
7079 =for apidoc sv_setref_uv
7081 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7082 argument will be upgraded to an RV. That RV will be modified to point to
7083 the new SV. The C<classname> argument indicates the package for the
7084 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7085 will be returned and will have a reference count of 1.
7091 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7093 sv_setuv(newSVrv(rv,classname), uv);
7098 =for apidoc sv_setref_nv
7100 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7101 argument will be upgraded to an RV. That RV will be modified to point to
7102 the new SV. The C<classname> argument indicates the package for the
7103 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7104 will be returned and will have a reference count of 1.
7110 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7112 sv_setnv(newSVrv(rv,classname), nv);
7117 =for apidoc sv_setref_pvn
7119 Copies a string into a new SV, optionally blessing the SV. The length of the
7120 string must be specified with C<n>. The C<rv> argument will be upgraded to
7121 an RV. That RV will be modified to point to the new SV. The C<classname>
7122 argument indicates the package for the blessing. Set C<classname> to
7123 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7124 a reference count of 1.
7126 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7132 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7134 sv_setpvn(newSVrv(rv,classname), pv, n);
7139 =for apidoc sv_bless
7141 Blesses an SV into a specified package. The SV must be an RV. The package
7142 must be designated by its stash (see C<gv_stashpv()>). The reference count
7143 of the SV is unaffected.
7149 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7153 Perl_croak(aTHX_ "Can't bless non-reference value");
7155 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7156 if (SvREADONLY(tmpRef))
7157 Perl_croak(aTHX_ PL_no_modify);
7158 if (SvOBJECT(tmpRef)) {
7159 if (SvTYPE(tmpRef) != SVt_PVIO)
7161 SvREFCNT_dec(SvSTASH(tmpRef));
7164 SvOBJECT_on(tmpRef);
7165 if (SvTYPE(tmpRef) != SVt_PVIO)
7167 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7168 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7178 /* Downgrades a PVGV to a PVMG.
7180 * XXX This function doesn't actually appear to be used anywhere
7185 S_sv_unglob(pTHX_ SV *sv)
7189 assert(SvTYPE(sv) == SVt_PVGV);
7194 SvREFCNT_dec(GvSTASH(sv));
7195 GvSTASH(sv) = Nullhv;
7197 sv_unmagic(sv, PERL_MAGIC_glob);
7198 Safefree(GvNAME(sv));
7201 /* need to keep SvANY(sv) in the right arena */
7202 xpvmg = new_XPVMG();
7203 StructCopy(SvANY(sv), xpvmg, XPVMG);
7204 del_XPVGV(SvANY(sv));
7207 SvFLAGS(sv) &= ~SVTYPEMASK;
7208 SvFLAGS(sv) |= SVt_PVMG;
7212 =for apidoc sv_unref_flags
7214 Unsets the RV status of the SV, and decrements the reference count of
7215 whatever was being referenced by the RV. This can almost be thought of
7216 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7217 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7218 (otherwise the decrementing is conditional on the reference count being
7219 different from one or the reference being a readonly SV).
7226 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7230 if (SvWEAKREF(sv)) {
7238 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7240 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7241 sv_2mortal(rv); /* Schedule for freeing later */
7245 =for apidoc sv_unref
7247 Unsets the RV status of the SV, and decrements the reference count of
7248 whatever was being referenced by the RV. This can almost be thought of
7249 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7250 being zero. See C<SvROK_off>.
7256 Perl_sv_unref(pTHX_ SV *sv)
7258 sv_unref_flags(sv, 0);
7262 =for apidoc sv_taint
7264 Taint an SV. Use C<SvTAINTED_on> instead.
7269 Perl_sv_taint(pTHX_ SV *sv)
7271 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7275 =for apidoc sv_untaint
7277 Untaint an SV. Use C<SvTAINTED_off> instead.
7282 Perl_sv_untaint(pTHX_ SV *sv)
7284 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7285 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7292 =for apidoc sv_tainted
7294 Test an SV for taintedness. Use C<SvTAINTED> instead.
7299 Perl_sv_tainted(pTHX_ SV *sv)
7301 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7302 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7303 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7310 =for apidoc sv_setpviv
7312 Copies an integer into the given SV, also updating its string value.
7313 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7319 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7321 char buf[TYPE_CHARS(UV)];
7323 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7325 sv_setpvn(sv, ptr, ebuf - ptr);
7329 =for apidoc sv_setpviv_mg
7331 Like C<sv_setpviv>, but also handles 'set' magic.
7337 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7339 char buf[TYPE_CHARS(UV)];
7341 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7343 sv_setpvn(sv, ptr, ebuf - ptr);
7347 #if defined(PERL_IMPLICIT_CONTEXT)
7349 /* pTHX_ magic can't cope with varargs, so this is a no-context
7350 * version of the main function, (which may itself be aliased to us).
7351 * Don't access this version directly.
7355 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7359 va_start(args, pat);
7360 sv_vsetpvf(sv, pat, &args);
7364 /* pTHX_ magic can't cope with varargs, so this is a no-context
7365 * version of the main function, (which may itself be aliased to us).
7366 * Don't access this version directly.
7370 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7374 va_start(args, pat);
7375 sv_vsetpvf_mg(sv, pat, &args);
7381 =for apidoc sv_setpvf
7383 Processes its arguments like C<sprintf> and sets an SV to the formatted
7384 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7390 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7393 va_start(args, pat);
7394 sv_vsetpvf(sv, pat, &args);
7398 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7401 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7403 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7407 =for apidoc sv_setpvf_mg
7409 Like C<sv_setpvf>, but also handles 'set' magic.
7415 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7418 va_start(args, pat);
7419 sv_vsetpvf_mg(sv, pat, &args);
7423 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7426 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7428 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7432 #if defined(PERL_IMPLICIT_CONTEXT)
7434 /* pTHX_ magic can't cope with varargs, so this is a no-context
7435 * version of the main function, (which may itself be aliased to us).
7436 * Don't access this version directly.
7440 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7444 va_start(args, pat);
7445 sv_vcatpvf(sv, pat, &args);
7449 /* pTHX_ magic can't cope with varargs, so this is a no-context
7450 * version of the main function, (which may itself be aliased to us).
7451 * Don't access this version directly.
7455 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7459 va_start(args, pat);
7460 sv_vcatpvf_mg(sv, pat, &args);
7466 =for apidoc sv_catpvf
7468 Processes its arguments like C<sprintf> and appends the formatted
7469 output to an SV. If the appended data contains "wide" characters
7470 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7471 and characters >255 formatted with %c), the original SV might get
7472 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7473 C<SvSETMAGIC()> must typically be called after calling this function
7474 to handle 'set' magic.
7479 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7482 va_start(args, pat);
7483 sv_vcatpvf(sv, pat, &args);
7487 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7490 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7492 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7496 =for apidoc sv_catpvf_mg
7498 Like C<sv_catpvf>, but also handles 'set' magic.
7504 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7507 va_start(args, pat);
7508 sv_vcatpvf_mg(sv, pat, &args);
7512 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7515 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7517 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7522 =for apidoc sv_vsetpvfn
7524 Works like C<vcatpvfn> but copies the text into the SV instead of
7527 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7533 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7535 sv_setpvn(sv, "", 0);
7536 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7539 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7542 S_expect_number(pTHX_ char** pattern)
7545 switch (**pattern) {
7546 case '1': case '2': case '3':
7547 case '4': case '5': case '6':
7548 case '7': case '8': case '9':
7549 while (isDIGIT(**pattern))
7550 var = var * 10 + (*(*pattern)++ - '0');
7554 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7557 =for apidoc sv_vcatpvfn
7559 Processes its arguments like C<vsprintf> and appends the formatted output
7560 to an SV. Uses an array of SVs if the C style variable argument list is
7561 missing (NULL). When running with taint checks enabled, indicates via
7562 C<maybe_tainted> if results are untrustworthy (often due to the use of
7565 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7571 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7578 static char nullstr[] = "(null)";
7581 /* no matter what, this is a string now */
7582 (void)SvPV_force(sv, origlen);
7584 /* special-case "", "%s", and "%_" */
7587 if (patlen == 2 && pat[0] == '%') {
7591 char *s = va_arg(*args, char*);
7592 sv_catpv(sv, s ? s : nullstr);
7594 else if (svix < svmax) {
7595 sv_catsv(sv, *svargs);
7596 if (DO_UTF8(*svargs))
7602 argsv = va_arg(*args, SV*);
7603 sv_catsv(sv, argsv);
7608 /* See comment on '_' below */
7613 patend = (char*)pat + patlen;
7614 for (p = (char*)pat; p < patend; p = q) {
7617 bool vectorize = FALSE;
7618 bool vectorarg = FALSE;
7619 bool vec_utf = FALSE;
7625 bool has_precis = FALSE;
7627 bool is_utf = FALSE;
7630 U8 utf8buf[UTF8_MAXLEN+1];
7631 STRLEN esignlen = 0;
7633 char *eptr = Nullch;
7635 /* Times 4: a decimal digit takes more than 3 binary digits.
7636 * NV_DIG: mantissa takes than many decimal digits.
7637 * Plus 32: Playing safe. */
7638 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7639 /* large enough for "%#.#f" --chip */
7640 /* what about long double NVs? --jhi */
7643 U8 *vecstr = Null(U8*);
7655 STRLEN dotstrlen = 1;
7656 I32 efix = 0; /* explicit format parameter index */
7657 I32 ewix = 0; /* explicit width index */
7658 I32 epix = 0; /* explicit precision index */
7659 I32 evix = 0; /* explicit vector index */
7660 bool asterisk = FALSE;
7662 /* echo everything up to the next format specification */
7663 for (q = p; q < patend && *q != '%'; ++q) ;
7665 sv_catpvn(sv, p, q - p);
7672 We allow format specification elements in this order:
7673 \d+\$ explicit format parameter index
7675 \*?(\d+\$)?v vector with optional (optionally specified) arg
7676 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7677 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7679 [%bcdefginopsux_DFOUX] format (mandatory)
7681 if (EXPECT_NUMBER(q, width)) {
7722 if (EXPECT_NUMBER(q, ewix))
7731 if ((vectorarg = asterisk)) {
7741 EXPECT_NUMBER(q, width);
7746 vecsv = va_arg(*args, SV*);
7748 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7749 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7750 dotstr = SvPVx(vecsv, dotstrlen);
7755 vecsv = va_arg(*args, SV*);
7756 vecstr = (U8*)SvPVx(vecsv,veclen);
7757 vec_utf = DO_UTF8(vecsv);
7759 else if (efix ? efix <= svmax : svix < svmax) {
7760 vecsv = svargs[efix ? efix-1 : svix++];
7761 vecstr = (U8*)SvPVx(vecsv,veclen);
7762 vec_utf = DO_UTF8(vecsv);
7772 i = va_arg(*args, int);
7774 i = (ewix ? ewix <= svmax : svix < svmax) ?
7775 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7777 width = (i < 0) ? -i : i;
7787 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7790 i = va_arg(*args, int);
7792 i = (ewix ? ewix <= svmax : svix < svmax)
7793 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7794 precis = (i < 0) ? 0 : i;
7799 precis = precis * 10 + (*q++ - '0');
7807 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7818 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7819 if (*(q + 1) == 'l') { /* lld, llf */
7842 argsv = (efix ? efix <= svmax : svix < svmax) ?
7843 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7850 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7852 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7854 eptr = (char*)utf8buf;
7855 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7867 eptr = va_arg(*args, char*);
7869 #ifdef MACOS_TRADITIONAL
7870 /* On MacOS, %#s format is used for Pascal strings */
7875 elen = strlen(eptr);
7878 elen = sizeof nullstr - 1;
7882 eptr = SvPVx(argsv, elen);
7883 if (DO_UTF8(argsv)) {
7884 if (has_precis && precis < elen) {
7886 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7889 if (width) { /* fudge width (can't fudge elen) */
7890 width += elen - sv_len_utf8(argsv);
7899 * The "%_" hack might have to be changed someday,
7900 * if ISO or ANSI decide to use '_' for something.
7901 * So we keep it hidden from users' code.
7905 argsv = va_arg(*args, SV*);
7906 eptr = SvPVx(argsv, elen);
7912 if (has_precis && elen > precis)
7921 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7939 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7949 case 'h': iv = (short)va_arg(*args, int); break;
7950 default: iv = va_arg(*args, int); break;
7951 case 'l': iv = va_arg(*args, long); break;
7952 case 'V': iv = va_arg(*args, IV); break;
7954 case 'q': iv = va_arg(*args, Quad_t); break;
7961 case 'h': iv = (short)iv; break;
7963 case 'l': iv = (long)iv; break;
7966 case 'q': iv = (Quad_t)iv; break;
7973 esignbuf[esignlen++] = plus;
7977 esignbuf[esignlen++] = '-';
8019 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
8029 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8030 default: uv = va_arg(*args, unsigned); break;
8031 case 'l': uv = va_arg(*args, unsigned long); break;
8032 case 'V': uv = va_arg(*args, UV); break;
8034 case 'q': uv = va_arg(*args, Quad_t); break;
8041 case 'h': uv = (unsigned short)uv; break;
8043 case 'l': uv = (unsigned long)uv; break;
8046 case 'q': uv = (Quad_t)uv; break;
8052 eptr = ebuf + sizeof ebuf;
8058 p = (char*)((c == 'X')
8059 ? "0123456789ABCDEF" : "0123456789abcdef");
8065 esignbuf[esignlen++] = '0';
8066 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8072 *--eptr = '0' + dig;
8074 if (alt && *eptr != '0')
8080 *--eptr = '0' + dig;
8083 esignbuf[esignlen++] = '0';
8084 esignbuf[esignlen++] = 'b';
8087 default: /* it had better be ten or less */
8088 #if defined(PERL_Y2KWARN)
8089 if (ckWARN(WARN_Y2K)) {
8091 char *s = SvPV(sv,n);
8092 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8093 && (n == 2 || !isDIGIT(s[n-3])))
8095 Perl_warner(aTHX_ WARN_Y2K,
8096 "Possible Y2K bug: %%%c %s",
8097 c, "format string following '19'");
8103 *--eptr = '0' + dig;
8104 } while (uv /= base);
8107 elen = (ebuf + sizeof ebuf) - eptr;
8110 zeros = precis - elen;
8111 else if (precis == 0 && elen == 1 && *eptr == '0')
8116 /* FLOATING POINT */
8119 c = 'f'; /* maybe %F isn't supported here */
8125 /* This is evil, but floating point is even more evil */
8128 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8131 if (c != 'e' && c != 'E') {
8133 (void)Perl_frexp(nv, &i);
8134 if (i == PERL_INT_MIN)
8135 Perl_die(aTHX_ "panic: frexp");
8137 need = BIT_DIGITS(i);
8139 need += has_precis ? precis : 6; /* known default */
8143 need += 20; /* fudge factor */
8144 if (PL_efloatsize < need) {
8145 Safefree(PL_efloatbuf);
8146 PL_efloatsize = need + 20; /* more fudge */
8147 New(906, PL_efloatbuf, PL_efloatsize, char);
8148 PL_efloatbuf[0] = '\0';
8151 eptr = ebuf + sizeof ebuf;
8154 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8156 /* Copy the one or more characters in a long double
8157 * format before the 'base' ([efgEFG]) character to
8158 * the format string. */
8159 static char const prifldbl[] = PERL_PRIfldbl;
8160 char const *p = prifldbl + sizeof(prifldbl) - 3;
8161 while (p >= prifldbl) { *--eptr = *p--; }
8166 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8171 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8183 /* No taint. Otherwise we are in the strange situation
8184 * where printf() taints but print($float) doesn't.
8186 (void)sprintf(PL_efloatbuf, eptr, nv);
8188 eptr = PL_efloatbuf;
8189 elen = strlen(PL_efloatbuf);
8196 i = SvCUR(sv) - origlen;
8199 case 'h': *(va_arg(*args, short*)) = i; break;
8200 default: *(va_arg(*args, int*)) = i; break;
8201 case 'l': *(va_arg(*args, long*)) = i; break;
8202 case 'V': *(va_arg(*args, IV*)) = i; break;
8204 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8209 sv_setuv_mg(argsv, (UV)i);
8210 continue; /* not "break" */
8217 if (!args && ckWARN(WARN_PRINTF) &&
8218 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8219 SV *msg = sv_newmortal();
8220 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8221 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8224 Perl_sv_catpvf(aTHX_ msg,
8225 "\"%%%c\"", c & 0xFF);
8227 Perl_sv_catpvf(aTHX_ msg,
8228 "\"%%\\%03"UVof"\"",
8231 sv_catpv(msg, "end of string");
8232 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8235 /* output mangled stuff ... */
8241 /* ... right here, because formatting flags should not apply */
8242 SvGROW(sv, SvCUR(sv) + elen + 1);
8244 Copy(eptr, p, elen, char);
8247 SvCUR(sv) = p - SvPVX(sv);
8248 continue; /* not "break" */
8251 have = esignlen + zeros + elen;
8252 need = (have > width ? have : width);
8255 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8257 if (esignlen && fill == '0') {
8258 for (i = 0; i < esignlen; i++)
8262 memset(p, fill, gap);
8265 if (esignlen && fill != '0') {
8266 for (i = 0; i < esignlen; i++)
8270 for (i = zeros; i; i--)
8274 Copy(eptr, p, elen, char);
8278 memset(p, ' ', gap);
8283 Copy(dotstr, p, dotstrlen, char);
8287 vectorize = FALSE; /* done iterating over vecstr */
8292 SvCUR(sv) = p - SvPVX(sv);
8300 /* =========================================================================
8302 =head1 Cloning an interpreter
8304 All the macros and functions in this section are for the private use of
8305 the main function, perl_clone().
8307 The foo_dup() functions make an exact copy of an existing foo thinngy.
8308 During the course of a cloning, a hash table is used to map old addresses
8309 to new addresses. The table is created and manipulated with the
8310 ptr_table_* functions.
8314 ============================================================================*/
8317 #if defined(USE_ITHREADS)
8319 #if defined(USE_THREADS)
8320 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
8323 #ifndef GpREFCNT_inc
8324 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8328 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8329 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8330 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8331 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8332 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8333 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8334 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8335 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8336 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8337 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8338 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8339 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8340 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8343 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8344 regcomp.c. AMS 20010712 */
8347 Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
8351 struct reg_substr_datum *s;
8354 return (REGEXP *)NULL;
8356 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8359 len = r->offsets[0];
8360 npar = r->nparens+1;
8362 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8363 Copy(r->program, ret->program, len+1, regnode);
8365 New(0, ret->startp, npar, I32);
8366 Copy(r->startp, ret->startp, npar, I32);
8367 New(0, ret->endp, npar, I32);
8368 Copy(r->startp, ret->startp, npar, I32);
8370 if (r->regstclass) {
8371 New(0, ret->regstclass, 1, regnode);
8372 ret->regstclass->flags = r->regstclass->flags;
8375 ret->regstclass = NULL;
8377 New(0, ret->substrs, 1, struct reg_substr_data);
8378 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8379 s->min_offset = r->substrs->data[i].min_offset;
8380 s->max_offset = r->substrs->data[i].max_offset;
8381 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8386 int count = r->data->count;
8388 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8389 char, struct reg_data);
8390 New(0, d->what, count, U8);
8393 for (i = 0; i < count; i++) {
8394 d->what[i] = r->data->what[i];
8395 switch (d->what[i]) {
8397 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8400 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8403 /* This is cheating. */
8404 New(0, d->data[i], 1, struct regnode_charclass_class);
8405 StructCopy(r->data->data[i], d->data[i],
8406 struct regnode_charclass_class);
8410 d->data[i] = r->data->data[i];
8420 New(0, ret->offsets, 2*len+1, U32);
8421 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8423 ret->precomp = SAVEPV(r->precomp);
8424 ret->subbeg = SAVEPV(r->subbeg);
8425 ret->sublen = r->sublen;
8426 ret->refcnt = r->refcnt;
8427 ret->minlen = r->minlen;
8428 ret->prelen = r->prelen;
8429 ret->nparens = r->nparens;
8430 ret->lastparen = r->lastparen;
8431 ret->lastcloseparen = r->lastcloseparen;
8432 ret->reganch = r->reganch;
8434 ptr_table_store(PL_ptr_table, r, ret);
8438 /* duplicate a file handle */
8441 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
8445 return (PerlIO*)NULL;
8447 /* look for it in the table first */
8448 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8452 /* create anew and remember what it is */
8453 ret = PerlIO_fdupopen(aTHX_ fp);
8454 ptr_table_store(PL_ptr_table, fp, ret);
8458 /* duplicate a directory handle */
8461 Perl_dirp_dup(pTHX_ DIR *dp)
8469 /* duplicate a typeglob */
8472 Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
8477 /* look for it in the table first */
8478 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8482 /* create anew and remember what it is */
8483 Newz(0, ret, 1, GP);
8484 ptr_table_store(PL_ptr_table, gp, ret);
8487 ret->gp_refcnt = 0; /* must be before any other dups! */
8488 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8489 ret->gp_io = io_dup_inc(gp->gp_io, param);
8490 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8491 ret->gp_av = av_dup_inc(gp->gp_av, param);
8492 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8493 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8494 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8495 ret->gp_cvgen = gp->gp_cvgen;
8496 ret->gp_flags = gp->gp_flags;
8497 ret->gp_line = gp->gp_line;
8498 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8502 /* duplicate a chain of magic */
8505 Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
8507 MAGIC *mgprev = (MAGIC*)NULL;
8510 return (MAGIC*)NULL;
8511 /* look for it in the table first */
8512 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8516 for (; mg; mg = mg->mg_moremagic) {
8518 Newz(0, nmg, 1, MAGIC);
8520 mgprev->mg_moremagic = nmg;
8523 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8524 nmg->mg_private = mg->mg_private;
8525 nmg->mg_type = mg->mg_type;
8526 nmg->mg_flags = mg->mg_flags;
8527 if (mg->mg_type == PERL_MAGIC_qr) {
8528 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8530 else if(mg->mg_type == PERL_MAGIC_backref) {
8531 AV *av = (AV*) mg->mg_obj;
8534 nmg->mg_obj = (SV*)newAV();
8538 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8543 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8544 ? sv_dup_inc(mg->mg_obj, param)
8545 : sv_dup(mg->mg_obj, param);
8547 nmg->mg_len = mg->mg_len;
8548 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8549 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8550 if (mg->mg_len >= 0) {
8551 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8552 if (mg->mg_type == PERL_MAGIC_overload_table &&
8553 AMT_AMAGIC((AMT*)mg->mg_ptr))
8555 AMT *amtp = (AMT*)mg->mg_ptr;
8556 AMT *namtp = (AMT*)nmg->mg_ptr;
8558 for (i = 1; i < NofAMmeth; i++) {
8559 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8563 else if (mg->mg_len == HEf_SVKEY)
8564 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8571 /* create a new pointer-mapping table */
8574 Perl_ptr_table_new(pTHX)
8577 Newz(0, tbl, 1, PTR_TBL_t);
8580 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8584 /* map an existing pointer using a table */
8587 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8589 PTR_TBL_ENT_t *tblent;
8590 UV hash = PTR2UV(sv);
8592 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8593 for (; tblent; tblent = tblent->next) {
8594 if (tblent->oldval == sv)
8595 return tblent->newval;
8600 /* add a new entry to a pointer-mapping table */
8603 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8605 PTR_TBL_ENT_t *tblent, **otblent;
8606 /* XXX this may be pessimal on platforms where pointers aren't good
8607 * hash values e.g. if they grow faster in the most significant
8609 UV hash = PTR2UV(oldv);
8613 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8614 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8615 if (tblent->oldval == oldv) {
8616 tblent->newval = newv;
8621 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8622 tblent->oldval = oldv;
8623 tblent->newval = newv;
8624 tblent->next = *otblent;
8627 if (i && tbl->tbl_items > tbl->tbl_max)
8628 ptr_table_split(tbl);
8631 /* double the hash bucket size of an existing ptr table */
8634 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8636 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8637 UV oldsize = tbl->tbl_max + 1;
8638 UV newsize = oldsize * 2;
8641 Renew(ary, newsize, PTR_TBL_ENT_t*);
8642 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8643 tbl->tbl_max = --newsize;
8645 for (i=0; i < oldsize; i++, ary++) {
8646 PTR_TBL_ENT_t **curentp, **entp, *ent;
8649 curentp = ary + oldsize;
8650 for (entp = ary, ent = *ary; ent; ent = *entp) {
8651 if ((newsize & PTR2UV(ent->oldval)) != i) {
8653 ent->next = *curentp;
8663 /* remove all the entries from a ptr table */
8666 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8668 register PTR_TBL_ENT_t **array;
8669 register PTR_TBL_ENT_t *entry;
8670 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8674 if (!tbl || !tbl->tbl_items) {
8678 array = tbl->tbl_ary;
8685 entry = entry->next;
8689 if (++riter > max) {
8692 entry = array[riter];
8699 /* clear and free a ptr table */
8702 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8707 ptr_table_clear(tbl);
8708 Safefree(tbl->tbl_ary);
8716 /* attempt to make everything in the typeglob readonly */
8719 S_gv_share(pTHX_ SV *sstr)
8722 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8724 if (GvIO(gv) || GvFORM(gv)) {
8725 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8727 else if (!GvCV(gv)) {
8731 /* CvPADLISTs cannot be shared */
8732 if (!CvXSUB(GvCV(gv))) {
8737 if (!GvUNIQUE(gv)) {
8739 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8740 HvNAME(GvSTASH(gv)), GvNAME(gv));
8746 * write attempts will die with
8747 * "Modification of a read-only value attempted"
8753 SvREADONLY_on(GvSV(gv));
8760 SvREADONLY_on(GvAV(gv));
8767 SvREADONLY_on(GvAV(gv));
8770 return sstr; /* he_dup() will SvREFCNT_inc() */
8773 /* duplicate an SV of any type (including AV, HV etc) */
8776 Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
8780 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8782 /* look for it in the table first */
8783 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8787 /* create anew and remember what it is */
8789 ptr_table_store(PL_ptr_table, sstr, dstr);
8792 SvFLAGS(dstr) = SvFLAGS(sstr);
8793 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8794 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8797 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8798 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8799 PL_watch_pvx, SvPVX(sstr));
8802 switch (SvTYPE(sstr)) {
8807 SvANY(dstr) = new_XIV();
8808 SvIVX(dstr) = SvIVX(sstr);
8811 SvANY(dstr) = new_XNV();
8812 SvNVX(dstr) = SvNVX(sstr);
8815 SvANY(dstr) = new_XRV();
8816 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8817 ? sv_dup(SvRV(sstr), param)
8818 : sv_dup_inc(SvRV(sstr), param);
8821 SvANY(dstr) = new_XPV();
8822 SvCUR(dstr) = SvCUR(sstr);
8823 SvLEN(dstr) = SvLEN(sstr);
8825 SvRV(dstr) = SvWEAKREF(sstr)
8826 ? sv_dup(SvRV(sstr), param)
8827 : sv_dup_inc(SvRV(sstr), param);
8828 else if (SvPVX(sstr) && SvLEN(sstr))
8829 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8831 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8834 SvANY(dstr) = new_XPVIV();
8835 SvCUR(dstr) = SvCUR(sstr);
8836 SvLEN(dstr) = SvLEN(sstr);
8837 SvIVX(dstr) = SvIVX(sstr);
8839 SvRV(dstr) = SvWEAKREF(sstr)
8840 ? sv_dup(SvRV(sstr), param)
8841 : sv_dup_inc(SvRV(sstr), param);
8842 else if (SvPVX(sstr) && SvLEN(sstr))
8843 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8845 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8848 SvANY(dstr) = new_XPVNV();
8849 SvCUR(dstr) = SvCUR(sstr);
8850 SvLEN(dstr) = SvLEN(sstr);
8851 SvIVX(dstr) = SvIVX(sstr);
8852 SvNVX(dstr) = SvNVX(sstr);
8854 SvRV(dstr) = SvWEAKREF(sstr)
8855 ? sv_dup(SvRV(sstr), param)
8856 : sv_dup_inc(SvRV(sstr), param);
8857 else if (SvPVX(sstr) && SvLEN(sstr))
8858 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8860 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8863 SvANY(dstr) = new_XPVMG();
8864 SvCUR(dstr) = SvCUR(sstr);
8865 SvLEN(dstr) = SvLEN(sstr);
8866 SvIVX(dstr) = SvIVX(sstr);
8867 SvNVX(dstr) = SvNVX(sstr);
8868 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8869 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8871 SvRV(dstr) = SvWEAKREF(sstr)
8872 ? sv_dup(SvRV(sstr), param)
8873 : sv_dup_inc(SvRV(sstr), param);
8874 else if (SvPVX(sstr) && SvLEN(sstr))
8875 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8877 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8880 SvANY(dstr) = new_XPVBM();
8881 SvCUR(dstr) = SvCUR(sstr);
8882 SvLEN(dstr) = SvLEN(sstr);
8883 SvIVX(dstr) = SvIVX(sstr);
8884 SvNVX(dstr) = SvNVX(sstr);
8885 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8886 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8888 SvRV(dstr) = SvWEAKREF(sstr)
8889 ? sv_dup(SvRV(sstr), param)
8890 : sv_dup_inc(SvRV(sstr), param);
8891 else if (SvPVX(sstr) && SvLEN(sstr))
8892 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8894 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8895 BmRARE(dstr) = BmRARE(sstr);
8896 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8897 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8900 SvANY(dstr) = new_XPVLV();
8901 SvCUR(dstr) = SvCUR(sstr);
8902 SvLEN(dstr) = SvLEN(sstr);
8903 SvIVX(dstr) = SvIVX(sstr);
8904 SvNVX(dstr) = SvNVX(sstr);
8905 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8906 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8908 SvRV(dstr) = SvWEAKREF(sstr)
8909 ? sv_dup(SvRV(sstr), param)
8910 : sv_dup_inc(SvRV(sstr), param);
8911 else if (SvPVX(sstr) && SvLEN(sstr))
8912 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8914 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8915 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8916 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8917 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8918 LvTYPE(dstr) = LvTYPE(sstr);
8921 if (GvUNIQUE((GV*)sstr)) {
8923 if ((share = gv_share(sstr))) {
8927 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8928 HvNAME(GvSTASH(share)), GvNAME(share));
8933 SvANY(dstr) = new_XPVGV();
8934 SvCUR(dstr) = SvCUR(sstr);
8935 SvLEN(dstr) = SvLEN(sstr);
8936 SvIVX(dstr) = SvIVX(sstr);
8937 SvNVX(dstr) = SvNVX(sstr);
8938 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8939 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8941 SvRV(dstr) = SvWEAKREF(sstr)
8942 ? sv_dup(SvRV(sstr), param)
8943 : sv_dup_inc(SvRV(sstr), param);
8944 else if (SvPVX(sstr) && SvLEN(sstr))
8945 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8947 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8948 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8949 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8950 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
8951 GvFLAGS(dstr) = GvFLAGS(sstr);
8952 GvGP(dstr) = gp_dup(GvGP(sstr), param);
8953 (void)GpREFCNT_inc(GvGP(dstr));
8956 SvANY(dstr) = new_XPVIO();
8957 SvCUR(dstr) = SvCUR(sstr);
8958 SvLEN(dstr) = SvLEN(sstr);
8959 SvIVX(dstr) = SvIVX(sstr);
8960 SvNVX(dstr) = SvNVX(sstr);
8961 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8962 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8964 SvRV(dstr) = SvWEAKREF(sstr)
8965 ? sv_dup(SvRV(sstr), param)
8966 : sv_dup_inc(SvRV(sstr), param);
8967 else if (SvPVX(sstr) && SvLEN(sstr))
8968 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8970 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8971 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8972 if (IoOFP(sstr) == IoIFP(sstr))
8973 IoOFP(dstr) = IoIFP(dstr);
8975 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8976 /* PL_rsfp_filters entries have fake IoDIRP() */
8977 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8978 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8980 IoDIRP(dstr) = IoDIRP(sstr);
8981 IoLINES(dstr) = IoLINES(sstr);
8982 IoPAGE(dstr) = IoPAGE(sstr);
8983 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8984 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8985 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8986 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
8987 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8988 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
8989 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8990 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
8991 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8992 IoTYPE(dstr) = IoTYPE(sstr);
8993 IoFLAGS(dstr) = IoFLAGS(sstr);
8996 SvANY(dstr) = new_XPVAV();
8997 SvCUR(dstr) = SvCUR(sstr);
8998 SvLEN(dstr) = SvLEN(sstr);
8999 SvIVX(dstr) = SvIVX(sstr);
9000 SvNVX(dstr) = SvNVX(sstr);
9001 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9002 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9003 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9004 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9005 if (AvARRAY((AV*)sstr)) {
9006 SV **dst_ary, **src_ary;
9007 SSize_t items = AvFILLp((AV*)sstr) + 1;
9009 src_ary = AvARRAY((AV*)sstr);
9010 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9011 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9012 SvPVX(dstr) = (char*)dst_ary;
9013 AvALLOC((AV*)dstr) = dst_ary;
9014 if (AvREAL((AV*)sstr)) {
9016 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9020 *dst_ary++ = sv_dup(*src_ary++, param);
9022 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9023 while (items-- > 0) {
9024 *dst_ary++ = &PL_sv_undef;
9028 SvPVX(dstr) = Nullch;
9029 AvALLOC((AV*)dstr) = (SV**)NULL;
9033 SvANY(dstr) = new_XPVHV();
9034 SvCUR(dstr) = SvCUR(sstr);
9035 SvLEN(dstr) = SvLEN(sstr);
9036 SvIVX(dstr) = SvIVX(sstr);
9037 SvNVX(dstr) = SvNVX(sstr);
9038 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9039 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9040 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9041 if (HvARRAY((HV*)sstr)) {
9043 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9044 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9045 Newz(0, dxhv->xhv_array,
9046 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9047 while (i <= sxhv->xhv_max) {
9048 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9049 !!HvSHAREKEYS(sstr), param);
9052 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9055 SvPVX(dstr) = Nullch;
9056 HvEITER((HV*)dstr) = (HE*)NULL;
9058 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9059 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9060 /* Record stashes for possible cloning in Perl_clone(). */
9061 if(HvNAME((HV*)dstr))
9062 av_push(param->stashes, dstr);
9065 SvANY(dstr) = new_XPVFM();
9066 FmLINES(dstr) = FmLINES(sstr);
9070 SvANY(dstr) = new_XPVCV();
9072 SvCUR(dstr) = SvCUR(sstr);
9073 SvLEN(dstr) = SvLEN(sstr);
9074 SvIVX(dstr) = SvIVX(sstr);
9075 SvNVX(dstr) = SvNVX(sstr);
9076 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9077 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9078 if (SvPVX(sstr) && SvLEN(sstr))
9079 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9081 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9082 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9083 CvSTART(dstr) = CvSTART(sstr);
9084 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9085 CvXSUB(dstr) = CvXSUB(sstr);
9086 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9087 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9088 if (param->flags & CLONEf_COPY_STACKS) {
9089 CvDEPTH(dstr) = CvDEPTH(sstr);
9093 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9094 /* XXX padlists are real, but pretend to be not */
9095 AvREAL_on(CvPADLIST(sstr));
9096 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9097 AvREAL_off(CvPADLIST(sstr));
9098 AvREAL_off(CvPADLIST(dstr));
9101 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9102 if (!CvANON(sstr) || CvCLONED(sstr))
9103 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9105 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9106 CvFLAGS(dstr) = CvFLAGS(sstr);
9107 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9110 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9114 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9120 /* duplicate a context */
9123 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
9128 return (PERL_CONTEXT*)NULL;
9130 /* look for it in the table first */
9131 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9135 /* create anew and remember what it is */
9136 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9137 ptr_table_store(PL_ptr_table, cxs, ncxs);
9140 PERL_CONTEXT *cx = &cxs[ix];
9141 PERL_CONTEXT *ncx = &ncxs[ix];
9142 ncx->cx_type = cx->cx_type;
9143 if (CxTYPE(cx) == CXt_SUBST) {
9144 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9147 ncx->blk_oldsp = cx->blk_oldsp;
9148 ncx->blk_oldcop = cx->blk_oldcop;
9149 ncx->blk_oldretsp = cx->blk_oldretsp;
9150 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9151 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9152 ncx->blk_oldpm = cx->blk_oldpm;
9153 ncx->blk_gimme = cx->blk_gimme;
9154 switch (CxTYPE(cx)) {
9156 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9157 ? cv_dup_inc(cx->blk_sub.cv, param)
9158 : cv_dup(cx->blk_sub.cv,param));
9159 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9160 ? av_dup_inc(cx->blk_sub.argarray, param)
9162 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9163 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9164 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9165 ncx->blk_sub.lval = cx->blk_sub.lval;
9168 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9169 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9170 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9171 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9172 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9175 ncx->blk_loop.label = cx->blk_loop.label;
9176 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9177 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9178 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9179 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9180 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9181 ? cx->blk_loop.iterdata
9182 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9183 ncx->blk_loop.oldcurpad
9184 = (SV**)ptr_table_fetch(PL_ptr_table,
9185 cx->blk_loop.oldcurpad);
9186 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9187 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9188 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9189 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9190 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9193 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9194 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9195 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9196 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9208 /* duplicate a stack info structure */
9211 Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
9216 return (PERL_SI*)NULL;
9218 /* look for it in the table first */
9219 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9223 /* create anew and remember what it is */
9224 Newz(56, nsi, 1, PERL_SI);
9225 ptr_table_store(PL_ptr_table, si, nsi);
9227 nsi->si_stack = av_dup_inc(si->si_stack, param);
9228 nsi->si_cxix = si->si_cxix;
9229 nsi->si_cxmax = si->si_cxmax;
9230 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9231 nsi->si_type = si->si_type;
9232 nsi->si_prev = si_dup(si->si_prev, param);
9233 nsi->si_next = si_dup(si->si_next, param);
9234 nsi->si_markoff = si->si_markoff;
9239 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9240 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9241 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9242 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9243 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9244 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9245 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9246 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9247 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9248 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9249 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9250 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9253 #define pv_dup_inc(p) SAVEPV(p)
9254 #define pv_dup(p) SAVEPV(p)
9255 #define svp_dup_inc(p,pp) any_dup(p,pp)
9257 /* map any object to the new equivent - either something in the
9258 * ptr table, or something in the interpreter structure
9262 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9269 /* look for it in the table first */
9270 ret = ptr_table_fetch(PL_ptr_table, v);
9274 /* see if it is part of the interpreter structure */
9275 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9276 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
9283 /* duplicate the save stack */
9286 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
9288 ANY *ss = proto_perl->Tsavestack;
9289 I32 ix = proto_perl->Tsavestack_ix;
9290 I32 max = proto_perl->Tsavestack_max;
9303 void (*dptr) (void*);
9304 void (*dxptr) (pTHXo_ void*);
9307 Newz(54, nss, max, ANY);
9313 case SAVEt_ITEM: /* normal string */
9314 sv = (SV*)POPPTR(ss,ix);
9315 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9316 sv = (SV*)POPPTR(ss,ix);
9317 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9319 case SAVEt_SV: /* scalar reference */
9320 sv = (SV*)POPPTR(ss,ix);
9321 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9322 gv = (GV*)POPPTR(ss,ix);
9323 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9325 case SAVEt_GENERIC_PVREF: /* generic char* */
9326 c = (char*)POPPTR(ss,ix);
9327 TOPPTR(nss,ix) = pv_dup(c);
9328 ptr = POPPTR(ss,ix);
9329 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9331 case SAVEt_GENERIC_SVREF: /* generic sv */
9332 case SAVEt_SVREF: /* scalar reference */
9333 sv = (SV*)POPPTR(ss,ix);
9334 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9335 ptr = POPPTR(ss,ix);
9336 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9338 case SAVEt_AV: /* array reference */
9339 av = (AV*)POPPTR(ss,ix);
9340 TOPPTR(nss,ix) = av_dup_inc(av, param);
9341 gv = (GV*)POPPTR(ss,ix);
9342 TOPPTR(nss,ix) = gv_dup(gv, param);
9344 case SAVEt_HV: /* hash reference */
9345 hv = (HV*)POPPTR(ss,ix);
9346 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9347 gv = (GV*)POPPTR(ss,ix);
9348 TOPPTR(nss,ix) = gv_dup(gv, param);
9350 case SAVEt_INT: /* int reference */
9351 ptr = POPPTR(ss,ix);
9352 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9353 intval = (int)POPINT(ss,ix);
9354 TOPINT(nss,ix) = intval;
9356 case SAVEt_LONG: /* long reference */
9357 ptr = POPPTR(ss,ix);
9358 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9359 longval = (long)POPLONG(ss,ix);
9360 TOPLONG(nss,ix) = longval;
9362 case SAVEt_I32: /* I32 reference */
9363 case SAVEt_I16: /* I16 reference */
9364 case SAVEt_I8: /* I8 reference */
9365 ptr = POPPTR(ss,ix);
9366 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9370 case SAVEt_IV: /* IV reference */
9371 ptr = POPPTR(ss,ix);
9372 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9376 case SAVEt_SPTR: /* SV* reference */
9377 ptr = POPPTR(ss,ix);
9378 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9379 sv = (SV*)POPPTR(ss,ix);
9380 TOPPTR(nss,ix) = sv_dup(sv, param);
9382 case SAVEt_VPTR: /* random* reference */
9383 ptr = POPPTR(ss,ix);
9384 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9385 ptr = POPPTR(ss,ix);
9386 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9388 case SAVEt_PPTR: /* char* reference */
9389 ptr = POPPTR(ss,ix);
9390 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9391 c = (char*)POPPTR(ss,ix);
9392 TOPPTR(nss,ix) = pv_dup(c);
9394 case SAVEt_HPTR: /* HV* reference */
9395 ptr = POPPTR(ss,ix);
9396 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9397 hv = (HV*)POPPTR(ss,ix);
9398 TOPPTR(nss,ix) = hv_dup(hv, param);
9400 case SAVEt_APTR: /* AV* reference */
9401 ptr = POPPTR(ss,ix);
9402 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9403 av = (AV*)POPPTR(ss,ix);
9404 TOPPTR(nss,ix) = av_dup(av, param);
9407 gv = (GV*)POPPTR(ss,ix);
9408 TOPPTR(nss,ix) = gv_dup(gv, param);
9410 case SAVEt_GP: /* scalar reference */
9411 gp = (GP*)POPPTR(ss,ix);
9412 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9413 (void)GpREFCNT_inc(gp);
9414 gv = (GV*)POPPTR(ss,ix);
9415 TOPPTR(nss,ix) = gv_dup_inc(c, param);
9416 c = (char*)POPPTR(ss,ix);
9417 TOPPTR(nss,ix) = pv_dup(c);
9424 case SAVEt_MORTALIZESV:
9425 sv = (SV*)POPPTR(ss,ix);
9426 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9429 ptr = POPPTR(ss,ix);
9430 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9431 /* these are assumed to be refcounted properly */
9432 switch (((OP*)ptr)->op_type) {
9439 TOPPTR(nss,ix) = ptr;
9444 TOPPTR(nss,ix) = Nullop;
9449 TOPPTR(nss,ix) = Nullop;
9452 c = (char*)POPPTR(ss,ix);
9453 TOPPTR(nss,ix) = pv_dup_inc(c);
9456 longval = POPLONG(ss,ix);
9457 TOPLONG(nss,ix) = longval;
9460 hv = (HV*)POPPTR(ss,ix);
9461 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9462 c = (char*)POPPTR(ss,ix);
9463 TOPPTR(nss,ix) = pv_dup_inc(c);
9467 case SAVEt_DESTRUCTOR:
9468 ptr = POPPTR(ss,ix);
9469 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9470 dptr = POPDPTR(ss,ix);
9471 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9473 case SAVEt_DESTRUCTOR_X:
9474 ptr = POPPTR(ss,ix);
9475 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9476 dxptr = POPDXPTR(ss,ix);
9477 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
9479 case SAVEt_REGCONTEXT:
9485 case SAVEt_STACK_POS: /* Position on Perl stack */
9489 case SAVEt_AELEM: /* array element */
9490 sv = (SV*)POPPTR(ss,ix);
9491 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9494 av = (AV*)POPPTR(ss,ix);
9495 TOPPTR(nss,ix) = av_dup_inc(av, param);
9497 case SAVEt_HELEM: /* hash element */
9498 sv = (SV*)POPPTR(ss,ix);
9499 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9500 sv = (SV*)POPPTR(ss,ix);
9501 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9502 hv = (HV*)POPPTR(ss,ix);
9503 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9506 ptr = POPPTR(ss,ix);
9507 TOPPTR(nss,ix) = ptr;
9514 av = (AV*)POPPTR(ss,ix);
9515 TOPPTR(nss,ix) = av_dup(av, param);
9518 longval = (long)POPLONG(ss,ix);
9519 TOPLONG(nss,ix) = longval;
9520 ptr = POPPTR(ss,ix);
9521 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9522 sv = (SV*)POPPTR(ss,ix);
9523 TOPPTR(nss,ix) = sv_dup(sv, param);
9526 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9538 =for apidoc perl_clone
9540 Create and return a new interpreter by cloning the current one.
9545 /* XXX the above needs expanding by someone who actually understands it ! */
9548 perl_clone(PerlInterpreter *proto_perl, UV flags)
9551 CPerlObj *pPerl = (CPerlObj*)proto_perl;
9554 #ifdef PERL_IMPLICIT_SYS
9556 /* perlhost.h so we need to call into it
9557 to clone the host, CPerlHost should have a c interface, sky */
9559 if (flags & CLONEf_CLONE_HOST) {
9560 return perl_clone_host(proto_perl,flags);
9562 return perl_clone_using(proto_perl, flags,
9564 proto_perl->IMemShared,
9565 proto_perl->IMemParse,
9575 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9576 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9577 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9578 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9579 struct IPerlDir* ipD, struct IPerlSock* ipS,
9580 struct IPerlProc* ipP)
9582 /* XXX many of the string copies here can be optimized if they're
9583 * constants; they need to be allocated as common memory and just
9584 * their pointers copied. */
9587 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9592 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
9594 PERL_SET_THX(pPerl);
9595 # else /* !PERL_OBJECT */
9596 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9597 PERL_SET_THX(my_perl);
9600 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9606 # else /* !DEBUGGING */
9607 Zero(my_perl, 1, PerlInterpreter);
9608 # endif /* DEBUGGING */
9612 PL_MemShared = ipMS;
9620 # endif /* PERL_OBJECT */
9621 #else /* !PERL_IMPLICIT_SYS */
9623 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9624 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9625 PERL_SET_THX(my_perl);
9630 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9636 # else /* !DEBUGGING */
9637 Zero(my_perl, 1, PerlInterpreter);
9638 # endif /* DEBUGGING */
9639 #endif /* PERL_IMPLICIT_SYS */
9640 param->flags = flags;
9643 PL_xiv_arenaroot = NULL;
9645 PL_xnv_arenaroot = NULL;
9647 PL_xrv_arenaroot = NULL;
9649 PL_xpv_arenaroot = NULL;
9651 PL_xpviv_arenaroot = NULL;
9652 PL_xpviv_root = NULL;
9653 PL_xpvnv_arenaroot = NULL;
9654 PL_xpvnv_root = NULL;
9655 PL_xpvcv_arenaroot = NULL;
9656 PL_xpvcv_root = NULL;
9657 PL_xpvav_arenaroot = NULL;
9658 PL_xpvav_root = NULL;
9659 PL_xpvhv_arenaroot = NULL;
9660 PL_xpvhv_root = NULL;
9661 PL_xpvmg_arenaroot = NULL;
9662 PL_xpvmg_root = NULL;
9663 PL_xpvlv_arenaroot = NULL;
9664 PL_xpvlv_root = NULL;
9665 PL_xpvbm_arenaroot = NULL;
9666 PL_xpvbm_root = NULL;
9667 PL_he_arenaroot = NULL;
9669 PL_nice_chunk = NULL;
9670 PL_nice_chunk_size = 0;
9673 PL_sv_root = Nullsv;
9674 PL_sv_arenaroot = Nullsv;
9676 PL_debug = proto_perl->Idebug;
9678 #ifdef USE_REENTRANT_API
9679 New(31337, PL_reentrant_buffer,1, REBUF);
9680 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9683 /* create SV map for pointer relocation */
9684 PL_ptr_table = ptr_table_new();
9686 /* initialize these special pointers as early as possible */
9687 SvANY(&PL_sv_undef) = NULL;
9688 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9689 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9690 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9693 SvUPGRADE(&PL_sv_no, SVt_PVNV);
9695 SvANY(&PL_sv_no) = new_XPVNV();
9697 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9698 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9699 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9700 SvCUR(&PL_sv_no) = 0;
9701 SvLEN(&PL_sv_no) = 1;
9702 SvNVX(&PL_sv_no) = 0;
9703 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9706 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
9708 SvANY(&PL_sv_yes) = new_XPVNV();
9710 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9711 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9712 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9713 SvCUR(&PL_sv_yes) = 1;
9714 SvLEN(&PL_sv_yes) = 2;
9715 SvNVX(&PL_sv_yes) = 1;
9716 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9718 /* create shared string table */
9719 PL_strtab = newHV();
9720 HvSHAREKEYS_off(PL_strtab);
9721 hv_ksplit(PL_strtab, 512);
9722 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9724 PL_compiling = proto_perl->Icompiling;
9725 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9726 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9727 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9728 if (!specialWARN(PL_compiling.cop_warnings))
9729 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9730 if (!specialCopIO(PL_compiling.cop_io))
9731 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9732 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9734 /* pseudo environmental stuff */
9735 PL_origargc = proto_perl->Iorigargc;
9737 New(0, PL_origargv, i+1, char*);
9738 PL_origargv[i] = '\0';
9740 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9744 param->stashes = newAV(); /* Setup array of objects to call clone on */
9747 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9748 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9749 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9750 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9751 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9752 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9755 PL_minus_c = proto_perl->Iminus_c;
9756 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9757 PL_localpatches = proto_perl->Ilocalpatches;
9758 PL_splitstr = proto_perl->Isplitstr;
9759 PL_preprocess = proto_perl->Ipreprocess;
9760 PL_minus_n = proto_perl->Iminus_n;
9761 PL_minus_p = proto_perl->Iminus_p;
9762 PL_minus_l = proto_perl->Iminus_l;
9763 PL_minus_a = proto_perl->Iminus_a;
9764 PL_minus_F = proto_perl->Iminus_F;
9765 PL_doswitches = proto_perl->Idoswitches;
9766 PL_dowarn = proto_perl->Idowarn;
9767 PL_doextract = proto_perl->Idoextract;
9768 PL_sawampersand = proto_perl->Isawampersand;
9769 PL_unsafe = proto_perl->Iunsafe;
9770 PL_inplace = SAVEPV(proto_perl->Iinplace);
9771 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9772 PL_perldb = proto_perl->Iperldb;
9773 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9775 /* magical thingies */
9776 /* XXX time(&PL_basetime) when asked for? */
9777 PL_basetime = proto_perl->Ibasetime;
9778 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9780 PL_maxsysfd = proto_perl->Imaxsysfd;
9781 PL_multiline = proto_perl->Imultiline;
9782 PL_statusvalue = proto_perl->Istatusvalue;
9784 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9787 /* Clone the regex array */
9788 PL_regex_padav = newAV();
9790 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9791 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9792 for(i = 0; i <= len; i++) {
9793 av_push(PL_regex_padav,
9794 newSViv((IV)re_dup((REGEXP *)SvIV(regexen[i]), param)));
9797 PL_regex_pad = AvARRAY(PL_regex_padav);
9799 /* shortcuts to various I/O objects */
9800 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9801 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9802 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9803 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9804 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9805 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9807 /* shortcuts to regexp stuff */
9808 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9810 /* shortcuts to misc objects */
9811 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9813 /* shortcuts to debugging objects */
9814 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9815 PL_DBline = gv_dup(proto_perl->IDBline, param);
9816 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9817 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9818 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9819 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9820 PL_lineary = av_dup(proto_perl->Ilineary, param);
9821 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9824 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9825 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9826 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9827 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9828 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9829 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9831 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9832 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9833 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9834 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9836 PL_sub_generation = proto_perl->Isub_generation;
9838 /* funky return mechanisms */
9839 PL_forkprocess = proto_perl->Iforkprocess;
9841 /* subprocess state */
9842 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9844 /* internal state */
9845 PL_tainting = proto_perl->Itainting;
9846 PL_maxo = proto_perl->Imaxo;
9847 if (proto_perl->Iop_mask)
9848 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9850 PL_op_mask = Nullch;
9852 /* current interpreter roots */
9853 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9854 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9855 PL_main_start = proto_perl->Imain_start;
9856 PL_eval_root = proto_perl->Ieval_root;
9857 PL_eval_start = proto_perl->Ieval_start;
9859 /* runtime control stuff */
9860 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9861 PL_copline = proto_perl->Icopline;
9863 PL_filemode = proto_perl->Ifilemode;
9864 PL_lastfd = proto_perl->Ilastfd;
9865 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9868 PL_gensym = proto_perl->Igensym;
9869 PL_preambled = proto_perl->Ipreambled;
9870 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9871 PL_laststatval = proto_perl->Ilaststatval;
9872 PL_laststype = proto_perl->Ilaststype;
9873 PL_mess_sv = Nullsv;
9875 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9876 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9878 /* interpreter atexit processing */
9879 PL_exitlistlen = proto_perl->Iexitlistlen;
9880 if (PL_exitlistlen) {
9881 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9882 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9885 PL_exitlist = (PerlExitListEntry*)NULL;
9886 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9888 PL_profiledata = NULL;
9889 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9890 /* PL_rsfp_filters entries have fake IoDIRP() */
9891 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9893 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9894 PL_comppad = av_dup(proto_perl->Icomppad, param);
9895 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9896 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9897 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9898 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9899 proto_perl->Tcurpad);
9901 #ifdef HAVE_INTERP_INTERN
9902 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9905 /* more statics moved here */
9906 PL_generation = proto_perl->Igeneration;
9907 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9909 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9910 PL_in_clean_all = proto_perl->Iin_clean_all;
9912 PL_uid = proto_perl->Iuid;
9913 PL_euid = proto_perl->Ieuid;
9914 PL_gid = proto_perl->Igid;
9915 PL_egid = proto_perl->Iegid;
9916 PL_nomemok = proto_perl->Inomemok;
9917 PL_an = proto_perl->Ian;
9918 PL_cop_seqmax = proto_perl->Icop_seqmax;
9919 PL_op_seqmax = proto_perl->Iop_seqmax;
9920 PL_evalseq = proto_perl->Ievalseq;
9921 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9922 PL_origalen = proto_perl->Iorigalen;
9923 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9924 PL_osname = SAVEPV(proto_perl->Iosname);
9925 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9926 PL_sighandlerp = proto_perl->Isighandlerp;
9929 PL_runops = proto_perl->Irunops;
9931 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9934 PL_cshlen = proto_perl->Icshlen;
9935 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9938 PL_lex_state = proto_perl->Ilex_state;
9939 PL_lex_defer = proto_perl->Ilex_defer;
9940 PL_lex_expect = proto_perl->Ilex_expect;
9941 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9942 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9943 PL_lex_starts = proto_perl->Ilex_starts;
9944 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
9945 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
9946 PL_lex_op = proto_perl->Ilex_op;
9947 PL_lex_inpat = proto_perl->Ilex_inpat;
9948 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9949 PL_lex_brackets = proto_perl->Ilex_brackets;
9950 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9951 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9952 PL_lex_casemods = proto_perl->Ilex_casemods;
9953 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9954 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9956 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9957 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9958 PL_nexttoke = proto_perl->Inexttoke;
9960 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
9961 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9962 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9963 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9964 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9965 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9966 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9967 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9968 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9969 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9970 PL_pending_ident = proto_perl->Ipending_ident;
9971 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9973 PL_expect = proto_perl->Iexpect;
9975 PL_multi_start = proto_perl->Imulti_start;
9976 PL_multi_end = proto_perl->Imulti_end;
9977 PL_multi_open = proto_perl->Imulti_open;
9978 PL_multi_close = proto_perl->Imulti_close;
9980 PL_error_count = proto_perl->Ierror_count;
9981 PL_subline = proto_perl->Isubline;
9982 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
9984 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9985 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9986 PL_padix = proto_perl->Ipadix;
9987 PL_padix_floor = proto_perl->Ipadix_floor;
9988 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9990 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9991 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9992 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9993 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9994 PL_last_lop_op = proto_perl->Ilast_lop_op;
9995 PL_in_my = proto_perl->Iin_my;
9996 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
9998 PL_cryptseen = proto_perl->Icryptseen;
10001 PL_hints = proto_perl->Ihints;
10003 PL_amagic_generation = proto_perl->Iamagic_generation;
10005 #ifdef USE_LOCALE_COLLATE
10006 PL_collation_ix = proto_perl->Icollation_ix;
10007 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10008 PL_collation_standard = proto_perl->Icollation_standard;
10009 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10010 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10011 #endif /* USE_LOCALE_COLLATE */
10013 #ifdef USE_LOCALE_NUMERIC
10014 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10015 PL_numeric_standard = proto_perl->Inumeric_standard;
10016 PL_numeric_local = proto_perl->Inumeric_local;
10017 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10018 #endif /* !USE_LOCALE_NUMERIC */
10020 /* utf8 character classes */
10021 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10022 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10023 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10024 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10025 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10026 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10027 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10028 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10029 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10030 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10031 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10032 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10033 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10034 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10035 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10036 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10037 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10040 PL_last_swash_hv = Nullhv; /* reinits on demand */
10041 PL_last_swash_klen = 0;
10042 PL_last_swash_key[0]= '\0';
10043 PL_last_swash_tmps = (U8*)NULL;
10044 PL_last_swash_slen = 0;
10046 /* perly.c globals */
10047 PL_yydebug = proto_perl->Iyydebug;
10048 PL_yynerrs = proto_perl->Iyynerrs;
10049 PL_yyerrflag = proto_perl->Iyyerrflag;
10050 PL_yychar = proto_perl->Iyychar;
10051 PL_yyval = proto_perl->Iyyval;
10052 PL_yylval = proto_perl->Iyylval;
10054 PL_glob_index = proto_perl->Iglob_index;
10055 PL_srand_called = proto_perl->Isrand_called;
10056 PL_uudmap['M'] = 0; /* reinits on demand */
10057 PL_bitcount = Nullch; /* reinits on demand */
10059 if (proto_perl->Ipsig_pend) {
10060 Newz(0, PL_psig_pend, SIG_SIZE, int);
10063 PL_psig_pend = (int*)NULL;
10066 if (proto_perl->Ipsig_ptr) {
10067 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10068 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10069 for (i = 1; i < SIG_SIZE; i++) {
10070 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10071 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10075 PL_psig_ptr = (SV**)NULL;
10076 PL_psig_name = (SV**)NULL;
10079 /* thrdvar.h stuff */
10081 if (flags & CLONEf_COPY_STACKS) {
10082 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10083 PL_tmps_ix = proto_perl->Ttmps_ix;
10084 PL_tmps_max = proto_perl->Ttmps_max;
10085 PL_tmps_floor = proto_perl->Ttmps_floor;
10086 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10088 while (i <= PL_tmps_ix) {
10089 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10093 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10094 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10095 Newz(54, PL_markstack, i, I32);
10096 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10097 - proto_perl->Tmarkstack);
10098 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10099 - proto_perl->Tmarkstack);
10100 Copy(proto_perl->Tmarkstack, PL_markstack,
10101 PL_markstack_ptr - PL_markstack + 1, I32);
10103 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10104 * NOTE: unlike the others! */
10105 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10106 PL_scopestack_max = proto_perl->Tscopestack_max;
10107 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10108 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10110 /* next push_return() sets PL_retstack[PL_retstack_ix]
10111 * NOTE: unlike the others! */
10112 PL_retstack_ix = proto_perl->Tretstack_ix;
10113 PL_retstack_max = proto_perl->Tretstack_max;
10114 Newz(54, PL_retstack, PL_retstack_max, OP*);
10115 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10117 /* NOTE: si_dup() looks at PL_markstack */
10118 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10120 /* PL_curstack = PL_curstackinfo->si_stack; */
10121 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10122 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10124 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10125 PL_stack_base = AvARRAY(PL_curstack);
10126 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10127 - proto_perl->Tstack_base);
10128 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10130 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10131 * NOTE: unlike the others! */
10132 PL_savestack_ix = proto_perl->Tsavestack_ix;
10133 PL_savestack_max = proto_perl->Tsavestack_max;
10134 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10135 PL_savestack = ss_dup(proto_perl, param);
10139 ENTER; /* perl_destruct() wants to LEAVE; */
10142 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10143 PL_top_env = &PL_start_env;
10145 PL_op = proto_perl->Top;
10148 PL_Xpv = (XPV*)NULL;
10149 PL_na = proto_perl->Tna;
10151 PL_statbuf = proto_perl->Tstatbuf;
10152 PL_statcache = proto_perl->Tstatcache;
10153 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10154 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10156 PL_timesbuf = proto_perl->Ttimesbuf;
10159 PL_tainted = proto_perl->Ttainted;
10160 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10161 PL_nrs = sv_dup_inc(proto_perl->Tnrs, param);
10162 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10163 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10164 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10165 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10166 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10167 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10168 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10169 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10171 PL_restartop = proto_perl->Trestartop;
10172 PL_in_eval = proto_perl->Tin_eval;
10173 PL_delaymagic = proto_perl->Tdelaymagic;
10174 PL_dirty = proto_perl->Tdirty;
10175 PL_localizing = proto_perl->Tlocalizing;
10177 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10178 PL_protect = proto_perl->Tprotect;
10180 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10181 PL_av_fetch_sv = Nullsv;
10182 PL_hv_fetch_sv = Nullsv;
10183 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10184 PL_modcount = proto_perl->Tmodcount;
10185 PL_lastgotoprobe = Nullop;
10186 PL_dumpindent = proto_perl->Tdumpindent;
10188 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10189 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10190 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10191 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10192 PL_sortcxix = proto_perl->Tsortcxix;
10193 PL_efloatbuf = Nullch; /* reinits on demand */
10194 PL_efloatsize = 0; /* reinits on demand */
10198 PL_screamfirst = NULL;
10199 PL_screamnext = NULL;
10200 PL_maxscream = -1; /* reinits on demand */
10201 PL_lastscream = Nullsv;
10203 PL_watchaddr = NULL;
10204 PL_watchok = Nullch;
10206 PL_regdummy = proto_perl->Tregdummy;
10207 PL_regcomp_parse = Nullch;
10208 PL_regxend = Nullch;
10209 PL_regcode = (regnode*)NULL;
10212 PL_regprecomp = Nullch;
10217 PL_seen_zerolen = 0;
10219 PL_regcomp_rx = (regexp*)NULL;
10221 PL_colorset = 0; /* reinits PL_colors[] */
10222 /*PL_colors[6] = {0,0,0,0,0,0};*/
10223 PL_reg_whilem_seen = 0;
10224 PL_reginput = Nullch;
10225 PL_regbol = Nullch;
10226 PL_regeol = Nullch;
10227 PL_regstartp = (I32*)NULL;
10228 PL_regendp = (I32*)NULL;
10229 PL_reglastparen = (U32*)NULL;
10230 PL_regtill = Nullch;
10231 PL_reg_start_tmp = (char**)NULL;
10232 PL_reg_start_tmpl = 0;
10233 PL_regdata = (struct reg_data*)NULL;
10236 PL_reg_eval_set = 0;
10238 PL_regprogram = (regnode*)NULL;
10240 PL_regcc = (CURCUR*)NULL;
10241 PL_reg_call_cc = (struct re_cc_state*)NULL;
10242 PL_reg_re = (regexp*)NULL;
10243 PL_reg_ganch = Nullch;
10244 PL_reg_sv = Nullsv;
10245 PL_reg_magic = (MAGIC*)NULL;
10247 PL_reg_oldcurpm = (PMOP*)NULL;
10248 PL_reg_curpm = (PMOP*)NULL;
10249 PL_reg_oldsaved = Nullch;
10250 PL_reg_oldsavedlen = 0;
10251 PL_reg_maxiter = 0;
10252 PL_reg_leftiter = 0;
10253 PL_reg_poscache = Nullch;
10254 PL_reg_poscache_size= 0;
10256 /* RE engine - function pointers */
10257 PL_regcompp = proto_perl->Tregcompp;
10258 PL_regexecp = proto_perl->Tregexecp;
10259 PL_regint_start = proto_perl->Tregint_start;
10260 PL_regint_string = proto_perl->Tregint_string;
10261 PL_regfree = proto_perl->Tregfree;
10263 PL_reginterp_cnt = 0;
10264 PL_reg_starttry = 0;
10266 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10267 ptr_table_free(PL_ptr_table);
10268 PL_ptr_table = NULL;
10271 /* Call the ->CLONE method, if it exists, for each of the stashes
10272 identified by sv_dup() above.
10274 while(av_len(param->stashes) != -1) {
10275 HV* stash = (HV*) av_shift(param->stashes);
10276 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10277 if (cloner && GvCV(cloner)) {
10282 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10284 call_sv((SV*)GvCV(cloner), G_DISCARD);
10290 SvREFCNT_dec(param->stashes);
10294 return (PerlInterpreter*)pPerl;
10300 #else /* !USE_ITHREADS */
10306 #endif /* USE_ITHREADS */