3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
9 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
12 * This file contains the code that creates, manipulates and destroys
13 * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
14 * structure of an SV, so their creation and destruction is handled
15 * here; higher-level functions are in av.c, hv.c, and so on. Opcode
16 * level functions (eg. substr, split, join) for each of the types are
28 /* Missing proto on LynxOS */
29 char *gconvert(double, int, int, char *);
32 #ifdef PERL_UTF8_CACHE_ASSERT
33 /* The cache element 0 is the Unicode offset;
34 * the cache element 1 is the byte offset of the element 0;
35 * the cache element 2 is the Unicode length of the substring;
36 * the cache element 3 is the byte length of the substring;
37 * The checking of the substring side would be good
38 * but substr() has enough code paths to make my head spin;
39 * if adding more checks watch out for the following tests:
40 * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
41 * lib/utf8.t lib/Unicode/Collate/t/index.t
44 #define ASSERT_UTF8_CACHE(cache) \
45 STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
47 #define ASSERT_UTF8_CACHE(cache) NOOP
50 #ifdef PERL_OLD_COPY_ON_WRITE
51 #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
52 #define SV_COW_NEXT_SV_SET(current,next) SvUV_set(current, PTR2UV(next))
53 /* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
57 /* ============================================================================
59 =head1 Allocation and deallocation of SVs.
61 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
62 av, hv...) contains type and reference count information, as well as a
63 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
64 specific to each type.
66 In all but the most memory-paranoid configuations (ex: PURIFY), this
67 allocation is done using arenas, which by default are approximately 4K
68 chunks of memory parcelled up into N heads or bodies (of same size).
69 Sv-bodies are allocated by their sv-type, guaranteeing size
70 consistency needed to allocate safely from arrays.
72 The first slot in each arena is reserved, and is used to hold a link
73 to the next arena. In the case of heads, the unused first slot also
74 contains some flags and a note of the number of slots. Snaked through
75 each arena chain is a linked list of free items; when this becomes
76 empty, an extra arena is allocated and divided up into N items which
77 are threaded into the free list.
79 The following global variables are associated with arenas:
81 PL_sv_arenaroot pointer to list of SV arenas
82 PL_sv_root pointer to list of free SV structures
84 PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype
85 PL_body_roots[] array of pointers to list of free bodies of svtype
86 arrays are indexed by the svtype needed
88 Note that some of the larger and more rarely used body types (eg
89 xpvio) are not allocated using arenas, but are instead just
90 malloc()/free()ed as required.
92 In addition, a few SV heads are not allocated from an arena, but are
93 instead directly created as static or auto variables, eg PL_sv_undef.
94 The size of arenas can be changed from the default by setting
95 PERL_ARENA_SIZE appropriately at compile time.
97 The SV arena serves the secondary purpose of allowing still-live SVs
98 to be located and destroyed during final cleanup.
100 At the lowest level, the macros new_SV() and del_SV() grab and free
101 an SV head. (If debugging with -DD, del_SV() calls the function S_del_sv()
102 to return the SV to the free list with error checking.) new_SV() calls
103 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
104 SVs in the free list have their SvTYPE field set to all ones.
106 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
107 that allocate and return individual body types. Normally these are mapped
108 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
109 instead mapped directly to malloc()/free() if PURIFY is defined. The
110 new/del functions remove from, or add to, the appropriate PL_foo_root
111 list, and call more_xiv() etc to add a new arena if the list is empty.
113 At the time of very final cleanup, sv_free_arenas() is called from
114 perl_destruct() to physically free all the arenas allocated since the
115 start of the interpreter.
117 Manipulation of any of the PL_*root pointers is protected by enclosing
118 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
119 if threads are enabled.
121 The function visit() scans the SV arenas list, and calls a specified
122 function for each SV it finds which is still live - ie which has an SvTYPE
123 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
124 following functions (specified as [function that calls visit()] / [function
125 called by visit() for each SV]):
127 sv_report_used() / do_report_used()
128 dump all remaining SVs (debugging aid)
130 sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
131 Attempt to free all objects pointed to by RVs,
132 and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
133 try to do the same for all objects indirectly
134 referenced by typeglobs too. Called once from
135 perl_destruct(), prior to calling sv_clean_all()
138 sv_clean_all() / do_clean_all()
139 SvREFCNT_dec(sv) each remaining SV, possibly
140 triggering an sv_free(). It also sets the
141 SVf_BREAK flag on the SV to indicate that the
142 refcnt has been artificially lowered, and thus
143 stopping sv_free() from giving spurious warnings
144 about SVs which unexpectedly have a refcnt
145 of zero. called repeatedly from perl_destruct()
146 until there are no SVs left.
148 =head2 Arena allocator API Summary
150 Private API to rest of sv.c
154 new_XIV(), del_XIV(),
155 new_XNV(), del_XNV(),
160 sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
165 ============================================================================ */
170 * "A time to plant, and a time to uproot what was planted..."
174 * nice_chunk and nice_chunk size need to be set
175 * and queried under the protection of sv_mutex
178 Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size)
183 new_chunk = (void *)(chunk);
184 new_chunk_size = (chunk_size);
185 if (new_chunk_size > PL_nice_chunk_size) {
186 Safefree(PL_nice_chunk);
187 PL_nice_chunk = (char *) new_chunk;
188 PL_nice_chunk_size = new_chunk_size;
195 #ifdef DEBUG_LEAKING_SCALARS
196 # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file)
198 # define FREE_SV_DEBUG_FILE(sv)
202 # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
203 /* Whilst I'd love to do this, it seems that things like to check on
205 # define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
207 # define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
208 Poison(&SvREFCNT(sv), 1, U32)
210 # define SvARENA_CHAIN(sv) SvANY(sv)
211 # define POSION_SV_HEAD(sv)
214 #define plant_SV(p) \
216 FREE_SV_DEBUG_FILE(p); \
218 SvARENA_CHAIN(p) = (void *)PL_sv_root; \
219 SvFLAGS(p) = SVTYPEMASK; \
224 /* sv_mutex must be held while calling uproot_SV() */
225 #define uproot_SV(p) \
228 PL_sv_root = (SV*)SvARENA_CHAIN(p); \
233 /* make some more SVs by adding another arena */
235 /* sv_mutex must be held while calling more_sv() */
242 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
243 PL_nice_chunk = Nullch;
244 PL_nice_chunk_size = 0;
247 char *chunk; /* must use New here to match call to */
248 Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
249 sv_add_arena(chunk, PERL_ARENA_SIZE, 0);
255 /* new_SV(): return a new, empty SV head */
257 #ifdef DEBUG_LEAKING_SCALARS
258 /* provide a real function for a debugger to play with */
268 sv = S_more_sv(aTHX);
273 sv->sv_debug_optype = PL_op ? PL_op->op_type : 0;
274 sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ?
275 (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline);
276 sv->sv_debug_inpad = 0;
277 sv->sv_debug_cloned = 0;
278 sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL;
282 # define new_SV(p) (p)=S_new_SV(aTHX)
291 (p) = S_more_sv(aTHX); \
300 /* del_SV(): return an empty SV head to the free list */
315 S_del_sv(pTHX_ SV *p)
320 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
321 const SV * const sv = sva + 1;
322 const SV * const svend = &sva[SvREFCNT(sva)];
323 if (p >= sv && p < svend) {
329 if (ckWARN_d(WARN_INTERNAL))
330 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
331 "Attempt to free non-arena SV: 0x%"UVxf
332 pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
339 #else /* ! DEBUGGING */
341 #define del_SV(p) plant_SV(p)
343 #endif /* DEBUGGING */
347 =head1 SV Manipulation Functions
349 =for apidoc sv_add_arena
351 Given a chunk of memory, link it to the head of the list of arenas,
352 and split it into a list of free SVs.
358 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
364 /* The first SV in an arena isn't an SV. */
365 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
366 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
367 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
369 PL_sv_arenaroot = sva;
370 PL_sv_root = sva + 1;
372 svend = &sva[SvREFCNT(sva) - 1];
375 SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1);
379 /* Must always set typemask because it's awlays checked in on cleanup
380 when the arenas are walked looking for objects. */
381 SvFLAGS(sv) = SVTYPEMASK;
384 SvARENA_CHAIN(sv) = 0;
388 SvFLAGS(sv) = SVTYPEMASK;
391 /* visit(): call the named function for each non-free SV in the arenas
392 * whose flags field matches the flags/mask args. */
395 S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask)
400 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
401 register const SV * const svend = &sva[SvREFCNT(sva)];
403 for (sv = sva + 1; sv < svend; ++sv) {
404 if (SvTYPE(sv) != SVTYPEMASK
405 && (sv->sv_flags & mask) == flags
418 /* called by sv_report_used() for each live SV */
421 do_report_used(pTHX_ SV *sv)
423 if (SvTYPE(sv) != SVTYPEMASK) {
424 PerlIO_printf(Perl_debug_log, "****\n");
431 =for apidoc sv_report_used
433 Dump the contents of all SVs not yet freed. (Debugging aid).
439 Perl_sv_report_used(pTHX)
442 visit(do_report_used, 0, 0);
446 /* called by sv_clean_objs() for each live SV */
449 do_clean_objs(pTHX_ SV *ref)
452 SV * const target = SvRV(ref);
453 if (SvOBJECT(target)) {
454 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref)));
455 if (SvWEAKREF(ref)) {
456 sv_del_backref(target, ref);
462 SvREFCNT_dec(target);
467 /* XXX Might want to check arrays, etc. */
470 /* called by sv_clean_objs() for each live SV */
472 #ifndef DISABLE_DESTRUCTOR_KLUDGE
474 do_clean_named_objs(pTHX_ SV *sv)
476 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
478 #ifdef PERL_DONT_CREATE_GVSV
481 SvOBJECT(GvSV(sv))) ||
482 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
483 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
484 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
485 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
487 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
488 SvFLAGS(sv) |= SVf_BREAK;
496 =for apidoc sv_clean_objs
498 Attempt to destroy all objects not yet freed
504 Perl_sv_clean_objs(pTHX)
506 PL_in_clean_objs = TRUE;
507 visit(do_clean_objs, SVf_ROK, SVf_ROK);
508 #ifndef DISABLE_DESTRUCTOR_KLUDGE
509 /* some barnacles may yet remain, clinging to typeglobs */
510 visit(do_clean_named_objs, SVt_PVGV, SVTYPEMASK);
512 PL_in_clean_objs = FALSE;
515 /* called by sv_clean_all() for each live SV */
518 do_clean_all(pTHX_ SV *sv)
520 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
521 SvFLAGS(sv) |= SVf_BREAK;
522 if (PL_comppad == (AV*)sv) {
524 PL_curpad = Null(SV**);
530 =for apidoc sv_clean_all
532 Decrement the refcnt of each remaining SV, possibly triggering a
533 cleanup. This function may have to be called multiple times to free
534 SVs which are in complex self-referential hierarchies.
540 Perl_sv_clean_all(pTHX)
543 PL_in_clean_all = TRUE;
544 cleaned = visit(do_clean_all, 0,0);
545 PL_in_clean_all = FALSE;
550 S_free_arena(pTHX_ void **root) {
552 void ** const next = *(void **)root;
559 =for apidoc sv_free_arenas
561 Deallocate the memory used by all arenas. Note that all the individual SV
562 heads and bodies within the arenas must already have been freed.
566 #define free_arena(name) \
568 S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \
569 PL_ ## name ## _arenaroot = 0; \
570 PL_ ## name ## _root = 0; \
574 Perl_sv_free_arenas(pTHX)
580 /* Free arenas here, but be careful about fake ones. (We assume
581 contiguity of the fake ones with the corresponding real ones.) */
583 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
584 svanext = (SV*) SvANY(sva);
585 while (svanext && SvFAKE(svanext))
586 svanext = (SV*) SvANY(svanext);
592 for (i=0; i<SVt_LAST; i++) {
593 S_free_arena(aTHX_ (void**) PL_body_arenaroots[i]);
594 PL_body_arenaroots[i] = 0;
595 PL_body_roots[i] = 0;
598 Safefree(PL_nice_chunk);
599 PL_nice_chunk = Nullch;
600 PL_nice_chunk_size = 0;
605 /* ---------------------------------------------------------------------
607 * support functions for report_uninit()
610 /* the maxiumum size of array or hash where we will scan looking
611 * for the undefined element that triggered the warning */
613 #define FUV_MAX_SEARCH_SIZE 1000
615 /* Look for an entry in the hash whose value has the same SV as val;
616 * If so, return a mortal copy of the key. */
619 S_find_hash_subscript(pTHX_ HV *hv, SV* val)
625 if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) ||
626 (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE))
631 for (i=HvMAX(hv); i>0; i--) {
633 for (entry = array[i]; entry; entry = HeNEXT(entry)) {
634 if (HeVAL(entry) != val)
636 if ( HeVAL(entry) == &PL_sv_undef ||
637 HeVAL(entry) == &PL_sv_placeholder)
641 if (HeKLEN(entry) == HEf_SVKEY)
642 return sv_mortalcopy(HeKEY_sv(entry));
643 return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry)));
649 /* Look for an entry in the array whose value has the same SV as val;
650 * If so, return the index, otherwise return -1. */
653 S_find_array_subscript(pTHX_ AV *av, SV* val)
657 if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
658 (AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
662 for (i=AvFILLp(av); i>=0; i--) {
663 if (svp[i] == val && svp[i] != &PL_sv_undef)
669 /* S_varname(): return the name of a variable, optionally with a subscript.
670 * If gv is non-zero, use the name of that global, along with gvtype (one
671 * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
672 * targ. Depending on the value of the subscript_type flag, return:
675 #define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
676 #define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
677 #define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
678 #define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
681 S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ,
682 SV* keyname, I32 aindex, int subscript_type)
685 SV * const name = sv_newmortal();
691 /* as gv_fullname4(), but add literal '^' for $^FOO names */
693 gv_fullname4(name, gv, buffer, 0);
695 if ((unsigned int)SvPVX(name)[1] <= 26) {
697 buffer[1] = SvPVX(name)[1] + 'A' - 1;
699 /* Swap the 1 unprintable control character for the 2 byte pretty
700 version - ie substr($name, 1, 1) = $buffer; */
701 sv_insert(name, 1, 1, buffer, 2);
706 CV * const cv = find_runcv(&unused);
710 if (!cv || !CvPADLIST(cv))
712 av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE));
713 sv = *av_fetch(av, targ, FALSE);
714 /* SvLEN in a pad name is not to be trusted */
715 sv_setpv(name, SvPV_nolen_const(sv));
718 if (subscript_type == FUV_SUBSCRIPT_HASH) {
719 SV * const sv = NEWSV(0,0);
721 Perl_sv_catpvf(aTHX_ name, "{%s}",
722 pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32));
725 else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
727 Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
729 else if (subscript_type == FUV_SUBSCRIPT_WITHIN)
730 sv_insert(name, 0, 0, "within ", 7);
737 =for apidoc find_uninit_var
739 Find the name of the undefined variable (if any) that caused the operator o
740 to issue a "Use of uninitialized value" warning.
741 If match is true, only return a name if it's value matches uninit_sv.
742 So roughly speaking, if a unary operator (such as OP_COS) generates a
743 warning, then following the direct child of the op may yield an
744 OP_PADSV or OP_GV that gives the name of the undefined variable. On the
745 other hand, with OP_ADD there are two branches to follow, so we only print
746 the variable name if we get an exact match.
748 The name is returned as a mortal SV.
750 Assumes that PL_op is the op that originally triggered the error, and that
751 PL_comppad/PL_curpad points to the currently executing pad.
757 S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match)
765 if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef ||
766 uninit_sv == &PL_sv_placeholder)))
769 switch (obase->op_type) {
776 const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV);
777 const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV);
780 int subscript_type = FUV_SUBSCRIPT_WITHIN;
782 if (pad) { /* @lex, %lex */
783 sv = PAD_SVl(obase->op_targ);
787 if (cUNOPx(obase)->op_first->op_type == OP_GV) {
788 /* @global, %global */
789 gv = cGVOPx_gv(cUNOPx(obase)->op_first);
792 sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv);
794 else /* @{expr}, %{expr} */
795 return find_uninit_var(cUNOPx(obase)->op_first,
799 /* attempt to find a match within the aggregate */
801 keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
803 subscript_type = FUV_SUBSCRIPT_HASH;
806 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
808 subscript_type = FUV_SUBSCRIPT_ARRAY;
811 if (match && subscript_type == FUV_SUBSCRIPT_WITHIN)
814 return varname(gv, hash ? '%' : '@', obase->op_targ,
815 keysv, index, subscript_type);
819 if (match && PAD_SVl(obase->op_targ) != uninit_sv)
821 return varname(Nullgv, '$', obase->op_targ,
822 Nullsv, 0, FUV_SUBSCRIPT_NONE);
825 gv = cGVOPx_gv(obase);
826 if (!gv || (match && GvSV(gv) != uninit_sv))
828 return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE);
831 if (obase->op_flags & OPf_SPECIAL) { /* lexical array */
834 av = (AV*)PAD_SV(obase->op_targ);
835 if (!av || SvRMAGICAL(av))
837 svp = av_fetch(av, (I32)obase->op_private, FALSE);
838 if (!svp || *svp != uninit_sv)
841 return varname(Nullgv, '$', obase->op_targ,
842 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
845 gv = cGVOPx_gv(obase);
851 if (!av || SvRMAGICAL(av))
853 svp = av_fetch(av, (I32)obase->op_private, FALSE);
854 if (!svp || *svp != uninit_sv)
857 return varname(gv, '$', 0,
858 Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
863 o = cUNOPx(obase)->op_first;
864 if (!o || o->op_type != OP_NULL ||
865 ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM))
867 return find_uninit_var(cBINOPo->op_last, uninit_sv, match);
872 /* $a[uninit_expr] or $h{uninit_expr} */
873 return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match);
876 o = cBINOPx(obase)->op_first;
877 kid = cBINOPx(obase)->op_last;
879 /* get the av or hv, and optionally the gv */
881 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) {
882 sv = PAD_SV(o->op_targ);
884 else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV)
885 && cUNOPo->op_first->op_type == OP_GV)
887 gv = cGVOPx_gv(cUNOPo->op_first);
890 sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv);
895 if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) {
896 /* index is constant */
900 if (obase->op_type == OP_HELEM) {
901 HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0);
902 if (!he || HeVAL(he) != uninit_sv)
906 SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE);
907 if (!svp || *svp != uninit_sv)
911 if (obase->op_type == OP_HELEM)
912 return varname(gv, '%', o->op_targ,
913 cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH);
915 return varname(gv, '@', o->op_targ, Nullsv,
916 SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY);
920 /* index is an expression;
921 * attempt to find a match within the aggregate */
922 if (obase->op_type == OP_HELEM) {
923 SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
925 return varname(gv, '%', o->op_targ,
926 keysv, 0, FUV_SUBSCRIPT_HASH);
929 const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
931 return varname(gv, '@', o->op_targ,
932 Nullsv, index, FUV_SUBSCRIPT_ARRAY);
937 (o->op_type == OP_PADAV || o->op_type == OP_RV2AV)
939 o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN);
945 /* only examine RHS */
946 return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match);
949 o = cUNOPx(obase)->op_first;
950 if (o->op_type == OP_PUSHMARK)
953 if (!o->op_sibling) {
954 /* one-arg version of open is highly magical */
956 if (o->op_type == OP_GV) { /* open FOO; */
958 if (match && GvSV(gv) != uninit_sv)
960 return varname(gv, '$', 0,
961 Nullsv, 0, FUV_SUBSCRIPT_NONE);
963 /* other possibilities not handled are:
964 * open $x; or open my $x; should return '${*$x}'
965 * open expr; should return '$'.expr ideally
971 /* ops where $_ may be an implicit arg */
975 if ( !(obase->op_flags & OPf_STACKED)) {
976 if (uninit_sv == ((obase->op_private & OPpTARGET_MY)
977 ? PAD_SVl(obase->op_targ)
981 sv_setpvn(sv, "$_", 2);
989 /* skip filehandle as it can't produce 'undef' warning */
990 o = cUNOPx(obase)->op_first;
991 if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK)
992 o = o->op_sibling->op_sibling;
999 match = 1; /* XS or custom code could trigger random warnings */
1004 if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
1005 return sv_2mortal(newSVpvn("${$/}", 5));
1010 if (!(obase->op_flags & OPf_KIDS))
1012 o = cUNOPx(obase)->op_first;
1018 /* if all except one arg are constant, or have no side-effects,
1019 * or are optimized away, then it's unambiguous */
1021 for (kid=o; kid; kid = kid->op_sibling) {
1023 ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
1024 || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
1025 || (kid->op_type == OP_PUSHMARK)
1029 if (o2) { /* more than one found */
1036 return find_uninit_var(o2, uninit_sv, match);
1040 sv = find_uninit_var(o, uninit_sv, 1);
1052 =for apidoc report_uninit
1054 Print appropriate "Use of uninitialized variable" warning
1060 Perl_report_uninit(pTHX_ SV* uninit_sv)
1063 SV* varname = Nullsv;
1065 varname = find_uninit_var(PL_op, uninit_sv,0);
1067 sv_insert(varname, 0, 0, " ", 1);
1069 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1070 varname ? SvPV_nolen_const(varname) : "",
1071 " in ", OP_DESC(PL_op));
1074 Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
1079 Here are mid-level routines that manage the allocation of bodies out
1080 of the various arenas. There are 5 kinds of arenas:
1082 1. SV-head arenas, which are discussed and handled above
1083 2. regular body arenas
1084 3. arenas for reduced-size bodies
1085 4. Hash-Entry arenas
1086 5. pte arenas (thread related)
1088 Arena types 2 & 3 are chained by body-type off an array of
1089 arena-root pointers, which is indexed by svtype. Some of the
1090 larger/less used body types are malloced singly, since a large
1091 unused block of them is wasteful. Also, several svtypes dont have
1092 bodies; the data fits into the sv-head itself. The arena-root
1093 pointer thus has a few unused root-pointers (which may be hijacked
1094 later for arena types 4,5)
1096 3 differs from 2 as an optimization; some body types have several
1097 unused fields in the front of the structure (which are kept in-place
1098 for consistency). These bodies can be allocated in smaller chunks,
1099 because the leading fields arent accessed. Pointers to such bodies
1100 are decremented to point at the unused 'ghost' memory, knowing that
1101 the pointers are used with offsets to the real memory.
1103 HE, HEK arenas are managed separately, with separate code, but may
1104 be merge-able later..
1106 PTE arenas are not sv-bodies, but they share these mid-level
1107 mechanics, so are considered here. The new mid-level mechanics rely
1108 on the sv_type of the body being allocated, so we just reserve one
1109 of the unused body-slots for PTEs, then use it in those (2) PTE
1110 contexts below (line ~10k)
1114 S_more_bodies (pTHX_ size_t size, svtype sv_type)
1116 void **arena_root = &PL_body_arenaroots[sv_type];
1117 void **root = &PL_body_roots[sv_type];
1120 const size_t count = PERL_ARENA_SIZE / size;
1122 Newx(start, count*size, char);
1123 *((void **) start) = *arena_root;
1124 *arena_root = (void *)start;
1126 end = start + (count-1) * size;
1128 /* The initial slot is used to link the arenas together, so it isn't to be
1129 linked into the list of ready-to-use bodies. */
1133 *root = (void *)start;
1135 while (start < end) {
1136 char * const next = start + size;
1137 *(void**) start = (void *)next;
1140 *(void **)start = 0;
1145 /* grab a new thing from the free list, allocating more if necessary */
1147 /* 1st, the inline version */
1149 #define new_body_inline(xpv, size, sv_type) \
1151 void **r3wt = &PL_body_roots[sv_type]; \
1153 xpv = *((void **)(r3wt)) \
1154 ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \
1155 *(r3wt) = *(void**)(xpv); \
1159 /* now use the inline version in the proper function */
1163 /* This isn't being used with -DPURIFY, so don't declare it. Otherwise
1164 compilers issue warnings. */
1167 S_new_body(pTHX_ size_t size, svtype sv_type)
1170 new_body_inline(xpv, size, sv_type);
1176 /* return a thing to the free list */
1178 #define del_body(thing, root) \
1180 void **thing_copy = (void **)thing; \
1182 *thing_copy = *root; \
1183 *root = (void*)thing_copy; \
1188 Revisiting type 3 arenas, there are 4 body-types which have some
1189 members that are never accessed. They are XPV, XPVIV, XPVAV,
1190 XPVHV, which have corresponding types: xpv_allocated,
1191 xpviv_allocated, xpvav_allocated, xpvhv_allocated,
1193 For these types, the arenas are carved up into *_allocated size
1194 chunks, we thus avoid wasted memory for those unaccessed members.
1195 When bodies are allocated, we adjust the pointer back in memory by
1196 the size of the bit not allocated, so it's as if we allocated the
1197 full structure. (But things will all go boom if you write to the
1198 part that is "not there", because you'll be overwriting the last
1199 members of the preceding structure in memory.)
1201 We calculate the correction using the STRUCT_OFFSET macro. For example, if
1202 xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero,
1203 and the pointer is unchanged. If the allocated structure is smaller (no
1204 initial NV actually allocated) then the net effect is to subtract the size
1205 of the NV from the pointer, to return a new pointer as if an initial NV were
1208 This is the same trick as was used for NV and IV bodies. Ironically it
1209 doesn't need to be used for NV bodies any more, because NV is now at the
1210 start of the structure. IV bodies don't need it either, because they are
1211 no longer allocated. */
1213 /* The following 2 arrays hide the above details in a pair of
1214 lookup-tables, allowing us to be body-type agnostic.
1216 size maps svtype to its body's allocated size.
1217 offset maps svtype to the body-pointer adjustment needed
1219 NB: elements in latter are 0 or <0, and are added during
1220 allocation, and subtracted during deallocation. It may be clearer
1221 to invert the values, and call it shrinkage_by_svtype.
1224 struct body_details {
1225 size_t size; /* Size to allocate */
1226 size_t copy; /* Size of structure to copy (may be shorter) */
1228 bool cant_upgrade; /* Can upgrade this type */
1229 bool zero_nv; /* zero the NV when upgrading from this */
1230 bool arena; /* Allocated from an arena */
1237 /* With -DPURFIY we allocate everything directly, and don't use arenas.
1238 This seems a rather elegant way to simplify some of the code below. */
1239 #define HASARENA FALSE
1241 #define HASARENA TRUE
1243 #define NOARENA FALSE
1245 static const struct body_details bodies_by_type[] = {
1246 {0, 0, 0, FALSE, NONV, NOARENA},
1247 /* IVs are in the head, so the allocation size is 0 */
1248 {0, sizeof(IV), -STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA},
1249 /* 8 bytes on most ILP32 with IEEE doubles */
1250 {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA},
1251 /* RVs are in the head now */
1252 /* However, this slot is overloaded and used by the pte */
1253 {0, 0, 0, FALSE, NONV, NOARENA},
1254 /* 8 bytes on most ILP32 with IEEE doubles */
1255 {sizeof(xpv_allocated),
1256 STRUCT_OFFSET(XPV, xpv_len) + sizeof (((XPV*)SvANY((SV*)0))->xpv_len)
1257 + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur),
1258 + STRUCT_OFFSET(xpv_allocated, xpv_cur) - STRUCT_OFFSET(XPV, xpv_cur)
1259 , FALSE, NONV, HASARENA},
1261 {sizeof(xpviv_allocated),
1262 STRUCT_OFFSET(XPVIV, xiv_u) + sizeof (((XPVIV*)SvANY((SV*)0))->xiv_u)
1263 + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur),
1264 + STRUCT_OFFSET(xpviv_allocated, xpv_cur) - STRUCT_OFFSET(XPVIV, xpv_cur)
1265 , FALSE, NONV, HASARENA},
1268 STRUCT_OFFSET(XPVNV, xiv_u) + sizeof (((XPVNV*)SvANY((SV*)0))->xiv_u),
1269 0, FALSE, HADNV, HASARENA},
1272 STRUCT_OFFSET(XPVMG, xmg_stash) + sizeof (((XPVMG*)SvANY((SV*)0))->xmg_stash),
1273 0, FALSE, HADNV, HASARENA},
1275 {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA},
1277 {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA},
1279 {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA},
1281 {sizeof(xpvav_allocated),
1282 STRUCT_OFFSET(XPVAV, xmg_stash)
1283 + sizeof (((XPVAV*)SvANY((SV *)0))->xmg_stash)
1284 + STRUCT_OFFSET(xpvav_allocated, xav_fill)
1285 - STRUCT_OFFSET(XPVAV, xav_fill),
1286 STRUCT_OFFSET(xpvav_allocated, xav_fill)
1287 - STRUCT_OFFSET(XPVAV, xav_fill), TRUE, HADNV, HASARENA},
1289 {sizeof(xpvhv_allocated),
1290 STRUCT_OFFSET(XPVHV, xmg_stash)
1291 + sizeof (((XPVHV*)SvANY((SV *)0))->xmg_stash)
1292 + STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
1293 - STRUCT_OFFSET(XPVHV, xhv_fill),
1294 STRUCT_OFFSET(xpvhv_allocated, xhv_fill)
1295 - STRUCT_OFFSET(XPVHV, xhv_fill), TRUE, HADNV, HASARENA},
1297 {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA},
1299 {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA},
1301 {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA}
1304 #define new_body_type(sv_type) \
1305 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
1306 + bodies_by_type[sv_type].offset)
1308 #define del_body_type(p, sv_type) \
1309 del_body(p, &PL_body_roots[sv_type])
1312 #define new_body_allocated(sv_type) \
1313 (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\
1314 + bodies_by_type[sv_type].offset)
1316 #define del_body_allocated(p, sv_type) \
1317 del_body(p - bodies_by_type[sv_type].offset, &PL_body_roots[sv_type])
1320 #define my_safemalloc(s) (void*)safemalloc(s)
1321 #define my_safecalloc(s) (void*)safecalloc(s, 1)
1322 #define my_safefree(p) safefree((char*)p)
1326 #define new_XNV() my_safemalloc(sizeof(XPVNV))
1327 #define del_XNV(p) my_safefree(p)
1329 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
1330 #define del_XPVNV(p) my_safefree(p)
1332 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
1333 #define del_XPVAV(p) my_safefree(p)
1335 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
1336 #define del_XPVHV(p) my_safefree(p)
1338 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
1339 #define del_XPVMG(p) my_safefree(p)
1341 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
1342 #define del_XPVGV(p) my_safefree(p)
1346 #define new_XNV() new_body_type(SVt_NV)
1347 #define del_XNV(p) del_body_type(p, SVt_NV)
1349 #define new_XPVNV() new_body_type(SVt_PVNV)
1350 #define del_XPVNV(p) del_body_type(p, SVt_PVNV)
1352 #define new_XPVAV() new_body_allocated(SVt_PVAV)
1353 #define del_XPVAV(p) del_body_allocated(p, SVt_PVAV)
1355 #define new_XPVHV() new_body_allocated(SVt_PVHV)
1356 #define del_XPVHV(p) del_body_allocated(p, SVt_PVHV)
1358 #define new_XPVMG() new_body_type(SVt_PVMG)
1359 #define del_XPVMG(p) del_body_type(p, SVt_PVMG)
1361 #define new_XPVGV() new_body_type(SVt_PVGV)
1362 #define del_XPVGV(p) del_body_type(p, SVt_PVGV)
1366 /* no arena for you! */
1368 #define new_NOARENA(details) \
1369 my_safemalloc((details)->size - (details)->offset)
1370 #define new_NOARENAZ(details) \
1371 my_safecalloc((details)->size - (details)->offset)
1374 =for apidoc sv_upgrade
1376 Upgrade an SV to a more complex form. Generally adds a new body type to the
1377 SV, then copies across as much information as possible from the old body.
1378 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1384 Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
1388 const U32 old_type = SvTYPE(sv);
1389 const struct body_details *const old_type_details
1390 = bodies_by_type + old_type;
1391 const struct body_details *new_type_details = bodies_by_type + new_type;
1393 if (new_type != SVt_PV && SvIsCOW(sv)) {
1394 sv_force_normal_flags(sv, 0);
1397 if (old_type == new_type)
1400 if (old_type > new_type)
1401 Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d",
1402 (int)old_type, (int)new_type);
1405 old_body = SvANY(sv);
1407 /* Copying structures onto other structures that have been neatly zeroed
1408 has a subtle gotcha. Consider XPVMG
1410 +------+------+------+------+------+-------+-------+
1411 | NV | CUR | LEN | IV | MAGIC | STASH |
1412 +------+------+------+------+------+-------+-------+
1413 0 4 8 12 16 20 24 28
1415 where NVs are aligned to 8 bytes, so that sizeof that structure is
1416 actually 32 bytes long, with 4 bytes of padding at the end:
1418 +------+------+------+------+------+-------+-------+------+
1419 | NV | CUR | LEN | IV | MAGIC | STASH | ??? |
1420 +------+------+------+------+------+-------+-------+------+
1421 0 4 8 12 16 20 24 28 32
1423 so what happens if you allocate memory for this structure:
1425 +------+------+------+------+------+-------+-------+------+------+...
1426 | NV | CUR | LEN | IV | MAGIC | STASH | GP | NAME |
1427 +------+------+------+------+------+-------+-------+------+------+...
1428 0 4 8 12 16 20 24 28 32 36
1430 zero it, then copy sizeof(XPVMG) bytes on top of it? Not quite what you
1431 expect, because you copy the area marked ??? onto GP. Now, ??? may have
1432 started out as zero once, but it's quite possible that it isn't. So now,
1433 rather than a nicely zeroed GP, you have it pointing somewhere random.
1436 (In fact, GP ends up pointing at a previous GP structure, because the
1437 principle cause of the padding in XPVMG getting garbage is a copy of
1438 sizeof(XPVMG) bytes from a XPVGV structure in sv_unglob)
1440 So we are careful and work out the size of used parts of all the
1447 if (new_type < SVt_PVIV) {
1448 new_type = (new_type == SVt_NV)
1449 ? SVt_PVNV : SVt_PVIV;
1450 new_type_details = bodies_by_type + new_type;
1454 if (new_type < SVt_PVNV) {
1455 new_type = SVt_PVNV;
1456 new_type_details = bodies_by_type + new_type;
1462 assert(new_type > SVt_PV);
1463 assert(SVt_IV < SVt_PV);
1464 assert(SVt_NV < SVt_PV);
1471 /* Because the XPVMG of PL_mess_sv isn't allocated from the arena,
1472 there's no way that it can be safely upgraded, because perl.c
1473 expects to Safefree(SvANY(PL_mess_sv)) */
1474 assert(sv != PL_mess_sv);
1475 /* This flag bit is used to mean other things in other scalar types.
1476 Given that it only has meaning inside the pad, it shouldn't be set
1477 on anything that can get upgraded. */
1478 assert((SvFLAGS(sv) & SVpad_TYPED) == 0);
1481 if (old_type_details->cant_upgrade)
1482 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1485 SvFLAGS(sv) &= ~SVTYPEMASK;
1486 SvFLAGS(sv) |= new_type;
1490 Perl_croak(aTHX_ "Can't upgrade to undef");
1492 assert(old_type == SVt_NULL);
1493 SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
1497 assert(old_type == SVt_NULL);
1498 SvANY(sv) = new_XNV();
1502 assert(old_type == SVt_NULL);
1503 SvANY(sv) = &sv->sv_u.svu_rv;
1507 SvANY(sv) = new_XPVHV();
1510 HvTOTALKEYS(sv) = 0;
1515 SvANY(sv) = new_XPVAV();
1522 /* SVt_NULL isn't the only thing upgraded to AV or HV.
1523 The target created by newSVrv also is, and it can have magic.
1524 However, it never has SvPVX set.
1526 if (old_type >= SVt_RV) {
1527 assert(SvPVX_const(sv) == 0);
1530 /* Could put this in the else clause below, as PVMG must have SvPVX
1531 0 already (the assertion above) */
1532 SvPV_set(sv, (char*)0);
1534 if (old_type >= SVt_PVMG) {
1535 SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_magic);
1536 SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash);
1545 /* XXX Is this still needed? Was it ever needed? Surely as there is
1546 no route from NV to PVIV, NOK can never be true */
1547 assert(!SvNOKp(sv));
1559 assert(new_type_details->size);
1560 /* We always allocated the full length item with PURIFY. To do this
1561 we fake things so that arena is false for all 16 types.. */
1562 if(new_type_details->arena) {
1563 /* This points to the start of the allocated area. */
1564 new_body_inline(new_body, new_type_details->size, new_type);
1565 Zero(new_body, new_type_details->size, char);
1566 new_body = ((char *)new_body) + new_type_details->offset;
1568 new_body = new_NOARENAZ(new_type_details);
1570 SvANY(sv) = new_body;
1572 if (old_type_details->copy) {
1573 Copy((char *)old_body - old_type_details->offset,
1574 (char *)new_body - old_type_details->offset,
1575 old_type_details->copy, char);
1578 #ifndef NV_ZERO_IS_ALLBITS_ZERO
1579 /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct
1581 if (old_type_details->zero_nv)
1585 if (new_type == SVt_PVIO)
1586 IoPAGE_LEN(sv) = 60;
1587 if (old_type < SVt_RV)
1591 Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type);
1594 if (old_type_details->size) {
1595 /* If the old body had an allocated size, then we need to free it. */
1597 my_safefree(old_body);
1599 del_body((void*)((char*)old_body - old_type_details->offset),
1600 &PL_body_roots[old_type]);
1606 =for apidoc sv_backoff
1608 Remove any string offset. You should normally use the C<SvOOK_off> macro
1615 Perl_sv_backoff(pTHX_ register SV *sv)
1618 assert(SvTYPE(sv) != SVt_PVHV);
1619 assert(SvTYPE(sv) != SVt_PVAV);
1621 const char * const s = SvPVX_const(sv);
1622 SvLEN_set(sv, SvLEN(sv) + SvIVX(sv));
1623 SvPV_set(sv, SvPVX(sv) - SvIVX(sv));
1625 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1627 SvFLAGS(sv) &= ~SVf_OOK;
1634 Expands the character buffer in the SV. If necessary, uses C<sv_unref> and
1635 upgrades the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1636 Use the C<SvGROW> wrapper instead.
1642 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1646 #ifdef HAS_64K_LIMIT
1647 if (newlen >= 0x10000) {
1648 PerlIO_printf(Perl_debug_log,
1649 "Allocation too large: %"UVxf"\n", (UV)newlen);
1652 #endif /* HAS_64K_LIMIT */
1655 if (SvTYPE(sv) < SVt_PV) {
1656 sv_upgrade(sv, SVt_PV);
1657 s = SvPVX_mutable(sv);
1659 else if (SvOOK(sv)) { /* pv is offset? */
1661 s = SvPVX_mutable(sv);
1662 if (newlen > SvLEN(sv))
1663 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1664 #ifdef HAS_64K_LIMIT
1665 if (newlen >= 0x10000)
1670 s = SvPVX_mutable(sv);
1672 if (newlen > SvLEN(sv)) { /* need more room? */
1673 newlen = PERL_STRLEN_ROUNDUP(newlen);
1674 if (SvLEN(sv) && s) {
1676 const STRLEN l = malloced_size((void*)SvPVX_const(sv));
1682 s = saferealloc(s, newlen);
1685 s = safemalloc(newlen);
1686 if (SvPVX_const(sv) && SvCUR(sv)) {
1687 Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1691 SvLEN_set(sv, newlen);
1697 =for apidoc sv_setiv
1699 Copies an integer into the given SV, upgrading first if necessary.
1700 Does not handle 'set' magic. See also C<sv_setiv_mg>.
1706 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1708 SV_CHECK_THINKFIRST_COW_DROP(sv);
1709 switch (SvTYPE(sv)) {
1711 sv_upgrade(sv, SVt_IV);
1714 sv_upgrade(sv, SVt_PVNV);
1718 sv_upgrade(sv, SVt_PVIV);
1727 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1730 (void)SvIOK_only(sv); /* validate number */
1736 =for apidoc sv_setiv_mg
1738 Like C<sv_setiv>, but also handles 'set' magic.
1744 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1751 =for apidoc sv_setuv
1753 Copies an unsigned integer into the given SV, upgrading first if necessary.
1754 Does not handle 'set' magic. See also C<sv_setuv_mg>.
1760 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1762 /* With these two if statements:
1763 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1766 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1768 If you wish to remove them, please benchmark to see what the effect is
1770 if (u <= (UV)IV_MAX) {
1771 sv_setiv(sv, (IV)u);
1780 =for apidoc sv_setuv_mg
1782 Like C<sv_setuv>, but also handles 'set' magic.
1788 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1797 =for apidoc sv_setnv
1799 Copies a double into the given SV, upgrading first if necessary.
1800 Does not handle 'set' magic. See also C<sv_setnv_mg>.
1806 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1808 SV_CHECK_THINKFIRST_COW_DROP(sv);
1809 switch (SvTYPE(sv)) {
1812 sv_upgrade(sv, SVt_NV);
1817 sv_upgrade(sv, SVt_PVNV);
1826 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1830 (void)SvNOK_only(sv); /* validate number */
1835 =for apidoc sv_setnv_mg
1837 Like C<sv_setnv>, but also handles 'set' magic.
1843 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1849 /* Print an "isn't numeric" warning, using a cleaned-up,
1850 * printable version of the offending string
1854 S_not_a_number(pTHX_ SV *sv)
1861 dsv = sv_2mortal(newSVpvn("", 0));
1862 pv = sv_uni_display(dsv, sv, 10, 0);
1865 const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
1866 /* each *s can expand to 4 chars + "...\0",
1867 i.e. need room for 8 chars */
1869 const char *s, *end;
1870 for (s = SvPVX_const(sv), end = s + SvCUR(sv); s < end && d < limit;
1873 if (ch & 128 && !isPRINT_LC(ch)) {
1882 else if (ch == '\r') {
1886 else if (ch == '\f') {
1890 else if (ch == '\\') {
1894 else if (ch == '\0') {
1898 else if (isPRINT_LC(ch))
1915 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1916 "Argument \"%s\" isn't numeric in %s", pv,
1919 Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1920 "Argument \"%s\" isn't numeric", pv);
1924 =for apidoc looks_like_number
1926 Test if the content of an SV looks like a number (or is a number).
1927 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1928 non-numeric warning), even if your atof() doesn't grok them.
1934 Perl_looks_like_number(pTHX_ SV *sv)
1936 register const char *sbegin;
1940 sbegin = SvPVX_const(sv);
1943 else if (SvPOKp(sv))
1944 sbegin = SvPV_const(sv, len);
1946 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
1947 return grok_number(sbegin, len, NULL);
1950 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1951 until proven guilty, assume that things are not that bad... */
1956 As 64 bit platforms often have an NV that doesn't preserve all bits of
1957 an IV (an assumption perl has been based on to date) it becomes necessary
1958 to remove the assumption that the NV always carries enough precision to
1959 recreate the IV whenever needed, and that the NV is the canonical form.
1960 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1961 precision as a side effect of conversion (which would lead to insanity
1962 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1963 1) to distinguish between IV/UV/NV slots that have cached a valid
1964 conversion where precision was lost and IV/UV/NV slots that have a
1965 valid conversion which has lost no precision
1966 2) to ensure that if a numeric conversion to one form is requested that
1967 would lose precision, the precise conversion (or differently
1968 imprecise conversion) is also performed and cached, to prevent
1969 requests for different numeric formats on the same SV causing
1970 lossy conversion chains. (lossless conversion chains are perfectly
1975 SvIOKp is true if the IV slot contains a valid value
1976 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1977 SvNOKp is true if the NV slot contains a valid value
1978 SvNOK is true only if the NV value is accurate
1981 while converting from PV to NV, check to see if converting that NV to an
1982 IV(or UV) would lose accuracy over a direct conversion from PV to
1983 IV(or UV). If it would, cache both conversions, return NV, but mark
1984 SV as IOK NOKp (ie not NOK).
1986 While converting from PV to IV, check to see if converting that IV to an
1987 NV would lose accuracy over a direct conversion from PV to NV. If it
1988 would, cache both conversions, flag similarly.
1990 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1991 correctly because if IV & NV were set NV *always* overruled.
1992 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1993 changes - now IV and NV together means that the two are interchangeable:
1994 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1996 The benefit of this is that operations such as pp_add know that if
1997 SvIOK is true for both left and right operands, then integer addition
1998 can be used instead of floating point (for cases where the result won't
1999 overflow). Before, floating point was always used, which could lead to
2000 loss of precision compared with integer addition.
2002 * making IV and NV equal status should make maths accurate on 64 bit
2004 * may speed up maths somewhat if pp_add and friends start to use
2005 integers when possible instead of fp. (Hopefully the overhead in
2006 looking for SvIOK and checking for overflow will not outweigh the
2007 fp to integer speedup)
2008 * will slow down integer operations (callers of SvIV) on "inaccurate"
2009 values, as the change from SvIOK to SvIOKp will cause a call into
2010 sv_2iv each time rather than a macro access direct to the IV slot
2011 * should speed up number->string conversion on integers as IV is
2012 favoured when IV and NV are equally accurate
2014 ####################################################################
2015 You had better be using SvIOK_notUV if you want an IV for arithmetic:
2016 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
2017 On the other hand, SvUOK is true iff UV.
2018 ####################################################################
2020 Your mileage will vary depending your CPU's relative fp to integer
2024 #ifndef NV_PRESERVES_UV
2025 # define IS_NUMBER_UNDERFLOW_IV 1
2026 # define IS_NUMBER_UNDERFLOW_UV 2
2027 # define IS_NUMBER_IV_AND_UV 2
2028 # define IS_NUMBER_OVERFLOW_IV 4
2029 # define IS_NUMBER_OVERFLOW_UV 5
2031 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
2033 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
2035 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2037 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2038 if (SvNVX(sv) < (NV)IV_MIN) {
2039 (void)SvIOKp_on(sv);
2041 SvIV_set(sv, IV_MIN);
2042 return IS_NUMBER_UNDERFLOW_IV;
2044 if (SvNVX(sv) > (NV)UV_MAX) {
2045 (void)SvIOKp_on(sv);
2048 SvUV_set(sv, UV_MAX);
2049 return IS_NUMBER_OVERFLOW_UV;
2051 (void)SvIOKp_on(sv);
2053 /* Can't use strtol etc to convert this string. (See truth table in
2055 if (SvNVX(sv) <= (UV)IV_MAX) {
2056 SvIV_set(sv, I_V(SvNVX(sv)));
2057 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2058 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2060 /* Integer is imprecise. NOK, IOKp */
2062 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2065 SvUV_set(sv, U_V(SvNVX(sv)));
2066 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2067 if (SvUVX(sv) == UV_MAX) {
2068 /* As we know that NVs don't preserve UVs, UV_MAX cannot
2069 possibly be preserved by NV. Hence, it must be overflow.
2071 return IS_NUMBER_OVERFLOW_UV;
2073 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2075 /* Integer is imprecise. NOK, IOKp */
2077 return IS_NUMBER_OVERFLOW_IV;
2079 #endif /* !NV_PRESERVES_UV*/
2082 =for apidoc sv_2iv_flags
2084 Return the integer value of an SV, doing any necessary string
2085 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2086 Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2092 Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
2096 if (SvGMAGICAL(sv)) {
2097 if (flags & SV_GMAGIC)
2102 return I_V(SvNVX(sv));
2104 if (SvPOKp(sv) && SvLEN(sv))
2107 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2108 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2114 if (SvTHINKFIRST(sv)) {
2117 SV * const tmpstr=AMG_CALLun(sv,numer);
2118 if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2119 return SvIV(tmpstr);
2122 return PTR2IV(SvRV(sv));
2125 sv_force_normal_flags(sv, 0);
2127 if (SvREADONLY(sv) && !SvOK(sv)) {
2128 if (ckWARN(WARN_UNINITIALIZED))
2135 return (IV)(SvUVX(sv));
2142 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2143 * without also getting a cached IV/UV from it at the same time
2144 * (ie PV->NV conversion should detect loss of accuracy and cache
2145 * IV or UV at same time to avoid this. NWC */
2147 if (SvTYPE(sv) == SVt_NV)
2148 sv_upgrade(sv, SVt_PVNV);
2150 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2151 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2152 certainly cast into the IV range at IV_MAX, whereas the correct
2153 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2155 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2156 SvIV_set(sv, I_V(SvNVX(sv)));
2157 if (SvNVX(sv) == (NV) SvIVX(sv)
2158 #ifndef NV_PRESERVES_UV
2159 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2160 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2161 /* Don't flag it as "accurately an integer" if the number
2162 came from a (by definition imprecise) NV operation, and
2163 we're outside the range of NV integer precision */
2166 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2167 DEBUG_c(PerlIO_printf(Perl_debug_log,
2168 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2174 /* IV not precise. No need to convert from PV, as NV
2175 conversion would already have cached IV if it detected
2176 that PV->IV would be better than PV->NV->IV
2177 flags already correct - don't set public IOK. */
2178 DEBUG_c(PerlIO_printf(Perl_debug_log,
2179 "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2184 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2185 but the cast (NV)IV_MIN rounds to a the value less (more
2186 negative) than IV_MIN which happens to be equal to SvNVX ??
2187 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2188 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2189 (NV)UVX == NVX are both true, but the values differ. :-(
2190 Hopefully for 2s complement IV_MIN is something like
2191 0x8000000000000000 which will be exact. NWC */
2194 SvUV_set(sv, U_V(SvNVX(sv)));
2196 (SvNVX(sv) == (NV) SvUVX(sv))
2197 #ifndef NV_PRESERVES_UV
2198 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2199 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2200 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2201 /* Don't flag it as "accurately an integer" if the number
2202 came from a (by definition imprecise) NV operation, and
2203 we're outside the range of NV integer precision */
2209 DEBUG_c(PerlIO_printf(Perl_debug_log,
2210 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2214 return (IV)SvUVX(sv);
2217 else if (SvPOKp(sv) && SvLEN(sv)) {
2219 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2220 /* We want to avoid a possible problem when we cache an IV which
2221 may be later translated to an NV, and the resulting NV is not
2222 the same as the direct translation of the initial string
2223 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2224 be careful to ensure that the value with the .456 is around if the
2225 NV value is requested in the future).
2227 This means that if we cache such an IV, we need to cache the
2228 NV as well. Moreover, we trade speed for space, and do not
2229 cache the NV if we are sure it's not needed.
2232 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2233 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2234 == IS_NUMBER_IN_UV) {
2235 /* It's definitely an integer, only upgrade to PVIV */
2236 if (SvTYPE(sv) < SVt_PVIV)
2237 sv_upgrade(sv, SVt_PVIV);
2239 } else if (SvTYPE(sv) < SVt_PVNV)
2240 sv_upgrade(sv, SVt_PVNV);
2242 /* If NV preserves UV then we only use the UV value if we know that
2243 we aren't going to call atof() below. If NVs don't preserve UVs
2244 then the value returned may have more precision than atof() will
2245 return, even though value isn't perfectly accurate. */
2246 if ((numtype & (IS_NUMBER_IN_UV
2247 #ifdef NV_PRESERVES_UV
2250 )) == IS_NUMBER_IN_UV) {
2251 /* This won't turn off the public IOK flag if it was set above */
2252 (void)SvIOKp_on(sv);
2254 if (!(numtype & IS_NUMBER_NEG)) {
2256 if (value <= (UV)IV_MAX) {
2257 SvIV_set(sv, (IV)value);
2259 SvUV_set(sv, value);
2263 /* 2s complement assumption */
2264 if (value <= (UV)IV_MIN) {
2265 SvIV_set(sv, -(IV)value);
2267 /* Too negative for an IV. This is a double upgrade, but
2268 I'm assuming it will be rare. */
2269 if (SvTYPE(sv) < SVt_PVNV)
2270 sv_upgrade(sv, SVt_PVNV);
2274 SvNV_set(sv, -(NV)value);
2275 SvIV_set(sv, IV_MIN);
2279 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2280 will be in the previous block to set the IV slot, and the next
2281 block to set the NV slot. So no else here. */
2283 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2284 != IS_NUMBER_IN_UV) {
2285 /* It wasn't an (integer that doesn't overflow the UV). */
2286 SvNV_set(sv, Atof(SvPVX_const(sv)));
2288 if (! numtype && ckWARN(WARN_NUMERIC))
2291 #if defined(USE_LONG_DOUBLE)
2292 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2293 PTR2UV(sv), SvNVX(sv)));
2295 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2296 PTR2UV(sv), SvNVX(sv)));
2300 #ifdef NV_PRESERVES_UV
2301 (void)SvIOKp_on(sv);
2303 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2304 SvIV_set(sv, I_V(SvNVX(sv)));
2305 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2308 /* Integer is imprecise. NOK, IOKp */
2310 /* UV will not work better than IV */
2312 if (SvNVX(sv) > (NV)UV_MAX) {
2314 /* Integer is inaccurate. NOK, IOKp, is UV */
2315 SvUV_set(sv, UV_MAX);
2318 SvUV_set(sv, U_V(SvNVX(sv)));
2319 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2320 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2324 /* Integer is imprecise. NOK, IOKp, is UV */
2330 #else /* NV_PRESERVES_UV */
2331 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2332 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2333 /* The IV slot will have been set from value returned by
2334 grok_number above. The NV slot has just been set using
2337 assert (SvIOKp(sv));
2339 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2340 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2341 /* Small enough to preserve all bits. */
2342 (void)SvIOKp_on(sv);
2344 SvIV_set(sv, I_V(SvNVX(sv)));
2345 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2347 /* Assumption: first non-preserved integer is < IV_MAX,
2348 this NV is in the preserved range, therefore: */
2349 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2351 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2355 0 0 already failed to read UV.
2356 0 1 already failed to read UV.
2357 1 0 you won't get here in this case. IV/UV
2358 slot set, public IOK, Atof() unneeded.
2359 1 1 already read UV.
2360 so there's no point in sv_2iuv_non_preserve() attempting
2361 to use atol, strtol, strtoul etc. */
2362 if (sv_2iuv_non_preserve (sv, numtype)
2363 >= IS_NUMBER_OVERFLOW_IV)
2367 #endif /* NV_PRESERVES_UV */
2370 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2372 if (SvTYPE(sv) < SVt_IV)
2373 /* Typically the caller expects that sv_any is not NULL now. */
2374 sv_upgrade(sv, SVt_IV);
2377 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2378 PTR2UV(sv),SvIVX(sv)));
2379 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2383 =for apidoc sv_2uv_flags
2385 Return the unsigned integer value of an SV, doing any necessary string
2386 conversion. If flags includes SV_GMAGIC, does an mg_get() first.
2387 Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
2393 Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
2397 if (SvGMAGICAL(sv)) {
2398 if (flags & SV_GMAGIC)
2403 return U_V(SvNVX(sv));
2404 if (SvPOKp(sv) && SvLEN(sv))
2407 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2408 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2414 if (SvTHINKFIRST(sv)) {
2417 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2418 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2419 return SvUV(tmpstr);
2420 return PTR2UV(SvRV(sv));
2423 sv_force_normal_flags(sv, 0);
2425 if (SvREADONLY(sv) && !SvOK(sv)) {
2426 if (ckWARN(WARN_UNINITIALIZED))
2436 return (UV)SvIVX(sv);
2440 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2441 * without also getting a cached IV/UV from it at the same time
2442 * (ie PV->NV conversion should detect loss of accuracy and cache
2443 * IV or UV at same time to avoid this. */
2444 /* IV-over-UV optimisation - choose to cache IV if possible */
2446 if (SvTYPE(sv) == SVt_NV)
2447 sv_upgrade(sv, SVt_PVNV);
2449 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2450 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2451 SvIV_set(sv, I_V(SvNVX(sv)));
2452 if (SvNVX(sv) == (NV) SvIVX(sv)
2453 #ifndef NV_PRESERVES_UV
2454 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2455 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2456 /* Don't flag it as "accurately an integer" if the number
2457 came from a (by definition imprecise) NV operation, and
2458 we're outside the range of NV integer precision */
2461 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2462 DEBUG_c(PerlIO_printf(Perl_debug_log,
2463 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2469 /* IV not precise. No need to convert from PV, as NV
2470 conversion would already have cached IV if it detected
2471 that PV->IV would be better than PV->NV->IV
2472 flags already correct - don't set public IOK. */
2473 DEBUG_c(PerlIO_printf(Perl_debug_log,
2474 "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2479 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2480 but the cast (NV)IV_MIN rounds to a the value less (more
2481 negative) than IV_MIN which happens to be equal to SvNVX ??
2482 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2483 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2484 (NV)UVX == NVX are both true, but the values differ. :-(
2485 Hopefully for 2s complement IV_MIN is something like
2486 0x8000000000000000 which will be exact. NWC */
2489 SvUV_set(sv, U_V(SvNVX(sv)));
2491 (SvNVX(sv) == (NV) SvUVX(sv))
2492 #ifndef NV_PRESERVES_UV
2493 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2494 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2495 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2496 /* Don't flag it as "accurately an integer" if the number
2497 came from a (by definition imprecise) NV operation, and
2498 we're outside the range of NV integer precision */
2503 DEBUG_c(PerlIO_printf(Perl_debug_log,
2504 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2510 else if (SvPOKp(sv) && SvLEN(sv)) {
2512 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2514 /* We want to avoid a possible problem when we cache a UV which
2515 may be later translated to an NV, and the resulting NV is not
2516 the translation of the initial data.
2518 This means that if we cache such a UV, we need to cache the
2519 NV as well. Moreover, we trade speed for space, and do not
2520 cache the NV if not needed.
2523 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2524 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2525 == IS_NUMBER_IN_UV) {
2526 /* It's definitely an integer, only upgrade to PVIV */
2527 if (SvTYPE(sv) < SVt_PVIV)
2528 sv_upgrade(sv, SVt_PVIV);
2530 } else if (SvTYPE(sv) < SVt_PVNV)
2531 sv_upgrade(sv, SVt_PVNV);
2533 /* If NV preserves UV then we only use the UV value if we know that
2534 we aren't going to call atof() below. If NVs don't preserve UVs
2535 then the value returned may have more precision than atof() will
2536 return, even though it isn't accurate. */
2537 if ((numtype & (IS_NUMBER_IN_UV
2538 #ifdef NV_PRESERVES_UV
2541 )) == IS_NUMBER_IN_UV) {
2542 /* This won't turn off the public IOK flag if it was set above */
2543 (void)SvIOKp_on(sv);
2545 if (!(numtype & IS_NUMBER_NEG)) {
2547 if (value <= (UV)IV_MAX) {
2548 SvIV_set(sv, (IV)value);
2550 /* it didn't overflow, and it was positive. */
2551 SvUV_set(sv, value);
2555 /* 2s complement assumption */
2556 if (value <= (UV)IV_MIN) {
2557 SvIV_set(sv, -(IV)value);
2559 /* Too negative for an IV. This is a double upgrade, but
2560 I'm assuming it will be rare. */
2561 if (SvTYPE(sv) < SVt_PVNV)
2562 sv_upgrade(sv, SVt_PVNV);
2566 SvNV_set(sv, -(NV)value);
2567 SvIV_set(sv, IV_MIN);
2572 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2573 != IS_NUMBER_IN_UV) {
2574 /* It wasn't an integer, or it overflowed the UV. */
2575 SvNV_set(sv, Atof(SvPVX_const(sv)));
2577 if (! numtype && ckWARN(WARN_NUMERIC))
2580 #if defined(USE_LONG_DOUBLE)
2581 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2582 PTR2UV(sv), SvNVX(sv)));
2584 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2585 PTR2UV(sv), SvNVX(sv)));
2588 #ifdef NV_PRESERVES_UV
2589 (void)SvIOKp_on(sv);
2591 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2592 SvIV_set(sv, I_V(SvNVX(sv)));
2593 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2596 /* Integer is imprecise. NOK, IOKp */
2598 /* UV will not work better than IV */
2600 if (SvNVX(sv) > (NV)UV_MAX) {
2602 /* Integer is inaccurate. NOK, IOKp, is UV */
2603 SvUV_set(sv, UV_MAX);
2606 SvUV_set(sv, U_V(SvNVX(sv)));
2607 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2608 NV preservse UV so can do correct comparison. */
2609 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2613 /* Integer is imprecise. NOK, IOKp, is UV */
2618 #else /* NV_PRESERVES_UV */
2619 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2620 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2621 /* The UV slot will have been set from value returned by
2622 grok_number above. The NV slot has just been set using
2625 assert (SvIOKp(sv));
2627 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2628 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2629 /* Small enough to preserve all bits. */
2630 (void)SvIOKp_on(sv);
2632 SvIV_set(sv, I_V(SvNVX(sv)));
2633 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2635 /* Assumption: first non-preserved integer is < IV_MAX,
2636 this NV is in the preserved range, therefore: */
2637 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2639 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2642 sv_2iuv_non_preserve (sv, numtype);
2644 #endif /* NV_PRESERVES_UV */
2648 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2649 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2652 if (SvTYPE(sv) < SVt_IV)
2653 /* Typically the caller expects that sv_any is not NULL now. */
2654 sv_upgrade(sv, SVt_IV);
2658 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2659 PTR2UV(sv),SvUVX(sv)));
2660 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2666 Return the num value of an SV, doing any necessary string or integer
2667 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2674 Perl_sv_2nv(pTHX_ register SV *sv)
2678 if (SvGMAGICAL(sv)) {
2682 if (SvPOKp(sv) && SvLEN(sv)) {
2683 if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) &&
2684 !grok_number(SvPVX_const(sv), SvCUR(sv), NULL))
2686 return Atof(SvPVX_const(sv));
2690 return (NV)SvUVX(sv);
2692 return (NV)SvIVX(sv);
2695 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2696 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
2702 if (SvTHINKFIRST(sv)) {
2705 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2706 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2707 return SvNV(tmpstr);
2708 return PTR2NV(SvRV(sv));
2711 sv_force_normal_flags(sv, 0);
2713 if (SvREADONLY(sv) && !SvOK(sv)) {
2714 if (ckWARN(WARN_UNINITIALIZED))
2719 if (SvTYPE(sv) < SVt_NV) {
2720 if (SvTYPE(sv) == SVt_IV)
2721 sv_upgrade(sv, SVt_PVNV);
2723 sv_upgrade(sv, SVt_NV);
2724 #ifdef USE_LONG_DOUBLE
2726 STORE_NUMERIC_LOCAL_SET_STANDARD();
2727 PerlIO_printf(Perl_debug_log,
2728 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2729 PTR2UV(sv), SvNVX(sv));
2730 RESTORE_NUMERIC_LOCAL();
2734 STORE_NUMERIC_LOCAL_SET_STANDARD();
2735 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2736 PTR2UV(sv), SvNVX(sv));
2737 RESTORE_NUMERIC_LOCAL();
2741 else if (SvTYPE(sv) < SVt_PVNV)
2742 sv_upgrade(sv, SVt_PVNV);
2747 SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv));
2748 #ifdef NV_PRESERVES_UV
2751 /* Only set the public NV OK flag if this NV preserves the IV */
2752 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2753 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2754 : (SvIVX(sv) == I_V(SvNVX(sv))))
2760 else if (SvPOKp(sv) && SvLEN(sv)) {
2762 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2763 if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC))
2765 #ifdef NV_PRESERVES_UV
2766 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2767 == IS_NUMBER_IN_UV) {
2768 /* It's definitely an integer */
2769 SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value);
2771 SvNV_set(sv, Atof(SvPVX_const(sv)));
2774 SvNV_set(sv, Atof(SvPVX_const(sv)));
2775 /* Only set the public NV OK flag if this NV preserves the value in
2776 the PV at least as well as an IV/UV would.
2777 Not sure how to do this 100% reliably. */
2778 /* if that shift count is out of range then Configure's test is
2779 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2781 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2782 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2783 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2784 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2785 /* Can't use strtol etc to convert this string, so don't try.
2786 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2789 /* value has been set. It may not be precise. */
2790 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2791 /* 2s complement assumption for (UV)IV_MIN */
2792 SvNOK_on(sv); /* Integer is too negative. */
2797 if (numtype & IS_NUMBER_NEG) {
2798 SvIV_set(sv, -(IV)value);
2799 } else if (value <= (UV)IV_MAX) {
2800 SvIV_set(sv, (IV)value);
2802 SvUV_set(sv, value);
2806 if (numtype & IS_NUMBER_NOT_INT) {
2807 /* I believe that even if the original PV had decimals,
2808 they are lost beyond the limit of the FP precision.
2809 However, neither is canonical, so both only get p
2810 flags. NWC, 2000/11/25 */
2811 /* Both already have p flags, so do nothing */
2813 const NV nv = SvNVX(sv);
2814 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2815 if (SvIVX(sv) == I_V(nv)) {
2820 /* It had no "." so it must be integer. */
2823 /* between IV_MAX and NV(UV_MAX).
2824 Could be slightly > UV_MAX */
2826 if (numtype & IS_NUMBER_NOT_INT) {
2827 /* UV and NV both imprecise. */
2829 const UV nv_as_uv = U_V(nv);
2831 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2842 #endif /* NV_PRESERVES_UV */
2845 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
2847 if (SvTYPE(sv) < SVt_NV)
2848 /* Typically the caller expects that sv_any is not NULL now. */
2849 /* XXX Ilya implies that this is a bug in callers that assume this
2850 and ideally should be fixed. */
2851 sv_upgrade(sv, SVt_NV);
2854 #if defined(USE_LONG_DOUBLE)
2856 STORE_NUMERIC_LOCAL_SET_STANDARD();
2857 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2858 PTR2UV(sv), SvNVX(sv));
2859 RESTORE_NUMERIC_LOCAL();
2863 STORE_NUMERIC_LOCAL_SET_STANDARD();
2864 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2865 PTR2UV(sv), SvNVX(sv));
2866 RESTORE_NUMERIC_LOCAL();
2872 /* asIV(): extract an integer from the string value of an SV.
2873 * Caller must validate PVX */
2876 S_asIV(pTHX_ SV *sv)
2879 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2881 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2882 == IS_NUMBER_IN_UV) {
2883 /* It's definitely an integer */
2884 if (numtype & IS_NUMBER_NEG) {
2885 if (value < (UV)IV_MIN)
2888 if (value < (UV)IV_MAX)
2893 if (ckWARN(WARN_NUMERIC))
2896 return I_V(Atof(SvPVX_const(sv)));
2899 /* asUV(): extract an unsigned integer from the string value of an SV
2900 * Caller must validate PVX */
2903 S_asUV(pTHX_ SV *sv)
2906 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
2908 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2909 == IS_NUMBER_IN_UV) {
2910 /* It's definitely an integer */
2911 if (!(numtype & IS_NUMBER_NEG))
2915 if (ckWARN(WARN_NUMERIC))
2918 return U_V(Atof(SvPVX_const(sv)));
2921 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2922 * UV as a string towards the end of buf, and return pointers to start and
2925 * We assume that buf is at least TYPE_CHARS(UV) long.
2929 S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2931 char *ptr = buf + TYPE_CHARS(UV);
2932 char * const ebuf = ptr;
2945 *--ptr = '0' + (char)(uv % 10);
2954 =for apidoc sv_2pv_flags
2956 Returns a pointer to the string value of an SV, and sets *lp to its length.
2957 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2959 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2960 usually end up here too.
2966 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2971 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2972 char *tmpbuf = tbuf;
2973 STRLEN len = 0; /* Hush gcc. len is always initialised before use. */
2980 if (SvGMAGICAL(sv)) {
2981 if (flags & SV_GMAGIC)
2986 if (flags & SV_MUTABLE_RETURN)
2987 return SvPVX_mutable(sv);
2988 if (flags & SV_CONST_RETURN)
2989 return (char *)SvPVX_const(sv);
2993 len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv))
2994 : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2996 goto tokensave_has_len;
2999 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
3004 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
3005 if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
3013 if (SvTHINKFIRST(sv)) {
3016 register const char *typestr;
3017 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
3018 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
3020 /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); */
3023 if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
3024 if (flags & SV_CONST_RETURN) {
3025 pv = (char *) SvPVX_const(tmpstr);
3027 pv = (flags & SV_MUTABLE_RETURN)
3028 ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
3031 *lp = SvCUR(tmpstr);
3033 pv = sv_2pv_flags(tmpstr, lp, flags);
3044 typestr = "NULLREF";
3048 switch (SvTYPE(sv)) {
3050 if ( ((SvFLAGS(sv) &
3051 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3052 == (SVs_OBJECT|SVs_SMG))
3053 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3054 const regexp *re = (regexp *)mg->mg_obj;
3057 const char *fptr = "msix";
3062 char need_newline = 0;
3063 U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3065 while((ch = *fptr++)) {
3067 reflags[left++] = ch;
3070 reflags[right--] = ch;
3075 reflags[left] = '-';
3079 mg->mg_len = re->prelen + 4 + left;
3081 * If /x was used, we have to worry about a regex
3082 * ending with a comment later being embedded
3083 * within another regex. If so, we don't want this
3084 * regex's "commentization" to leak out to the
3085 * right part of the enclosing regex, we must cap
3086 * it with a newline.
3088 * So, if /x was used, we scan backwards from the
3089 * end of the regex. If we find a '#' before we
3090 * find a newline, we need to add a newline
3091 * ourself. If we find a '\n' first (or if we
3092 * don't find '#' or '\n'), we don't need to add
3093 * anything. -jfriedl
3095 if (PMf_EXTENDED & re->reganch)
3097 const char *endptr = re->precomp + re->prelen;
3098 while (endptr >= re->precomp)
3100 const char c = *(endptr--);
3102 break; /* don't need another */
3104 /* we end while in a comment, so we
3106 mg->mg_len++; /* save space for it */
3107 need_newline = 1; /* note to add it */
3113 Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
3114 Copy("(?", mg->mg_ptr, 2, char);
3115 Copy(reflags, mg->mg_ptr+2, left, char);
3116 Copy(":", mg->mg_ptr+left+2, 1, char);
3117 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3119 mg->mg_ptr[mg->mg_len - 2] = '\n';
3120 mg->mg_ptr[mg->mg_len - 1] = ')';
3121 mg->mg_ptr[mg->mg_len] = 0;
3123 PL_reginterp_cnt += re->program[0].next_off;
3125 if (re->reganch & ROPT_UTF8)
3141 case SVt_PVBM: typestr = SvROK(sv) ? "REF" : "SCALAR"; break;
3142 case SVt_PVLV: typestr = SvROK(sv) ? "REF"
3143 /* tied lvalues should appear to be
3144 * scalars for backwards compatitbility */
3145 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3146 ? "SCALAR" : "LVALUE"; break;
3147 case SVt_PVAV: typestr = "ARRAY"; break;
3148 case SVt_PVHV: typestr = "HASH"; break;
3149 case SVt_PVCV: typestr = "CODE"; break;
3150 case SVt_PVGV: typestr = "GLOB"; break;
3151 case SVt_PVFM: typestr = "FORMAT"; break;
3152 case SVt_PVIO: typestr = "IO"; break;
3153 default: typestr = "UNKNOWN"; break;
3157 const char * const name = HvNAME_get(SvSTASH(sv));
3158 Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
3159 name ? name : "__ANON__" , typestr, PTR2UV(sv));
3162 Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr, PTR2UV(sv));
3166 *lp = strlen(typestr);
3167 return (char *)typestr;
3169 if (SvREADONLY(sv) && !SvOK(sv)) {
3170 if (ckWARN(WARN_UNINITIALIZED))
3177 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3178 /* I'm assuming that if both IV and NV are equally valid then
3179 converting the IV is going to be more efficient */
3180 const U32 isIOK = SvIOK(sv);
3181 const U32 isUIOK = SvIsUV(sv);
3182 char buf[TYPE_CHARS(UV)];
3185 if (SvTYPE(sv) < SVt_PVIV)
3186 sv_upgrade(sv, SVt_PVIV);
3188 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3190 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3191 /* inlined from sv_setpvn */
3192 SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1));
3193 Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char);
3194 SvCUR_set(sv, ebuf - ptr);
3204 else if (SvNOKp(sv)) {
3205 if (SvTYPE(sv) < SVt_PVNV)
3206 sv_upgrade(sv, SVt_PVNV);
3207 /* The +20 is pure guesswork. Configure test needed. --jhi */
3208 s = SvGROW_mutable(sv, NV_DIG + 20);
3209 olderrno = errno; /* some Xenix systems wipe out errno here */
3211 if (SvNVX(sv) == 0.0)
3212 (void)strcpy(s,"0");
3216 Gconvert(SvNVX(sv), NV_DIG, 0, s);
3219 #ifdef FIXNEGATIVEZERO
3220 if (*s == '-' && s[1] == '0' && !s[2])
3230 if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
3234 if (SvTYPE(sv) < SVt_PV)
3235 /* Typically the caller expects that sv_any is not NULL now. */
3236 sv_upgrade(sv, SVt_PV);
3240 const STRLEN len = s - SvPVX_const(sv);
3246 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3247 PTR2UV(sv),SvPVX_const(sv)));
3248 if (flags & SV_CONST_RETURN)
3249 return (char *)SvPVX_const(sv);
3250 if (flags & SV_MUTABLE_RETURN)
3251 return SvPVX_mutable(sv);
3255 len = strlen(tmpbuf);
3258 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
3259 /* Sneaky stuff here */
3263 tsv = newSVpvn(tmpbuf, len);
3272 #ifdef FIXNEGATIVEZERO
3273 if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') {
3279 SvUPGRADE(sv, SVt_PV);
3282 s = SvGROW_mutable(sv, len + 1);
3285 return memcpy(s, tmpbuf, len + 1);
3290 =for apidoc sv_copypv
3292 Copies a stringified representation of the source SV into the
3293 destination SV. Automatically performs any necessary mg_get and
3294 coercion of numeric values into strings. Guaranteed to preserve
3295 UTF-8 flag even from overloaded objects. Similar in nature to
3296 sv_2pv[_flags] but operates directly on an SV instead of just the
3297 string. Mostly uses sv_2pv_flags to do its work, except when that
3298 would lose the UTF-8'ness of the PV.
3304 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3307 const char * const s = SvPV_const(ssv,len);
3308 sv_setpvn(dsv,s,len);
3316 =for apidoc sv_2pvbyte
3318 Return a pointer to the byte-encoded representation of the SV, and set *lp
3319 to its length. May cause the SV to be downgraded from UTF-8 as a
3322 Usually accessed via the C<SvPVbyte> macro.
3328 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3330 sv_utf8_downgrade(sv,0);
3331 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3335 =for apidoc sv_2pvutf8
3337 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3338 to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
3340 Usually accessed via the C<SvPVutf8> macro.
3346 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3348 sv_utf8_upgrade(sv);
3349 return lp ? SvPV(sv,*lp) : SvPV_nolen(sv);
3354 =for apidoc sv_2bool
3356 This function is only called on magical items, and is only used by
3357 sv_true() or its macro equivalent.
3363 Perl_sv_2bool(pTHX_ register SV *sv)
3371 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3372 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3373 return (bool)SvTRUE(tmpsv);
3374 return SvRV(sv) != 0;
3377 register XPV* const Xpvtmp = (XPV*)SvANY(sv);
3379 (*sv->sv_u.svu_pv > '0' ||
3380 Xpvtmp->xpv_cur > 1 ||
3381 (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
3388 return SvIVX(sv) != 0;
3391 return SvNVX(sv) != 0.0;
3399 =for apidoc sv_utf8_upgrade
3401 Converts the PV of an SV to its UTF-8-encoded form.
3402 Forces the SV to string form if it is not already.
3403 Always sets the SvUTF8 flag to avoid future validity checks even
3404 if all the bytes have hibit clear.
3406 This is not as a general purpose byte encoding to Unicode interface:
3407 use the Encode extension for that.
3409 =for apidoc sv_utf8_upgrade_flags
3411 Converts the PV of an SV to its UTF-8-encoded form.
3412 Forces the SV to string form if it is not already.
3413 Always sets the SvUTF8 flag to avoid future validity checks even
3414 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3415 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3416 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3418 This is not as a general purpose byte encoding to Unicode interface:
3419 use the Encode extension for that.
3425 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3427 if (sv == &PL_sv_undef)
3431 if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
3432 (void) sv_2pv_flags(sv,&len, flags);
3436 (void) SvPV_force(sv,len);
3445 sv_force_normal_flags(sv, 0);
3448 if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3449 sv_recode_to_utf8(sv, PL_encoding);
3450 else { /* Assume Latin-1/EBCDIC */
3451 /* This function could be much more efficient if we
3452 * had a FLAG in SVs to signal if there are any hibit
3453 * chars in the PV. Given that there isn't such a flag
3454 * make the loop as fast as possible. */
3455 const U8 *s = (U8 *) SvPVX_const(sv);
3456 const U8 * const e = (U8 *) SvEND(sv);
3462 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3466 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
3467 U8 * const recoded = bytes_to_utf8((U8*)s, &len);
3469 SvPV_free(sv); /* No longer using what was there before. */
3471 SvPV_set(sv, (char*)recoded);
3472 SvCUR_set(sv, len - 1);
3473 SvLEN_set(sv, len); /* No longer know the real size. */
3475 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3482 =for apidoc sv_utf8_downgrade
3484 Attempts to convert the PV of an SV from characters to bytes.
3485 If the PV contains a character beyond byte, this conversion will fail;
3486 in this case, either returns false or, if C<fail_ok> is not
3489 This is not as a general purpose Unicode to byte encoding interface:
3490 use the Encode extension for that.
3496 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3498 if (SvPOKp(sv) && SvUTF8(sv)) {
3504 sv_force_normal_flags(sv, 0);
3506 s = (U8 *) SvPV(sv, len);
3507 if (!utf8_to_bytes(s, &len)) {
3512 Perl_croak(aTHX_ "Wide character in %s",
3515 Perl_croak(aTHX_ "Wide character");
3526 =for apidoc sv_utf8_encode
3528 Converts the PV of an SV to UTF-8, but then turns the C<SvUTF8>
3529 flag off so that it looks like octets again.
3535 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3537 (void) sv_utf8_upgrade(sv);
3539 sv_force_normal_flags(sv, 0);
3541 if (SvREADONLY(sv)) {
3542 Perl_croak(aTHX_ PL_no_modify);
3548 =for apidoc sv_utf8_decode
3550 If the PV of the SV is an octet sequence in UTF-8
3551 and contains a multiple-byte character, the C<SvUTF8> flag is turned on
3552 so that it looks like a character. If the PV contains only single-byte
3553 characters, the C<SvUTF8> flag stays being off.
3554 Scans PV for validity and returns false if the PV is invalid UTF-8.
3560 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3566 /* The octets may have got themselves encoded - get them back as
3569 if (!sv_utf8_downgrade(sv, TRUE))
3572 /* it is actually just a matter of turning the utf8 flag on, but
3573 * we want to make sure everything inside is valid utf8 first.
3575 c = (const U8 *) SvPVX_const(sv);
3576 if (!is_utf8_string(c, SvCUR(sv)+1))
3578 e = (const U8 *) SvEND(sv);
3581 if (!UTF8_IS_INVARIANT(ch)) {
3591 =for apidoc sv_setsv
3593 Copies the contents of the source SV C<ssv> into the destination SV
3594 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3595 function if the source SV needs to be reused. Does not handle 'set' magic.
3596 Loosely speaking, it performs a copy-by-value, obliterating any previous
3597 content of the destination.
3599 You probably want to use one of the assortment of wrappers, such as
3600 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3601 C<SvSetMagicSV_nosteal>.
3603 =for apidoc sv_setsv_flags
3605 Copies the contents of the source SV C<ssv> into the destination SV
3606 C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
3607 function if the source SV needs to be reused. Does not handle 'set' magic.
3608 Loosely speaking, it performs a copy-by-value, obliterating any previous
3609 content of the destination.
3610 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3611 C<ssv> if appropriate, else not. If the C<flags> parameter has the
3612 C<NOSTEAL> bit set then the buffers of temps will not be stolen. <sv_setsv>
3613 and C<sv_setsv_nomg> are implemented in terms of this function.
3615 You probably want to use one of the assortment of wrappers, such as
3616 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3617 C<SvSetMagicSV_nosteal>.
3619 This is the primary function for copying scalars, and most other
3620 copy-ish functions and macros use this underneath.
3626 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3628 register U32 sflags;
3634 SV_CHECK_THINKFIRST_COW_DROP(dstr);
3636 sstr = &PL_sv_undef;
3637 stype = SvTYPE(sstr);
3638 dtype = SvTYPE(dstr);
3643 /* need to nuke the magic */
3645 SvRMAGICAL_off(dstr);
3648 /* There's a lot of redundancy below but we're going for speed here */
3653 if (dtype != SVt_PVGV) {
3654 (void)SvOK_off(dstr);
3662 sv_upgrade(dstr, SVt_IV);
3665 sv_upgrade(dstr, SVt_PVNV);
3669 sv_upgrade(dstr, SVt_PVIV);
3672 (void)SvIOK_only(dstr);
3673 SvIV_set(dstr, SvIVX(sstr));
3676 if (SvTAINTED(sstr))
3687 sv_upgrade(dstr, SVt_NV);
3692 sv_upgrade(dstr, SVt_PVNV);
3695 SvNV_set(dstr, SvNVX(sstr));
3696 (void)SvNOK_only(dstr);
3697 if (SvTAINTED(sstr))
3705 sv_upgrade(dstr, SVt_RV);
3706 else if (dtype == SVt_PVGV &&
3707 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3710 if (GvIMPORTED(dstr) != GVf_IMPORTED
3711 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3713 GvIMPORTED_on(dstr);
3722 #ifdef PERL_OLD_COPY_ON_WRITE
3723 if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
3724 if (dtype < SVt_PVIV)
3725 sv_upgrade(dstr, SVt_PVIV);
3732 sv_upgrade(dstr, SVt_PV);
3735 if (dtype < SVt_PVIV)
3736 sv_upgrade(dstr, SVt_PVIV);
3739 if (dtype < SVt_PVNV)
3740 sv_upgrade(dstr, SVt_PVNV);
3747 const char * const type = sv_reftype(sstr,0);
3749 Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_NAME(PL_op));
3751 Perl_croak(aTHX_ "Bizarre copy of %s", type);
3756 if (dtype <= SVt_PVGV) {
3758 if (dtype != SVt_PVGV) {
3759 const char * const name = GvNAME(sstr);
3760 const STRLEN len = GvNAMELEN(sstr);
3761 /* don't upgrade SVt_PVLV: it can hold a glob */
3762 if (dtype != SVt_PVLV)
3763 sv_upgrade(dstr, SVt_PVGV);
3764 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3765 GvSTASH(dstr) = GvSTASH(sstr);
3767 Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr);
3768 GvNAME(dstr) = savepvn(name, len);
3769 GvNAMELEN(dstr) = len;
3770 SvFAKE_on(dstr); /* can coerce to non-glob */
3773 #ifdef GV_UNIQUE_CHECK
3774 if (GvUNIQUE((GV*)dstr)) {
3775 Perl_croak(aTHX_ PL_no_modify);
3779 (void)SvOK_off(dstr);
3780 GvINTRO_off(dstr); /* one-shot flag */
3782 GvGP(dstr) = gp_ref(GvGP(sstr));
3783 if (SvTAINTED(sstr))
3785 if (GvIMPORTED(dstr) != GVf_IMPORTED
3786 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3788 GvIMPORTED_on(dstr);
3796 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3798 if ((int)SvTYPE(sstr) != stype) {
3799 stype = SvTYPE(sstr);
3800 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3804 if (stype == SVt_PVLV)
3805 SvUPGRADE(dstr, SVt_PVNV);
3807 SvUPGRADE(dstr, (U32)stype);
3810 sflags = SvFLAGS(sstr);
3812 if (sflags & SVf_ROK) {
3813 if (dtype >= SVt_PV) {
3814 if (dtype == SVt_PVGV) {
3815 SV * const sref = SvREFCNT_inc(SvRV(sstr));
3817 const int intro = GvINTRO(dstr);
3819 #ifdef GV_UNIQUE_CHECK
3820 if (GvUNIQUE((GV*)dstr)) {
3821 Perl_croak(aTHX_ PL_no_modify);
3826 GvINTRO_off(dstr); /* one-shot flag */
3827 GvLINE(dstr) = CopLINE(PL_curcop);
3828 GvEGV(dstr) = (GV*)dstr;
3831 switch (SvTYPE(sref)) {
3834 SAVEGENERICSV(GvAV(dstr));
3836 dref = (SV*)GvAV(dstr);
3837 GvAV(dstr) = (AV*)sref;
3838 if (!GvIMPORTED_AV(dstr)
3839 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3841 GvIMPORTED_AV_on(dstr);
3846 SAVEGENERICSV(GvHV(dstr));
3848 dref = (SV*)GvHV(dstr);
3849 GvHV(dstr) = (HV*)sref;
3850 if (!GvIMPORTED_HV(dstr)
3851 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3853 GvIMPORTED_HV_on(dstr);
3858 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3859 SvREFCNT_dec(GvCV(dstr));
3860 GvCV(dstr) = Nullcv;
3861 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3862 PL_sub_generation++;
3864 SAVEGENERICSV(GvCV(dstr));
3867 dref = (SV*)GvCV(dstr);
3868 if (GvCV(dstr) != (CV*)sref) {
3869 CV* const cv = GvCV(dstr);
3871 if (!GvCVGEN((GV*)dstr) &&
3872 (CvROOT(cv) || CvXSUB(cv)))
3874 /* Redefining a sub - warning is mandatory if
3875 it was a const and its value changed. */
3876 if (ckWARN(WARN_REDEFINE)
3878 && (!CvCONST((CV*)sref)
3879 || sv_cmp(cv_const_sv(cv),
3880 cv_const_sv((CV*)sref)))))
3882 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3884 ? "Constant subroutine %s::%s redefined"
3885 : "Subroutine %s::%s redefined",
3886 HvNAME_get(GvSTASH((GV*)dstr)),
3887 GvENAME((GV*)dstr));
3891 cv_ckproto(cv, (GV*)dstr,
3893 ? SvPVX_const(sref) : Nullch);
3895 GvCV(dstr) = (CV*)sref;
3896 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3897 GvASSUMECV_on(dstr);
3898 PL_sub_generation++;
3900 if (!GvIMPORTED_CV(dstr)
3901 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3903 GvIMPORTED_CV_on(dstr);
3908 SAVEGENERICSV(GvIOp(dstr));
3910 dref = (SV*)GvIOp(dstr);
3911 GvIOp(dstr) = (IO*)sref;
3915 SAVEGENERICSV(GvFORM(dstr));
3917 dref = (SV*)GvFORM(dstr);
3918 GvFORM(dstr) = (CV*)sref;
3922 SAVEGENERICSV(GvSV(dstr));
3924 dref = (SV*)GvSV(dstr);
3926 if (!GvIMPORTED_SV(dstr)
3927 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3929 GvIMPORTED_SV_on(dstr);
3935 if (SvTAINTED(sstr))
3939 if (SvPVX_const(dstr)) {
3945 (void)SvOK_off(dstr);
3946 SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr)));
3948 if (sflags & SVp_NOK) {
3950 /* Only set the public OK flag if the source has public OK. */
3951 if (sflags & SVf_NOK)
3952 SvFLAGS(dstr) |= SVf_NOK;
3953 SvNV_set(dstr, SvNVX(sstr));
3955 if (sflags & SVp_IOK) {
3956 (void)SvIOKp_on(dstr);
3957 if (sflags & SVf_IOK)
3958 SvFLAGS(dstr) |= SVf_IOK;
3959 if (sflags & SVf_IVisUV)
3961 SvIV_set(dstr, SvIVX(sstr));
3963 if (SvAMAGIC(sstr)) {
3967 else if (sflags & SVp_POK) {
3971 * Check to see if we can just swipe the string. If so, it's a
3972 * possible small lose on short strings, but a big win on long ones.
3973 * It might even be a win on short strings if SvPVX_const(dstr)
3974 * has to be allocated and SvPVX_const(sstr) has to be freed.
3977 /* Whichever path we take through the next code, we want this true,
3978 and doing it now facilitates the COW check. */
3979 (void)SvPOK_only(dstr);
3982 /* We're not already COW */
3983 ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
3984 #ifndef PERL_OLD_COPY_ON_WRITE
3985 /* or we are, but dstr isn't a suitable target. */
3986 || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS
3991 (sflags & SVs_TEMP) && /* slated for free anyway? */
3992 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3993 (!(flags & SV_NOSTEAL)) &&
3994 /* and we're allowed to steal temps */
3995 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3996 SvLEN(sstr) && /* and really is a string */
3997 /* and won't be needed again, potentially */
3998 !(PL_op && PL_op->op_type == OP_AASSIGN))
3999 #ifdef PERL_OLD_COPY_ON_WRITE
4000 && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
4001 && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
4002 && SvTYPE(sstr) >= SVt_PVIV)
4005 /* Failed the swipe test, and it's not a shared hash key either.
4006 Have to copy the string. */
4007 STRLEN len = SvCUR(sstr);
4008 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
4009 Move(SvPVX_const(sstr),SvPVX(dstr),len,char);
4010 SvCUR_set(dstr, len);
4011 *SvEND(dstr) = '\0';
4013 /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
4015 /* Either it's a shared hash key, or it's suitable for
4016 copy-on-write or we can swipe the string. */
4018 PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
4022 #ifdef PERL_OLD_COPY_ON_WRITE
4024 /* I believe I should acquire a global SV mutex if
4025 it's a COW sv (not a shared hash key) to stop
4026 it going un copy-on-write.
4027 If the source SV has gone un copy on write between up there
4028 and down here, then (assert() that) it is of the correct
4029 form to make it copy on write again */
4030 if ((sflags & (SVf_FAKE | SVf_READONLY))
4031 != (SVf_FAKE | SVf_READONLY)) {
4032 SvREADONLY_on(sstr);
4034 /* Make the source SV into a loop of 1.
4035 (about to become 2) */
4036 SV_COW_NEXT_SV_SET(sstr, sstr);
4040 /* Initial code is common. */
4041 if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
4046 /* making another shared SV. */
4047 STRLEN cur = SvCUR(sstr);
4048 STRLEN len = SvLEN(sstr);
4049 #ifdef PERL_OLD_COPY_ON_WRITE
4051 assert (SvTYPE(dstr) >= SVt_PVIV);
4052 /* SvIsCOW_normal */
4053 /* splice us in between source and next-after-source. */
4054 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4055 SV_COW_NEXT_SV_SET(sstr, dstr);
4056 SvPV_set(dstr, SvPVX_mutable(sstr));
4060 /* SvIsCOW_shared_hash */
4061 DEBUG_C(PerlIO_printf(Perl_debug_log,
4062 "Copy on write: Sharing hash\n"));
4064 assert (SvTYPE(dstr) >= SVt_PV);
4066 HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
4068 SvLEN_set(dstr, len);
4069 SvCUR_set(dstr, cur);
4070 SvREADONLY_on(dstr);
4072 /* Relesase a global SV mutex. */
4075 { /* Passes the swipe test. */
4076 SvPV_set(dstr, SvPVX_mutable(sstr));
4077 SvLEN_set(dstr, SvLEN(sstr));
4078 SvCUR_set(dstr, SvCUR(sstr));
4081 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
4082 SvPV_set(sstr, Nullch);
4088 if (sflags & SVf_UTF8)
4090 if (sflags & SVp_NOK) {
4092 if (sflags & SVf_NOK)
4093 SvFLAGS(dstr) |= SVf_NOK;
4094 SvNV_set(dstr, SvNVX(sstr));
4096 if (sflags & SVp_IOK) {
4097 (void)SvIOKp_on(dstr);
4098 if (sflags & SVf_IOK)
4099 SvFLAGS(dstr) |= SVf_IOK;
4100 if (sflags & SVf_IVisUV)
4102 SvIV_set(dstr, SvIVX(sstr));
4105 MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4106 sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4107 smg->mg_ptr, smg->mg_len);
4108 SvRMAGICAL_on(dstr);
4111 else if (sflags & SVp_IOK) {
4112 if (sflags & SVf_IOK)
4113 (void)SvIOK_only(dstr);
4115 (void)SvOK_off(dstr);
4116 (void)SvIOKp_on(dstr);
4118 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
4119 if (sflags & SVf_IVisUV)
4121 SvIV_set(dstr, SvIVX(sstr));
4122 if (sflags & SVp_NOK) {
4123 if (sflags & SVf_NOK)
4124 (void)SvNOK_on(dstr);
4126 (void)SvNOKp_on(dstr);
4127 SvNV_set(dstr, SvNVX(sstr));
4130 else if (sflags & SVp_NOK) {
4131 if (sflags & SVf_NOK)
4132 (void)SvNOK_only(dstr);
4134 (void)SvOK_off(dstr);
4137 SvNV_set(dstr, SvNVX(sstr));
4140 if (dtype == SVt_PVGV) {
4141 if (ckWARN(WARN_MISC))
4142 Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4145 (void)SvOK_off(dstr);
4147 if (SvTAINTED(sstr))
4152 =for apidoc sv_setsv_mg
4154 Like C<sv_setsv>, but also handles 'set' magic.
4160 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4162 sv_setsv(dstr,sstr);
4166 #ifdef PERL_OLD_COPY_ON_WRITE
4168 Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
4170 STRLEN cur = SvCUR(sstr);
4171 STRLEN len = SvLEN(sstr);
4172 register char *new_pv;
4175 PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
4183 if (SvTHINKFIRST(dstr))
4184 sv_force_normal_flags(dstr, SV_COW_DROP_PV);
4185 else if (SvPVX_const(dstr))
4186 Safefree(SvPVX_const(dstr));
4190 SvUPGRADE(dstr, SVt_PVIV);
4192 assert (SvPOK(sstr));
4193 assert (SvPOKp(sstr));
4194 assert (!SvIOK(sstr));
4195 assert (!SvIOKp(sstr));
4196 assert (!SvNOK(sstr));
4197 assert (!SvNOKp(sstr));
4199 if (SvIsCOW(sstr)) {
4201 if (SvLEN(sstr) == 0) {
4202 /* source is a COW shared hash key. */
4203 DEBUG_C(PerlIO_printf(Perl_debug_log,
4204 "Fast copy on write: Sharing hash\n"));
4205 new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr))));
4208 SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
4210 assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
4211 SvUPGRADE(sstr, SVt_PVIV);
4212 SvREADONLY_on(sstr);
4214 DEBUG_C(PerlIO_printf(Perl_debug_log,
4215 "Fast copy on write: Converting sstr to COW\n"));
4216 SV_COW_NEXT_SV_SET(dstr, sstr);
4218 SV_COW_NEXT_SV_SET(sstr, dstr);
4219 new_pv = SvPVX_mutable(sstr);
4222 SvPV_set(dstr, new_pv);
4223 SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
4226 SvLEN_set(dstr, len);
4227 SvCUR_set(dstr, cur);
4236 =for apidoc sv_setpvn
4238 Copies a string into an SV. The C<len> parameter indicates the number of
4239 bytes to be copied. If the C<ptr> argument is NULL the SV will become
4240 undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
4246 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4248 register char *dptr;
4250 SV_CHECK_THINKFIRST_COW_DROP(sv);
4256 /* len is STRLEN which is unsigned, need to copy to signed */
4259 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4261 SvUPGRADE(sv, SVt_PV);
4263 dptr = SvGROW(sv, len + 1);
4264 Move(ptr,dptr,len,char);
4267 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4272 =for apidoc sv_setpvn_mg
4274 Like C<sv_setpvn>, but also handles 'set' magic.
4280 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4282 sv_setpvn(sv,ptr,len);
4287 =for apidoc sv_setpv
4289 Copies a string into an SV. The string must be null-terminated. Does not
4290 handle 'set' magic. See C<sv_setpv_mg>.
4296 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4298 register STRLEN len;
4300 SV_CHECK_THINKFIRST_COW_DROP(sv);
4306 SvUPGRADE(sv, SVt_PV);
4308 SvGROW(sv, len + 1);
4309 Move(ptr,SvPVX(sv),len+1,char);
4311 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4316 =for apidoc sv_setpv_mg
4318 Like C<sv_setpv>, but also handles 'set' magic.
4324 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4331 =for apidoc sv_usepvn
4333 Tells an SV to use C<ptr> to find its string value. Normally the string is
4334 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4335 The C<ptr> should point to memory that was allocated by C<malloc>. The
4336 string length, C<len>, must be supplied. This function will realloc the
4337 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4338 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
4339 See C<sv_usepvn_mg>.
4345 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4348 SV_CHECK_THINKFIRST_COW_DROP(sv);
4349 SvUPGRADE(sv, SVt_PV);
4354 if (SvPVX_const(sv))
4357 allocate = PERL_STRLEN_ROUNDUP(len + 1);
4358 ptr = saferealloc (ptr, allocate);
4361 SvLEN_set(sv, allocate);
4363 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4368 =for apidoc sv_usepvn_mg
4370 Like C<sv_usepvn>, but also handles 'set' magic.
4376 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4378 sv_usepvn(sv,ptr,len);
4382 #ifdef PERL_OLD_COPY_ON_WRITE
4383 /* Need to do this *after* making the SV normal, as we need the buffer
4384 pointer to remain valid until after we've copied it. If we let go too early,
4385 another thread could invalidate it by unsharing last of the same hash key
4386 (which it can do by means other than releasing copy-on-write Svs)
4387 or by changing the other copy-on-write SVs in the loop. */
4389 S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after)
4391 if (len) { /* this SV was SvIsCOW_normal(sv) */
4392 /* we need to find the SV pointing to us. */
4393 SV * const current = SV_COW_NEXT_SV(after);
4395 if (current == sv) {
4396 /* The SV we point to points back to us (there were only two of us
4398 Hence other SV is no longer copy on write either. */
4400 SvREADONLY_off(after);
4402 /* We need to follow the pointers around the loop. */
4404 while ((next = SV_COW_NEXT_SV(current)) != sv) {
4407 /* don't loop forever if the structure is bust, and we have
4408 a pointer into a closed loop. */
4409 assert (current != after);
4410 assert (SvPVX_const(current) == pvx);
4412 /* Make the SV before us point to the SV after us. */
4413 SV_COW_NEXT_SV_SET(current, after);
4416 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4421 Perl_sv_release_IVX(pTHX_ register SV *sv)
4424 sv_force_normal_flags(sv, 0);
4430 =for apidoc sv_force_normal_flags
4432 Undo various types of fakery on an SV: if the PV is a shared string, make
4433 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4434 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
4435 we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
4436 then a copy-on-write scalar drops its PV buffer (if any) and becomes
4437 SvPOK_off rather than making a copy. (Used where this scalar is about to be
4438 set to some other value.) In addition, the C<flags> parameter gets passed to
4439 C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
4440 with flags set to 0.
4446 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4448 #ifdef PERL_OLD_COPY_ON_WRITE
4449 if (SvREADONLY(sv)) {
4450 /* At this point I believe I should acquire a global SV mutex. */
4452 const char * const pvx = SvPVX_const(sv);
4453 const STRLEN len = SvLEN(sv);
4454 const STRLEN cur = SvCUR(sv);
4455 SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */
4457 PerlIO_printf(Perl_debug_log,
4458 "Copy on write: Force normal %ld\n",
4464 /* This SV doesn't own the buffer, so need to Newx() a new one: */
4465 SvPV_set(sv, (char*)0);
4467 if (flags & SV_COW_DROP_PV) {
4468 /* OK, so we don't need to copy our buffer. */
4471 SvGROW(sv, cur + 1);
4472 Move(pvx,SvPVX(sv),cur,char);
4476 sv_release_COW(sv, pvx, len, next);
4481 else if (IN_PERL_RUNTIME)
4482 Perl_croak(aTHX_ PL_no_modify);
4483 /* At this point I believe that I can drop the global SV mutex. */
4486 if (SvREADONLY(sv)) {
4488 const char * const pvx = SvPVX_const(sv);
4489 const STRLEN len = SvCUR(sv);
4492 SvPV_set(sv, Nullch);
4494 SvGROW(sv, len + 1);
4495 Move(pvx,SvPVX(sv),len,char);
4497 unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
4499 else if (IN_PERL_RUNTIME)
4500 Perl_croak(aTHX_ PL_no_modify);
4504 sv_unref_flags(sv, flags);
4505 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4512 Efficient removal of characters from the beginning of the string buffer.
4513 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4514 the string buffer. The C<ptr> becomes the first character of the adjusted
4515 string. Uses the "OOK hack".
4516 Beware: after this function returns, C<ptr> and SvPVX_const(sv) may no longer
4517 refer to the same chunk of data.
4523 Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr)
4525 register STRLEN delta;
4526 if (!ptr || !SvPOKp(sv))
4528 delta = ptr - SvPVX_const(sv);
4529 SV_CHECK_THINKFIRST(sv);
4530 if (SvTYPE(sv) < SVt_PVIV)
4531 sv_upgrade(sv,SVt_PVIV);
4534 if (!SvLEN(sv)) { /* make copy of shared string */
4535 const char *pvx = SvPVX_const(sv);
4536 const STRLEN len = SvCUR(sv);
4537 SvGROW(sv, len + 1);
4538 Move(pvx,SvPVX(sv),len,char);
4542 /* Same SvOOK_on but SvOOK_on does a SvIOK_off
4543 and we do that anyway inside the SvNIOK_off
4545 SvFLAGS(sv) |= SVf_OOK;
4548 SvLEN_set(sv, SvLEN(sv) - delta);
4549 SvCUR_set(sv, SvCUR(sv) - delta);
4550 SvPV_set(sv, SvPVX(sv) + delta);
4551 SvIV_set(sv, SvIVX(sv) + delta);
4555 =for apidoc sv_catpvn
4557 Concatenates the string onto the end of the string which is in the SV. The
4558 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4559 status set, then the bytes appended should be valid UTF-8.
4560 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
4562 =for apidoc sv_catpvn_flags
4564 Concatenates the string onto the end of the string which is in the SV. The
4565 C<len> indicates number of bytes to copy. If the SV has the UTF-8
4566 status set, then the bytes appended should be valid UTF-8.
4567 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4568 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4569 in terms of this function.
4575 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4578 const char *dstr = SvPV_force_flags(dsv, dlen, flags);
4580 SvGROW(dsv, dlen + slen + 1);
4582 sstr = SvPVX_const(dsv);
4583 Move(sstr, SvPVX(dsv) + dlen, slen, char);
4584 SvCUR_set(dsv, SvCUR(dsv) + slen);
4586 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
4588 if (flags & SV_SMAGIC)
4593 =for apidoc sv_catsv
4595 Concatenates the string from SV C<ssv> onto the end of the string in
4596 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
4597 not 'set' magic. See C<sv_catsv_mg>.
4599 =for apidoc sv_catsv_flags
4601 Concatenates the string from SV C<ssv> onto the end of the string in
4602 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
4603 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4604 and C<sv_catsv_nomg> are implemented in terms of this function.
4609 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4614 if ((spv = SvPV_const(ssv, slen))) {
4615 /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4616 gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4617 Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4618 get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
4619 dsv->sv_flags doesn't have that bit set.
4620 Andy Dougherty 12 Oct 2001
4622 const I32 sutf8 = DO_UTF8(ssv);
4625 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4627 dutf8 = DO_UTF8(dsv);
4629 if (dutf8 != sutf8) {
4631 /* Not modifying source SV, so taking a temporary copy. */
4632 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4634 sv_utf8_upgrade(csv);
4635 spv = SvPV_const(csv, slen);
4638 sv_utf8_upgrade_nomg(dsv);
4640 sv_catpvn_nomg(dsv, spv, slen);
4643 if (flags & SV_SMAGIC)
4648 =for apidoc sv_catpv
4650 Concatenates the string onto the end of the string which is in the SV.
4651 If the SV has the UTF-8 status set, then the bytes appended should be
4652 valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4657 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4659 register STRLEN len;
4665 junk = SvPV_force(sv, tlen);
4667 SvGROW(sv, tlen + len + 1);
4669 ptr = SvPVX_const(sv);
4670 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4671 SvCUR_set(sv, SvCUR(sv) + len);
4672 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4677 =for apidoc sv_catpv_mg
4679 Like C<sv_catpv>, but also handles 'set' magic.
4685 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4694 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4695 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4702 Perl_newSV(pTHX_ STRLEN len)
4708 sv_upgrade(sv, SVt_PV);
4709 SvGROW(sv, len + 1);
4714 =for apidoc sv_magicext
4716 Adds magic to an SV, upgrading it if necessary. Applies the
4717 supplied vtable and returns a pointer to the magic added.
4719 Note that C<sv_magicext> will allow things that C<sv_magic> will not.
4720 In particular, you can add magic to SvREADONLY SVs, and add more than
4721 one instance of the same 'how'.
4723 If C<namlen> is greater than zero then a C<savepvn> I<copy> of C<name> is
4724 stored, if C<namlen> is zero then C<name> is stored as-is and - as another
4725 special case - if C<(name && namlen == HEf_SVKEY)> then C<name> is assumed
4726 to contain an C<SV*> and is stored as-is with its REFCNT incremented.
4728 (This is now used as a subroutine by C<sv_magic>.)
4733 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable,
4734 const char* name, I32 namlen)
4738 if (SvTYPE(sv) < SVt_PVMG) {
4739 SvUPGRADE(sv, SVt_PVMG);
4741 Newxz(mg, 1, MAGIC);
4742 mg->mg_moremagic = SvMAGIC(sv);
4743 SvMAGIC_set(sv, mg);
4745 /* Sometimes a magic contains a reference loop, where the sv and
4746 object refer to each other. To prevent a reference loop that
4747 would prevent such objects being freed, we look for such loops
4748 and if we find one we avoid incrementing the object refcount.
4750 Note we cannot do this to avoid self-tie loops as intervening RV must
4751 have its REFCNT incremented to keep it in existence.
4754 if (!obj || obj == sv ||
4755 how == PERL_MAGIC_arylen ||
4756 how == PERL_MAGIC_qr ||
4757 how == PERL_MAGIC_symtab ||
4758 (SvTYPE(obj) == SVt_PVGV &&
4759 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4760 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4761 GvFORM(obj) == (CV*)sv)))
4766 mg->mg_obj = SvREFCNT_inc(obj);
4767 mg->mg_flags |= MGf_REFCOUNTED;
4770 /* Normal self-ties simply pass a null object, and instead of
4771 using mg_obj directly, use the SvTIED_obj macro to produce a
4772 new RV as needed. For glob "self-ties", we are tieing the PVIO
4773 with an RV obj pointing to the glob containing the PVIO. In
4774 this case, to avoid a reference loop, we need to weaken the
4778 if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4779 obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4785 mg->mg_len = namlen;
4788 mg->mg_ptr = savepvn(name, namlen);
4789 else if (namlen == HEf_SVKEY)
4790 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4792 mg->mg_ptr = (char *) name;
4794 mg->mg_virtual = vtable;
4798 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4803 =for apidoc sv_magic
4805 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4806 then adds a new magic item of type C<how> to the head of the magic list.
4808 See C<sv_magicext> (which C<sv_magic> now calls) for a description of the
4809 handling of the C<name> and C<namlen> arguments.
4811 You need to use C<sv_magicext> to add magic to SvREADONLY SVs and also
4812 to add more than one instance of the same 'how'.
4818 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4820 const MGVTBL *vtable;
4823 #ifdef PERL_OLD_COPY_ON_WRITE
4825 sv_force_normal_flags(sv, 0);
4827 if (SvREADONLY(sv)) {
4829 /* its okay to attach magic to shared strings; the subsequent
4830 * upgrade to PVMG will unshare the string */
4831 !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
4834 && how != PERL_MAGIC_regex_global
4835 && how != PERL_MAGIC_bm
4836 && how != PERL_MAGIC_fm
4837 && how != PERL_MAGIC_sv
4838 && how != PERL_MAGIC_backref
4841 Perl_croak(aTHX_ PL_no_modify);
4844 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4845 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4846 /* sv_magic() refuses to add a magic of the same 'how' as an
4849 if (how == PERL_MAGIC_taint)
4857 vtable = &PL_vtbl_sv;
4859 case PERL_MAGIC_overload:
4860 vtable = &PL_vtbl_amagic;
4862 case PERL_MAGIC_overload_elem:
4863 vtable = &PL_vtbl_amagicelem;
4865 case PERL_MAGIC_overload_table:
4866 vtable = &PL_vtbl_ovrld;
4869 vtable = &PL_vtbl_bm;
4871 case PERL_MAGIC_regdata:
4872 vtable = &PL_vtbl_regdata;
4874 case PERL_MAGIC_regdatum:
4875 vtable = &PL_vtbl_regdatum;
4877 case PERL_MAGIC_env:
4878 vtable = &PL_vtbl_env;
4881 vtable = &PL_vtbl_fm;
4883 case PERL_MAGIC_envelem:
4884 vtable = &PL_vtbl_envelem;
4886 case PERL_MAGIC_regex_global:
4887 vtable = &PL_vtbl_mglob;
4889 case PERL_MAGIC_isa:
4890 vtable = &PL_vtbl_isa;
4892 case PERL_MAGIC_isaelem:
4893 vtable = &PL_vtbl_isaelem;
4895 case PERL_MAGIC_nkeys:
4896 vtable = &PL_vtbl_nkeys;
4898 case PERL_MAGIC_dbfile:
4901 case PERL_MAGIC_dbline:
4902 vtable = &PL_vtbl_dbline;
4904 #ifdef USE_LOCALE_COLLATE
4905 case PERL_MAGIC_collxfrm:
4906 vtable = &PL_vtbl_collxfrm;
4908 #endif /* USE_LOCALE_COLLATE */
4909 case PERL_MAGIC_tied:
4910 vtable = &PL_vtbl_pack;
4912 case PERL_MAGIC_tiedelem:
4913 case PERL_MAGIC_tiedscalar:
4914 vtable = &PL_vtbl_packelem;
4917 vtable = &PL_vtbl_regexp;
4919 case PERL_MAGIC_sig:
4920 vtable = &PL_vtbl_sig;
4922 case PERL_MAGIC_sigelem:
4923 vtable = &PL_vtbl_sigelem;
4925 case PERL_MAGIC_taint:
4926 vtable = &PL_vtbl_taint;
4928 case PERL_MAGIC_uvar:
4929 vtable = &PL_vtbl_uvar;
4931 case PERL_MAGIC_vec:
4932 vtable = &PL_vtbl_vec;
4934 case PERL_MAGIC_arylen_p:
4935 case PERL_MAGIC_rhash:
4936 case PERL_MAGIC_symtab:
4937 case PERL_MAGIC_vstring:
4940 case PERL_MAGIC_utf8:
4941 vtable = &PL_vtbl_utf8;
4943 case PERL_MAGIC_substr:
4944 vtable = &PL_vtbl_substr;
4946 case PERL_MAGIC_defelem:
4947 vtable = &PL_vtbl_defelem;
4949 case PERL_MAGIC_glob:
4950 vtable = &PL_vtbl_glob;
4952 case PERL_MAGIC_arylen:
4953 vtable = &PL_vtbl_arylen;
4955 case PERL_MAGIC_pos:
4956 vtable = &PL_vtbl_pos;
4958 case PERL_MAGIC_backref:
4959 vtable = &PL_vtbl_backref;
4961 case PERL_MAGIC_ext:
4962 /* Reserved for use by extensions not perl internals. */
4963 /* Useful for attaching extension internal data to perl vars. */
4964 /* Note that multiple extensions may clash if magical scalars */
4965 /* etc holding private data from one are passed to another. */
4969 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4972 /* Rest of work is done else where */
4973 mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4976 case PERL_MAGIC_taint:
4979 case PERL_MAGIC_ext:
4980 case PERL_MAGIC_dbfile:
4987 =for apidoc sv_unmagic
4989 Removes all magic of type C<type> from an SV.
4995 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4999 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
5002 for (mg = *mgp; mg; mg = *mgp) {
5003 if (mg->mg_type == type) {
5004 const MGVTBL* const vtbl = mg->mg_virtual;
5005 *mgp = mg->mg_moremagic;
5006 if (vtbl && vtbl->svt_free)
5007 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
5008 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
5010 Safefree(mg->mg_ptr);
5011 else if (mg->mg_len == HEf_SVKEY)
5012 SvREFCNT_dec((SV*)mg->mg_ptr);
5013 else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
5014 Safefree(mg->mg_ptr);
5016 if (mg->mg_flags & MGf_REFCOUNTED)
5017 SvREFCNT_dec(mg->mg_obj);
5021 mgp = &mg->mg_moremagic;
5025 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
5032 =for apidoc sv_rvweaken
5034 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
5035 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
5036 push a back-reference to this RV onto the array of backreferences
5037 associated with that magic.
5043 Perl_sv_rvweaken(pTHX_ SV *sv)
5046 if (!SvOK(sv)) /* let undefs pass */
5049 Perl_croak(aTHX_ "Can't weaken a nonreference");
5050 else if (SvWEAKREF(sv)) {
5051 if (ckWARN(WARN_MISC))
5052 Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
5056 Perl_sv_add_backref(aTHX_ tsv, sv);
5062 /* Give tsv backref magic if it hasn't already got it, then push a
5063 * back-reference to sv onto the array associated with the backref magic.
5067 Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv)
5071 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
5072 av = (AV*)mg->mg_obj;
5075 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
5076 /* av now has a refcnt of 2, which avoids it getting freed
5077 * before us during global cleanup. The extra ref is removed
5078 * by magic_killbackrefs() when tsv is being freed */
5080 if (AvFILLp(av) >= AvMAX(av)) {
5081 av_extend(av, AvFILLp(av)+1);
5083 AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
5086 /* delete a back-reference to ourselves from the backref magic associated
5087 * with the SV we point to.
5091 S_sv_del_backref(pTHX_ SV *tsv, SV *sv)
5097 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) {
5098 if (PL_in_clean_all)
5101 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
5102 Perl_croak(aTHX_ "panic: del_backref");
5103 av = (AV *)mg->mg_obj;
5105 /* We shouldn't be in here more than once, but for paranoia reasons lets
5107 for (i = AvFILLp(av); i >= 0; i--) {
5109 const SSize_t fill = AvFILLp(av);
5111 /* We weren't the last entry.
5112 An unordered list has this property that you can take the
5113 last element off the end to fill the hole, and it's still
5114 an unordered list :-)
5119 AvFILLp(av) = fill - 1;
5125 =for apidoc sv_insert
5127 Inserts a string at the specified offset/length within the SV. Similar to
5128 the Perl substr() function.
5134 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen)
5138 register char *midend;
5139 register char *bigend;
5145 Perl_croak(aTHX_ "Can't modify non-existent substring");
5146 SvPV_force(bigstr, curlen);
5147 (void)SvPOK_only_UTF8(bigstr);
5148 if (offset + len > curlen) {
5149 SvGROW(bigstr, offset+len+1);
5150 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
5151 SvCUR_set(bigstr, offset+len);
5155 i = littlelen - len;
5156 if (i > 0) { /* string might grow */
5157 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
5158 mid = big + offset + len;
5159 midend = bigend = big + SvCUR(bigstr);
5162 while (midend > mid) /* shove everything down */
5163 *--bigend = *--midend;
5164 Move(little,big+offset,littlelen,char);
5165 SvCUR_set(bigstr, SvCUR(bigstr) + i);
5170 Move(little,SvPVX(bigstr)+offset,len,char);
5175 big = SvPVX(bigstr);
5178 bigend = big + SvCUR(bigstr);
5180 if (midend > bigend)
5181 Perl_croak(aTHX_ "panic: sv_insert");
5183 if (mid - big > bigend - midend) { /* faster to shorten from end */
5185 Move(little, mid, littlelen,char);
5188 i = bigend - midend;
5190 Move(midend, mid, i,char);
5194 SvCUR_set(bigstr, mid - big);
5196 else if ((i = mid - big)) { /* faster from front */
5197 midend -= littlelen;
5199 sv_chop(bigstr,midend-i);
5204 Move(little, mid, littlelen,char);
5206 else if (littlelen) {
5207 midend -= littlelen;
5208 sv_chop(bigstr,midend);
5209 Move(little,midend,littlelen,char);
5212 sv_chop(bigstr,midend);
5218 =for apidoc sv_replace
5220 Make the first argument a copy of the second, then delete the original.
5221 The target SV physically takes over ownership of the body of the source SV
5222 and inherits its flags; however, the target keeps any magic it owns,
5223 and any magic in the source is discarded.
5224 Note that this is a rather specialist SV copying operation; most of the
5225 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5231 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5233 const U32 refcnt = SvREFCNT(sv);
5234 SV_CHECK_THINKFIRST_COW_DROP(sv);
5235 if (SvREFCNT(nsv) != 1) {
5236 Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%"
5237 UVuf " != 1)", (UV) SvREFCNT(nsv));
5239 if (SvMAGICAL(sv)) {
5243 sv_upgrade(nsv, SVt_PVMG);
5244 SvMAGIC_set(nsv, SvMAGIC(sv));
5245 SvFLAGS(nsv) |= SvMAGICAL(sv);
5247 SvMAGIC_set(sv, NULL);
5251 assert(!SvREFCNT(sv));
5252 #ifdef DEBUG_LEAKING_SCALARS
5253 sv->sv_flags = nsv->sv_flags;
5254 sv->sv_any = nsv->sv_any;
5255 sv->sv_refcnt = nsv->sv_refcnt;
5256 sv->sv_u = nsv->sv_u;
5258 StructCopy(nsv,sv,SV);
5260 /* Currently could join these into one piece of pointer arithmetic, but
5261 it would be unclear. */
5262 if(SvTYPE(sv) == SVt_IV)
5264 = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
5265 else if (SvTYPE(sv) == SVt_RV) {
5266 SvANY(sv) = &sv->sv_u.svu_rv;
5270 #ifdef PERL_OLD_COPY_ON_WRITE
5271 if (SvIsCOW_normal(nsv)) {
5272 /* We need to follow the pointers around the loop to make the
5273 previous SV point to sv, rather than nsv. */
5276 while ((next = SV_COW_NEXT_SV(current)) != nsv) {
5279 assert(SvPVX_const(current) == SvPVX_const(nsv));
5281 /* Make the SV before us point to the SV after us. */
5283 PerlIO_printf(Perl_debug_log, "previous is\n");
5285 PerlIO_printf(Perl_debug_log,
5286 "move it from 0x%"UVxf" to 0x%"UVxf"\n",
5287 (UV) SV_COW_NEXT_SV(current), (UV) sv);
5289 SV_COW_NEXT_SV_SET(current, sv);
5292 SvREFCNT(sv) = refcnt;
5293 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
5299 =for apidoc sv_clear
5301 Clear an SV: call any destructors, free up any memory used by the body,
5302 and free the body itself. The SV's head is I<not> freed, although
5303 its type is set to all 1's so that it won't inadvertently be assumed
5304 to be live during global destruction etc.
5305 This function should only be called when REFCNT is zero. Most of the time
5306 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5313 Perl_sv_clear(pTHX_ register SV *sv)
5316 const U32 type = SvTYPE(sv);
5317 const struct body_details *const sv_type_details
5318 = bodies_by_type + type;
5321 assert(SvREFCNT(sv) == 0);
5327 if (PL_defstash) { /* Still have a symbol table? */
5332 stash = SvSTASH(sv);
5333 destructor = StashHANDLER(stash,DESTROY);
5335 SV* const tmpref = newRV(sv);
5336 SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
5338 PUSHSTACKi(PERLSI_DESTROY);
5343 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5349 if(SvREFCNT(tmpref) < 2) {
5350 /* tmpref is not kept alive! */
5352 SvRV_set(tmpref, NULL);
5355 SvREFCNT_dec(tmpref);
5357 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5361 if (PL_in_clean_objs)
5362 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5364 /* DESTROY gave object new lease on life */
5370 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
5371 SvOBJECT_off(sv); /* Curse the object. */
5372 if (type != SVt_PVIO)
5373 --PL_sv_objcount; /* XXX Might want something more general */
5376 if (type >= SVt_PVMG) {
5379 if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED)
5380 SvREFCNT_dec(SvSTASH(sv));
5385 IoIFP(sv) != PerlIO_stdin() &&
5386 IoIFP(sv) != PerlIO_stdout() &&
5387 IoIFP(sv) != PerlIO_stderr())
5389 io_close((IO*)sv, FALSE);
5391 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5392 PerlDir_close(IoDIRP(sv));
5393 IoDIRP(sv) = (DIR*)NULL;
5394 Safefree(IoTOP_NAME(sv));
5395 Safefree(IoFMT_NAME(sv));
5396 Safefree(IoBOTTOM_NAME(sv));
5411 if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5412 SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5413 HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5414 PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5416 else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
5417 SvREFCNT_dec(LvTARG(sv));
5421 Safefree(GvNAME(sv));
5422 /* If we're in a stash, we don't own a reference to it. However it does
5423 have a back reference to us, which needs to be cleared. */
5425 sv_del_backref((SV*)GvSTASH(sv), sv);
5430 /* Don't bother with SvOOK_off(sv); as we're only going to free it. */
5432 SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv));
5433 /* Don't even bother with turning off the OOK flag. */
5438 SV *target = SvRV(sv);
5440 sv_del_backref(target, sv);
5442 SvREFCNT_dec(target);
5444 #ifdef PERL_OLD_COPY_ON_WRITE
5445 else if (SvPVX_const(sv)) {
5447 /* I believe I need to grab the global SV mutex here and
5448 then recheck the COW status. */
5450 PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
5453 sv_release_COW(sv, SvPVX_const(sv), SvLEN(sv),
5454 SV_COW_NEXT_SV(sv));
5455 /* And drop it here. */
5457 } else if (SvLEN(sv)) {
5458 Safefree(SvPVX_const(sv));
5462 else if (SvPVX_const(sv) && SvLEN(sv))
5463 Safefree(SvPVX_mutable(sv));
5464 else if (SvPVX_const(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5465 unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv)));
5474 SvFLAGS(sv) &= SVf_BREAK;
5475 SvFLAGS(sv) |= SVTYPEMASK;
5477 if (sv_type_details->arena) {
5478 del_body(((char *)SvANY(sv) - sv_type_details->offset),
5479 &PL_body_roots[type]);
5481 else if (sv_type_details->size) {
5482 my_safefree(SvANY(sv));
5487 =for apidoc sv_newref
5489 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5496 Perl_sv_newref(pTHX_ SV *sv)
5506 Decrement an SV's reference count, and if it drops to zero, call
5507 C<sv_clear> to invoke destructors and free up any memory used by
5508 the body; finally, deallocate the SV's head itself.
5509 Normally called via a wrapper macro C<SvREFCNT_dec>.
5515 Perl_sv_free(pTHX_ SV *sv)
5520 if (SvREFCNT(sv) == 0) {
5521 if (SvFLAGS(sv) & SVf_BREAK)
5522 /* this SV's refcnt has been artificially decremented to
5523 * trigger cleanup */
5525 if (PL_in_clean_all) /* All is fair */
5527 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5528 /* make sure SvREFCNT(sv)==0 happens very seldom */
5529 SvREFCNT(sv) = (~(U32)0)/2;
5532 if (ckWARN_d(WARN_INTERNAL)) {
5533 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5534 "Attempt to free unreferenced scalar: SV 0x%"UVxf
5535 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5536 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
5537 Perl_dump_sv_child(aTHX_ sv);
5542 if (--(SvREFCNT(sv)) > 0)
5544 Perl_sv_free2(aTHX_ sv);
5548 Perl_sv_free2(pTHX_ SV *sv)
5553 if (ckWARN_d(WARN_DEBUGGING))
5554 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5555 "Attempt to free temp prematurely: SV 0x%"UVxf
5556 pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
5560 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5561 /* make sure SvREFCNT(sv)==0 happens very seldom */
5562 SvREFCNT(sv) = (~(U32)0)/2;
5573 Returns the length of the string in the SV. Handles magic and type
5574 coercion. See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5580 Perl_sv_len(pTHX_ register SV *sv)
5588 len = mg_length(sv);
5590 (void)SvPV_const(sv, len);
5595 =for apidoc sv_len_utf8
5597 Returns the number of characters in the string in an SV, counting wide
5598 UTF-8 bytes as a single character. Handles magic and type coercion.
5604 * The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
5605 * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5606 * (Note that the mg_len is not the length of the mg_ptr field.)
5611 Perl_sv_len_utf8(pTHX_ register SV *sv)
5617 return mg_length(sv);
5621 const U8 *s = (U8*)SvPV_const(sv, len);
5622 MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5624 if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5626 #ifdef PERL_UTF8_CACHE_ASSERT
5627 assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5631 ulen = Perl_utf8_length(aTHX_ s, s + len);
5632 if (!mg && !SvREADONLY(sv)) {
5633 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5634 mg = mg_find(sv, PERL_MAGIC_utf8);
5644 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5645 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5646 * between UTF-8 and byte offsets. There are two (substr offset and substr
5647 * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5648 * and byte offset) cache positions.
5650 * The mg_len field is used by sv_len_utf8(), see its comments.
5651 * Note that the mg_len is not the length of the mg_ptr field.
5655 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
5656 I32 offsetp, const U8 *s, const U8 *start)
5660 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5662 *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
5666 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5668 Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5669 (*mgp)->mg_ptr = (char *) *cachep;
5673 (*cachep)[i] = offsetp;
5674 (*cachep)[i+1] = s - start;
5682 * S_utf8_mg_pos() is used to query and update mg_ptr field of
5683 * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
5684 * between UTF-8 and byte offsets. See also the comments of
5685 * S_utf8_mg_pos_init().
5689 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
5693 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5695 *mgp = mg_find(sv, PERL_MAGIC_utf8);
5696 if (*mgp && (*mgp)->mg_ptr) {
5697 *cachep = (STRLEN *) (*mgp)->mg_ptr;
5698 ASSERT_UTF8_CACHE(*cachep);
5699 if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
5701 else { /* We will skip to the right spot. */
5706 /* The assumption is that going backward is half
5707 * the speed of going forward (that's where the
5708 * 2 * backw in the below comes from). (The real
5709 * figure of course depends on the UTF-8 data.) */
5711 if ((*cachep)[i] > (STRLEN)uoff) {
5713 backw = (*cachep)[i] - (STRLEN)uoff;
5715 if (forw < 2 * backw)
5718 p = start + (*cachep)[i+1];
5720 /* Try this only for the substr offset (i == 0),
5721 * not for the substr length (i == 2). */
5722 else if (i == 0) { /* (*cachep)[i] < uoff */
5723 const STRLEN ulen = sv_len_utf8(sv);
5725 if ((STRLEN)uoff < ulen) {
5726 forw = (STRLEN)uoff - (*cachep)[i];
5727 backw = ulen - (STRLEN)uoff;
5729 if (forw < 2 * backw)
5730 p = start + (*cachep)[i+1];
5735 /* If the string is not long enough for uoff,
5736 * we could extend it, but not at this low a level. */
5740 if (forw < 2 * backw) {
5747 while (UTF8_IS_CONTINUATION(*p))
5752 /* Update the cache. */
5753 (*cachep)[i] = (STRLEN)uoff;
5754 (*cachep)[i+1] = p - start;
5756 /* Drop the stale "length" cache */
5765 if (found) { /* Setup the return values. */
5766 *offsetp = (*cachep)[i+1];
5767 *sp = start + *offsetp;
5770 *offsetp = send - start;
5772 else if (*sp < start) {
5778 #ifdef PERL_UTF8_CACHE_ASSERT
5783 while (n-- && s < send)
5787 assert(*offsetp == s - start);
5788 assert((*cachep)[0] == (STRLEN)uoff);
5789 assert((*cachep)[1] == *offsetp);
5791 ASSERT_UTF8_CACHE(*cachep);
5800 =for apidoc sv_pos_u2b
5802 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5803 the start of the string, to a count of the equivalent number of bytes; if
5804 lenp is non-zero, it does the same to lenp, but this time starting from
5805 the offset, rather than from the start of the string. Handles magic and
5812 * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5813 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5814 * byte offsets. See also the comments of S_utf8_mg_pos().
5819 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5827 start = (U8*)SvPV_const(sv, len);
5831 const U8 *s = start;
5832 I32 uoffset = *offsetp;
5833 const U8 * const send = s + len;
5837 if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5839 if (!found && uoffset > 0) {
5840 while (s < send && uoffset--)
5844 if (utf8_mg_pos_init(sv, &mg, &cache, 0, *offsetp, s, start))
5846 *offsetp = s - start;
5851 if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp, &s, start, send)) {
5855 if (!found && *lenp > 0) {
5858 while (s < send && ulen--)
5862 utf8_mg_pos_init(sv, &mg, &cache, 2, *lenp, s, start);
5866 ASSERT_UTF8_CACHE(cache);
5878 =for apidoc sv_pos_b2u
5880 Converts the value pointed to by offsetp from a count of bytes from the
5881 start of the string, to a count of the equivalent number of UTF-8 chars.
5882 Handles magic and type coercion.
5888 * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5889 * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5890 * byte offsets. See also the comments of S_utf8_mg_pos().
5895 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5903 s = (const U8*)SvPV_const(sv, len);
5904 if ((I32)len < *offsetp)
5905 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5907 const U8* send = s + *offsetp;
5909 STRLEN *cache = NULL;
5913 if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5914 mg = mg_find(sv, PERL_MAGIC_utf8);
5915 if (mg && mg->mg_ptr) {
5916 cache = (STRLEN *) mg->mg_ptr;
5917 if (cache[1] == (STRLEN)*offsetp) {
5918 /* An exact match. */
5919 *offsetp = cache[0];
5923 else if (cache[1] < (STRLEN)*offsetp) {
5924 /* We already know part of the way. */
5927 /* Let the below loop do the rest. */
5929 else { /* cache[1] > *offsetp */
5930 /* We already know all of the way, now we may
5931 * be able to walk back. The same assumption
5932 * is made as in S_utf8_mg_pos(), namely that
5933 * walking backward is twice slower than
5934 * walking forward. */
5935 const STRLEN forw = *offsetp;
5936 STRLEN backw = cache[1] - *offsetp;
5938 if (!(forw < 2 * backw)) {
5939 const U8 *p = s + cache[1];
5946 while (UTF8_IS_CONTINUATION(*p)) {
5954 *offsetp = cache[0];
5956 /* Drop the stale "length" cache */
5964 ASSERT_UTF8_CACHE(cache);
5970 /* Call utf8n_to_uvchr() to validate the sequence
5971 * (unless a simple non-UTF character) */
5972 if (!UTF8_IS_INVARIANT(*s))
5973 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5982 if (!SvREADONLY(sv)) {
5984 sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5985 mg = mg_find(sv, PERL_MAGIC_utf8);
5990 Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5991 mg->mg_ptr = (char *) cache;
5996 cache[1] = *offsetp;
5997 /* Drop the stale "length" cache */
6010 Returns a boolean indicating whether the strings in the two SVs are
6011 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6012 coerce its args to strings if necessary.
6018 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
6026 SV* svrecode = Nullsv;
6033 pv1 = SvPV_const(sv1, cur1);
6040 pv2 = SvPV_const(sv2, cur2);
6042 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6043 /* Differing utf8ness.
6044 * Do not UTF8size the comparands as a side-effect. */
6047 svrecode = newSVpvn(pv2, cur2);
6048 sv_recode_to_utf8(svrecode, PL_encoding);
6049 pv2 = SvPV_const(svrecode, cur2);
6052 svrecode = newSVpvn(pv1, cur1);
6053 sv_recode_to_utf8(svrecode, PL_encoding);
6054 pv1 = SvPV_const(svrecode, cur1);
6056 /* Now both are in UTF-8. */
6058 SvREFCNT_dec(svrecode);
6063 bool is_utf8 = TRUE;
6066 /* sv1 is the UTF-8 one,
6067 * if is equal it must be downgrade-able */
6068 char * const pv = (char*)bytes_from_utf8((const U8*)pv1,
6074 /* sv2 is the UTF-8 one,
6075 * if is equal it must be downgrade-able */
6076 char * const pv = (char *)bytes_from_utf8((const U8*)pv2,
6082 /* Downgrade not possible - cannot be eq */
6090 eq = (pv1 == pv2) || memEQ(pv1, pv2, cur1);
6093 SvREFCNT_dec(svrecode);
6104 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
6105 string in C<sv1> is less than, equal to, or greater than the string in
6106 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
6107 coerce its args to strings if necessary. See also C<sv_cmp_locale>.
6113 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
6116 const char *pv1, *pv2;
6119 SV *svrecode = Nullsv;
6126 pv1 = SvPV_const(sv1, cur1);
6133 pv2 = SvPV_const(sv2, cur2);
6135 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
6136 /* Differing utf8ness.
6137 * Do not UTF8size the comparands as a side-effect. */
6140 svrecode = newSVpvn(pv2, cur2);
6141 sv_recode_to_utf8(svrecode, PL_encoding);
6142 pv2 = SvPV_const(svrecode, cur2);
6145 pv2 = tpv = (char*)bytes_to_utf8((const U8*)pv2, &cur2);
6150 svrecode = newSVpvn(pv1, cur1);
6151 sv_recode_to_utf8(svrecode, PL_encoding);
6152 pv1 = SvPV_const(svrecode, cur1);
6155 pv1 = tpv = (char*)bytes_to_utf8((const U8*)pv1, &cur1);
6161 cmp = cur2 ? -1 : 0;
6165 const I32 retval = memcmp((const void*)pv1, (const void*)pv2, cur1 < cur2 ? cur1 : cur2);
6168 cmp = retval < 0 ? -1 : 1;
6169 } else if (cur1 == cur2) {
6172 cmp = cur1 < cur2 ? -1 : 1;
6177 SvREFCNT_dec(svrecode);
6186 =for apidoc sv_cmp_locale
6188 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
6189 'use bytes' aware, handles get magic, and will coerce its args to strings
6190 if necessary. See also C<sv_cmp_locale>. See also C<sv_cmp>.
6196 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
6198 #ifdef USE_LOCALE_COLLATE
6204 if (PL_collation_standard)
6208 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6210 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6212 if (!pv1 || !len1) {
6223 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6226 return retval < 0 ? -1 : 1;
6229 * When the result of collation is equality, that doesn't mean
6230 * that there are no differences -- some locales exclude some
6231 * characters from consideration. So to avoid false equalities,
6232 * we use the raw string as a tiebreaker.
6238 #endif /* USE_LOCALE_COLLATE */
6240 return sv_cmp(sv1, sv2);
6244 #ifdef USE_LOCALE_COLLATE
6247 =for apidoc sv_collxfrm
6249 Add Collate Transform magic to an SV if it doesn't already have it.
6251 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6252 scalar data of the variable, but transformed to such a format that a normal
6253 memory comparison can be used to compare the data according to the locale
6260 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6264 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6265 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6271 Safefree(mg->mg_ptr);
6272 s = SvPV_const(sv, len);
6273 if ((xf = mem_collxfrm(s, len, &xlen))) {
6274 if (SvREADONLY(sv)) {
6277 return xf + sizeof(PL_collation_ix);
6280 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6281 mg = mg_find(sv, PERL_MAGIC_collxfrm);
6294 if (mg && mg->mg_ptr) {
6296 return mg->mg_ptr + sizeof(PL_collation_ix);
6304 #endif /* USE_LOCALE_COLLATE */
6309 Get a line from the filehandle and store it into the SV, optionally
6310 appending to the currently-stored string.
6316 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6320 register STDCHAR rslast;
6321 register STDCHAR *bp;
6327 if (SvTHINKFIRST(sv))
6328 sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6329 /* XXX. If you make this PVIV, then copy on write can copy scalars read
6331 However, perlbench says it's slower, because the existing swipe code
6332 is faster than copy on write.
6333 Swings and roundabouts. */
6334 SvUPGRADE(sv, SVt_PV);
6339 if (PerlIO_isutf8(fp)) {
6341 sv_utf8_upgrade_nomg(sv);
6342 sv_pos_u2b(sv,&append,0);
6344 } else if (SvUTF8(sv)) {
6345 SV * const tsv = NEWSV(0,0);
6346 sv_gets(tsv, fp, 0);
6347 sv_utf8_upgrade_nomg(tsv);
6348 SvCUR_set(sv,append);
6351 goto return_string_or_null;
6356 if (PerlIO_isutf8(fp))
6359 if (IN_PERL_COMPILETIME) {
6360 /* we always read code in line mode */
6364 else if (RsSNARF(PL_rs)) {
6365 /* If it is a regular disk file use size from stat() as estimate
6366 of amount we are going to read - may result in malloc-ing
6367 more memory than we realy need if layers bellow reduce
6368 size we read (e.g. CRLF or a gzip layer)
6371 if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
6372 const Off_t offset = PerlIO_tell(fp);
6373 if (offset != (Off_t) -1 && st.st_size + append > offset) {
6374 (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6380 else if (RsRECORD(PL_rs)) {
6384 /* Grab the size of the record we're getting */
6385 recsize = SvIV(SvRV(PL_rs));
6386 buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6389 /* VMS wants read instead of fread, because fread doesn't respect */
6390 /* RMS record boundaries. This is not necessarily a good thing to be */
6391 /* doing, but we've got no other real choice - except avoid stdio
6392 as implementation - perhaps write a :vms layer ?
6394 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6396 bytesread = PerlIO_read(fp, buffer, recsize);
6400 SvCUR_set(sv, bytesread += append);
6401 buffer[bytesread] = '\0';
6402 goto return_string_or_null;
6404 else if (RsPARA(PL_rs)) {
6410 /* Get $/ i.e. PL_rs into same encoding as stream wants */
6411 if (PerlIO_isutf8(fp)) {
6412 rsptr = SvPVutf8(PL_rs, rslen);
6415 if (SvUTF8(PL_rs)) {
6416 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6417 Perl_croak(aTHX_ "Wide character in $/");
6420 rsptr = SvPV_const(PL_rs, rslen);
6424 rslast = rslen ? rsptr[rslen - 1] : '\0';
6426 if (rspara) { /* have to do this both before and after */
6427 do { /* to make sure file boundaries work right */
6430 i = PerlIO_getc(fp);
6434 PerlIO_ungetc(fp,i);
6440 /* See if we know enough about I/O mechanism to cheat it ! */
6442 /* This used to be #ifdef test - it is made run-time test for ease
6443 of abstracting out stdio interface. One call should be cheap
6444 enough here - and may even be a macro allowing compile
6448 if (PerlIO_fast_gets(fp)) {
6451 * We're going to steal some values from the stdio struct
6452 * and put EVERYTHING in the innermost loop into registers.
6454 register STDCHAR *ptr;
6458 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6459 /* An ungetc()d char is handled separately from the regular
6460 * buffer, so we getc() it back out and stuff it in the buffer.
6462 i = PerlIO_getc(fp);
6463 if (i == EOF) return 0;
6464 *(--((*fp)->_ptr)) = (unsigned char) i;
6468 /* Here is some breathtakingly efficient cheating */
6470 cnt = PerlIO_get_cnt(fp); /* get count into register */
6471 /* make sure we have the room */
6472 if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6473 /* Not room for all of it
6474 if we are looking for a separator and room for some
6476 if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6477 /* just process what we have room for */
6478 shortbuffered = cnt - SvLEN(sv) + append + 1;
6479 cnt -= shortbuffered;
6483 /* remember that cnt can be negative */
6484 SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6489 bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
6490 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6491 DEBUG_P(PerlIO_printf(Perl_debug_log,
6492 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6493 DEBUG_P(PerlIO_printf(Perl_debug_log,
6494 "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6495 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6496 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6501 while (cnt > 0) { /* this | eat */
6503 if ((*bp++ = *ptr++) == rslast) /* really | dust */
6504 goto thats_all_folks; /* screams | sed :-) */
6508 Copy(ptr, bp, cnt, char); /* this | eat */
6509 bp += cnt; /* screams | dust */
6510 ptr += cnt; /* louder | sed :-) */
6515 if (shortbuffered) { /* oh well, must extend */
6516 cnt = shortbuffered;
6518 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6520 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6521 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6525 DEBUG_P(PerlIO_printf(Perl_debug_log,
6526 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6527 PTR2UV(ptr),(long)cnt));
6528 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6530 DEBUG_P(PerlIO_printf(Perl_debug_log,
6531 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6532 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6533 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6535 /* This used to call 'filbuf' in stdio form, but as that behaves like
6536 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6537 another abstraction. */
6538 i = PerlIO_getc(fp); /* get more characters */
6540 DEBUG_P(PerlIO_printf(Perl_debug_log,
6541 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6542 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6543 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6545 cnt = PerlIO_get_cnt(fp);
6546 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
6547 DEBUG_P(PerlIO_printf(Perl_debug_log,
6548 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6550 if (i == EOF) /* all done for ever? */
6551 goto thats_really_all_folks;
6553 bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
6555 SvGROW(sv, bpx + cnt + 2);
6556 bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
6558 *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
6560 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
6561 goto thats_all_folks;
6565 if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
6566 memNE((char*)bp - rslen, rsptr, rslen))
6567 goto screamer; /* go back to the fray */
6568 thats_really_all_folks:
6570 cnt += shortbuffered;
6571 DEBUG_P(PerlIO_printf(Perl_debug_log,
6572 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6573 PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
6574 DEBUG_P(PerlIO_printf(Perl_debug_log,
6575 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6576 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6577 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6579 SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
6580 DEBUG_P(PerlIO_printf(Perl_debug_log,
6581 "Screamer: done, len=%ld, string=|%.*s|\n",
6582 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv)));
6586 /*The big, slow, and stupid way. */
6587 #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */
6589 Newx(buf, 8192, STDCHAR);
6597 register const STDCHAR *bpe = buf + sizeof(buf);
6599 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6600 ; /* keep reading */
6604 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6605 /* Accomodate broken VAXC compiler, which applies U8 cast to
6606 * both args of ?: operator, causing EOF to change into 255
6609 i = (U8)buf[cnt - 1];
6615 cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
6617 sv_catpvn(sv, (char *) buf, cnt);
6619 sv_setpvn(sv, (char *) buf, cnt);
6621 if (i != EOF && /* joy */
6623 SvCUR(sv) < rslen ||
6624 memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6628 * If we're reading from a TTY and we get a short read,
6629 * indicating that the user hit his EOF character, we need
6630 * to notice it now, because if we try to read from the TTY
6631 * again, the EOF condition will disappear.
6633 * The comparison of cnt to sizeof(buf) is an optimization
6634 * that prevents unnecessary calls to feof().
6638 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6642 #ifdef USE_HEAP_INSTEAD_OF_STACK
6647 if (rspara) { /* have to do this both before and after */
6648 while (i != EOF) { /* to make sure file boundaries work right */
6649 i = PerlIO_getc(fp);
6651 PerlIO_ungetc(fp,i);
6657 return_string_or_null:
6658 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6664 Auto-increment of the value in the SV, doing string to numeric conversion
6665 if necessary. Handles 'get' magic.
6671 Perl_sv_inc(pTHX_ register SV *sv)
6679 if (SvTHINKFIRST(sv)) {
6681 sv_force_normal_flags(sv, 0);
6682 if (SvREADONLY(sv)) {
6683 if (IN_PERL_RUNTIME)
6684 Perl_croak(aTHX_ PL_no_modify);
6688 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6690 i = PTR2IV(SvRV(sv));
6695 flags = SvFLAGS(sv);
6696 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6697 /* It's (privately or publicly) a float, but not tested as an
6698 integer, so test it to see. */
6700 flags = SvFLAGS(sv);
6702 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6703 /* It's publicly an integer, or privately an integer-not-float */
6704 #ifdef PERL_PRESERVE_IVUV
6708 if (SvUVX(sv) == UV_MAX)
6709 sv_setnv(sv, UV_MAX_P1);
6711 (void)SvIOK_only_UV(sv);
6712 SvUV_set(sv, SvUVX(sv) + 1);
6714 if (SvIVX(sv) == IV_MAX)
6715 sv_setuv(sv, (UV)IV_MAX + 1);
6717 (void)SvIOK_only(sv);
6718 SvIV_set(sv, SvIVX(sv) + 1);
6723 if (flags & SVp_NOK) {
6724 (void)SvNOK_only(sv);
6725 SvNV_set(sv, SvNVX(sv) + 1.0);
6729 if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
6730 if ((flags & SVTYPEMASK) < SVt_PVIV)
6731 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
6732 (void)SvIOK_only(sv);
6737 while (isALPHA(*d)) d++;
6738 while (isDIGIT(*d)) d++;
6740 #ifdef PERL_PRESERVE_IVUV
6741 /* Got to punt this as an integer if needs be, but we don't issue
6742 warnings. Probably ought to make the sv_iv_please() that does
6743 the conversion if possible, and silently. */
6744 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6745 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6746 /* Need to try really hard to see if it's an integer.
6747 9.22337203685478e+18 is an integer.
6748 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6749 so $a="9.22337203685478e+18"; $a+0; $a++
6750 needs to be the same as $a="9.22337203685478e+18"; $a++
6757 /* sv_2iv *should* have made this an NV */
6758 if (flags & SVp_NOK) {
6759 (void)SvNOK_only(sv);
6760 SvNV_set(sv, SvNVX(sv) + 1.0);
6763 /* I don't think we can get here. Maybe I should assert this
6764 And if we do get here I suspect that sv_setnv will croak. NWC
6766 #if defined(USE_LONG_DOUBLE)
6767 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",
6768 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6770 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6771 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6774 #endif /* PERL_PRESERVE_IVUV */
6775 sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
6779 while (d >= SvPVX_const(sv)) {
6787 /* MKS: The original code here died if letters weren't consecutive.
6788 * at least it didn't have to worry about non-C locales. The
6789 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6790 * arranged in order (although not consecutively) and that only
6791 * [A-Za-z] are accepted by isALPHA in the C locale.
6793 if (*d != 'z' && *d != 'Z') {
6794 do { ++*d; } while (!isALPHA(*d));
6797 *(d--) -= 'z' - 'a';
6802 *(d--) -= 'z' - 'a' + 1;
6806 /* oh,oh, the number grew */
6807 SvGROW(sv, SvCUR(sv) + 2);
6808 SvCUR_set(sv, SvCUR(sv) + 1);
6809 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--)
6820 Auto-decrement of the value in the SV, doing string to numeric conversion
6821 if necessary. Handles 'get' magic.
6827 Perl_sv_dec(pTHX_ register SV *sv)
6834 if (SvTHINKFIRST(sv)) {
6836 sv_force_normal_flags(sv, 0);
6837 if (SvREADONLY(sv)) {
6838 if (IN_PERL_RUNTIME)
6839 Perl_croak(aTHX_ PL_no_modify);
6843 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6845 i = PTR2IV(SvRV(sv));
6850 /* Unlike sv_inc we don't have to worry about string-never-numbers
6851 and keeping them magic. But we mustn't warn on punting */
6852 flags = SvFLAGS(sv);
6853 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6854 /* It's publicly an integer, or privately an integer-not-float */
6855 #ifdef PERL_PRESERVE_IVUV
6859 if (SvUVX(sv) == 0) {
6860 (void)SvIOK_only(sv);
6864 (void)SvIOK_only_UV(sv);
6865 SvUV_set(sv, SvUVX(sv) - 1);
6868 if (SvIVX(sv) == IV_MIN)
6869 sv_setnv(sv, (NV)IV_MIN - 1.0);
6871 (void)SvIOK_only(sv);
6872 SvIV_set(sv, SvIVX(sv) - 1);
6877 if (flags & SVp_NOK) {
6878 SvNV_set(sv, SvNVX(sv) - 1.0);
6879 (void)SvNOK_only(sv);
6882 if (!(flags & SVp_POK)) {
6883 if ((flags & SVTYPEMASK) < SVt_PVIV)
6884 sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
6886 (void)SvIOK_only(sv);
6889 #ifdef PERL_PRESERVE_IVUV
6891 const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
6892 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6893 /* Need to try really hard to see if it's an integer.
6894 9.22337203685478e+18 is an integer.
6895 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6896 so $a="9.22337203685478e+18"; $a+0; $a--
6897 needs to be the same as $a="9.22337203685478e+18"; $a--
6904 /* sv_2iv *should* have made this an NV */
6905 if (flags & SVp_NOK) {
6906 (void)SvNOK_only(sv);
6907 SvNV_set(sv, SvNVX(sv) - 1.0);
6910 /* I don't think we can get here. Maybe I should assert this
6911 And if we do get here I suspect that sv_setnv will croak. NWC
6913 #if defined(USE_LONG_DOUBLE)
6914 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",
6915 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6917 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6918 SvPVX_const(sv), SvIVX(sv), SvNVX(sv)));
6922 #endif /* PERL_PRESERVE_IVUV */
6923 sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */
6927 =for apidoc sv_mortalcopy
6929 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6930 The new SV is marked as mortal. It will be destroyed "soon", either by an
6931 explicit call to FREETMPS, or by an implicit call at places such as
6932 statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
6937 /* Make a string that will exist for the duration of the expression
6938 * evaluation. Actually, it may have to last longer than that, but
6939 * hopefully we won't free it until it has been assigned to a
6940 * permanent location. */
6943 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6948 sv_setsv(sv,oldstr);
6950 PL_tmps_stack[++PL_tmps_ix] = sv;
6956 =for apidoc sv_newmortal
6958 Creates a new null SV which is mortal. The reference count of the SV is
6959 set to 1. It will be destroyed "soon", either by an explicit call to
6960 FREETMPS, or by an implicit call at places such as statement boundaries.
6961 See also C<sv_mortalcopy> and C<sv_2mortal>.
6967 Perl_sv_newmortal(pTHX)
6972 SvFLAGS(sv) = SVs_TEMP;
6974 PL_tmps_stack[++PL_tmps_ix] = sv;
6979 =for apidoc sv_2mortal
6981 Marks an existing SV as mortal. The SV will be destroyed "soon", either
6982 by an explicit call to FREETMPS, or by an implicit call at places such as
6983 statement boundaries. SvTEMP() is turned on which means that the SV's
6984 string buffer can be "stolen" if this SV is copied. See also C<sv_newmortal>
6985 and C<sv_mortalcopy>.
6991 Perl_sv_2mortal(pTHX_ register SV *sv)
6996 if (SvREADONLY(sv) && SvIMMORTAL(sv))
6999 PL_tmps_stack[++PL_tmps_ix] = sv;
7007 Creates a new SV and copies a string into it. The reference count for the
7008 SV is set to 1. If C<len> is zero, Perl will compute the length using
7009 strlen(). For efficiency, consider using C<newSVpvn> instead.
7015 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
7020 sv_setpvn(sv,s,len ? len : strlen(s));
7025 =for apidoc newSVpvn
7027 Creates a new SV and copies a string into it. The reference count for the
7028 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
7029 string. You are responsible for ensuring that the source string is at least
7030 C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
7036 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
7041 sv_setpvn(sv,s,len);
7047 =for apidoc newSVhek
7049 Creates a new SV from the hash key structure. It will generate scalars that
7050 point to the shared string table where possible. Returns a new (undefined)
7051 SV if the hek is NULL.
7057 Perl_newSVhek(pTHX_ const HEK *hek)
7066 if (HEK_LEN(hek) == HEf_SVKEY) {
7067 return newSVsv(*(SV**)HEK_KEY(hek));
7069 const int flags = HEK_FLAGS(hek);
7070 if (flags & HVhek_WASUTF8) {
7072 Andreas would like keys he put in as utf8 to come back as utf8
7074 STRLEN utf8_len = HEK_LEN(hek);
7075 const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
7076 SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len);
7079 Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
7081 } else if (flags & HVhek_REHASH) {
7082 /* We don't have a pointer to the hv, so we have to replicate the
7083 flag into every HEK. This hv is using custom a hasing
7084 algorithm. Hence we can't return a shared string scalar, as
7085 that would contain the (wrong) hash value, and might get passed
7086 into an hv routine with a regular hash */
7088 SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
7093 /* This will be overwhelminly the most common case. */
7094 return newSVpvn_share(HEK_KEY(hek),
7095 (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
7101 =for apidoc newSVpvn_share
7103 Creates a new SV with its SvPVX_const pointing to a shared string in the string
7104 table. If the string does not already exist in the table, it is created
7105 first. Turns on READONLY and FAKE. The string's hash is stored in the UV
7106 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
7107 otherwise the hash is computed. The idea here is that as the string table
7108 is used for shared hash keys these strings will have SvPVX_const == HeKEY and
7109 hash lookup will avoid string compare.
7115 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
7118 bool is_utf8 = FALSE;
7120 STRLEN tmplen = -len;
7122 /* See the note in hv.c:hv_fetch() --jhi */
7123 src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8);
7127 PERL_HASH(hash, src, len);
7129 sv_upgrade(sv, SVt_PV);
7130 SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash));
7142 #if defined(PERL_IMPLICIT_CONTEXT)
7144 /* pTHX_ magic can't cope with varargs, so this is a no-context
7145 * version of the main function, (which may itself be aliased to us).
7146 * Don't access this version directly.
7150 Perl_newSVpvf_nocontext(const char* pat, ...)
7155 va_start(args, pat);
7156 sv = vnewSVpvf(pat, &args);
7163 =for apidoc newSVpvf
7165 Creates a new SV and initializes it with the string formatted like
7172 Perl_newSVpvf(pTHX_ const char* pat, ...)
7176 va_start(args, pat);
7177 sv = vnewSVpvf(pat, &args);
7182 /* backend for newSVpvf() and newSVpvf_nocontext() */
7185 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
7189 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
7196 Creates a new SV and copies a floating point value into it.
7197 The reference count for the SV is set to 1.
7203 Perl_newSVnv(pTHX_ NV n)
7215 Creates a new SV and copies an integer into it. The reference count for the
7222 Perl_newSViv(pTHX_ IV i)
7234 Creates a new SV and copies an unsigned integer into it.
7235 The reference count for the SV is set to 1.
7241 Perl_newSVuv(pTHX_ UV u)
7251 =for apidoc newRV_noinc
7253 Creates an RV wrapper for an SV. The reference count for the original
7254 SV is B<not> incremented.
7260 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7265 sv_upgrade(sv, SVt_RV);
7267 SvRV_set(sv, tmpRef);
7272 /* newRV_inc is the official function name to use now.
7273 * newRV_inc is in fact #defined to newRV in sv.h
7277 Perl_newRV(pTHX_ SV *tmpRef)
7279 return newRV_noinc(SvREFCNT_inc(tmpRef));
7285 Creates a new SV which is an exact duplicate of the original SV.
7292 Perl_newSVsv(pTHX_ register SV *old)
7298 if (SvTYPE(old) == SVTYPEMASK) {
7299 if (ckWARN_d(WARN_INTERNAL))
7300 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7304 /* SV_GMAGIC is the default for sv_setv()
7305 SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
7306 with SvTEMP_off and SvTEMP_on round a call to sv_setsv. */
7307 sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
7312 =for apidoc sv_reset
7314 Underlying implementation for the C<reset> Perl function.
7315 Note that the perl-level function is vaguely deprecated.
7321 Perl_sv_reset(pTHX_ register const char *s, HV *stash)
7324 char todo[PERL_UCHAR_MAX+1];
7329 if (!*s) { /* reset ?? searches */
7330 MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab);
7332 PMOP *pm = (PMOP *) mg->mg_obj;
7334 pm->op_pmdynflags &= ~PMdf_USED;
7341 /* reset variables */
7343 if (!HvARRAY(stash))
7346 Zero(todo, 256, char);
7349 I32 i = (unsigned char)*s;
7353 max = (unsigned char)*s++;
7354 for ( ; i <= max; i++) {
7357 for (i = 0; i <= (I32) HvMAX(stash); i++) {
7359 for (entry = HvARRAY(stash)[i];
7361 entry = HeNEXT(entry))
7366 if (!todo[(U8)*HeKEY(entry)])
7368 gv = (GV*)HeVAL(entry);
7371 if (SvTHINKFIRST(sv)) {
7372 if (!SvREADONLY(sv) && SvROK(sv))
7374 /* XXX Is this continue a bug? Why should THINKFIRST
7375 exempt us from resetting arrays and hashes? */
7379 if (SvTYPE(sv) >= SVt_PV) {
7381 if (SvPVX_const(sv) != Nullch)
7389 if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
7391 Perl_die(aTHX_ "Can't reset %%ENV on this system");
7394 # if defined(USE_ENVIRON_ARRAY)
7397 # endif /* USE_ENVIRON_ARRAY */
7408 Using various gambits, try to get an IO from an SV: the IO slot if its a
7409 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7410 named after the PV if we're a string.
7416 Perl_sv_2io(pTHX_ SV *sv)
7421 switch (SvTYPE(sv)) {
7429 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7433 Perl_croak(aTHX_ PL_no_usym, "filehandle");
7435 return sv_2io(SvRV(sv));
7436 gv = gv_fetchsv(sv, FALSE, SVt_PVIO);
7442 Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7451 Using various gambits, try to get a CV from an SV; in addition, try if
7452 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7458 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7465 return *gvp = Nullgv, Nullcv;
7466 switch (SvTYPE(sv)) {
7484 SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */
7485 tryAMAGICunDEREF(to_cv);
7488 if (SvTYPE(sv) == SVt_PVCV) {
7497 Perl_croak(aTHX_ "Not a subroutine reference");
7502 gv = gv_fetchsv(sv, lref, SVt_PVCV);
7508 if (lref && !GvCVu(gv)) {
7511 tmpsv = NEWSV(704,0);
7512 gv_efullname3(tmpsv, gv, Nullch);
7513 /* XXX this is probably not what they think they're getting.
7514 * It has the same effect as "sub name;", i.e. just a forward
7516 newSUB(start_subparse(FALSE, 0),
7517 newSVOP(OP_CONST, 0, tmpsv),
7522 Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7532 Returns true if the SV has a true value by Perl's rules.
7533 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7534 instead use an in-line version.
7540 Perl_sv_true(pTHX_ register SV *sv)
7545 register const XPV* const tXpv = (XPV*)SvANY(sv);
7547 (tXpv->xpv_cur > 1 ||
7548 (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0')))
7555 return SvIVX(sv) != 0;
7558 return SvNVX(sv) != 0.0;
7560 return sv_2bool(sv);
7566 =for apidoc sv_pvn_force
7568 Get a sensible string out of the SV somehow.
7569 A private implementation of the C<SvPV_force> macro for compilers which
7570 can't cope with complex macro expressions. Always use the macro instead.
7572 =for apidoc sv_pvn_force_flags
7574 Get a sensible string out of the SV somehow.
7575 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7576 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7577 implemented in terms of this function.
7578 You normally want to use the various wrapper macros instead: see
7579 C<SvPV_force> and C<SvPV_force_nomg>
7585 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7588 if (SvTHINKFIRST(sv) && !SvROK(sv))
7589 sv_force_normal_flags(sv, 0);
7599 if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) {
7600 const char * const ref = sv_reftype(sv,0);
7602 Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s",
7603 ref, OP_NAME(PL_op));
7605 Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref);
7607 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)
7608 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7610 s = sv_2pv_flags(sv, &len, flags);
7614 if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
7617 SvUPGRADE(sv, SVt_PV); /* Never FALSE */
7618 SvGROW(sv, len + 1);
7619 Move(s,SvPVX(sv),len,char);
7624 SvPOK_on(sv); /* validate pointer */
7626 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7627 PTR2UV(sv),SvPVX_const(sv)));
7630 return SvPVX_mutable(sv);
7634 =for apidoc sv_pvbyten_force
7636 The backend for the C<SvPVbytex_force> macro. Always use the macro instead.
7642 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7644 sv_pvn_force(sv,lp);
7645 sv_utf8_downgrade(sv,0);
7651 =for apidoc sv_pvutf8n_force
7653 The backend for the C<SvPVutf8x_force> macro. Always use the macro instead.
7659 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7661 sv_pvn_force(sv,lp);
7662 sv_utf8_upgrade(sv);
7668 =for apidoc sv_reftype
7670 Returns a string describing what the SV is a reference to.
7676 Perl_sv_reftype(pTHX_ const SV *sv, int ob)
7678 /* The fact that I don't need to downcast to char * everywhere, only in ?:
7679 inside return suggests a const propagation bug in g++. */
7680 if (ob && SvOBJECT(sv)) {
7681 char * const name = HvNAME_get(SvSTASH(sv));
7682 return name ? name : (char *) "__ANON__";
7685 switch (SvTYPE(sv)) {
7702 case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
7703 /* tied lvalues should appear to be
7704 * scalars for backwards compatitbility */
7705 : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7706 ? "SCALAR" : "LVALUE");
7707 case SVt_PVAV: return "ARRAY";
7708 case SVt_PVHV: return "HASH";
7709 case SVt_PVCV: return "CODE";
7710 case SVt_PVGV: return "GLOB";
7711 case SVt_PVFM: return "FORMAT";
7712 case SVt_PVIO: return "IO";
7713 default: return "UNKNOWN";
7719 =for apidoc sv_isobject
7721 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7722 object. If the SV is not an RV, or if the object is not blessed, then this
7729 Perl_sv_isobject(pTHX_ SV *sv)
7745 Returns a boolean indicating whether the SV is blessed into the specified
7746 class. This does not check for subtypes; use C<sv_derived_from> to verify
7747 an inheritance relationship.
7753 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7764 hvname = HvNAME_get(SvSTASH(sv));
7768 return strEQ(hvname, name);
7774 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
7775 it will be upgraded to one. If C<classname> is non-null then the new SV will
7776 be blessed in the specified package. The new SV is returned and its
7777 reference count is 1.
7783 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7789 SV_CHECK_THINKFIRST_COW_DROP(rv);
7792 if (SvTYPE(rv) >= SVt_PVMG) {
7793 const U32 refcnt = SvREFCNT(rv);
7797 SvREFCNT(rv) = refcnt;
7800 if (SvTYPE(rv) < SVt_RV)
7801 sv_upgrade(rv, SVt_RV);
7802 else if (SvTYPE(rv) > SVt_RV) {
7813 HV* const stash = gv_stashpv(classname, TRUE);
7814 (void)sv_bless(rv, stash);
7820 =for apidoc sv_setref_pv
7822 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
7823 argument will be upgraded to an RV. That RV will be modified to point to
7824 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7825 into the SV. The C<classname> argument indicates the package for the
7826 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7827 will have a reference count of 1, and the RV will be returned.
7829 Do not use with other Perl types such as HV, AV, SV, CV, because those
7830 objects will become corrupted by the pointer copy process.
7832 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7838 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7841 sv_setsv(rv, &PL_sv_undef);
7845 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7850 =for apidoc sv_setref_iv
7852 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
7853 argument will be upgraded to an RV. That RV will be modified to point to
7854 the new SV. The C<classname> argument indicates the package for the
7855 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7856 will have a reference count of 1, and the RV will be returned.
7862 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7864 sv_setiv(newSVrv(rv,classname), iv);
7869 =for apidoc sv_setref_uv
7871 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
7872 argument will be upgraded to an RV. That RV will be modified to point to
7873 the new SV. The C<classname> argument indicates the package for the
7874 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7875 will have a reference count of 1, and the RV will be returned.
7881 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7883 sv_setuv(newSVrv(rv,classname), uv);
7888 =for apidoc sv_setref_nv
7890 Copies a double into a new SV, optionally blessing the SV. The C<rv>
7891 argument will be upgraded to an RV. That RV will be modified to point to
7892 the new SV. The C<classname> argument indicates the package for the
7893 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
7894 will have a reference count of 1, and the RV will be returned.
7900 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7902 sv_setnv(newSVrv(rv,classname), nv);
7907 =for apidoc sv_setref_pvn
7909 Copies a string into a new SV, optionally blessing the SV. The length of the
7910 string must be specified with C<n>. The C<rv> argument will be upgraded to
7911 an RV. That RV will be modified to point to the new SV. The C<classname>
7912 argument indicates the package for the blessing. Set C<classname> to
7913 C<Nullch> to avoid the blessing. The new SV will have a reference count
7914 of 1, and the RV will be returned.
7916 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7922 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n)
7924 sv_setpvn(newSVrv(rv,classname), pv, n);
7929 =for apidoc sv_bless
7931 Blesses an SV into a specified package. The SV must be an RV. The package
7932 must be designated by its stash (see C<gv_stashpv()>). The reference count
7933 of the SV is unaffected.
7939 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7943 Perl_croak(aTHX_ "Can't bless non-reference value");
7945 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7946 if (SvREADONLY(tmpRef))
7947 Perl_croak(aTHX_ PL_no_modify);
7948 if (SvOBJECT(tmpRef)) {
7949 if (SvTYPE(tmpRef) != SVt_PVIO)
7951 SvREFCNT_dec(SvSTASH(tmpRef));
7954 SvOBJECT_on(tmpRef);
7955 if (SvTYPE(tmpRef) != SVt_PVIO)
7957 SvUPGRADE(tmpRef, SVt_PVMG);
7958 SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
7965 if(SvSMAGICAL(tmpRef))
7966 if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7974 /* Downgrades a PVGV to a PVMG.
7978 S_sv_unglob(pTHX_ SV *sv)
7982 assert(SvTYPE(sv) == SVt_PVGV);
7987 sv_del_backref((SV*)GvSTASH(sv), sv);
7988 GvSTASH(sv) = Nullhv;
7990 sv_unmagic(sv, PERL_MAGIC_glob);
7991 Safefree(GvNAME(sv));
7994 /* need to keep SvANY(sv) in the right arena */
7995 xpvmg = new_XPVMG();
7996 StructCopy(SvANY(sv), xpvmg, XPVMG);
7997 del_XPVGV(SvANY(sv));
8000 SvFLAGS(sv) &= ~SVTYPEMASK;
8001 SvFLAGS(sv) |= SVt_PVMG;
8005 =for apidoc sv_unref_flags
8007 Unsets the RV status of the SV, and decrements the reference count of
8008 whatever was being referenced by the RV. This can almost be thought of
8009 as a reversal of C<newSVrv>. The C<cflags> argument can contain
8010 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
8011 (otherwise the decrementing is conditional on the reference count being
8012 different from one or the reference being a readonly SV).
8019 Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags)
8021 SV* const target = SvRV(ref);
8023 if (SvWEAKREF(ref)) {
8024 sv_del_backref(target, ref);
8026 SvRV_set(ref, NULL);
8029 SvRV_set(ref, NULL);
8031 /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was
8032 assigned to as BEGIN {$a = \"Foo"} will fail. */
8033 if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF))
8034 SvREFCNT_dec(target);
8035 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
8036 sv_2mortal(target); /* Schedule for freeing later */
8040 =for apidoc sv_untaint
8042 Untaint an SV. Use C<SvTAINTED_off> instead.
8047 Perl_sv_untaint(pTHX_ SV *sv)
8049 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8050 MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8057 =for apidoc sv_tainted
8059 Test an SV for taintedness. Use C<SvTAINTED> instead.
8064 Perl_sv_tainted(pTHX_ SV *sv)
8066 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8067 const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
8068 if (mg && (mg->mg_len & 1) )
8075 =for apidoc sv_setpviv
8077 Copies an integer into the given SV, also updating its string value.
8078 Does not handle 'set' magic. See C<sv_setpviv_mg>.
8084 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8086 char buf[TYPE_CHARS(UV)];
8088 char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8090 sv_setpvn(sv, ptr, ebuf - ptr);
8094 =for apidoc sv_setpviv_mg
8096 Like C<sv_setpviv>, but also handles 'set' magic.
8102 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8108 #if defined(PERL_IMPLICIT_CONTEXT)
8110 /* pTHX_ magic can't cope with varargs, so this is a no-context
8111 * version of the main function, (which may itself be aliased to us).
8112 * Don't access this version directly.
8116 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8120 va_start(args, pat);
8121 sv_vsetpvf(sv, pat, &args);
8125 /* pTHX_ magic can't cope with varargs, so this is a no-context
8126 * version of the main function, (which may itself be aliased to us).
8127 * Don't access this version directly.
8131 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8135 va_start(args, pat);
8136 sv_vsetpvf_mg(sv, pat, &args);
8142 =for apidoc sv_setpvf
8144 Works like C<sv_catpvf> but copies the text into the SV instead of
8145 appending it. Does not handle 'set' magic. See C<sv_setpvf_mg>.
8151 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8154 va_start(args, pat);
8155 sv_vsetpvf(sv, pat, &args);
8160 =for apidoc sv_vsetpvf
8162 Works like C<sv_vcatpvf> but copies the text into the SV instead of
8163 appending it. Does not handle 'set' magic. See C<sv_vsetpvf_mg>.
8165 Usually used via its frontend C<sv_setpvf>.
8171 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8173 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8177 =for apidoc sv_setpvf_mg
8179 Like C<sv_setpvf>, but also handles 'set' magic.
8185 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8188 va_start(args, pat);
8189 sv_vsetpvf_mg(sv, pat, &args);
8194 =for apidoc sv_vsetpvf_mg
8196 Like C<sv_vsetpvf>, but also handles 'set' magic.
8198 Usually used via its frontend C<sv_setpvf_mg>.
8204 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8206 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8210 #if defined(PERL_IMPLICIT_CONTEXT)
8212 /* pTHX_ magic can't cope with varargs, so this is a no-context
8213 * version of the main function, (which may itself be aliased to us).
8214 * Don't access this version directly.
8218 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8222 va_start(args, pat);
8223 sv_vcatpvf(sv, pat, &args);
8227 /* pTHX_ magic can't cope with varargs, so this is a no-context
8228 * version of the main function, (which may itself be aliased to us).
8229 * Don't access this version directly.
8233 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8237 va_start(args, pat);
8238 sv_vcatpvf_mg(sv, pat, &args);
8244 =for apidoc sv_catpvf
8246 Processes its arguments like C<sprintf> and appends the formatted
8247 output to an SV. If the appended data contains "wide" characters
8248 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8249 and characters >255 formatted with %c), the original SV might get
8250 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See
8251 C<sv_catpvf_mg>. If the original SV was UTF-8, the pattern should be
8252 valid UTF-8; if the original SV was bytes, the pattern should be too.
8257 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8260 va_start(args, pat);
8261 sv_vcatpvf(sv, pat, &args);
8266 =for apidoc sv_vcatpvf
8268 Processes its arguments like C<vsprintf> and appends the formatted output
8269 to an SV. Does not handle 'set' magic. See C<sv_vcatpvf_mg>.
8271 Usually used via its frontend C<sv_catpvf>.
8277 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8279 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8283 =for apidoc sv_catpvf_mg
8285 Like C<sv_catpvf>, but also handles 'set' magic.
8291 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8294 va_start(args, pat);
8295 sv_vcatpvf_mg(sv, pat, &args);
8300 =for apidoc sv_vcatpvf_mg
8302 Like C<sv_vcatpvf>, but also handles 'set' magic.
8304 Usually used via its frontend C<sv_catpvf_mg>.
8310 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8312 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8317 =for apidoc sv_vsetpvfn
8319 Works like C<sv_vcatpvfn> but copies the text into the SV instead of
8322 Usually used via one of its frontends C<sv_vsetpvf> and C<sv_vsetpvf_mg>.
8328 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8330 sv_setpvn(sv, "", 0);
8331 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8334 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8337 S_expect_number(pTHX_ char** pattern)
8340 switch (**pattern) {
8341 case '1': case '2': case '3':
8342 case '4': case '5': case '6':
8343 case '7': case '8': case '9':
8344 while (isDIGIT(**pattern))
8345 var = var * 10 + (*(*pattern)++ - '0');
8349 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8352 F0convert(NV nv, char *endbuf, STRLEN *len)
8354 const int neg = nv < 0;
8363 if (uv & 1 && uv == nv)
8364 uv--; /* Round to even */
8366 const unsigned dig = uv % 10;
8379 =for apidoc sv_vcatpvfn
8381 Processes its arguments like C<vsprintf> and appends the formatted output
8382 to an SV. Uses an array of SVs if the C style variable argument list is
8383 missing (NULL). When running with taint checks enabled, indicates via
8384 C<maybe_tainted> if results are untrustworthy (often due to the use of
8387 Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
8393 #define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
8394 vecstr = (U8*)SvPV_const(vecsv,veclen);\
8395 vec_utf8 = DO_UTF8(vecsv);
8397 /* XXX maybe_tainted is never assigned to, so the doc above is lying. */
8400 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8407 static const char nullstr[] = "(null)";
8409 bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
8410 const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
8412 /* Times 4: a decimal digit takes more than 3 binary digits.
8413 * NV_DIG: mantissa takes than many decimal digits.
8414 * Plus 32: Playing safe. */
8415 char ebuf[IV_DIG * 4 + NV_DIG + 32];
8416 /* large enough for "%#.#f" --chip */
8417 /* what about long double NVs? --jhi */
8419 PERL_UNUSED_ARG(maybe_tainted);
8421 /* no matter what, this is a string now */
8422 (void)SvPV_force(sv, origlen);
8424 /* special-case "", "%s", and "%-p" (SVf - see below) */
8427 if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
8429 const char * const s = va_arg(*args, char*);
8430 sv_catpv(sv, s ? s : nullstr);
8432 else if (svix < svmax) {
8433 sv_catsv(sv, *svargs);
8434 if (DO_UTF8(*svargs))
8439 if (args && patlen == 3 && pat[0] == '%' &&
8440 pat[1] == '-' && pat[2] == 'p') {
8441 argsv = va_arg(*args, SV*);
8442 sv_catsv(sv, argsv);
8448 #ifndef USE_LONG_DOUBLE
8449 /* special-case "%.<number>[gf]" */
8450 if ( !args && patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8451 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8452 unsigned digits = 0;
8456 while (*pp >= '0' && *pp <= '9')
8457 digits = 10 * digits + (*pp++ - '0');
8458 if (pp - pat == (int)patlen - 1) {
8466 /* Add check for digits != 0 because it seems that some
8467 gconverts are buggy in this case, and we don't yet have
8468 a Configure test for this. */
8469 if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8470 /* 0, point, slack */
8471 Gconvert(nv, (int)digits, 0, ebuf);
8473 if (*ebuf) /* May return an empty string for digits==0 */
8476 } else if (!digits) {
8479 if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8480 sv_catpvn(sv, p, l);
8486 #endif /* !USE_LONG_DOUBLE */
8488 if (!args && svix < svmax && DO_UTF8(*svargs))
8491 patend = (char*)pat + patlen;
8492 for (p = (char*)pat; p < patend; p = q) {
8495 bool vectorize = FALSE;
8496 bool vectorarg = FALSE;
8497 bool vec_utf8 = FALSE;
8503 bool has_precis = FALSE;
8506 bool is_utf8 = FALSE; /* is this item utf8? */
8507 #ifdef HAS_LDBL_SPRINTF_BUG
8508 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
8509 with sfio - Allen <allens@cpan.org> */
8510 bool fix_ldbl_sprintf_bug = FALSE;
8514 U8 utf8buf[UTF8_MAXBYTES+1];
8515 STRLEN esignlen = 0;
8517 const char *eptr = Nullch;
8520 const U8 *vecstr = Null(U8*);
8527 /* we need a long double target in case HAS_LONG_DOUBLE but
8530 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8538 const char *dotstr = ".";
8539 STRLEN dotstrlen = 1;
8540 I32 efix = 0; /* explicit format parameter index */
8541 I32 ewix = 0; /* explicit width index */
8542 I32 epix = 0; /* explicit precision index */
8543 I32 evix = 0; /* explicit vector index */
8544 bool asterisk = FALSE;
8546 /* echo everything up to the next format specification */
8547 for (q = p; q < patend && *q != '%'; ++q) ;
8549 if (has_utf8 && !pat_utf8)
8550 sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8552 sv_catpvn(sv, p, q - p);
8559 We allow format specification elements in this order:
8560 \d+\$ explicit format parameter index
8562 v|\*(\d+\$)?v vector with optional (optionally specified) arg
8563 0 flag (as above): repeated to allow "v02"
8564 \d+|\*(\d+\$)? width using optional (optionally specified) arg
8565 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8567 [%bcdefginopsuxDFOUX] format (mandatory)
8572 As of perl5.9.3, printf format checking is on by default.
8573 Internally, perl uses %p formats to provide an escape to
8574 some extended formatting. This block deals with those
8575 extensions: if it does not match, (char*)q is reset and
8576 the normal format processing code is used.
8578 Currently defined extensions are:
8579 %p include pointer address (standard)
8580 %-p (SVf) include an SV (previously %_)
8581 %-<num>p include an SV with precision <num>
8582 %1p (VDf) include a v-string (as %vd)
8583 %<num>p reserved for future extensions
8585 Robin Barker 2005-07-14
8592 EXPECT_NUMBER(q, n);
8599 argsv = va_arg(*args, SV*);
8600 eptr = SvPVx_const(argsv, elen);
8606 else if (n == vdNUMBER) { /* VDf */
8613 if (ckWARN_d(WARN_INTERNAL))
8614 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
8615 "internal %%<num>p might conflict with future printf extensions");
8621 if (EXPECT_NUMBER(q, width)) {
8662 if (EXPECT_NUMBER(q, ewix))
8671 if ((vectorarg = asterisk)) {
8684 EXPECT_NUMBER(q, width);
8690 vecsv = va_arg(*args, SV*);
8692 vecsv = (evix ? evix <= svmax : svix < svmax) ?
8693 svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
8694 dotstr = SvPV_const(vecsv, dotstrlen);
8701 else if (efix ? efix <= svmax : svix < svmax) {
8702 vecsv = svargs[efix ? efix-1 : svix++];
8703 vecstr = (U8*)SvPV_const(vecsv,veclen);
8704 vec_utf8 = DO_UTF8(vecsv);
8705 /* if this is a version object, we need to return the
8706 * stringified representation (which the SvPVX_const has
8707 * already done for us), but not vectorize the args
8709 if ( *q == 'd' && sv_derived_from(vecsv,"version") )
8711 q++; /* skip past the rest of the %vd format */
8712 eptr = (const char *) vecstr;
8726 i = va_arg(*args, int);
8728 i = (ewix ? ewix <= svmax : svix < svmax) ?
8729 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8731 width = (i < 0) ? -i : i;
8741 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8743 /* XXX: todo, support specified precision parameter */
8747 i = va_arg(*args, int);
8749 i = (ewix ? ewix <= svmax : svix < svmax)
8750 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8751 precis = (i < 0) ? 0 : i;
8756 precis = precis * 10 + (*q++ - '0');
8765 case 'I': /* Ix, I32x, and I64x */
8767 if (q[1] == '6' && q[2] == '4') {
8773 if (q[1] == '3' && q[2] == '2') {
8783 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8794 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8795 if (*(q + 1) == 'l') { /* lld, llf */
8820 argsv = (efix ? efix <= svmax : svix < svmax) ?
8821 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
8828 uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8830 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8832 eptr = (char*)utf8buf;
8833 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8844 if (args && !vectorize) {
8845 eptr = va_arg(*args, char*);
8847 #ifdef MACOS_TRADITIONAL
8848 /* On MacOS, %#s format is used for Pascal strings */
8853 elen = strlen(eptr);
8855 eptr = (char *)nullstr;
8856 elen = sizeof nullstr - 1;
8860 eptr = SvPVx_const(argsv, elen);
8861 if (DO_UTF8(argsv)) {
8862 if (has_precis && precis < elen) {
8864 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8867 if (width) { /* fudge width (can't fudge elen) */
8868 width += elen - sv_len_utf8(argsv);
8876 if (has_precis && elen > precis)
8883 if (alt || vectorize)
8885 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8906 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8915 esignbuf[esignlen++] = plus;
8919 case 'h': iv = (short)va_arg(*args, int); break;
8920 case 'l': iv = va_arg(*args, long); break;
8921 case 'V': iv = va_arg(*args, IV); break;
8922 default: iv = va_arg(*args, int); break;
8924 case 'q': iv = va_arg(*args, Quad_t); break;
8929 IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8931 case 'h': iv = (short)tiv; break;
8932 case 'l': iv = (long)tiv; break;
8934 default: iv = tiv; break;
8936 case 'q': iv = (Quad_t)tiv; break;
8940 if ( !vectorize ) /* we already set uv above */
8945 esignbuf[esignlen++] = plus;
8949 esignbuf[esignlen++] = '-';
8992 uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
9003 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
9004 case 'l': uv = va_arg(*args, unsigned long); break;
9005 case 'V': uv = va_arg(*args, UV); break;
9006 default: uv = va_arg(*args, unsigned); break;
9008 case 'q': uv = va_arg(*args, Uquad_t); break;
9013 UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
9015 case 'h': uv = (unsigned short)tuv; break;
9016 case 'l': uv = (unsigned long)tuv; break;
9018 default: uv = tuv; break;
9020 case 'q': uv = (Uquad_t)tuv; break;
9027 char *ptr = ebuf + sizeof ebuf;
9033 p = (char*)((c == 'X')
9034 ? "0123456789ABCDEF" : "0123456789abcdef");
9040 esignbuf[esignlen++] = '0';
9041 esignbuf[esignlen++] = c; /* 'x' or 'X' */
9049 if (alt && *ptr != '0')
9058 esignbuf[esignlen++] = '0';
9059 esignbuf[esignlen++] = 'b';
9062 default: /* it had better be ten or less */
9066 } while (uv /= base);
9069 elen = (ebuf + sizeof ebuf) - ptr;
9073 zeros = precis - elen;
9074 else if (precis == 0 && elen == 1 && *eptr == '0')
9080 /* FLOATING POINT */
9083 c = 'f'; /* maybe %F isn't supported here */
9089 /* This is evil, but floating point is even more evil */
9091 /* for SV-style calling, we can only get NV
9092 for C-style calling, we assume %f is double;
9093 for simplicity we allow any of %Lf, %llf, %qf for long double
9097 #if defined(USE_LONG_DOUBLE)
9101 /* [perl #20339] - we should accept and ignore %lf rather than die */
9105 #if defined(USE_LONG_DOUBLE)
9106 intsize = args ? 0 : 'q';
9110 #if defined(HAS_LONG_DOUBLE)
9119 /* now we need (long double) if intsize == 'q', else (double) */
9120 nv = (args && !vectorize) ?
9121 #if LONG_DOUBLESIZE > DOUBLESIZE
9123 va_arg(*args, long double) :
9124 va_arg(*args, double)
9126 va_arg(*args, double)
9132 if (c != 'e' && c != 'E') {
9134 /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9135 will cast our (long double) to (double) */
9136 (void)Perl_frexp(nv, &i);
9137 if (i == PERL_INT_MIN)
9138 Perl_die(aTHX_ "panic: frexp");
9140 need = BIT_DIGITS(i);
9142 need += has_precis ? precis : 6; /* known default */
9147 #ifdef HAS_LDBL_SPRINTF_BUG
9148 /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9149 with sfio - Allen <allens@cpan.org> */
9152 # define MY_DBL_MAX DBL_MAX
9153 # else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9154 # if DOUBLESIZE >= 8
9155 # define MY_DBL_MAX 1.7976931348623157E+308L
9157 # define MY_DBL_MAX 3.40282347E+38L
9161 # ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9162 # define MY_DBL_MAX_BUG 1L
9164 # define MY_DBL_MAX_BUG MY_DBL_MAX
9168 # define MY_DBL_MIN DBL_MIN
9169 # else /* XXX guessing! -Allen */
9170 # if DOUBLESIZE >= 8
9171 # define MY_DBL_MIN 2.2250738585072014E-308L
9173 # define MY_DBL_MIN 1.17549435E-38L
9177 if ((intsize == 'q') && (c == 'f') &&
9178 ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9180 /* it's going to be short enough that
9181 * long double precision is not needed */
9183 if ((nv <= 0L) && (nv >= -0L))
9184 fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9186 /* would use Perl_fp_class as a double-check but not
9187 * functional on IRIX - see perl.h comments */
9189 if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9190 /* It's within the range that a double can represent */
9191 #if defined(DBL_MAX) && !defined(DBL_MIN)
9192 if ((nv >= ((long double)1/DBL_MAX)) ||
9193 (nv <= (-(long double)1/DBL_MAX)))
9195 fix_ldbl_sprintf_bug = TRUE;
9198 if (fix_ldbl_sprintf_bug == TRUE) {
9208 # undef MY_DBL_MAX_BUG
9211 #endif /* HAS_LDBL_SPRINTF_BUG */
9213 need += 20; /* fudge factor */
9214 if (PL_efloatsize < need) {
9215 Safefree(PL_efloatbuf);
9216 PL_efloatsize = need + 20; /* more fudge */
9217 Newx(PL_efloatbuf, PL_efloatsize, char);
9218 PL_efloatbuf[0] = '\0';
9221 if ( !(width || left || plus || alt) && fill != '0'
9222 && has_precis && intsize != 'q' ) { /* Shortcuts */
9223 /* See earlier comment about buggy Gconvert when digits,
9225 if ( c == 'g' && precis) {
9226 Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9227 /* May return an empty string for digits==0 */
9228 if (*PL_efloatbuf) {
9229 elen = strlen(PL_efloatbuf);
9230 goto float_converted;
9232 } else if ( c == 'f' && !precis) {
9233 if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9238 char *ptr = ebuf + sizeof ebuf;
9241 /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9242 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9243 if (intsize == 'q') {
9244 /* Copy the one or more characters in a long double
9245 * format before the 'base' ([efgEFG]) character to
9246 * the format string. */
9247 static char const prifldbl[] = PERL_PRIfldbl;
9248 char const *p = prifldbl + sizeof(prifldbl) - 3;
9249 while (p >= prifldbl) { *--ptr = *p--; }
9254 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9259 do { *--ptr = '0' + (base % 10); } while (base /= 10);
9271 /* No taint. Otherwise we are in the strange situation
9272 * where printf() taints but print($float) doesn't.
9274 #if defined(HAS_LONG_DOUBLE)
9275 elen = ((intsize == 'q')
9276 ? my_sprintf(PL_efloatbuf, ptr, nv)
9277 : my_sprintf(PL_efloatbuf, ptr, (double)nv));
9279 elen = my_sprintf(PL_efloatbuf, ptr, nv);
9283 eptr = PL_efloatbuf;
9289 i = SvCUR(sv) - origlen;
9290 if (args && !vectorize) {
9292 case 'h': *(va_arg(*args, short*)) = i; break;
9293 default: *(va_arg(*args, int*)) = i; break;
9294 case 'l': *(va_arg(*args, long*)) = i; break;
9295 case 'V': *(va_arg(*args, IV*)) = i; break;
9297 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
9302 sv_setuv_mg(argsv, (UV)i);
9304 continue; /* not "break" */
9311 && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)
9312 && ckWARN(WARN_PRINTF))
9314 SV * const msg = sv_newmortal();
9315 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9316 (PL_op->op_type == OP_PRTF) ? "" : "s");
9319 Perl_sv_catpvf(aTHX_ msg,
9320 "\"%%%c\"", c & 0xFF);
9322 Perl_sv_catpvf(aTHX_ msg,
9323 "\"%%\\%03"UVof"\"",
9326 sv_catpv(msg, "end of string");
9327 Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9330 /* output mangled stuff ... */
9336 /* ... right here, because formatting flags should not apply */
9337 SvGROW(sv, SvCUR(sv) + elen + 1);
9339 Copy(eptr, p, elen, char);
9342 SvCUR_set(sv, p - SvPVX_const(sv));
9344 continue; /* not "break" */
9347 /* calculate width before utf8_upgrade changes it */
9348 have = esignlen + zeros + elen;
9350 if (is_utf8 != has_utf8) {
9353 sv_utf8_upgrade(sv);
9356 SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
9357 sv_utf8_upgrade(nsv);
9358 eptr = SvPVX_const(nsv);
9361 SvGROW(sv, SvCUR(sv) + elen + 1);
9366 need = (have > width ? have : width);
9369 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9371 if (esignlen && fill == '0') {
9373 for (i = 0; i < (int)esignlen; i++)
9377 memset(p, fill, gap);
9380 if (esignlen && fill != '0') {
9382 for (i = 0; i < (int)esignlen; i++)
9387 for (i = zeros; i; i--)
9391 Copy(eptr, p, elen, char);
9395 memset(p, ' ', gap);
9400 Copy(dotstr, p, dotstrlen, char);
9404 vectorize = FALSE; /* done iterating over vecstr */
9411 SvCUR_set(sv, p - SvPVX_const(sv));
9419 /* =========================================================================
9421 =head1 Cloning an interpreter
9423 All the macros and functions in this section are for the private use of
9424 the main function, perl_clone().
9426 The foo_dup() functions make an exact copy of an existing foo thinngy.
9427 During the course of a cloning, a hash table is used to map old addresses
9428 to new addresses. The table is created and manipulated with the
9429 ptr_table_* functions.
9433 ============================================================================*/
9436 #if defined(USE_ITHREADS)
9438 #ifndef GpREFCNT_inc
9439 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9443 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
9444 #define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
9445 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9446 #define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
9447 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9448 #define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
9449 #define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9450 #define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
9451 #define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9452 #define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
9453 #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9454 #define SAVEPV(p) (p ? savepv(p) : Nullch)
9455 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
9458 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9459 regcomp.c. AMS 20010712 */
9462 Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
9467 struct reg_substr_datum *s;
9470 return (REGEXP *)NULL;
9472 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9475 len = r->offsets[0];
9476 npar = r->nparens+1;
9478 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9479 Copy(r->program, ret->program, len+1, regnode);
9481 Newx(ret->startp, npar, I32);
9482 Copy(r->startp, ret->startp, npar, I32);
9483 Newx(ret->endp, npar, I32);
9484 Copy(r->startp, ret->startp, npar, I32);
9486 Newx(ret->substrs, 1, struct reg_substr_data);
9487 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9488 s->min_offset = r->substrs->data[i].min_offset;
9489 s->max_offset = r->substrs->data[i].max_offset;
9490 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
9491 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9494 ret->regstclass = NULL;
9497 const int count = r->data->count;
9500 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
9501 char, struct reg_data);
9502 Newx(d->what, count, U8);
9505 for (i = 0; i < count; i++) {
9506 d->what[i] = r->data->what[i];
9507 switch (d->what[i]) {
9508 /* legal options are one of: sfpont
9509 see also regcomp.h and pregfree() */
9511 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9514 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9517 /* This is cheating. */
9518 Newx(d->data[i], 1, struct regnode_charclass_class);
9519 StructCopy(r->data->data[i], d->data[i],
9520 struct regnode_charclass_class);
9521 ret->regstclass = (regnode*)d->data[i];
9524 /* Compiled op trees are readonly, and can thus be
9525 shared without duplication. */
9527 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9531 d->data[i] = r->data->data[i];
9534 d->data[i] = r->data->data[i];
9536 ((reg_trie_data*)d->data[i])->refcount++;
9540 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
9549 Newx(ret->offsets, 2*len+1, U32);
9550 Copy(r->offsets, ret->offsets, 2*len+1, U32);
9552 ret->precomp = SAVEPVN(r->precomp, r->prelen);
9553 ret->refcnt = r->refcnt;
9554 ret->minlen = r->minlen;
9555 ret->prelen = r->prelen;
9556 ret->nparens = r->nparens;
9557 ret->lastparen = r->lastparen;
9558 ret->lastcloseparen = r->lastcloseparen;
9559 ret->reganch = r->reganch;
9561 ret->sublen = r->sublen;
9563 if (RX_MATCH_COPIED(ret))
9564 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
9566 ret->subbeg = Nullch;
9567 #ifdef PERL_OLD_COPY_ON_WRITE
9568 ret->saved_copy = Nullsv;
9571 ptr_table_store(PL_ptr_table, r, ret);
9575 /* duplicate a file handle */
9578 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9582 PERL_UNUSED_ARG(type);
9585 return (PerlIO*)NULL;
9587 /* look for it in the table first */
9588 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9592 /* create anew and remember what it is */
9593 ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9594 ptr_table_store(PL_ptr_table, fp, ret);
9598 /* duplicate a directory handle */
9601 Perl_dirp_dup(pTHX_ DIR *dp)
9609 /* duplicate a typeglob */
9612 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9617 /* look for it in the table first */
9618 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9622 /* create anew and remember what it is */
9624 ptr_table_store(PL_ptr_table, gp, ret);
9627 ret->gp_refcnt = 0; /* must be before any other dups! */
9628 ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
9629 ret->gp_io = io_dup_inc(gp->gp_io, param);
9630 ret->gp_form = cv_dup_inc(gp->gp_form, param);
9631 ret->gp_av = av_dup_inc(gp->gp_av, param);
9632 ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
9633 ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9634 ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
9635 ret->gp_cvgen = gp->gp_cvgen;
9636 ret->gp_line = gp->gp_line;
9637 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
9641 /* duplicate a chain of magic */
9644 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9646 MAGIC *mgprev = (MAGIC*)NULL;
9649 return (MAGIC*)NULL;
9650 /* look for it in the table first */
9651 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9655 for (; mg; mg = mg->mg_moremagic) {
9657 Newxz(nmg, 1, MAGIC);
9659 mgprev->mg_moremagic = nmg;
9662 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
9663 nmg->mg_private = mg->mg_private;
9664 nmg->mg_type = mg->mg_type;
9665 nmg->mg_flags = mg->mg_flags;
9666 if (mg->mg_type == PERL_MAGIC_qr) {
9667 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9669 else if(mg->mg_type == PERL_MAGIC_backref) {
9670 const AV * const av = (AV*) mg->mg_obj;
9673 (void)SvREFCNT_inc(nmg->mg_obj = (SV*)newAV());
9675 for (i = AvFILLp(av); i >= 0; i--) {
9676 if (!svp[i]) continue;
9677 av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9680 else if (mg->mg_type == PERL_MAGIC_symtab) {
9681 nmg->mg_obj = mg->mg_obj;
9684 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
9685 ? sv_dup_inc(mg->mg_obj, param)
9686 : sv_dup(mg->mg_obj, param);
9688 nmg->mg_len = mg->mg_len;
9689 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
9690 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9691 if (mg->mg_len > 0) {
9692 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
9693 if (mg->mg_type == PERL_MAGIC_overload_table &&
9694 AMT_AMAGIC((AMT*)mg->mg_ptr))
9696 AMT * const amtp = (AMT*)mg->mg_ptr;
9697 AMT * const namtp = (AMT*)nmg->mg_ptr;
9699 for (i = 1; i < NofAMmeth; i++) {
9700 namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9704 else if (mg->mg_len == HEf_SVKEY)
9705 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9707 if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9708 CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9715 /* create a new pointer-mapping table */
9718 Perl_ptr_table_new(pTHX)
9721 Newxz(tbl, 1, PTR_TBL_t);
9724 Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9729 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
9731 # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
9735 we use the PTE_SVSLOT 'reservation' made above, both here (in the
9736 following define) and at call to new_body_inline made below in
9737 Perl_ptr_table_store()
9740 #define del_pte(p) del_body_type(p, PTE_SVSLOT)
9742 /* map an existing pointer using a table */
9745 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv)
9747 PTR_TBL_ENT_t *tblent;
9748 const UV hash = PTR_TABLE_HASH(sv);
9750 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9751 for (; tblent; tblent = tblent->next) {
9752 if (tblent->oldval == sv)
9753 return tblent->newval;
9758 /* add a new entry to a pointer-mapping table */
9761 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv)
9763 PTR_TBL_ENT_t *tblent, **otblent;
9764 /* XXX this may be pessimal on platforms where pointers aren't good
9765 * hash values e.g. if they grow faster in the most significant
9767 const UV hash = PTR_TABLE_HASH(oldsv);
9771 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9772 for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
9773 if (tblent->oldval == oldsv) {
9774 tblent->newval = newsv;
9778 new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT);
9779 tblent->oldval = oldsv;
9780 tblent->newval = newsv;
9781 tblent->next = *otblent;
9784 if (!empty && tbl->tbl_items > tbl->tbl_max)
9785 ptr_table_split(tbl);
9788 /* double the hash bucket size of an existing ptr table */
9791 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9793 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9794 const UV oldsize = tbl->tbl_max + 1;
9795 UV newsize = oldsize * 2;
9798 Renew(ary, newsize, PTR_TBL_ENT_t*);
9799 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9800 tbl->tbl_max = --newsize;
9802 for (i=0; i < oldsize; i++, ary++) {
9803 PTR_TBL_ENT_t **curentp, **entp, *ent;
9806 curentp = ary + oldsize;
9807 for (entp = ary, ent = *ary; ent; ent = *entp) {
9808 if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9810 ent->next = *curentp;
9820 /* remove all the entries from a ptr table */
9823 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9825 register PTR_TBL_ENT_t **array;
9826 register PTR_TBL_ENT_t *entry;
9830 if (!tbl || !tbl->tbl_items) {
9834 array = tbl->tbl_ary;
9840 PTR_TBL_ENT_t *oentry = entry;
9841 entry = entry->next;
9845 if (++riter > max) {
9848 entry = array[riter];
9855 /* clear and free a ptr table */
9858 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9863 ptr_table_clear(tbl);
9864 Safefree(tbl->tbl_ary);
9870 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9873 SvRV_set(dstr, SvWEAKREF(sstr)
9874 ? sv_dup(SvRV(sstr), param)
9875 : sv_dup_inc(SvRV(sstr), param));
9878 else if (SvPVX_const(sstr)) {
9879 /* Has something there */
9881 /* Normal PV - clone whole allocated space */
9882 SvPV_set(dstr, SAVEPVN(SvPVX_const(sstr), SvLEN(sstr)-1));
9883 if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9884 /* Not that normal - actually sstr is copy on write.
9885 But we are a true, independant SV, so: */
9886 SvREADONLY_off(dstr);
9891 /* Special case - not normally malloced for some reason */
9892 if ((SvREADONLY(sstr) && SvFAKE(sstr))) {
9893 /* A "shared" PV - clone it as "shared" PV */
9895 HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)),
9899 /* Some other special case - random pointer */
9900 SvPV_set(dstr, SvPVX(sstr));
9906 if (SvTYPE(dstr) == SVt_RV)
9907 SvRV_set(dstr, NULL);
9913 /* duplicate an SV of any type (including AV, HV etc) */
9916 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9921 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9923 /* look for it in the table first */
9924 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9928 if(param->flags & CLONEf_JOIN_IN) {
9929 /** We are joining here so we don't want do clone
9930 something that is bad **/
9933 if(SvTYPE(sstr) == SVt_PVHV &&
9934 (hvname = HvNAME_get(sstr))) {
9935 /** don't clone stashes if they already exist **/
9936 return (SV*)gv_stashpv(hvname,0);
9940 /* create anew and remember what it is */
9943 #ifdef DEBUG_LEAKING_SCALARS
9944 dstr->sv_debug_optype = sstr->sv_debug_optype;
9945 dstr->sv_debug_line = sstr->sv_debug_line;
9946 dstr->sv_debug_inpad = sstr->sv_debug_inpad;
9947 dstr->sv_debug_cloned = 1;
9949 dstr->sv_debug_file = savepv(sstr->sv_debug_file);
9951 dstr->sv_debug_file = savesharedpv(sstr->sv_debug_file);
9955 ptr_table_store(PL_ptr_table, sstr, dstr);
9958 SvFLAGS(dstr) = SvFLAGS(sstr);
9959 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
9960 SvREFCNT(dstr) = 0; /* must be before any other dups! */
9963 if (SvANY(sstr) && PL_watch_pvx && SvPVX_const(sstr) == PL_watch_pvx)
9964 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9965 PL_watch_pvx, SvPVX_const(sstr));
9968 /* don't clone objects whose class has asked us not to */
9969 if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
9970 SvFLAGS(dstr) &= ~SVTYPEMASK;
9975 switch (SvTYPE(sstr)) {
9980 SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv));
9981 SvIV_set(dstr, SvIVX(sstr));
9984 SvANY(dstr) = new_XNV();
9985 SvNV_set(dstr, SvNVX(sstr));
9988 SvANY(dstr) = &(dstr->sv_u.svu_rv);
9989 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9993 /* These are all the types that need complex bodies allocating. */
9995 const svtype sv_type = SvTYPE(sstr);
9996 const struct body_details *const sv_type_details
9997 = bodies_by_type + sv_type;
10001 Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]",
10006 if (GvUNIQUE((GV*)sstr)) {
10007 /* Do sharing here, and fall through */
10020 assert(sv_type_details->copy);
10021 if (sv_type_details->arena) {
10022 new_body_inline(new_body, sv_type_details->copy, sv_type);
10024 = (void*)((char*)new_body + sv_type_details->offset);
10026 new_body = new_NOARENA(sv_type_details);
10030 SvANY(dstr) = new_body;
10033 Copy(((char*)SvANY(sstr)) - sv_type_details->offset,
10034 ((char*)SvANY(dstr)) - sv_type_details->offset,
10035 sv_type_details->copy, char);
10037 Copy(((char*)SvANY(sstr)),
10038 ((char*)SvANY(dstr)),
10039 sv_type_details->size - sv_type_details->offset, char);
10042 if (sv_type != SVt_PVAV && sv_type != SVt_PVHV)
10043 Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10045 /* The Copy above means that all the source (unduplicated) pointers
10046 are now in the destination. We can check the flags and the
10047 pointers in either, but it's possible that there's less cache
10048 missing by always going for the destination.
10049 FIXME - instrument and check that assumption */
10050 if (sv_type >= SVt_PVMG) {
10052 SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
10054 SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
10057 /* The cast silences a GCC warning about unhandled types. */
10058 switch ((int)sv_type) {
10070 /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
10071 if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */
10072 LvTARG(dstr) = dstr;
10073 else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */
10074 LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param);
10076 LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
10079 GvNAME(dstr) = SAVEPVN(GvNAME(dstr), GvNAMELEN(dstr));
10080 GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param);
10081 /* Don't call sv_add_backref here as it's going to be created
10082 as part of the magic cloning of the symbol table. */
10083 GvGP(dstr) = gp_dup(GvGP(dstr), param);
10084 (void)GpREFCNT_inc(GvGP(dstr));
10087 IoIFP(dstr) = fp_dup(IoIFP(dstr), IoTYPE(dstr), param);
10088 if (IoOFP(dstr) == IoIFP(sstr))
10089 IoOFP(dstr) = IoIFP(dstr);
10091 IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param);
10092 /* PL_rsfp_filters entries have fake IoDIRP() */
10093 if (IoDIRP(dstr) && !(IoFLAGS(dstr) & IOf_FAKE_DIRP))
10094 IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
10095 if(IoFLAGS(dstr) & IOf_FAKE_DIRP) {
10096 /* I have no idea why fake dirp (rsfps)
10097 should be treated differently but otherwise
10098 we end up with leaks -- sky*/
10099 IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(dstr), param);
10100 IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(dstr), param);
10101 IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(dstr), param);
10103 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(dstr), param);
10104 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(dstr), param);
10105 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(dstr), param);
10107 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(dstr));
10108 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(dstr));
10109 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr));
10112 if (AvARRAY((AV*)sstr)) {
10113 SV **dst_ary, **src_ary;
10114 SSize_t items = AvFILLp((AV*)sstr) + 1;
10116 src_ary = AvARRAY((AV*)sstr);
10117 Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*);
10118 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10119 SvPV_set(dstr, (char*)dst_ary);
10120 AvALLOC((AV*)dstr) = dst_ary;
10121 if (AvREAL((AV*)sstr)) {
10122 while (items-- > 0)
10123 *dst_ary++ = sv_dup_inc(*src_ary++, param);
10126 while (items-- > 0)
10127 *dst_ary++ = sv_dup(*src_ary++, param);
10129 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10130 while (items-- > 0) {
10131 *dst_ary++ = &PL_sv_undef;
10135 SvPV_set(dstr, Nullch);
10136 AvALLOC((AV*)dstr) = (SV**)NULL;
10143 if (HvARRAY((HV*)sstr)) {
10145 const bool sharekeys = !!HvSHAREKEYS(sstr);
10146 XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
10147 XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
10149 Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
10150 + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
10152 HvARRAY(dstr) = (HE**)darray;
10153 while (i <= sxhv->xhv_max) {
10154 const HE *source = HvARRAY(sstr)[i];
10155 HvARRAY(dstr)[i] = source
10156 ? he_dup(source, sharekeys, param) : 0;
10160 struct xpvhv_aux *saux = HvAUX(sstr);
10161 struct xpvhv_aux *daux = HvAUX(dstr);
10162 /* This flag isn't copied. */
10163 /* SvOOK_on(hv) attacks the IV flags. */
10164 SvFLAGS(dstr) |= SVf_OOK;
10166 hvname = saux->xhv_name;
10168 = hvname ? hek_dup(hvname, param) : hvname;
10170 daux->xhv_riter = saux->xhv_riter;
10171 daux->xhv_eiter = saux->xhv_eiter
10172 ? he_dup(saux->xhv_eiter,
10173 (bool)!!HvSHAREKEYS(sstr), param) : 0;
10177 SvPV_set(dstr, Nullch);
10179 /* Record stashes for possible cloning in Perl_clone(). */
10181 av_push(param->stashes, dstr);
10186 /* NOTE: not refcounted */
10187 CvSTASH(dstr) = hv_dup(CvSTASH(dstr), param);
10189 CvROOT(dstr) = OpREFCNT_inc(CvROOT(dstr));
10191 if (CvCONST(dstr)) {
10192 CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ?
10193 SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) :
10194 sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param);
10196 /* don't dup if copying back - CvGV isn't refcounted, so the
10197 * duped GV may never be freed. A bit of a hack! DAPM */
10198 CvGV(dstr) = (param->flags & CLONEf_JOIN_IN) ?
10199 Nullgv : gv_dup(CvGV(dstr), param) ;
10200 if (!(param->flags & CLONEf_COPY_STACKS)) {
10203 PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10205 CvWEAKOUTSIDE(sstr)
10206 ? cv_dup( CvOUTSIDE(dstr), param)
10207 : cv_dup_inc(CvOUTSIDE(dstr), param);
10209 CvFILE(dstr) = SAVEPV(CvFILE(dstr));
10215 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10221 /* duplicate a context */
10224 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10226 PERL_CONTEXT *ncxs;
10229 return (PERL_CONTEXT*)NULL;
10231 /* look for it in the table first */
10232 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10236 /* create anew and remember what it is */
10237 Newxz(ncxs, max + 1, PERL_CONTEXT);
10238 ptr_table_store(PL_ptr_table, cxs, ncxs);
10241 PERL_CONTEXT *cx = &cxs[ix];
10242 PERL_CONTEXT *ncx = &ncxs[ix];
10243 ncx->cx_type = cx->cx_type;
10244 if (CxTYPE(cx) == CXt_SUBST) {
10245 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10248 ncx->blk_oldsp = cx->blk_oldsp;
10249 ncx->blk_oldcop = cx->blk_oldcop;
10250 ncx->blk_oldmarksp = cx->blk_oldmarksp;
10251 ncx->blk_oldscopesp = cx->blk_oldscopesp;
10252 ncx->blk_oldpm = cx->blk_oldpm;
10253 ncx->blk_gimme = cx->blk_gimme;
10254 switch (CxTYPE(cx)) {
10256 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
10257 ? cv_dup_inc(cx->blk_sub.cv, param)
10258 : cv_dup(cx->blk_sub.cv,param));
10259 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
10260 ? av_dup_inc(cx->blk_sub.argarray, param)
10262 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
10263 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
10264 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10265 ncx->blk_sub.lval = cx->blk_sub.lval;
10266 ncx->blk_sub.retop = cx->blk_sub.retop;
10269 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10270 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10271 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10272 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10273 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
10274 ncx->blk_eval.retop = cx->blk_eval.retop;
10277 ncx->blk_loop.label = cx->blk_loop.label;
10278 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
10279 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
10280 ncx->blk_loop.next_op = cx->blk_loop.next_op;
10281 ncx->blk_loop.last_op = cx->blk_loop.last_op;
10282 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
10283 ? cx->blk_loop.iterdata
10284 : gv_dup((GV*)cx->blk_loop.iterdata, param));
10285 ncx->blk_loop.oldcomppad
10286 = (PAD*)ptr_table_fetch(PL_ptr_table,
10287 cx->blk_loop.oldcomppad);
10288 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
10289 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
10290 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
10291 ncx->blk_loop.iterix = cx->blk_loop.iterix;
10292 ncx->blk_loop.itermax = cx->blk_loop.itermax;
10295 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
10296 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
10297 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
10298 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
10299 ncx->blk_sub.retop = cx->blk_sub.retop;
10311 /* duplicate a stack info structure */
10314 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10319 return (PERL_SI*)NULL;
10321 /* look for it in the table first */
10322 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10326 /* create anew and remember what it is */
10327 Newxz(nsi, 1, PERL_SI);
10328 ptr_table_store(PL_ptr_table, si, nsi);
10330 nsi->si_stack = av_dup_inc(si->si_stack, param);
10331 nsi->si_cxix = si->si_cxix;
10332 nsi->si_cxmax = si->si_cxmax;
10333 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10334 nsi->si_type = si->si_type;
10335 nsi->si_prev = si_dup(si->si_prev, param);
10336 nsi->si_next = si_dup(si->si_next, param);
10337 nsi->si_markoff = si->si_markoff;
10342 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
10343 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
10344 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
10345 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
10346 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
10347 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
10348 #define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
10349 #define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
10350 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
10351 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
10352 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
10353 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
10354 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
10355 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
10358 #define pv_dup_inc(p) SAVEPV(p)
10359 #define pv_dup(p) SAVEPV(p)
10360 #define svp_dup_inc(p,pp) any_dup(p,pp)
10362 /* map any object to the new equivent - either something in the
10363 * ptr table, or something in the interpreter structure
10367 Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl)
10372 return (void*)NULL;
10374 /* look for it in the table first */
10375 ret = ptr_table_fetch(PL_ptr_table, v);
10379 /* see if it is part of the interpreter structure */
10380 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10381 ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10389 /* duplicate the save stack */
10392 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10394 ANY * const ss = proto_perl->Tsavestack;
10395 const I32 max = proto_perl->Tsavestack_max;
10396 I32 ix = proto_perl->Tsavestack_ix;
10408 void (*dptr) (void*);
10409 void (*dxptr) (pTHX_ void*);
10411 Newxz(nss, max, ANY);
10414 I32 i = POPINT(ss,ix);
10415 TOPINT(nss,ix) = i;
10417 case SAVEt_ITEM: /* normal string */
10418 sv = (SV*)POPPTR(ss,ix);
10419 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10420 sv = (SV*)POPPTR(ss,ix);
10421 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10423 case SAVEt_SV: /* scalar reference */
10424 sv = (SV*)POPPTR(ss,ix);
10425 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10426 gv = (GV*)POPPTR(ss,ix);
10427 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10429 case SAVEt_GENERIC_PVREF: /* generic char* */
10430 c = (char*)POPPTR(ss,ix);
10431 TOPPTR(nss,ix) = pv_dup(c);
10432 ptr = POPPTR(ss,ix);
10433 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10435 case SAVEt_SHARED_PVREF: /* char* in shared space */
10436 c = (char*)POPPTR(ss,ix);
10437 TOPPTR(nss,ix) = savesharedpv(c);
10438 ptr = POPPTR(ss,ix);
10439 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10441 case SAVEt_GENERIC_SVREF: /* generic sv */
10442 case SAVEt_SVREF: /* scalar reference */
10443 sv = (SV*)POPPTR(ss,ix);
10444 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10445 ptr = POPPTR(ss,ix);
10446 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10448 case SAVEt_AV: /* array reference */
10449 av = (AV*)POPPTR(ss,ix);
10450 TOPPTR(nss,ix) = av_dup_inc(av, param);
10451 gv = (GV*)POPPTR(ss,ix);
10452 TOPPTR(nss,ix) = gv_dup(gv, param);
10454 case SAVEt_HV: /* hash reference */
10455 hv = (HV*)POPPTR(ss,ix);
10456 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10457 gv = (GV*)POPPTR(ss,ix);
10458 TOPPTR(nss,ix) = gv_dup(gv, param);
10460 case SAVEt_INT: /* int reference */
10461 ptr = POPPTR(ss,ix);
10462 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10463 intval = (int)POPINT(ss,ix);
10464 TOPINT(nss,ix) = intval;
10466 case SAVEt_LONG: /* long reference */
10467 ptr = POPPTR(ss,ix);
10468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10469 longval = (long)POPLONG(ss,ix);
10470 TOPLONG(nss,ix) = longval;
10472 case SAVEt_I32: /* I32 reference */
10473 case SAVEt_I16: /* I16 reference */
10474 case SAVEt_I8: /* I8 reference */
10475 ptr = POPPTR(ss,ix);
10476 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10478 TOPINT(nss,ix) = i;
10480 case SAVEt_IV: /* IV reference */
10481 ptr = POPPTR(ss,ix);
10482 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10484 TOPIV(nss,ix) = iv;
10486 case SAVEt_SPTR: /* SV* reference */
10487 ptr = POPPTR(ss,ix);
10488 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10489 sv = (SV*)POPPTR(ss,ix);
10490 TOPPTR(nss,ix) = sv_dup(sv, param);
10492 case SAVEt_VPTR: /* random* reference */
10493 ptr = POPPTR(ss,ix);
10494 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10495 ptr = POPPTR(ss,ix);
10496 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10498 case SAVEt_PPTR: /* char* reference */
10499 ptr = POPPTR(ss,ix);
10500 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10501 c = (char*)POPPTR(ss,ix);
10502 TOPPTR(nss,ix) = pv_dup(c);
10504 case SAVEt_HPTR: /* HV* reference */
10505 ptr = POPPTR(ss,ix);
10506 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10507 hv = (HV*)POPPTR(ss,ix);
10508 TOPPTR(nss,ix) = hv_dup(hv, param);
10510 case SAVEt_APTR: /* AV* reference */
10511 ptr = POPPTR(ss,ix);
10512 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10513 av = (AV*)POPPTR(ss,ix);
10514 TOPPTR(nss,ix) = av_dup(av, param);
10517 gv = (GV*)POPPTR(ss,ix);
10518 TOPPTR(nss,ix) = gv_dup(gv, param);
10520 case SAVEt_GP: /* scalar reference */
10521 gp = (GP*)POPPTR(ss,ix);
10522 TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10523 (void)GpREFCNT_inc(gp);
10524 gv = (GV*)POPPTR(ss,ix);
10525 TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10526 c = (char*)POPPTR(ss,ix);
10527 TOPPTR(nss,ix) = pv_dup(c);
10529 TOPIV(nss,ix) = iv;
10531 TOPIV(nss,ix) = iv;
10534 case SAVEt_MORTALIZESV:
10535 sv = (SV*)POPPTR(ss,ix);
10536 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10539 ptr = POPPTR(ss,ix);
10540 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10541 /* these are assumed to be refcounted properly */
10543 switch (((OP*)ptr)->op_type) {
10545 case OP_LEAVESUBLV:
10549 case OP_LEAVEWRITE:
10550 TOPPTR(nss,ix) = ptr;
10555 TOPPTR(nss,ix) = Nullop;
10560 TOPPTR(nss,ix) = Nullop;
10563 c = (char*)POPPTR(ss,ix);
10564 TOPPTR(nss,ix) = pv_dup_inc(c);
10566 case SAVEt_CLEARSV:
10567 longval = POPLONG(ss,ix);
10568 TOPLONG(nss,ix) = longval;
10571 hv = (HV*)POPPTR(ss,ix);
10572 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10573 c = (char*)POPPTR(ss,ix);
10574 TOPPTR(nss,ix) = pv_dup_inc(c);
10576 TOPINT(nss,ix) = i;
10578 case SAVEt_DESTRUCTOR:
10579 ptr = POPPTR(ss,ix);
10580 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10581 dptr = POPDPTR(ss,ix);
10582 TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*),
10583 any_dup(FPTR2DPTR(void *, dptr),
10586 case SAVEt_DESTRUCTOR_X:
10587 ptr = POPPTR(ss,ix);
10588 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
10589 dxptr = POPDXPTR(ss,ix);
10590 TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*),
10591 any_dup(FPTR2DPTR(void *, dxptr),
10594 case SAVEt_REGCONTEXT:
10597 TOPINT(nss,ix) = i;
10600 case SAVEt_STACK_POS: /* Position on Perl stack */
10602 TOPINT(nss,ix) = i;
10604 case SAVEt_AELEM: /* array element */
10605 sv = (SV*)POPPTR(ss,ix);
10606 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10608 TOPINT(nss,ix) = i;
10609 av = (AV*)POPPTR(ss,ix);
10610 TOPPTR(nss,ix) = av_dup_inc(av, param);
10612 case SAVEt_HELEM: /* hash element */
10613 sv = (SV*)POPPTR(ss,ix);
10614 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10615 sv = (SV*)POPPTR(ss,ix);
10616 TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10617 hv = (HV*)POPPTR(ss,ix);
10618 TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10621 ptr = POPPTR(ss,ix);
10622 TOPPTR(nss,ix) = ptr;
10626 TOPINT(nss,ix) = i;
10628 case SAVEt_COMPPAD:
10629 av = (AV*)POPPTR(ss,ix);
10630 TOPPTR(nss,ix) = av_dup(av, param);
10633 longval = (long)POPLONG(ss,ix);
10634 TOPLONG(nss,ix) = longval;
10635 ptr = POPPTR(ss,ix);
10636 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10637 sv = (SV*)POPPTR(ss,ix);
10638 TOPPTR(nss,ix) = sv_dup(sv, param);
10641 ptr = POPPTR(ss,ix);
10642 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10643 longval = (long)POPBOOL(ss,ix);
10644 TOPBOOL(nss,ix) = (bool)longval;
10646 case SAVEt_SET_SVFLAGS:
10648 TOPINT(nss,ix) = i;
10650 TOPINT(nss,ix) = i;
10651 sv = (SV*)POPPTR(ss,ix);
10652 TOPPTR(nss,ix) = sv_dup(sv, param);
10655 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10663 /* if sv is a stash, call $class->CLONE_SKIP(), and set the SVphv_CLONEABLE
10664 * flag to the result. This is done for each stash before cloning starts,
10665 * so we know which stashes want their objects cloned */
10668 do_mark_cloneable_stash(pTHX_ SV *sv)
10670 const HEK * const hvname = HvNAME_HEK((HV*)sv);
10672 GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
10673 SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
10674 if (cloner && GvCV(cloner)) {
10681 XPUSHs(sv_2mortal(newSVhek(hvname)));
10683 call_sv((SV*)GvCV(cloner), G_SCALAR);
10690 SvFLAGS(sv) &= ~SVphv_CLONEABLE;
10698 =for apidoc perl_clone
10700 Create and return a new interpreter by cloning the current one.
10702 perl_clone takes these flags as parameters:
10704 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10705 without it we only clone the data and zero the stacks,
10706 with it we copy the stacks and the new perl interpreter is
10707 ready to run at the exact same point as the previous one.
10708 The pseudo-fork code uses COPY_STACKS while the
10709 threads->new doesn't.
10711 CLONEf_KEEP_PTR_TABLE
10712 perl_clone keeps a ptr_table with the pointer of the old
10713 variable as a key and the new variable as a value,
10714 this allows it to check if something has been cloned and not
10715 clone it again but rather just use the value and increase the
10716 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10717 the ptr_table using the function
10718 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10719 reason to keep it around is if you want to dup some of your own
10720 variable who are outside the graph perl scans, example of this
10721 code is in threads.xs create
10724 This is a win32 thing, it is ignored on unix, it tells perls
10725 win32host code (which is c++) to clone itself, this is needed on
10726 win32 if you want to run two threads at the same time,
10727 if you just want to do some stuff in a separate perl interpreter
10728 and then throw it away and return to the original one,
10729 you don't need to do anything.
10734 /* XXX the above needs expanding by someone who actually understands it ! */
10735 EXTERN_C PerlInterpreter *
10736 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10739 perl_clone(PerlInterpreter *proto_perl, UV flags)
10742 #ifdef PERL_IMPLICIT_SYS
10744 /* perlhost.h so we need to call into it
10745 to clone the host, CPerlHost should have a c interface, sky */
10747 if (flags & CLONEf_CLONE_HOST) {
10748 return perl_clone_host(proto_perl,flags);
10750 return perl_clone_using(proto_perl, flags,
10752 proto_perl->IMemShared,
10753 proto_perl->IMemParse,
10755 proto_perl->IStdIO,
10759 proto_perl->IProc);
10763 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10764 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10765 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10766 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10767 struct IPerlDir* ipD, struct IPerlSock* ipS,
10768 struct IPerlProc* ipP)
10770 /* XXX many of the string copies here can be optimized if they're
10771 * constants; they need to be allocated as common memory and just
10772 * their pointers copied. */
10775 CLONE_PARAMS clone_params;
10776 CLONE_PARAMS* param = &clone_params;
10778 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10779 /* for each stash, determine whether its objects should be cloned */
10780 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10781 PERL_SET_THX(my_perl);
10784 Poison(my_perl, 1, PerlInterpreter);
10786 PL_curcop = (COP *)Nullop;
10790 PL_savestack_ix = 0;
10791 PL_savestack_max = -1;
10792 PL_sig_pending = 0;
10793 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10794 # else /* !DEBUGGING */
10795 Zero(my_perl, 1, PerlInterpreter);
10796 # endif /* DEBUGGING */
10798 /* host pointers */
10800 PL_MemShared = ipMS;
10801 PL_MemParse = ipMP;
10808 #else /* !PERL_IMPLICIT_SYS */
10810 CLONE_PARAMS clone_params;
10811 CLONE_PARAMS* param = &clone_params;
10812 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10813 /* for each stash, determine whether its objects should be cloned */
10814 S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK);
10815 PERL_SET_THX(my_perl);
10818 Poison(my_perl, 1, PerlInterpreter);
10820 PL_curcop = (COP *)Nullop;
10824 PL_savestack_ix = 0;
10825 PL_savestack_max = -1;
10826 PL_sig_pending = 0;
10827 Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10828 # else /* !DEBUGGING */
10829 Zero(my_perl, 1, PerlInterpreter);
10830 # endif /* DEBUGGING */
10831 #endif /* PERL_IMPLICIT_SYS */
10832 param->flags = flags;
10833 param->proto_perl = proto_perl;
10835 Zero(&PL_body_arenaroots, 1, PL_body_arenaroots);
10836 Zero(&PL_body_roots, 1, PL_body_roots);
10838 PL_nice_chunk = NULL;
10839 PL_nice_chunk_size = 0;
10841 PL_sv_objcount = 0;
10842 PL_sv_root = Nullsv;
10843 PL_sv_arenaroot = Nullsv;
10845 PL_debug = proto_perl->Idebug;
10847 PL_hash_seed = proto_perl->Ihash_seed;
10848 PL_rehash_seed = proto_perl->Irehash_seed;
10850 #ifdef USE_REENTRANT_API
10851 /* XXX: things like -Dm will segfault here in perlio, but doing
10852 * PERL_SET_CONTEXT(proto_perl);
10853 * breaks too many other things
10855 Perl_reentrant_init(aTHX);
10858 /* create SV map for pointer relocation */
10859 PL_ptr_table = ptr_table_new();
10861 /* initialize these special pointers as early as possible */
10862 SvANY(&PL_sv_undef) = NULL;
10863 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
10864 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
10865 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10867 SvANY(&PL_sv_no) = new_XPVNV();
10868 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
10869 SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10870 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10871 SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
10872 SvCUR_set(&PL_sv_no, 0);
10873 SvLEN_set(&PL_sv_no, 1);
10874 SvIV_set(&PL_sv_no, 0);
10875 SvNV_set(&PL_sv_no, 0);
10876 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10878 SvANY(&PL_sv_yes) = new_XPVNV();
10879 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
10880 SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
10881 |SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10882 SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
10883 SvCUR_set(&PL_sv_yes, 1);
10884 SvLEN_set(&PL_sv_yes, 2);
10885 SvIV_set(&PL_sv_yes, 1);
10886 SvNV_set(&PL_sv_yes, 1);
10887 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10889 /* create (a non-shared!) shared string table */
10890 PL_strtab = newHV();
10891 HvSHAREKEYS_off(PL_strtab);
10892 hv_ksplit(PL_strtab, HvTOTALKEYS(proto_perl->Istrtab));
10893 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10895 PL_compiling = proto_perl->Icompiling;
10897 /* These two PVs will be free'd special way so must set them same way op.c does */
10898 PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10899 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10901 PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
10902 ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10904 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10905 if (!specialWARN(PL_compiling.cop_warnings))
10906 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10907 if (!specialCopIO(PL_compiling.cop_io))
10908 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10909 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10911 /* pseudo environmental stuff */
10912 PL_origargc = proto_perl->Iorigargc;
10913 PL_origargv = proto_perl->Iorigargv;
10915 param->stashes = newAV(); /* Setup array of objects to call clone on */
10917 /* Set tainting stuff before PerlIO_debug can possibly get called */
10918 PL_tainting = proto_perl->Itainting;
10919 PL_taint_warn = proto_perl->Itaint_warn;
10921 #ifdef PERLIO_LAYERS
10922 /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10923 PerlIO_clone(aTHX_ proto_perl, param);
10926 PL_envgv = gv_dup(proto_perl->Ienvgv, param);
10927 PL_incgv = gv_dup(proto_perl->Iincgv, param);
10928 PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
10929 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
10930 PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
10931 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
10934 PL_minus_c = proto_perl->Iminus_c;
10935 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
10936 PL_localpatches = proto_perl->Ilocalpatches;
10937 PL_splitstr = proto_perl->Isplitstr;
10938 PL_preprocess = proto_perl->Ipreprocess;
10939 PL_minus_n = proto_perl->Iminus_n;
10940 PL_minus_p = proto_perl->Iminus_p;
10941 PL_minus_l = proto_perl->Iminus_l;
10942 PL_minus_a = proto_perl->Iminus_a;
10943 PL_minus_F = proto_perl->Iminus_F;
10944 PL_doswitches = proto_perl->Idoswitches;
10945 PL_dowarn = proto_perl->Idowarn;
10946 PL_doextract = proto_perl->Idoextract;
10947 PL_sawampersand = proto_perl->Isawampersand;
10948 PL_unsafe = proto_perl->Iunsafe;
10949 PL_inplace = SAVEPV(proto_perl->Iinplace);
10950 PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
10951 PL_perldb = proto_perl->Iperldb;
10952 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10953 PL_exit_flags = proto_perl->Iexit_flags;
10955 /* magical thingies */
10956 /* XXX time(&PL_basetime) when asked for? */
10957 PL_basetime = proto_perl->Ibasetime;
10958 PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
10960 PL_maxsysfd = proto_perl->Imaxsysfd;
10961 PL_multiline = proto_perl->Imultiline;
10962 PL_statusvalue = proto_perl->Istatusvalue;
10964 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
10966 PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
10968 PL_encoding = sv_dup(proto_perl->Iencoding, param);
10970 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
10971 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
10972 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
10974 /* Clone the regex array */
10975 PL_regex_padav = newAV();
10977 const I32 len = av_len((AV*)proto_perl->Iregex_padav);
10978 SV** const regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10980 av_push(PL_regex_padav,
10981 sv_dup_inc(regexen[0],param));
10982 for(i = 1; i <= len; i++) {
10983 if(SvREPADTMP(regexen[i])) {
10984 av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10986 av_push(PL_regex_padav,
10988 newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10989 SvIVX(regexen[i])), param)))
10994 PL_regex_pad = AvARRAY(PL_regex_padav);
10996 /* shortcuts to various I/O objects */
10997 PL_stdingv = gv_dup(proto_perl->Istdingv, param);
10998 PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
10999 PL_defgv = gv_dup(proto_perl->Idefgv, param);
11000 PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
11001 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
11002 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
11004 /* shortcuts to regexp stuff */
11005 PL_replgv = gv_dup(proto_perl->Ireplgv, param);
11007 /* shortcuts to misc objects */
11008 PL_errgv = gv_dup(proto_perl->Ierrgv, param);
11010 /* shortcuts to debugging objects */
11011 PL_DBgv = gv_dup(proto_perl->IDBgv, param);
11012 PL_DBline = gv_dup(proto_perl->IDBline, param);
11013 PL_DBsub = gv_dup(proto_perl->IDBsub, param);
11014 PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
11015 PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
11016 PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
11017 PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
11018 PL_lineary = av_dup(proto_perl->Ilineary, param);
11019 PL_dbargs = av_dup(proto_perl->Idbargs, param);
11021 /* symbol tables */
11022 PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
11023 PL_curstash = hv_dup(proto_perl->Tcurstash, param);
11024 PL_debstash = hv_dup(proto_perl->Idebstash, param);
11025 PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
11026 PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
11028 PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
11029 PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
11030 PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param);
11031 PL_endav = av_dup_inc(proto_perl->Iendav, param);
11032 PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
11033 PL_initav = av_dup_inc(proto_perl->Iinitav, param);
11035 PL_sub_generation = proto_perl->Isub_generation;
11037 /* funky return mechanisms */
11038 PL_forkprocess = proto_perl->Iforkprocess;
11040 /* subprocess state */
11041 PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
11043 /* internal state */
11044 PL_maxo = proto_perl->Imaxo;
11045 if (proto_perl->Iop_mask)
11046 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
11048 PL_op_mask = Nullch;
11049 /* PL_asserting = proto_perl->Iasserting; */
11051 /* current interpreter roots */
11052 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
11053 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
11054 PL_main_start = proto_perl->Imain_start;
11055 PL_eval_root = proto_perl->Ieval_root;
11056 PL_eval_start = proto_perl->Ieval_start;
11058 /* runtime control stuff */
11059 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
11060 PL_copline = proto_perl->Icopline;
11062 PL_filemode = proto_perl->Ifilemode;
11063 PL_lastfd = proto_perl->Ilastfd;
11064 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
11067 PL_gensym = proto_perl->Igensym;
11068 PL_preambled = proto_perl->Ipreambled;
11069 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
11070 PL_laststatval = proto_perl->Ilaststatval;
11071 PL_laststype = proto_perl->Ilaststype;
11072 PL_mess_sv = Nullsv;
11074 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
11076 /* interpreter atexit processing */
11077 PL_exitlistlen = proto_perl->Iexitlistlen;
11078 if (PL_exitlistlen) {
11079 Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11080 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
11083 PL_exitlist = (PerlExitListEntry*)NULL;
11084 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
11085 PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
11086 PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
11088 PL_profiledata = NULL;
11089 PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
11090 /* PL_rsfp_filters entries have fake IoDIRP() */
11091 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
11093 PL_compcv = cv_dup(proto_perl->Icompcv, param);
11095 PAD_CLONE_VARS(proto_perl, param);
11097 #ifdef HAVE_INTERP_INTERN
11098 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
11101 /* more statics moved here */
11102 PL_generation = proto_perl->Igeneration;
11103 PL_DBcv = cv_dup(proto_perl->IDBcv, param);
11105 PL_in_clean_objs = proto_perl->Iin_clean_objs;
11106 PL_in_clean_all = proto_perl->Iin_clean_all;
11108 PL_uid = proto_perl->Iuid;
11109 PL_euid = proto_perl->Ieuid;
11110 PL_gid = proto_perl->Igid;
11111 PL_egid = proto_perl->Iegid;
11112 PL_nomemok = proto_perl->Inomemok;
11113 PL_an = proto_perl->Ian;
11114 PL_evalseq = proto_perl->Ievalseq;
11115 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
11116 PL_origalen = proto_perl->Iorigalen;
11117 #ifdef PERL_USES_PL_PIDSTATUS
11118 PL_pidstatus = newHV(); /* XXX flag for cloning? */
11120 PL_osname = SAVEPV(proto_perl->Iosname);
11121 PL_sighandlerp = proto_perl->Isighandlerp;
11123 PL_runops = proto_perl->Irunops;
11125 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11128 PL_cshlen = proto_perl->Icshlen;
11129 PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
11132 PL_lex_state = proto_perl->Ilex_state;
11133 PL_lex_defer = proto_perl->Ilex_defer;
11134 PL_lex_expect = proto_perl->Ilex_expect;
11135 PL_lex_formbrack = proto_perl->Ilex_formbrack;
11136 PL_lex_dojoin = proto_perl->Ilex_dojoin;
11137 PL_lex_starts = proto_perl->Ilex_starts;
11138 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
11139 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
11140 PL_lex_op = proto_perl->Ilex_op;
11141 PL_lex_inpat = proto_perl->Ilex_inpat;
11142 PL_lex_inwhat = proto_perl->Ilex_inwhat;
11143 PL_lex_brackets = proto_perl->Ilex_brackets;
11144 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11145 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
11146 PL_lex_casemods = proto_perl->Ilex_casemods;
11147 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11148 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
11150 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11151 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
11152 PL_nexttoke = proto_perl->Inexttoke;
11154 /* XXX This is probably masking the deeper issue of why
11155 * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11156 * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11157 * (A little debugging with a watchpoint on it may help.)
11159 if (SvANY(proto_perl->Ilinestr)) {
11160 PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
11161 i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr);
11162 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11163 i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr);
11164 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11165 i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr);
11166 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11167 i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr);
11168 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11171 PL_linestr = NEWSV(65,79);
11172 sv_upgrade(PL_linestr,SVt_PVIV);
11173 sv_setpvn(PL_linestr,"",0);
11174 PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11176 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11177 PL_pending_ident = proto_perl->Ipending_ident;
11178 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
11180 PL_expect = proto_perl->Iexpect;
11182 PL_multi_start = proto_perl->Imulti_start;
11183 PL_multi_end = proto_perl->Imulti_end;
11184 PL_multi_open = proto_perl->Imulti_open;
11185 PL_multi_close = proto_perl->Imulti_close;
11187 PL_error_count = proto_perl->Ierror_count;
11188 PL_subline = proto_perl->Isubline;
11189 PL_subname = sv_dup_inc(proto_perl->Isubname, param);
11191 /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11192 if (SvANY(proto_perl->Ilinestr)) {
11193 i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr);
11194 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11195 i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr);
11196 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11197 PL_last_lop_op = proto_perl->Ilast_lop_op;
11200 PL_last_uni = SvPVX(PL_linestr);
11201 PL_last_lop = SvPVX(PL_linestr);
11202 PL_last_lop_op = 0;
11204 PL_in_my = proto_perl->Iin_my;
11205 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
11207 PL_cryptseen = proto_perl->Icryptseen;
11210 PL_hints = proto_perl->Ihints;
11212 PL_amagic_generation = proto_perl->Iamagic_generation;
11214 #ifdef USE_LOCALE_COLLATE
11215 PL_collation_ix = proto_perl->Icollation_ix;
11216 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
11217 PL_collation_standard = proto_perl->Icollation_standard;
11218 PL_collxfrm_base = proto_perl->Icollxfrm_base;
11219 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
11220 #endif /* USE_LOCALE_COLLATE */
11222 #ifdef USE_LOCALE_NUMERIC
11223 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
11224 PL_numeric_standard = proto_perl->Inumeric_standard;
11225 PL_numeric_local = proto_perl->Inumeric_local;
11226 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11227 #endif /* !USE_LOCALE_NUMERIC */
11229 /* utf8 character classes */
11230 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
11231 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11232 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
11233 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
11234 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
11235 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11236 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
11237 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
11238 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
11239 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
11240 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
11241 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
11242 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11243 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
11244 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
11245 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
11246 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
11247 PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
11248 PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
11249 PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
11251 /* Did the locale setup indicate UTF-8? */
11252 PL_utf8locale = proto_perl->Iutf8locale;
11253 /* Unicode features (see perlrun/-C) */
11254 PL_unicode = proto_perl->Iunicode;
11256 /* Pre-5.8 signals control */
11257 PL_signals = proto_perl->Isignals;
11259 /* times() ticks per second */
11260 PL_clocktick = proto_perl->Iclocktick;
11262 /* Recursion stopper for PerlIO_find_layer */
11263 PL_in_load_module = proto_perl->Iin_load_module;
11265 /* sort() routine */
11266 PL_sort_RealCmp = proto_perl->Isort_RealCmp;
11268 /* Not really needed/useful since the reenrant_retint is "volatile",
11269 * but do it for consistency's sake. */
11270 PL_reentrant_retint = proto_perl->Ireentrant_retint;
11272 /* Hooks to shared SVs and locks. */
11273 PL_sharehook = proto_perl->Isharehook;
11274 PL_lockhook = proto_perl->Ilockhook;
11275 PL_unlockhook = proto_perl->Iunlockhook;
11276 PL_threadhook = proto_perl->Ithreadhook;
11278 PL_runops_std = proto_perl->Irunops_std;
11279 PL_runops_dbg = proto_perl->Irunops_dbg;
11281 #ifdef THREADS_HAVE_PIDS
11282 PL_ppid = proto_perl->Ippid;
11286 PL_last_swash_hv = Nullhv; /* reinits on demand */
11287 PL_last_swash_klen = 0;
11288 PL_last_swash_key[0]= '\0';
11289 PL_last_swash_tmps = (U8*)NULL;
11290 PL_last_swash_slen = 0;
11292 PL_glob_index = proto_perl->Iglob_index;
11293 PL_srand_called = proto_perl->Isrand_called;
11294 PL_uudmap['M'] = 0; /* reinits on demand */
11295 PL_bitcount = Nullch; /* reinits on demand */
11297 if (proto_perl->Ipsig_pend) {
11298 Newxz(PL_psig_pend, SIG_SIZE, int);
11301 PL_psig_pend = (int*)NULL;
11304 if (proto_perl->Ipsig_ptr) {
11305 Newxz(PL_psig_ptr, SIG_SIZE, SV*);
11306 Newxz(PL_psig_name, SIG_SIZE, SV*);
11307 for (i = 1; i < SIG_SIZE; i++) {
11308 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11309 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11313 PL_psig_ptr = (SV**)NULL;
11314 PL_psig_name = (SV**)NULL;
11317 /* thrdvar.h stuff */
11319 if (flags & CLONEf_COPY_STACKS) {
11320 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11321 PL_tmps_ix = proto_perl->Ttmps_ix;
11322 PL_tmps_max = proto_perl->Ttmps_max;
11323 PL_tmps_floor = proto_perl->Ttmps_floor;
11324 Newxz(PL_tmps_stack, PL_tmps_max, SV*);
11326 while (i <= PL_tmps_ix) {
11327 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11331 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11332 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11333 Newxz(PL_markstack, i, I32);
11334 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
11335 - proto_perl->Tmarkstack);
11336 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
11337 - proto_perl->Tmarkstack);
11338 Copy(proto_perl->Tmarkstack, PL_markstack,
11339 PL_markstack_ptr - PL_markstack + 1, I32);
11341 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11342 * NOTE: unlike the others! */
11343 PL_scopestack_ix = proto_perl->Tscopestack_ix;
11344 PL_scopestack_max = proto_perl->Tscopestack_max;
11345 Newxz(PL_scopestack, PL_scopestack_max, I32);
11346 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11348 /* NOTE: si_dup() looks at PL_markstack */
11349 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
11351 /* PL_curstack = PL_curstackinfo->si_stack; */
11352 PL_curstack = av_dup(proto_perl->Tcurstack, param);
11353 PL_mainstack = av_dup(proto_perl->Tmainstack, param);
11355 /* next PUSHs() etc. set *(PL_stack_sp+1) */
11356 PL_stack_base = AvARRAY(PL_curstack);
11357 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
11358 - proto_perl->Tstack_base);
11359 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
11361 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11362 * NOTE: unlike the others! */
11363 PL_savestack_ix = proto_perl->Tsavestack_ix;
11364 PL_savestack_max = proto_perl->Tsavestack_max;
11365 /*Newxz(PL_savestack, PL_savestack_max, ANY);*/
11366 PL_savestack = ss_dup(proto_perl, param);
11370 ENTER; /* perl_destruct() wants to LEAVE; */
11373 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
11374 PL_top_env = &PL_start_env;
11376 PL_op = proto_perl->Top;
11379 PL_Xpv = (XPV*)NULL;
11380 PL_na = proto_perl->Tna;
11382 PL_statbuf = proto_perl->Tstatbuf;
11383 PL_statcache = proto_perl->Tstatcache;
11384 PL_statgv = gv_dup(proto_perl->Tstatgv, param);
11385 PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
11387 PL_timesbuf = proto_perl->Ttimesbuf;
11390 PL_tainted = proto_perl->Ttainted;
11391 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
11392 PL_rs = sv_dup_inc(proto_perl->Trs, param);
11393 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
11394 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
11395 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
11396 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
11397 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
11398 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
11399 PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
11401 PL_restartop = proto_perl->Trestartop;
11402 PL_in_eval = proto_perl->Tin_eval;
11403 PL_delaymagic = proto_perl->Tdelaymagic;
11404 PL_dirty = proto_perl->Tdirty;
11405 PL_localizing = proto_perl->Tlocalizing;
11407 PL_errors = sv_dup_inc(proto_perl->Terrors, param);
11408 PL_hv_fetch_ent_mh = Nullhe;
11409 PL_modcount = proto_perl->Tmodcount;
11410 PL_lastgotoprobe = Nullop;
11411 PL_dumpindent = proto_perl->Tdumpindent;
11413 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11414 PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
11415 PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
11416 PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
11417 PL_efloatbuf = Nullch; /* reinits on demand */
11418 PL_efloatsize = 0; /* reinits on demand */
11422 PL_screamfirst = NULL;
11423 PL_screamnext = NULL;
11424 PL_maxscream = -1; /* reinits on demand */
11425 PL_lastscream = Nullsv;
11427 PL_watchaddr = NULL;
11428 PL_watchok = Nullch;
11430 PL_regdummy = proto_perl->Tregdummy;
11431 PL_regprecomp = Nullch;
11434 PL_colorset = 0; /* reinits PL_colors[] */
11435 /*PL_colors[6] = {0,0,0,0,0,0};*/
11436 PL_reginput = Nullch;
11437 PL_regbol = Nullch;
11438 PL_regeol = Nullch;
11439 PL_regstartp = (I32*)NULL;
11440 PL_regendp = (I32*)NULL;
11441 PL_reglastparen = (U32*)NULL;
11442 PL_reglastcloseparen = (U32*)NULL;
11443 PL_regtill = Nullch;
11444 PL_reg_start_tmp = (char**)NULL;
11445 PL_reg_start_tmpl = 0;
11446 PL_regdata = (struct reg_data*)NULL;
11449 PL_reg_eval_set = 0;
11451 PL_regprogram = (regnode*)NULL;
11453 PL_regcc = (CURCUR*)NULL;
11454 PL_reg_call_cc = (struct re_cc_state*)NULL;
11455 PL_reg_re = (regexp*)NULL;
11456 PL_reg_ganch = Nullch;
11457 PL_reg_sv = Nullsv;
11458 PL_reg_match_utf8 = FALSE;
11459 PL_reg_magic = (MAGIC*)NULL;
11461 PL_reg_oldcurpm = (PMOP*)NULL;
11462 PL_reg_curpm = (PMOP*)NULL;
11463 PL_reg_oldsaved = Nullch;
11464 PL_reg_oldsavedlen = 0;
11465 #ifdef PERL_OLD_COPY_ON_WRITE
11468 PL_reg_maxiter = 0;
11469 PL_reg_leftiter = 0;
11470 PL_reg_poscache = Nullch;
11471 PL_reg_poscache_size= 0;
11473 /* RE engine - function pointers */
11474 PL_regcompp = proto_perl->Tregcompp;
11475 PL_regexecp = proto_perl->Tregexecp;
11476 PL_regint_start = proto_perl->Tregint_start;
11477 PL_regint_string = proto_perl->Tregint_string;
11478 PL_regfree = proto_perl->Tregfree;
11480 PL_reginterp_cnt = 0;
11481 PL_reg_starttry = 0;
11483 /* Pluggable optimizer */
11484 PL_peepp = proto_perl->Tpeepp;
11486 PL_stashcache = newHV();
11488 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11489 ptr_table_free(PL_ptr_table);
11490 PL_ptr_table = NULL;
11493 /* Call the ->CLONE method, if it exists, for each of the stashes
11494 identified by sv_dup() above.
11496 while(av_len(param->stashes) != -1) {
11497 HV* const stash = (HV*) av_shift(param->stashes);
11498 GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11499 if (cloner && GvCV(cloner)) {
11504 XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
11506 call_sv((SV*)GvCV(cloner), G_DISCARD);
11512 SvREFCNT_dec(param->stashes);
11514 /* orphaned? eg threads->new inside BEGIN or use */
11515 if (PL_compcv && ! SvREFCNT(PL_compcv)) {
11516 (void)SvREFCNT_inc(PL_compcv);
11517 SAVEFREESV(PL_compcv);
11523 #endif /* USE_ITHREADS */
11526 =head1 Unicode Support
11528 =for apidoc sv_recode_to_utf8
11530 The encoding is assumed to be an Encode object, on entry the PV
11531 of the sv is assumed to be octets in that encoding, and the sv
11532 will be converted into Unicode (and UTF-8).
11534 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11535 is not a reference, nothing is done to the sv. If the encoding is not
11536 an C<Encode::XS> Encoding object, bad things will happen.
11537 (See F<lib/encoding.pm> and L<Encode>).
11539 The PV of the sv is returned.
11544 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11547 if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11561 Passing sv_yes is wrong - it needs to be or'ed set of constants
11562 for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11563 remove converted chars from source.
11565 Both will default the value - let them.
11567 XPUSHs(&PL_sv_yes);
11570 call_method("decode", G_SCALAR);
11574 s = SvPV_const(uni, len);
11575 if (s != SvPVX_const(sv)) {
11576 SvGROW(sv, len + 1);
11577 Move(s, SvPVX(sv), len + 1, char);
11578 SvCUR_set(sv, len);
11585 return SvPOKp(sv) ? SvPVX(sv) : NULL;
11589 =for apidoc sv_cat_decode
11591 The encoding is assumed to be an Encode object, the PV of the ssv is
11592 assumed to be octets in that encoding and decoding the input starts
11593 from the position which (PV + *offset) pointed to. The dsv will be
11594 concatenated the decoded UTF-8 string from ssv. Decoding will terminate
11595 when the string tstr appears in decoding output or the input ends on
11596 the PV of the ssv. The value which the offset points will be modified
11597 to the last input position on the ssv.
11599 Returns TRUE if the terminator was found, else returns FALSE.
11604 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11605 SV *ssv, int *offset, char *tstr, int tlen)
11609 if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11620 XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11621 XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11623 call_method("cat_decode", G_SCALAR);
11625 ret = SvTRUE(TOPs);
11626 *offset = SvIV(offsv);
11632 Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11638 * c-indentation-style: bsd
11639 * c-basic-offset: 4
11640 * indent-tabs-mode: t
11643 * ex: set ts=8 sts=4 sw=4 noet: