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);
3314 XPUSHs(PL_encoding);
3318 call_method("decode", G_SCALAR);
3322 s = SvPVutf8(uni, len);
3323 if (s != SvPVX(sv)) {
3325 Move(s, SvPVX(sv), len, char);
3330 } else { /* Assume Latin-1/EBCDIC */
3331 /* This function could be much more efficient if we
3332 * had a FLAG in SVs to signal if there are any hibit
3333 * chars in the PV. Given that there isn't such a flag
3334 * make the loop as fast as possible. */
3335 s = (U8 *) SvPVX(sv);
3336 e = (U8 *) SvEND(sv);
3340 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3346 len = SvCUR(sv) + 1; /* Plus the \0 */
3347 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3348 SvCUR(sv) = len - 1;
3350 Safefree(s); /* No longer using what was there before. */
3351 SvLEN(sv) = len; /* No longer know the real size. */
3354 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3360 =for apidoc sv_utf8_downgrade
3362 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3363 This may not be possible if the PV contains non-byte encoding characters;
3364 if this is the case, either returns false or, if C<fail_ok> is not
3371 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3373 if (SvPOK(sv) && SvUTF8(sv)) {
3378 if (SvREADONLY(sv) && SvFAKE(sv))
3379 sv_force_normal(sv);
3380 s = (U8 *) SvPV(sv, len);
3381 if (!utf8_to_bytes(s, &len)) {
3384 #ifdef USE_BYTES_DOWNGRADES
3385 else if (IN_BYTES) {
3387 U8 *e = (U8 *) SvEND(sv);
3390 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3391 if (first && ch > 255) {
3393 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3396 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3403 len = (d - (U8 *) SvPVX(sv));
3408 Perl_croak(aTHX_ "Wide character in %s",
3411 Perl_croak(aTHX_ "Wide character");
3422 =for apidoc sv_utf8_encode
3424 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3425 flag so that it looks like octets again. Used as a building block
3426 for encode_utf8 in Encode.xs
3432 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3434 (void) sv_utf8_upgrade(sv);
3439 =for apidoc sv_utf8_decode
3441 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3442 turn off SvUTF8 if needed so that we see characters. Used as a building block
3443 for decode_utf8 in Encode.xs
3449 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3455 /* The octets may have got themselves encoded - get them back as
3458 if (!sv_utf8_downgrade(sv, TRUE))
3461 /* it is actually just a matter of turning the utf8 flag on, but
3462 * we want to make sure everything inside is valid utf8 first.
3464 c = (U8 *) SvPVX(sv);
3465 if (!is_utf8_string(c, SvCUR(sv)+1))
3467 e = (U8 *) SvEND(sv);
3470 if (!UTF8_IS_INVARIANT(ch)) {
3480 =for apidoc sv_setsv
3482 Copies the contents of the source SV C<ssv> into the destination SV
3483 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3484 function if the source SV needs to be reused. Does not handle 'set' magic.
3485 Loosely speaking, it performs a copy-by-value, obliterating any previous
3486 content of the destination.
3488 You probably want to use one of the assortment of wrappers, such as
3489 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3490 C<SvSetMagicSV_nosteal>.
3496 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3497 for binary compatibility only
3500 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3502 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3506 =for apidoc sv_setsv_flags
3508 Copies the contents of the source SV C<ssv> into the destination SV
3509 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3510 function if the source SV needs to be reused. Does not handle 'set' magic.
3511 Loosely speaking, it performs a copy-by-value, obliterating any previous
3512 content of the destination.
3513 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3514 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3515 implemented in terms of this function.
3517 You probably want to use one of the assortment of wrappers, such as
3518 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3519 C<SvSetMagicSV_nosteal>.
3521 This is the primary function for copying scalars, and most other
3522 copy-ish functions and macros use this underneath.
3528 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3530 register U32 sflags;
3536 SV_CHECK_THINKFIRST(dstr);
3538 sstr = &PL_sv_undef;
3539 stype = SvTYPE(sstr);
3540 dtype = SvTYPE(dstr);
3544 /* There's a lot of redundancy below but we're going for speed here */
3549 if (dtype != SVt_PVGV) {
3550 (void)SvOK_off(dstr);
3558 sv_upgrade(dstr, SVt_IV);
3561 sv_upgrade(dstr, SVt_PVNV);
3565 sv_upgrade(dstr, SVt_PVIV);
3568 (void)SvIOK_only(dstr);
3569 SvIVX(dstr) = SvIVX(sstr);
3572 if (SvTAINTED(sstr))
3583 sv_upgrade(dstr, SVt_NV);
3588 sv_upgrade(dstr, SVt_PVNV);
3591 SvNVX(dstr) = SvNVX(sstr);
3592 (void)SvNOK_only(dstr);
3593 if (SvTAINTED(sstr))
3601 sv_upgrade(dstr, SVt_RV);
3602 else if (dtype == SVt_PVGV &&
3603 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3606 if (GvIMPORTED(dstr) != GVf_IMPORTED
3607 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3609 GvIMPORTED_on(dstr);
3620 sv_upgrade(dstr, SVt_PV);
3623 if (dtype < SVt_PVIV)
3624 sv_upgrade(dstr, SVt_PVIV);
3627 if (dtype < SVt_PVNV)
3628 sv_upgrade(dstr, SVt_PVNV);
3635 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3638 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3642 if (dtype <= SVt_PVGV) {
3644 if (dtype != SVt_PVGV) {
3645 char *name = GvNAME(sstr);
3646 STRLEN len = GvNAMELEN(sstr);
3647 sv_upgrade(dstr, SVt_PVGV);
3648 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3649 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3650 GvNAME(dstr) = savepvn(name, len);
3651 GvNAMELEN(dstr) = len;
3652 SvFAKE_on(dstr); /* can coerce to non-glob */
3654 /* ahem, death to those who redefine active sort subs */
3655 else if (PL_curstackinfo->si_type == PERLSI_SORT
3656 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3657 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3660 #ifdef GV_UNIQUE_CHECK
3661 if (GvUNIQUE((GV*)dstr)) {
3662 Perl_croak(aTHX_ PL_no_modify);
3666 (void)SvOK_off(dstr);
3667 GvINTRO_off(dstr); /* one-shot flag */
3669 GvGP(dstr) = gp_ref(GvGP(sstr));
3670 if (SvTAINTED(sstr))
3672 if (GvIMPORTED(dstr) != GVf_IMPORTED
3673 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3675 GvIMPORTED_on(dstr);
3683 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3685 if (SvTYPE(sstr) != stype) {
3686 stype = SvTYPE(sstr);
3687 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3691 if (stype == SVt_PVLV)
3692 (void)SvUPGRADE(dstr, SVt_PVNV);
3694 (void)SvUPGRADE(dstr, stype);
3697 sflags = SvFLAGS(sstr);
3699 if (sflags & SVf_ROK) {
3700 if (dtype >= SVt_PV) {
3701 if (dtype == SVt_PVGV) {
3702 SV *sref = SvREFCNT_inc(SvRV(sstr));
3704 int intro = GvINTRO(dstr);
3706 #ifdef GV_UNIQUE_CHECK
3707 if (GvUNIQUE((GV*)dstr)) {
3708 Perl_croak(aTHX_ PL_no_modify);
3713 GvINTRO_off(dstr); /* one-shot flag */
3714 GvLINE(dstr) = CopLINE(PL_curcop);
3715 GvEGV(dstr) = (GV*)dstr;
3718 switch (SvTYPE(sref)) {
3721 SAVESPTR(GvAV(dstr));
3723 dref = (SV*)GvAV(dstr);
3724 GvAV(dstr) = (AV*)sref;
3725 if (!GvIMPORTED_AV(dstr)
3726 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3728 GvIMPORTED_AV_on(dstr);
3733 SAVESPTR(GvHV(dstr));
3735 dref = (SV*)GvHV(dstr);
3736 GvHV(dstr) = (HV*)sref;
3737 if (!GvIMPORTED_HV(dstr)
3738 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3740 GvIMPORTED_HV_on(dstr);
3745 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3746 SvREFCNT_dec(GvCV(dstr));
3747 GvCV(dstr) = Nullcv;
3748 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3749 PL_sub_generation++;
3751 SAVESPTR(GvCV(dstr));
3754 dref = (SV*)GvCV(dstr);
3755 if (GvCV(dstr) != (CV*)sref) {
3756 CV* cv = GvCV(dstr);
3758 if (!GvCVGEN((GV*)dstr) &&
3759 (CvROOT(cv) || CvXSUB(cv)))
3761 /* ahem, death to those who redefine
3762 * active sort subs */
3763 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3764 PL_sortcop == CvSTART(cv))
3766 "Can't redefine active sort subroutine %s",
3767 GvENAME((GV*)dstr));
3768 /* Redefining a sub - warning is mandatory if
3769 it was a const and its value changed. */
3770 if (ckWARN(WARN_REDEFINE)
3772 && (!CvCONST((CV*)sref)
3773 || sv_cmp(cv_const_sv(cv),
3774 cv_const_sv((CV*)sref)))))
3776 Perl_warner(aTHX_ WARN_REDEFINE,
3778 ? "Constant subroutine %s redefined"
3779 : "Subroutine %s redefined",
3780 GvENAME((GV*)dstr));
3783 cv_ckproto(cv, (GV*)dstr,
3784 SvPOK(sref) ? SvPVX(sref) : Nullch);
3786 GvCV(dstr) = (CV*)sref;
3787 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3788 GvASSUMECV_on(dstr);
3789 PL_sub_generation++;
3791 if (!GvIMPORTED_CV(dstr)
3792 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3794 GvIMPORTED_CV_on(dstr);
3799 SAVESPTR(GvIOp(dstr));
3801 dref = (SV*)GvIOp(dstr);
3802 GvIOp(dstr) = (IO*)sref;
3806 SAVESPTR(GvFORM(dstr));
3808 dref = (SV*)GvFORM(dstr);
3809 GvFORM(dstr) = (CV*)sref;
3813 SAVESPTR(GvSV(dstr));
3815 dref = (SV*)GvSV(dstr);
3817 if (!GvIMPORTED_SV(dstr)
3818 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3820 GvIMPORTED_SV_on(dstr);
3828 if (SvTAINTED(sstr))
3833 (void)SvOOK_off(dstr); /* backoff */
3835 Safefree(SvPVX(dstr));
3836 SvLEN(dstr)=SvCUR(dstr)=0;
3839 (void)SvOK_off(dstr);
3840 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3842 if (sflags & SVp_NOK) {
3844 /* Only set the public OK flag if the source has public OK. */
3845 if (sflags & SVf_NOK)
3846 SvFLAGS(dstr) |= SVf_NOK;
3847 SvNVX(dstr) = SvNVX(sstr);
3849 if (sflags & SVp_IOK) {
3850 (void)SvIOKp_on(dstr);
3851 if (sflags & SVf_IOK)
3852 SvFLAGS(dstr) |= SVf_IOK;
3853 if (sflags & SVf_IVisUV)
3855 SvIVX(dstr) = SvIVX(sstr);
3857 if (SvAMAGIC(sstr)) {
3861 else if (sflags & SVp_POK) {
3864 * Check to see if we can just swipe the string. If so, it's a
3865 * possible small lose on short strings, but a big win on long ones.
3866 * It might even be a win on short strings if SvPVX(dstr)
3867 * has to be allocated and SvPVX(sstr) has to be freed.
3870 if (SvTEMP(sstr) && /* slated for free anyway? */
3871 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3872 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3873 SvLEN(sstr) && /* and really is a string */
3874 /* and won't be needed again, potentially */
3875 !(PL_op && PL_op->op_type == OP_AASSIGN))
3877 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3879 SvFLAGS(dstr) &= ~SVf_OOK;
3880 Safefree(SvPVX(dstr) - SvIVX(dstr));
3882 else if (SvLEN(dstr))
3883 Safefree(SvPVX(dstr));
3885 (void)SvPOK_only(dstr);
3886 SvPV_set(dstr, SvPVX(sstr));
3887 SvLEN_set(dstr, SvLEN(sstr));
3888 SvCUR_set(dstr, SvCUR(sstr));
3891 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3892 SvPV_set(sstr, Nullch);
3897 else { /* have to copy actual string */
3898 STRLEN len = SvCUR(sstr);
3900 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3901 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3902 SvCUR_set(dstr, len);
3903 *SvEND(dstr) = '\0';
3904 (void)SvPOK_only(dstr);
3906 if (sflags & SVf_UTF8)
3909 if (sflags & SVp_NOK) {
3911 if (sflags & SVf_NOK)
3912 SvFLAGS(dstr) |= SVf_NOK;
3913 SvNVX(dstr) = SvNVX(sstr);
3915 if (sflags & SVp_IOK) {
3916 (void)SvIOKp_on(dstr);
3917 if (sflags & SVf_IOK)
3918 SvFLAGS(dstr) |= SVf_IOK;
3919 if (sflags & SVf_IVisUV)
3921 SvIVX(dstr) = SvIVX(sstr);
3924 else if (sflags & SVp_IOK) {
3925 if (sflags & SVf_IOK)
3926 (void)SvIOK_only(dstr);
3928 (void)SvOK_off(dstr);
3929 (void)SvIOKp_on(dstr);
3931 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3932 if (sflags & SVf_IVisUV)
3934 SvIVX(dstr) = SvIVX(sstr);
3935 if (sflags & SVp_NOK) {
3936 if (sflags & SVf_NOK)
3937 (void)SvNOK_on(dstr);
3939 (void)SvNOKp_on(dstr);
3940 SvNVX(dstr) = SvNVX(sstr);
3943 else if (sflags & SVp_NOK) {
3944 if (sflags & SVf_NOK)
3945 (void)SvNOK_only(dstr);
3947 (void)SvOK_off(dstr);
3950 SvNVX(dstr) = SvNVX(sstr);
3953 if (dtype == SVt_PVGV) {
3954 if (ckWARN(WARN_MISC))
3955 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3958 (void)SvOK_off(dstr);
3960 if (SvTAINTED(sstr))
3965 =for apidoc sv_setsv_mg
3967 Like C<sv_setsv>, but also handles 'set' magic.
3973 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3975 sv_setsv(dstr,sstr);
3980 =for apidoc sv_setpvn
3982 Copies a string into an SV. The C<len> parameter indicates the number of
3983 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3989 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3991 register char *dptr;
3993 SV_CHECK_THINKFIRST(sv);
3999 /* len is STRLEN which is unsigned, need to copy to signed */
4002 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4004 (void)SvUPGRADE(sv, SVt_PV);
4006 SvGROW(sv, len + 1);
4008 Move(ptr,dptr,len,char);
4011 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4016 =for apidoc sv_setpvn_mg
4018 Like C<sv_setpvn>, but also handles 'set' magic.
4024 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4026 sv_setpvn(sv,ptr,len);
4031 =for apidoc sv_setpv
4033 Copies a string into an SV. The string must be null-terminated. Does not
4034 handle 'set' magic. See C<sv_setpv_mg>.
4040 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4042 register STRLEN len;
4044 SV_CHECK_THINKFIRST(sv);
4050 (void)SvUPGRADE(sv, SVt_PV);
4052 SvGROW(sv, len + 1);
4053 Move(ptr,SvPVX(sv),len+1,char);
4055 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4060 =for apidoc sv_setpv_mg
4062 Like C<sv_setpv>, but also handles 'set' magic.
4068 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4075 =for apidoc sv_usepvn
4077 Tells an SV to use C<ptr> to find its string value. Normally the string is
4078 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4079 The C<ptr> should point to memory that was allocated by C<malloc>. The
4080 string length, C<len>, must be supplied. This function will realloc the
4081 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4082 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4083 See C<sv_usepvn_mg>.
4089 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4091 SV_CHECK_THINKFIRST(sv);
4092 (void)SvUPGRADE(sv, SVt_PV);
4097 (void)SvOOK_off(sv);
4098 if (SvPVX(sv) && SvLEN(sv))
4099 Safefree(SvPVX(sv));
4100 Renew(ptr, len+1, char);
4103 SvLEN_set(sv, len+1);
4105 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4110 =for apidoc sv_usepvn_mg
4112 Like C<sv_usepvn>, but also handles 'set' magic.
4118 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4120 sv_usepvn(sv,ptr,len);
4125 =for apidoc sv_force_normal_flags
4127 Undo various types of fakery on an SV: if the PV is a shared string, make
4128 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4129 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4130 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4136 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4138 if (SvREADONLY(sv)) {
4140 char *pvx = SvPVX(sv);
4141 STRLEN len = SvCUR(sv);
4142 U32 hash = SvUVX(sv);
4143 SvGROW(sv, len + 1);
4144 Move(pvx,SvPVX(sv),len,char);
4148 unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4150 else if (PL_curcop != &PL_compiling)
4151 Perl_croak(aTHX_ PL_no_modify);
4154 sv_unref_flags(sv, flags);
4155 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4160 =for apidoc sv_force_normal
4162 Undo various types of fakery on an SV: if the PV is a shared string, make
4163 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4164 an xpvmg. See also C<sv_force_normal_flags>.
4170 Perl_sv_force_normal(pTHX_ register SV *sv)
4172 sv_force_normal_flags(sv, 0);
4178 Efficient removal of characters from the beginning of the string buffer.
4179 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4180 the string buffer. The C<ptr> becomes the first character of the adjusted
4181 string. Uses the "OOK hack".
4187 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4189 register STRLEN delta;
4191 if (!ptr || !SvPOKp(sv))
4193 SV_CHECK_THINKFIRST(sv);
4194 if (SvTYPE(sv) < SVt_PVIV)
4195 sv_upgrade(sv,SVt_PVIV);
4198 if (!SvLEN(sv)) { /* make copy of shared string */
4199 char *pvx = SvPVX(sv);
4200 STRLEN len = SvCUR(sv);
4201 SvGROW(sv, len + 1);
4202 Move(pvx,SvPVX(sv),len,char);
4206 SvFLAGS(sv) |= SVf_OOK;
4208 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4209 delta = ptr - SvPVX(sv);
4217 =for apidoc sv_catpvn
4219 Concatenates the string onto the end of the string which is in the SV. The
4220 C<len> indicates number of bytes to copy. If the SV has the UTF8
4221 status set, then the bytes appended should be valid UTF8.
4222 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4227 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4228 for binary compatibility only
4231 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4233 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4237 =for apidoc sv_catpvn_flags
4239 Concatenates the string onto the end of the string which is in the SV. The
4240 C<len> indicates number of bytes to copy. If the SV has the UTF8
4241 status set, then the bytes appended should be valid UTF8.
4242 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4243 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4244 in terms of this function.
4250 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4255 dstr = SvPV_force_flags(dsv, dlen, flags);
4256 SvGROW(dsv, dlen + slen + 1);
4259 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4262 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4267 =for apidoc sv_catpvn_mg
4269 Like C<sv_catpvn>, but also handles 'set' magic.
4275 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4277 sv_catpvn(sv,ptr,len);
4282 =for apidoc sv_catsv
4284 Concatenates the string from SV C<ssv> onto the end of the string in
4285 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4286 not 'set' magic. See C<sv_catsv_mg>.
4290 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4291 for binary compatibility only
4294 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4296 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4300 =for apidoc sv_catsv_flags
4302 Concatenates the string from SV C<ssv> onto the end of the string in
4303 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4304 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4305 and C<sv_catsv_nomg> are implemented in terms of this function.
4310 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4316 if ((spv = SvPV(ssv, slen))) {
4317 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4318 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4319 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4320 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4321 dsv->sv_flags doesn't have that bit set.
4322 Andy Dougherty 12 Oct 2001
4324 I32 sutf8 = DO_UTF8(ssv);
4327 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4329 dutf8 = DO_UTF8(dsv);
4331 if (dutf8 != sutf8) {
4333 /* Not modifying source SV, so taking a temporary copy. */
4334 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4336 sv_utf8_upgrade(csv);
4337 spv = SvPV(csv, slen);
4340 sv_utf8_upgrade_nomg(dsv);
4342 sv_catpvn_nomg(dsv, spv, slen);
4347 =for apidoc sv_catsv_mg
4349 Like C<sv_catsv>, but also handles 'set' magic.
4355 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4362 =for apidoc sv_catpv
4364 Concatenates the string onto the end of the string which is in the SV.
4365 If the SV has the UTF8 status set, then the bytes appended should be
4366 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4371 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4373 register STRLEN len;
4379 junk = SvPV_force(sv, tlen);
4381 SvGROW(sv, tlen + len + 1);
4384 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4386 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4391 =for apidoc sv_catpv_mg
4393 Like C<sv_catpv>, but also handles 'set' magic.
4399 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4408 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4409 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4416 Perl_newSV(pTHX_ STRLEN len)
4422 sv_upgrade(sv, SVt_PV);
4423 SvGROW(sv, len + 1);
4429 =for apidoc sv_magic
4431 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4432 then adds a new magic item of type C<how> to the head of the magic list.
4434 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4440 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4444 if (SvREADONLY(sv)) {
4445 if (PL_curcop != &PL_compiling
4446 && how != PERL_MAGIC_regex_global
4447 && how != PERL_MAGIC_bm
4448 && how != PERL_MAGIC_fm
4449 && how != PERL_MAGIC_sv
4452 Perl_croak(aTHX_ PL_no_modify);
4455 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4456 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4457 if (how == PERL_MAGIC_taint)
4463 (void)SvUPGRADE(sv, SVt_PVMG);
4465 Newz(702,mg, 1, MAGIC);
4466 mg->mg_moremagic = SvMAGIC(sv);
4469 /* Some magic contains a reference loop, where the sv and object refer to
4470 each other. To avoid a reference loop that would prevent such objects
4471 being freed, we look for such loops and if we find one we avoid
4472 incrementing the object refcount. */
4473 if (!obj || obj == sv ||
4474 how == PERL_MAGIC_arylen ||
4475 how == PERL_MAGIC_qr ||
4476 (SvTYPE(obj) == SVt_PVGV &&
4477 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4478 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4479 GvFORM(obj) == (CV*)sv)))
4484 mg->mg_obj = SvREFCNT_inc(obj);
4485 mg->mg_flags |= MGf_REFCOUNTED;
4488 mg->mg_len = namlen;
4491 mg->mg_ptr = savepvn(name, namlen);
4492 else if (namlen == HEf_SVKEY)
4493 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4498 mg->mg_virtual = &PL_vtbl_sv;
4500 case PERL_MAGIC_overload:
4501 mg->mg_virtual = &PL_vtbl_amagic;
4503 case PERL_MAGIC_overload_elem:
4504 mg->mg_virtual = &PL_vtbl_amagicelem;
4506 case PERL_MAGIC_overload_table:
4507 mg->mg_virtual = &PL_vtbl_ovrld;
4510 mg->mg_virtual = &PL_vtbl_bm;
4512 case PERL_MAGIC_regdata:
4513 mg->mg_virtual = &PL_vtbl_regdata;
4515 case PERL_MAGIC_regdatum:
4516 mg->mg_virtual = &PL_vtbl_regdatum;
4518 case PERL_MAGIC_env:
4519 mg->mg_virtual = &PL_vtbl_env;
4522 mg->mg_virtual = &PL_vtbl_fm;
4524 case PERL_MAGIC_envelem:
4525 mg->mg_virtual = &PL_vtbl_envelem;
4527 case PERL_MAGIC_regex_global:
4528 mg->mg_virtual = &PL_vtbl_mglob;
4530 case PERL_MAGIC_isa:
4531 mg->mg_virtual = &PL_vtbl_isa;
4533 case PERL_MAGIC_isaelem:
4534 mg->mg_virtual = &PL_vtbl_isaelem;
4536 case PERL_MAGIC_nkeys:
4537 mg->mg_virtual = &PL_vtbl_nkeys;
4539 case PERL_MAGIC_dbfile:
4543 case PERL_MAGIC_dbline:
4544 mg->mg_virtual = &PL_vtbl_dbline;
4546 #ifdef USE_5005THREADS
4547 case PERL_MAGIC_mutex:
4548 mg->mg_virtual = &PL_vtbl_mutex;
4550 #endif /* USE_5005THREADS */
4551 #ifdef USE_LOCALE_COLLATE
4552 case PERL_MAGIC_collxfrm:
4553 mg->mg_virtual = &PL_vtbl_collxfrm;
4555 #endif /* USE_LOCALE_COLLATE */
4556 case PERL_MAGIC_tied:
4557 mg->mg_virtual = &PL_vtbl_pack;
4559 case PERL_MAGIC_tiedelem:
4560 case PERL_MAGIC_tiedscalar:
4561 mg->mg_virtual = &PL_vtbl_packelem;
4564 mg->mg_virtual = &PL_vtbl_regexp;
4566 case PERL_MAGIC_sig:
4567 mg->mg_virtual = &PL_vtbl_sig;
4569 case PERL_MAGIC_sigelem:
4570 mg->mg_virtual = &PL_vtbl_sigelem;
4572 case PERL_MAGIC_taint:
4573 mg->mg_virtual = &PL_vtbl_taint;
4576 case PERL_MAGIC_uvar:
4577 mg->mg_virtual = &PL_vtbl_uvar;
4579 case PERL_MAGIC_vec:
4580 mg->mg_virtual = &PL_vtbl_vec;
4582 case PERL_MAGIC_substr:
4583 mg->mg_virtual = &PL_vtbl_substr;
4585 case PERL_MAGIC_defelem:
4586 mg->mg_virtual = &PL_vtbl_defelem;
4588 case PERL_MAGIC_glob:
4589 mg->mg_virtual = &PL_vtbl_glob;
4591 case PERL_MAGIC_arylen:
4592 mg->mg_virtual = &PL_vtbl_arylen;
4594 case PERL_MAGIC_pos:
4595 mg->mg_virtual = &PL_vtbl_pos;
4597 case PERL_MAGIC_backref:
4598 mg->mg_virtual = &PL_vtbl_backref;
4600 case PERL_MAGIC_ext:
4601 /* Reserved for use by extensions not perl internals. */
4602 /* Useful for attaching extension internal data to perl vars. */
4603 /* Note that multiple extensions may clash if magical scalars */
4604 /* etc holding private data from one are passed to another. */
4608 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4612 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4616 =for apidoc sv_unmagic
4618 Removes all magic of type C<type> from an SV.
4624 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4628 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4631 for (mg = *mgp; mg; mg = *mgp) {
4632 if (mg->mg_type == type) {
4633 MGVTBL* vtbl = mg->mg_virtual;
4634 *mgp = mg->mg_moremagic;
4635 if (vtbl && vtbl->svt_free)
4636 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4637 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4638 if (mg->mg_len >= 0)
4639 Safefree(mg->mg_ptr);
4640 else if (mg->mg_len == HEf_SVKEY)
4641 SvREFCNT_dec((SV*)mg->mg_ptr);
4643 if (mg->mg_flags & MGf_REFCOUNTED)
4644 SvREFCNT_dec(mg->mg_obj);
4648 mgp = &mg->mg_moremagic;
4652 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4659 =for apidoc sv_rvweaken
4661 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4662 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4663 push a back-reference to this RV onto the array of backreferences
4664 associated with that magic.
4670 Perl_sv_rvweaken(pTHX_ SV *sv)
4673 if (!SvOK(sv)) /* let undefs pass */
4676 Perl_croak(aTHX_ "Can't weaken a nonreference");
4677 else if (SvWEAKREF(sv)) {
4678 if (ckWARN(WARN_MISC))
4679 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4683 sv_add_backref(tsv, sv);
4689 /* Give tsv backref magic if it hasn't already got it, then push a
4690 * back-reference to sv onto the array associated with the backref magic.
4694 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4698 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4699 av = (AV*)mg->mg_obj;
4702 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4703 SvREFCNT_dec(av); /* for sv_magic */
4708 /* delete a back-reference to ourselves from the backref magic associated
4709 * with the SV we point to.
4713 S_sv_del_backref(pTHX_ SV *sv)
4720 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4721 Perl_croak(aTHX_ "panic: del_backref");
4722 av = (AV *)mg->mg_obj;
4727 svp[i] = &PL_sv_undef; /* XXX */
4734 =for apidoc sv_insert
4736 Inserts a string at the specified offset/length within the SV. Similar to
4737 the Perl substr() function.
4743 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4747 register char *midend;
4748 register char *bigend;
4754 Perl_croak(aTHX_ "Can't modify non-existent substring");
4755 SvPV_force(bigstr, curlen);
4756 (void)SvPOK_only_UTF8(bigstr);
4757 if (offset + len > curlen) {
4758 SvGROW(bigstr, offset+len+1);
4759 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4760 SvCUR_set(bigstr, offset+len);
4764 i = littlelen - len;
4765 if (i > 0) { /* string might grow */
4766 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4767 mid = big + offset + len;
4768 midend = bigend = big + SvCUR(bigstr);
4771 while (midend > mid) /* shove everything down */
4772 *--bigend = *--midend;
4773 Move(little,big+offset,littlelen,char);
4779 Move(little,SvPVX(bigstr)+offset,len,char);
4784 big = SvPVX(bigstr);
4787 bigend = big + SvCUR(bigstr);
4789 if (midend > bigend)
4790 Perl_croak(aTHX_ "panic: sv_insert");
4792 if (mid - big > bigend - midend) { /* faster to shorten from end */
4794 Move(little, mid, littlelen,char);
4797 i = bigend - midend;
4799 Move(midend, mid, i,char);
4803 SvCUR_set(bigstr, mid - big);
4806 else if ((i = mid - big)) { /* faster from front */
4807 midend -= littlelen;
4809 sv_chop(bigstr,midend-i);
4814 Move(little, mid, littlelen,char);
4816 else if (littlelen) {
4817 midend -= littlelen;
4818 sv_chop(bigstr,midend);
4819 Move(little,midend,littlelen,char);
4822 sv_chop(bigstr,midend);
4828 =for apidoc sv_replace
4830 Make the first argument a copy of the second, then delete the original.
4831 The target SV physically takes over ownership of the body of the source SV
4832 and inherits its flags; however, the target keeps any magic it owns,
4833 and any magic in the source is discarded.
4834 Note that this is a rather specialist SV copying operation; most of the
4835 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4841 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4843 U32 refcnt = SvREFCNT(sv);
4844 SV_CHECK_THINKFIRST(sv);
4845 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4846 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4847 if (SvMAGICAL(sv)) {
4851 sv_upgrade(nsv, SVt_PVMG);
4852 SvMAGIC(nsv) = SvMAGIC(sv);
4853 SvFLAGS(nsv) |= SvMAGICAL(sv);
4859 assert(!SvREFCNT(sv));
4860 StructCopy(nsv,sv,SV);
4861 SvREFCNT(sv) = refcnt;
4862 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4867 =for apidoc sv_clear
4869 Clear an SV: call any destructors, free up any memory used by the body,
4870 and free the body itself. The SV's head is I<not> freed, although
4871 its type is set to all 1's so that it won't inadvertently be assumed
4872 to be live during global destruction etc.
4873 This function should only be called when REFCNT is zero. Most of the time
4874 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4881 Perl_sv_clear(pTHX_ register SV *sv)
4885 assert(SvREFCNT(sv) == 0);
4888 if (PL_defstash) { /* Still have a symbol table? */
4893 Zero(&tmpref, 1, SV);
4894 sv_upgrade(&tmpref, SVt_RV);
4896 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4897 SvREFCNT(&tmpref) = 1;
4900 stash = SvSTASH(sv);
4901 destructor = StashHANDLER(stash,DESTROY);
4904 PUSHSTACKi(PERLSI_DESTROY);
4905 SvRV(&tmpref) = SvREFCNT_inc(sv);
4910 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4916 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4918 del_XRV(SvANY(&tmpref));
4921 if (PL_in_clean_objs)
4922 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4924 /* DESTROY gave object new lease on life */
4930 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4931 SvOBJECT_off(sv); /* Curse the object. */
4932 if (SvTYPE(sv) != SVt_PVIO)
4933 --PL_sv_objcount; /* XXX Might want something more general */
4936 if (SvTYPE(sv) >= SVt_PVMG) {
4939 if (SvFLAGS(sv) & SVpad_TYPED)
4940 SvREFCNT_dec(SvSTASH(sv));
4943 switch (SvTYPE(sv)) {
4946 IoIFP(sv) != PerlIO_stdin() &&
4947 IoIFP(sv) != PerlIO_stdout() &&
4948 IoIFP(sv) != PerlIO_stderr())
4950 io_close((IO*)sv, FALSE);
4952 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4953 PerlDir_close(IoDIRP(sv));
4954 IoDIRP(sv) = (DIR*)NULL;
4955 Safefree(IoTOP_NAME(sv));
4956 Safefree(IoFMT_NAME(sv));
4957 Safefree(IoBOTTOM_NAME(sv));
4972 SvREFCNT_dec(LvTARG(sv));
4976 Safefree(GvNAME(sv));
4977 /* cannot decrease stash refcount yet, as we might recursively delete
4978 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4979 of stash until current sv is completely gone.
4980 -- JohnPC, 27 Mar 1998 */
4981 stash = GvSTASH(sv);
4987 (void)SvOOK_off(sv);
4995 SvREFCNT_dec(SvRV(sv));
4997 else if (SvPVX(sv) && SvLEN(sv))
4998 Safefree(SvPVX(sv));
4999 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5000 unsharepvn(SvPVX(sv),
5001 SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5014 switch (SvTYPE(sv)) {
5030 del_XPVIV(SvANY(sv));
5033 del_XPVNV(SvANY(sv));
5036 del_XPVMG(SvANY(sv));
5039 del_XPVLV(SvANY(sv));
5042 del_XPVAV(SvANY(sv));
5045 del_XPVHV(SvANY(sv));
5048 del_XPVCV(SvANY(sv));
5051 del_XPVGV(SvANY(sv));
5052 /* code duplication for increased performance. */
5053 SvFLAGS(sv) &= SVf_BREAK;
5054 SvFLAGS(sv) |= SVTYPEMASK;
5055 /* decrease refcount of the stash that owns this GV, if any */
5057 SvREFCNT_dec(stash);
5058 return; /* not break, SvFLAGS reset already happened */
5060 del_XPVBM(SvANY(sv));
5063 del_XPVFM(SvANY(sv));
5066 del_XPVIO(SvANY(sv));
5069 SvFLAGS(sv) &= SVf_BREAK;
5070 SvFLAGS(sv) |= SVTYPEMASK;
5074 =for apidoc sv_newref
5076 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5083 Perl_sv_newref(pTHX_ SV *sv)
5086 ATOMIC_INC(SvREFCNT(sv));
5093 Decrement an SV's reference count, and if it drops to zero, call
5094 C<sv_clear> to invoke destructors and free up any memory used by
5095 the body; finally, deallocate the SV's head itself.
5096 Normally called via a wrapper macro C<SvREFCNT_dec>.
5102 Perl_sv_free(pTHX_ SV *sv)
5104 int refcount_is_zero;
5108 if (SvREFCNT(sv) == 0) {
5109 if (SvFLAGS(sv) & SVf_BREAK)
5110 /* this SV's refcnt has been artificially decremented to
5111 * trigger cleanup */
5113 if (PL_in_clean_all) /* All is fair */
5115 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5116 /* make sure SvREFCNT(sv)==0 happens very seldom */
5117 SvREFCNT(sv) = (~(U32)0)/2;
5120 if (ckWARN_d(WARN_INTERNAL))
5121 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5124 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5125 if (!refcount_is_zero)
5129 if (ckWARN_d(WARN_DEBUGGING))
5130 Perl_warner(aTHX_ WARN_DEBUGGING,
5131 "Attempt to free temp prematurely: SV 0x%"UVxf,
5136 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5137 /* make sure SvREFCNT(sv)==0 happens very seldom */
5138 SvREFCNT(sv) = (~(U32)0)/2;
5149 Returns the length of the string in the SV. Handles magic and type
5150 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5156 Perl_sv_len(pTHX_ register SV *sv)
5164 len = mg_length(sv);
5166 (void)SvPV(sv, len);
5171 =for apidoc sv_len_utf8
5173 Returns the number of characters in the string in an SV, counting wide
5174 UTF8 bytes as a single character. Handles magic and type coercion.
5180 Perl_sv_len_utf8(pTHX_ register SV *sv)
5186 return mg_length(sv);
5190 U8 *s = (U8*)SvPV(sv, len);
5192 return Perl_utf8_length(aTHX_ s, s + len);
5197 =for apidoc sv_pos_u2b
5199 Converts the value pointed to by offsetp from a count of UTF8 chars from
5200 the start of the string, to a count of the equivalent number of bytes; if
5201 lenp is non-zero, it does the same to lenp, but this time starting from
5202 the offset, rather than from the start of the string. Handles magic and
5209 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5214 I32 uoffset = *offsetp;
5220 start = s = (U8*)SvPV(sv, len);
5222 while (s < send && uoffset--)
5226 *offsetp = s - start;
5230 while (s < send && ulen--)
5240 =for apidoc sv_pos_b2u
5242 Converts the value pointed to by offsetp from a count of bytes from the
5243 start of the string, to a count of the equivalent number of UTF8 chars.
5244 Handles magic and type coercion.
5250 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5259 s = (U8*)SvPV(sv, len);
5261 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5262 send = s + *offsetp;
5266 /* Call utf8n_to_uvchr() to validate the sequence */
5267 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5282 Returns a boolean indicating whether the strings in the two SVs are
5283 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5284 coerce its args to strings if necessary.
5290 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5304 pv1 = SvPV(sv1, cur1);
5311 pv2 = SvPV(sv2, cur2);
5313 /* do not utf8ize the comparands as a side-effect */
5314 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5315 bool is_utf8 = TRUE;
5316 /* UTF-8ness differs */
5319 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5320 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5325 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5326 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5331 /* Downgrade not possible - cannot be eq */
5337 eq = memEQ(pv1, pv2, cur1);
5348 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5349 string in C<sv1> is less than, equal to, or greater than the string in
5350 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5351 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5357 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5362 bool pv1tmp = FALSE;
5363 bool pv2tmp = FALSE;
5370 pv1 = SvPV(sv1, cur1);
5377 pv2 = SvPV(sv2, cur2);
5379 /* do not utf8ize the comparands as a side-effect */
5380 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5382 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5386 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5392 cmp = cur2 ? -1 : 0;
5396 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5399 cmp = retval < 0 ? -1 : 1;
5400 } else if (cur1 == cur2) {
5403 cmp = cur1 < cur2 ? -1 : 1;
5416 =for apidoc sv_cmp_locale
5418 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5419 'use bytes' aware, handles get magic, and will coerce its args to strings
5420 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5426 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5428 #ifdef USE_LOCALE_COLLATE
5434 if (PL_collation_standard)
5438 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5440 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5442 if (!pv1 || !len1) {
5453 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5456 return retval < 0 ? -1 : 1;
5459 * When the result of collation is equality, that doesn't mean
5460 * that there are no differences -- some locales exclude some
5461 * characters from consideration. So to avoid false equalities,
5462 * we use the raw string as a tiebreaker.
5468 #endif /* USE_LOCALE_COLLATE */
5470 return sv_cmp(sv1, sv2);
5474 #ifdef USE_LOCALE_COLLATE
5477 =for apidoc sv_collxfrm
5479 Add Collate Transform magic to an SV if it doesn't already have it.
5481 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5482 scalar data of the variable, but transformed to such a format that a normal
5483 memory comparison can be used to compare the data according to the locale
5490 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5494 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5495 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5500 Safefree(mg->mg_ptr);
5502 if ((xf = mem_collxfrm(s, len, &xlen))) {
5503 if (SvREADONLY(sv)) {
5506 return xf + sizeof(PL_collation_ix);
5509 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5510 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5523 if (mg && mg->mg_ptr) {
5525 return mg->mg_ptr + sizeof(PL_collation_ix);
5533 #endif /* USE_LOCALE_COLLATE */
5538 Get a line from the filehandle and store it into the SV, optionally
5539 appending to the currently-stored string.
5545 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5549 register STDCHAR rslast;
5550 register STDCHAR *bp;
5555 SV_CHECK_THINKFIRST(sv);
5556 (void)SvUPGRADE(sv, SVt_PV);
5560 if (PL_curcop == &PL_compiling) {
5561 /* we always read code in line mode */
5565 else if (RsSNARF(PL_rs)) {
5569 else if (RsRECORD(PL_rs)) {
5570 I32 recsize, bytesread;
5573 /* Grab the size of the record we're getting */
5574 recsize = SvIV(SvRV(PL_rs));
5575 (void)SvPOK_only(sv); /* Validate pointer */
5576 buffer = SvGROW(sv, recsize + 1);
5579 /* VMS wants read instead of fread, because fread doesn't respect */
5580 /* RMS record boundaries. This is not necessarily a good thing to be */
5581 /* doing, but we've got no other real choice */
5582 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5584 bytesread = PerlIO_read(fp, buffer, recsize);
5586 SvCUR_set(sv, bytesread);
5587 buffer[bytesread] = '\0';
5588 if (PerlIO_isutf8(fp))
5592 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5594 else if (RsPARA(PL_rs)) {
5600 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5601 if (PerlIO_isutf8(fp)) {
5602 rsptr = SvPVutf8(PL_rs, rslen);
5605 if (SvUTF8(PL_rs)) {
5606 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5607 Perl_croak(aTHX_ "Wide character in $/");
5610 rsptr = SvPV(PL_rs, rslen);
5614 rslast = rslen ? rsptr[rslen - 1] : '\0';
5616 if (rspara) { /* have to do this both before and after */
5617 do { /* to make sure file boundaries work right */
5620 i = PerlIO_getc(fp);
5624 PerlIO_ungetc(fp,i);
5630 /* See if we know enough about I/O mechanism to cheat it ! */
5632 /* This used to be #ifdef test - it is made run-time test for ease
5633 of abstracting out stdio interface. One call should be cheap
5634 enough here - and may even be a macro allowing compile
5638 if (PerlIO_fast_gets(fp)) {
5641 * We're going to steal some values from the stdio struct
5642 * and put EVERYTHING in the innermost loop into registers.
5644 register STDCHAR *ptr;
5648 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5649 /* An ungetc()d char is handled separately from the regular
5650 * buffer, so we getc() it back out and stuff it in the buffer.
5652 i = PerlIO_getc(fp);
5653 if (i == EOF) return 0;
5654 *(--((*fp)->_ptr)) = (unsigned char) i;
5658 /* Here is some breathtakingly efficient cheating */
5660 cnt = PerlIO_get_cnt(fp); /* get count into register */
5661 (void)SvPOK_only(sv); /* validate pointer */
5662 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5663 if (cnt > 80 && SvLEN(sv) > append) {
5664 shortbuffered = cnt - SvLEN(sv) + append + 1;
5665 cnt -= shortbuffered;
5669 /* remember that cnt can be negative */
5670 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5675 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5676 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5677 DEBUG_P(PerlIO_printf(Perl_debug_log,
5678 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5679 DEBUG_P(PerlIO_printf(Perl_debug_log,
5680 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5681 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5682 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5687 while (cnt > 0) { /* this | eat */
5689 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5690 goto thats_all_folks; /* screams | sed :-) */
5694 Copy(ptr, bp, cnt, char); /* this | eat */
5695 bp += cnt; /* screams | dust */
5696 ptr += cnt; /* louder | sed :-) */
5701 if (shortbuffered) { /* oh well, must extend */
5702 cnt = shortbuffered;
5704 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5706 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5707 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5711 DEBUG_P(PerlIO_printf(Perl_debug_log,
5712 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5713 PTR2UV(ptr),(long)cnt));
5714 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5715 DEBUG_P(PerlIO_printf(Perl_debug_log,
5716 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5717 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5718 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5719 /* This used to call 'filbuf' in stdio form, but as that behaves like
5720 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5721 another abstraction. */
5722 i = PerlIO_getc(fp); /* get more characters */
5723 DEBUG_P(PerlIO_printf(Perl_debug_log,
5724 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5725 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5726 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5727 cnt = PerlIO_get_cnt(fp);
5728 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5729 DEBUG_P(PerlIO_printf(Perl_debug_log,
5730 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5732 if (i == EOF) /* all done for ever? */
5733 goto thats_really_all_folks;
5735 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5737 SvGROW(sv, bpx + cnt + 2);
5738 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5740 *bp++ = i; /* store character from PerlIO_getc */
5742 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5743 goto thats_all_folks;
5747 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5748 memNE((char*)bp - rslen, rsptr, rslen))
5749 goto screamer; /* go back to the fray */
5750 thats_really_all_folks:
5752 cnt += shortbuffered;
5753 DEBUG_P(PerlIO_printf(Perl_debug_log,
5754 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5755 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5756 DEBUG_P(PerlIO_printf(Perl_debug_log,
5757 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5758 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5759 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5761 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5762 DEBUG_P(PerlIO_printf(Perl_debug_log,
5763 "Screamer: done, len=%ld, string=|%.*s|\n",
5764 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5769 /*The big, slow, and stupid way */
5772 /* Need to work around EPOC SDK features */
5773 /* On WINS: MS VC5 generates calls to _chkstk, */
5774 /* if a `large' stack frame is allocated */
5775 /* gcc on MARM does not generate calls like these */
5781 register STDCHAR *bpe = buf + sizeof(buf);
5783 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5784 ; /* keep reading */
5788 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5789 /* Accomodate broken VAXC compiler, which applies U8 cast to
5790 * both args of ?: operator, causing EOF to change into 255
5792 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5796 sv_catpvn(sv, (char *) buf, cnt);
5798 sv_setpvn(sv, (char *) buf, cnt);
5800 if (i != EOF && /* joy */
5802 SvCUR(sv) < rslen ||
5803 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5807 * If we're reading from a TTY and we get a short read,
5808 * indicating that the user hit his EOF character, we need
5809 * to notice it now, because if we try to read from the TTY
5810 * again, the EOF condition will disappear.
5812 * The comparison of cnt to sizeof(buf) is an optimization
5813 * that prevents unnecessary calls to feof().
5817 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5822 if (rspara) { /* have to do this both before and after */
5823 while (i != EOF) { /* to make sure file boundaries work right */
5824 i = PerlIO_getc(fp);
5826 PerlIO_ungetc(fp,i);
5832 if (PerlIO_isutf8(fp))
5837 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5843 Auto-increment of the value in the SV, doing string to numeric conversion
5844 if necessary. Handles 'get' magic.
5850 Perl_sv_inc(pTHX_ register SV *sv)
5859 if (SvTHINKFIRST(sv)) {
5860 if (SvREADONLY(sv)) {
5861 if (PL_curcop != &PL_compiling)
5862 Perl_croak(aTHX_ PL_no_modify);
5866 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5868 i = PTR2IV(SvRV(sv));
5873 flags = SvFLAGS(sv);
5874 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5875 /* It's (privately or publicly) a float, but not tested as an
5876 integer, so test it to see. */
5878 flags = SvFLAGS(sv);
5880 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5881 /* It's publicly an integer, or privately an integer-not-float */
5882 #ifdef PERL_PRESERVE_IVUV
5886 if (SvUVX(sv) == UV_MAX)
5887 sv_setnv(sv, (NV)UV_MAX + 1.0);
5889 (void)SvIOK_only_UV(sv);
5892 if (SvIVX(sv) == IV_MAX)
5893 sv_setuv(sv, (UV)IV_MAX + 1);
5895 (void)SvIOK_only(sv);
5901 if (flags & SVp_NOK) {
5902 (void)SvNOK_only(sv);
5907 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5908 if ((flags & SVTYPEMASK) < SVt_PVIV)
5909 sv_upgrade(sv, SVt_IV);
5910 (void)SvIOK_only(sv);
5915 while (isALPHA(*d)) d++;
5916 while (isDIGIT(*d)) d++;
5918 #ifdef PERL_PRESERVE_IVUV
5919 /* Got to punt this an an integer if needs be, but we don't issue
5920 warnings. Probably ought to make the sv_iv_please() that does
5921 the conversion if possible, and silently. */
5922 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5923 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5924 /* Need to try really hard to see if it's an integer.
5925 9.22337203685478e+18 is an integer.
5926 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5927 so $a="9.22337203685478e+18"; $a+0; $a++
5928 needs to be the same as $a="9.22337203685478e+18"; $a++
5935 /* sv_2iv *should* have made this an NV */
5936 if (flags & SVp_NOK) {
5937 (void)SvNOK_only(sv);
5941 /* I don't think we can get here. Maybe I should assert this
5942 And if we do get here I suspect that sv_setnv will croak. NWC
5944 #if defined(USE_LONG_DOUBLE)
5945 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",
5946 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5948 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5949 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5952 #endif /* PERL_PRESERVE_IVUV */
5953 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5957 while (d >= SvPVX(sv)) {
5965 /* MKS: The original code here died if letters weren't consecutive.
5966 * at least it didn't have to worry about non-C locales. The
5967 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5968 * arranged in order (although not consecutively) and that only
5969 * [A-Za-z] are accepted by isALPHA in the C locale.
5971 if (*d != 'z' && *d != 'Z') {
5972 do { ++*d; } while (!isALPHA(*d));
5975 *(d--) -= 'z' - 'a';
5980 *(d--) -= 'z' - 'a' + 1;
5984 /* oh,oh, the number grew */
5985 SvGROW(sv, SvCUR(sv) + 2);
5987 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5998 Auto-decrement of the value in the SV, doing string to numeric conversion
5999 if necessary. Handles 'get' magic.
6005 Perl_sv_dec(pTHX_ register SV *sv)
6013 if (SvTHINKFIRST(sv)) {
6014 if (SvREADONLY(sv)) {
6015 if (PL_curcop != &PL_compiling)
6016 Perl_croak(aTHX_ PL_no_modify);
6020 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6022 i = PTR2IV(SvRV(sv));
6027 /* Unlike sv_inc we don't have to worry about string-never-numbers
6028 and keeping them magic. But we mustn't warn on punting */
6029 flags = SvFLAGS(sv);
6030 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6031 /* It's publicly an integer, or privately an integer-not-float */
6032 #ifdef PERL_PRESERVE_IVUV
6036 if (SvUVX(sv) == 0) {
6037 (void)SvIOK_only(sv);
6041 (void)SvIOK_only_UV(sv);
6045 if (SvIVX(sv) == IV_MIN)
6046 sv_setnv(sv, (NV)IV_MIN - 1.0);
6048 (void)SvIOK_only(sv);
6054 if (flags & SVp_NOK) {
6056 (void)SvNOK_only(sv);
6059 if (!(flags & SVp_POK)) {
6060 if ((flags & SVTYPEMASK) < SVt_PVNV)
6061 sv_upgrade(sv, SVt_NV);
6063 (void)SvNOK_only(sv);
6066 #ifdef PERL_PRESERVE_IVUV
6068 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6069 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6070 /* Need to try really hard to see if it's an integer.
6071 9.22337203685478e+18 is an integer.
6072 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6073 so $a="9.22337203685478e+18"; $a+0; $a--
6074 needs to be the same as $a="9.22337203685478e+18"; $a--
6081 /* sv_2iv *should* have made this an NV */
6082 if (flags & SVp_NOK) {
6083 (void)SvNOK_only(sv);
6087 /* I don't think we can get here. Maybe I should assert this
6088 And if we do get here I suspect that sv_setnv will croak. NWC
6090 #if defined(USE_LONG_DOUBLE)
6091 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",
6092 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6094 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6095 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6099 #endif /* PERL_PRESERVE_IVUV */
6100 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6104 =for apidoc sv_mortalcopy
6106 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6107 The new SV is marked as mortal. It will be destroyed "soon", either by an
6108 explicit call to FREETMPS, or by an implicit call at places such as
6109 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6114 /* Make a string that will exist for the duration of the expression
6115 * evaluation. Actually, it may have to last longer than that, but
6116 * hopefully we won't free it until it has been assigned to a
6117 * permanent location. */
6120 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6125 sv_setsv(sv,oldstr);
6127 PL_tmps_stack[++PL_tmps_ix] = sv;
6133 =for apidoc sv_newmortal
6135 Creates a new null SV which is mortal. The reference count of the SV is
6136 set to 1. It will be destroyed "soon", either by an explicit call to
6137 FREETMPS, or by an implicit call at places such as statement boundaries.
6138 See also C<sv_mortalcopy> and C<sv_2mortal>.
6144 Perl_sv_newmortal(pTHX)
6149 SvFLAGS(sv) = SVs_TEMP;
6151 PL_tmps_stack[++PL_tmps_ix] = sv;
6156 =for apidoc sv_2mortal
6158 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6159 by an explicit call to FREETMPS, or by an implicit call at places such as
6160 statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
6166 Perl_sv_2mortal(pTHX_ register SV *sv)
6170 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6173 PL_tmps_stack[++PL_tmps_ix] = sv;
6181 Creates a new SV and copies a string into it. The reference count for the
6182 SV is set to 1. If C<len> is zero, Perl will compute the length using
6183 strlen(). For efficiency, consider using C<newSVpvn> instead.
6189 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6196 sv_setpvn(sv,s,len);
6201 =for apidoc newSVpvn
6203 Creates a new SV and copies a string into it. The reference count for the
6204 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6205 string. You are responsible for ensuring that the source string is at least
6212 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6217 sv_setpvn(sv,s,len);
6222 =for apidoc newSVpvn_share
6224 Creates a new SV with its SvPVX pointing to a shared string in the string
6225 table. If the string does not already exist in the table, it is created
6226 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6227 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6228 otherwise the hash is computed. The idea here is that as the string table
6229 is used for shared hash keys these strings will have SvPVX == HeKEY and
6230 hash lookup will avoid string compare.
6236 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6239 bool is_utf8 = FALSE;
6241 STRLEN tmplen = -len;
6243 /* See the note in hv.c:hv_fetch() --jhi */
6244 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6248 PERL_HASH(hash, src, len);
6250 sv_upgrade(sv, SVt_PVIV);
6251 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6264 #if defined(PERL_IMPLICIT_CONTEXT)
6266 /* pTHX_ magic can't cope with varargs, so this is a no-context
6267 * version of the main function, (which may itself be aliased to us).
6268 * Don't access this version directly.
6272 Perl_newSVpvf_nocontext(const char* pat, ...)
6277 va_start(args, pat);
6278 sv = vnewSVpvf(pat, &args);
6285 =for apidoc newSVpvf
6287 Creates a new SV and initializes it with the string formatted like
6294 Perl_newSVpvf(pTHX_ const char* pat, ...)
6298 va_start(args, pat);
6299 sv = vnewSVpvf(pat, &args);
6304 /* backend for newSVpvf() and newSVpvf_nocontext() */
6307 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6311 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6318 Creates a new SV and copies a floating point value into it.
6319 The reference count for the SV is set to 1.
6325 Perl_newSVnv(pTHX_ NV n)
6337 Creates a new SV and copies an integer into it. The reference count for the
6344 Perl_newSViv(pTHX_ IV i)
6356 Creates a new SV and copies an unsigned integer into it.
6357 The reference count for the SV is set to 1.
6363 Perl_newSVuv(pTHX_ UV u)
6373 =for apidoc newRV_noinc
6375 Creates an RV wrapper for an SV. The reference count for the original
6376 SV is B<not> incremented.
6382 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6387 sv_upgrade(sv, SVt_RV);
6394 /* newRV_inc is the official function name to use now.
6395 * newRV_inc is in fact #defined to newRV in sv.h
6399 Perl_newRV(pTHX_ SV *tmpRef)
6401 return newRV_noinc(SvREFCNT_inc(tmpRef));
6407 Creates a new SV which is an exact duplicate of the original SV.
6414 Perl_newSVsv(pTHX_ register SV *old)
6420 if (SvTYPE(old) == SVTYPEMASK) {
6421 if (ckWARN_d(WARN_INTERNAL))
6422 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6437 =for apidoc sv_reset
6439 Underlying implementation for the C<reset> Perl function.
6440 Note that the perl-level function is vaguely deprecated.
6446 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6454 char todo[PERL_UCHAR_MAX+1];
6459 if (!*s) { /* reset ?? searches */
6460 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6461 pm->op_pmdynflags &= ~PMdf_USED;
6466 /* reset variables */
6468 if (!HvARRAY(stash))
6471 Zero(todo, 256, char);
6473 i = (unsigned char)*s;
6477 max = (unsigned char)*s++;
6478 for ( ; i <= max; i++) {
6481 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6482 for (entry = HvARRAY(stash)[i];
6484 entry = HeNEXT(entry))
6486 if (!todo[(U8)*HeKEY(entry)])
6488 gv = (GV*)HeVAL(entry);
6490 if (SvTHINKFIRST(sv)) {
6491 if (!SvREADONLY(sv) && SvROK(sv))
6496 if (SvTYPE(sv) >= SVt_PV) {
6498 if (SvPVX(sv) != Nullch)
6505 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6507 #ifdef USE_ENVIRON_ARRAY
6509 environ[0] = Nullch;
6520 Using various gambits, try to get an IO from an SV: the IO slot if its a
6521 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6522 named after the PV if we're a string.
6528 Perl_sv_2io(pTHX_ SV *sv)
6534 switch (SvTYPE(sv)) {
6542 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6546 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6548 return sv_2io(SvRV(sv));
6549 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6555 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6564 Using various gambits, try to get a CV from an SV; in addition, try if
6565 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6571 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6578 return *gvp = Nullgv, Nullcv;
6579 switch (SvTYPE(sv)) {
6598 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6599 tryAMAGICunDEREF(to_cv);
6602 if (SvTYPE(sv) == SVt_PVCV) {
6611 Perl_croak(aTHX_ "Not a subroutine reference");
6616 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6622 if (lref && !GvCVu(gv)) {
6625 tmpsv = NEWSV(704,0);
6626 gv_efullname3(tmpsv, gv, Nullch);
6627 /* XXX this is probably not what they think they're getting.
6628 * It has the same effect as "sub name;", i.e. just a forward
6630 newSUB(start_subparse(FALSE, 0),
6631 newSVOP(OP_CONST, 0, tmpsv),
6636 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6645 Returns true if the SV has a true value by Perl's rules.
6646 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6647 instead use an in-line version.
6653 Perl_sv_true(pTHX_ register SV *sv)
6659 if ((tXpv = (XPV*)SvANY(sv)) &&
6660 (tXpv->xpv_cur > 1 ||
6661 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6668 return SvIVX(sv) != 0;
6671 return SvNVX(sv) != 0.0;
6673 return sv_2bool(sv);
6681 A private implementation of the C<SvIVx> macro for compilers which can't
6682 cope with complex macro expressions. Always use the macro instead.
6688 Perl_sv_iv(pTHX_ register SV *sv)
6692 return (IV)SvUVX(sv);
6701 A private implementation of the C<SvUVx> macro for compilers which can't
6702 cope with complex macro expressions. Always use the macro instead.
6708 Perl_sv_uv(pTHX_ register SV *sv)
6713 return (UV)SvIVX(sv);
6721 A private implementation of the C<SvNVx> macro for compilers which can't
6722 cope with complex macro expressions. Always use the macro instead.
6728 Perl_sv_nv(pTHX_ register SV *sv)
6738 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6739 cope with complex macro expressions. Always use the macro instead.
6745 Perl_sv_pv(pTHX_ SV *sv)
6752 return sv_2pv(sv, &n_a);
6758 A private implementation of the C<SvPV> macro for compilers which can't
6759 cope with complex macro expressions. Always use the macro instead.
6765 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6771 return sv_2pv(sv, lp);
6774 /* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
6778 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
6784 return sv_2pv_flags(sv, lp, 0);
6788 =for apidoc sv_pvn_force
6790 Get a sensible string out of the SV somehow.
6791 A private implementation of the C<SvPV_force> macro for compilers which
6792 can't cope with complex macro expressions. Always use the macro instead.
6798 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6800 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6804 =for apidoc sv_pvn_force_flags
6806 Get a sensible string out of the SV somehow.
6807 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6808 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6809 implemented in terms of this function.
6810 You normally want to use the various wrapper macros instead: see
6811 C<SvPV_force> and C<SvPV_force_nomg>
6817 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6821 if (SvTHINKFIRST(sv) && !SvROK(sv))
6822 sv_force_normal(sv);
6828 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6829 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6833 s = sv_2pv_flags(sv, lp, flags);
6834 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6839 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6840 SvGROW(sv, len + 1);
6841 Move(s,SvPVX(sv),len,char);
6846 SvPOK_on(sv); /* validate pointer */
6848 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6849 PTR2UV(sv),SvPVX(sv)));
6856 =for apidoc sv_pvbyte
6858 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6859 which can't cope with complex macro expressions. Always use the macro
6866 Perl_sv_pvbyte(pTHX_ SV *sv)
6868 sv_utf8_downgrade(sv,0);
6873 =for apidoc sv_pvbyten
6875 A private implementation of the C<SvPVbyte> macro for compilers
6876 which can't cope with complex macro expressions. Always use the macro
6883 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6885 sv_utf8_downgrade(sv,0);
6886 return sv_pvn(sv,lp);
6890 =for apidoc sv_pvbyten_force
6892 A private implementation of the C<SvPVbytex_force> macro for compilers
6893 which can't cope with complex macro expressions. Always use the macro
6900 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6902 sv_utf8_downgrade(sv,0);
6903 return sv_pvn_force(sv,lp);
6907 =for apidoc sv_pvutf8
6909 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6910 which can't cope with complex macro expressions. Always use the macro
6917 Perl_sv_pvutf8(pTHX_ SV *sv)
6919 sv_utf8_upgrade(sv);
6924 =for apidoc sv_pvutf8n
6926 A private implementation of the C<SvPVutf8> macro for compilers
6927 which can't cope with complex macro expressions. Always use the macro
6934 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6936 sv_utf8_upgrade(sv);
6937 return sv_pvn(sv,lp);
6941 =for apidoc sv_pvutf8n_force
6943 A private implementation of the C<SvPVutf8_force> macro for compilers
6944 which can't cope with complex macro expressions. Always use the macro
6951 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6953 sv_utf8_upgrade(sv);
6954 return sv_pvn_force(sv,lp);
6958 =for apidoc sv_reftype
6960 Returns a string describing what the SV is a reference to.
6966 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6968 if (ob && SvOBJECT(sv))
6969 return HvNAME(SvSTASH(sv));
6971 switch (SvTYPE(sv)) {
6985 case SVt_PVLV: return "LVALUE";
6986 case SVt_PVAV: return "ARRAY";
6987 case SVt_PVHV: return "HASH";
6988 case SVt_PVCV: return "CODE";
6989 case SVt_PVGV: return "GLOB";
6990 case SVt_PVFM: return "FORMAT";
6991 case SVt_PVIO: return "IO";
6992 default: return "UNKNOWN";
6998 =for apidoc sv_isobject
7000 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7001 object. If the SV is not an RV, or if the object is not blessed, then this
7008 Perl_sv_isobject(pTHX_ SV *sv)
7025 Returns a boolean indicating whether the SV is blessed into the specified
7026 class. This does not check for subtypes; use C<sv_derived_from> to verify
7027 an inheritance relationship.
7033 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7045 return strEQ(HvNAME(SvSTASH(sv)), name);
7051 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7052 it will be upgraded to one. If C<classname> is non-null then the new SV will
7053 be blessed in the specified package. The new SV is returned and its
7054 reference count is 1.
7060 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7066 SV_CHECK_THINKFIRST(rv);
7069 if (SvTYPE(rv) >= SVt_PVMG) {
7070 U32 refcnt = SvREFCNT(rv);
7074 SvREFCNT(rv) = refcnt;
7077 if (SvTYPE(rv) < SVt_RV)
7078 sv_upgrade(rv, SVt_RV);
7079 else if (SvTYPE(rv) > SVt_RV) {
7080 (void)SvOOK_off(rv);
7081 if (SvPVX(rv) && SvLEN(rv))
7082 Safefree(SvPVX(rv));
7092 HV* stash = gv_stashpv(classname, TRUE);
7093 (void)sv_bless(rv, stash);
7099 =for apidoc sv_setref_pv
7101 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7102 argument will be upgraded to an RV. That RV will be modified to point to
7103 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7104 into the SV. The C<classname> argument indicates the package for the
7105 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7106 will be returned and will have a reference count of 1.
7108 Do not use with other Perl types such as HV, AV, SV, CV, because those
7109 objects will become corrupted by the pointer copy process.
7111 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7117 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7120 sv_setsv(rv, &PL_sv_undef);
7124 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7129 =for apidoc sv_setref_iv
7131 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7132 argument will be upgraded to an RV. That RV will be modified to point to
7133 the new SV. The C<classname> argument indicates the package for the
7134 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7135 will be returned and will have a reference count of 1.
7141 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7143 sv_setiv(newSVrv(rv,classname), iv);
7148 =for apidoc sv_setref_uv
7150 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7151 argument will be upgraded to an RV. That RV will be modified to point to
7152 the new SV. The C<classname> argument indicates the package for the
7153 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7154 will be returned and will have a reference count of 1.
7160 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7162 sv_setuv(newSVrv(rv,classname), uv);
7167 =for apidoc sv_setref_nv
7169 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7170 argument will be upgraded to an RV. That RV will be modified to point to
7171 the new SV. The C<classname> argument indicates the package for the
7172 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7173 will be returned and will have a reference count of 1.
7179 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7181 sv_setnv(newSVrv(rv,classname), nv);
7186 =for apidoc sv_setref_pvn
7188 Copies a string into a new SV, optionally blessing the SV. The length of the
7189 string must be specified with C<n>. The C<rv> argument will be upgraded to
7190 an RV. That RV will be modified to point to the new SV. The C<classname>
7191 argument indicates the package for the blessing. Set C<classname> to
7192 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7193 a reference count of 1.
7195 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7201 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7203 sv_setpvn(newSVrv(rv,classname), pv, n);
7208 =for apidoc sv_bless
7210 Blesses an SV into a specified package. The SV must be an RV. The package
7211 must be designated by its stash (see C<gv_stashpv()>). The reference count
7212 of the SV is unaffected.
7218 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7222 Perl_croak(aTHX_ "Can't bless non-reference value");
7224 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7225 if (SvREADONLY(tmpRef))
7226 Perl_croak(aTHX_ PL_no_modify);
7227 if (SvOBJECT(tmpRef)) {
7228 if (SvTYPE(tmpRef) != SVt_PVIO)
7230 SvREFCNT_dec(SvSTASH(tmpRef));
7233 SvOBJECT_on(tmpRef);
7234 if (SvTYPE(tmpRef) != SVt_PVIO)
7236 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7237 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7244 if(SvSMAGICAL(tmpRef))
7245 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7253 /* Downgrades a PVGV to a PVMG.
7255 * XXX This function doesn't actually appear to be used anywhere
7260 S_sv_unglob(pTHX_ SV *sv)
7264 assert(SvTYPE(sv) == SVt_PVGV);
7269 SvREFCNT_dec(GvSTASH(sv));
7270 GvSTASH(sv) = Nullhv;
7272 sv_unmagic(sv, PERL_MAGIC_glob);
7273 Safefree(GvNAME(sv));
7276 /* need to keep SvANY(sv) in the right arena */
7277 xpvmg = new_XPVMG();
7278 StructCopy(SvANY(sv), xpvmg, XPVMG);
7279 del_XPVGV(SvANY(sv));
7282 SvFLAGS(sv) &= ~SVTYPEMASK;
7283 SvFLAGS(sv) |= SVt_PVMG;
7287 =for apidoc sv_unref_flags
7289 Unsets the RV status of the SV, and decrements the reference count of
7290 whatever was being referenced by the RV. This can almost be thought of
7291 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7292 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7293 (otherwise the decrementing is conditional on the reference count being
7294 different from one or the reference being a readonly SV).
7301 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7305 if (SvWEAKREF(sv)) {
7313 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7315 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7316 sv_2mortal(rv); /* Schedule for freeing later */
7320 =for apidoc sv_unref
7322 Unsets the RV status of the SV, and decrements the reference count of
7323 whatever was being referenced by the RV. This can almost be thought of
7324 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7325 being zero. See C<SvROK_off>.
7331 Perl_sv_unref(pTHX_ SV *sv)
7333 sv_unref_flags(sv, 0);
7337 =for apidoc sv_taint
7339 Taint an SV. Use C<SvTAINTED_on> instead.
7344 Perl_sv_taint(pTHX_ SV *sv)
7346 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7350 =for apidoc sv_untaint
7352 Untaint an SV. Use C<SvTAINTED_off> instead.
7357 Perl_sv_untaint(pTHX_ SV *sv)
7359 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7360 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7367 =for apidoc sv_tainted
7369 Test an SV for taintedness. Use C<SvTAINTED> instead.
7374 Perl_sv_tainted(pTHX_ SV *sv)
7376 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7377 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7378 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7385 =for apidoc sv_setpviv
7387 Copies an integer into the given SV, also updating its string value.
7388 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7394 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7396 char buf[TYPE_CHARS(UV)];
7398 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7400 sv_setpvn(sv, ptr, ebuf - ptr);
7404 =for apidoc sv_setpviv_mg
7406 Like C<sv_setpviv>, but also handles 'set' magic.
7412 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7414 char buf[TYPE_CHARS(UV)];
7416 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7418 sv_setpvn(sv, ptr, ebuf - ptr);
7422 #if defined(PERL_IMPLICIT_CONTEXT)
7424 /* pTHX_ magic can't cope with varargs, so this is a no-context
7425 * version of the main function, (which may itself be aliased to us).
7426 * Don't access this version directly.
7430 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7434 va_start(args, pat);
7435 sv_vsetpvf(sv, pat, &args);
7439 /* pTHX_ magic can't cope with varargs, so this is a no-context
7440 * version of the main function, (which may itself be aliased to us).
7441 * Don't access this version directly.
7445 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7449 va_start(args, pat);
7450 sv_vsetpvf_mg(sv, pat, &args);
7456 =for apidoc sv_setpvf
7458 Processes its arguments like C<sprintf> and sets an SV to the formatted
7459 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7465 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7468 va_start(args, pat);
7469 sv_vsetpvf(sv, pat, &args);
7473 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7476 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7478 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7482 =for apidoc sv_setpvf_mg
7484 Like C<sv_setpvf>, but also handles 'set' magic.
7490 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7493 va_start(args, pat);
7494 sv_vsetpvf_mg(sv, pat, &args);
7498 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7501 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7503 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7507 #if defined(PERL_IMPLICIT_CONTEXT)
7509 /* pTHX_ magic can't cope with varargs, so this is a no-context
7510 * version of the main function, (which may itself be aliased to us).
7511 * Don't access this version directly.
7515 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7519 va_start(args, pat);
7520 sv_vcatpvf(sv, pat, &args);
7524 /* pTHX_ magic can't cope with varargs, so this is a no-context
7525 * version of the main function, (which may itself be aliased to us).
7526 * Don't access this version directly.
7530 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7534 va_start(args, pat);
7535 sv_vcatpvf_mg(sv, pat, &args);
7541 =for apidoc sv_catpvf
7543 Processes its arguments like C<sprintf> and appends the formatted
7544 output to an SV. If the appended data contains "wide" characters
7545 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7546 and characters >255 formatted with %c), the original SV might get
7547 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7548 C<SvSETMAGIC()> must typically be called after calling this function
7549 to handle 'set' magic.
7554 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7557 va_start(args, pat);
7558 sv_vcatpvf(sv, pat, &args);
7562 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7565 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7567 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7571 =for apidoc sv_catpvf_mg
7573 Like C<sv_catpvf>, but also handles 'set' magic.
7579 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7582 va_start(args, pat);
7583 sv_vcatpvf_mg(sv, pat, &args);
7587 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7590 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7592 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7597 =for apidoc sv_vsetpvfn
7599 Works like C<vcatpvfn> but copies the text into the SV instead of
7602 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7608 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7610 sv_setpvn(sv, "", 0);
7611 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7614 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7617 S_expect_number(pTHX_ char** pattern)
7620 switch (**pattern) {
7621 case '1': case '2': case '3':
7622 case '4': case '5': case '6':
7623 case '7': case '8': case '9':
7624 while (isDIGIT(**pattern))
7625 var = var * 10 + (*(*pattern)++ - '0');
7629 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7632 =for apidoc sv_vcatpvfn
7634 Processes its arguments like C<vsprintf> and appends the formatted output
7635 to an SV. Uses an array of SVs if the C style variable argument list is
7636 missing (NULL). When running with taint checks enabled, indicates via
7637 C<maybe_tainted> if results are untrustworthy (often due to the use of
7640 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7646 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7653 static char nullstr[] = "(null)";
7656 /* no matter what, this is a string now */
7657 (void)SvPV_force(sv, origlen);
7659 /* special-case "", "%s", and "%_" */
7662 if (patlen == 2 && pat[0] == '%') {
7666 char *s = va_arg(*args, char*);
7667 sv_catpv(sv, s ? s : nullstr);
7669 else if (svix < svmax) {
7670 sv_catsv(sv, *svargs);
7671 if (DO_UTF8(*svargs))
7677 argsv = va_arg(*args, SV*);
7678 sv_catsv(sv, argsv);
7683 /* See comment on '_' below */
7688 patend = (char*)pat + patlen;
7689 for (p = (char*)pat; p < patend; p = q) {
7692 bool vectorize = FALSE;
7693 bool vectorarg = FALSE;
7694 bool vec_utf = FALSE;
7700 bool has_precis = FALSE;
7702 bool is_utf = FALSE;
7705 U8 utf8buf[UTF8_MAXLEN+1];
7706 STRLEN esignlen = 0;
7708 char *eptr = Nullch;
7710 /* Times 4: a decimal digit takes more than 3 binary digits.
7711 * NV_DIG: mantissa takes than many decimal digits.
7712 * Plus 32: Playing safe. */
7713 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7714 /* large enough for "%#.#f" --chip */
7715 /* what about long double NVs? --jhi */
7718 U8 *vecstr = Null(U8*);
7730 STRLEN dotstrlen = 1;
7731 I32 efix = 0; /* explicit format parameter index */
7732 I32 ewix = 0; /* explicit width index */
7733 I32 epix = 0; /* explicit precision index */
7734 I32 evix = 0; /* explicit vector index */
7735 bool asterisk = FALSE;
7737 /* echo everything up to the next format specification */
7738 for (q = p; q < patend && *q != '%'; ++q) ;
7740 sv_catpvn(sv, p, q - p);
7747 We allow format specification elements in this order:
7748 \d+\$ explicit format parameter index
7750 \*?(\d+\$)?v vector with optional (optionally specified) arg
7751 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7752 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7754 [%bcdefginopsux_DFOUX] format (mandatory)
7756 if (EXPECT_NUMBER(q, width)) {
7797 if (EXPECT_NUMBER(q, ewix))
7806 if ((vectorarg = asterisk)) {
7816 EXPECT_NUMBER(q, width);
7821 vecsv = va_arg(*args, SV*);
7823 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7824 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7825 dotstr = SvPVx(vecsv, dotstrlen);
7830 vecsv = va_arg(*args, SV*);
7831 vecstr = (U8*)SvPVx(vecsv,veclen);
7832 vec_utf = DO_UTF8(vecsv);
7834 else if (efix ? efix <= svmax : svix < svmax) {
7835 vecsv = svargs[efix ? efix-1 : svix++];
7836 vecstr = (U8*)SvPVx(vecsv,veclen);
7837 vec_utf = DO_UTF8(vecsv);
7847 i = va_arg(*args, int);
7849 i = (ewix ? ewix <= svmax : svix < svmax) ?
7850 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7852 width = (i < 0) ? -i : i;
7862 if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
7865 i = va_arg(*args, int);
7867 i = (ewix ? ewix <= svmax : svix < svmax)
7868 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7869 precis = (i < 0) ? 0 : i;
7874 precis = precis * 10 + (*q++ - '0');
7882 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7893 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7894 if (*(q + 1) == 'l') { /* lld, llf */
7917 argsv = (efix ? efix <= svmax : svix < svmax) ?
7918 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7925 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7927 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7929 eptr = (char*)utf8buf;
7930 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7942 eptr = va_arg(*args, char*);
7944 #ifdef MACOS_TRADITIONAL
7945 /* On MacOS, %#s format is used for Pascal strings */
7950 elen = strlen(eptr);
7953 elen = sizeof nullstr - 1;
7957 eptr = SvPVx(argsv, elen);
7958 if (DO_UTF8(argsv)) {
7959 if (has_precis && precis < elen) {
7961 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7964 if (width) { /* fudge width (can't fudge elen) */
7965 width += elen - sv_len_utf8(argsv);
7974 * The "%_" hack might have to be changed someday,
7975 * if ISO or ANSI decide to use '_' for something.
7976 * So we keep it hidden from users' code.
7980 argsv = va_arg(*args, SV*);
7981 eptr = SvPVx(argsv, elen);
7987 if (has_precis && elen > precis)
7996 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8014 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8022 esignbuf[esignlen++] = plus;
8026 case 'h': iv = (short)va_arg(*args, int); break;
8027 default: iv = va_arg(*args, int); break;
8028 case 'l': iv = va_arg(*args, long); break;
8029 case 'V': iv = va_arg(*args, IV); break;
8031 case 'q': iv = va_arg(*args, Quad_t); break;
8038 case 'h': iv = (short)iv; break;
8040 case 'l': iv = (long)iv; break;
8043 case 'q': iv = (Quad_t)iv; break;
8047 if ( !vectorize ) /* we already set uv above */
8052 esignbuf[esignlen++] = plus;
8056 esignbuf[esignlen++] = '-';
8099 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
8109 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8110 default: uv = va_arg(*args, unsigned); break;
8111 case 'l': uv = va_arg(*args, unsigned long); break;
8112 case 'V': uv = va_arg(*args, UV); break;
8114 case 'q': uv = va_arg(*args, Quad_t); break;
8121 case 'h': uv = (unsigned short)uv; break;
8123 case 'l': uv = (unsigned long)uv; break;
8126 case 'q': uv = (Quad_t)uv; break;
8132 eptr = ebuf + sizeof ebuf;
8138 p = (char*)((c == 'X')
8139 ? "0123456789ABCDEF" : "0123456789abcdef");
8145 esignbuf[esignlen++] = '0';
8146 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8152 *--eptr = '0' + dig;
8154 if (alt && *eptr != '0')
8160 *--eptr = '0' + dig;
8163 esignbuf[esignlen++] = '0';
8164 esignbuf[esignlen++] = 'b';
8167 default: /* it had better be ten or less */
8168 #if defined(PERL_Y2KWARN)
8169 if (ckWARN(WARN_Y2K)) {
8171 char *s = SvPV(sv,n);
8172 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8173 && (n == 2 || !isDIGIT(s[n-3])))
8175 Perl_warner(aTHX_ WARN_Y2K,
8176 "Possible Y2K bug: %%%c %s",
8177 c, "format string following '19'");
8183 *--eptr = '0' + dig;
8184 } while (uv /= base);
8187 elen = (ebuf + sizeof ebuf) - eptr;
8190 zeros = precis - elen;
8191 else if (precis == 0 && elen == 1 && *eptr == '0')
8196 /* FLOATING POINT */
8199 c = 'f'; /* maybe %F isn't supported here */
8205 /* This is evil, but floating point is even more evil */
8208 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8211 if (c != 'e' && c != 'E') {
8213 (void)Perl_frexp(nv, &i);
8214 if (i == PERL_INT_MIN)
8215 Perl_die(aTHX_ "panic: frexp");
8217 need = BIT_DIGITS(i);
8219 need += has_precis ? precis : 6; /* known default */
8223 need += 20; /* fudge factor */
8224 if (PL_efloatsize < need) {
8225 Safefree(PL_efloatbuf);
8226 PL_efloatsize = need + 20; /* more fudge */
8227 New(906, PL_efloatbuf, PL_efloatsize, char);
8228 PL_efloatbuf[0] = '\0';
8231 eptr = ebuf + sizeof ebuf;
8234 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8236 /* Copy the one or more characters in a long double
8237 * format before the 'base' ([efgEFG]) character to
8238 * the format string. */
8239 static char const prifldbl[] = PERL_PRIfldbl;
8240 char const *p = prifldbl + sizeof(prifldbl) - 3;
8241 while (p >= prifldbl) { *--eptr = *p--; }
8246 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8251 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8263 /* No taint. Otherwise we are in the strange situation
8264 * where printf() taints but print($float) doesn't.
8266 (void)sprintf(PL_efloatbuf, eptr, nv);
8268 eptr = PL_efloatbuf;
8269 elen = strlen(PL_efloatbuf);
8276 i = SvCUR(sv) - origlen;
8279 case 'h': *(va_arg(*args, short*)) = i; break;
8280 default: *(va_arg(*args, int*)) = i; break;
8281 case 'l': *(va_arg(*args, long*)) = i; break;
8282 case 'V': *(va_arg(*args, IV*)) = i; break;
8284 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8289 sv_setuv_mg(argsv, (UV)i);
8290 continue; /* not "break" */
8297 if (!args && ckWARN(WARN_PRINTF) &&
8298 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8299 SV *msg = sv_newmortal();
8300 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8301 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8304 Perl_sv_catpvf(aTHX_ msg,
8305 "\"%%%c\"", c & 0xFF);
8307 Perl_sv_catpvf(aTHX_ msg,
8308 "\"%%\\%03"UVof"\"",
8311 sv_catpv(msg, "end of string");
8312 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8315 /* output mangled stuff ... */
8321 /* ... right here, because formatting flags should not apply */
8322 SvGROW(sv, SvCUR(sv) + elen + 1);
8324 Copy(eptr, p, elen, char);
8327 SvCUR(sv) = p - SvPVX(sv);
8328 continue; /* not "break" */
8331 have = esignlen + zeros + elen;
8332 need = (have > width ? have : width);
8335 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8337 if (esignlen && fill == '0') {
8338 for (i = 0; i < esignlen; i++)
8342 memset(p, fill, gap);
8345 if (esignlen && fill != '0') {
8346 for (i = 0; i < esignlen; i++)
8350 for (i = zeros; i; i--)
8354 Copy(eptr, p, elen, char);
8358 memset(p, ' ', gap);
8363 Copy(dotstr, p, dotstrlen, char);
8367 vectorize = FALSE; /* done iterating over vecstr */
8372 SvCUR(sv) = p - SvPVX(sv);
8380 /* =========================================================================
8382 =head1 Cloning an interpreter
8384 All the macros and functions in this section are for the private use of
8385 the main function, perl_clone().
8387 The foo_dup() functions make an exact copy of an existing foo thinngy.
8388 During the course of a cloning, a hash table is used to map old addresses
8389 to new addresses. The table is created and manipulated with the
8390 ptr_table_* functions.
8394 ============================================================================*/
8397 #if defined(USE_ITHREADS)
8399 #if defined(USE_5005THREADS)
8400 # include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
8403 #ifndef GpREFCNT_inc
8404 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8408 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8409 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8410 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8411 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8412 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8413 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8414 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8415 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8416 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8417 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8418 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8419 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8420 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8423 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
8424 regcomp.c. AMS 20010712 */
8427 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
8431 struct reg_substr_datum *s;
8434 return (REGEXP *)NULL;
8436 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8439 len = r->offsets[0];
8440 npar = r->nparens+1;
8442 Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8443 Copy(r->program, ret->program, len+1, regnode);
8445 New(0, ret->startp, npar, I32);
8446 Copy(r->startp, ret->startp, npar, I32);
8447 New(0, ret->endp, npar, I32);
8448 Copy(r->startp, ret->startp, npar, I32);
8450 New(0, ret->substrs, 1, struct reg_substr_data);
8451 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8452 s->min_offset = r->substrs->data[i].min_offset;
8453 s->max_offset = r->substrs->data[i].max_offset;
8454 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8457 ret->regstclass = NULL;
8460 int count = r->data->count;
8462 Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
8463 char, struct reg_data);
8464 New(0, d->what, count, U8);
8467 for (i = 0; i < count; i++) {
8468 d->what[i] = r->data->what[i];
8469 switch (d->what[i]) {
8471 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8474 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8477 /* This is cheating. */
8478 New(0, d->data[i], 1, struct regnode_charclass_class);
8479 StructCopy(r->data->data[i], d->data[i],
8480 struct regnode_charclass_class);
8481 ret->regstclass = (regnode*)d->data[i];
8484 /* Compiled op trees are readonly, and can thus be
8485 shared without duplication. */
8486 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8489 d->data[i] = r->data->data[i];
8499 New(0, ret->offsets, 2*len+1, U32);
8500 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8502 ret->precomp = SAVEPV(r->precomp);
8503 ret->refcnt = r->refcnt;
8504 ret->minlen = r->minlen;
8505 ret->prelen = r->prelen;
8506 ret->nparens = r->nparens;
8507 ret->lastparen = r->lastparen;
8508 ret->lastcloseparen = r->lastcloseparen;
8509 ret->reganch = r->reganch;
8511 ret->sublen = r->sublen;
8513 if (RX_MATCH_COPIED(ret))
8514 ret->subbeg = SAVEPV(r->subbeg);
8516 ret->subbeg = Nullch;
8518 ptr_table_store(PL_ptr_table, r, ret);
8522 /* duplicate a file handle */
8525 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
8529 return (PerlIO*)NULL;
8531 /* look for it in the table first */
8532 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8536 /* create anew and remember what it is */
8537 ret = PerlIO_fdupopen(aTHX_ fp, param);
8538 ptr_table_store(PL_ptr_table, fp, ret);
8542 /* duplicate a directory handle */
8545 Perl_dirp_dup(pTHX_ DIR *dp)
8553 /* duplicate a typeglob */
8556 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
8561 /* look for it in the table first */
8562 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8566 /* create anew and remember what it is */
8567 Newz(0, ret, 1, GP);
8568 ptr_table_store(PL_ptr_table, gp, ret);
8571 ret->gp_refcnt = 0; /* must be before any other dups! */
8572 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8573 ret->gp_io = io_dup_inc(gp->gp_io, param);
8574 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8575 ret->gp_av = av_dup_inc(gp->gp_av, param);
8576 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8577 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8578 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8579 ret->gp_cvgen = gp->gp_cvgen;
8580 ret->gp_flags = gp->gp_flags;
8581 ret->gp_line = gp->gp_line;
8582 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8586 /* duplicate a chain of magic */
8589 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
8591 MAGIC *mgprev = (MAGIC*)NULL;
8594 return (MAGIC*)NULL;
8595 /* look for it in the table first */
8596 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8600 for (; mg; mg = mg->mg_moremagic) {
8602 Newz(0, nmg, 1, MAGIC);
8604 mgprev->mg_moremagic = nmg;
8607 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8608 nmg->mg_private = mg->mg_private;
8609 nmg->mg_type = mg->mg_type;
8610 nmg->mg_flags = mg->mg_flags;
8611 if (mg->mg_type == PERL_MAGIC_qr) {
8612 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
8614 else if(mg->mg_type == PERL_MAGIC_backref) {
8615 AV *av = (AV*) mg->mg_obj;
8618 nmg->mg_obj = (SV*)newAV();
8622 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
8627 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8628 ? sv_dup_inc(mg->mg_obj, param)
8629 : sv_dup(mg->mg_obj, param);
8631 nmg->mg_len = mg->mg_len;
8632 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8633 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8634 if (mg->mg_len >= 0) {
8635 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8636 if (mg->mg_type == PERL_MAGIC_overload_table &&
8637 AMT_AMAGIC((AMT*)mg->mg_ptr))
8639 AMT *amtp = (AMT*)mg->mg_ptr;
8640 AMT *namtp = (AMT*)nmg->mg_ptr;
8642 for (i = 1; i < NofAMmeth; i++) {
8643 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8647 else if (mg->mg_len == HEf_SVKEY)
8648 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8655 /* create a new pointer-mapping table */
8658 Perl_ptr_table_new(pTHX)
8661 Newz(0, tbl, 1, PTR_TBL_t);
8664 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8668 /* map an existing pointer using a table */
8671 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8673 PTR_TBL_ENT_t *tblent;
8674 UV hash = PTR2UV(sv);
8676 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8677 for (; tblent; tblent = tblent->next) {
8678 if (tblent->oldval == sv)
8679 return tblent->newval;
8684 /* add a new entry to a pointer-mapping table */
8687 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8689 PTR_TBL_ENT_t *tblent, **otblent;
8690 /* XXX this may be pessimal on platforms where pointers aren't good
8691 * hash values e.g. if they grow faster in the most significant
8693 UV hash = PTR2UV(oldv);
8697 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8698 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8699 if (tblent->oldval == oldv) {
8700 tblent->newval = newv;
8705 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8706 tblent->oldval = oldv;
8707 tblent->newval = newv;
8708 tblent->next = *otblent;
8711 if (i && tbl->tbl_items > tbl->tbl_max)
8712 ptr_table_split(tbl);
8715 /* double the hash bucket size of an existing ptr table */
8718 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8720 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8721 UV oldsize = tbl->tbl_max + 1;
8722 UV newsize = oldsize * 2;
8725 Renew(ary, newsize, PTR_TBL_ENT_t*);
8726 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8727 tbl->tbl_max = --newsize;
8729 for (i=0; i < oldsize; i++, ary++) {
8730 PTR_TBL_ENT_t **curentp, **entp, *ent;
8733 curentp = ary + oldsize;
8734 for (entp = ary, ent = *ary; ent; ent = *entp) {
8735 if ((newsize & PTR2UV(ent->oldval)) != i) {
8737 ent->next = *curentp;
8747 /* remove all the entries from a ptr table */
8750 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8752 register PTR_TBL_ENT_t **array;
8753 register PTR_TBL_ENT_t *entry;
8754 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8758 if (!tbl || !tbl->tbl_items) {
8762 array = tbl->tbl_ary;
8769 entry = entry->next;
8773 if (++riter > max) {
8776 entry = array[riter];
8783 /* clear and free a ptr table */
8786 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8791 ptr_table_clear(tbl);
8792 Safefree(tbl->tbl_ary);
8800 /* attempt to make everything in the typeglob readonly */
8803 S_gv_share(pTHX_ SV *sstr)
8806 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8808 if (GvIO(gv) || GvFORM(gv)) {
8809 GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8811 else if (!GvCV(gv)) {
8815 /* CvPADLISTs cannot be shared */
8816 if (!CvXSUB(GvCV(gv))) {
8821 if (!GvUNIQUE(gv)) {
8823 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8824 HvNAME(GvSTASH(gv)), GvNAME(gv));
8830 * write attempts will die with
8831 * "Modification of a read-only value attempted"
8837 SvREADONLY_on(GvSV(gv));
8844 SvREADONLY_on(GvAV(gv));
8851 SvREADONLY_on(GvAV(gv));
8854 return sstr; /* he_dup() will SvREFCNT_inc() */
8857 /* duplicate an SV of any type (including AV, HV etc) */
8860 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
8864 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8866 /* look for it in the table first */
8867 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8871 /* create anew and remember what it is */
8873 ptr_table_store(PL_ptr_table, sstr, dstr);
8876 SvFLAGS(dstr) = SvFLAGS(sstr);
8877 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8878 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8881 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8882 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8883 PL_watch_pvx, SvPVX(sstr));
8886 switch (SvTYPE(sstr)) {
8891 SvANY(dstr) = new_XIV();
8892 SvIVX(dstr) = SvIVX(sstr);
8895 SvANY(dstr) = new_XNV();
8896 SvNVX(dstr) = SvNVX(sstr);
8899 SvANY(dstr) = new_XRV();
8900 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
8901 ? sv_dup(SvRV(sstr), param)
8902 : sv_dup_inc(SvRV(sstr), param);
8905 SvANY(dstr) = new_XPV();
8906 SvCUR(dstr) = SvCUR(sstr);
8907 SvLEN(dstr) = SvLEN(sstr);
8909 SvRV(dstr) = SvWEAKREF(sstr)
8910 ? sv_dup(SvRV(sstr), param)
8911 : sv_dup_inc(SvRV(sstr), param);
8912 else if (SvPVX(sstr) && SvLEN(sstr))
8913 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8915 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8918 SvANY(dstr) = new_XPVIV();
8919 SvCUR(dstr) = SvCUR(sstr);
8920 SvLEN(dstr) = SvLEN(sstr);
8921 SvIVX(dstr) = SvIVX(sstr);
8923 SvRV(dstr) = SvWEAKREF(sstr)
8924 ? sv_dup(SvRV(sstr), param)
8925 : sv_dup_inc(SvRV(sstr), param);
8926 else if (SvPVX(sstr) && SvLEN(sstr))
8927 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8929 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8932 SvANY(dstr) = new_XPVNV();
8933 SvCUR(dstr) = SvCUR(sstr);
8934 SvLEN(dstr) = SvLEN(sstr);
8935 SvIVX(dstr) = SvIVX(sstr);
8936 SvNVX(dstr) = SvNVX(sstr);
8938 SvRV(dstr) = SvWEAKREF(sstr)
8939 ? sv_dup(SvRV(sstr), param)
8940 : sv_dup_inc(SvRV(sstr), param);
8941 else if (SvPVX(sstr) && SvLEN(sstr))
8942 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8944 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8947 SvANY(dstr) = new_XPVMG();
8948 SvCUR(dstr) = SvCUR(sstr);
8949 SvLEN(dstr) = SvLEN(sstr);
8950 SvIVX(dstr) = SvIVX(sstr);
8951 SvNVX(dstr) = SvNVX(sstr);
8952 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8953 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8955 SvRV(dstr) = SvWEAKREF(sstr)
8956 ? sv_dup(SvRV(sstr), param)
8957 : sv_dup_inc(SvRV(sstr), param);
8958 else if (SvPVX(sstr) && SvLEN(sstr))
8959 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8961 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8964 SvANY(dstr) = new_XPVBM();
8965 SvCUR(dstr) = SvCUR(sstr);
8966 SvLEN(dstr) = SvLEN(sstr);
8967 SvIVX(dstr) = SvIVX(sstr);
8968 SvNVX(dstr) = SvNVX(sstr);
8969 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8970 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8972 SvRV(dstr) = SvWEAKREF(sstr)
8973 ? sv_dup(SvRV(sstr), param)
8974 : sv_dup_inc(SvRV(sstr), param);
8975 else if (SvPVX(sstr) && SvLEN(sstr))
8976 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8978 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8979 BmRARE(dstr) = BmRARE(sstr);
8980 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8981 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8984 SvANY(dstr) = new_XPVLV();
8985 SvCUR(dstr) = SvCUR(sstr);
8986 SvLEN(dstr) = SvLEN(sstr);
8987 SvIVX(dstr) = SvIVX(sstr);
8988 SvNVX(dstr) = SvNVX(sstr);
8989 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8990 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8992 SvRV(dstr) = SvWEAKREF(sstr)
8993 ? sv_dup(SvRV(sstr), param)
8994 : sv_dup_inc(SvRV(sstr), param);
8995 else if (SvPVX(sstr) && SvLEN(sstr))
8996 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8998 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8999 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
9000 LvTARGLEN(dstr) = LvTARGLEN(sstr);
9001 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
9002 LvTYPE(dstr) = LvTYPE(sstr);
9005 if (GvUNIQUE((GV*)sstr)) {
9007 if ((share = gv_share(sstr))) {
9011 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9012 HvNAME(GvSTASH(share)), GvNAME(share));
9017 SvANY(dstr) = new_XPVGV();
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 GvNAMELEN(dstr) = GvNAMELEN(sstr);
9033 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9034 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
9035 GvFLAGS(dstr) = GvFLAGS(sstr);
9036 GvGP(dstr) = gp_dup(GvGP(sstr), param);
9037 (void)GpREFCNT_inc(GvGP(dstr));
9040 SvANY(dstr) = new_XPVIO();
9041 SvCUR(dstr) = SvCUR(sstr);
9042 SvLEN(dstr) = SvLEN(sstr);
9043 SvIVX(dstr) = SvIVX(sstr);
9044 SvNVX(dstr) = SvNVX(sstr);
9045 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9046 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9048 SvRV(dstr) = SvWEAKREF(sstr)
9049 ? sv_dup(SvRV(sstr), param)
9050 : sv_dup_inc(SvRV(sstr), param);
9051 else if (SvPVX(sstr) && SvLEN(sstr))
9052 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9054 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9055 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
9056 if (IoOFP(sstr) == IoIFP(sstr))
9057 IoOFP(dstr) = IoIFP(dstr);
9059 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
9060 /* PL_rsfp_filters entries have fake IoDIRP() */
9061 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
9062 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
9064 IoDIRP(dstr) = IoDIRP(sstr);
9065 IoLINES(dstr) = IoLINES(sstr);
9066 IoPAGE(dstr) = IoPAGE(sstr);
9067 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
9068 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
9069 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
9070 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
9071 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
9072 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
9073 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
9074 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
9075 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
9076 IoTYPE(dstr) = IoTYPE(sstr);
9077 IoFLAGS(dstr) = IoFLAGS(sstr);
9080 SvANY(dstr) = new_XPVAV();
9081 SvCUR(dstr) = SvCUR(sstr);
9082 SvLEN(dstr) = SvLEN(sstr);
9083 SvIVX(dstr) = SvIVX(sstr);
9084 SvNVX(dstr) = SvNVX(sstr);
9085 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9086 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9087 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
9088 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
9089 if (AvARRAY((AV*)sstr)) {
9090 SV **dst_ary, **src_ary;
9091 SSize_t items = AvFILLp((AV*)sstr) + 1;
9093 src_ary = AvARRAY((AV*)sstr);
9094 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
9095 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
9096 SvPVX(dstr) = (char*)dst_ary;
9097 AvALLOC((AV*)dstr) = dst_ary;
9098 if (AvREAL((AV*)sstr)) {
9100 *dst_ary++ = sv_dup_inc(*src_ary++, param);
9104 *dst_ary++ = sv_dup(*src_ary++, param);
9106 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
9107 while (items-- > 0) {
9108 *dst_ary++ = &PL_sv_undef;
9112 SvPVX(dstr) = Nullch;
9113 AvALLOC((AV*)dstr) = (SV**)NULL;
9117 SvANY(dstr) = new_XPVHV();
9118 SvCUR(dstr) = SvCUR(sstr);
9119 SvLEN(dstr) = SvLEN(sstr);
9120 SvIVX(dstr) = SvIVX(sstr);
9121 SvNVX(dstr) = SvNVX(sstr);
9122 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9123 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9124 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
9125 if (HvARRAY((HV*)sstr)) {
9127 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
9128 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
9129 Newz(0, dxhv->xhv_array,
9130 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
9131 while (i <= sxhv->xhv_max) {
9132 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
9133 !!HvSHAREKEYS(sstr), param);
9136 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
9139 SvPVX(dstr) = Nullch;
9140 HvEITER((HV*)dstr) = (HE*)NULL;
9142 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
9143 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
9144 /* Record stashes for possible cloning in Perl_clone(). */
9145 if(HvNAME((HV*)dstr))
9146 av_push(param->stashes, dstr);
9149 SvANY(dstr) = new_XPVFM();
9150 FmLINES(dstr) = FmLINES(sstr);
9154 SvANY(dstr) = new_XPVCV();
9156 SvCUR(dstr) = SvCUR(sstr);
9157 SvLEN(dstr) = SvLEN(sstr);
9158 SvIVX(dstr) = SvIVX(sstr);
9159 SvNVX(dstr) = SvNVX(sstr);
9160 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
9161 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
9162 if (SvPVX(sstr) && SvLEN(sstr))
9163 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9165 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
9166 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
9167 CvSTART(dstr) = CvSTART(sstr);
9168 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
9169 CvXSUB(dstr) = CvXSUB(sstr);
9170 CvXSUBANY(dstr) = CvXSUBANY(sstr);
9171 if (CvCONST(sstr)) {
9172 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
9173 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
9174 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
9176 CvGV(dstr) = gv_dup(CvGV(sstr), param);
9177 if (param->flags & CLONEf_COPY_STACKS) {
9178 CvDEPTH(dstr) = CvDEPTH(sstr);
9182 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
9183 /* XXX padlists are real, but pretend to be not */
9184 AvREAL_on(CvPADLIST(sstr));
9185 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9186 AvREAL_off(CvPADLIST(sstr));
9187 AvREAL_off(CvPADLIST(dstr));
9190 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9191 if (!CvANON(sstr) || CvCLONED(sstr))
9192 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9194 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9195 CvFLAGS(dstr) = CvFLAGS(sstr);
9196 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9199 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9203 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9209 /* duplicate a context */
9212 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
9217 return (PERL_CONTEXT*)NULL;
9219 /* look for it in the table first */
9220 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9224 /* create anew and remember what it is */
9225 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9226 ptr_table_store(PL_ptr_table, cxs, ncxs);
9229 PERL_CONTEXT *cx = &cxs[ix];
9230 PERL_CONTEXT *ncx = &ncxs[ix];
9231 ncx->cx_type = cx->cx_type;
9232 if (CxTYPE(cx) == CXt_SUBST) {
9233 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9236 ncx->blk_oldsp = cx->blk_oldsp;
9237 ncx->blk_oldcop = cx->blk_oldcop;
9238 ncx->blk_oldretsp = cx->blk_oldretsp;
9239 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9240 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9241 ncx->blk_oldpm = cx->blk_oldpm;
9242 ncx->blk_gimme = cx->blk_gimme;
9243 switch (CxTYPE(cx)) {
9245 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9246 ? cv_dup_inc(cx->blk_sub.cv, param)
9247 : cv_dup(cx->blk_sub.cv,param));
9248 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9249 ? av_dup_inc(cx->blk_sub.argarray, param)
9251 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9252 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9253 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9254 ncx->blk_sub.lval = cx->blk_sub.lval;
9257 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9258 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9259 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9260 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9261 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9264 ncx->blk_loop.label = cx->blk_loop.label;
9265 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9266 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9267 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9268 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9269 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9270 ? cx->blk_loop.iterdata
9271 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9272 ncx->blk_loop.oldcurpad
9273 = (SV**)ptr_table_fetch(PL_ptr_table,
9274 cx->blk_loop.oldcurpad);
9275 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9276 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9277 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9278 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9279 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9282 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9283 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9284 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9285 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9297 /* duplicate a stack info structure */
9300 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
9305 return (PERL_SI*)NULL;
9307 /* look for it in the table first */
9308 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9312 /* create anew and remember what it is */
9313 Newz(56, nsi, 1, PERL_SI);
9314 ptr_table_store(PL_ptr_table, si, nsi);
9316 nsi->si_stack = av_dup_inc(si->si_stack, param);
9317 nsi->si_cxix = si->si_cxix;
9318 nsi->si_cxmax = si->si_cxmax;
9319 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9320 nsi->si_type = si->si_type;
9321 nsi->si_prev = si_dup(si->si_prev, param);
9322 nsi->si_next = si_dup(si->si_next, param);
9323 nsi->si_markoff = si->si_markoff;
9328 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9329 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9330 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9331 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9332 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9333 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9334 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9335 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9336 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9337 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9338 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9339 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9342 #define pv_dup_inc(p) SAVEPV(p)
9343 #define pv_dup(p) SAVEPV(p)
9344 #define svp_dup_inc(p,pp) any_dup(p,pp)
9346 /* map any object to the new equivent - either something in the
9347 * ptr table, or something in the interpreter structure
9351 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9358 /* look for it in the table first */
9359 ret = ptr_table_fetch(PL_ptr_table, v);
9363 /* see if it is part of the interpreter structure */
9364 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9365 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
9372 /* duplicate the save stack */
9375 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
9377 ANY *ss = proto_perl->Tsavestack;
9378 I32 ix = proto_perl->Tsavestack_ix;
9379 I32 max = proto_perl->Tsavestack_max;
9392 void (*dptr) (void*);
9393 void (*dxptr) (pTHX_ void*);
9396 Newz(54, nss, max, ANY);
9402 case SAVEt_ITEM: /* normal string */
9403 sv = (SV*)POPPTR(ss,ix);
9404 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9405 sv = (SV*)POPPTR(ss,ix);
9406 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9408 case SAVEt_SV: /* scalar reference */
9409 sv = (SV*)POPPTR(ss,ix);
9410 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9411 gv = (GV*)POPPTR(ss,ix);
9412 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9414 case SAVEt_GENERIC_PVREF: /* generic char* */
9415 c = (char*)POPPTR(ss,ix);
9416 TOPPTR(nss,ix) = pv_dup(c);
9417 ptr = POPPTR(ss,ix);
9418 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9420 case SAVEt_GENERIC_SVREF: /* generic sv */
9421 case SAVEt_SVREF: /* scalar reference */
9422 sv = (SV*)POPPTR(ss,ix);
9423 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9424 ptr = POPPTR(ss,ix);
9425 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9427 case SAVEt_AV: /* array reference */
9428 av = (AV*)POPPTR(ss,ix);
9429 TOPPTR(nss,ix) = av_dup_inc(av, param);
9430 gv = (GV*)POPPTR(ss,ix);
9431 TOPPTR(nss,ix) = gv_dup(gv, param);
9433 case SAVEt_HV: /* hash reference */
9434 hv = (HV*)POPPTR(ss,ix);
9435 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9436 gv = (GV*)POPPTR(ss,ix);
9437 TOPPTR(nss,ix) = gv_dup(gv, param);
9439 case SAVEt_INT: /* int reference */
9440 ptr = POPPTR(ss,ix);
9441 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9442 intval = (int)POPINT(ss,ix);
9443 TOPINT(nss,ix) = intval;
9445 case SAVEt_LONG: /* long reference */
9446 ptr = POPPTR(ss,ix);
9447 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9448 longval = (long)POPLONG(ss,ix);
9449 TOPLONG(nss,ix) = longval;
9451 case SAVEt_I32: /* I32 reference */
9452 case SAVEt_I16: /* I16 reference */
9453 case SAVEt_I8: /* I8 reference */
9454 ptr = POPPTR(ss,ix);
9455 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9459 case SAVEt_IV: /* IV reference */
9460 ptr = POPPTR(ss,ix);
9461 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9465 case SAVEt_SPTR: /* SV* reference */
9466 ptr = POPPTR(ss,ix);
9467 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9468 sv = (SV*)POPPTR(ss,ix);
9469 TOPPTR(nss,ix) = sv_dup(sv, param);
9471 case SAVEt_VPTR: /* random* reference */
9472 ptr = POPPTR(ss,ix);
9473 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9474 ptr = POPPTR(ss,ix);
9475 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9477 case SAVEt_PPTR: /* char* reference */
9478 ptr = POPPTR(ss,ix);
9479 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9480 c = (char*)POPPTR(ss,ix);
9481 TOPPTR(nss,ix) = pv_dup(c);
9483 case SAVEt_HPTR: /* HV* reference */
9484 ptr = POPPTR(ss,ix);
9485 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9486 hv = (HV*)POPPTR(ss,ix);
9487 TOPPTR(nss,ix) = hv_dup(hv, param);
9489 case SAVEt_APTR: /* AV* reference */
9490 ptr = POPPTR(ss,ix);
9491 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9492 av = (AV*)POPPTR(ss,ix);
9493 TOPPTR(nss,ix) = av_dup(av, param);
9496 gv = (GV*)POPPTR(ss,ix);
9497 TOPPTR(nss,ix) = gv_dup(gv, param);
9499 case SAVEt_GP: /* scalar reference */
9500 gp = (GP*)POPPTR(ss,ix);
9501 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9502 (void)GpREFCNT_inc(gp);
9503 gv = (GV*)POPPTR(ss,ix);
9504 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9505 c = (char*)POPPTR(ss,ix);
9506 TOPPTR(nss,ix) = pv_dup(c);
9513 case SAVEt_MORTALIZESV:
9514 sv = (SV*)POPPTR(ss,ix);
9515 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9518 ptr = POPPTR(ss,ix);
9519 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9520 /* these are assumed to be refcounted properly */
9521 switch (((OP*)ptr)->op_type) {
9528 TOPPTR(nss,ix) = ptr;
9533 TOPPTR(nss,ix) = Nullop;
9538 TOPPTR(nss,ix) = Nullop;
9541 c = (char*)POPPTR(ss,ix);
9542 TOPPTR(nss,ix) = pv_dup_inc(c);
9545 longval = POPLONG(ss,ix);
9546 TOPLONG(nss,ix) = longval;
9549 hv = (HV*)POPPTR(ss,ix);
9550 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9551 c = (char*)POPPTR(ss,ix);
9552 TOPPTR(nss,ix) = pv_dup_inc(c);
9556 case SAVEt_DESTRUCTOR:
9557 ptr = POPPTR(ss,ix);
9558 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9559 dptr = POPDPTR(ss,ix);
9560 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9562 case SAVEt_DESTRUCTOR_X:
9563 ptr = POPPTR(ss,ix);
9564 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9565 dxptr = POPDXPTR(ss,ix);
9566 TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
9568 case SAVEt_REGCONTEXT:
9574 case SAVEt_STACK_POS: /* Position on Perl stack */
9578 case SAVEt_AELEM: /* array element */
9579 sv = (SV*)POPPTR(ss,ix);
9580 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9583 av = (AV*)POPPTR(ss,ix);
9584 TOPPTR(nss,ix) = av_dup_inc(av, param);
9586 case SAVEt_HELEM: /* hash element */
9587 sv = (SV*)POPPTR(ss,ix);
9588 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9589 sv = (SV*)POPPTR(ss,ix);
9590 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9591 hv = (HV*)POPPTR(ss,ix);
9592 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9595 ptr = POPPTR(ss,ix);
9596 TOPPTR(nss,ix) = ptr;
9603 av = (AV*)POPPTR(ss,ix);
9604 TOPPTR(nss,ix) = av_dup(av, param);
9607 longval = (long)POPLONG(ss,ix);
9608 TOPLONG(nss,ix) = longval;
9609 ptr = POPPTR(ss,ix);
9610 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9611 sv = (SV*)POPPTR(ss,ix);
9612 TOPPTR(nss,ix) = sv_dup(sv, param);
9615 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9623 =for apidoc perl_clone
9625 Create and return a new interpreter by cloning the current one.
9630 /* XXX the above needs expanding by someone who actually understands it ! */
9631 EXTERN_C PerlInterpreter *
9632 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
9635 perl_clone(PerlInterpreter *proto_perl, UV flags)
9637 #ifdef PERL_IMPLICIT_SYS
9639 /* perlhost.h so we need to call into it
9640 to clone the host, CPerlHost should have a c interface, sky */
9642 if (flags & CLONEf_CLONE_HOST) {
9643 return perl_clone_host(proto_perl,flags);
9645 return perl_clone_using(proto_perl, flags,
9647 proto_perl->IMemShared,
9648 proto_perl->IMemParse,
9658 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9659 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9660 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9661 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9662 struct IPerlDir* ipD, struct IPerlSock* ipS,
9663 struct IPerlProc* ipP)
9665 /* XXX many of the string copies here can be optimized if they're
9666 * constants; they need to be allocated as common memory and just
9667 * their pointers copied. */
9670 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9672 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9673 PERL_SET_THX(my_perl);
9676 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9682 # else /* !DEBUGGING */
9683 Zero(my_perl, 1, PerlInterpreter);
9684 # endif /* DEBUGGING */
9688 PL_MemShared = ipMS;
9696 #else /* !PERL_IMPLICIT_SYS */
9698 CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
9699 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9700 PERL_SET_THX(my_perl);
9705 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9711 # else /* !DEBUGGING */
9712 Zero(my_perl, 1, PerlInterpreter);
9713 # endif /* DEBUGGING */
9714 #endif /* PERL_IMPLICIT_SYS */
9715 param->flags = flags;
9718 PL_xiv_arenaroot = NULL;
9720 PL_xnv_arenaroot = NULL;
9722 PL_xrv_arenaroot = NULL;
9724 PL_xpv_arenaroot = NULL;
9726 PL_xpviv_arenaroot = NULL;
9727 PL_xpviv_root = NULL;
9728 PL_xpvnv_arenaroot = NULL;
9729 PL_xpvnv_root = NULL;
9730 PL_xpvcv_arenaroot = NULL;
9731 PL_xpvcv_root = NULL;
9732 PL_xpvav_arenaroot = NULL;
9733 PL_xpvav_root = NULL;
9734 PL_xpvhv_arenaroot = NULL;
9735 PL_xpvhv_root = NULL;
9736 PL_xpvmg_arenaroot = NULL;
9737 PL_xpvmg_root = NULL;
9738 PL_xpvlv_arenaroot = NULL;
9739 PL_xpvlv_root = NULL;
9740 PL_xpvbm_arenaroot = NULL;
9741 PL_xpvbm_root = NULL;
9742 PL_he_arenaroot = NULL;
9744 PL_nice_chunk = NULL;
9745 PL_nice_chunk_size = 0;
9748 PL_sv_root = Nullsv;
9749 PL_sv_arenaroot = Nullsv;
9751 PL_debug = proto_perl->Idebug;
9753 #ifdef USE_REENTRANT_API
9754 New(31337, PL_reentrant_buffer,1, REBUF);
9755 New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
9758 /* create SV map for pointer relocation */
9759 PL_ptr_table = ptr_table_new();
9761 /* initialize these special pointers as early as possible */
9762 SvANY(&PL_sv_undef) = NULL;
9763 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9764 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9765 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9767 SvANY(&PL_sv_no) = new_XPVNV();
9768 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9769 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9770 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9771 SvCUR(&PL_sv_no) = 0;
9772 SvLEN(&PL_sv_no) = 1;
9773 SvNVX(&PL_sv_no) = 0;
9774 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9776 SvANY(&PL_sv_yes) = new_XPVNV();
9777 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9778 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9779 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9780 SvCUR(&PL_sv_yes) = 1;
9781 SvLEN(&PL_sv_yes) = 2;
9782 SvNVX(&PL_sv_yes) = 1;
9783 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9785 /* create shared string table */
9786 PL_strtab = newHV();
9787 HvSHAREKEYS_off(PL_strtab);
9788 hv_ksplit(PL_strtab, 512);
9789 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9791 PL_compiling = proto_perl->Icompiling;
9792 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9793 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9794 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9795 if (!specialWARN(PL_compiling.cop_warnings))
9796 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9797 if (!specialCopIO(PL_compiling.cop_io))
9798 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9799 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9801 /* pseudo environmental stuff */
9802 PL_origargc = proto_perl->Iorigargc;
9804 New(0, PL_origargv, i+1, char*);
9805 PL_origargv[i] = '\0';
9807 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9810 param->stashes = newAV(); /* Setup array of objects to call clone on */
9812 #ifdef PERLIO_LAYERS
9813 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
9814 PerlIO_clone(aTHX_ proto_perl, param);
9817 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9818 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9819 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9820 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9821 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9822 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9825 PL_minus_c = proto_perl->Iminus_c;
9826 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9827 PL_localpatches = proto_perl->Ilocalpatches;
9828 PL_splitstr = proto_perl->Isplitstr;
9829 PL_preprocess = proto_perl->Ipreprocess;
9830 PL_minus_n = proto_perl->Iminus_n;
9831 PL_minus_p = proto_perl->Iminus_p;
9832 PL_minus_l = proto_perl->Iminus_l;
9833 PL_minus_a = proto_perl->Iminus_a;
9834 PL_minus_F = proto_perl->Iminus_F;
9835 PL_doswitches = proto_perl->Idoswitches;
9836 PL_dowarn = proto_perl->Idowarn;
9837 PL_doextract = proto_perl->Idoextract;
9838 PL_sawampersand = proto_perl->Isawampersand;
9839 PL_unsafe = proto_perl->Iunsafe;
9840 PL_inplace = SAVEPV(proto_perl->Iinplace);
9841 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9842 PL_perldb = proto_perl->Iperldb;
9843 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9844 PL_exit_flags = proto_perl->Iexit_flags;
9846 /* magical thingies */
9847 /* XXX time(&PL_basetime) when asked for? */
9848 PL_basetime = proto_perl->Ibasetime;
9849 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9851 PL_maxsysfd = proto_perl->Imaxsysfd;
9852 PL_multiline = proto_perl->Imultiline;
9853 PL_statusvalue = proto_perl->Istatusvalue;
9855 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9857 PL_encoding = sv_dup(proto_perl->Iencoding, param);
9859 /* Clone the regex array */
9860 PL_regex_padav = newAV();
9862 I32 len = av_len((AV*)proto_perl->Iregex_padav);
9863 SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
9864 av_push(PL_regex_padav,
9865 sv_dup_inc(regexen[0],param));
9866 for(i = 1; i <= len; i++) {
9867 if(SvREPADTMP(regexen[i])) {
9868 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
9870 av_push(PL_regex_padav,
9872 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
9873 SvIVX(regexen[i])), param)))
9878 PL_regex_pad = AvARRAY(PL_regex_padav);
9880 /* shortcuts to various I/O objects */
9881 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9882 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9883 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9884 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9885 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9886 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9888 /* shortcuts to regexp stuff */
9889 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9891 /* shortcuts to misc objects */
9892 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9894 /* shortcuts to debugging objects */
9895 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9896 PL_DBline = gv_dup(proto_perl->IDBline, param);
9897 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9898 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9899 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9900 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9901 PL_lineary = av_dup(proto_perl->Ilineary, param);
9902 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9905 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9906 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9907 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9908 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9909 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9910 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9912 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9913 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
9914 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9915 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9916 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9918 PL_sub_generation = proto_perl->Isub_generation;
9920 /* funky return mechanisms */
9921 PL_forkprocess = proto_perl->Iforkprocess;
9923 /* subprocess state */
9924 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9926 /* internal state */
9927 PL_tainting = proto_perl->Itainting;
9928 PL_maxo = proto_perl->Imaxo;
9929 if (proto_perl->Iop_mask)
9930 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9932 PL_op_mask = Nullch;
9934 /* current interpreter roots */
9935 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9936 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9937 PL_main_start = proto_perl->Imain_start;
9938 PL_eval_root = proto_perl->Ieval_root;
9939 PL_eval_start = proto_perl->Ieval_start;
9941 /* runtime control stuff */
9942 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9943 PL_copline = proto_perl->Icopline;
9945 PL_filemode = proto_perl->Ifilemode;
9946 PL_lastfd = proto_perl->Ilastfd;
9947 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9950 PL_gensym = proto_perl->Igensym;
9951 PL_preambled = proto_perl->Ipreambled;
9952 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9953 PL_laststatval = proto_perl->Ilaststatval;
9954 PL_laststype = proto_perl->Ilaststype;
9955 PL_mess_sv = Nullsv;
9957 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9958 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9960 /* interpreter atexit processing */
9961 PL_exitlistlen = proto_perl->Iexitlistlen;
9962 if (PL_exitlistlen) {
9963 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9964 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9967 PL_exitlist = (PerlExitListEntry*)NULL;
9968 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9969 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
9970 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
9972 PL_profiledata = NULL;
9973 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
9974 /* PL_rsfp_filters entries have fake IoDIRP() */
9975 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9977 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9978 PL_comppad = av_dup(proto_perl->Icomppad, param);
9979 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9980 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9981 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9982 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9983 proto_perl->Tcurpad);
9985 #ifdef HAVE_INTERP_INTERN
9986 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9989 /* more statics moved here */
9990 PL_generation = proto_perl->Igeneration;
9991 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9993 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9994 PL_in_clean_all = proto_perl->Iin_clean_all;
9996 PL_uid = proto_perl->Iuid;
9997 PL_euid = proto_perl->Ieuid;
9998 PL_gid = proto_perl->Igid;
9999 PL_egid = proto_perl->Iegid;
10000 PL_nomemok = proto_perl->Inomemok;
10001 PL_an = proto_perl->Ian;
10002 PL_cop_seqmax = proto_perl->Icop_seqmax;
10003 PL_op_seqmax = proto_perl->Iop_seqmax;
10004 PL_evalseq = proto_perl->Ievalseq;
10005 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
10006 PL_origalen = proto_perl->Iorigalen;
10007 PL_pidstatus = newHV(); /* XXX flag for cloning? */
10008 PL_osname = SAVEPV(proto_perl->Iosname);
10009 PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
10010 PL_sighandlerp = proto_perl->Isighandlerp;
10013 PL_runops = proto_perl->Irunops;
10015 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
10018 PL_cshlen = proto_perl->Icshlen;
10019 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
10022 PL_lex_state = proto_perl->Ilex_state;
10023 PL_lex_defer = proto_perl->Ilex_defer;
10024 PL_lex_expect = proto_perl->Ilex_expect;
10025 PL_lex_formbrack = proto_perl->Ilex_formbrack;
10026 PL_lex_dojoin = proto_perl->Ilex_dojoin;
10027 PL_lex_starts = proto_perl->Ilex_starts;
10028 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
10029 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
10030 PL_lex_op = proto_perl->Ilex_op;
10031 PL_lex_inpat = proto_perl->Ilex_inpat;
10032 PL_lex_inwhat = proto_perl->Ilex_inwhat;
10033 PL_lex_brackets = proto_perl->Ilex_brackets;
10034 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
10035 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
10036 PL_lex_casemods = proto_perl->Ilex_casemods;
10037 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
10038 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
10040 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
10041 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
10042 PL_nexttoke = proto_perl->Inexttoke;
10044 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
10045 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
10046 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10047 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
10048 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10049 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
10050 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10051 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10052 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
10053 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10054 PL_pending_ident = proto_perl->Ipending_ident;
10055 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
10057 PL_expect = proto_perl->Iexpect;
10059 PL_multi_start = proto_perl->Imulti_start;
10060 PL_multi_end = proto_perl->Imulti_end;
10061 PL_multi_open = proto_perl->Imulti_open;
10062 PL_multi_close = proto_perl->Imulti_close;
10064 PL_error_count = proto_perl->Ierror_count;
10065 PL_subline = proto_perl->Isubline;
10066 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
10068 PL_min_intro_pending = proto_perl->Imin_intro_pending;
10069 PL_max_intro_pending = proto_perl->Imax_intro_pending;
10070 PL_padix = proto_perl->Ipadix;
10071 PL_padix_floor = proto_perl->Ipadix_floor;
10072 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
10074 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
10075 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10076 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
10077 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
10078 PL_last_lop_op = proto_perl->Ilast_lop_op;
10079 PL_in_my = proto_perl->Iin_my;
10080 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
10082 PL_cryptseen = proto_perl->Icryptseen;
10085 PL_hints = proto_perl->Ihints;
10087 PL_amagic_generation = proto_perl->Iamagic_generation;
10089 #ifdef USE_LOCALE_COLLATE
10090 PL_collation_ix = proto_perl->Icollation_ix;
10091 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
10092 PL_collation_standard = proto_perl->Icollation_standard;
10093 PL_collxfrm_base = proto_perl->Icollxfrm_base;
10094 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
10095 #endif /* USE_LOCALE_COLLATE */
10097 #ifdef USE_LOCALE_NUMERIC
10098 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
10099 PL_numeric_standard = proto_perl->Inumeric_standard;
10100 PL_numeric_local = proto_perl->Inumeric_local;
10101 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
10102 #endif /* !USE_LOCALE_NUMERIC */
10104 /* utf8 character classes */
10105 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
10106 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
10107 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
10108 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
10109 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
10110 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
10111 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
10112 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
10113 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
10114 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
10115 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
10116 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
10117 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
10118 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
10119 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
10120 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
10121 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
10124 PL_last_swash_hv = Nullhv; /* reinits on demand */
10125 PL_last_swash_klen = 0;
10126 PL_last_swash_key[0]= '\0';
10127 PL_last_swash_tmps = (U8*)NULL;
10128 PL_last_swash_slen = 0;
10130 /* perly.c globals */
10131 PL_yydebug = proto_perl->Iyydebug;
10132 PL_yynerrs = proto_perl->Iyynerrs;
10133 PL_yyerrflag = proto_perl->Iyyerrflag;
10134 PL_yychar = proto_perl->Iyychar;
10135 PL_yyval = proto_perl->Iyyval;
10136 PL_yylval = proto_perl->Iyylval;
10138 PL_glob_index = proto_perl->Iglob_index;
10139 PL_srand_called = proto_perl->Isrand_called;
10140 PL_uudmap['M'] = 0; /* reinits on demand */
10141 PL_bitcount = Nullch; /* reinits on demand */
10143 if (proto_perl->Ipsig_pend) {
10144 Newz(0, PL_psig_pend, SIG_SIZE, int);
10147 PL_psig_pend = (int*)NULL;
10150 if (proto_perl->Ipsig_ptr) {
10151 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
10152 Newz(0, PL_psig_name, SIG_SIZE, SV*);
10153 for (i = 1; i < SIG_SIZE; i++) {
10154 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
10155 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
10159 PL_psig_ptr = (SV**)NULL;
10160 PL_psig_name = (SV**)NULL;
10163 /* thrdvar.h stuff */
10165 if (flags & CLONEf_COPY_STACKS) {
10166 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
10167 PL_tmps_ix = proto_perl->Ttmps_ix;
10168 PL_tmps_max = proto_perl->Ttmps_max;
10169 PL_tmps_floor = proto_perl->Ttmps_floor;
10170 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
10172 while (i <= PL_tmps_ix) {
10173 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
10177 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
10178 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
10179 Newz(54, PL_markstack, i, I32);
10180 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
10181 - proto_perl->Tmarkstack);
10182 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
10183 - proto_perl->Tmarkstack);
10184 Copy(proto_perl->Tmarkstack, PL_markstack,
10185 PL_markstack_ptr - PL_markstack + 1, I32);
10187 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
10188 * NOTE: unlike the others! */
10189 PL_scopestack_ix = proto_perl->Tscopestack_ix;
10190 PL_scopestack_max = proto_perl->Tscopestack_max;
10191 Newz(54, PL_scopestack, PL_scopestack_max, I32);
10192 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
10194 /* next push_return() sets PL_retstack[PL_retstack_ix]
10195 * NOTE: unlike the others! */
10196 PL_retstack_ix = proto_perl->Tretstack_ix;
10197 PL_retstack_max = proto_perl->Tretstack_max;
10198 Newz(54, PL_retstack, PL_retstack_max, OP*);
10199 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10201 /* NOTE: si_dup() looks at PL_markstack */
10202 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10204 /* PL_curstack = PL_curstackinfo->si_stack; */
10205 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10206 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10208 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10209 PL_stack_base = AvARRAY(PL_curstack);
10210 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10211 - proto_perl->Tstack_base);
10212 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10214 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10215 * NOTE: unlike the others! */
10216 PL_savestack_ix = proto_perl->Tsavestack_ix;
10217 PL_savestack_max = proto_perl->Tsavestack_max;
10218 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10219 PL_savestack = ss_dup(proto_perl, param);
10223 ENTER; /* perl_destruct() wants to LEAVE; */
10226 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10227 PL_top_env = &PL_start_env;
10229 PL_op = proto_perl->Top;
10232 PL_Xpv = (XPV*)NULL;
10233 PL_na = proto_perl->Tna;
10235 PL_statbuf = proto_perl->Tstatbuf;
10236 PL_statcache = proto_perl->Tstatcache;
10237 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10238 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10240 PL_timesbuf = proto_perl->Ttimesbuf;
10243 PL_tainted = proto_perl->Ttainted;
10244 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10245 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10246 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10247 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10248 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10249 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10250 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10251 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10252 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10254 PL_restartop = proto_perl->Trestartop;
10255 PL_in_eval = proto_perl->Tin_eval;
10256 PL_delaymagic = proto_perl->Tdelaymagic;
10257 PL_dirty = proto_perl->Tdirty;
10258 PL_localizing = proto_perl->Tlocalizing;
10260 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10261 PL_protect = proto_perl->Tprotect;
10263 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10264 PL_av_fetch_sv = Nullsv;
10265 PL_hv_fetch_sv = Nullsv;
10266 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10267 PL_modcount = proto_perl->Tmodcount;
10268 PL_lastgotoprobe = Nullop;
10269 PL_dumpindent = proto_perl->Tdumpindent;
10271 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10272 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10273 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10274 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10275 PL_sortcxix = proto_perl->Tsortcxix;
10276 PL_efloatbuf = Nullch; /* reinits on demand */
10277 PL_efloatsize = 0; /* reinits on demand */
10281 PL_screamfirst = NULL;
10282 PL_screamnext = NULL;
10283 PL_maxscream = -1; /* reinits on demand */
10284 PL_lastscream = Nullsv;
10286 PL_watchaddr = NULL;
10287 PL_watchok = Nullch;
10289 PL_regdummy = proto_perl->Tregdummy;
10290 PL_regcomp_parse = Nullch;
10291 PL_regxend = Nullch;
10292 PL_regcode = (regnode*)NULL;
10295 PL_regprecomp = Nullch;
10300 PL_seen_zerolen = 0;
10302 PL_regcomp_rx = (regexp*)NULL;
10304 PL_colorset = 0; /* reinits PL_colors[] */
10305 /*PL_colors[6] = {0,0,0,0,0,0};*/
10306 PL_reg_whilem_seen = 0;
10307 PL_reginput = Nullch;
10308 PL_regbol = Nullch;
10309 PL_regeol = Nullch;
10310 PL_regstartp = (I32*)NULL;
10311 PL_regendp = (I32*)NULL;
10312 PL_reglastparen = (U32*)NULL;
10313 PL_regtill = Nullch;
10314 PL_reg_start_tmp = (char**)NULL;
10315 PL_reg_start_tmpl = 0;
10316 PL_regdata = (struct reg_data*)NULL;
10319 PL_reg_eval_set = 0;
10321 PL_regprogram = (regnode*)NULL;
10323 PL_regcc = (CURCUR*)NULL;
10324 PL_reg_call_cc = (struct re_cc_state*)NULL;
10325 PL_reg_re = (regexp*)NULL;
10326 PL_reg_ganch = Nullch;
10327 PL_reg_sv = Nullsv;
10328 PL_reg_match_utf8 = FALSE;
10329 PL_reg_magic = (MAGIC*)NULL;
10331 PL_reg_oldcurpm = (PMOP*)NULL;
10332 PL_reg_curpm = (PMOP*)NULL;
10333 PL_reg_oldsaved = Nullch;
10334 PL_reg_oldsavedlen = 0;
10335 PL_reg_maxiter = 0;
10336 PL_reg_leftiter = 0;
10337 PL_reg_poscache = Nullch;
10338 PL_reg_poscache_size= 0;
10340 /* RE engine - function pointers */
10341 PL_regcompp = proto_perl->Tregcompp;
10342 PL_regexecp = proto_perl->Tregexecp;
10343 PL_regint_start = proto_perl->Tregint_start;
10344 PL_regint_string = proto_perl->Tregint_string;
10345 PL_regfree = proto_perl->Tregfree;
10347 PL_reginterp_cnt = 0;
10348 PL_reg_starttry = 0;
10350 /* Pluggable optimizer */
10351 PL_peepp = proto_perl->Tpeepp;
10353 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10354 ptr_table_free(PL_ptr_table);
10355 PL_ptr_table = NULL;
10358 /* Call the ->CLONE method, if it exists, for each of the stashes
10359 identified by sv_dup() above.
10361 while(av_len(param->stashes) != -1) {
10362 HV* stash = (HV*) av_shift(param->stashes);
10363 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10364 if (cloner && GvCV(cloner)) {
10369 XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
10371 call_sv((SV*)GvCV(cloner), G_DISCARD);
10377 SvREFCNT_dec(param->stashes);
10383 #endif /* USE_ITHREADS */