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
24 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
27 /* ============================================================================
29 =head1 Allocation and deallocation of SVs.
31 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
32 av, hv...) contains type and reference count information, as well as a
33 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
34 specific to each type.
36 Normally, this allocation is done using arenas, which are approximately
37 1K chunks of memory parcelled up into N heads or bodies. The first slot
38 in each arena is reserved, and is used to hold a link to the next arena.
39 In the case of heads, the unused first slot also contains some flags and
40 a note of the number of slots. Snaked through each arena chain is a
41 linked list of free items; when this becomes empty, an extra arena is
42 allocated and divided up into N items which are threaded into the free
45 The following global variables are associated with arenas:
47 PL_sv_arenaroot pointer to list of SV arenas
48 PL_sv_root pointer to list of free SV structures
50 PL_foo_arenaroot pointer to list of foo arenas,
51 PL_foo_root pointer to list of free foo bodies
52 ... for foo in xiv, xnv, xrv, xpv etc.
54 Note that some of the larger and more rarely used body types (eg xpvio)
55 are not allocated using arenas, but are instead just malloc()/free()ed as
56 required. Also, if PURIFY is defined, arenas are abandoned altogether,
57 with all items individually malloc()ed. In addition, a few SV heads are
58 not allocated from an arena, but are instead directly created as static
59 or auto variables, eg PL_sv_undef.
61 The SV arena serves the secondary purpose of allowing still-live SVs
62 to be located and destroyed during final cleanup.
64 At the lowest level, the macros new_SV() and del_SV() grab and free
65 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
66 to return the SV to the free list with error checking.) new_SV() calls
67 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
68 SVs in the free list have their SvTYPE field set to all ones.
70 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
71 that allocate and return individual body types. Normally these are mapped
72 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
73 instead mapped directly to malloc()/free() if PURIFY is defined. The
74 new/del functions remove from, or add to, the appropriate PL_foo_root
75 list, and call more_xiv() etc to add a new arena if the list is empty.
77 At the time of very final cleanup, sv_free_arenas() is called from
78 perl_destruct() to physically free all the arenas allocated since the
79 start of the interpreter. Note that this also clears PL_he_arenaroot,
80 which is otherwise dealt with in hv.c.
82 Manipulation of any of the PL_*root pointers is protected by enclosing
83 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
84 if threads are enabled.
86 The function visit() scans the SV arenas list, and calls a specified
87 function for each SV it finds which is still live - ie which has an SvTYPE
88 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
89 following functions (specified as [function that calls visit()] / [function
90 called by visit() for each SV]):
92 sv_report_used() / do_report_used()
93 dump all remaining SVs (debugging aid)
95 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
96 Attempt to free all objects pointed to by RVs,
97 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
98 try to do the same for all objects indirectly
99 referenced by typeglobs too. Called once from
100 perl_destruct(), prior to calling sv_clean_all()
103 sv_clean_all() / do_clean_all()
104 SvREFCNT_dec(sv) each remaining SV, possibly
105 triggering an sv_free(). It also sets the
106 SVf_BREAK flag on the SV to indicate that the
107 refcnt has been artificially lowered, and thus
108 stopping sv_free() from giving spurious warnings
109 about SVs which unexpectedly have a refcnt
110 of zero. called repeatedly from perl_destruct()
111 until there are no SVs left.
115 Private API to rest of sv.c
119 new_XIV(), del_XIV(),
120 new_XNV(), del_XNV(),
125 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
130 ============================================================================ */
135 * "A time to plant, and a time to uproot what was planted..."
138 #define plant_SV(p) \
140 SvANY(p) = (void *)PL_sv_root; \
141 SvFLAGS(p) = SVTYPEMASK; \
146 /* sv_mutex must be held while calling uproot_SV() */
147 #define uproot_SV(p) \
150 PL_sv_root = (SV*)SvANY(p); \
155 /* new_SV(): return a new, empty SV head */
171 /* del_SV(): return an empty SV head to the free list */
186 S_del_sv(pTHX_ SV *p)
193 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
195 svend = &sva[SvREFCNT(sva)];
196 if (p >= sv && p < svend)
200 if (ckWARN_d(WARN_INTERNAL))
201 Perl_warner(aTHX_ WARN_INTERNAL,
202 "Attempt to free non-arena SV: 0x%"UVxf,
210 #else /* ! DEBUGGING */
212 #define del_SV(p) plant_SV(p)
214 #endif /* DEBUGGING */
218 =for apidoc sv_add_arena
220 Given a chunk of memory, link it to the head of the list of arenas,
221 and split it into a list of free SVs.
227 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
232 Zero(ptr, size, char);
234 /* The first SV in an arena isn't an SV. */
235 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
236 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
237 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
239 PL_sv_arenaroot = sva;
240 PL_sv_root = sva + 1;
242 svend = &sva[SvREFCNT(sva) - 1];
245 SvANY(sv) = (void *)(SV*)(sv + 1);
246 SvFLAGS(sv) = SVTYPEMASK;
250 SvFLAGS(sv) = SVTYPEMASK;
253 /* make some more SVs by adding another arena */
255 /* sv_mutex must be held while calling more_sv() */
262 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
263 PL_nice_chunk = Nullch;
264 PL_nice_chunk_size = 0;
267 char *chunk; /* must use New here to match call to */
268 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
269 sv_add_arena(chunk, 1008, 0);
275 /* visit(): call the named function for each non-free SV in the arenas. */
278 S_visit(pTHX_ SVFUNC_t f)
285 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
286 svend = &sva[SvREFCNT(sva)];
287 for (sv = sva + 1; sv < svend; ++sv) {
288 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
297 /* called by sv_report_used() for each live SV */
300 do_report_used(pTHXo_ SV *sv)
302 if (SvTYPE(sv) != SVTYPEMASK) {
303 PerlIO_printf(Perl_debug_log, "****\n");
309 =for apidoc sv_report_used
311 Dump the contents of all SVs not yet freed. (Debugging aid).
317 Perl_sv_report_used(pTHX)
319 visit(do_report_used);
322 /* called by sv_clean_objs() for each live SV */
325 do_clean_objs(pTHXo_ SV *sv)
329 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
330 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
342 /* XXX Might want to check arrays, etc. */
345 /* called by sv_clean_objs() for each live SV */
347 #ifndef DISABLE_DESTRUCTOR_KLUDGE
349 do_clean_named_objs(pTHXo_ SV *sv)
351 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
352 if ( SvOBJECT(GvSV(sv)) ||
353 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
354 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
355 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
356 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
358 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
366 =for apidoc sv_clean_objs
368 Attempt to destroy all objects not yet freed
374 Perl_sv_clean_objs(pTHX)
376 PL_in_clean_objs = TRUE;
377 visit(do_clean_objs);
378 #ifndef DISABLE_DESTRUCTOR_KLUDGE
379 /* some barnacles may yet remain, clinging to typeglobs */
380 visit(do_clean_named_objs);
382 PL_in_clean_objs = FALSE;
385 /* called by sv_clean_all() for each live SV */
388 do_clean_all(pTHXo_ SV *sv)
390 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
391 SvFLAGS(sv) |= SVf_BREAK;
396 =for apidoc sv_clean_all
398 Decrement the refcnt of each remaining SV, possibly triggering a
399 cleanup. This function may have to be called multiple times to free
400 SVs which are in complex self-referential hierarchies.
406 Perl_sv_clean_all(pTHX)
409 PL_in_clean_all = TRUE;
410 cleaned = visit(do_clean_all);
411 PL_in_clean_all = FALSE;
416 =for apidoc sv_free_arenas
418 Deallocate the memory used by all arenas. Note that all the individual SV
419 heads and bodies within the arenas must already have been freed.
425 Perl_sv_free_arenas(pTHX)
429 XPV *arena, *arenanext;
431 /* Free arenas here, but be careful about fake ones. (We assume
432 contiguity of the fake ones with the corresponding real ones.) */
434 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
435 svanext = (SV*) SvANY(sva);
436 while (svanext && SvFAKE(svanext))
437 svanext = (SV*) SvANY(svanext);
440 Safefree((void *)sva);
443 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
444 arenanext = (XPV*)arena->xpv_pv;
447 PL_xiv_arenaroot = 0;
449 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
450 arenanext = (XPV*)arena->xpv_pv;
453 PL_xnv_arenaroot = 0;
455 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
456 arenanext = (XPV*)arena->xpv_pv;
459 PL_xrv_arenaroot = 0;
461 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
462 arenanext = (XPV*)arena->xpv_pv;
465 PL_xpv_arenaroot = 0;
467 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
468 arenanext = (XPV*)arena->xpv_pv;
471 PL_xpviv_arenaroot = 0;
473 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
474 arenanext = (XPV*)arena->xpv_pv;
477 PL_xpvnv_arenaroot = 0;
479 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
480 arenanext = (XPV*)arena->xpv_pv;
483 PL_xpvcv_arenaroot = 0;
485 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
486 arenanext = (XPV*)arena->xpv_pv;
489 PL_xpvav_arenaroot = 0;
491 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
492 arenanext = (XPV*)arena->xpv_pv;
495 PL_xpvhv_arenaroot = 0;
497 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
498 arenanext = (XPV*)arena->xpv_pv;
501 PL_xpvmg_arenaroot = 0;
503 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
504 arenanext = (XPV*)arena->xpv_pv;
507 PL_xpvlv_arenaroot = 0;
509 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
510 arenanext = (XPV*)arena->xpv_pv;
513 PL_xpvbm_arenaroot = 0;
515 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
516 arenanext = (XPV*)arena->xpv_pv;
522 Safefree(PL_nice_chunk);
523 PL_nice_chunk = Nullch;
524 PL_nice_chunk_size = 0;
530 =for apidoc report_uninit
532 Print appropriate "Use of uninitialized variable" warning
538 Perl_report_uninit(pTHX)
541 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
542 " in ", PL_op_desc[PL_op->op_type]);
544 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
547 /* grab a new IV body from the free list, allocating more if necessary */
558 * See comment in more_xiv() -- RAM.
560 PL_xiv_root = *(IV**)xiv;
562 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
565 /* return an IV body to the free list */
568 S_del_xiv(pTHX_ XPVIV *p)
570 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
572 *(IV**)xiv = PL_xiv_root;
577 /* allocate another arena's worth of IV bodies */
585 New(705, ptr, 1008/sizeof(XPV), XPV);
586 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
587 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
590 xivend = &xiv[1008 / sizeof(IV) - 1];
591 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
593 while (xiv < xivend) {
594 *(IV**)xiv = (IV *)(xiv + 1);
600 /* grab a new NV body from the free list, allocating more if necessary */
610 PL_xnv_root = *(NV**)xnv;
612 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
615 /* return an NV body to the free list */
618 S_del_xnv(pTHX_ XPVNV *p)
620 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
622 *(NV**)xnv = PL_xnv_root;
627 /* allocate another arena's worth of NV bodies */
635 New(711, ptr, 1008/sizeof(XPV), XPV);
636 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
637 PL_xnv_arenaroot = ptr;
640 xnvend = &xnv[1008 / sizeof(NV) - 1];
641 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
643 while (xnv < xnvend) {
644 *(NV**)xnv = (NV*)(xnv + 1);
650 /* grab a new struct xrv from the free list, allocating more if necessary */
660 PL_xrv_root = (XRV*)xrv->xrv_rv;
665 /* return a struct xrv to the free list */
668 S_del_xrv(pTHX_ XRV *p)
671 p->xrv_rv = (SV*)PL_xrv_root;
676 /* allocate another arena's worth of struct xrv */
682 register XRV* xrvend;
684 New(712, ptr, 1008/sizeof(XPV), XPV);
685 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
686 PL_xrv_arenaroot = ptr;
689 xrvend = &xrv[1008 / sizeof(XRV) - 1];
690 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
692 while (xrv < xrvend) {
693 xrv->xrv_rv = (SV*)(xrv + 1);
699 /* grab a new struct xpv from the free list, allocating more if necessary */
709 PL_xpv_root = (XPV*)xpv->xpv_pv;
714 /* return a struct xpv to the free list */
717 S_del_xpv(pTHX_ XPV *p)
720 p->xpv_pv = (char*)PL_xpv_root;
725 /* allocate another arena's worth of struct xpv */
731 register XPV* xpvend;
732 New(713, xpv, 1008/sizeof(XPV), XPV);
733 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
734 PL_xpv_arenaroot = xpv;
736 xpvend = &xpv[1008 / sizeof(XPV) - 1];
738 while (xpv < xpvend) {
739 xpv->xpv_pv = (char*)(xpv + 1);
745 /* grab a new struct xpviv from the free list, allocating more if necessary */
754 xpviv = PL_xpviv_root;
755 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
760 /* return a struct xpviv to the free list */
763 S_del_xpviv(pTHX_ XPVIV *p)
766 p->xpv_pv = (char*)PL_xpviv_root;
771 /* allocate another arena's worth of struct xpviv */
776 register XPVIV* xpviv;
777 register XPVIV* xpvivend;
778 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
779 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
780 PL_xpviv_arenaroot = xpviv;
782 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
783 PL_xpviv_root = ++xpviv;
784 while (xpviv < xpvivend) {
785 xpviv->xpv_pv = (char*)(xpviv + 1);
791 /* grab a new struct xpvnv from the free list, allocating more if necessary */
800 xpvnv = PL_xpvnv_root;
801 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
806 /* return a struct xpvnv to the free list */
809 S_del_xpvnv(pTHX_ XPVNV *p)
812 p->xpv_pv = (char*)PL_xpvnv_root;
817 /* allocate another arena's worth of struct xpvnv */
822 register XPVNV* xpvnv;
823 register XPVNV* xpvnvend;
824 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
825 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
826 PL_xpvnv_arenaroot = xpvnv;
828 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
829 PL_xpvnv_root = ++xpvnv;
830 while (xpvnv < xpvnvend) {
831 xpvnv->xpv_pv = (char*)(xpvnv + 1);
837 /* grab a new struct xpvcv from the free list, allocating more if necessary */
846 xpvcv = PL_xpvcv_root;
847 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
852 /* return a struct xpvcv to the free list */
855 S_del_xpvcv(pTHX_ XPVCV *p)
858 p->xpv_pv = (char*)PL_xpvcv_root;
863 /* allocate another arena's worth of struct xpvcv */
868 register XPVCV* xpvcv;
869 register XPVCV* xpvcvend;
870 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
871 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
872 PL_xpvcv_arenaroot = xpvcv;
874 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
875 PL_xpvcv_root = ++xpvcv;
876 while (xpvcv < xpvcvend) {
877 xpvcv->xpv_pv = (char*)(xpvcv + 1);
883 /* grab a new struct xpvav from the free list, allocating more if necessary */
892 xpvav = PL_xpvav_root;
893 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
898 /* return a struct xpvav to the free list */
901 S_del_xpvav(pTHX_ XPVAV *p)
904 p->xav_array = (char*)PL_xpvav_root;
909 /* allocate another arena's worth of struct xpvav */
914 register XPVAV* xpvav;
915 register XPVAV* xpvavend;
916 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
917 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
918 PL_xpvav_arenaroot = xpvav;
920 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
921 PL_xpvav_root = ++xpvav;
922 while (xpvav < xpvavend) {
923 xpvav->xav_array = (char*)(xpvav + 1);
926 xpvav->xav_array = 0;
929 /* grab a new struct xpvhv from the free list, allocating more if necessary */
938 xpvhv = PL_xpvhv_root;
939 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
944 /* return a struct xpvhv to the free list */
947 S_del_xpvhv(pTHX_ XPVHV *p)
950 p->xhv_array = (char*)PL_xpvhv_root;
955 /* allocate another arena's worth of struct xpvhv */
960 register XPVHV* xpvhv;
961 register XPVHV* xpvhvend;
962 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
963 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
964 PL_xpvhv_arenaroot = xpvhv;
966 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
967 PL_xpvhv_root = ++xpvhv;
968 while (xpvhv < xpvhvend) {
969 xpvhv->xhv_array = (char*)(xpvhv + 1);
972 xpvhv->xhv_array = 0;
975 /* grab a new struct xpvmg from the free list, allocating more if necessary */
984 xpvmg = PL_xpvmg_root;
985 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
990 /* return a struct xpvmg to the free list */
993 S_del_xpvmg(pTHX_ XPVMG *p)
996 p->xpv_pv = (char*)PL_xpvmg_root;
1001 /* allocate another arena's worth of struct xpvmg */
1006 register XPVMG* xpvmg;
1007 register XPVMG* xpvmgend;
1008 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1009 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1010 PL_xpvmg_arenaroot = xpvmg;
1012 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1013 PL_xpvmg_root = ++xpvmg;
1014 while (xpvmg < xpvmgend) {
1015 xpvmg->xpv_pv = (char*)(xpvmg + 1);
1021 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1030 xpvlv = PL_xpvlv_root;
1031 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1036 /* return a struct xpvlv to the free list */
1039 S_del_xpvlv(pTHX_ XPVLV *p)
1042 p->xpv_pv = (char*)PL_xpvlv_root;
1047 /* allocate another arena's worth of struct xpvlv */
1052 register XPVLV* xpvlv;
1053 register XPVLV* xpvlvend;
1054 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1055 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1056 PL_xpvlv_arenaroot = xpvlv;
1058 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1059 PL_xpvlv_root = ++xpvlv;
1060 while (xpvlv < xpvlvend) {
1061 xpvlv->xpv_pv = (char*)(xpvlv + 1);
1067 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1076 xpvbm = PL_xpvbm_root;
1077 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1082 /* return a struct xpvbm to the free list */
1085 S_del_xpvbm(pTHX_ XPVBM *p)
1088 p->xpv_pv = (char*)PL_xpvbm_root;
1093 /* allocate another arena's worth of struct xpvbm */
1098 register XPVBM* xpvbm;
1099 register XPVBM* xpvbmend;
1100 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1101 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1102 PL_xpvbm_arenaroot = xpvbm;
1104 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1105 PL_xpvbm_root = ++xpvbm;
1106 while (xpvbm < xpvbmend) {
1107 xpvbm->xpv_pv = (char*)(xpvbm + 1);
1114 # define my_safemalloc(s) (void*)safexmalloc(717,s)
1115 # define my_safefree(p) safexfree((char*)p)
1117 # define my_safemalloc(s) (void*)safemalloc(s)
1118 # define my_safefree(p) safefree((char*)p)
1123 #define new_XIV() my_safemalloc(sizeof(XPVIV))
1124 #define del_XIV(p) my_safefree(p)
1126 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1127 #define del_XNV(p) my_safefree(p)
1129 #define new_XRV() my_safemalloc(sizeof(XRV))
1130 #define del_XRV(p) my_safefree(p)
1132 #define new_XPV() my_safemalloc(sizeof(XPV))
1133 #define del_XPV(p) my_safefree(p)
1135 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
1136 #define del_XPVIV(p) my_safefree(p)
1138 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1139 #define del_XPVNV(p) my_safefree(p)
1141 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
1142 #define del_XPVCV(p) my_safefree(p)
1144 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1145 #define del_XPVAV(p) my_safefree(p)
1147 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1148 #define del_XPVHV(p) my_safefree(p)
1150 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1151 #define del_XPVMG(p) my_safefree(p)
1153 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
1154 #define del_XPVLV(p) my_safefree(p)
1156 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
1157 #define del_XPVBM(p) my_safefree(p)
1161 #define new_XIV() (void*)new_xiv()
1162 #define del_XIV(p) del_xiv((XPVIV*) p)
1164 #define new_XNV() (void*)new_xnv()
1165 #define del_XNV(p) del_xnv((XPVNV*) p)
1167 #define new_XRV() (void*)new_xrv()
1168 #define del_XRV(p) del_xrv((XRV*) p)
1170 #define new_XPV() (void*)new_xpv()
1171 #define del_XPV(p) del_xpv((XPV *)p)
1173 #define new_XPVIV() (void*)new_xpviv()
1174 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
1176 #define new_XPVNV() (void*)new_xpvnv()
1177 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
1179 #define new_XPVCV() (void*)new_xpvcv()
1180 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
1182 #define new_XPVAV() (void*)new_xpvav()
1183 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
1185 #define new_XPVHV() (void*)new_xpvhv()
1186 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
1188 #define new_XPVMG() (void*)new_xpvmg()
1189 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
1191 #define new_XPVLV() (void*)new_xpvlv()
1192 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
1194 #define new_XPVBM() (void*)new_xpvbm()
1195 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
1199 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1200 #define del_XPVGV(p) my_safefree(p)
1202 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
1203 #define del_XPVFM(p) my_safefree(p)
1205 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
1206 #define del_XPVIO(p) my_safefree(p)
1209 =for apidoc sv_upgrade
1211 Upgrade an SV to a more complex form. Generally adds a new body type to the
1212 SV, then copies across as much information as possible from the old body.
1213 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1219 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1229 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
1230 sv_force_normal(sv);
1233 if (SvTYPE(sv) == mt)
1237 (void)SvOOK_off(sv);
1239 switch (SvTYPE(sv)) {
1260 else if (mt < SVt_PVIV)
1277 pv = (char*)SvRV(sv);
1297 else if (mt == SVt_NV)
1308 del_XPVIV(SvANY(sv));
1318 del_XPVNV(SvANY(sv));
1326 magic = SvMAGIC(sv);
1327 stash = SvSTASH(sv);
1328 del_XPVMG(SvANY(sv));
1331 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1336 Perl_croak(aTHX_ "Can't upgrade to undef");
1338 SvANY(sv) = new_XIV();
1342 SvANY(sv) = new_XNV();
1346 SvANY(sv) = new_XRV();
1350 SvANY(sv) = new_XPV();
1356 SvANY(sv) = new_XPVIV();
1366 SvANY(sv) = new_XPVNV();
1374 SvANY(sv) = new_XPVMG();
1380 SvMAGIC(sv) = magic;
1381 SvSTASH(sv) = stash;
1384 SvANY(sv) = new_XPVLV();
1390 SvMAGIC(sv) = magic;
1391 SvSTASH(sv) = stash;
1398 SvANY(sv) = new_XPVAV();
1406 SvMAGIC(sv) = magic;
1407 SvSTASH(sv) = stash;
1413 SvANY(sv) = new_XPVHV();
1421 SvMAGIC(sv) = magic;
1422 SvSTASH(sv) = stash;
1429 SvANY(sv) = new_XPVCV();
1430 Zero(SvANY(sv), 1, XPVCV);
1436 SvMAGIC(sv) = magic;
1437 SvSTASH(sv) = stash;
1440 SvANY(sv) = new_XPVGV();
1446 SvMAGIC(sv) = magic;
1447 SvSTASH(sv) = stash;
1455 SvANY(sv) = new_XPVBM();
1461 SvMAGIC(sv) = magic;
1462 SvSTASH(sv) = stash;
1468 SvANY(sv) = new_XPVFM();
1469 Zero(SvANY(sv), 1, XPVFM);
1475 SvMAGIC(sv) = magic;
1476 SvSTASH(sv) = stash;
1479 SvANY(sv) = new_XPVIO();
1480 Zero(SvANY(sv), 1, XPVIO);
1486 SvMAGIC(sv) = magic;
1487 SvSTASH(sv) = stash;
1488 IoPAGE_LEN(sv) = 60;
1491 SvFLAGS(sv) &= ~SVTYPEMASK;
1497 =for apidoc sv_backoff
1499 Remove any string offset. You should normally use the C<SvOOK_off> macro
1506 Perl_sv_backoff(pTHX_ register SV *sv)
1510 char *s = SvPVX(sv);
1511 SvLEN(sv) += SvIVX(sv);
1512 SvPVX(sv) -= SvIVX(sv);
1514 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1516 SvFLAGS(sv) &= ~SVf_OOK;
1523 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1524 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1525 Use the C<SvGROW> wrapper instead.
1531 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1535 #ifdef HAS_64K_LIMIT
1536 if (newlen >= 0x10000) {
1537 PerlIO_printf(Perl_debug_log,
1538 "Allocation too large: %"UVxf"\n", (UV)newlen);
1541 #endif /* HAS_64K_LIMIT */
1544 if (SvTYPE(sv) < SVt_PV) {
1545 sv_upgrade(sv, SVt_PV);
1548 else if (SvOOK(sv)) { /* pv is offset? */
1551 if (newlen > SvLEN(sv))
1552 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1553 #ifdef HAS_64K_LIMIT
1554 if (newlen >= 0x10000)
1560 if (newlen > SvLEN(sv)) { /* need more room? */
1561 if (SvLEN(sv) && s) {
1562 #if defined(MYMALLOC) && !defined(LEAKTEST)
1563 STRLEN l = malloced_size((void*)SvPVX(sv));
1569 Renew(s,newlen,char);
1572 New(703,s,newlen,char);
1574 SvLEN_set(sv, newlen);
1580 =for apidoc sv_setiv
1582 Copies an integer into the given SV, upgrading first if necessary.
1583 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1589 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1591 SV_CHECK_THINKFIRST(sv);
1592 switch (SvTYPE(sv)) {
1594 sv_upgrade(sv, SVt_IV);
1597 sv_upgrade(sv, SVt_PVNV);
1601 sv_upgrade(sv, SVt_PVIV);
1610 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1611 PL_op_desc[PL_op->op_type]);
1613 (void)SvIOK_only(sv); /* validate number */
1619 =for apidoc sv_setiv_mg
1621 Like C<sv_setiv>, but also handles 'set' magic.
1627 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1634 =for apidoc sv_setuv
1636 Copies an unsigned integer into the given SV, upgrading first if necessary.
1637 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1643 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1645 /* With these two if statements:
1646 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1649 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1651 If you wish to remove them, please benchmark to see what the effect is
1653 if (u <= (UV)IV_MAX) {
1654 sv_setiv(sv, (IV)u);
1663 =for apidoc sv_setuv_mg
1665 Like C<sv_setuv>, but also handles 'set' magic.
1671 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1673 /* With these two if statements:
1674 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1677 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1679 If you wish to remove them, please benchmark to see what the effect is
1681 if (u <= (UV)IV_MAX) {
1682 sv_setiv(sv, (IV)u);
1692 =for apidoc sv_setnv
1694 Copies a double into the given SV, upgrading first if necessary.
1695 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1701 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1703 SV_CHECK_THINKFIRST(sv);
1704 switch (SvTYPE(sv)) {
1707 sv_upgrade(sv, SVt_NV);
1712 sv_upgrade(sv, SVt_PVNV);
1721 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1722 PL_op_name[PL_op->op_type]);
1725 (void)SvNOK_only(sv); /* validate number */
1730 =for apidoc sv_setnv_mg
1732 Like C<sv_setnv>, but also handles 'set' magic.
1738 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1744 /* Print an "isn't numeric" warning, using a cleaned-up,
1745 * printable version of the offending string
1749 S_not_a_number(pTHX_ SV *sv)
1753 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1754 /* each *s can expand to 4 chars + "...\0",
1755 i.e. need room for 8 chars */
1758 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1760 if (ch & 128 && !isPRINT_LC(ch)) {
1769 else if (ch == '\r') {
1773 else if (ch == '\f') {
1777 else if (ch == '\\') {
1781 else if (ch == '\0') {
1785 else if (isPRINT_LC(ch))
1800 Perl_warner(aTHX_ WARN_NUMERIC,
1801 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1802 PL_op_desc[PL_op->op_type]);
1804 Perl_warner(aTHX_ WARN_NUMERIC,
1805 "Argument \"%s\" isn't numeric", tmpbuf);
1809 =for apidoc looks_like_number
1811 Test if the content of an SV looks like a number (or is a number).
1812 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1813 non-numeric warning), even if your atof() doesn't grok them.
1819 Perl_looks_like_number(pTHX_ SV *sv)
1821 register char *sbegin;
1828 else if (SvPOKp(sv))
1829 sbegin = SvPV(sv, len);
1831 return 1; /* Historic. Wrong? */
1832 return grok_number(sbegin, len, NULL);
1835 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1836 until proven guilty, assume that things are not that bad... */
1841 As 64 bit platforms often have an NV that doesn't preserve all bits of
1842 an IV (an assumption perl has been based on to date) it becomes necessary
1843 to remove the assumption that the NV always carries enough precision to
1844 recreate the IV whenever needed, and that the NV is the canonical form.
1845 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1846 precision as a side effect of conversion (which would lead to insanity
1847 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1848 1) to distinguish between IV/UV/NV slots that have cached a valid
1849 conversion where precision was lost and IV/UV/NV slots that have a
1850 valid conversion which has lost no precision
1851 2) to ensure that if a numeric conversion to one form is requested that
1852 would lose precision, the precise conversion (or differently
1853 imprecise conversion) is also performed and cached, to prevent
1854 requests for different numeric formats on the same SV causing
1855 lossy conversion chains. (lossless conversion chains are perfectly
1860 SvIOKp is true if the IV slot contains a valid value
1861 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1862 SvNOKp is true if the NV slot contains a valid value
1863 SvNOK is true only if the NV value is accurate
1866 while converting from PV to NV, check to see if converting that NV to an
1867 IV(or UV) would lose accuracy over a direct conversion from PV to
1868 IV(or UV). If it would, cache both conversions, return NV, but mark
1869 SV as IOK NOKp (ie not NOK).
1871 While converting from PV to IV, check to see if converting that IV to an
1872 NV would lose accuracy over a direct conversion from PV to NV. If it
1873 would, cache both conversions, flag similarly.
1875 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1876 correctly because if IV & NV were set NV *always* overruled.
1877 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1878 changes - now IV and NV together means that the two are interchangeable:
1879 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1881 The benefit of this is that operations such as pp_add know that if
1882 SvIOK is true for both left and right operands, then integer addition
1883 can be used instead of floating point (for cases where the result won't
1884 overflow). Before, floating point was always used, which could lead to
1885 loss of precision compared with integer addition.
1887 * making IV and NV equal status should make maths accurate on 64 bit
1889 * may speed up maths somewhat if pp_add and friends start to use
1890 integers when possible instead of fp. (Hopefully the overhead in
1891 looking for SvIOK and checking for overflow will not outweigh the
1892 fp to integer speedup)
1893 * will slow down integer operations (callers of SvIV) on "inaccurate"
1894 values, as the change from SvIOK to SvIOKp will cause a call into
1895 sv_2iv each time rather than a macro access direct to the IV slot
1896 * should speed up number->string conversion on integers as IV is
1897 favoured when IV and NV are equally accurate
1899 ####################################################################
1900 You had better be using SvIOK_notUV if you want an IV for arithmetic:
1901 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1902 On the other hand, SvUOK is true iff UV.
1903 ####################################################################
1905 Your mileage will vary depending your CPU's relative fp to integer
1909 #ifndef NV_PRESERVES_UV
1910 # define IS_NUMBER_UNDERFLOW_IV 1
1911 # define IS_NUMBER_UNDERFLOW_UV 2
1912 # define IS_NUMBER_IV_AND_UV 2
1913 # define IS_NUMBER_OVERFLOW_IV 4
1914 # define IS_NUMBER_OVERFLOW_UV 5
1916 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1918 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1920 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
1922 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));
1923 if (SvNVX(sv) < (NV)IV_MIN) {
1924 (void)SvIOKp_on(sv);
1927 return IS_NUMBER_UNDERFLOW_IV;
1929 if (SvNVX(sv) > (NV)UV_MAX) {
1930 (void)SvIOKp_on(sv);
1934 return IS_NUMBER_OVERFLOW_UV;
1936 (void)SvIOKp_on(sv);
1938 /* Can't use strtol etc to convert this string. (See truth table in
1940 if (SvNVX(sv) <= (UV)IV_MAX) {
1941 SvIVX(sv) = I_V(SvNVX(sv));
1942 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1943 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1945 /* Integer is imprecise. NOK, IOKp */
1947 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1950 SvUVX(sv) = U_V(SvNVX(sv));
1951 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1952 if (SvUVX(sv) == UV_MAX) {
1953 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1954 possibly be preserved by NV. Hence, it must be overflow.
1956 return IS_NUMBER_OVERFLOW_UV;
1958 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1960 /* Integer is imprecise. NOK, IOKp */
1962 return IS_NUMBER_OVERFLOW_IV;
1964 #endif /* !NV_PRESERVES_UV*/
1969 Return the integer value of an SV, doing any necessary string conversion,
1970 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
1976 Perl_sv_2iv(pTHX_ register SV *sv)
1980 if (SvGMAGICAL(sv)) {
1985 return I_V(SvNVX(sv));
1987 if (SvPOKp(sv) && SvLEN(sv))
1990 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1991 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1997 if (SvTHINKFIRST(sv)) {
2000 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2001 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2002 return SvIV(tmpstr);
2003 return PTR2IV(SvRV(sv));
2005 if (SvREADONLY(sv) && SvFAKE(sv)) {
2006 sv_force_normal(sv);
2008 if (SvREADONLY(sv) && !SvOK(sv)) {
2009 if (ckWARN(WARN_UNINITIALIZED))
2016 return (IV)(SvUVX(sv));
2023 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2024 * without also getting a cached IV/UV from it at the same time
2025 * (ie PV->NV conversion should detect loss of accuracy and cache
2026 * IV or UV at same time to avoid this. NWC */
2028 if (SvTYPE(sv) == SVt_NV)
2029 sv_upgrade(sv, SVt_PVNV);
2031 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2032 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2033 certainly cast into the IV range at IV_MAX, whereas the correct
2034 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2036 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2037 SvIVX(sv) = I_V(SvNVX(sv));
2038 if (SvNVX(sv) == (NV) SvIVX(sv)
2039 #ifndef NV_PRESERVES_UV
2040 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2041 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2042 /* Don't flag it as "accurately an integer" if the number
2043 came from a (by definition imprecise) NV operation, and
2044 we're outside the range of NV integer precision */
2047 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2048 DEBUG_c(PerlIO_printf(Perl_debug_log,
2049 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
2055 /* IV not precise. No need to convert from PV, as NV
2056 conversion would already have cached IV if it detected
2057 that PV->IV would be better than PV->NV->IV
2058 flags already correct - don't set public IOK. */
2059 DEBUG_c(PerlIO_printf(Perl_debug_log,
2060 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
2065 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2066 but the cast (NV)IV_MIN rounds to a the value less (more
2067 negative) than IV_MIN which happens to be equal to SvNVX ??
2068 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2069 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2070 (NV)UVX == NVX are both true, but the values differ. :-(
2071 Hopefully for 2s complement IV_MIN is something like
2072 0x8000000000000000 which will be exact. NWC */
2075 SvUVX(sv) = U_V(SvNVX(sv));
2077 (SvNVX(sv) == (NV) SvUVX(sv))
2078 #ifndef NV_PRESERVES_UV
2079 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2080 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2081 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2082 /* Don't flag it as "accurately an integer" if the number
2083 came from a (by definition imprecise) NV operation, and
2084 we're outside the range of NV integer precision */
2090 DEBUG_c(PerlIO_printf(Perl_debug_log,
2091 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2095 return (IV)SvUVX(sv);
2098 else if (SvPOKp(sv) && SvLEN(sv)) {
2100 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2101 /* We want to avoid a possible problem when we cache an IV which
2102 may be later translated to an NV, and the resulting NV is not
2103 the same as the direct translation of the initial string
2104 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2105 be careful to ensure that the value with the .456 is around if the
2106 NV value is requested in the future).
2108 This means that if we cache such an IV, we need to cache the
2109 NV as well. Moreover, we trade speed for space, and do not
2110 cache the NV if we are sure it's not needed.
2113 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2114 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2115 == IS_NUMBER_IN_UV) {
2116 /* It's definitely an integer, only upgrade to PVIV */
2117 if (SvTYPE(sv) < SVt_PVIV)
2118 sv_upgrade(sv, SVt_PVIV);
2120 } else if (SvTYPE(sv) < SVt_PVNV)
2121 sv_upgrade(sv, SVt_PVNV);
2123 /* If NV preserves UV then we only use the UV value if we know that
2124 we aren't going to call atof() below. If NVs don't preserve UVs
2125 then the value returned may have more precision than atof() will
2126 return, even though value isn't perfectly accurate. */
2127 if ((numtype & (IS_NUMBER_IN_UV
2128 #ifdef NV_PRESERVES_UV
2131 )) == IS_NUMBER_IN_UV) {
2132 /* This won't turn off the public IOK flag if it was set above */
2133 (void)SvIOKp_on(sv);
2135 if (!(numtype & IS_NUMBER_NEG)) {
2137 if (value <= (UV)IV_MAX) {
2138 SvIVX(sv) = (IV)value;
2144 /* 2s complement assumption */
2145 if (value <= (UV)IV_MIN) {
2146 SvIVX(sv) = -(IV)value;
2148 /* Too negative for an IV. This is a double upgrade, but
2149 I'm assuming it will be be rare. */
2150 if (SvTYPE(sv) < SVt_PVNV)
2151 sv_upgrade(sv, SVt_PVNV);
2155 SvNVX(sv) = -(NV)value;
2160 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2161 will be in the previous block to set the IV slot, and the next
2162 block to set the NV slot. So no else here. */
2164 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2165 != IS_NUMBER_IN_UV) {
2166 /* It wasn't an (integer that doesn't overflow the UV). */
2167 SvNVX(sv) = Atof(SvPVX(sv));
2169 if (! numtype && ckWARN(WARN_NUMERIC))
2172 #if defined(USE_LONG_DOUBLE)
2173 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2174 PTR2UV(sv), SvNVX(sv)));
2176 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2177 PTR2UV(sv), SvNVX(sv)));
2181 #ifdef NV_PRESERVES_UV
2182 (void)SvIOKp_on(sv);
2184 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2185 SvIVX(sv) = I_V(SvNVX(sv));
2186 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2189 /* Integer is imprecise. NOK, IOKp */
2191 /* UV will not work better than IV */
2193 if (SvNVX(sv) > (NV)UV_MAX) {
2195 /* Integer is inaccurate. NOK, IOKp, is UV */
2199 SvUVX(sv) = U_V(SvNVX(sv));
2200 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2201 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2205 /* Integer is imprecise. NOK, IOKp, is UV */
2211 #else /* NV_PRESERVES_UV */
2212 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2213 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2214 /* The IV slot will have been set from value returned by
2215 grok_number above. The NV slot has just been set using
2218 assert (SvIOKp(sv));
2220 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2221 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2222 /* Small enough to preserve all bits. */
2223 (void)SvIOKp_on(sv);
2225 SvIVX(sv) = I_V(SvNVX(sv));
2226 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2228 /* Assumption: first non-preserved integer is < IV_MAX,
2229 this NV is in the preserved range, therefore: */
2230 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2232 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);
2236 0 0 already failed to read UV.
2237 0 1 already failed to read UV.
2238 1 0 you won't get here in this case. IV/UV
2239 slot set, public IOK, Atof() unneeded.
2240 1 1 already read UV.
2241 so there's no point in sv_2iuv_non_preserve() attempting
2242 to use atol, strtol, strtoul etc. */
2243 if (sv_2iuv_non_preserve (sv, numtype)
2244 >= IS_NUMBER_OVERFLOW_IV)
2248 #endif /* NV_PRESERVES_UV */
2251 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2253 if (SvTYPE(sv) < SVt_IV)
2254 /* Typically the caller expects that sv_any is not NULL now. */
2255 sv_upgrade(sv, SVt_IV);
2258 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2259 PTR2UV(sv),SvIVX(sv)));
2260 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2266 Return the unsigned integer value of an SV, doing any necessary string
2267 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2274 Perl_sv_2uv(pTHX_ register SV *sv)
2278 if (SvGMAGICAL(sv)) {
2283 return U_V(SvNVX(sv));
2284 if (SvPOKp(sv) && SvLEN(sv))
2287 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2288 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2294 if (SvTHINKFIRST(sv)) {
2297 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2298 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2299 return SvUV(tmpstr);
2300 return PTR2UV(SvRV(sv));
2302 if (SvREADONLY(sv) && SvFAKE(sv)) {
2303 sv_force_normal(sv);
2305 if (SvREADONLY(sv) && !SvOK(sv)) {
2306 if (ckWARN(WARN_UNINITIALIZED))
2316 return (UV)SvIVX(sv);
2320 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2321 * without also getting a cached IV/UV from it at the same time
2322 * (ie PV->NV conversion should detect loss of accuracy and cache
2323 * IV or UV at same time to avoid this. */
2324 /* IV-over-UV optimisation - choose to cache IV if possible */
2326 if (SvTYPE(sv) == SVt_NV)
2327 sv_upgrade(sv, SVt_PVNV);
2329 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2330 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2331 SvIVX(sv) = I_V(SvNVX(sv));
2332 if (SvNVX(sv) == (NV) SvIVX(sv)
2333 #ifndef NV_PRESERVES_UV
2334 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2335 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2336 /* Don't flag it as "accurately an integer" if the number
2337 came from a (by definition imprecise) NV operation, and
2338 we're outside the range of NV integer precision */
2341 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2342 DEBUG_c(PerlIO_printf(Perl_debug_log,
2343 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2349 /* IV not precise. No need to convert from PV, as NV
2350 conversion would already have cached IV if it detected
2351 that PV->IV would be better than PV->NV->IV
2352 flags already correct - don't set public IOK. */
2353 DEBUG_c(PerlIO_printf(Perl_debug_log,
2354 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2359 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2360 but the cast (NV)IV_MIN rounds to a the value less (more
2361 negative) than IV_MIN which happens to be equal to SvNVX ??
2362 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2363 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2364 (NV)UVX == NVX are both true, but the values differ. :-(
2365 Hopefully for 2s complement IV_MIN is something like
2366 0x8000000000000000 which will be exact. NWC */
2369 SvUVX(sv) = U_V(SvNVX(sv));
2371 (SvNVX(sv) == (NV) SvUVX(sv))
2372 #ifndef NV_PRESERVES_UV
2373 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2374 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2375 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2376 /* Don't flag it as "accurately an integer" if the number
2377 came from a (by definition imprecise) NV operation, and
2378 we're outside the range of NV integer precision */
2383 DEBUG_c(PerlIO_printf(Perl_debug_log,
2384 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2390 else if (SvPOKp(sv) && SvLEN(sv)) {
2392 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2394 /* We want to avoid a possible problem when we cache a UV which
2395 may be later translated to an NV, and the resulting NV is not
2396 the translation of the initial data.
2398 This means that if we cache such a UV, we need to cache the
2399 NV as well. Moreover, we trade speed for space, and do not
2400 cache the NV if not needed.
2403 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2404 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2405 == IS_NUMBER_IN_UV) {
2406 /* It's definitely an integer, only upgrade to PVIV */
2407 if (SvTYPE(sv) < SVt_PVIV)
2408 sv_upgrade(sv, SVt_PVIV);
2410 } else if (SvTYPE(sv) < SVt_PVNV)
2411 sv_upgrade(sv, SVt_PVNV);
2413 /* If NV preserves UV then we only use the UV value if we know that
2414 we aren't going to call atof() below. If NVs don't preserve UVs
2415 then the value returned may have more precision than atof() will
2416 return, even though it isn't accurate. */
2417 if ((numtype & (IS_NUMBER_IN_UV
2418 #ifdef NV_PRESERVES_UV
2421 )) == IS_NUMBER_IN_UV) {
2422 /* This won't turn off the public IOK flag if it was set above */
2423 (void)SvIOKp_on(sv);
2425 if (!(numtype & IS_NUMBER_NEG)) {
2427 if (value <= (UV)IV_MAX) {
2428 SvIVX(sv) = (IV)value;
2430 /* it didn't overflow, and it was positive. */
2435 /* 2s complement assumption */
2436 if (value <= (UV)IV_MIN) {
2437 SvIVX(sv) = -(IV)value;
2439 /* Too negative for an IV. This is a double upgrade, but
2440 I'm assuming it will be be rare. */
2441 if (SvTYPE(sv) < SVt_PVNV)
2442 sv_upgrade(sv, SVt_PVNV);
2446 SvNVX(sv) = -(NV)value;
2452 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2453 != IS_NUMBER_IN_UV) {
2454 /* It wasn't an integer, or it overflowed the UV. */
2455 SvNVX(sv) = Atof(SvPVX(sv));
2457 if (! numtype && ckWARN(WARN_NUMERIC))
2460 #if defined(USE_LONG_DOUBLE)
2461 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2462 PTR2UV(sv), SvNVX(sv)));
2464 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2465 PTR2UV(sv), SvNVX(sv)));
2468 #ifdef NV_PRESERVES_UV
2469 (void)SvIOKp_on(sv);
2471 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2472 SvIVX(sv) = I_V(SvNVX(sv));
2473 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2476 /* Integer is imprecise. NOK, IOKp */
2478 /* UV will not work better than IV */
2480 if (SvNVX(sv) > (NV)UV_MAX) {
2482 /* Integer is inaccurate. NOK, IOKp, is UV */
2486 SvUVX(sv) = U_V(SvNVX(sv));
2487 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2488 NV preservse UV so can do correct comparison. */
2489 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2493 /* Integer is imprecise. NOK, IOKp, is UV */
2498 #else /* NV_PRESERVES_UV */
2499 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2500 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2501 /* The UV slot will have been set from value returned by
2502 grok_number above. The NV slot has just been set using
2505 assert (SvIOKp(sv));
2507 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2508 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2509 /* Small enough to preserve all bits. */
2510 (void)SvIOKp_on(sv);
2512 SvIVX(sv) = I_V(SvNVX(sv));
2513 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2515 /* Assumption: first non-preserved integer is < IV_MAX,
2516 this NV is in the preserved range, therefore: */
2517 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2519 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);
2522 sv_2iuv_non_preserve (sv, numtype);
2524 #endif /* NV_PRESERVES_UV */
2528 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2529 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2532 if (SvTYPE(sv) < SVt_IV)
2533 /* Typically the caller expects that sv_any is not NULL now. */
2534 sv_upgrade(sv, SVt_IV);
2538 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2539 PTR2UV(sv),SvUVX(sv)));
2540 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2546 Return the num value of an SV, doing any necessary string or integer
2547 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2554 Perl_sv_2nv(pTHX_ register SV *sv)
2558 if (SvGMAGICAL(sv)) {
2562 if (SvPOKp(sv) && SvLEN(sv)) {
2563 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2564 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2566 return Atof(SvPVX(sv));
2570 return (NV)SvUVX(sv);
2572 return (NV)SvIVX(sv);
2575 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2576 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2582 if (SvTHINKFIRST(sv)) {
2585 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2586 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2587 return SvNV(tmpstr);
2588 return PTR2NV(SvRV(sv));
2590 if (SvREADONLY(sv) && SvFAKE(sv)) {
2591 sv_force_normal(sv);
2593 if (SvREADONLY(sv) && !SvOK(sv)) {
2594 if (ckWARN(WARN_UNINITIALIZED))
2599 if (SvTYPE(sv) < SVt_NV) {
2600 if (SvTYPE(sv) == SVt_IV)
2601 sv_upgrade(sv, SVt_PVNV);
2603 sv_upgrade(sv, SVt_NV);
2604 #ifdef USE_LONG_DOUBLE
2606 STORE_NUMERIC_LOCAL_SET_STANDARD();
2607 PerlIO_printf(Perl_debug_log,
2608 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2609 PTR2UV(sv), SvNVX(sv));
2610 RESTORE_NUMERIC_LOCAL();
2614 STORE_NUMERIC_LOCAL_SET_STANDARD();
2615 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2616 PTR2UV(sv), SvNVX(sv));
2617 RESTORE_NUMERIC_LOCAL();
2621 else if (SvTYPE(sv) < SVt_PVNV)
2622 sv_upgrade(sv, SVt_PVNV);
2623 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2626 else if (SvIOKp(sv)) {
2627 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2628 #ifdef NV_PRESERVES_UV
2631 /* Only set the public NV OK flag if this NV preserves the IV */
2632 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2633 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2634 : (SvIVX(sv) == I_V(SvNVX(sv))))
2640 else if (SvPOKp(sv) && SvLEN(sv)) {
2642 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2643 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2645 #ifdef NV_PRESERVES_UV
2646 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2647 == IS_NUMBER_IN_UV) {
2648 /* It's definitely an integer */
2649 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2651 SvNVX(sv) = Atof(SvPVX(sv));
2654 SvNVX(sv) = Atof(SvPVX(sv));
2655 /* Only set the public NV OK flag if this NV preserves the value in
2656 the PV at least as well as an IV/UV would.
2657 Not sure how to do this 100% reliably. */
2658 /* if that shift count is out of range then Configure's test is
2659 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2661 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2662 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2663 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2664 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2665 /* Can't use strtol etc to convert this string, so don't try.
2666 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2669 /* value has been set. It may not be precise. */
2670 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2671 /* 2s complement assumption for (UV)IV_MIN */
2672 SvNOK_on(sv); /* Integer is too negative. */
2677 if (numtype & IS_NUMBER_NEG) {
2678 SvIVX(sv) = -(IV)value;
2679 } else if (value <= (UV)IV_MAX) {
2680 SvIVX(sv) = (IV)value;
2686 if (numtype & IS_NUMBER_NOT_INT) {
2687 /* I believe that even if the original PV had decimals,
2688 they are lost beyond the limit of the FP precision.
2689 However, neither is canonical, so both only get p
2690 flags. NWC, 2000/11/25 */
2691 /* Both already have p flags, so do nothing */
2694 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2695 if (SvIVX(sv) == I_V(nv)) {
2700 /* It had no "." so it must be integer. */
2703 /* between IV_MAX and NV(UV_MAX).
2704 Could be slightly > UV_MAX */
2706 if (numtype & IS_NUMBER_NOT_INT) {
2707 /* UV and NV both imprecise. */
2709 UV nv_as_uv = U_V(nv);
2711 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2722 #endif /* NV_PRESERVES_UV */
2725 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2727 if (SvTYPE(sv) < SVt_NV)
2728 /* Typically the caller expects that sv_any is not NULL now. */
2729 /* XXX Ilya implies that this is a bug in callers that assume this
2730 and ideally should be fixed. */
2731 sv_upgrade(sv, SVt_NV);
2734 #if defined(USE_LONG_DOUBLE)
2736 STORE_NUMERIC_LOCAL_SET_STANDARD();
2737 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2738 PTR2UV(sv), SvNVX(sv));
2739 RESTORE_NUMERIC_LOCAL();
2743 STORE_NUMERIC_LOCAL_SET_STANDARD();
2744 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2745 PTR2UV(sv), SvNVX(sv));
2746 RESTORE_NUMERIC_LOCAL();
2752 /* asIV(): extract an integer from the string value of an SV.
2753 * Caller must validate PVX */
2756 S_asIV(pTHX_ SV *sv)
2759 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2761 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2762 == IS_NUMBER_IN_UV) {
2763 /* It's definitely an integer */
2764 if (numtype & IS_NUMBER_NEG) {
2765 if (value < (UV)IV_MIN)
2768 if (value < (UV)IV_MAX)
2773 if (ckWARN(WARN_NUMERIC))
2776 return I_V(Atof(SvPVX(sv)));
2779 /* asUV(): extract an unsigned integer from the string value of an SV
2780 * Caller must validate PVX */
2783 S_asUV(pTHX_ SV *sv)
2786 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2788 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2789 == IS_NUMBER_IN_UV) {
2790 /* It's definitely an integer */
2791 if (!(numtype & IS_NUMBER_NEG))
2795 if (ckWARN(WARN_NUMERIC))
2798 return U_V(Atof(SvPVX(sv)));
2802 =for apidoc sv_2pv_nolen
2804 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2805 use the macro wrapper C<SvPV_nolen(sv)> instead.
2810 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2813 return sv_2pv(sv, &n_a);
2816 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2817 * UV as a string towards the end of buf, and return pointers to start and
2820 * We assume that buf is at least TYPE_CHARS(UV) long.
2824 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2826 char *ptr = buf + TYPE_CHARS(UV);
2840 *--ptr = '0' + (uv % 10);
2848 /* For backwards-compatibility only. sv_2pv() is normally #def'ed to
2849 * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
2853 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2855 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2859 =for apidoc sv_2pv_flags
2861 Returns a pointer to the string value of an SV, and sets *lp to its length.
2862 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2864 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2865 usually end up here too.
2871 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2876 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2877 char *tmpbuf = tbuf;
2883 if (SvGMAGICAL(sv)) {
2884 if (flags & SV_GMAGIC)
2892 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2894 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2899 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2904 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2905 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2912 if (SvTHINKFIRST(sv)) {
2915 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2916 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2917 return SvPV(tmpstr,*lp);
2924 switch (SvTYPE(sv)) {
2926 if ( ((SvFLAGS(sv) &
2927 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2928 == (SVs_OBJECT|SVs_RMG))
2929 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2930 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2931 regexp *re = (regexp *)mg->mg_obj;
2934 char *fptr = "msix";
2939 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2941 while((ch = *fptr++)) {
2943 reflags[left++] = ch;
2946 reflags[right--] = ch;
2951 reflags[left] = '-';
2955 mg->mg_len = re->prelen + 4 + left;
2956 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2957 Copy("(?", mg->mg_ptr, 2, char);
2958 Copy(reflags, mg->mg_ptr+2, left, char);
2959 Copy(":", mg->mg_ptr+left+2, 1, char);
2960 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2961 mg->mg_ptr[mg->mg_len - 1] = ')';
2962 mg->mg_ptr[mg->mg_len] = 0;
2964 PL_reginterp_cnt += re->program[0].next_off;
2976 case SVt_PVBM: if (SvROK(sv))
2979 s = "SCALAR"; break;
2980 case SVt_PVLV: s = "LVALUE"; break;
2981 case SVt_PVAV: s = "ARRAY"; break;
2982 case SVt_PVHV: s = "HASH"; break;
2983 case SVt_PVCV: s = "CODE"; break;
2984 case SVt_PVGV: s = "GLOB"; break;
2985 case SVt_PVFM: s = "FORMAT"; break;
2986 case SVt_PVIO: s = "IO"; break;
2987 default: s = "UNKNOWN"; break;
2991 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2994 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3000 if (SvREADONLY(sv) && !SvOK(sv)) {
3001 if (ckWARN(WARN_UNINITIALIZED))
3007 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3008 /* I'm assuming that if both IV and NV are equally valid then
3009 converting the IV is going to be more efficient */
3010 U32 isIOK = SvIOK(sv);
3011 U32 isUIOK = SvIsUV(sv);
3012 char buf[TYPE_CHARS(UV)];
3015 if (SvTYPE(sv) < SVt_PVIV)
3016 sv_upgrade(sv, SVt_PVIV);
3018 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3020 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3021 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
3022 Move(ptr,SvPVX(sv),ebuf - ptr,char);
3023 SvCUR_set(sv, ebuf - ptr);
3033 else if (SvNOKp(sv)) {
3034 if (SvTYPE(sv) < SVt_PVNV)
3035 sv_upgrade(sv, SVt_PVNV);
3036 /* The +20 is pure guesswork. Configure test needed. --jhi */
3037 SvGROW(sv, NV_DIG + 20);
3039 olderrno = errno; /* some Xenix systems wipe out errno here */
3041 if (SvNVX(sv) == 0.0)
3042 (void)strcpy(s,"0");
3046 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3049 #ifdef FIXNEGATIVEZERO
3050 if (*s == '-' && s[1] == '0' && !s[2])
3060 if (ckWARN(WARN_UNINITIALIZED)
3061 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3064 if (SvTYPE(sv) < SVt_PV)
3065 /* Typically the caller expects that sv_any is not NULL now. */
3066 sv_upgrade(sv, SVt_PV);
3069 *lp = s - SvPVX(sv);
3072 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3073 PTR2UV(sv),SvPVX(sv)));
3077 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3078 /* Sneaky stuff here */
3082 tsv = newSVpv(tmpbuf, 0);
3098 len = strlen(tmpbuf);
3100 #ifdef FIXNEGATIVEZERO
3101 if (len == 2 && t[0] == '-' && t[1] == '0') {
3106 (void)SvUPGRADE(sv, SVt_PV);
3108 s = SvGROW(sv, len + 1);
3117 =for apidoc sv_2pvbyte_nolen
3119 Return a pointer to the byte-encoded representation of the SV.
3120 May cause the SV to be downgraded from UTF8 as a side-effect.
3122 Usually accessed via the C<SvPVbyte_nolen> macro.
3128 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3131 return sv_2pvbyte(sv, &n_a);
3135 =for apidoc sv_2pvbyte
3137 Return a pointer to the byte-encoded representation of the SV, and set *lp
3138 to its length. May cause the SV to be downgraded from UTF8 as a
3141 Usually accessed via the C<SvPVbyte> macro.
3147 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3149 sv_utf8_downgrade(sv,0);
3150 return SvPV(sv,*lp);
3154 =for apidoc sv_2pvutf8_nolen
3156 Return a pointer to the UTF8-encoded representation of the SV.
3157 May cause the SV to be upgraded to UTF8 as a side-effect.
3159 Usually accessed via the C<SvPVutf8_nolen> macro.
3165 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3168 return sv_2pvutf8(sv, &n_a);
3172 =for apidoc sv_2pvutf8
3174 Return a pointer to the UTF8-encoded representation of the SV, and set *lp
3175 to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
3177 Usually accessed via the C<SvPVutf8> macro.
3183 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3185 sv_utf8_upgrade(sv);
3186 return SvPV(sv,*lp);
3190 =for apidoc sv_2bool
3192 This function is only called on magical items, and is only used by
3193 sv_true() or its macro equivalent.
3199 Perl_sv_2bool(pTHX_ register SV *sv)
3208 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3209 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
3210 return SvTRUE(tmpsv);
3211 return SvRV(sv) != 0;
3214 register XPV* Xpvtmp;
3215 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3216 (*Xpvtmp->xpv_pv > '0' ||
3217 Xpvtmp->xpv_cur > 1 ||
3218 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3225 return SvIVX(sv) != 0;
3228 return SvNVX(sv) != 0.0;
3236 =for apidoc sv_utf8_upgrade
3238 Convert the PV of an SV to its UTF8-encoded form.
3239 Forces the SV to string form if it is not already.
3240 Always sets the SvUTF8 flag to avoid future validity checks even
3241 if all the bytes have hibit clear.
3247 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3249 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3253 =for apidoc sv_utf8_upgrade_flags
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. If C<flags> has C<SV_GMAGIC> bit set,
3259 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3260 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3266 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3276 (void) sv_2pv_flags(sv,&len, flags);
3284 if (SvREADONLY(sv) && SvFAKE(sv)) {
3285 sv_force_normal(sv);
3288 /* This function could be much more efficient if we had a FLAG in SVs
3289 * to signal if there are any hibit chars in the PV.
3290 * Given that there isn't make loop fast as possible
3292 s = (U8 *) SvPVX(sv);
3293 e = (U8 *) SvEND(sv);
3297 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3303 len = SvCUR(sv) + 1; /* Plus the \0 */
3304 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3305 SvCUR(sv) = len - 1;
3307 Safefree(s); /* No longer using what was there before. */
3308 SvLEN(sv) = len; /* No longer know the real size. */
3310 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3316 =for apidoc sv_utf8_downgrade
3318 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3319 This may not be possible if the PV contains non-byte encoding characters;
3320 if this is the case, either returns false or, if C<fail_ok> is not
3327 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3329 if (SvPOK(sv) && SvUTF8(sv)) {
3334 if (SvREADONLY(sv) && SvFAKE(sv))
3335 sv_force_normal(sv);
3336 s = (U8 *) SvPV(sv, len);
3337 if (!utf8_to_bytes(s, &len)) {
3340 #ifdef USE_BYTES_DOWNGRADES
3341 else if (IN_BYTES) {
3343 U8 *e = (U8 *) SvEND(sv);
3346 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3347 if (first && ch > 255) {
3349 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3350 PL_op_desc[PL_op->op_type]);
3352 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3359 len = (d - (U8 *) SvPVX(sv));
3364 Perl_croak(aTHX_ "Wide character in %s",
3365 PL_op_desc[PL_op->op_type]);
3367 Perl_croak(aTHX_ "Wide character");
3378 =for apidoc sv_utf8_encode
3380 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3381 flag so that it looks like octets again. Used as a building block
3382 for encode_utf8 in Encode.xs
3388 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3390 (void) sv_utf8_upgrade(sv);
3395 =for apidoc sv_utf8_decode
3397 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3398 turn off SvUTF8 if needed so that we see characters. Used as a building block
3399 for decode_utf8 in Encode.xs
3405 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3411 /* The octets may have got themselves encoded - get them back as
3414 if (!sv_utf8_downgrade(sv, TRUE))
3417 /* it is actually just a matter of turning the utf8 flag on, but
3418 * we want to make sure everything inside is valid utf8 first.
3420 c = (U8 *) SvPVX(sv);
3421 if (!is_utf8_string(c, SvCUR(sv)+1))
3423 e = (U8 *) SvEND(sv);
3426 if (!UTF8_IS_INVARIANT(ch)) {
3436 =for apidoc sv_setsv
3438 Copies the contents of the source SV C<ssv> into the destination SV
3439 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3440 function if the source SV needs to be reused. Does not handle 'set' magic.
3441 Loosely speaking, it performs a copy-by-value, obliterating any previous
3442 content of the destination.
3444 You probably want to use one of the assortment of wrappers, such as
3445 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3446 C<SvSetMagicSV_nosteal>.
3452 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3453 for binary compatibility only
3456 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3458 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3462 =for apidoc sv_setsv_flags
3464 Copies the contents of the source SV C<ssv> into the destination SV
3465 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3466 function if the source SV needs to be reused. Does not handle 'set' magic.
3467 Loosely speaking, it performs a copy-by-value, obliterating any previous
3468 content of the destination.
3469 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3470 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3471 implemented in terms of this function.
3473 You probably want to use one of the assortment of wrappers, such as
3474 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3475 C<SvSetMagicSV_nosteal>.
3477 This is the primary function for copying scalars, and most other
3478 copy-ish functions and macros use this underneath.
3484 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3486 register U32 sflags;
3492 SV_CHECK_THINKFIRST(dstr);
3494 sstr = &PL_sv_undef;
3495 stype = SvTYPE(sstr);
3496 dtype = SvTYPE(dstr);
3500 /* There's a lot of redundancy below but we're going for speed here */
3505 if (dtype != SVt_PVGV) {
3506 (void)SvOK_off(dstr);
3514 sv_upgrade(dstr, SVt_IV);
3517 sv_upgrade(dstr, SVt_PVNV);
3521 sv_upgrade(dstr, SVt_PVIV);
3524 (void)SvIOK_only(dstr);
3525 SvIVX(dstr) = SvIVX(sstr);
3528 if (SvTAINTED(sstr))
3539 sv_upgrade(dstr, SVt_NV);
3544 sv_upgrade(dstr, SVt_PVNV);
3547 SvNVX(dstr) = SvNVX(sstr);
3548 (void)SvNOK_only(dstr);
3549 if (SvTAINTED(sstr))
3557 sv_upgrade(dstr, SVt_RV);
3558 else if (dtype == SVt_PVGV &&
3559 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3562 if (GvIMPORTED(dstr) != GVf_IMPORTED
3563 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3565 GvIMPORTED_on(dstr);
3576 sv_upgrade(dstr, SVt_PV);
3579 if (dtype < SVt_PVIV)
3580 sv_upgrade(dstr, SVt_PVIV);
3583 if (dtype < SVt_PVNV)
3584 sv_upgrade(dstr, SVt_PVNV);
3591 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3592 PL_op_name[PL_op->op_type]);
3594 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3598 if (dtype <= SVt_PVGV) {
3600 if (dtype != SVt_PVGV) {
3601 char *name = GvNAME(sstr);
3602 STRLEN len = GvNAMELEN(sstr);
3603 sv_upgrade(dstr, SVt_PVGV);
3604 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3605 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3606 GvNAME(dstr) = savepvn(name, len);
3607 GvNAMELEN(dstr) = len;
3608 SvFAKE_on(dstr); /* can coerce to non-glob */
3610 /* ahem, death to those who redefine active sort subs */
3611 else if (PL_curstackinfo->si_type == PERLSI_SORT
3612 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3613 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3616 #ifdef GV_SHARED_CHECK
3617 if (GvSHARED((GV*)dstr)) {
3618 Perl_croak(aTHX_ PL_no_modify);
3622 (void)SvOK_off(dstr);
3623 GvINTRO_off(dstr); /* one-shot flag */
3625 GvGP(dstr) = gp_ref(GvGP(sstr));
3626 if (SvTAINTED(sstr))
3628 if (GvIMPORTED(dstr) != GVf_IMPORTED
3629 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3631 GvIMPORTED_on(dstr);
3639 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3641 if (SvTYPE(sstr) != stype) {
3642 stype = SvTYPE(sstr);
3643 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3647 if (stype == SVt_PVLV)
3648 (void)SvUPGRADE(dstr, SVt_PVNV);
3650 (void)SvUPGRADE(dstr, stype);
3653 sflags = SvFLAGS(sstr);
3655 if (sflags & SVf_ROK) {
3656 if (dtype >= SVt_PV) {
3657 if (dtype == SVt_PVGV) {
3658 SV *sref = SvREFCNT_inc(SvRV(sstr));
3660 int intro = GvINTRO(dstr);
3662 #ifdef GV_SHARED_CHECK
3663 if (GvSHARED((GV*)dstr)) {
3664 Perl_croak(aTHX_ PL_no_modify);
3669 GvINTRO_off(dstr); /* one-shot flag */
3670 GvLINE(dstr) = CopLINE(PL_curcop);
3671 GvEGV(dstr) = (GV*)dstr;
3674 switch (SvTYPE(sref)) {
3677 SAVESPTR(GvAV(dstr));
3679 dref = (SV*)GvAV(dstr);
3680 GvAV(dstr) = (AV*)sref;
3681 if (!GvIMPORTED_AV(dstr)
3682 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3684 GvIMPORTED_AV_on(dstr);
3689 SAVESPTR(GvHV(dstr));
3691 dref = (SV*)GvHV(dstr);
3692 GvHV(dstr) = (HV*)sref;
3693 if (!GvIMPORTED_HV(dstr)
3694 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3696 GvIMPORTED_HV_on(dstr);
3701 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3702 SvREFCNT_dec(GvCV(dstr));
3703 GvCV(dstr) = Nullcv;
3704 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3705 PL_sub_generation++;
3707 SAVESPTR(GvCV(dstr));
3710 dref = (SV*)GvCV(dstr);
3711 if (GvCV(dstr) != (CV*)sref) {
3712 CV* cv = GvCV(dstr);
3714 if (!GvCVGEN((GV*)dstr) &&
3715 (CvROOT(cv) || CvXSUB(cv)))
3717 /* ahem, death to those who redefine
3718 * active sort subs */
3719 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3720 PL_sortcop == CvSTART(cv))
3722 "Can't redefine active sort subroutine %s",
3723 GvENAME((GV*)dstr));
3724 /* Redefining a sub - warning is mandatory if
3725 it was a const and its value changed. */
3726 if (ckWARN(WARN_REDEFINE)
3728 && (!CvCONST((CV*)sref)
3729 || sv_cmp(cv_const_sv(cv),
3730 cv_const_sv((CV*)sref)))))
3732 Perl_warner(aTHX_ WARN_REDEFINE,
3734 ? "Constant subroutine %s redefined"
3735 : "Subroutine %s redefined",
3736 GvENAME((GV*)dstr));
3739 cv_ckproto(cv, (GV*)dstr,
3740 SvPOK(sref) ? SvPVX(sref) : Nullch);
3742 GvCV(dstr) = (CV*)sref;
3743 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3744 GvASSUMECV_on(dstr);
3745 PL_sub_generation++;
3747 if (!GvIMPORTED_CV(dstr)
3748 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3750 GvIMPORTED_CV_on(dstr);
3755 SAVESPTR(GvIOp(dstr));
3757 dref = (SV*)GvIOp(dstr);
3758 GvIOp(dstr) = (IO*)sref;
3762 SAVESPTR(GvFORM(dstr));
3764 dref = (SV*)GvFORM(dstr);
3765 GvFORM(dstr) = (CV*)sref;
3769 SAVESPTR(GvSV(dstr));
3771 dref = (SV*)GvSV(dstr);
3773 if (!GvIMPORTED_SV(dstr)
3774 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3776 GvIMPORTED_SV_on(dstr);
3784 if (SvTAINTED(sstr))
3789 (void)SvOOK_off(dstr); /* backoff */
3791 Safefree(SvPVX(dstr));
3792 SvLEN(dstr)=SvCUR(dstr)=0;
3795 (void)SvOK_off(dstr);
3796 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3798 if (sflags & SVp_NOK) {
3800 /* Only set the public OK flag if the source has public OK. */
3801 if (sflags & SVf_NOK)
3802 SvFLAGS(dstr) |= SVf_NOK;
3803 SvNVX(dstr) = SvNVX(sstr);
3805 if (sflags & SVp_IOK) {
3806 (void)SvIOKp_on(dstr);
3807 if (sflags & SVf_IOK)
3808 SvFLAGS(dstr) |= SVf_IOK;
3809 if (sflags & SVf_IVisUV)
3811 SvIVX(dstr) = SvIVX(sstr);
3813 if (SvAMAGIC(sstr)) {
3817 else if (sflags & SVp_POK) {
3820 * Check to see if we can just swipe the string. If so, it's a
3821 * possible small lose on short strings, but a big win on long ones.
3822 * It might even be a win on short strings if SvPVX(dstr)
3823 * has to be allocated and SvPVX(sstr) has to be freed.
3826 if (SvTEMP(sstr) && /* slated for free anyway? */
3827 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3828 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3829 SvLEN(sstr) && /* and really is a string */
3830 /* and won't be needed again, potentially */
3831 !(PL_op && PL_op->op_type == OP_AASSIGN))
3833 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3835 SvFLAGS(dstr) &= ~SVf_OOK;
3836 Safefree(SvPVX(dstr) - SvIVX(dstr));
3838 else if (SvLEN(dstr))
3839 Safefree(SvPVX(dstr));
3841 (void)SvPOK_only(dstr);
3842 SvPV_set(dstr, SvPVX(sstr));
3843 SvLEN_set(dstr, SvLEN(sstr));
3844 SvCUR_set(dstr, SvCUR(sstr));
3847 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3848 SvPV_set(sstr, Nullch);
3853 else { /* have to copy actual string */
3854 STRLEN len = SvCUR(sstr);
3856 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3857 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3858 SvCUR_set(dstr, len);
3859 *SvEND(dstr) = '\0';
3860 (void)SvPOK_only(dstr);
3862 if (sflags & SVf_UTF8)
3865 if (sflags & SVp_NOK) {
3867 if (sflags & SVf_NOK)
3868 SvFLAGS(dstr) |= SVf_NOK;
3869 SvNVX(dstr) = SvNVX(sstr);
3871 if (sflags & SVp_IOK) {
3872 (void)SvIOKp_on(dstr);
3873 if (sflags & SVf_IOK)
3874 SvFLAGS(dstr) |= SVf_IOK;
3875 if (sflags & SVf_IVisUV)
3877 SvIVX(dstr) = SvIVX(sstr);
3880 else if (sflags & SVp_IOK) {
3881 if (sflags & SVf_IOK)
3882 (void)SvIOK_only(dstr);
3884 (void)SvOK_off(dstr);
3885 (void)SvIOKp_on(dstr);
3887 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3888 if (sflags & SVf_IVisUV)
3890 SvIVX(dstr) = SvIVX(sstr);
3891 if (sflags & SVp_NOK) {
3892 if (sflags & SVf_NOK)
3893 (void)SvNOK_on(dstr);
3895 (void)SvNOKp_on(dstr);
3896 SvNVX(dstr) = SvNVX(sstr);
3899 else if (sflags & SVp_NOK) {
3900 if (sflags & SVf_NOK)
3901 (void)SvNOK_only(dstr);
3903 (void)SvOK_off(dstr);
3906 SvNVX(dstr) = SvNVX(sstr);
3909 if (dtype == SVt_PVGV) {
3910 if (ckWARN(WARN_MISC))
3911 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3914 (void)SvOK_off(dstr);
3916 if (SvTAINTED(sstr))
3921 =for apidoc sv_setsv_mg
3923 Like C<sv_setsv>, but also handles 'set' magic.
3929 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3931 sv_setsv(dstr,sstr);
3936 =for apidoc sv_setpvn
3938 Copies a string into an SV. The C<len> parameter indicates the number of
3939 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3945 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3947 register char *dptr;
3949 SV_CHECK_THINKFIRST(sv);
3955 /* len is STRLEN which is unsigned, need to copy to signed */
3958 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3960 (void)SvUPGRADE(sv, SVt_PV);
3962 SvGROW(sv, len + 1);
3964 Move(ptr,dptr,len,char);
3967 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3972 =for apidoc sv_setpvn_mg
3974 Like C<sv_setpvn>, but also handles 'set' magic.
3980 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3982 sv_setpvn(sv,ptr,len);
3987 =for apidoc sv_setpv
3989 Copies a string into an SV. The string must be null-terminated. Does not
3990 handle 'set' magic. See C<sv_setpv_mg>.
3996 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3998 register STRLEN len;
4000 SV_CHECK_THINKFIRST(sv);
4006 (void)SvUPGRADE(sv, SVt_PV);
4008 SvGROW(sv, len + 1);
4009 Move(ptr,SvPVX(sv),len+1,char);
4011 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4016 =for apidoc sv_setpv_mg
4018 Like C<sv_setpv>, but also handles 'set' magic.
4024 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4031 =for apidoc sv_usepvn
4033 Tells an SV to use C<ptr> to find its string value. Normally the string is
4034 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4035 The C<ptr> should point to memory that was allocated by C<malloc>. The
4036 string length, C<len>, must be supplied. This function will realloc the
4037 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4038 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4039 See C<sv_usepvn_mg>.
4045 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4047 SV_CHECK_THINKFIRST(sv);
4048 (void)SvUPGRADE(sv, SVt_PV);
4053 (void)SvOOK_off(sv);
4054 if (SvPVX(sv) && SvLEN(sv))
4055 Safefree(SvPVX(sv));
4056 Renew(ptr, len+1, char);
4059 SvLEN_set(sv, len+1);
4061 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4066 =for apidoc sv_usepvn_mg
4068 Like C<sv_usepvn>, but also handles 'set' magic.
4074 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4076 sv_usepvn(sv,ptr,len);
4081 =for apidoc sv_force_normal_flags
4083 Undo various types of fakery on an SV: if the PV is a shared string, make
4084 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4085 an xpvmg. The C<flags> parameter gets passed to C<sv_unref_flags()>
4086 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4092 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4094 if (SvREADONLY(sv)) {
4096 char *pvx = SvPVX(sv);
4097 STRLEN len = SvCUR(sv);
4098 U32 hash = SvUVX(sv);
4099 SvGROW(sv, len + 1);
4100 Move(pvx,SvPVX(sv),len,char);
4104 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
4106 else if (PL_curcop != &PL_compiling)
4107 Perl_croak(aTHX_ PL_no_modify);
4110 sv_unref_flags(sv, flags);
4111 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4116 =for apidoc sv_force_normal
4118 Undo various types of fakery on an SV: if the PV is a shared string, make
4119 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4120 an xpvmg. See also C<sv_force_normal_flags>.
4126 Perl_sv_force_normal(pTHX_ register SV *sv)
4128 sv_force_normal_flags(sv, 0);
4134 Efficient removal of characters from the beginning of the string buffer.
4135 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4136 the string buffer. The C<ptr> becomes the first character of the adjusted
4137 string. Uses the "OOK hack".
4143 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4145 register STRLEN delta;
4147 if (!ptr || !SvPOKp(sv))
4149 SV_CHECK_THINKFIRST(sv);
4150 if (SvTYPE(sv) < SVt_PVIV)
4151 sv_upgrade(sv,SVt_PVIV);
4154 if (!SvLEN(sv)) { /* make copy of shared string */
4155 char *pvx = SvPVX(sv);
4156 STRLEN len = SvCUR(sv);
4157 SvGROW(sv, len + 1);
4158 Move(pvx,SvPVX(sv),len,char);
4162 SvFLAGS(sv) |= SVf_OOK;
4164 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
4165 delta = ptr - SvPVX(sv);
4173 =for apidoc sv_catpvn
4175 Concatenates the string onto the end of the string which is in the SV. The
4176 C<len> indicates number of bytes to copy. If the SV has the UTF8
4177 status set, then the bytes appended should be valid UTF8.
4178 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4183 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
4184 for binary compatibility only
4187 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4189 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4193 =for apidoc sv_catpvn_flags
4195 Concatenates the string onto the end of the string which is in the SV. The
4196 C<len> indicates number of bytes to copy. If the SV has the UTF8
4197 status set, then the bytes appended should be valid UTF8.
4198 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4199 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4200 in terms of this function.
4206 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4211 dstr = SvPV_force_flags(dsv, dlen, flags);
4212 SvGROW(dsv, dlen + slen + 1);
4215 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4218 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4223 =for apidoc sv_catpvn_mg
4225 Like C<sv_catpvn>, but also handles 'set' magic.
4231 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4233 sv_catpvn(sv,ptr,len);
4238 =for apidoc sv_catsv
4240 Concatenates the string from SV C<ssv> onto the end of the string in
4241 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4242 not 'set' magic. See C<sv_catsv_mg>.
4246 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
4247 for binary compatibility only
4250 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4252 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4256 =for apidoc sv_catsv_flags
4258 Concatenates the string from SV C<ssv> onto the end of the string in
4259 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4260 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4261 and C<sv_catsv_nomg> are implemented in terms of this function.
4266 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4272 if ((spv = SvPV(ssv, slen))) {
4273 bool sutf8 = DO_UTF8(ssv);
4276 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4278 dutf8 = DO_UTF8(dsv);
4280 if (dutf8 != sutf8) {
4282 /* Not modifying source SV, so taking a temporary copy. */
4283 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4285 sv_utf8_upgrade(csv);
4286 spv = SvPV(csv, slen);
4289 sv_utf8_upgrade_nomg(dsv);
4291 sv_catpvn_nomg(dsv, spv, slen);
4296 =for apidoc sv_catsv_mg
4298 Like C<sv_catsv>, but also handles 'set' magic.
4304 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4311 =for apidoc sv_catpv
4313 Concatenates the string onto the end of the string which is in the SV.
4314 If the SV has the UTF8 status set, then the bytes appended should be
4315 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4320 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4322 register STRLEN len;
4328 junk = SvPV_force(sv, tlen);
4330 SvGROW(sv, tlen + len + 1);
4333 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4335 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4340 =for apidoc sv_catpv_mg
4342 Like C<sv_catpv>, but also handles 'set' magic.
4348 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4357 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4358 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4365 Perl_newSV(pTHX_ STRLEN len)
4371 sv_upgrade(sv, SVt_PV);
4372 SvGROW(sv, len + 1);
4378 =for apidoc sv_magic
4380 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4381 then adds a new magic item of type C<how> to the head of the magic list.
4383 C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
4389 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4393 if (SvREADONLY(sv)) {
4394 if (PL_curcop != &PL_compiling
4395 && how != PERL_MAGIC_regex_global
4396 && how != PERL_MAGIC_bm
4397 && how != PERL_MAGIC_fm
4398 && how != PERL_MAGIC_sv
4401 Perl_croak(aTHX_ PL_no_modify);
4404 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4405 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4406 if (how == PERL_MAGIC_taint)
4412 (void)SvUPGRADE(sv, SVt_PVMG);
4414 Newz(702,mg, 1, MAGIC);
4415 mg->mg_moremagic = SvMAGIC(sv);
4418 /* Some magic sontains a reference loop, where the sv and object refer to
4419 each other. To prevent a avoid a reference loop that would prevent such
4420 objects being freed, we look for such loops and if we find one we avoid
4421 incrementing the object refcount. */
4422 if (!obj || obj == sv ||
4423 how == PERL_MAGIC_arylen ||
4424 how == PERL_MAGIC_qr ||
4425 (SvTYPE(obj) == SVt_PVGV &&
4426 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4427 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4428 GvFORM(obj) == (CV*)sv)))
4433 mg->mg_obj = SvREFCNT_inc(obj);
4434 mg->mg_flags |= MGf_REFCOUNTED;
4437 mg->mg_len = namlen;
4440 mg->mg_ptr = savepvn(name, namlen);
4441 else if (namlen == HEf_SVKEY)
4442 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4447 mg->mg_virtual = &PL_vtbl_sv;
4449 case PERL_MAGIC_overload:
4450 mg->mg_virtual = &PL_vtbl_amagic;
4452 case PERL_MAGIC_overload_elem:
4453 mg->mg_virtual = &PL_vtbl_amagicelem;
4455 case PERL_MAGIC_overload_table:
4456 mg->mg_virtual = &PL_vtbl_ovrld;
4459 mg->mg_virtual = &PL_vtbl_bm;
4461 case PERL_MAGIC_regdata:
4462 mg->mg_virtual = &PL_vtbl_regdata;
4464 case PERL_MAGIC_regdatum:
4465 mg->mg_virtual = &PL_vtbl_regdatum;
4467 case PERL_MAGIC_env:
4468 mg->mg_virtual = &PL_vtbl_env;
4471 mg->mg_virtual = &PL_vtbl_fm;
4473 case PERL_MAGIC_envelem:
4474 mg->mg_virtual = &PL_vtbl_envelem;
4476 case PERL_MAGIC_regex_global:
4477 mg->mg_virtual = &PL_vtbl_mglob;
4479 case PERL_MAGIC_isa:
4480 mg->mg_virtual = &PL_vtbl_isa;
4482 case PERL_MAGIC_isaelem:
4483 mg->mg_virtual = &PL_vtbl_isaelem;
4485 case PERL_MAGIC_nkeys:
4486 mg->mg_virtual = &PL_vtbl_nkeys;
4488 case PERL_MAGIC_dbfile:
4492 case PERL_MAGIC_dbline:
4493 mg->mg_virtual = &PL_vtbl_dbline;
4496 case PERL_MAGIC_mutex:
4497 mg->mg_virtual = &PL_vtbl_mutex;
4499 #endif /* USE_THREADS */
4500 #ifdef USE_LOCALE_COLLATE
4501 case PERL_MAGIC_collxfrm:
4502 mg->mg_virtual = &PL_vtbl_collxfrm;
4504 #endif /* USE_LOCALE_COLLATE */
4505 case PERL_MAGIC_tied:
4506 mg->mg_virtual = &PL_vtbl_pack;
4508 case PERL_MAGIC_tiedelem:
4509 case PERL_MAGIC_tiedscalar:
4510 mg->mg_virtual = &PL_vtbl_packelem;
4513 mg->mg_virtual = &PL_vtbl_regexp;
4515 case PERL_MAGIC_sig:
4516 mg->mg_virtual = &PL_vtbl_sig;
4518 case PERL_MAGIC_sigelem:
4519 mg->mg_virtual = &PL_vtbl_sigelem;
4521 case PERL_MAGIC_taint:
4522 mg->mg_virtual = &PL_vtbl_taint;
4525 case PERL_MAGIC_uvar:
4526 mg->mg_virtual = &PL_vtbl_uvar;
4528 case PERL_MAGIC_vec:
4529 mg->mg_virtual = &PL_vtbl_vec;
4531 case PERL_MAGIC_substr:
4532 mg->mg_virtual = &PL_vtbl_substr;
4534 case PERL_MAGIC_defelem:
4535 mg->mg_virtual = &PL_vtbl_defelem;
4537 case PERL_MAGIC_glob:
4538 mg->mg_virtual = &PL_vtbl_glob;
4540 case PERL_MAGIC_arylen:
4541 mg->mg_virtual = &PL_vtbl_arylen;
4543 case PERL_MAGIC_pos:
4544 mg->mg_virtual = &PL_vtbl_pos;
4546 case PERL_MAGIC_backref:
4547 mg->mg_virtual = &PL_vtbl_backref;
4549 case PERL_MAGIC_ext:
4550 /* Reserved for use by extensions not perl internals. */
4551 /* Useful for attaching extension internal data to perl vars. */
4552 /* Note that multiple extensions may clash if magical scalars */
4553 /* etc holding private data from one are passed to another. */
4557 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4561 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4565 =for apidoc sv_unmagic
4567 Removes all magic of type C<type> from an SV.
4573 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4577 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4580 for (mg = *mgp; mg; mg = *mgp) {
4581 if (mg->mg_type == type) {
4582 MGVTBL* vtbl = mg->mg_virtual;
4583 *mgp = mg->mg_moremagic;
4584 if (vtbl && vtbl->svt_free)
4585 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4586 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4587 if (mg->mg_len >= 0)
4588 Safefree(mg->mg_ptr);
4589 else if (mg->mg_len == HEf_SVKEY)
4590 SvREFCNT_dec((SV*)mg->mg_ptr);
4592 if (mg->mg_flags & MGf_REFCOUNTED)
4593 SvREFCNT_dec(mg->mg_obj);
4597 mgp = &mg->mg_moremagic;
4601 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4608 =for apidoc sv_rvweaken
4610 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4611 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4612 push a back-reference to this RV onto the array of backreferences
4613 associated with that magic.
4619 Perl_sv_rvweaken(pTHX_ SV *sv)
4622 if (!SvOK(sv)) /* let undefs pass */
4625 Perl_croak(aTHX_ "Can't weaken a nonreference");
4626 else if (SvWEAKREF(sv)) {
4627 if (ckWARN(WARN_MISC))
4628 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4632 sv_add_backref(tsv, sv);
4638 /* Give tsv backref magic if it hasn't already got it, then push a
4639 * back-reference to sv onto the array associated with the backref magic.
4643 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4647 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4648 av = (AV*)mg->mg_obj;
4651 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4652 SvREFCNT_dec(av); /* for sv_magic */
4657 /* delete a back-reference to ourselves from the backref magic associated
4658 * with the SV we point to.
4662 S_sv_del_backref(pTHX_ SV *sv)
4669 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4670 Perl_croak(aTHX_ "panic: del_backref");
4671 av = (AV *)mg->mg_obj;
4676 svp[i] = &PL_sv_undef; /* XXX */
4683 =for apidoc sv_insert
4685 Inserts a string at the specified offset/length within the SV. Similar to
4686 the Perl substr() function.
4692 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4696 register char *midend;
4697 register char *bigend;
4703 Perl_croak(aTHX_ "Can't modify non-existent substring");
4704 SvPV_force(bigstr, curlen);
4705 (void)SvPOK_only_UTF8(bigstr);
4706 if (offset + len > curlen) {
4707 SvGROW(bigstr, offset+len+1);
4708 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4709 SvCUR_set(bigstr, offset+len);
4713 i = littlelen - len;
4714 if (i > 0) { /* string might grow */
4715 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4716 mid = big + offset + len;
4717 midend = bigend = big + SvCUR(bigstr);
4720 while (midend > mid) /* shove everything down */
4721 *--bigend = *--midend;
4722 Move(little,big+offset,littlelen,char);
4728 Move(little,SvPVX(bigstr)+offset,len,char);
4733 big = SvPVX(bigstr);
4736 bigend = big + SvCUR(bigstr);
4738 if (midend > bigend)
4739 Perl_croak(aTHX_ "panic: sv_insert");
4741 if (mid - big > bigend - midend) { /* faster to shorten from end */
4743 Move(little, mid, littlelen,char);
4746 i = bigend - midend;
4748 Move(midend, mid, i,char);
4752 SvCUR_set(bigstr, mid - big);
4755 else if ((i = mid - big)) { /* faster from front */
4756 midend -= littlelen;
4758 sv_chop(bigstr,midend-i);
4763 Move(little, mid, littlelen,char);
4765 else if (littlelen) {
4766 midend -= littlelen;
4767 sv_chop(bigstr,midend);
4768 Move(little,midend,littlelen,char);
4771 sv_chop(bigstr,midend);
4777 =for apidoc sv_replace
4779 Make the first argument a copy of the second, then delete the original.
4780 The target SV physically takes over ownership of the body of the source SV
4781 and inherits its flags; however, the target keeps any magic it owns,
4782 and any magic in the source is discarded.
4783 Note that this is a rather specialist SV copying operation; most of the
4784 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
4790 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4792 U32 refcnt = SvREFCNT(sv);
4793 SV_CHECK_THINKFIRST(sv);
4794 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4795 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4796 if (SvMAGICAL(sv)) {
4800 sv_upgrade(nsv, SVt_PVMG);
4801 SvMAGIC(nsv) = SvMAGIC(sv);
4802 SvFLAGS(nsv) |= SvMAGICAL(sv);
4808 assert(!SvREFCNT(sv));
4809 StructCopy(nsv,sv,SV);
4810 SvREFCNT(sv) = refcnt;
4811 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4816 =for apidoc sv_clear
4818 Clear an SV: call any destructors, free up any memory used by the body,
4819 and free the body itself. The SV's head is I<not> freed, although
4820 its type is set to all 1's so that it won't inadvertently be assumed
4821 to be live during global destruction etc.
4822 This function should only be called when REFCNT is zero. Most of the time
4823 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
4830 Perl_sv_clear(pTHX_ register SV *sv)
4834 assert(SvREFCNT(sv) == 0);
4837 if (PL_defstash) { /* Still have a symbol table? */
4842 Zero(&tmpref, 1, SV);
4843 sv_upgrade(&tmpref, SVt_RV);
4845 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4846 SvREFCNT(&tmpref) = 1;
4849 stash = SvSTASH(sv);
4850 destructor = StashHANDLER(stash,DESTROY);
4853 PUSHSTACKi(PERLSI_DESTROY);
4854 SvRV(&tmpref) = SvREFCNT_inc(sv);
4859 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4865 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4867 del_XRV(SvANY(&tmpref));
4870 if (PL_in_clean_objs)
4871 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4873 /* DESTROY gave object new lease on life */
4879 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4880 SvOBJECT_off(sv); /* Curse the object. */
4881 if (SvTYPE(sv) != SVt_PVIO)
4882 --PL_sv_objcount; /* XXX Might want something more general */
4885 if (SvTYPE(sv) >= SVt_PVMG) {
4888 if (SvFLAGS(sv) & SVpad_TYPED)
4889 SvREFCNT_dec(SvSTASH(sv));
4892 switch (SvTYPE(sv)) {
4895 IoIFP(sv) != PerlIO_stdin() &&
4896 IoIFP(sv) != PerlIO_stdout() &&
4897 IoIFP(sv) != PerlIO_stderr())
4899 io_close((IO*)sv, FALSE);
4901 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4902 PerlDir_close(IoDIRP(sv));
4903 IoDIRP(sv) = (DIR*)NULL;
4904 Safefree(IoTOP_NAME(sv));
4905 Safefree(IoFMT_NAME(sv));
4906 Safefree(IoBOTTOM_NAME(sv));
4921 SvREFCNT_dec(LvTARG(sv));
4925 Safefree(GvNAME(sv));
4926 /* cannot decrease stash refcount yet, as we might recursively delete
4927 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4928 of stash until current sv is completely gone.
4929 -- JohnPC, 27 Mar 1998 */
4930 stash = GvSTASH(sv);
4936 (void)SvOOK_off(sv);
4944 SvREFCNT_dec(SvRV(sv));
4946 else if (SvPVX(sv) && SvLEN(sv))
4947 Safefree(SvPVX(sv));
4948 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4949 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4961 switch (SvTYPE(sv)) {
4977 del_XPVIV(SvANY(sv));
4980 del_XPVNV(SvANY(sv));
4983 del_XPVMG(SvANY(sv));
4986 del_XPVLV(SvANY(sv));
4989 del_XPVAV(SvANY(sv));
4992 del_XPVHV(SvANY(sv));
4995 del_XPVCV(SvANY(sv));
4998 del_XPVGV(SvANY(sv));
4999 /* code duplication for increased performance. */
5000 SvFLAGS(sv) &= SVf_BREAK;
5001 SvFLAGS(sv) |= SVTYPEMASK;
5002 /* decrease refcount of the stash that owns this GV, if any */
5004 SvREFCNT_dec(stash);
5005 return; /* not break, SvFLAGS reset already happened */
5007 del_XPVBM(SvANY(sv));
5010 del_XPVFM(SvANY(sv));
5013 del_XPVIO(SvANY(sv));
5016 SvFLAGS(sv) &= SVf_BREAK;
5017 SvFLAGS(sv) |= SVTYPEMASK;
5021 =for apidoc sv_newref
5023 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5030 Perl_sv_newref(pTHX_ SV *sv)
5033 ATOMIC_INC(SvREFCNT(sv));
5040 Decrement an SV's reference count, and if it drops to zero, call
5041 C<sv_clear> to invoke destructors and free up any memory used by
5042 the body; finally, deallocate the SV's head itself.
5043 Normally called via a wrapper macro C<SvREFCNT_dec>.
5049 Perl_sv_free(pTHX_ SV *sv)
5051 int refcount_is_zero;
5055 if (SvREFCNT(sv) == 0) {
5056 if (SvFLAGS(sv) & SVf_BREAK)
5057 /* this SV's refcnt has been artificially decremented to
5058 * trigger cleanup */
5060 if (PL_in_clean_all) /* All is fair */
5062 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5063 /* make sure SvREFCNT(sv)==0 happens very seldom */
5064 SvREFCNT(sv) = (~(U32)0)/2;
5067 if (ckWARN_d(WARN_INTERNAL))
5068 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
5071 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5072 if (!refcount_is_zero)
5076 if (ckWARN_d(WARN_DEBUGGING))
5077 Perl_warner(aTHX_ WARN_DEBUGGING,
5078 "Attempt to free temp prematurely: SV 0x%"UVxf,
5083 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5084 /* make sure SvREFCNT(sv)==0 happens very seldom */
5085 SvREFCNT(sv) = (~(U32)0)/2;
5096 Returns the length of the string in the SV. Handles magic and type
5097 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5103 Perl_sv_len(pTHX_ register SV *sv)
5112 len = mg_length(sv);
5114 junk = SvPV(sv, len);
5119 =for apidoc sv_len_utf8
5121 Returns the number of characters in the string in an SV, counting wide
5122 UTF8 bytes as a single character. Handles magic and type coercion.
5128 Perl_sv_len_utf8(pTHX_ register SV *sv)
5134 return mg_length(sv);
5138 U8 *s = (U8*)SvPV(sv, len);
5140 return Perl_utf8_length(aTHX_ s, s + len);
5145 =for apidoc sv_pos_u2b
5147 Converts the value pointed to by offsetp from a count of UTF8 chars from
5148 the start of the string, to a count of the equivalent number of bytes; if
5149 lenp is non-zero, it does the same to lenp, but this time starting from
5150 the offset, rather than from the start of the string. Handles magic and
5157 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5162 I32 uoffset = *offsetp;
5168 start = s = (U8*)SvPV(sv, len);
5170 while (s < send && uoffset--)
5174 *offsetp = s - start;
5178 while (s < send && ulen--)
5188 =for apidoc sv_pos_b2u
5190 Converts the value pointed to by offsetp from a count of bytes from the
5191 start of the string, to a count of the equivalent number of UTF8 chars.
5192 Handles magic and type coercion.
5198 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
5207 s = (U8*)SvPV(sv, len);
5209 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5210 send = s + *offsetp;
5214 /* Call utf8n_to_uvchr() to validate the sequence */
5215 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5230 Returns a boolean indicating whether the strings in the two SVs are
5231 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5232 coerce its args to strings if necessary.
5238 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5252 pv1 = SvPV(sv1, cur1);
5259 pv2 = SvPV(sv2, cur2);
5261 /* do not utf8ize the comparands as a side-effect */
5262 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5263 bool is_utf8 = TRUE;
5264 /* UTF-8ness differs */
5265 if (PL_hints & HINT_UTF8_DISTINCT)
5269 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
5270 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
5275 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
5276 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
5281 /* Downgrade not possible - cannot be eq */
5287 eq = memEQ(pv1, pv2, cur1);
5298 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
5299 string in C<sv1> is less than, equal to, or greater than the string in
5300 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5301 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
5307 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5312 bool pv1tmp = FALSE;
5313 bool pv2tmp = FALSE;
5320 pv1 = SvPV(sv1, cur1);
5327 pv2 = SvPV(sv2, cur2);
5329 /* do not utf8ize the comparands as a side-effect */
5330 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5331 if (PL_hints & HINT_UTF8_DISTINCT)
5332 return SvUTF8(sv1) ? 1 : -1;
5335 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5339 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5345 cmp = cur2 ? -1 : 0;
5349 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5352 cmp = retval < 0 ? -1 : 1;
5353 } else if (cur1 == cur2) {
5356 cmp = cur1 < cur2 ? -1 : 1;
5369 =for apidoc sv_cmp_locale
5371 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5372 'use bytes' aware, handles get magic, and will coerce its args to strings
5373 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
5379 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5381 #ifdef USE_LOCALE_COLLATE
5387 if (PL_collation_standard)
5391 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5393 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5395 if (!pv1 || !len1) {
5406 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5409 return retval < 0 ? -1 : 1;
5412 * When the result of collation is equality, that doesn't mean
5413 * that there are no differences -- some locales exclude some
5414 * characters from consideration. So to avoid false equalities,
5415 * we use the raw string as a tiebreaker.
5421 #endif /* USE_LOCALE_COLLATE */
5423 return sv_cmp(sv1, sv2);
5427 #ifdef USE_LOCALE_COLLATE
5430 =for apidoc sv_collxfrm
5432 Add Collate Transform magic to an SV if it doesn't already have it.
5434 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5435 scalar data of the variable, but transformed to such a format that a normal
5436 memory comparison can be used to compare the data according to the locale
5443 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5447 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5448 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5453 Safefree(mg->mg_ptr);
5455 if ((xf = mem_collxfrm(s, len, &xlen))) {
5456 if (SvREADONLY(sv)) {
5459 return xf + sizeof(PL_collation_ix);
5462 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5463 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5476 if (mg && mg->mg_ptr) {
5478 return mg->mg_ptr + sizeof(PL_collation_ix);
5486 #endif /* USE_LOCALE_COLLATE */
5491 Get a line from the filehandle and store it into the SV, optionally
5492 appending to the currently-stored string.
5498 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5502 register STDCHAR rslast;
5503 register STDCHAR *bp;
5507 SV_CHECK_THINKFIRST(sv);
5508 (void)SvUPGRADE(sv, SVt_PV);
5512 if (RsSNARF(PL_rs)) {
5516 else if (RsRECORD(PL_rs)) {
5517 I32 recsize, bytesread;
5520 /* Grab the size of the record we're getting */
5521 recsize = SvIV(SvRV(PL_rs));
5522 (void)SvPOK_only(sv); /* Validate pointer */
5523 buffer = SvGROW(sv, recsize + 1);
5526 /* VMS wants read instead of fread, because fread doesn't respect */
5527 /* RMS record boundaries. This is not necessarily a good thing to be */
5528 /* doing, but we've got no other real choice */
5529 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5531 bytesread = PerlIO_read(fp, buffer, recsize);
5533 SvCUR_set(sv, bytesread);
5534 buffer[bytesread] = '\0';
5535 if (PerlIO_isutf8(fp))
5539 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5541 else if (RsPARA(PL_rs)) {
5546 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5547 if (PerlIO_isutf8(fp)) {
5548 rsptr = SvPVutf8(PL_rs, rslen);
5551 if (SvUTF8(PL_rs)) {
5552 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5553 Perl_croak(aTHX_ "Wide character in $/");
5556 rsptr = SvPV(PL_rs, rslen);
5560 rslast = rslen ? rsptr[rslen - 1] : '\0';
5562 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5563 do { /* to make sure file boundaries work right */
5566 i = PerlIO_getc(fp);
5570 PerlIO_ungetc(fp,i);
5576 /* See if we know enough about I/O mechanism to cheat it ! */
5578 /* This used to be #ifdef test - it is made run-time test for ease
5579 of abstracting out stdio interface. One call should be cheap
5580 enough here - and may even be a macro allowing compile
5584 if (PerlIO_fast_gets(fp)) {
5587 * We're going to steal some values from the stdio struct
5588 * and put EVERYTHING in the innermost loop into registers.
5590 register STDCHAR *ptr;
5594 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5595 /* An ungetc()d char is handled separately from the regular
5596 * buffer, so we getc() it back out and stuff it in the buffer.
5598 i = PerlIO_getc(fp);
5599 if (i == EOF) return 0;
5600 *(--((*fp)->_ptr)) = (unsigned char) i;
5604 /* Here is some breathtakingly efficient cheating */
5606 cnt = PerlIO_get_cnt(fp); /* get count into register */
5607 (void)SvPOK_only(sv); /* validate pointer */
5608 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5609 if (cnt > 80 && SvLEN(sv) > append) {
5610 shortbuffered = cnt - SvLEN(sv) + append + 1;
5611 cnt -= shortbuffered;
5615 /* remember that cnt can be negative */
5616 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5621 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5622 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5623 DEBUG_P(PerlIO_printf(Perl_debug_log,
5624 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5625 DEBUG_P(PerlIO_printf(Perl_debug_log,
5626 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5627 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5628 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5633 while (cnt > 0) { /* this | eat */
5635 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5636 goto thats_all_folks; /* screams | sed :-) */
5640 Copy(ptr, bp, cnt, char); /* this | eat */
5641 bp += cnt; /* screams | dust */
5642 ptr += cnt; /* louder | sed :-) */
5647 if (shortbuffered) { /* oh well, must extend */
5648 cnt = shortbuffered;
5650 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5652 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5653 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5657 DEBUG_P(PerlIO_printf(Perl_debug_log,
5658 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5659 PTR2UV(ptr),(long)cnt));
5660 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5661 DEBUG_P(PerlIO_printf(Perl_debug_log,
5662 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5663 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5664 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5665 /* This used to call 'filbuf' in stdio form, but as that behaves like
5666 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5667 another abstraction. */
5668 i = PerlIO_getc(fp); /* get more characters */
5669 DEBUG_P(PerlIO_printf(Perl_debug_log,
5670 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5671 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5672 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5673 cnt = PerlIO_get_cnt(fp);
5674 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5675 DEBUG_P(PerlIO_printf(Perl_debug_log,
5676 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5678 if (i == EOF) /* all done for ever? */
5679 goto thats_really_all_folks;
5681 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5683 SvGROW(sv, bpx + cnt + 2);
5684 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5686 *bp++ = i; /* store character from PerlIO_getc */
5688 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5689 goto thats_all_folks;
5693 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5694 memNE((char*)bp - rslen, rsptr, rslen))
5695 goto screamer; /* go back to the fray */
5696 thats_really_all_folks:
5698 cnt += shortbuffered;
5699 DEBUG_P(PerlIO_printf(Perl_debug_log,
5700 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5701 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5702 DEBUG_P(PerlIO_printf(Perl_debug_log,
5703 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5704 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5705 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5707 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5708 DEBUG_P(PerlIO_printf(Perl_debug_log,
5709 "Screamer: done, len=%ld, string=|%.*s|\n",
5710 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5715 /*The big, slow, and stupid way */
5718 /* Need to work around EPOC SDK features */
5719 /* On WINS: MS VC5 generates calls to _chkstk, */
5720 /* if a `large' stack frame is allocated */
5721 /* gcc on MARM does not generate calls like these */
5727 register STDCHAR *bpe = buf + sizeof(buf);
5729 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5730 ; /* keep reading */
5734 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5735 /* Accomodate broken VAXC compiler, which applies U8 cast to
5736 * both args of ?: operator, causing EOF to change into 255
5738 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5742 sv_catpvn(sv, (char *) buf, cnt);
5744 sv_setpvn(sv, (char *) buf, cnt);
5746 if (i != EOF && /* joy */
5748 SvCUR(sv) < rslen ||
5749 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5753 * If we're reading from a TTY and we get a short read,
5754 * indicating that the user hit his EOF character, we need
5755 * to notice it now, because if we try to read from the TTY
5756 * again, the EOF condition will disappear.
5758 * The comparison of cnt to sizeof(buf) is an optimization
5759 * that prevents unnecessary calls to feof().
5763 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5768 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5769 while (i != EOF) { /* to make sure file boundaries work right */
5770 i = PerlIO_getc(fp);
5772 PerlIO_ungetc(fp,i);
5778 if (PerlIO_isutf8(fp))
5783 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5789 Auto-increment of the value in the SV, doing string to numeric conversion
5790 if necessary. Handles 'get' magic.
5796 Perl_sv_inc(pTHX_ register SV *sv)
5805 if (SvTHINKFIRST(sv)) {
5806 if (SvREADONLY(sv)) {
5807 if (PL_curcop != &PL_compiling)
5808 Perl_croak(aTHX_ PL_no_modify);
5812 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5814 i = PTR2IV(SvRV(sv));
5819 flags = SvFLAGS(sv);
5820 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5821 /* It's (privately or publicly) a float, but not tested as an
5822 integer, so test it to see. */
5824 flags = SvFLAGS(sv);
5826 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5827 /* It's publicly an integer, or privately an integer-not-float */
5830 if (SvUVX(sv) == UV_MAX)
5831 sv_setnv(sv, (NV)UV_MAX + 1.0);
5833 (void)SvIOK_only_UV(sv);
5836 if (SvIVX(sv) == IV_MAX)
5837 sv_setuv(sv, (UV)IV_MAX + 1);
5839 (void)SvIOK_only(sv);
5845 if (flags & SVp_NOK) {
5846 (void)SvNOK_only(sv);
5851 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5852 if ((flags & SVTYPEMASK) < SVt_PVIV)
5853 sv_upgrade(sv, SVt_IV);
5854 (void)SvIOK_only(sv);
5859 while (isALPHA(*d)) d++;
5860 while (isDIGIT(*d)) d++;
5862 #ifdef PERL_PRESERVE_IVUV
5863 /* Got to punt this an an integer if needs be, but we don't issue
5864 warnings. Probably ought to make the sv_iv_please() that does
5865 the conversion if possible, and silently. */
5866 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5867 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5868 /* Need to try really hard to see if it's an integer.
5869 9.22337203685478e+18 is an integer.
5870 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5871 so $a="9.22337203685478e+18"; $a+0; $a++
5872 needs to be the same as $a="9.22337203685478e+18"; $a++
5879 /* sv_2iv *should* have made this an NV */
5880 if (flags & SVp_NOK) {
5881 (void)SvNOK_only(sv);
5885 /* I don't think we can get here. Maybe I should assert this
5886 And if we do get here I suspect that sv_setnv will croak. NWC
5888 #if defined(USE_LONG_DOUBLE)
5889 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",
5890 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5892 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5893 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5896 #endif /* PERL_PRESERVE_IVUV */
5897 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5901 while (d >= SvPVX(sv)) {
5909 /* MKS: The original code here died if letters weren't consecutive.
5910 * at least it didn't have to worry about non-C locales. The
5911 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5912 * arranged in order (although not consecutively) and that only
5913 * [A-Za-z] are accepted by isALPHA in the C locale.
5915 if (*d != 'z' && *d != 'Z') {
5916 do { ++*d; } while (!isALPHA(*d));
5919 *(d--) -= 'z' - 'a';
5924 *(d--) -= 'z' - 'a' + 1;
5928 /* oh,oh, the number grew */
5929 SvGROW(sv, SvCUR(sv) + 2);
5931 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5942 Auto-decrement of the value in the SV, doing string to numeric conversion
5943 if necessary. Handles 'get' magic.
5949 Perl_sv_dec(pTHX_ register SV *sv)
5957 if (SvTHINKFIRST(sv)) {
5958 if (SvREADONLY(sv)) {
5959 if (PL_curcop != &PL_compiling)
5960 Perl_croak(aTHX_ PL_no_modify);
5964 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5966 i = PTR2IV(SvRV(sv));
5971 /* Unlike sv_inc we don't have to worry about string-never-numbers
5972 and keeping them magic. But we mustn't warn on punting */
5973 flags = SvFLAGS(sv);
5974 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5975 /* It's publicly an integer, or privately an integer-not-float */
5978 if (SvUVX(sv) == 0) {
5979 (void)SvIOK_only(sv);
5983 (void)SvIOK_only_UV(sv);
5987 if (SvIVX(sv) == IV_MIN)
5988 sv_setnv(sv, (NV)IV_MIN - 1.0);
5990 (void)SvIOK_only(sv);
5996 if (flags & SVp_NOK) {
5998 (void)SvNOK_only(sv);
6001 if (!(flags & SVp_POK)) {
6002 if ((flags & SVTYPEMASK) < SVt_PVNV)
6003 sv_upgrade(sv, SVt_NV);
6005 (void)SvNOK_only(sv);
6008 #ifdef PERL_PRESERVE_IVUV
6010 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6011 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6012 /* Need to try really hard to see if it's an integer.
6013 9.22337203685478e+18 is an integer.
6014 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6015 so $a="9.22337203685478e+18"; $a+0; $a--
6016 needs to be the same as $a="9.22337203685478e+18"; $a--
6023 /* sv_2iv *should* have made this an NV */
6024 if (flags & SVp_NOK) {
6025 (void)SvNOK_only(sv);
6029 /* I don't think we can get here. Maybe I should assert this
6030 And if we do get here I suspect that sv_setnv will croak. NWC
6032 #if defined(USE_LONG_DOUBLE)
6033 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",
6034 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6036 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
6037 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6041 #endif /* PERL_PRESERVE_IVUV */
6042 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
6046 =for apidoc sv_mortalcopy
6048 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6049 The new SV is marked as mortal. It will be destroyed when the current
6050 context ends. See also C<sv_newmortal> and C<sv_2mortal>.
6055 /* Make a string that will exist for the duration of the expression
6056 * evaluation. Actually, it may have to last longer than that, but
6057 * hopefully we won't free it until it has been assigned to a
6058 * permanent location. */
6061 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6066 sv_setsv(sv,oldstr);
6068 PL_tmps_stack[++PL_tmps_ix] = sv;
6074 =for apidoc sv_newmortal
6076 Creates a new null SV which is mortal. The reference count of the SV is
6077 set to 1. It will be destroyed when the current context ends. See
6078 also C<sv_mortalcopy> and C<sv_2mortal>.
6084 Perl_sv_newmortal(pTHX)
6089 SvFLAGS(sv) = SVs_TEMP;
6091 PL_tmps_stack[++PL_tmps_ix] = sv;
6096 =for apidoc sv_2mortal
6098 Marks an existing SV as mortal. The SV will be destroyed when the current
6099 context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
6105 Perl_sv_2mortal(pTHX_ register SV *sv)
6109 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6112 PL_tmps_stack[++PL_tmps_ix] = sv;
6120 Creates a new SV and copies a string into it. The reference count for the
6121 SV is set to 1. If C<len> is zero, Perl will compute the length using
6122 strlen(). For efficiency, consider using C<newSVpvn> instead.
6128 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6135 sv_setpvn(sv,s,len);
6140 =for apidoc newSVpvn
6142 Creates a new SV and copies a string into it. The reference count for the
6143 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
6144 string. You are responsible for ensuring that the source string is at least
6151 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6156 sv_setpvn(sv,s,len);
6161 =for apidoc newSVpvn_share
6163 Creates a new SV with its SvPVX pointing to a shared string in the string
6164 table. If the string does not already exist in the table, it is created
6165 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
6166 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6167 otherwise the hash is computed. The idea here is that as the string table
6168 is used for shared hash keys these strings will have SvPVX == HeKEY and
6169 hash lookup will avoid string compare.
6175 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6178 bool is_utf8 = FALSE;
6183 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
6184 STRLEN tmplen = len;
6185 /* See the note in hv.c:hv_fetch() --jhi */
6186 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6190 PERL_HASH(hash, src, len);
6192 sv_upgrade(sv, SVt_PVIV);
6193 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6206 #if defined(PERL_IMPLICIT_CONTEXT)
6208 /* pTHX_ magic can't cope with varargs, so this is a no-context
6209 * version of the main function, (which may itself be aliased to us).
6210 * Don't access this version directly.
6214 Perl_newSVpvf_nocontext(const char* pat, ...)
6219 va_start(args, pat);
6220 sv = vnewSVpvf(pat, &args);
6227 =for apidoc newSVpvf
6229 Creates a new SV and initializes it with the string formatted like
6236 Perl_newSVpvf(pTHX_ const char* pat, ...)
6240 va_start(args, pat);
6241 sv = vnewSVpvf(pat, &args);
6246 /* backend for newSVpvf() and newSVpvf_nocontext() */
6249 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6253 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6260 Creates a new SV and copies a floating point value into it.
6261 The reference count for the SV is set to 1.
6267 Perl_newSVnv(pTHX_ NV n)
6279 Creates a new SV and copies an integer into it. The reference count for the
6286 Perl_newSViv(pTHX_ IV i)
6298 Creates a new SV and copies an unsigned integer into it.
6299 The reference count for the SV is set to 1.
6305 Perl_newSVuv(pTHX_ UV u)
6315 =for apidoc newRV_noinc
6317 Creates an RV wrapper for an SV. The reference count for the original
6318 SV is B<not> incremented.
6324 Perl_newRV_noinc(pTHX_ SV *tmpRef)
6329 sv_upgrade(sv, SVt_RV);
6336 /* newRV_inc is the official function name to use now.
6337 * newRV_inc is in fact #defined to newRV in sv.h
6341 Perl_newRV(pTHX_ SV *tmpRef)
6343 return newRV_noinc(SvREFCNT_inc(tmpRef));
6349 Creates a new SV which is an exact duplicate of the original SV.
6356 Perl_newSVsv(pTHX_ register SV *old)
6362 if (SvTYPE(old) == SVTYPEMASK) {
6363 if (ckWARN_d(WARN_INTERNAL))
6364 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6379 =for apidoc sv_reset
6381 Underlying implementation for the C<reset> Perl function.
6382 Note that the perl-level function is vaguely deprecated.
6388 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6396 char todo[PERL_UCHAR_MAX+1];
6401 if (!*s) { /* reset ?? searches */
6402 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6403 pm->op_pmdynflags &= ~PMdf_USED;
6408 /* reset variables */
6410 if (!HvARRAY(stash))
6413 Zero(todo, 256, char);
6415 i = (unsigned char)*s;
6419 max = (unsigned char)*s++;
6420 for ( ; i <= max; i++) {
6423 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6424 for (entry = HvARRAY(stash)[i];
6426 entry = HeNEXT(entry))
6428 if (!todo[(U8)*HeKEY(entry)])
6430 gv = (GV*)HeVAL(entry);
6432 if (SvTHINKFIRST(sv)) {
6433 if (!SvREADONLY(sv) && SvROK(sv))
6438 if (SvTYPE(sv) >= SVt_PV) {
6440 if (SvPVX(sv) != Nullch)
6447 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6449 #ifdef USE_ENVIRON_ARRAY
6451 environ[0] = Nullch;
6462 Using various gambits, try to get an IO from an SV: the IO slot if its a
6463 GV; or the recursive result if we're an RV; or the IO slot of the symbol
6464 named after the PV if we're a string.
6470 Perl_sv_2io(pTHX_ SV *sv)
6476 switch (SvTYPE(sv)) {
6484 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6488 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6490 return sv_2io(SvRV(sv));
6491 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6497 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6506 Using various gambits, try to get a CV from an SV; in addition, try if
6507 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
6513 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6520 return *gvp = Nullgv, Nullcv;
6521 switch (SvTYPE(sv)) {
6540 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6541 tryAMAGICunDEREF(to_cv);
6544 if (SvTYPE(sv) == SVt_PVCV) {
6553 Perl_croak(aTHX_ "Not a subroutine reference");
6558 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6564 if (lref && !GvCVu(gv)) {
6567 tmpsv = NEWSV(704,0);
6568 gv_efullname3(tmpsv, gv, Nullch);
6569 /* XXX this is probably not what they think they're getting.
6570 * It has the same effect as "sub name;", i.e. just a forward
6572 newSUB(start_subparse(FALSE, 0),
6573 newSVOP(OP_CONST, 0, tmpsv),
6578 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6587 Returns true if the SV has a true value by Perl's rules.
6588 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
6589 instead use an in-line version.
6595 Perl_sv_true(pTHX_ register SV *sv)
6601 if ((tXpv = (XPV*)SvANY(sv)) &&
6602 (tXpv->xpv_cur > 1 ||
6603 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6610 return SvIVX(sv) != 0;
6613 return SvNVX(sv) != 0.0;
6615 return sv_2bool(sv);
6623 A private implementation of the C<SvIVx> macro for compilers which can't
6624 cope with complex macro expressions. Always use the macro instead.
6630 Perl_sv_iv(pTHX_ register SV *sv)
6634 return (IV)SvUVX(sv);
6643 A private implementation of the C<SvUVx> macro for compilers which can't
6644 cope with complex macro expressions. Always use the macro instead.
6650 Perl_sv_uv(pTHX_ register SV *sv)
6655 return (UV)SvIVX(sv);
6663 A private implementation of the C<SvNVx> macro for compilers which can't
6664 cope with complex macro expressions. Always use the macro instead.
6670 Perl_sv_nv(pTHX_ register SV *sv)
6680 A private implementation of the C<SvPV_nolen> macro for compilers which can't
6681 cope with complex macro expressions. Always use the macro instead.
6687 Perl_sv_pv(pTHX_ SV *sv)
6694 return sv_2pv(sv, &n_a);
6700 A private implementation of the C<SvPV> macro for compilers which can't
6701 cope with complex macro expressions. Always use the macro instead.
6707 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6713 return sv_2pv(sv, lp);
6717 =for apidoc sv_pvn_force
6719 Get a sensible string out of the SV somehow.
6720 A private implementation of the C<SvPV_force> macro for compilers which
6721 can't cope with complex macro expressions. Always use the macro instead.
6727 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6729 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6733 =for apidoc sv_pvn_force_flags
6735 Get a sensible string out of the SV somehow.
6736 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6737 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6738 implemented in terms of this function.
6739 You normally want to use the various wrapper macros instead: see
6740 C<SvPV_force> and C<SvPV_force_nomg>
6746 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6750 if (SvTHINKFIRST(sv) && !SvROK(sv))
6751 sv_force_normal(sv);
6757 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6758 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6759 PL_op_name[PL_op->op_type]);
6762 s = sv_2pv_flags(sv, lp, flags);
6763 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6768 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6769 SvGROW(sv, len + 1);
6770 Move(s,SvPVX(sv),len,char);
6775 SvPOK_on(sv); /* validate pointer */
6777 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6778 PTR2UV(sv),SvPVX(sv)));
6785 =for apidoc sv_pvbyte
6787 A private implementation of the C<SvPVbyte_nolen> macro for compilers
6788 which can't cope with complex macro expressions. Always use the macro
6795 Perl_sv_pvbyte(pTHX_ SV *sv)
6797 sv_utf8_downgrade(sv,0);
6802 =for apidoc sv_pvbyten
6804 A private implementation of the C<SvPVbyte> macro for compilers
6805 which can't cope with complex macro expressions. Always use the macro
6812 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6814 sv_utf8_downgrade(sv,0);
6815 return sv_pvn(sv,lp);
6819 =for apidoc sv_pvbyten_force
6821 A private implementation of the C<SvPVbytex_force> macro for compilers
6822 which can't cope with complex macro expressions. Always use the macro
6829 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6831 sv_utf8_downgrade(sv,0);
6832 return sv_pvn_force(sv,lp);
6836 =for apidoc sv_pvutf8
6838 A private implementation of the C<SvPVutf8_nolen> macro for compilers
6839 which can't cope with complex macro expressions. Always use the macro
6846 Perl_sv_pvutf8(pTHX_ SV *sv)
6848 sv_utf8_upgrade(sv);
6853 =for apidoc sv_pvutf8n
6855 A private implementation of the C<SvPVutf8> macro for compilers
6856 which can't cope with complex macro expressions. Always use the macro
6863 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6865 sv_utf8_upgrade(sv);
6866 return sv_pvn(sv,lp);
6870 =for apidoc sv_pvutf8n_force
6872 A private implementation of the C<SvPVutf8_force> macro for compilers
6873 which can't cope with complex macro expressions. Always use the macro
6880 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6882 sv_utf8_upgrade(sv);
6883 return sv_pvn_force(sv,lp);
6887 =for apidoc sv_reftype
6889 Returns a string describing what the SV is a reference to.
6895 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6897 if (ob && SvOBJECT(sv))
6898 return HvNAME(SvSTASH(sv));
6900 switch (SvTYPE(sv)) {
6914 case SVt_PVLV: return "LVALUE";
6915 case SVt_PVAV: return "ARRAY";
6916 case SVt_PVHV: return "HASH";
6917 case SVt_PVCV: return "CODE";
6918 case SVt_PVGV: return "GLOB";
6919 case SVt_PVFM: return "FORMAT";
6920 case SVt_PVIO: return "IO";
6921 default: return "UNKNOWN";
6927 =for apidoc sv_isobject
6929 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6930 object. If the SV is not an RV, or if the object is not blessed, then this
6937 Perl_sv_isobject(pTHX_ SV *sv)
6954 Returns a boolean indicating whether the SV is blessed into the specified
6955 class. This does not check for subtypes; use C<sv_derived_from> to verify
6956 an inheritance relationship.
6962 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6974 return strEQ(HvNAME(SvSTASH(sv)), name);
6980 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6981 it will be upgraded to one. If C<classname> is non-null then the new SV will
6982 be blessed in the specified package. The new SV is returned and its
6983 reference count is 1.
6989 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6995 SV_CHECK_THINKFIRST(rv);
6998 if (SvTYPE(rv) >= SVt_PVMG) {
6999 U32 refcnt = SvREFCNT(rv);
7003 SvREFCNT(rv) = refcnt;
7006 if (SvTYPE(rv) < SVt_RV)
7007 sv_upgrade(rv, SVt_RV);
7008 else if (SvTYPE(rv) > SVt_RV) {
7009 (void)SvOOK_off(rv);
7010 if (SvPVX(rv) && SvLEN(rv))
7011 Safefree(SvPVX(rv));
7021 HV* stash = gv_stashpv(classname, TRUE);
7022 (void)sv_bless(rv, stash);
7028 =for apidoc sv_setref_pv
7030 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7031 argument will be upgraded to an RV. That RV will be modified to point to
7032 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7033 into the SV. The C<classname> argument indicates the package for the
7034 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7035 will be returned and will have a reference count of 1.
7037 Do not use with other Perl types such as HV, AV, SV, CV, because those
7038 objects will become corrupted by the pointer copy process.
7040 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7046 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7049 sv_setsv(rv, &PL_sv_undef);
7053 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7058 =for apidoc sv_setref_iv
7060 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7061 argument will be upgraded to an RV. That RV will be modified to point to
7062 the new SV. The C<classname> argument indicates the package for the
7063 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7064 will be returned and will have a reference count of 1.
7070 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7072 sv_setiv(newSVrv(rv,classname), iv);
7077 =for apidoc sv_setref_uv
7079 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7080 argument will be upgraded to an RV. That RV will be modified to point to
7081 the new SV. The C<classname> argument indicates the package for the
7082 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7083 will be returned and will have a reference count of 1.
7089 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7091 sv_setuv(newSVrv(rv,classname), uv);
7096 =for apidoc sv_setref_nv
7098 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7099 argument will be upgraded to an RV. That RV will be modified to point to
7100 the new SV. The C<classname> argument indicates the package for the
7101 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7102 will be returned and will have a reference count of 1.
7108 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7110 sv_setnv(newSVrv(rv,classname), nv);
7115 =for apidoc sv_setref_pvn
7117 Copies a string into a new SV, optionally blessing the SV. The length of the
7118 string must be specified with C<n>. The C<rv> argument will be upgraded to
7119 an RV. That RV will be modified to point to the new SV. The C<classname>
7120 argument indicates the package for the blessing. Set C<classname> to
7121 C<Nullch> to avoid the blessing. The new SV will be returned and will have
7122 a reference count of 1.
7124 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7130 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7132 sv_setpvn(newSVrv(rv,classname), pv, n);
7137 =for apidoc sv_bless
7139 Blesses an SV into a specified package. The SV must be an RV. The package
7140 must be designated by its stash (see C<gv_stashpv()>). The reference count
7141 of the SV is unaffected.
7147 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7151 Perl_croak(aTHX_ "Can't bless non-reference value");
7153 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7154 if (SvREADONLY(tmpRef))
7155 Perl_croak(aTHX_ PL_no_modify);
7156 if (SvOBJECT(tmpRef)) {
7157 if (SvTYPE(tmpRef) != SVt_PVIO)
7159 SvREFCNT_dec(SvSTASH(tmpRef));
7162 SvOBJECT_on(tmpRef);
7163 if (SvTYPE(tmpRef) != SVt_PVIO)
7165 (void)SvUPGRADE(tmpRef, SVt_PVMG);
7166 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7176 /* Downgrades a PVGV to a PVMG.
7178 * XXX This function doesn't actually appear to be used anywhere
7183 S_sv_unglob(pTHX_ SV *sv)
7187 assert(SvTYPE(sv) == SVt_PVGV);
7192 SvREFCNT_dec(GvSTASH(sv));
7193 GvSTASH(sv) = Nullhv;
7195 sv_unmagic(sv, PERL_MAGIC_glob);
7196 Safefree(GvNAME(sv));
7199 /* need to keep SvANY(sv) in the right arena */
7200 xpvmg = new_XPVMG();
7201 StructCopy(SvANY(sv), xpvmg, XPVMG);
7202 del_XPVGV(SvANY(sv));
7205 SvFLAGS(sv) &= ~SVTYPEMASK;
7206 SvFLAGS(sv) |= SVt_PVMG;
7210 =for apidoc sv_unref_flags
7212 Unsets the RV status of the SV, and decrements the reference count of
7213 whatever was being referenced by the RV. This can almost be thought of
7214 as a reversal of C<newSVrv>. The C<cflags> argument can contain
7215 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7216 (otherwise the decrementing is conditional on the reference count being
7217 different from one or the reference being a readonly SV).
7224 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7228 if (SvWEAKREF(sv)) {
7236 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
7238 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7239 sv_2mortal(rv); /* Schedule for freeing later */
7243 =for apidoc sv_unref
7245 Unsets the RV status of the SV, and decrements the reference count of
7246 whatever was being referenced by the RV. This can almost be thought of
7247 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
7248 being zero. See C<SvROK_off>.
7254 Perl_sv_unref(pTHX_ SV *sv)
7256 sv_unref_flags(sv, 0);
7260 =for apidoc sv_taint
7262 Taint an SV. Use C<SvTAINTED_on> instead.
7267 Perl_sv_taint(pTHX_ SV *sv)
7269 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7273 =for apidoc sv_untaint
7275 Untaint an SV. Use C<SvTAINTED_off> instead.
7280 Perl_sv_untaint(pTHX_ SV *sv)
7282 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7283 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7290 =for apidoc sv_tainted
7292 Test an SV for taintedness. Use C<SvTAINTED> instead.
7297 Perl_sv_tainted(pTHX_ SV *sv)
7299 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
7300 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
7301 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
7308 =for apidoc sv_setpviv
7310 Copies an integer into the given SV, also updating its string value.
7311 Does not handle 'set' magic. See C<sv_setpviv_mg>.
7317 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
7319 char buf[TYPE_CHARS(UV)];
7321 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7323 sv_setpvn(sv, ptr, ebuf - ptr);
7327 =for apidoc sv_setpviv_mg
7329 Like C<sv_setpviv>, but also handles 'set' magic.
7335 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
7337 char buf[TYPE_CHARS(UV)];
7339 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
7341 sv_setpvn(sv, ptr, ebuf - ptr);
7345 #if defined(PERL_IMPLICIT_CONTEXT)
7347 /* pTHX_ magic can't cope with varargs, so this is a no-context
7348 * version of the main function, (which may itself be aliased to us).
7349 * Don't access this version directly.
7353 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
7357 va_start(args, pat);
7358 sv_vsetpvf(sv, pat, &args);
7362 /* pTHX_ magic can't cope with varargs, so this is a no-context
7363 * version of the main function, (which may itself be aliased to us).
7364 * Don't access this version directly.
7368 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
7372 va_start(args, pat);
7373 sv_vsetpvf_mg(sv, pat, &args);
7379 =for apidoc sv_setpvf
7381 Processes its arguments like C<sprintf> and sets an SV to the formatted
7382 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
7388 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
7391 va_start(args, pat);
7392 sv_vsetpvf(sv, pat, &args);
7396 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
7399 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7401 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7405 =for apidoc sv_setpvf_mg
7407 Like C<sv_setpvf>, but also handles 'set' magic.
7413 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7416 va_start(args, pat);
7417 sv_vsetpvf_mg(sv, pat, &args);
7421 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
7424 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7426 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7430 #if defined(PERL_IMPLICIT_CONTEXT)
7432 /* pTHX_ magic can't cope with varargs, so this is a no-context
7433 * version of the main function, (which may itself be aliased to us).
7434 * Don't access this version directly.
7438 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
7442 va_start(args, pat);
7443 sv_vcatpvf(sv, pat, &args);
7447 /* pTHX_ magic can't cope with varargs, so this is a no-context
7448 * version of the main function, (which may itself be aliased to us).
7449 * Don't access this version directly.
7453 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
7457 va_start(args, pat);
7458 sv_vcatpvf_mg(sv, pat, &args);
7464 =for apidoc sv_catpvf
7466 Processes its arguments like C<sprintf> and appends the formatted
7467 output to an SV. If the appended data contains "wide" characters
7468 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
7469 and characters >255 formatted with %c), the original SV might get
7470 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
7471 C<SvSETMAGIC()> must typically be called after calling this function
7472 to handle 'set' magic.
7477 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
7480 va_start(args, pat);
7481 sv_vcatpvf(sv, pat, &args);
7485 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
7488 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
7490 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7494 =for apidoc sv_catpvf_mg
7496 Like C<sv_catpvf>, but also handles 'set' magic.
7502 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
7505 va_start(args, pat);
7506 sv_vcatpvf_mg(sv, pat, &args);
7510 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
7513 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
7515 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7520 =for apidoc sv_vsetpvfn
7522 Works like C<vcatpvfn> but copies the text into the SV instead of
7525 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
7531 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7533 sv_setpvn(sv, "", 0);
7534 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
7537 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
7540 S_expect_number(pTHX_ char** pattern)
7543 switch (**pattern) {
7544 case '1': case '2': case '3':
7545 case '4': case '5': case '6':
7546 case '7': case '8': case '9':
7547 while (isDIGIT(**pattern))
7548 var = var * 10 + (*(*pattern)++ - '0');
7552 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
7555 =for apidoc sv_vcatpvfn
7557 Processes its arguments like C<vsprintf> and appends the formatted output
7558 to an SV. Uses an array of SVs if the C style variable argument list is
7559 missing (NULL). When running with taint checks enabled, indicates via
7560 C<maybe_tainted> if results are untrustworthy (often due to the use of
7563 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
7569 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7576 static char nullstr[] = "(null)";
7579 /* no matter what, this is a string now */
7580 (void)SvPV_force(sv, origlen);
7582 /* special-case "", "%s", and "%_" */
7585 if (patlen == 2 && pat[0] == '%') {
7589 char *s = va_arg(*args, char*);
7590 sv_catpv(sv, s ? s : nullstr);
7592 else if (svix < svmax) {
7593 sv_catsv(sv, *svargs);
7594 if (DO_UTF8(*svargs))
7600 argsv = va_arg(*args, SV*);
7601 sv_catsv(sv, argsv);
7606 /* See comment on '_' below */
7611 patend = (char*)pat + patlen;
7612 for (p = (char*)pat; p < patend; p = q) {
7615 bool vectorize = FALSE;
7616 bool vectorarg = FALSE;
7617 bool vec_utf = FALSE;
7623 bool has_precis = FALSE;
7625 bool is_utf = FALSE;
7628 U8 utf8buf[UTF8_MAXLEN+1];
7629 STRLEN esignlen = 0;
7631 char *eptr = Nullch;
7633 /* Times 4: a decimal digit takes more than 3 binary digits.
7634 * NV_DIG: mantissa takes than many decimal digits.
7635 * Plus 32: Playing safe. */
7636 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7637 /* large enough for "%#.#f" --chip */
7638 /* what about long double NVs? --jhi */
7641 U8 *vecstr = Null(U8*);
7653 STRLEN dotstrlen = 1;
7654 I32 efix = 0; /* explicit format parameter index */
7655 I32 ewix = 0; /* explicit width index */
7656 I32 epix = 0; /* explicit precision index */
7657 I32 evix = 0; /* explicit vector index */
7658 bool asterisk = FALSE;
7660 /* echo everything up to the next format specification */
7661 for (q = p; q < patend && *q != '%'; ++q) ;
7663 sv_catpvn(sv, p, q - p);
7670 We allow format specification elements in this order:
7671 \d+\$ explicit format parameter index
7673 \*?(\d+\$)?v vector with optional (optionally specified) arg
7674 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7675 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7677 [%bcdefginopsux_DFOUX] format (mandatory)
7679 if (EXPECT_NUMBER(q, width)) {
7720 if (EXPECT_NUMBER(q, ewix))
7729 if ((vectorarg = asterisk)) {
7739 EXPECT_NUMBER(q, width);
7744 vecsv = va_arg(*args, SV*);
7746 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7747 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7748 dotstr = SvPVx(vecsv, dotstrlen);
7753 vecsv = va_arg(*args, SV*);
7754 vecstr = (U8*)SvPVx(vecsv,veclen);
7755 vec_utf = DO_UTF8(vecsv);
7757 else if (efix ? efix <= svmax : svix < svmax) {
7758 vecsv = svargs[efix ? efix-1 : svix++];
7759 vecstr = (U8*)SvPVx(vecsv,veclen);
7760 vec_utf = DO_UTF8(vecsv);
7770 i = va_arg(*args, int);
7772 i = (ewix ? ewix <= svmax : svix < svmax) ?
7773 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7775 width = (i < 0) ? -i : i;
7785 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7788 i = va_arg(*args, int);
7790 i = (ewix ? ewix <= svmax : svix < svmax)
7791 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7792 precis = (i < 0) ? 0 : i;
7797 precis = precis * 10 + (*q++ - '0');
7805 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7816 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7817 if (*(q + 1) == 'l') { /* lld, llf */
7840 argsv = (efix ? efix <= svmax : svix < svmax) ?
7841 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7848 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7850 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7852 eptr = (char*)utf8buf;
7853 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7865 eptr = va_arg(*args, char*);
7867 #ifdef MACOS_TRADITIONAL
7868 /* On MacOS, %#s format is used for Pascal strings */
7873 elen = strlen(eptr);
7876 elen = sizeof nullstr - 1;
7880 eptr = SvPVx(argsv, elen);
7881 if (DO_UTF8(argsv)) {
7882 if (has_precis && precis < elen) {
7884 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7887 if (width) { /* fudge width (can't fudge elen) */
7888 width += elen - sv_len_utf8(argsv);
7897 * The "%_" hack might have to be changed someday,
7898 * if ISO or ANSI decide to use '_' for something.
7899 * So we keep it hidden from users' code.
7903 argsv = va_arg(*args, SV*);
7904 eptr = SvPVx(argsv, elen);
7910 if (has_precis && elen > precis)
7919 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7937 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7947 case 'h': iv = (short)va_arg(*args, int); break;
7948 default: iv = va_arg(*args, int); break;
7949 case 'l': iv = va_arg(*args, long); break;
7950 case 'V': iv = va_arg(*args, IV); break;
7952 case 'q': iv = va_arg(*args, Quad_t); break;
7959 case 'h': iv = (short)iv; break;
7961 case 'l': iv = (long)iv; break;
7964 case 'q': iv = (Quad_t)iv; break;
7971 esignbuf[esignlen++] = plus;
7975 esignbuf[esignlen++] = '-';
8017 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
8027 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
8028 default: uv = va_arg(*args, unsigned); break;
8029 case 'l': uv = va_arg(*args, unsigned long); break;
8030 case 'V': uv = va_arg(*args, UV); break;
8032 case 'q': uv = va_arg(*args, Quad_t); break;
8039 case 'h': uv = (unsigned short)uv; break;
8041 case 'l': uv = (unsigned long)uv; break;
8044 case 'q': uv = (Quad_t)uv; break;
8050 eptr = ebuf + sizeof ebuf;
8056 p = (char*)((c == 'X')
8057 ? "0123456789ABCDEF" : "0123456789abcdef");
8063 esignbuf[esignlen++] = '0';
8064 esignbuf[esignlen++] = c; /* 'x' or 'X' */
8070 *--eptr = '0' + dig;
8072 if (alt && *eptr != '0')
8078 *--eptr = '0' + dig;
8081 esignbuf[esignlen++] = '0';
8082 esignbuf[esignlen++] = 'b';
8085 default: /* it had better be ten or less */
8086 #if defined(PERL_Y2KWARN)
8087 if (ckWARN(WARN_Y2K)) {
8089 char *s = SvPV(sv,n);
8090 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8091 && (n == 2 || !isDIGIT(s[n-3])))
8093 Perl_warner(aTHX_ WARN_Y2K,
8094 "Possible Y2K bug: %%%c %s",
8095 c, "format string following '19'");
8101 *--eptr = '0' + dig;
8102 } while (uv /= base);
8105 elen = (ebuf + sizeof ebuf) - eptr;
8108 zeros = precis - elen;
8109 else if (precis == 0 && elen == 1 && *eptr == '0')
8114 /* FLOATING POINT */
8117 c = 'f'; /* maybe %F isn't supported here */
8123 /* This is evil, but floating point is even more evil */
8126 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
8129 if (c != 'e' && c != 'E') {
8131 (void)Perl_frexp(nv, &i);
8132 if (i == PERL_INT_MIN)
8133 Perl_die(aTHX_ "panic: frexp");
8135 need = BIT_DIGITS(i);
8137 need += has_precis ? precis : 6; /* known default */
8141 need += 20; /* fudge factor */
8142 if (PL_efloatsize < need) {
8143 Safefree(PL_efloatbuf);
8144 PL_efloatsize = need + 20; /* more fudge */
8145 New(906, PL_efloatbuf, PL_efloatsize, char);
8146 PL_efloatbuf[0] = '\0';
8149 eptr = ebuf + sizeof ebuf;
8152 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
8154 /* Copy the one or more characters in a long double
8155 * format before the 'base' ([efgEFG]) character to
8156 * the format string. */
8157 static char const prifldbl[] = PERL_PRIfldbl;
8158 char const *p = prifldbl + sizeof(prifldbl) - 3;
8159 while (p >= prifldbl) { *--eptr = *p--; }
8164 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8169 do { *--eptr = '0' + (base % 10); } while (base /= 10);
8181 /* No taint. Otherwise we are in the strange situation
8182 * where printf() taints but print($float) doesn't.
8184 (void)sprintf(PL_efloatbuf, eptr, nv);
8186 eptr = PL_efloatbuf;
8187 elen = strlen(PL_efloatbuf);
8194 i = SvCUR(sv) - origlen;
8197 case 'h': *(va_arg(*args, short*)) = i; break;
8198 default: *(va_arg(*args, int*)) = i; break;
8199 case 'l': *(va_arg(*args, long*)) = i; break;
8200 case 'V': *(va_arg(*args, IV*)) = i; break;
8202 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
8207 sv_setuv_mg(argsv, (UV)i);
8208 continue; /* not "break" */
8215 if (!args && ckWARN(WARN_PRINTF) &&
8216 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
8217 SV *msg = sv_newmortal();
8218 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
8219 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
8222 Perl_sv_catpvf(aTHX_ msg,
8223 "\"%%%c\"", c & 0xFF);
8225 Perl_sv_catpvf(aTHX_ msg,
8226 "\"%%\\%03"UVof"\"",
8229 sv_catpv(msg, "end of string");
8230 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
8233 /* output mangled stuff ... */
8239 /* ... right here, because formatting flags should not apply */
8240 SvGROW(sv, SvCUR(sv) + elen + 1);
8242 Copy(eptr, p, elen, char);
8245 SvCUR(sv) = p - SvPVX(sv);
8246 continue; /* not "break" */
8249 have = esignlen + zeros + elen;
8250 need = (have > width ? have : width);
8253 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
8255 if (esignlen && fill == '0') {
8256 for (i = 0; i < esignlen; i++)
8260 memset(p, fill, gap);
8263 if (esignlen && fill != '0') {
8264 for (i = 0; i < esignlen; i++)
8268 for (i = zeros; i; i--)
8272 Copy(eptr, p, elen, char);
8276 memset(p, ' ', gap);
8281 Copy(dotstr, p, dotstrlen, char);
8285 vectorize = FALSE; /* done iterating over vecstr */
8290 SvCUR(sv) = p - SvPVX(sv);
8298 /* =========================================================================
8300 =head1 Cloning an interpreter
8302 All the macros and functions in this section are for the private use of
8303 the main function, perl_clone().
8305 The foo_dup() functions make an exact copy of an existing foo thinngy.
8306 During the course of a cloning, a hash table is used to map old addresses
8307 to new addresses. The table is created and manipulated with the
8308 ptr_table_* functions.
8312 ============================================================================*/
8315 #if defined(USE_ITHREADS)
8317 #if defined(USE_THREADS)
8318 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
8321 #ifndef GpREFCNT_inc
8322 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
8326 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8327 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
8328 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8329 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
8330 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8331 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
8332 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8333 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
8334 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
8335 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
8336 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8337 #define SAVEPV(p) (p ? savepv(p) : Nullch)
8338 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
8342 /* duplicate a regexp */
8345 Perl_re_dup(pTHX_ REGEXP *r)
8347 /* XXX fix when pmop->op_pmregexp becomes shared */
8348 return ReREFCNT_inc(r);
8351 /* duplicate a file handle */
8354 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
8358 return (PerlIO*)NULL;
8360 /* look for it in the table first */
8361 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
8365 /* create anew and remember what it is */
8366 ret = PerlIO_fdupopen(aTHX_ fp);
8367 ptr_table_store(PL_ptr_table, fp, ret);
8371 /* duplicate a directory handle */
8374 Perl_dirp_dup(pTHX_ DIR *dp)
8382 /* duplicate a typeglob */
8385 Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
8390 /* look for it in the table first */
8391 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
8395 /* create anew and remember what it is */
8396 Newz(0, ret, 1, GP);
8397 ptr_table_store(PL_ptr_table, gp, ret);
8400 ret->gp_refcnt = 0; /* must be before any other dups! */
8401 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
8402 ret->gp_io = io_dup_inc(gp->gp_io, param);
8403 ret->gp_form = cv_dup_inc(gp->gp_form, param);
8404 ret->gp_av = av_dup_inc(gp->gp_av, param);
8405 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
8406 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
8407 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
8408 ret->gp_cvgen = gp->gp_cvgen;
8409 ret->gp_flags = gp->gp_flags;
8410 ret->gp_line = gp->gp_line;
8411 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
8415 /* duplicate a chain of magic */
8418 Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param)
8420 MAGIC *mgprev = (MAGIC*)NULL;
8423 return (MAGIC*)NULL;
8424 /* look for it in the table first */
8425 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
8429 for (; mg; mg = mg->mg_moremagic) {
8431 Newz(0, nmg, 1, MAGIC);
8433 mgprev->mg_moremagic = nmg;
8436 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
8437 nmg->mg_private = mg->mg_private;
8438 nmg->mg_type = mg->mg_type;
8439 nmg->mg_flags = mg->mg_flags;
8440 if (mg->mg_type == PERL_MAGIC_qr) {
8441 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
8444 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
8445 ? sv_dup_inc(mg->mg_obj, param)
8446 : sv_dup(mg->mg_obj, param);
8448 nmg->mg_len = mg->mg_len;
8449 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
8450 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
8451 if (mg->mg_len >= 0) {
8452 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
8453 if (mg->mg_type == PERL_MAGIC_overload_table &&
8454 AMT_AMAGIC((AMT*)mg->mg_ptr))
8456 AMT *amtp = (AMT*)mg->mg_ptr;
8457 AMT *namtp = (AMT*)nmg->mg_ptr;
8459 for (i = 1; i < NofAMmeth; i++) {
8460 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
8464 else if (mg->mg_len == HEf_SVKEY)
8465 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
8472 /* create a new pointer-mapping table */
8475 Perl_ptr_table_new(pTHX)
8478 Newz(0, tbl, 1, PTR_TBL_t);
8481 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
8485 /* map an existing pointer using a table */
8488 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
8490 PTR_TBL_ENT_t *tblent;
8491 UV hash = PTR2UV(sv);
8493 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
8494 for (; tblent; tblent = tblent->next) {
8495 if (tblent->oldval == sv)
8496 return tblent->newval;
8501 /* add a new entry to a pointer-mapping table */
8504 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
8506 PTR_TBL_ENT_t *tblent, **otblent;
8507 /* XXX this may be pessimal on platforms where pointers aren't good
8508 * hash values e.g. if they grow faster in the most significant
8510 UV hash = PTR2UV(oldv);
8514 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
8515 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
8516 if (tblent->oldval == oldv) {
8517 tblent->newval = newv;
8522 Newz(0, tblent, 1, PTR_TBL_ENT_t);
8523 tblent->oldval = oldv;
8524 tblent->newval = newv;
8525 tblent->next = *otblent;
8528 if (i && tbl->tbl_items > tbl->tbl_max)
8529 ptr_table_split(tbl);
8532 /* double the hash bucket size of an existing ptr table */
8535 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
8537 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
8538 UV oldsize = tbl->tbl_max + 1;
8539 UV newsize = oldsize * 2;
8542 Renew(ary, newsize, PTR_TBL_ENT_t*);
8543 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
8544 tbl->tbl_max = --newsize;
8546 for (i=0; i < oldsize; i++, ary++) {
8547 PTR_TBL_ENT_t **curentp, **entp, *ent;
8550 curentp = ary + oldsize;
8551 for (entp = ary, ent = *ary; ent; ent = *entp) {
8552 if ((newsize & PTR2UV(ent->oldval)) != i) {
8554 ent->next = *curentp;
8564 /* remove all the entries from a ptr table */
8567 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
8569 register PTR_TBL_ENT_t **array;
8570 register PTR_TBL_ENT_t *entry;
8571 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
8575 if (!tbl || !tbl->tbl_items) {
8579 array = tbl->tbl_ary;
8586 entry = entry->next;
8590 if (++riter > max) {
8593 entry = array[riter];
8600 /* clear and free a ptr table */
8603 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8608 ptr_table_clear(tbl);
8609 Safefree(tbl->tbl_ary);
8617 /* attempt to make everything in the typeglob readonly */
8620 S_gv_share(pTHX_ SV *sstr)
8623 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8625 if (GvIO(gv) || GvFORM(gv)) {
8626 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8628 else if (!GvCV(gv)) {
8632 /* CvPADLISTs cannot be shared */
8633 if (!CvXSUB(GvCV(gv))) {
8638 if (!GvSHARED(gv)) {
8640 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8641 HvNAME(GvSTASH(gv)), GvNAME(gv));
8647 * write attempts will die with
8648 * "Modification of a read-only value attempted"
8654 SvREADONLY_on(GvSV(gv));
8661 SvREADONLY_on(GvAV(gv));
8668 SvREADONLY_on(GvAV(gv));
8671 return sstr; /* he_dup() will SvREFCNT_inc() */
8674 /* duplicate an SV of any type (including AV, HV etc) */
8677 Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
8681 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8683 /* look for it in the table first */
8684 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8688 /* create anew and remember what it is */
8690 ptr_table_store(PL_ptr_table, sstr, dstr);
8693 SvFLAGS(dstr) = SvFLAGS(sstr);
8694 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8695 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8698 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8699 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8700 PL_watch_pvx, SvPVX(sstr));
8703 switch (SvTYPE(sstr)) {
8708 SvANY(dstr) = new_XIV();
8709 SvIVX(dstr) = SvIVX(sstr);
8712 SvANY(dstr) = new_XNV();
8713 SvNVX(dstr) = SvNVX(sstr);
8716 SvANY(dstr) = new_XRV();
8717 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8718 ? sv_dup(SvRV(sstr), param)
8719 : sv_dup_inc(SvRV(sstr), param);
8722 SvANY(dstr) = new_XPV();
8723 SvCUR(dstr) = SvCUR(sstr);
8724 SvLEN(dstr) = SvLEN(sstr);
8726 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8727 ? sv_dup(SvRV(sstr), param)
8728 : sv_dup_inc(SvRV(sstr), param);
8729 else if (SvPVX(sstr) && SvLEN(sstr))
8730 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8732 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8735 SvANY(dstr) = new_XPVIV();
8736 SvCUR(dstr) = SvCUR(sstr);
8737 SvLEN(dstr) = SvLEN(sstr);
8738 SvIVX(dstr) = SvIVX(sstr);
8740 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8741 ? sv_dup(SvRV(sstr), param)
8742 : sv_dup_inc(SvRV(sstr), param);
8743 else if (SvPVX(sstr) && SvLEN(sstr))
8744 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8746 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8749 SvANY(dstr) = new_XPVNV();
8750 SvCUR(dstr) = SvCUR(sstr);
8751 SvLEN(dstr) = SvLEN(sstr);
8752 SvIVX(dstr) = SvIVX(sstr);
8753 SvNVX(dstr) = SvNVX(sstr);
8755 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8756 ? sv_dup(SvRV(sstr), param)
8757 : sv_dup_inc(SvRV(sstr), param);
8758 else if (SvPVX(sstr) && SvLEN(sstr))
8759 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8761 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8764 SvANY(dstr) = new_XPVMG();
8765 SvCUR(dstr) = SvCUR(sstr);
8766 SvLEN(dstr) = SvLEN(sstr);
8767 SvIVX(dstr) = SvIVX(sstr);
8768 SvNVX(dstr) = SvNVX(sstr);
8769 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8770 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8772 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8773 ? sv_dup(SvRV(sstr), param)
8774 : sv_dup_inc(SvRV(sstr), param);
8775 else if (SvPVX(sstr) && SvLEN(sstr))
8776 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8778 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8781 SvANY(dstr) = new_XPVBM();
8782 SvCUR(dstr) = SvCUR(sstr);
8783 SvLEN(dstr) = SvLEN(sstr);
8784 SvIVX(dstr) = SvIVX(sstr);
8785 SvNVX(dstr) = SvNVX(sstr);
8786 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8787 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8789 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8790 ? sv_dup(SvRV(sstr), param)
8791 : sv_dup_inc(SvRV(sstr), param);
8792 else if (SvPVX(sstr) && SvLEN(sstr))
8793 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8795 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8796 BmRARE(dstr) = BmRARE(sstr);
8797 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8798 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8801 SvANY(dstr) = new_XPVLV();
8802 SvCUR(dstr) = SvCUR(sstr);
8803 SvLEN(dstr) = SvLEN(sstr);
8804 SvIVX(dstr) = SvIVX(sstr);
8805 SvNVX(dstr) = SvNVX(sstr);
8806 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8807 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8809 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8810 ? sv_dup(SvRV(sstr), param)
8811 : sv_dup_inc(SvRV(sstr), param);
8812 else if (SvPVX(sstr) && SvLEN(sstr))
8813 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8815 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8816 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8817 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8818 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
8819 LvTYPE(dstr) = LvTYPE(sstr);
8822 if (GvSHARED((GV*)sstr)) {
8824 if ((share = gv_share(sstr))) {
8828 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8829 HvNAME(GvSTASH(share)), GvNAME(share));
8834 SvANY(dstr) = new_XPVGV();
8835 SvCUR(dstr) = SvCUR(sstr);
8836 SvLEN(dstr) = SvLEN(sstr);
8837 SvIVX(dstr) = SvIVX(sstr);
8838 SvNVX(dstr) = SvNVX(sstr);
8839 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8840 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8842 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8843 ? sv_dup(SvRV(sstr), param)
8844 : sv_dup_inc(SvRV(sstr), param);
8845 else if (SvPVX(sstr) && SvLEN(sstr))
8846 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8848 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8849 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8850 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8851 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
8852 GvFLAGS(dstr) = GvFLAGS(sstr);
8853 GvGP(dstr) = gp_dup(GvGP(sstr), param);
8854 (void)GpREFCNT_inc(GvGP(dstr));
8857 SvANY(dstr) = new_XPVIO();
8858 SvCUR(dstr) = SvCUR(sstr);
8859 SvLEN(dstr) = SvLEN(sstr);
8860 SvIVX(dstr) = SvIVX(sstr);
8861 SvNVX(dstr) = SvNVX(sstr);
8862 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8863 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8865 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8866 ? sv_dup(SvRV(sstr), param)
8867 : sv_dup_inc(SvRV(sstr), param);
8868 else if (SvPVX(sstr) && SvLEN(sstr))
8869 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8871 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8872 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8873 if (IoOFP(sstr) == IoIFP(sstr))
8874 IoOFP(dstr) = IoIFP(dstr);
8876 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8877 /* PL_rsfp_filters entries have fake IoDIRP() */
8878 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8879 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8881 IoDIRP(dstr) = IoDIRP(sstr);
8882 IoLINES(dstr) = IoLINES(sstr);
8883 IoPAGE(dstr) = IoPAGE(sstr);
8884 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8885 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8886 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8887 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
8888 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8889 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
8890 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8891 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
8892 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8893 IoTYPE(dstr) = IoTYPE(sstr);
8894 IoFLAGS(dstr) = IoFLAGS(sstr);
8897 SvANY(dstr) = new_XPVAV();
8898 SvCUR(dstr) = SvCUR(sstr);
8899 SvLEN(dstr) = SvLEN(sstr);
8900 SvIVX(dstr) = SvIVX(sstr);
8901 SvNVX(dstr) = SvNVX(sstr);
8902 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8903 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8904 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
8905 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8906 if (AvARRAY((AV*)sstr)) {
8907 SV **dst_ary, **src_ary;
8908 SSize_t items = AvFILLp((AV*)sstr) + 1;
8910 src_ary = AvARRAY((AV*)sstr);
8911 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8912 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8913 SvPVX(dstr) = (char*)dst_ary;
8914 AvALLOC((AV*)dstr) = dst_ary;
8915 if (AvREAL((AV*)sstr)) {
8917 *dst_ary++ = sv_dup_inc(*src_ary++, param);
8921 *dst_ary++ = sv_dup(*src_ary++, param);
8923 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8924 while (items-- > 0) {
8925 *dst_ary++ = &PL_sv_undef;
8929 SvPVX(dstr) = Nullch;
8930 AvALLOC((AV*)dstr) = (SV**)NULL;
8934 SvANY(dstr) = new_XPVHV();
8935 SvCUR(dstr) = SvCUR(sstr);
8936 SvLEN(dstr) = SvLEN(sstr);
8937 SvIVX(dstr) = SvIVX(sstr);
8938 SvNVX(dstr) = SvNVX(sstr);
8939 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8940 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8941 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8942 if (HvARRAY((HV*)sstr)) {
8944 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8945 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8946 Newz(0, dxhv->xhv_array,
8947 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8948 while (i <= sxhv->xhv_max) {
8949 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8950 !!HvSHAREKEYS(sstr), param);
8953 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
8956 SvPVX(dstr) = Nullch;
8957 HvEITER((HV*)dstr) = (HE*)NULL;
8959 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8960 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8961 /* Record stashes for possible cloning in Perl_clone(). */
8962 if(HvNAME((HV*)dstr))
8963 av_push(param->stashes, dstr);
8966 SvANY(dstr) = new_XPVFM();
8967 FmLINES(dstr) = FmLINES(sstr);
8971 SvANY(dstr) = new_XPVCV();
8973 SvCUR(dstr) = SvCUR(sstr);
8974 SvLEN(dstr) = SvLEN(sstr);
8975 SvIVX(dstr) = SvIVX(sstr);
8976 SvNVX(dstr) = SvNVX(sstr);
8977 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
8978 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
8979 if (SvPVX(sstr) && SvLEN(sstr))
8980 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8982 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8983 CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
8984 CvSTART(dstr) = CvSTART(sstr);
8985 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8986 CvXSUB(dstr) = CvXSUB(sstr);
8987 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8988 CvGV(dstr) = gv_dup(CvGV(sstr), param);
8989 if (param->flags & CLONEf_COPY_STACKS) {
8990 CvDEPTH(dstr) = CvDEPTH(sstr);
8994 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8995 /* XXX padlists are real, but pretend to be not */
8996 AvREAL_on(CvPADLIST(sstr));
8997 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
8998 AvREAL_off(CvPADLIST(sstr));
8999 AvREAL_off(CvPADLIST(dstr));
9002 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
9003 if (!CvANON(sstr) || CvCLONED(sstr))
9004 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
9006 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
9007 CvFLAGS(dstr) = CvFLAGS(sstr);
9008 CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
9011 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
9015 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
9021 /* duplicate a context */
9024 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param)
9029 return (PERL_CONTEXT*)NULL;
9031 /* look for it in the table first */
9032 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
9036 /* create anew and remember what it is */
9037 Newz(56, ncxs, max + 1, PERL_CONTEXT);
9038 ptr_table_store(PL_ptr_table, cxs, ncxs);
9041 PERL_CONTEXT *cx = &cxs[ix];
9042 PERL_CONTEXT *ncx = &ncxs[ix];
9043 ncx->cx_type = cx->cx_type;
9044 if (CxTYPE(cx) == CXt_SUBST) {
9045 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
9048 ncx->blk_oldsp = cx->blk_oldsp;
9049 ncx->blk_oldcop = cx->blk_oldcop;
9050 ncx->blk_oldretsp = cx->blk_oldretsp;
9051 ncx->blk_oldmarksp = cx->blk_oldmarksp;
9052 ncx->blk_oldscopesp = cx->blk_oldscopesp;
9053 ncx->blk_oldpm = cx->blk_oldpm;
9054 ncx->blk_gimme = cx->blk_gimme;
9055 switch (CxTYPE(cx)) {
9057 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
9058 ? cv_dup_inc(cx->blk_sub.cv, param)
9059 : cv_dup(cx->blk_sub.cv,param));
9060 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
9061 ? av_dup_inc(cx->blk_sub.argarray, param)
9063 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
9064 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
9065 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9066 ncx->blk_sub.lval = cx->blk_sub.lval;
9069 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
9070 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
9071 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
9072 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
9073 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
9076 ncx->blk_loop.label = cx->blk_loop.label;
9077 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
9078 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
9079 ncx->blk_loop.next_op = cx->blk_loop.next_op;
9080 ncx->blk_loop.last_op = cx->blk_loop.last_op;
9081 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
9082 ? cx->blk_loop.iterdata
9083 : gv_dup((GV*)cx->blk_loop.iterdata, param));
9084 ncx->blk_loop.oldcurpad
9085 = (SV**)ptr_table_fetch(PL_ptr_table,
9086 cx->blk_loop.oldcurpad);
9087 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
9088 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
9089 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
9090 ncx->blk_loop.iterix = cx->blk_loop.iterix;
9091 ncx->blk_loop.itermax = cx->blk_loop.itermax;
9094 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
9095 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
9096 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
9097 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
9109 /* duplicate a stack info structure */
9112 Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param)
9117 return (PERL_SI*)NULL;
9119 /* look for it in the table first */
9120 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
9124 /* create anew and remember what it is */
9125 Newz(56, nsi, 1, PERL_SI);
9126 ptr_table_store(PL_ptr_table, si, nsi);
9128 nsi->si_stack = av_dup_inc(si->si_stack, param);
9129 nsi->si_cxix = si->si_cxix;
9130 nsi->si_cxmax = si->si_cxmax;
9131 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
9132 nsi->si_type = si->si_type;
9133 nsi->si_prev = si_dup(si->si_prev, param);
9134 nsi->si_next = si_dup(si->si_next, param);
9135 nsi->si_markoff = si->si_markoff;
9140 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
9141 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
9142 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
9143 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
9144 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
9145 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
9146 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
9147 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
9148 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
9149 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
9150 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
9151 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
9154 #define pv_dup_inc(p) SAVEPV(p)
9155 #define pv_dup(p) SAVEPV(p)
9156 #define svp_dup_inc(p,pp) any_dup(p,pp)
9158 /* map any object to the new equivent - either something in the
9159 * ptr table, or something in the interpreter structure
9163 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
9170 /* look for it in the table first */
9171 ret = ptr_table_fetch(PL_ptr_table, v);
9175 /* see if it is part of the interpreter structure */
9176 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
9177 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
9184 /* duplicate the save stack */
9187 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param)
9189 ANY *ss = proto_perl->Tsavestack;
9190 I32 ix = proto_perl->Tsavestack_ix;
9191 I32 max = proto_perl->Tsavestack_max;
9204 void (*dptr) (void*);
9205 void (*dxptr) (pTHXo_ void*);
9208 Newz(54, nss, max, ANY);
9214 case SAVEt_ITEM: /* normal string */
9215 sv = (SV*)POPPTR(ss,ix);
9216 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9217 sv = (SV*)POPPTR(ss,ix);
9218 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9220 case SAVEt_SV: /* scalar reference */
9221 sv = (SV*)POPPTR(ss,ix);
9222 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9223 gv = (GV*)POPPTR(ss,ix);
9224 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
9226 case SAVEt_GENERIC_PVREF: /* generic char* */
9227 c = (char*)POPPTR(ss,ix);
9228 TOPPTR(nss,ix) = pv_dup(c);
9229 ptr = POPPTR(ss,ix);
9230 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9232 case SAVEt_GENERIC_SVREF: /* generic sv */
9233 case SAVEt_SVREF: /* scalar reference */
9234 sv = (SV*)POPPTR(ss,ix);
9235 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9236 ptr = POPPTR(ss,ix);
9237 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
9239 case SAVEt_AV: /* array reference */
9240 av = (AV*)POPPTR(ss,ix);
9241 TOPPTR(nss,ix) = av_dup_inc(av, param);
9242 gv = (GV*)POPPTR(ss,ix);
9243 TOPPTR(nss,ix) = gv_dup(gv, param);
9245 case SAVEt_HV: /* hash reference */
9246 hv = (HV*)POPPTR(ss,ix);
9247 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9248 gv = (GV*)POPPTR(ss,ix);
9249 TOPPTR(nss,ix) = gv_dup(gv, param);
9251 case SAVEt_INT: /* int reference */
9252 ptr = POPPTR(ss,ix);
9253 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9254 intval = (int)POPINT(ss,ix);
9255 TOPINT(nss,ix) = intval;
9257 case SAVEt_LONG: /* long reference */
9258 ptr = POPPTR(ss,ix);
9259 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9260 longval = (long)POPLONG(ss,ix);
9261 TOPLONG(nss,ix) = longval;
9263 case SAVEt_I32: /* I32 reference */
9264 case SAVEt_I16: /* I16 reference */
9265 case SAVEt_I8: /* I8 reference */
9266 ptr = POPPTR(ss,ix);
9267 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9271 case SAVEt_IV: /* IV reference */
9272 ptr = POPPTR(ss,ix);
9273 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9277 case SAVEt_SPTR: /* SV* reference */
9278 ptr = POPPTR(ss,ix);
9279 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9280 sv = (SV*)POPPTR(ss,ix);
9281 TOPPTR(nss,ix) = sv_dup(sv, param);
9283 case SAVEt_VPTR: /* random* reference */
9284 ptr = POPPTR(ss,ix);
9285 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9286 ptr = POPPTR(ss,ix);
9287 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9289 case SAVEt_PPTR: /* char* reference */
9290 ptr = POPPTR(ss,ix);
9291 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9292 c = (char*)POPPTR(ss,ix);
9293 TOPPTR(nss,ix) = pv_dup(c);
9295 case SAVEt_HPTR: /* HV* reference */
9296 ptr = POPPTR(ss,ix);
9297 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9298 hv = (HV*)POPPTR(ss,ix);
9299 TOPPTR(nss,ix) = hv_dup(hv, param);
9301 case SAVEt_APTR: /* AV* reference */
9302 ptr = POPPTR(ss,ix);
9303 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9304 av = (AV*)POPPTR(ss,ix);
9305 TOPPTR(nss,ix) = av_dup(av, param);
9308 gv = (GV*)POPPTR(ss,ix);
9309 TOPPTR(nss,ix) = gv_dup(gv, param);
9311 case SAVEt_GP: /* scalar reference */
9312 gp = (GP*)POPPTR(ss,ix);
9313 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
9314 (void)GpREFCNT_inc(gp);
9315 gv = (GV*)POPPTR(ss,ix);
9316 TOPPTR(nss,ix) = gv_dup_inc(c, param);
9317 c = (char*)POPPTR(ss,ix);
9318 TOPPTR(nss,ix) = pv_dup(c);
9325 case SAVEt_MORTALIZESV:
9326 sv = (SV*)POPPTR(ss,ix);
9327 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9330 ptr = POPPTR(ss,ix);
9331 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
9332 /* these are assumed to be refcounted properly */
9333 switch (((OP*)ptr)->op_type) {
9340 TOPPTR(nss,ix) = ptr;
9345 TOPPTR(nss,ix) = Nullop;
9350 TOPPTR(nss,ix) = Nullop;
9353 c = (char*)POPPTR(ss,ix);
9354 TOPPTR(nss,ix) = pv_dup_inc(c);
9357 longval = POPLONG(ss,ix);
9358 TOPLONG(nss,ix) = longval;
9361 hv = (HV*)POPPTR(ss,ix);
9362 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9363 c = (char*)POPPTR(ss,ix);
9364 TOPPTR(nss,ix) = pv_dup_inc(c);
9368 case SAVEt_DESTRUCTOR:
9369 ptr = POPPTR(ss,ix);
9370 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9371 dptr = POPDPTR(ss,ix);
9372 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
9374 case SAVEt_DESTRUCTOR_X:
9375 ptr = POPPTR(ss,ix);
9376 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
9377 dxptr = POPDXPTR(ss,ix);
9378 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
9380 case SAVEt_REGCONTEXT:
9386 case SAVEt_STACK_POS: /* Position on Perl stack */
9390 case SAVEt_AELEM: /* array element */
9391 sv = (SV*)POPPTR(ss,ix);
9392 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9395 av = (AV*)POPPTR(ss,ix);
9396 TOPPTR(nss,ix) = av_dup_inc(av, param);
9398 case SAVEt_HELEM: /* hash element */
9399 sv = (SV*)POPPTR(ss,ix);
9400 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9401 sv = (SV*)POPPTR(ss,ix);
9402 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
9403 hv = (HV*)POPPTR(ss,ix);
9404 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
9407 ptr = POPPTR(ss,ix);
9408 TOPPTR(nss,ix) = ptr;
9415 av = (AV*)POPPTR(ss,ix);
9416 TOPPTR(nss,ix) = av_dup(av, param);
9419 longval = (long)POPLONG(ss,ix);
9420 TOPLONG(nss,ix) = longval;
9421 ptr = POPPTR(ss,ix);
9422 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
9423 sv = (SV*)POPPTR(ss,ix);
9424 TOPPTR(nss,ix) = sv_dup(sv, param);
9427 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
9439 =for apidoc perl_clone
9441 Create and return a new interpreter by cloning the current one.
9446 /* XXX the above needs expanding by someone who actually understands it ! */
9449 perl_clone(PerlInterpreter *proto_perl, UV flags)
9452 CPerlObj *pPerl = (CPerlObj*)proto_perl;
9455 #ifdef PERL_IMPLICIT_SYS
9457 /* perlhost.h so we need to call into it
9458 to clone the host, CPerlHost should have a c interface, sky */
9460 if (flags & CLONEf_CLONE_HOST) {
9461 return perl_clone_host(proto_perl,flags);
9463 return perl_clone_using(proto_perl, flags,
9465 proto_perl->IMemShared,
9466 proto_perl->IMemParse,
9476 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
9477 struct IPerlMem* ipM, struct IPerlMem* ipMS,
9478 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
9479 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
9480 struct IPerlDir* ipD, struct IPerlSock* ipS,
9481 struct IPerlProc* ipP)
9483 /* XXX many of the string copies here can be optimized if they're
9484 * constants; they need to be allocated as common memory and just
9485 * their pointers copied. */
9488 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9493 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
9495 PERL_SET_THX(pPerl);
9496 # else /* !PERL_OBJECT */
9497 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
9498 PERL_SET_THX(my_perl);
9501 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9507 # else /* !DEBUGGING */
9508 Zero(my_perl, 1, PerlInterpreter);
9509 # endif /* DEBUGGING */
9513 PL_MemShared = ipMS;
9521 # endif /* PERL_OBJECT */
9522 #else /* !PERL_IMPLICIT_SYS */
9524 clone_params* param = (clone_params*) malloc(sizeof(clone_params));
9525 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
9526 PERL_SET_THX(my_perl);
9531 memset(my_perl, 0xab, sizeof(PerlInterpreter));
9537 # else /* !DEBUGGING */
9538 Zero(my_perl, 1, PerlInterpreter);
9539 # endif /* DEBUGGING */
9540 #endif /* PERL_IMPLICIT_SYS */
9541 param->flags = flags;
9544 PL_xiv_arenaroot = NULL;
9546 PL_xnv_arenaroot = NULL;
9548 PL_xrv_arenaroot = NULL;
9550 PL_xpv_arenaroot = NULL;
9552 PL_xpviv_arenaroot = NULL;
9553 PL_xpviv_root = NULL;
9554 PL_xpvnv_arenaroot = NULL;
9555 PL_xpvnv_root = NULL;
9556 PL_xpvcv_arenaroot = NULL;
9557 PL_xpvcv_root = NULL;
9558 PL_xpvav_arenaroot = NULL;
9559 PL_xpvav_root = NULL;
9560 PL_xpvhv_arenaroot = NULL;
9561 PL_xpvhv_root = NULL;
9562 PL_xpvmg_arenaroot = NULL;
9563 PL_xpvmg_root = NULL;
9564 PL_xpvlv_arenaroot = NULL;
9565 PL_xpvlv_root = NULL;
9566 PL_xpvbm_arenaroot = NULL;
9567 PL_xpvbm_root = NULL;
9568 PL_he_arenaroot = NULL;
9570 PL_nice_chunk = NULL;
9571 PL_nice_chunk_size = 0;
9574 PL_sv_root = Nullsv;
9575 PL_sv_arenaroot = Nullsv;
9577 PL_debug = proto_perl->Idebug;
9579 /* create SV map for pointer relocation */
9580 PL_ptr_table = ptr_table_new();
9582 /* initialize these special pointers as early as possible */
9583 SvANY(&PL_sv_undef) = NULL;
9584 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
9585 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
9586 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
9589 SvUPGRADE(&PL_sv_no, SVt_PVNV);
9591 SvANY(&PL_sv_no) = new_XPVNV();
9593 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
9594 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9595 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
9596 SvCUR(&PL_sv_no) = 0;
9597 SvLEN(&PL_sv_no) = 1;
9598 SvNVX(&PL_sv_no) = 0;
9599 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
9602 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
9604 SvANY(&PL_sv_yes) = new_XPVNV();
9606 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
9607 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
9608 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
9609 SvCUR(&PL_sv_yes) = 1;
9610 SvLEN(&PL_sv_yes) = 2;
9611 SvNVX(&PL_sv_yes) = 1;
9612 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
9614 /* create shared string table */
9615 PL_strtab = newHV();
9616 HvSHAREKEYS_off(PL_strtab);
9617 hv_ksplit(PL_strtab, 512);
9618 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
9620 PL_compiling = proto_perl->Icompiling;
9621 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
9622 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
9623 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
9624 if (!specialWARN(PL_compiling.cop_warnings))
9625 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
9626 if (!specialCopIO(PL_compiling.cop_io))
9627 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
9628 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
9630 /* pseudo environmental stuff */
9631 PL_origargc = proto_perl->Iorigargc;
9633 New(0, PL_origargv, i+1, char*);
9634 PL_origargv[i] = '\0';
9636 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
9640 param->stashes = newAV(); /* Setup array of objects to call clone on */
9643 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
9644 PL_incgv = gv_dup(proto_perl->Iincgv, param);
9645 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
9646 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
9647 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
9648 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
9651 PL_minus_c = proto_perl->Iminus_c;
9652 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
9653 PL_localpatches = proto_perl->Ilocalpatches;
9654 PL_splitstr = proto_perl->Isplitstr;
9655 PL_preprocess = proto_perl->Ipreprocess;
9656 PL_minus_n = proto_perl->Iminus_n;
9657 PL_minus_p = proto_perl->Iminus_p;
9658 PL_minus_l = proto_perl->Iminus_l;
9659 PL_minus_a = proto_perl->Iminus_a;
9660 PL_minus_F = proto_perl->Iminus_F;
9661 PL_doswitches = proto_perl->Idoswitches;
9662 PL_dowarn = proto_perl->Idowarn;
9663 PL_doextract = proto_perl->Idoextract;
9664 PL_sawampersand = proto_perl->Isawampersand;
9665 PL_unsafe = proto_perl->Iunsafe;
9666 PL_inplace = SAVEPV(proto_perl->Iinplace);
9667 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
9668 PL_perldb = proto_perl->Iperldb;
9669 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9671 /* magical thingies */
9672 /* XXX time(&PL_basetime) when asked for? */
9673 PL_basetime = proto_perl->Ibasetime;
9674 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
9676 PL_maxsysfd = proto_perl->Imaxsysfd;
9677 PL_multiline = proto_perl->Imultiline;
9678 PL_statusvalue = proto_perl->Istatusvalue;
9680 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9683 /* shortcuts to various I/O objects */
9684 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
9685 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
9686 PL_defgv = gv_dup(proto_perl->Idefgv, param);
9687 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
9688 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
9689 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
9691 /* shortcuts to regexp stuff */
9692 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
9694 /* shortcuts to misc objects */
9695 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
9697 /* shortcuts to debugging objects */
9698 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
9699 PL_DBline = gv_dup(proto_perl->IDBline, param);
9700 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
9701 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
9702 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
9703 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
9704 PL_lineary = av_dup(proto_perl->Ilineary, param);
9705 PL_dbargs = av_dup(proto_perl->Idbargs, param);
9708 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
9709 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
9710 PL_nullstash = hv_dup(proto_perl->Inullstash, param);
9711 PL_debstash = hv_dup(proto_perl->Idebstash, param);
9712 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
9713 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
9715 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
9716 PL_endav = av_dup_inc(proto_perl->Iendav, param);
9717 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
9718 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
9720 PL_sub_generation = proto_perl->Isub_generation;
9722 /* funky return mechanisms */
9723 PL_forkprocess = proto_perl->Iforkprocess;
9725 /* subprocess state */
9726 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
9728 /* internal state */
9729 PL_tainting = proto_perl->Itainting;
9730 PL_maxo = proto_perl->Imaxo;
9731 if (proto_perl->Iop_mask)
9732 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9734 PL_op_mask = Nullch;
9736 /* current interpreter roots */
9737 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
9738 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9739 PL_main_start = proto_perl->Imain_start;
9740 PL_eval_root = proto_perl->Ieval_root;
9741 PL_eval_start = proto_perl->Ieval_start;
9743 /* runtime control stuff */
9744 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9745 PL_copline = proto_perl->Icopline;
9747 PL_filemode = proto_perl->Ifilemode;
9748 PL_lastfd = proto_perl->Ilastfd;
9749 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9752 PL_gensym = proto_perl->Igensym;
9753 PL_preambled = proto_perl->Ipreambled;
9754 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
9755 PL_laststatval = proto_perl->Ilaststatval;
9756 PL_laststype = proto_perl->Ilaststype;
9757 PL_mess_sv = Nullsv;
9759 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
9760 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9762 /* interpreter atexit processing */
9763 PL_exitlistlen = proto_perl->Iexitlistlen;
9764 if (PL_exitlistlen) {
9765 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9766 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9769 PL_exitlist = (PerlExitListEntry*)NULL;
9770 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
9772 PL_profiledata = NULL;
9773 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9774 /* PL_rsfp_filters entries have fake IoDIRP() */
9775 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
9777 PL_compcv = cv_dup(proto_perl->Icompcv, param);
9778 PL_comppad = av_dup(proto_perl->Icomppad, param);
9779 PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
9780 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9781 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9782 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9783 proto_perl->Tcurpad);
9785 #ifdef HAVE_INTERP_INTERN
9786 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9789 /* more statics moved here */
9790 PL_generation = proto_perl->Igeneration;
9791 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
9793 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9794 PL_in_clean_all = proto_perl->Iin_clean_all;
9796 PL_uid = proto_perl->Iuid;
9797 PL_euid = proto_perl->Ieuid;
9798 PL_gid = proto_perl->Igid;
9799 PL_egid = proto_perl->Iegid;
9800 PL_nomemok = proto_perl->Inomemok;
9801 PL_an = proto_perl->Ian;
9802 PL_cop_seqmax = proto_perl->Icop_seqmax;
9803 PL_op_seqmax = proto_perl->Iop_seqmax;
9804 PL_evalseq = proto_perl->Ievalseq;
9805 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9806 PL_origalen = proto_perl->Iorigalen;
9807 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9808 PL_osname = SAVEPV(proto_perl->Iosname);
9809 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9810 PL_sighandlerp = proto_perl->Isighandlerp;
9813 PL_runops = proto_perl->Irunops;
9815 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9818 PL_cshlen = proto_perl->Icshlen;
9819 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9822 PL_lex_state = proto_perl->Ilex_state;
9823 PL_lex_defer = proto_perl->Ilex_defer;
9824 PL_lex_expect = proto_perl->Ilex_expect;
9825 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9826 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9827 PL_lex_starts = proto_perl->Ilex_starts;
9828 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
9829 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
9830 PL_lex_op = proto_perl->Ilex_op;
9831 PL_lex_inpat = proto_perl->Ilex_inpat;
9832 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9833 PL_lex_brackets = proto_perl->Ilex_brackets;
9834 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9835 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9836 PL_lex_casemods = proto_perl->Ilex_casemods;
9837 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9838 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9840 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9841 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9842 PL_nexttoke = proto_perl->Inexttoke;
9844 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
9845 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9846 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9847 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9848 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9849 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9850 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9851 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9852 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9853 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9854 PL_pending_ident = proto_perl->Ipending_ident;
9855 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9857 PL_expect = proto_perl->Iexpect;
9859 PL_multi_start = proto_perl->Imulti_start;
9860 PL_multi_end = proto_perl->Imulti_end;
9861 PL_multi_open = proto_perl->Imulti_open;
9862 PL_multi_close = proto_perl->Imulti_close;
9864 PL_error_count = proto_perl->Ierror_count;
9865 PL_subline = proto_perl->Isubline;
9866 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
9868 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9869 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9870 PL_padix = proto_perl->Ipadix;
9871 PL_padix_floor = proto_perl->Ipadix_floor;
9872 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9874 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9875 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9876 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9877 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9878 PL_last_lop_op = proto_perl->Ilast_lop_op;
9879 PL_in_my = proto_perl->Iin_my;
9880 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
9882 PL_cryptseen = proto_perl->Icryptseen;
9885 PL_hints = proto_perl->Ihints;
9887 PL_amagic_generation = proto_perl->Iamagic_generation;
9889 #ifdef USE_LOCALE_COLLATE
9890 PL_collation_ix = proto_perl->Icollation_ix;
9891 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9892 PL_collation_standard = proto_perl->Icollation_standard;
9893 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9894 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9895 #endif /* USE_LOCALE_COLLATE */
9897 #ifdef USE_LOCALE_NUMERIC
9898 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9899 PL_numeric_standard = proto_perl->Inumeric_standard;
9900 PL_numeric_local = proto_perl->Inumeric_local;
9901 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
9902 #endif /* !USE_LOCALE_NUMERIC */
9904 /* utf8 character classes */
9905 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
9906 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
9907 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
9908 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
9909 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
9910 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
9911 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
9912 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
9913 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
9914 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
9915 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
9916 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
9917 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
9918 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
9919 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
9920 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
9921 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
9924 PL_last_swash_hv = Nullhv; /* reinits on demand */
9925 PL_last_swash_klen = 0;
9926 PL_last_swash_key[0]= '\0';
9927 PL_last_swash_tmps = (U8*)NULL;
9928 PL_last_swash_slen = 0;
9930 /* perly.c globals */
9931 PL_yydebug = proto_perl->Iyydebug;
9932 PL_yynerrs = proto_perl->Iyynerrs;
9933 PL_yyerrflag = proto_perl->Iyyerrflag;
9934 PL_yychar = proto_perl->Iyychar;
9935 PL_yyval = proto_perl->Iyyval;
9936 PL_yylval = proto_perl->Iyylval;
9938 PL_glob_index = proto_perl->Iglob_index;
9939 PL_srand_called = proto_perl->Isrand_called;
9940 PL_uudmap['M'] = 0; /* reinits on demand */
9941 PL_bitcount = Nullch; /* reinits on demand */
9943 if (proto_perl->Ipsig_pend) {
9944 Newz(0, PL_psig_pend, SIG_SIZE, int);
9947 PL_psig_pend = (int*)NULL;
9950 if (proto_perl->Ipsig_ptr) {
9951 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9952 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9953 for (i = 1; i < SIG_SIZE; i++) {
9954 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
9955 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
9959 PL_psig_ptr = (SV**)NULL;
9960 PL_psig_name = (SV**)NULL;
9963 /* thrdvar.h stuff */
9965 if (flags & CLONEf_COPY_STACKS) {
9966 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9967 PL_tmps_ix = proto_perl->Ttmps_ix;
9968 PL_tmps_max = proto_perl->Ttmps_max;
9969 PL_tmps_floor = proto_perl->Ttmps_floor;
9970 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9972 while (i <= PL_tmps_ix) {
9973 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
9977 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9978 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9979 Newz(54, PL_markstack, i, I32);
9980 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9981 - proto_perl->Tmarkstack);
9982 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9983 - proto_perl->Tmarkstack);
9984 Copy(proto_perl->Tmarkstack, PL_markstack,
9985 PL_markstack_ptr - PL_markstack + 1, I32);
9987 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9988 * NOTE: unlike the others! */
9989 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9990 PL_scopestack_max = proto_perl->Tscopestack_max;
9991 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9992 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9994 /* next push_return() sets PL_retstack[PL_retstack_ix]
9995 * NOTE: unlike the others! */
9996 PL_retstack_ix = proto_perl->Tretstack_ix;
9997 PL_retstack_max = proto_perl->Tretstack_max;
9998 Newz(54, PL_retstack, PL_retstack_max, OP*);
9999 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
10001 /* NOTE: si_dup() looks at PL_markstack */
10002 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
10004 /* PL_curstack = PL_curstackinfo->si_stack; */
10005 PL_curstack = av_dup(proto_perl->Tcurstack, param);
10006 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
10008 /* next PUSHs() etc. set *(PL_stack_sp+1) */
10009 PL_stack_base = AvARRAY(PL_curstack);
10010 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
10011 - proto_perl->Tstack_base);
10012 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
10014 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
10015 * NOTE: unlike the others! */
10016 PL_savestack_ix = proto_perl->Tsavestack_ix;
10017 PL_savestack_max = proto_perl->Tsavestack_max;
10018 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
10019 PL_savestack = ss_dup(proto_perl, param);
10023 ENTER; /* perl_destruct() wants to LEAVE; */
10026 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
10027 PL_top_env = &PL_start_env;
10029 PL_op = proto_perl->Top;
10032 PL_Xpv = (XPV*)NULL;
10033 PL_na = proto_perl->Tna;
10035 PL_statbuf = proto_perl->Tstatbuf;
10036 PL_statcache = proto_perl->Tstatcache;
10037 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
10038 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
10040 PL_timesbuf = proto_perl->Ttimesbuf;
10043 PL_tainted = proto_perl->Ttainted;
10044 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
10045 PL_nrs = sv_dup_inc(proto_perl->Tnrs, param);
10046 PL_rs = sv_dup_inc(proto_perl->Trs, param);
10047 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
10048 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
10049 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
10050 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
10051 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
10052 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
10053 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
10055 PL_restartop = proto_perl->Trestartop;
10056 PL_in_eval = proto_perl->Tin_eval;
10057 PL_delaymagic = proto_perl->Tdelaymagic;
10058 PL_dirty = proto_perl->Tdirty;
10059 PL_localizing = proto_perl->Tlocalizing;
10061 #ifdef PERL_FLEXIBLE_EXCEPTIONS
10062 PL_protect = proto_perl->Tprotect;
10064 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
10065 PL_av_fetch_sv = Nullsv;
10066 PL_hv_fetch_sv = Nullsv;
10067 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
10068 PL_modcount = proto_perl->Tmodcount;
10069 PL_lastgotoprobe = Nullop;
10070 PL_dumpindent = proto_perl->Tdumpindent;
10072 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
10073 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
10074 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
10075 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
10076 PL_sortcxix = proto_perl->Tsortcxix;
10077 PL_efloatbuf = Nullch; /* reinits on demand */
10078 PL_efloatsize = 0; /* reinits on demand */
10082 PL_screamfirst = NULL;
10083 PL_screamnext = NULL;
10084 PL_maxscream = -1; /* reinits on demand */
10085 PL_lastscream = Nullsv;
10087 PL_watchaddr = NULL;
10088 PL_watchok = Nullch;
10090 PL_regdummy = proto_perl->Tregdummy;
10091 PL_regcomp_parse = Nullch;
10092 PL_regxend = Nullch;
10093 PL_regcode = (regnode*)NULL;
10096 PL_regprecomp = Nullch;
10101 PL_seen_zerolen = 0;
10103 PL_regcomp_rx = (regexp*)NULL;
10105 PL_colorset = 0; /* reinits PL_colors[] */
10106 /*PL_colors[6] = {0,0,0,0,0,0};*/
10107 PL_reg_whilem_seen = 0;
10108 PL_reginput = Nullch;
10109 PL_regbol = Nullch;
10110 PL_regeol = Nullch;
10111 PL_regstartp = (I32*)NULL;
10112 PL_regendp = (I32*)NULL;
10113 PL_reglastparen = (U32*)NULL;
10114 PL_regtill = Nullch;
10115 PL_reg_start_tmp = (char**)NULL;
10116 PL_reg_start_tmpl = 0;
10117 PL_regdata = (struct reg_data*)NULL;
10120 PL_reg_eval_set = 0;
10122 PL_regprogram = (regnode*)NULL;
10124 PL_regcc = (CURCUR*)NULL;
10125 PL_reg_call_cc = (struct re_cc_state*)NULL;
10126 PL_reg_re = (regexp*)NULL;
10127 PL_reg_ganch = Nullch;
10128 PL_reg_sv = Nullsv;
10129 PL_reg_magic = (MAGIC*)NULL;
10131 PL_reg_oldcurpm = (PMOP*)NULL;
10132 PL_reg_curpm = (PMOP*)NULL;
10133 PL_reg_oldsaved = Nullch;
10134 PL_reg_oldsavedlen = 0;
10135 PL_reg_maxiter = 0;
10136 PL_reg_leftiter = 0;
10137 PL_reg_poscache = Nullch;
10138 PL_reg_poscache_size= 0;
10140 /* RE engine - function pointers */
10141 PL_regcompp = proto_perl->Tregcompp;
10142 PL_regexecp = proto_perl->Tregexecp;
10143 PL_regint_start = proto_perl->Tregint_start;
10144 PL_regint_string = proto_perl->Tregint_string;
10145 PL_regfree = proto_perl->Tregfree;
10147 PL_reginterp_cnt = 0;
10148 PL_reg_starttry = 0;
10150 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
10151 ptr_table_free(PL_ptr_table);
10152 PL_ptr_table = NULL;
10155 /* Call the ->CLONE method, if it exists, for each of the stashes
10156 identified by sv_dup() above.
10158 while(av_len(param->stashes) != -1) {
10159 HV* stash = (HV*) av_shift(param->stashes);
10160 GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
10161 if (cloner && GvCV(cloner)) {
10166 XPUSHs(newSVpv(HvNAME(stash), 0));
10168 call_sv((SV*)GvCV(cloner), G_DISCARD);
10175 return (PerlInterpreter*)pPerl;
10181 #else /* !USE_ITHREADS */
10187 #endif /* USE_ITHREADS */