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(pTHX_ 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(pTHX_ 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(pTHX_ 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(pTHX_ 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 ", OP_DESC(PL_op));
545 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
548 /* grab a new IV body from the free list, allocating more if necessary */
559 * See comment in more_xiv() -- RAM.
561 PL_xiv_root = *(IV**)xiv;
563 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
566 /* return an IV body to the free list */
569 S_del_xiv(pTHX_ XPVIV *p)
571 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
573 *(IV**)xiv = PL_xiv_root;
578 /* allocate another arena's worth of IV bodies */
586 New(705, ptr, 1008/sizeof(XPV), XPV);
587 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
588 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
591 xivend = &xiv[1008 / sizeof(IV) - 1];
592 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
594 while (xiv < xivend) {
595 *(IV**)xiv = (IV *)(xiv + 1);
601 /* grab a new NV body from the free list, allocating more if necessary */
611 PL_xnv_root = *(NV**)xnv;
613 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
616 /* return an NV body to the free list */
619 S_del_xnv(pTHX_ XPVNV *p)
621 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
623 *(NV**)xnv = PL_xnv_root;
628 /* allocate another arena's worth of NV bodies */
636 New(711, ptr, 1008/sizeof(XPV), XPV);
637 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
638 PL_xnv_arenaroot = ptr;
641 xnvend = &xnv[1008 / sizeof(NV) - 1];
642 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
644 while (xnv < xnvend) {
645 *(NV**)xnv = (NV*)(xnv + 1);
651 /* grab a new struct xrv from the free list, allocating more if necessary */
661 PL_xrv_root = (XRV*)xrv->xrv_rv;
666 /* return a struct xrv to the free list */
669 S_del_xrv(pTHX_ XRV *p)
672 p->xrv_rv = (SV*)PL_xrv_root;
677 /* allocate another arena's worth of struct xrv */
683 register XRV* xrvend;
685 New(712, ptr, 1008/sizeof(XPV), XPV);
686 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
687 PL_xrv_arenaroot = ptr;
690 xrvend = &xrv[1008 / sizeof(XRV) - 1];
691 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
693 while (xrv < xrvend) {
694 xrv->xrv_rv = (SV*)(xrv + 1);
700 /* grab a new struct xpv from the free list, allocating more if necessary */
710 PL_xpv_root = (XPV*)xpv->xpv_pv;
715 /* return a struct xpv to the free list */
718 S_del_xpv(pTHX_ XPV *p)
721 p->xpv_pv = (char*)PL_xpv_root;
726 /* allocate another arena's worth of struct xpv */
732 register XPV* xpvend;
733 New(713, xpv, 1008/sizeof(XPV), XPV);
734 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
735 PL_xpv_arenaroot = xpv;
737 xpvend = &xpv[1008 / sizeof(XPV) - 1];
739 while (xpv < xpvend) {
740 xpv->xpv_pv = (char*)(xpv + 1);
746 /* grab a new struct xpviv from the free list, allocating more if necessary */
755 xpviv = PL_xpviv_root;
756 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
761 /* return a struct xpviv to the free list */
764 S_del_xpviv(pTHX_ XPVIV *p)
767 p->xpv_pv = (char*)PL_xpviv_root;
772 /* allocate another arena's worth of struct xpviv */
777 register XPVIV* xpviv;
778 register XPVIV* xpvivend;
779 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
780 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
781 PL_xpviv_arenaroot = xpviv;
783 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
784 PL_xpviv_root = ++xpviv;
785 while (xpviv < xpvivend) {
786 xpviv->xpv_pv = (char*)(xpviv + 1);
792 /* grab a new struct xpvnv from the free list, allocating more if necessary */
801 xpvnv = PL_xpvnv_root;
802 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
807 /* return a struct xpvnv to the free list */
810 S_del_xpvnv(pTHX_ XPVNV *p)
813 p->xpv_pv = (char*)PL_xpvnv_root;
818 /* allocate another arena's worth of struct xpvnv */
823 register XPVNV* xpvnv;
824 register XPVNV* xpvnvend;
825 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
826 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
827 PL_xpvnv_arenaroot = xpvnv;
829 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
830 PL_xpvnv_root = ++xpvnv;
831 while (xpvnv < xpvnvend) {
832 xpvnv->xpv_pv = (char*)(xpvnv + 1);
838 /* grab a new struct xpvcv from the free list, allocating more if necessary */
847 xpvcv = PL_xpvcv_root;
848 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
853 /* return a struct xpvcv to the free list */
856 S_del_xpvcv(pTHX_ XPVCV *p)
859 p->xpv_pv = (char*)PL_xpvcv_root;
864 /* allocate another arena's worth of struct xpvcv */
869 register XPVCV* xpvcv;
870 register XPVCV* xpvcvend;
871 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
872 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
873 PL_xpvcv_arenaroot = xpvcv;
875 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
876 PL_xpvcv_root = ++xpvcv;
877 while (xpvcv < xpvcvend) {
878 xpvcv->xpv_pv = (char*)(xpvcv + 1);
884 /* grab a new struct xpvav from the free list, allocating more if necessary */
893 xpvav = PL_xpvav_root;
894 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
899 /* return a struct xpvav to the free list */
902 S_del_xpvav(pTHX_ XPVAV *p)
905 p->xav_array = (char*)PL_xpvav_root;
910 /* allocate another arena's worth of struct xpvav */
915 register XPVAV* xpvav;
916 register XPVAV* xpvavend;
917 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
918 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
919 PL_xpvav_arenaroot = xpvav;
921 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
922 PL_xpvav_root = ++xpvav;
923 while (xpvav < xpvavend) {
924 xpvav->xav_array = (char*)(xpvav + 1);
927 xpvav->xav_array = 0;
930 /* grab a new struct xpvhv from the free list, allocating more if necessary */
939 xpvhv = PL_xpvhv_root;
940 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
945 /* return a struct xpvhv to the free list */
948 S_del_xpvhv(pTHX_ XPVHV *p)
951 p->xhv_array = (char*)PL_xpvhv_root;
956 /* allocate another arena's worth of struct xpvhv */
961 register XPVHV* xpvhv;
962 register XPVHV* xpvhvend;
963 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
964 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
965 PL_xpvhv_arenaroot = xpvhv;
967 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
968 PL_xpvhv_root = ++xpvhv;
969 while (xpvhv < xpvhvend) {
970 xpvhv->xhv_array = (char*)(xpvhv + 1);
973 xpvhv->xhv_array = 0;
976 /* grab a new struct xpvmg from the free list, allocating more if necessary */
985 xpvmg = PL_xpvmg_root;
986 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
991 /* return a struct xpvmg to the free list */
994 S_del_xpvmg(pTHX_ XPVMG *p)
997 p->xpv_pv = (char*)PL_xpvmg_root;
1002 /* allocate another arena's worth of struct xpvmg */
1007 register XPVMG* xpvmg;
1008 register XPVMG* xpvmgend;
1009 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1010 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1011 PL_xpvmg_arenaroot = xpvmg;
1013 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1014 PL_xpvmg_root = ++xpvmg;
1015 while (xpvmg < xpvmgend) {
1016 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1022 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1031 xpvlv = PL_xpvlv_root;
1032 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1037 /* return a struct xpvlv to the free list */
1040 S_del_xpvlv(pTHX_ XPVLV *p)
1043 p->xpv_pv = (char*)PL_xpvlv_root;
1048 /* allocate another arena's worth of struct xpvlv */
1053 register XPVLV* xpvlv;
1054 register XPVLV* xpvlvend;
1055 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1056 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1057 PL_xpvlv_arenaroot = xpvlv;
1059 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1060 PL_xpvlv_root = ++xpvlv;
1061 while (xpvlv < xpvlvend) {
1062 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1068 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1077 xpvbm = PL_xpvbm_root;
1078 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1083 /* return a struct xpvbm to the free list */
1086 S_del_xpvbm(pTHX_ XPVBM *p)
1089 p->xpv_pv = (char*)PL_xpvbm_root;
1094 /* allocate another arena's worth of struct xpvbm */
1099 register XPVBM* xpvbm;
1100 register XPVBM* xpvbmend;
1101 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1102 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1103 PL_xpvbm_arenaroot = xpvbm;
1105 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1106 PL_xpvbm_root = ++xpvbm;
1107 while (xpvbm < xpvbmend) {
1108 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1115 # define my_safemalloc(s) (void*)safexmalloc(717,s)
1116 # define my_safefree(p) safexfree((char*)p)
1118 # define my_safemalloc(s) (void*)safemalloc(s)
1119 # define my_safefree(p) safefree((char*)p)
1124 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1125 #define del_XIV(p) my_safefree(p)
1127 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1128 #define del_XNV(p) my_safefree(p)
1130 #define new_XRV() my_safemalloc(sizeof(XRV))
1131 #define del_XRV(p) my_safefree(p)
1133 #define new_XPV() my_safemalloc(sizeof(XPV))
1134 #define del_XPV(p) my_safefree(p)
1136 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1137 #define del_XPVIV(p) my_safefree(p)
1139 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1140 #define del_XPVNV(p) my_safefree(p)
1142 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1143 #define del_XPVCV(p) my_safefree(p)
1145 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1146 #define del_XPVAV(p) my_safefree(p)
1148 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1149 #define del_XPVHV(p) my_safefree(p)
1151 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1152 #define del_XPVMG(p) my_safefree(p)
1154 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1155 #define del_XPVLV(p) my_safefree(p)
1157 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1158 #define del_XPVBM(p) my_safefree(p)
1162 #define new_XIV() (void*)new_xiv()
1163 #define del_XIV(p) del_xiv((XPVIV*) p)
1165 #define new_XNV() (void*)new_xnv()
1166 #define del_XNV(p) del_xnv((XPVNV*) p)
1168 #define new_XRV() (void*)new_xrv()
1169 #define del_XRV(p) del_xrv((XRV*) p)
1171 #define new_XPV() (void*)new_xpv()
1172 #define del_XPV(p) del_xpv((XPV *)p)
1174 #define new_XPVIV() (void*)new_xpviv()
1175 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1177 #define new_XPVNV() (void*)new_xpvnv()
1178 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1180 #define new_XPVCV() (void*)new_xpvcv()
1181 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1183 #define new_XPVAV() (void*)new_xpvav()
1184 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1186 #define new_XPVHV() (void*)new_xpvhv()
1187 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1189 #define new_XPVMG() (void*)new_xpvmg()
1190 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1192 #define new_XPVLV() (void*)new_xpvlv()
1193 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1195 #define new_XPVBM() (void*)new_xpvbm()
1196 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1200 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1201 #define del_XPVGV(p) my_safefree(p)
1203 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1204 #define del_XPVFM(p) my_safefree(p)
1206 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1207 #define del_XPVIO(p) my_safefree(p)
1210 =for apidoc sv_upgrade
1212 Upgrade an SV to a more complex form. Generally adds a new body type to the
1213 SV, then copies across as much information as possible from the old body.
1214 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1220 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1230 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
1231 sv_force_normal(sv);
1234 if (SvTYPE(sv) == mt)
1238 (void)SvOOK_off(sv);
1240 switch (SvTYPE(sv)) {
1261 else if (mt < SVt_PVIV)
1278 pv = (char*)SvRV(sv);
1298 else if (mt == SVt_NV)
1309 del_XPVIV(SvANY(sv));
1319 del_XPVNV(SvANY(sv));
1327 magic = SvMAGIC(sv);
1328 stash = SvSTASH(sv);
1329 del_XPVMG(SvANY(sv));
1332 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1337 Perl_croak(aTHX_ "Can't upgrade to undef");
1339 SvANY(sv) = new_XIV();
1343 SvANY(sv) = new_XNV();
1347 SvANY(sv) = new_XRV();
1351 SvANY(sv) = new_XPV();
1357 SvANY(sv) = new_XPVIV();
1367 SvANY(sv) = new_XPVNV();
1375 SvANY(sv) = new_XPVMG();
1381 SvMAGIC(sv) = magic;
1382 SvSTASH(sv) = stash;
1385 SvANY(sv) = new_XPVLV();
1391 SvMAGIC(sv) = magic;
1392 SvSTASH(sv) = stash;
1399 SvANY(sv) = new_XPVAV();
1407 SvMAGIC(sv) = magic;
1408 SvSTASH(sv) = stash;
1414 SvANY(sv) = new_XPVHV();
1422 SvMAGIC(sv) = magic;
1423 SvSTASH(sv) = stash;
1430 SvANY(sv) = new_XPVCV();
1431 Zero(SvANY(sv), 1, XPVCV);
1437 SvMAGIC(sv) = magic;
1438 SvSTASH(sv) = stash;
1441 SvANY(sv) = new_XPVGV();
1447 SvMAGIC(sv) = magic;
1448 SvSTASH(sv) = stash;
1456 SvANY(sv) = new_XPVBM();
1462 SvMAGIC(sv) = magic;
1463 SvSTASH(sv) = stash;
1469 SvANY(sv) = new_XPVFM();
1470 Zero(SvANY(sv), 1, XPVFM);
1476 SvMAGIC(sv) = magic;
1477 SvSTASH(sv) = stash;
1480 SvANY(sv) = new_XPVIO();
1481 Zero(SvANY(sv), 1, XPVIO);
1487 SvMAGIC(sv) = magic;
1488 SvSTASH(sv) = stash;
1489 IoPAGE_LEN(sv) = 60;
1492 SvFLAGS(sv) &= ~SVTYPEMASK;
1498 =for apidoc sv_backoff
1500 Remove any string offset. You should normally use the C<SvOOK_off> macro
1507 Perl_sv_backoff(pTHX_ register SV *sv)
1511 char *s = SvPVX(sv);
1512 SvLEN(sv) += SvIVX(sv);
1513 SvPVX(sv) -= SvIVX(sv);
1515 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1517 SvFLAGS(sv) &= ~SVf_OOK;
1524 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1525 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1526 Use the C<SvGROW> wrapper instead.
1532 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1536 #ifdef HAS_64K_LIMIT
1537 if (newlen >= 0x10000) {
1538 PerlIO_printf(Perl_debug_log,
1539 "Allocation too large: %"UVxf"\n", (UV)newlen);
1542 #endif /* HAS_64K_LIMIT */
1545 if (SvTYPE(sv) < SVt_PV) {
1546 sv_upgrade(sv, SVt_PV);
1549 else if (SvOOK(sv)) { /* pv is offset? */
1552 if (newlen > SvLEN(sv))
1553 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1554 #ifdef HAS_64K_LIMIT
1555 if (newlen >= 0x10000)
1561 if (newlen > SvLEN(sv)) { /* need more room? */
1562 if (SvLEN(sv) && s) {
1563 #if defined(MYMALLOC) && !defined(LEAKTEST)
1564 STRLEN l = malloced_size((void*)SvPVX(sv));
1570 Renew(s,newlen,char);
1573 /* sv_force_normal_flags() must not try to unshare the new
1574 PVX we allocate below. AMS 20010713 */
1575 if (SvREADONLY(sv) && SvFAKE(sv)) {
1579 New(703, s, newlen, char);
1582 SvLEN_set(sv, newlen);
1588 =for apidoc sv_setiv
1590 Copies an integer into the given SV, upgrading first if necessary.
1591 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1597 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1599 SV_CHECK_THINKFIRST(sv);
1600 switch (SvTYPE(sv)) {
1602 sv_upgrade(sv, SVt_IV);
1605 sv_upgrade(sv, SVt_PVNV);
1609 sv_upgrade(sv, SVt_PVIV);
1618 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1621 (void)SvIOK_only(sv); /* validate number */
1627 =for apidoc sv_setiv_mg
1629 Like C<sv_setiv>, but also handles 'set' magic.
1635 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1642 =for apidoc sv_setuv
1644 Copies an unsigned integer into the given SV, upgrading first if necessary.
1645 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1651 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1653 /* With these two if statements:
1654 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1657 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1659 If you wish to remove them, please benchmark to see what the effect is
1661 if (u <= (UV)IV_MAX) {
1662 sv_setiv(sv, (IV)u);
1671 =for apidoc sv_setuv_mg
1673 Like C<sv_setuv>, but also handles 'set' magic.
1679 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1681 /* With these two if statements:
1682 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1685 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1687 If you wish to remove them, please benchmark to see what the effect is
1689 if (u <= (UV)IV_MAX) {
1690 sv_setiv(sv, (IV)u);
1700 =for apidoc sv_setnv
1702 Copies a double into the given SV, upgrading first if necessary.
1703 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1709 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1711 SV_CHECK_THINKFIRST(sv);
1712 switch (SvTYPE(sv)) {
1715 sv_upgrade(sv, SVt_NV);
1720 sv_upgrade(sv, SVt_PVNV);
1729 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1733 (void)SvNOK_only(sv); /* validate number */
1738 =for apidoc sv_setnv_mg
1740 Like C<sv_setnv>, but also handles 'set' magic.
1746 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1752 /* Print an "isn't numeric" warning, using a cleaned-up,
1753 * printable version of the offending string
1757 S_not_a_number(pTHX_ SV *sv)
1761 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1762 /* each *s can expand to 4 chars + "...\0",
1763 i.e. need room for 8 chars */
1766 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1768 if (ch & 128 && !isPRINT_LC(ch)) {
1777 else if (ch == '\r') {
1781 else if (ch == '\f') {
1785 else if (ch == '\\') {
1789 else if (ch == '\0') {
1793 else if (isPRINT_LC(ch))
1808 Perl_warner(aTHX_ WARN_NUMERIC,
1809 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1812 Perl_warner(aTHX_ WARN_NUMERIC,
1813 "Argument \"%s\" isn't numeric", tmpbuf);
1817 =for apidoc looks_like_number
1819 Test if the content of an SV looks like a number (or is a number).
1820 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1821 non-numeric warning), even if your atof() doesn't grok them.
1827 Perl_looks_like_number(pTHX_ SV *sv)
1829 register char *sbegin;
1836 else if (SvPOKp(sv))
1837 sbegin = SvPV(sv, len);
1839 return 1; /* Historic. Wrong? */
1840 return grok_number(sbegin, len, NULL);
1843 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1844 until proven guilty, assume that things are not that bad... */
1849 As 64 bit platforms often have an NV that doesn't preserve all bits of
1850 an IV (an assumption perl has been based on to date) it becomes necessary
1851 to remove the assumption that the NV always carries enough precision to
1852 recreate the IV whenever needed, and that the NV is the canonical form.
1853 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1854 precision as a side effect of conversion (which would lead to insanity
1855 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1856 1) to distinguish between IV/UV/NV slots that have cached a valid
1857 conversion where precision was lost and IV/UV/NV slots that have a
1858 valid conversion which has lost no precision
1859 2) to ensure that if a numeric conversion to one form is requested that
1860 would lose precision, the precise conversion (or differently
1861 imprecise conversion) is also performed and cached, to prevent
1862 requests for different numeric formats on the same SV causing
1863 lossy conversion chains. (lossless conversion chains are perfectly
1868 SvIOKp is true if the IV slot contains a valid value
1869 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1870 SvNOKp is true if the NV slot contains a valid value
1871 SvNOK is true only if the NV value is accurate
1874 while converting from PV to NV, check to see if converting that NV to an
1875 IV(or UV) would lose accuracy over a direct conversion from PV to
1876 IV(or UV). If it would, cache both conversions, return NV, but mark
1877 SV as IOK NOKp (ie not NOK).
1879 While converting from PV to IV, check to see if converting that IV to an
1880 NV would lose accuracy over a direct conversion from PV to NV. If it
1881 would, cache both conversions, flag similarly.
1883 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1884 correctly because if IV & NV were set NV *always* overruled.
1885 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1886 changes - now IV and NV together means that the two are interchangeable:
1887 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1889 The benefit of this is that operations such as pp_add know that if
1890 SvIOK is true for both left and right operands, then integer addition
1891 can be used instead of floating point (for cases where the result won't
1892 overflow). Before, floating point was always used, which could lead to
1893 loss of precision compared with integer addition.
1895 * making IV and NV equal status should make maths accurate on 64 bit
1897 * may speed up maths somewhat if pp_add and friends start to use
1898 integers when possible instead of fp. (Hopefully the overhead in
1899 looking for SvIOK and checking for overflow will not outweigh the
1900 fp to integer speedup)
1901 * will slow down integer operations (callers of SvIV) on "inaccurate"
1902 values, as the change from SvIOK to SvIOKp will cause a call into
1903 sv_2iv each time rather than a macro access direct to the IV slot
1904 * should speed up number->string conversion on integers as IV is
1905 favoured when IV and NV are equally accurate
1907 ####################################################################
1908 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1909 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1910 On the other hand, SvUOK is true iff UV.
1911 ####################################################################
1913 Your mileage will vary depending your CPU's relative fp to integer
1917 #ifndef NV_PRESERVES_UV
1918 # define IS_NUMBER_UNDERFLOW_IV 1
1919 # define IS_NUMBER_UNDERFLOW_UV 2
1920 # define IS_NUMBER_IV_AND_UV 2
1921 # define IS_NUMBER_OVERFLOW_IV 4
1922 # define IS_NUMBER_OVERFLOW_UV 5
1924 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1926 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1928 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1930 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1931 if (SvNVX(sv) < (NV)IV_MIN) {
1932 (void)SvIOKp_on(sv);
1935 return IS_NUMBER_UNDERFLOW_IV;
1937 if (SvNVX(sv) > (NV)UV_MAX) {
1938 (void)SvIOKp_on(sv);
1942 return IS_NUMBER_OVERFLOW_UV;
1944 (void)SvIOKp_on(sv);
1946 /* Can't use strtol etc to convert this string. (See truth table in
1948 if (SvNVX(sv) <= (UV)IV_MAX) {
1949 SvIVX(sv) = I_V(SvNVX(sv));
1950 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1951 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1953 /* Integer is imprecise. NOK, IOKp */
1955 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1958 SvUVX(sv) = U_V(SvNVX(sv));
1959 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1960 if (SvUVX(sv) == UV_MAX) {
1961 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1962 possibly be preserved by NV. Hence, it must be overflow.
1964 return IS_NUMBER_OVERFLOW_UV;
1966 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1968 /* Integer is imprecise. NOK, IOKp */
1970 return IS_NUMBER_OVERFLOW_IV;
1972 #endif /* !NV_PRESERVES_UV*/
1977 Return the integer value of an SV, doing any necessary string conversion,
1978 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1984 Perl_sv_2iv(pTHX_ register SV *sv)
1988 if (SvGMAGICAL(sv)) {
1993 return I_V(SvNVX(sv));
1995 if (SvPOKp(sv) && SvLEN(sv))
1998 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1999 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2005 if (SvTHINKFIRST(sv)) {
2008 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2009 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2010 return SvIV(tmpstr);
2011 return PTR2IV(SvRV(sv));
2013 if (SvREADONLY(sv) && SvFAKE(sv)) {
2014 sv_force_normal(sv);
2016 if (SvREADONLY(sv) && !SvOK(sv)) {
2017 if (ckWARN(WARN_UNINITIALIZED))
2024 return (IV)(SvUVX(sv));
2031 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2032 * without also getting a cached IV/UV from it at the same time
2033 * (ie PV->NV conversion should detect loss of accuracy and cache
2034 * IV or UV at same time to avoid this. NWC */
2036 if (SvTYPE(sv) == SVt_NV)
2037 sv_upgrade(sv, SVt_PVNV);
2039 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2040 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2041 certainly cast into the IV range at IV_MAX, whereas the correct
2042 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2044 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2045 SvIVX(sv) = I_V(SvNVX(sv));
2046 if (SvNVX(sv) == (NV) SvIVX(sv)
2047 #ifndef NV_PRESERVES_UV
2048 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2049 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2050 /* Don't flag it as "accurately an integer" if the number
2051 came from a (by definition imprecise) NV operation, and
2052 we're outside the range of NV integer precision */
2055 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2056 DEBUG_c(PerlIO_printf(Perl_debug_log,
2057 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2063 /* IV not precise. No need to convert from PV, as NV
2064 conversion would already have cached IV if it detected
2065 that PV->IV would be better than PV->NV->IV
2066 flags already correct - don't set public IOK. */
2067 DEBUG_c(PerlIO_printf(Perl_debug_log,
2068 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2073 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2074 but the cast (NV)IV_MIN rounds to a the value less (more
2075 negative) than IV_MIN which happens to be equal to SvNVX ??
2076 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2077 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2078 (NV)UVX == NVX are both true, but the values differ. :-(
2079 Hopefully for 2s complement IV_MIN is something like
2080 0x8000000000000000 which will be exact. NWC */
2083 SvUVX(sv) = U_V(SvNVX(sv));
2085 (SvNVX(sv) == (NV) SvUVX(sv))
2086 #ifndef NV_PRESERVES_UV
2087 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2088 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2089 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2090 /* Don't flag it as "accurately an integer" if the number
2091 came from a (by definition imprecise) NV operation, and
2092 we're outside the range of NV integer precision */
2098 DEBUG_c(PerlIO_printf(Perl_debug_log,
2099 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2103 return (IV)SvUVX(sv);
2106 else if (SvPOKp(sv) && SvLEN(sv)) {
2108 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2109 /* We want to avoid a possible problem when we cache an IV which
2110 may be later translated to an NV, and the resulting NV is not
2111 the same as the direct translation of the initial string
2112 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2113 be careful to ensure that the value with the .456 is around if the
2114 NV value is requested in the future).
2116 This means that if we cache such an IV, we need to cache the
2117 NV as well. Moreover, we trade speed for space, and do not
2118 cache the NV if we are sure it's not needed.
2121 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2122 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2123 == IS_NUMBER_IN_UV) {
2124 /* It's definitely an integer, only upgrade to PVIV */
2125 if (SvTYPE(sv) < SVt_PVIV)
2126 sv_upgrade(sv, SVt_PVIV);
2128 } else if (SvTYPE(sv) < SVt_PVNV)
2129 sv_upgrade(sv, SVt_PVNV);
2131 /* If NV preserves UV then we only use the UV value if we know that
2132 we aren't going to call atof() below. If NVs don't preserve UVs
2133 then the value returned may have more precision than atof() will
2134 return, even though value isn't perfectly accurate. */
2135 if ((numtype & (IS_NUMBER_IN_UV
2136 #ifdef NV_PRESERVES_UV
2139 )) == IS_NUMBER_IN_UV) {
2140 /* This won't turn off the public IOK flag if it was set above */
2141 (void)SvIOKp_on(sv);
2143 if (!(numtype & IS_NUMBER_NEG)) {
2145 if (value <= (UV)IV_MAX) {
2146 SvIVX(sv) = (IV)value;
2152 /* 2s complement assumption */
2153 if (value <= (UV)IV_MIN) {
2154 SvIVX(sv) = -(IV)value;
2156 /* Too negative for an IV. This is a double upgrade, but
2157 I'm assuming it will be be rare. */
2158 if (SvTYPE(sv) < SVt_PVNV)
2159 sv_upgrade(sv, SVt_PVNV);
2163 SvNVX(sv) = -(NV)value;
2168 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2169 will be in the previous block to set the IV slot, and the next
2170 block to set the NV slot. So no else here. */
2172 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2173 != IS_NUMBER_IN_UV) {
2174 /* It wasn't an (integer that doesn't overflow the UV). */
2175 SvNVX(sv) = Atof(SvPVX(sv));
2177 if (! numtype && ckWARN(WARN_NUMERIC))
2180 #if defined(USE_LONG_DOUBLE)
2181 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2182 PTR2UV(sv), SvNVX(sv)));
2184 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2185 PTR2UV(sv), SvNVX(sv)));
2189 #ifdef NV_PRESERVES_UV
2190 (void)SvIOKp_on(sv);
2192 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2193 SvIVX(sv) = I_V(SvNVX(sv));
2194 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2197 /* Integer is imprecise. NOK, IOKp */
2199 /* UV will not work better than IV */
2201 if (SvNVX(sv) > (NV)UV_MAX) {
2203 /* Integer is inaccurate. NOK, IOKp, is UV */
2207 SvUVX(sv) = U_V(SvNVX(sv));
2208 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2209 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2213 /* Integer is imprecise. NOK, IOKp, is UV */
2219 #else /* NV_PRESERVES_UV */
2220 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2221 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2222 /* The IV slot will have been set from value returned by
2223 grok_number above. The NV slot has just been set using
2226 assert (SvIOKp(sv));
2228 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2229 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2230 /* Small enough to preserve all bits. */
2231 (void)SvIOKp_on(sv);
2233 SvIVX(sv) = I_V(SvNVX(sv));
2234 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2236 /* Assumption: first non-preserved integer is < IV_MAX,
2237 this NV is in the preserved range, therefore: */
2238 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2240 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2244 0 0 already failed to read UV.
2245 0 1 already failed to read UV.
2246 1 0 you won't get here in this case. IV/UV
2247 slot set, public IOK, Atof() unneeded.
2248 1 1 already read UV.
2249 so there's no point in sv_2iuv_non_preserve() attempting
2250 to use atol, strtol, strtoul etc. */
2251 if (sv_2iuv_non_preserve (sv, numtype)
2252 >= IS_NUMBER_OVERFLOW_IV)
2256 #endif /* NV_PRESERVES_UV */
2259 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2261 if (SvTYPE(sv) < SVt_IV)
2262 /* Typically the caller expects that sv_any is not NULL now. */
2263 sv_upgrade(sv, SVt_IV);
2266 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2267 PTR2UV(sv),SvIVX(sv)));
2268 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2274 Return the unsigned integer value of an SV, doing any necessary string
2275 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2282 Perl_sv_2uv(pTHX_ register SV *sv)
2286 if (SvGMAGICAL(sv)) {
2291 return U_V(SvNVX(sv));
2292 if (SvPOKp(sv) && SvLEN(sv))
2295 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2296 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2302 if (SvTHINKFIRST(sv)) {
2305 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2306 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2307 return SvUV(tmpstr);
2308 return PTR2UV(SvRV(sv));
2310 if (SvREADONLY(sv) && SvFAKE(sv)) {
2311 sv_force_normal(sv);
2313 if (SvREADONLY(sv) && !SvOK(sv)) {
2314 if (ckWARN(WARN_UNINITIALIZED))
2324 return (UV)SvIVX(sv);
2328 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2329 * without also getting a cached IV/UV from it at the same time
2330 * (ie PV->NV conversion should detect loss of accuracy and cache
2331 * IV or UV at same time to avoid this. */
2332 /* IV-over-UV optimisation - choose to cache IV if possible */
2334 if (SvTYPE(sv) == SVt_NV)
2335 sv_upgrade(sv, SVt_PVNV);
2337 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2338 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2339 SvIVX(sv) = I_V(SvNVX(sv));
2340 if (SvNVX(sv) == (NV) SvIVX(sv)
2341 #ifndef NV_PRESERVES_UV
2342 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2343 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2344 /* Don't flag it as "accurately an integer" if the number
2345 came from a (by definition imprecise) NV operation, and
2346 we're outside the range of NV integer precision */
2349 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2350 DEBUG_c(PerlIO_printf(Perl_debug_log,
2351 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2357 /* IV not precise. No need to convert from PV, as NV
2358 conversion would already have cached IV if it detected
2359 that PV->IV would be better than PV->NV->IV
2360 flags already correct - don't set public IOK. */
2361 DEBUG_c(PerlIO_printf(Perl_debug_log,
2362 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2367 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2368 but the cast (NV)IV_MIN rounds to a the value less (more
2369 negative) than IV_MIN which happens to be equal to SvNVX ??
2370 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2371 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2372 (NV)UVX == NVX are both true, but the values differ. :-(
2373 Hopefully for 2s complement IV_MIN is something like
2374 0x8000000000000000 which will be exact. NWC */
2377 SvUVX(sv) = U_V(SvNVX(sv));
2379 (SvNVX(sv) == (NV) SvUVX(sv))
2380 #ifndef NV_PRESERVES_UV
2381 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2382 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2383 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2384 /* Don't flag it as "accurately an integer" if the number
2385 came from a (by definition imprecise) NV operation, and
2386 we're outside the range of NV integer precision */
2391 DEBUG_c(PerlIO_printf(Perl_debug_log,
2392 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2398 else if (SvPOKp(sv) && SvLEN(sv)) {
2400 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2402 /* We want to avoid a possible problem when we cache a UV which
2403 may be later translated to an NV, and the resulting NV is not
2404 the translation of the initial data.
2406 This means that if we cache such a UV, we need to cache the
2407 NV as well. Moreover, we trade speed for space, and do not
2408 cache the NV if not needed.
2411 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2412 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2413 == IS_NUMBER_IN_UV) {
2414 /* It's definitely an integer, only upgrade to PVIV */
2415 if (SvTYPE(sv) < SVt_PVIV)
2416 sv_upgrade(sv, SVt_PVIV);
2418 } else if (SvTYPE(sv) < SVt_PVNV)
2419 sv_upgrade(sv, SVt_PVNV);
2421 /* If NV preserves UV then we only use the UV value if we know that
2422 we aren't going to call atof() below. If NVs don't preserve UVs
2423 then the value returned may have more precision than atof() will
2424 return, even though it isn't accurate. */
2425 if ((numtype & (IS_NUMBER_IN_UV
2426 #ifdef NV_PRESERVES_UV
2429 )) == IS_NUMBER_IN_UV) {
2430 /* This won't turn off the public IOK flag if it was set above */
2431 (void)SvIOKp_on(sv);
2433 if (!(numtype & IS_NUMBER_NEG)) {
2435 if (value <= (UV)IV_MAX) {
2436 SvIVX(sv) = (IV)value;
2438 /* it didn't overflow, and it was positive. */
2443 /* 2s complement assumption */
2444 if (value <= (UV)IV_MIN) {
2445 SvIVX(sv) = -(IV)value;
2447 /* Too negative for an IV. This is a double upgrade, but
2448 I'm assuming it will be be rare. */
2449 if (SvTYPE(sv) < SVt_PVNV)
2450 sv_upgrade(sv, SVt_PVNV);
2454 SvNVX(sv) = -(NV)value;
2460 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2461 != IS_NUMBER_IN_UV) {
2462 /* It wasn't an integer, or it overflowed the UV. */
2463 SvNVX(sv) = Atof(SvPVX(sv));
2465 if (! numtype && ckWARN(WARN_NUMERIC))
2468 #if defined(USE_LONG_DOUBLE)
2469 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2470 PTR2UV(sv), SvNVX(sv)));
2472 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2473 PTR2UV(sv), SvNVX(sv)));
2476 #ifdef NV_PRESERVES_UV
2477 (void)SvIOKp_on(sv);
2479 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2480 SvIVX(sv) = I_V(SvNVX(sv));
2481 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2484 /* Integer is imprecise. NOK, IOKp */
2486 /* UV will not work better than IV */
2488 if (SvNVX(sv) > (NV)UV_MAX) {
2490 /* Integer is inaccurate. NOK, IOKp, is UV */
2494 SvUVX(sv) = U_V(SvNVX(sv));
2495 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2496 NV preservse UV so can do correct comparison. */
2497 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2501 /* Integer is imprecise. NOK, IOKp, is UV */
2506 #else /* NV_PRESERVES_UV */
2507 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2508 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2509 /* The UV slot will have been set from value returned by
2510 grok_number above. The NV slot has just been set using
2513 assert (SvIOKp(sv));
2515 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2516 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2517 /* Small enough to preserve all bits. */
2518 (void)SvIOKp_on(sv);
2520 SvIVX(sv) = I_V(SvNVX(sv));
2521 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2523 /* Assumption: first non-preserved integer is < IV_MAX,
2524 this NV is in the preserved range, therefore: */
2525 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2527 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2530 sv_2iuv_non_preserve (sv, numtype);
2532 #endif /* NV_PRESERVES_UV */
2536 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2537 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2540 if (SvTYPE(sv) < SVt_IV)
2541 /* Typically the caller expects that sv_any is not NULL now. */
2542 sv_upgrade(sv, SVt_IV);
2546 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2547 PTR2UV(sv),SvUVX(sv)));
2548 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2554 Return the num value of an SV, doing any necessary string or integer
2555 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2562 Perl_sv_2nv(pTHX_ register SV *sv)
2566 if (SvGMAGICAL(sv)) {
2570 if (SvPOKp(sv) && SvLEN(sv)) {
2571 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2572 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2574 return Atof(SvPVX(sv));
2578 return (NV)SvUVX(sv);
2580 return (NV)SvIVX(sv);
2583 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2584 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2590 if (SvTHINKFIRST(sv)) {
2593 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2594 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2595 return SvNV(tmpstr);
2596 return PTR2NV(SvRV(sv));
2598 if (SvREADONLY(sv) && SvFAKE(sv)) {
2599 sv_force_normal(sv);
2601 if (SvREADONLY(sv) && !SvOK(sv)) {
2602 if (ckWARN(WARN_UNINITIALIZED))
2607 if (SvTYPE(sv) < SVt_NV) {
2608 if (SvTYPE(sv) == SVt_IV)
2609 sv_upgrade(sv, SVt_PVNV);
2611 sv_upgrade(sv, SVt_NV);
2612 #ifdef USE_LONG_DOUBLE
2614 STORE_NUMERIC_LOCAL_SET_STANDARD();
2615 PerlIO_printf(Perl_debug_log,
2616 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2617 PTR2UV(sv), SvNVX(sv));
2618 RESTORE_NUMERIC_LOCAL();
2622 STORE_NUMERIC_LOCAL_SET_STANDARD();
2623 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2624 PTR2UV(sv), SvNVX(sv));
2625 RESTORE_NUMERIC_LOCAL();
2629 else if (SvTYPE(sv) < SVt_PVNV)
2630 sv_upgrade(sv, SVt_PVNV);
2635 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2636 #ifdef NV_PRESERVES_UV
2639 /* Only set the public NV OK flag if this NV preserves the IV */
2640 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2641 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2642 : (SvIVX(sv) == I_V(SvNVX(sv))))
2648 else if (SvPOKp(sv) && SvLEN(sv)) {
2650 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2651 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2653 #ifdef NV_PRESERVES_UV
2654 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2655 == IS_NUMBER_IN_UV) {
2656 /* It's definitely an integer */
2657 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2659 SvNVX(sv) = Atof(SvPVX(sv));
2662 SvNVX(sv) = Atof(SvPVX(sv));
2663 /* Only set the public NV OK flag if this NV preserves the value in
2664 the PV at least as well as an IV/UV would.
2665 Not sure how to do this 100% reliably. */
2666 /* if that shift count is out of range then Configure's test is
2667 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2669 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2670 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2671 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2672 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2673 /* Can't use strtol etc to convert this string, so don't try.
2674 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2677 /* value has been set. It may not be precise. */
2678 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2679 /* 2s complement assumption for (UV)IV_MIN */
2680 SvNOK_on(sv); /* Integer is too negative. */
2685 if (numtype & IS_NUMBER_NEG) {
2686 SvIVX(sv) = -(IV)value;
2687 } else if (value <= (UV)IV_MAX) {
2688 SvIVX(sv) = (IV)value;
2694 if (numtype & IS_NUMBER_NOT_INT) {
2695 /* I believe that even if the original PV had decimals,
2696 they are lost beyond the limit of the FP precision.
2697 However, neither is canonical, so both only get p
2698 flags. NWC, 2000/11/25 */
2699 /* Both already have p flags, so do nothing */
2702 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2703 if (SvIVX(sv) == I_V(nv)) {
2708 /* It had no "." so it must be integer. */
2711 /* between IV_MAX and NV(UV_MAX).
2712 Could be slightly > UV_MAX */
2714 if (numtype & IS_NUMBER_NOT_INT) {
2715 /* UV and NV both imprecise. */
2717 UV nv_as_uv = U_V(nv);
2719 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2730 #endif /* NV_PRESERVES_UV */
2733 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2735 if (SvTYPE(sv) < SVt_NV)
2736 /* Typically the caller expects that sv_any is not NULL now. */
2737 /* XXX Ilya implies that this is a bug in callers that assume this
2738 and ideally should be fixed. */
2739 sv_upgrade(sv, SVt_NV);
2742 #if defined(USE_LONG_DOUBLE)
2744 STORE_NUMERIC_LOCAL_SET_STANDARD();
2745 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2746 PTR2UV(sv), SvNVX(sv));
2747 RESTORE_NUMERIC_LOCAL();
2751 STORE_NUMERIC_LOCAL_SET_STANDARD();
2752 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2753 PTR2UV(sv), SvNVX(sv));
2754 RESTORE_NUMERIC_LOCAL();
2760 /* asIV(): extract an integer from the string value of an SV.
2761 * Caller must validate PVX */
2764 S_asIV(pTHX_ SV *sv)
2767 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2769 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2770 == IS_NUMBER_IN_UV) {
2771 /* It's definitely an integer */
2772 if (numtype & IS_NUMBER_NEG) {
2773 if (value < (UV)IV_MIN)
2776 if (value < (UV)IV_MAX)
2781 if (ckWARN(WARN_NUMERIC))
2784 return I_V(Atof(SvPVX(sv)));
2787 /* asUV(): extract an unsigned integer from the string value of an SV
2788 * Caller must validate PVX */
2791 S_asUV(pTHX_ SV *sv)
2794 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2796 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2797 == IS_NUMBER_IN_UV) {
2798 /* It's definitely an integer */
2799 if (!(numtype & IS_NUMBER_NEG))
2803 if (ckWARN(WARN_NUMERIC))
2806 return U_V(Atof(SvPVX(sv)));
2810 =for apidoc sv_2pv_nolen
2812 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2813 use the macro wrapper C<SvPV_nolen(sv)> instead.
2818 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2821 return sv_2pv(sv, &n_a);
2824 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2825 * UV as a string towards the end of buf, and return pointers to start and
2828 * We assume that buf is at least TYPE_CHARS(UV) long.
2832 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2834 char *ptr = buf + TYPE_CHARS(UV);
2848 *--ptr = '0' + (uv % 10);
2856 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2857 * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2861 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2863 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2867 =for apidoc sv_2pv_flags
2869 Returns a pointer to the string value of an SV, and sets *lp to its length.
2870 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2872 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2873 usually end up here too.
2879 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2884 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2885 char *tmpbuf = tbuf;
2891 if (SvGMAGICAL(sv)) {
2892 if (flags & SV_GMAGIC)
2900 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2902 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2907 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2912 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2913 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2920 if (SvTHINKFIRST(sv)) {
2923 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2924 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2925 return SvPV(tmpstr,*lp);
2932 switch (SvTYPE(sv)) {
2934 if ( ((SvFLAGS(sv) &
2935 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2936 == (SVs_OBJECT|SVs_RMG))
2937 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2938 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2939 regexp *re = (regexp *)mg->mg_obj;
2942 char *fptr = "msix";
2947 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2949 while((ch = *fptr++)) {
2951 reflags[left++] = ch;
2954 reflags[right--] = ch;
2959 reflags[left] = '-';
2963 mg->mg_len = re->prelen + 4 + left;
2964 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2965 Copy("(?", mg->mg_ptr, 2, char);
2966 Copy(reflags, mg->mg_ptr+2, left, char);
2967 Copy(":", mg->mg_ptr+left+2, 1, char);
2968 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2969 mg->mg_ptr[mg->mg_len - 1] = ')';
2970 mg->mg_ptr[mg->mg_len] = 0;
2972 PL_reginterp_cnt += re->program[0].next_off;
2984 case SVt_PVBM: if (SvROK(sv))
2987 s = "SCALAR"; break;
2988 case SVt_PVLV: s = "LVALUE"; break;
2989 case SVt_PVAV: s = "ARRAY"; break;
2990 case SVt_PVHV: s = "HASH"; break;
2991 case SVt_PVCV: s = "CODE"; break;
2992 case SVt_PVGV: s = "GLOB"; break;
2993 case SVt_PVFM: s = "FORMAT"; break;
2994 case SVt_PVIO: s = "IO"; break;
2995 default: s = "UNKNOWN"; break;
2999 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3002 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3008 if (SvREADONLY(sv) && !SvOK(sv)) {
3009 if (ckWARN(WARN_UNINITIALIZED))
3015 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3016 /* I'm assuming that if both IV and NV are equally valid then
3017 converting the IV is going to be more efficient */
3018 U32 isIOK = SvIOK(sv);
3019 U32 isUIOK = SvIsUV(sv);
3020 char buf[TYPE_CHARS(UV)];
3023 if (SvTYPE(sv) < SVt_PVIV)
3024 sv_upgrade(sv, SVt_PVIV);
3026 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3028 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3029 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
3030 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3031 SvCUR_set(sv, ebuf - ptr);
3041 else if (SvNOKp(sv)) {
3042 if (SvTYPE(sv) < SVt_PVNV)
3043 sv_upgrade(sv, SVt_PVNV);
3044 /* The +20 is pure guesswork. Configure test needed. --jhi */
3045 SvGROW(sv, NV_DIG + 20);
3047 olderrno = errno; /* some Xenix systems wipe out errno here */
3049 if (SvNVX(sv) == 0.0)
3050 (void)strcpy(s,"0");
3054 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3057 #ifdef FIXNEGATIVEZERO
3058 if (*s == '-' && s[1] == '0' && !s[2])
3068 if (ckWARN(WARN_UNINITIALIZED)
3069 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3072 if (SvTYPE(sv) < SVt_PV)
3073 /* Typically the caller expects that sv_any is not NULL now. */
3074 sv_upgrade(sv, SVt_PV);
3077 *lp = s - SvPVX(sv);
3080 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3081 PTR2UV(sv),SvPVX(sv)));
3085 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3086 /* Sneaky stuff here */
3090 tsv = newSVpv(tmpbuf, 0);
3106 len = strlen(tmpbuf);
3108 #ifdef FIXNEGATIVEZERO
3109 if (len == 2 && t[0] == '-' && t[1] == '0') {
3114 (void)SvUPGRADE(sv, SVt_PV);
3116 s = SvGROW(sv, len + 1);
3125 =for apidoc sv_2pvbyte_nolen
3127 Return a pointer to the byte-encoded representation of the SV.
3128 May cause the SV to be downgraded from UTF8 as a side-effect.
3130 Usually accessed via the C<SvPVbyte_nolen> macro.
3136 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3139 return sv_2pvbyte(sv, &n_a);
3143 =for apidoc sv_2pvbyte
3145 Return a pointer to the byte-encoded representation of the SV, and set *lp
3146 to its length. May cause the SV to be downgraded from UTF8 as a
3149 Usually accessed via the C<SvPVbyte> macro.
3155 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3157 sv_utf8_downgrade(sv,0);
3158 return SvPV(sv,*lp);
3162 =for apidoc sv_2pvutf8_nolen
3164 Return a pointer to the UTF8-encoded representation of the SV.
3165 May cause the SV to be upgraded to UTF8 as a side-effect.
3167 Usually accessed via the C<SvPVutf8_nolen> macro.
3173 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3176 return sv_2pvutf8(sv, &n_a);
3180 =for apidoc sv_2pvutf8
3182 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3183 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3185 Usually accessed via the C<SvPVutf8> macro.
3191 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3193 sv_utf8_upgrade(sv);
3194 return SvPV(sv,*lp);
3198 =for apidoc sv_2bool
3200 This function is only called on magical items, and is only used by
3201 sv_true() or its macro equivalent.
3207 Perl_sv_2bool(pTHX_ register SV *sv)
3216 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3217 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
3218 return SvTRUE(tmpsv);
3219 return SvRV(sv) != 0;
3222 register XPV* Xpvtmp;
3223 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3224 (*Xpvtmp->xpv_pv > '0' ||
3225 Xpvtmp->xpv_cur > 1 ||
3226 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3233 return SvIVX(sv) != 0;
3236 return SvNVX(sv) != 0.0;
3244 =for apidoc sv_utf8_upgrade
3246 Convert the PV of an SV to its UTF8-encoded form.
3247 Forces the SV to string form if it is not already.
3248 Always sets the SvUTF8 flag to avoid future validity checks even
3249 if all the bytes have hibit clear.
3255 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3257 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3261 =for apidoc sv_utf8_upgrade_flags
3263 Convert the PV of an SV to its UTF8-encoded form.
3264 Forces the SV to string form if it is not already.
3265 Always sets the SvUTF8 flag to avoid future validity checks even
3266 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3267 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3268 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3274 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3284 (void) sv_2pv_flags(sv,&len, flags);
3292 if (SvREADONLY(sv) && SvFAKE(sv)) {
3293 sv_force_normal(sv);
3296 /* This function could be much more efficient if we had a FLAG in SVs
3297 * to signal if there are any hibit chars in the PV.
3298 * Given that there isn't make loop fast as possible
3300 s = (U8 *) SvPVX(sv);
3301 e = (U8 *) SvEND(sv);
3305 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3311 len = SvCUR(sv) + 1; /* Plus the \0 */
3312 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3313 SvCUR(sv) = len - 1;
3315 Safefree(s); /* No longer using what was there before. */
3316 SvLEN(sv) = len; /* No longer know the real size. */
3318 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3324 =for apidoc sv_utf8_downgrade
3326 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3327 This may not be possible if the PV contains non-byte encoding characters;
3328 if this is the case, either returns false or, if C<fail_ok> is not
3335 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3337 if (SvPOK(sv) && SvUTF8(sv)) {
3342 if (SvREADONLY(sv) && SvFAKE(sv))
3343 sv_force_normal(sv);
3344 s = (U8 *) SvPV(sv, len);
3345 if (!utf8_to_bytes(s, &len)) {
3348 #ifdef USE_BYTES_DOWNGRADES
3349 else if (IN_BYTES) {
3351 U8 *e = (U8 *) SvEND(sv);
3354 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3355 if (first && ch > 255) {
3357 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3360 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3367 len = (d - (U8 *) SvPVX(sv));
3372 Perl_croak(aTHX_ "Wide character in %s",
3375 Perl_croak(aTHX_ "Wide character");
3386 =for apidoc sv_utf8_encode
3388 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3389 flag so that it looks like octets again. Used as a building block
3390 for encode_utf8 in Encode.xs
3396 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3398 (void) sv_utf8_upgrade(sv);
3403 =for apidoc sv_utf8_decode
3405 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3406 turn off SvUTF8 if needed so that we see characters. Used as a building block
3407 for decode_utf8 in Encode.xs
3413 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3419 /* The octets may have got themselves encoded - get them back as
3422 if (!sv_utf8_downgrade(sv, TRUE))
3425 /* it is actually just a matter of turning the utf8 flag on, but
3426 * we want to make sure everything inside is valid utf8 first.
3428 c = (U8 *) SvPVX(sv);
3429 if (!is_utf8_string(c, SvCUR(sv)+1))
3431 e = (U8 *) SvEND(sv);
3434 if (!UTF8_IS_INVARIANT(ch)) {
3444 =for apidoc sv_setsv
3446 Copies the contents of the source SV C<ssv> into the destination SV
3447 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3448 function if the source SV needs to be reused. Does not handle 'set' magic.
3449 Loosely speaking, it performs a copy-by-value, obliterating any previous
3450 content of the destination.
3452 You probably want to use one of the assortment of wrappers, such as
3453 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3454 C<SvSetMagicSV_nosteal>.
3460 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3461 for binary compatibility only
3464 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3466 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3470 =for apidoc sv_setsv_flags
3472 Copies the contents of the source SV C<ssv> into the destination SV
3473 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3474 function if the source SV needs to be reused. Does not handle 'set' magic.
3475 Loosely speaking, it performs a copy-by-value, obliterating any previous
3476 content of the destination.
3477 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3478 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3479 implemented in terms of this function.
3481 You probably want to use one of the assortment of wrappers, such as
3482 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3483 C<SvSetMagicSV_nosteal>.
3485 This is the primary function for copying scalars, and most other
3486 copy-ish functions and macros use this underneath.
3492 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3494 register U32 sflags;
3500 SV_CHECK_THINKFIRST(dstr);
3502 sstr = &PL_sv_undef;
3503 stype = SvTYPE(sstr);
3504 dtype = SvTYPE(dstr);
3508 /* There's a lot of redundancy below but we're going for speed here */
3513 if (dtype != SVt_PVGV) {
3514 (void)SvOK_off(dstr);
3522 sv_upgrade(dstr, SVt_IV);
3525 sv_upgrade(dstr, SVt_PVNV);
3529 sv_upgrade(dstr, SVt_PVIV);
3532 (void)SvIOK_only(dstr);
3533 SvIVX(dstr) = SvIVX(sstr);
3536 if (SvTAINTED(sstr))
3547 sv_upgrade(dstr, SVt_NV);
3552 sv_upgrade(dstr, SVt_PVNV);
3555 SvNVX(dstr) = SvNVX(sstr);
3556 (void)SvNOK_only(dstr);
3557 if (SvTAINTED(sstr))
3565 sv_upgrade(dstr, SVt_RV);
3566 else if (dtype == SVt_PVGV &&
3567 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3570 if (GvIMPORTED(dstr) != GVf_IMPORTED
3571 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3573 GvIMPORTED_on(dstr);
3584 sv_upgrade(dstr, SVt_PV);
3587 if (dtype < SVt_PVIV)
3588 sv_upgrade(dstr, SVt_PVIV);
3591 if (dtype < SVt_PVNV)
3592 sv_upgrade(dstr, SVt_PVNV);
3599 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3602 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3606 if (dtype <= SVt_PVGV) {
3608 if (dtype != SVt_PVGV) {
3609 char *name = GvNAME(sstr);
3610 STRLEN len = GvNAMELEN(sstr);
3611 sv_upgrade(dstr, SVt_PVGV);
3612 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3613 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3614 GvNAME(dstr) = savepvn(name, len);
3615 GvNAMELEN(dstr) = len;
3616 SvFAKE_on(dstr); /* can coerce to non-glob */
3618 /* ahem, death to those who redefine active sort subs */
3619 else if (PL_curstackinfo->si_type == PERLSI_SORT
3620 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3621 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3624 #ifdef GV_UNIQUE_CHECK
3625 if (GvUNIQUE((GV*)dstr)) {
3626 Perl_croak(aTHX_ PL_no_modify);
3630 (void)SvOK_off(dstr);
3631 GvINTRO_off(dstr); /* one-shot flag */
3633 GvGP(dstr) = gp_ref(GvGP(sstr));
3634 if (SvTAINTED(sstr))
3636 if (GvIMPORTED(dstr) != GVf_IMPORTED
3637 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3639 GvIMPORTED_on(dstr);
3647 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3649 if (SvTYPE(sstr) != stype) {
3650 stype = SvTYPE(sstr);
3651 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3655 if (stype == SVt_PVLV)
3656 (void)SvUPGRADE(dstr, SVt_PVNV);
3658 (void)SvUPGRADE(dstr, stype);
3661 sflags = SvFLAGS(sstr);
3663 if (sflags & SVf_ROK) {
3664 if (dtype >= SVt_PV) {
3665 if (dtype == SVt_PVGV) {
3666 SV *sref = SvREFCNT_inc(SvRV(sstr));
3668 int intro = GvINTRO(dstr);
3670 #ifdef GV_UNIQUE_CHECK
3671 if (GvUNIQUE((GV*)dstr)) {
3672 Perl_croak(aTHX_ PL_no_modify);
3677 GvINTRO_off(dstr); /* one-shot flag */
3678 GvLINE(dstr) = CopLINE(PL_curcop);
3679 GvEGV(dstr) = (GV*)dstr;
3682 switch (SvTYPE(sref)) {
3685 SAVESPTR(GvAV(dstr));
3687 dref = (SV*)GvAV(dstr);
3688 GvAV(dstr) = (AV*)sref;
3689 if (!GvIMPORTED_AV(dstr)
3690 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3692 GvIMPORTED_AV_on(dstr);
3697 SAVESPTR(GvHV(dstr));
3699 dref = (SV*)GvHV(dstr);
3700 GvHV(dstr) = (HV*)sref;
3701 if (!GvIMPORTED_HV(dstr)
3702 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3704 GvIMPORTED_HV_on(dstr);
3709 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3710 SvREFCNT_dec(GvCV(dstr));
3711 GvCV(dstr) = Nullcv;
3712 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3713 PL_sub_generation++;
3715 SAVESPTR(GvCV(dstr));
3718 dref = (SV*)GvCV(dstr);
3719 if (GvCV(dstr) != (CV*)sref) {
3720 CV* cv = GvCV(dstr);
3722 if (!GvCVGEN((GV*)dstr) &&
3723 (CvROOT(cv) || CvXSUB(cv)))
3725 /* ahem, death to those who redefine
3726 * active sort subs */
3727 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3728 PL_sortcop == CvSTART(cv))
3730 "Can't redefine active sort subroutine %s",
3731 GvENAME((GV*)dstr));
3732 /* Redefining a sub - warning is mandatory if
3733 it was a const and its value changed. */
3734 if (ckWARN(WARN_REDEFINE)
3736 && (!CvCONST((CV*)sref)
3737 || sv_cmp(cv_const_sv(cv),
3738 cv_const_sv((CV*)sref)))))
3740 Perl_warner(aTHX_ WARN_REDEFINE,
3742 ? "Constant subroutine %s redefined"
3743 : "Subroutine %s redefined",
3744 GvENAME((GV*)dstr));
3747 cv_ckproto(cv, (GV*)dstr,
3748 SvPOK(sref) ? SvPVX(sref) : Nullch);
3750 GvCV(dstr) = (CV*)sref;
3751 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3752 GvASSUMECV_on(dstr);
3753 PL_sub_generation++;
3755 if (!GvIMPORTED_CV(dstr)
3756 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3758 GvIMPORTED_CV_on(dstr);
3763 SAVESPTR(GvIOp(dstr));
3765 dref = (SV*)GvIOp(dstr);
3766 GvIOp(dstr) = (IO*)sref;
3770 SAVESPTR(GvFORM(dstr));
3772 dref = (SV*)GvFORM(dstr);
3773 GvFORM(dstr) = (CV*)sref;
3777 SAVESPTR(GvSV(dstr));
3779 dref = (SV*)GvSV(dstr);
3781 if (!GvIMPORTED_SV(dstr)
3782 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3784 GvIMPORTED_SV_on(dstr);
3792 if (SvTAINTED(sstr))
3797 (void)SvOOK_off(dstr); /* backoff */
3799 Safefree(SvPVX(dstr));
3800 SvLEN(dstr)=SvCUR(dstr)=0;
3803 (void)SvOK_off(dstr);
3804 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3806 if (sflags & SVp_NOK) {
3808 /* Only set the public OK flag if the source has public OK. */
3809 if (sflags & SVf_NOK)
3810 SvFLAGS(dstr) |= SVf_NOK;
3811 SvNVX(dstr) = SvNVX(sstr);
3813 if (sflags & SVp_IOK) {
3814 (void)SvIOKp_on(dstr);
3815 if (sflags & SVf_IOK)
3816 SvFLAGS(dstr) |= SVf_IOK;
3817 if (sflags & SVf_IVisUV)
3819 SvIVX(dstr) = SvIVX(sstr);
3821 if (SvAMAGIC(sstr)) {
3825 else if (sflags & SVp_POK) {
3828 * Check to see if we can just swipe the string. If so, it's a
3829 * possible small lose on short strings, but a big win on long ones.
3830 * It might even be a win on short strings if SvPVX(dstr)
3831 * has to be allocated and SvPVX(sstr) has to be freed.
3834 if (SvTEMP(sstr) && /* slated for free anyway? */
3835 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3836 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3837 SvLEN(sstr) && /* and really is a string */
3838 /* and won't be needed again, potentially */
3839 !(PL_op && PL_op->op_type == OP_AASSIGN))
3841 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3843 SvFLAGS(dstr) &= ~SVf_OOK;
3844 Safefree(SvPVX(dstr) - SvIVX(dstr));
3846 else if (SvLEN(dstr))
3847 Safefree(SvPVX(dstr));
3849 (void)SvPOK_only(dstr);
3850 SvPV_set(dstr, SvPVX(sstr));
3851 SvLEN_set(dstr, SvLEN(sstr));
3852 SvCUR_set(dstr, SvCUR(sstr));
3855 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3856 SvPV_set(sstr, Nullch);
3861 else { /* have to copy actual string */
3862 STRLEN len = SvCUR(sstr);
3864 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3865 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3866 SvCUR_set(dstr, len);
3867 *SvEND(dstr) = '\0';
3868 (void)SvPOK_only(dstr);
3870 if (sflags & SVf_UTF8)
3873 if (sflags & SVp_NOK) {
3875 if (sflags & SVf_NOK)
3876 SvFLAGS(dstr) |= SVf_NOK;
3877 SvNVX(dstr) = SvNVX(sstr);
3879 if (sflags & SVp_IOK) {
3880 (void)SvIOKp_on(dstr);
3881 if (sflags & SVf_IOK)
3882 SvFLAGS(dstr) |= SVf_IOK;
3883 if (sflags & SVf_IVisUV)
3885 SvIVX(dstr) = SvIVX(sstr);
3888 else if (sflags & SVp_IOK) {
3889 if (sflags & SVf_IOK)
3890 (void)SvIOK_only(dstr);
3892 (void)SvOK_off(dstr);
3893 (void)SvIOKp_on(dstr);
3895 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3896 if (sflags & SVf_IVisUV)
3898 SvIVX(dstr) = SvIVX(sstr);
3899 if (sflags & SVp_NOK) {
3900 if (sflags & SVf_NOK)
3901 (void)SvNOK_on(dstr);
3903 (void)SvNOKp_on(dstr);
3904 SvNVX(dstr) = SvNVX(sstr);
3907 else if (sflags & SVp_NOK) {
3908 if (sflags & SVf_NOK)
3909 (void)SvNOK_only(dstr);
3911 (void)SvOK_off(dstr);
3914 SvNVX(dstr) = SvNVX(sstr);
3917 if (dtype == SVt_PVGV) {
3918 if (ckWARN(WARN_MISC))
3919 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3922 (void)SvOK_off(dstr);
3924 if (SvTAINTED(sstr))
3929 =for apidoc sv_setsv_mg
3931 Like C<sv_setsv>, but also handles 'set' magic.
3937 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3939 sv_setsv(dstr,sstr);
3944 =for apidoc sv_setpvn
3946 Copies a string into an SV. The C<len> parameter indicates the number of
3947 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3953 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3955 register char *dptr;
3957 SV_CHECK_THINKFIRST(sv);
3963 /* len is STRLEN which is unsigned, need to copy to signed */
3966 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3968 (void)SvUPGRADE(sv, SVt_PV);
3970 SvGROW(sv, len + 1);
3972 Move(ptr,dptr,len,char);
3975 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3980 =for apidoc sv_setpvn_mg
3982 Like C<sv_setpvn>, but also handles 'set' magic.
3988 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3990 sv_setpvn(sv,ptr,len);
3995 =for apidoc sv_setpv
3997 Copies a string into an SV. The string must be null-terminated. Does not
3998 handle 'set' magic. See C<sv_setpv_mg>.
4004 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4006 register STRLEN len;
4008 SV_CHECK_THINKFIRST(sv);
4014 (void)SvUPGRADE(sv, SVt_PV);
4016 SvGROW(sv, len + 1);
4017 Move(ptr,SvPVX(sv),len+1,char);
4019 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4024 =for apidoc sv_setpv_mg
4026 Like C<sv_setpv>, but also handles 'set' magic.
4032 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4039 =for apidoc sv_usepvn
4041 Tells an SV to use C<ptr> to find its string value. Normally the string is
4042 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4043 The C<ptr> should point to memory that was allocated by C<malloc>. The
4044 string length, C<len>, must be supplied. This function will realloc the
4045 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4046 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4047 See C<sv_usepvn_mg>.
4053 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4055 SV_CHECK_THINKFIRST(sv);
4056 (void)SvUPGRADE(sv, SVt_PV);
4061 (void)SvOOK_off(sv);
4062 if (SvPVX(sv) && SvLEN(sv))
4063 Safefree(SvPVX(sv));
4064 Renew(ptr, len+1, char);
4067 SvLEN_set(sv, len+1);
4069 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4074 =for apidoc sv_usepvn_mg
4076 Like C<sv_usepvn>, but also handles 'set' magic.
4082 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4084 sv_usepvn(sv,ptr,len);
4089 =for apidoc sv_force_normal_flags
4091 Undo various types of fakery on an SV: if the PV is a shared string, make
4092 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4093 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4094 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4100 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4102 if (SvREADONLY(sv)) {
4104 char *pvx = SvPVX(sv);
4105 STRLEN len = SvCUR(sv);
4106 U32 hash = SvUVX(sv);
4107 SvGROW(sv, len + 1);
4108 Move(pvx,SvPVX(sv),len,char);
4112 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4114 else if (PL_curcop != &PL_compiling)
4115 Perl_croak(aTHX_ PL_no_modify);
4118 sv_unref_flags(sv, flags);
4119 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4124 =for apidoc sv_force_normal
4126 Undo various types of fakery on an SV: if the PV is a shared string, make
4127 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4128 an xpvmg. See also C<sv_force_normal_flags>.
4134 Perl_sv_force_normal(pTHX_ register SV *sv)
4136 sv_force_normal_flags(sv, 0);
4142 Efficient removal of characters from the beginning of the string buffer.
4143 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4144 the string buffer. The C<ptr> becomes the first character of the adjusted
4145 string. Uses the "OOK hack".
4151 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4153 register STRLEN delta;
4155 if (!ptr || !SvPOKp(sv))
4157 SV_CHECK_THINKFIRST(sv);
4158 if (SvTYPE(sv) < SVt_PVIV)
4159 sv_upgrade(sv,SVt_PVIV);
4162 if (!SvLEN(sv)) { /* make copy of shared string */
4163 char *pvx = SvPVX(sv);
4164 STRLEN len = SvCUR(sv);
4165 SvGROW(sv, len + 1);
4166 Move(pvx,SvPVX(sv),len,char);
4170 SvFLAGS(sv) |= SVf_OOK;
4172 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4173 delta = ptr - SvPVX(sv);
4181 =for apidoc sv_catpvn
4183 Concatenates the string onto the end of the string which is in the SV. The
4184 C<len> indicates number of bytes to copy. If the SV has the UTF8
4185 status set, then the bytes appended should be valid UTF8.
4186 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4191 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4192 for binary compatibility only
4195 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4197 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4201 =for apidoc sv_catpvn_flags
4203 Concatenates the string onto the end of the string which is in the SV. The
4204 C<len> indicates number of bytes to copy. If the SV has the UTF8
4205 status set, then the bytes appended should be valid UTF8.
4206 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4207 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4208 in terms of this function.
4214 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4219 dstr = SvPV_force_flags(dsv, dlen, flags);
4220 SvGROW(dsv, dlen + slen + 1);
4223 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4226 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4231 =for apidoc sv_catpvn_mg
4233 Like C<sv_catpvn>, but also handles 'set' magic.
4239 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4241 sv_catpvn(sv,ptr,len);
4246 =for apidoc sv_catsv
4248 Concatenates the string from SV C<ssv> onto the end of the string in
4249 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4250 not 'set' magic. See C<sv_catsv_mg>.
4254 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4255 for binary compatibility only
4258 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4260 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4264 =for apidoc sv_catsv_flags
4266 Concatenates the string from SV C<ssv> onto the end of the string in
4267 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4268 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4269 and C<sv_catsv_nomg> are implemented in terms of this function.
4274 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4280 if ((spv = SvPV(ssv, slen))) {
4281 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4282 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4283 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4284 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4285 dsv->sv_flags doesn't have that bit set.
4286 Andy Dougherty 12 Oct 2001
4288 I32 sutf8 = DO_UTF8(ssv);
4291 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4293 dutf8 = DO_UTF8(dsv);
4295 if (dutf8 != sutf8) {
4297 /* Not modifying source SV, so taking a temporary copy. */
4298 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4300 sv_utf8_upgrade(csv);
4301 spv = SvPV(csv, slen);
4304 sv_utf8_upgrade_nomg(dsv);
4306 sv_catpvn_nomg(dsv, spv, slen);
4311 =for apidoc sv_catsv_mg
4313 Like C<sv_catsv>, but also handles 'set' magic.
4319 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4326 =for apidoc sv_catpv
4328 Concatenates the string onto the end of the string which is in the SV.
4329 If the SV has the UTF8 status set, then the bytes appended should be
4330 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4335 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4337 register STRLEN len;
4343 junk = SvPV_force(sv, tlen);
4345 SvGROW(sv, tlen + len + 1);
4348 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4350 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4355 =for apidoc sv_catpv_mg
4357 Like C<sv_catpv>, but also handles 'set' magic.
4363 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4372 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4373 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4380 Perl_newSV(pTHX_ STRLEN len)
4386 sv_upgrade(sv, SVt_PV);
4387 SvGROW(sv, len + 1);
4393 =for apidoc sv_magic
4395 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4396 then adds a new magic item of type C<how> to the head of the magic list.
4398 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4404 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4408 if (SvREADONLY(sv)) {
4409 if (PL_curcop != &PL_compiling
4410 && how != PERL_MAGIC_regex_global
4411 && how != PERL_MAGIC_bm
4412 && how != PERL_MAGIC_fm
4413 && how != PERL_MAGIC_sv
4416 Perl_croak(aTHX_ PL_no_modify);
4419 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4420 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4421 if (how == PERL_MAGIC_taint)
4427 (void)SvUPGRADE(sv, SVt_PVMG);
4429 Newz(702,mg, 1, MAGIC);
4430 mg->mg_moremagic = SvMAGIC(sv);
4433 /* Some magic contains a reference loop, where the sv and object refer to
4434 each other. To avoid a reference loop that would prevent such objects
4435 being freed, we look for such loops and if we find one we avoid
4436 incrementing the object refcount. */
4437 if (!obj || obj == sv ||
4438 how == PERL_MAGIC_arylen ||
4439 how == PERL_MAGIC_qr ||
4440 (SvTYPE(obj) == SVt_PVGV &&
4441 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4442 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4443 GvFORM(obj) == (CV*)sv)))
4448 mg->mg_obj = SvREFCNT_inc(obj);
4449 mg->mg_flags |= MGf_REFCOUNTED;
4452 mg->mg_len = namlen;
4455 mg->mg_ptr = savepvn(name, namlen);
4456 else if (namlen == HEf_SVKEY)
4457 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4462 mg->mg_virtual = &PL_vtbl_sv;
4464 case PERL_MAGIC_overload:
4465 mg->mg_virtual = &PL_vtbl_amagic;
4467 case PERL_MAGIC_overload_elem:
4468 mg->mg_virtual = &PL_vtbl_amagicelem;
4470 case PERL_MAGIC_overload_table:
4471 mg->mg_virtual = &PL_vtbl_ovrld;
4474 mg->mg_virtual = &PL_vtbl_bm;
4476 case PERL_MAGIC_regdata:
4477 mg->mg_virtual = &PL_vtbl_regdata;
4479 case PERL_MAGIC_regdatum:
4480 mg->mg_virtual = &PL_vtbl_regdatum;
4482 case PERL_MAGIC_env:
4483 mg->mg_virtual = &PL_vtbl_env;
4486 mg->mg_virtual = &PL_vtbl_fm;
4488 case PERL_MAGIC_envelem:
4489 mg->mg_virtual = &PL_vtbl_envelem;
4491 case PERL_MAGIC_regex_global:
4492 mg->mg_virtual = &PL_vtbl_mglob;
4494 case PERL_MAGIC_isa:
4495 mg->mg_virtual = &PL_vtbl_isa;
4497 case PERL_MAGIC_isaelem:
4498 mg->mg_virtual = &PL_vtbl_isaelem;
4500 case PERL_MAGIC_nkeys:
4501 mg->mg_virtual = &PL_vtbl_nkeys;
4503 case PERL_MAGIC_dbfile:
4507 case PERL_MAGIC_dbline:
4508 mg->mg_virtual = &PL_vtbl_dbline;
4510 #ifdef USE_5005THREADS
4511 case PERL_MAGIC_mutex:
4512 mg->mg_virtual = &PL_vtbl_mutex;
4514 #endif /* USE_5005THREADS */
4515 #ifdef USE_LOCALE_COLLATE
4516 case PERL_MAGIC_collxfrm:
4517 mg->mg_virtual = &PL_vtbl_collxfrm;
4519 #endif /* USE_LOCALE_COLLATE */
4520 case PERL_MAGIC_tied:
4521 mg->mg_virtual = &PL_vtbl_pack;
4523 case PERL_MAGIC_tiedelem:
4524 case PERL_MAGIC_tiedscalar:
4525 mg->mg_virtual = &PL_vtbl_packelem;
4528 mg->mg_virtual = &PL_vtbl_regexp;
4530 case PERL_MAGIC_sig:
4531 mg->mg_virtual = &PL_vtbl_sig;
4533 case PERL_MAGIC_sigelem:
4534 mg->mg_virtual = &PL_vtbl_sigelem;
4536 case PERL_MAGIC_taint:
4537 mg->mg_virtual = &PL_vtbl_taint;
4540 case PERL_MAGIC_uvar:
4541 mg->mg_virtual = &PL_vtbl_uvar;
4543 case PERL_MAGIC_vec:
4544 mg->mg_virtual = &PL_vtbl_vec;
4546 case PERL_MAGIC_substr:
4547 mg->mg_virtual = &PL_vtbl_substr;
4549 case PERL_MAGIC_defelem:
4550 mg->mg_virtual = &PL_vtbl_defelem;
4552 case PERL_MAGIC_glob:
4553 mg->mg_virtual = &PL_vtbl_glob;
4555 case PERL_MAGIC_arylen:
4556 mg->mg_virtual = &PL_vtbl_arylen;
4558 case PERL_MAGIC_pos:
4559 mg->mg_virtual = &PL_vtbl_pos;
4561 case PERL_MAGIC_backref:
4562 mg->mg_virtual = &PL_vtbl_backref;
4564 case PERL_MAGIC_ext:
4565 /* Reserved for use by extensions not perl internals. */
4566 /* Useful for attaching extension internal data to perl vars. */
4567 /* Note that multiple extensions may clash if magical scalars */
4568 /* etc holding private data from one are passed to another. */
4572 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4576 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4580 =for apidoc sv_unmagic
4582 Removes all magic of type C<type> from an SV.
4588 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4592 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4595 for (mg = *mgp; mg; mg = *mgp) {
4596 if (mg->mg_type == type) {
4597 MGVTBL* vtbl = mg->mg_virtual;
4598 *mgp = mg->mg_moremagic;
4599 if (vtbl && vtbl->svt_free)
4600 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4601 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4602 if (mg->mg_len >= 0)
4603 Safefree(mg->mg_ptr);
4604 else if (mg->mg_len == HEf_SVKEY)
4605 SvREFCNT_dec((SV*)mg->mg_ptr);
4607 if (mg->mg_flags & MGf_REFCOUNTED)
4608 SvREFCNT_dec(mg->mg_obj);
4612 mgp = &mg->mg_moremagic;
4616 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4623 =for apidoc sv_rvweaken
4625 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4626 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4627 push a back-reference to this RV onto the array of backreferences
4628 associated with that magic.
4634 Perl_sv_rvweaken(pTHX_ SV *sv)
4637 if (!SvOK(sv)) /* let undefs pass */
4640 Perl_croak(aTHX_ "Can't weaken a nonreference");
4641 else if (SvWEAKREF(sv)) {
4642 if (ckWARN(WARN_MISC))
4643 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4647 sv_add_backref(tsv, sv);
4653 /* Give tsv backref magic if it hasn't already got it, then push a
4654 * back-reference to sv onto the array associated with the backref magic.
4658 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4662 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4663 av = (AV*)mg->mg_obj;
4666 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4667 SvREFCNT_dec(av); /* for sv_magic */
4672 /* delete a back-reference to ourselves from the backref magic associated
4673 * with the SV we point to.
4677 S_sv_del_backref(pTHX_ SV *sv)
4684 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4685 Perl_croak(aTHX_ "panic: del_backref");
4686 av = (AV *)mg->mg_obj;
4691 svp[i] = &PL_sv_undef; /* XXX */
4698 =for apidoc sv_insert
4700 Inserts a string at the specified offset/length within the SV. Similar to
4701 the Perl substr() function.
4707 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4711 register char *midend;
4712 register char *bigend;
4718 Perl_croak(aTHX_ "Can't modify non-existent substring");
4719 SvPV_force(bigstr, curlen);
4720 (void)SvPOK_only_UTF8(bigstr);
4721 if (offset + len > curlen) {
4722 SvGROW(bigstr, offset+len+1);
4723 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4724 SvCUR_set(bigstr, offset+len);
4728 i = littlelen - len;
4729 if (i > 0) { /* string might grow */
4730 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4731 mid = big + offset + len;
4732 midend = bigend = big + SvCUR(bigstr);
4735 while (midend > mid) /* shove everything down */
4736 *--bigend = *--midend;
4737 Move(little,big+offset,littlelen,char);
4743 Move(little,SvPVX(bigstr)+offset,len,char);
4748 big = SvPVX(bigstr);
4751 bigend = big + SvCUR(bigstr);
4753 if (midend > bigend)
4754 Perl_croak(aTHX_ "panic: sv_insert");
4756 if (mid - big > bigend - midend) { /* faster to shorten from end */
4758 Move(little, mid, littlelen,char);
4761 i = bigend - midend;
4763 Move(midend, mid, i,char);
4767 SvCUR_set(bigstr, mid - big);
4770 else if ((i = mid - big)) { /* faster from front */
4771 midend -= littlelen;
4773 sv_chop(bigstr,midend-i);
4778 Move(little, mid, littlelen,char);
4780 else if (littlelen) {
4781 midend -= littlelen;
4782 sv_chop(bigstr,midend);
4783 Move(little,midend,littlelen,char);
4786 sv_chop(bigstr,midend);
4792 =for apidoc sv_replace
4794 Make the first argument a copy of the second, then delete the original.
4795 The target SV physically takes over ownership of the body of the source SV
4796 and inherits its flags; however, the target keeps any magic it owns,
4797 and any magic in the source is discarded.
4798 Note that this is a rather specialist SV copying operation; most of the
4799 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4805 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4807 U32 refcnt = SvREFCNT(sv);
4808 SV_CHECK_THINKFIRST(sv);
4809 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4810 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4811 if (SvMAGICAL(sv)) {
4815 sv_upgrade(nsv, SVt_PVMG);
4816 SvMAGIC(nsv) = SvMAGIC(sv);
4817 SvFLAGS(nsv) |= SvMAGICAL(sv);
4823 assert(!SvREFCNT(sv));
4824 StructCopy(nsv,sv,SV);
4825 SvREFCNT(sv) = refcnt;
4826 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4831 =for apidoc sv_clear
4833 Clear an SV: call any destructors, free up any memory used by the body,
4834 and free the body itself. The SV's head is I<not> freed, although
4835 its type is set to all 1's so that it won't inadvertently be assumed
4836 to be live during global destruction etc.
4837 This function should only be called when REFCNT is zero. Most of the time
4838 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4845 Perl_sv_clear(pTHX_ register SV *sv)
4849 assert(SvREFCNT(sv) == 0);
4852 if (PL_defstash) { /* Still have a symbol table? */
4857 Zero(&tmpref, 1, SV);
4858 sv_upgrade(&tmpref, SVt_RV);
4860 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4861 SvREFCNT(&tmpref) = 1;
4864 stash = SvSTASH(sv);
4865 destructor = StashHANDLER(stash,DESTROY);
4868 PUSHSTACKi(PERLSI_DESTROY);
4869 SvRV(&tmpref) = SvREFCNT_inc(sv);
4874 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4880 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4882 del_XRV(SvANY(&tmpref));
4885 if (PL_in_clean_objs)
4886 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4888 /* DESTROY gave object new lease on life */
4894 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4895 SvOBJECT_off(sv); /* Curse the object. */
4896 if (SvTYPE(sv) != SVt_PVIO)
4897 --PL_sv_objcount; /* XXX Might want something more general */
4900 if (SvTYPE(sv) >= SVt_PVMG) {
4903 if (SvFLAGS(sv) & SVpad_TYPED)
4904 SvREFCNT_dec(SvSTASH(sv));
4907 switch (SvTYPE(sv)) {
4910 IoIFP(sv) != PerlIO_stdin() &&
4911 IoIFP(sv) != PerlIO_stdout() &&
4912 IoIFP(sv) != PerlIO_stderr())
4914 io_close((IO*)sv, FALSE);
4916 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4917 PerlDir_close(IoDIRP(sv));
4918 IoDIRP(sv) = (DIR*)NULL;
4919 Safefree(IoTOP_NAME(sv));
4920 Safefree(IoFMT_NAME(sv));
4921 Safefree(IoBOTTOM_NAME(sv));
4936 SvREFCNT_dec(LvTARG(sv));
4940 Safefree(GvNAME(sv));
4941 /* cannot decrease stash refcount yet, as we might recursively delete
4942 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4943 of stash until current sv is completely gone.
4944 -- JohnPC, 27 Mar 1998 */
4945 stash = GvSTASH(sv);
4951 (void)SvOOK_off(sv);
4959 SvREFCNT_dec(SvRV(sv));
4961 else if (SvPVX(sv) && SvLEN(sv))
4962 Safefree(SvPVX(sv));
4963 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4964 unsharepvn(SvPVX(sv),
4965 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
4978 switch (SvTYPE(sv)) {
4994 del_XPVIV(SvANY(sv));
4997 del_XPVNV(SvANY(sv));
5000 del_XPVMG(SvANY(sv));
5003 del_XPVLV(SvANY(sv));
5006 del_XPVAV(SvANY(sv));
5009 del_XPVHV(SvANY(sv));
5012 del_XPVCV(SvANY(sv));
5015 del_XPVGV(SvANY(sv));
5016 /* code duplication for increased performance. */
5017 SvFLAGS(sv) &= SVf_BREAK;
5018 SvFLAGS(sv) |= SVTYPEMASK;
5019 /* decrease refcount of the stash that owns this GV, if any */
5021 SvREFCNT_dec(stash);
5022 return; /* not break, SvFLAGS reset already happened */
5024 del_XPVBM(SvANY(sv));
5027 del_XPVFM(SvANY(sv));
5030 del_XPVIO(SvANY(sv));
5033 SvFLAGS(sv) &= SVf_BREAK;
5034 SvFLAGS(sv) |= SVTYPEMASK;
5038 =for apidoc sv_newref
5040 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5047 Perl_sv_newref(pTHX_ SV *sv)
5050 ATOMIC_INC(SvREFCNT(sv));
5057 Decrement an SV's reference count, and if it drops to zero, call
5058 C<sv_clear> to invoke destructors and free up any memory used by
5059 the body; finally, deallocate the SV's head itself.
5060 Normally called via a wrapper macro C<SvREFCNT_dec>.
5066 Perl_sv_free(pTHX_ SV *sv)
5068 int refcount_is_zero;
5072 if (SvREFCNT(sv) == 0) {
5073 if (SvFLAGS(sv) & SVf_BREAK)
5074 /* this SV's refcnt has been artificially decremented to
5075 * trigger cleanup */
5077 if (PL_in_clean_all) /* All is fair */
5079 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5080 /* make sure SvREFCNT(sv)==0 happens very seldom */
5081 SvREFCNT(sv) = (~(U32)0)/2;
5084 if (ckWARN_d(WARN_INTERNAL))
5085 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5088 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5089 if (!refcount_is_zero)
5093 if (ckWARN_d(WARN_DEBUGGING))
5094 Perl_warner(aTHX_ WARN_DEBUGGING,
5095 "Attempt to free temp prematurely: SV 0x%"UVxf,
5100 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5101 /* make sure SvREFCNT(sv)==0 happens very seldom */
5102 SvREFCNT(sv) = (~(U32)0)/2;
5113 Returns the length of the string in the SV. Handles magic and type
5114 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5120 Perl_sv_len(pTHX_ register SV *sv)
5128 len = mg_length(sv);
5130 (void)SvPV(sv, len);
5135 =for apidoc sv_len_utf8
5137 Returns the number of characters in the string in an SV, counting wide
5138 UTF8 bytes as a single character. Handles magic and type coercion.
5144 Perl_sv_len_utf8(pTHX_ register SV *sv)
5150 return mg_length(sv);
5154 U8 *s = (U8*)SvPV(sv, len);
5156 return Perl_utf8_length(aTHX_ s, s + len);
5161 =for apidoc sv_pos_u2b
5163 Converts the value pointed to by offsetp from a count of UTF8 chars from
5164 the start of the string, to a count of the equivalent number of bytes; if
5165 lenp is non-zero, it does the same to lenp, but this time starting from
5166 the offset, rather than from the start of the string. Handles magic and
5173 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5178 I32 uoffset = *offsetp;
5184 start = s = (U8*)SvPV(sv, len);
5186 while (s < send && uoffset--)
5190 *offsetp = s - start;
5194 while (s < send && ulen--)
5204 =for apidoc sv_pos_b2u
5206 Converts the value pointed to by offsetp from a count of bytes from the
5207 start of the string, to a count of the equivalent number of UTF8 chars.
5208 Handles magic and type coercion.
5214 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5223 s = (U8*)SvPV(sv, len);
5225 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5226 send = s + *offsetp;
5230 /* Call utf8n_to_uvchr() to validate the sequence */
5231 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5246 Returns a boolean indicating whether the strings in the two SVs are
5247 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5248 coerce its args to strings if necessary.
5254 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5268 pv1 = SvPV(sv1, cur1);
5275 pv2 = SvPV(sv2, cur2);
5277 /* do not utf8ize the comparands as a side-effect */
5278 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5279 bool is_utf8 = TRUE;
5280 /* UTF-8ness differs */
5283 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5284 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5289 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5290 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5295 /* Downgrade not possible - cannot be eq */
5301 eq = memEQ(pv1, pv2, cur1);
5312 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5313 string in C<sv1> is less than, equal to, or greater than the string in
5314 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5315 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5321 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5326 bool pv1tmp = FALSE;
5327 bool pv2tmp = FALSE;
5334 pv1 = SvPV(sv1, cur1);
5341 pv2 = SvPV(sv2, cur2);
5343 /* do not utf8ize the comparands as a side-effect */
5344 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5346 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5350 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5356 cmp = cur2 ? -1 : 0;
5360 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5363 cmp = retval < 0 ? -1 : 1;
5364 } else if (cur1 == cur2) {
5367 cmp = cur1 < cur2 ? -1 : 1;
5380 =for apidoc sv_cmp_locale
5382 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5383 'use bytes' aware, handles get magic, and will coerce its args to strings
5384 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5390 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5392 #ifdef USE_LOCALE_COLLATE
5398 if (PL_collation_standard)
5402 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5404 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5406 if (!pv1 || !len1) {
5417 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5420 return retval < 0 ? -1 : 1;
5423 * When the result of collation is equality, that doesn't mean
5424 * that there are no differences -- some locales exclude some
5425 * characters from consideration. So to avoid false equalities,
5426 * we use the raw string as a tiebreaker.
5432 #endif /* USE_LOCALE_COLLATE */
5434 return sv_cmp(sv1, sv2);
5438 #ifdef USE_LOCALE_COLLATE
5441 =for apidoc sv_collxfrm
5443 Add Collate Transform magic to an SV if it doesn't already have it.
5445 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5446 scalar data of the variable, but transformed to such a format that a normal
5447 memory comparison can be used to compare the data according to the locale
5454 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5458 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5459 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5464 Safefree(mg->mg_ptr);
5466 if ((xf = mem_collxfrm(s, len, &xlen))) {
5467 if (SvREADONLY(sv)) {
5470 return xf + sizeof(PL_collation_ix);
5473 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5474 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5487 if (mg && mg->mg_ptr) {
5489 return mg->mg_ptr + sizeof(PL_collation_ix);
5497 #endif /* USE_LOCALE_COLLATE */
5502 Get a line from the filehandle and store it into the SV, optionally
5503 appending to the currently-stored string.
5509 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5513 register STDCHAR rslast;
5514 register STDCHAR *bp;
5519 SV_CHECK_THINKFIRST(sv);
5520 (void)SvUPGRADE(sv, SVt_PV);
5524 if (PL_curcop == &PL_compiling) {
5525 /* we always read code in line mode */
5529 else if (RsSNARF(PL_rs)) {
5533 else if (RsRECORD(PL_rs)) {
5534 I32 recsize, bytesread;
5537 /* Grab the size of the record we're getting */
5538 recsize = SvIV(SvRV(PL_rs));
5539 (void)SvPOK_only(sv); /* Validate pointer */
5540 buffer = SvGROW(sv, recsize + 1);
5543 /* VMS wants read instead of fread, because fread doesn't respect */
5544 /* RMS record boundaries. This is not necessarily a good thing to be */
5545 /* doing, but we've got no other real choice */
5546 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5548 bytesread = PerlIO_read(fp, buffer, recsize);
5550 SvCUR_set(sv, bytesread);
5551 buffer[bytesread] = '\0';
5552 if (PerlIO_isutf8(fp))
5556 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5558 else if (RsPARA(PL_rs)) {
5564 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5565 if (PerlIO_isutf8(fp)) {
5566 rsptr = SvPVutf8(PL_rs, rslen);
5569 if (SvUTF8(PL_rs)) {
5570 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5571 Perl_croak(aTHX_ "Wide character in $/");
5574 rsptr = SvPV(PL_rs, rslen);
5578 rslast = rslen ? rsptr[rslen - 1] : '\0';
5580 if (rspara) { /* have to do this both before and after */
5581 do { /* to make sure file boundaries work right */
5584 i = PerlIO_getc(fp);
5588 PerlIO_ungetc(fp,i);
5594 /* See if we know enough about I/O mechanism to cheat it ! */
5596 /* This used to be #ifdef test - it is made run-time test for ease
5597 of abstracting out stdio interface. One call should be cheap
5598 enough here - and may even be a macro allowing compile
5602 if (PerlIO_fast_gets(fp)) {
5605 * We're going to steal some values from the stdio struct
5606 * and put EVERYTHING in the innermost loop into registers.
5608 register STDCHAR *ptr;
5612 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5613 /* An ungetc()d char is handled separately from the regular
5614 * buffer, so we getc() it back out and stuff it in the buffer.
5616 i = PerlIO_getc(fp);
5617 if (i == EOF) return 0;
5618 *(--((*fp)->_ptr)) = (unsigned char) i;
5622 /* Here is some breathtakingly efficient cheating */
5624 cnt = PerlIO_get_cnt(fp); /* get count into register */
5625 (void)SvPOK_only(sv); /* validate pointer */
5626 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5627 if (cnt > 80 && SvLEN(sv) > append) {
5628 shortbuffered = cnt - SvLEN(sv) + append + 1;
5629 cnt -= shortbuffered;
5633 /* remember that cnt can be negative */
5634 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5639 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5640 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5641 DEBUG_P(PerlIO_printf(Perl_debug_log,
5642 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5643 DEBUG_P(PerlIO_printf(Perl_debug_log,
5644 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5645 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5646 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5651 while (cnt > 0) { /* this | eat */
5653 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5654 goto thats_all_folks; /* screams | sed :-) */
5658 Copy(ptr, bp, cnt, char); /* this | eat */
5659 bp += cnt; /* screams | dust */
5660 ptr += cnt; /* louder | sed :-) */
5665 if (shortbuffered) { /* oh well, must extend */
5666 cnt = shortbuffered;
5668 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5670 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5671 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5675 DEBUG_P(PerlIO_printf(Perl_debug_log,
5676 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5677 PTR2UV(ptr),(long)cnt));
5678 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5679 DEBUG_P(PerlIO_printf(Perl_debug_log,
5680 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5681 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5682 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5683 /* This used to call 'filbuf' in stdio form, but as that behaves like
5684 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5685 another abstraction. */
5686 i = PerlIO_getc(fp); /* get more characters */
5687 DEBUG_P(PerlIO_printf(Perl_debug_log,
5688 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5689 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5690 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5691 cnt = PerlIO_get_cnt(fp);
5692 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5693 DEBUG_P(PerlIO_printf(Perl_debug_log,
5694 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5696 if (i == EOF) /* all done for ever? */
5697 goto thats_really_all_folks;
5699 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5701 SvGROW(sv, bpx + cnt + 2);
5702 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5704 *bp++ = i; /* store character from PerlIO_getc */
5706 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5707 goto thats_all_folks;
5711 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5712 memNE((char*)bp - rslen, rsptr, rslen))
5713 goto screamer; /* go back to the fray */
5714 thats_really_all_folks:
5716 cnt += shortbuffered;
5717 DEBUG_P(PerlIO_printf(Perl_debug_log,
5718 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5719 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5720 DEBUG_P(PerlIO_printf(Perl_debug_log,
5721 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5722 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5723 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5725 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5726 DEBUG_P(PerlIO_printf(Perl_debug_log,
5727 "Screamer: done, len=%ld, string=|%.*s|\n",
5728 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5733 /*The big, slow, and stupid way */
5736 /* Need to work around EPOC SDK features */
5737 /* On WINS: MS VC5 generates calls to _chkstk, */
5738 /* if a `large' stack frame is allocated */
5739 /* gcc on MARM does not generate calls like these */
5745 register STDCHAR *bpe = buf + sizeof(buf);
5747 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5748 ; /* keep reading */
5752 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5753 /* Accomodate broken VAXC compiler, which applies U8 cast to
5754 * both args of ?: operator, causing EOF to change into 255
5756 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5760 sv_catpvn(sv, (char *) buf, cnt);
5762 sv_setpvn(sv, (char *) buf, cnt);
5764 if (i != EOF && /* joy */
5766 SvCUR(sv) < rslen ||
5767 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5771 * If we're reading from a TTY and we get a short read,
5772 * indicating that the user hit his EOF character, we need
5773 * to notice it now, because if we try to read from the TTY
5774 * again, the EOF condition will disappear.
5776 * The comparison of cnt to sizeof(buf) is an optimization
5777 * that prevents unnecessary calls to feof().
5781 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5786 if (rspara) { /* have to do this both before and after */
5787 while (i != EOF) { /* to make sure file boundaries work right */
5788 i = PerlIO_getc(fp);
5790 PerlIO_ungetc(fp,i);
5796 if (PerlIO_isutf8(fp))
5801 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5807 Auto-increment of the value in the SV, doing string to numeric conversion
5808 if necessary. Handles 'get' magic.
5814 Perl_sv_inc(pTHX_ register SV *sv)
5823 if (SvTHINKFIRST(sv)) {
5824 if (SvREADONLY(sv)) {
5825 if (PL_curcop != &PL_compiling)
5826 Perl_croak(aTHX_ PL_no_modify);
5830 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5832 i = PTR2IV(SvRV(sv));
5837 flags = SvFLAGS(sv);
5838 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5839 /* It's (privately or publicly) a float, but not tested as an
5840 integer, so test it to see. */
5842 flags = SvFLAGS(sv);
5844 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5845 /* It's publicly an integer, or privately an integer-not-float */
5846 #ifdef PERL_PRESERVE_IVUV
5850 if (SvUVX(sv) == UV_MAX)
5851 sv_setnv(sv, (NV)UV_MAX + 1.0);
5853 (void)SvIOK_only_UV(sv);
5856 if (SvIVX(sv) == IV_MAX)
5857 sv_setuv(sv, (UV)IV_MAX + 1);
5859 (void)SvIOK_only(sv);
5865 if (flags & SVp_NOK) {
5866 (void)SvNOK_only(sv);
5871 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5872 if ((flags & SVTYPEMASK) < SVt_PVIV)
5873 sv_upgrade(sv, SVt_IV);
5874 (void)SvIOK_only(sv);
5879 while (isALPHA(*d)) d++;
5880 while (isDIGIT(*d)) d++;
5882 #ifdef PERL_PRESERVE_IVUV
5883 /* Got to punt this an an integer if needs be, but we don't issue
5884 warnings. Probably ought to make the sv_iv_please() that does
5885 the conversion if possible, and silently. */
5886 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5887 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5888 /* Need to try really hard to see if it's an integer.
5889 9.22337203685478e+18 is an integer.
5890 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5891 so $a="9.22337203685478e+18"; $a+0; $a++
5892 needs to be the same as $a="9.22337203685478e+18"; $a++
5899 /* sv_2iv *should* have made this an NV */
5900 if (flags & SVp_NOK) {
5901 (void)SvNOK_only(sv);
5905 /* I don't think we can get here. Maybe I should assert this
5906 And if we do get here I suspect that sv_setnv will croak. NWC
5908 #if defined(USE_LONG_DOUBLE)
5909 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",
5910 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5912 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5913 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5916 #endif /* PERL_PRESERVE_IVUV */
5917 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5921 while (d >= SvPVX(sv)) {
5929 /* MKS: The original code here died if letters weren't consecutive.
5930 * at least it didn't have to worry about non-C locales. The
5931 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5932 * arranged in order (although not consecutively) and that only
5933 * [A-Za-z] are accepted by isALPHA in the C locale.
5935 if (*d != 'z' && *d != 'Z') {
5936 do { ++*d; } while (!isALPHA(*d));
5939 *(d--) -= 'z' - 'a';
5944 *(d--) -= 'z' - 'a' + 1;
5948 /* oh,oh, the number grew */
5949 SvGROW(sv, SvCUR(sv) + 2);
5951 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5962 Auto-decrement of the value in the SV, doing string to numeric conversion
5963 if necessary. Handles 'get' magic.
5969 Perl_sv_dec(pTHX_ register SV *sv)
5977 if (SvTHINKFIRST(sv)) {
5978 if (SvREADONLY(sv)) {
5979 if (PL_curcop != &PL_compiling)
5980 Perl_croak(aTHX_ PL_no_modify);
5984 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5986 i = PTR2IV(SvRV(sv));
5991 /* Unlike sv_inc we don't have to worry about string-never-numbers
5992 and keeping them magic. But we mustn't warn on punting */
5993 flags = SvFLAGS(sv);
5994 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5995 /* It's publicly an integer, or privately an integer-not-float */
5996 #ifdef PERL_PRESERVE_IVUV
6000 if (SvUVX(sv) == 0) {
6001 (void)SvIOK_only(sv);
6005 (void)SvIOK_only_UV(sv);
6009 if (SvIVX(sv) == IV_MIN)
6010 sv_setnv(sv, (NV)IV_MIN - 1.0);
6012 (void)SvIOK_only(sv);
6018 if (flags & SVp_NOK) {
6020 (void)SvNOK_only(sv);
6023 if (!(flags & SVp_POK)) {
6024 if ((flags & SVTYPEMASK) < SVt_PVNV)
6025 sv_upgrade(sv, SVt_NV);
6027 (void)SvNOK_only(sv);
6030 #ifdef PERL_PRESERVE_IVUV
6032 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6033 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6034 /* Need to try really hard to see if it's an integer.
6035 9.22337203685478e+18 is an integer.
6036 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6037 so $a="9.22337203685478e+18"; $a+0; $a--
6038 needs to be the same as $a="9.22337203685478e+18"; $a--
6045 /* sv_2iv *should* have made this an NV */
6046 if (flags & SVp_NOK) {
6047 (void)SvNOK_only(sv);
6051 /* I don't think we can get here. Maybe I should assert this
6052 And if we do get here I suspect that sv_setnv will croak. NWC
6054 #if defined(USE_LONG_DOUBLE)
6055 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",
6056 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6058 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6059 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6063 #endif /* PERL_PRESERVE_IVUV */
6064 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6068 =for apidoc sv_mortalcopy
6070 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6071 The new SV is marked as mortal. It will be destroyed "soon", either by an
6072 explicit call to FREETMPS, or by an implicit call at places such as
6073 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6078 /* Make a string that will exist for the duration of the expression
6079 * evaluation. Actually, it may have to last longer than that, but
6080 * hopefully we won't free it until it has been assigned to a
6081 * permanent location. */
6084 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6089 sv_setsv(sv,oldstr);
6091 PL_tmps_stack[++PL_tmps_ix] = sv;
6097 =for apidoc sv_newmortal
6099 Creates a new null SV which is mortal. The reference count of the SV is
6100 set to 1. It will be destroyed "soon", either by an explicit call to
6101 FREETMPS, or by an implicit call at places such as statement boundaries.
6102 See also C<sv_mortalcopy> and C<sv_2mortal>.
6108 Perl_sv_newmortal(pTHX)
6113 SvFLAGS(sv) = SVs_TEMP;
6115 PL_tmps_stack[++PL_tmps_ix] = sv;
6120 =for apidoc sv_2mortal
6122 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6123 by an explicit call to FREETMPS, or by an implicit call at places such as
6124 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6130 Perl_sv_2mortal(pTHX_ register SV *sv)
6134 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6137 PL_tmps_stack[++PL_tmps_ix] = sv;
6145 Creates a new SV and copies a string into it. The reference count for the
6146 SV is set to 1. If C<len> is zero, Perl will compute the length using
6147 strlen(). For efficiency, consider using C<newSVpvn> instead.
6153 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6160 sv_setpvn(sv,s,len);
6165 =for apidoc newSVpvn
6167 Creates a new SV and copies a string into it. The reference count for the
6168 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6169 string. You are responsible for ensuring that the source string is at least
6176 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6181 sv_setpvn(sv,s,len);
6186 =for apidoc newSVpvn_share
6188 Creates a new SV with its SvPVX pointing to a shared string in the string
6189 table. If the string does not already exist in the table, it is created
6190 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6191 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6192 otherwise the hash is computed. The idea here is that as the string table
6193 is used for shared hash keys these strings will have SvPVX == HeKEY and
6194 hash lookup will avoid string compare.
6200 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6203 bool is_utf8 = FALSE;
6205 STRLEN tmplen = -len;
6207 /* See the note in hv.c:hv_fetch() --jhi */
6208 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6212 PERL_HASH(hash, src, len);
6214 sv_upgrade(sv, SVt_PVIV);
6215 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6228 #if defined(PERL_IMPLICIT_CONTEXT)
6230 /* pTHX_ magic can't cope with varargs, so this is a no-context
6231 * version of the main function, (which may itself be aliased to us).
6232 * Don't access this version directly.
6236 Perl_newSVpvf_nocontext(const char* pat, ...)
6241 va_start(args, pat);
6242 sv = vnewSVpvf(pat, &args);
6249 =for apidoc newSVpvf
6251 Creates a new SV and initializes it with the string formatted like
6258 Perl_newSVpvf(pTHX_ const char* pat, ...)
6262 va_start(args, pat);
6263 sv = vnewSVpvf(pat, &args);
6268 /* backend for newSVpvf() and newSVpvf_nocontext() */
6271 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6275 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6282 Creates a new SV and copies a floating point value into it.
6283 The reference count for the SV is set to 1.
6289 Perl_newSVnv(pTHX_ NV n)
6301 Creates a new SV and copies an integer into it. The reference count for the
6308 Perl_newSViv(pTHX_ IV i)
6320 Creates a new SV and copies an unsigned integer into it.
6321 The reference count for the SV is set to 1.
6327 Perl_newSVuv(pTHX_ UV u)
6337 =for apidoc newRV_noinc
6339 Creates an RV wrapper for an SV. The reference count for the original
6340 SV is B<not> incremented.
6346 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6351 sv_upgrade(sv, SVt_RV);
6358 /* newRV_inc is the official function name to use now.
6359 * newRV_inc is in fact #defined to newRV in sv.h
6363 Perl_newRV(pTHX_ SV *tmpRef)
6365 return newRV_noinc(SvREFCNT_inc(tmpRef));
6371 Creates a new SV which is an exact duplicate of the original SV.
6378 Perl_newSVsv(pTHX_ register SV *old)
6384 if (SvTYPE(old) == SVTYPEMASK) {
6385 if (ckWARN_d(WARN_INTERNAL))
6386 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6401 =for apidoc sv_reset
6403 Underlying implementation for the C<reset> Perl function.
6404 Note that the perl-level function is vaguely deprecated.
6410 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6418 char todo[PERL_UCHAR_MAX+1];
6423 if (!*s) { /* reset ?? searches */
6424 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6425 pm->op_pmdynflags &= ~PMdf_USED;
6430 /* reset variables */
6432 if (!HvARRAY(stash))
6435 Zero(todo, 256, char);
6437 i = (unsigned char)*s;
6441 max = (unsigned char)*s++;
6442 for ( ; i <= max; i++) {
6445 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6446 for (entry = HvARRAY(stash)[i];
6448 entry = HeNEXT(entry))
6450 if (!todo[(U8)*HeKEY(entry)])
6452 gv = (GV*)HeVAL(entry);
6454 if (SvTHINKFIRST(sv)) {
6455 if (!SvREADONLY(sv) && SvROK(sv))
6460 if (SvTYPE(sv) >= SVt_PV) {
6462 if (SvPVX(sv) != Nullch)
6469 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6471 #ifdef USE_ENVIRON_ARRAY
6473 environ[0] = Nullch;
6484 Using various gambits, try to get an IO from an SV: the IO slot if its a
6485 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6486 named after the PV if we're a string.
6492 Perl_sv_2io(pTHX_ SV *sv)
6498 switch (SvTYPE(sv)) {
6506 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6510 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6512 return sv_2io(SvRV(sv));
6513 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6519 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6528 Using various gambits, try to get a CV from an SV; in addition, try if
6529 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6535 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6542 return *gvp = Nullgv, Nullcv;
6543 switch (SvTYPE(sv)) {
6562 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6563 tryAMAGICunDEREF(to_cv);
6566 if (SvTYPE(sv) == SVt_PVCV) {
6575 Perl_croak(aTHX_ "Not a subroutine reference");
6580 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6586 if (lref && !GvCVu(gv)) {
6589 tmpsv = NEWSV(704,0);
6590 gv_efullname3(tmpsv, gv, Nullch);
6591 /* XXX this is probably not what they think they're getting.
6592 * It has the same effect as "sub name;", i.e. just a forward
6594 newSUB(start_subparse(FALSE, 0),
6595 newSVOP(OP_CONST, 0, tmpsv),
6600 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6609 Returns true if the SV has a true value by Perl's rules.
6610 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6611 instead use an in-line version.
6617 Perl_sv_true(pTHX_ register SV *sv)
6623 if ((tXpv = (XPV*)SvANY(sv)) &&
6624 (tXpv->xpv_cur > 1 ||
6625 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6632 return SvIVX(sv) != 0;
6635 return SvNVX(sv) != 0.0;
6637 return sv_2bool(sv);
6645 A private implementation of the C<SvIVx> macro for compilers which can't
6646 cope with complex macro expressions. Always use the macro instead.
6652 Perl_sv_iv(pTHX_ register SV *sv)
6656 return (IV)SvUVX(sv);
6665 A private implementation of the C<SvUVx> macro for compilers which can't
6666 cope with complex macro expressions. Always use the macro instead.
6672 Perl_sv_uv(pTHX_ register SV *sv)
6677 return (UV)SvIVX(sv);
6685 A private implementation of the C<SvNVx> macro for compilers which can't
6686 cope with complex macro expressions. Always use the macro instead.
6692 Perl_sv_nv(pTHX_ register SV *sv)
6702 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6703 cope with complex macro expressions. Always use the macro instead.
6709 Perl_sv_pv(pTHX_ SV *sv)
6716 return sv_2pv(sv, &n_a);
6722 A private implementation of the C<SvPV> macro for compilers which can't
6723 cope with complex macro expressions. Always use the macro instead.
6729 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6735 return sv_2pv(sv, lp);
6738 /* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
6742 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
6748 return sv_2pv_flags(sv, lp, 0);
6752 =for apidoc sv_pvn_force
6754 Get a sensible string out of the SV somehow.
6755 A private implementation of the C<SvPV_force> macro for compilers which
6756 can't cope with complex macro expressions. Always use the macro instead.
6762 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6764 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6768 =for apidoc sv_pvn_force_flags
6770 Get a sensible string out of the SV somehow.
6771 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6772 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6773 implemented in terms of this function.
6774 You normally want to use the various wrapper macros instead: see
6775 C<SvPV_force> and C<SvPV_force_nomg>
6781 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6785 if (SvTHINKFIRST(sv) && !SvROK(sv))
6786 sv_force_normal(sv);
6792 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6793 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6797 s = sv_2pv_flags(sv, lp, flags);
6798 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6803 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6804 SvGROW(sv, len + 1);
6805 Move(s,SvPVX(sv),len,char);
6810 SvPOK_on(sv); /* validate pointer */
6812 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6813 PTR2UV(sv),SvPVX(sv)));
6820 =for apidoc sv_pvbyte
6822 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6823 which can't cope with complex macro expressions. Always use the macro
6830 Perl_sv_pvbyte(pTHX_ SV *sv)
6832 sv_utf8_downgrade(sv,0);
6837 =for apidoc sv_pvbyten
6839 A private implementation of the C<SvPVbyte> macro for compilers
6840 which can't cope with complex macro expressions. Always use the macro
6847 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6849 sv_utf8_downgrade(sv,0);
6850 return sv_pvn(sv,lp);
6854 =for apidoc sv_pvbyten_force
6856 A private implementation of the C<SvPVbytex_force> macro for compilers
6857 which can't cope with complex macro expressions. Always use the macro
6864 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6866 sv_utf8_downgrade(sv,0);
6867 return sv_pvn_force(sv,lp);
6871 =for apidoc sv_pvutf8
6873 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6874 which can't cope with complex macro expressions. Always use the macro
6881 Perl_sv_pvutf8(pTHX_ SV *sv)
6883 sv_utf8_upgrade(sv);
6888 =for apidoc sv_pvutf8n
6890 A private implementation of the C<SvPVutf8> macro for compilers
6891 which can't cope with complex macro expressions. Always use the macro
6898 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6900 sv_utf8_upgrade(sv);
6901 return sv_pvn(sv,lp);
6905 =for apidoc sv_pvutf8n_force
6907 A private implementation of the C<SvPVutf8_force> macro for compilers
6908 which can't cope with complex macro expressions. Always use the macro
6915 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6917 sv_utf8_upgrade(sv);
6918 return sv_pvn_force(sv,lp);
6922 =for apidoc sv_reftype
6924 Returns a string describing what the SV is a reference to.
6930 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6932 if (ob && SvOBJECT(sv))
6933 return HvNAME(SvSTASH(sv));
6935 switch (SvTYPE(sv)) {
6949 case SVt_PVLV: return "LVALUE";
6950 case SVt_PVAV: return "ARRAY";
6951 case SVt_PVHV: return "HASH";
6952 case SVt_PVCV: return "CODE";
6953 case SVt_PVGV: return "GLOB";
6954 case SVt_PVFM: return "FORMAT";
6955 case SVt_PVIO: return "IO";
6956 default: return "UNKNOWN";
6962 =for apidoc sv_isobject
6964 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6965 object. If the SV is not an RV, or if the object is not blessed, then this
6972 Perl_sv_isobject(pTHX_ SV *sv)
6989 Returns a boolean indicating whether the SV is blessed into the specified
6990 class. This does not check for subtypes; use C<sv_derived_from> to verify
6991 an inheritance relationship.
6997 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7009 return strEQ(HvNAME(SvSTASH(sv)), name);
7015 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7016 it will be upgraded to one. If C<classname> is non-null then the new SV will
7017 be blessed in the specified package. The new SV is returned and its
7018 reference count is 1.
7024 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7030 SV_CHECK_THINKFIRST(rv);
7033 if (SvTYPE(rv) >= SVt_PVMG) {
7034 U32 refcnt = SvREFCNT(rv);
7038 SvREFCNT(rv) = refcnt;
7041 if (SvTYPE(rv) < SVt_RV)
7042 sv_upgrade(rv, SVt_RV);
7043 else if (SvTYPE(rv) > SVt_RV) {
7044 (void)SvOOK_off(rv);
7045 if (SvPVX(rv) && SvLEN(rv))
7046 Safefree(SvPVX(rv));
7056 HV* stash = gv_stashpv(classname, TRUE);
7057 (void)sv_bless(rv, stash);
7063 =for apidoc sv_setref_pv
7065 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7066 argument will be upgraded to an RV. That RV will be modified to point to
7067 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7068 into the SV. The C<classname> argument indicates the package for the
7069 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7070 will be returned and will have a reference count of 1.
7072 Do not use with other Perl types such as HV, AV, SV, CV, because those
7073 objects will become corrupted by the pointer copy process.
7075 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7081 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7084 sv_setsv(rv, &PL_sv_undef);
7088 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7093 =for apidoc sv_setref_iv
7095 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7096 argument will be upgraded to an RV. That RV will be modified to point to
7097 the new SV. The C<classname> argument indicates the package for the
7098 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7099 will be returned and will have a reference count of 1.
7105 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7107 sv_setiv(newSVrv(rv,classname), iv);
7112 =for apidoc sv_setref_uv
7114 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7115 argument will be upgraded to an RV. That RV will be modified to point to
7116 the new SV. The C<classname> argument indicates the package for the
7117 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7118 will be returned and will have a reference count of 1.
7124 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7126 sv_setuv(newSVrv(rv,classname), uv);
7131 =for apidoc sv_setref_nv
7133 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7134 argument will be upgraded to an RV. That RV will be modified to point to
7135 the new SV. The C<classname> argument indicates the package for the
7136 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7137 will be returned and will have a reference count of 1.
7143 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7145 sv_setnv(newSVrv(rv,classname), nv);
7150 =for apidoc sv_setref_pvn
7152 Copies a string into a new SV, optionally blessing the SV. The length of the
7153 string must be specified with C<n>. The C<rv> argument will be upgraded to
7154 an RV. That RV will be modified to point to the new SV. The C<classname>
7155 argument indicates the package for the blessing. Set C<classname> to
7156 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7157 a reference count of 1.
7159 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7165 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7167 sv_setpvn(newSVrv(rv,classname), pv, n);
7172 =for apidoc sv_bless
7174 Blesses an SV into a specified package. The SV must be an RV. The package
7175 must be designated by its stash (see C<gv_stashpv()>). The reference count
7176 of the SV is unaffected.
7182 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7186 Perl_croak(aTHX_ "Can't bless non-reference value");
7188 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7189 if (SvREADONLY(tmpRef))
7190 Perl_croak(aTHX_ PL_no_modify);
7191 if (SvOBJECT(tmpRef)) {
7192 if (SvTYPE(tmpRef) != SVt_PVIO)
7194 SvREFCNT_dec(SvSTASH(tmpRef));
7197 SvOBJECT_on(tmpRef);
7198 if (SvTYPE(tmpRef) != SVt_PVIO)
7200 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7201 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7211 /* Downgrades a PVGV to a PVMG.
7213 * XXX This function doesn't actually appear to be used anywhere
7218 S_sv_unglob(pTHX_ SV *sv)
7222 assert(SvTYPE(sv) == SVt_PVGV);
7227 SvREFCNT_dec(GvSTASH(sv));
7228 GvSTASH(sv) = Nullhv;
7230 sv_unmagic(sv, PERL_MAGIC_glob);
7231 Safefree(GvNAME(sv));
7234 /* need to keep SvANY(sv) in the right arena */
7235 xpvmg = new_XPVMG();
7236 StructCopy(SvANY(sv), xpvmg, XPVMG);
7237 del_XPVGV(SvANY(sv));
7240 SvFLAGS(sv) &= ~SVTYPEMASK;
7241 SvFLAGS(sv) |= SVt_PVMG;
7245 =for apidoc sv_unref_flags
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>. The C<cflags> argument can contain
7250 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7251 (otherwise the decrementing is conditional on the reference count being
7252 different from one or the reference being a readonly SV).
7259 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7263 if (SvWEAKREF(sv)) {
7271 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7273 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7274 sv_2mortal(rv); /* Schedule for freeing later */
7278 =for apidoc sv_unref
7280 Unsets the RV status of the SV, and decrements the reference count of
7281 whatever was being referenced by the RV. This can almost be thought of
7282 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7283 being zero. See C<SvROK_off>.
7289 Perl_sv_unref(pTHX_ SV *sv)
7291 sv_unref_flags(sv, 0);
7295 =for apidoc sv_taint
7297 Taint an SV. Use C<SvTAINTED_on> instead.
7302 Perl_sv_taint(pTHX_ SV *sv)
7304 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7308 =for apidoc sv_untaint
7310 Untaint an SV. Use C<SvTAINTED_off> instead.
7315 Perl_sv_untaint(pTHX_ SV *sv)
7317 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7318 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7325 =for apidoc sv_tainted
7327 Test an SV for taintedness. Use C<SvTAINTED> instead.
7332 Perl_sv_tainted(pTHX_ SV *sv)
7334 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7335 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7336 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7343 =for apidoc sv_setpviv
7345 Copies an integer into the given SV, also updating its string value.
7346 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7352 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7354 char buf[TYPE_CHARS(UV)];
7356 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7358 sv_setpvn(sv, ptr, ebuf - ptr);
7362 =for apidoc sv_setpviv_mg
7364 Like C<sv_setpviv>, but also handles 'set' magic.
7370 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7372 char buf[TYPE_CHARS(UV)];
7374 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7376 sv_setpvn(sv, ptr, ebuf - ptr);
7380 #if defined(PERL_IMPLICIT_CONTEXT)
7382 /* pTHX_ magic can't cope with varargs, so this is a no-context
7383 * version of the main function, (which may itself be aliased to us).
7384 * Don't access this version directly.
7388 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7392 va_start(args, pat);
7393 sv_vsetpvf(sv, pat, &args);
7397 /* pTHX_ magic can't cope with varargs, so this is a no-context
7398 * version of the main function, (which may itself be aliased to us).
7399 * Don't access this version directly.
7403 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7407 va_start(args, pat);
7408 sv_vsetpvf_mg(sv, pat, &args);
7414 =for apidoc sv_setpvf
7416 Processes its arguments like C<sprintf> and sets an SV to the formatted
7417 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7423 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7426 va_start(args, pat);
7427 sv_vsetpvf(sv, pat, &args);
7431 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7434 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7436 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7440 =for apidoc sv_setpvf_mg
7442 Like C<sv_setpvf>, but also handles 'set' magic.
7448 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7451 va_start(args, pat);
7452 sv_vsetpvf_mg(sv, pat, &args);
7456 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7459 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7461 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7465 #if defined(PERL_IMPLICIT_CONTEXT)
7467 /* pTHX_ magic can't cope with varargs, so this is a no-context
7468 * version of the main function, (which may itself be aliased to us).
7469 * Don't access this version directly.
7473 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7477 va_start(args, pat);
7478 sv_vcatpvf(sv, pat, &args);
7482 /* pTHX_ magic can't cope with varargs, so this is a no-context
7483 * version of the main function, (which may itself be aliased to us).
7484 * Don't access this version directly.
7488 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7492 va_start(args, pat);
7493 sv_vcatpvf_mg(sv, pat, &args);
7499 =for apidoc sv_catpvf
7501 Processes its arguments like C<sprintf> and appends the formatted
7502 output to an SV. If the appended data contains "wide" characters
7503 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7504 and characters >255 formatted with %c), the original SV might get
7505 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7506 C<SvSETMAGIC()> must typically be called after calling this function
7507 to handle 'set' magic.
7512 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7515 va_start(args, pat);
7516 sv_vcatpvf(sv, pat, &args);
7520 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7523 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7525 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7529 =for apidoc sv_catpvf_mg
7531 Like C<sv_catpvf>, but also handles 'set' magic.
7537 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7540 va_start(args, pat);
7541 sv_vcatpvf_mg(sv, pat, &args);
7545 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7548 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7550 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7555 =for apidoc sv_vsetpvfn
7557 Works like C<vcatpvfn> but copies the text into the SV instead of
7560 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7566 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7568 sv_setpvn(sv, "", 0);
7569 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7572 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7575 S_expect_number(pTHX_ char** pattern)
7578 switch (**pattern) {
7579 case '1': case '2': case '3':
7580 case '4': case '5': case '6':
7581 case '7': case '8': case '9':
7582 while (isDIGIT(**pattern))
7583 var = var * 10 + (*(*pattern)++ - '0');
7587 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7590 =for apidoc sv_vcatpvfn
7592 Processes its arguments like C<vsprintf> and appends the formatted output
7593 to an SV. Uses an array of SVs if the C style variable argument list is
7594 missing (NULL). When running with taint checks enabled, indicates via
7595 C<maybe_tainted> if results are untrustworthy (often due to the use of
7598 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7604 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7611 static char nullstr[] = "(null)";
7614 /* no matter what, this is a string now */
7615 (void)SvPV_force(sv, origlen);
7617 /* special-case "", "%s", and "%_" */
7620 if (patlen == 2 && pat[0] == '%') {
7624 char *s = va_arg(*args, char*);
7625 sv_catpv(sv, s ? s : nullstr);
7627 else if (svix < svmax) {
7628 sv_catsv(sv, *svargs);
7629 if (DO_UTF8(*svargs))
7635 argsv = va_arg(*args, SV*);
7636 sv_catsv(sv, argsv);
7641 /* See comment on '_' below */
7646 patend = (char*)pat + patlen;
7647 for (p = (char*)pat; p < patend; p = q) {
7650 bool vectorize = FALSE;
7651 bool vectorarg = FALSE;
7652 bool vec_utf = FALSE;
7658 bool has_precis = FALSE;
7660 bool is_utf = FALSE;
7663 U8 utf8buf[UTF8_MAXLEN+1];
7664 STRLEN esignlen = 0;
7666 char *eptr = Nullch;
7668 /* Times 4: a decimal digit takes more than 3 binary digits.
7669 * NV_DIG: mantissa takes than many decimal digits.
7670 * Plus 32: Playing safe. */
7671 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7672 /* large enough for "%#.#f" --chip */
7673 /* what about long double NVs? --jhi */
7676 U8 *vecstr = Null(U8*);
7688 STRLEN dotstrlen = 1;
7689 I32 efix = 0; /* explicit format parameter index */
7690 I32 ewix = 0; /* explicit width index */
7691 I32 epix = 0; /* explicit precision index */
7692 I32 evix = 0; /* explicit vector index */
7693 bool asterisk = FALSE;
7695 /* echo everything up to the next format specification */
7696 for (q = p; q < patend && *q != '%'; ++q) ;
7698 sv_catpvn(sv, p, q - p);
7705 We allow format specification elements in this order:
7706 \d+\$ explicit format parameter index
7708 \*?(\d+\$)?v vector with optional (optionally specified) arg
7709 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7710 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7712 [%bcdefginopsux_DFOUX] format (mandatory)
7714 if (EXPECT_NUMBER(q, width)) {
7755 if (EXPECT_NUMBER(q, ewix))
7764 if ((vectorarg = asterisk)) {
7774 EXPECT_NUMBER(q, width);
7779 vecsv = va_arg(*args, SV*);
7781 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7782 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7783 dotstr = SvPVx(vecsv, dotstrlen);
7788 vecsv = va_arg(*args, SV*);
7789 vecstr = (U8*)SvPVx(vecsv,veclen);
7790 vec_utf = DO_UTF8(vecsv);
7792 else if (efix ? efix <= svmax : svix < svmax) {
7793 vecsv = svargs[efix ? efix-1 : svix++];
7794 vecstr = (U8*)SvPVx(vecsv,veclen);
7795 vec_utf = DO_UTF8(vecsv);
7805 i = va_arg(*args, int);
7807 i = (ewix ? ewix <= svmax : svix < svmax) ?
7808 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7810 width = (i < 0) ? -i : i;
7820 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7823 i = va_arg(*args, int);
7825 i = (ewix ? ewix <= svmax : svix < svmax)
7826 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7827 precis = (i < 0) ? 0 : i;
7832 precis = precis * 10 + (*q++ - '0');
7840 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7851 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7852 if (*(q + 1) == 'l') { /* lld, llf */
7875 argsv = (efix ? efix <= svmax : svix < svmax) ?
7876 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7883 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7885 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7887 eptr = (char*)utf8buf;
7888 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7900 eptr = va_arg(*args, char*);
7902 #ifdef MACOS_TRADITIONAL
7903 /* On MacOS, %#s format is used for Pascal strings */
7908 elen = strlen(eptr);
7911 elen = sizeof nullstr - 1;
7915 eptr = SvPVx(argsv, elen);
7916 if (DO_UTF8(argsv)) {
7917 if (has_precis && precis < elen) {
7919 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7922 if (width) { /* fudge width (can't fudge elen) */
7923 width += elen - sv_len_utf8(argsv);
7932 * The "%_" hack might have to be changed someday,
7933 * if ISO or ANSI decide to use '_' for something.
7934 * So we keep it hidden from users' code.
7938 argsv = va_arg(*args, SV*);
7939 eptr = SvPVx(argsv, elen);
7945 if (has_precis && elen > precis)
7954 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7972 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
7980 esignbuf[esignlen++] = plus;
7984 case 'h': iv = (short)va_arg(*args, int); break;
7985 default: iv = va_arg(*args, int); break;
7986 case 'l': iv = va_arg(*args, long); break;
7987 case 'V': iv = va_arg(*args, IV); break;
7989 case 'q': iv = va_arg(*args, Quad_t); break;
7996 case 'h': iv = (short)iv; break;
7998 case 'l': iv = (long)iv; break;
8001 case 'q': iv = (Quad_t)iv; break;
8005 if ( !vectorize ) /* we already set uv above */
8010 esignbuf[esignlen++] = plus;
8014 esignbuf[esignlen++] = '-';
8057 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8067 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8068 default: uv = va_arg(*args, unsigned); break;
8069 case 'l': uv = va_arg(*args, unsigned long); break;
8070 case 'V': uv = va_arg(*args, UV); break;
8072 case 'q': uv = va_arg(*args, Quad_t); break;
8079 case 'h': uv = (unsigned short)uv; break;
8081 case 'l': uv = (unsigned long)uv; break;
8084 case 'q': uv = (Quad_t)uv; break;
8090 eptr = ebuf + sizeof ebuf;
8096 p = (char*)((c == 'X')
8097 ? "0123456789ABCDEF" : "0123456789abcdef");
8103 esignbuf[esignlen++] = '0';
8104 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8110 *--eptr = '0' + dig;
8112 if (alt && *eptr != '0')
8118 *--eptr = '0' + dig;
8121 esignbuf[esignlen++] = '0';
8122 esignbuf[esignlen++] = 'b';
8125 default: /* it had better be ten or less */
8126 #if defined(PERL_Y2KWARN)
8127 if (ckWARN(WARN_Y2K)) {
8129 char *s = SvPV(sv,n);
8130 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8131 && (n == 2 || !isDIGIT(s[n-3])))
8133 Perl_warner(aTHX_ WARN_Y2K,
8134 "Possible Y2K bug: %%%c %s",
8135 c, "format string following '19'");
8141 *--eptr = '0' + dig;
8142 } while (uv /= base);
8145 elen = (ebuf + sizeof ebuf) - eptr;
8148 zeros = precis - elen;
8149 else if (precis == 0 && elen == 1 && *eptr == '0')
8154 /* FLOATING POINT */
8157 c = 'f'; /* maybe %F isn't supported here */
8163 /* This is evil, but floating point is even more evil */
8166 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8169 if (c != 'e' && c != 'E') {
8171 (void)Perl_frexp(nv, &i);
8172 if (i == PERL_INT_MIN)
8173 Perl_die(aTHX_ "panic: frexp");
8175 need = BIT_DIGITS(i);
8177 need += has_precis ? precis : 6; /* known default */
8181 need += 20; /* fudge factor */
8182 if (PL_efloatsize < need) {
8183 Safefree(PL_efloatbuf);
8184 PL_efloatsize = need + 20; /* more fudge */
8185 New(906, PL_efloatbuf, PL_efloatsize, char);
8186 PL_efloatbuf[0] = '\0';
8189 eptr = ebuf + sizeof ebuf;
8192 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8194 /* Copy the one or more characters in a long double
8195 * format before the 'base' ([efgEFG]) character to
8196 * the format string. */
8197 static char const prifldbl[] = PERL_PRIfldbl;
8198 char const *p = prifldbl + sizeof(prifldbl) - 3;
8199 while (p >= prifldbl) { *--eptr = *p--; }
8204 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8209 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8221 /* No taint. Otherwise we are in the strange situation
8222 * where printf() taints but print($float) doesn't.
8224 (void)sprintf(PL_efloatbuf, eptr, nv);
8226 eptr = PL_efloatbuf;
8227 elen = strlen(PL_efloatbuf);
8234 i = SvCUR(sv) - origlen;
8237 case 'h': *(va_arg(*args, short*)) = i; break;
8238 default: *(va_arg(*args, int*)) = i; break;
8239 case 'l': *(va_arg(*args, long*)) = i; break;
8240 case 'V': *(va_arg(*args, IV*)) = i; break;
8242 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8247 sv_setuv_mg(argsv, (UV)i);
8248 continue; /* not "break" */
8255 if (!args && ckWARN(WARN_PRINTF) &&
8256 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8257 SV *msg = sv_newmortal();
8258 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8259 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8262 Perl_sv_catpvf(aTHX_ msg,
8263 "\"%%%c\"", c & 0xFF);
8265 Perl_sv_catpvf(aTHX_ msg,
8266 "\"%%\\%03"UVof"\"",
8269 sv_catpv(msg, "end of string");
8270 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8273 /* output mangled stuff ... */
8279 /* ... right here, because formatting flags should not apply */
8280 SvGROW(sv, SvCUR(sv) + elen + 1);
8282 Copy(eptr, p, elen, char);
8285 SvCUR(sv) = p - SvPVX(sv);
8286 continue; /* not "break" */
8289 have = esignlen + zeros + elen;
8290 need = (have > width ? have : width);
8293 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8295 if (esignlen && fill == '0') {
8296 for (i = 0; i < esignlen; i++)
8300 memset(p, fill, gap);
8303 if (esignlen && fill != '0') {
8304 for (i = 0; i < esignlen; i++)
8308 for (i = zeros; i; i--)
8312 Copy(eptr, p, elen, char);
8316 memset(p, ' ', gap);
8321 Copy(dotstr, p, dotstrlen, char);
8325 vectorize = FALSE; /* done iterating over vecstr */
8330 SvCUR(sv) = p - SvPVX(sv);
8338 /* =========================================================================
8340 =head1 Cloning an interpreter
8342 All the macros and functions in this section are for the private use of
8343 the main function, perl_clone().
8345 The foo_dup() functions make an exact copy of an existing foo thinngy.
8346 During the course of a cloning, a hash table is used to map old addresses
8347 to new addresses. The table is created and manipulated with the
8348 ptr_table_* functions.
8352 ============================================================================*/
8355 #if defined(USE_ITHREADS)
8357 #if defined(USE_5005THREADS)
8358 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8361 #ifndef GpREFCNT_inc
8362 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8366 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8367 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8368 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8369 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8370 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8371 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8372 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8373 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8374 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8375 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8376 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8377 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8378 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8381 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8382 regcomp.c. AMS 20010712 */
8385 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8389 struct reg_substr_datum *s;
8392 return (REGEXP *)NULL;
8394 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8397 len = r->offsets[0];
8398 npar = r->nparens+1;
8400 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8401 Copy(r->program, ret->program, len+1, regnode);
8403 New(0, ret->startp, npar, I32);
8404 Copy(r->startp, ret->startp, npar, I32);
8405 New(0, ret->endp, npar, I32);
8406 Copy(r->startp, ret->startp, npar, I32);
8408 New(0, ret->substrs, 1, struct reg_substr_data);
8409 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8410 s->min_offset = r->substrs->data[i].min_offset;
8411 s->max_offset = r->substrs->data[i].max_offset;
8412 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8415 ret->regstclass = NULL;
8418 int count = r->data->count;
8420 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8421 char, struct reg_data);
8422 New(0, d->what, count, U8);
8425 for (i = 0; i < count; i++) {
8426 d->what[i] = r->data->what[i];
8427 switch (d->what[i]) {
8429 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8432 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8435 /* This is cheating. */
8436 New(0, d->data[i], 1, struct regnode_charclass_class);
8437 StructCopy(r->data->data[i], d->data[i],
8438 struct regnode_charclass_class);
8439 ret->regstclass = (regnode*)d->data[i];
8442 /* Compiled op trees are readonly, and can thus be
8443 shared without duplication. */
8444 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8447 d->data[i] = r->data->data[i];
8457 New(0, ret->offsets, 2*len+1, U32);
8458 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8460 ret->precomp = SAVEPV(r->precomp);
8461 ret->refcnt = r->refcnt;
8462 ret->minlen = r->minlen;
8463 ret->prelen = r->prelen;
8464 ret->nparens = r->nparens;
8465 ret->lastparen = r->lastparen;
8466 ret->lastcloseparen = r->lastcloseparen;
8467 ret->reganch = r->reganch;
8469 ret->sublen = r->sublen;
8471 if (RX_MATCH_COPIED(ret))
8472 ret->subbeg = SAVEPV(r->subbeg);
8474 ret->subbeg = Nullch;
8476 ptr_table_store(PL_ptr_table, r, ret);
8480 /* duplicate a file handle */
8483 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8487 return (PerlIO*)NULL;
8489 /* look for it in the table first */
8490 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8494 /* create anew and remember what it is */
8495 ret = PerlIO_fdupopen(aTHX_ fp, param);
8496 ptr_table_store(PL_ptr_table, fp, ret);
8500 /* duplicate a directory handle */
8503 Perl_dirp_dup(pTHX_ DIR *dp)
8511 /* duplicate a typeglob */
8514 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8519 /* look for it in the table first */
8520 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8524 /* create anew and remember what it is */
8525 Newz(0, ret, 1, GP);
8526 ptr_table_store(PL_ptr_table, gp, ret);
8529 ret->gp_refcnt = 0; /* must be before any other dups! */
8530 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8531 ret->gp_io = io_dup_inc(gp->gp_io, param);
8532 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8533 ret->gp_av = av_dup_inc(gp->gp_av, param);
8534 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8535 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8536 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8537 ret->gp_cvgen = gp->gp_cvgen;
8538 ret->gp_flags = gp->gp_flags;
8539 ret->gp_line = gp->gp_line;
8540 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8544 /* duplicate a chain of magic */
8547 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8549 MAGIC *mgprev = (MAGIC*)NULL;
8552 return (MAGIC*)NULL;
8553 /* look for it in the table first */
8554 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8558 for (; mg; mg = mg->mg_moremagic) {
8560 Newz(0, nmg, 1, MAGIC);
8562 mgprev->mg_moremagic = nmg;
8565 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8566 nmg->mg_private = mg->mg_private;
8567 nmg->mg_type = mg->mg_type;
8568 nmg->mg_flags = mg->mg_flags;
8569 if (mg->mg_type == PERL_MAGIC_qr) {
8570 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8572 else if(mg->mg_type == PERL_MAGIC_backref) {
8573 AV *av = (AV*) mg->mg_obj;
8576 nmg->mg_obj = (SV*)newAV();
8580 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8585 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8586 ? sv_dup_inc(mg->mg_obj, param)
8587 : sv_dup(mg->mg_obj, param);
8589 nmg->mg_len = mg->mg_len;
8590 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8591 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8592 if (mg->mg_len >= 0) {
8593 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8594 if (mg->mg_type == PERL_MAGIC_overload_table &&
8595 AMT_AMAGIC((AMT*)mg->mg_ptr))
8597 AMT *amtp = (AMT*)mg->mg_ptr;
8598 AMT *namtp = (AMT*)nmg->mg_ptr;
8600 for (i = 1; i < NofAMmeth; i++) {
8601 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8605 else if (mg->mg_len == HEf_SVKEY)
8606 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8613 /* create a new pointer-mapping table */
8616 Perl_ptr_table_new(pTHX)
8619 Newz(0, tbl, 1, PTR_TBL_t);
8622 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8626 /* map an existing pointer using a table */
8629 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8631 PTR_TBL_ENT_t *tblent;
8632 UV hash = PTR2UV(sv);
8634 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8635 for (; tblent; tblent = tblent->next) {
8636 if (tblent->oldval == sv)
8637 return tblent->newval;
8642 /* add a new entry to a pointer-mapping table */
8645 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8647 PTR_TBL_ENT_t *tblent, **otblent;
8648 /* XXX this may be pessimal on platforms where pointers aren't good
8649 * hash values e.g. if they grow faster in the most significant
8651 UV hash = PTR2UV(oldv);
8655 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8656 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8657 if (tblent->oldval == oldv) {
8658 tblent->newval = newv;
8663 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8664 tblent->oldval = oldv;
8665 tblent->newval = newv;
8666 tblent->next = *otblent;
8669 if (i && tbl->tbl_items > tbl->tbl_max)
8670 ptr_table_split(tbl);
8673 /* double the hash bucket size of an existing ptr table */
8676 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8678 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8679 UV oldsize = tbl->tbl_max + 1;
8680 UV newsize = oldsize * 2;
8683 Renew(ary, newsize, PTR_TBL_ENT_t*);
8684 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8685 tbl->tbl_max = --newsize;
8687 for (i=0; i < oldsize; i++, ary++) {
8688 PTR_TBL_ENT_t **curentp, **entp, *ent;
8691 curentp = ary + oldsize;
8692 for (entp = ary, ent = *ary; ent; ent = *entp) {
8693 if ((newsize & PTR2UV(ent->oldval)) != i) {
8695 ent->next = *curentp;
8705 /* remove all the entries from a ptr table */
8708 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8710 register PTR_TBL_ENT_t **array;
8711 register PTR_TBL_ENT_t *entry;
8712 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8716 if (!tbl || !tbl->tbl_items) {
8720 array = tbl->tbl_ary;
8727 entry = entry->next;
8731 if (++riter > max) {
8734 entry = array[riter];
8741 /* clear and free a ptr table */
8744 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8749 ptr_table_clear(tbl);
8750 Safefree(tbl->tbl_ary);
8758 /* attempt to make everything in the typeglob readonly */
8761 S_gv_share(pTHX_ SV *sstr)
8764 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8766 if (GvIO(gv) || GvFORM(gv)) {
8767 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8769 else if (!GvCV(gv)) {
8773 /* CvPADLISTs cannot be shared */
8774 if (!CvXSUB(GvCV(gv))) {
8779 if (!GvUNIQUE(gv)) {
8781 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8782 HvNAME(GvSTASH(gv)), GvNAME(gv));
8788 * write attempts will die with
8789 * "Modification of a read-only value attempted"
8795 SvREADONLY_on(GvSV(gv));
8802 SvREADONLY_on(GvAV(gv));
8809 SvREADONLY_on(GvAV(gv));
8812 return sstr; /* he_dup() will SvREFCNT_inc() */
8815 /* duplicate an SV of any type (including AV, HV etc) */
8818 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
8822 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8824 /* look for it in the table first */
8825 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8829 /* create anew and remember what it is */
8831 ptr_table_store(PL_ptr_table, sstr, dstr);
8834 SvFLAGS(dstr) = SvFLAGS(sstr);
8835 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8836 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8839 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8840 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8841 PL_watch_pvx, SvPVX(sstr));
8844 switch (SvTYPE(sstr)) {
8849 SvANY(dstr) = new_XIV();
8850 SvIVX(dstr) = SvIVX(sstr);
8853 SvANY(dstr) = new_XNV();
8854 SvNVX(dstr) = SvNVX(sstr);
8857 SvANY(dstr) = new_XRV();
8858 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8859 ? sv_dup(SvRV(sstr), param)
8860 : sv_dup_inc(SvRV(sstr), param);
8863 SvANY(dstr) = new_XPV();
8864 SvCUR(dstr) = SvCUR(sstr);
8865 SvLEN(dstr) = SvLEN(sstr);
8867 SvRV(dstr) = SvWEAKREF(sstr)
8868 ? sv_dup(SvRV(sstr), param)
8869 : sv_dup_inc(SvRV(sstr), param);
8870 else if (SvPVX(sstr) && SvLEN(sstr))
8871 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8873 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8876 SvANY(dstr) = new_XPVIV();
8877 SvCUR(dstr) = SvCUR(sstr);
8878 SvLEN(dstr) = SvLEN(sstr);
8879 SvIVX(dstr) = SvIVX(sstr);
8881 SvRV(dstr) = SvWEAKREF(sstr)
8882 ? sv_dup(SvRV(sstr), param)
8883 : sv_dup_inc(SvRV(sstr), param);
8884 else if (SvPVX(sstr) && SvLEN(sstr))
8885 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8887 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8890 SvANY(dstr) = new_XPVNV();
8891 SvCUR(dstr) = SvCUR(sstr);
8892 SvLEN(dstr) = SvLEN(sstr);
8893 SvIVX(dstr) = SvIVX(sstr);
8894 SvNVX(dstr) = SvNVX(sstr);
8896 SvRV(dstr) = SvWEAKREF(sstr)
8897 ? sv_dup(SvRV(sstr), param)
8898 : sv_dup_inc(SvRV(sstr), param);
8899 else if (SvPVX(sstr) && SvLEN(sstr))
8900 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8902 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8905 SvANY(dstr) = new_XPVMG();
8906 SvCUR(dstr) = SvCUR(sstr);
8907 SvLEN(dstr) = SvLEN(sstr);
8908 SvIVX(dstr) = SvIVX(sstr);
8909 SvNVX(dstr) = SvNVX(sstr);
8910 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8911 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8913 SvRV(dstr) = SvWEAKREF(sstr)
8914 ? sv_dup(SvRV(sstr), param)
8915 : sv_dup_inc(SvRV(sstr), param);
8916 else if (SvPVX(sstr) && SvLEN(sstr))
8917 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8919 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8922 SvANY(dstr) = new_XPVBM();
8923 SvCUR(dstr) = SvCUR(sstr);
8924 SvLEN(dstr) = SvLEN(sstr);
8925 SvIVX(dstr) = SvIVX(sstr);
8926 SvNVX(dstr) = SvNVX(sstr);
8927 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8928 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8930 SvRV(dstr) = SvWEAKREF(sstr)
8931 ? sv_dup(SvRV(sstr), param)
8932 : sv_dup_inc(SvRV(sstr), param);
8933 else if (SvPVX(sstr) && SvLEN(sstr))
8934 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8936 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8937 BmRARE(dstr) = BmRARE(sstr);
8938 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8939 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8942 SvANY(dstr) = new_XPVLV();
8943 SvCUR(dstr) = SvCUR(sstr);
8944 SvLEN(dstr) = SvLEN(sstr);
8945 SvIVX(dstr) = SvIVX(sstr);
8946 SvNVX(dstr) = SvNVX(sstr);
8947 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8948 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8950 SvRV(dstr) = SvWEAKREF(sstr)
8951 ? sv_dup(SvRV(sstr), param)
8952 : sv_dup_inc(SvRV(sstr), param);
8953 else if (SvPVX(sstr) && SvLEN(sstr))
8954 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8956 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8957 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8958 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8959 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8960 LvTYPE(dstr) = LvTYPE(sstr);
8963 if (GvUNIQUE((GV*)sstr)) {
8965 if ((share = gv_share(sstr))) {
8969 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8970 HvNAME(GvSTASH(share)), GvNAME(share));
8975 SvANY(dstr) = new_XPVGV();
8976 SvCUR(dstr) = SvCUR(sstr);
8977 SvLEN(dstr) = SvLEN(sstr);
8978 SvIVX(dstr) = SvIVX(sstr);
8979 SvNVX(dstr) = SvNVX(sstr);
8980 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8981 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8983 SvRV(dstr) = SvWEAKREF(sstr)
8984 ? sv_dup(SvRV(sstr), param)
8985 : sv_dup_inc(SvRV(sstr), param);
8986 else if (SvPVX(sstr) && SvLEN(sstr))
8987 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8989 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8990 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8991 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8992 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
8993 GvFLAGS(dstr) = GvFLAGS(sstr);
8994 GvGP(dstr) = gp_dup(GvGP(sstr), param);
8995 (void)GpREFCNT_inc(GvGP(dstr));
8998 SvANY(dstr) = new_XPVIO();
8999 SvCUR(dstr) = SvCUR(sstr);
9000 SvLEN(dstr) = SvLEN(sstr);
9001 SvIVX(dstr) = SvIVX(sstr);
9002 SvNVX(dstr) = SvNVX(sstr);
9003 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9004 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9006 SvRV(dstr) = SvWEAKREF(sstr)
9007 ? sv_dup(SvRV(sstr), param)
9008 : sv_dup_inc(SvRV(sstr), param);
9009 else if (SvPVX(sstr) && SvLEN(sstr))
9010 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9012 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9013 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9014 if (IoOFP(sstr) == IoIFP(sstr))
9015 IoOFP(dstr) = IoIFP(dstr);
9017 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9018 /* PL_rsfp_filters entries have fake IoDIRP() */
9019 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9020 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
9022 IoDIRP(dstr) = IoDIRP(sstr);
9023 IoLINES(dstr) = IoLINES(sstr);
9024 IoPAGE(dstr) = IoPAGE(sstr);
9025 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
9026 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
9027 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
9028 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
9029 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
9030 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
9031 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
9032 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
9033 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
9034 IoTYPE(dstr) = IoTYPE(sstr);
9035 IoFLAGS(dstr) = IoFLAGS(sstr);
9038 SvANY(dstr) = new_XPVAV();
9039 SvCUR(dstr) = SvCUR(sstr);
9040 SvLEN(dstr) = SvLEN(sstr);
9041 SvIVX(dstr) = SvIVX(sstr);
9042 SvNVX(dstr) = SvNVX(sstr);
9043 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9044 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9045 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9046 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9047 if (AvARRAY((AV*)sstr)) {
9048 SV **dst_ary, **src_ary;
9049 SSize_t items = AvFILLp((AV*)sstr) + 1;
9051 src_ary = AvARRAY((AV*)sstr);
9052 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9053 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9054 SvPVX(dstr) = (char*)dst_ary;
9055 AvALLOC((AV*)dstr) = dst_ary;
9056 if (AvREAL((AV*)sstr)) {
9058 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9062 *dst_ary++ = sv_dup(*src_ary++, param);
9064 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9065 while (items-- > 0) {
9066 *dst_ary++ = &PL_sv_undef;
9070 SvPVX(dstr) = Nullch;
9071 AvALLOC((AV*)dstr) = (SV**)NULL;
9075 SvANY(dstr) = new_XPVHV();
9076 SvCUR(dstr) = SvCUR(sstr);
9077 SvLEN(dstr) = SvLEN(sstr);
9078 SvIVX(dstr) = SvIVX(sstr);
9079 SvNVX(dstr) = SvNVX(sstr);
9080 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9081 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9082 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9083 if (HvARRAY((HV*)sstr)) {
9085 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9086 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9087 Newz(0, dxhv->xhv_array,
9088 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9089 while (i <= sxhv->xhv_max) {
9090 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9091 !!HvSHAREKEYS(sstr), param);
9094 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9097 SvPVX(dstr) = Nullch;
9098 HvEITER((HV*)dstr) = (HE*)NULL;
9100 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9101 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9102 /* Record stashes for possible cloning in Perl_clone(). */
9103 if(HvNAME((HV*)dstr))
9104 av_push(param->stashes, dstr);
9107 SvANY(dstr) = new_XPVFM();
9108 FmLINES(dstr) = FmLINES(sstr);
9112 SvANY(dstr) = new_XPVCV();
9114 SvCUR(dstr) = SvCUR(sstr);
9115 SvLEN(dstr) = SvLEN(sstr);
9116 SvIVX(dstr) = SvIVX(sstr);
9117 SvNVX(dstr) = SvNVX(sstr);
9118 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9119 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9120 if (SvPVX(sstr) && SvLEN(sstr))
9121 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9123 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9124 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9125 CvSTART(dstr) = CvSTART(sstr);
9126 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9127 CvXSUB(dstr) = CvXSUB(sstr);
9128 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9129 if (CvCONST(sstr)) {
9130 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9131 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9132 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9134 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9135 if (param->flags & CLONEf_COPY_STACKS) {
9136 CvDEPTH(dstr) = CvDEPTH(sstr);
9140 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9141 /* XXX padlists are real, but pretend to be not */
9142 AvREAL_on(CvPADLIST(sstr));
9143 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9144 AvREAL_off(CvPADLIST(sstr));
9145 AvREAL_off(CvPADLIST(dstr));
9148 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9149 if (!CvANON(sstr) || CvCLONED(sstr))
9150 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9152 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9153 CvFLAGS(dstr) = CvFLAGS(sstr);
9154 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9157 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9161 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9167 /* duplicate a context */
9170 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9175 return (PERL_CONTEXT*)NULL;
9177 /* look for it in the table first */
9178 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9182 /* create anew and remember what it is */
9183 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9184 ptr_table_store(PL_ptr_table, cxs, ncxs);
9187 PERL_CONTEXT *cx = &cxs[ix];
9188 PERL_CONTEXT *ncx = &ncxs[ix];
9189 ncx->cx_type = cx->cx_type;
9190 if (CxTYPE(cx) == CXt_SUBST) {
9191 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9194 ncx->blk_oldsp = cx->blk_oldsp;
9195 ncx->blk_oldcop = cx->blk_oldcop;
9196 ncx->blk_oldretsp = cx->blk_oldretsp;
9197 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9198 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9199 ncx->blk_oldpm = cx->blk_oldpm;
9200 ncx->blk_gimme = cx->blk_gimme;
9201 switch (CxTYPE(cx)) {
9203 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9204 ? cv_dup_inc(cx->blk_sub.cv, param)
9205 : cv_dup(cx->blk_sub.cv,param));
9206 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9207 ? av_dup_inc(cx->blk_sub.argarray, param)
9209 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9210 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9211 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9212 ncx->blk_sub.lval = cx->blk_sub.lval;
9215 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9216 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9217 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9218 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9219 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9222 ncx->blk_loop.label = cx->blk_loop.label;
9223 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9224 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9225 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9226 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9227 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9228 ? cx->blk_loop.iterdata
9229 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9230 ncx->blk_loop.oldcurpad
9231 = (SV**)ptr_table_fetch(PL_ptr_table,
9232 cx->blk_loop.oldcurpad);
9233 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9234 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9235 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9236 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9237 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9240 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9241 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9242 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9243 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9255 /* duplicate a stack info structure */
9258 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9263 return (PERL_SI*)NULL;
9265 /* look for it in the table first */
9266 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9270 /* create anew and remember what it is */
9271 Newz(56, nsi, 1, PERL_SI);
9272 ptr_table_store(PL_ptr_table, si, nsi);
9274 nsi->si_stack = av_dup_inc(si->si_stack, param);
9275 nsi->si_cxix = si->si_cxix;
9276 nsi->si_cxmax = si->si_cxmax;
9277 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9278 nsi->si_type = si->si_type;
9279 nsi->si_prev = si_dup(si->si_prev, param);
9280 nsi->si_next = si_dup(si->si_next, param);
9281 nsi->si_markoff = si->si_markoff;
9286 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9287 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9288 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9289 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9290 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9291 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9292 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9293 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9294 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9295 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9296 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9297 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9300 #define pv_dup_inc(p) SAVEPV(p)
9301 #define pv_dup(p) SAVEPV(p)
9302 #define svp_dup_inc(p,pp) any_dup(p,pp)
9304 /* map any object to the new equivent - either something in the
9305 * ptr table, or something in the interpreter structure
9309 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9316 /* look for it in the table first */
9317 ret = ptr_table_fetch(PL_ptr_table, v);
9321 /* see if it is part of the interpreter structure */
9322 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9323 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9330 /* duplicate the save stack */
9333 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9335 ANY *ss = proto_perl->Tsavestack;
9336 I32 ix = proto_perl->Tsavestack_ix;
9337 I32 max = proto_perl->Tsavestack_max;
9350 void (*dptr) (void*);
9351 void (*dxptr) (pTHX_ void*);
9354 Newz(54, nss, max, ANY);
9360 case SAVEt_ITEM: /* normal string */
9361 sv = (SV*)POPPTR(ss,ix);
9362 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9363 sv = (SV*)POPPTR(ss,ix);
9364 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9366 case SAVEt_SV: /* scalar reference */
9367 sv = (SV*)POPPTR(ss,ix);
9368 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9369 gv = (GV*)POPPTR(ss,ix);
9370 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9372 case SAVEt_GENERIC_PVREF: /* generic char* */
9373 c = (char*)POPPTR(ss,ix);
9374 TOPPTR(nss,ix) = pv_dup(c);
9375 ptr = POPPTR(ss,ix);
9376 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9378 case SAVEt_GENERIC_SVREF: /* generic sv */
9379 case SAVEt_SVREF: /* scalar reference */
9380 sv = (SV*)POPPTR(ss,ix);
9381 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9382 ptr = POPPTR(ss,ix);
9383 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9385 case SAVEt_AV: /* array reference */
9386 av = (AV*)POPPTR(ss,ix);
9387 TOPPTR(nss,ix) = av_dup_inc(av, param);
9388 gv = (GV*)POPPTR(ss,ix);
9389 TOPPTR(nss,ix) = gv_dup(gv, param);
9391 case SAVEt_HV: /* hash reference */
9392 hv = (HV*)POPPTR(ss,ix);
9393 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9394 gv = (GV*)POPPTR(ss,ix);
9395 TOPPTR(nss,ix) = gv_dup(gv, param);
9397 case SAVEt_INT: /* int reference */
9398 ptr = POPPTR(ss,ix);
9399 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9400 intval = (int)POPINT(ss,ix);
9401 TOPINT(nss,ix) = intval;
9403 case SAVEt_LONG: /* long reference */
9404 ptr = POPPTR(ss,ix);
9405 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9406 longval = (long)POPLONG(ss,ix);
9407 TOPLONG(nss,ix) = longval;
9409 case SAVEt_I32: /* I32 reference */
9410 case SAVEt_I16: /* I16 reference */
9411 case SAVEt_I8: /* I8 reference */
9412 ptr = POPPTR(ss,ix);
9413 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9417 case SAVEt_IV: /* IV reference */
9418 ptr = POPPTR(ss,ix);
9419 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9423 case SAVEt_SPTR: /* SV* reference */
9424 ptr = POPPTR(ss,ix);
9425 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9426 sv = (SV*)POPPTR(ss,ix);
9427 TOPPTR(nss,ix) = sv_dup(sv, param);
9429 case SAVEt_VPTR: /* random* reference */
9430 ptr = POPPTR(ss,ix);
9431 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9432 ptr = POPPTR(ss,ix);
9433 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9435 case SAVEt_PPTR: /* char* reference */
9436 ptr = POPPTR(ss,ix);
9437 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9438 c = (char*)POPPTR(ss,ix);
9439 TOPPTR(nss,ix) = pv_dup(c);
9441 case SAVEt_HPTR: /* HV* reference */
9442 ptr = POPPTR(ss,ix);
9443 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9444 hv = (HV*)POPPTR(ss,ix);
9445 TOPPTR(nss,ix) = hv_dup(hv, param);
9447 case SAVEt_APTR: /* AV* reference */
9448 ptr = POPPTR(ss,ix);
9449 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9450 av = (AV*)POPPTR(ss,ix);
9451 TOPPTR(nss,ix) = av_dup(av, param);
9454 gv = (GV*)POPPTR(ss,ix);
9455 TOPPTR(nss,ix) = gv_dup(gv, param);
9457 case SAVEt_GP: /* scalar reference */
9458 gp = (GP*)POPPTR(ss,ix);
9459 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9460 (void)GpREFCNT_inc(gp);
9461 gv = (GV*)POPPTR(ss,ix);
9462 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9463 c = (char*)POPPTR(ss,ix);
9464 TOPPTR(nss,ix) = pv_dup(c);
9471 case SAVEt_MORTALIZESV:
9472 sv = (SV*)POPPTR(ss,ix);
9473 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9476 ptr = POPPTR(ss,ix);
9477 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9478 /* these are assumed to be refcounted properly */
9479 switch (((OP*)ptr)->op_type) {
9486 TOPPTR(nss,ix) = ptr;
9491 TOPPTR(nss,ix) = Nullop;
9496 TOPPTR(nss,ix) = Nullop;
9499 c = (char*)POPPTR(ss,ix);
9500 TOPPTR(nss,ix) = pv_dup_inc(c);
9503 longval = POPLONG(ss,ix);
9504 TOPLONG(nss,ix) = longval;
9507 hv = (HV*)POPPTR(ss,ix);
9508 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9509 c = (char*)POPPTR(ss,ix);
9510 TOPPTR(nss,ix) = pv_dup_inc(c);
9514 case SAVEt_DESTRUCTOR:
9515 ptr = POPPTR(ss,ix);
9516 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9517 dptr = POPDPTR(ss,ix);
9518 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9520 case SAVEt_DESTRUCTOR_X:
9521 ptr = POPPTR(ss,ix);
9522 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9523 dxptr = POPDXPTR(ss,ix);
9524 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9526 case SAVEt_REGCONTEXT:
9532 case SAVEt_STACK_POS: /* Position on Perl stack */
9536 case SAVEt_AELEM: /* array element */
9537 sv = (SV*)POPPTR(ss,ix);
9538 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9541 av = (AV*)POPPTR(ss,ix);
9542 TOPPTR(nss,ix) = av_dup_inc(av, param);
9544 case SAVEt_HELEM: /* hash element */
9545 sv = (SV*)POPPTR(ss,ix);
9546 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9547 sv = (SV*)POPPTR(ss,ix);
9548 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9549 hv = (HV*)POPPTR(ss,ix);
9550 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9553 ptr = POPPTR(ss,ix);
9554 TOPPTR(nss,ix) = ptr;
9561 av = (AV*)POPPTR(ss,ix);
9562 TOPPTR(nss,ix) = av_dup(av, param);
9565 longval = (long)POPLONG(ss,ix);
9566 TOPLONG(nss,ix) = longval;
9567 ptr = POPPTR(ss,ix);
9568 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9569 sv = (SV*)POPPTR(ss,ix);
9570 TOPPTR(nss,ix) = sv_dup(sv, param);
9573 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9581 =for apidoc perl_clone
9583 Create and return a new interpreter by cloning the current one.
9588 /* XXX the above needs expanding by someone who actually understands it ! */
9589 EXTERN_C PerlInterpreter *
9590 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
9593 perl_clone(PerlInterpreter *proto_perl, UV flags)
9595 #ifdef PERL_IMPLICIT_SYS
9597 /* perlhost.h so we need to call into it
9598 to clone the host, CPerlHost should have a c interface, sky */
9600 if (flags & CLONEf_CLONE_HOST) {
9601 return perl_clone_host(proto_perl,flags);
9603 return perl_clone_using(proto_perl, flags,
9605 proto_perl->IMemShared,
9606 proto_perl->IMemParse,
9616 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9617 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9618 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9619 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9620 struct IPerlDir* ipD, struct IPerlSock* ipS,
9621 struct IPerlProc* ipP)
9623 /* XXX many of the string copies here can be optimized if they're
9624 * constants; they need to be allocated as common memory and just
9625 * their pointers copied. */
9628 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9630 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9631 PERL_SET_THX(my_perl);
9634 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9640 # else /* !DEBUGGING */
9641 Zero(my_perl, 1, PerlInterpreter);
9642 # endif /* DEBUGGING */
9646 PL_MemShared = ipMS;
9654 #else /* !PERL_IMPLICIT_SYS */
9656 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9657 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9658 PERL_SET_THX(my_perl);
9663 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9669 # else /* !DEBUGGING */
9670 Zero(my_perl, 1, PerlInterpreter);
9671 # endif /* DEBUGGING */
9672 #endif /* PERL_IMPLICIT_SYS */
9673 param->flags = flags;
9676 PL_xiv_arenaroot = NULL;
9678 PL_xnv_arenaroot = NULL;
9680 PL_xrv_arenaroot = NULL;
9682 PL_xpv_arenaroot = NULL;
9684 PL_xpviv_arenaroot = NULL;
9685 PL_xpviv_root = NULL;
9686 PL_xpvnv_arenaroot = NULL;
9687 PL_xpvnv_root = NULL;
9688 PL_xpvcv_arenaroot = NULL;
9689 PL_xpvcv_root = NULL;
9690 PL_xpvav_arenaroot = NULL;
9691 PL_xpvav_root = NULL;
9692 PL_xpvhv_arenaroot = NULL;
9693 PL_xpvhv_root = NULL;
9694 PL_xpvmg_arenaroot = NULL;
9695 PL_xpvmg_root = NULL;
9696 PL_xpvlv_arenaroot = NULL;
9697 PL_xpvlv_root = NULL;
9698 PL_xpvbm_arenaroot = NULL;
9699 PL_xpvbm_root = NULL;
9700 PL_he_arenaroot = NULL;
9702 PL_nice_chunk = NULL;
9703 PL_nice_chunk_size = 0;
9706 PL_sv_root = Nullsv;
9707 PL_sv_arenaroot = Nullsv;
9709 PL_debug = proto_perl->Idebug;
9711 #ifdef USE_REENTRANT_API
9712 New(31337, PL_reentrant_buffer,1, REBUF);
9713 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9716 /* create SV map for pointer relocation */
9717 PL_ptr_table = ptr_table_new();
9719 /* initialize these special pointers as early as possible */
9720 SvANY(&PL_sv_undef) = NULL;
9721 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9722 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9723 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9725 SvANY(&PL_sv_no) = new_XPVNV();
9726 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9727 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9728 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9729 SvCUR(&PL_sv_no) = 0;
9730 SvLEN(&PL_sv_no) = 1;
9731 SvNVX(&PL_sv_no) = 0;
9732 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9734 SvANY(&PL_sv_yes) = new_XPVNV();
9735 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9736 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9737 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9738 SvCUR(&PL_sv_yes) = 1;
9739 SvLEN(&PL_sv_yes) = 2;
9740 SvNVX(&PL_sv_yes) = 1;
9741 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9743 /* create shared string table */
9744 PL_strtab = newHV();
9745 HvSHAREKEYS_off(PL_strtab);
9746 hv_ksplit(PL_strtab, 512);
9747 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9749 PL_compiling = proto_perl->Icompiling;
9750 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9751 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9752 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9753 if (!specialWARN(PL_compiling.cop_warnings))
9754 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9755 if (!specialCopIO(PL_compiling.cop_io))
9756 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9757 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9759 /* pseudo environmental stuff */
9760 PL_origargc = proto_perl->Iorigargc;
9762 New(0, PL_origargv, i+1, char*);
9763 PL_origargv[i] = '\0';
9765 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9768 param->stashes = newAV(); /* Setup array of objects to call clone on */
9770 #ifdef PERLIO_LAYERS
9771 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
9772 PerlIO_clone(aTHX_ proto_perl, param);
9775 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9776 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9777 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9778 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9779 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9780 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9783 PL_minus_c = proto_perl->Iminus_c;
9784 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9785 PL_localpatches = proto_perl->Ilocalpatches;
9786 PL_splitstr = proto_perl->Isplitstr;
9787 PL_preprocess = proto_perl->Ipreprocess;
9788 PL_minus_n = proto_perl->Iminus_n;
9789 PL_minus_p = proto_perl->Iminus_p;
9790 PL_minus_l = proto_perl->Iminus_l;
9791 PL_minus_a = proto_perl->Iminus_a;
9792 PL_minus_F = proto_perl->Iminus_F;
9793 PL_doswitches = proto_perl->Idoswitches;
9794 PL_dowarn = proto_perl->Idowarn;
9795 PL_doextract = proto_perl->Idoextract;
9796 PL_sawampersand = proto_perl->Isawampersand;
9797 PL_unsafe = proto_perl->Iunsafe;
9798 PL_inplace = SAVEPV(proto_perl->Iinplace);
9799 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9800 PL_perldb = proto_perl->Iperldb;
9801 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9802 PL_exit_flags = proto_perl->Iexit_flags;
9804 /* magical thingies */
9805 /* XXX time(&PL_basetime) when asked for? */
9806 PL_basetime = proto_perl->Ibasetime;
9807 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9809 PL_maxsysfd = proto_perl->Imaxsysfd;
9810 PL_multiline = proto_perl->Imultiline;
9811 PL_statusvalue = proto_perl->Istatusvalue;
9813 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9816 /* Clone the regex array */
9817 PL_regex_padav = newAV();
9819 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9820 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9821 av_push(PL_regex_padav,
9822 sv_dup_inc(regexen[0],param));
9823 for(i = 1; i <= len; i++) {
9824 if(SvREPADTMP(regexen[i])) {
9825 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
9827 av_push(PL_regex_padav,
9829 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
9830 SvIVX(regexen[i])), param)))
9835 PL_regex_pad = AvARRAY(PL_regex_padav);
9837 /* shortcuts to various I/O objects */
9838 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9839 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9840 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9841 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9842 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9843 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9845 /* shortcuts to regexp stuff */
9846 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9848 /* shortcuts to misc objects */
9849 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9851 /* shortcuts to debugging objects */
9852 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9853 PL_DBline = gv_dup(proto_perl->IDBline, param);
9854 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9855 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9856 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9857 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9858 PL_lineary = av_dup(proto_perl->Ilineary, param);
9859 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9862 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9863 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9864 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9865 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9866 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9867 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9869 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9870 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
9871 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9872 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9873 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9875 PL_sub_generation = proto_perl->Isub_generation;
9877 /* funky return mechanisms */
9878 PL_forkprocess = proto_perl->Iforkprocess;
9880 /* subprocess state */
9881 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9883 /* internal state */
9884 PL_tainting = proto_perl->Itainting;
9885 PL_maxo = proto_perl->Imaxo;
9886 if (proto_perl->Iop_mask)
9887 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9889 PL_op_mask = Nullch;
9891 /* current interpreter roots */
9892 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9893 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9894 PL_main_start = proto_perl->Imain_start;
9895 PL_eval_root = proto_perl->Ieval_root;
9896 PL_eval_start = proto_perl->Ieval_start;
9898 /* runtime control stuff */
9899 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9900 PL_copline = proto_perl->Icopline;
9902 PL_filemode = proto_perl->Ifilemode;
9903 PL_lastfd = proto_perl->Ilastfd;
9904 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9907 PL_gensym = proto_perl->Igensym;
9908 PL_preambled = proto_perl->Ipreambled;
9909 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9910 PL_laststatval = proto_perl->Ilaststatval;
9911 PL_laststype = proto_perl->Ilaststype;
9912 PL_mess_sv = Nullsv;
9914 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9915 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9917 /* interpreter atexit processing */
9918 PL_exitlistlen = proto_perl->Iexitlistlen;
9919 if (PL_exitlistlen) {
9920 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9921 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9924 PL_exitlist = (PerlExitListEntry*)NULL;
9925 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9926 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
9927 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
9929 PL_profiledata = NULL;
9930 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
9931 /* PL_rsfp_filters entries have fake IoDIRP() */
9932 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9934 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9935 PL_comppad = av_dup(proto_perl->Icomppad, param);
9936 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9937 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9938 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9939 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9940 proto_perl->Tcurpad);
9942 #ifdef HAVE_INTERP_INTERN
9943 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9946 /* more statics moved here */
9947 PL_generation = proto_perl->Igeneration;
9948 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9950 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9951 PL_in_clean_all = proto_perl->Iin_clean_all;
9953 PL_uid = proto_perl->Iuid;
9954 PL_euid = proto_perl->Ieuid;
9955 PL_gid = proto_perl->Igid;
9956 PL_egid = proto_perl->Iegid;
9957 PL_nomemok = proto_perl->Inomemok;
9958 PL_an = proto_perl->Ian;
9959 PL_cop_seqmax = proto_perl->Icop_seqmax;
9960 PL_op_seqmax = proto_perl->Iop_seqmax;
9961 PL_evalseq = proto_perl->Ievalseq;
9962 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9963 PL_origalen = proto_perl->Iorigalen;
9964 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9965 PL_osname = SAVEPV(proto_perl->Iosname);
9966 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
9967 PL_sighandlerp = proto_perl->Isighandlerp;
9970 PL_runops = proto_perl->Irunops;
9972 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9975 PL_cshlen = proto_perl->Icshlen;
9976 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
9979 PL_lex_state = proto_perl->Ilex_state;
9980 PL_lex_defer = proto_perl->Ilex_defer;
9981 PL_lex_expect = proto_perl->Ilex_expect;
9982 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9983 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9984 PL_lex_starts = proto_perl->Ilex_starts;
9985 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
9986 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
9987 PL_lex_op = proto_perl->Ilex_op;
9988 PL_lex_inpat = proto_perl->Ilex_inpat;
9989 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9990 PL_lex_brackets = proto_perl->Ilex_brackets;
9991 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9992 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9993 PL_lex_casemods = proto_perl->Ilex_casemods;
9994 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9995 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9997 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9998 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9999 PL_nexttoke = proto_perl->Inexttoke;
10001 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10002 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10003 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10004 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10005 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10006 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10007 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10008 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10009 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10010 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10011 PL_pending_ident = proto_perl->Ipending_ident;
10012 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10014 PL_expect = proto_perl->Iexpect;
10016 PL_multi_start = proto_perl->Imulti_start;
10017 PL_multi_end = proto_perl->Imulti_end;
10018 PL_multi_open = proto_perl->Imulti_open;
10019 PL_multi_close = proto_perl->Imulti_close;
10021 PL_error_count = proto_perl->Ierror_count;
10022 PL_subline = proto_perl->Isubline;
10023 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10025 PL_min_intro_pending = proto_perl->Imin_intro_pending;
10026 PL_max_intro_pending = proto_perl->Imax_intro_pending;
10027 PL_padix = proto_perl->Ipadix;
10028 PL_padix_floor = proto_perl->Ipadix_floor;
10029 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
10031 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10032 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10033 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10034 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10035 PL_last_lop_op = proto_perl->Ilast_lop_op;
10036 PL_in_my = proto_perl->Iin_my;
10037 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10039 PL_cryptseen = proto_perl->Icryptseen;
10042 PL_hints = proto_perl->Ihints;
10044 PL_amagic_generation = proto_perl->Iamagic_generation;
10046 #ifdef USE_LOCALE_COLLATE
10047 PL_collation_ix = proto_perl->Icollation_ix;
10048 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10049 PL_collation_standard = proto_perl->Icollation_standard;
10050 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10051 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10052 #endif /* USE_LOCALE_COLLATE */
10054 #ifdef USE_LOCALE_NUMERIC
10055 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10056 PL_numeric_standard = proto_perl->Inumeric_standard;
10057 PL_numeric_local = proto_perl->Inumeric_local;
10058 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10059 #endif /* !USE_LOCALE_NUMERIC */
10061 /* utf8 character classes */
10062 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10063 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10064 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10065 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10066 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10067 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10068 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10069 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10070 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10071 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10072 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10073 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10074 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10075 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10076 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10077 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10078 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10081 PL_last_swash_hv = Nullhv; /* reinits on demand */
10082 PL_last_swash_klen = 0;
10083 PL_last_swash_key[0]= '\0';
10084 PL_last_swash_tmps = (U8*)NULL;
10085 PL_last_swash_slen = 0;
10087 /* perly.c globals */
10088 PL_yydebug = proto_perl->Iyydebug;
10089 PL_yynerrs = proto_perl->Iyynerrs;
10090 PL_yyerrflag = proto_perl->Iyyerrflag;
10091 PL_yychar = proto_perl->Iyychar;
10092 PL_yyval = proto_perl->Iyyval;
10093 PL_yylval = proto_perl->Iyylval;
10095 PL_glob_index = proto_perl->Iglob_index;
10096 PL_srand_called = proto_perl->Isrand_called;
10097 PL_uudmap['M'] = 0; /* reinits on demand */
10098 PL_bitcount = Nullch; /* reinits on demand */
10100 if (proto_perl->Ipsig_pend) {
10101 Newz(0, PL_psig_pend, SIG_SIZE, int);
10104 PL_psig_pend = (int*)NULL;
10107 if (proto_perl->Ipsig_ptr) {
10108 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10109 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10110 for (i = 1; i < SIG_SIZE; i++) {
10111 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10112 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10116 PL_psig_ptr = (SV**)NULL;
10117 PL_psig_name = (SV**)NULL;
10120 /* thrdvar.h stuff */
10122 if (flags & CLONEf_COPY_STACKS) {
10123 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10124 PL_tmps_ix = proto_perl->Ttmps_ix;
10125 PL_tmps_max = proto_perl->Ttmps_max;
10126 PL_tmps_floor = proto_perl->Ttmps_floor;
10127 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10129 while (i <= PL_tmps_ix) {
10130 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10134 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10135 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10136 Newz(54, PL_markstack, i, I32);
10137 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10138 - proto_perl->Tmarkstack);
10139 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10140 - proto_perl->Tmarkstack);
10141 Copy(proto_perl->Tmarkstack, PL_markstack,
10142 PL_markstack_ptr - PL_markstack + 1, I32);
10144 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10145 * NOTE: unlike the others! */
10146 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10147 PL_scopestack_max = proto_perl->Tscopestack_max;
10148 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10149 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10151 /* next push_return() sets PL_retstack[PL_retstack_ix]
10152 * NOTE: unlike the others! */
10153 PL_retstack_ix = proto_perl->Tretstack_ix;
10154 PL_retstack_max = proto_perl->Tretstack_max;
10155 Newz(54, PL_retstack, PL_retstack_max, OP*);
10156 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10158 /* NOTE: si_dup() looks at PL_markstack */
10159 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10161 /* PL_curstack = PL_curstackinfo->si_stack; */
10162 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10163 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10165 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10166 PL_stack_base = AvARRAY(PL_curstack);
10167 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10168 - proto_perl->Tstack_base);
10169 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10171 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10172 * NOTE: unlike the others! */
10173 PL_savestack_ix = proto_perl->Tsavestack_ix;
10174 PL_savestack_max = proto_perl->Tsavestack_max;
10175 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10176 PL_savestack = ss_dup(proto_perl, param);
10180 ENTER; /* perl_destruct() wants to LEAVE; */
10183 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10184 PL_top_env = &PL_start_env;
10186 PL_op = proto_perl->Top;
10189 PL_Xpv = (XPV*)NULL;
10190 PL_na = proto_perl->Tna;
10192 PL_statbuf = proto_perl->Tstatbuf;
10193 PL_statcache = proto_perl->Tstatcache;
10194 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10195 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10197 PL_timesbuf = proto_perl->Ttimesbuf;
10200 PL_tainted = proto_perl->Ttainted;
10201 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10202 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10203 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10204 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10205 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10206 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10207 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10208 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10209 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10211 PL_restartop = proto_perl->Trestartop;
10212 PL_in_eval = proto_perl->Tin_eval;
10213 PL_delaymagic = proto_perl->Tdelaymagic;
10214 PL_dirty = proto_perl->Tdirty;
10215 PL_localizing = proto_perl->Tlocalizing;
10217 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10218 PL_protect = proto_perl->Tprotect;
10220 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10221 PL_av_fetch_sv = Nullsv;
10222 PL_hv_fetch_sv = Nullsv;
10223 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10224 PL_modcount = proto_perl->Tmodcount;
10225 PL_lastgotoprobe = Nullop;
10226 PL_dumpindent = proto_perl->Tdumpindent;
10228 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10229 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10230 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10231 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10232 PL_sortcxix = proto_perl->Tsortcxix;
10233 PL_efloatbuf = Nullch; /* reinits on demand */
10234 PL_efloatsize = 0; /* reinits on demand */
10238 PL_screamfirst = NULL;
10239 PL_screamnext = NULL;
10240 PL_maxscream = -1; /* reinits on demand */
10241 PL_lastscream = Nullsv;
10243 PL_watchaddr = NULL;
10244 PL_watchok = Nullch;
10246 PL_regdummy = proto_perl->Tregdummy;
10247 PL_regcomp_parse = Nullch;
10248 PL_regxend = Nullch;
10249 PL_regcode = (regnode*)NULL;
10252 PL_regprecomp = Nullch;
10257 PL_seen_zerolen = 0;
10259 PL_regcomp_rx = (regexp*)NULL;
10261 PL_colorset = 0; /* reinits PL_colors[] */
10262 /*PL_colors[6] = {0,0,0,0,0,0};*/
10263 PL_reg_whilem_seen = 0;
10264 PL_reginput = Nullch;
10265 PL_regbol = Nullch;
10266 PL_regeol = Nullch;
10267 PL_regstartp = (I32*)NULL;
10268 PL_regendp = (I32*)NULL;
10269 PL_reglastparen = (U32*)NULL;
10270 PL_regtill = Nullch;
10271 PL_reg_start_tmp = (char**)NULL;
10272 PL_reg_start_tmpl = 0;
10273 PL_regdata = (struct reg_data*)NULL;
10276 PL_reg_eval_set = 0;
10278 PL_regprogram = (regnode*)NULL;
10280 PL_regcc = (CURCUR*)NULL;
10281 PL_reg_call_cc = (struct re_cc_state*)NULL;
10282 PL_reg_re = (regexp*)NULL;
10283 PL_reg_ganch = Nullch;
10284 PL_reg_sv = Nullsv;
10285 PL_reg_match_utf8 = FALSE;
10286 PL_reg_magic = (MAGIC*)NULL;
10288 PL_reg_oldcurpm = (PMOP*)NULL;
10289 PL_reg_curpm = (PMOP*)NULL;
10290 PL_reg_oldsaved = Nullch;
10291 PL_reg_oldsavedlen = 0;
10292 PL_reg_maxiter = 0;
10293 PL_reg_leftiter = 0;
10294 PL_reg_poscache = Nullch;
10295 PL_reg_poscache_size= 0;
10297 /* RE engine - function pointers */
10298 PL_regcompp = proto_perl->Tregcompp;
10299 PL_regexecp = proto_perl->Tregexecp;
10300 PL_regint_start = proto_perl->Tregint_start;
10301 PL_regint_string = proto_perl->Tregint_string;
10302 PL_regfree = proto_perl->Tregfree;
10304 PL_reginterp_cnt = 0;
10305 PL_reg_starttry = 0;
10307 /* Pluggable optimizer */
10308 PL_peepp = proto_perl->Tpeepp;
10310 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10311 ptr_table_free(PL_ptr_table);
10312 PL_ptr_table = NULL;
10315 /* Call the ->CLONE method, if it exists, for each of the stashes
10316 identified by sv_dup() above.
10318 while(av_len(param->stashes) != -1) {
10319 HV* stash = (HV*) av_shift(param->stashes);
10320 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10321 if (cloner && GvCV(cloner)) {
10326 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10328 call_sv((SV*)GvCV(cloner), G_DISCARD);
10334 SvREFCNT_dec(param->stashes);
10340 #endif /* USE_ITHREADS */