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);
3306 Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
3307 else { /* Assume Latin-1/EBCDIC */
3308 /* This function could be much more efficient if we
3309 * had a FLAG in SVs to signal if there are any hibit
3310 * chars in the PV. Given that there isn't such a flag
3311 * make the loop as fast as possible. */
3312 s = (U8 *) SvPVX(sv);
3313 e = (U8 *) SvEND(sv);
3317 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3323 len = SvCUR(sv) + 1; /* Plus the \0 */
3324 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3325 SvCUR(sv) = len - 1;
3327 Safefree(s); /* No longer using what was there before. */
3328 SvLEN(sv) = len; /* No longer know the real size. */
3330 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3337 =for apidoc sv_utf8_downgrade
3339 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3340 This may not be possible if the PV contains non-byte encoding characters;
3341 if this is the case, either returns false or, if C<fail_ok> is not
3348 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3350 if (SvPOK(sv) && SvUTF8(sv)) {
3355 if (SvREADONLY(sv) && SvFAKE(sv))
3356 sv_force_normal(sv);
3357 s = (U8 *) SvPV(sv, len);
3358 if (!utf8_to_bytes(s, &len)) {
3361 #ifdef USE_BYTES_DOWNGRADES
3362 else if (IN_BYTES) {
3364 U8 *e = (U8 *) SvEND(sv);
3367 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3368 if (first && ch > 255) {
3370 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3373 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3380 len = (d - (U8 *) SvPVX(sv));
3385 Perl_croak(aTHX_ "Wide character in %s",
3388 Perl_croak(aTHX_ "Wide character");
3399 =for apidoc sv_utf8_encode
3401 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3402 flag so that it looks like octets again. Used as a building block
3403 for encode_utf8 in Encode.xs
3409 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3411 (void) sv_utf8_upgrade(sv);
3416 =for apidoc sv_utf8_decode
3418 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3419 turn off SvUTF8 if needed so that we see characters. Used as a building block
3420 for decode_utf8 in Encode.xs
3426 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3432 /* The octets may have got themselves encoded - get them back as
3435 if (!sv_utf8_downgrade(sv, TRUE))
3438 /* it is actually just a matter of turning the utf8 flag on, but
3439 * we want to make sure everything inside is valid utf8 first.
3441 c = (U8 *) SvPVX(sv);
3442 if (!is_utf8_string(c, SvCUR(sv)+1))
3444 e = (U8 *) SvEND(sv);
3447 if (!UTF8_IS_INVARIANT(ch)) {
3457 =for apidoc sv_setsv
3459 Copies the contents of the source SV C<ssv> into the destination SV
3460 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3461 function if the source SV needs to be reused. Does not handle 'set' magic.
3462 Loosely speaking, it performs a copy-by-value, obliterating any previous
3463 content of the destination.
3465 You probably want to use one of the assortment of wrappers, such as
3466 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3467 C<SvSetMagicSV_nosteal>.
3473 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3474 for binary compatibility only
3477 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3479 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3483 =for apidoc sv_setsv_flags
3485 Copies the contents of the source SV C<ssv> into the destination SV
3486 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3487 function if the source SV needs to be reused. Does not handle 'set' magic.
3488 Loosely speaking, it performs a copy-by-value, obliterating any previous
3489 content of the destination.
3490 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3491 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3492 implemented in terms of this function.
3494 You probably want to use one of the assortment of wrappers, such as
3495 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3496 C<SvSetMagicSV_nosteal>.
3498 This is the primary function for copying scalars, and most other
3499 copy-ish functions and macros use this underneath.
3505 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3507 register U32 sflags;
3513 SV_CHECK_THINKFIRST(dstr);
3515 sstr = &PL_sv_undef;
3516 stype = SvTYPE(sstr);
3517 dtype = SvTYPE(dstr);
3521 /* There's a lot of redundancy below but we're going for speed here */
3526 if (dtype != SVt_PVGV) {
3527 (void)SvOK_off(dstr);
3535 sv_upgrade(dstr, SVt_IV);
3538 sv_upgrade(dstr, SVt_PVNV);
3542 sv_upgrade(dstr, SVt_PVIV);
3545 (void)SvIOK_only(dstr);
3546 SvIVX(dstr) = SvIVX(sstr);
3549 if (SvTAINTED(sstr))
3560 sv_upgrade(dstr, SVt_NV);
3565 sv_upgrade(dstr, SVt_PVNV);
3568 SvNVX(dstr) = SvNVX(sstr);
3569 (void)SvNOK_only(dstr);
3570 if (SvTAINTED(sstr))
3578 sv_upgrade(dstr, SVt_RV);
3579 else if (dtype == SVt_PVGV &&
3580 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3583 if (GvIMPORTED(dstr) != GVf_IMPORTED
3584 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3586 GvIMPORTED_on(dstr);
3597 sv_upgrade(dstr, SVt_PV);
3600 if (dtype < SVt_PVIV)
3601 sv_upgrade(dstr, SVt_PVIV);
3604 if (dtype < SVt_PVNV)
3605 sv_upgrade(dstr, SVt_PVNV);
3612 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3615 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3619 if (dtype <= SVt_PVGV) {
3621 if (dtype != SVt_PVGV) {
3622 char *name = GvNAME(sstr);
3623 STRLEN len = GvNAMELEN(sstr);
3624 sv_upgrade(dstr, SVt_PVGV);
3625 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3626 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3627 GvNAME(dstr) = savepvn(name, len);
3628 GvNAMELEN(dstr) = len;
3629 SvFAKE_on(dstr); /* can coerce to non-glob */
3631 /* ahem, death to those who redefine active sort subs */
3632 else if (PL_curstackinfo->si_type == PERLSI_SORT
3633 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3634 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3637 #ifdef GV_UNIQUE_CHECK
3638 if (GvUNIQUE((GV*)dstr)) {
3639 Perl_croak(aTHX_ PL_no_modify);
3643 (void)SvOK_off(dstr);
3644 GvINTRO_off(dstr); /* one-shot flag */
3646 GvGP(dstr) = gp_ref(GvGP(sstr));
3647 if (SvTAINTED(sstr))
3649 if (GvIMPORTED(dstr) != GVf_IMPORTED
3650 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3652 GvIMPORTED_on(dstr);
3660 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3662 if (SvTYPE(sstr) != stype) {
3663 stype = SvTYPE(sstr);
3664 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3668 if (stype == SVt_PVLV)
3669 (void)SvUPGRADE(dstr, SVt_PVNV);
3671 (void)SvUPGRADE(dstr, stype);
3674 sflags = SvFLAGS(sstr);
3676 if (sflags & SVf_ROK) {
3677 if (dtype >= SVt_PV) {
3678 if (dtype == SVt_PVGV) {
3679 SV *sref = SvREFCNT_inc(SvRV(sstr));
3681 int intro = GvINTRO(dstr);
3683 #ifdef GV_UNIQUE_CHECK
3684 if (GvUNIQUE((GV*)dstr)) {
3685 Perl_croak(aTHX_ PL_no_modify);
3690 GvINTRO_off(dstr); /* one-shot flag */
3691 GvLINE(dstr) = CopLINE(PL_curcop);
3692 GvEGV(dstr) = (GV*)dstr;
3695 switch (SvTYPE(sref)) {
3698 SAVESPTR(GvAV(dstr));
3700 dref = (SV*)GvAV(dstr);
3701 GvAV(dstr) = (AV*)sref;
3702 if (!GvIMPORTED_AV(dstr)
3703 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3705 GvIMPORTED_AV_on(dstr);
3710 SAVESPTR(GvHV(dstr));
3712 dref = (SV*)GvHV(dstr);
3713 GvHV(dstr) = (HV*)sref;
3714 if (!GvIMPORTED_HV(dstr)
3715 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3717 GvIMPORTED_HV_on(dstr);
3722 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3723 SvREFCNT_dec(GvCV(dstr));
3724 GvCV(dstr) = Nullcv;
3725 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3726 PL_sub_generation++;
3728 SAVESPTR(GvCV(dstr));
3731 dref = (SV*)GvCV(dstr);
3732 if (GvCV(dstr) != (CV*)sref) {
3733 CV* cv = GvCV(dstr);
3735 if (!GvCVGEN((GV*)dstr) &&
3736 (CvROOT(cv) || CvXSUB(cv)))
3738 /* ahem, death to those who redefine
3739 * active sort subs */
3740 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3741 PL_sortcop == CvSTART(cv))
3743 "Can't redefine active sort subroutine %s",
3744 GvENAME((GV*)dstr));
3745 /* Redefining a sub - warning is mandatory if
3746 it was a const and its value changed. */
3747 if (ckWARN(WARN_REDEFINE)
3749 && (!CvCONST((CV*)sref)
3750 || sv_cmp(cv_const_sv(cv),
3751 cv_const_sv((CV*)sref)))))
3753 Perl_warner(aTHX_ WARN_REDEFINE,
3755 ? "Constant subroutine %s redefined"
3756 : "Subroutine %s redefined",
3757 GvENAME((GV*)dstr));
3760 cv_ckproto(cv, (GV*)dstr,
3761 SvPOK(sref) ? SvPVX(sref) : Nullch);
3763 GvCV(dstr) = (CV*)sref;
3764 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3765 GvASSUMECV_on(dstr);
3766 PL_sub_generation++;
3768 if (!GvIMPORTED_CV(dstr)
3769 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3771 GvIMPORTED_CV_on(dstr);
3776 SAVESPTR(GvIOp(dstr));
3778 dref = (SV*)GvIOp(dstr);
3779 GvIOp(dstr) = (IO*)sref;
3783 SAVESPTR(GvFORM(dstr));
3785 dref = (SV*)GvFORM(dstr);
3786 GvFORM(dstr) = (CV*)sref;
3790 SAVESPTR(GvSV(dstr));
3792 dref = (SV*)GvSV(dstr);
3794 if (!GvIMPORTED_SV(dstr)
3795 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3797 GvIMPORTED_SV_on(dstr);
3805 if (SvTAINTED(sstr))
3810 (void)SvOOK_off(dstr); /* backoff */
3812 Safefree(SvPVX(dstr));
3813 SvLEN(dstr)=SvCUR(dstr)=0;
3816 (void)SvOK_off(dstr);
3817 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3819 if (sflags & SVp_NOK) {
3821 /* Only set the public OK flag if the source has public OK. */
3822 if (sflags & SVf_NOK)
3823 SvFLAGS(dstr) |= SVf_NOK;
3824 SvNVX(dstr) = SvNVX(sstr);
3826 if (sflags & SVp_IOK) {
3827 (void)SvIOKp_on(dstr);
3828 if (sflags & SVf_IOK)
3829 SvFLAGS(dstr) |= SVf_IOK;
3830 if (sflags & SVf_IVisUV)
3832 SvIVX(dstr) = SvIVX(sstr);
3834 if (SvAMAGIC(sstr)) {
3838 else if (sflags & SVp_POK) {
3841 * Check to see if we can just swipe the string. If so, it's a
3842 * possible small lose on short strings, but a big win on long ones.
3843 * It might even be a win on short strings if SvPVX(dstr)
3844 * has to be allocated and SvPVX(sstr) has to be freed.
3847 if (SvTEMP(sstr) && /* slated for free anyway? */
3848 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3849 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3850 SvLEN(sstr) && /* and really is a string */
3851 /* and won't be needed again, potentially */
3852 !(PL_op && PL_op->op_type == OP_AASSIGN))
3854 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3856 SvFLAGS(dstr) &= ~SVf_OOK;
3857 Safefree(SvPVX(dstr) - SvIVX(dstr));
3859 else if (SvLEN(dstr))
3860 Safefree(SvPVX(dstr));
3862 (void)SvPOK_only(dstr);
3863 SvPV_set(dstr, SvPVX(sstr));
3864 SvLEN_set(dstr, SvLEN(sstr));
3865 SvCUR_set(dstr, SvCUR(sstr));
3868 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3869 SvPV_set(sstr, Nullch);
3874 else { /* have to copy actual string */
3875 STRLEN len = SvCUR(sstr);
3877 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3878 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3879 SvCUR_set(dstr, len);
3880 *SvEND(dstr) = '\0';
3881 (void)SvPOK_only(dstr);
3883 if (sflags & SVf_UTF8)
3886 if (sflags & SVp_NOK) {
3888 if (sflags & SVf_NOK)
3889 SvFLAGS(dstr) |= SVf_NOK;
3890 SvNVX(dstr) = SvNVX(sstr);
3892 if (sflags & SVp_IOK) {
3893 (void)SvIOKp_on(dstr);
3894 if (sflags & SVf_IOK)
3895 SvFLAGS(dstr) |= SVf_IOK;
3896 if (sflags & SVf_IVisUV)
3898 SvIVX(dstr) = SvIVX(sstr);
3901 else if (sflags & SVp_IOK) {
3902 if (sflags & SVf_IOK)
3903 (void)SvIOK_only(dstr);
3905 (void)SvOK_off(dstr);
3906 (void)SvIOKp_on(dstr);
3908 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3909 if (sflags & SVf_IVisUV)
3911 SvIVX(dstr) = SvIVX(sstr);
3912 if (sflags & SVp_NOK) {
3913 if (sflags & SVf_NOK)
3914 (void)SvNOK_on(dstr);
3916 (void)SvNOKp_on(dstr);
3917 SvNVX(dstr) = SvNVX(sstr);
3920 else if (sflags & SVp_NOK) {
3921 if (sflags & SVf_NOK)
3922 (void)SvNOK_only(dstr);
3924 (void)SvOK_off(dstr);
3927 SvNVX(dstr) = SvNVX(sstr);
3930 if (dtype == SVt_PVGV) {
3931 if (ckWARN(WARN_MISC))
3932 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3935 (void)SvOK_off(dstr);
3937 if (SvTAINTED(sstr))
3942 =for apidoc sv_setsv_mg
3944 Like C<sv_setsv>, but also handles 'set' magic.
3950 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3952 sv_setsv(dstr,sstr);
3957 =for apidoc sv_setpvn
3959 Copies a string into an SV. The C<len> parameter indicates the number of
3960 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3966 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3968 register char *dptr;
3970 SV_CHECK_THINKFIRST(sv);
3976 /* len is STRLEN which is unsigned, need to copy to signed */
3979 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3981 (void)SvUPGRADE(sv, SVt_PV);
3983 SvGROW(sv, len + 1);
3985 Move(ptr,dptr,len,char);
3988 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3993 =for apidoc sv_setpvn_mg
3995 Like C<sv_setpvn>, but also handles 'set' magic.
4001 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4003 sv_setpvn(sv,ptr,len);
4008 =for apidoc sv_setpv
4010 Copies a string into an SV. The string must be null-terminated. Does not
4011 handle 'set' magic. See C<sv_setpv_mg>.
4017 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4019 register STRLEN len;
4021 SV_CHECK_THINKFIRST(sv);
4027 (void)SvUPGRADE(sv, SVt_PV);
4029 SvGROW(sv, len + 1);
4030 Move(ptr,SvPVX(sv),len+1,char);
4032 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4037 =for apidoc sv_setpv_mg
4039 Like C<sv_setpv>, but also handles 'set' magic.
4045 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4052 =for apidoc sv_usepvn
4054 Tells an SV to use C<ptr> to find its string value. Normally the string is
4055 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4056 The C<ptr> should point to memory that was allocated by C<malloc>. The
4057 string length, C<len>, must be supplied. This function will realloc the
4058 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4059 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4060 See C<sv_usepvn_mg>.
4066 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4068 SV_CHECK_THINKFIRST(sv);
4069 (void)SvUPGRADE(sv, SVt_PV);
4074 (void)SvOOK_off(sv);
4075 if (SvPVX(sv) && SvLEN(sv))
4076 Safefree(SvPVX(sv));
4077 Renew(ptr, len+1, char);
4080 SvLEN_set(sv, len+1);
4082 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4087 =for apidoc sv_usepvn_mg
4089 Like C<sv_usepvn>, but also handles 'set' magic.
4095 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4097 sv_usepvn(sv,ptr,len);
4102 =for apidoc sv_force_normal_flags
4104 Undo various types of fakery on an SV: if the PV is a shared string, make
4105 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4106 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4107 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4113 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4115 if (SvREADONLY(sv)) {
4117 char *pvx = SvPVX(sv);
4118 STRLEN len = SvCUR(sv);
4119 U32 hash = SvUVX(sv);
4120 SvGROW(sv, len + 1);
4121 Move(pvx,SvPVX(sv),len,char);
4125 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4127 else if (PL_curcop != &PL_compiling)
4128 Perl_croak(aTHX_ PL_no_modify);
4131 sv_unref_flags(sv, flags);
4132 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4137 =for apidoc sv_force_normal
4139 Undo various types of fakery on an SV: if the PV is a shared string, make
4140 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4141 an xpvmg. See also C<sv_force_normal_flags>.
4147 Perl_sv_force_normal(pTHX_ register SV *sv)
4149 sv_force_normal_flags(sv, 0);
4155 Efficient removal of characters from the beginning of the string buffer.
4156 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4157 the string buffer. The C<ptr> becomes the first character of the adjusted
4158 string. Uses the "OOK hack".
4164 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4166 register STRLEN delta;
4168 if (!ptr || !SvPOKp(sv))
4170 SV_CHECK_THINKFIRST(sv);
4171 if (SvTYPE(sv) < SVt_PVIV)
4172 sv_upgrade(sv,SVt_PVIV);
4175 if (!SvLEN(sv)) { /* make copy of shared string */
4176 char *pvx = SvPVX(sv);
4177 STRLEN len = SvCUR(sv);
4178 SvGROW(sv, len + 1);
4179 Move(pvx,SvPVX(sv),len,char);
4183 SvFLAGS(sv) |= SVf_OOK;
4185 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4186 delta = ptr - SvPVX(sv);
4194 =for apidoc sv_catpvn
4196 Concatenates the string onto the end of the string which is in the SV. The
4197 C<len> indicates number of bytes to copy. If the SV has the UTF8
4198 status set, then the bytes appended should be valid UTF8.
4199 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4204 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4205 for binary compatibility only
4208 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4210 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4214 =for apidoc sv_catpvn_flags
4216 Concatenates the string onto the end of the string which is in the SV. The
4217 C<len> indicates number of bytes to copy. If the SV has the UTF8
4218 status set, then the bytes appended should be valid UTF8.
4219 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4220 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4221 in terms of this function.
4227 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4232 dstr = SvPV_force_flags(dsv, dlen, flags);
4233 SvGROW(dsv, dlen + slen + 1);
4236 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4239 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4244 =for apidoc sv_catpvn_mg
4246 Like C<sv_catpvn>, but also handles 'set' magic.
4252 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4254 sv_catpvn(sv,ptr,len);
4259 =for apidoc sv_catsv
4261 Concatenates the string from SV C<ssv> onto the end of the string in
4262 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4263 not 'set' magic. See C<sv_catsv_mg>.
4267 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4268 for binary compatibility only
4271 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4273 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4277 =for apidoc sv_catsv_flags
4279 Concatenates the string from SV C<ssv> onto the end of the string in
4280 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4281 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4282 and C<sv_catsv_nomg> are implemented in terms of this function.
4287 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4293 if ((spv = SvPV(ssv, slen))) {
4294 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4295 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4296 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4297 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4298 dsv->sv_flags doesn't have that bit set.
4299 Andy Dougherty 12 Oct 2001
4301 I32 sutf8 = DO_UTF8(ssv);
4304 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4306 dutf8 = DO_UTF8(dsv);
4308 if (dutf8 != sutf8) {
4310 /* Not modifying source SV, so taking a temporary copy. */
4311 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4313 sv_utf8_upgrade(csv);
4314 spv = SvPV(csv, slen);
4317 sv_utf8_upgrade_nomg(dsv);
4319 sv_catpvn_nomg(dsv, spv, slen);
4324 =for apidoc sv_catsv_mg
4326 Like C<sv_catsv>, but also handles 'set' magic.
4332 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4339 =for apidoc sv_catpv
4341 Concatenates the string onto the end of the string which is in the SV.
4342 If the SV has the UTF8 status set, then the bytes appended should be
4343 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4348 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4350 register STRLEN len;
4356 junk = SvPV_force(sv, tlen);
4358 SvGROW(sv, tlen + len + 1);
4361 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4363 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4368 =for apidoc sv_catpv_mg
4370 Like C<sv_catpv>, but also handles 'set' magic.
4376 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4385 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4386 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4393 Perl_newSV(pTHX_ STRLEN len)
4399 sv_upgrade(sv, SVt_PV);
4400 SvGROW(sv, len + 1);
4406 =for apidoc sv_magic
4408 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4409 then adds a new magic item of type C<how> to the head of the magic list.
4411 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4417 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4421 if (SvREADONLY(sv)) {
4422 if (PL_curcop != &PL_compiling
4423 && how != PERL_MAGIC_regex_global
4424 && how != PERL_MAGIC_bm
4425 && how != PERL_MAGIC_fm
4426 && how != PERL_MAGIC_sv
4429 Perl_croak(aTHX_ PL_no_modify);
4432 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4433 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4434 if (how == PERL_MAGIC_taint)
4440 (void)SvUPGRADE(sv, SVt_PVMG);
4442 Newz(702,mg, 1, MAGIC);
4443 mg->mg_moremagic = SvMAGIC(sv);
4446 /* Some magic contains a reference loop, where the sv and object refer to
4447 each other. To avoid a reference loop that would prevent such objects
4448 being freed, we look for such loops and if we find one we avoid
4449 incrementing the object refcount. */
4450 if (!obj || obj == sv ||
4451 how == PERL_MAGIC_arylen ||
4452 how == PERL_MAGIC_qr ||
4453 (SvTYPE(obj) == SVt_PVGV &&
4454 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4455 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4456 GvFORM(obj) == (CV*)sv)))
4461 mg->mg_obj = SvREFCNT_inc(obj);
4462 mg->mg_flags |= MGf_REFCOUNTED;
4465 mg->mg_len = namlen;
4468 mg->mg_ptr = savepvn(name, namlen);
4469 else if (namlen == HEf_SVKEY)
4470 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4475 mg->mg_virtual = &PL_vtbl_sv;
4477 case PERL_MAGIC_overload:
4478 mg->mg_virtual = &PL_vtbl_amagic;
4480 case PERL_MAGIC_overload_elem:
4481 mg->mg_virtual = &PL_vtbl_amagicelem;
4483 case PERL_MAGIC_overload_table:
4484 mg->mg_virtual = &PL_vtbl_ovrld;
4487 mg->mg_virtual = &PL_vtbl_bm;
4489 case PERL_MAGIC_regdata:
4490 mg->mg_virtual = &PL_vtbl_regdata;
4492 case PERL_MAGIC_regdatum:
4493 mg->mg_virtual = &PL_vtbl_regdatum;
4495 case PERL_MAGIC_env:
4496 mg->mg_virtual = &PL_vtbl_env;
4499 mg->mg_virtual = &PL_vtbl_fm;
4501 case PERL_MAGIC_envelem:
4502 mg->mg_virtual = &PL_vtbl_envelem;
4504 case PERL_MAGIC_regex_global:
4505 mg->mg_virtual = &PL_vtbl_mglob;
4507 case PERL_MAGIC_isa:
4508 mg->mg_virtual = &PL_vtbl_isa;
4510 case PERL_MAGIC_isaelem:
4511 mg->mg_virtual = &PL_vtbl_isaelem;
4513 case PERL_MAGIC_nkeys:
4514 mg->mg_virtual = &PL_vtbl_nkeys;
4516 case PERL_MAGIC_dbfile:
4520 case PERL_MAGIC_dbline:
4521 mg->mg_virtual = &PL_vtbl_dbline;
4523 #ifdef USE_5005THREADS
4524 case PERL_MAGIC_mutex:
4525 mg->mg_virtual = &PL_vtbl_mutex;
4527 #endif /* USE_5005THREADS */
4528 #ifdef USE_LOCALE_COLLATE
4529 case PERL_MAGIC_collxfrm:
4530 mg->mg_virtual = &PL_vtbl_collxfrm;
4532 #endif /* USE_LOCALE_COLLATE */
4533 case PERL_MAGIC_tied:
4534 mg->mg_virtual = &PL_vtbl_pack;
4536 case PERL_MAGIC_tiedelem:
4537 case PERL_MAGIC_tiedscalar:
4538 mg->mg_virtual = &PL_vtbl_packelem;
4541 mg->mg_virtual = &PL_vtbl_regexp;
4543 case PERL_MAGIC_sig:
4544 mg->mg_virtual = &PL_vtbl_sig;
4546 case PERL_MAGIC_sigelem:
4547 mg->mg_virtual = &PL_vtbl_sigelem;
4549 case PERL_MAGIC_taint:
4550 mg->mg_virtual = &PL_vtbl_taint;
4553 case PERL_MAGIC_uvar:
4554 mg->mg_virtual = &PL_vtbl_uvar;
4556 case PERL_MAGIC_vec:
4557 mg->mg_virtual = &PL_vtbl_vec;
4559 case PERL_MAGIC_substr:
4560 mg->mg_virtual = &PL_vtbl_substr;
4562 case PERL_MAGIC_defelem:
4563 mg->mg_virtual = &PL_vtbl_defelem;
4565 case PERL_MAGIC_glob:
4566 mg->mg_virtual = &PL_vtbl_glob;
4568 case PERL_MAGIC_arylen:
4569 mg->mg_virtual = &PL_vtbl_arylen;
4571 case PERL_MAGIC_pos:
4572 mg->mg_virtual = &PL_vtbl_pos;
4574 case PERL_MAGIC_backref:
4575 mg->mg_virtual = &PL_vtbl_backref;
4577 case PERL_MAGIC_ext:
4578 /* Reserved for use by extensions not perl internals. */
4579 /* Useful for attaching extension internal data to perl vars. */
4580 /* Note that multiple extensions may clash if magical scalars */
4581 /* etc holding private data from one are passed to another. */
4585 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4589 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4593 =for apidoc sv_unmagic
4595 Removes all magic of type C<type> from an SV.
4601 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4605 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4608 for (mg = *mgp; mg; mg = *mgp) {
4609 if (mg->mg_type == type) {
4610 MGVTBL* vtbl = mg->mg_virtual;
4611 *mgp = mg->mg_moremagic;
4612 if (vtbl && vtbl->svt_free)
4613 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4614 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4615 if (mg->mg_len >= 0)
4616 Safefree(mg->mg_ptr);
4617 else if (mg->mg_len == HEf_SVKEY)
4618 SvREFCNT_dec((SV*)mg->mg_ptr);
4620 if (mg->mg_flags & MGf_REFCOUNTED)
4621 SvREFCNT_dec(mg->mg_obj);
4625 mgp = &mg->mg_moremagic;
4629 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4636 =for apidoc sv_rvweaken
4638 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4639 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4640 push a back-reference to this RV onto the array of backreferences
4641 associated with that magic.
4647 Perl_sv_rvweaken(pTHX_ SV *sv)
4650 if (!SvOK(sv)) /* let undefs pass */
4653 Perl_croak(aTHX_ "Can't weaken a nonreference");
4654 else if (SvWEAKREF(sv)) {
4655 if (ckWARN(WARN_MISC))
4656 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4660 sv_add_backref(tsv, sv);
4666 /* Give tsv backref magic if it hasn't already got it, then push a
4667 * back-reference to sv onto the array associated with the backref magic.
4671 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4675 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4676 av = (AV*)mg->mg_obj;
4679 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4680 SvREFCNT_dec(av); /* for sv_magic */
4685 /* delete a back-reference to ourselves from the backref magic associated
4686 * with the SV we point to.
4690 S_sv_del_backref(pTHX_ SV *sv)
4697 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4698 Perl_croak(aTHX_ "panic: del_backref");
4699 av = (AV *)mg->mg_obj;
4704 svp[i] = &PL_sv_undef; /* XXX */
4711 =for apidoc sv_insert
4713 Inserts a string at the specified offset/length within the SV. Similar to
4714 the Perl substr() function.
4720 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4724 register char *midend;
4725 register char *bigend;
4731 Perl_croak(aTHX_ "Can't modify non-existent substring");
4732 SvPV_force(bigstr, curlen);
4733 (void)SvPOK_only_UTF8(bigstr);
4734 if (offset + len > curlen) {
4735 SvGROW(bigstr, offset+len+1);
4736 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4737 SvCUR_set(bigstr, offset+len);
4741 i = littlelen - len;
4742 if (i > 0) { /* string might grow */
4743 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4744 mid = big + offset + len;
4745 midend = bigend = big + SvCUR(bigstr);
4748 while (midend > mid) /* shove everything down */
4749 *--bigend = *--midend;
4750 Move(little,big+offset,littlelen,char);
4756 Move(little,SvPVX(bigstr)+offset,len,char);
4761 big = SvPVX(bigstr);
4764 bigend = big + SvCUR(bigstr);
4766 if (midend > bigend)
4767 Perl_croak(aTHX_ "panic: sv_insert");
4769 if (mid - big > bigend - midend) { /* faster to shorten from end */
4771 Move(little, mid, littlelen,char);
4774 i = bigend - midend;
4776 Move(midend, mid, i,char);
4780 SvCUR_set(bigstr, mid - big);
4783 else if ((i = mid - big)) { /* faster from front */
4784 midend -= littlelen;
4786 sv_chop(bigstr,midend-i);
4791 Move(little, mid, littlelen,char);
4793 else if (littlelen) {
4794 midend -= littlelen;
4795 sv_chop(bigstr,midend);
4796 Move(little,midend,littlelen,char);
4799 sv_chop(bigstr,midend);
4805 =for apidoc sv_replace
4807 Make the first argument a copy of the second, then delete the original.
4808 The target SV physically takes over ownership of the body of the source SV
4809 and inherits its flags; however, the target keeps any magic it owns,
4810 and any magic in the source is discarded.
4811 Note that this is a rather specialist SV copying operation; most of the
4812 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4818 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4820 U32 refcnt = SvREFCNT(sv);
4821 SV_CHECK_THINKFIRST(sv);
4822 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4823 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4824 if (SvMAGICAL(sv)) {
4828 sv_upgrade(nsv, SVt_PVMG);
4829 SvMAGIC(nsv) = SvMAGIC(sv);
4830 SvFLAGS(nsv) |= SvMAGICAL(sv);
4836 assert(!SvREFCNT(sv));
4837 StructCopy(nsv,sv,SV);
4838 SvREFCNT(sv) = refcnt;
4839 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4844 =for apidoc sv_clear
4846 Clear an SV: call any destructors, free up any memory used by the body,
4847 and free the body itself. The SV's head is I<not> freed, although
4848 its type is set to all 1's so that it won't inadvertently be assumed
4849 to be live during global destruction etc.
4850 This function should only be called when REFCNT is zero. Most of the time
4851 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4858 Perl_sv_clear(pTHX_ register SV *sv)
4862 assert(SvREFCNT(sv) == 0);
4865 if (PL_defstash) { /* Still have a symbol table? */
4870 Zero(&tmpref, 1, SV);
4871 sv_upgrade(&tmpref, SVt_RV);
4873 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4874 SvREFCNT(&tmpref) = 1;
4877 stash = SvSTASH(sv);
4878 destructor = StashHANDLER(stash,DESTROY);
4881 PUSHSTACKi(PERLSI_DESTROY);
4882 SvRV(&tmpref) = SvREFCNT_inc(sv);
4887 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4893 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4895 del_XRV(SvANY(&tmpref));
4898 if (PL_in_clean_objs)
4899 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4901 /* DESTROY gave object new lease on life */
4907 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4908 SvOBJECT_off(sv); /* Curse the object. */
4909 if (SvTYPE(sv) != SVt_PVIO)
4910 --PL_sv_objcount; /* XXX Might want something more general */
4913 if (SvTYPE(sv) >= SVt_PVMG) {
4916 if (SvFLAGS(sv) & SVpad_TYPED)
4917 SvREFCNT_dec(SvSTASH(sv));
4920 switch (SvTYPE(sv)) {
4923 IoIFP(sv) != PerlIO_stdin() &&
4924 IoIFP(sv) != PerlIO_stdout() &&
4925 IoIFP(sv) != PerlIO_stderr())
4927 io_close((IO*)sv, FALSE);
4929 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4930 PerlDir_close(IoDIRP(sv));
4931 IoDIRP(sv) = (DIR*)NULL;
4932 Safefree(IoTOP_NAME(sv));
4933 Safefree(IoFMT_NAME(sv));
4934 Safefree(IoBOTTOM_NAME(sv));
4949 SvREFCNT_dec(LvTARG(sv));
4953 Safefree(GvNAME(sv));
4954 /* cannot decrease stash refcount yet, as we might recursively delete
4955 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4956 of stash until current sv is completely gone.
4957 -- JohnPC, 27 Mar 1998 */
4958 stash = GvSTASH(sv);
4964 (void)SvOOK_off(sv);
4972 SvREFCNT_dec(SvRV(sv));
4974 else if (SvPVX(sv) && SvLEN(sv))
4975 Safefree(SvPVX(sv));
4976 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4977 unsharepvn(SvPVX(sv),
4978 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
4991 switch (SvTYPE(sv)) {
5007 del_XPVIV(SvANY(sv));
5010 del_XPVNV(SvANY(sv));
5013 del_XPVMG(SvANY(sv));
5016 del_XPVLV(SvANY(sv));
5019 del_XPVAV(SvANY(sv));
5022 del_XPVHV(SvANY(sv));
5025 del_XPVCV(SvANY(sv));
5028 del_XPVGV(SvANY(sv));
5029 /* code duplication for increased performance. */
5030 SvFLAGS(sv) &= SVf_BREAK;
5031 SvFLAGS(sv) |= SVTYPEMASK;
5032 /* decrease refcount of the stash that owns this GV, if any */
5034 SvREFCNT_dec(stash);
5035 return; /* not break, SvFLAGS reset already happened */
5037 del_XPVBM(SvANY(sv));
5040 del_XPVFM(SvANY(sv));
5043 del_XPVIO(SvANY(sv));
5046 SvFLAGS(sv) &= SVf_BREAK;
5047 SvFLAGS(sv) |= SVTYPEMASK;
5051 =for apidoc sv_newref
5053 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5060 Perl_sv_newref(pTHX_ SV *sv)
5063 ATOMIC_INC(SvREFCNT(sv));
5070 Decrement an SV's reference count, and if it drops to zero, call
5071 C<sv_clear> to invoke destructors and free up any memory used by
5072 the body; finally, deallocate the SV's head itself.
5073 Normally called via a wrapper macro C<SvREFCNT_dec>.
5079 Perl_sv_free(pTHX_ SV *sv)
5081 int refcount_is_zero;
5085 if (SvREFCNT(sv) == 0) {
5086 if (SvFLAGS(sv) & SVf_BREAK)
5087 /* this SV's refcnt has been artificially decremented to
5088 * trigger cleanup */
5090 if (PL_in_clean_all) /* All is fair */
5092 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5093 /* make sure SvREFCNT(sv)==0 happens very seldom */
5094 SvREFCNT(sv) = (~(U32)0)/2;
5097 if (ckWARN_d(WARN_INTERNAL))
5098 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5101 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5102 if (!refcount_is_zero)
5106 if (ckWARN_d(WARN_DEBUGGING))
5107 Perl_warner(aTHX_ WARN_DEBUGGING,
5108 "Attempt to free temp prematurely: SV 0x%"UVxf,
5113 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5114 /* make sure SvREFCNT(sv)==0 happens very seldom */
5115 SvREFCNT(sv) = (~(U32)0)/2;
5126 Returns the length of the string in the SV. Handles magic and type
5127 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5133 Perl_sv_len(pTHX_ register SV *sv)
5141 len = mg_length(sv);
5143 (void)SvPV(sv, len);
5148 =for apidoc sv_len_utf8
5150 Returns the number of characters in the string in an SV, counting wide
5151 UTF8 bytes as a single character. Handles magic and type coercion.
5157 Perl_sv_len_utf8(pTHX_ register SV *sv)
5163 return mg_length(sv);
5167 U8 *s = (U8*)SvPV(sv, len);
5169 return Perl_utf8_length(aTHX_ s, s + len);
5174 =for apidoc sv_pos_u2b
5176 Converts the value pointed to by offsetp from a count of UTF8 chars from
5177 the start of the string, to a count of the equivalent number of bytes; if
5178 lenp is non-zero, it does the same to lenp, but this time starting from
5179 the offset, rather than from the start of the string. Handles magic and
5186 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5191 I32 uoffset = *offsetp;
5197 start = s = (U8*)SvPV(sv, len);
5199 while (s < send && uoffset--)
5203 *offsetp = s - start;
5207 while (s < send && ulen--)
5217 =for apidoc sv_pos_b2u
5219 Converts the value pointed to by offsetp from a count of bytes from the
5220 start of the string, to a count of the equivalent number of UTF8 chars.
5221 Handles magic and type coercion.
5227 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5236 s = (U8*)SvPV(sv, len);
5238 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5239 send = s + *offsetp;
5243 /* Call utf8n_to_uvchr() to validate the sequence */
5244 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5259 Returns a boolean indicating whether the strings in the two SVs are
5260 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5261 coerce its args to strings if necessary.
5267 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5281 pv1 = SvPV(sv1, cur1);
5288 pv2 = SvPV(sv2, cur2);
5290 /* do not utf8ize the comparands as a side-effect */
5291 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5292 bool is_utf8 = TRUE;
5293 /* UTF-8ness differs */
5296 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5297 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5302 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5303 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5308 /* Downgrade not possible - cannot be eq */
5314 eq = memEQ(pv1, pv2, cur1);
5325 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5326 string in C<sv1> is less than, equal to, or greater than the string in
5327 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5328 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5334 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5339 bool pv1tmp = FALSE;
5340 bool pv2tmp = FALSE;
5347 pv1 = SvPV(sv1, cur1);
5354 pv2 = SvPV(sv2, cur2);
5356 /* do not utf8ize the comparands as a side-effect */
5357 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5359 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5363 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5369 cmp = cur2 ? -1 : 0;
5373 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5376 cmp = retval < 0 ? -1 : 1;
5377 } else if (cur1 == cur2) {
5380 cmp = cur1 < cur2 ? -1 : 1;
5393 =for apidoc sv_cmp_locale
5395 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5396 'use bytes' aware, handles get magic, and will coerce its args to strings
5397 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5403 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5405 #ifdef USE_LOCALE_COLLATE
5411 if (PL_collation_standard)
5415 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5417 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5419 if (!pv1 || !len1) {
5430 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5433 return retval < 0 ? -1 : 1;
5436 * When the result of collation is equality, that doesn't mean
5437 * that there are no differences -- some locales exclude some
5438 * characters from consideration. So to avoid false equalities,
5439 * we use the raw string as a tiebreaker.
5445 #endif /* USE_LOCALE_COLLATE */
5447 return sv_cmp(sv1, sv2);
5451 #ifdef USE_LOCALE_COLLATE
5454 =for apidoc sv_collxfrm
5456 Add Collate Transform magic to an SV if it doesn't already have it.
5458 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5459 scalar data of the variable, but transformed to such a format that a normal
5460 memory comparison can be used to compare the data according to the locale
5467 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5471 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5472 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5477 Safefree(mg->mg_ptr);
5479 if ((xf = mem_collxfrm(s, len, &xlen))) {
5480 if (SvREADONLY(sv)) {
5483 return xf + sizeof(PL_collation_ix);
5486 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5487 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5500 if (mg && mg->mg_ptr) {
5502 return mg->mg_ptr + sizeof(PL_collation_ix);
5510 #endif /* USE_LOCALE_COLLATE */
5515 Get a line from the filehandle and store it into the SV, optionally
5516 appending to the currently-stored string.
5522 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5526 register STDCHAR rslast;
5527 register STDCHAR *bp;
5532 SV_CHECK_THINKFIRST(sv);
5533 (void)SvUPGRADE(sv, SVt_PV);
5537 if (PL_curcop == &PL_compiling) {
5538 /* we always read code in line mode */
5542 else if (RsSNARF(PL_rs)) {
5546 else if (RsRECORD(PL_rs)) {
5547 I32 recsize, bytesread;
5550 /* Grab the size of the record we're getting */
5551 recsize = SvIV(SvRV(PL_rs));
5552 (void)SvPOK_only(sv); /* Validate pointer */
5553 buffer = SvGROW(sv, recsize + 1);
5556 /* VMS wants read instead of fread, because fread doesn't respect */
5557 /* RMS record boundaries. This is not necessarily a good thing to be */
5558 /* doing, but we've got no other real choice */
5559 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5561 bytesread = PerlIO_read(fp, buffer, recsize);
5563 SvCUR_set(sv, bytesread);
5564 buffer[bytesread] = '\0';
5565 if (PerlIO_isutf8(fp))
5569 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5571 else if (RsPARA(PL_rs)) {
5577 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5578 if (PerlIO_isutf8(fp)) {
5579 rsptr = SvPVutf8(PL_rs, rslen);
5582 if (SvUTF8(PL_rs)) {
5583 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5584 Perl_croak(aTHX_ "Wide character in $/");
5587 rsptr = SvPV(PL_rs, rslen);
5591 rslast = rslen ? rsptr[rslen - 1] : '\0';
5593 if (rspara) { /* have to do this both before and after */
5594 do { /* to make sure file boundaries work right */
5597 i = PerlIO_getc(fp);
5601 PerlIO_ungetc(fp,i);
5607 /* See if we know enough about I/O mechanism to cheat it ! */
5609 /* This used to be #ifdef test - it is made run-time test for ease
5610 of abstracting out stdio interface. One call should be cheap
5611 enough here - and may even be a macro allowing compile
5615 if (PerlIO_fast_gets(fp)) {
5618 * We're going to steal some values from the stdio struct
5619 * and put EVERYTHING in the innermost loop into registers.
5621 register STDCHAR *ptr;
5625 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5626 /* An ungetc()d char is handled separately from the regular
5627 * buffer, so we getc() it back out and stuff it in the buffer.
5629 i = PerlIO_getc(fp);
5630 if (i == EOF) return 0;
5631 *(--((*fp)->_ptr)) = (unsigned char) i;
5635 /* Here is some breathtakingly efficient cheating */
5637 cnt = PerlIO_get_cnt(fp); /* get count into register */
5638 (void)SvPOK_only(sv); /* validate pointer */
5639 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5640 if (cnt > 80 && SvLEN(sv) > append) {
5641 shortbuffered = cnt - SvLEN(sv) + append + 1;
5642 cnt -= shortbuffered;
5646 /* remember that cnt can be negative */
5647 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5652 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5653 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5654 DEBUG_P(PerlIO_printf(Perl_debug_log,
5655 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5656 DEBUG_P(PerlIO_printf(Perl_debug_log,
5657 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5658 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5659 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5664 while (cnt > 0) { /* this | eat */
5666 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5667 goto thats_all_folks; /* screams | sed :-) */
5671 Copy(ptr, bp, cnt, char); /* this | eat */
5672 bp += cnt; /* screams | dust */
5673 ptr += cnt; /* louder | sed :-) */
5678 if (shortbuffered) { /* oh well, must extend */
5679 cnt = shortbuffered;
5681 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5683 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5684 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5688 DEBUG_P(PerlIO_printf(Perl_debug_log,
5689 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5690 PTR2UV(ptr),(long)cnt));
5691 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5692 DEBUG_P(PerlIO_printf(Perl_debug_log,
5693 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5694 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5695 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5696 /* This used to call 'filbuf' in stdio form, but as that behaves like
5697 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5698 another abstraction. */
5699 i = PerlIO_getc(fp); /* get more characters */
5700 DEBUG_P(PerlIO_printf(Perl_debug_log,
5701 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5702 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5703 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5704 cnt = PerlIO_get_cnt(fp);
5705 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5706 DEBUG_P(PerlIO_printf(Perl_debug_log,
5707 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5709 if (i == EOF) /* all done for ever? */
5710 goto thats_really_all_folks;
5712 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5714 SvGROW(sv, bpx + cnt + 2);
5715 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5717 *bp++ = i; /* store character from PerlIO_getc */
5719 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5720 goto thats_all_folks;
5724 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5725 memNE((char*)bp - rslen, rsptr, rslen))
5726 goto screamer; /* go back to the fray */
5727 thats_really_all_folks:
5729 cnt += shortbuffered;
5730 DEBUG_P(PerlIO_printf(Perl_debug_log,
5731 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5732 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5733 DEBUG_P(PerlIO_printf(Perl_debug_log,
5734 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5735 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5736 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5738 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5739 DEBUG_P(PerlIO_printf(Perl_debug_log,
5740 "Screamer: done, len=%ld, string=|%.*s|\n",
5741 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5746 /*The big, slow, and stupid way */
5749 /* Need to work around EPOC SDK features */
5750 /* On WINS: MS VC5 generates calls to _chkstk, */
5751 /* if a `large' stack frame is allocated */
5752 /* gcc on MARM does not generate calls like these */
5758 register STDCHAR *bpe = buf + sizeof(buf);
5760 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5761 ; /* keep reading */
5765 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5766 /* Accomodate broken VAXC compiler, which applies U8 cast to
5767 * both args of ?: operator, causing EOF to change into 255
5769 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5773 sv_catpvn(sv, (char *) buf, cnt);
5775 sv_setpvn(sv, (char *) buf, cnt);
5777 if (i != EOF && /* joy */
5779 SvCUR(sv) < rslen ||
5780 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5784 * If we're reading from a TTY and we get a short read,
5785 * indicating that the user hit his EOF character, we need
5786 * to notice it now, because if we try to read from the TTY
5787 * again, the EOF condition will disappear.
5789 * The comparison of cnt to sizeof(buf) is an optimization
5790 * that prevents unnecessary calls to feof().
5794 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5799 if (rspara) { /* have to do this both before and after */
5800 while (i != EOF) { /* to make sure file boundaries work right */
5801 i = PerlIO_getc(fp);
5803 PerlIO_ungetc(fp,i);
5809 if (PerlIO_isutf8(fp))
5814 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5820 Auto-increment of the value in the SV, doing string to numeric conversion
5821 if necessary. Handles 'get' magic.
5827 Perl_sv_inc(pTHX_ register SV *sv)
5836 if (SvTHINKFIRST(sv)) {
5837 if (SvREADONLY(sv)) {
5838 if (PL_curcop != &PL_compiling)
5839 Perl_croak(aTHX_ PL_no_modify);
5843 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5845 i = PTR2IV(SvRV(sv));
5850 flags = SvFLAGS(sv);
5851 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5852 /* It's (privately or publicly) a float, but not tested as an
5853 integer, so test it to see. */
5855 flags = SvFLAGS(sv);
5857 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5858 /* It's publicly an integer, or privately an integer-not-float */
5859 #ifdef PERL_PRESERVE_IVUV
5863 if (SvUVX(sv) == UV_MAX)
5864 sv_setnv(sv, (NV)UV_MAX + 1.0);
5866 (void)SvIOK_only_UV(sv);
5869 if (SvIVX(sv) == IV_MAX)
5870 sv_setuv(sv, (UV)IV_MAX + 1);
5872 (void)SvIOK_only(sv);
5878 if (flags & SVp_NOK) {
5879 (void)SvNOK_only(sv);
5884 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5885 if ((flags & SVTYPEMASK) < SVt_PVIV)
5886 sv_upgrade(sv, SVt_IV);
5887 (void)SvIOK_only(sv);
5892 while (isALPHA(*d)) d++;
5893 while (isDIGIT(*d)) d++;
5895 #ifdef PERL_PRESERVE_IVUV
5896 /* Got to punt this an an integer if needs be, but we don't issue
5897 warnings. Probably ought to make the sv_iv_please() that does
5898 the conversion if possible, and silently. */
5899 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5900 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5901 /* Need to try really hard to see if it's an integer.
5902 9.22337203685478e+18 is an integer.
5903 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5904 so $a="9.22337203685478e+18"; $a+0; $a++
5905 needs to be the same as $a="9.22337203685478e+18"; $a++
5912 /* sv_2iv *should* have made this an NV */
5913 if (flags & SVp_NOK) {
5914 (void)SvNOK_only(sv);
5918 /* I don't think we can get here. Maybe I should assert this
5919 And if we do get here I suspect that sv_setnv will croak. NWC
5921 #if defined(USE_LONG_DOUBLE)
5922 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",
5923 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5925 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5926 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5929 #endif /* PERL_PRESERVE_IVUV */
5930 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5934 while (d >= SvPVX(sv)) {
5942 /* MKS: The original code here died if letters weren't consecutive.
5943 * at least it didn't have to worry about non-C locales. The
5944 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5945 * arranged in order (although not consecutively) and that only
5946 * [A-Za-z] are accepted by isALPHA in the C locale.
5948 if (*d != 'z' && *d != 'Z') {
5949 do { ++*d; } while (!isALPHA(*d));
5952 *(d--) -= 'z' - 'a';
5957 *(d--) -= 'z' - 'a' + 1;
5961 /* oh,oh, the number grew */
5962 SvGROW(sv, SvCUR(sv) + 2);
5964 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5975 Auto-decrement of the value in the SV, doing string to numeric conversion
5976 if necessary. Handles 'get' magic.
5982 Perl_sv_dec(pTHX_ register SV *sv)
5990 if (SvTHINKFIRST(sv)) {
5991 if (SvREADONLY(sv)) {
5992 if (PL_curcop != &PL_compiling)
5993 Perl_croak(aTHX_ PL_no_modify);
5997 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5999 i = PTR2IV(SvRV(sv));
6004 /* Unlike sv_inc we don't have to worry about string-never-numbers
6005 and keeping them magic. But we mustn't warn on punting */
6006 flags = SvFLAGS(sv);
6007 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6008 /* It's publicly an integer, or privately an integer-not-float */
6009 #ifdef PERL_PRESERVE_IVUV
6013 if (SvUVX(sv) == 0) {
6014 (void)SvIOK_only(sv);
6018 (void)SvIOK_only_UV(sv);
6022 if (SvIVX(sv) == IV_MIN)
6023 sv_setnv(sv, (NV)IV_MIN - 1.0);
6025 (void)SvIOK_only(sv);
6031 if (flags & SVp_NOK) {
6033 (void)SvNOK_only(sv);
6036 if (!(flags & SVp_POK)) {
6037 if ((flags & SVTYPEMASK) < SVt_PVNV)
6038 sv_upgrade(sv, SVt_NV);
6040 (void)SvNOK_only(sv);
6043 #ifdef PERL_PRESERVE_IVUV
6045 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6046 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6047 /* Need to try really hard to see if it's an integer.
6048 9.22337203685478e+18 is an integer.
6049 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6050 so $a="9.22337203685478e+18"; $a+0; $a--
6051 needs to be the same as $a="9.22337203685478e+18"; $a--
6058 /* sv_2iv *should* have made this an NV */
6059 if (flags & SVp_NOK) {
6060 (void)SvNOK_only(sv);
6064 /* I don't think we can get here. Maybe I should assert this
6065 And if we do get here I suspect that sv_setnv will croak. NWC
6067 #if defined(USE_LONG_DOUBLE)
6068 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",
6069 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6071 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6072 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6076 #endif /* PERL_PRESERVE_IVUV */
6077 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6081 =for apidoc sv_mortalcopy
6083 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6084 The new SV is marked as mortal. It will be destroyed "soon", either by an
6085 explicit call to FREETMPS, or by an implicit call at places such as
6086 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6091 /* Make a string that will exist for the duration of the expression
6092 * evaluation. Actually, it may have to last longer than that, but
6093 * hopefully we won't free it until it has been assigned to a
6094 * permanent location. */
6097 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6102 sv_setsv(sv,oldstr);
6104 PL_tmps_stack[++PL_tmps_ix] = sv;
6110 =for apidoc sv_newmortal
6112 Creates a new null SV which is mortal. The reference count of the SV is
6113 set to 1. It will be destroyed "soon", either by an explicit call to
6114 FREETMPS, or by an implicit call at places such as statement boundaries.
6115 See also C<sv_mortalcopy> and C<sv_2mortal>.
6121 Perl_sv_newmortal(pTHX)
6126 SvFLAGS(sv) = SVs_TEMP;
6128 PL_tmps_stack[++PL_tmps_ix] = sv;
6133 =for apidoc sv_2mortal
6135 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6136 by an explicit call to FREETMPS, or by an implicit call at places such as
6137 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6143 Perl_sv_2mortal(pTHX_ register SV *sv)
6147 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6150 PL_tmps_stack[++PL_tmps_ix] = sv;
6158 Creates a new SV and copies a string into it. The reference count for the
6159 SV is set to 1. If C<len> is zero, Perl will compute the length using
6160 strlen(). For efficiency, consider using C<newSVpvn> instead.
6166 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6173 sv_setpvn(sv,s,len);
6178 =for apidoc newSVpvn
6180 Creates a new SV and copies a string into it. The reference count for the
6181 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6182 string. You are responsible for ensuring that the source string is at least
6189 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6194 sv_setpvn(sv,s,len);
6199 =for apidoc newSVpvn_share
6201 Creates a new SV with its SvPVX pointing to a shared string in the string
6202 table. If the string does not already exist in the table, it is created
6203 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6204 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6205 otherwise the hash is computed. The idea here is that as the string table
6206 is used for shared hash keys these strings will have SvPVX == HeKEY and
6207 hash lookup will avoid string compare.
6213 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6216 bool is_utf8 = FALSE;
6218 STRLEN tmplen = -len;
6220 /* See the note in hv.c:hv_fetch() --jhi */
6221 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6225 PERL_HASH(hash, src, len);
6227 sv_upgrade(sv, SVt_PVIV);
6228 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6241 #if defined(PERL_IMPLICIT_CONTEXT)
6243 /* pTHX_ magic can't cope with varargs, so this is a no-context
6244 * version of the main function, (which may itself be aliased to us).
6245 * Don't access this version directly.
6249 Perl_newSVpvf_nocontext(const char* pat, ...)
6254 va_start(args, pat);
6255 sv = vnewSVpvf(pat, &args);
6262 =for apidoc newSVpvf
6264 Creates a new SV and initializes it with the string formatted like
6271 Perl_newSVpvf(pTHX_ const char* pat, ...)
6275 va_start(args, pat);
6276 sv = vnewSVpvf(pat, &args);
6281 /* backend for newSVpvf() and newSVpvf_nocontext() */
6284 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6288 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6295 Creates a new SV and copies a floating point value into it.
6296 The reference count for the SV is set to 1.
6302 Perl_newSVnv(pTHX_ NV n)
6314 Creates a new SV and copies an integer into it. The reference count for the
6321 Perl_newSViv(pTHX_ IV i)
6333 Creates a new SV and copies an unsigned integer into it.
6334 The reference count for the SV is set to 1.
6340 Perl_newSVuv(pTHX_ UV u)
6350 =for apidoc newRV_noinc
6352 Creates an RV wrapper for an SV. The reference count for the original
6353 SV is B<not> incremented.
6359 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6364 sv_upgrade(sv, SVt_RV);
6371 /* newRV_inc is the official function name to use now.
6372 * newRV_inc is in fact #defined to newRV in sv.h
6376 Perl_newRV(pTHX_ SV *tmpRef)
6378 return newRV_noinc(SvREFCNT_inc(tmpRef));
6384 Creates a new SV which is an exact duplicate of the original SV.
6391 Perl_newSVsv(pTHX_ register SV *old)
6397 if (SvTYPE(old) == SVTYPEMASK) {
6398 if (ckWARN_d(WARN_INTERNAL))
6399 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6414 =for apidoc sv_reset
6416 Underlying implementation for the C<reset> Perl function.
6417 Note that the perl-level function is vaguely deprecated.
6423 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6431 char todo[PERL_UCHAR_MAX+1];
6436 if (!*s) { /* reset ?? searches */
6437 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6438 pm->op_pmdynflags &= ~PMdf_USED;
6443 /* reset variables */
6445 if (!HvARRAY(stash))
6448 Zero(todo, 256, char);
6450 i = (unsigned char)*s;
6454 max = (unsigned char)*s++;
6455 for ( ; i <= max; i++) {
6458 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6459 for (entry = HvARRAY(stash)[i];
6461 entry = HeNEXT(entry))
6463 if (!todo[(U8)*HeKEY(entry)])
6465 gv = (GV*)HeVAL(entry);
6467 if (SvTHINKFIRST(sv)) {
6468 if (!SvREADONLY(sv) && SvROK(sv))
6473 if (SvTYPE(sv) >= SVt_PV) {
6475 if (SvPVX(sv) != Nullch)
6482 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6484 #ifdef USE_ENVIRON_ARRAY
6486 environ[0] = Nullch;
6497 Using various gambits, try to get an IO from an SV: the IO slot if its a
6498 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6499 named after the PV if we're a string.
6505 Perl_sv_2io(pTHX_ SV *sv)
6511 switch (SvTYPE(sv)) {
6519 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6523 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6525 return sv_2io(SvRV(sv));
6526 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6532 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6541 Using various gambits, try to get a CV from an SV; in addition, try if
6542 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6548 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6555 return *gvp = Nullgv, Nullcv;
6556 switch (SvTYPE(sv)) {
6575 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6576 tryAMAGICunDEREF(to_cv);
6579 if (SvTYPE(sv) == SVt_PVCV) {
6588 Perl_croak(aTHX_ "Not a subroutine reference");
6593 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6599 if (lref && !GvCVu(gv)) {
6602 tmpsv = NEWSV(704,0);
6603 gv_efullname3(tmpsv, gv, Nullch);
6604 /* XXX this is probably not what they think they're getting.
6605 * It has the same effect as "sub name;", i.e. just a forward
6607 newSUB(start_subparse(FALSE, 0),
6608 newSVOP(OP_CONST, 0, tmpsv),
6613 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6622 Returns true if the SV has a true value by Perl's rules.
6623 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6624 instead use an in-line version.
6630 Perl_sv_true(pTHX_ register SV *sv)
6636 if ((tXpv = (XPV*)SvANY(sv)) &&
6637 (tXpv->xpv_cur > 1 ||
6638 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6645 return SvIVX(sv) != 0;
6648 return SvNVX(sv) != 0.0;
6650 return sv_2bool(sv);
6658 A private implementation of the C<SvIVx> macro for compilers which can't
6659 cope with complex macro expressions. Always use the macro instead.
6665 Perl_sv_iv(pTHX_ register SV *sv)
6669 return (IV)SvUVX(sv);
6678 A private implementation of the C<SvUVx> macro for compilers which can't
6679 cope with complex macro expressions. Always use the macro instead.
6685 Perl_sv_uv(pTHX_ register SV *sv)
6690 return (UV)SvIVX(sv);
6698 A private implementation of the C<SvNVx> macro for compilers which can't
6699 cope with complex macro expressions. Always use the macro instead.
6705 Perl_sv_nv(pTHX_ register SV *sv)
6715 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6716 cope with complex macro expressions. Always use the macro instead.
6722 Perl_sv_pv(pTHX_ SV *sv)
6729 return sv_2pv(sv, &n_a);
6735 A private implementation of the C<SvPV> macro for compilers which can't
6736 cope with complex macro expressions. Always use the macro instead.
6742 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6748 return sv_2pv(sv, lp);
6751 /* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
6755 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
6761 return sv_2pv_flags(sv, lp, 0);
6765 =for apidoc sv_pvn_force
6767 Get a sensible string out of the SV somehow.
6768 A private implementation of the C<SvPV_force> macro for compilers which
6769 can't cope with complex macro expressions. Always use the macro instead.
6775 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6777 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6781 =for apidoc sv_pvn_force_flags
6783 Get a sensible string out of the SV somehow.
6784 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6785 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6786 implemented in terms of this function.
6787 You normally want to use the various wrapper macros instead: see
6788 C<SvPV_force> and C<SvPV_force_nomg>
6794 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6798 if (SvTHINKFIRST(sv) && !SvROK(sv))
6799 sv_force_normal(sv);
6805 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6806 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6810 s = sv_2pv_flags(sv, lp, flags);
6811 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6816 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6817 SvGROW(sv, len + 1);
6818 Move(s,SvPVX(sv),len,char);
6823 SvPOK_on(sv); /* validate pointer */
6825 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6826 PTR2UV(sv),SvPVX(sv)));
6833 =for apidoc sv_pvbyte
6835 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6836 which can't cope with complex macro expressions. Always use the macro
6843 Perl_sv_pvbyte(pTHX_ SV *sv)
6845 sv_utf8_downgrade(sv,0);
6850 =for apidoc sv_pvbyten
6852 A private implementation of the C<SvPVbyte> macro for compilers
6853 which can't cope with complex macro expressions. Always use the macro
6860 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6862 sv_utf8_downgrade(sv,0);
6863 return sv_pvn(sv,lp);
6867 =for apidoc sv_pvbyten_force
6869 A private implementation of the C<SvPVbytex_force> macro for compilers
6870 which can't cope with complex macro expressions. Always use the macro
6877 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6879 sv_utf8_downgrade(sv,0);
6880 return sv_pvn_force(sv,lp);
6884 =for apidoc sv_pvutf8
6886 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6887 which can't cope with complex macro expressions. Always use the macro
6894 Perl_sv_pvutf8(pTHX_ SV *sv)
6896 sv_utf8_upgrade(sv);
6901 =for apidoc sv_pvutf8n
6903 A private implementation of the C<SvPVutf8> macro for compilers
6904 which can't cope with complex macro expressions. Always use the macro
6911 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6913 sv_utf8_upgrade(sv);
6914 return sv_pvn(sv,lp);
6918 =for apidoc sv_pvutf8n_force
6920 A private implementation of the C<SvPVutf8_force> macro for compilers
6921 which can't cope with complex macro expressions. Always use the macro
6928 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6930 sv_utf8_upgrade(sv);
6931 return sv_pvn_force(sv,lp);
6935 =for apidoc sv_reftype
6937 Returns a string describing what the SV is a reference to.
6943 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6945 if (ob && SvOBJECT(sv))
6946 return HvNAME(SvSTASH(sv));
6948 switch (SvTYPE(sv)) {
6962 case SVt_PVLV: return "LVALUE";
6963 case SVt_PVAV: return "ARRAY";
6964 case SVt_PVHV: return "HASH";
6965 case SVt_PVCV: return "CODE";
6966 case SVt_PVGV: return "GLOB";
6967 case SVt_PVFM: return "FORMAT";
6968 case SVt_PVIO: return "IO";
6969 default: return "UNKNOWN";
6975 =for apidoc sv_isobject
6977 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6978 object. If the SV is not an RV, or if the object is not blessed, then this
6985 Perl_sv_isobject(pTHX_ SV *sv)
7002 Returns a boolean indicating whether the SV is blessed into the specified
7003 class. This does not check for subtypes; use C<sv_derived_from> to verify
7004 an inheritance relationship.
7010 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7022 return strEQ(HvNAME(SvSTASH(sv)), name);
7028 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7029 it will be upgraded to one. If C<classname> is non-null then the new SV will
7030 be blessed in the specified package. The new SV is returned and its
7031 reference count is 1.
7037 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7043 SV_CHECK_THINKFIRST(rv);
7046 if (SvTYPE(rv) >= SVt_PVMG) {
7047 U32 refcnt = SvREFCNT(rv);
7051 SvREFCNT(rv) = refcnt;
7054 if (SvTYPE(rv) < SVt_RV)
7055 sv_upgrade(rv, SVt_RV);
7056 else if (SvTYPE(rv) > SVt_RV) {
7057 (void)SvOOK_off(rv);
7058 if (SvPVX(rv) && SvLEN(rv))
7059 Safefree(SvPVX(rv));
7069 HV* stash = gv_stashpv(classname, TRUE);
7070 (void)sv_bless(rv, stash);
7076 =for apidoc sv_setref_pv
7078 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7079 argument will be upgraded to an RV. That RV will be modified to point to
7080 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7081 into the SV. The C<classname> argument indicates the package for the
7082 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7083 will be returned and will have a reference count of 1.
7085 Do not use with other Perl types such as HV, AV, SV, CV, because those
7086 objects will become corrupted by the pointer copy process.
7088 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7094 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7097 sv_setsv(rv, &PL_sv_undef);
7101 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7106 =for apidoc sv_setref_iv
7108 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7109 argument will be upgraded to an RV. That RV will be modified to point to
7110 the new SV. The C<classname> argument indicates the package for the
7111 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7112 will be returned and will have a reference count of 1.
7118 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7120 sv_setiv(newSVrv(rv,classname), iv);
7125 =for apidoc sv_setref_uv
7127 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7128 argument will be upgraded to an RV. That RV will be modified to point to
7129 the new SV. The C<classname> argument indicates the package for the
7130 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7131 will be returned and will have a reference count of 1.
7137 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7139 sv_setuv(newSVrv(rv,classname), uv);
7144 =for apidoc sv_setref_nv
7146 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7147 argument will be upgraded to an RV. That RV will be modified to point to
7148 the new SV. The C<classname> argument indicates the package for the
7149 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7150 will be returned and will have a reference count of 1.
7156 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7158 sv_setnv(newSVrv(rv,classname), nv);
7163 =for apidoc sv_setref_pvn
7165 Copies a string into a new SV, optionally blessing the SV. The length of the
7166 string must be specified with C<n>. The C<rv> argument will be upgraded to
7167 an RV. That RV will be modified to point to the new SV. The C<classname>
7168 argument indicates the package for the blessing. Set C<classname> to
7169 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7170 a reference count of 1.
7172 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7178 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7180 sv_setpvn(newSVrv(rv,classname), pv, n);
7185 =for apidoc sv_bless
7187 Blesses an SV into a specified package. The SV must be an RV. The package
7188 must be designated by its stash (see C<gv_stashpv()>). The reference count
7189 of the SV is unaffected.
7195 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7199 Perl_croak(aTHX_ "Can't bless non-reference value");
7201 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7202 if (SvREADONLY(tmpRef))
7203 Perl_croak(aTHX_ PL_no_modify);
7204 if (SvOBJECT(tmpRef)) {
7205 if (SvTYPE(tmpRef) != SVt_PVIO)
7207 SvREFCNT_dec(SvSTASH(tmpRef));
7210 SvOBJECT_on(tmpRef);
7211 if (SvTYPE(tmpRef) != SVt_PVIO)
7213 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7214 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7221 if(SvSMAGICAL(tmpRef))
7222 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7230 /* Downgrades a PVGV to a PVMG.
7232 * XXX This function doesn't actually appear to be used anywhere
7237 S_sv_unglob(pTHX_ SV *sv)
7241 assert(SvTYPE(sv) == SVt_PVGV);
7246 SvREFCNT_dec(GvSTASH(sv));
7247 GvSTASH(sv) = Nullhv;
7249 sv_unmagic(sv, PERL_MAGIC_glob);
7250 Safefree(GvNAME(sv));
7253 /* need to keep SvANY(sv) in the right arena */
7254 xpvmg = new_XPVMG();
7255 StructCopy(SvANY(sv), xpvmg, XPVMG);
7256 del_XPVGV(SvANY(sv));
7259 SvFLAGS(sv) &= ~SVTYPEMASK;
7260 SvFLAGS(sv) |= SVt_PVMG;
7264 =for apidoc sv_unref_flags
7266 Unsets the RV status of the SV, and decrements the reference count of
7267 whatever was being referenced by the RV. This can almost be thought of
7268 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7269 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7270 (otherwise the decrementing is conditional on the reference count being
7271 different from one or the reference being a readonly SV).
7278 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7282 if (SvWEAKREF(sv)) {
7290 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7292 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7293 sv_2mortal(rv); /* Schedule for freeing later */
7297 =for apidoc sv_unref
7299 Unsets the RV status of the SV, and decrements the reference count of
7300 whatever was being referenced by the RV. This can almost be thought of
7301 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7302 being zero. See C<SvROK_off>.
7308 Perl_sv_unref(pTHX_ SV *sv)
7310 sv_unref_flags(sv, 0);
7314 =for apidoc sv_taint
7316 Taint an SV. Use C<SvTAINTED_on> instead.
7321 Perl_sv_taint(pTHX_ SV *sv)
7323 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7327 =for apidoc sv_untaint
7329 Untaint an SV. Use C<SvTAINTED_off> instead.
7334 Perl_sv_untaint(pTHX_ SV *sv)
7336 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7337 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7344 =for apidoc sv_tainted
7346 Test an SV for taintedness. Use C<SvTAINTED> instead.
7351 Perl_sv_tainted(pTHX_ SV *sv)
7353 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7354 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7355 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7362 =for apidoc sv_setpviv
7364 Copies an integer into the given SV, also updating its string value.
7365 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7371 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7373 char buf[TYPE_CHARS(UV)];
7375 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7377 sv_setpvn(sv, ptr, ebuf - ptr);
7381 =for apidoc sv_setpviv_mg
7383 Like C<sv_setpviv>, but also handles 'set' magic.
7389 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7391 char buf[TYPE_CHARS(UV)];
7393 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7395 sv_setpvn(sv, ptr, ebuf - ptr);
7399 #if defined(PERL_IMPLICIT_CONTEXT)
7401 /* pTHX_ magic can't cope with varargs, so this is a no-context
7402 * version of the main function, (which may itself be aliased to us).
7403 * Don't access this version directly.
7407 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7411 va_start(args, pat);
7412 sv_vsetpvf(sv, pat, &args);
7416 /* pTHX_ magic can't cope with varargs, so this is a no-context
7417 * version of the main function, (which may itself be aliased to us).
7418 * Don't access this version directly.
7422 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7426 va_start(args, pat);
7427 sv_vsetpvf_mg(sv, pat, &args);
7433 =for apidoc sv_setpvf
7435 Processes its arguments like C<sprintf> and sets an SV to the formatted
7436 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7442 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7445 va_start(args, pat);
7446 sv_vsetpvf(sv, pat, &args);
7450 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7453 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7455 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7459 =for apidoc sv_setpvf_mg
7461 Like C<sv_setpvf>, but also handles 'set' magic.
7467 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7470 va_start(args, pat);
7471 sv_vsetpvf_mg(sv, pat, &args);
7475 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7478 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7480 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7484 #if defined(PERL_IMPLICIT_CONTEXT)
7486 /* pTHX_ magic can't cope with varargs, so this is a no-context
7487 * version of the main function, (which may itself be aliased to us).
7488 * Don't access this version directly.
7492 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7496 va_start(args, pat);
7497 sv_vcatpvf(sv, pat, &args);
7501 /* pTHX_ magic can't cope with varargs, so this is a no-context
7502 * version of the main function, (which may itself be aliased to us).
7503 * Don't access this version directly.
7507 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7511 va_start(args, pat);
7512 sv_vcatpvf_mg(sv, pat, &args);
7518 =for apidoc sv_catpvf
7520 Processes its arguments like C<sprintf> and appends the formatted
7521 output to an SV. If the appended data contains "wide" characters
7522 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7523 and characters >255 formatted with %c), the original SV might get
7524 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7525 C<SvSETMAGIC()> must typically be called after calling this function
7526 to handle 'set' magic.
7531 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7534 va_start(args, pat);
7535 sv_vcatpvf(sv, pat, &args);
7539 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7542 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7544 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7548 =for apidoc sv_catpvf_mg
7550 Like C<sv_catpvf>, but also handles 'set' magic.
7556 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7559 va_start(args, pat);
7560 sv_vcatpvf_mg(sv, pat, &args);
7564 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7567 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7569 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7574 =for apidoc sv_vsetpvfn
7576 Works like C<vcatpvfn> but copies the text into the SV instead of
7579 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7585 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7587 sv_setpvn(sv, "", 0);
7588 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7591 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7594 S_expect_number(pTHX_ char** pattern)
7597 switch (**pattern) {
7598 case '1': case '2': case '3':
7599 case '4': case '5': case '6':
7600 case '7': case '8': case '9':
7601 while (isDIGIT(**pattern))
7602 var = var * 10 + (*(*pattern)++ - '0');
7606 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7609 =for apidoc sv_vcatpvfn
7611 Processes its arguments like C<vsprintf> and appends the formatted output
7612 to an SV. Uses an array of SVs if the C style variable argument list is
7613 missing (NULL). When running with taint checks enabled, indicates via
7614 C<maybe_tainted> if results are untrustworthy (often due to the use of
7617 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7623 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7630 static char nullstr[] = "(null)";
7633 /* no matter what, this is a string now */
7634 (void)SvPV_force(sv, origlen);
7636 /* special-case "", "%s", and "%_" */
7639 if (patlen == 2 && pat[0] == '%') {
7643 char *s = va_arg(*args, char*);
7644 sv_catpv(sv, s ? s : nullstr);
7646 else if (svix < svmax) {
7647 sv_catsv(sv, *svargs);
7648 if (DO_UTF8(*svargs))
7654 argsv = va_arg(*args, SV*);
7655 sv_catsv(sv, argsv);
7660 /* See comment on '_' below */
7665 patend = (char*)pat + patlen;
7666 for (p = (char*)pat; p < patend; p = q) {
7669 bool vectorize = FALSE;
7670 bool vectorarg = FALSE;
7671 bool vec_utf = FALSE;
7677 bool has_precis = FALSE;
7679 bool is_utf = FALSE;
7682 U8 utf8buf[UTF8_MAXLEN+1];
7683 STRLEN esignlen = 0;
7685 char *eptr = Nullch;
7687 /* Times 4: a decimal digit takes more than 3 binary digits.
7688 * NV_DIG: mantissa takes than many decimal digits.
7689 * Plus 32: Playing safe. */
7690 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7691 /* large enough for "%#.#f" --chip */
7692 /* what about long double NVs? --jhi */
7695 U8 *vecstr = Null(U8*);
7707 STRLEN dotstrlen = 1;
7708 I32 efix = 0; /* explicit format parameter index */
7709 I32 ewix = 0; /* explicit width index */
7710 I32 epix = 0; /* explicit precision index */
7711 I32 evix = 0; /* explicit vector index */
7712 bool asterisk = FALSE;
7714 /* echo everything up to the next format specification */
7715 for (q = p; q < patend && *q != '%'; ++q) ;
7717 sv_catpvn(sv, p, q - p);
7724 We allow format specification elements in this order:
7725 \d+\$ explicit format parameter index
7727 \*?(\d+\$)?v vector with optional (optionally specified) arg
7728 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7729 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7731 [%bcdefginopsux_DFOUX] format (mandatory)
7733 if (EXPECT_NUMBER(q, width)) {
7774 if (EXPECT_NUMBER(q, ewix))
7783 if ((vectorarg = asterisk)) {
7793 EXPECT_NUMBER(q, width);
7798 vecsv = va_arg(*args, SV*);
7800 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7801 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7802 dotstr = SvPVx(vecsv, dotstrlen);
7807 vecsv = va_arg(*args, SV*);
7808 vecstr = (U8*)SvPVx(vecsv,veclen);
7809 vec_utf = DO_UTF8(vecsv);
7811 else if (efix ? efix <= svmax : svix < svmax) {
7812 vecsv = svargs[efix ? efix-1 : svix++];
7813 vecstr = (U8*)SvPVx(vecsv,veclen);
7814 vec_utf = DO_UTF8(vecsv);
7824 i = va_arg(*args, int);
7826 i = (ewix ? ewix <= svmax : svix < svmax) ?
7827 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7829 width = (i < 0) ? -i : i;
7839 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7842 i = va_arg(*args, int);
7844 i = (ewix ? ewix <= svmax : svix < svmax)
7845 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7846 precis = (i < 0) ? 0 : i;
7851 precis = precis * 10 + (*q++ - '0');
7859 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7870 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7871 if (*(q + 1) == 'l') { /* lld, llf */
7894 argsv = (efix ? efix <= svmax : svix < svmax) ?
7895 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7902 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7904 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7906 eptr = (char*)utf8buf;
7907 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7919 eptr = va_arg(*args, char*);
7921 #ifdef MACOS_TRADITIONAL
7922 /* On MacOS, %#s format is used for Pascal strings */
7927 elen = strlen(eptr);
7930 elen = sizeof nullstr - 1;
7934 eptr = SvPVx(argsv, elen);
7935 if (DO_UTF8(argsv)) {
7936 if (has_precis && precis < elen) {
7938 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7941 if (width) { /* fudge width (can't fudge elen) */
7942 width += elen - sv_len_utf8(argsv);
7951 * The "%_" hack might have to be changed someday,
7952 * if ISO or ANSI decide to use '_' for something.
7953 * So we keep it hidden from users' code.
7957 argsv = va_arg(*args, SV*);
7958 eptr = SvPVx(argsv, elen);
7964 if (has_precis && elen > precis)
7973 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7991 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
7999 esignbuf[esignlen++] = plus;
8003 case 'h': iv = (short)va_arg(*args, int); break;
8004 default: iv = va_arg(*args, int); break;
8005 case 'l': iv = va_arg(*args, long); break;
8006 case 'V': iv = va_arg(*args, IV); break;
8008 case 'q': iv = va_arg(*args, Quad_t); break;
8015 case 'h': iv = (short)iv; break;
8017 case 'l': iv = (long)iv; break;
8020 case 'q': iv = (Quad_t)iv; break;
8024 if ( !vectorize ) /* we already set uv above */
8029 esignbuf[esignlen++] = plus;
8033 esignbuf[esignlen++] = '-';
8076 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8086 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8087 default: uv = va_arg(*args, unsigned); break;
8088 case 'l': uv = va_arg(*args, unsigned long); break;
8089 case 'V': uv = va_arg(*args, UV); break;
8091 case 'q': uv = va_arg(*args, Quad_t); break;
8098 case 'h': uv = (unsigned short)uv; break;
8100 case 'l': uv = (unsigned long)uv; break;
8103 case 'q': uv = (Quad_t)uv; break;
8109 eptr = ebuf + sizeof ebuf;
8115 p = (char*)((c == 'X')
8116 ? "0123456789ABCDEF" : "0123456789abcdef");
8122 esignbuf[esignlen++] = '0';
8123 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8129 *--eptr = '0' + dig;
8131 if (alt && *eptr != '0')
8137 *--eptr = '0' + dig;
8140 esignbuf[esignlen++] = '0';
8141 esignbuf[esignlen++] = 'b';
8144 default: /* it had better be ten or less */
8145 #if defined(PERL_Y2KWARN)
8146 if (ckWARN(WARN_Y2K)) {
8148 char *s = SvPV(sv,n);
8149 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8150 && (n == 2 || !isDIGIT(s[n-3])))
8152 Perl_warner(aTHX_ WARN_Y2K,
8153 "Possible Y2K bug: %%%c %s",
8154 c, "format string following '19'");
8160 *--eptr = '0' + dig;
8161 } while (uv /= base);
8164 elen = (ebuf + sizeof ebuf) - eptr;
8167 zeros = precis - elen;
8168 else if (precis == 0 && elen == 1 && *eptr == '0')
8173 /* FLOATING POINT */
8176 c = 'f'; /* maybe %F isn't supported here */
8182 /* This is evil, but floating point is even more evil */
8185 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8188 if (c != 'e' && c != 'E') {
8190 (void)Perl_frexp(nv, &i);
8191 if (i == PERL_INT_MIN)
8192 Perl_die(aTHX_ "panic: frexp");
8194 need = BIT_DIGITS(i);
8196 need += has_precis ? precis : 6; /* known default */
8200 need += 20; /* fudge factor */
8201 if (PL_efloatsize < need) {
8202 Safefree(PL_efloatbuf);
8203 PL_efloatsize = need + 20; /* more fudge */
8204 New(906, PL_efloatbuf, PL_efloatsize, char);
8205 PL_efloatbuf[0] = '\0';
8208 eptr = ebuf + sizeof ebuf;
8211 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8213 /* Copy the one or more characters in a long double
8214 * format before the 'base' ([efgEFG]) character to
8215 * the format string. */
8216 static char const prifldbl[] = PERL_PRIfldbl;
8217 char const *p = prifldbl + sizeof(prifldbl) - 3;
8218 while (p >= prifldbl) { *--eptr = *p--; }
8223 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8228 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8240 /* No taint. Otherwise we are in the strange situation
8241 * where printf() taints but print($float) doesn't.
8243 (void)sprintf(PL_efloatbuf, eptr, nv);
8245 eptr = PL_efloatbuf;
8246 elen = strlen(PL_efloatbuf);
8253 i = SvCUR(sv) - origlen;
8256 case 'h': *(va_arg(*args, short*)) = i; break;
8257 default: *(va_arg(*args, int*)) = i; break;
8258 case 'l': *(va_arg(*args, long*)) = i; break;
8259 case 'V': *(va_arg(*args, IV*)) = i; break;
8261 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8266 sv_setuv_mg(argsv, (UV)i);
8267 continue; /* not "break" */
8274 if (!args && ckWARN(WARN_PRINTF) &&
8275 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8276 SV *msg = sv_newmortal();
8277 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8278 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8281 Perl_sv_catpvf(aTHX_ msg,
8282 "\"%%%c\"", c & 0xFF);
8284 Perl_sv_catpvf(aTHX_ msg,
8285 "\"%%\\%03"UVof"\"",
8288 sv_catpv(msg, "end of string");
8289 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8292 /* output mangled stuff ... */
8298 /* ... right here, because formatting flags should not apply */
8299 SvGROW(sv, SvCUR(sv) + elen + 1);
8301 Copy(eptr, p, elen, char);
8304 SvCUR(sv) = p - SvPVX(sv);
8305 continue; /* not "break" */
8308 have = esignlen + zeros + elen;
8309 need = (have > width ? have : width);
8312 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8314 if (esignlen && fill == '0') {
8315 for (i = 0; i < esignlen; i++)
8319 memset(p, fill, gap);
8322 if (esignlen && fill != '0') {
8323 for (i = 0; i < esignlen; i++)
8327 for (i = zeros; i; i--)
8331 Copy(eptr, p, elen, char);
8335 memset(p, ' ', gap);
8340 Copy(dotstr, p, dotstrlen, char);
8344 vectorize = FALSE; /* done iterating over vecstr */
8349 SvCUR(sv) = p - SvPVX(sv);
8357 /* =========================================================================
8359 =head1 Cloning an interpreter
8361 All the macros and functions in this section are for the private use of
8362 the main function, perl_clone().
8364 The foo_dup() functions make an exact copy of an existing foo thinngy.
8365 During the course of a cloning, a hash table is used to map old addresses
8366 to new addresses. The table is created and manipulated with the
8367 ptr_table_* functions.
8371 ============================================================================*/
8374 #if defined(USE_ITHREADS)
8376 #if defined(USE_5005THREADS)
8377 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8380 #ifndef GpREFCNT_inc
8381 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8385 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8386 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8387 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8388 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8389 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8390 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8391 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8392 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8393 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8394 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8395 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8396 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8397 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8400 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8401 regcomp.c. AMS 20010712 */
8404 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8408 struct reg_substr_datum *s;
8411 return (REGEXP *)NULL;
8413 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8416 len = r->offsets[0];
8417 npar = r->nparens+1;
8419 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8420 Copy(r->program, ret->program, len+1, regnode);
8422 New(0, ret->startp, npar, I32);
8423 Copy(r->startp, ret->startp, npar, I32);
8424 New(0, ret->endp, npar, I32);
8425 Copy(r->startp, ret->startp, npar, I32);
8427 New(0, ret->substrs, 1, struct reg_substr_data);
8428 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8429 s->min_offset = r->substrs->data[i].min_offset;
8430 s->max_offset = r->substrs->data[i].max_offset;
8431 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8434 ret->regstclass = NULL;
8437 int count = r->data->count;
8439 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8440 char, struct reg_data);
8441 New(0, d->what, count, U8);
8444 for (i = 0; i < count; i++) {
8445 d->what[i] = r->data->what[i];
8446 switch (d->what[i]) {
8448 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8451 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8454 /* This is cheating. */
8455 New(0, d->data[i], 1, struct regnode_charclass_class);
8456 StructCopy(r->data->data[i], d->data[i],
8457 struct regnode_charclass_class);
8458 ret->regstclass = (regnode*)d->data[i];
8461 /* Compiled op trees are readonly, and can thus be
8462 shared without duplication. */
8463 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8466 d->data[i] = r->data->data[i];
8476 New(0, ret->offsets, 2*len+1, U32);
8477 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8479 ret->precomp = SAVEPV(r->precomp);
8480 ret->refcnt = r->refcnt;
8481 ret->minlen = r->minlen;
8482 ret->prelen = r->prelen;
8483 ret->nparens = r->nparens;
8484 ret->lastparen = r->lastparen;
8485 ret->lastcloseparen = r->lastcloseparen;
8486 ret->reganch = r->reganch;
8488 ret->sublen = r->sublen;
8490 if (RX_MATCH_COPIED(ret))
8491 ret->subbeg = SAVEPV(r->subbeg);
8493 ret->subbeg = Nullch;
8495 ptr_table_store(PL_ptr_table, r, ret);
8499 /* duplicate a file handle */
8502 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8506 return (PerlIO*)NULL;
8508 /* look for it in the table first */
8509 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8513 /* create anew and remember what it is */
8514 ret = PerlIO_fdupopen(aTHX_ fp, param);
8515 ptr_table_store(PL_ptr_table, fp, ret);
8519 /* duplicate a directory handle */
8522 Perl_dirp_dup(pTHX_ DIR *dp)
8530 /* duplicate a typeglob */
8533 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8538 /* look for it in the table first */
8539 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8543 /* create anew and remember what it is */
8544 Newz(0, ret, 1, GP);
8545 ptr_table_store(PL_ptr_table, gp, ret);
8548 ret->gp_refcnt = 0; /* must be before any other dups! */
8549 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8550 ret->gp_io = io_dup_inc(gp->gp_io, param);
8551 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8552 ret->gp_av = av_dup_inc(gp->gp_av, param);
8553 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8554 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8555 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8556 ret->gp_cvgen = gp->gp_cvgen;
8557 ret->gp_flags = gp->gp_flags;
8558 ret->gp_line = gp->gp_line;
8559 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8563 /* duplicate a chain of magic */
8566 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8568 MAGIC *mgprev = (MAGIC*)NULL;
8571 return (MAGIC*)NULL;
8572 /* look for it in the table first */
8573 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8577 for (; mg; mg = mg->mg_moremagic) {
8579 Newz(0, nmg, 1, MAGIC);
8581 mgprev->mg_moremagic = nmg;
8584 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8585 nmg->mg_private = mg->mg_private;
8586 nmg->mg_type = mg->mg_type;
8587 nmg->mg_flags = mg->mg_flags;
8588 if (mg->mg_type == PERL_MAGIC_qr) {
8589 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8591 else if(mg->mg_type == PERL_MAGIC_backref) {
8592 AV *av = (AV*) mg->mg_obj;
8595 nmg->mg_obj = (SV*)newAV();
8599 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8604 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8605 ? sv_dup_inc(mg->mg_obj, param)
8606 : sv_dup(mg->mg_obj, param);
8608 nmg->mg_len = mg->mg_len;
8609 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8610 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8611 if (mg->mg_len >= 0) {
8612 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8613 if (mg->mg_type == PERL_MAGIC_overload_table &&
8614 AMT_AMAGIC((AMT*)mg->mg_ptr))
8616 AMT *amtp = (AMT*)mg->mg_ptr;
8617 AMT *namtp = (AMT*)nmg->mg_ptr;
8619 for (i = 1; i < NofAMmeth; i++) {
8620 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8624 else if (mg->mg_len == HEf_SVKEY)
8625 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8632 /* create a new pointer-mapping table */
8635 Perl_ptr_table_new(pTHX)
8638 Newz(0, tbl, 1, PTR_TBL_t);
8641 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8645 /* map an existing pointer using a table */
8648 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8650 PTR_TBL_ENT_t *tblent;
8651 UV hash = PTR2UV(sv);
8653 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8654 for (; tblent; tblent = tblent->next) {
8655 if (tblent->oldval == sv)
8656 return tblent->newval;
8661 /* add a new entry to a pointer-mapping table */
8664 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8666 PTR_TBL_ENT_t *tblent, **otblent;
8667 /* XXX this may be pessimal on platforms where pointers aren't good
8668 * hash values e.g. if they grow faster in the most significant
8670 UV hash = PTR2UV(oldv);
8674 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8675 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8676 if (tblent->oldval == oldv) {
8677 tblent->newval = newv;
8682 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8683 tblent->oldval = oldv;
8684 tblent->newval = newv;
8685 tblent->next = *otblent;
8688 if (i && tbl->tbl_items > tbl->tbl_max)
8689 ptr_table_split(tbl);
8692 /* double the hash bucket size of an existing ptr table */
8695 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8697 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8698 UV oldsize = tbl->tbl_max + 1;
8699 UV newsize = oldsize * 2;
8702 Renew(ary, newsize, PTR_TBL_ENT_t*);
8703 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8704 tbl->tbl_max = --newsize;
8706 for (i=0; i < oldsize; i++, ary++) {
8707 PTR_TBL_ENT_t **curentp, **entp, *ent;
8710 curentp = ary + oldsize;
8711 for (entp = ary, ent = *ary; ent; ent = *entp) {
8712 if ((newsize & PTR2UV(ent->oldval)) != i) {
8714 ent->next = *curentp;
8724 /* remove all the entries from a ptr table */
8727 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8729 register PTR_TBL_ENT_t **array;
8730 register PTR_TBL_ENT_t *entry;
8731 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8735 if (!tbl || !tbl->tbl_items) {
8739 array = tbl->tbl_ary;
8746 entry = entry->next;
8750 if (++riter > max) {
8753 entry = array[riter];
8760 /* clear and free a ptr table */
8763 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8768 ptr_table_clear(tbl);
8769 Safefree(tbl->tbl_ary);
8777 /* attempt to make everything in the typeglob readonly */
8780 S_gv_share(pTHX_ SV *sstr)
8783 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8785 if (GvIO(gv) || GvFORM(gv)) {
8786 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8788 else if (!GvCV(gv)) {
8792 /* CvPADLISTs cannot be shared */
8793 if (!CvXSUB(GvCV(gv))) {
8798 if (!GvUNIQUE(gv)) {
8800 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8801 HvNAME(GvSTASH(gv)), GvNAME(gv));
8807 * write attempts will die with
8808 * "Modification of a read-only value attempted"
8814 SvREADONLY_on(GvSV(gv));
8821 SvREADONLY_on(GvAV(gv));
8828 SvREADONLY_on(GvAV(gv));
8831 return sstr; /* he_dup() will SvREFCNT_inc() */
8834 /* duplicate an SV of any type (including AV, HV etc) */
8837 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
8841 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8843 /* look for it in the table first */
8844 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8848 /* create anew and remember what it is */
8850 ptr_table_store(PL_ptr_table, sstr, dstr);
8853 SvFLAGS(dstr) = SvFLAGS(sstr);
8854 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8855 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8858 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8859 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8860 PL_watch_pvx, SvPVX(sstr));
8863 switch (SvTYPE(sstr)) {
8868 SvANY(dstr) = new_XIV();
8869 SvIVX(dstr) = SvIVX(sstr);
8872 SvANY(dstr) = new_XNV();
8873 SvNVX(dstr) = SvNVX(sstr);
8876 SvANY(dstr) = new_XRV();
8877 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8878 ? sv_dup(SvRV(sstr), param)
8879 : sv_dup_inc(SvRV(sstr), param);
8882 SvANY(dstr) = new_XPV();
8883 SvCUR(dstr) = SvCUR(sstr);
8884 SvLEN(dstr) = SvLEN(sstr);
8886 SvRV(dstr) = SvWEAKREF(sstr)
8887 ? sv_dup(SvRV(sstr), param)
8888 : sv_dup_inc(SvRV(sstr), param);
8889 else if (SvPVX(sstr) && SvLEN(sstr))
8890 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8892 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8895 SvANY(dstr) = new_XPVIV();
8896 SvCUR(dstr) = SvCUR(sstr);
8897 SvLEN(dstr) = SvLEN(sstr);
8898 SvIVX(dstr) = SvIVX(sstr);
8900 SvRV(dstr) = SvWEAKREF(sstr)
8901 ? sv_dup(SvRV(sstr), param)
8902 : sv_dup_inc(SvRV(sstr), param);
8903 else if (SvPVX(sstr) && SvLEN(sstr))
8904 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8906 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8909 SvANY(dstr) = new_XPVNV();
8910 SvCUR(dstr) = SvCUR(sstr);
8911 SvLEN(dstr) = SvLEN(sstr);
8912 SvIVX(dstr) = SvIVX(sstr);
8913 SvNVX(dstr) = SvNVX(sstr);
8915 SvRV(dstr) = SvWEAKREF(sstr)
8916 ? sv_dup(SvRV(sstr), param)
8917 : sv_dup_inc(SvRV(sstr), param);
8918 else if (SvPVX(sstr) && SvLEN(sstr))
8919 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8921 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8924 SvANY(dstr) = new_XPVMG();
8925 SvCUR(dstr) = SvCUR(sstr);
8926 SvLEN(dstr) = SvLEN(sstr);
8927 SvIVX(dstr) = SvIVX(sstr);
8928 SvNVX(dstr) = SvNVX(sstr);
8929 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8930 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8932 SvRV(dstr) = SvWEAKREF(sstr)
8933 ? sv_dup(SvRV(sstr), param)
8934 : sv_dup_inc(SvRV(sstr), param);
8935 else if (SvPVX(sstr) && SvLEN(sstr))
8936 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8938 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8941 SvANY(dstr) = new_XPVBM();
8942 SvCUR(dstr) = SvCUR(sstr);
8943 SvLEN(dstr) = SvLEN(sstr);
8944 SvIVX(dstr) = SvIVX(sstr);
8945 SvNVX(dstr) = SvNVX(sstr);
8946 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8947 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8949 SvRV(dstr) = SvWEAKREF(sstr)
8950 ? sv_dup(SvRV(sstr), param)
8951 : sv_dup_inc(SvRV(sstr), param);
8952 else if (SvPVX(sstr) && SvLEN(sstr))
8953 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8955 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8956 BmRARE(dstr) = BmRARE(sstr);
8957 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8958 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8961 SvANY(dstr) = new_XPVLV();
8962 SvCUR(dstr) = SvCUR(sstr);
8963 SvLEN(dstr) = SvLEN(sstr);
8964 SvIVX(dstr) = SvIVX(sstr);
8965 SvNVX(dstr) = SvNVX(sstr);
8966 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8967 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8969 SvRV(dstr) = SvWEAKREF(sstr)
8970 ? sv_dup(SvRV(sstr), param)
8971 : sv_dup_inc(SvRV(sstr), param);
8972 else if (SvPVX(sstr) && SvLEN(sstr))
8973 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8975 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8976 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8977 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8978 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8979 LvTYPE(dstr) = LvTYPE(sstr);
8982 if (GvUNIQUE((GV*)sstr)) {
8984 if ((share = gv_share(sstr))) {
8988 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8989 HvNAME(GvSTASH(share)), GvNAME(share));
8994 SvANY(dstr) = new_XPVGV();
8995 SvCUR(dstr) = SvCUR(sstr);
8996 SvLEN(dstr) = SvLEN(sstr);
8997 SvIVX(dstr) = SvIVX(sstr);
8998 SvNVX(dstr) = SvNVX(sstr);
8999 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9000 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9002 SvRV(dstr) = SvWEAKREF(sstr)
9003 ? sv_dup(SvRV(sstr), param)
9004 : sv_dup_inc(SvRV(sstr), param);
9005 else if (SvPVX(sstr) && SvLEN(sstr))
9006 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9008 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9009 GvNAMELEN(dstr) = GvNAMELEN(sstr);
9010 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9011 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
9012 GvFLAGS(dstr) = GvFLAGS(sstr);
9013 GvGP(dstr) = gp_dup(GvGP(sstr), param);
9014 (void)GpREFCNT_inc(GvGP(dstr));
9017 SvANY(dstr) = new_XPVIO();
9018 SvCUR(dstr) = SvCUR(sstr);
9019 SvLEN(dstr) = SvLEN(sstr);
9020 SvIVX(dstr) = SvIVX(sstr);
9021 SvNVX(dstr) = SvNVX(sstr);
9022 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9023 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9025 SvRV(dstr) = SvWEAKREF(sstr)
9026 ? sv_dup(SvRV(sstr), param)
9027 : sv_dup_inc(SvRV(sstr), param);
9028 else if (SvPVX(sstr) && SvLEN(sstr))
9029 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9031 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9032 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9033 if (IoOFP(sstr) == IoIFP(sstr))
9034 IoOFP(dstr) = IoIFP(dstr);
9036 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9037 /* PL_rsfp_filters entries have fake IoDIRP() */
9038 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9039 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
9041 IoDIRP(dstr) = IoDIRP(sstr);
9042 IoLINES(dstr) = IoLINES(sstr);
9043 IoPAGE(dstr) = IoPAGE(sstr);
9044 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
9045 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
9046 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
9047 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
9048 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
9049 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
9050 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
9051 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
9052 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
9053 IoTYPE(dstr) = IoTYPE(sstr);
9054 IoFLAGS(dstr) = IoFLAGS(sstr);
9057 SvANY(dstr) = new_XPVAV();
9058 SvCUR(dstr) = SvCUR(sstr);
9059 SvLEN(dstr) = SvLEN(sstr);
9060 SvIVX(dstr) = SvIVX(sstr);
9061 SvNVX(dstr) = SvNVX(sstr);
9062 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9063 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9064 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9065 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9066 if (AvARRAY((AV*)sstr)) {
9067 SV **dst_ary, **src_ary;
9068 SSize_t items = AvFILLp((AV*)sstr) + 1;
9070 src_ary = AvARRAY((AV*)sstr);
9071 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9072 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9073 SvPVX(dstr) = (char*)dst_ary;
9074 AvALLOC((AV*)dstr) = dst_ary;
9075 if (AvREAL((AV*)sstr)) {
9077 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9081 *dst_ary++ = sv_dup(*src_ary++, param);
9083 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9084 while (items-- > 0) {
9085 *dst_ary++ = &PL_sv_undef;
9089 SvPVX(dstr) = Nullch;
9090 AvALLOC((AV*)dstr) = (SV**)NULL;
9094 SvANY(dstr) = new_XPVHV();
9095 SvCUR(dstr) = SvCUR(sstr);
9096 SvLEN(dstr) = SvLEN(sstr);
9097 SvIVX(dstr) = SvIVX(sstr);
9098 SvNVX(dstr) = SvNVX(sstr);
9099 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9100 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9101 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9102 if (HvARRAY((HV*)sstr)) {
9104 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9105 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9106 Newz(0, dxhv->xhv_array,
9107 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9108 while (i <= sxhv->xhv_max) {
9109 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9110 !!HvSHAREKEYS(sstr), param);
9113 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9116 SvPVX(dstr) = Nullch;
9117 HvEITER((HV*)dstr) = (HE*)NULL;
9119 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9120 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9121 /* Record stashes for possible cloning in Perl_clone(). */
9122 if(HvNAME((HV*)dstr))
9123 av_push(param->stashes, dstr);
9126 SvANY(dstr) = new_XPVFM();
9127 FmLINES(dstr) = FmLINES(sstr);
9131 SvANY(dstr) = new_XPVCV();
9133 SvCUR(dstr) = SvCUR(sstr);
9134 SvLEN(dstr) = SvLEN(sstr);
9135 SvIVX(dstr) = SvIVX(sstr);
9136 SvNVX(dstr) = SvNVX(sstr);
9137 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9138 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9139 if (SvPVX(sstr) && SvLEN(sstr))
9140 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9142 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9143 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9144 CvSTART(dstr) = CvSTART(sstr);
9145 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9146 CvXSUB(dstr) = CvXSUB(sstr);
9147 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9148 if (CvCONST(sstr)) {
9149 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9150 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9151 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9153 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9154 if (param->flags & CLONEf_COPY_STACKS) {
9155 CvDEPTH(dstr) = CvDEPTH(sstr);
9159 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9160 /* XXX padlists are real, but pretend to be not */
9161 AvREAL_on(CvPADLIST(sstr));
9162 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9163 AvREAL_off(CvPADLIST(sstr));
9164 AvREAL_off(CvPADLIST(dstr));
9167 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9168 if (!CvANON(sstr) || CvCLONED(sstr))
9169 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9171 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9172 CvFLAGS(dstr) = CvFLAGS(sstr);
9173 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9176 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9180 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9186 /* duplicate a context */
9189 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9194 return (PERL_CONTEXT*)NULL;
9196 /* look for it in the table first */
9197 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9201 /* create anew and remember what it is */
9202 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9203 ptr_table_store(PL_ptr_table, cxs, ncxs);
9206 PERL_CONTEXT *cx = &cxs[ix];
9207 PERL_CONTEXT *ncx = &ncxs[ix];
9208 ncx->cx_type = cx->cx_type;
9209 if (CxTYPE(cx) == CXt_SUBST) {
9210 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9213 ncx->blk_oldsp = cx->blk_oldsp;
9214 ncx->blk_oldcop = cx->blk_oldcop;
9215 ncx->blk_oldretsp = cx->blk_oldretsp;
9216 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9217 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9218 ncx->blk_oldpm = cx->blk_oldpm;
9219 ncx->blk_gimme = cx->blk_gimme;
9220 switch (CxTYPE(cx)) {
9222 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9223 ? cv_dup_inc(cx->blk_sub.cv, param)
9224 : cv_dup(cx->blk_sub.cv,param));
9225 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9226 ? av_dup_inc(cx->blk_sub.argarray, param)
9228 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9229 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9230 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9231 ncx->blk_sub.lval = cx->blk_sub.lval;
9234 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9235 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9236 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9237 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9238 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9241 ncx->blk_loop.label = cx->blk_loop.label;
9242 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9243 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9244 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9245 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9246 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9247 ? cx->blk_loop.iterdata
9248 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9249 ncx->blk_loop.oldcurpad
9250 = (SV**)ptr_table_fetch(PL_ptr_table,
9251 cx->blk_loop.oldcurpad);
9252 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9253 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9254 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9255 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9256 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9259 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9260 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9261 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9262 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9274 /* duplicate a stack info structure */
9277 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9282 return (PERL_SI*)NULL;
9284 /* look for it in the table first */
9285 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9289 /* create anew and remember what it is */
9290 Newz(56, nsi, 1, PERL_SI);
9291 ptr_table_store(PL_ptr_table, si, nsi);
9293 nsi->si_stack = av_dup_inc(si->si_stack, param);
9294 nsi->si_cxix = si->si_cxix;
9295 nsi->si_cxmax = si->si_cxmax;
9296 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9297 nsi->si_type = si->si_type;
9298 nsi->si_prev = si_dup(si->si_prev, param);
9299 nsi->si_next = si_dup(si->si_next, param);
9300 nsi->si_markoff = si->si_markoff;
9305 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9306 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9307 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9308 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9309 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9310 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9311 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9312 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9313 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9314 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9315 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9316 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9319 #define pv_dup_inc(p) SAVEPV(p)
9320 #define pv_dup(p) SAVEPV(p)
9321 #define svp_dup_inc(p,pp) any_dup(p,pp)
9323 /* map any object to the new equivent - either something in the
9324 * ptr table, or something in the interpreter structure
9328 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9335 /* look for it in the table first */
9336 ret = ptr_table_fetch(PL_ptr_table, v);
9340 /* see if it is part of the interpreter structure */
9341 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9342 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9349 /* duplicate the save stack */
9352 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9354 ANY *ss = proto_perl->Tsavestack;
9355 I32 ix = proto_perl->Tsavestack_ix;
9356 I32 max = proto_perl->Tsavestack_max;
9369 void (*dptr) (void*);
9370 void (*dxptr) (pTHX_ void*);
9373 Newz(54, nss, max, ANY);
9379 case SAVEt_ITEM: /* normal string */
9380 sv = (SV*)POPPTR(ss,ix);
9381 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9382 sv = (SV*)POPPTR(ss,ix);
9383 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9385 case SAVEt_SV: /* scalar reference */
9386 sv = (SV*)POPPTR(ss,ix);
9387 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9388 gv = (GV*)POPPTR(ss,ix);
9389 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9391 case SAVEt_GENERIC_PVREF: /* generic char* */
9392 c = (char*)POPPTR(ss,ix);
9393 TOPPTR(nss,ix) = pv_dup(c);
9394 ptr = POPPTR(ss,ix);
9395 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9397 case SAVEt_GENERIC_SVREF: /* generic sv */
9398 case SAVEt_SVREF: /* scalar reference */
9399 sv = (SV*)POPPTR(ss,ix);
9400 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9401 ptr = POPPTR(ss,ix);
9402 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9404 case SAVEt_AV: /* array reference */
9405 av = (AV*)POPPTR(ss,ix);
9406 TOPPTR(nss,ix) = av_dup_inc(av, param);
9407 gv = (GV*)POPPTR(ss,ix);
9408 TOPPTR(nss,ix) = gv_dup(gv, param);
9410 case SAVEt_HV: /* hash reference */
9411 hv = (HV*)POPPTR(ss,ix);
9412 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9413 gv = (GV*)POPPTR(ss,ix);
9414 TOPPTR(nss,ix) = gv_dup(gv, param);
9416 case SAVEt_INT: /* int reference */
9417 ptr = POPPTR(ss,ix);
9418 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9419 intval = (int)POPINT(ss,ix);
9420 TOPINT(nss,ix) = intval;
9422 case SAVEt_LONG: /* long reference */
9423 ptr = POPPTR(ss,ix);
9424 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9425 longval = (long)POPLONG(ss,ix);
9426 TOPLONG(nss,ix) = longval;
9428 case SAVEt_I32: /* I32 reference */
9429 case SAVEt_I16: /* I16 reference */
9430 case SAVEt_I8: /* I8 reference */
9431 ptr = POPPTR(ss,ix);
9432 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9436 case SAVEt_IV: /* IV reference */
9437 ptr = POPPTR(ss,ix);
9438 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9442 case SAVEt_SPTR: /* SV* reference */
9443 ptr = POPPTR(ss,ix);
9444 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9445 sv = (SV*)POPPTR(ss,ix);
9446 TOPPTR(nss,ix) = sv_dup(sv, param);
9448 case SAVEt_VPTR: /* random* reference */
9449 ptr = POPPTR(ss,ix);
9450 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9451 ptr = POPPTR(ss,ix);
9452 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9454 case SAVEt_PPTR: /* char* reference */
9455 ptr = POPPTR(ss,ix);
9456 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9457 c = (char*)POPPTR(ss,ix);
9458 TOPPTR(nss,ix) = pv_dup(c);
9460 case SAVEt_HPTR: /* HV* reference */
9461 ptr = POPPTR(ss,ix);
9462 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9463 hv = (HV*)POPPTR(ss,ix);
9464 TOPPTR(nss,ix) = hv_dup(hv, param);
9466 case SAVEt_APTR: /* AV* reference */
9467 ptr = POPPTR(ss,ix);
9468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9469 av = (AV*)POPPTR(ss,ix);
9470 TOPPTR(nss,ix) = av_dup(av, param);
9473 gv = (GV*)POPPTR(ss,ix);
9474 TOPPTR(nss,ix) = gv_dup(gv, param);
9476 case SAVEt_GP: /* scalar reference */
9477 gp = (GP*)POPPTR(ss,ix);
9478 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9479 (void)GpREFCNT_inc(gp);
9480 gv = (GV*)POPPTR(ss,ix);
9481 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9482 c = (char*)POPPTR(ss,ix);
9483 TOPPTR(nss,ix) = pv_dup(c);
9490 case SAVEt_MORTALIZESV:
9491 sv = (SV*)POPPTR(ss,ix);
9492 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9495 ptr = POPPTR(ss,ix);
9496 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9497 /* these are assumed to be refcounted properly */
9498 switch (((OP*)ptr)->op_type) {
9505 TOPPTR(nss,ix) = ptr;
9510 TOPPTR(nss,ix) = Nullop;
9515 TOPPTR(nss,ix) = Nullop;
9518 c = (char*)POPPTR(ss,ix);
9519 TOPPTR(nss,ix) = pv_dup_inc(c);
9522 longval = POPLONG(ss,ix);
9523 TOPLONG(nss,ix) = longval;
9526 hv = (HV*)POPPTR(ss,ix);
9527 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9528 c = (char*)POPPTR(ss,ix);
9529 TOPPTR(nss,ix) = pv_dup_inc(c);
9533 case SAVEt_DESTRUCTOR:
9534 ptr = POPPTR(ss,ix);
9535 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9536 dptr = POPDPTR(ss,ix);
9537 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9539 case SAVEt_DESTRUCTOR_X:
9540 ptr = POPPTR(ss,ix);
9541 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9542 dxptr = POPDXPTR(ss,ix);
9543 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9545 case SAVEt_REGCONTEXT:
9551 case SAVEt_STACK_POS: /* Position on Perl stack */
9555 case SAVEt_AELEM: /* array element */
9556 sv = (SV*)POPPTR(ss,ix);
9557 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9560 av = (AV*)POPPTR(ss,ix);
9561 TOPPTR(nss,ix) = av_dup_inc(av, param);
9563 case SAVEt_HELEM: /* hash element */
9564 sv = (SV*)POPPTR(ss,ix);
9565 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9566 sv = (SV*)POPPTR(ss,ix);
9567 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9568 hv = (HV*)POPPTR(ss,ix);
9569 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9572 ptr = POPPTR(ss,ix);
9573 TOPPTR(nss,ix) = ptr;
9580 av = (AV*)POPPTR(ss,ix);
9581 TOPPTR(nss,ix) = av_dup(av, param);
9584 longval = (long)POPLONG(ss,ix);
9585 TOPLONG(nss,ix) = longval;
9586 ptr = POPPTR(ss,ix);
9587 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9588 sv = (SV*)POPPTR(ss,ix);
9589 TOPPTR(nss,ix) = sv_dup(sv, param);
9592 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9600 =for apidoc perl_clone
9602 Create and return a new interpreter by cloning the current one.
9607 /* XXX the above needs expanding by someone who actually understands it ! */
9608 EXTERN_C PerlInterpreter *
9609 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
9612 perl_clone(PerlInterpreter *proto_perl, UV flags)
9614 #ifdef PERL_IMPLICIT_SYS
9616 /* perlhost.h so we need to call into it
9617 to clone the host, CPerlHost should have a c interface, sky */
9619 if (flags & CLONEf_CLONE_HOST) {
9620 return perl_clone_host(proto_perl,flags);
9622 return perl_clone_using(proto_perl, flags,
9624 proto_perl->IMemShared,
9625 proto_perl->IMemParse,
9635 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9636 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9637 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9638 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9639 struct IPerlDir* ipD, struct IPerlSock* ipS,
9640 struct IPerlProc* ipP)
9642 /* XXX many of the string copies here can be optimized if they're
9643 * constants; they need to be allocated as common memory and just
9644 * their pointers copied. */
9647 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9649 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9650 PERL_SET_THX(my_perl);
9653 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9659 # else /* !DEBUGGING */
9660 Zero(my_perl, 1, PerlInterpreter);
9661 # endif /* DEBUGGING */
9665 PL_MemShared = ipMS;
9673 #else /* !PERL_IMPLICIT_SYS */
9675 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9676 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9677 PERL_SET_THX(my_perl);
9682 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9688 # else /* !DEBUGGING */
9689 Zero(my_perl, 1, PerlInterpreter);
9690 # endif /* DEBUGGING */
9691 #endif /* PERL_IMPLICIT_SYS */
9692 param->flags = flags;
9695 PL_xiv_arenaroot = NULL;
9697 PL_xnv_arenaroot = NULL;
9699 PL_xrv_arenaroot = NULL;
9701 PL_xpv_arenaroot = NULL;
9703 PL_xpviv_arenaroot = NULL;
9704 PL_xpviv_root = NULL;
9705 PL_xpvnv_arenaroot = NULL;
9706 PL_xpvnv_root = NULL;
9707 PL_xpvcv_arenaroot = NULL;
9708 PL_xpvcv_root = NULL;
9709 PL_xpvav_arenaroot = NULL;
9710 PL_xpvav_root = NULL;
9711 PL_xpvhv_arenaroot = NULL;
9712 PL_xpvhv_root = NULL;
9713 PL_xpvmg_arenaroot = NULL;
9714 PL_xpvmg_root = NULL;
9715 PL_xpvlv_arenaroot = NULL;
9716 PL_xpvlv_root = NULL;
9717 PL_xpvbm_arenaroot = NULL;
9718 PL_xpvbm_root = NULL;
9719 PL_he_arenaroot = NULL;
9721 PL_nice_chunk = NULL;
9722 PL_nice_chunk_size = 0;
9725 PL_sv_root = Nullsv;
9726 PL_sv_arenaroot = Nullsv;
9728 PL_debug = proto_perl->Idebug;
9730 #ifdef USE_REENTRANT_API
9731 New(31337, PL_reentrant_buffer,1, REBUF);
9732 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9735 /* create SV map for pointer relocation */
9736 PL_ptr_table = ptr_table_new();
9738 /* initialize these special pointers as early as possible */
9739 SvANY(&PL_sv_undef) = NULL;
9740 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9741 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9742 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9744 SvANY(&PL_sv_no) = new_XPVNV();
9745 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9746 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9747 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9748 SvCUR(&PL_sv_no) = 0;
9749 SvLEN(&PL_sv_no) = 1;
9750 SvNVX(&PL_sv_no) = 0;
9751 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9753 SvANY(&PL_sv_yes) = new_XPVNV();
9754 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9755 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9756 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9757 SvCUR(&PL_sv_yes) = 1;
9758 SvLEN(&PL_sv_yes) = 2;
9759 SvNVX(&PL_sv_yes) = 1;
9760 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9762 /* create shared string table */
9763 PL_strtab = newHV();
9764 HvSHAREKEYS_off(PL_strtab);
9765 hv_ksplit(PL_strtab, 512);
9766 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9768 PL_compiling = proto_perl->Icompiling;
9769 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9770 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9771 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9772 if (!specialWARN(PL_compiling.cop_warnings))
9773 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9774 if (!specialCopIO(PL_compiling.cop_io))
9775 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9776 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9778 /* pseudo environmental stuff */
9779 PL_origargc = proto_perl->Iorigargc;
9781 New(0, PL_origargv, i+1, char*);
9782 PL_origargv[i] = '\0';
9784 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9787 param->stashes = newAV(); /* Setup array of objects to call clone on */
9789 #ifdef PERLIO_LAYERS
9790 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
9791 PerlIO_clone(aTHX_ proto_perl, param);
9794 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9795 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9796 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9797 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9798 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9799 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9802 PL_minus_c = proto_perl->Iminus_c;
9803 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9804 PL_localpatches = proto_perl->Ilocalpatches;
9805 PL_splitstr = proto_perl->Isplitstr;
9806 PL_preprocess = proto_perl->Ipreprocess;
9807 PL_minus_n = proto_perl->Iminus_n;
9808 PL_minus_p = proto_perl->Iminus_p;
9809 PL_minus_l = proto_perl->Iminus_l;
9810 PL_minus_a = proto_perl->Iminus_a;
9811 PL_minus_F = proto_perl->Iminus_F;
9812 PL_doswitches = proto_perl->Idoswitches;
9813 PL_dowarn = proto_perl->Idowarn;
9814 PL_doextract = proto_perl->Idoextract;
9815 PL_sawampersand = proto_perl->Isawampersand;
9816 PL_unsafe = proto_perl->Iunsafe;
9817 PL_inplace = SAVEPV(proto_perl->Iinplace);
9818 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9819 PL_perldb = proto_perl->Iperldb;
9820 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9821 PL_exit_flags = proto_perl->Iexit_flags;
9823 /* magical thingies */
9824 /* XXX time(&PL_basetime) when asked for? */
9825 PL_basetime = proto_perl->Ibasetime;
9826 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9828 PL_maxsysfd = proto_perl->Imaxsysfd;
9829 PL_multiline = proto_perl->Imultiline;
9830 PL_statusvalue = proto_perl->Istatusvalue;
9832 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9834 PL_encoding = sv_dup(proto_perl->Iencoding, param);
9836 /* Clone the regex array */
9837 PL_regex_padav = newAV();
9839 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9840 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9841 av_push(PL_regex_padav,
9842 sv_dup_inc(regexen[0],param));
9843 for(i = 1; i <= len; i++) {
9844 if(SvREPADTMP(regexen[i])) {
9845 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
9847 av_push(PL_regex_padav,
9849 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
9850 SvIVX(regexen[i])), param)))
9855 PL_regex_pad = AvARRAY(PL_regex_padav);
9857 /* shortcuts to various I/O objects */
9858 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9859 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9860 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9861 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9862 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9863 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9865 /* shortcuts to regexp stuff */
9866 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9868 /* shortcuts to misc objects */
9869 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9871 /* shortcuts to debugging objects */
9872 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9873 PL_DBline = gv_dup(proto_perl->IDBline, param);
9874 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9875 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9876 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9877 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9878 PL_lineary = av_dup(proto_perl->Ilineary, param);
9879 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9882 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9883 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9884 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9885 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9886 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9887 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9889 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9890 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
9891 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9892 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9893 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9895 PL_sub_generation = proto_perl->Isub_generation;
9897 /* funky return mechanisms */
9898 PL_forkprocess = proto_perl->Iforkprocess;
9900 /* subprocess state */
9901 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9903 /* internal state */
9904 PL_tainting = proto_perl->Itainting;
9905 PL_maxo = proto_perl->Imaxo;
9906 if (proto_perl->Iop_mask)
9907 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9909 PL_op_mask = Nullch;
9911 /* current interpreter roots */
9912 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9913 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9914 PL_main_start = proto_perl->Imain_start;
9915 PL_eval_root = proto_perl->Ieval_root;
9916 PL_eval_start = proto_perl->Ieval_start;
9918 /* runtime control stuff */
9919 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9920 PL_copline = proto_perl->Icopline;
9922 PL_filemode = proto_perl->Ifilemode;
9923 PL_lastfd = proto_perl->Ilastfd;
9924 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9927 PL_gensym = proto_perl->Igensym;
9928 PL_preambled = proto_perl->Ipreambled;
9929 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9930 PL_laststatval = proto_perl->Ilaststatval;
9931 PL_laststype = proto_perl->Ilaststype;
9932 PL_mess_sv = Nullsv;
9934 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9935 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9937 /* interpreter atexit processing */
9938 PL_exitlistlen = proto_perl->Iexitlistlen;
9939 if (PL_exitlistlen) {
9940 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9941 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9944 PL_exitlist = (PerlExitListEntry*)NULL;
9945 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9946 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
9947 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
9949 PL_profiledata = NULL;
9950 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
9951 /* PL_rsfp_filters entries have fake IoDIRP() */
9952 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9954 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9955 PL_comppad = av_dup(proto_perl->Icomppad, param);
9956 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9957 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9958 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9959 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9960 proto_perl->Tcurpad);
9962 #ifdef HAVE_INTERP_INTERN
9963 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9966 /* more statics moved here */
9967 PL_generation = proto_perl->Igeneration;
9968 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9970 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9971 PL_in_clean_all = proto_perl->Iin_clean_all;
9973 PL_uid = proto_perl->Iuid;
9974 PL_euid = proto_perl->Ieuid;
9975 PL_gid = proto_perl->Igid;
9976 PL_egid = proto_perl->Iegid;
9977 PL_nomemok = proto_perl->Inomemok;
9978 PL_an = proto_perl->Ian;
9979 PL_cop_seqmax = proto_perl->Icop_seqmax;
9980 PL_op_seqmax = proto_perl->Iop_seqmax;
9981 PL_evalseq = proto_perl->Ievalseq;
9982 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9983 PL_origalen = proto_perl->Iorigalen;
9984 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9985 PL_osname = SAVEPV(proto_perl->Iosname);
9986 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
9987 PL_sighandlerp = proto_perl->Isighandlerp;
9990 PL_runops = proto_perl->Irunops;
9992 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9995 PL_cshlen = proto_perl->Icshlen;
9996 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
9999 PL_lex_state = proto_perl->Ilex_state;
10000 PL_lex_defer = proto_perl->Ilex_defer;
10001 PL_lex_expect = proto_perl->Ilex_expect;
10002 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10003 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10004 PL_lex_starts = proto_perl->Ilex_starts;
10005 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10006 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10007 PL_lex_op = proto_perl->Ilex_op;
10008 PL_lex_inpat = proto_perl->Ilex_inpat;
10009 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10010 PL_lex_brackets = proto_perl->Ilex_brackets;
10011 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10012 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10013 PL_lex_casemods = proto_perl->Ilex_casemods;
10014 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10015 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10017 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10018 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10019 PL_nexttoke = proto_perl->Inexttoke;
10021 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10022 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10023 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10024 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10025 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10026 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10027 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10028 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10029 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10030 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10031 PL_pending_ident = proto_perl->Ipending_ident;
10032 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10034 PL_expect = proto_perl->Iexpect;
10036 PL_multi_start = proto_perl->Imulti_start;
10037 PL_multi_end = proto_perl->Imulti_end;
10038 PL_multi_open = proto_perl->Imulti_open;
10039 PL_multi_close = proto_perl->Imulti_close;
10041 PL_error_count = proto_perl->Ierror_count;
10042 PL_subline = proto_perl->Isubline;
10043 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10045 PL_min_intro_pending = proto_perl->Imin_intro_pending;
10046 PL_max_intro_pending = proto_perl->Imax_intro_pending;
10047 PL_padix = proto_perl->Ipadix;
10048 PL_padix_floor = proto_perl->Ipadix_floor;
10049 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
10051 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10052 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10053 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10054 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10055 PL_last_lop_op = proto_perl->Ilast_lop_op;
10056 PL_in_my = proto_perl->Iin_my;
10057 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10059 PL_cryptseen = proto_perl->Icryptseen;
10062 PL_hints = proto_perl->Ihints;
10064 PL_amagic_generation = proto_perl->Iamagic_generation;
10066 #ifdef USE_LOCALE_COLLATE
10067 PL_collation_ix = proto_perl->Icollation_ix;
10068 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10069 PL_collation_standard = proto_perl->Icollation_standard;
10070 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10071 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10072 #endif /* USE_LOCALE_COLLATE */
10074 #ifdef USE_LOCALE_NUMERIC
10075 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10076 PL_numeric_standard = proto_perl->Inumeric_standard;
10077 PL_numeric_local = proto_perl->Inumeric_local;
10078 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10079 #endif /* !USE_LOCALE_NUMERIC */
10081 /* utf8 character classes */
10082 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10083 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10084 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10085 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10086 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10087 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10088 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10089 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10090 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10091 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10092 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10093 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10094 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10095 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10096 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10097 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10098 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10101 PL_last_swash_hv = Nullhv; /* reinits on demand */
10102 PL_last_swash_klen = 0;
10103 PL_last_swash_key[0]= '\0';
10104 PL_last_swash_tmps = (U8*)NULL;
10105 PL_last_swash_slen = 0;
10107 /* perly.c globals */
10108 PL_yydebug = proto_perl->Iyydebug;
10109 PL_yynerrs = proto_perl->Iyynerrs;
10110 PL_yyerrflag = proto_perl->Iyyerrflag;
10111 PL_yychar = proto_perl->Iyychar;
10112 PL_yyval = proto_perl->Iyyval;
10113 PL_yylval = proto_perl->Iyylval;
10115 PL_glob_index = proto_perl->Iglob_index;
10116 PL_srand_called = proto_perl->Isrand_called;
10117 PL_uudmap['M'] = 0; /* reinits on demand */
10118 PL_bitcount = Nullch; /* reinits on demand */
10120 if (proto_perl->Ipsig_pend) {
10121 Newz(0, PL_psig_pend, SIG_SIZE, int);
10124 PL_psig_pend = (int*)NULL;
10127 if (proto_perl->Ipsig_ptr) {
10128 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10129 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10130 for (i = 1; i < SIG_SIZE; i++) {
10131 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10132 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10136 PL_psig_ptr = (SV**)NULL;
10137 PL_psig_name = (SV**)NULL;
10140 /* thrdvar.h stuff */
10142 if (flags & CLONEf_COPY_STACKS) {
10143 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10144 PL_tmps_ix = proto_perl->Ttmps_ix;
10145 PL_tmps_max = proto_perl->Ttmps_max;
10146 PL_tmps_floor = proto_perl->Ttmps_floor;
10147 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10149 while (i <= PL_tmps_ix) {
10150 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10154 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10155 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10156 Newz(54, PL_markstack, i, I32);
10157 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10158 - proto_perl->Tmarkstack);
10159 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10160 - proto_perl->Tmarkstack);
10161 Copy(proto_perl->Tmarkstack, PL_markstack,
10162 PL_markstack_ptr - PL_markstack + 1, I32);
10164 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10165 * NOTE: unlike the others! */
10166 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10167 PL_scopestack_max = proto_perl->Tscopestack_max;
10168 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10169 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10171 /* next push_return() sets PL_retstack[PL_retstack_ix]
10172 * NOTE: unlike the others! */
10173 PL_retstack_ix = proto_perl->Tretstack_ix;
10174 PL_retstack_max = proto_perl->Tretstack_max;
10175 Newz(54, PL_retstack, PL_retstack_max, OP*);
10176 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10178 /* NOTE: si_dup() looks at PL_markstack */
10179 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10181 /* PL_curstack = PL_curstackinfo->si_stack; */
10182 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10183 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10185 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10186 PL_stack_base = AvARRAY(PL_curstack);
10187 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10188 - proto_perl->Tstack_base);
10189 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10191 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10192 * NOTE: unlike the others! */
10193 PL_savestack_ix = proto_perl->Tsavestack_ix;
10194 PL_savestack_max = proto_perl->Tsavestack_max;
10195 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10196 PL_savestack = ss_dup(proto_perl, param);
10200 ENTER; /* perl_destruct() wants to LEAVE; */
10203 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10204 PL_top_env = &PL_start_env;
10206 PL_op = proto_perl->Top;
10209 PL_Xpv = (XPV*)NULL;
10210 PL_na = proto_perl->Tna;
10212 PL_statbuf = proto_perl->Tstatbuf;
10213 PL_statcache = proto_perl->Tstatcache;
10214 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10215 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10217 PL_timesbuf = proto_perl->Ttimesbuf;
10220 PL_tainted = proto_perl->Ttainted;
10221 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10222 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10223 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10224 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10225 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10226 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10227 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10228 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10229 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10231 PL_restartop = proto_perl->Trestartop;
10232 PL_in_eval = proto_perl->Tin_eval;
10233 PL_delaymagic = proto_perl->Tdelaymagic;
10234 PL_dirty = proto_perl->Tdirty;
10235 PL_localizing = proto_perl->Tlocalizing;
10237 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10238 PL_protect = proto_perl->Tprotect;
10240 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10241 PL_av_fetch_sv = Nullsv;
10242 PL_hv_fetch_sv = Nullsv;
10243 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10244 PL_modcount = proto_perl->Tmodcount;
10245 PL_lastgotoprobe = Nullop;
10246 PL_dumpindent = proto_perl->Tdumpindent;
10248 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10249 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10250 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10251 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10252 PL_sortcxix = proto_perl->Tsortcxix;
10253 PL_efloatbuf = Nullch; /* reinits on demand */
10254 PL_efloatsize = 0; /* reinits on demand */
10258 PL_screamfirst = NULL;
10259 PL_screamnext = NULL;
10260 PL_maxscream = -1; /* reinits on demand */
10261 PL_lastscream = Nullsv;
10263 PL_watchaddr = NULL;
10264 PL_watchok = Nullch;
10266 PL_regdummy = proto_perl->Tregdummy;
10267 PL_regcomp_parse = Nullch;
10268 PL_regxend = Nullch;
10269 PL_regcode = (regnode*)NULL;
10272 PL_regprecomp = Nullch;
10277 PL_seen_zerolen = 0;
10279 PL_regcomp_rx = (regexp*)NULL;
10281 PL_colorset = 0; /* reinits PL_colors[] */
10282 /*PL_colors[6] = {0,0,0,0,0,0};*/
10283 PL_reg_whilem_seen = 0;
10284 PL_reginput = Nullch;
10285 PL_regbol = Nullch;
10286 PL_regeol = Nullch;
10287 PL_regstartp = (I32*)NULL;
10288 PL_regendp = (I32*)NULL;
10289 PL_reglastparen = (U32*)NULL;
10290 PL_regtill = Nullch;
10291 PL_reg_start_tmp = (char**)NULL;
10292 PL_reg_start_tmpl = 0;
10293 PL_regdata = (struct reg_data*)NULL;
10296 PL_reg_eval_set = 0;
10298 PL_regprogram = (regnode*)NULL;
10300 PL_regcc = (CURCUR*)NULL;
10301 PL_reg_call_cc = (struct re_cc_state*)NULL;
10302 PL_reg_re = (regexp*)NULL;
10303 PL_reg_ganch = Nullch;
10304 PL_reg_sv = Nullsv;
10305 PL_reg_match_utf8 = FALSE;
10306 PL_reg_magic = (MAGIC*)NULL;
10308 PL_reg_oldcurpm = (PMOP*)NULL;
10309 PL_reg_curpm = (PMOP*)NULL;
10310 PL_reg_oldsaved = Nullch;
10311 PL_reg_oldsavedlen = 0;
10312 PL_reg_maxiter = 0;
10313 PL_reg_leftiter = 0;
10314 PL_reg_poscache = Nullch;
10315 PL_reg_poscache_size= 0;
10317 /* RE engine - function pointers */
10318 PL_regcompp = proto_perl->Tregcompp;
10319 PL_regexecp = proto_perl->Tregexecp;
10320 PL_regint_start = proto_perl->Tregint_start;
10321 PL_regint_string = proto_perl->Tregint_string;
10322 PL_regfree = proto_perl->Tregfree;
10324 PL_reginterp_cnt = 0;
10325 PL_reg_starttry = 0;
10327 /* Pluggable optimizer */
10328 PL_peepp = proto_perl->Tpeepp;
10330 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10331 ptr_table_free(PL_ptr_table);
10332 PL_ptr_table = NULL;
10335 /* Call the ->CLONE method, if it exists, for each of the stashes
10336 identified by sv_dup() above.
10338 while(av_len(param->stashes) != -1) {
10339 HV* stash = (HV*) av_shift(param->stashes);
10340 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10341 if (cloner && GvCV(cloner)) {
10346 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10348 call_sv((SV*)GvCV(cloner), G_DISCARD);
10354 SvREFCNT_dec(param->stashes);
10360 #endif /* USE_ITHREADS */
10363 =for apidoc sv_recode_to_utf8
10365 The encoding is assumed to be an Encode object, on entry the PV
10366 of the sv is assumed to be octets in that encoding, and the sv
10367 will be converted into Unicode (and UTF-8).
10369 If the sv already is UTF-8 (or if it is not POK), or if the encoding
10370 is not a reference, nothing is done to the sv. If the encoding is not
10371 an C<Encode::XS> Encoding object, bad things will happen.
10372 (See F<lib/encoding.pm> and L<Encode>).
10374 The PV of the sv is returned.
10379 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
10381 if (SvPOK(sv) && !SvUTF8(sv) && SvROK(encoding)) {
10392 XPUSHs(&PL_sv_yes);
10394 call_method("decode", G_SCALAR);
10398 s = SvPVutf8(uni, len);
10399 if (s != SvPVX(sv)) {
10401 Move(s, SvPVX(sv), len, char);
10402 SvCUR_set(sv, len);