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)
1764 dsv = sv_2mortal(newSVpv("", 0));
1765 pv = sv_uni_display(dsv, sv, 10, 0);
1768 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1769 /* each *s can expand to 4 chars + "...\0",
1770 i.e. need room for 8 chars */
1773 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1775 if (ch & 128 && !isPRINT_LC(ch)) {
1784 else if (ch == '\r') {
1788 else if (ch == '\f') {
1792 else if (ch == '\\') {
1796 else if (ch == '\0') {
1800 else if (isPRINT_LC(ch))
1817 Perl_warner(aTHX_ WARN_NUMERIC,
1818 "Argument \"%s\" isn't numeric in %s", pv,
1821 Perl_warner(aTHX_ WARN_NUMERIC,
1822 "Argument \"%s\" isn't numeric", pv);
1826 =for apidoc looks_like_number
1828 Test if the content of an SV looks like a number (or is a number).
1829 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1830 non-numeric warning), even if your atof() doesn't grok them.
1836 Perl_looks_like_number(pTHX_ SV *sv)
1838 register char *sbegin;
1845 else if (SvPOKp(sv))
1846 sbegin = SvPV(sv, len);
1848 return 1; /* Historic. Wrong? */
1849 return grok_number(sbegin, len, NULL);
1852 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1853 until proven guilty, assume that things are not that bad... */
1858 As 64 bit platforms often have an NV that doesn't preserve all bits of
1859 an IV (an assumption perl has been based on to date) it becomes necessary
1860 to remove the assumption that the NV always carries enough precision to
1861 recreate the IV whenever needed, and that the NV is the canonical form.
1862 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1863 precision as a side effect of conversion (which would lead to insanity
1864 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1865 1) to distinguish between IV/UV/NV slots that have cached a valid
1866 conversion where precision was lost and IV/UV/NV slots that have a
1867 valid conversion which has lost no precision
1868 2) to ensure that if a numeric conversion to one form is requested that
1869 would lose precision, the precise conversion (or differently
1870 imprecise conversion) is also performed and cached, to prevent
1871 requests for different numeric formats on the same SV causing
1872 lossy conversion chains. (lossless conversion chains are perfectly
1877 SvIOKp is true if the IV slot contains a valid value
1878 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1879 SvNOKp is true if the NV slot contains a valid value
1880 SvNOK is true only if the NV value is accurate
1883 while converting from PV to NV, check to see if converting that NV to an
1884 IV(or UV) would lose accuracy over a direct conversion from PV to
1885 IV(or UV). If it would, cache both conversions, return NV, but mark
1886 SV as IOK NOKp (ie not NOK).
1888 While converting from PV to IV, check to see if converting that IV to an
1889 NV would lose accuracy over a direct conversion from PV to NV. If it
1890 would, cache both conversions, flag similarly.
1892 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1893 correctly because if IV & NV were set NV *always* overruled.
1894 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1895 changes - now IV and NV together means that the two are interchangeable:
1896 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1898 The benefit of this is that operations such as pp_add know that if
1899 SvIOK is true for both left and right operands, then integer addition
1900 can be used instead of floating point (for cases where the result won't
1901 overflow). Before, floating point was always used, which could lead to
1902 loss of precision compared with integer addition.
1904 * making IV and NV equal status should make maths accurate on 64 bit
1906 * may speed up maths somewhat if pp_add and friends start to use
1907 integers when possible instead of fp. (Hopefully the overhead in
1908 looking for SvIOK and checking for overflow will not outweigh the
1909 fp to integer speedup)
1910 * will slow down integer operations (callers of SvIV) on "inaccurate"
1911 values, as the change from SvIOK to SvIOKp will cause a call into
1912 sv_2iv each time rather than a macro access direct to the IV slot
1913 * should speed up number->string conversion on integers as IV is
1914 favoured when IV and NV are equally accurate
1916 ####################################################################
1917 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1918 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1919 On the other hand, SvUOK is true iff UV.
1920 ####################################################################
1922 Your mileage will vary depending your CPU's relative fp to integer
1926 #ifndef NV_PRESERVES_UV
1927 # define IS_NUMBER_UNDERFLOW_IV 1
1928 # define IS_NUMBER_UNDERFLOW_UV 2
1929 # define IS_NUMBER_IV_AND_UV 2
1930 # define IS_NUMBER_OVERFLOW_IV 4
1931 # define IS_NUMBER_OVERFLOW_UV 5
1933 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1935 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1937 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1939 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));
1940 if (SvNVX(sv) < (NV)IV_MIN) {
1941 (void)SvIOKp_on(sv);
1944 return IS_NUMBER_UNDERFLOW_IV;
1946 if (SvNVX(sv) > (NV)UV_MAX) {
1947 (void)SvIOKp_on(sv);
1951 return IS_NUMBER_OVERFLOW_UV;
1953 (void)SvIOKp_on(sv);
1955 /* Can't use strtol etc to convert this string. (See truth table in
1957 if (SvNVX(sv) <= (UV)IV_MAX) {
1958 SvIVX(sv) = I_V(SvNVX(sv));
1959 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1960 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1962 /* Integer is imprecise. NOK, IOKp */
1964 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1967 SvUVX(sv) = U_V(SvNVX(sv));
1968 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1969 if (SvUVX(sv) == UV_MAX) {
1970 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1971 possibly be preserved by NV. Hence, it must be overflow.
1973 return IS_NUMBER_OVERFLOW_UV;
1975 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1977 /* Integer is imprecise. NOK, IOKp */
1979 return IS_NUMBER_OVERFLOW_IV;
1981 #endif /* !NV_PRESERVES_UV*/
1986 Return the integer value of an SV, doing any necessary string conversion,
1987 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1993 Perl_sv_2iv(pTHX_ register SV *sv)
1997 if (SvGMAGICAL(sv)) {
2002 return I_V(SvNVX(sv));
2004 if (SvPOKp(sv) && SvLEN(sv))
2007 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2008 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2014 if (SvTHINKFIRST(sv)) {
2017 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2018 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2019 return SvIV(tmpstr);
2020 return PTR2IV(SvRV(sv));
2022 if (SvREADONLY(sv) && SvFAKE(sv)) {
2023 sv_force_normal(sv);
2025 if (SvREADONLY(sv) && !SvOK(sv)) {
2026 if (ckWARN(WARN_UNINITIALIZED))
2033 return (IV)(SvUVX(sv));
2040 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2041 * without also getting a cached IV/UV from it at the same time
2042 * (ie PV->NV conversion should detect loss of accuracy and cache
2043 * IV or UV at same time to avoid this. NWC */
2045 if (SvTYPE(sv) == SVt_NV)
2046 sv_upgrade(sv, SVt_PVNV);
2048 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2049 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2050 certainly cast into the IV range at IV_MAX, whereas the correct
2051 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2053 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2054 SvIVX(sv) = I_V(SvNVX(sv));
2055 if (SvNVX(sv) == (NV) SvIVX(sv)
2056 #ifndef NV_PRESERVES_UV
2057 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2058 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2059 /* Don't flag it as "accurately an integer" if the number
2060 came from a (by definition imprecise) NV operation, and
2061 we're outside the range of NV integer precision */
2064 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2065 DEBUG_c(PerlIO_printf(Perl_debug_log,
2066 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2072 /* IV not precise. No need to convert from PV, as NV
2073 conversion would already have cached IV if it detected
2074 that PV->IV would be better than PV->NV->IV
2075 flags already correct - don't set public IOK. */
2076 DEBUG_c(PerlIO_printf(Perl_debug_log,
2077 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2082 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2083 but the cast (NV)IV_MIN rounds to a the value less (more
2084 negative) than IV_MIN which happens to be equal to SvNVX ??
2085 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2086 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2087 (NV)UVX == NVX are both true, but the values differ. :-(
2088 Hopefully for 2s complement IV_MIN is something like
2089 0x8000000000000000 which will be exact. NWC */
2092 SvUVX(sv) = U_V(SvNVX(sv));
2094 (SvNVX(sv) == (NV) SvUVX(sv))
2095 #ifndef NV_PRESERVES_UV
2096 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2097 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2098 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2099 /* Don't flag it as "accurately an integer" if the number
2100 came from a (by definition imprecise) NV operation, and
2101 we're outside the range of NV integer precision */
2107 DEBUG_c(PerlIO_printf(Perl_debug_log,
2108 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2112 return (IV)SvUVX(sv);
2115 else if (SvPOKp(sv) && SvLEN(sv)) {
2117 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2118 /* We want to avoid a possible problem when we cache an IV which
2119 may be later translated to an NV, and the resulting NV is not
2120 the same as the direct translation of the initial string
2121 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2122 be careful to ensure that the value with the .456 is around if the
2123 NV value is requested in the future).
2125 This means that if we cache such an IV, we need to cache the
2126 NV as well. Moreover, we trade speed for space, and do not
2127 cache the NV if we are sure it's not needed.
2130 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2131 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2132 == IS_NUMBER_IN_UV) {
2133 /* It's definitely an integer, only upgrade to PVIV */
2134 if (SvTYPE(sv) < SVt_PVIV)
2135 sv_upgrade(sv, SVt_PVIV);
2137 } else if (SvTYPE(sv) < SVt_PVNV)
2138 sv_upgrade(sv, SVt_PVNV);
2140 /* If NV preserves UV then we only use the UV value if we know that
2141 we aren't going to call atof() below. If NVs don't preserve UVs
2142 then the value returned may have more precision than atof() will
2143 return, even though value isn't perfectly accurate. */
2144 if ((numtype & (IS_NUMBER_IN_UV
2145 #ifdef NV_PRESERVES_UV
2148 )) == IS_NUMBER_IN_UV) {
2149 /* This won't turn off the public IOK flag if it was set above */
2150 (void)SvIOKp_on(sv);
2152 if (!(numtype & IS_NUMBER_NEG)) {
2154 if (value <= (UV)IV_MAX) {
2155 SvIVX(sv) = (IV)value;
2161 /* 2s complement assumption */
2162 if (value <= (UV)IV_MIN) {
2163 SvIVX(sv) = -(IV)value;
2165 /* Too negative for an IV. This is a double upgrade, but
2166 I'm assuming it will be be rare. */
2167 if (SvTYPE(sv) < SVt_PVNV)
2168 sv_upgrade(sv, SVt_PVNV);
2172 SvNVX(sv) = -(NV)value;
2177 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2178 will be in the previous block to set the IV slot, and the next
2179 block to set the NV slot. So no else here. */
2181 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2182 != IS_NUMBER_IN_UV) {
2183 /* It wasn't an (integer that doesn't overflow the UV). */
2184 SvNVX(sv) = Atof(SvPVX(sv));
2186 if (! numtype && ckWARN(WARN_NUMERIC))
2189 #if defined(USE_LONG_DOUBLE)
2190 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2191 PTR2UV(sv), SvNVX(sv)));
2193 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2194 PTR2UV(sv), SvNVX(sv)));
2198 #ifdef NV_PRESERVES_UV
2199 (void)SvIOKp_on(sv);
2201 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2202 SvIVX(sv) = I_V(SvNVX(sv));
2203 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2206 /* Integer is imprecise. NOK, IOKp */
2208 /* UV will not work better than IV */
2210 if (SvNVX(sv) > (NV)UV_MAX) {
2212 /* Integer is inaccurate. NOK, IOKp, is UV */
2216 SvUVX(sv) = U_V(SvNVX(sv));
2217 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2218 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2222 /* Integer is imprecise. NOK, IOKp, is UV */
2228 #else /* NV_PRESERVES_UV */
2229 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2230 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2231 /* The IV slot will have been set from value returned by
2232 grok_number above. The NV slot has just been set using
2235 assert (SvIOKp(sv));
2237 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2238 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2239 /* Small enough to preserve all bits. */
2240 (void)SvIOKp_on(sv);
2242 SvIVX(sv) = I_V(SvNVX(sv));
2243 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2245 /* Assumption: first non-preserved integer is < IV_MAX,
2246 this NV is in the preserved range, therefore: */
2247 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2249 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);
2253 0 0 already failed to read UV.
2254 0 1 already failed to read UV.
2255 1 0 you won't get here in this case. IV/UV
2256 slot set, public IOK, Atof() unneeded.
2257 1 1 already read UV.
2258 so there's no point in sv_2iuv_non_preserve() attempting
2259 to use atol, strtol, strtoul etc. */
2260 if (sv_2iuv_non_preserve (sv, numtype)
2261 >= IS_NUMBER_OVERFLOW_IV)
2265 #endif /* NV_PRESERVES_UV */
2268 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2270 if (SvTYPE(sv) < SVt_IV)
2271 /* Typically the caller expects that sv_any is not NULL now. */
2272 sv_upgrade(sv, SVt_IV);
2275 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2276 PTR2UV(sv),SvIVX(sv)));
2277 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2283 Return the unsigned integer value of an SV, doing any necessary string
2284 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2291 Perl_sv_2uv(pTHX_ register SV *sv)
2295 if (SvGMAGICAL(sv)) {
2300 return U_V(SvNVX(sv));
2301 if (SvPOKp(sv) && SvLEN(sv))
2304 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2305 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2311 if (SvTHINKFIRST(sv)) {
2314 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2315 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2316 return SvUV(tmpstr);
2317 return PTR2UV(SvRV(sv));
2319 if (SvREADONLY(sv) && SvFAKE(sv)) {
2320 sv_force_normal(sv);
2322 if (SvREADONLY(sv) && !SvOK(sv)) {
2323 if (ckWARN(WARN_UNINITIALIZED))
2333 return (UV)SvIVX(sv);
2337 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2338 * without also getting a cached IV/UV from it at the same time
2339 * (ie PV->NV conversion should detect loss of accuracy and cache
2340 * IV or UV at same time to avoid this. */
2341 /* IV-over-UV optimisation - choose to cache IV if possible */
2343 if (SvTYPE(sv) == SVt_NV)
2344 sv_upgrade(sv, SVt_PVNV);
2346 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2347 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2348 SvIVX(sv) = I_V(SvNVX(sv));
2349 if (SvNVX(sv) == (NV) SvIVX(sv)
2350 #ifndef NV_PRESERVES_UV
2351 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2352 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2353 /* Don't flag it as "accurately an integer" if the number
2354 came from a (by definition imprecise) NV operation, and
2355 we're outside the range of NV integer precision */
2358 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2359 DEBUG_c(PerlIO_printf(Perl_debug_log,
2360 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2366 /* IV not precise. No need to convert from PV, as NV
2367 conversion would already have cached IV if it detected
2368 that PV->IV would be better than PV->NV->IV
2369 flags already correct - don't set public IOK. */
2370 DEBUG_c(PerlIO_printf(Perl_debug_log,
2371 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2376 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2377 but the cast (NV)IV_MIN rounds to a the value less (more
2378 negative) than IV_MIN which happens to be equal to SvNVX ??
2379 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2380 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2381 (NV)UVX == NVX are both true, but the values differ. :-(
2382 Hopefully for 2s complement IV_MIN is something like
2383 0x8000000000000000 which will be exact. NWC */
2386 SvUVX(sv) = U_V(SvNVX(sv));
2388 (SvNVX(sv) == (NV) SvUVX(sv))
2389 #ifndef NV_PRESERVES_UV
2390 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2391 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2392 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2393 /* Don't flag it as "accurately an integer" if the number
2394 came from a (by definition imprecise) NV operation, and
2395 we're outside the range of NV integer precision */
2400 DEBUG_c(PerlIO_printf(Perl_debug_log,
2401 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2407 else if (SvPOKp(sv) && SvLEN(sv)) {
2409 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2411 /* We want to avoid a possible problem when we cache a UV which
2412 may be later translated to an NV, and the resulting NV is not
2413 the translation of the initial data.
2415 This means that if we cache such a UV, we need to cache the
2416 NV as well. Moreover, we trade speed for space, and do not
2417 cache the NV if not needed.
2420 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2421 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2422 == IS_NUMBER_IN_UV) {
2423 /* It's definitely an integer, only upgrade to PVIV */
2424 if (SvTYPE(sv) < SVt_PVIV)
2425 sv_upgrade(sv, SVt_PVIV);
2427 } else if (SvTYPE(sv) < SVt_PVNV)
2428 sv_upgrade(sv, SVt_PVNV);
2430 /* If NV preserves UV then we only use the UV value if we know that
2431 we aren't going to call atof() below. If NVs don't preserve UVs
2432 then the value returned may have more precision than atof() will
2433 return, even though it isn't accurate. */
2434 if ((numtype & (IS_NUMBER_IN_UV
2435 #ifdef NV_PRESERVES_UV
2438 )) == IS_NUMBER_IN_UV) {
2439 /* This won't turn off the public IOK flag if it was set above */
2440 (void)SvIOKp_on(sv);
2442 if (!(numtype & IS_NUMBER_NEG)) {
2444 if (value <= (UV)IV_MAX) {
2445 SvIVX(sv) = (IV)value;
2447 /* it didn't overflow, and it was positive. */
2452 /* 2s complement assumption */
2453 if (value <= (UV)IV_MIN) {
2454 SvIVX(sv) = -(IV)value;
2456 /* Too negative for an IV. This is a double upgrade, but
2457 I'm assuming it will be be rare. */
2458 if (SvTYPE(sv) < SVt_PVNV)
2459 sv_upgrade(sv, SVt_PVNV);
2463 SvNVX(sv) = -(NV)value;
2469 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2470 != IS_NUMBER_IN_UV) {
2471 /* It wasn't an integer, or it overflowed the UV. */
2472 SvNVX(sv) = Atof(SvPVX(sv));
2474 if (! numtype && ckWARN(WARN_NUMERIC))
2477 #if defined(USE_LONG_DOUBLE)
2478 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2479 PTR2UV(sv), SvNVX(sv)));
2481 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2482 PTR2UV(sv), SvNVX(sv)));
2485 #ifdef NV_PRESERVES_UV
2486 (void)SvIOKp_on(sv);
2488 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2489 SvIVX(sv) = I_V(SvNVX(sv));
2490 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2493 /* Integer is imprecise. NOK, IOKp */
2495 /* UV will not work better than IV */
2497 if (SvNVX(sv) > (NV)UV_MAX) {
2499 /* Integer is inaccurate. NOK, IOKp, is UV */
2503 SvUVX(sv) = U_V(SvNVX(sv));
2504 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2505 NV preservse UV so can do correct comparison. */
2506 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2510 /* Integer is imprecise. NOK, IOKp, is UV */
2515 #else /* NV_PRESERVES_UV */
2516 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2517 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2518 /* The UV slot will have been set from value returned by
2519 grok_number above. The NV slot has just been set using
2522 assert (SvIOKp(sv));
2524 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2525 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2526 /* Small enough to preserve all bits. */
2527 (void)SvIOKp_on(sv);
2529 SvIVX(sv) = I_V(SvNVX(sv));
2530 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2532 /* Assumption: first non-preserved integer is < IV_MAX,
2533 this NV is in the preserved range, therefore: */
2534 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2536 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);
2539 sv_2iuv_non_preserve (sv, numtype);
2541 #endif /* NV_PRESERVES_UV */
2545 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2546 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2549 if (SvTYPE(sv) < SVt_IV)
2550 /* Typically the caller expects that sv_any is not NULL now. */
2551 sv_upgrade(sv, SVt_IV);
2555 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2556 PTR2UV(sv),SvUVX(sv)));
2557 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2563 Return the num value of an SV, doing any necessary string or integer
2564 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2571 Perl_sv_2nv(pTHX_ register SV *sv)
2575 if (SvGMAGICAL(sv)) {
2579 if (SvPOKp(sv) && SvLEN(sv)) {
2580 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2581 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2583 return Atof(SvPVX(sv));
2587 return (NV)SvUVX(sv);
2589 return (NV)SvIVX(sv);
2592 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2593 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2599 if (SvTHINKFIRST(sv)) {
2602 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2603 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2604 return SvNV(tmpstr);
2605 return PTR2NV(SvRV(sv));
2607 if (SvREADONLY(sv) && SvFAKE(sv)) {
2608 sv_force_normal(sv);
2610 if (SvREADONLY(sv) && !SvOK(sv)) {
2611 if (ckWARN(WARN_UNINITIALIZED))
2616 if (SvTYPE(sv) < SVt_NV) {
2617 if (SvTYPE(sv) == SVt_IV)
2618 sv_upgrade(sv, SVt_PVNV);
2620 sv_upgrade(sv, SVt_NV);
2621 #ifdef USE_LONG_DOUBLE
2623 STORE_NUMERIC_LOCAL_SET_STANDARD();
2624 PerlIO_printf(Perl_debug_log,
2625 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2626 PTR2UV(sv), SvNVX(sv));
2627 RESTORE_NUMERIC_LOCAL();
2631 STORE_NUMERIC_LOCAL_SET_STANDARD();
2632 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2633 PTR2UV(sv), SvNVX(sv));
2634 RESTORE_NUMERIC_LOCAL();
2638 else if (SvTYPE(sv) < SVt_PVNV)
2639 sv_upgrade(sv, SVt_PVNV);
2644 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2645 #ifdef NV_PRESERVES_UV
2648 /* Only set the public NV OK flag if this NV preserves the IV */
2649 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2650 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2651 : (SvIVX(sv) == I_V(SvNVX(sv))))
2657 else if (SvPOKp(sv) && SvLEN(sv)) {
2659 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2660 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2662 #ifdef NV_PRESERVES_UV
2663 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2664 == IS_NUMBER_IN_UV) {
2665 /* It's definitely an integer */
2666 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2668 SvNVX(sv) = Atof(SvPVX(sv));
2671 SvNVX(sv) = Atof(SvPVX(sv));
2672 /* Only set the public NV OK flag if this NV preserves the value in
2673 the PV at least as well as an IV/UV would.
2674 Not sure how to do this 100% reliably. */
2675 /* if that shift count is out of range then Configure's test is
2676 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2678 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2679 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2680 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2681 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2682 /* Can't use strtol etc to convert this string, so don't try.
2683 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2686 /* value has been set. It may not be precise. */
2687 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2688 /* 2s complement assumption for (UV)IV_MIN */
2689 SvNOK_on(sv); /* Integer is too negative. */
2694 if (numtype & IS_NUMBER_NEG) {
2695 SvIVX(sv) = -(IV)value;
2696 } else if (value <= (UV)IV_MAX) {
2697 SvIVX(sv) = (IV)value;
2703 if (numtype & IS_NUMBER_NOT_INT) {
2704 /* I believe that even if the original PV had decimals,
2705 they are lost beyond the limit of the FP precision.
2706 However, neither is canonical, so both only get p
2707 flags. NWC, 2000/11/25 */
2708 /* Both already have p flags, so do nothing */
2711 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2712 if (SvIVX(sv) == I_V(nv)) {
2717 /* It had no "." so it must be integer. */
2720 /* between IV_MAX and NV(UV_MAX).
2721 Could be slightly > UV_MAX */
2723 if (numtype & IS_NUMBER_NOT_INT) {
2724 /* UV and NV both imprecise. */
2726 UV nv_as_uv = U_V(nv);
2728 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2739 #endif /* NV_PRESERVES_UV */
2742 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2744 if (SvTYPE(sv) < SVt_NV)
2745 /* Typically the caller expects that sv_any is not NULL now. */
2746 /* XXX Ilya implies that this is a bug in callers that assume this
2747 and ideally should be fixed. */
2748 sv_upgrade(sv, SVt_NV);
2751 #if defined(USE_LONG_DOUBLE)
2753 STORE_NUMERIC_LOCAL_SET_STANDARD();
2754 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2755 PTR2UV(sv), SvNVX(sv));
2756 RESTORE_NUMERIC_LOCAL();
2760 STORE_NUMERIC_LOCAL_SET_STANDARD();
2761 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2762 PTR2UV(sv), SvNVX(sv));
2763 RESTORE_NUMERIC_LOCAL();
2769 /* asIV(): extract an integer from the string value of an SV.
2770 * Caller must validate PVX */
2773 S_asIV(pTHX_ SV *sv)
2776 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2778 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2779 == IS_NUMBER_IN_UV) {
2780 /* It's definitely an integer */
2781 if (numtype & IS_NUMBER_NEG) {
2782 if (value < (UV)IV_MIN)
2785 if (value < (UV)IV_MAX)
2790 if (ckWARN(WARN_NUMERIC))
2793 return I_V(Atof(SvPVX(sv)));
2796 /* asUV(): extract an unsigned integer from the string value of an SV
2797 * Caller must validate PVX */
2800 S_asUV(pTHX_ SV *sv)
2803 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2805 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2806 == IS_NUMBER_IN_UV) {
2807 /* It's definitely an integer */
2808 if (!(numtype & IS_NUMBER_NEG))
2812 if (ckWARN(WARN_NUMERIC))
2815 return U_V(Atof(SvPVX(sv)));
2819 =for apidoc sv_2pv_nolen
2821 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2822 use the macro wrapper C<SvPV_nolen(sv)> instead.
2827 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2830 return sv_2pv(sv, &n_a);
2833 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2834 * UV as a string towards the end of buf, and return pointers to start and
2837 * We assume that buf is at least TYPE_CHARS(UV) long.
2841 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2843 char *ptr = buf + TYPE_CHARS(UV);
2857 *--ptr = '0' + (uv % 10);
2865 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2866 * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2870 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2872 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2876 =for apidoc sv_2pv_flags
2878 Returns a pointer to the string value of an SV, and sets *lp to its length.
2879 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2881 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2882 usually end up here too.
2888 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2893 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2894 char *tmpbuf = tbuf;
2900 if (SvGMAGICAL(sv)) {
2901 if (flags & SV_GMAGIC)
2909 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2911 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2916 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2921 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2922 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2929 if (SvTHINKFIRST(sv)) {
2932 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2933 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2934 return SvPV(tmpstr,*lp);
2941 switch (SvTYPE(sv)) {
2943 if ( ((SvFLAGS(sv) &
2944 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2945 == (SVs_OBJECT|SVs_RMG))
2946 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2947 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2948 regexp *re = (regexp *)mg->mg_obj;
2951 char *fptr = "msix";
2956 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2958 while((ch = *fptr++)) {
2960 reflags[left++] = ch;
2963 reflags[right--] = ch;
2968 reflags[left] = '-';
2972 mg->mg_len = re->prelen + 4 + left;
2973 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2974 Copy("(?", mg->mg_ptr, 2, char);
2975 Copy(reflags, mg->mg_ptr+2, left, char);
2976 Copy(":", mg->mg_ptr+left+2, 1, char);
2977 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2978 mg->mg_ptr[mg->mg_len - 1] = ')';
2979 mg->mg_ptr[mg->mg_len] = 0;
2981 PL_reginterp_cnt += re->program[0].next_off;
2993 case SVt_PVBM: if (SvROK(sv))
2996 s = "SCALAR"; break;
2997 case SVt_PVLV: s = "LVALUE"; break;
2998 case SVt_PVAV: s = "ARRAY"; break;
2999 case SVt_PVHV: s = "HASH"; break;
3000 case SVt_PVCV: s = "CODE"; break;
3001 case SVt_PVGV: s = "GLOB"; break;
3002 case SVt_PVFM: s = "FORMAT"; break;
3003 case SVt_PVIO: s = "IO"; break;
3004 default: s = "UNKNOWN"; break;
3008 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
3011 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3017 if (SvREADONLY(sv) && !SvOK(sv)) {
3018 if (ckWARN(WARN_UNINITIALIZED))
3024 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3025 /* I'm assuming that if both IV and NV are equally valid then
3026 converting the IV is going to be more efficient */
3027 U32 isIOK = SvIOK(sv);
3028 U32 isUIOK = SvIsUV(sv);
3029 char buf[TYPE_CHARS(UV)];
3032 if (SvTYPE(sv) < SVt_PVIV)
3033 sv_upgrade(sv, SVt_PVIV);
3035 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3037 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3038 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
3039 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3040 SvCUR_set(sv, ebuf - ptr);
3050 else if (SvNOKp(sv)) {
3051 if (SvTYPE(sv) < SVt_PVNV)
3052 sv_upgrade(sv, SVt_PVNV);
3053 /* The +20 is pure guesswork. Configure test needed. --jhi */
3054 SvGROW(sv, NV_DIG + 20);
3056 olderrno = errno; /* some Xenix systems wipe out errno here */
3058 if (SvNVX(sv) == 0.0)
3059 (void)strcpy(s,"0");
3063 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3066 #ifdef FIXNEGATIVEZERO
3067 if (*s == '-' && s[1] == '0' && !s[2])
3077 if (ckWARN(WARN_UNINITIALIZED)
3078 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3081 if (SvTYPE(sv) < SVt_PV)
3082 /* Typically the caller expects that sv_any is not NULL now. */
3083 sv_upgrade(sv, SVt_PV);
3086 *lp = s - SvPVX(sv);
3089 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3090 PTR2UV(sv),SvPVX(sv)));
3094 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3095 /* Sneaky stuff here */
3099 tsv = newSVpv(tmpbuf, 0);
3115 len = strlen(tmpbuf);
3117 #ifdef FIXNEGATIVEZERO
3118 if (len == 2 && t[0] == '-' && t[1] == '0') {
3123 (void)SvUPGRADE(sv, SVt_PV);
3125 s = SvGROW(sv, len + 1);
3134 =for apidoc sv_2pvbyte_nolen
3136 Return a pointer to the byte-encoded representation of the SV.
3137 May cause the SV to be downgraded from UTF8 as a side-effect.
3139 Usually accessed via the C<SvPVbyte_nolen> macro.
3145 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3148 return sv_2pvbyte(sv, &n_a);
3152 =for apidoc sv_2pvbyte
3154 Return a pointer to the byte-encoded representation of the SV, and set *lp
3155 to its length. May cause the SV to be downgraded from UTF8 as a
3158 Usually accessed via the C<SvPVbyte> macro.
3164 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3166 sv_utf8_downgrade(sv,0);
3167 return SvPV(sv,*lp);
3171 =for apidoc sv_2pvutf8_nolen
3173 Return a pointer to the UTF8-encoded representation of the SV.
3174 May cause the SV to be upgraded to UTF8 as a side-effect.
3176 Usually accessed via the C<SvPVutf8_nolen> macro.
3182 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3185 return sv_2pvutf8(sv, &n_a);
3189 =for apidoc sv_2pvutf8
3191 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3192 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3194 Usually accessed via the C<SvPVutf8> macro.
3200 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3202 sv_utf8_upgrade(sv);
3203 return SvPV(sv,*lp);
3207 =for apidoc sv_2bool
3209 This function is only called on magical items, and is only used by
3210 sv_true() or its macro equivalent.
3216 Perl_sv_2bool(pTHX_ register SV *sv)
3225 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3226 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
3227 return SvTRUE(tmpsv);
3228 return SvRV(sv) != 0;
3231 register XPV* Xpvtmp;
3232 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3233 (*Xpvtmp->xpv_pv > '0' ||
3234 Xpvtmp->xpv_cur > 1 ||
3235 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3242 return SvIVX(sv) != 0;
3245 return SvNVX(sv) != 0.0;
3253 =for apidoc sv_utf8_upgrade
3255 Convert the PV of an SV to its UTF8-encoded form.
3256 Forces the SV to string form if it is not already.
3257 Always sets the SvUTF8 flag to avoid future validity checks even
3258 if all the bytes have hibit clear.
3264 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3266 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3270 =for apidoc sv_utf8_upgrade_flags
3272 Convert the PV of an SV to its UTF8-encoded form.
3273 Forces the SV to string form if it is not already.
3274 Always sets the SvUTF8 flag to avoid future validity checks even
3275 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3276 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3277 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3283 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3293 (void) sv_2pv_flags(sv,&len, flags);
3301 if (SvREADONLY(sv) && SvFAKE(sv)) {
3302 sv_force_normal(sv);
3305 /* This function could be much more efficient if we had a FLAG in SVs
3306 * to signal if there are any hibit chars in the PV.
3307 * Given that there isn't make loop fast as possible
3309 s = (U8 *) SvPVX(sv);
3310 e = (U8 *) SvEND(sv);
3314 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3320 len = SvCUR(sv) + 1; /* Plus the \0 */
3321 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3322 SvCUR(sv) = len - 1;
3324 Safefree(s); /* No longer using what was there before. */
3325 SvLEN(sv) = len; /* No longer know the real size. */
3327 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3333 =for apidoc sv_utf8_downgrade
3335 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3336 This may not be possible if the PV contains non-byte encoding characters;
3337 if this is the case, either returns false or, if C<fail_ok> is not
3344 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3346 if (SvPOK(sv) && SvUTF8(sv)) {
3351 if (SvREADONLY(sv) && SvFAKE(sv))
3352 sv_force_normal(sv);
3353 s = (U8 *) SvPV(sv, len);
3354 if (!utf8_to_bytes(s, &len)) {
3357 #ifdef USE_BYTES_DOWNGRADES
3358 else if (IN_BYTES) {
3360 U8 *e = (U8 *) SvEND(sv);
3363 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3364 if (first && ch > 255) {
3366 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3369 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3376 len = (d - (U8 *) SvPVX(sv));
3381 Perl_croak(aTHX_ "Wide character in %s",
3384 Perl_croak(aTHX_ "Wide character");
3395 =for apidoc sv_utf8_encode
3397 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3398 flag so that it looks like octets again. Used as a building block
3399 for encode_utf8 in Encode.xs
3405 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3407 (void) sv_utf8_upgrade(sv);
3412 =for apidoc sv_utf8_decode
3414 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3415 turn off SvUTF8 if needed so that we see characters. Used as a building block
3416 for decode_utf8 in Encode.xs
3422 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3428 /* The octets may have got themselves encoded - get them back as
3431 if (!sv_utf8_downgrade(sv, TRUE))
3434 /* it is actually just a matter of turning the utf8 flag on, but
3435 * we want to make sure everything inside is valid utf8 first.
3437 c = (U8 *) SvPVX(sv);
3438 if (!is_utf8_string(c, SvCUR(sv)+1))
3440 e = (U8 *) SvEND(sv);
3443 if (!UTF8_IS_INVARIANT(ch)) {
3453 =for apidoc sv_setsv
3455 Copies the contents of the source SV C<ssv> into the destination SV
3456 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3457 function if the source SV needs to be reused. Does not handle 'set' magic.
3458 Loosely speaking, it performs a copy-by-value, obliterating any previous
3459 content of the destination.
3461 You probably want to use one of the assortment of wrappers, such as
3462 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3463 C<SvSetMagicSV_nosteal>.
3469 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3470 for binary compatibility only
3473 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3475 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3479 =for apidoc sv_setsv_flags
3481 Copies the contents of the source SV C<ssv> into the destination SV
3482 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3483 function if the source SV needs to be reused. Does not handle 'set' magic.
3484 Loosely speaking, it performs a copy-by-value, obliterating any previous
3485 content of the destination.
3486 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3487 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3488 implemented in terms of this function.
3490 You probably want to use one of the assortment of wrappers, such as
3491 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3492 C<SvSetMagicSV_nosteal>.
3494 This is the primary function for copying scalars, and most other
3495 copy-ish functions and macros use this underneath.
3501 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3503 register U32 sflags;
3509 SV_CHECK_THINKFIRST(dstr);
3511 sstr = &PL_sv_undef;
3512 stype = SvTYPE(sstr);
3513 dtype = SvTYPE(dstr);
3517 /* There's a lot of redundancy below but we're going for speed here */
3522 if (dtype != SVt_PVGV) {
3523 (void)SvOK_off(dstr);
3531 sv_upgrade(dstr, SVt_IV);
3534 sv_upgrade(dstr, SVt_PVNV);
3538 sv_upgrade(dstr, SVt_PVIV);
3541 (void)SvIOK_only(dstr);
3542 SvIVX(dstr) = SvIVX(sstr);
3545 if (SvTAINTED(sstr))
3556 sv_upgrade(dstr, SVt_NV);
3561 sv_upgrade(dstr, SVt_PVNV);
3564 SvNVX(dstr) = SvNVX(sstr);
3565 (void)SvNOK_only(dstr);
3566 if (SvTAINTED(sstr))
3574 sv_upgrade(dstr, SVt_RV);
3575 else if (dtype == SVt_PVGV &&
3576 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3579 if (GvIMPORTED(dstr) != GVf_IMPORTED
3580 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3582 GvIMPORTED_on(dstr);
3593 sv_upgrade(dstr, SVt_PV);
3596 if (dtype < SVt_PVIV)
3597 sv_upgrade(dstr, SVt_PVIV);
3600 if (dtype < SVt_PVNV)
3601 sv_upgrade(dstr, SVt_PVNV);
3608 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3611 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3615 if (dtype <= SVt_PVGV) {
3617 if (dtype != SVt_PVGV) {
3618 char *name = GvNAME(sstr);
3619 STRLEN len = GvNAMELEN(sstr);
3620 sv_upgrade(dstr, SVt_PVGV);
3621 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3622 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3623 GvNAME(dstr) = savepvn(name, len);
3624 GvNAMELEN(dstr) = len;
3625 SvFAKE_on(dstr); /* can coerce to non-glob */
3627 /* ahem, death to those who redefine active sort subs */
3628 else if (PL_curstackinfo->si_type == PERLSI_SORT
3629 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3630 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3633 #ifdef GV_UNIQUE_CHECK
3634 if (GvUNIQUE((GV*)dstr)) {
3635 Perl_croak(aTHX_ PL_no_modify);
3639 (void)SvOK_off(dstr);
3640 GvINTRO_off(dstr); /* one-shot flag */
3642 GvGP(dstr) = gp_ref(GvGP(sstr));
3643 if (SvTAINTED(sstr))
3645 if (GvIMPORTED(dstr) != GVf_IMPORTED
3646 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3648 GvIMPORTED_on(dstr);
3656 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3658 if (SvTYPE(sstr) != stype) {
3659 stype = SvTYPE(sstr);
3660 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3664 if (stype == SVt_PVLV)
3665 (void)SvUPGRADE(dstr, SVt_PVNV);
3667 (void)SvUPGRADE(dstr, stype);
3670 sflags = SvFLAGS(sstr);
3672 if (sflags & SVf_ROK) {
3673 if (dtype >= SVt_PV) {
3674 if (dtype == SVt_PVGV) {
3675 SV *sref = SvREFCNT_inc(SvRV(sstr));
3677 int intro = GvINTRO(dstr);
3679 #ifdef GV_UNIQUE_CHECK
3680 if (GvUNIQUE((GV*)dstr)) {
3681 Perl_croak(aTHX_ PL_no_modify);
3686 GvINTRO_off(dstr); /* one-shot flag */
3687 GvLINE(dstr) = CopLINE(PL_curcop);
3688 GvEGV(dstr) = (GV*)dstr;
3691 switch (SvTYPE(sref)) {
3694 SAVESPTR(GvAV(dstr));
3696 dref = (SV*)GvAV(dstr);
3697 GvAV(dstr) = (AV*)sref;
3698 if (!GvIMPORTED_AV(dstr)
3699 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3701 GvIMPORTED_AV_on(dstr);
3706 SAVESPTR(GvHV(dstr));
3708 dref = (SV*)GvHV(dstr);
3709 GvHV(dstr) = (HV*)sref;
3710 if (!GvIMPORTED_HV(dstr)
3711 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3713 GvIMPORTED_HV_on(dstr);
3718 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3719 SvREFCNT_dec(GvCV(dstr));
3720 GvCV(dstr) = Nullcv;
3721 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3722 PL_sub_generation++;
3724 SAVESPTR(GvCV(dstr));
3727 dref = (SV*)GvCV(dstr);
3728 if (GvCV(dstr) != (CV*)sref) {
3729 CV* cv = GvCV(dstr);
3731 if (!GvCVGEN((GV*)dstr) &&
3732 (CvROOT(cv) || CvXSUB(cv)))
3734 /* ahem, death to those who redefine
3735 * active sort subs */
3736 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3737 PL_sortcop == CvSTART(cv))
3739 "Can't redefine active sort subroutine %s",
3740 GvENAME((GV*)dstr));
3741 /* Redefining a sub - warning is mandatory if
3742 it was a const and its value changed. */
3743 if (ckWARN(WARN_REDEFINE)
3745 && (!CvCONST((CV*)sref)
3746 || sv_cmp(cv_const_sv(cv),
3747 cv_const_sv((CV*)sref)))))
3749 Perl_warner(aTHX_ WARN_REDEFINE,
3751 ? "Constant subroutine %s redefined"
3752 : "Subroutine %s redefined",
3753 GvENAME((GV*)dstr));
3756 cv_ckproto(cv, (GV*)dstr,
3757 SvPOK(sref) ? SvPVX(sref) : Nullch);
3759 GvCV(dstr) = (CV*)sref;
3760 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3761 GvASSUMECV_on(dstr);
3762 PL_sub_generation++;
3764 if (!GvIMPORTED_CV(dstr)
3765 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3767 GvIMPORTED_CV_on(dstr);
3772 SAVESPTR(GvIOp(dstr));
3774 dref = (SV*)GvIOp(dstr);
3775 GvIOp(dstr) = (IO*)sref;
3779 SAVESPTR(GvFORM(dstr));
3781 dref = (SV*)GvFORM(dstr);
3782 GvFORM(dstr) = (CV*)sref;
3786 SAVESPTR(GvSV(dstr));
3788 dref = (SV*)GvSV(dstr);
3790 if (!GvIMPORTED_SV(dstr)
3791 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3793 GvIMPORTED_SV_on(dstr);
3801 if (SvTAINTED(sstr))
3806 (void)SvOOK_off(dstr); /* backoff */
3808 Safefree(SvPVX(dstr));
3809 SvLEN(dstr)=SvCUR(dstr)=0;
3812 (void)SvOK_off(dstr);
3813 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3815 if (sflags & SVp_NOK) {
3817 /* Only set the public OK flag if the source has public OK. */
3818 if (sflags & SVf_NOK)
3819 SvFLAGS(dstr) |= SVf_NOK;
3820 SvNVX(dstr) = SvNVX(sstr);
3822 if (sflags & SVp_IOK) {
3823 (void)SvIOKp_on(dstr);
3824 if (sflags & SVf_IOK)
3825 SvFLAGS(dstr) |= SVf_IOK;
3826 if (sflags & SVf_IVisUV)
3828 SvIVX(dstr) = SvIVX(sstr);
3830 if (SvAMAGIC(sstr)) {
3834 else if (sflags & SVp_POK) {
3837 * Check to see if we can just swipe the string. If so, it's a
3838 * possible small lose on short strings, but a big win on long ones.
3839 * It might even be a win on short strings if SvPVX(dstr)
3840 * has to be allocated and SvPVX(sstr) has to be freed.
3843 if (SvTEMP(sstr) && /* slated for free anyway? */
3844 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3845 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3846 SvLEN(sstr) && /* and really is a string */
3847 /* and won't be needed again, potentially */
3848 !(PL_op && PL_op->op_type == OP_AASSIGN))
3850 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3852 SvFLAGS(dstr) &= ~SVf_OOK;
3853 Safefree(SvPVX(dstr) - SvIVX(dstr));
3855 else if (SvLEN(dstr))
3856 Safefree(SvPVX(dstr));
3858 (void)SvPOK_only(dstr);
3859 SvPV_set(dstr, SvPVX(sstr));
3860 SvLEN_set(dstr, SvLEN(sstr));
3861 SvCUR_set(dstr, SvCUR(sstr));
3864 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3865 SvPV_set(sstr, Nullch);
3870 else { /* have to copy actual string */
3871 STRLEN len = SvCUR(sstr);
3873 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3874 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3875 SvCUR_set(dstr, len);
3876 *SvEND(dstr) = '\0';
3877 (void)SvPOK_only(dstr);
3879 if (sflags & SVf_UTF8)
3882 if (sflags & SVp_NOK) {
3884 if (sflags & SVf_NOK)
3885 SvFLAGS(dstr) |= SVf_NOK;
3886 SvNVX(dstr) = SvNVX(sstr);
3888 if (sflags & SVp_IOK) {
3889 (void)SvIOKp_on(dstr);
3890 if (sflags & SVf_IOK)
3891 SvFLAGS(dstr) |= SVf_IOK;
3892 if (sflags & SVf_IVisUV)
3894 SvIVX(dstr) = SvIVX(sstr);
3897 else if (sflags & SVp_IOK) {
3898 if (sflags & SVf_IOK)
3899 (void)SvIOK_only(dstr);
3901 (void)SvOK_off(dstr);
3902 (void)SvIOKp_on(dstr);
3904 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3905 if (sflags & SVf_IVisUV)
3907 SvIVX(dstr) = SvIVX(sstr);
3908 if (sflags & SVp_NOK) {
3909 if (sflags & SVf_NOK)
3910 (void)SvNOK_on(dstr);
3912 (void)SvNOKp_on(dstr);
3913 SvNVX(dstr) = SvNVX(sstr);
3916 else if (sflags & SVp_NOK) {
3917 if (sflags & SVf_NOK)
3918 (void)SvNOK_only(dstr);
3920 (void)SvOK_off(dstr);
3923 SvNVX(dstr) = SvNVX(sstr);
3926 if (dtype == SVt_PVGV) {
3927 if (ckWARN(WARN_MISC))
3928 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3931 (void)SvOK_off(dstr);
3933 if (SvTAINTED(sstr))
3938 =for apidoc sv_setsv_mg
3940 Like C<sv_setsv>, but also handles 'set' magic.
3946 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3948 sv_setsv(dstr,sstr);
3953 =for apidoc sv_setpvn
3955 Copies a string into an SV. The C<len> parameter indicates the number of
3956 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3962 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3964 register char *dptr;
3966 SV_CHECK_THINKFIRST(sv);
3972 /* len is STRLEN which is unsigned, need to copy to signed */
3975 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3977 (void)SvUPGRADE(sv, SVt_PV);
3979 SvGROW(sv, len + 1);
3981 Move(ptr,dptr,len,char);
3984 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3989 =for apidoc sv_setpvn_mg
3991 Like C<sv_setpvn>, but also handles 'set' magic.
3997 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3999 sv_setpvn(sv,ptr,len);
4004 =for apidoc sv_setpv
4006 Copies a string into an SV. The string must be null-terminated. Does not
4007 handle 'set' magic. See C<sv_setpv_mg>.
4013 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4015 register STRLEN len;
4017 SV_CHECK_THINKFIRST(sv);
4023 (void)SvUPGRADE(sv, SVt_PV);
4025 SvGROW(sv, len + 1);
4026 Move(ptr,SvPVX(sv),len+1,char);
4028 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4033 =for apidoc sv_setpv_mg
4035 Like C<sv_setpv>, but also handles 'set' magic.
4041 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4048 =for apidoc sv_usepvn
4050 Tells an SV to use C<ptr> to find its string value. Normally the string is
4051 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4052 The C<ptr> should point to memory that was allocated by C<malloc>. The
4053 string length, C<len>, must be supplied. This function will realloc the
4054 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4055 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4056 See C<sv_usepvn_mg>.
4062 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4064 SV_CHECK_THINKFIRST(sv);
4065 (void)SvUPGRADE(sv, SVt_PV);
4070 (void)SvOOK_off(sv);
4071 if (SvPVX(sv) && SvLEN(sv))
4072 Safefree(SvPVX(sv));
4073 Renew(ptr, len+1, char);
4076 SvLEN_set(sv, len+1);
4078 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4083 =for apidoc sv_usepvn_mg
4085 Like C<sv_usepvn>, but also handles 'set' magic.
4091 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4093 sv_usepvn(sv,ptr,len);
4098 =for apidoc sv_force_normal_flags
4100 Undo various types of fakery on an SV: if the PV is a shared string, make
4101 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4102 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4103 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4109 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4111 if (SvREADONLY(sv)) {
4113 char *pvx = SvPVX(sv);
4114 STRLEN len = SvCUR(sv);
4115 U32 hash = SvUVX(sv);
4116 SvGROW(sv, len + 1);
4117 Move(pvx,SvPVX(sv),len,char);
4121 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4123 else if (PL_curcop != &PL_compiling)
4124 Perl_croak(aTHX_ PL_no_modify);
4127 sv_unref_flags(sv, flags);
4128 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4133 =for apidoc sv_force_normal
4135 Undo various types of fakery on an SV: if the PV is a shared string, make
4136 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4137 an xpvmg. See also C<sv_force_normal_flags>.
4143 Perl_sv_force_normal(pTHX_ register SV *sv)
4145 sv_force_normal_flags(sv, 0);
4151 Efficient removal of characters from the beginning of the string buffer.
4152 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4153 the string buffer. The C<ptr> becomes the first character of the adjusted
4154 string. Uses the "OOK hack".
4160 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4162 register STRLEN delta;
4164 if (!ptr || !SvPOKp(sv))
4166 SV_CHECK_THINKFIRST(sv);
4167 if (SvTYPE(sv) < SVt_PVIV)
4168 sv_upgrade(sv,SVt_PVIV);
4171 if (!SvLEN(sv)) { /* make copy of shared string */
4172 char *pvx = SvPVX(sv);
4173 STRLEN len = SvCUR(sv);
4174 SvGROW(sv, len + 1);
4175 Move(pvx,SvPVX(sv),len,char);
4179 SvFLAGS(sv) |= SVf_OOK;
4181 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4182 delta = ptr - SvPVX(sv);
4190 =for apidoc sv_catpvn
4192 Concatenates the string onto the end of the string which is in the SV. The
4193 C<len> indicates number of bytes to copy. If the SV has the UTF8
4194 status set, then the bytes appended should be valid UTF8.
4195 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4200 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4201 for binary compatibility only
4204 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4206 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4210 =for apidoc sv_catpvn_flags
4212 Concatenates the string onto the end of the string which is in the SV. The
4213 C<len> indicates number of bytes to copy. If the SV has the UTF8
4214 status set, then the bytes appended should be valid UTF8.
4215 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4216 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4217 in terms of this function.
4223 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4228 dstr = SvPV_force_flags(dsv, dlen, flags);
4229 SvGROW(dsv, dlen + slen + 1);
4232 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4235 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4240 =for apidoc sv_catpvn_mg
4242 Like C<sv_catpvn>, but also handles 'set' magic.
4248 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4250 sv_catpvn(sv,ptr,len);
4255 =for apidoc sv_catsv
4257 Concatenates the string from SV C<ssv> onto the end of the string in
4258 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4259 not 'set' magic. See C<sv_catsv_mg>.
4263 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4264 for binary compatibility only
4267 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4269 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4273 =for apidoc sv_catsv_flags
4275 Concatenates the string from SV C<ssv> onto the end of the string in
4276 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4277 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4278 and C<sv_catsv_nomg> are implemented in terms of this function.
4283 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4289 if ((spv = SvPV(ssv, slen))) {
4290 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4291 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4292 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4293 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4294 dsv->sv_flags doesn't have that bit set.
4295 Andy Dougherty 12 Oct 2001
4297 I32 sutf8 = DO_UTF8(ssv);
4300 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4302 dutf8 = DO_UTF8(dsv);
4304 if (dutf8 != sutf8) {
4306 /* Not modifying source SV, so taking a temporary copy. */
4307 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4309 sv_utf8_upgrade(csv);
4310 spv = SvPV(csv, slen);
4313 sv_utf8_upgrade_nomg(dsv);
4315 sv_catpvn_nomg(dsv, spv, slen);
4320 =for apidoc sv_catsv_mg
4322 Like C<sv_catsv>, but also handles 'set' magic.
4328 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4335 =for apidoc sv_catpv
4337 Concatenates the string onto the end of the string which is in the SV.
4338 If the SV has the UTF8 status set, then the bytes appended should be
4339 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4344 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4346 register STRLEN len;
4352 junk = SvPV_force(sv, tlen);
4354 SvGROW(sv, tlen + len + 1);
4357 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4359 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4364 =for apidoc sv_catpv_mg
4366 Like C<sv_catpv>, but also handles 'set' magic.
4372 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4381 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4382 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4389 Perl_newSV(pTHX_ STRLEN len)
4395 sv_upgrade(sv, SVt_PV);
4396 SvGROW(sv, len + 1);
4402 =for apidoc sv_magic
4404 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4405 then adds a new magic item of type C<how> to the head of the magic list.
4407 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4413 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4417 if (SvREADONLY(sv)) {
4418 if (PL_curcop != &PL_compiling
4419 && how != PERL_MAGIC_regex_global
4420 && how != PERL_MAGIC_bm
4421 && how != PERL_MAGIC_fm
4422 && how != PERL_MAGIC_sv
4425 Perl_croak(aTHX_ PL_no_modify);
4428 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4429 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4430 if (how == PERL_MAGIC_taint)
4436 (void)SvUPGRADE(sv, SVt_PVMG);
4438 Newz(702,mg, 1, MAGIC);
4439 mg->mg_moremagic = SvMAGIC(sv);
4442 /* Some magic contains a reference loop, where the sv and object refer to
4443 each other. To avoid a reference loop that would prevent such objects
4444 being freed, we look for such loops and if we find one we avoid
4445 incrementing the object refcount. */
4446 if (!obj || obj == sv ||
4447 how == PERL_MAGIC_arylen ||
4448 how == PERL_MAGIC_qr ||
4449 (SvTYPE(obj) == SVt_PVGV &&
4450 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4451 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4452 GvFORM(obj) == (CV*)sv)))
4457 mg->mg_obj = SvREFCNT_inc(obj);
4458 mg->mg_flags |= MGf_REFCOUNTED;
4461 mg->mg_len = namlen;
4464 mg->mg_ptr = savepvn(name, namlen);
4465 else if (namlen == HEf_SVKEY)
4466 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4471 mg->mg_virtual = &PL_vtbl_sv;
4473 case PERL_MAGIC_overload:
4474 mg->mg_virtual = &PL_vtbl_amagic;
4476 case PERL_MAGIC_overload_elem:
4477 mg->mg_virtual = &PL_vtbl_amagicelem;
4479 case PERL_MAGIC_overload_table:
4480 mg->mg_virtual = &PL_vtbl_ovrld;
4483 mg->mg_virtual = &PL_vtbl_bm;
4485 case PERL_MAGIC_regdata:
4486 mg->mg_virtual = &PL_vtbl_regdata;
4488 case PERL_MAGIC_regdatum:
4489 mg->mg_virtual = &PL_vtbl_regdatum;
4491 case PERL_MAGIC_env:
4492 mg->mg_virtual = &PL_vtbl_env;
4495 mg->mg_virtual = &PL_vtbl_fm;
4497 case PERL_MAGIC_envelem:
4498 mg->mg_virtual = &PL_vtbl_envelem;
4500 case PERL_MAGIC_regex_global:
4501 mg->mg_virtual = &PL_vtbl_mglob;
4503 case PERL_MAGIC_isa:
4504 mg->mg_virtual = &PL_vtbl_isa;
4506 case PERL_MAGIC_isaelem:
4507 mg->mg_virtual = &PL_vtbl_isaelem;
4509 case PERL_MAGIC_nkeys:
4510 mg->mg_virtual = &PL_vtbl_nkeys;
4512 case PERL_MAGIC_dbfile:
4516 case PERL_MAGIC_dbline:
4517 mg->mg_virtual = &PL_vtbl_dbline;
4519 #ifdef USE_5005THREADS
4520 case PERL_MAGIC_mutex:
4521 mg->mg_virtual = &PL_vtbl_mutex;
4523 #endif /* USE_5005THREADS */
4524 #ifdef USE_LOCALE_COLLATE
4525 case PERL_MAGIC_collxfrm:
4526 mg->mg_virtual = &PL_vtbl_collxfrm;
4528 #endif /* USE_LOCALE_COLLATE */
4529 case PERL_MAGIC_tied:
4530 mg->mg_virtual = &PL_vtbl_pack;
4532 case PERL_MAGIC_tiedelem:
4533 case PERL_MAGIC_tiedscalar:
4534 mg->mg_virtual = &PL_vtbl_packelem;
4537 mg->mg_virtual = &PL_vtbl_regexp;
4539 case PERL_MAGIC_sig:
4540 mg->mg_virtual = &PL_vtbl_sig;
4542 case PERL_MAGIC_sigelem:
4543 mg->mg_virtual = &PL_vtbl_sigelem;
4545 case PERL_MAGIC_taint:
4546 mg->mg_virtual = &PL_vtbl_taint;
4549 case PERL_MAGIC_uvar:
4550 mg->mg_virtual = &PL_vtbl_uvar;
4552 case PERL_MAGIC_vec:
4553 mg->mg_virtual = &PL_vtbl_vec;
4555 case PERL_MAGIC_substr:
4556 mg->mg_virtual = &PL_vtbl_substr;
4558 case PERL_MAGIC_defelem:
4559 mg->mg_virtual = &PL_vtbl_defelem;
4561 case PERL_MAGIC_glob:
4562 mg->mg_virtual = &PL_vtbl_glob;
4564 case PERL_MAGIC_arylen:
4565 mg->mg_virtual = &PL_vtbl_arylen;
4567 case PERL_MAGIC_pos:
4568 mg->mg_virtual = &PL_vtbl_pos;
4570 case PERL_MAGIC_backref:
4571 mg->mg_virtual = &PL_vtbl_backref;
4573 case PERL_MAGIC_ext:
4574 /* Reserved for use by extensions not perl internals. */
4575 /* Useful for attaching extension internal data to perl vars. */
4576 /* Note that multiple extensions may clash if magical scalars */
4577 /* etc holding private data from one are passed to another. */
4581 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4585 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4589 =for apidoc sv_unmagic
4591 Removes all magic of type C<type> from an SV.
4597 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4601 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4604 for (mg = *mgp; mg; mg = *mgp) {
4605 if (mg->mg_type == type) {
4606 MGVTBL* vtbl = mg->mg_virtual;
4607 *mgp = mg->mg_moremagic;
4608 if (vtbl && vtbl->svt_free)
4609 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4610 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4611 if (mg->mg_len >= 0)
4612 Safefree(mg->mg_ptr);
4613 else if (mg->mg_len == HEf_SVKEY)
4614 SvREFCNT_dec((SV*)mg->mg_ptr);
4616 if (mg->mg_flags & MGf_REFCOUNTED)
4617 SvREFCNT_dec(mg->mg_obj);
4621 mgp = &mg->mg_moremagic;
4625 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4632 =for apidoc sv_rvweaken
4634 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4635 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4636 push a back-reference to this RV onto the array of backreferences
4637 associated with that magic.
4643 Perl_sv_rvweaken(pTHX_ SV *sv)
4646 if (!SvOK(sv)) /* let undefs pass */
4649 Perl_croak(aTHX_ "Can't weaken a nonreference");
4650 else if (SvWEAKREF(sv)) {
4651 if (ckWARN(WARN_MISC))
4652 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4656 sv_add_backref(tsv, sv);
4662 /* Give tsv backref magic if it hasn't already got it, then push a
4663 * back-reference to sv onto the array associated with the backref magic.
4667 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4671 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4672 av = (AV*)mg->mg_obj;
4675 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4676 SvREFCNT_dec(av); /* for sv_magic */
4681 /* delete a back-reference to ourselves from the backref magic associated
4682 * with the SV we point to.
4686 S_sv_del_backref(pTHX_ SV *sv)
4693 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4694 Perl_croak(aTHX_ "panic: del_backref");
4695 av = (AV *)mg->mg_obj;
4700 svp[i] = &PL_sv_undef; /* XXX */
4707 =for apidoc sv_insert
4709 Inserts a string at the specified offset/length within the SV. Similar to
4710 the Perl substr() function.
4716 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4720 register char *midend;
4721 register char *bigend;
4727 Perl_croak(aTHX_ "Can't modify non-existent substring");
4728 SvPV_force(bigstr, curlen);
4729 (void)SvPOK_only_UTF8(bigstr);
4730 if (offset + len > curlen) {
4731 SvGROW(bigstr, offset+len+1);
4732 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4733 SvCUR_set(bigstr, offset+len);
4737 i = littlelen - len;
4738 if (i > 0) { /* string might grow */
4739 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4740 mid = big + offset + len;
4741 midend = bigend = big + SvCUR(bigstr);
4744 while (midend > mid) /* shove everything down */
4745 *--bigend = *--midend;
4746 Move(little,big+offset,littlelen,char);
4752 Move(little,SvPVX(bigstr)+offset,len,char);
4757 big = SvPVX(bigstr);
4760 bigend = big + SvCUR(bigstr);
4762 if (midend > bigend)
4763 Perl_croak(aTHX_ "panic: sv_insert");
4765 if (mid - big > bigend - midend) { /* faster to shorten from end */
4767 Move(little, mid, littlelen,char);
4770 i = bigend - midend;
4772 Move(midend, mid, i,char);
4776 SvCUR_set(bigstr, mid - big);
4779 else if ((i = mid - big)) { /* faster from front */
4780 midend -= littlelen;
4782 sv_chop(bigstr,midend-i);
4787 Move(little, mid, littlelen,char);
4789 else if (littlelen) {
4790 midend -= littlelen;
4791 sv_chop(bigstr,midend);
4792 Move(little,midend,littlelen,char);
4795 sv_chop(bigstr,midend);
4801 =for apidoc sv_replace
4803 Make the first argument a copy of the second, then delete the original.
4804 The target SV physically takes over ownership of the body of the source SV
4805 and inherits its flags; however, the target keeps any magic it owns,
4806 and any magic in the source is discarded.
4807 Note that this is a rather specialist SV copying operation; most of the
4808 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4814 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4816 U32 refcnt = SvREFCNT(sv);
4817 SV_CHECK_THINKFIRST(sv);
4818 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4819 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4820 if (SvMAGICAL(sv)) {
4824 sv_upgrade(nsv, SVt_PVMG);
4825 SvMAGIC(nsv) = SvMAGIC(sv);
4826 SvFLAGS(nsv) |= SvMAGICAL(sv);
4832 assert(!SvREFCNT(sv));
4833 StructCopy(nsv,sv,SV);
4834 SvREFCNT(sv) = refcnt;
4835 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4840 =for apidoc sv_clear
4842 Clear an SV: call any destructors, free up any memory used by the body,
4843 and free the body itself. The SV's head is I<not> freed, although
4844 its type is set to all 1's so that it won't inadvertently be assumed
4845 to be live during global destruction etc.
4846 This function should only be called when REFCNT is zero. Most of the time
4847 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4854 Perl_sv_clear(pTHX_ register SV *sv)
4858 assert(SvREFCNT(sv) == 0);
4861 if (PL_defstash) { /* Still have a symbol table? */
4866 Zero(&tmpref, 1, SV);
4867 sv_upgrade(&tmpref, SVt_RV);
4869 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4870 SvREFCNT(&tmpref) = 1;
4873 stash = SvSTASH(sv);
4874 destructor = StashHANDLER(stash,DESTROY);
4877 PUSHSTACKi(PERLSI_DESTROY);
4878 SvRV(&tmpref) = SvREFCNT_inc(sv);
4883 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4889 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4891 del_XRV(SvANY(&tmpref));
4894 if (PL_in_clean_objs)
4895 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4897 /* DESTROY gave object new lease on life */
4903 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4904 SvOBJECT_off(sv); /* Curse the object. */
4905 if (SvTYPE(sv) != SVt_PVIO)
4906 --PL_sv_objcount; /* XXX Might want something more general */
4909 if (SvTYPE(sv) >= SVt_PVMG) {
4912 if (SvFLAGS(sv) & SVpad_TYPED)
4913 SvREFCNT_dec(SvSTASH(sv));
4916 switch (SvTYPE(sv)) {
4919 IoIFP(sv) != PerlIO_stdin() &&
4920 IoIFP(sv) != PerlIO_stdout() &&
4921 IoIFP(sv) != PerlIO_stderr())
4923 io_close((IO*)sv, FALSE);
4925 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4926 PerlDir_close(IoDIRP(sv));
4927 IoDIRP(sv) = (DIR*)NULL;
4928 Safefree(IoTOP_NAME(sv));
4929 Safefree(IoFMT_NAME(sv));
4930 Safefree(IoBOTTOM_NAME(sv));
4945 SvREFCNT_dec(LvTARG(sv));
4949 Safefree(GvNAME(sv));
4950 /* cannot decrease stash refcount yet, as we might recursively delete
4951 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4952 of stash until current sv is completely gone.
4953 -- JohnPC, 27 Mar 1998 */
4954 stash = GvSTASH(sv);
4960 (void)SvOOK_off(sv);
4968 SvREFCNT_dec(SvRV(sv));
4970 else if (SvPVX(sv) && SvLEN(sv))
4971 Safefree(SvPVX(sv));
4972 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4973 unsharepvn(SvPVX(sv),
4974 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
4987 switch (SvTYPE(sv)) {
5003 del_XPVIV(SvANY(sv));
5006 del_XPVNV(SvANY(sv));
5009 del_XPVMG(SvANY(sv));
5012 del_XPVLV(SvANY(sv));
5015 del_XPVAV(SvANY(sv));
5018 del_XPVHV(SvANY(sv));
5021 del_XPVCV(SvANY(sv));
5024 del_XPVGV(SvANY(sv));
5025 /* code duplication for increased performance. */
5026 SvFLAGS(sv) &= SVf_BREAK;
5027 SvFLAGS(sv) |= SVTYPEMASK;
5028 /* decrease refcount of the stash that owns this GV, if any */
5030 SvREFCNT_dec(stash);
5031 return; /* not break, SvFLAGS reset already happened */
5033 del_XPVBM(SvANY(sv));
5036 del_XPVFM(SvANY(sv));
5039 del_XPVIO(SvANY(sv));
5042 SvFLAGS(sv) &= SVf_BREAK;
5043 SvFLAGS(sv) |= SVTYPEMASK;
5047 =for apidoc sv_newref
5049 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5056 Perl_sv_newref(pTHX_ SV *sv)
5059 ATOMIC_INC(SvREFCNT(sv));
5066 Decrement an SV's reference count, and if it drops to zero, call
5067 C<sv_clear> to invoke destructors and free up any memory used by
5068 the body; finally, deallocate the SV's head itself.
5069 Normally called via a wrapper macro C<SvREFCNT_dec>.
5075 Perl_sv_free(pTHX_ SV *sv)
5077 int refcount_is_zero;
5081 if (SvREFCNT(sv) == 0) {
5082 if (SvFLAGS(sv) & SVf_BREAK)
5083 /* this SV's refcnt has been artificially decremented to
5084 * trigger cleanup */
5086 if (PL_in_clean_all) /* All is fair */
5088 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5089 /* make sure SvREFCNT(sv)==0 happens very seldom */
5090 SvREFCNT(sv) = (~(U32)0)/2;
5093 if (ckWARN_d(WARN_INTERNAL))
5094 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5097 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5098 if (!refcount_is_zero)
5102 if (ckWARN_d(WARN_DEBUGGING))
5103 Perl_warner(aTHX_ WARN_DEBUGGING,
5104 "Attempt to free temp prematurely: SV 0x%"UVxf,
5109 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5110 /* make sure SvREFCNT(sv)==0 happens very seldom */
5111 SvREFCNT(sv) = (~(U32)0)/2;
5122 Returns the length of the string in the SV. Handles magic and type
5123 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5129 Perl_sv_len(pTHX_ register SV *sv)
5137 len = mg_length(sv);
5139 (void)SvPV(sv, len);
5144 =for apidoc sv_len_utf8
5146 Returns the number of characters in the string in an SV, counting wide
5147 UTF8 bytes as a single character. Handles magic and type coercion.
5153 Perl_sv_len_utf8(pTHX_ register SV *sv)
5159 return mg_length(sv);
5163 U8 *s = (U8*)SvPV(sv, len);
5165 return Perl_utf8_length(aTHX_ s, s + len);
5170 =for apidoc sv_pos_u2b
5172 Converts the value pointed to by offsetp from a count of UTF8 chars from
5173 the start of the string, to a count of the equivalent number of bytes; if
5174 lenp is non-zero, it does the same to lenp, but this time starting from
5175 the offset, rather than from the start of the string. Handles magic and
5182 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5187 I32 uoffset = *offsetp;
5193 start = s = (U8*)SvPV(sv, len);
5195 while (s < send && uoffset--)
5199 *offsetp = s - start;
5203 while (s < send && ulen--)
5213 =for apidoc sv_pos_b2u
5215 Converts the value pointed to by offsetp from a count of bytes from the
5216 start of the string, to a count of the equivalent number of UTF8 chars.
5217 Handles magic and type coercion.
5223 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5232 s = (U8*)SvPV(sv, len);
5234 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5235 send = s + *offsetp;
5239 /* Call utf8n_to_uvchr() to validate the sequence */
5240 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5255 Returns a boolean indicating whether the strings in the two SVs are
5256 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5257 coerce its args to strings if necessary.
5263 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5277 pv1 = SvPV(sv1, cur1);
5284 pv2 = SvPV(sv2, cur2);
5286 /* do not utf8ize the comparands as a side-effect */
5287 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5288 bool is_utf8 = TRUE;
5289 /* UTF-8ness differs */
5292 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5293 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5298 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5299 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5304 /* Downgrade not possible - cannot be eq */
5310 eq = memEQ(pv1, pv2, cur1);
5321 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5322 string in C<sv1> is less than, equal to, or greater than the string in
5323 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5324 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5330 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5335 bool pv1tmp = FALSE;
5336 bool pv2tmp = FALSE;
5343 pv1 = SvPV(sv1, cur1);
5350 pv2 = SvPV(sv2, cur2);
5352 /* do not utf8ize the comparands as a side-effect */
5353 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5355 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5359 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5365 cmp = cur2 ? -1 : 0;
5369 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5372 cmp = retval < 0 ? -1 : 1;
5373 } else if (cur1 == cur2) {
5376 cmp = cur1 < cur2 ? -1 : 1;
5389 =for apidoc sv_cmp_locale
5391 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5392 'use bytes' aware, handles get magic, and will coerce its args to strings
5393 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5399 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5401 #ifdef USE_LOCALE_COLLATE
5407 if (PL_collation_standard)
5411 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5413 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5415 if (!pv1 || !len1) {
5426 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5429 return retval < 0 ? -1 : 1;
5432 * When the result of collation is equality, that doesn't mean
5433 * that there are no differences -- some locales exclude some
5434 * characters from consideration. So to avoid false equalities,
5435 * we use the raw string as a tiebreaker.
5441 #endif /* USE_LOCALE_COLLATE */
5443 return sv_cmp(sv1, sv2);
5447 #ifdef USE_LOCALE_COLLATE
5450 =for apidoc sv_collxfrm
5452 Add Collate Transform magic to an SV if it doesn't already have it.
5454 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5455 scalar data of the variable, but transformed to such a format that a normal
5456 memory comparison can be used to compare the data according to the locale
5463 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5467 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5468 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5473 Safefree(mg->mg_ptr);
5475 if ((xf = mem_collxfrm(s, len, &xlen))) {
5476 if (SvREADONLY(sv)) {
5479 return xf + sizeof(PL_collation_ix);
5482 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5483 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5496 if (mg && mg->mg_ptr) {
5498 return mg->mg_ptr + sizeof(PL_collation_ix);
5506 #endif /* USE_LOCALE_COLLATE */
5511 Get a line from the filehandle and store it into the SV, optionally
5512 appending to the currently-stored string.
5518 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5522 register STDCHAR rslast;
5523 register STDCHAR *bp;
5528 SV_CHECK_THINKFIRST(sv);
5529 (void)SvUPGRADE(sv, SVt_PV);
5533 if (PL_curcop == &PL_compiling) {
5534 /* we always read code in line mode */
5538 else if (RsSNARF(PL_rs)) {
5542 else if (RsRECORD(PL_rs)) {
5543 I32 recsize, bytesread;
5546 /* Grab the size of the record we're getting */
5547 recsize = SvIV(SvRV(PL_rs));
5548 (void)SvPOK_only(sv); /* Validate pointer */
5549 buffer = SvGROW(sv, recsize + 1);
5552 /* VMS wants read instead of fread, because fread doesn't respect */
5553 /* RMS record boundaries. This is not necessarily a good thing to be */
5554 /* doing, but we've got no other real choice */
5555 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5557 bytesread = PerlIO_read(fp, buffer, recsize);
5559 SvCUR_set(sv, bytesread);
5560 buffer[bytesread] = '\0';
5561 if (PerlIO_isutf8(fp))
5565 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5567 else if (RsPARA(PL_rs)) {
5573 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5574 if (PerlIO_isutf8(fp)) {
5575 rsptr = SvPVutf8(PL_rs, rslen);
5578 if (SvUTF8(PL_rs)) {
5579 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5580 Perl_croak(aTHX_ "Wide character in $/");
5583 rsptr = SvPV(PL_rs, rslen);
5587 rslast = rslen ? rsptr[rslen - 1] : '\0';
5589 if (rspara) { /* have to do this both before and after */
5590 do { /* to make sure file boundaries work right */
5593 i = PerlIO_getc(fp);
5597 PerlIO_ungetc(fp,i);
5603 /* See if we know enough about I/O mechanism to cheat it ! */
5605 /* This used to be #ifdef test - it is made run-time test for ease
5606 of abstracting out stdio interface. One call should be cheap
5607 enough here - and may even be a macro allowing compile
5611 if (PerlIO_fast_gets(fp)) {
5614 * We're going to steal some values from the stdio struct
5615 * and put EVERYTHING in the innermost loop into registers.
5617 register STDCHAR *ptr;
5621 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5622 /* An ungetc()d char is handled separately from the regular
5623 * buffer, so we getc() it back out and stuff it in the buffer.
5625 i = PerlIO_getc(fp);
5626 if (i == EOF) return 0;
5627 *(--((*fp)->_ptr)) = (unsigned char) i;
5631 /* Here is some breathtakingly efficient cheating */
5633 cnt = PerlIO_get_cnt(fp); /* get count into register */
5634 (void)SvPOK_only(sv); /* validate pointer */
5635 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5636 if (cnt > 80 && SvLEN(sv) > append) {
5637 shortbuffered = cnt - SvLEN(sv) + append + 1;
5638 cnt -= shortbuffered;
5642 /* remember that cnt can be negative */
5643 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5648 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5649 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5650 DEBUG_P(PerlIO_printf(Perl_debug_log,
5651 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5652 DEBUG_P(PerlIO_printf(Perl_debug_log,
5653 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5654 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5655 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5660 while (cnt > 0) { /* this | eat */
5662 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5663 goto thats_all_folks; /* screams | sed :-) */
5667 Copy(ptr, bp, cnt, char); /* this | eat */
5668 bp += cnt; /* screams | dust */
5669 ptr += cnt; /* louder | sed :-) */
5674 if (shortbuffered) { /* oh well, must extend */
5675 cnt = shortbuffered;
5677 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5679 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5680 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5684 DEBUG_P(PerlIO_printf(Perl_debug_log,
5685 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5686 PTR2UV(ptr),(long)cnt));
5687 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5688 DEBUG_P(PerlIO_printf(Perl_debug_log,
5689 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5690 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5691 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5692 /* This used to call 'filbuf' in stdio form, but as that behaves like
5693 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5694 another abstraction. */
5695 i = PerlIO_getc(fp); /* get more characters */
5696 DEBUG_P(PerlIO_printf(Perl_debug_log,
5697 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5698 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5699 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5700 cnt = PerlIO_get_cnt(fp);
5701 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5702 DEBUG_P(PerlIO_printf(Perl_debug_log,
5703 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5705 if (i == EOF) /* all done for ever? */
5706 goto thats_really_all_folks;
5708 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5710 SvGROW(sv, bpx + cnt + 2);
5711 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5713 *bp++ = i; /* store character from PerlIO_getc */
5715 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5716 goto thats_all_folks;
5720 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5721 memNE((char*)bp - rslen, rsptr, rslen))
5722 goto screamer; /* go back to the fray */
5723 thats_really_all_folks:
5725 cnt += shortbuffered;
5726 DEBUG_P(PerlIO_printf(Perl_debug_log,
5727 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5728 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5729 DEBUG_P(PerlIO_printf(Perl_debug_log,
5730 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5731 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5732 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5734 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5735 DEBUG_P(PerlIO_printf(Perl_debug_log,
5736 "Screamer: done, len=%ld, string=|%.*s|\n",
5737 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5742 /*The big, slow, and stupid way */
5745 /* Need to work around EPOC SDK features */
5746 /* On WINS: MS VC5 generates calls to _chkstk, */
5747 /* if a `large' stack frame is allocated */
5748 /* gcc on MARM does not generate calls like these */
5754 register STDCHAR *bpe = buf + sizeof(buf);
5756 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5757 ; /* keep reading */
5761 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5762 /* Accomodate broken VAXC compiler, which applies U8 cast to
5763 * both args of ?: operator, causing EOF to change into 255
5765 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5769 sv_catpvn(sv, (char *) buf, cnt);
5771 sv_setpvn(sv, (char *) buf, cnt);
5773 if (i != EOF && /* joy */
5775 SvCUR(sv) < rslen ||
5776 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5780 * If we're reading from a TTY and we get a short read,
5781 * indicating that the user hit his EOF character, we need
5782 * to notice it now, because if we try to read from the TTY
5783 * again, the EOF condition will disappear.
5785 * The comparison of cnt to sizeof(buf) is an optimization
5786 * that prevents unnecessary calls to feof().
5790 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5795 if (rspara) { /* have to do this both before and after */
5796 while (i != EOF) { /* to make sure file boundaries work right */
5797 i = PerlIO_getc(fp);
5799 PerlIO_ungetc(fp,i);
5805 if (PerlIO_isutf8(fp))
5810 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5816 Auto-increment of the value in the SV, doing string to numeric conversion
5817 if necessary. Handles 'get' magic.
5823 Perl_sv_inc(pTHX_ register SV *sv)
5832 if (SvTHINKFIRST(sv)) {
5833 if (SvREADONLY(sv)) {
5834 if (PL_curcop != &PL_compiling)
5835 Perl_croak(aTHX_ PL_no_modify);
5839 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5841 i = PTR2IV(SvRV(sv));
5846 flags = SvFLAGS(sv);
5847 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5848 /* It's (privately or publicly) a float, but not tested as an
5849 integer, so test it to see. */
5851 flags = SvFLAGS(sv);
5853 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5854 /* It's publicly an integer, or privately an integer-not-float */
5855 #ifdef PERL_PRESERVE_IVUV
5859 if (SvUVX(sv) == UV_MAX)
5860 sv_setnv(sv, (NV)UV_MAX + 1.0);
5862 (void)SvIOK_only_UV(sv);
5865 if (SvIVX(sv) == IV_MAX)
5866 sv_setuv(sv, (UV)IV_MAX + 1);
5868 (void)SvIOK_only(sv);
5874 if (flags & SVp_NOK) {
5875 (void)SvNOK_only(sv);
5880 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5881 if ((flags & SVTYPEMASK) < SVt_PVIV)
5882 sv_upgrade(sv, SVt_IV);
5883 (void)SvIOK_only(sv);
5888 while (isALPHA(*d)) d++;
5889 while (isDIGIT(*d)) d++;
5891 #ifdef PERL_PRESERVE_IVUV
5892 /* Got to punt this an an integer if needs be, but we don't issue
5893 warnings. Probably ought to make the sv_iv_please() that does
5894 the conversion if possible, and silently. */
5895 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5896 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5897 /* Need to try really hard to see if it's an integer.
5898 9.22337203685478e+18 is an integer.
5899 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5900 so $a="9.22337203685478e+18"; $a+0; $a++
5901 needs to be the same as $a="9.22337203685478e+18"; $a++
5908 /* sv_2iv *should* have made this an NV */
5909 if (flags & SVp_NOK) {
5910 (void)SvNOK_only(sv);
5914 /* I don't think we can get here. Maybe I should assert this
5915 And if we do get here I suspect that sv_setnv will croak. NWC
5917 #if defined(USE_LONG_DOUBLE)
5918 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",
5919 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5921 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5922 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5925 #endif /* PERL_PRESERVE_IVUV */
5926 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5930 while (d >= SvPVX(sv)) {
5938 /* MKS: The original code here died if letters weren't consecutive.
5939 * at least it didn't have to worry about non-C locales. The
5940 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5941 * arranged in order (although not consecutively) and that only
5942 * [A-Za-z] are accepted by isALPHA in the C locale.
5944 if (*d != 'z' && *d != 'Z') {
5945 do { ++*d; } while (!isALPHA(*d));
5948 *(d--) -= 'z' - 'a';
5953 *(d--) -= 'z' - 'a' + 1;
5957 /* oh,oh, the number grew */
5958 SvGROW(sv, SvCUR(sv) + 2);
5960 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5971 Auto-decrement of the value in the SV, doing string to numeric conversion
5972 if necessary. Handles 'get' magic.
5978 Perl_sv_dec(pTHX_ register SV *sv)
5986 if (SvTHINKFIRST(sv)) {
5987 if (SvREADONLY(sv)) {
5988 if (PL_curcop != &PL_compiling)
5989 Perl_croak(aTHX_ PL_no_modify);
5993 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5995 i = PTR2IV(SvRV(sv));
6000 /* Unlike sv_inc we don't have to worry about string-never-numbers
6001 and keeping them magic. But we mustn't warn on punting */
6002 flags = SvFLAGS(sv);
6003 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6004 /* It's publicly an integer, or privately an integer-not-float */
6005 #ifdef PERL_PRESERVE_IVUV
6009 if (SvUVX(sv) == 0) {
6010 (void)SvIOK_only(sv);
6014 (void)SvIOK_only_UV(sv);
6018 if (SvIVX(sv) == IV_MIN)
6019 sv_setnv(sv, (NV)IV_MIN - 1.0);
6021 (void)SvIOK_only(sv);
6027 if (flags & SVp_NOK) {
6029 (void)SvNOK_only(sv);
6032 if (!(flags & SVp_POK)) {
6033 if ((flags & SVTYPEMASK) < SVt_PVNV)
6034 sv_upgrade(sv, SVt_NV);
6036 (void)SvNOK_only(sv);
6039 #ifdef PERL_PRESERVE_IVUV
6041 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6042 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6043 /* Need to try really hard to see if it's an integer.
6044 9.22337203685478e+18 is an integer.
6045 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6046 so $a="9.22337203685478e+18"; $a+0; $a--
6047 needs to be the same as $a="9.22337203685478e+18"; $a--
6054 /* sv_2iv *should* have made this an NV */
6055 if (flags & SVp_NOK) {
6056 (void)SvNOK_only(sv);
6060 /* I don't think we can get here. Maybe I should assert this
6061 And if we do get here I suspect that sv_setnv will croak. NWC
6063 #if defined(USE_LONG_DOUBLE)
6064 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",
6065 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6067 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6068 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6072 #endif /* PERL_PRESERVE_IVUV */
6073 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6077 =for apidoc sv_mortalcopy
6079 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6080 The new SV is marked as mortal. It will be destroyed "soon", either by an
6081 explicit call to FREETMPS, or by an implicit call at places such as
6082 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6087 /* Make a string that will exist for the duration of the expression
6088 * evaluation. Actually, it may have to last longer than that, but
6089 * hopefully we won't free it until it has been assigned to a
6090 * permanent location. */
6093 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6098 sv_setsv(sv,oldstr);
6100 PL_tmps_stack[++PL_tmps_ix] = sv;
6106 =for apidoc sv_newmortal
6108 Creates a new null SV which is mortal. The reference count of the SV is
6109 set to 1. It will be destroyed "soon", either by an explicit call to
6110 FREETMPS, or by an implicit call at places such as statement boundaries.
6111 See also C<sv_mortalcopy> and C<sv_2mortal>.
6117 Perl_sv_newmortal(pTHX)
6122 SvFLAGS(sv) = SVs_TEMP;
6124 PL_tmps_stack[++PL_tmps_ix] = sv;
6129 =for apidoc sv_2mortal
6131 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6132 by an explicit call to FREETMPS, or by an implicit call at places such as
6133 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6139 Perl_sv_2mortal(pTHX_ register SV *sv)
6143 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6146 PL_tmps_stack[++PL_tmps_ix] = sv;
6154 Creates a new SV and copies a string into it. The reference count for the
6155 SV is set to 1. If C<len> is zero, Perl will compute the length using
6156 strlen(). For efficiency, consider using C<newSVpvn> instead.
6162 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6169 sv_setpvn(sv,s,len);
6174 =for apidoc newSVpvn
6176 Creates a new SV and copies a string into it. The reference count for the
6177 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6178 string. You are responsible for ensuring that the source string is at least
6185 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6190 sv_setpvn(sv,s,len);
6195 =for apidoc newSVpvn_share
6197 Creates a new SV with its SvPVX pointing to a shared string in the string
6198 table. If the string does not already exist in the table, it is created
6199 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6200 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6201 otherwise the hash is computed. The idea here is that as the string table
6202 is used for shared hash keys these strings will have SvPVX == HeKEY and
6203 hash lookup will avoid string compare.
6209 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6212 bool is_utf8 = FALSE;
6214 STRLEN tmplen = -len;
6216 /* See the note in hv.c:hv_fetch() --jhi */
6217 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6221 PERL_HASH(hash, src, len);
6223 sv_upgrade(sv, SVt_PVIV);
6224 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6237 #if defined(PERL_IMPLICIT_CONTEXT)
6239 /* pTHX_ magic can't cope with varargs, so this is a no-context
6240 * version of the main function, (which may itself be aliased to us).
6241 * Don't access this version directly.
6245 Perl_newSVpvf_nocontext(const char* pat, ...)
6250 va_start(args, pat);
6251 sv = vnewSVpvf(pat, &args);
6258 =for apidoc newSVpvf
6260 Creates a new SV and initializes it with the string formatted like
6267 Perl_newSVpvf(pTHX_ const char* pat, ...)
6271 va_start(args, pat);
6272 sv = vnewSVpvf(pat, &args);
6277 /* backend for newSVpvf() and newSVpvf_nocontext() */
6280 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6284 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6291 Creates a new SV and copies a floating point value into it.
6292 The reference count for the SV is set to 1.
6298 Perl_newSVnv(pTHX_ NV n)
6310 Creates a new SV and copies an integer into it. The reference count for the
6317 Perl_newSViv(pTHX_ IV i)
6329 Creates a new SV and copies an unsigned integer into it.
6330 The reference count for the SV is set to 1.
6336 Perl_newSVuv(pTHX_ UV u)
6346 =for apidoc newRV_noinc
6348 Creates an RV wrapper for an SV. The reference count for the original
6349 SV is B<not> incremented.
6355 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6360 sv_upgrade(sv, SVt_RV);
6367 /* newRV_inc is the official function name to use now.
6368 * newRV_inc is in fact #defined to newRV in sv.h
6372 Perl_newRV(pTHX_ SV *tmpRef)
6374 return newRV_noinc(SvREFCNT_inc(tmpRef));
6380 Creates a new SV which is an exact duplicate of the original SV.
6387 Perl_newSVsv(pTHX_ register SV *old)
6393 if (SvTYPE(old) == SVTYPEMASK) {
6394 if (ckWARN_d(WARN_INTERNAL))
6395 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6410 =for apidoc sv_reset
6412 Underlying implementation for the C<reset> Perl function.
6413 Note that the perl-level function is vaguely deprecated.
6419 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6427 char todo[PERL_UCHAR_MAX+1];
6432 if (!*s) { /* reset ?? searches */
6433 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6434 pm->op_pmdynflags &= ~PMdf_USED;
6439 /* reset variables */
6441 if (!HvARRAY(stash))
6444 Zero(todo, 256, char);
6446 i = (unsigned char)*s;
6450 max = (unsigned char)*s++;
6451 for ( ; i <= max; i++) {
6454 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6455 for (entry = HvARRAY(stash)[i];
6457 entry = HeNEXT(entry))
6459 if (!todo[(U8)*HeKEY(entry)])
6461 gv = (GV*)HeVAL(entry);
6463 if (SvTHINKFIRST(sv)) {
6464 if (!SvREADONLY(sv) && SvROK(sv))
6469 if (SvTYPE(sv) >= SVt_PV) {
6471 if (SvPVX(sv) != Nullch)
6478 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6480 #ifdef USE_ENVIRON_ARRAY
6482 environ[0] = Nullch;
6493 Using various gambits, try to get an IO from an SV: the IO slot if its a
6494 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6495 named after the PV if we're a string.
6501 Perl_sv_2io(pTHX_ SV *sv)
6507 switch (SvTYPE(sv)) {
6515 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6519 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6521 return sv_2io(SvRV(sv));
6522 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6528 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6537 Using various gambits, try to get a CV from an SV; in addition, try if
6538 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6544 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6551 return *gvp = Nullgv, Nullcv;
6552 switch (SvTYPE(sv)) {
6571 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6572 tryAMAGICunDEREF(to_cv);
6575 if (SvTYPE(sv) == SVt_PVCV) {
6584 Perl_croak(aTHX_ "Not a subroutine reference");
6589 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6595 if (lref && !GvCVu(gv)) {
6598 tmpsv = NEWSV(704,0);
6599 gv_efullname3(tmpsv, gv, Nullch);
6600 /* XXX this is probably not what they think they're getting.
6601 * It has the same effect as "sub name;", i.e. just a forward
6603 newSUB(start_subparse(FALSE, 0),
6604 newSVOP(OP_CONST, 0, tmpsv),
6609 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6618 Returns true if the SV has a true value by Perl's rules.
6619 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6620 instead use an in-line version.
6626 Perl_sv_true(pTHX_ register SV *sv)
6632 if ((tXpv = (XPV*)SvANY(sv)) &&
6633 (tXpv->xpv_cur > 1 ||
6634 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6641 return SvIVX(sv) != 0;
6644 return SvNVX(sv) != 0.0;
6646 return sv_2bool(sv);
6654 A private implementation of the C<SvIVx> macro for compilers which can't
6655 cope with complex macro expressions. Always use the macro instead.
6661 Perl_sv_iv(pTHX_ register SV *sv)
6665 return (IV)SvUVX(sv);
6674 A private implementation of the C<SvUVx> macro for compilers which can't
6675 cope with complex macro expressions. Always use the macro instead.
6681 Perl_sv_uv(pTHX_ register SV *sv)
6686 return (UV)SvIVX(sv);
6694 A private implementation of the C<SvNVx> macro for compilers which can't
6695 cope with complex macro expressions. Always use the macro instead.
6701 Perl_sv_nv(pTHX_ register SV *sv)
6711 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6712 cope with complex macro expressions. Always use the macro instead.
6718 Perl_sv_pv(pTHX_ SV *sv)
6725 return sv_2pv(sv, &n_a);
6731 A private implementation of the C<SvPV> macro for compilers which can't
6732 cope with complex macro expressions. Always use the macro instead.
6738 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6744 return sv_2pv(sv, lp);
6747 /* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
6751 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
6757 return sv_2pv_flags(sv, lp, 0);
6761 =for apidoc sv_pvn_force
6763 Get a sensible string out of the SV somehow.
6764 A private implementation of the C<SvPV_force> macro for compilers which
6765 can't cope with complex macro expressions. Always use the macro instead.
6771 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6773 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6777 =for apidoc sv_pvn_force_flags
6779 Get a sensible string out of the SV somehow.
6780 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6781 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6782 implemented in terms of this function.
6783 You normally want to use the various wrapper macros instead: see
6784 C<SvPV_force> and C<SvPV_force_nomg>
6790 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6794 if (SvTHINKFIRST(sv) && !SvROK(sv))
6795 sv_force_normal(sv);
6801 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6802 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6806 s = sv_2pv_flags(sv, lp, flags);
6807 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6812 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6813 SvGROW(sv, len + 1);
6814 Move(s,SvPVX(sv),len,char);
6819 SvPOK_on(sv); /* validate pointer */
6821 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6822 PTR2UV(sv),SvPVX(sv)));
6829 =for apidoc sv_pvbyte
6831 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6832 which can't cope with complex macro expressions. Always use the macro
6839 Perl_sv_pvbyte(pTHX_ SV *sv)
6841 sv_utf8_downgrade(sv,0);
6846 =for apidoc sv_pvbyten
6848 A private implementation of the C<SvPVbyte> macro for compilers
6849 which can't cope with complex macro expressions. Always use the macro
6856 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6858 sv_utf8_downgrade(sv,0);
6859 return sv_pvn(sv,lp);
6863 =for apidoc sv_pvbyten_force
6865 A private implementation of the C<SvPVbytex_force> macro for compilers
6866 which can't cope with complex macro expressions. Always use the macro
6873 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6875 sv_utf8_downgrade(sv,0);
6876 return sv_pvn_force(sv,lp);
6880 =for apidoc sv_pvutf8
6882 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6883 which can't cope with complex macro expressions. Always use the macro
6890 Perl_sv_pvutf8(pTHX_ SV *sv)
6892 sv_utf8_upgrade(sv);
6897 =for apidoc sv_pvutf8n
6899 A private implementation of the C<SvPVutf8> macro for compilers
6900 which can't cope with complex macro expressions. Always use the macro
6907 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6909 sv_utf8_upgrade(sv);
6910 return sv_pvn(sv,lp);
6914 =for apidoc sv_pvutf8n_force
6916 A private implementation of the C<SvPVutf8_force> macro for compilers
6917 which can't cope with complex macro expressions. Always use the macro
6924 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6926 sv_utf8_upgrade(sv);
6927 return sv_pvn_force(sv,lp);
6931 =for apidoc sv_reftype
6933 Returns a string describing what the SV is a reference to.
6939 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6941 if (ob && SvOBJECT(sv))
6942 return HvNAME(SvSTASH(sv));
6944 switch (SvTYPE(sv)) {
6958 case SVt_PVLV: return "LVALUE";
6959 case SVt_PVAV: return "ARRAY";
6960 case SVt_PVHV: return "HASH";
6961 case SVt_PVCV: return "CODE";
6962 case SVt_PVGV: return "GLOB";
6963 case SVt_PVFM: return "FORMAT";
6964 case SVt_PVIO: return "IO";
6965 default: return "UNKNOWN";
6971 =for apidoc sv_isobject
6973 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6974 object. If the SV is not an RV, or if the object is not blessed, then this
6981 Perl_sv_isobject(pTHX_ SV *sv)
6998 Returns a boolean indicating whether the SV is blessed into the specified
6999 class. This does not check for subtypes; use C<sv_derived_from> to verify
7000 an inheritance relationship.
7006 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7018 return strEQ(HvNAME(SvSTASH(sv)), name);
7024 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7025 it will be upgraded to one. If C<classname> is non-null then the new SV will
7026 be blessed in the specified package. The new SV is returned and its
7027 reference count is 1.
7033 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7039 SV_CHECK_THINKFIRST(rv);
7042 if (SvTYPE(rv) >= SVt_PVMG) {
7043 U32 refcnt = SvREFCNT(rv);
7047 SvREFCNT(rv) = refcnt;
7050 if (SvTYPE(rv) < SVt_RV)
7051 sv_upgrade(rv, SVt_RV);
7052 else if (SvTYPE(rv) > SVt_RV) {
7053 (void)SvOOK_off(rv);
7054 if (SvPVX(rv) && SvLEN(rv))
7055 Safefree(SvPVX(rv));
7065 HV* stash = gv_stashpv(classname, TRUE);
7066 (void)sv_bless(rv, stash);
7072 =for apidoc sv_setref_pv
7074 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7075 argument will be upgraded to an RV. That RV will be modified to point to
7076 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7077 into the SV. The C<classname> argument indicates the package for the
7078 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7079 will be returned and will have a reference count of 1.
7081 Do not use with other Perl types such as HV, AV, SV, CV, because those
7082 objects will become corrupted by the pointer copy process.
7084 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7090 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7093 sv_setsv(rv, &PL_sv_undef);
7097 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7102 =for apidoc sv_setref_iv
7104 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7105 argument will be upgraded to an RV. That RV will be modified to point to
7106 the new SV. The C<classname> argument indicates the package for the
7107 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7108 will be returned and will have a reference count of 1.
7114 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7116 sv_setiv(newSVrv(rv,classname), iv);
7121 =for apidoc sv_setref_uv
7123 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7124 argument will be upgraded to an RV. That RV will be modified to point to
7125 the new SV. The C<classname> argument indicates the package for the
7126 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7127 will be returned and will have a reference count of 1.
7133 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7135 sv_setuv(newSVrv(rv,classname), uv);
7140 =for apidoc sv_setref_nv
7142 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7143 argument will be upgraded to an RV. That RV will be modified to point to
7144 the new SV. The C<classname> argument indicates the package for the
7145 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7146 will be returned and will have a reference count of 1.
7152 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7154 sv_setnv(newSVrv(rv,classname), nv);
7159 =for apidoc sv_setref_pvn
7161 Copies a string into a new SV, optionally blessing the SV. The length of the
7162 string must be specified with C<n>. The C<rv> argument will be upgraded to
7163 an RV. That RV will be modified to point to the new SV. The C<classname>
7164 argument indicates the package for the blessing. Set C<classname> to
7165 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7166 a reference count of 1.
7168 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7174 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7176 sv_setpvn(newSVrv(rv,classname), pv, n);
7181 =for apidoc sv_bless
7183 Blesses an SV into a specified package. The SV must be an RV. The package
7184 must be designated by its stash (see C<gv_stashpv()>). The reference count
7185 of the SV is unaffected.
7191 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7195 Perl_croak(aTHX_ "Can't bless non-reference value");
7197 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7198 if (SvREADONLY(tmpRef))
7199 Perl_croak(aTHX_ PL_no_modify);
7200 if (SvOBJECT(tmpRef)) {
7201 if (SvTYPE(tmpRef) != SVt_PVIO)
7203 SvREFCNT_dec(SvSTASH(tmpRef));
7206 SvOBJECT_on(tmpRef);
7207 if (SvTYPE(tmpRef) != SVt_PVIO)
7209 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7210 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7217 if(SvSMAGICAL(tmpRef))
7218 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7226 /* Downgrades a PVGV to a PVMG.
7228 * XXX This function doesn't actually appear to be used anywhere
7233 S_sv_unglob(pTHX_ SV *sv)
7237 assert(SvTYPE(sv) == SVt_PVGV);
7242 SvREFCNT_dec(GvSTASH(sv));
7243 GvSTASH(sv) = Nullhv;
7245 sv_unmagic(sv, PERL_MAGIC_glob);
7246 Safefree(GvNAME(sv));
7249 /* need to keep SvANY(sv) in the right arena */
7250 xpvmg = new_XPVMG();
7251 StructCopy(SvANY(sv), xpvmg, XPVMG);
7252 del_XPVGV(SvANY(sv));
7255 SvFLAGS(sv) &= ~SVTYPEMASK;
7256 SvFLAGS(sv) |= SVt_PVMG;
7260 =for apidoc sv_unref_flags
7262 Unsets the RV status of the SV, and decrements the reference count of
7263 whatever was being referenced by the RV. This can almost be thought of
7264 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7265 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7266 (otherwise the decrementing is conditional on the reference count being
7267 different from one or the reference being a readonly SV).
7274 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7278 if (SvWEAKREF(sv)) {
7286 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7288 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7289 sv_2mortal(rv); /* Schedule for freeing later */
7293 =for apidoc sv_unref
7295 Unsets the RV status of the SV, and decrements the reference count of
7296 whatever was being referenced by the RV. This can almost be thought of
7297 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7298 being zero. See C<SvROK_off>.
7304 Perl_sv_unref(pTHX_ SV *sv)
7306 sv_unref_flags(sv, 0);
7310 =for apidoc sv_taint
7312 Taint an SV. Use C<SvTAINTED_on> instead.
7317 Perl_sv_taint(pTHX_ SV *sv)
7319 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7323 =for apidoc sv_untaint
7325 Untaint an SV. Use C<SvTAINTED_off> instead.
7330 Perl_sv_untaint(pTHX_ SV *sv)
7332 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7333 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7340 =for apidoc sv_tainted
7342 Test an SV for taintedness. Use C<SvTAINTED> instead.
7347 Perl_sv_tainted(pTHX_ SV *sv)
7349 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7350 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7351 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7358 =for apidoc sv_setpviv
7360 Copies an integer into the given SV, also updating its string value.
7361 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7367 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7369 char buf[TYPE_CHARS(UV)];
7371 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7373 sv_setpvn(sv, ptr, ebuf - ptr);
7377 =for apidoc sv_setpviv_mg
7379 Like C<sv_setpviv>, but also handles 'set' magic.
7385 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7387 char buf[TYPE_CHARS(UV)];
7389 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7391 sv_setpvn(sv, ptr, ebuf - ptr);
7395 #if defined(PERL_IMPLICIT_CONTEXT)
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_nocontext(SV *sv, const char* pat, ...)
7407 va_start(args, pat);
7408 sv_vsetpvf(sv, pat, &args);
7412 /* pTHX_ magic can't cope with varargs, so this is a no-context
7413 * version of the main function, (which may itself be aliased to us).
7414 * Don't access this version directly.
7418 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7422 va_start(args, pat);
7423 sv_vsetpvf_mg(sv, pat, &args);
7429 =for apidoc sv_setpvf
7431 Processes its arguments like C<sprintf> and sets an SV to the formatted
7432 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7438 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7441 va_start(args, pat);
7442 sv_vsetpvf(sv, pat, &args);
7446 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7449 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7451 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7455 =for apidoc sv_setpvf_mg
7457 Like C<sv_setpvf>, but also handles 'set' magic.
7463 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7466 va_start(args, pat);
7467 sv_vsetpvf_mg(sv, pat, &args);
7471 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7474 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7476 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7480 #if defined(PERL_IMPLICIT_CONTEXT)
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_nocontext(SV *sv, const char* pat, ...)
7492 va_start(args, pat);
7493 sv_vcatpvf(sv, pat, &args);
7497 /* pTHX_ magic can't cope with varargs, so this is a no-context
7498 * version of the main function, (which may itself be aliased to us).
7499 * Don't access this version directly.
7503 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7507 va_start(args, pat);
7508 sv_vcatpvf_mg(sv, pat, &args);
7514 =for apidoc sv_catpvf
7516 Processes its arguments like C<sprintf> and appends the formatted
7517 output to an SV. If the appended data contains "wide" characters
7518 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7519 and characters >255 formatted with %c), the original SV might get
7520 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7521 C<SvSETMAGIC()> must typically be called after calling this function
7522 to handle 'set' magic.
7527 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7530 va_start(args, pat);
7531 sv_vcatpvf(sv, pat, &args);
7535 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7538 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7540 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7544 =for apidoc sv_catpvf_mg
7546 Like C<sv_catpvf>, but also handles 'set' magic.
7552 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7555 va_start(args, pat);
7556 sv_vcatpvf_mg(sv, pat, &args);
7560 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7563 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7565 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7570 =for apidoc sv_vsetpvfn
7572 Works like C<vcatpvfn> but copies the text into the SV instead of
7575 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7581 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7583 sv_setpvn(sv, "", 0);
7584 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7587 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7590 S_expect_number(pTHX_ char** pattern)
7593 switch (**pattern) {
7594 case '1': case '2': case '3':
7595 case '4': case '5': case '6':
7596 case '7': case '8': case '9':
7597 while (isDIGIT(**pattern))
7598 var = var * 10 + (*(*pattern)++ - '0');
7602 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7605 =for apidoc sv_vcatpvfn
7607 Processes its arguments like C<vsprintf> and appends the formatted output
7608 to an SV. Uses an array of SVs if the C style variable argument list is
7609 missing (NULL). When running with taint checks enabled, indicates via
7610 C<maybe_tainted> if results are untrustworthy (often due to the use of
7613 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7619 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7626 static char nullstr[] = "(null)";
7629 /* no matter what, this is a string now */
7630 (void)SvPV_force(sv, origlen);
7632 /* special-case "", "%s", and "%_" */
7635 if (patlen == 2 && pat[0] == '%') {
7639 char *s = va_arg(*args, char*);
7640 sv_catpv(sv, s ? s : nullstr);
7642 else if (svix < svmax) {
7643 sv_catsv(sv, *svargs);
7644 if (DO_UTF8(*svargs))
7650 argsv = va_arg(*args, SV*);
7651 sv_catsv(sv, argsv);
7656 /* See comment on '_' below */
7661 patend = (char*)pat + patlen;
7662 for (p = (char*)pat; p < patend; p = q) {
7665 bool vectorize = FALSE;
7666 bool vectorarg = FALSE;
7667 bool vec_utf = FALSE;
7673 bool has_precis = FALSE;
7675 bool is_utf = FALSE;
7678 U8 utf8buf[UTF8_MAXLEN+1];
7679 STRLEN esignlen = 0;
7681 char *eptr = Nullch;
7683 /* Times 4: a decimal digit takes more than 3 binary digits.
7684 * NV_DIG: mantissa takes than many decimal digits.
7685 * Plus 32: Playing safe. */
7686 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7687 /* large enough for "%#.#f" --chip */
7688 /* what about long double NVs? --jhi */
7691 U8 *vecstr = Null(U8*);
7703 STRLEN dotstrlen = 1;
7704 I32 efix = 0; /* explicit format parameter index */
7705 I32 ewix = 0; /* explicit width index */
7706 I32 epix = 0; /* explicit precision index */
7707 I32 evix = 0; /* explicit vector index */
7708 bool asterisk = FALSE;
7710 /* echo everything up to the next format specification */
7711 for (q = p; q < patend && *q != '%'; ++q) ;
7713 sv_catpvn(sv, p, q - p);
7720 We allow format specification elements in this order:
7721 \d+\$ explicit format parameter index
7723 \*?(\d+\$)?v vector with optional (optionally specified) arg
7724 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7725 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7727 [%bcdefginopsux_DFOUX] format (mandatory)
7729 if (EXPECT_NUMBER(q, width)) {
7770 if (EXPECT_NUMBER(q, ewix))
7779 if ((vectorarg = asterisk)) {
7789 EXPECT_NUMBER(q, width);
7794 vecsv = va_arg(*args, SV*);
7796 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7797 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7798 dotstr = SvPVx(vecsv, dotstrlen);
7803 vecsv = va_arg(*args, SV*);
7804 vecstr = (U8*)SvPVx(vecsv,veclen);
7805 vec_utf = DO_UTF8(vecsv);
7807 else if (efix ? efix <= svmax : svix < svmax) {
7808 vecsv = svargs[efix ? efix-1 : svix++];
7809 vecstr = (U8*)SvPVx(vecsv,veclen);
7810 vec_utf = DO_UTF8(vecsv);
7820 i = va_arg(*args, int);
7822 i = (ewix ? ewix <= svmax : svix < svmax) ?
7823 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7825 width = (i < 0) ? -i : i;
7835 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7838 i = va_arg(*args, int);
7840 i = (ewix ? ewix <= svmax : svix < svmax)
7841 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7842 precis = (i < 0) ? 0 : i;
7847 precis = precis * 10 + (*q++ - '0');
7855 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7866 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7867 if (*(q + 1) == 'l') { /* lld, llf */
7890 argsv = (efix ? efix <= svmax : svix < svmax) ?
7891 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7898 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7900 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7902 eptr = (char*)utf8buf;
7903 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7915 eptr = va_arg(*args, char*);
7917 #ifdef MACOS_TRADITIONAL
7918 /* On MacOS, %#s format is used for Pascal strings */
7923 elen = strlen(eptr);
7926 elen = sizeof nullstr - 1;
7930 eptr = SvPVx(argsv, elen);
7931 if (DO_UTF8(argsv)) {
7932 if (has_precis && precis < elen) {
7934 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7937 if (width) { /* fudge width (can't fudge elen) */
7938 width += elen - sv_len_utf8(argsv);
7947 * The "%_" hack might have to be changed someday,
7948 * if ISO or ANSI decide to use '_' for something.
7949 * So we keep it hidden from users' code.
7953 argsv = va_arg(*args, SV*);
7954 eptr = SvPVx(argsv, elen);
7960 if (has_precis && elen > precis)
7969 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7987 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
7995 esignbuf[esignlen++] = plus;
7999 case 'h': iv = (short)va_arg(*args, int); break;
8000 default: iv = va_arg(*args, int); break;
8001 case 'l': iv = va_arg(*args, long); break;
8002 case 'V': iv = va_arg(*args, IV); break;
8004 case 'q': iv = va_arg(*args, Quad_t); break;
8011 case 'h': iv = (short)iv; break;
8013 case 'l': iv = (long)iv; break;
8016 case 'q': iv = (Quad_t)iv; break;
8020 if ( !vectorize ) /* we already set uv above */
8025 esignbuf[esignlen++] = plus;
8029 esignbuf[esignlen++] = '-';
8072 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8082 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8083 default: uv = va_arg(*args, unsigned); break;
8084 case 'l': uv = va_arg(*args, unsigned long); break;
8085 case 'V': uv = va_arg(*args, UV); break;
8087 case 'q': uv = va_arg(*args, Quad_t); break;
8094 case 'h': uv = (unsigned short)uv; break;
8096 case 'l': uv = (unsigned long)uv; break;
8099 case 'q': uv = (Quad_t)uv; break;
8105 eptr = ebuf + sizeof ebuf;
8111 p = (char*)((c == 'X')
8112 ? "0123456789ABCDEF" : "0123456789abcdef");
8118 esignbuf[esignlen++] = '0';
8119 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8125 *--eptr = '0' + dig;
8127 if (alt && *eptr != '0')
8133 *--eptr = '0' + dig;
8136 esignbuf[esignlen++] = '0';
8137 esignbuf[esignlen++] = 'b';
8140 default: /* it had better be ten or less */
8141 #if defined(PERL_Y2KWARN)
8142 if (ckWARN(WARN_Y2K)) {
8144 char *s = SvPV(sv,n);
8145 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8146 && (n == 2 || !isDIGIT(s[n-3])))
8148 Perl_warner(aTHX_ WARN_Y2K,
8149 "Possible Y2K bug: %%%c %s",
8150 c, "format string following '19'");
8156 *--eptr = '0' + dig;
8157 } while (uv /= base);
8160 elen = (ebuf + sizeof ebuf) - eptr;
8163 zeros = precis - elen;
8164 else if (precis == 0 && elen == 1 && *eptr == '0')
8169 /* FLOATING POINT */
8172 c = 'f'; /* maybe %F isn't supported here */
8178 /* This is evil, but floating point is even more evil */
8181 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8184 if (c != 'e' && c != 'E') {
8186 (void)Perl_frexp(nv, &i);
8187 if (i == PERL_INT_MIN)
8188 Perl_die(aTHX_ "panic: frexp");
8190 need = BIT_DIGITS(i);
8192 need += has_precis ? precis : 6; /* known default */
8196 need += 20; /* fudge factor */
8197 if (PL_efloatsize < need) {
8198 Safefree(PL_efloatbuf);
8199 PL_efloatsize = need + 20; /* more fudge */
8200 New(906, PL_efloatbuf, PL_efloatsize, char);
8201 PL_efloatbuf[0] = '\0';
8204 eptr = ebuf + sizeof ebuf;
8207 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8209 /* Copy the one or more characters in a long double
8210 * format before the 'base' ([efgEFG]) character to
8211 * the format string. */
8212 static char const prifldbl[] = PERL_PRIfldbl;
8213 char const *p = prifldbl + sizeof(prifldbl) - 3;
8214 while (p >= prifldbl) { *--eptr = *p--; }
8219 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8224 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8236 /* No taint. Otherwise we are in the strange situation
8237 * where printf() taints but print($float) doesn't.
8239 (void)sprintf(PL_efloatbuf, eptr, nv);
8241 eptr = PL_efloatbuf;
8242 elen = strlen(PL_efloatbuf);
8249 i = SvCUR(sv) - origlen;
8252 case 'h': *(va_arg(*args, short*)) = i; break;
8253 default: *(va_arg(*args, int*)) = i; break;
8254 case 'l': *(va_arg(*args, long*)) = i; break;
8255 case 'V': *(va_arg(*args, IV*)) = i; break;
8257 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8262 sv_setuv_mg(argsv, (UV)i);
8263 continue; /* not "break" */
8270 if (!args && ckWARN(WARN_PRINTF) &&
8271 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8272 SV *msg = sv_newmortal();
8273 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8274 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8277 Perl_sv_catpvf(aTHX_ msg,
8278 "\"%%%c\"", c & 0xFF);
8280 Perl_sv_catpvf(aTHX_ msg,
8281 "\"%%\\%03"UVof"\"",
8284 sv_catpv(msg, "end of string");
8285 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8288 /* output mangled stuff ... */
8294 /* ... right here, because formatting flags should not apply */
8295 SvGROW(sv, SvCUR(sv) + elen + 1);
8297 Copy(eptr, p, elen, char);
8300 SvCUR(sv) = p - SvPVX(sv);
8301 continue; /* not "break" */
8304 have = esignlen + zeros + elen;
8305 need = (have > width ? have : width);
8308 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8310 if (esignlen && fill == '0') {
8311 for (i = 0; i < esignlen; i++)
8315 memset(p, fill, gap);
8318 if (esignlen && fill != '0') {
8319 for (i = 0; i < esignlen; i++)
8323 for (i = zeros; i; i--)
8327 Copy(eptr, p, elen, char);
8331 memset(p, ' ', gap);
8336 Copy(dotstr, p, dotstrlen, char);
8340 vectorize = FALSE; /* done iterating over vecstr */
8345 SvCUR(sv) = p - SvPVX(sv);
8353 /* =========================================================================
8355 =head1 Cloning an interpreter
8357 All the macros and functions in this section are for the private use of
8358 the main function, perl_clone().
8360 The foo_dup() functions make an exact copy of an existing foo thinngy.
8361 During the course of a cloning, a hash table is used to map old addresses
8362 to new addresses. The table is created and manipulated with the
8363 ptr_table_* functions.
8367 ============================================================================*/
8370 #if defined(USE_ITHREADS)
8372 #if defined(USE_5005THREADS)
8373 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8376 #ifndef GpREFCNT_inc
8377 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8381 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8382 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8383 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8384 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8385 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8386 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8387 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8388 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8389 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8390 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8391 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8392 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8393 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8396 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8397 regcomp.c. AMS 20010712 */
8400 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8404 struct reg_substr_datum *s;
8407 return (REGEXP *)NULL;
8409 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8412 len = r->offsets[0];
8413 npar = r->nparens+1;
8415 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8416 Copy(r->program, ret->program, len+1, regnode);
8418 New(0, ret->startp, npar, I32);
8419 Copy(r->startp, ret->startp, npar, I32);
8420 New(0, ret->endp, npar, I32);
8421 Copy(r->startp, ret->startp, npar, I32);
8423 New(0, ret->substrs, 1, struct reg_substr_data);
8424 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8425 s->min_offset = r->substrs->data[i].min_offset;
8426 s->max_offset = r->substrs->data[i].max_offset;
8427 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8430 ret->regstclass = NULL;
8433 int count = r->data->count;
8435 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8436 char, struct reg_data);
8437 New(0, d->what, count, U8);
8440 for (i = 0; i < count; i++) {
8441 d->what[i] = r->data->what[i];
8442 switch (d->what[i]) {
8444 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8447 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8450 /* This is cheating. */
8451 New(0, d->data[i], 1, struct regnode_charclass_class);
8452 StructCopy(r->data->data[i], d->data[i],
8453 struct regnode_charclass_class);
8454 ret->regstclass = (regnode*)d->data[i];
8457 /* Compiled op trees are readonly, and can thus be
8458 shared without duplication. */
8459 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8462 d->data[i] = r->data->data[i];
8472 New(0, ret->offsets, 2*len+1, U32);
8473 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8475 ret->precomp = SAVEPV(r->precomp);
8476 ret->refcnt = r->refcnt;
8477 ret->minlen = r->minlen;
8478 ret->prelen = r->prelen;
8479 ret->nparens = r->nparens;
8480 ret->lastparen = r->lastparen;
8481 ret->lastcloseparen = r->lastcloseparen;
8482 ret->reganch = r->reganch;
8484 ret->sublen = r->sublen;
8486 if (RX_MATCH_COPIED(ret))
8487 ret->subbeg = SAVEPV(r->subbeg);
8489 ret->subbeg = Nullch;
8491 ptr_table_store(PL_ptr_table, r, ret);
8495 /* duplicate a file handle */
8498 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8502 return (PerlIO*)NULL;
8504 /* look for it in the table first */
8505 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8509 /* create anew and remember what it is */
8510 ret = PerlIO_fdupopen(aTHX_ fp, param);
8511 ptr_table_store(PL_ptr_table, fp, ret);
8515 /* duplicate a directory handle */
8518 Perl_dirp_dup(pTHX_ DIR *dp)
8526 /* duplicate a typeglob */
8529 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8534 /* look for it in the table first */
8535 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8539 /* create anew and remember what it is */
8540 Newz(0, ret, 1, GP);
8541 ptr_table_store(PL_ptr_table, gp, ret);
8544 ret->gp_refcnt = 0; /* must be before any other dups! */
8545 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8546 ret->gp_io = io_dup_inc(gp->gp_io, param);
8547 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8548 ret->gp_av = av_dup_inc(gp->gp_av, param);
8549 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8550 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8551 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8552 ret->gp_cvgen = gp->gp_cvgen;
8553 ret->gp_flags = gp->gp_flags;
8554 ret->gp_line = gp->gp_line;
8555 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8559 /* duplicate a chain of magic */
8562 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8564 MAGIC *mgprev = (MAGIC*)NULL;
8567 return (MAGIC*)NULL;
8568 /* look for it in the table first */
8569 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8573 for (; mg; mg = mg->mg_moremagic) {
8575 Newz(0, nmg, 1, MAGIC);
8577 mgprev->mg_moremagic = nmg;
8580 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8581 nmg->mg_private = mg->mg_private;
8582 nmg->mg_type = mg->mg_type;
8583 nmg->mg_flags = mg->mg_flags;
8584 if (mg->mg_type == PERL_MAGIC_qr) {
8585 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8587 else if(mg->mg_type == PERL_MAGIC_backref) {
8588 AV *av = (AV*) mg->mg_obj;
8591 nmg->mg_obj = (SV*)newAV();
8595 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8600 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8601 ? sv_dup_inc(mg->mg_obj, param)
8602 : sv_dup(mg->mg_obj, param);
8604 nmg->mg_len = mg->mg_len;
8605 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8606 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8607 if (mg->mg_len >= 0) {
8608 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8609 if (mg->mg_type == PERL_MAGIC_overload_table &&
8610 AMT_AMAGIC((AMT*)mg->mg_ptr))
8612 AMT *amtp = (AMT*)mg->mg_ptr;
8613 AMT *namtp = (AMT*)nmg->mg_ptr;
8615 for (i = 1; i < NofAMmeth; i++) {
8616 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8620 else if (mg->mg_len == HEf_SVKEY)
8621 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8628 /* create a new pointer-mapping table */
8631 Perl_ptr_table_new(pTHX)
8634 Newz(0, tbl, 1, PTR_TBL_t);
8637 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8641 /* map an existing pointer using a table */
8644 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8646 PTR_TBL_ENT_t *tblent;
8647 UV hash = PTR2UV(sv);
8649 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8650 for (; tblent; tblent = tblent->next) {
8651 if (tblent->oldval == sv)
8652 return tblent->newval;
8657 /* add a new entry to a pointer-mapping table */
8660 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8662 PTR_TBL_ENT_t *tblent, **otblent;
8663 /* XXX this may be pessimal on platforms where pointers aren't good
8664 * hash values e.g. if they grow faster in the most significant
8666 UV hash = PTR2UV(oldv);
8670 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8671 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8672 if (tblent->oldval == oldv) {
8673 tblent->newval = newv;
8678 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8679 tblent->oldval = oldv;
8680 tblent->newval = newv;
8681 tblent->next = *otblent;
8684 if (i && tbl->tbl_items > tbl->tbl_max)
8685 ptr_table_split(tbl);
8688 /* double the hash bucket size of an existing ptr table */
8691 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8693 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8694 UV oldsize = tbl->tbl_max + 1;
8695 UV newsize = oldsize * 2;
8698 Renew(ary, newsize, PTR_TBL_ENT_t*);
8699 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8700 tbl->tbl_max = --newsize;
8702 for (i=0; i < oldsize; i++, ary++) {
8703 PTR_TBL_ENT_t **curentp, **entp, *ent;
8706 curentp = ary + oldsize;
8707 for (entp = ary, ent = *ary; ent; ent = *entp) {
8708 if ((newsize & PTR2UV(ent->oldval)) != i) {
8710 ent->next = *curentp;
8720 /* remove all the entries from a ptr table */
8723 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8725 register PTR_TBL_ENT_t **array;
8726 register PTR_TBL_ENT_t *entry;
8727 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8731 if (!tbl || !tbl->tbl_items) {
8735 array = tbl->tbl_ary;
8742 entry = entry->next;
8746 if (++riter > max) {
8749 entry = array[riter];
8756 /* clear and free a ptr table */
8759 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8764 ptr_table_clear(tbl);
8765 Safefree(tbl->tbl_ary);
8773 /* attempt to make everything in the typeglob readonly */
8776 S_gv_share(pTHX_ SV *sstr)
8779 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8781 if (GvIO(gv) || GvFORM(gv)) {
8782 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8784 else if (!GvCV(gv)) {
8788 /* CvPADLISTs cannot be shared */
8789 if (!CvXSUB(GvCV(gv))) {
8794 if (!GvUNIQUE(gv)) {
8796 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8797 HvNAME(GvSTASH(gv)), GvNAME(gv));
8803 * write attempts will die with
8804 * "Modification of a read-only value attempted"
8810 SvREADONLY_on(GvSV(gv));
8817 SvREADONLY_on(GvAV(gv));
8824 SvREADONLY_on(GvAV(gv));
8827 return sstr; /* he_dup() will SvREFCNT_inc() */
8830 /* duplicate an SV of any type (including AV, HV etc) */
8833 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
8837 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8839 /* look for it in the table first */
8840 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8844 /* create anew and remember what it is */
8846 ptr_table_store(PL_ptr_table, sstr, dstr);
8849 SvFLAGS(dstr) = SvFLAGS(sstr);
8850 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8851 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8854 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8855 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8856 PL_watch_pvx, SvPVX(sstr));
8859 switch (SvTYPE(sstr)) {
8864 SvANY(dstr) = new_XIV();
8865 SvIVX(dstr) = SvIVX(sstr);
8868 SvANY(dstr) = new_XNV();
8869 SvNVX(dstr) = SvNVX(sstr);
8872 SvANY(dstr) = new_XRV();
8873 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8874 ? sv_dup(SvRV(sstr), param)
8875 : sv_dup_inc(SvRV(sstr), param);
8878 SvANY(dstr) = new_XPV();
8879 SvCUR(dstr) = SvCUR(sstr);
8880 SvLEN(dstr) = SvLEN(sstr);
8882 SvRV(dstr) = SvWEAKREF(sstr)
8883 ? sv_dup(SvRV(sstr), param)
8884 : sv_dup_inc(SvRV(sstr), param);
8885 else if (SvPVX(sstr) && SvLEN(sstr))
8886 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8888 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8891 SvANY(dstr) = new_XPVIV();
8892 SvCUR(dstr) = SvCUR(sstr);
8893 SvLEN(dstr) = SvLEN(sstr);
8894 SvIVX(dstr) = SvIVX(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_XPVNV();
8906 SvCUR(dstr) = SvCUR(sstr);
8907 SvLEN(dstr) = SvLEN(sstr);
8908 SvIVX(dstr) = SvIVX(sstr);
8909 SvNVX(dstr) = SvNVX(sstr);
8911 SvRV(dstr) = SvWEAKREF(sstr)
8912 ? sv_dup(SvRV(sstr), param)
8913 : sv_dup_inc(SvRV(sstr), param);
8914 else if (SvPVX(sstr) && SvLEN(sstr))
8915 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8917 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8920 SvANY(dstr) = new_XPVMG();
8921 SvCUR(dstr) = SvCUR(sstr);
8922 SvLEN(dstr) = SvLEN(sstr);
8923 SvIVX(dstr) = SvIVX(sstr);
8924 SvNVX(dstr) = SvNVX(sstr);
8925 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8926 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8928 SvRV(dstr) = SvWEAKREF(sstr)
8929 ? sv_dup(SvRV(sstr), param)
8930 : sv_dup_inc(SvRV(sstr), param);
8931 else if (SvPVX(sstr) && SvLEN(sstr))
8932 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8934 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8937 SvANY(dstr) = new_XPVBM();
8938 SvCUR(dstr) = SvCUR(sstr);
8939 SvLEN(dstr) = SvLEN(sstr);
8940 SvIVX(dstr) = SvIVX(sstr);
8941 SvNVX(dstr) = SvNVX(sstr);
8942 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8943 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8945 SvRV(dstr) = SvWEAKREF(sstr)
8946 ? sv_dup(SvRV(sstr), param)
8947 : sv_dup_inc(SvRV(sstr), param);
8948 else if (SvPVX(sstr) && SvLEN(sstr))
8949 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8951 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8952 BmRARE(dstr) = BmRARE(sstr);
8953 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8954 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8957 SvANY(dstr) = new_XPVLV();
8958 SvCUR(dstr) = SvCUR(sstr);
8959 SvLEN(dstr) = SvLEN(sstr);
8960 SvIVX(dstr) = SvIVX(sstr);
8961 SvNVX(dstr) = SvNVX(sstr);
8962 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8963 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8965 SvRV(dstr) = SvWEAKREF(sstr)
8966 ? sv_dup(SvRV(sstr), param)
8967 : sv_dup_inc(SvRV(sstr), param);
8968 else if (SvPVX(sstr) && SvLEN(sstr))
8969 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8971 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8972 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8973 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8974 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8975 LvTYPE(dstr) = LvTYPE(sstr);
8978 if (GvUNIQUE((GV*)sstr)) {
8980 if ((share = gv_share(sstr))) {
8984 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8985 HvNAME(GvSTASH(share)), GvNAME(share));
8990 SvANY(dstr) = new_XPVGV();
8991 SvCUR(dstr) = SvCUR(sstr);
8992 SvLEN(dstr) = SvLEN(sstr);
8993 SvIVX(dstr) = SvIVX(sstr);
8994 SvNVX(dstr) = SvNVX(sstr);
8995 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8996 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8998 SvRV(dstr) = SvWEAKREF(sstr)
8999 ? sv_dup(SvRV(sstr), param)
9000 : sv_dup_inc(SvRV(sstr), param);
9001 else if (SvPVX(sstr) && SvLEN(sstr))
9002 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9004 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9005 GvNAMELEN(dstr) = GvNAMELEN(sstr);
9006 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9007 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
9008 GvFLAGS(dstr) = GvFLAGS(sstr);
9009 GvGP(dstr) = gp_dup(GvGP(sstr), param);
9010 (void)GpREFCNT_inc(GvGP(dstr));
9013 SvANY(dstr) = new_XPVIO();
9014 SvCUR(dstr) = SvCUR(sstr);
9015 SvLEN(dstr) = SvLEN(sstr);
9016 SvIVX(dstr) = SvIVX(sstr);
9017 SvNVX(dstr) = SvNVX(sstr);
9018 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9019 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9021 SvRV(dstr) = SvWEAKREF(sstr)
9022 ? sv_dup(SvRV(sstr), param)
9023 : sv_dup_inc(SvRV(sstr), param);
9024 else if (SvPVX(sstr) && SvLEN(sstr))
9025 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9027 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9028 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9029 if (IoOFP(sstr) == IoIFP(sstr))
9030 IoOFP(dstr) = IoIFP(dstr);
9032 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9033 /* PL_rsfp_filters entries have fake IoDIRP() */
9034 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9035 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
9037 IoDIRP(dstr) = IoDIRP(sstr);
9038 IoLINES(dstr) = IoLINES(sstr);
9039 IoPAGE(dstr) = IoPAGE(sstr);
9040 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
9041 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
9042 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
9043 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
9044 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
9045 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
9046 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
9047 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
9048 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
9049 IoTYPE(dstr) = IoTYPE(sstr);
9050 IoFLAGS(dstr) = IoFLAGS(sstr);
9053 SvANY(dstr) = new_XPVAV();
9054 SvCUR(dstr) = SvCUR(sstr);
9055 SvLEN(dstr) = SvLEN(sstr);
9056 SvIVX(dstr) = SvIVX(sstr);
9057 SvNVX(dstr) = SvNVX(sstr);
9058 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9059 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9060 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9061 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9062 if (AvARRAY((AV*)sstr)) {
9063 SV **dst_ary, **src_ary;
9064 SSize_t items = AvFILLp((AV*)sstr) + 1;
9066 src_ary = AvARRAY((AV*)sstr);
9067 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9068 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9069 SvPVX(dstr) = (char*)dst_ary;
9070 AvALLOC((AV*)dstr) = dst_ary;
9071 if (AvREAL((AV*)sstr)) {
9073 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9077 *dst_ary++ = sv_dup(*src_ary++, param);
9079 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9080 while (items-- > 0) {
9081 *dst_ary++ = &PL_sv_undef;
9085 SvPVX(dstr) = Nullch;
9086 AvALLOC((AV*)dstr) = (SV**)NULL;
9090 SvANY(dstr) = new_XPVHV();
9091 SvCUR(dstr) = SvCUR(sstr);
9092 SvLEN(dstr) = SvLEN(sstr);
9093 SvIVX(dstr) = SvIVX(sstr);
9094 SvNVX(dstr) = SvNVX(sstr);
9095 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9096 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9097 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9098 if (HvARRAY((HV*)sstr)) {
9100 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9101 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9102 Newz(0, dxhv->xhv_array,
9103 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9104 while (i <= sxhv->xhv_max) {
9105 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9106 !!HvSHAREKEYS(sstr), param);
9109 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9112 SvPVX(dstr) = Nullch;
9113 HvEITER((HV*)dstr) = (HE*)NULL;
9115 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9116 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9117 /* Record stashes for possible cloning in Perl_clone(). */
9118 if(HvNAME((HV*)dstr))
9119 av_push(param->stashes, dstr);
9122 SvANY(dstr) = new_XPVFM();
9123 FmLINES(dstr) = FmLINES(sstr);
9127 SvANY(dstr) = new_XPVCV();
9129 SvCUR(dstr) = SvCUR(sstr);
9130 SvLEN(dstr) = SvLEN(sstr);
9131 SvIVX(dstr) = SvIVX(sstr);
9132 SvNVX(dstr) = SvNVX(sstr);
9133 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9134 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9135 if (SvPVX(sstr) && SvLEN(sstr))
9136 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9138 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9139 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9140 CvSTART(dstr) = CvSTART(sstr);
9141 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9142 CvXSUB(dstr) = CvXSUB(sstr);
9143 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9144 if (CvCONST(sstr)) {
9145 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9146 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9147 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9149 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9150 if (param->flags & CLONEf_COPY_STACKS) {
9151 CvDEPTH(dstr) = CvDEPTH(sstr);
9155 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9156 /* XXX padlists are real, but pretend to be not */
9157 AvREAL_on(CvPADLIST(sstr));
9158 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9159 AvREAL_off(CvPADLIST(sstr));
9160 AvREAL_off(CvPADLIST(dstr));
9163 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9164 if (!CvANON(sstr) || CvCLONED(sstr))
9165 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9167 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9168 CvFLAGS(dstr) = CvFLAGS(sstr);
9169 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9172 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9176 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9182 /* duplicate a context */
9185 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9190 return (PERL_CONTEXT*)NULL;
9192 /* look for it in the table first */
9193 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9197 /* create anew and remember what it is */
9198 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9199 ptr_table_store(PL_ptr_table, cxs, ncxs);
9202 PERL_CONTEXT *cx = &cxs[ix];
9203 PERL_CONTEXT *ncx = &ncxs[ix];
9204 ncx->cx_type = cx->cx_type;
9205 if (CxTYPE(cx) == CXt_SUBST) {
9206 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9209 ncx->blk_oldsp = cx->blk_oldsp;
9210 ncx->blk_oldcop = cx->blk_oldcop;
9211 ncx->blk_oldretsp = cx->blk_oldretsp;
9212 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9213 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9214 ncx->blk_oldpm = cx->blk_oldpm;
9215 ncx->blk_gimme = cx->blk_gimme;
9216 switch (CxTYPE(cx)) {
9218 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9219 ? cv_dup_inc(cx->blk_sub.cv, param)
9220 : cv_dup(cx->blk_sub.cv,param));
9221 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9222 ? av_dup_inc(cx->blk_sub.argarray, param)
9224 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9225 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9226 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9227 ncx->blk_sub.lval = cx->blk_sub.lval;
9230 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9231 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9232 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9233 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9234 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9237 ncx->blk_loop.label = cx->blk_loop.label;
9238 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9239 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9240 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9241 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9242 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9243 ? cx->blk_loop.iterdata
9244 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9245 ncx->blk_loop.oldcurpad
9246 = (SV**)ptr_table_fetch(PL_ptr_table,
9247 cx->blk_loop.oldcurpad);
9248 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9249 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9250 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9251 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9252 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9255 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9256 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9257 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9258 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9270 /* duplicate a stack info structure */
9273 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9278 return (PERL_SI*)NULL;
9280 /* look for it in the table first */
9281 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9285 /* create anew and remember what it is */
9286 Newz(56, nsi, 1, PERL_SI);
9287 ptr_table_store(PL_ptr_table, si, nsi);
9289 nsi->si_stack = av_dup_inc(si->si_stack, param);
9290 nsi->si_cxix = si->si_cxix;
9291 nsi->si_cxmax = si->si_cxmax;
9292 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9293 nsi->si_type = si->si_type;
9294 nsi->si_prev = si_dup(si->si_prev, param);
9295 nsi->si_next = si_dup(si->si_next, param);
9296 nsi->si_markoff = si->si_markoff;
9301 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9302 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9303 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9304 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9305 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9306 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9307 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9308 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9309 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9310 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9311 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9312 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9315 #define pv_dup_inc(p) SAVEPV(p)
9316 #define pv_dup(p) SAVEPV(p)
9317 #define svp_dup_inc(p,pp) any_dup(p,pp)
9319 /* map any object to the new equivent - either something in the
9320 * ptr table, or something in the interpreter structure
9324 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9331 /* look for it in the table first */
9332 ret = ptr_table_fetch(PL_ptr_table, v);
9336 /* see if it is part of the interpreter structure */
9337 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9338 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9345 /* duplicate the save stack */
9348 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9350 ANY *ss = proto_perl->Tsavestack;
9351 I32 ix = proto_perl->Tsavestack_ix;
9352 I32 max = proto_perl->Tsavestack_max;
9365 void (*dptr) (void*);
9366 void (*dxptr) (pTHX_ void*);
9369 Newz(54, nss, max, ANY);
9375 case SAVEt_ITEM: /* normal string */
9376 sv = (SV*)POPPTR(ss,ix);
9377 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9378 sv = (SV*)POPPTR(ss,ix);
9379 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9381 case SAVEt_SV: /* scalar reference */
9382 sv = (SV*)POPPTR(ss,ix);
9383 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9384 gv = (GV*)POPPTR(ss,ix);
9385 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9387 case SAVEt_GENERIC_PVREF: /* generic char* */
9388 c = (char*)POPPTR(ss,ix);
9389 TOPPTR(nss,ix) = pv_dup(c);
9390 ptr = POPPTR(ss,ix);
9391 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9393 case SAVEt_GENERIC_SVREF: /* generic sv */
9394 case SAVEt_SVREF: /* scalar reference */
9395 sv = (SV*)POPPTR(ss,ix);
9396 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9397 ptr = POPPTR(ss,ix);
9398 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9400 case SAVEt_AV: /* array reference */
9401 av = (AV*)POPPTR(ss,ix);
9402 TOPPTR(nss,ix) = av_dup_inc(av, param);
9403 gv = (GV*)POPPTR(ss,ix);
9404 TOPPTR(nss,ix) = gv_dup(gv, param);
9406 case SAVEt_HV: /* hash reference */
9407 hv = (HV*)POPPTR(ss,ix);
9408 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9409 gv = (GV*)POPPTR(ss,ix);
9410 TOPPTR(nss,ix) = gv_dup(gv, param);
9412 case SAVEt_INT: /* int reference */
9413 ptr = POPPTR(ss,ix);
9414 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9415 intval = (int)POPINT(ss,ix);
9416 TOPINT(nss,ix) = intval;
9418 case SAVEt_LONG: /* long reference */
9419 ptr = POPPTR(ss,ix);
9420 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9421 longval = (long)POPLONG(ss,ix);
9422 TOPLONG(nss,ix) = longval;
9424 case SAVEt_I32: /* I32 reference */
9425 case SAVEt_I16: /* I16 reference */
9426 case SAVEt_I8: /* I8 reference */
9427 ptr = POPPTR(ss,ix);
9428 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9432 case SAVEt_IV: /* IV reference */
9433 ptr = POPPTR(ss,ix);
9434 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9438 case SAVEt_SPTR: /* SV* reference */
9439 ptr = POPPTR(ss,ix);
9440 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9441 sv = (SV*)POPPTR(ss,ix);
9442 TOPPTR(nss,ix) = sv_dup(sv, param);
9444 case SAVEt_VPTR: /* random* reference */
9445 ptr = POPPTR(ss,ix);
9446 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9447 ptr = POPPTR(ss,ix);
9448 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9450 case SAVEt_PPTR: /* char* reference */
9451 ptr = POPPTR(ss,ix);
9452 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9453 c = (char*)POPPTR(ss,ix);
9454 TOPPTR(nss,ix) = pv_dup(c);
9456 case SAVEt_HPTR: /* HV* reference */
9457 ptr = POPPTR(ss,ix);
9458 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9459 hv = (HV*)POPPTR(ss,ix);
9460 TOPPTR(nss,ix) = hv_dup(hv, param);
9462 case SAVEt_APTR: /* AV* reference */
9463 ptr = POPPTR(ss,ix);
9464 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9465 av = (AV*)POPPTR(ss,ix);
9466 TOPPTR(nss,ix) = av_dup(av, param);
9469 gv = (GV*)POPPTR(ss,ix);
9470 TOPPTR(nss,ix) = gv_dup(gv, param);
9472 case SAVEt_GP: /* scalar reference */
9473 gp = (GP*)POPPTR(ss,ix);
9474 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9475 (void)GpREFCNT_inc(gp);
9476 gv = (GV*)POPPTR(ss,ix);
9477 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9478 c = (char*)POPPTR(ss,ix);
9479 TOPPTR(nss,ix) = pv_dup(c);
9486 case SAVEt_MORTALIZESV:
9487 sv = (SV*)POPPTR(ss,ix);
9488 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9491 ptr = POPPTR(ss,ix);
9492 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9493 /* these are assumed to be refcounted properly */
9494 switch (((OP*)ptr)->op_type) {
9501 TOPPTR(nss,ix) = ptr;
9506 TOPPTR(nss,ix) = Nullop;
9511 TOPPTR(nss,ix) = Nullop;
9514 c = (char*)POPPTR(ss,ix);
9515 TOPPTR(nss,ix) = pv_dup_inc(c);
9518 longval = POPLONG(ss,ix);
9519 TOPLONG(nss,ix) = longval;
9522 hv = (HV*)POPPTR(ss,ix);
9523 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9524 c = (char*)POPPTR(ss,ix);
9525 TOPPTR(nss,ix) = pv_dup_inc(c);
9529 case SAVEt_DESTRUCTOR:
9530 ptr = POPPTR(ss,ix);
9531 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9532 dptr = POPDPTR(ss,ix);
9533 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9535 case SAVEt_DESTRUCTOR_X:
9536 ptr = POPPTR(ss,ix);
9537 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9538 dxptr = POPDXPTR(ss,ix);
9539 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9541 case SAVEt_REGCONTEXT:
9547 case SAVEt_STACK_POS: /* Position on Perl stack */
9551 case SAVEt_AELEM: /* array element */
9552 sv = (SV*)POPPTR(ss,ix);
9553 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9556 av = (AV*)POPPTR(ss,ix);
9557 TOPPTR(nss,ix) = av_dup_inc(av, param);
9559 case SAVEt_HELEM: /* hash element */
9560 sv = (SV*)POPPTR(ss,ix);
9561 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9562 sv = (SV*)POPPTR(ss,ix);
9563 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9564 hv = (HV*)POPPTR(ss,ix);
9565 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9568 ptr = POPPTR(ss,ix);
9569 TOPPTR(nss,ix) = ptr;
9576 av = (AV*)POPPTR(ss,ix);
9577 TOPPTR(nss,ix) = av_dup(av, param);
9580 longval = (long)POPLONG(ss,ix);
9581 TOPLONG(nss,ix) = longval;
9582 ptr = POPPTR(ss,ix);
9583 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9584 sv = (SV*)POPPTR(ss,ix);
9585 TOPPTR(nss,ix) = sv_dup(sv, param);
9588 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9596 =for apidoc perl_clone
9598 Create and return a new interpreter by cloning the current one.
9603 /* XXX the above needs expanding by someone who actually understands it ! */
9604 EXTERN_C PerlInterpreter *
9605 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
9608 perl_clone(PerlInterpreter *proto_perl, UV flags)
9610 #ifdef PERL_IMPLICIT_SYS
9612 /* perlhost.h so we need to call into it
9613 to clone the host, CPerlHost should have a c interface, sky */
9615 if (flags & CLONEf_CLONE_HOST) {
9616 return perl_clone_host(proto_perl,flags);
9618 return perl_clone_using(proto_perl, flags,
9620 proto_perl->IMemShared,
9621 proto_perl->IMemParse,
9631 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9632 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9633 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9634 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9635 struct IPerlDir* ipD, struct IPerlSock* ipS,
9636 struct IPerlProc* ipP)
9638 /* XXX many of the string copies here can be optimized if they're
9639 * constants; they need to be allocated as common memory and just
9640 * their pointers copied. */
9643 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9645 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9646 PERL_SET_THX(my_perl);
9649 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9655 # else /* !DEBUGGING */
9656 Zero(my_perl, 1, PerlInterpreter);
9657 # endif /* DEBUGGING */
9661 PL_MemShared = ipMS;
9669 #else /* !PERL_IMPLICIT_SYS */
9671 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9672 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9673 PERL_SET_THX(my_perl);
9678 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9684 # else /* !DEBUGGING */
9685 Zero(my_perl, 1, PerlInterpreter);
9686 # endif /* DEBUGGING */
9687 #endif /* PERL_IMPLICIT_SYS */
9688 param->flags = flags;
9691 PL_xiv_arenaroot = NULL;
9693 PL_xnv_arenaroot = NULL;
9695 PL_xrv_arenaroot = NULL;
9697 PL_xpv_arenaroot = NULL;
9699 PL_xpviv_arenaroot = NULL;
9700 PL_xpviv_root = NULL;
9701 PL_xpvnv_arenaroot = NULL;
9702 PL_xpvnv_root = NULL;
9703 PL_xpvcv_arenaroot = NULL;
9704 PL_xpvcv_root = NULL;
9705 PL_xpvav_arenaroot = NULL;
9706 PL_xpvav_root = NULL;
9707 PL_xpvhv_arenaroot = NULL;
9708 PL_xpvhv_root = NULL;
9709 PL_xpvmg_arenaroot = NULL;
9710 PL_xpvmg_root = NULL;
9711 PL_xpvlv_arenaroot = NULL;
9712 PL_xpvlv_root = NULL;
9713 PL_xpvbm_arenaroot = NULL;
9714 PL_xpvbm_root = NULL;
9715 PL_he_arenaroot = NULL;
9717 PL_nice_chunk = NULL;
9718 PL_nice_chunk_size = 0;
9721 PL_sv_root = Nullsv;
9722 PL_sv_arenaroot = Nullsv;
9724 PL_debug = proto_perl->Idebug;
9726 #ifdef USE_REENTRANT_API
9727 New(31337, PL_reentrant_buffer,1, REBUF);
9728 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9731 /* create SV map for pointer relocation */
9732 PL_ptr_table = ptr_table_new();
9734 /* initialize these special pointers as early as possible */
9735 SvANY(&PL_sv_undef) = NULL;
9736 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9737 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9738 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9740 SvANY(&PL_sv_no) = new_XPVNV();
9741 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9742 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9743 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9744 SvCUR(&PL_sv_no) = 0;
9745 SvLEN(&PL_sv_no) = 1;
9746 SvNVX(&PL_sv_no) = 0;
9747 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9749 SvANY(&PL_sv_yes) = new_XPVNV();
9750 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9751 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9752 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9753 SvCUR(&PL_sv_yes) = 1;
9754 SvLEN(&PL_sv_yes) = 2;
9755 SvNVX(&PL_sv_yes) = 1;
9756 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9758 /* create shared string table */
9759 PL_strtab = newHV();
9760 HvSHAREKEYS_off(PL_strtab);
9761 hv_ksplit(PL_strtab, 512);
9762 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9764 PL_compiling = proto_perl->Icompiling;
9765 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9766 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9767 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9768 if (!specialWARN(PL_compiling.cop_warnings))
9769 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9770 if (!specialCopIO(PL_compiling.cop_io))
9771 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9772 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9774 /* pseudo environmental stuff */
9775 PL_origargc = proto_perl->Iorigargc;
9777 New(0, PL_origargv, i+1, char*);
9778 PL_origargv[i] = '\0';
9780 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9783 param->stashes = newAV(); /* Setup array of objects to call clone on */
9785 #ifdef PERLIO_LAYERS
9786 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
9787 PerlIO_clone(aTHX_ proto_perl, param);
9790 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9791 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9792 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9793 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9794 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9795 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9798 PL_minus_c = proto_perl->Iminus_c;
9799 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9800 PL_localpatches = proto_perl->Ilocalpatches;
9801 PL_splitstr = proto_perl->Isplitstr;
9802 PL_preprocess = proto_perl->Ipreprocess;
9803 PL_minus_n = proto_perl->Iminus_n;
9804 PL_minus_p = proto_perl->Iminus_p;
9805 PL_minus_l = proto_perl->Iminus_l;
9806 PL_minus_a = proto_perl->Iminus_a;
9807 PL_minus_F = proto_perl->Iminus_F;
9808 PL_doswitches = proto_perl->Idoswitches;
9809 PL_dowarn = proto_perl->Idowarn;
9810 PL_doextract = proto_perl->Idoextract;
9811 PL_sawampersand = proto_perl->Isawampersand;
9812 PL_unsafe = proto_perl->Iunsafe;
9813 PL_inplace = SAVEPV(proto_perl->Iinplace);
9814 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9815 PL_perldb = proto_perl->Iperldb;
9816 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9817 PL_exit_flags = proto_perl->Iexit_flags;
9819 /* magical thingies */
9820 /* XXX time(&PL_basetime) when asked for? */
9821 PL_basetime = proto_perl->Ibasetime;
9822 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9824 PL_maxsysfd = proto_perl->Imaxsysfd;
9825 PL_multiline = proto_perl->Imultiline;
9826 PL_statusvalue = proto_perl->Istatusvalue;
9828 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9831 /* Clone the regex array */
9832 PL_regex_padav = newAV();
9834 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9835 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9836 av_push(PL_regex_padav,
9837 sv_dup_inc(regexen[0],param));
9838 for(i = 1; i <= len; i++) {
9839 if(SvREPADTMP(regexen[i])) {
9840 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
9842 av_push(PL_regex_padav,
9844 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
9845 SvIVX(regexen[i])), param)))
9850 PL_regex_pad = AvARRAY(PL_regex_padav);
9852 /* shortcuts to various I/O objects */
9853 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9854 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9855 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9856 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9857 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9858 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9860 /* shortcuts to regexp stuff */
9861 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9863 /* shortcuts to misc objects */
9864 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9866 /* shortcuts to debugging objects */
9867 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9868 PL_DBline = gv_dup(proto_perl->IDBline, param);
9869 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9870 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9871 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9872 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9873 PL_lineary = av_dup(proto_perl->Ilineary, param);
9874 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9877 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9878 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9879 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9880 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9881 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9882 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9884 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9885 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
9886 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9887 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9888 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9890 PL_sub_generation = proto_perl->Isub_generation;
9892 /* funky return mechanisms */
9893 PL_forkprocess = proto_perl->Iforkprocess;
9895 /* subprocess state */
9896 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9898 /* internal state */
9899 PL_tainting = proto_perl->Itainting;
9900 PL_maxo = proto_perl->Imaxo;
9901 if (proto_perl->Iop_mask)
9902 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9904 PL_op_mask = Nullch;
9906 /* current interpreter roots */
9907 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9908 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9909 PL_main_start = proto_perl->Imain_start;
9910 PL_eval_root = proto_perl->Ieval_root;
9911 PL_eval_start = proto_perl->Ieval_start;
9913 /* runtime control stuff */
9914 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9915 PL_copline = proto_perl->Icopline;
9917 PL_filemode = proto_perl->Ifilemode;
9918 PL_lastfd = proto_perl->Ilastfd;
9919 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9922 PL_gensym = proto_perl->Igensym;
9923 PL_preambled = proto_perl->Ipreambled;
9924 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9925 PL_laststatval = proto_perl->Ilaststatval;
9926 PL_laststype = proto_perl->Ilaststype;
9927 PL_mess_sv = Nullsv;
9929 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9930 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9932 /* interpreter atexit processing */
9933 PL_exitlistlen = proto_perl->Iexitlistlen;
9934 if (PL_exitlistlen) {
9935 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9936 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9939 PL_exitlist = (PerlExitListEntry*)NULL;
9940 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9941 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
9942 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
9944 PL_profiledata = NULL;
9945 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
9946 /* PL_rsfp_filters entries have fake IoDIRP() */
9947 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9949 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9950 PL_comppad = av_dup(proto_perl->Icomppad, param);
9951 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9952 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9953 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9954 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9955 proto_perl->Tcurpad);
9957 #ifdef HAVE_INTERP_INTERN
9958 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9961 /* more statics moved here */
9962 PL_generation = proto_perl->Igeneration;
9963 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9965 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9966 PL_in_clean_all = proto_perl->Iin_clean_all;
9968 PL_uid = proto_perl->Iuid;
9969 PL_euid = proto_perl->Ieuid;
9970 PL_gid = proto_perl->Igid;
9971 PL_egid = proto_perl->Iegid;
9972 PL_nomemok = proto_perl->Inomemok;
9973 PL_an = proto_perl->Ian;
9974 PL_cop_seqmax = proto_perl->Icop_seqmax;
9975 PL_op_seqmax = proto_perl->Iop_seqmax;
9976 PL_evalseq = proto_perl->Ievalseq;
9977 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9978 PL_origalen = proto_perl->Iorigalen;
9979 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9980 PL_osname = SAVEPV(proto_perl->Iosname);
9981 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
9982 PL_sighandlerp = proto_perl->Isighandlerp;
9985 PL_runops = proto_perl->Irunops;
9987 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9990 PL_cshlen = proto_perl->Icshlen;
9991 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
9994 PL_lex_state = proto_perl->Ilex_state;
9995 PL_lex_defer = proto_perl->Ilex_defer;
9996 PL_lex_expect = proto_perl->Ilex_expect;
9997 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9998 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9999 PL_lex_starts = proto_perl->Ilex_starts;
10000 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10001 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10002 PL_lex_op = proto_perl->Ilex_op;
10003 PL_lex_inpat = proto_perl->Ilex_inpat;
10004 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10005 PL_lex_brackets = proto_perl->Ilex_brackets;
10006 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10007 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10008 PL_lex_casemods = proto_perl->Ilex_casemods;
10009 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10010 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10012 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10013 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10014 PL_nexttoke = proto_perl->Inexttoke;
10016 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10017 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10018 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10019 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10020 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10021 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10022 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10023 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10024 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10025 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10026 PL_pending_ident = proto_perl->Ipending_ident;
10027 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10029 PL_expect = proto_perl->Iexpect;
10031 PL_multi_start = proto_perl->Imulti_start;
10032 PL_multi_end = proto_perl->Imulti_end;
10033 PL_multi_open = proto_perl->Imulti_open;
10034 PL_multi_close = proto_perl->Imulti_close;
10036 PL_error_count = proto_perl->Ierror_count;
10037 PL_subline = proto_perl->Isubline;
10038 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10040 PL_min_intro_pending = proto_perl->Imin_intro_pending;
10041 PL_max_intro_pending = proto_perl->Imax_intro_pending;
10042 PL_padix = proto_perl->Ipadix;
10043 PL_padix_floor = proto_perl->Ipadix_floor;
10044 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
10046 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10047 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10048 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10049 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10050 PL_last_lop_op = proto_perl->Ilast_lop_op;
10051 PL_in_my = proto_perl->Iin_my;
10052 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10054 PL_cryptseen = proto_perl->Icryptseen;
10057 PL_hints = proto_perl->Ihints;
10059 PL_amagic_generation = proto_perl->Iamagic_generation;
10061 #ifdef USE_LOCALE_COLLATE
10062 PL_collation_ix = proto_perl->Icollation_ix;
10063 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10064 PL_collation_standard = proto_perl->Icollation_standard;
10065 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10066 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10067 #endif /* USE_LOCALE_COLLATE */
10069 #ifdef USE_LOCALE_NUMERIC
10070 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10071 PL_numeric_standard = proto_perl->Inumeric_standard;
10072 PL_numeric_local = proto_perl->Inumeric_local;
10073 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10074 #endif /* !USE_LOCALE_NUMERIC */
10076 /* utf8 character classes */
10077 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10078 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10079 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10080 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10081 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10082 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10083 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10084 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10085 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10086 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10087 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10088 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10089 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10090 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10091 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10092 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10093 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10096 PL_last_swash_hv = Nullhv; /* reinits on demand */
10097 PL_last_swash_klen = 0;
10098 PL_last_swash_key[0]= '\0';
10099 PL_last_swash_tmps = (U8*)NULL;
10100 PL_last_swash_slen = 0;
10102 /* perly.c globals */
10103 PL_yydebug = proto_perl->Iyydebug;
10104 PL_yynerrs = proto_perl->Iyynerrs;
10105 PL_yyerrflag = proto_perl->Iyyerrflag;
10106 PL_yychar = proto_perl->Iyychar;
10107 PL_yyval = proto_perl->Iyyval;
10108 PL_yylval = proto_perl->Iyylval;
10110 PL_glob_index = proto_perl->Iglob_index;
10111 PL_srand_called = proto_perl->Isrand_called;
10112 PL_uudmap['M'] = 0; /* reinits on demand */
10113 PL_bitcount = Nullch; /* reinits on demand */
10115 if (proto_perl->Ipsig_pend) {
10116 Newz(0, PL_psig_pend, SIG_SIZE, int);
10119 PL_psig_pend = (int*)NULL;
10122 if (proto_perl->Ipsig_ptr) {
10123 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10124 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10125 for (i = 1; i < SIG_SIZE; i++) {
10126 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10127 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10131 PL_psig_ptr = (SV**)NULL;
10132 PL_psig_name = (SV**)NULL;
10135 /* thrdvar.h stuff */
10137 if (flags & CLONEf_COPY_STACKS) {
10138 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10139 PL_tmps_ix = proto_perl->Ttmps_ix;
10140 PL_tmps_max = proto_perl->Ttmps_max;
10141 PL_tmps_floor = proto_perl->Ttmps_floor;
10142 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10144 while (i <= PL_tmps_ix) {
10145 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10149 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10150 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10151 Newz(54, PL_markstack, i, I32);
10152 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10153 - proto_perl->Tmarkstack);
10154 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10155 - proto_perl->Tmarkstack);
10156 Copy(proto_perl->Tmarkstack, PL_markstack,
10157 PL_markstack_ptr - PL_markstack + 1, I32);
10159 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10160 * NOTE: unlike the others! */
10161 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10162 PL_scopestack_max = proto_perl->Tscopestack_max;
10163 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10164 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10166 /* next push_return() sets PL_retstack[PL_retstack_ix]
10167 * NOTE: unlike the others! */
10168 PL_retstack_ix = proto_perl->Tretstack_ix;
10169 PL_retstack_max = proto_perl->Tretstack_max;
10170 Newz(54, PL_retstack, PL_retstack_max, OP*);
10171 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10173 /* NOTE: si_dup() looks at PL_markstack */
10174 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10176 /* PL_curstack = PL_curstackinfo->si_stack; */
10177 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10178 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10180 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10181 PL_stack_base = AvARRAY(PL_curstack);
10182 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10183 - proto_perl->Tstack_base);
10184 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10186 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10187 * NOTE: unlike the others! */
10188 PL_savestack_ix = proto_perl->Tsavestack_ix;
10189 PL_savestack_max = proto_perl->Tsavestack_max;
10190 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10191 PL_savestack = ss_dup(proto_perl, param);
10195 ENTER; /* perl_destruct() wants to LEAVE; */
10198 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10199 PL_top_env = &PL_start_env;
10201 PL_op = proto_perl->Top;
10204 PL_Xpv = (XPV*)NULL;
10205 PL_na = proto_perl->Tna;
10207 PL_statbuf = proto_perl->Tstatbuf;
10208 PL_statcache = proto_perl->Tstatcache;
10209 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10210 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10212 PL_timesbuf = proto_perl->Ttimesbuf;
10215 PL_tainted = proto_perl->Ttainted;
10216 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10217 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10218 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10219 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10220 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10221 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10222 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10223 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10224 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10226 PL_restartop = proto_perl->Trestartop;
10227 PL_in_eval = proto_perl->Tin_eval;
10228 PL_delaymagic = proto_perl->Tdelaymagic;
10229 PL_dirty = proto_perl->Tdirty;
10230 PL_localizing = proto_perl->Tlocalizing;
10232 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10233 PL_protect = proto_perl->Tprotect;
10235 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10236 PL_av_fetch_sv = Nullsv;
10237 PL_hv_fetch_sv = Nullsv;
10238 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10239 PL_modcount = proto_perl->Tmodcount;
10240 PL_lastgotoprobe = Nullop;
10241 PL_dumpindent = proto_perl->Tdumpindent;
10243 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10244 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10245 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10246 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10247 PL_sortcxix = proto_perl->Tsortcxix;
10248 PL_efloatbuf = Nullch; /* reinits on demand */
10249 PL_efloatsize = 0; /* reinits on demand */
10253 PL_screamfirst = NULL;
10254 PL_screamnext = NULL;
10255 PL_maxscream = -1; /* reinits on demand */
10256 PL_lastscream = Nullsv;
10258 PL_watchaddr = NULL;
10259 PL_watchok = Nullch;
10261 PL_regdummy = proto_perl->Tregdummy;
10262 PL_regcomp_parse = Nullch;
10263 PL_regxend = Nullch;
10264 PL_regcode = (regnode*)NULL;
10267 PL_regprecomp = Nullch;
10272 PL_seen_zerolen = 0;
10274 PL_regcomp_rx = (regexp*)NULL;
10276 PL_colorset = 0; /* reinits PL_colors[] */
10277 /*PL_colors[6] = {0,0,0,0,0,0};*/
10278 PL_reg_whilem_seen = 0;
10279 PL_reginput = Nullch;
10280 PL_regbol = Nullch;
10281 PL_regeol = Nullch;
10282 PL_regstartp = (I32*)NULL;
10283 PL_regendp = (I32*)NULL;
10284 PL_reglastparen = (U32*)NULL;
10285 PL_regtill = Nullch;
10286 PL_reg_start_tmp = (char**)NULL;
10287 PL_reg_start_tmpl = 0;
10288 PL_regdata = (struct reg_data*)NULL;
10291 PL_reg_eval_set = 0;
10293 PL_regprogram = (regnode*)NULL;
10295 PL_regcc = (CURCUR*)NULL;
10296 PL_reg_call_cc = (struct re_cc_state*)NULL;
10297 PL_reg_re = (regexp*)NULL;
10298 PL_reg_ganch = Nullch;
10299 PL_reg_sv = Nullsv;
10300 PL_reg_match_utf8 = FALSE;
10301 PL_reg_magic = (MAGIC*)NULL;
10303 PL_reg_oldcurpm = (PMOP*)NULL;
10304 PL_reg_curpm = (PMOP*)NULL;
10305 PL_reg_oldsaved = Nullch;
10306 PL_reg_oldsavedlen = 0;
10307 PL_reg_maxiter = 0;
10308 PL_reg_leftiter = 0;
10309 PL_reg_poscache = Nullch;
10310 PL_reg_poscache_size= 0;
10312 /* RE engine - function pointers */
10313 PL_regcompp = proto_perl->Tregcompp;
10314 PL_regexecp = proto_perl->Tregexecp;
10315 PL_regint_start = proto_perl->Tregint_start;
10316 PL_regint_string = proto_perl->Tregint_string;
10317 PL_regfree = proto_perl->Tregfree;
10319 PL_reginterp_cnt = 0;
10320 PL_reg_starttry = 0;
10322 /* Pluggable optimizer */
10323 PL_peepp = proto_perl->Tpeepp;
10325 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10326 ptr_table_free(PL_ptr_table);
10327 PL_ptr_table = NULL;
10330 /* Call the ->CLONE method, if it exists, for each of the stashes
10331 identified by sv_dup() above.
10333 while(av_len(param->stashes) != -1) {
10334 HV* stash = (HV*) av_shift(param->stashes);
10335 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10336 if (cloner && GvCV(cloner)) {
10341 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10343 call_sv((SV*)GvCV(cloner), G_DISCARD);
10349 SvREFCNT_dec(param->stashes);
10355 #endif /* USE_ITHREADS */