xref: /onnv-gate/usr/src/cmd/perl/5.8.4/distrib/sv.c (revision 1277:fbc63bc995ee)
1 /*    sv.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
5  *
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.
8  *
9  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
10  *
11  *
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
17  * in the pp*.c files.
18  */
19 
20 #include "EXTERN.h"
21 #define PERL_IN_SV_C
22 #include "perl.h"
23 #include "regcomp.h"
24 
25 #define FCALL *f
26 
27 #ifdef PERL_UTF8_CACHE_ASSERT
28 /* The cache element 0 is the Unicode offset;
29  * the cache element 1 is the byte offset of the element 0;
30  * the cache element 2 is the Unicode length of the substring;
31  * the cache element 3 is the byte length of the substring;
32  * The checking of the substring side would be good
33  * but substr() has enough code paths to make my head spin;
34  * if adding more checks watch out for the following tests:
35  *   t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
36  *   lib/utf8.t lib/Unicode/Collate/t/index.t
37  * --jhi
38  */
39 #define ASSERT_UTF8_CACHE(cache) \
40 	STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
41 #else
42 #define ASSERT_UTF8_CACHE(cache) NOOP
43 #endif
44 
45 /* ============================================================================
46 
47 =head1 Allocation and deallocation of SVs.
48 
49 An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
50 av, hv...) contains type and reference count information, as well as a
51 pointer to the body (struct xrv, xpv, xpviv...), which contains fields
52 specific to each type.
53 
54 Normally, this allocation is done using arenas, which are approximately
55 1K chunks of memory parcelled up into N heads or bodies. The first slot
56 in each arena is reserved, and is used to hold a link to the next arena.
57 In the case of heads, the unused first slot also contains some flags and
58 a note of the number of slots.  Snaked through each arena chain is a
59 linked list of free items; when this becomes empty, an extra arena is
60 allocated and divided up into N items which are threaded into the free
61 list.
62 
63 The following global variables are associated with arenas:
64 
65     PL_sv_arenaroot	pointer to list of SV arenas
66     PL_sv_root		pointer to list of free SV structures
67 
68     PL_foo_arenaroot	pointer to list of foo arenas,
69     PL_foo_root		pointer to list of free foo bodies
70 			    ... for foo in xiv, xnv, xrv, xpv etc.
71 
72 Note that some of the larger and more rarely used body types (eg xpvio)
73 are not allocated using arenas, but are instead just malloc()/free()ed as
74 required. Also, if PURIFY is defined, arenas are abandoned altogether,
75 with all items individually malloc()ed. In addition, a few SV heads are
76 not allocated from an arena, but are instead directly created as static
77 or auto variables, eg PL_sv_undef.
78 
79 The SV arena serves the secondary purpose of allowing still-live SVs
80 to be located and destroyed during final cleanup.
81 
82 At the lowest level, the macros new_SV() and del_SV() grab and free
83 an SV head.  (If debugging with -DD, del_SV() calls the function S_del_sv()
84 to return the SV to the free list with error checking.) new_SV() calls
85 more_sv() / sv_add_arena() to add an extra arena if the free list is empty.
86 SVs in the free list have their SvTYPE field set to all ones.
87 
88 Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
89 that allocate and return individual body types. Normally these are mapped
90 to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
91 instead mapped directly to malloc()/free() if PURIFY is defined. The
92 new/del functions remove from, or add to, the appropriate PL_foo_root
93 list, and call more_xiv() etc to add a new arena if the list is empty.
94 
95 At the time of very final cleanup, sv_free_arenas() is called from
96 perl_destruct() to physically free all the arenas allocated since the
97 start of the interpreter.  Note that this also clears PL_he_arenaroot,
98 which is otherwise dealt with in hv.c.
99 
100 Manipulation of any of the PL_*root pointers is protected by enclosing
101 LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing
102 if threads are enabled.
103 
104 The function visit() scans the SV arenas list, and calls a specified
105 function for each SV it finds which is still live - ie which has an SvTYPE
106 other than all 1's, and a non-zero SvREFCNT. visit() is used by the
107 following functions (specified as [function that calls visit()] / [function
108 called by visit() for each SV]):
109 
110     sv_report_used() / do_report_used()
111     			dump all remaining SVs (debugging aid)
112 
113     sv_clean_objs() / do_clean_objs(),do_clean_named_objs()
114 			Attempt to free all objects pointed to by RVs,
115 			and, unless DISABLE_DESTRUCTOR_KLUDGE is defined,
116 			try to do the same for all objects indirectly
117 			referenced by typeglobs too.  Called once from
118 			perl_destruct(), prior to calling sv_clean_all()
119 			below.
120 
121     sv_clean_all() / do_clean_all()
122 			SvREFCNT_dec(sv) each remaining SV, possibly
123 			triggering an sv_free(). It also sets the
124 			SVf_BREAK flag on the SV to indicate that the
125 			refcnt has been artificially lowered, and thus
126 			stopping sv_free() from giving spurious warnings
127 			about SVs which unexpectedly have a refcnt
128 			of zero.  called repeatedly from perl_destruct()
129 			until there are no SVs left.
130 
131 =head2 Summary
132 
133 Private API to rest of sv.c
134 
135     new_SV(),  del_SV(),
136 
137     new_XIV(), del_XIV(),
138     new_XNV(), del_XNV(),
139     etc
140 
141 Public API:
142 
143     sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
144 
145 
146 =cut
147 
148 ============================================================================ */
149 
150 
151 
152 /*
153  * "A time to plant, and a time to uproot what was planted..."
154  */
155 
156 #define plant_SV(p) \
157     STMT_START {					\
158 	SvANY(p) = (void *)PL_sv_root;			\
159 	SvFLAGS(p) = SVTYPEMASK;			\
160 	PL_sv_root = (p);				\
161 	--PL_sv_count;					\
162     } STMT_END
163 
164 /* sv_mutex must be held while calling uproot_SV() */
165 #define uproot_SV(p) \
166     STMT_START {					\
167 	(p) = PL_sv_root;				\
168 	PL_sv_root = (SV*)SvANY(p);			\
169 	++PL_sv_count;					\
170     } STMT_END
171 
172 
173 /* new_SV(): return a new, empty SV head */
174 
175 #ifdef DEBUG_LEAKING_SCALARS
176 /* provide a real function for a debugger to play with */
177 STATIC SV*
S_new_SV(pTHX)178 S_new_SV(pTHX)
179 {
180     SV* sv;
181 
182     LOCK_SV_MUTEX;
183     if (PL_sv_root)
184 	uproot_SV(sv);
185     else
186 	sv = more_sv();
187     UNLOCK_SV_MUTEX;
188     SvANY(sv) = 0;
189     SvREFCNT(sv) = 1;
190     SvFLAGS(sv) = 0;
191     return sv;
192 }
193 #  define new_SV(p) (p)=S_new_SV(aTHX)
194 
195 #else
196 #  define new_SV(p) \
197     STMT_START {					\
198 	LOCK_SV_MUTEX;					\
199 	if (PL_sv_root)					\
200 	    uproot_SV(p);				\
201 	else						\
202 	    (p) = more_sv();				\
203 	UNLOCK_SV_MUTEX;				\
204 	SvANY(p) = 0;					\
205 	SvREFCNT(p) = 1;				\
206 	SvFLAGS(p) = 0;					\
207     } STMT_END
208 #endif
209 
210 
211 /* del_SV(): return an empty SV head to the free list */
212 
213 #ifdef DEBUGGING
214 
215 #define del_SV(p) \
216     STMT_START {					\
217 	LOCK_SV_MUTEX;					\
218 	if (DEBUG_D_TEST)				\
219 	    del_sv(p);					\
220 	else						\
221 	    plant_SV(p);				\
222 	UNLOCK_SV_MUTEX;				\
223     } STMT_END
224 
225 STATIC void
S_del_sv(pTHX_ SV * p)226 S_del_sv(pTHX_ SV *p)
227 {
228     if (DEBUG_D_TEST) {
229 	SV* sva;
230 	SV* sv;
231 	SV* svend;
232 	int ok = 0;
233 	for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
234 	    sv = sva + 1;
235 	    svend = &sva[SvREFCNT(sva)];
236 	    if (p >= sv && p < svend)
237 		ok = 1;
238 	}
239 	if (!ok) {
240 	    if (ckWARN_d(WARN_INTERNAL))
241 	        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
242 			    "Attempt to free non-arena SV: 0x%"UVxf,
243 			    PTR2UV(p));
244 	    return;
245 	}
246     }
247     plant_SV(p);
248 }
249 
250 #else /* ! DEBUGGING */
251 
252 #define del_SV(p)   plant_SV(p)
253 
254 #endif /* DEBUGGING */
255 
256 
257 /*
258 =head1 SV Manipulation Functions
259 
260 =for apidoc sv_add_arena
261 
262 Given a chunk of memory, link it to the head of the list of arenas,
263 and split it into a list of free SVs.
264 
265 =cut
266 */
267 
268 void
Perl_sv_add_arena(pTHX_ char * ptr,U32 size,U32 flags)269 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
270 {
271     SV* sva = (SV*)ptr;
272     register SV* sv;
273     register SV* svend;
274     Zero(ptr, size, char);
275 
276     /* The first SV in an arena isn't an SV. */
277     SvANY(sva) = (void *) PL_sv_arenaroot;		/* ptr to next arena */
278     SvREFCNT(sva) = size / sizeof(SV);		/* number of SV slots */
279     SvFLAGS(sva) = flags;			/* FAKE if not to be freed */
280 
281     PL_sv_arenaroot = sva;
282     PL_sv_root = sva + 1;
283 
284     svend = &sva[SvREFCNT(sva) - 1];
285     sv = sva + 1;
286     while (sv < svend) {
287 	SvANY(sv) = (void *)(SV*)(sv + 1);
288 	SvFLAGS(sv) = SVTYPEMASK;
289 	sv++;
290     }
291     SvANY(sv) = 0;
292     SvFLAGS(sv) = SVTYPEMASK;
293 }
294 
295 /* make some more SVs by adding another arena */
296 
297 /* sv_mutex must be held while calling more_sv() */
298 STATIC SV*
S_more_sv(pTHX)299 S_more_sv(pTHX)
300 {
301     register SV* sv;
302 
303     if (PL_nice_chunk) {
304 	sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
305 	PL_nice_chunk = Nullch;
306         PL_nice_chunk_size = 0;
307     }
308     else {
309 	char *chunk;                /* must use New here to match call to */
310 	New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
311 	sv_add_arena(chunk, 1008, 0);
312     }
313     uproot_SV(sv);
314     return sv;
315 }
316 
317 /* visit(): call the named function for each non-free SV in the arenas. */
318 
319 STATIC I32
S_visit(pTHX_ SVFUNC_t f)320 S_visit(pTHX_ SVFUNC_t f)
321 {
322     SV* sva;
323     SV* sv;
324     register SV* svend;
325     I32 visited = 0;
326 
327     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
328 	svend = &sva[SvREFCNT(sva)];
329 	for (sv = sva + 1; sv < svend; ++sv) {
330 	    if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
331 		(FCALL)(aTHX_ sv);
332 		++visited;
333 	    }
334 	}
335     }
336     return visited;
337 }
338 
339 #ifdef DEBUGGING
340 
341 /* called by sv_report_used() for each live SV */
342 
343 static void
do_report_used(pTHX_ SV * sv)344 do_report_used(pTHX_ SV *sv)
345 {
346     if (SvTYPE(sv) != SVTYPEMASK) {
347 	PerlIO_printf(Perl_debug_log, "****\n");
348 	sv_dump(sv);
349     }
350 }
351 #endif
352 
353 /*
354 =for apidoc sv_report_used
355 
356 Dump the contents of all SVs not yet freed. (Debugging aid).
357 
358 =cut
359 */
360 
361 void
Perl_sv_report_used(pTHX)362 Perl_sv_report_used(pTHX)
363 {
364 #ifdef DEBUGGING
365     visit(do_report_used);
366 #endif
367 }
368 
369 /* called by sv_clean_objs() for each live SV */
370 
371 static void
do_clean_objs(pTHX_ SV * sv)372 do_clean_objs(pTHX_ SV *sv)
373 {
374     SV* rv;
375 
376     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
377 	DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
378 	if (SvWEAKREF(sv)) {
379 	    sv_del_backref(sv);
380 	    SvWEAKREF_off(sv);
381 	    SvRV(sv) = 0;
382 	} else {
383 	    SvROK_off(sv);
384 	    SvRV(sv) = 0;
385 	    SvREFCNT_dec(rv);
386 	}
387     }
388 
389     /* XXX Might want to check arrays, etc. */
390 }
391 
392 /* called by sv_clean_objs() for each live SV */
393 
394 #ifndef DISABLE_DESTRUCTOR_KLUDGE
395 static void
do_clean_named_objs(pTHX_ SV * sv)396 do_clean_named_objs(pTHX_ SV *sv)
397 {
398     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
399 	if ( SvOBJECT(GvSV(sv)) ||
400 	     (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
401 	     (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
402 	     (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
403 	     (GvCV(sv) && SvOBJECT(GvCV(sv))) )
404 	{
405 	    DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
406 	    SvFLAGS(sv) |= SVf_BREAK;
407 	    SvREFCNT_dec(sv);
408 	}
409     }
410 }
411 #endif
412 
413 /*
414 =for apidoc sv_clean_objs
415 
416 Attempt to destroy all objects not yet freed
417 
418 =cut
419 */
420 
421 void
Perl_sv_clean_objs(pTHX)422 Perl_sv_clean_objs(pTHX)
423 {
424     PL_in_clean_objs = TRUE;
425     visit(do_clean_objs);
426 #ifndef DISABLE_DESTRUCTOR_KLUDGE
427     /* some barnacles may yet remain, clinging to typeglobs */
428     visit(do_clean_named_objs);
429 #endif
430     PL_in_clean_objs = FALSE;
431 }
432 
433 /* called by sv_clean_all() for each live SV */
434 
435 static void
do_clean_all(pTHX_ SV * sv)436 do_clean_all(pTHX_ SV *sv)
437 {
438     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
439     SvFLAGS(sv) |= SVf_BREAK;
440     SvREFCNT_dec(sv);
441 }
442 
443 /*
444 =for apidoc sv_clean_all
445 
446 Decrement the refcnt of each remaining SV, possibly triggering a
447 cleanup. This function may have to be called multiple times to free
448 SVs which are in complex self-referential hierarchies.
449 
450 =cut
451 */
452 
453 I32
Perl_sv_clean_all(pTHX)454 Perl_sv_clean_all(pTHX)
455 {
456     I32 cleaned;
457     PL_in_clean_all = TRUE;
458     cleaned = visit(do_clean_all);
459     PL_in_clean_all = FALSE;
460     return cleaned;
461 }
462 
463 /*
464 =for apidoc sv_free_arenas
465 
466 Deallocate the memory used by all arenas. Note that all the individual SV
467 heads and bodies within the arenas must already have been freed.
468 
469 =cut
470 */
471 
472 void
Perl_sv_free_arenas(pTHX)473 Perl_sv_free_arenas(pTHX)
474 {
475     SV* sva;
476     SV* svanext;
477     XPV *arena, *arenanext;
478 
479     /* Free arenas here, but be careful about fake ones.  (We assume
480        contiguity of the fake ones with the corresponding real ones.) */
481 
482     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
483 	svanext = (SV*) SvANY(sva);
484 	while (svanext && SvFAKE(svanext))
485 	    svanext = (SV*) SvANY(svanext);
486 
487 	if (!SvFAKE(sva))
488 	    Safefree((void *)sva);
489     }
490 
491     for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
492 	arenanext = (XPV*)arena->xpv_pv;
493 	Safefree(arena);
494     }
495     PL_xiv_arenaroot = 0;
496     PL_xiv_root = 0;
497 
498     for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
499 	arenanext = (XPV*)arena->xpv_pv;
500 	Safefree(arena);
501     }
502     PL_xnv_arenaroot = 0;
503     PL_xnv_root = 0;
504 
505     for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
506 	arenanext = (XPV*)arena->xpv_pv;
507 	Safefree(arena);
508     }
509     PL_xrv_arenaroot = 0;
510     PL_xrv_root = 0;
511 
512     for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
513 	arenanext = (XPV*)arena->xpv_pv;
514 	Safefree(arena);
515     }
516     PL_xpv_arenaroot = 0;
517     PL_xpv_root = 0;
518 
519     for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
520 	arenanext = (XPV*)arena->xpv_pv;
521 	Safefree(arena);
522     }
523     PL_xpviv_arenaroot = 0;
524     PL_xpviv_root = 0;
525 
526     for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
527 	arenanext = (XPV*)arena->xpv_pv;
528 	Safefree(arena);
529     }
530     PL_xpvnv_arenaroot = 0;
531     PL_xpvnv_root = 0;
532 
533     for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
534 	arenanext = (XPV*)arena->xpv_pv;
535 	Safefree(arena);
536     }
537     PL_xpvcv_arenaroot = 0;
538     PL_xpvcv_root = 0;
539 
540     for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
541 	arenanext = (XPV*)arena->xpv_pv;
542 	Safefree(arena);
543     }
544     PL_xpvav_arenaroot = 0;
545     PL_xpvav_root = 0;
546 
547     for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
548 	arenanext = (XPV*)arena->xpv_pv;
549 	Safefree(arena);
550     }
551     PL_xpvhv_arenaroot = 0;
552     PL_xpvhv_root = 0;
553 
554     for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
555 	arenanext = (XPV*)arena->xpv_pv;
556 	Safefree(arena);
557     }
558     PL_xpvmg_arenaroot = 0;
559     PL_xpvmg_root = 0;
560 
561     for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
562 	arenanext = (XPV*)arena->xpv_pv;
563 	Safefree(arena);
564     }
565     PL_xpvlv_arenaroot = 0;
566     PL_xpvlv_root = 0;
567 
568     for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
569 	arenanext = (XPV*)arena->xpv_pv;
570 	Safefree(arena);
571     }
572     PL_xpvbm_arenaroot = 0;
573     PL_xpvbm_root = 0;
574 
575     for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
576 	arenanext = (XPV*)arena->xpv_pv;
577 	Safefree(arena);
578     }
579     PL_he_arenaroot = 0;
580     PL_he_root = 0;
581 
582     if (PL_nice_chunk)
583 	Safefree(PL_nice_chunk);
584     PL_nice_chunk = Nullch;
585     PL_nice_chunk_size = 0;
586     PL_sv_arenaroot = 0;
587     PL_sv_root = 0;
588 }
589 
590 /*
591 =for apidoc report_uninit
592 
593 Print appropriate "Use of uninitialized variable" warning
594 
595 =cut
596 */
597 
598 void
Perl_report_uninit(pTHX)599 Perl_report_uninit(pTHX)
600 {
601     if (PL_op)
602 	Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
603 		    " in ", OP_DESC(PL_op));
604     else
605 	Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
606 }
607 
608 /* grab a new IV body from the free list, allocating more if necessary */
609 
610 STATIC XPVIV*
S_new_xiv(pTHX)611 S_new_xiv(pTHX)
612 {
613     IV* xiv;
614     LOCK_SV_MUTEX;
615     if (!PL_xiv_root)
616 	more_xiv();
617     xiv = PL_xiv_root;
618     /*
619      * See comment in more_xiv() -- RAM.
620      */
621     PL_xiv_root = *(IV**)xiv;
622     UNLOCK_SV_MUTEX;
623     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
624 }
625 
626 /* return an IV body to the free list */
627 
628 STATIC void
S_del_xiv(pTHX_ XPVIV * p)629 S_del_xiv(pTHX_ XPVIV *p)
630 {
631     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
632     LOCK_SV_MUTEX;
633     *(IV**)xiv = PL_xiv_root;
634     PL_xiv_root = xiv;
635     UNLOCK_SV_MUTEX;
636 }
637 
638 /* allocate another arena's worth of IV bodies */
639 
640 STATIC void
S_more_xiv(pTHX)641 S_more_xiv(pTHX)
642 {
643     register IV* xiv;
644     register IV* xivend;
645     XPV* ptr;
646     New(705, ptr, 1008/sizeof(XPV), XPV);
647     ptr->xpv_pv = (char*)PL_xiv_arenaroot;	/* linked list of xiv arenas */
648     PL_xiv_arenaroot = ptr;			/* to keep Purify happy */
649 
650     xiv = (IV*) ptr;
651     xivend = &xiv[1008 / sizeof(IV) - 1];
652     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;	/* fudge by size of XPV */
653     PL_xiv_root = xiv;
654     while (xiv < xivend) {
655 	*(IV**)xiv = (IV *)(xiv + 1);
656 	xiv++;
657     }
658     *(IV**)xiv = 0;
659 }
660 
661 /* grab a new NV body from the free list, allocating more if necessary */
662 
663 STATIC XPVNV*
S_new_xnv(pTHX)664 S_new_xnv(pTHX)
665 {
666     NV* xnv;
667     LOCK_SV_MUTEX;
668     if (!PL_xnv_root)
669 	more_xnv();
670     xnv = PL_xnv_root;
671     PL_xnv_root = *(NV**)xnv;
672     UNLOCK_SV_MUTEX;
673     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
674 }
675 
676 /* return an NV body to the free list */
677 
678 STATIC void
S_del_xnv(pTHX_ XPVNV * p)679 S_del_xnv(pTHX_ XPVNV *p)
680 {
681     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
682     LOCK_SV_MUTEX;
683     *(NV**)xnv = PL_xnv_root;
684     PL_xnv_root = xnv;
685     UNLOCK_SV_MUTEX;
686 }
687 
688 /* allocate another arena's worth of NV bodies */
689 
690 STATIC void
S_more_xnv(pTHX)691 S_more_xnv(pTHX)
692 {
693     register NV* xnv;
694     register NV* xnvend;
695     XPV *ptr;
696     New(711, ptr, 1008/sizeof(XPV), XPV);
697     ptr->xpv_pv = (char*)PL_xnv_arenaroot;
698     PL_xnv_arenaroot = ptr;
699 
700     xnv = (NV*) ptr;
701     xnvend = &xnv[1008 / sizeof(NV) - 1];
702     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
703     PL_xnv_root = xnv;
704     while (xnv < xnvend) {
705 	*(NV**)xnv = (NV*)(xnv + 1);
706 	xnv++;
707     }
708     *(NV**)xnv = 0;
709 }
710 
711 /* grab a new struct xrv from the free list, allocating more if necessary */
712 
713 STATIC XRV*
S_new_xrv(pTHX)714 S_new_xrv(pTHX)
715 {
716     XRV* xrv;
717     LOCK_SV_MUTEX;
718     if (!PL_xrv_root)
719 	more_xrv();
720     xrv = PL_xrv_root;
721     PL_xrv_root = (XRV*)xrv->xrv_rv;
722     UNLOCK_SV_MUTEX;
723     return xrv;
724 }
725 
726 /* return a struct xrv to the free list */
727 
728 STATIC void
S_del_xrv(pTHX_ XRV * p)729 S_del_xrv(pTHX_ XRV *p)
730 {
731     LOCK_SV_MUTEX;
732     p->xrv_rv = (SV*)PL_xrv_root;
733     PL_xrv_root = p;
734     UNLOCK_SV_MUTEX;
735 }
736 
737 /* allocate another arena's worth of struct xrv */
738 
739 STATIC void
S_more_xrv(pTHX)740 S_more_xrv(pTHX)
741 {
742     register XRV* xrv;
743     register XRV* xrvend;
744     XPV *ptr;
745     New(712, ptr, 1008/sizeof(XPV), XPV);
746     ptr->xpv_pv = (char*)PL_xrv_arenaroot;
747     PL_xrv_arenaroot = ptr;
748 
749     xrv = (XRV*) ptr;
750     xrvend = &xrv[1008 / sizeof(XRV) - 1];
751     xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
752     PL_xrv_root = xrv;
753     while (xrv < xrvend) {
754 	xrv->xrv_rv = (SV*)(xrv + 1);
755 	xrv++;
756     }
757     xrv->xrv_rv = 0;
758 }
759 
760 /* grab a new struct xpv from the free list, allocating more if necessary */
761 
762 STATIC XPV*
S_new_xpv(pTHX)763 S_new_xpv(pTHX)
764 {
765     XPV* xpv;
766     LOCK_SV_MUTEX;
767     if (!PL_xpv_root)
768 	more_xpv();
769     xpv = PL_xpv_root;
770     PL_xpv_root = (XPV*)xpv->xpv_pv;
771     UNLOCK_SV_MUTEX;
772     return xpv;
773 }
774 
775 /* return a struct xpv to the free list */
776 
777 STATIC void
S_del_xpv(pTHX_ XPV * p)778 S_del_xpv(pTHX_ XPV *p)
779 {
780     LOCK_SV_MUTEX;
781     p->xpv_pv = (char*)PL_xpv_root;
782     PL_xpv_root = p;
783     UNLOCK_SV_MUTEX;
784 }
785 
786 /* allocate another arena's worth of struct xpv */
787 
788 STATIC void
S_more_xpv(pTHX)789 S_more_xpv(pTHX)
790 {
791     register XPV* xpv;
792     register XPV* xpvend;
793     New(713, xpv, 1008/sizeof(XPV), XPV);
794     xpv->xpv_pv = (char*)PL_xpv_arenaroot;
795     PL_xpv_arenaroot = xpv;
796 
797     xpvend = &xpv[1008 / sizeof(XPV) - 1];
798     PL_xpv_root = ++xpv;
799     while (xpv < xpvend) {
800 	xpv->xpv_pv = (char*)(xpv + 1);
801 	xpv++;
802     }
803     xpv->xpv_pv = 0;
804 }
805 
806 /* grab a new struct xpviv from the free list, allocating more if necessary */
807 
808 STATIC XPVIV*
S_new_xpviv(pTHX)809 S_new_xpviv(pTHX)
810 {
811     XPVIV* xpviv;
812     LOCK_SV_MUTEX;
813     if (!PL_xpviv_root)
814 	more_xpviv();
815     xpviv = PL_xpviv_root;
816     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
817     UNLOCK_SV_MUTEX;
818     return xpviv;
819 }
820 
821 /* return a struct xpviv to the free list */
822 
823 STATIC void
S_del_xpviv(pTHX_ XPVIV * p)824 S_del_xpviv(pTHX_ XPVIV *p)
825 {
826     LOCK_SV_MUTEX;
827     p->xpv_pv = (char*)PL_xpviv_root;
828     PL_xpviv_root = p;
829     UNLOCK_SV_MUTEX;
830 }
831 
832 /* allocate another arena's worth of struct xpviv */
833 
834 STATIC void
S_more_xpviv(pTHX)835 S_more_xpviv(pTHX)
836 {
837     register XPVIV* xpviv;
838     register XPVIV* xpvivend;
839     New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
840     xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
841     PL_xpviv_arenaroot = xpviv;
842 
843     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
844     PL_xpviv_root = ++xpviv;
845     while (xpviv < xpvivend) {
846 	xpviv->xpv_pv = (char*)(xpviv + 1);
847 	xpviv++;
848     }
849     xpviv->xpv_pv = 0;
850 }
851 
852 /* grab a new struct xpvnv from the free list, allocating more if necessary */
853 
854 STATIC XPVNV*
S_new_xpvnv(pTHX)855 S_new_xpvnv(pTHX)
856 {
857     XPVNV* xpvnv;
858     LOCK_SV_MUTEX;
859     if (!PL_xpvnv_root)
860 	more_xpvnv();
861     xpvnv = PL_xpvnv_root;
862     PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
863     UNLOCK_SV_MUTEX;
864     return xpvnv;
865 }
866 
867 /* return a struct xpvnv to the free list */
868 
869 STATIC void
S_del_xpvnv(pTHX_ XPVNV * p)870 S_del_xpvnv(pTHX_ XPVNV *p)
871 {
872     LOCK_SV_MUTEX;
873     p->xpv_pv = (char*)PL_xpvnv_root;
874     PL_xpvnv_root = p;
875     UNLOCK_SV_MUTEX;
876 }
877 
878 /* allocate another arena's worth of struct xpvnv */
879 
880 STATIC void
S_more_xpvnv(pTHX)881 S_more_xpvnv(pTHX)
882 {
883     register XPVNV* xpvnv;
884     register XPVNV* xpvnvend;
885     New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
886     xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
887     PL_xpvnv_arenaroot = xpvnv;
888 
889     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
890     PL_xpvnv_root = ++xpvnv;
891     while (xpvnv < xpvnvend) {
892 	xpvnv->xpv_pv = (char*)(xpvnv + 1);
893 	xpvnv++;
894     }
895     xpvnv->xpv_pv = 0;
896 }
897 
898 /* grab a new struct xpvcv from the free list, allocating more if necessary */
899 
900 STATIC XPVCV*
S_new_xpvcv(pTHX)901 S_new_xpvcv(pTHX)
902 {
903     XPVCV* xpvcv;
904     LOCK_SV_MUTEX;
905     if (!PL_xpvcv_root)
906 	more_xpvcv();
907     xpvcv = PL_xpvcv_root;
908     PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
909     UNLOCK_SV_MUTEX;
910     return xpvcv;
911 }
912 
913 /* return a struct xpvcv to the free list */
914 
915 STATIC void
S_del_xpvcv(pTHX_ XPVCV * p)916 S_del_xpvcv(pTHX_ XPVCV *p)
917 {
918     LOCK_SV_MUTEX;
919     p->xpv_pv = (char*)PL_xpvcv_root;
920     PL_xpvcv_root = p;
921     UNLOCK_SV_MUTEX;
922 }
923 
924 /* allocate another arena's worth of struct xpvcv */
925 
926 STATIC void
S_more_xpvcv(pTHX)927 S_more_xpvcv(pTHX)
928 {
929     register XPVCV* xpvcv;
930     register XPVCV* xpvcvend;
931     New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
932     xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
933     PL_xpvcv_arenaroot = xpvcv;
934 
935     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
936     PL_xpvcv_root = ++xpvcv;
937     while (xpvcv < xpvcvend) {
938 	xpvcv->xpv_pv = (char*)(xpvcv + 1);
939 	xpvcv++;
940     }
941     xpvcv->xpv_pv = 0;
942 }
943 
944 /* grab a new struct xpvav from the free list, allocating more if necessary */
945 
946 STATIC XPVAV*
S_new_xpvav(pTHX)947 S_new_xpvav(pTHX)
948 {
949     XPVAV* xpvav;
950     LOCK_SV_MUTEX;
951     if (!PL_xpvav_root)
952 	more_xpvav();
953     xpvav = PL_xpvav_root;
954     PL_xpvav_root = (XPVAV*)xpvav->xav_array;
955     UNLOCK_SV_MUTEX;
956     return xpvav;
957 }
958 
959 /* return a struct xpvav to the free list */
960 
961 STATIC void
S_del_xpvav(pTHX_ XPVAV * p)962 S_del_xpvav(pTHX_ XPVAV *p)
963 {
964     LOCK_SV_MUTEX;
965     p->xav_array = (char*)PL_xpvav_root;
966     PL_xpvav_root = p;
967     UNLOCK_SV_MUTEX;
968 }
969 
970 /* allocate another arena's worth of struct xpvav */
971 
972 STATIC void
S_more_xpvav(pTHX)973 S_more_xpvav(pTHX)
974 {
975     register XPVAV* xpvav;
976     register XPVAV* xpvavend;
977     New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
978     xpvav->xav_array = (char*)PL_xpvav_arenaroot;
979     PL_xpvav_arenaroot = xpvav;
980 
981     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
982     PL_xpvav_root = ++xpvav;
983     while (xpvav < xpvavend) {
984 	xpvav->xav_array = (char*)(xpvav + 1);
985 	xpvav++;
986     }
987     xpvav->xav_array = 0;
988 }
989 
990 /* grab a new struct xpvhv from the free list, allocating more if necessary */
991 
992 STATIC XPVHV*
S_new_xpvhv(pTHX)993 S_new_xpvhv(pTHX)
994 {
995     XPVHV* xpvhv;
996     LOCK_SV_MUTEX;
997     if (!PL_xpvhv_root)
998 	more_xpvhv();
999     xpvhv = PL_xpvhv_root;
1000     PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
1001     UNLOCK_SV_MUTEX;
1002     return xpvhv;
1003 }
1004 
1005 /* return a struct xpvhv to the free list */
1006 
1007 STATIC void
S_del_xpvhv(pTHX_ XPVHV * p)1008 S_del_xpvhv(pTHX_ XPVHV *p)
1009 {
1010     LOCK_SV_MUTEX;
1011     p->xhv_array = (char*)PL_xpvhv_root;
1012     PL_xpvhv_root = p;
1013     UNLOCK_SV_MUTEX;
1014 }
1015 
1016 /* allocate another arena's worth of struct xpvhv */
1017 
1018 STATIC void
S_more_xpvhv(pTHX)1019 S_more_xpvhv(pTHX)
1020 {
1021     register XPVHV* xpvhv;
1022     register XPVHV* xpvhvend;
1023     New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
1024     xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
1025     PL_xpvhv_arenaroot = xpvhv;
1026 
1027     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
1028     PL_xpvhv_root = ++xpvhv;
1029     while (xpvhv < xpvhvend) {
1030 	xpvhv->xhv_array = (char*)(xpvhv + 1);
1031 	xpvhv++;
1032     }
1033     xpvhv->xhv_array = 0;
1034 }
1035 
1036 /* grab a new struct xpvmg from the free list, allocating more if necessary */
1037 
1038 STATIC XPVMG*
S_new_xpvmg(pTHX)1039 S_new_xpvmg(pTHX)
1040 {
1041     XPVMG* xpvmg;
1042     LOCK_SV_MUTEX;
1043     if (!PL_xpvmg_root)
1044 	more_xpvmg();
1045     xpvmg = PL_xpvmg_root;
1046     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
1047     UNLOCK_SV_MUTEX;
1048     return xpvmg;
1049 }
1050 
1051 /* return a struct xpvmg to the free list */
1052 
1053 STATIC void
S_del_xpvmg(pTHX_ XPVMG * p)1054 S_del_xpvmg(pTHX_ XPVMG *p)
1055 {
1056     LOCK_SV_MUTEX;
1057     p->xpv_pv = (char*)PL_xpvmg_root;
1058     PL_xpvmg_root = p;
1059     UNLOCK_SV_MUTEX;
1060 }
1061 
1062 /* allocate another arena's worth of struct xpvmg */
1063 
1064 STATIC void
S_more_xpvmg(pTHX)1065 S_more_xpvmg(pTHX)
1066 {
1067     register XPVMG* xpvmg;
1068     register XPVMG* xpvmgend;
1069     New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
1070     xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
1071     PL_xpvmg_arenaroot = xpvmg;
1072 
1073     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
1074     PL_xpvmg_root = ++xpvmg;
1075     while (xpvmg < xpvmgend) {
1076 	xpvmg->xpv_pv = (char*)(xpvmg + 1);
1077 	xpvmg++;
1078     }
1079     xpvmg->xpv_pv = 0;
1080 }
1081 
1082 /* grab a new struct xpvlv from the free list, allocating more if necessary */
1083 
1084 STATIC XPVLV*
S_new_xpvlv(pTHX)1085 S_new_xpvlv(pTHX)
1086 {
1087     XPVLV* xpvlv;
1088     LOCK_SV_MUTEX;
1089     if (!PL_xpvlv_root)
1090 	more_xpvlv();
1091     xpvlv = PL_xpvlv_root;
1092     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
1093     UNLOCK_SV_MUTEX;
1094     return xpvlv;
1095 }
1096 
1097 /* return a struct xpvlv to the free list */
1098 
1099 STATIC void
S_del_xpvlv(pTHX_ XPVLV * p)1100 S_del_xpvlv(pTHX_ XPVLV *p)
1101 {
1102     LOCK_SV_MUTEX;
1103     p->xpv_pv = (char*)PL_xpvlv_root;
1104     PL_xpvlv_root = p;
1105     UNLOCK_SV_MUTEX;
1106 }
1107 
1108 /* allocate another arena's worth of struct xpvlv */
1109 
1110 STATIC void
S_more_xpvlv(pTHX)1111 S_more_xpvlv(pTHX)
1112 {
1113     register XPVLV* xpvlv;
1114     register XPVLV* xpvlvend;
1115     New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
1116     xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
1117     PL_xpvlv_arenaroot = xpvlv;
1118 
1119     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
1120     PL_xpvlv_root = ++xpvlv;
1121     while (xpvlv < xpvlvend) {
1122 	xpvlv->xpv_pv = (char*)(xpvlv + 1);
1123 	xpvlv++;
1124     }
1125     xpvlv->xpv_pv = 0;
1126 }
1127 
1128 /* grab a new struct xpvbm from the free list, allocating more if necessary */
1129 
1130 STATIC XPVBM*
S_new_xpvbm(pTHX)1131 S_new_xpvbm(pTHX)
1132 {
1133     XPVBM* xpvbm;
1134     LOCK_SV_MUTEX;
1135     if (!PL_xpvbm_root)
1136 	more_xpvbm();
1137     xpvbm = PL_xpvbm_root;
1138     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
1139     UNLOCK_SV_MUTEX;
1140     return xpvbm;
1141 }
1142 
1143 /* return a struct xpvbm to the free list */
1144 
1145 STATIC void
S_del_xpvbm(pTHX_ XPVBM * p)1146 S_del_xpvbm(pTHX_ XPVBM *p)
1147 {
1148     LOCK_SV_MUTEX;
1149     p->xpv_pv = (char*)PL_xpvbm_root;
1150     PL_xpvbm_root = p;
1151     UNLOCK_SV_MUTEX;
1152 }
1153 
1154 /* allocate another arena's worth of struct xpvbm */
1155 
1156 STATIC void
S_more_xpvbm(pTHX)1157 S_more_xpvbm(pTHX)
1158 {
1159     register XPVBM* xpvbm;
1160     register XPVBM* xpvbmend;
1161     New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
1162     xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
1163     PL_xpvbm_arenaroot = xpvbm;
1164 
1165     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
1166     PL_xpvbm_root = ++xpvbm;
1167     while (xpvbm < xpvbmend) {
1168 	xpvbm->xpv_pv = (char*)(xpvbm + 1);
1169 	xpvbm++;
1170     }
1171     xpvbm->xpv_pv = 0;
1172 }
1173 
1174 #define my_safemalloc(s)	(void*)safemalloc(s)
1175 #define my_safefree(p)	safefree((char*)p)
1176 
1177 #ifdef PURIFY
1178 
1179 #define new_XIV()	my_safemalloc(sizeof(XPVIV))
1180 #define del_XIV(p)	my_safefree(p)
1181 
1182 #define new_XNV()	my_safemalloc(sizeof(XPVNV))
1183 #define del_XNV(p)	my_safefree(p)
1184 
1185 #define new_XRV()	my_safemalloc(sizeof(XRV))
1186 #define del_XRV(p)	my_safefree(p)
1187 
1188 #define new_XPV()	my_safemalloc(sizeof(XPV))
1189 #define del_XPV(p)	my_safefree(p)
1190 
1191 #define new_XPVIV()	my_safemalloc(sizeof(XPVIV))
1192 #define del_XPVIV(p)	my_safefree(p)
1193 
1194 #define new_XPVNV()	my_safemalloc(sizeof(XPVNV))
1195 #define del_XPVNV(p)	my_safefree(p)
1196 
1197 #define new_XPVCV()	my_safemalloc(sizeof(XPVCV))
1198 #define del_XPVCV(p)	my_safefree(p)
1199 
1200 #define new_XPVAV()	my_safemalloc(sizeof(XPVAV))
1201 #define del_XPVAV(p)	my_safefree(p)
1202 
1203 #define new_XPVHV()	my_safemalloc(sizeof(XPVHV))
1204 #define del_XPVHV(p)	my_safefree(p)
1205 
1206 #define new_XPVMG()	my_safemalloc(sizeof(XPVMG))
1207 #define del_XPVMG(p)	my_safefree(p)
1208 
1209 #define new_XPVLV()	my_safemalloc(sizeof(XPVLV))
1210 #define del_XPVLV(p)	my_safefree(p)
1211 
1212 #define new_XPVBM()	my_safemalloc(sizeof(XPVBM))
1213 #define del_XPVBM(p)	my_safefree(p)
1214 
1215 #else /* !PURIFY */
1216 
1217 #define new_XIV()	(void*)new_xiv()
1218 #define del_XIV(p)	del_xiv((XPVIV*) p)
1219 
1220 #define new_XNV()	(void*)new_xnv()
1221 #define del_XNV(p)	del_xnv((XPVNV*) p)
1222 
1223 #define new_XRV()	(void*)new_xrv()
1224 #define del_XRV(p)	del_xrv((XRV*) p)
1225 
1226 #define new_XPV()	(void*)new_xpv()
1227 #define del_XPV(p)	del_xpv((XPV *)p)
1228 
1229 #define new_XPVIV()	(void*)new_xpviv()
1230 #define del_XPVIV(p)	del_xpviv((XPVIV *)p)
1231 
1232 #define new_XPVNV()	(void*)new_xpvnv()
1233 #define del_XPVNV(p)	del_xpvnv((XPVNV *)p)
1234 
1235 #define new_XPVCV()	(void*)new_xpvcv()
1236 #define del_XPVCV(p)	del_xpvcv((XPVCV *)p)
1237 
1238 #define new_XPVAV()	(void*)new_xpvav()
1239 #define del_XPVAV(p)	del_xpvav((XPVAV *)p)
1240 
1241 #define new_XPVHV()	(void*)new_xpvhv()
1242 #define del_XPVHV(p)	del_xpvhv((XPVHV *)p)
1243 
1244 #define new_XPVMG()	(void*)new_xpvmg()
1245 #define del_XPVMG(p)	del_xpvmg((XPVMG *)p)
1246 
1247 #define new_XPVLV()	(void*)new_xpvlv()
1248 #define del_XPVLV(p)	del_xpvlv((XPVLV *)p)
1249 
1250 #define new_XPVBM()	(void*)new_xpvbm()
1251 #define del_XPVBM(p)	del_xpvbm((XPVBM *)p)
1252 
1253 #endif /* PURIFY */
1254 
1255 #define new_XPVGV()	my_safemalloc(sizeof(XPVGV))
1256 #define del_XPVGV(p)	my_safefree(p)
1257 
1258 #define new_XPVFM()	my_safemalloc(sizeof(XPVFM))
1259 #define del_XPVFM(p)	my_safefree(p)
1260 
1261 #define new_XPVIO()	my_safemalloc(sizeof(XPVIO))
1262 #define del_XPVIO(p)	my_safefree(p)
1263 
1264 /*
1265 =for apidoc sv_upgrade
1266 
1267 Upgrade an SV to a more complex form.  Generally adds a new body type to the
1268 SV, then copies across as much information as possible from the old body.
1269 You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
1270 
1271 =cut
1272 */
1273 
1274 bool
Perl_sv_upgrade(pTHX_ register SV * sv,U32 mt)1275 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
1276 {
1277 
1278     char*	pv = NULL;
1279     U32		cur = 0;
1280     U32		len = 0;
1281     IV		iv = 0;
1282     NV		nv = 0.0;
1283     MAGIC*	magic = NULL;
1284     HV*		stash = Nullhv;
1285 
1286     if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
1287 	sv_force_normal(sv);
1288     }
1289 
1290     if (SvTYPE(sv) == mt)
1291 	return TRUE;
1292 
1293     if (mt < SVt_PVIV)
1294 	(void)SvOOK_off(sv);
1295 
1296     switch (SvTYPE(sv)) {
1297     case SVt_NULL:
1298 	pv	= 0;
1299 	cur	= 0;
1300 	len	= 0;
1301 	iv	= 0;
1302 	nv	= 0.0;
1303 	magic	= 0;
1304 	stash	= 0;
1305 	break;
1306     case SVt_IV:
1307 	pv	= 0;
1308 	cur	= 0;
1309 	len	= 0;
1310 	iv	= SvIVX(sv);
1311 	nv	= (NV)SvIVX(sv);
1312 	del_XIV(SvANY(sv));
1313 	magic	= 0;
1314 	stash	= 0;
1315 	if (mt == SVt_NV)
1316 	    mt = SVt_PVNV;
1317 	else if (mt < SVt_PVIV)
1318 	    mt = SVt_PVIV;
1319 	break;
1320     case SVt_NV:
1321 	pv	= 0;
1322 	cur	= 0;
1323 	len	= 0;
1324 	nv	= SvNVX(sv);
1325 	iv	= I_V(nv);
1326 	magic	= 0;
1327 	stash	= 0;
1328 	del_XNV(SvANY(sv));
1329 	SvANY(sv) = 0;
1330 	if (mt < SVt_PVNV)
1331 	    mt = SVt_PVNV;
1332 	break;
1333     case SVt_RV:
1334 	pv	= (char*)SvRV(sv);
1335 	cur	= 0;
1336 	len	= 0;
1337 	iv	= PTR2IV(pv);
1338 	nv	= PTR2NV(pv);
1339 	del_XRV(SvANY(sv));
1340 	magic	= 0;
1341 	stash	= 0;
1342 	break;
1343     case SVt_PV:
1344 	pv	= SvPVX(sv);
1345 	cur	= SvCUR(sv);
1346 	len	= SvLEN(sv);
1347 	iv	= 0;
1348 	nv	= 0.0;
1349 	magic	= 0;
1350 	stash	= 0;
1351 	del_XPV(SvANY(sv));
1352 	if (mt <= SVt_IV)
1353 	    mt = SVt_PVIV;
1354 	else if (mt == SVt_NV)
1355 	    mt = SVt_PVNV;
1356 	break;
1357     case SVt_PVIV:
1358 	pv	= SvPVX(sv);
1359 	cur	= SvCUR(sv);
1360 	len	= SvLEN(sv);
1361 	iv	= SvIVX(sv);
1362 	nv	= 0.0;
1363 	magic	= 0;
1364 	stash	= 0;
1365 	del_XPVIV(SvANY(sv));
1366 	break;
1367     case SVt_PVNV:
1368 	pv	= SvPVX(sv);
1369 	cur	= SvCUR(sv);
1370 	len	= SvLEN(sv);
1371 	iv	= SvIVX(sv);
1372 	nv	= SvNVX(sv);
1373 	magic	= 0;
1374 	stash	= 0;
1375 	del_XPVNV(SvANY(sv));
1376 	break;
1377     case SVt_PVMG:
1378 	pv	= SvPVX(sv);
1379 	cur	= SvCUR(sv);
1380 	len	= SvLEN(sv);
1381 	iv	= SvIVX(sv);
1382 	nv	= SvNVX(sv);
1383 	magic	= SvMAGIC(sv);
1384 	stash	= SvSTASH(sv);
1385 	del_XPVMG(SvANY(sv));
1386 	break;
1387     default:
1388 	Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1389     }
1390 
1391     switch (mt) {
1392     case SVt_NULL:
1393 	Perl_croak(aTHX_ "Can't upgrade to undef");
1394     case SVt_IV:
1395 	SvANY(sv) = new_XIV();
1396 	SvIVX(sv)	= iv;
1397 	break;
1398     case SVt_NV:
1399 	SvANY(sv) = new_XNV();
1400 	SvNVX(sv)	= nv;
1401 	break;
1402     case SVt_RV:
1403 	SvANY(sv) = new_XRV();
1404 	SvRV(sv) = (SV*)pv;
1405 	break;
1406     case SVt_PV:
1407 	SvANY(sv) = new_XPV();
1408 	SvPVX(sv)	= pv;
1409 	SvCUR(sv)	= cur;
1410 	SvLEN(sv)	= len;
1411 	break;
1412     case SVt_PVIV:
1413 	SvANY(sv) = new_XPVIV();
1414 	SvPVX(sv)	= pv;
1415 	SvCUR(sv)	= cur;
1416 	SvLEN(sv)	= len;
1417 	SvIVX(sv)	= iv;
1418 	if (SvNIOK(sv))
1419 	    (void)SvIOK_on(sv);
1420 	SvNOK_off(sv);
1421 	break;
1422     case SVt_PVNV:
1423 	SvANY(sv) = new_XPVNV();
1424 	SvPVX(sv)	= pv;
1425 	SvCUR(sv)	= cur;
1426 	SvLEN(sv)	= len;
1427 	SvIVX(sv)	= iv;
1428 	SvNVX(sv)	= nv;
1429 	break;
1430     case SVt_PVMG:
1431 	SvANY(sv) = new_XPVMG();
1432 	SvPVX(sv)	= pv;
1433 	SvCUR(sv)	= cur;
1434 	SvLEN(sv)	= len;
1435 	SvIVX(sv)	= iv;
1436 	SvNVX(sv)	= nv;
1437 	SvMAGIC(sv)	= magic;
1438 	SvSTASH(sv)	= stash;
1439 	break;
1440     case SVt_PVLV:
1441 	SvANY(sv) = new_XPVLV();
1442 	SvPVX(sv)	= pv;
1443 	SvCUR(sv)	= cur;
1444 	SvLEN(sv)	= len;
1445 	SvIVX(sv)	= iv;
1446 	SvNVX(sv)	= nv;
1447 	SvMAGIC(sv)	= magic;
1448 	SvSTASH(sv)	= stash;
1449 	LvTARGOFF(sv)	= 0;
1450 	LvTARGLEN(sv)	= 0;
1451 	LvTARG(sv)	= 0;
1452 	LvTYPE(sv)	= 0;
1453 	break;
1454     case SVt_PVAV:
1455 	SvANY(sv) = new_XPVAV();
1456 	if (pv)
1457 	    Safefree(pv);
1458 	SvPVX(sv)	= 0;
1459 	AvMAX(sv)	= -1;
1460 	AvFILLp(sv)	= -1;
1461 	SvIVX(sv)	= 0;
1462 	SvNVX(sv)	= 0.0;
1463 	SvMAGIC(sv)	= magic;
1464 	SvSTASH(sv)	= stash;
1465 	AvALLOC(sv)	= 0;
1466 	AvARYLEN(sv)	= 0;
1467 	AvFLAGS(sv)	= AVf_REAL;
1468 	break;
1469     case SVt_PVHV:
1470 	SvANY(sv) = new_XPVHV();
1471 	if (pv)
1472 	    Safefree(pv);
1473 	SvPVX(sv)	= 0;
1474 	HvFILL(sv)	= 0;
1475 	HvMAX(sv)	= 0;
1476 	HvTOTALKEYS(sv)	= 0;
1477 	HvPLACEHOLDERS(sv) = 0;
1478 	SvMAGIC(sv)	= magic;
1479 	SvSTASH(sv)	= stash;
1480 	HvRITER(sv)	= 0;
1481 	HvEITER(sv)	= 0;
1482 	HvPMROOT(sv)	= 0;
1483 	HvNAME(sv)	= 0;
1484 	break;
1485     case SVt_PVCV:
1486 	SvANY(sv) = new_XPVCV();
1487 	Zero(SvANY(sv), 1, XPVCV);
1488 	SvPVX(sv)	= pv;
1489 	SvCUR(sv)	= cur;
1490 	SvLEN(sv)	= len;
1491 	SvIVX(sv)	= iv;
1492 	SvNVX(sv)	= nv;
1493 	SvMAGIC(sv)	= magic;
1494 	SvSTASH(sv)	= stash;
1495 	break;
1496     case SVt_PVGV:
1497 	SvANY(sv) = new_XPVGV();
1498 	SvPVX(sv)	= pv;
1499 	SvCUR(sv)	= cur;
1500 	SvLEN(sv)	= len;
1501 	SvIVX(sv)	= iv;
1502 	SvNVX(sv)	= nv;
1503 	SvMAGIC(sv)	= magic;
1504 	SvSTASH(sv)	= stash;
1505 	GvGP(sv)	= 0;
1506 	GvNAME(sv)	= 0;
1507 	GvNAMELEN(sv)	= 0;
1508 	GvSTASH(sv)	= 0;
1509 	GvFLAGS(sv)	= 0;
1510 	break;
1511     case SVt_PVBM:
1512 	SvANY(sv) = new_XPVBM();
1513 	SvPVX(sv)	= pv;
1514 	SvCUR(sv)	= cur;
1515 	SvLEN(sv)	= len;
1516 	SvIVX(sv)	= iv;
1517 	SvNVX(sv)	= nv;
1518 	SvMAGIC(sv)	= magic;
1519 	SvSTASH(sv)	= stash;
1520 	BmRARE(sv)	= 0;
1521 	BmUSEFUL(sv)	= 0;
1522 	BmPREVIOUS(sv)	= 0;
1523 	break;
1524     case SVt_PVFM:
1525 	SvANY(sv) = new_XPVFM();
1526 	Zero(SvANY(sv), 1, XPVFM);
1527 	SvPVX(sv)	= pv;
1528 	SvCUR(sv)	= cur;
1529 	SvLEN(sv)	= len;
1530 	SvIVX(sv)	= iv;
1531 	SvNVX(sv)	= nv;
1532 	SvMAGIC(sv)	= magic;
1533 	SvSTASH(sv)	= stash;
1534 	break;
1535     case SVt_PVIO:
1536 	SvANY(sv) = new_XPVIO();
1537 	Zero(SvANY(sv), 1, XPVIO);
1538 	SvPVX(sv)	= pv;
1539 	SvCUR(sv)	= cur;
1540 	SvLEN(sv)	= len;
1541 	SvIVX(sv)	= iv;
1542 	SvNVX(sv)	= nv;
1543 	SvMAGIC(sv)	= magic;
1544 	SvSTASH(sv)	= stash;
1545 	IoPAGE_LEN(sv)	= 60;
1546 	break;
1547     }
1548     SvFLAGS(sv) &= ~SVTYPEMASK;
1549     SvFLAGS(sv) |= mt;
1550     return TRUE;
1551 }
1552 
1553 /*
1554 =for apidoc sv_backoff
1555 
1556 Remove any string offset. You should normally use the C<SvOOK_off> macro
1557 wrapper instead.
1558 
1559 =cut
1560 */
1561 
1562 int
Perl_sv_backoff(pTHX_ register SV * sv)1563 Perl_sv_backoff(pTHX_ register SV *sv)
1564 {
1565     assert(SvOOK(sv));
1566     if (SvIVX(sv)) {
1567 	char *s = SvPVX(sv);
1568 	SvLEN(sv) += SvIVX(sv);
1569 	SvPVX(sv) -= SvIVX(sv);
1570 	SvIV_set(sv, 0);
1571 	Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1572     }
1573     SvFLAGS(sv) &= ~SVf_OOK;
1574     return 0;
1575 }
1576 
1577 /*
1578 =for apidoc sv_grow
1579 
1580 Expands the character buffer in the SV.  If necessary, uses C<sv_unref> and
1581 upgrades the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1582 Use the C<SvGROW> wrapper instead.
1583 
1584 =cut
1585 */
1586 
1587 char *
Perl_sv_grow(pTHX_ register SV * sv,register STRLEN newlen)1588 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1589 {
1590     register char *s;
1591 
1592 
1593 
1594 #ifdef HAS_64K_LIMIT
1595     if (newlen >= 0x10000) {
1596 	PerlIO_printf(Perl_debug_log,
1597 		      "Allocation too large: %"UVxf"\n", (UV)newlen);
1598 	my_exit(1);
1599     }
1600 #endif /* HAS_64K_LIMIT */
1601     if (SvROK(sv))
1602 	sv_unref(sv);
1603     if (SvTYPE(sv) < SVt_PV) {
1604 	sv_upgrade(sv, SVt_PV);
1605 	s = SvPVX(sv);
1606     }
1607     else if (SvOOK(sv)) {	/* pv is offset? */
1608 	sv_backoff(sv);
1609 	s = SvPVX(sv);
1610 	if (newlen > SvLEN(sv))
1611 	    newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1612 #ifdef HAS_64K_LIMIT
1613 	if (newlen >= 0x10000)
1614 	    newlen = 0xFFFF;
1615 #endif
1616     }
1617     else
1618 	s = SvPVX(sv);
1619 
1620     if (newlen > SvLEN(sv)) {		/* need more room? */
1621 	if (SvLEN(sv) && s) {
1622 #ifdef MYMALLOC
1623 	    STRLEN l = malloced_size((void*)SvPVX(sv));
1624 	    if (newlen <= l) {
1625 		SvLEN_set(sv, l);
1626 		return s;
1627 	    } else
1628 #endif
1629 	    Renew(s,newlen,char);
1630 	}
1631         else {
1632 	    /* sv_force_normal_flags() must not try to unshare the new
1633 	       PVX we allocate below. AMS 20010713 */
1634 	    if (SvREADONLY(sv) && SvFAKE(sv)) {
1635 		SvFAKE_off(sv);
1636 		SvREADONLY_off(sv);
1637 	    }
1638 	    New(703, s, newlen, char);
1639 	    if (SvPVX(sv) && SvCUR(sv)) {
1640 	        Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
1641 	    }
1642 	}
1643 	SvPV_set(sv, s);
1644         SvLEN_set(sv, newlen);
1645     }
1646     return s;
1647 }
1648 
1649 /*
1650 =for apidoc sv_setiv
1651 
1652 Copies an integer into the given SV, upgrading first if necessary.
1653 Does not handle 'set' magic.  See also C<sv_setiv_mg>.
1654 
1655 =cut
1656 */
1657 
1658 void
Perl_sv_setiv(pTHX_ register SV * sv,IV i)1659 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1660 {
1661     SV_CHECK_THINKFIRST(sv);
1662     switch (SvTYPE(sv)) {
1663     case SVt_NULL:
1664 	sv_upgrade(sv, SVt_IV);
1665 	break;
1666     case SVt_NV:
1667 	sv_upgrade(sv, SVt_PVNV);
1668 	break;
1669     case SVt_RV:
1670     case SVt_PV:
1671 	sv_upgrade(sv, SVt_PVIV);
1672 	break;
1673 
1674     case SVt_PVGV:
1675     case SVt_PVAV:
1676     case SVt_PVHV:
1677     case SVt_PVCV:
1678     case SVt_PVFM:
1679     case SVt_PVIO:
1680 	Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1681 		   OP_DESC(PL_op));
1682     }
1683     (void)SvIOK_only(sv);			/* validate number */
1684     SvIVX(sv) = i;
1685     SvTAINT(sv);
1686 }
1687 
1688 /*
1689 =for apidoc sv_setiv_mg
1690 
1691 Like C<sv_setiv>, but also handles 'set' magic.
1692 
1693 =cut
1694 */
1695 
1696 void
Perl_sv_setiv_mg(pTHX_ register SV * sv,IV i)1697 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1698 {
1699     sv_setiv(sv,i);
1700     SvSETMAGIC(sv);
1701 }
1702 
1703 /*
1704 =for apidoc sv_setuv
1705 
1706 Copies an unsigned integer into the given SV, upgrading first if necessary.
1707 Does not handle 'set' magic.  See also C<sv_setuv_mg>.
1708 
1709 =cut
1710 */
1711 
1712 void
Perl_sv_setuv(pTHX_ register SV * sv,UV u)1713 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1714 {
1715     /* With these two if statements:
1716        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1717 
1718        without
1719        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1720 
1721        If you wish to remove them, please benchmark to see what the effect is
1722     */
1723     if (u <= (UV)IV_MAX) {
1724        sv_setiv(sv, (IV)u);
1725        return;
1726     }
1727     sv_setiv(sv, 0);
1728     SvIsUV_on(sv);
1729     SvUVX(sv) = u;
1730 }
1731 
1732 /*
1733 =for apidoc sv_setuv_mg
1734 
1735 Like C<sv_setuv>, but also handles 'set' magic.
1736 
1737 =cut
1738 */
1739 
1740 void
Perl_sv_setuv_mg(pTHX_ register SV * sv,UV u)1741 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1742 {
1743     /* With these two if statements:
1744        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1745 
1746        without
1747        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1748 
1749        If you wish to remove them, please benchmark to see what the effect is
1750     */
1751     if (u <= (UV)IV_MAX) {
1752        sv_setiv(sv, (IV)u);
1753     } else {
1754        sv_setiv(sv, 0);
1755        SvIsUV_on(sv);
1756        sv_setuv(sv,u);
1757     }
1758     SvSETMAGIC(sv);
1759 }
1760 
1761 /*
1762 =for apidoc sv_setnv
1763 
1764 Copies a double into the given SV, upgrading first if necessary.
1765 Does not handle 'set' magic.  See also C<sv_setnv_mg>.
1766 
1767 =cut
1768 */
1769 
1770 void
Perl_sv_setnv(pTHX_ register SV * sv,NV num)1771 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1772 {
1773     SV_CHECK_THINKFIRST(sv);
1774     switch (SvTYPE(sv)) {
1775     case SVt_NULL:
1776     case SVt_IV:
1777 	sv_upgrade(sv, SVt_NV);
1778 	break;
1779     case SVt_RV:
1780     case SVt_PV:
1781     case SVt_PVIV:
1782 	sv_upgrade(sv, SVt_PVNV);
1783 	break;
1784 
1785     case SVt_PVGV:
1786     case SVt_PVAV:
1787     case SVt_PVHV:
1788     case SVt_PVCV:
1789     case SVt_PVFM:
1790     case SVt_PVIO:
1791 	Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1792 		   OP_NAME(PL_op));
1793     }
1794     SvNVX(sv) = num;
1795     (void)SvNOK_only(sv);			/* validate number */
1796     SvTAINT(sv);
1797 }
1798 
1799 /*
1800 =for apidoc sv_setnv_mg
1801 
1802 Like C<sv_setnv>, but also handles 'set' magic.
1803 
1804 =cut
1805 */
1806 
1807 void
Perl_sv_setnv_mg(pTHX_ register SV * sv,NV num)1808 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1809 {
1810     sv_setnv(sv,num);
1811     SvSETMAGIC(sv);
1812 }
1813 
1814 /* Print an "isn't numeric" warning, using a cleaned-up,
1815  * printable version of the offending string
1816  */
1817 
1818 STATIC void
S_not_a_number(pTHX_ SV * sv)1819 S_not_a_number(pTHX_ SV *sv)
1820 {
1821      SV *dsv;
1822      char tmpbuf[64];
1823      char *pv;
1824 
1825      if (DO_UTF8(sv)) {
1826           dsv = sv_2mortal(newSVpv("", 0));
1827           pv = sv_uni_display(dsv, sv, 10, 0);
1828      } else {
1829 	  char *d = tmpbuf;
1830 	  char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1831 	  /* each *s can expand to 4 chars + "...\0",
1832 	     i.e. need room for 8 chars */
1833 
1834 	  char *s, *end;
1835 	  for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1836 	       int ch = *s & 0xFF;
1837 	       if (ch & 128 && !isPRINT_LC(ch)) {
1838 		    *d++ = 'M';
1839 		    *d++ = '-';
1840 		    ch &= 127;
1841 	       }
1842 	       if (ch == '\n') {
1843 		    *d++ = '\\';
1844 		    *d++ = 'n';
1845 	       }
1846 	       else if (ch == '\r') {
1847 		    *d++ = '\\';
1848 		    *d++ = 'r';
1849 	       }
1850 	       else if (ch == '\f') {
1851 		    *d++ = '\\';
1852 		    *d++ = 'f';
1853 	       }
1854 	       else if (ch == '\\') {
1855 		    *d++ = '\\';
1856 		    *d++ = '\\';
1857 	       }
1858 	       else if (ch == '\0') {
1859 		    *d++ = '\\';
1860 		    *d++ = '0';
1861 	       }
1862 	       else if (isPRINT_LC(ch))
1863 		    *d++ = ch;
1864 	       else {
1865 		    *d++ = '^';
1866 		    *d++ = toCTRL(ch);
1867 	       }
1868 	  }
1869 	  if (s < end) {
1870 	       *d++ = '.';
1871 	       *d++ = '.';
1872 	       *d++ = '.';
1873 	  }
1874 	  *d = '\0';
1875 	  pv = tmpbuf;
1876     }
1877 
1878     if (PL_op)
1879 	Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1880 		    "Argument \"%s\" isn't numeric in %s", pv,
1881 		    OP_DESC(PL_op));
1882     else
1883 	Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
1884 		    "Argument \"%s\" isn't numeric", pv);
1885 }
1886 
1887 /*
1888 =for apidoc looks_like_number
1889 
1890 Test if the content of an SV looks like a number (or is a number).
1891 C<Inf> and C<Infinity> are treated as numbers (so will not issue a
1892 non-numeric warning), even if your atof() doesn't grok them.
1893 
1894 =cut
1895 */
1896 
1897 I32
Perl_looks_like_number(pTHX_ SV * sv)1898 Perl_looks_like_number(pTHX_ SV *sv)
1899 {
1900     register char *sbegin;
1901     STRLEN len;
1902 
1903     if (SvPOK(sv)) {
1904 	sbegin = SvPVX(sv);
1905 	len = SvCUR(sv);
1906     }
1907     else if (SvPOKp(sv))
1908 	sbegin = SvPV(sv, len);
1909     else
1910 	return 1; /* Historic.  Wrong?  */
1911     return grok_number(sbegin, len, NULL);
1912 }
1913 
1914 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1915    until proven guilty, assume that things are not that bad... */
1916 
1917 /*
1918    NV_PRESERVES_UV:
1919 
1920    As 64 bit platforms often have an NV that doesn't preserve all bits of
1921    an IV (an assumption perl has been based on to date) it becomes necessary
1922    to remove the assumption that the NV always carries enough precision to
1923    recreate the IV whenever needed, and that the NV is the canonical form.
1924    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1925    precision as a side effect of conversion (which would lead to insanity
1926    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1927    1) to distinguish between IV/UV/NV slots that have cached a valid
1928       conversion where precision was lost and IV/UV/NV slots that have a
1929       valid conversion which has lost no precision
1930    2) to ensure that if a numeric conversion to one form is requested that
1931       would lose precision, the precise conversion (or differently
1932       imprecise conversion) is also performed and cached, to prevent
1933       requests for different numeric formats on the same SV causing
1934       lossy conversion chains. (lossless conversion chains are perfectly
1935       acceptable (still))
1936 
1937 
1938    flags are used:
1939    SvIOKp is true if the IV slot contains a valid value
1940    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1941    SvNOKp is true if the NV slot contains a valid value
1942    SvNOK  is true only if the NV value is accurate
1943 
1944    so
1945    while converting from PV to NV, check to see if converting that NV to an
1946    IV(or UV) would lose accuracy over a direct conversion from PV to
1947    IV(or UV). If it would, cache both conversions, return NV, but mark
1948    SV as IOK NOKp (ie not NOK).
1949 
1950    While converting from PV to IV, check to see if converting that IV to an
1951    NV would lose accuracy over a direct conversion from PV to NV. If it
1952    would, cache both conversions, flag similarly.
1953 
1954    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1955    correctly because if IV & NV were set NV *always* overruled.
1956    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flag's meaning
1957    changes - now IV and NV together means that the two are interchangeable:
1958    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1959 
1960    The benefit of this is that operations such as pp_add know that if
1961    SvIOK is true for both left and right operands, then integer addition
1962    can be used instead of floating point (for cases where the result won't
1963    overflow). Before, floating point was always used, which could lead to
1964    loss of precision compared with integer addition.
1965 
1966    * making IV and NV equal status should make maths accurate on 64 bit
1967      platforms
1968    * may speed up maths somewhat if pp_add and friends start to use
1969      integers when possible instead of fp. (Hopefully the overhead in
1970      looking for SvIOK and checking for overflow will not outweigh the
1971      fp to integer speedup)
1972    * will slow down integer operations (callers of SvIV) on "inaccurate"
1973      values, as the change from SvIOK to SvIOKp will cause a call into
1974      sv_2iv each time rather than a macro access direct to the IV slot
1975    * should speed up number->string conversion on integers as IV is
1976      favoured when IV and NV are equally accurate
1977 
1978    ####################################################################
1979    You had better be using SvIOK_notUV if you want an IV for arithmetic:
1980    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV.
1981    On the other hand, SvUOK is true iff UV.
1982    ####################################################################
1983 
1984    Your mileage will vary depending your CPU's relative fp to integer
1985    performance ratio.
1986 */
1987 
1988 #ifndef NV_PRESERVES_UV
1989 #  define IS_NUMBER_UNDERFLOW_IV 1
1990 #  define IS_NUMBER_UNDERFLOW_UV 2
1991 #  define IS_NUMBER_IV_AND_UV    2
1992 #  define IS_NUMBER_OVERFLOW_IV  4
1993 #  define IS_NUMBER_OVERFLOW_UV  5
1994 
1995 /* sv_2iuv_non_preserve(): private routine for use by sv_2iv() and sv_2uv() */
1996 
1997 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1998 STATIC int
S_sv_2iuv_non_preserve(pTHX_ register SV * sv,I32 numtype)1999 S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
2000 {
2001     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
2002     if (SvNVX(sv) < (NV)IV_MIN) {
2003 	(void)SvIOKp_on(sv);
2004 	(void)SvNOK_on(sv);
2005 	SvIVX(sv) = IV_MIN;
2006 	return IS_NUMBER_UNDERFLOW_IV;
2007     }
2008     if (SvNVX(sv) > (NV)UV_MAX) {
2009 	(void)SvIOKp_on(sv);
2010 	(void)SvNOK_on(sv);
2011 	SvIsUV_on(sv);
2012 	SvUVX(sv) = UV_MAX;
2013 	return IS_NUMBER_OVERFLOW_UV;
2014     }
2015     (void)SvIOKp_on(sv);
2016     (void)SvNOK_on(sv);
2017     /* Can't use strtol etc to convert this string.  (See truth table in
2018        sv_2iv  */
2019     if (SvNVX(sv) <= (UV)IV_MAX) {
2020         SvIVX(sv) = I_V(SvNVX(sv));
2021         if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2022             SvIOK_on(sv); /* Integer is precise. NOK, IOK */
2023         } else {
2024             /* Integer is imprecise. NOK, IOKp */
2025         }
2026         return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
2027     }
2028     SvIsUV_on(sv);
2029     SvUVX(sv) = U_V(SvNVX(sv));
2030     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2031         if (SvUVX(sv) == UV_MAX) {
2032             /* As we know that NVs don't preserve UVs, UV_MAX cannot
2033                possibly be preserved by NV. Hence, it must be overflow.
2034                NOK, IOKp */
2035             return IS_NUMBER_OVERFLOW_UV;
2036         }
2037         SvIOK_on(sv); /* Integer is precise. NOK, UOK */
2038     } else {
2039         /* Integer is imprecise. NOK, IOKp */
2040     }
2041     return IS_NUMBER_OVERFLOW_IV;
2042 }
2043 #endif /* !NV_PRESERVES_UV*/
2044 
2045 /*
2046 =for apidoc sv_2iv
2047 
2048 Return the integer value of an SV, doing any necessary string conversion,
2049 magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
2050 
2051 =cut
2052 */
2053 
2054 IV
Perl_sv_2iv(pTHX_ register SV * sv)2055 Perl_sv_2iv(pTHX_ register SV *sv)
2056 {
2057     if (!sv)
2058 	return 0;
2059     if (SvGMAGICAL(sv)) {
2060 	mg_get(sv);
2061 	if (SvIOKp(sv))
2062 	    return SvIVX(sv);
2063 	if (SvNOKp(sv)) {
2064 	    return I_V(SvNVX(sv));
2065 	}
2066 	if (SvPOKp(sv) && SvLEN(sv))
2067 	    return asIV(sv);
2068 	if (!SvROK(sv)) {
2069 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2070 		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2071 		    report_uninit();
2072 	    }
2073 	    return 0;
2074 	}
2075     }
2076     if (SvTHINKFIRST(sv)) {
2077 	if (SvROK(sv)) {
2078 	  SV* tmpstr;
2079           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2080                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2081 	      return SvIV(tmpstr);
2082 	  return PTR2IV(SvRV(sv));
2083 	}
2084 	if (SvREADONLY(sv) && SvFAKE(sv)) {
2085 	    sv_force_normal(sv);
2086 	}
2087 	if (SvREADONLY(sv) && !SvOK(sv)) {
2088 	    if (ckWARN(WARN_UNINITIALIZED))
2089 		report_uninit();
2090 	    return 0;
2091 	}
2092     }
2093     if (SvIOKp(sv)) {
2094 	if (SvIsUV(sv)) {
2095 	    return (IV)(SvUVX(sv));
2096 	}
2097 	else {
2098 	    return SvIVX(sv);
2099 	}
2100     }
2101     if (SvNOKp(sv)) {
2102 	/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2103 	 * without also getting a cached IV/UV from it at the same time
2104 	 * (ie PV->NV conversion should detect loss of accuracy and cache
2105 	 * IV or UV at same time to avoid this.  NWC */
2106 
2107 	if (SvTYPE(sv) == SVt_NV)
2108 	    sv_upgrade(sv, SVt_PVNV);
2109 
2110 	(void)SvIOKp_on(sv);	/* Must do this first, to clear any SvOOK */
2111 	/* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
2112 	   certainly cast into the IV range at IV_MAX, whereas the correct
2113 	   answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
2114 	   cases go to UV */
2115 	if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2116 	    SvIVX(sv) = I_V(SvNVX(sv));
2117 	    if (SvNVX(sv) == (NV) SvIVX(sv)
2118 #ifndef NV_PRESERVES_UV
2119 		&& (((UV)1 << NV_PRESERVES_UV_BITS) >
2120 		    (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2121 		/* Don't flag it as "accurately an integer" if the number
2122 		   came from a (by definition imprecise) NV operation, and
2123 		   we're outside the range of NV integer precision */
2124 #endif
2125 		) {
2126 		SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2127 		DEBUG_c(PerlIO_printf(Perl_debug_log,
2128 				      "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
2129 				      PTR2UV(sv),
2130 				      SvNVX(sv),
2131 				      SvIVX(sv)));
2132 
2133 	    } else {
2134 		/* IV not precise.  No need to convert from PV, as NV
2135 		   conversion would already have cached IV if it detected
2136 		   that PV->IV would be better than PV->NV->IV
2137 		   flags already correct - don't set public IOK.  */
2138 		DEBUG_c(PerlIO_printf(Perl_debug_log,
2139 				      "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
2140 				      PTR2UV(sv),
2141 				      SvNVX(sv),
2142 				      SvIVX(sv)));
2143 	    }
2144 	    /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2145 	       but the cast (NV)IV_MIN rounds to a the value less (more
2146 	       negative) than IV_MIN which happens to be equal to SvNVX ??
2147 	       Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2148 	       NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2149 	       (NV)UVX == NVX are both true, but the values differ. :-(
2150 	       Hopefully for 2s complement IV_MIN is something like
2151 	       0x8000000000000000 which will be exact. NWC */
2152 	}
2153 	else {
2154 	    SvUVX(sv) = U_V(SvNVX(sv));
2155 	    if (
2156 		(SvNVX(sv) == (NV) SvUVX(sv))
2157 #ifndef  NV_PRESERVES_UV
2158 		/* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2159 		/*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2160 		&& (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(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 */
2164 #endif
2165 		)
2166 		SvIOK_on(sv);
2167 	    SvIsUV_on(sv);
2168 	  ret_iv_max:
2169 	    DEBUG_c(PerlIO_printf(Perl_debug_log,
2170 				  "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
2171 				  PTR2UV(sv),
2172 				  SvUVX(sv),
2173 				  SvUVX(sv)));
2174 	    return (IV)SvUVX(sv);
2175 	}
2176     }
2177     else if (SvPOKp(sv) && SvLEN(sv)) {
2178 	UV value;
2179 	int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2180 	/* We want to avoid a possible problem when we cache an IV which
2181 	   may be later translated to an NV, and the resulting NV is not
2182 	   the same as the direct translation of the initial string
2183 	   (eg 123.456 can shortcut to the IV 123 with atol(), but we must
2184 	   be careful to ensure that the value with the .456 is around if the
2185 	   NV value is requested in the future).
2186 
2187 	   This means that if we cache such an IV, we need to cache the
2188 	   NV as well.  Moreover, we trade speed for space, and do not
2189 	   cache the NV if we are sure it's not needed.
2190 	 */
2191 
2192 	/* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2193 	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2194 	     == IS_NUMBER_IN_UV) {
2195 	    /* It's definitely an integer, only upgrade to PVIV */
2196 	    if (SvTYPE(sv) < SVt_PVIV)
2197 		sv_upgrade(sv, SVt_PVIV);
2198 	    (void)SvIOK_on(sv);
2199 	} else if (SvTYPE(sv) < SVt_PVNV)
2200 	    sv_upgrade(sv, SVt_PVNV);
2201 
2202 	/* If NV preserves UV then we only use the UV value if we know that
2203 	   we aren't going to call atof() below. If NVs don't preserve UVs
2204 	   then the value returned may have more precision than atof() will
2205 	   return, even though value isn't perfectly accurate.  */
2206 	if ((numtype & (IS_NUMBER_IN_UV
2207 #ifdef NV_PRESERVES_UV
2208 			| IS_NUMBER_NOT_INT
2209 #endif
2210 	    )) == IS_NUMBER_IN_UV) {
2211 	    /* This won't turn off the public IOK flag if it was set above  */
2212 	    (void)SvIOKp_on(sv);
2213 
2214 	    if (!(numtype & IS_NUMBER_NEG)) {
2215 		/* positive */;
2216 		if (value <= (UV)IV_MAX) {
2217 		    SvIVX(sv) = (IV)value;
2218 		} else {
2219 		    SvUVX(sv) = value;
2220 		    SvIsUV_on(sv);
2221 		}
2222 	    } else {
2223 		/* 2s complement assumption  */
2224 		if (value <= (UV)IV_MIN) {
2225 		    SvIVX(sv) = -(IV)value;
2226 		} else {
2227 		    /* Too negative for an IV.  This is a double upgrade, but
2228 		       I'm assuming it will be rare.  */
2229 		    if (SvTYPE(sv) < SVt_PVNV)
2230 			sv_upgrade(sv, SVt_PVNV);
2231 		    SvNOK_on(sv);
2232 		    SvIOK_off(sv);
2233 		    SvIOKp_on(sv);
2234 		    SvNVX(sv) = -(NV)value;
2235 		    SvIVX(sv) = IV_MIN;
2236 		}
2237 	    }
2238 	}
2239 	/* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2240            will be in the previous block to set the IV slot, and the next
2241            block to set the NV slot.  So no else here.  */
2242 
2243 	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2244 	    != IS_NUMBER_IN_UV) {
2245 	    /* It wasn't an (integer that doesn't overflow the UV). */
2246 	    SvNVX(sv) = Atof(SvPVX(sv));
2247 
2248 	    if (! numtype && ckWARN(WARN_NUMERIC))
2249 		not_a_number(sv);
2250 
2251 #if defined(USE_LONG_DOUBLE)
2252 	    DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2253 				  PTR2UV(sv), SvNVX(sv)));
2254 #else
2255 	    DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
2256 				  PTR2UV(sv), SvNVX(sv)));
2257 #endif
2258 
2259 
2260 #ifdef NV_PRESERVES_UV
2261 	    (void)SvIOKp_on(sv);
2262 	    (void)SvNOK_on(sv);
2263 	    if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2264 		SvIVX(sv) = I_V(SvNVX(sv));
2265 		if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2266 		    SvIOK_on(sv);
2267 		} else {
2268 		    /* Integer is imprecise. NOK, IOKp */
2269 		}
2270 		/* UV will not work better than IV */
2271 	    } else {
2272 		if (SvNVX(sv) > (NV)UV_MAX) {
2273 		    SvIsUV_on(sv);
2274 		    /* Integer is inaccurate. NOK, IOKp, is UV */
2275 		    SvUVX(sv) = UV_MAX;
2276 		    SvIsUV_on(sv);
2277 		} else {
2278 		    SvUVX(sv) = U_V(SvNVX(sv));
2279 		    /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2280 		    if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2281 			SvIOK_on(sv);
2282 			SvIsUV_on(sv);
2283 		    } else {
2284 			/* Integer is imprecise. NOK, IOKp, is UV */
2285 			SvIsUV_on(sv);
2286 		    }
2287 		}
2288 		goto ret_iv_max;
2289 	    }
2290 #else /* NV_PRESERVES_UV */
2291             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2292                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2293                 /* The IV slot will have been set from value returned by
2294                    grok_number above.  The NV slot has just been set using
2295                    Atof.  */
2296 	        SvNOK_on(sv);
2297                 assert (SvIOKp(sv));
2298             } else {
2299                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2300                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2301                     /* Small enough to preserve all bits. */
2302                     (void)SvIOKp_on(sv);
2303                     SvNOK_on(sv);
2304                     SvIVX(sv) = I_V(SvNVX(sv));
2305                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2306                         SvIOK_on(sv);
2307                     /* Assumption: first non-preserved integer is < IV_MAX,
2308                        this NV is in the preserved range, therefore: */
2309                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2310                           < (UV)IV_MAX)) {
2311                         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);
2312                     }
2313                 } else {
2314                     /* IN_UV NOT_INT
2315                          0      0	already failed to read UV.
2316                          0      1       already failed to read UV.
2317                          1      0       you won't get here in this case. IV/UV
2318                          	        slot set, public IOK, Atof() unneeded.
2319                          1      1       already read UV.
2320                        so there's no point in sv_2iuv_non_preserve() attempting
2321                        to use atol, strtol, strtoul etc.  */
2322                     if (sv_2iuv_non_preserve (sv, numtype)
2323                         >= IS_NUMBER_OVERFLOW_IV)
2324                     goto ret_iv_max;
2325                 }
2326             }
2327 #endif /* NV_PRESERVES_UV */
2328 	}
2329     } else  {
2330 	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2331 	    report_uninit();
2332 	if (SvTYPE(sv) < SVt_IV)
2333 	    /* Typically the caller expects that sv_any is not NULL now.  */
2334 	    sv_upgrade(sv, SVt_IV);
2335 	return 0;
2336     }
2337     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2338 	PTR2UV(sv),SvIVX(sv)));
2339     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2340 }
2341 
2342 /*
2343 =for apidoc sv_2uv
2344 
2345 Return the unsigned integer value of an SV, doing any necessary string
2346 conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
2347 macros.
2348 
2349 =cut
2350 */
2351 
2352 UV
Perl_sv_2uv(pTHX_ register SV * sv)2353 Perl_sv_2uv(pTHX_ register SV *sv)
2354 {
2355     if (!sv)
2356 	return 0;
2357     if (SvGMAGICAL(sv)) {
2358 	mg_get(sv);
2359 	if (SvIOKp(sv))
2360 	    return SvUVX(sv);
2361 	if (SvNOKp(sv))
2362 	    return U_V(SvNVX(sv));
2363 	if (SvPOKp(sv) && SvLEN(sv))
2364 	    return asUV(sv);
2365 	if (!SvROK(sv)) {
2366 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2367 		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2368 		    report_uninit();
2369 	    }
2370 	    return 0;
2371 	}
2372     }
2373     if (SvTHINKFIRST(sv)) {
2374 	if (SvROK(sv)) {
2375 	  SV* tmpstr;
2376           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2377                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2378 	      return SvUV(tmpstr);
2379 	  return PTR2UV(SvRV(sv));
2380 	}
2381 	if (SvREADONLY(sv) && SvFAKE(sv)) {
2382 	    sv_force_normal(sv);
2383 	}
2384 	if (SvREADONLY(sv) && !SvOK(sv)) {
2385 	    if (ckWARN(WARN_UNINITIALIZED))
2386 		report_uninit();
2387 	    return 0;
2388 	}
2389     }
2390     if (SvIOKp(sv)) {
2391 	if (SvIsUV(sv)) {
2392 	    return SvUVX(sv);
2393 	}
2394 	else {
2395 	    return (UV)SvIVX(sv);
2396 	}
2397     }
2398     if (SvNOKp(sv)) {
2399 	/* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2400 	 * without also getting a cached IV/UV from it at the same time
2401 	 * (ie PV->NV conversion should detect loss of accuracy and cache
2402 	 * IV or UV at same time to avoid this. */
2403 	/* IV-over-UV optimisation - choose to cache IV if possible */
2404 
2405 	if (SvTYPE(sv) == SVt_NV)
2406 	    sv_upgrade(sv, SVt_PVNV);
2407 
2408 	(void)SvIOKp_on(sv);	/* Must do this first, to clear any SvOOK */
2409 	if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2410 	    SvIVX(sv) = I_V(SvNVX(sv));
2411 	    if (SvNVX(sv) == (NV) SvIVX(sv)
2412 #ifndef NV_PRESERVES_UV
2413 		&& (((UV)1 << NV_PRESERVES_UV_BITS) >
2414 		    (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2415 		/* Don't flag it as "accurately an integer" if the number
2416 		   came from a (by definition imprecise) NV operation, and
2417 		   we're outside the range of NV integer precision */
2418 #endif
2419 		) {
2420 		SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2421 		DEBUG_c(PerlIO_printf(Perl_debug_log,
2422 				      "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
2423 				      PTR2UV(sv),
2424 				      SvNVX(sv),
2425 				      SvIVX(sv)));
2426 
2427 	    } else {
2428 		/* IV not precise.  No need to convert from PV, as NV
2429 		   conversion would already have cached IV if it detected
2430 		   that PV->IV would be better than PV->NV->IV
2431 		   flags already correct - don't set public IOK.  */
2432 		DEBUG_c(PerlIO_printf(Perl_debug_log,
2433 				      "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
2434 				      PTR2UV(sv),
2435 				      SvNVX(sv),
2436 				      SvIVX(sv)));
2437 	    }
2438 	    /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2439 	       but the cast (NV)IV_MIN rounds to a the value less (more
2440 	       negative) than IV_MIN which happens to be equal to SvNVX ??
2441 	       Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2442 	       NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2443 	       (NV)UVX == NVX are both true, but the values differ. :-(
2444 	       Hopefully for 2s complement IV_MIN is something like
2445 	       0x8000000000000000 which will be exact. NWC */
2446 	}
2447 	else {
2448 	    SvUVX(sv) = U_V(SvNVX(sv));
2449 	    if (
2450 		(SvNVX(sv) == (NV) SvUVX(sv))
2451 #ifndef  NV_PRESERVES_UV
2452 		/* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2453 		/*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2454 		&& (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2455 		/* Don't flag it as "accurately an integer" if the number
2456 		   came from a (by definition imprecise) NV operation, and
2457 		   we're outside the range of NV integer precision */
2458 #endif
2459 		)
2460 		SvIOK_on(sv);
2461 	    SvIsUV_on(sv);
2462 	    DEBUG_c(PerlIO_printf(Perl_debug_log,
2463 				  "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2464 				  PTR2UV(sv),
2465 				  SvUVX(sv),
2466 				  SvUVX(sv)));
2467 	}
2468     }
2469     else if (SvPOKp(sv) && SvLEN(sv)) {
2470 	UV value;
2471 	int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2472 
2473 	/* We want to avoid a possible problem when we cache a UV which
2474 	   may be later translated to an NV, and the resulting NV is not
2475 	   the translation of the initial data.
2476 
2477 	   This means that if we cache such a UV, we need to cache the
2478 	   NV as well.  Moreover, we trade speed for space, and do not
2479 	   cache the NV if not needed.
2480 	 */
2481 
2482 	/* SVt_PVNV is one higher than SVt_PVIV, hence this order  */
2483 	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2484 	     == IS_NUMBER_IN_UV) {
2485 	    /* It's definitely an integer, only upgrade to PVIV */
2486 	    if (SvTYPE(sv) < SVt_PVIV)
2487 		sv_upgrade(sv, SVt_PVIV);
2488 	    (void)SvIOK_on(sv);
2489 	} else if (SvTYPE(sv) < SVt_PVNV)
2490 	    sv_upgrade(sv, SVt_PVNV);
2491 
2492 	/* If NV preserves UV then we only use the UV value if we know that
2493 	   we aren't going to call atof() below. If NVs don't preserve UVs
2494 	   then the value returned may have more precision than atof() will
2495 	   return, even though it isn't accurate.  */
2496 	if ((numtype & (IS_NUMBER_IN_UV
2497 #ifdef NV_PRESERVES_UV
2498 			| IS_NUMBER_NOT_INT
2499 #endif
2500 	    )) == IS_NUMBER_IN_UV) {
2501 	    /* This won't turn off the public IOK flag if it was set above  */
2502 	    (void)SvIOKp_on(sv);
2503 
2504 	    if (!(numtype & IS_NUMBER_NEG)) {
2505 		/* positive */;
2506 		if (value <= (UV)IV_MAX) {
2507 		    SvIVX(sv) = (IV)value;
2508 		} else {
2509 		    /* it didn't overflow, and it was positive. */
2510 		    SvUVX(sv) = value;
2511 		    SvIsUV_on(sv);
2512 		}
2513 	    } else {
2514 		/* 2s complement assumption  */
2515 		if (value <= (UV)IV_MIN) {
2516 		    SvIVX(sv) = -(IV)value;
2517 		} else {
2518 		    /* Too negative for an IV.  This is a double upgrade, but
2519 		       I'm assuming it will be rare.  */
2520 		    if (SvTYPE(sv) < SVt_PVNV)
2521 			sv_upgrade(sv, SVt_PVNV);
2522 		    SvNOK_on(sv);
2523 		    SvIOK_off(sv);
2524 		    SvIOKp_on(sv);
2525 		    SvNVX(sv) = -(NV)value;
2526 		    SvIVX(sv) = IV_MIN;
2527 		}
2528 	    }
2529 	}
2530 
2531 	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2532 	    != IS_NUMBER_IN_UV) {
2533 	    /* It wasn't an integer, or it overflowed the UV. */
2534 	    SvNVX(sv) = Atof(SvPVX(sv));
2535 
2536             if (! numtype && ckWARN(WARN_NUMERIC))
2537 		    not_a_number(sv);
2538 
2539 #if defined(USE_LONG_DOUBLE)
2540             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2541                                   PTR2UV(sv), SvNVX(sv)));
2542 #else
2543             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
2544                                   PTR2UV(sv), SvNVX(sv)));
2545 #endif
2546 
2547 #ifdef NV_PRESERVES_UV
2548             (void)SvIOKp_on(sv);
2549             (void)SvNOK_on(sv);
2550             if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2551                 SvIVX(sv) = I_V(SvNVX(sv));
2552                 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2553                     SvIOK_on(sv);
2554                 } else {
2555                     /* Integer is imprecise. NOK, IOKp */
2556                 }
2557                 /* UV will not work better than IV */
2558             } else {
2559                 if (SvNVX(sv) > (NV)UV_MAX) {
2560                     SvIsUV_on(sv);
2561                     /* Integer is inaccurate. NOK, IOKp, is UV */
2562                     SvUVX(sv) = UV_MAX;
2563                     SvIsUV_on(sv);
2564                 } else {
2565                     SvUVX(sv) = U_V(SvNVX(sv));
2566                     /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2567                        NV preservse UV so can do correct comparison.  */
2568                     if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2569                         SvIOK_on(sv);
2570                         SvIsUV_on(sv);
2571                     } else {
2572                         /* Integer is imprecise. NOK, IOKp, is UV */
2573                         SvIsUV_on(sv);
2574                     }
2575                 }
2576             }
2577 #else /* NV_PRESERVES_UV */
2578             if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2579                 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2580                 /* The UV slot will have been set from value returned by
2581                    grok_number above.  The NV slot has just been set using
2582                    Atof.  */
2583 	        SvNOK_on(sv);
2584                 assert (SvIOKp(sv));
2585             } else {
2586                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2587                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2588                     /* Small enough to preserve all bits. */
2589                     (void)SvIOKp_on(sv);
2590                     SvNOK_on(sv);
2591                     SvIVX(sv) = I_V(SvNVX(sv));
2592                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2593                         SvIOK_on(sv);
2594                     /* Assumption: first non-preserved integer is < IV_MAX,
2595                        this NV is in the preserved range, therefore: */
2596                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2597                           < (UV)IV_MAX)) {
2598                         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);
2599                     }
2600                 } else
2601                     sv_2iuv_non_preserve (sv, numtype);
2602             }
2603 #endif /* NV_PRESERVES_UV */
2604 	}
2605     }
2606     else  {
2607 	if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2608 	    if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2609 		report_uninit();
2610 	}
2611 	if (SvTYPE(sv) < SVt_IV)
2612 	    /* Typically the caller expects that sv_any is not NULL now.  */
2613 	    sv_upgrade(sv, SVt_IV);
2614 	return 0;
2615     }
2616 
2617     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2618 			  PTR2UV(sv),SvUVX(sv)));
2619     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2620 }
2621 
2622 /*
2623 =for apidoc sv_2nv
2624 
2625 Return the num value of an SV, doing any necessary string or integer
2626 conversion, magic etc. Normally used via the C<SvNV(sv)> and C<SvNVx(sv)>
2627 macros.
2628 
2629 =cut
2630 */
2631 
2632 NV
Perl_sv_2nv(pTHX_ register SV * sv)2633 Perl_sv_2nv(pTHX_ register SV *sv)
2634 {
2635     if (!sv)
2636 	return 0.0;
2637     if (SvGMAGICAL(sv)) {
2638 	mg_get(sv);
2639 	if (SvNOKp(sv))
2640 	    return SvNVX(sv);
2641 	if (SvPOKp(sv) && SvLEN(sv)) {
2642 	    if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2643 		!grok_number(SvPVX(sv), SvCUR(sv), NULL))
2644 		not_a_number(sv);
2645 	    return Atof(SvPVX(sv));
2646 	}
2647 	if (SvIOKp(sv)) {
2648 	    if (SvIsUV(sv))
2649 		return (NV)SvUVX(sv);
2650 	    else
2651 		return (NV)SvIVX(sv);
2652 	}
2653         if (!SvROK(sv)) {
2654 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2655 		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2656 		    report_uninit();
2657 	    }
2658             return 0;
2659         }
2660     }
2661     if (SvTHINKFIRST(sv)) {
2662 	if (SvROK(sv)) {
2663 	  SV* tmpstr;
2664           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2665                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv))))
2666 	      return SvNV(tmpstr);
2667 	  return PTR2NV(SvRV(sv));
2668 	}
2669 	if (SvREADONLY(sv) && SvFAKE(sv)) {
2670 	    sv_force_normal(sv);
2671 	}
2672 	if (SvREADONLY(sv) && !SvOK(sv)) {
2673 	    if (ckWARN(WARN_UNINITIALIZED))
2674 		report_uninit();
2675 	    return 0.0;
2676 	}
2677     }
2678     if (SvTYPE(sv) < SVt_NV) {
2679 	if (SvTYPE(sv) == SVt_IV)
2680 	    sv_upgrade(sv, SVt_PVNV);
2681 	else
2682 	    sv_upgrade(sv, SVt_NV);
2683 #ifdef USE_LONG_DOUBLE
2684 	DEBUG_c({
2685 	    STORE_NUMERIC_LOCAL_SET_STANDARD();
2686 	    PerlIO_printf(Perl_debug_log,
2687 			  "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2688 			  PTR2UV(sv), SvNVX(sv));
2689 	    RESTORE_NUMERIC_LOCAL();
2690 	});
2691 #else
2692 	DEBUG_c({
2693 	    STORE_NUMERIC_LOCAL_SET_STANDARD();
2694 	    PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
2695 			  PTR2UV(sv), SvNVX(sv));
2696 	    RESTORE_NUMERIC_LOCAL();
2697 	});
2698 #endif
2699     }
2700     else if (SvTYPE(sv) < SVt_PVNV)
2701 	sv_upgrade(sv, SVt_PVNV);
2702     if (SvNOKp(sv)) {
2703         return SvNVX(sv);
2704     }
2705     if (SvIOKp(sv)) {
2706 	SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2707 #ifdef NV_PRESERVES_UV
2708 	SvNOK_on(sv);
2709 #else
2710 	/* Only set the public NV OK flag if this NV preserves the IV  */
2711 	/* Check it's not 0xFFFFFFFFFFFFFFFF */
2712 	if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2713 		       : (SvIVX(sv) == I_V(SvNVX(sv))))
2714 	    SvNOK_on(sv);
2715 	else
2716 	    SvNOKp_on(sv);
2717 #endif
2718     }
2719     else if (SvPOKp(sv) && SvLEN(sv)) {
2720 	UV value;
2721 	int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2722 	if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2723 	    not_a_number(sv);
2724 #ifdef NV_PRESERVES_UV
2725 	if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2726 	    == IS_NUMBER_IN_UV) {
2727 	    /* It's definitely an integer */
2728 	    SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2729 	} else
2730 	    SvNVX(sv) = Atof(SvPVX(sv));
2731 	SvNOK_on(sv);
2732 #else
2733 	SvNVX(sv) = Atof(SvPVX(sv));
2734 	/* Only set the public NV OK flag if this NV preserves the value in
2735 	   the PV at least as well as an IV/UV would.
2736 	   Not sure how to do this 100% reliably. */
2737 	/* if that shift count is out of range then Configure's test is
2738 	   wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2739 	   UV_BITS */
2740 	if (((UV)1 << NV_PRESERVES_UV_BITS) >
2741 	    U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2742 	    SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2743 	} else if (!(numtype & IS_NUMBER_IN_UV)) {
2744             /* Can't use strtol etc to convert this string, so don't try.
2745                sv_2iv and sv_2uv will use the NV to convert, not the PV.  */
2746             SvNOK_on(sv);
2747         } else {
2748             /* value has been set.  It may not be precise.  */
2749 	    if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2750 		/* 2s complement assumption for (UV)IV_MIN  */
2751                 SvNOK_on(sv); /* Integer is too negative.  */
2752             } else {
2753                 SvNOKp_on(sv);
2754                 SvIOKp_on(sv);
2755 
2756                 if (numtype & IS_NUMBER_NEG) {
2757                     SvIVX(sv) = -(IV)value;
2758                 } else if (value <= (UV)IV_MAX) {
2759 		    SvIVX(sv) = (IV)value;
2760 		} else {
2761 		    SvUVX(sv) = value;
2762 		    SvIsUV_on(sv);
2763 		}
2764 
2765                 if (numtype & IS_NUMBER_NOT_INT) {
2766                     /* I believe that even if the original PV had decimals,
2767                        they are lost beyond the limit of the FP precision.
2768                        However, neither is canonical, so both only get p
2769                        flags.  NWC, 2000/11/25 */
2770                     /* Both already have p flags, so do nothing */
2771                 } else {
2772                     NV nv = SvNVX(sv);
2773                     if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2774                         if (SvIVX(sv) == I_V(nv)) {
2775                             SvNOK_on(sv);
2776                             SvIOK_on(sv);
2777                         } else {
2778                             SvIOK_on(sv);
2779                             /* It had no "." so it must be integer.  */
2780                         }
2781                     } else {
2782                         /* between IV_MAX and NV(UV_MAX).
2783                            Could be slightly > UV_MAX */
2784 
2785                         if (numtype & IS_NUMBER_NOT_INT) {
2786                             /* UV and NV both imprecise.  */
2787                         } else {
2788                             UV nv_as_uv = U_V(nv);
2789 
2790                             if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2791                                 SvNOK_on(sv);
2792                                 SvIOK_on(sv);
2793                             } else {
2794                                 SvIOK_on(sv);
2795                             }
2796                         }
2797                     }
2798                 }
2799             }
2800         }
2801 #endif /* NV_PRESERVES_UV */
2802     }
2803     else  {
2804 	if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2805 	    report_uninit();
2806 	if (SvTYPE(sv) < SVt_NV)
2807 	    /* Typically the caller expects that sv_any is not NULL now.  */
2808 	    /* XXX Ilya implies that this is a bug in callers that assume this
2809 	       and ideally should be fixed.  */
2810 	    sv_upgrade(sv, SVt_NV);
2811 	return 0.0;
2812     }
2813 #if defined(USE_LONG_DOUBLE)
2814     DEBUG_c({
2815 	STORE_NUMERIC_LOCAL_SET_STANDARD();
2816 	PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2817 		      PTR2UV(sv), SvNVX(sv));
2818 	RESTORE_NUMERIC_LOCAL();
2819     });
2820 #else
2821     DEBUG_c({
2822 	STORE_NUMERIC_LOCAL_SET_STANDARD();
2823 	PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
2824 		      PTR2UV(sv), SvNVX(sv));
2825 	RESTORE_NUMERIC_LOCAL();
2826     });
2827 #endif
2828     return SvNVX(sv);
2829 }
2830 
2831 /* asIV(): extract an integer from the string value of an SV.
2832  * Caller must validate PVX  */
2833 
2834 STATIC IV
S_asIV(pTHX_ SV * sv)2835 S_asIV(pTHX_ SV *sv)
2836 {
2837     UV value;
2838     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2839 
2840     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2841 	== IS_NUMBER_IN_UV) {
2842 	/* It's definitely an integer */
2843 	if (numtype & IS_NUMBER_NEG) {
2844 	    if (value < (UV)IV_MIN)
2845 		return -(IV)value;
2846 	} else {
2847 	    if (value < (UV)IV_MAX)
2848 		return (IV)value;
2849 	}
2850     }
2851     if (!numtype) {
2852 	if (ckWARN(WARN_NUMERIC))
2853 	    not_a_number(sv);
2854     }
2855     return I_V(Atof(SvPVX(sv)));
2856 }
2857 
2858 /* asUV(): extract an unsigned integer from the string value of an SV
2859  * Caller must validate PVX  */
2860 
2861 STATIC UV
S_asUV(pTHX_ SV * sv)2862 S_asUV(pTHX_ SV *sv)
2863 {
2864     UV value;
2865     int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2866 
2867     if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2868 	== IS_NUMBER_IN_UV) {
2869 	/* It's definitely an integer */
2870 	if (!(numtype & IS_NUMBER_NEG))
2871 	    return value;
2872     }
2873     if (!numtype) {
2874 	if (ckWARN(WARN_NUMERIC))
2875 	    not_a_number(sv);
2876     }
2877     return U_V(Atof(SvPVX(sv)));
2878 }
2879 
2880 /*
2881 =for apidoc sv_2pv_nolen
2882 
2883 Like C<sv_2pv()>, but doesn't return the length too. You should usually
2884 use the macro wrapper C<SvPV_nolen(sv)> instead.
2885 =cut
2886 */
2887 
2888 char *
Perl_sv_2pv_nolen(pTHX_ register SV * sv)2889 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2890 {
2891     STRLEN n_a;
2892     return sv_2pv(sv, &n_a);
2893 }
2894 
2895 /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or
2896  * UV as a string towards the end of buf, and return pointers to start and
2897  * end of it.
2898  *
2899  * We assume that buf is at least TYPE_CHARS(UV) long.
2900  */
2901 
2902 static char *
uiv_2buf(char * buf,IV iv,UV uv,int is_uv,char ** peob)2903 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2904 {
2905     char *ptr = buf + TYPE_CHARS(UV);
2906     char *ebuf = ptr;
2907     int sign;
2908 
2909     if (is_uv)
2910 	sign = 0;
2911     else if (iv >= 0) {
2912 	uv = iv;
2913 	sign = 0;
2914     } else {
2915 	uv = -iv;
2916 	sign = 1;
2917     }
2918     do {
2919 	*--ptr = '0' + (char)(uv % 10);
2920     } while (uv /= 10);
2921     if (sign)
2922 	*--ptr = '-';
2923     *peob = ebuf;
2924     return ptr;
2925 }
2926 
2927 /* sv_2pv() is now a macro using Perl_sv_2pv_flags();
2928  * this function provided for binary compatibility only
2929  */
2930 
2931 char *
Perl_sv_2pv(pTHX_ register SV * sv,STRLEN * lp)2932 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2933 {
2934     return sv_2pv_flags(sv, lp, SV_GMAGIC);
2935 }
2936 
2937 /*
2938 =for apidoc sv_2pv_flags
2939 
2940 Returns a pointer to the string value of an SV, and sets *lp to its length.
2941 If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
2942 if necessary.
2943 Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
2944 usually end up here too.
2945 
2946 =cut
2947 */
2948 
2949 char *
Perl_sv_2pv_flags(pTHX_ register SV * sv,STRLEN * lp,I32 flags)2950 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2951 {
2952     register char *s;
2953     int olderrno;
2954     SV *tsv, *origsv;
2955     char tbuf[64];	/* Must fit sprintf/Gconvert of longest IV/NV */
2956     char *tmpbuf = tbuf;
2957 
2958     if (!sv) {
2959 	*lp = 0;
2960 	return "";
2961     }
2962     if (SvGMAGICAL(sv)) {
2963 	if (flags & SV_GMAGIC)
2964 	    mg_get(sv);
2965 	if (SvPOKp(sv)) {
2966 	    *lp = SvCUR(sv);
2967 	    return SvPVX(sv);
2968 	}
2969 	if (SvIOKp(sv)) {
2970 	    if (SvIsUV(sv))
2971 		(void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2972 	    else
2973 		(void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2974 	    tsv = Nullsv;
2975 	    goto tokensave;
2976 	}
2977 	if (SvNOKp(sv)) {
2978 	    Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2979 	    tsv = Nullsv;
2980 	    goto tokensave;
2981 	}
2982         if (!SvROK(sv)) {
2983 	    if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2984 		if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2985 		    report_uninit();
2986 	    }
2987             *lp = 0;
2988             return "";
2989         }
2990     }
2991     if (SvTHINKFIRST(sv)) {
2992 	if (SvROK(sv)) {
2993 	    SV* tmpstr;
2994             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2995                 (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
2996                 char *pv = SvPV(tmpstr, *lp);
2997                 if (SvUTF8(tmpstr))
2998                     SvUTF8_on(sv);
2999                 else
3000                     SvUTF8_off(sv);
3001                 return pv;
3002             }
3003 	    origsv = sv;
3004 	    sv = (SV*)SvRV(sv);
3005 	    if (!sv)
3006 		s = "NULLREF";
3007 	    else {
3008 		MAGIC *mg;
3009 
3010 		switch (SvTYPE(sv)) {
3011 		case SVt_PVMG:
3012 		    if ( ((SvFLAGS(sv) &
3013 			   (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
3014 			  == (SVs_OBJECT|SVs_SMG))
3015 			 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
3016 			regexp *re = (regexp *)mg->mg_obj;
3017 
3018 			if (!mg->mg_ptr) {
3019 			    char *fptr = "msix";
3020 			    char reflags[6];
3021 			    char ch;
3022 			    int left = 0;
3023 			    int right = 4;
3024                             char need_newline = 0;
3025  			    U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12);
3026 
3027  			    while((ch = *fptr++)) {
3028  				if(reganch & 1) {
3029  				    reflags[left++] = ch;
3030  				}
3031  				else {
3032  				    reflags[right--] = ch;
3033  				}
3034  				reganch >>= 1;
3035  			    }
3036  			    if(left != 4) {
3037  				reflags[left] = '-';
3038  				left = 5;
3039  			    }
3040 
3041 			    mg->mg_len = re->prelen + 4 + left;
3042                             /*
3043                              * If /x was used, we have to worry about a regex
3044                              * ending with a comment later being embedded
3045                              * within another regex. If so, we don't want this
3046                              * regex's "commentization" to leak out to the
3047                              * right part of the enclosing regex, we must cap
3048                              * it with a newline.
3049                              *
3050                              * So, if /x was used, we scan backwards from the
3051                              * end of the regex. If we find a '#' before we
3052                              * find a newline, we need to add a newline
3053                              * ourself. If we find a '\n' first (or if we
3054                              * don't find '#' or '\n'), we don't need to add
3055                              * anything.  -jfriedl
3056                              */
3057                             if (PMf_EXTENDED & re->reganch)
3058                             {
3059                                 char *endptr = re->precomp + re->prelen;
3060                                 while (endptr >= re->precomp)
3061                                 {
3062                                     char c = *(endptr--);
3063                                     if (c == '\n')
3064                                         break; /* don't need another */
3065                                     if (c == '#') {
3066                                         /* we end while in a comment, so we
3067                                            need a newline */
3068                                         mg->mg_len++; /* save space for it */
3069                                         need_newline = 1; /* note to add it */
3070 					break;
3071                                     }
3072                                 }
3073                             }
3074 
3075 			    New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
3076 			    Copy("(?", mg->mg_ptr, 2, char);
3077 			    Copy(reflags, mg->mg_ptr+2, left, char);
3078 			    Copy(":", mg->mg_ptr+left+2, 1, char);
3079 			    Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
3080                             if (need_newline)
3081                                 mg->mg_ptr[mg->mg_len - 2] = '\n';
3082 			    mg->mg_ptr[mg->mg_len - 1] = ')';
3083 			    mg->mg_ptr[mg->mg_len] = 0;
3084 			}
3085 			PL_reginterp_cnt += re->program[0].next_off;
3086 
3087 			if (re->reganch & ROPT_UTF8)
3088 			    SvUTF8_on(origsv);
3089 			else
3090 			    SvUTF8_off(origsv);
3091 			*lp = mg->mg_len;
3092 			return mg->mg_ptr;
3093 		    }
3094 					/* Fall through */
3095 		case SVt_NULL:
3096 		case SVt_IV:
3097 		case SVt_NV:
3098 		case SVt_RV:
3099 		case SVt_PV:
3100 		case SVt_PVIV:
3101 		case SVt_PVNV:
3102 		case SVt_PVBM:	if (SvROK(sv))
3103 				    s = "REF";
3104 				else
3105 				    s = "SCALAR";		break;
3106 		case SVt_PVLV:	s = SvROK(sv) ? "REF"
3107 				/* tied lvalues should appear to be
3108 				 * scalars for backwards compatitbility */
3109 				: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
3110 				    ? "SCALAR" : "LVALUE";	break;
3111 		case SVt_PVAV:	s = "ARRAY";			break;
3112 		case SVt_PVHV:	s = "HASH";			break;
3113 		case SVt_PVCV:	s = "CODE";			break;
3114 		case SVt_PVGV:	s = "GLOB";			break;
3115 		case SVt_PVFM:	s = "FORMAT";			break;
3116 		case SVt_PVIO:	s = "IO";			break;
3117 		default:	s = "UNKNOWN";			break;
3118 		}
3119 		tsv = NEWSV(0,0);
3120 		if (SvOBJECT(sv)) {
3121                     HV *svs = SvSTASH(sv);
3122 		    Perl_sv_setpvf(
3123                         aTHX_ tsv, "%s=%s",
3124                         /* [20011101.072] This bandaid for C<package;>
3125                            should eventually be removed. AMS 20011103 */
3126                         (svs ? HvNAME(svs) : "<none>"), s
3127                     );
3128                 }
3129 		else
3130 		    sv_setpv(tsv, s);
3131 		Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
3132 		goto tokensaveref;
3133 	    }
3134 	    *lp = strlen(s);
3135 	    return s;
3136 	}
3137 	if (SvREADONLY(sv) && !SvOK(sv)) {
3138 	    if (ckWARN(WARN_UNINITIALIZED))
3139 		report_uninit();
3140 	    *lp = 0;
3141 	    return "";
3142 	}
3143     }
3144     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
3145 	/* I'm assuming that if both IV and NV are equally valid then
3146 	   converting the IV is going to be more efficient */
3147 	U32 isIOK = SvIOK(sv);
3148 	U32 isUIOK = SvIsUV(sv);
3149 	char buf[TYPE_CHARS(UV)];
3150 	char *ebuf, *ptr;
3151 
3152 	if (SvTYPE(sv) < SVt_PVIV)
3153 	    sv_upgrade(sv, SVt_PVIV);
3154 	if (isUIOK)
3155 	    ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
3156 	else
3157 	    ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
3158 	SvGROW(sv, (STRLEN)(ebuf - ptr + 1));	/* inlined from sv_setpvn */
3159 	Move(ptr,SvPVX(sv),ebuf - ptr,char);
3160 	SvCUR_set(sv, ebuf - ptr);
3161 	s = SvEND(sv);
3162 	*s = '\0';
3163 	if (isIOK)
3164 	    SvIOK_on(sv);
3165 	else
3166 	    SvIOKp_on(sv);
3167 	if (isUIOK)
3168 	    SvIsUV_on(sv);
3169     }
3170     else if (SvNOKp(sv)) {
3171 	if (SvTYPE(sv) < SVt_PVNV)
3172 	    sv_upgrade(sv, SVt_PVNV);
3173 	/* The +20 is pure guesswork.  Configure test needed. --jhi */
3174 	SvGROW(sv, NV_DIG + 20);
3175 	s = SvPVX(sv);
3176 	olderrno = errno;	/* some Xenix systems wipe out errno here */
3177 #ifdef apollo
3178 	if (SvNVX(sv) == 0.0)
3179 	    (void)strcpy(s,"0");
3180 	else
3181 #endif /*apollo*/
3182 	{
3183 	    Gconvert(SvNVX(sv), NV_DIG, 0, s);
3184 	}
3185 	errno = olderrno;
3186 #ifdef FIXNEGATIVEZERO
3187         if (*s == '-' && s[1] == '0' && !s[2])
3188 	    strcpy(s,"0");
3189 #endif
3190 	while (*s) s++;
3191 #ifdef hcx
3192 	if (s[-1] == '.')
3193 	    *--s = '\0';
3194 #endif
3195     }
3196     else {
3197 	if (ckWARN(WARN_UNINITIALIZED)
3198 	    && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
3199 	    report_uninit();
3200 	*lp = 0;
3201 	if (SvTYPE(sv) < SVt_PV)
3202 	    /* Typically the caller expects that sv_any is not NULL now.  */
3203 	    sv_upgrade(sv, SVt_PV);
3204 	return "";
3205     }
3206     *lp = s - SvPVX(sv);
3207     SvCUR_set(sv, *lp);
3208     SvPOK_on(sv);
3209     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
3210 			  PTR2UV(sv),SvPVX(sv)));
3211     return SvPVX(sv);
3212 
3213   tokensave:
3214     if (SvROK(sv)) {	/* XXX Skip this when sv_pvn_force calls */
3215 	/* Sneaky stuff here */
3216 
3217       tokensaveref:
3218 	if (!tsv)
3219 	    tsv = newSVpv(tmpbuf, 0);
3220 	sv_2mortal(tsv);
3221 	*lp = SvCUR(tsv);
3222 	return SvPVX(tsv);
3223     }
3224     else {
3225 	STRLEN len;
3226 	char *t;
3227 
3228 	if (tsv) {
3229 	    sv_2mortal(tsv);
3230 	    t = SvPVX(tsv);
3231 	    len = SvCUR(tsv);
3232 	}
3233 	else {
3234 	    t = tmpbuf;
3235 	    len = strlen(tmpbuf);
3236 	}
3237 #ifdef FIXNEGATIVEZERO
3238 	if (len == 2 && t[0] == '-' && t[1] == '0') {
3239 	    t = "0";
3240 	    len = 1;
3241 	}
3242 #endif
3243 	(void)SvUPGRADE(sv, SVt_PV);
3244 	*lp = len;
3245 	s = SvGROW(sv, len + 1);
3246 	SvCUR_set(sv, len);
3247 	(void)strcpy(s, t);
3248 	SvPOKp_on(sv);
3249 	return s;
3250     }
3251 }
3252 
3253 /*
3254 =for apidoc sv_copypv
3255 
3256 Copies a stringified representation of the source SV into the
3257 destination SV.  Automatically performs any necessary mg_get and
3258 coercion of numeric values into strings.  Guaranteed to preserve
3259 UTF-8 flag even from overloaded objects.  Similar in nature to
3260 sv_2pv[_flags] but operates directly on an SV instead of just the
3261 string.  Mostly uses sv_2pv_flags to do its work, except when that
3262 would lose the UTF-8'ness of the PV.
3263 
3264 =cut
3265 */
3266 
3267 void
Perl_sv_copypv(pTHX_ SV * dsv,register SV * ssv)3268 Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
3269 {
3270     STRLEN len;
3271     char *s;
3272     s = SvPV(ssv,len);
3273     sv_setpvn(dsv,s,len);
3274     if (SvUTF8(ssv))
3275 	SvUTF8_on(dsv);
3276     else
3277 	SvUTF8_off(dsv);
3278 }
3279 
3280 /*
3281 =for apidoc sv_2pvbyte_nolen
3282 
3283 Return a pointer to the byte-encoded representation of the SV.
3284 May cause the SV to be downgraded from UTF-8 as a side-effect.
3285 
3286 Usually accessed via the C<SvPVbyte_nolen> macro.
3287 
3288 =cut
3289 */
3290 
3291 char *
Perl_sv_2pvbyte_nolen(pTHX_ register SV * sv)3292 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
3293 {
3294     STRLEN n_a;
3295     return sv_2pvbyte(sv, &n_a);
3296 }
3297 
3298 /*
3299 =for apidoc sv_2pvbyte
3300 
3301 Return a pointer to the byte-encoded representation of the SV, and set *lp
3302 to its length.  May cause the SV to be downgraded from UTF-8 as a
3303 side-effect.
3304 
3305 Usually accessed via the C<SvPVbyte> macro.
3306 
3307 =cut
3308 */
3309 
3310 char *
Perl_sv_2pvbyte(pTHX_ register SV * sv,STRLEN * lp)3311 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
3312 {
3313     sv_utf8_downgrade(sv,0);
3314     return SvPV(sv,*lp);
3315 }
3316 
3317 /*
3318 =for apidoc sv_2pvutf8_nolen
3319 
3320 Return a pointer to the UTF-8-encoded representation of the SV.
3321 May cause the SV to be upgraded to UTF-8 as a side-effect.
3322 
3323 Usually accessed via the C<SvPVutf8_nolen> macro.
3324 
3325 =cut
3326 */
3327 
3328 char *
Perl_sv_2pvutf8_nolen(pTHX_ register SV * sv)3329 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
3330 {
3331     STRLEN n_a;
3332     return sv_2pvutf8(sv, &n_a);
3333 }
3334 
3335 /*
3336 =for apidoc sv_2pvutf8
3337 
3338 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
3339 to its length.  May cause the SV to be upgraded to UTF-8 as a side-effect.
3340 
3341 Usually accessed via the C<SvPVutf8> macro.
3342 
3343 =cut
3344 */
3345 
3346 char *
Perl_sv_2pvutf8(pTHX_ register SV * sv,STRLEN * lp)3347 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
3348 {
3349     sv_utf8_upgrade(sv);
3350     return SvPV(sv,*lp);
3351 }
3352 
3353 /*
3354 =for apidoc sv_2bool
3355 
3356 This function is only called on magical items, and is only used by
3357 sv_true() or its macro equivalent.
3358 
3359 =cut
3360 */
3361 
3362 bool
Perl_sv_2bool(pTHX_ register SV * sv)3363 Perl_sv_2bool(pTHX_ register SV *sv)
3364 {
3365     if (SvGMAGICAL(sv))
3366 	mg_get(sv);
3367 
3368     if (!SvOK(sv))
3369 	return 0;
3370     if (SvROK(sv)) {
3371 	SV* tmpsv;
3372         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
3373                 (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
3374 	    return (bool)SvTRUE(tmpsv);
3375       return SvRV(sv) != 0;
3376     }
3377     if (SvPOKp(sv)) {
3378 	register XPV* Xpvtmp;
3379 	if ((Xpvtmp = (XPV*)SvANY(sv)) &&
3380 		(*Xpvtmp->xpv_pv > '0' ||
3381 		Xpvtmp->xpv_cur > 1 ||
3382 		(Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
3383 	    return 1;
3384 	else
3385 	    return 0;
3386     }
3387     else {
3388 	if (SvIOKp(sv))
3389 	    return SvIVX(sv) != 0;
3390 	else {
3391 	    if (SvNOKp(sv))
3392 		return SvNVX(sv) != 0.0;
3393 	    else
3394 		return FALSE;
3395 	}
3396     }
3397 }
3398 
3399 /* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
3400  * this function provided for binary compatibility only
3401  */
3402 
3403 
3404 STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV * sv)3405 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
3406 {
3407     return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3408 }
3409 
3410 /*
3411 =for apidoc sv_utf8_upgrade
3412 
3413 Convert the PV of an SV to its UTF-8-encoded form.
3414 Forces the SV to string form if it is not already.
3415 Always sets the SvUTF8 flag to avoid future validity checks even
3416 if all the bytes have hibit clear.
3417 
3418 This is not as a general purpose byte encoding to Unicode interface:
3419 use the Encode extension for that.
3420 
3421 =for apidoc sv_utf8_upgrade_flags
3422 
3423 Convert the PV of an SV to its UTF-8-encoded form.
3424 Forces the SV to string form if it is not already.
3425 Always sets the SvUTF8 flag to avoid future validity checks even
3426 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3427 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3428 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3429 
3430 This is not as a general purpose byte encoding to Unicode interface:
3431 use the Encode extension for that.
3432 
3433 =cut
3434 */
3435 
3436 STRLEN
Perl_sv_utf8_upgrade_flags(pTHX_ register SV * sv,I32 flags)3437 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3438 {
3439     U8 *s, *t, *e;
3440     int  hibit = 0;
3441 
3442     if (!sv)
3443 	return 0;
3444 
3445     if (!SvPOK(sv)) {
3446 	STRLEN len = 0;
3447 	(void) sv_2pv_flags(sv,&len, flags);
3448 	if (!SvPOK(sv))
3449 	     return len;
3450     }
3451 
3452     if (SvUTF8(sv))
3453 	return SvCUR(sv);
3454 
3455     if (SvREADONLY(sv) && SvFAKE(sv)) {
3456 	sv_force_normal(sv);
3457     }
3458 
3459     if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
3460         sv_recode_to_utf8(sv, PL_encoding);
3461     else { /* Assume Latin-1/EBCDIC */
3462 	 /* This function could be much more efficient if we
3463 	  * had a FLAG in SVs to signal if there are any hibit
3464 	  * chars in the PV.  Given that there isn't such a flag
3465 	  * make the loop as fast as possible. */
3466 	 s = (U8 *) SvPVX(sv);
3467 	 e = (U8 *) SvEND(sv);
3468 	 t = s;
3469 	 while (t < e) {
3470 	      U8 ch = *t++;
3471 	      if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3472 		   break;
3473 	 }
3474 	 if (hibit) {
3475 	      STRLEN len;
3476 	      (void)SvOOK_off(sv);
3477 	      s = (U8*)SvPVX(sv);
3478 	      len = SvCUR(sv) + 1; /* Plus the \0 */
3479 	      SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3480 	      SvCUR(sv) = len - 1;
3481 	      if (SvLEN(sv) != 0)
3482 		   Safefree(s); /* No longer using what was there before. */
3483 	      SvLEN(sv) = len; /* No longer know the real size. */
3484 	 }
3485 	 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3486 	 SvUTF8_on(sv);
3487     }
3488     return SvCUR(sv);
3489 }
3490 
3491 /*
3492 =for apidoc sv_utf8_downgrade
3493 
3494 Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
3495 This may not be possible if the PV contains non-byte encoding characters;
3496 if this is the case, either returns false or, if C<fail_ok> is not
3497 true, croaks.
3498 
3499 This is not as a general purpose Unicode to byte encoding interface:
3500 use the Encode extension for that.
3501 
3502 =cut
3503 */
3504 
3505 bool
Perl_sv_utf8_downgrade(pTHX_ register SV * sv,bool fail_ok)3506 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3507 {
3508     if (SvPOK(sv) && SvUTF8(sv)) {
3509         if (SvCUR(sv)) {
3510 	    U8 *s;
3511 	    STRLEN len;
3512 
3513 	    if (SvREADONLY(sv) && SvFAKE(sv))
3514 		sv_force_normal(sv);
3515 	    s = (U8 *) SvPV(sv, len);
3516 	    if (!utf8_to_bytes(s, &len)) {
3517 	        if (fail_ok)
3518 		    return FALSE;
3519 		else {
3520 		    if (PL_op)
3521 		        Perl_croak(aTHX_ "Wide character in %s",
3522 				   OP_DESC(PL_op));
3523 		    else
3524 		        Perl_croak(aTHX_ "Wide character");
3525 		}
3526 	    }
3527 	    SvCUR(sv) = len;
3528 	}
3529     }
3530     SvUTF8_off(sv);
3531     return TRUE;
3532 }
3533 
3534 /*
3535 =for apidoc sv_utf8_encode
3536 
3537 Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
3538 flag so that it looks like octets again. Used as a building block
3539 for encode_utf8 in Encode.xs
3540 
3541 =cut
3542 */
3543 
3544 void
Perl_sv_utf8_encode(pTHX_ register SV * sv)3545 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3546 {
3547     (void) sv_utf8_upgrade(sv);
3548     if (SvIsCOW(sv)) {
3549         sv_force_normal_flags(sv, 0);
3550     }
3551     if (SvREADONLY(sv)) {
3552 	Perl_croak(aTHX_ PL_no_modify);
3553     }
3554     SvUTF8_off(sv);
3555 }
3556 
3557 /*
3558 =for apidoc sv_utf8_decode
3559 
3560 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3561 turn off SvUTF8 if needed so that we see characters. Used as a building block
3562 for decode_utf8 in Encode.xs
3563 
3564 =cut
3565 */
3566 
3567 bool
Perl_sv_utf8_decode(pTHX_ register SV * sv)3568 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3569 {
3570     if (SvPOK(sv)) {
3571         U8 *c;
3572         U8 *e;
3573 
3574 	/* The octets may have got themselves encoded - get them back as
3575 	 * bytes
3576 	 */
3577 	if (!sv_utf8_downgrade(sv, TRUE))
3578 	    return FALSE;
3579 
3580         /* it is actually just a matter of turning the utf8 flag on, but
3581          * we want to make sure everything inside is valid utf8 first.
3582          */
3583         c = (U8 *) SvPVX(sv);
3584 	if (!is_utf8_string(c, SvCUR(sv)+1))
3585 	    return FALSE;
3586         e = (U8 *) SvEND(sv);
3587         while (c < e) {
3588 	    U8 ch = *c++;
3589             if (!UTF8_IS_INVARIANT(ch)) {
3590 		SvUTF8_on(sv);
3591 		break;
3592 	    }
3593         }
3594     }
3595     return TRUE;
3596 }
3597 
3598 /* sv_setsv() is now a macro using Perl_sv_setsv_flags();
3599  * this function provided for binary compatibility only
3600  */
3601 
3602 void
Perl_sv_setsv(pTHX_ SV * dstr,register SV * sstr)3603 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3604 {
3605     sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3606 }
3607 
3608 /*
3609 =for apidoc sv_setsv
3610 
3611 Copies the contents of the source SV C<ssv> into the destination SV
3612 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3613 function if the source SV needs to be reused. Does not handle 'set' magic.
3614 Loosely speaking, it performs a copy-by-value, obliterating any previous
3615 content of the destination.
3616 
3617 You probably want to use one of the assortment of wrappers, such as
3618 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3619 C<SvSetMagicSV_nosteal>.
3620 
3621 =for apidoc sv_setsv_flags
3622 
3623 Copies the contents of the source SV C<ssv> into the destination SV
3624 C<dsv>.  The source SV may be destroyed if it is mortal, so don't use this
3625 function if the source SV needs to be reused. Does not handle 'set' magic.
3626 Loosely speaking, it performs a copy-by-value, obliterating any previous
3627 content of the destination.
3628 If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
3629 C<ssv> if appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are
3630 implemented in terms of this function.
3631 
3632 You probably want to use one of the assortment of wrappers, such as
3633 C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
3634 C<SvSetMagicSV_nosteal>.
3635 
3636 This is the primary function for copying scalars, and most other
3637 copy-ish functions and macros use this underneath.
3638 
3639 =cut
3640 */
3641 
3642 void
Perl_sv_setsv_flags(pTHX_ SV * dstr,register SV * sstr,I32 flags)3643 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3644 {
3645     register U32 sflags;
3646     register int dtype;
3647     register int stype;
3648 
3649     if (sstr == dstr)
3650 	return;
3651     SV_CHECK_THINKFIRST(dstr);
3652     if (!sstr)
3653 	sstr = &PL_sv_undef;
3654     stype = SvTYPE(sstr);
3655     dtype = SvTYPE(dstr);
3656 
3657     SvAMAGIC_off(dstr);
3658     if ( SvVOK(dstr) )
3659     {
3660 	/* need to nuke the magic */
3661 	mg_free(dstr);
3662 	SvRMAGICAL_off(dstr);
3663     }
3664 
3665     /* There's a lot of redundancy below but we're going for speed here */
3666 
3667     switch (stype) {
3668     case SVt_NULL:
3669       undef_sstr:
3670 	if (dtype != SVt_PVGV) {
3671 	    (void)SvOK_off(dstr);
3672 	    return;
3673 	}
3674 	break;
3675     case SVt_IV:
3676 	if (SvIOK(sstr)) {
3677 	    switch (dtype) {
3678 	    case SVt_NULL:
3679 		sv_upgrade(dstr, SVt_IV);
3680 		break;
3681 	    case SVt_NV:
3682 		sv_upgrade(dstr, SVt_PVNV);
3683 		break;
3684 	    case SVt_RV:
3685 	    case SVt_PV:
3686 		sv_upgrade(dstr, SVt_PVIV);
3687 		break;
3688 	    }
3689 	    (void)SvIOK_only(dstr);
3690 	    SvIVX(dstr) = SvIVX(sstr);
3691 	    if (SvIsUV(sstr))
3692 		SvIsUV_on(dstr);
3693 	    if (SvTAINTED(sstr))
3694 		SvTAINT(dstr);
3695 	    return;
3696 	}
3697 	goto undef_sstr;
3698 
3699     case SVt_NV:
3700 	if (SvNOK(sstr)) {
3701 	    switch (dtype) {
3702 	    case SVt_NULL:
3703 	    case SVt_IV:
3704 		sv_upgrade(dstr, SVt_NV);
3705 		break;
3706 	    case SVt_RV:
3707 	    case SVt_PV:
3708 	    case SVt_PVIV:
3709 		sv_upgrade(dstr, SVt_PVNV);
3710 		break;
3711 	    }
3712 	    SvNVX(dstr) = SvNVX(sstr);
3713 	    (void)SvNOK_only(dstr);
3714 	    if (SvTAINTED(sstr))
3715 		SvTAINT(dstr);
3716 	    return;
3717 	}
3718 	goto undef_sstr;
3719 
3720     case SVt_RV:
3721 	if (dtype < SVt_RV)
3722 	    sv_upgrade(dstr, SVt_RV);
3723 	else if (dtype == SVt_PVGV &&
3724 		 SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3725 	    sstr = SvRV(sstr);
3726 	    if (sstr == dstr) {
3727 		if (GvIMPORTED(dstr) != GVf_IMPORTED
3728 		    && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3729 		{
3730 		    GvIMPORTED_on(dstr);
3731 		}
3732 		GvMULTI_on(dstr);
3733 		return;
3734 	    }
3735 	    goto glob_assign;
3736 	}
3737 	break;
3738     case SVt_PV:
3739     case SVt_PVFM:
3740 	if (dtype < SVt_PV)
3741 	    sv_upgrade(dstr, SVt_PV);
3742 	break;
3743     case SVt_PVIV:
3744 	if (dtype < SVt_PVIV)
3745 	    sv_upgrade(dstr, SVt_PVIV);
3746 	break;
3747     case SVt_PVNV:
3748 	if (dtype < SVt_PVNV)
3749 	    sv_upgrade(dstr, SVt_PVNV);
3750 	break;
3751     case SVt_PVAV:
3752     case SVt_PVHV:
3753     case SVt_PVCV:
3754     case SVt_PVIO:
3755 	if (PL_op)
3756 	    Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3757 		OP_NAME(PL_op));
3758 	else
3759 	    Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3760 	break;
3761 
3762     case SVt_PVGV:
3763 	if (dtype <= SVt_PVGV) {
3764   glob_assign:
3765 	    if (dtype != SVt_PVGV) {
3766 		char *name = GvNAME(sstr);
3767 		STRLEN len = GvNAMELEN(sstr);
3768 		sv_upgrade(dstr, SVt_PVGV);
3769 		sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3770 		GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3771 		GvNAME(dstr) = savepvn(name, len);
3772 		GvNAMELEN(dstr) = len;
3773 		SvFAKE_on(dstr);	/* can coerce to non-glob */
3774 	    }
3775 	    /* ahem, death to those who redefine active sort subs */
3776 	    else if (PL_curstackinfo->si_type == PERLSI_SORT
3777 		     && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3778 		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3779 		      GvNAME(dstr));
3780 
3781 #ifdef GV_UNIQUE_CHECK
3782                 if (GvUNIQUE((GV*)dstr)) {
3783                     Perl_croak(aTHX_ PL_no_modify);
3784                 }
3785 #endif
3786 
3787 	    (void)SvOK_off(dstr);
3788 	    GvINTRO_off(dstr);		/* one-shot flag */
3789 	    gp_free((GV*)dstr);
3790 	    GvGP(dstr) = gp_ref(GvGP(sstr));
3791 	    if (SvTAINTED(sstr))
3792 		SvTAINT(dstr);
3793 	    if (GvIMPORTED(dstr) != GVf_IMPORTED
3794 		&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3795 	    {
3796 		GvIMPORTED_on(dstr);
3797 	    }
3798 	    GvMULTI_on(dstr);
3799 	    return;
3800 	}
3801 	/* FALL THROUGH */
3802 
3803     default:
3804 	if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3805 	    mg_get(sstr);
3806 	    if ((int)SvTYPE(sstr) != stype) {
3807 		stype = SvTYPE(sstr);
3808 		if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3809 		    goto glob_assign;
3810 	    }
3811 	}
3812 	if (stype == SVt_PVLV)
3813 	    (void)SvUPGRADE(dstr, SVt_PVNV);
3814 	else
3815 	    (void)SvUPGRADE(dstr, (U32)stype);
3816     }
3817 
3818     sflags = SvFLAGS(sstr);
3819 
3820     if (sflags & SVf_ROK) {
3821 	if (dtype >= SVt_PV) {
3822 	    if (dtype == SVt_PVGV) {
3823 		SV *sref = SvREFCNT_inc(SvRV(sstr));
3824 		SV *dref = 0;
3825 		int intro = GvINTRO(dstr);
3826 
3827 #ifdef GV_UNIQUE_CHECK
3828                 if (GvUNIQUE((GV*)dstr)) {
3829                     Perl_croak(aTHX_ PL_no_modify);
3830                 }
3831 #endif
3832 
3833 		if (intro) {
3834 		    GvINTRO_off(dstr);	/* one-shot flag */
3835 		    GvLINE(dstr) = CopLINE(PL_curcop);
3836 		    GvEGV(dstr) = (GV*)dstr;
3837 		}
3838 		GvMULTI_on(dstr);
3839 		switch (SvTYPE(sref)) {
3840 		case SVt_PVAV:
3841 		    if (intro)
3842 			SAVEGENERICSV(GvAV(dstr));
3843 		    else
3844 			dref = (SV*)GvAV(dstr);
3845 		    GvAV(dstr) = (AV*)sref;
3846 		    if (!GvIMPORTED_AV(dstr)
3847 			&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3848 		    {
3849 			GvIMPORTED_AV_on(dstr);
3850 		    }
3851 		    break;
3852 		case SVt_PVHV:
3853 		    if (intro)
3854 			SAVEGENERICSV(GvHV(dstr));
3855 		    else
3856 			dref = (SV*)GvHV(dstr);
3857 		    GvHV(dstr) = (HV*)sref;
3858 		    if (!GvIMPORTED_HV(dstr)
3859 			&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3860 		    {
3861 			GvIMPORTED_HV_on(dstr);
3862 		    }
3863 		    break;
3864 		case SVt_PVCV:
3865 		    if (intro) {
3866 			if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3867 			    SvREFCNT_dec(GvCV(dstr));
3868 			    GvCV(dstr) = Nullcv;
3869 			    GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3870 			    PL_sub_generation++;
3871 			}
3872 			SAVEGENERICSV(GvCV(dstr));
3873 		    }
3874 		    else
3875 			dref = (SV*)GvCV(dstr);
3876 		    if (GvCV(dstr) != (CV*)sref) {
3877 			CV* cv = GvCV(dstr);
3878 			if (cv) {
3879 			    if (!GvCVGEN((GV*)dstr) &&
3880 				(CvROOT(cv) || CvXSUB(cv)))
3881 			    {
3882 				/* ahem, death to those who redefine
3883 				 * active sort subs */
3884 				if (PL_curstackinfo->si_type == PERLSI_SORT &&
3885 				      PL_sortcop == CvSTART(cv))
3886 				    Perl_croak(aTHX_
3887 				    "Can't redefine active sort subroutine %s",
3888 					  GvENAME((GV*)dstr));
3889  				/* Redefining a sub - warning is mandatory if
3890  				   it was a const and its value changed. */
3891  				if (ckWARN(WARN_REDEFINE)
3892  				    || (CvCONST(cv)
3893  					&& (!CvCONST((CV*)sref)
3894  					    || sv_cmp(cv_const_sv(cv),
3895  						      cv_const_sv((CV*)sref)))))
3896  				{
3897  				    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
3898  					CvCONST(cv)
3899  					? "Constant subroutine %s::%s redefined"
3900  					: "Subroutine %s::%s redefined",
3901 					HvNAME(GvSTASH((GV*)dstr)),
3902  					GvENAME((GV*)dstr));
3903  				}
3904 			    }
3905 			    if (!intro)
3906 				cv_ckproto(cv, (GV*)dstr,
3907 					SvPOK(sref) ? SvPVX(sref) : Nullch);
3908 			}
3909 			GvCV(dstr) = (CV*)sref;
3910 			GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3911 			GvASSUMECV_on(dstr);
3912 			PL_sub_generation++;
3913 		    }
3914 		    if (!GvIMPORTED_CV(dstr)
3915 			&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3916 		    {
3917 			GvIMPORTED_CV_on(dstr);
3918 		    }
3919 		    break;
3920 		case SVt_PVIO:
3921 		    if (intro)
3922 			SAVEGENERICSV(GvIOp(dstr));
3923 		    else
3924 			dref = (SV*)GvIOp(dstr);
3925 		    GvIOp(dstr) = (IO*)sref;
3926 		    break;
3927 		case SVt_PVFM:
3928 		    if (intro)
3929 			SAVEGENERICSV(GvFORM(dstr));
3930 		    else
3931 			dref = (SV*)GvFORM(dstr);
3932 		    GvFORM(dstr) = (CV*)sref;
3933 		    break;
3934 		default:
3935 		    if (intro)
3936 			SAVEGENERICSV(GvSV(dstr));
3937 		    else
3938 			dref = (SV*)GvSV(dstr);
3939 		    GvSV(dstr) = sref;
3940 		    if (!GvIMPORTED_SV(dstr)
3941 			&& CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3942 		    {
3943 			GvIMPORTED_SV_on(dstr);
3944 		    }
3945 		    break;
3946 		}
3947 		if (dref)
3948 		    SvREFCNT_dec(dref);
3949 		if (SvTAINTED(sstr))
3950 		    SvTAINT(dstr);
3951 		return;
3952 	    }
3953 	    if (SvPVX(dstr)) {
3954 		(void)SvOOK_off(dstr);		/* backoff */
3955 		if (SvLEN(dstr))
3956 		    Safefree(SvPVX(dstr));
3957 		SvLEN(dstr)=SvCUR(dstr)=0;
3958 	    }
3959 	}
3960 	(void)SvOK_off(dstr);
3961 	SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3962 	SvROK_on(dstr);
3963 	if (sflags & SVp_NOK) {
3964 	    SvNOKp_on(dstr);
3965 	    /* Only set the public OK flag if the source has public OK.  */
3966 	    if (sflags & SVf_NOK)
3967 		SvFLAGS(dstr) |= SVf_NOK;
3968 	    SvNVX(dstr) = SvNVX(sstr);
3969 	}
3970 	if (sflags & SVp_IOK) {
3971 	    (void)SvIOKp_on(dstr);
3972 	    if (sflags & SVf_IOK)
3973 		SvFLAGS(dstr) |= SVf_IOK;
3974 	    if (sflags & SVf_IVisUV)
3975 		SvIsUV_on(dstr);
3976 	    SvIVX(dstr) = SvIVX(sstr);
3977 	}
3978 	if (SvAMAGIC(sstr)) {
3979 	    SvAMAGIC_on(dstr);
3980 	}
3981     }
3982     else if (sflags & SVp_POK) {
3983 
3984 	/*
3985 	 * Check to see if we can just swipe the string.  If so, it's a
3986 	 * possible small lose on short strings, but a big win on long ones.
3987 	 * It might even be a win on short strings if SvPVX(dstr)
3988 	 * has to be allocated and SvPVX(sstr) has to be freed.
3989 	 */
3990 
3991 	if (SvTEMP(sstr) &&		/* slated for free anyway? */
3992 	    SvREFCNT(sstr) == 1 && 	/* and no other references to it? */
3993 	    !(sflags & SVf_OOK) && 	/* and not involved in OOK hack? */
3994 	    SvLEN(sstr) 	&&	/* and really is a string */
3995 	    			/* and won't be needed again, potentially */
3996 	    !(PL_op && PL_op->op_type == OP_AASSIGN))
3997 	{
3998 	    if (SvPVX(dstr)) {		/* we know that dtype >= SVt_PV */
3999 		if (SvOOK(dstr)) {
4000 		    SvFLAGS(dstr) &= ~SVf_OOK;
4001 		    Safefree(SvPVX(dstr) - SvIVX(dstr));
4002 		}
4003 		else if (SvLEN(dstr))
4004 		    Safefree(SvPVX(dstr));
4005 	    }
4006 	    (void)SvPOK_only(dstr);
4007 	    SvPV_set(dstr, SvPVX(sstr));
4008 	    SvLEN_set(dstr, SvLEN(sstr));
4009 	    SvCUR_set(dstr, SvCUR(sstr));
4010 
4011 	    SvTEMP_off(dstr);
4012 	    (void)SvOK_off(sstr);	/* NOTE: nukes most SvFLAGS on sstr */
4013 	    SvPV_set(sstr, Nullch);
4014 	    SvLEN_set(sstr, 0);
4015 	    SvCUR_set(sstr, 0);
4016 	    SvTEMP_off(sstr);
4017 	}
4018 	else {				/* have to copy actual string */
4019 	    STRLEN len = SvCUR(sstr);
4020 	    SvGROW(dstr, len + 1);	/* inlined from sv_setpvn */
4021 	    Move(SvPVX(sstr),SvPVX(dstr),len,char);
4022 	    SvCUR_set(dstr, len);
4023 	    *SvEND(dstr) = '\0';
4024 	    (void)SvPOK_only(dstr);
4025 	}
4026 	if (sflags & SVf_UTF8)
4027 	    SvUTF8_on(dstr);
4028 	/*SUPPRESS 560*/
4029 	if (sflags & SVp_NOK) {
4030 	    SvNOKp_on(dstr);
4031 	    if (sflags & SVf_NOK)
4032 		SvFLAGS(dstr) |= SVf_NOK;
4033 	    SvNVX(dstr) = SvNVX(sstr);
4034 	}
4035 	if (sflags & SVp_IOK) {
4036 	    (void)SvIOKp_on(dstr);
4037 	    if (sflags & SVf_IOK)
4038 		SvFLAGS(dstr) |= SVf_IOK;
4039 	    if (sflags & SVf_IVisUV)
4040 		SvIsUV_on(dstr);
4041 	    SvIVX(dstr) = SvIVX(sstr);
4042 	}
4043 	if ( SvVOK(sstr) ) {
4044 	    MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
4045 	    sv_magic(dstr, NULL, PERL_MAGIC_vstring,
4046 		     smg->mg_ptr, smg->mg_len);
4047 	    SvRMAGICAL_on(dstr);
4048 	}
4049     }
4050     else if (sflags & SVp_IOK) {
4051 	if (sflags & SVf_IOK)
4052 	    (void)SvIOK_only(dstr);
4053 	else {
4054 	    (void)SvOK_off(dstr);
4055 	    (void)SvIOKp_on(dstr);
4056 	}
4057 	/* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
4058 	if (sflags & SVf_IVisUV)
4059 	    SvIsUV_on(dstr);
4060 	SvIVX(dstr) = SvIVX(sstr);
4061 	if (sflags & SVp_NOK) {
4062 	    if (sflags & SVf_NOK)
4063 		(void)SvNOK_on(dstr);
4064 	    else
4065 		(void)SvNOKp_on(dstr);
4066 	    SvNVX(dstr) = SvNVX(sstr);
4067 	}
4068     }
4069     else if (sflags & SVp_NOK) {
4070 	if (sflags & SVf_NOK)
4071 	    (void)SvNOK_only(dstr);
4072 	else {
4073 	    (void)SvOK_off(dstr);
4074 	    SvNOKp_on(dstr);
4075 	}
4076 	SvNVX(dstr) = SvNVX(sstr);
4077     }
4078     else {
4079 	if (dtype == SVt_PVGV) {
4080 	    if (ckWARN(WARN_MISC))
4081 		Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
4082 	}
4083 	else
4084 	    (void)SvOK_off(dstr);
4085     }
4086     if (SvTAINTED(sstr))
4087 	SvTAINT(dstr);
4088 }
4089 
4090 /*
4091 =for apidoc sv_setsv_mg
4092 
4093 Like C<sv_setsv>, but also handles 'set' magic.
4094 
4095 =cut
4096 */
4097 
4098 void
Perl_sv_setsv_mg(pTHX_ SV * dstr,register SV * sstr)4099 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
4100 {
4101     sv_setsv(dstr,sstr);
4102     SvSETMAGIC(dstr);
4103 }
4104 
4105 /*
4106 =for apidoc sv_setpvn
4107 
4108 Copies a string into an SV.  The C<len> parameter indicates the number of
4109 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
4110 
4111 =cut
4112 */
4113 
4114 void
Perl_sv_setpvn(pTHX_ register SV * sv,register const char * ptr,register STRLEN len)4115 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4116 {
4117     register char *dptr;
4118 
4119     SV_CHECK_THINKFIRST(sv);
4120     if (!ptr) {
4121 	(void)SvOK_off(sv);
4122 	return;
4123     }
4124     else {
4125         /* len is STRLEN which is unsigned, need to copy to signed */
4126 	IV iv = len;
4127 	if (iv < 0)
4128 	    Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
4129     }
4130     (void)SvUPGRADE(sv, SVt_PV);
4131 
4132     SvGROW(sv, len + 1);
4133     dptr = SvPVX(sv);
4134     Move(ptr,dptr,len,char);
4135     dptr[len] = '\0';
4136     SvCUR_set(sv, len);
4137     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
4138     SvTAINT(sv);
4139 }
4140 
4141 /*
4142 =for apidoc sv_setpvn_mg
4143 
4144 Like C<sv_setpvn>, but also handles 'set' magic.
4145 
4146 =cut
4147 */
4148 
4149 void
Perl_sv_setpvn_mg(pTHX_ register SV * sv,register const char * ptr,register STRLEN len)4150 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4151 {
4152     sv_setpvn(sv,ptr,len);
4153     SvSETMAGIC(sv);
4154 }
4155 
4156 /*
4157 =for apidoc sv_setpv
4158 
4159 Copies a string into an SV.  The string must be null-terminated.  Does not
4160 handle 'set' magic.  See C<sv_setpv_mg>.
4161 
4162 =cut
4163 */
4164 
4165 void
Perl_sv_setpv(pTHX_ register SV * sv,register const char * ptr)4166 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
4167 {
4168     register STRLEN len;
4169 
4170     SV_CHECK_THINKFIRST(sv);
4171     if (!ptr) {
4172 	(void)SvOK_off(sv);
4173 	return;
4174     }
4175     len = strlen(ptr);
4176     (void)SvUPGRADE(sv, SVt_PV);
4177 
4178     SvGROW(sv, len + 1);
4179     Move(ptr,SvPVX(sv),len+1,char);
4180     SvCUR_set(sv, len);
4181     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
4182     SvTAINT(sv);
4183 }
4184 
4185 /*
4186 =for apidoc sv_setpv_mg
4187 
4188 Like C<sv_setpv>, but also handles 'set' magic.
4189 
4190 =cut
4191 */
4192 
4193 void
Perl_sv_setpv_mg(pTHX_ register SV * sv,register const char * ptr)4194 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
4195 {
4196     sv_setpv(sv,ptr);
4197     SvSETMAGIC(sv);
4198 }
4199 
4200 /*
4201 =for apidoc sv_usepvn
4202 
4203 Tells an SV to use C<ptr> to find its string value.  Normally the string is
4204 stored inside the SV but sv_usepvn allows the SV to use an outside string.
4205 The C<ptr> should point to memory that was allocated by C<malloc>.  The
4206 string length, C<len>, must be supplied.  This function will realloc the
4207 memory pointed to by C<ptr>, so that pointer should not be freed or used by
4208 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
4209 See C<sv_usepvn_mg>.
4210 
4211 =cut
4212 */
4213 
4214 void
Perl_sv_usepvn(pTHX_ register SV * sv,register char * ptr,register STRLEN len)4215 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4216 {
4217     SV_CHECK_THINKFIRST(sv);
4218     (void)SvUPGRADE(sv, SVt_PV);
4219     if (!ptr) {
4220 	(void)SvOK_off(sv);
4221 	return;
4222     }
4223     (void)SvOOK_off(sv);
4224     if (SvPVX(sv) && SvLEN(sv))
4225 	Safefree(SvPVX(sv));
4226     Renew(ptr, len+1, char);
4227     SvPVX(sv) = ptr;
4228     SvCUR_set(sv, len);
4229     SvLEN_set(sv, len+1);
4230     *SvEND(sv) = '\0';
4231     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
4232     SvTAINT(sv);
4233 }
4234 
4235 /*
4236 =for apidoc sv_usepvn_mg
4237 
4238 Like C<sv_usepvn>, but also handles 'set' magic.
4239 
4240 =cut
4241 */
4242 
4243 void
Perl_sv_usepvn_mg(pTHX_ register SV * sv,register char * ptr,register STRLEN len)4244 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
4245 {
4246     sv_usepvn(sv,ptr,len);
4247     SvSETMAGIC(sv);
4248 }
4249 
4250 /*
4251 =for apidoc sv_force_normal_flags
4252 
4253 Undo various types of fakery on an SV: if the PV is a shared string, make
4254 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4255 an xpvmg. The C<flags> parameter gets passed to  C<sv_unref_flags()>
4256 when unrefing. C<sv_force_normal> calls this function with flags set to 0.
4257 
4258 =cut
4259 */
4260 
4261 void
Perl_sv_force_normal_flags(pTHX_ register SV * sv,U32 flags)4262 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
4263 {
4264     if (SvREADONLY(sv)) {
4265 	if (SvFAKE(sv)) {
4266 	    char *pvx = SvPVX(sv);
4267 	    STRLEN len = SvCUR(sv);
4268             U32 hash   = SvUVX(sv);
4269 	    SvFAKE_off(sv);
4270 	    SvREADONLY_off(sv);
4271 	    SvGROW(sv, len + 1);
4272 	    Move(pvx,SvPVX(sv),len,char);
4273 	    *SvEND(sv) = '\0';
4274 	    unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
4275 	}
4276 	else if (IN_PERL_RUNTIME)
4277 	    Perl_croak(aTHX_ PL_no_modify);
4278     }
4279     if (SvROK(sv))
4280 	sv_unref_flags(sv, flags);
4281     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
4282 	sv_unglob(sv);
4283 }
4284 
4285 /*
4286 =for apidoc sv_force_normal
4287 
4288 Undo various types of fakery on an SV: if the PV is a shared string, make
4289 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
4290 an xpvmg. See also C<sv_force_normal_flags>.
4291 
4292 =cut
4293 */
4294 
4295 void
Perl_sv_force_normal(pTHX_ register SV * sv)4296 Perl_sv_force_normal(pTHX_ register SV *sv)
4297 {
4298     sv_force_normal_flags(sv, 0);
4299 }
4300 
4301 /*
4302 =for apidoc sv_chop
4303 
4304 Efficient removal of characters from the beginning of the string buffer.
4305 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
4306 the string buffer.  The C<ptr> becomes the first character of the adjusted
4307 string. Uses the "OOK hack".
4308 Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
4309 refer to the same chunk of data.
4310 
4311 =cut
4312 */
4313 
4314 void
Perl_sv_chop(pTHX_ register SV * sv,register char * ptr)4315 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
4316 {
4317     register STRLEN delta;
4318     if (!ptr || !SvPOKp(sv))
4319 	return;
4320     delta = ptr - SvPVX(sv);
4321     SV_CHECK_THINKFIRST(sv);
4322     if (SvTYPE(sv) < SVt_PVIV)
4323 	sv_upgrade(sv,SVt_PVIV);
4324 
4325     if (!SvOOK(sv)) {
4326 	if (!SvLEN(sv)) { /* make copy of shared string */
4327 	    char *pvx = SvPVX(sv);
4328 	    STRLEN len = SvCUR(sv);
4329 	    SvGROW(sv, len + 1);
4330 	    Move(pvx,SvPVX(sv),len,char);
4331 	    *SvEND(sv) = '\0';
4332 	}
4333 	SvIVX(sv) = 0;
4334 	/* Same SvOOK_on but SvOOK_on does a SvIOK_off
4335 	   and we do that anyway inside the SvNIOK_off
4336 	*/
4337 	SvFLAGS(sv) |= SVf_OOK;
4338     }
4339     SvNIOK_off(sv);
4340     SvLEN(sv) -= delta;
4341     SvCUR(sv) -= delta;
4342     SvPVX(sv) += delta;
4343     SvIVX(sv) += delta;
4344 }
4345 
4346 /* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
4347  * this function provided for binary compatibility only
4348  */
4349 
4350 void
Perl_sv_catpvn(pTHX_ SV * dsv,const char * sstr,STRLEN slen)4351 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
4352 {
4353     sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
4354 }
4355 
4356 /*
4357 =for apidoc sv_catpvn
4358 
4359 Concatenates the string onto the end of the string which is in the SV.  The
4360 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4361 status set, then the bytes appended should be valid UTF-8.
4362 Handles 'get' magic, but not 'set' magic.  See C<sv_catpvn_mg>.
4363 
4364 =for apidoc sv_catpvn_flags
4365 
4366 Concatenates the string onto the end of the string which is in the SV.  The
4367 C<len> indicates number of bytes to copy.  If the SV has the UTF-8
4368 status set, then the bytes appended should be valid UTF-8.
4369 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
4370 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
4371 in terms of this function.
4372 
4373 =cut
4374 */
4375 
4376 void
Perl_sv_catpvn_flags(pTHX_ register SV * dsv,register const char * sstr,register STRLEN slen,I32 flags)4377 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
4378 {
4379     STRLEN dlen;
4380     char *dstr;
4381 
4382     dstr = SvPV_force_flags(dsv, dlen, flags);
4383     SvGROW(dsv, dlen + slen + 1);
4384     if (sstr == dstr)
4385 	sstr = SvPVX(dsv);
4386     Move(sstr, SvPVX(dsv) + dlen, slen, char);
4387     SvCUR(dsv) += slen;
4388     *SvEND(dsv) = '\0';
4389     (void)SvPOK_only_UTF8(dsv);		/* validate pointer */
4390     SvTAINT(dsv);
4391 }
4392 
4393 /*
4394 =for apidoc sv_catpvn_mg
4395 
4396 Like C<sv_catpvn>, but also handles 'set' magic.
4397 
4398 =cut
4399 */
4400 
4401 void
Perl_sv_catpvn_mg(pTHX_ register SV * sv,register const char * ptr,register STRLEN len)4402 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
4403 {
4404     sv_catpvn(sv,ptr,len);
4405     SvSETMAGIC(sv);
4406 }
4407 
4408 /* sv_catsv() is now a macro using Perl_sv_catsv_flags();
4409  * this function provided for binary compatibility only
4410  */
4411 
4412 void
Perl_sv_catsv(pTHX_ SV * dstr,register SV * sstr)4413 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
4414 {
4415     sv_catsv_flags(dstr, sstr, SV_GMAGIC);
4416 }
4417 
4418 /*
4419 =for apidoc sv_catsv
4420 
4421 Concatenates the string from SV C<ssv> onto the end of the string in
4422 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
4423 not 'set' magic.  See C<sv_catsv_mg>.
4424 
4425 =for apidoc sv_catsv_flags
4426 
4427 Concatenates the string from SV C<ssv> onto the end of the string in
4428 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  If C<flags> has C<SV_GMAGIC>
4429 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
4430 and C<sv_catsv_nomg> are implemented in terms of this function.
4431 
4432 =cut */
4433 
4434 void
Perl_sv_catsv_flags(pTHX_ SV * dsv,register SV * ssv,I32 flags)4435 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
4436 {
4437     char *spv;
4438     STRLEN slen;
4439     if (!ssv)
4440 	return;
4441     if ((spv = SvPV(ssv, slen))) {
4442 	/*  sutf8 and dutf8 were type bool, but under USE_ITHREADS,
4443 	    gcc version 2.95.2 20000220 (Debian GNU/Linux) for
4444 	    Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
4445 	    get dutf8 = 0x20000000, (i.e.  SVf_UTF8) even though
4446 	    dsv->sv_flags doesn't have that bit set.
4447 		Andy Dougherty  12 Oct 2001
4448 	*/
4449 	I32 sutf8 = DO_UTF8(ssv);
4450 	I32 dutf8;
4451 
4452 	if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4453 	    mg_get(dsv);
4454 	dutf8 = DO_UTF8(dsv);
4455 
4456 	if (dutf8 != sutf8) {
4457 	    if (dutf8) {
4458 		/* Not modifying source SV, so taking a temporary copy. */
4459 		SV* csv = sv_2mortal(newSVpvn(spv, slen));
4460 
4461 		sv_utf8_upgrade(csv);
4462 		spv = SvPV(csv, slen);
4463 	    }
4464 	    else
4465 		sv_utf8_upgrade_nomg(dsv);
4466 	}
4467 	sv_catpvn_nomg(dsv, spv, slen);
4468     }
4469 }
4470 
4471 /*
4472 =for apidoc sv_catsv_mg
4473 
4474 Like C<sv_catsv>, but also handles 'set' magic.
4475 
4476 =cut
4477 */
4478 
4479 void
Perl_sv_catsv_mg(pTHX_ SV * dsv,register SV * ssv)4480 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4481 {
4482     sv_catsv(dsv,ssv);
4483     SvSETMAGIC(dsv);
4484 }
4485 
4486 /*
4487 =for apidoc sv_catpv
4488 
4489 Concatenates the string onto the end of the string which is in the SV.
4490 If the SV has the UTF-8 status set, then the bytes appended should be
4491 valid UTF-8.  Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
4492 
4493 =cut */
4494 
4495 void
Perl_sv_catpv(pTHX_ register SV * sv,register const char * ptr)4496 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4497 {
4498     register STRLEN len;
4499     STRLEN tlen;
4500     char *junk;
4501 
4502     if (!ptr)
4503 	return;
4504     junk = SvPV_force(sv, tlen);
4505     len = strlen(ptr);
4506     SvGROW(sv, tlen + len + 1);
4507     if (ptr == junk)
4508 	ptr = SvPVX(sv);
4509     Move(ptr,SvPVX(sv)+tlen,len+1,char);
4510     SvCUR(sv) += len;
4511     (void)SvPOK_only_UTF8(sv);		/* validate pointer */
4512     SvTAINT(sv);
4513 }
4514 
4515 /*
4516 =for apidoc sv_catpv_mg
4517 
4518 Like C<sv_catpv>, but also handles 'set' magic.
4519 
4520 =cut
4521 */
4522 
4523 void
Perl_sv_catpv_mg(pTHX_ register SV * sv,register const char * ptr)4524 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4525 {
4526     sv_catpv(sv,ptr);
4527     SvSETMAGIC(sv);
4528 }
4529 
4530 /*
4531 =for apidoc newSV
4532 
4533 Create a new null SV, or if len > 0, create a new empty SVt_PV type SV
4534 with an initial PV allocation of len+1. Normally accessed via the C<NEWSV>
4535 macro.
4536 
4537 =cut
4538 */
4539 
4540 SV *
Perl_newSV(pTHX_ STRLEN len)4541 Perl_newSV(pTHX_ STRLEN len)
4542 {
4543     register SV *sv;
4544 
4545     new_SV(sv);
4546     if (len) {
4547 	sv_upgrade(sv, SVt_PV);
4548 	SvGROW(sv, len + 1);
4549     }
4550     return sv;
4551 }
4552 /*
4553 =for apidoc sv_magicext
4554 
4555 Adds magic to an SV, upgrading it if necessary. Applies the
4556 supplied vtable and returns pointer to the magic added.
4557 
4558 Note that sv_magicext will allow things that sv_magic will not.
4559 In particular you can add magic to SvREADONLY SVs and and more than
4560 one instance of the same 'how'
4561 
4562 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
4563 if C<namelen> is zero then C<name> is stored as-is and - as another special
4564 case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
4565 an C<SV*> and has its REFCNT incremented
4566 
4567 (This is now used as a subroutine by sv_magic.)
4568 
4569 =cut
4570 */
4571 MAGIC *
Perl_sv_magicext(pTHX_ SV * sv,SV * obj,int how,MGVTBL * vtable,const char * name,I32 namlen)4572 Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
4573 		 const char* name, I32 namlen)
4574 {
4575     MAGIC* mg;
4576 
4577     if (SvTYPE(sv) < SVt_PVMG) {
4578 	(void)SvUPGRADE(sv, SVt_PVMG);
4579     }
4580     Newz(702,mg, 1, MAGIC);
4581     mg->mg_moremagic = SvMAGIC(sv);
4582     SvMAGIC(sv) = mg;
4583 
4584     /* Some magic sontains a reference loop, where the sv and object refer to
4585        each other.  To prevent a reference loop that would prevent such
4586        objects being freed, we look for such loops and if we find one we
4587        avoid incrementing the object refcount.
4588 
4589        Note we cannot do this to avoid self-tie loops as intervening RV must
4590        have its REFCNT incremented to keep it in existence.
4591 
4592     */
4593     if (!obj || obj == sv ||
4594 	how == PERL_MAGIC_arylen ||
4595 	how == PERL_MAGIC_qr ||
4596 	(SvTYPE(obj) == SVt_PVGV &&
4597 	    (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4598 	    GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4599 	    GvFORM(obj) == (CV*)sv)))
4600     {
4601 	mg->mg_obj = obj;
4602     }
4603     else {
4604 	mg->mg_obj = SvREFCNT_inc(obj);
4605 	mg->mg_flags |= MGf_REFCOUNTED;
4606     }
4607 
4608     /* Normal self-ties simply pass a null object, and instead of
4609        using mg_obj directly, use the SvTIED_obj macro to produce a
4610        new RV as needed.  For glob "self-ties", we are tieing the PVIO
4611        with an RV obj pointing to the glob containing the PVIO.  In
4612        this case, to avoid a reference loop, we need to weaken the
4613        reference.
4614     */
4615 
4616     if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
4617         obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
4618     {
4619       sv_rvweaken(obj);
4620     }
4621 
4622     mg->mg_type = how;
4623     mg->mg_len = namlen;
4624     if (name) {
4625 	if (namlen > 0)
4626 	    mg->mg_ptr = savepvn(name, namlen);
4627 	else if (namlen == HEf_SVKEY)
4628 	    mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4629 	else
4630 	    mg->mg_ptr = (char *) name;
4631     }
4632     mg->mg_virtual = vtable;
4633 
4634     mg_magical(sv);
4635     if (SvGMAGICAL(sv))
4636 	SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4637     return mg;
4638 }
4639 
4640 /*
4641 =for apidoc sv_magic
4642 
4643 Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
4644 then adds a new magic item of type C<how> to the head of the magic list.
4645 
4646 =cut
4647 */
4648 
4649 void
Perl_sv_magic(pTHX_ register SV * sv,SV * obj,int how,const char * name,I32 namlen)4650 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4651 {
4652     MAGIC* mg;
4653     MGVTBL *vtable = 0;
4654 
4655     if (SvREADONLY(sv)) {
4656 	if (IN_PERL_RUNTIME
4657 	    && how != PERL_MAGIC_regex_global
4658 	    && how != PERL_MAGIC_bm
4659 	    && how != PERL_MAGIC_fm
4660 	    && how != PERL_MAGIC_sv
4661 	    && how != PERL_MAGIC_backref
4662 	   )
4663 	{
4664 	    Perl_croak(aTHX_ PL_no_modify);
4665 	}
4666     }
4667     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4668 	if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4669 	    /* sv_magic() refuses to add a magic of the same 'how' as an
4670 	       existing one
4671 	     */
4672 	    if (how == PERL_MAGIC_taint)
4673 		mg->mg_len |= 1;
4674 	    return;
4675 	}
4676     }
4677 
4678     switch (how) {
4679     case PERL_MAGIC_sv:
4680 	vtable = &PL_vtbl_sv;
4681 	break;
4682     case PERL_MAGIC_overload:
4683         vtable = &PL_vtbl_amagic;
4684         break;
4685     case PERL_MAGIC_overload_elem:
4686         vtable = &PL_vtbl_amagicelem;
4687         break;
4688     case PERL_MAGIC_overload_table:
4689         vtable = &PL_vtbl_ovrld;
4690         break;
4691     case PERL_MAGIC_bm:
4692 	vtable = &PL_vtbl_bm;
4693 	break;
4694     case PERL_MAGIC_regdata:
4695 	vtable = &PL_vtbl_regdata;
4696 	break;
4697     case PERL_MAGIC_regdatum:
4698 	vtable = &PL_vtbl_regdatum;
4699 	break;
4700     case PERL_MAGIC_env:
4701 	vtable = &PL_vtbl_env;
4702 	break;
4703     case PERL_MAGIC_fm:
4704 	vtable = &PL_vtbl_fm;
4705 	break;
4706     case PERL_MAGIC_envelem:
4707 	vtable = &PL_vtbl_envelem;
4708 	break;
4709     case PERL_MAGIC_regex_global:
4710 	vtable = &PL_vtbl_mglob;
4711 	break;
4712     case PERL_MAGIC_isa:
4713 	vtable = &PL_vtbl_isa;
4714 	break;
4715     case PERL_MAGIC_isaelem:
4716 	vtable = &PL_vtbl_isaelem;
4717 	break;
4718     case PERL_MAGIC_nkeys:
4719 	vtable = &PL_vtbl_nkeys;
4720 	break;
4721     case PERL_MAGIC_dbfile:
4722 	vtable = 0;
4723 	break;
4724     case PERL_MAGIC_dbline:
4725 	vtable = &PL_vtbl_dbline;
4726 	break;
4727 #ifdef USE_5005THREADS
4728     case PERL_MAGIC_mutex:
4729 	vtable = &PL_vtbl_mutex;
4730 	break;
4731 #endif /* USE_5005THREADS */
4732 #ifdef USE_LOCALE_COLLATE
4733     case PERL_MAGIC_collxfrm:
4734         vtable = &PL_vtbl_collxfrm;
4735         break;
4736 #endif /* USE_LOCALE_COLLATE */
4737     case PERL_MAGIC_tied:
4738 	vtable = &PL_vtbl_pack;
4739 	break;
4740     case PERL_MAGIC_tiedelem:
4741     case PERL_MAGIC_tiedscalar:
4742 	vtable = &PL_vtbl_packelem;
4743 	break;
4744     case PERL_MAGIC_qr:
4745 	vtable = &PL_vtbl_regexp;
4746 	break;
4747     case PERL_MAGIC_sig:
4748 	vtable = &PL_vtbl_sig;
4749 	break;
4750     case PERL_MAGIC_sigelem:
4751 	vtable = &PL_vtbl_sigelem;
4752 	break;
4753     case PERL_MAGIC_taint:
4754 	vtable = &PL_vtbl_taint;
4755 	break;
4756     case PERL_MAGIC_uvar:
4757 	vtable = &PL_vtbl_uvar;
4758 	break;
4759     case PERL_MAGIC_vec:
4760 	vtable = &PL_vtbl_vec;
4761 	break;
4762     case PERL_MAGIC_vstring:
4763 	vtable = 0;
4764 	break;
4765     case PERL_MAGIC_utf8:
4766         vtable = &PL_vtbl_utf8;
4767         break;
4768     case PERL_MAGIC_substr:
4769 	vtable = &PL_vtbl_substr;
4770 	break;
4771     case PERL_MAGIC_defelem:
4772 	vtable = &PL_vtbl_defelem;
4773 	break;
4774     case PERL_MAGIC_glob:
4775 	vtable = &PL_vtbl_glob;
4776 	break;
4777     case PERL_MAGIC_arylen:
4778 	vtable = &PL_vtbl_arylen;
4779 	break;
4780     case PERL_MAGIC_pos:
4781 	vtable = &PL_vtbl_pos;
4782 	break;
4783     case PERL_MAGIC_backref:
4784 	vtable = &PL_vtbl_backref;
4785 	break;
4786     case PERL_MAGIC_ext:
4787 	/* Reserved for use by extensions not perl internals.	        */
4788 	/* Useful for attaching extension internal data to perl vars.	*/
4789 	/* Note that multiple extensions may clash if magical scalars	*/
4790 	/* etc holding private data from one are passed to another.	*/
4791 	break;
4792     default:
4793 	Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4794     }
4795 
4796     /* Rest of work is done else where */
4797     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
4798 
4799     switch (how) {
4800     case PERL_MAGIC_taint:
4801 	mg->mg_len = 1;
4802 	break;
4803     case PERL_MAGIC_ext:
4804     case PERL_MAGIC_dbfile:
4805 	SvRMAGICAL_on(sv);
4806 	break;
4807     }
4808 }
4809 
4810 /*
4811 =for apidoc sv_unmagic
4812 
4813 Removes all magic of type C<type> from an SV.
4814 
4815 =cut
4816 */
4817 
4818 int
Perl_sv_unmagic(pTHX_ SV * sv,int type)4819 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4820 {
4821     MAGIC* mg;
4822     MAGIC** mgp;
4823     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4824 	return 0;
4825     mgp = &SvMAGIC(sv);
4826     for (mg = *mgp; mg; mg = *mgp) {
4827 	if (mg->mg_type == type) {
4828 	    MGVTBL* vtbl = mg->mg_virtual;
4829 	    *mgp = mg->mg_moremagic;
4830 	    if (vtbl && vtbl->svt_free)
4831 		CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4832 	    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4833 		if (mg->mg_len > 0)
4834 		    Safefree(mg->mg_ptr);
4835 		else if (mg->mg_len == HEf_SVKEY)
4836 		    SvREFCNT_dec((SV*)mg->mg_ptr);
4837 		else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
4838 		    Safefree(mg->mg_ptr);
4839             }
4840 	    if (mg->mg_flags & MGf_REFCOUNTED)
4841 		SvREFCNT_dec(mg->mg_obj);
4842 	    Safefree(mg);
4843 	}
4844 	else
4845 	    mgp = &mg->mg_moremagic;
4846     }
4847     if (!SvMAGIC(sv)) {
4848 	SvMAGICAL_off(sv);
4849        SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4850     }
4851 
4852     return 0;
4853 }
4854 
4855 /*
4856 =for apidoc sv_rvweaken
4857 
4858 Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
4859 referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
4860 push a back-reference to this RV onto the array of backreferences
4861 associated with that magic.
4862 
4863 =cut
4864 */
4865 
4866 SV *
Perl_sv_rvweaken(pTHX_ SV * sv)4867 Perl_sv_rvweaken(pTHX_ SV *sv)
4868 {
4869     SV *tsv;
4870     if (!SvOK(sv))  /* let undefs pass */
4871 	return sv;
4872     if (!SvROK(sv))
4873 	Perl_croak(aTHX_ "Can't weaken a nonreference");
4874     else if (SvWEAKREF(sv)) {
4875 	if (ckWARN(WARN_MISC))
4876 	    Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
4877 	return sv;
4878     }
4879     tsv = SvRV(sv);
4880     sv_add_backref(tsv, sv);
4881     SvWEAKREF_on(sv);
4882     SvREFCNT_dec(tsv);
4883     return sv;
4884 }
4885 
4886 /* Give tsv backref magic if it hasn't already got it, then push a
4887  * back-reference to sv onto the array associated with the backref magic.
4888  */
4889 
4890 STATIC void
S_sv_add_backref(pTHX_ SV * tsv,SV * sv)4891 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4892 {
4893     AV *av;
4894     MAGIC *mg;
4895     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4896 	av = (AV*)mg->mg_obj;
4897     else {
4898 	av = newAV();
4899 	sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4900 	/* av now has a refcnt of 2, which avoids it getting freed
4901 	 * before us during global cleanup. The extra ref is removed
4902 	 * by magic_killbackrefs() when tsv is being freed */
4903     }
4904     if (AvFILLp(av) >= AvMAX(av)) {
4905         SV **svp = AvARRAY(av);
4906         I32 i = AvFILLp(av);
4907         while (i >= 0) {
4908             if (svp[i] == &PL_sv_undef) {
4909                 svp[i] = sv;        /* reuse the slot */
4910                 return;
4911             }
4912             i--;
4913         }
4914         av_extend(av, AvFILLp(av)+1);
4915     }
4916     AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
4917 }
4918 
4919 /* delete a back-reference to ourselves from the backref magic associated
4920  * with the SV we point to.
4921  */
4922 
4923 STATIC void
S_sv_del_backref(pTHX_ SV * sv)4924 S_sv_del_backref(pTHX_ SV *sv)
4925 {
4926     AV *av;
4927     SV **svp;
4928     I32 i;
4929     SV *tsv = SvRV(sv);
4930     MAGIC *mg = NULL;
4931     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4932 	Perl_croak(aTHX_ "panic: del_backref");
4933     av = (AV *)mg->mg_obj;
4934     svp = AvARRAY(av);
4935     i = AvFILLp(av);
4936     while (i >= 0) {
4937 	if (svp[i] == sv) {
4938 	    svp[i] = &PL_sv_undef; /* XXX */
4939 	}
4940 	i--;
4941     }
4942 }
4943 
4944 /*
4945 =for apidoc sv_insert
4946 
4947 Inserts a string at the specified offset/length within the SV. Similar to
4948 the Perl substr() function.
4949 
4950 =cut
4951 */
4952 
4953 void
Perl_sv_insert(pTHX_ SV * bigstr,STRLEN offset,STRLEN len,char * little,STRLEN littlelen)4954 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4955 {
4956     register char *big;
4957     register char *mid;
4958     register char *midend;
4959     register char *bigend;
4960     register I32 i;
4961     STRLEN curlen;
4962 
4963 
4964     if (!bigstr)
4965 	Perl_croak(aTHX_ "Can't modify non-existent substring");
4966     SvPV_force(bigstr, curlen);
4967     (void)SvPOK_only_UTF8(bigstr);
4968     if (offset + len > curlen) {
4969 	SvGROW(bigstr, offset+len+1);
4970 	Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4971 	SvCUR_set(bigstr, offset+len);
4972     }
4973 
4974     SvTAINT(bigstr);
4975     i = littlelen - len;
4976     if (i > 0) {			/* string might grow */
4977 	big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4978 	mid = big + offset + len;
4979 	midend = bigend = big + SvCUR(bigstr);
4980 	bigend += i;
4981 	*bigend = '\0';
4982 	while (midend > mid)		/* shove everything down */
4983 	    *--bigend = *--midend;
4984 	Move(little,big+offset,littlelen,char);
4985 	SvCUR(bigstr) += i;
4986 	SvSETMAGIC(bigstr);
4987 	return;
4988     }
4989     else if (i == 0) {
4990 	Move(little,SvPVX(bigstr)+offset,len,char);
4991 	SvSETMAGIC(bigstr);
4992 	return;
4993     }
4994 
4995     big = SvPVX(bigstr);
4996     mid = big + offset;
4997     midend = mid + len;
4998     bigend = big + SvCUR(bigstr);
4999 
5000     if (midend > bigend)
5001 	Perl_croak(aTHX_ "panic: sv_insert");
5002 
5003     if (mid - big > bigend - midend) {	/* faster to shorten from end */
5004 	if (littlelen) {
5005 	    Move(little, mid, littlelen,char);
5006 	    mid += littlelen;
5007 	}
5008 	i = bigend - midend;
5009 	if (i > 0) {
5010 	    Move(midend, mid, i,char);
5011 	    mid += i;
5012 	}
5013 	*mid = '\0';
5014 	SvCUR_set(bigstr, mid - big);
5015     }
5016     /*SUPPRESS 560*/
5017     else if ((i = mid - big)) {	/* faster from front */
5018 	midend -= littlelen;
5019 	mid = midend;
5020 	sv_chop(bigstr,midend-i);
5021 	big += i;
5022 	while (i--)
5023 	    *--midend = *--big;
5024 	if (littlelen)
5025 	    Move(little, mid, littlelen,char);
5026     }
5027     else if (littlelen) {
5028 	midend -= littlelen;
5029 	sv_chop(bigstr,midend);
5030 	Move(little,midend,littlelen,char);
5031     }
5032     else {
5033 	sv_chop(bigstr,midend);
5034     }
5035     SvSETMAGIC(bigstr);
5036 }
5037 
5038 /*
5039 =for apidoc sv_replace
5040 
5041 Make the first argument a copy of the second, then delete the original.
5042 The target SV physically takes over ownership of the body of the source SV
5043 and inherits its flags; however, the target keeps any magic it owns,
5044 and any magic in the source is discarded.
5045 Note that this is a rather specialist SV copying operation; most of the
5046 time you'll want to use C<sv_setsv> or one of its many macro front-ends.
5047 
5048 =cut
5049 */
5050 
5051 void
Perl_sv_replace(pTHX_ register SV * sv,register SV * nsv)5052 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
5053 {
5054     U32 refcnt = SvREFCNT(sv);
5055     SV_CHECK_THINKFIRST(sv);
5056     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
5057 	Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
5058     if (SvMAGICAL(sv)) {
5059 	if (SvMAGICAL(nsv))
5060 	    mg_free(nsv);
5061 	else
5062 	    sv_upgrade(nsv, SVt_PVMG);
5063 	SvMAGIC(nsv) = SvMAGIC(sv);
5064 	SvFLAGS(nsv) |= SvMAGICAL(sv);
5065 	SvMAGICAL_off(sv);
5066 	SvMAGIC(sv) = 0;
5067     }
5068     SvREFCNT(sv) = 0;
5069     sv_clear(sv);
5070     assert(!SvREFCNT(sv));
5071     StructCopy(nsv,sv,SV);
5072     SvREFCNT(sv) = refcnt;
5073     SvFLAGS(nsv) |= SVTYPEMASK;		/* Mark as freed */
5074     SvREFCNT(nsv) = 0;
5075     del_SV(nsv);
5076 }
5077 
5078 /*
5079 =for apidoc sv_clear
5080 
5081 Clear an SV: call any destructors, free up any memory used by the body,
5082 and free the body itself. The SV's head is I<not> freed, although
5083 its type is set to all 1's so that it won't inadvertently be assumed
5084 to be live during global destruction etc.
5085 This function should only be called when REFCNT is zero. Most of the time
5086 you'll want to call C<sv_free()> (or its macro wrapper C<SvREFCNT_dec>)
5087 instead.
5088 
5089 =cut
5090 */
5091 
5092 void
Perl_sv_clear(pTHX_ register SV * sv)5093 Perl_sv_clear(pTHX_ register SV *sv)
5094 {
5095     HV* stash;
5096     assert(sv);
5097     assert(SvREFCNT(sv) == 0);
5098 
5099     if (SvOBJECT(sv)) {
5100 	if (PL_defstash) {		/* Still have a symbol table? */
5101 	    dSP;
5102 	    CV* destructor;
5103 
5104 
5105 
5106 	    do {
5107 		stash = SvSTASH(sv);
5108 		destructor = StashHANDLER(stash,DESTROY);
5109 		if (destructor) {
5110 		    SV* tmpref = newRV(sv);
5111 	            SvREADONLY_on(tmpref);   /* DESTROY() could be naughty */
5112 		    ENTER;
5113 		    PUSHSTACKi(PERLSI_DESTROY);
5114 		    EXTEND(SP, 2);
5115 		    PUSHMARK(SP);
5116 		    PUSHs(tmpref);
5117 		    PUTBACK;
5118 		    call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
5119 
5120 
5121 		    POPSTACK;
5122 		    SPAGAIN;
5123 		    LEAVE;
5124 		    if(SvREFCNT(tmpref) < 2) {
5125 		        /* tmpref is not kept alive! */
5126 		        SvREFCNT(sv)--;
5127 			SvRV(tmpref) = 0;
5128 			SvROK_off(tmpref);
5129 		    }
5130 		    SvREFCNT_dec(tmpref);
5131 		}
5132 	    } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
5133 
5134 
5135 	    if (SvREFCNT(sv)) {
5136 		if (PL_in_clean_objs)
5137 		    Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
5138 			  HvNAME(stash));
5139 		/* DESTROY gave object new lease on life */
5140 		return;
5141 	    }
5142 	}
5143 
5144 	if (SvOBJECT(sv)) {
5145 	    SvREFCNT_dec(SvSTASH(sv));	/* possibly of changed persuasion */
5146 	    SvOBJECT_off(sv);	/* Curse the object. */
5147 	    if (SvTYPE(sv) != SVt_PVIO)
5148 		--PL_sv_objcount;	/* XXX Might want something more general */
5149 	}
5150     }
5151     if (SvTYPE(sv) >= SVt_PVMG) {
5152     	if (SvMAGIC(sv))
5153 	    mg_free(sv);
5154 	if (SvFLAGS(sv) & SVpad_TYPED)
5155 	    SvREFCNT_dec(SvSTASH(sv));
5156     }
5157     stash = NULL;
5158     switch (SvTYPE(sv)) {
5159     case SVt_PVIO:
5160 	if (IoIFP(sv) &&
5161 	    IoIFP(sv) != PerlIO_stdin() &&
5162 	    IoIFP(sv) != PerlIO_stdout() &&
5163 	    IoIFP(sv) != PerlIO_stderr())
5164 	{
5165 	    io_close((IO*)sv, FALSE);
5166 	}
5167 	if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
5168 	    PerlDir_close(IoDIRP(sv));
5169 	IoDIRP(sv) = (DIR*)NULL;
5170 	Safefree(IoTOP_NAME(sv));
5171 	Safefree(IoFMT_NAME(sv));
5172 	Safefree(IoBOTTOM_NAME(sv));
5173 	/* FALL THROUGH */
5174     case SVt_PVBM:
5175 	goto freescalar;
5176     case SVt_PVCV:
5177     case SVt_PVFM:
5178 	cv_undef((CV*)sv);
5179 	goto freescalar;
5180     case SVt_PVHV:
5181 	hv_undef((HV*)sv);
5182 	break;
5183     case SVt_PVAV:
5184 	av_undef((AV*)sv);
5185 	break;
5186     case SVt_PVLV:
5187 	if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
5188 	    SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
5189 	    HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
5190 	    PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
5191 	}
5192 	else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
5193 	    SvREFCNT_dec(LvTARG(sv));
5194 	goto freescalar;
5195     case SVt_PVGV:
5196 	gp_free((GV*)sv);
5197 	Safefree(GvNAME(sv));
5198 	/* cannot decrease stash refcount yet, as we might recursively delete
5199 	   ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
5200 	   of stash until current sv is completely gone.
5201 	   -- JohnPC, 27 Mar 1998 */
5202 	stash = GvSTASH(sv);
5203 	/* FALL THROUGH */
5204     case SVt_PVMG:
5205     case SVt_PVNV:
5206     case SVt_PVIV:
5207       freescalar:
5208 	(void)SvOOK_off(sv);
5209 	/* FALL THROUGH */
5210     case SVt_PV:
5211     case SVt_RV:
5212 	if (SvROK(sv)) {
5213 	    if (SvWEAKREF(sv))
5214 	        sv_del_backref(sv);
5215 	    else
5216 	        SvREFCNT_dec(SvRV(sv));
5217 	}
5218 	else if (SvPVX(sv) && SvLEN(sv))
5219 	    Safefree(SvPVX(sv));
5220 	else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
5221 	    unsharepvn(SvPVX(sv),
5222 		       SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
5223 		       SvUVX(sv));
5224 	    SvFAKE_off(sv);
5225 	}
5226 	break;
5227 /*
5228     case SVt_NV:
5229     case SVt_IV:
5230     case SVt_NULL:
5231 	break;
5232 */
5233     }
5234 
5235     switch (SvTYPE(sv)) {
5236     case SVt_NULL:
5237 	break;
5238     case SVt_IV:
5239 	del_XIV(SvANY(sv));
5240 	break;
5241     case SVt_NV:
5242 	del_XNV(SvANY(sv));
5243 	break;
5244     case SVt_RV:
5245 	del_XRV(SvANY(sv));
5246 	break;
5247     case SVt_PV:
5248 	del_XPV(SvANY(sv));
5249 	break;
5250     case SVt_PVIV:
5251 	del_XPVIV(SvANY(sv));
5252 	break;
5253     case SVt_PVNV:
5254 	del_XPVNV(SvANY(sv));
5255 	break;
5256     case SVt_PVMG:
5257 	del_XPVMG(SvANY(sv));
5258 	break;
5259     case SVt_PVLV:
5260 	del_XPVLV(SvANY(sv));
5261 	break;
5262     case SVt_PVAV:
5263 	del_XPVAV(SvANY(sv));
5264 	break;
5265     case SVt_PVHV:
5266 	del_XPVHV(SvANY(sv));
5267 	break;
5268     case SVt_PVCV:
5269 	del_XPVCV(SvANY(sv));
5270 	break;
5271     case SVt_PVGV:
5272 	del_XPVGV(SvANY(sv));
5273 	/* code duplication for increased performance. */
5274 	SvFLAGS(sv) &= SVf_BREAK;
5275 	SvFLAGS(sv) |= SVTYPEMASK;
5276 	/* decrease refcount of the stash that owns this GV, if any */
5277 	if (stash)
5278 	    SvREFCNT_dec(stash);
5279 	return; /* not break, SvFLAGS reset already happened */
5280     case SVt_PVBM:
5281 	del_XPVBM(SvANY(sv));
5282 	break;
5283     case SVt_PVFM:
5284 	del_XPVFM(SvANY(sv));
5285 	break;
5286     case SVt_PVIO:
5287 	del_XPVIO(SvANY(sv));
5288 	break;
5289     }
5290     SvFLAGS(sv) &= SVf_BREAK;
5291     SvFLAGS(sv) |= SVTYPEMASK;
5292 }
5293 
5294 /*
5295 =for apidoc sv_newref
5296 
5297 Increment an SV's reference count. Use the C<SvREFCNT_inc()> wrapper
5298 instead.
5299 
5300 =cut
5301 */
5302 
5303 SV *
Perl_sv_newref(pTHX_ SV * sv)5304 Perl_sv_newref(pTHX_ SV *sv)
5305 {
5306     if (sv)
5307 	ATOMIC_INC(SvREFCNT(sv));
5308     return sv;
5309 }
5310 
5311 /*
5312 =for apidoc sv_free
5313 
5314 Decrement an SV's reference count, and if it drops to zero, call
5315 C<sv_clear> to invoke destructors and free up any memory used by
5316 the body; finally, deallocate the SV's head itself.
5317 Normally called via a wrapper macro C<SvREFCNT_dec>.
5318 
5319 =cut
5320 */
5321 
5322 void
Perl_sv_free(pTHX_ SV * sv)5323 Perl_sv_free(pTHX_ SV *sv)
5324 {
5325     int refcount_is_zero;
5326 
5327     if (!sv)
5328 	return;
5329     if (SvREFCNT(sv) == 0) {
5330 	if (SvFLAGS(sv) & SVf_BREAK)
5331 	    /* this SV's refcnt has been artificially decremented to
5332 	     * trigger cleanup */
5333 	    return;
5334 	if (PL_in_clean_all) /* All is fair */
5335 	    return;
5336 	if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5337 	    /* make sure SvREFCNT(sv)==0 happens very seldom */
5338 	    SvREFCNT(sv) = (~(U32)0)/2;
5339 	    return;
5340 	}
5341 	if (ckWARN_d(WARN_INTERNAL))
5342 	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
5343                         "Attempt to free unreferenced scalar: SV 0x%"UVxf,
5344                 PTR2UV(sv));
5345 	return;
5346     }
5347     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
5348     if (!refcount_is_zero)
5349 	return;
5350 #ifdef DEBUGGING
5351     if (SvTEMP(sv)) {
5352 	if (ckWARN_d(WARN_DEBUGGING))
5353 	    Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
5354 			"Attempt to free temp prematurely: SV 0x%"UVxf,
5355 			PTR2UV(sv));
5356 	return;
5357     }
5358 #endif
5359     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
5360 	/* make sure SvREFCNT(sv)==0 happens very seldom */
5361 	SvREFCNT(sv) = (~(U32)0)/2;
5362 	return;
5363     }
5364     sv_clear(sv);
5365     if (! SvREFCNT(sv))
5366 	del_SV(sv);
5367 }
5368 
5369 /*
5370 =for apidoc sv_len
5371 
5372 Returns the length of the string in the SV. Handles magic and type
5373 coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
5374 
5375 =cut
5376 */
5377 
5378 STRLEN
Perl_sv_len(pTHX_ register SV * sv)5379 Perl_sv_len(pTHX_ register SV *sv)
5380 {
5381     STRLEN len;
5382 
5383     if (!sv)
5384 	return 0;
5385 
5386     if (SvGMAGICAL(sv))
5387 	len = mg_length(sv);
5388     else
5389         (void)SvPV(sv, len);
5390     return len;
5391 }
5392 
5393 /*
5394 =for apidoc sv_len_utf8
5395 
5396 Returns the number of characters in the string in an SV, counting wide
5397 UTF-8 bytes as a single character. Handles magic and type coercion.
5398 
5399 =cut
5400 */
5401 
5402 /*
5403  * The length is cached in PERL_UTF8_magic, in the mg_len field.  Also the
5404  * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
5405  * (Note that the mg_len is not the length of the mg_ptr field.)
5406  *
5407  */
5408 
5409 STRLEN
Perl_sv_len_utf8(pTHX_ register SV * sv)5410 Perl_sv_len_utf8(pTHX_ register SV *sv)
5411 {
5412     if (!sv)
5413 	return 0;
5414 
5415     if (SvGMAGICAL(sv))
5416 	return mg_length(sv);
5417     else
5418     {
5419 	STRLEN len, ulen;
5420 	U8 *s = (U8*)SvPV(sv, len);
5421 	MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
5422 
5423 	if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
5424 	     ulen = mg->mg_len;
5425 #ifdef PERL_UTF8_CACHE_ASSERT
5426 	    assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
5427 #endif
5428         }
5429 	else {
5430 	     ulen = Perl_utf8_length(aTHX_ s, s + len);
5431 	     if (!mg && !SvREADONLY(sv)) {
5432 		  sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5433 		  mg = mg_find(sv, PERL_MAGIC_utf8);
5434 		  assert(mg);
5435 	     }
5436 	     if (mg)
5437 		  mg->mg_len = ulen;
5438 	}
5439 	return ulen;
5440     }
5441 }
5442 
5443 /* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
5444  * a PERL_UTF8_magic.  The mg_ptr is used to store the mapping
5445  * between UTF-8 and byte offsets.  There are two (substr offset and substr
5446  * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
5447  * and byte offset) cache positions.
5448  *
5449  * The mg_len field is used by sv_len_utf8(), see its comments.
5450  * Note that the mg_len is not the length of the mg_ptr field.
5451  *
5452  */
5453 STATIC bool
S_utf8_mg_pos_init(pTHX_ SV * sv,MAGIC ** mgp,STRLEN ** cachep,I32 i,I32 * offsetp,U8 * s,U8 * start)5454 S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, U8 *s, U8 *start)
5455 {
5456     bool found = FALSE;
5457 
5458     if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5459 	if (!*mgp)
5460 	    *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0);
5461 	assert(*mgp);
5462 
5463         if ((*mgp)->mg_ptr)
5464             *cachep = (STRLEN *) (*mgp)->mg_ptr;
5465         else {
5466             Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5467             (*mgp)->mg_ptr = (char *) *cachep;
5468         }
5469         assert(*cachep);
5470 
5471         (*cachep)[i]   = *offsetp;
5472         (*cachep)[i+1] = s - start;
5473         found = TRUE;
5474     }
5475 
5476     return found;
5477 }
5478 
5479 /*
5480  * S_utf8_mg_pos() is used to query and update mg_ptr field of
5481  * a PERL_UTF8_magic.  The mg_ptr is used to store the mapping
5482  * between UTF-8 and byte offsets.  See also the comments of
5483  * S_utf8_mg_pos_init().
5484  *
5485  */
5486 STATIC bool
S_utf8_mg_pos(pTHX_ SV * sv,MAGIC ** mgp,STRLEN ** cachep,I32 i,I32 * offsetp,I32 uoff,U8 ** sp,U8 * start,U8 * send)5487 S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, U8 **sp, U8 *start, U8 *send)
5488 {
5489     bool found = FALSE;
5490 
5491     if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5492         if (!*mgp)
5493             *mgp = mg_find(sv, PERL_MAGIC_utf8);
5494         if (*mgp && (*mgp)->mg_ptr) {
5495             *cachep = (STRLEN *) (*mgp)->mg_ptr;
5496 	    ASSERT_UTF8_CACHE(*cachep);
5497             if ((*cachep)[i] == (STRLEN)uoff)	/* An exact match. */
5498 		 found = TRUE;
5499 	    else {			/* We will skip to the right spot. */
5500 		 STRLEN forw  = 0;
5501 		 STRLEN backw = 0;
5502 		 U8* p = NULL;
5503 
5504 		 /* The assumption is that going backward is half
5505 		  * the speed of going forward (that's where the
5506 		  * 2 * backw in the below comes from).  (The real
5507 		  * figure of course depends on the UTF-8 data.) */
5508 
5509 		 if ((*cachep)[i] > (STRLEN)uoff) {
5510 		      forw  = uoff;
5511 		      backw = (*cachep)[i] - (STRLEN)uoff;
5512 
5513 		      if (forw < 2 * backw)
5514 			   p = start;
5515 		      else
5516 			   p = start + (*cachep)[i+1];
5517 		 }
5518 		 /* Try this only for the substr offset (i == 0),
5519 		  * not for the substr length (i == 2). */
5520 		 else if (i == 0) { /* (*cachep)[i] < uoff */
5521 		      STRLEN ulen = sv_len_utf8(sv);
5522 
5523 		      if ((STRLEN)uoff < ulen) {
5524 			   forw  = (STRLEN)uoff - (*cachep)[i];
5525 			   backw = ulen - (STRLEN)uoff;
5526 
5527 			   if (forw < 2 * backw)
5528 				p = start + (*cachep)[i+1];
5529 			   else
5530 				p = send;
5531 		      }
5532 
5533 		      /* If the string is not long enough for uoff,
5534 		       * we could extend it, but not at this low a level. */
5535 		 }
5536 
5537 		 if (p) {
5538 		      if (forw < 2 * backw) {
5539 			   while (forw--)
5540 				p += UTF8SKIP(p);
5541 		      }
5542 		      else {
5543 			   while (backw--) {
5544 				p--;
5545 				while (UTF8_IS_CONTINUATION(*p))
5546 				     p--;
5547 			   }
5548 		      }
5549 
5550 		      /* Update the cache. */
5551 		      (*cachep)[i]   = (STRLEN)uoff;
5552 		      (*cachep)[i+1] = p - start;
5553 
5554 		      /* Drop the stale "length" cache */
5555 		      if (i == 0) {
5556 			  (*cachep)[2] = 0;
5557 			  (*cachep)[3] = 0;
5558 		      }
5559 
5560 		      found = TRUE;
5561 		 }
5562 	    }
5563 	    if (found) {	/* Setup the return values. */
5564 		 *offsetp = (*cachep)[i+1];
5565 		 *sp = start + *offsetp;
5566 		 if (*sp >= send) {
5567 		      *sp = send;
5568 		      *offsetp = send - start;
5569 		 }
5570 		 else if (*sp < start) {
5571 		      *sp = start;
5572 		      *offsetp = 0;
5573 		 }
5574 	    }
5575 	}
5576 #ifdef PERL_UTF8_CACHE_ASSERT
5577 	if (found) {
5578 	     U8 *s = start;
5579 	     I32 n = uoff;
5580 
5581 	     while (n-- && s < send)
5582 		  s += UTF8SKIP(s);
5583 
5584 	     if (i == 0) {
5585 		  assert(*offsetp == s - start);
5586 		  assert((*cachep)[0] == (STRLEN)uoff);
5587 		  assert((*cachep)[1] == *offsetp);
5588 	     }
5589 	     ASSERT_UTF8_CACHE(*cachep);
5590 	}
5591 #endif
5592     }
5593 
5594     return found;
5595 }
5596 
5597 /*
5598 =for apidoc sv_pos_u2b
5599 
5600 Converts the value pointed to by offsetp from a count of UTF-8 chars from
5601 the start of the string, to a count of the equivalent number of bytes; if
5602 lenp is non-zero, it does the same to lenp, but this time starting from
5603 the offset, rather than from the start of the string. Handles magic and
5604 type coercion.
5605 
5606 =cut
5607 */
5608 
5609 /*
5610  * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
5611  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5612  * byte offsets.  See also the comments of S_utf8_mg_pos().
5613  *
5614  */
5615 
5616 void
Perl_sv_pos_u2b(pTHX_ register SV * sv,I32 * offsetp,I32 * lenp)5617 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
5618 {
5619     U8 *start;
5620     U8 *s;
5621     STRLEN len;
5622     STRLEN *cache = 0;
5623     STRLEN boffset = 0;
5624 
5625     if (!sv)
5626 	return;
5627 
5628     start = s = (U8*)SvPV(sv, len);
5629     if (len) {
5630 	 I32 uoffset = *offsetp;
5631 	 U8 *send = s + len;
5632 	 MAGIC *mg = 0;
5633 	 bool found = FALSE;
5634 
5635          if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
5636              found = TRUE;
5637 	 if (!found && uoffset > 0) {
5638 	      while (s < send && uoffset--)
5639 		   s += UTF8SKIP(s);
5640 	      if (s >= send)
5641 		   s = send;
5642               if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
5643                   boffset = cache[1];
5644 	      *offsetp = s - start;
5645 	 }
5646 	 if (lenp) {
5647 	      found = FALSE;
5648 	      start = s;
5649               if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
5650                   *lenp -= boffset;
5651                   found = TRUE;
5652               }
5653 	      if (!found && *lenp > 0) {
5654 		   I32 ulen = *lenp;
5655 		   if (ulen > 0)
5656 			while (s < send && ulen--)
5657 			     s += UTF8SKIP(s);
5658 		   if (s >= send)
5659 			s = send;
5660                    utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start);
5661 	      }
5662 	      *lenp = s - start;
5663 	 }
5664 	 ASSERT_UTF8_CACHE(cache);
5665     }
5666     else {
5667 	 *offsetp = 0;
5668 	 if (lenp)
5669 	      *lenp = 0;
5670     }
5671 
5672     return;
5673 }
5674 
5675 /*
5676 =for apidoc sv_pos_b2u
5677 
5678 Converts the value pointed to by offsetp from a count of bytes from the
5679 start of the string, to a count of the equivalent number of UTF-8 chars.
5680 Handles magic and type coercion.
5681 
5682 =cut
5683 */
5684 
5685 /*
5686  * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
5687  * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
5688  * byte offsets.  See also the comments of S_utf8_mg_pos().
5689  *
5690  */
5691 
5692 void
Perl_sv_pos_b2u(pTHX_ register SV * sv,I32 * offsetp)5693 Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
5694 {
5695     U8* s;
5696     STRLEN len;
5697 
5698     if (!sv)
5699 	return;
5700 
5701     s = (U8*)SvPV(sv, len);
5702     if ((I32)len < *offsetp)
5703 	Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
5704     else {
5705 	U8* send = s + *offsetp;
5706 	MAGIC* mg = NULL;
5707 	STRLEN *cache = NULL;
5708 
5709 	len = 0;
5710 
5711 	if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
5712 	    mg = mg_find(sv, PERL_MAGIC_utf8);
5713 	    if (mg && mg->mg_ptr) {
5714 		cache = (STRLEN *) mg->mg_ptr;
5715 		if (cache[1] == (STRLEN)*offsetp) {
5716 		    /* An exact match. */
5717 		    *offsetp = cache[0];
5718 
5719 		    return;
5720 		}
5721 		else if (cache[1] < (STRLEN)*offsetp) {
5722 		    /* We already know part of the way. */
5723 		    len = cache[0];
5724 		    s  += cache[1];
5725 		    /* Let the below loop do the rest. */
5726 		}
5727 		else { /* cache[1] > *offsetp */
5728 		    /* We already know all of the way, now we may
5729 		     * be able to walk back.  The same assumption
5730 		     * is made as in S_utf8_mg_pos(), namely that
5731 		     * walking backward is twice slower than
5732 		     * walking forward. */
5733 		    STRLEN forw  = *offsetp;
5734 		    STRLEN backw = cache[1] - *offsetp;
5735 
5736 		    if (!(forw < 2 * backw)) {
5737 			U8 *p = s + cache[1];
5738 			STRLEN ubackw = 0;
5739 
5740 			cache[1] -= backw;
5741 
5742 			while (backw--) {
5743 			    p--;
5744 			    while (UTF8_IS_CONTINUATION(*p)) {
5745 				p--;
5746 				backw--;
5747 			    }
5748 			    ubackw++;
5749 			}
5750 
5751 			cache[0] -= ubackw;
5752 			*offsetp = cache[0];
5753 
5754 			/* Drop the stale "length" cache */
5755 			cache[2] = 0;
5756 			cache[3] = 0;
5757 
5758 			return;
5759 		    }
5760 		}
5761 	    }
5762 	    ASSERT_UTF8_CACHE(cache);
5763 	 }
5764 
5765 	while (s < send) {
5766 	    STRLEN n = 1;
5767 
5768 	    /* Call utf8n_to_uvchr() to validate the sequence
5769 	     * (unless a simple non-UTF character) */
5770 	    if (!UTF8_IS_INVARIANT(*s))
5771 		utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
5772 	    if (n > 0) {
5773 		s += n;
5774 		len++;
5775 	    }
5776 	    else
5777 		break;
5778 	}
5779 
5780 	if (!SvREADONLY(sv)) {
5781 	    if (!mg) {
5782 		sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
5783 		mg = mg_find(sv, PERL_MAGIC_utf8);
5784 	    }
5785 	    assert(mg);
5786 
5787 	    if (!mg->mg_ptr) {
5788 		Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
5789 		mg->mg_ptr = (char *) cache;
5790 	    }
5791 	    assert(cache);
5792 
5793 	    cache[0] = len;
5794 	    cache[1] = *offsetp;
5795 	    /* Drop the stale "length" cache */
5796 	    cache[2] = 0;
5797 	    cache[3] = 0;
5798 	}
5799 
5800 	*offsetp = len;
5801     }
5802 
5803     return;
5804 }
5805 
5806 /*
5807 =for apidoc sv_eq
5808 
5809 Returns a boolean indicating whether the strings in the two SVs are
5810 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5811 coerce its args to strings if necessary.
5812 
5813 =cut
5814 */
5815 
5816 I32
Perl_sv_eq(pTHX_ register SV * sv1,register SV * sv2)5817 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
5818 {
5819     char *pv1;
5820     STRLEN cur1;
5821     char *pv2;
5822     STRLEN cur2;
5823     I32  eq     = 0;
5824     char *tpv   = Nullch;
5825     SV* svrecode = Nullsv;
5826 
5827     if (!sv1) {
5828 	pv1 = "";
5829 	cur1 = 0;
5830     }
5831     else
5832 	pv1 = SvPV(sv1, cur1);
5833 
5834     if (!sv2){
5835 	pv2 = "";
5836 	cur2 = 0;
5837     }
5838     else
5839 	pv2 = SvPV(sv2, cur2);
5840 
5841     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5842         /* Differing utf8ness.
5843 	 * Do not UTF8size the comparands as a side-effect. */
5844 	 if (PL_encoding) {
5845 	      if (SvUTF8(sv1)) {
5846 		   svrecode = newSVpvn(pv2, cur2);
5847 		   sv_recode_to_utf8(svrecode, PL_encoding);
5848 		   pv2 = SvPV(svrecode, cur2);
5849 	      }
5850 	      else {
5851 		   svrecode = newSVpvn(pv1, cur1);
5852 		   sv_recode_to_utf8(svrecode, PL_encoding);
5853 		   pv1 = SvPV(svrecode, cur1);
5854 	      }
5855 	      /* Now both are in UTF-8. */
5856 	      if (cur1 != cur2) {
5857 		   SvREFCNT_dec(svrecode);
5858 		   return FALSE;
5859 	      }
5860 	 }
5861 	 else {
5862 	      bool is_utf8 = TRUE;
5863 
5864 	      if (SvUTF8(sv1)) {
5865 		   /* sv1 is the UTF-8 one,
5866 		    * if is equal it must be downgrade-able */
5867 		   char *pv = (char*)bytes_from_utf8((U8*)pv1,
5868 						     &cur1, &is_utf8);
5869 		   if (pv != pv1)
5870 			pv1 = tpv = pv;
5871 	      }
5872 	      else {
5873 		   /* sv2 is the UTF-8 one,
5874 		    * if is equal it must be downgrade-able */
5875 		   char *pv = (char *)bytes_from_utf8((U8*)pv2,
5876 						      &cur2, &is_utf8);
5877 		   if (pv != pv2)
5878 			pv2 = tpv = pv;
5879 	      }
5880 	      if (is_utf8) {
5881 		   /* Downgrade not possible - cannot be eq */
5882 		   return FALSE;
5883 	      }
5884 	 }
5885     }
5886 
5887     if (cur1 == cur2)
5888 	eq = memEQ(pv1, pv2, cur1);
5889 
5890     if (svrecode)
5891 	 SvREFCNT_dec(svrecode);
5892 
5893     if (tpv)
5894 	Safefree(tpv);
5895 
5896     return eq;
5897 }
5898 
5899 /*
5900 =for apidoc sv_cmp
5901 
5902 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
5903 string in C<sv1> is less than, equal to, or greater than the string in
5904 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
5905 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
5906 
5907 =cut
5908 */
5909 
5910 I32
Perl_sv_cmp(pTHX_ register SV * sv1,register SV * sv2)5911 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
5912 {
5913     STRLEN cur1, cur2;
5914     char *pv1, *pv2, *tpv = Nullch;
5915     I32  cmp;
5916     SV *svrecode = Nullsv;
5917 
5918     if (!sv1) {
5919 	pv1 = "";
5920 	cur1 = 0;
5921     }
5922     else
5923 	pv1 = SvPV(sv1, cur1);
5924 
5925     if (!sv2) {
5926 	pv2 = "";
5927 	cur2 = 0;
5928     }
5929     else
5930 	pv2 = SvPV(sv2, cur2);
5931 
5932     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
5933         /* Differing utf8ness.
5934 	 * Do not UTF8size the comparands as a side-effect. */
5935 	if (SvUTF8(sv1)) {
5936 	    if (PL_encoding) {
5937 		 svrecode = newSVpvn(pv2, cur2);
5938 		 sv_recode_to_utf8(svrecode, PL_encoding);
5939 		 pv2 = SvPV(svrecode, cur2);
5940 	    }
5941 	    else {
5942 		 pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
5943 	    }
5944 	}
5945 	else {
5946 	    if (PL_encoding) {
5947 		 svrecode = newSVpvn(pv1, cur1);
5948 		 sv_recode_to_utf8(svrecode, PL_encoding);
5949 		 pv1 = SvPV(svrecode, cur1);
5950 	    }
5951 	    else {
5952 		 pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5953 	    }
5954 	}
5955     }
5956 
5957     if (!cur1) {
5958 	cmp = cur2 ? -1 : 0;
5959     } else if (!cur2) {
5960 	cmp = 1;
5961     } else {
5962 	I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5963 
5964 	if (retval) {
5965 	    cmp = retval < 0 ? -1 : 1;
5966 	} else if (cur1 == cur2) {
5967 	    cmp = 0;
5968         } else {
5969 	    cmp = cur1 < cur2 ? -1 : 1;
5970 	}
5971     }
5972 
5973     if (svrecode)
5974 	 SvREFCNT_dec(svrecode);
5975 
5976     if (tpv)
5977 	Safefree(tpv);
5978 
5979     return cmp;
5980 }
5981 
5982 /*
5983 =for apidoc sv_cmp_locale
5984 
5985 Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
5986 'use bytes' aware, handles get magic, and will coerce its args to strings
5987 if necessary.  See also C<sv_cmp_locale>.  See also C<sv_cmp>.
5988 
5989 =cut
5990 */
5991 
5992 I32
Perl_sv_cmp_locale(pTHX_ register SV * sv1,register SV * sv2)5993 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5994 {
5995 #ifdef USE_LOCALE_COLLATE
5996 
5997     char *pv1, *pv2;
5998     STRLEN len1, len2;
5999     I32 retval;
6000 
6001     if (PL_collation_standard)
6002 	goto raw_compare;
6003 
6004     len1 = 0;
6005     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
6006     len2 = 0;
6007     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
6008 
6009     if (!pv1 || !len1) {
6010 	if (pv2 && len2)
6011 	    return -1;
6012 	else
6013 	    goto raw_compare;
6014     }
6015     else {
6016 	if (!pv2 || !len2)
6017 	    return 1;
6018     }
6019 
6020     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
6021 
6022     if (retval)
6023 	return retval < 0 ? -1 : 1;
6024 
6025     /*
6026      * When the result of collation is equality, that doesn't mean
6027      * that there are no differences -- some locales exclude some
6028      * characters from consideration.  So to avoid false equalities,
6029      * we use the raw string as a tiebreaker.
6030      */
6031 
6032   raw_compare:
6033     /* FALL THROUGH */
6034 
6035 #endif /* USE_LOCALE_COLLATE */
6036 
6037     return sv_cmp(sv1, sv2);
6038 }
6039 
6040 
6041 #ifdef USE_LOCALE_COLLATE
6042 
6043 /*
6044 =for apidoc sv_collxfrm
6045 
6046 Add Collate Transform magic to an SV if it doesn't already have it.
6047 
6048 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
6049 scalar data of the variable, but transformed to such a format that a normal
6050 memory comparison can be used to compare the data according to the locale
6051 settings.
6052 
6053 =cut
6054 */
6055 
6056 char *
Perl_sv_collxfrm(pTHX_ SV * sv,STRLEN * nxp)6057 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
6058 {
6059     MAGIC *mg;
6060 
6061     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
6062     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
6063 	char *s, *xf;
6064 	STRLEN len, xlen;
6065 
6066 	if (mg)
6067 	    Safefree(mg->mg_ptr);
6068 	s = SvPV(sv, len);
6069 	if ((xf = mem_collxfrm(s, len, &xlen))) {
6070 	    if (SvREADONLY(sv)) {
6071 		SAVEFREEPV(xf);
6072 		*nxp = xlen;
6073 		return xf + sizeof(PL_collation_ix);
6074 	    }
6075 	    if (! mg) {
6076 		sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
6077 		mg = mg_find(sv, PERL_MAGIC_collxfrm);
6078 		assert(mg);
6079 	    }
6080 	    mg->mg_ptr = xf;
6081 	    mg->mg_len = xlen;
6082 	}
6083 	else {
6084 	    if (mg) {
6085 		mg->mg_ptr = NULL;
6086 		mg->mg_len = -1;
6087 	    }
6088 	}
6089     }
6090     if (mg && mg->mg_ptr) {
6091 	*nxp = mg->mg_len;
6092 	return mg->mg_ptr + sizeof(PL_collation_ix);
6093     }
6094     else {
6095 	*nxp = 0;
6096 	return NULL;
6097     }
6098 }
6099 
6100 #endif /* USE_LOCALE_COLLATE */
6101 
6102 /*
6103 =for apidoc sv_gets
6104 
6105 Get a line from the filehandle and store it into the SV, optionally
6106 appending to the currently-stored string.
6107 
6108 =cut
6109 */
6110 
6111 char *
Perl_sv_gets(pTHX_ register SV * sv,register PerlIO * fp,I32 append)6112 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
6113 {
6114     char *rsptr;
6115     STRLEN rslen;
6116     register STDCHAR rslast;
6117     register STDCHAR *bp;
6118     register I32 cnt;
6119     I32 i = 0;
6120     I32 rspara = 0;
6121     I32 recsize;
6122 
6123     if (SvTHINKFIRST(sv))
6124 	sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
6125     /* XXX. If you make this PVIV, then copy on write can copy scalars read
6126        from <>.
6127        However, perlbench says it's slower, because the existing swipe code
6128        is faster than copy on write.
6129        Swings and roundabouts.  */
6130     (void)SvUPGRADE(sv, SVt_PV);
6131 
6132     SvSCREAM_off(sv);
6133 
6134     if (append) {
6135 	if (PerlIO_isutf8(fp)) {
6136 	    if (!SvUTF8(sv)) {
6137 		sv_utf8_upgrade_nomg(sv);
6138 		sv_pos_u2b(sv,&append,0);
6139 	    }
6140 	} else if (SvUTF8(sv)) {
6141 	    SV *tsv = NEWSV(0,0);
6142 	    sv_gets(tsv, fp, 0);
6143 	    sv_utf8_upgrade_nomg(tsv);
6144 	    SvCUR_set(sv,append);
6145 	    sv_catsv(sv,tsv);
6146 	    sv_free(tsv);
6147 	    goto return_string_or_null;
6148 	}
6149     }
6150 
6151     SvPOK_only(sv);
6152     if (PerlIO_isutf8(fp))
6153 	SvUTF8_on(sv);
6154 
6155     if (IN_PERL_COMPILETIME) {
6156 	/* we always read code in line mode */
6157 	rsptr = "\n";
6158 	rslen = 1;
6159     }
6160     else if (RsSNARF(PL_rs)) {
6161     	/* If it is a regular disk file use size from stat() as estimate
6162 	   of amount we are going to read - may result in malloc-ing
6163 	   more memory than we realy need if layers bellow reduce
6164 	   size we read (e.g. CRLF or a gzip layer)
6165 	 */
6166 	Stat_t st;
6167 	if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode))  {
6168 	    Off_t offset = PerlIO_tell(fp);
6169 	    if (offset != (Off_t) -1 && st.st_size + append > offset) {
6170 	     	(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
6171 	    }
6172 	}
6173 	rsptr = NULL;
6174 	rslen = 0;
6175     }
6176     else if (RsRECORD(PL_rs)) {
6177       I32 bytesread;
6178       char *buffer;
6179 
6180       /* Grab the size of the record we're getting */
6181       recsize = SvIV(SvRV(PL_rs));
6182       buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
6183       /* Go yank in */
6184 #ifdef VMS
6185       /* VMS wants read instead of fread, because fread doesn't respect */
6186       /* RMS record boundaries. This is not necessarily a good thing to be */
6187       /* doing, but we've got no other real choice - except avoid stdio
6188          as implementation - perhaps write a :vms layer ?
6189        */
6190       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
6191 #else
6192       bytesread = PerlIO_read(fp, buffer, recsize);
6193 #endif
6194       if (bytesread < 0)
6195 	  bytesread = 0;
6196       SvCUR_set(sv, bytesread += append);
6197       buffer[bytesread] = '\0';
6198       goto return_string_or_null;
6199     }
6200     else if (RsPARA(PL_rs)) {
6201 	rsptr = "\n\n";
6202 	rslen = 2;
6203 	rspara = 1;
6204     }
6205     else {
6206 	/* Get $/ i.e. PL_rs into same encoding as stream wants */
6207 	if (PerlIO_isutf8(fp)) {
6208 	    rsptr = SvPVutf8(PL_rs, rslen);
6209 	}
6210 	else {
6211 	    if (SvUTF8(PL_rs)) {
6212 		if (!sv_utf8_downgrade(PL_rs, TRUE)) {
6213 		    Perl_croak(aTHX_ "Wide character in $/");
6214 		}
6215 	    }
6216 	    rsptr = SvPV(PL_rs, rslen);
6217 	}
6218     }
6219 
6220     rslast = rslen ? rsptr[rslen - 1] : '\0';
6221 
6222     if (rspara) {		/* have to do this both before and after */
6223 	do {			/* to make sure file boundaries work right */
6224 	    if (PerlIO_eof(fp))
6225 		return 0;
6226 	    i = PerlIO_getc(fp);
6227 	    if (i != '\n') {
6228 		if (i == -1)
6229 		    return 0;
6230 		PerlIO_ungetc(fp,i);
6231 		break;
6232 	    }
6233 	} while (i != EOF);
6234     }
6235 
6236     /* See if we know enough about I/O mechanism to cheat it ! */
6237 
6238     /* This used to be #ifdef test - it is made run-time test for ease
6239        of abstracting out stdio interface. One call should be cheap
6240        enough here - and may even be a macro allowing compile
6241        time optimization.
6242      */
6243 
6244     if (PerlIO_fast_gets(fp)) {
6245 
6246     /*
6247      * We're going to steal some values from the stdio struct
6248      * and put EVERYTHING in the innermost loop into registers.
6249      */
6250     register STDCHAR *ptr;
6251     STRLEN bpx;
6252     I32 shortbuffered;
6253 
6254 #if defined(VMS) && defined(PERLIO_IS_STDIO)
6255     /* An ungetc()d char is handled separately from the regular
6256      * buffer, so we getc() it back out and stuff it in the buffer.
6257      */
6258     i = PerlIO_getc(fp);
6259     if (i == EOF) return 0;
6260     *(--((*fp)->_ptr)) = (unsigned char) i;
6261     (*fp)->_cnt++;
6262 #endif
6263 
6264     /* Here is some breathtakingly efficient cheating */
6265 
6266     cnt = PerlIO_get_cnt(fp);			/* get count into register */
6267     /* make sure we have the room */
6268     if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
6269     	/* Not room for all of it
6270 	   if we are looking for a separator and room for some
6271 	 */
6272 	if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
6273 	    /* just process what we have room for */
6274 	    shortbuffered = cnt - SvLEN(sv) + append + 1;
6275 	    cnt -= shortbuffered;
6276 	}
6277 	else {
6278 	    shortbuffered = 0;
6279 	    /* remember that cnt can be negative */
6280 	    SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
6281 	}
6282     }
6283     else
6284 	shortbuffered = 0;
6285     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
6286     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
6287     DEBUG_P(PerlIO_printf(Perl_debug_log,
6288 	"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6289     DEBUG_P(PerlIO_printf(Perl_debug_log,
6290 	"Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6291 	       PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6292 	       PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
6293     for (;;) {
6294       screamer:
6295 	if (cnt > 0) {
6296 	    if (rslen) {
6297 		while (cnt > 0) {		     /* this     |  eat */
6298 		    cnt--;
6299 		    if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
6300 			goto thats_all_folks;	     /* screams  |  sed :-) */
6301 		}
6302 	    }
6303 	    else {
6304 	        Copy(ptr, bp, cnt, char);	     /* this     |  eat */
6305 		bp += cnt;			     /* screams  |  dust */
6306 		ptr += cnt;			     /* louder   |  sed :-) */
6307 		cnt = 0;
6308 	    }
6309 	}
6310 
6311 	if (shortbuffered) {		/* oh well, must extend */
6312 	    cnt = shortbuffered;
6313 	    shortbuffered = 0;
6314 	    bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
6315 	    SvCUR_set(sv, bpx);
6316 	    SvGROW(sv, SvLEN(sv) + append + cnt + 2);
6317 	    bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
6318 	    continue;
6319 	}
6320 
6321 	DEBUG_P(PerlIO_printf(Perl_debug_log,
6322 			      "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
6323 			      PTR2UV(ptr),(long)cnt));
6324 	PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
6325 #if 0
6326 	DEBUG_P(PerlIO_printf(Perl_debug_log,
6327 	    "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6328 	    PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6329 	    PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6330 #endif
6331 	/* This used to call 'filbuf' in stdio form, but as that behaves like
6332 	   getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
6333 	   another abstraction.  */
6334 	i   = PerlIO_getc(fp);		/* get more characters */
6335 #if 0
6336 	DEBUG_P(PerlIO_printf(Perl_debug_log,
6337 	    "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6338 	    PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6339 	    PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6340 #endif
6341 	cnt = PerlIO_get_cnt(fp);
6342 	ptr = (STDCHAR*)PerlIO_get_ptr(fp);	/* reregisterize cnt and ptr */
6343 	DEBUG_P(PerlIO_printf(Perl_debug_log,
6344 	    "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6345 
6346 	if (i == EOF)			/* all done for ever? */
6347 	    goto thats_really_all_folks;
6348 
6349 	bpx = bp - (STDCHAR*)SvPVX(sv);	/* box up before relocation */
6350 	SvCUR_set(sv, bpx);
6351 	SvGROW(sv, bpx + cnt + 2);
6352 	bp = (STDCHAR*)SvPVX(sv) + bpx;	/* unbox after relocation */
6353 
6354 	*bp++ = (STDCHAR)i;		/* store character from PerlIO_getc */
6355 
6356 	if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
6357 	    goto thats_all_folks;
6358     }
6359 
6360 thats_all_folks:
6361     if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) ||
6362 	  memNE((char*)bp - rslen, rsptr, rslen))
6363 	goto screamer;				/* go back to the fray */
6364 thats_really_all_folks:
6365     if (shortbuffered)
6366 	cnt += shortbuffered;
6367 	DEBUG_P(PerlIO_printf(Perl_debug_log,
6368 	    "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
6369     PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt);	/* put these back or we're in trouble */
6370     DEBUG_P(PerlIO_printf(Perl_debug_log,
6371 	"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
6372 	PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
6373 	PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
6374     *bp = '\0';
6375     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));	/* set length */
6376     DEBUG_P(PerlIO_printf(Perl_debug_log,
6377 	"Screamer: done, len=%ld, string=|%.*s|\n",
6378 	(long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
6379     }
6380    else
6381     {
6382        /*The big, slow, and stupid way. */
6383 
6384       /* Any stack-challenged places. */
6385 #if defined(EPOC)
6386       /* EPOC: need to work around SDK features.         *
6387        * On WINS: MS VC5 generates calls to _chkstk,     *
6388        * if a "large" stack frame is allocated.          *
6389        * gcc on MARM does not generate calls like these. */
6390 #   define USEHEAPINSTEADOFSTACK
6391 #endif
6392 
6393 #ifdef USEHEAPINSTEADOFSTACK
6394 	STDCHAR *buf = 0;
6395 	New(0, buf, 8192, STDCHAR);
6396 	assert(buf);
6397 #else
6398 	STDCHAR buf[8192];
6399 #endif
6400 
6401 screamer2:
6402 	if (rslen) {
6403 	    register STDCHAR *bpe = buf + sizeof(buf);
6404 	    bp = buf;
6405 	    while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe)
6406 		; /* keep reading */
6407 	    cnt = bp - buf;
6408 	}
6409 	else {
6410 	    cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
6411 	    /* Accomodate broken VAXC compiler, which applies U8 cast to
6412 	     * both args of ?: operator, causing EOF to change into 255
6413 	     */
6414 	    if (cnt > 0)
6415 		 i = (U8)buf[cnt - 1];
6416 	    else
6417 		 i = EOF;
6418 	}
6419 
6420 	if (cnt < 0)
6421 	    cnt = 0;  /* we do need to re-set the sv even when cnt <= 0 */
6422 	if (append)
6423 	     sv_catpvn(sv, (char *) buf, cnt);
6424 	else
6425 	     sv_setpvn(sv, (char *) buf, cnt);
6426 
6427 	if (i != EOF &&			/* joy */
6428 	    (!rslen ||
6429 	     SvCUR(sv) < rslen ||
6430 	     memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
6431 	{
6432 	    append = -1;
6433 	    /*
6434 	     * If we're reading from a TTY and we get a short read,
6435 	     * indicating that the user hit his EOF character, we need
6436 	     * to notice it now, because if we try to read from the TTY
6437 	     * again, the EOF condition will disappear.
6438 	     *
6439 	     * The comparison of cnt to sizeof(buf) is an optimization
6440 	     * that prevents unnecessary calls to feof().
6441 	     *
6442 	     * - jik 9/25/96
6443 	     */
6444 	    if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
6445 		goto screamer2;
6446 	}
6447 
6448 #ifdef USEHEAPINSTEADOFSTACK
6449 	Safefree(buf);
6450 #endif
6451     }
6452 
6453     if (rspara) {		/* have to do this both before and after */
6454         while (i != EOF) {	/* to make sure file boundaries work right */
6455 	    i = PerlIO_getc(fp);
6456 	    if (i != '\n') {
6457 		PerlIO_ungetc(fp,i);
6458 		break;
6459 	    }
6460 	}
6461     }
6462 
6463 return_string_or_null:
6464     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
6465 }
6466 
6467 /*
6468 =for apidoc sv_inc
6469 
6470 Auto-increment of the value in the SV, doing string to numeric conversion
6471 if necessary. Handles 'get' magic.
6472 
6473 =cut
6474 */
6475 
6476 void
Perl_sv_inc(pTHX_ register SV * sv)6477 Perl_sv_inc(pTHX_ register SV *sv)
6478 {
6479     register char *d;
6480     int flags;
6481 
6482     if (!sv)
6483 	return;
6484     if (SvGMAGICAL(sv))
6485 	mg_get(sv);
6486     if (SvTHINKFIRST(sv)) {
6487 	if (SvREADONLY(sv) && SvFAKE(sv))
6488 	    sv_force_normal(sv);
6489 	if (SvREADONLY(sv)) {
6490 	    if (IN_PERL_RUNTIME)
6491 		Perl_croak(aTHX_ PL_no_modify);
6492 	}
6493 	if (SvROK(sv)) {
6494 	    IV i;
6495 	    if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
6496 		return;
6497 	    i = PTR2IV(SvRV(sv));
6498 	    sv_unref(sv);
6499 	    sv_setiv(sv, i);
6500 	}
6501     }
6502     flags = SvFLAGS(sv);
6503     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
6504 	/* It's (privately or publicly) a float, but not tested as an
6505 	   integer, so test it to see. */
6506 	(void) SvIV(sv);
6507 	flags = SvFLAGS(sv);
6508     }
6509     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6510 	/* It's publicly an integer, or privately an integer-not-float */
6511 #ifdef PERL_PRESERVE_IVUV
6512       oops_its_int:
6513 #endif
6514 	if (SvIsUV(sv)) {
6515 	    if (SvUVX(sv) == UV_MAX)
6516 		sv_setnv(sv, UV_MAX_P1);
6517 	    else
6518 		(void)SvIOK_only_UV(sv);
6519 		++SvUVX(sv);
6520 	} else {
6521 	    if (SvIVX(sv) == IV_MAX)
6522 		sv_setuv(sv, (UV)IV_MAX + 1);
6523 	    else {
6524 		(void)SvIOK_only(sv);
6525 		++SvIVX(sv);
6526 	    }
6527 	}
6528 	return;
6529     }
6530     if (flags & SVp_NOK) {
6531 	(void)SvNOK_only(sv);
6532 	SvNVX(sv) += 1.0;
6533 	return;
6534     }
6535 
6536     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
6537 	if ((flags & SVTYPEMASK) < SVt_PVIV)
6538 	    sv_upgrade(sv, SVt_IV);
6539 	(void)SvIOK_only(sv);
6540 	SvIVX(sv) = 1;
6541 	return;
6542     }
6543     d = SvPVX(sv);
6544     while (isALPHA(*d)) d++;
6545     while (isDIGIT(*d)) d++;
6546     if (*d) {
6547 #ifdef PERL_PRESERVE_IVUV
6548 	/* Got to punt this as an integer if needs be, but we don't issue
6549 	   warnings. Probably ought to make the sv_iv_please() that does
6550 	   the conversion if possible, and silently.  */
6551 	int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6552 	if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6553 	    /* Need to try really hard to see if it's an integer.
6554 	       9.22337203685478e+18 is an integer.
6555 	       but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6556 	       so $a="9.22337203685478e+18"; $a+0; $a++
6557 	       needs to be the same as $a="9.22337203685478e+18"; $a++
6558 	       or we go insane. */
6559 
6560 	    (void) sv_2iv(sv);
6561 	    if (SvIOK(sv))
6562 		goto oops_its_int;
6563 
6564 	    /* sv_2iv *should* have made this an NV */
6565 	    if (flags & SVp_NOK) {
6566 		(void)SvNOK_only(sv);
6567 		SvNVX(sv) += 1.0;
6568 		return;
6569 	    }
6570 	    /* I don't think we can get here. Maybe I should assert this
6571 	       And if we do get here I suspect that sv_setnv will croak. NWC
6572 	       Fall through. */
6573 #if defined(USE_LONG_DOUBLE)
6574 	    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",
6575 				  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6576 #else
6577 	    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6578 				  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6579 #endif
6580 	}
6581 #endif /* PERL_PRESERVE_IVUV */
6582 	sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
6583 	return;
6584     }
6585     d--;
6586     while (d >= SvPVX(sv)) {
6587 	if (isDIGIT(*d)) {
6588 	    if (++*d <= '9')
6589 		return;
6590 	    *(d--) = '0';
6591 	}
6592 	else {
6593 #ifdef EBCDIC
6594 	    /* MKS: The original code here died if letters weren't consecutive.
6595 	     * at least it didn't have to worry about non-C locales.  The
6596 	     * new code assumes that ('z'-'a')==('Z'-'A'), letters are
6597 	     * arranged in order (although not consecutively) and that only
6598 	     * [A-Za-z] are accepted by isALPHA in the C locale.
6599 	     */
6600 	    if (*d != 'z' && *d != 'Z') {
6601 		do { ++*d; } while (!isALPHA(*d));
6602 		return;
6603 	    }
6604 	    *(d--) -= 'z' - 'a';
6605 #else
6606 	    ++*d;
6607 	    if (isALPHA(*d))
6608 		return;
6609 	    *(d--) -= 'z' - 'a' + 1;
6610 #endif
6611 	}
6612     }
6613     /* oh,oh, the number grew */
6614     SvGROW(sv, SvCUR(sv) + 2);
6615     SvCUR(sv)++;
6616     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
6617 	*d = d[-1];
6618     if (isDIGIT(d[1]))
6619 	*d = '1';
6620     else
6621 	*d = d[1];
6622 }
6623 
6624 /*
6625 =for apidoc sv_dec
6626 
6627 Auto-decrement of the value in the SV, doing string to numeric conversion
6628 if necessary. Handles 'get' magic.
6629 
6630 =cut
6631 */
6632 
6633 void
Perl_sv_dec(pTHX_ register SV * sv)6634 Perl_sv_dec(pTHX_ register SV *sv)
6635 {
6636     int flags;
6637 
6638     if (!sv)
6639 	return;
6640     if (SvGMAGICAL(sv))
6641 	mg_get(sv);
6642     if (SvTHINKFIRST(sv)) {
6643 	if (SvREADONLY(sv) && SvFAKE(sv))
6644 	    sv_force_normal(sv);
6645 	if (SvREADONLY(sv)) {
6646 	    if (IN_PERL_RUNTIME)
6647 		Perl_croak(aTHX_ PL_no_modify);
6648 	}
6649 	if (SvROK(sv)) {
6650 	    IV i;
6651 	    if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
6652 		return;
6653 	    i = PTR2IV(SvRV(sv));
6654 	    sv_unref(sv);
6655 	    sv_setiv(sv, i);
6656 	}
6657     }
6658     /* Unlike sv_inc we don't have to worry about string-never-numbers
6659        and keeping them magic. But we mustn't warn on punting */
6660     flags = SvFLAGS(sv);
6661     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
6662 	/* It's publicly an integer, or privately an integer-not-float */
6663 #ifdef PERL_PRESERVE_IVUV
6664       oops_its_int:
6665 #endif
6666 	if (SvIsUV(sv)) {
6667 	    if (SvUVX(sv) == 0) {
6668 		(void)SvIOK_only(sv);
6669 		SvIVX(sv) = -1;
6670 	    }
6671 	    else {
6672 		(void)SvIOK_only_UV(sv);
6673 		--SvUVX(sv);
6674 	    }
6675 	} else {
6676 	    if (SvIVX(sv) == IV_MIN)
6677 		sv_setnv(sv, (NV)IV_MIN - 1.0);
6678 	    else {
6679 		(void)SvIOK_only(sv);
6680 		--SvIVX(sv);
6681 	    }
6682 	}
6683 	return;
6684     }
6685     if (flags & SVp_NOK) {
6686 	SvNVX(sv) -= 1.0;
6687 	(void)SvNOK_only(sv);
6688 	return;
6689     }
6690     if (!(flags & SVp_POK)) {
6691 	if ((flags & SVTYPEMASK) < SVt_PVNV)
6692 	    sv_upgrade(sv, SVt_NV);
6693 	SvNVX(sv) = -1.0;
6694 	(void)SvNOK_only(sv);
6695 	return;
6696     }
6697 #ifdef PERL_PRESERVE_IVUV
6698     {
6699 	int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
6700 	if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
6701 	    /* Need to try really hard to see if it's an integer.
6702 	       9.22337203685478e+18 is an integer.
6703 	       but "9.22337203685478e+18" + 0 is UV=9223372036854779904
6704 	       so $a="9.22337203685478e+18"; $a+0; $a--
6705 	       needs to be the same as $a="9.22337203685478e+18"; $a--
6706 	       or we go insane. */
6707 
6708 	    (void) sv_2iv(sv);
6709 	    if (SvIOK(sv))
6710 		goto oops_its_int;
6711 
6712 	    /* sv_2iv *should* have made this an NV */
6713 	    if (flags & SVp_NOK) {
6714 		(void)SvNOK_only(sv);
6715 		SvNVX(sv) -= 1.0;
6716 		return;
6717 	    }
6718 	    /* I don't think we can get here. Maybe I should assert this
6719 	       And if we do get here I suspect that sv_setnv will croak. NWC
6720 	       Fall through. */
6721 #if defined(USE_LONG_DOUBLE)
6722 	    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",
6723 				  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6724 #else
6725 	    DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
6726 				  SvPVX(sv), SvIVX(sv), SvNVX(sv)));
6727 #endif
6728 	}
6729     }
6730 #endif /* PERL_PRESERVE_IVUV */
6731     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0);	/* punt */
6732 }
6733 
6734 /*
6735 =for apidoc sv_mortalcopy
6736 
6737 Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
6738 The new SV is marked as mortal. It will be destroyed "soon", either by an
6739 explicit call to FREETMPS, or by an implicit call at places such as
6740 statement boundaries.  See also C<sv_newmortal> and C<sv_2mortal>.
6741 
6742 =cut
6743 */
6744 
6745 /* Make a string that will exist for the duration of the expression
6746  * evaluation.  Actually, it may have to last longer than that, but
6747  * hopefully we won't free it until it has been assigned to a
6748  * permanent location. */
6749 
6750 SV *
Perl_sv_mortalcopy(pTHX_ SV * oldstr)6751 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
6752 {
6753     register SV *sv;
6754 
6755     new_SV(sv);
6756     sv_setsv(sv,oldstr);
6757     EXTEND_MORTAL(1);
6758     PL_tmps_stack[++PL_tmps_ix] = sv;
6759     SvTEMP_on(sv);
6760     return sv;
6761 }
6762 
6763 /*
6764 =for apidoc sv_newmortal
6765 
6766 Creates a new null SV which is mortal.  The reference count of the SV is
6767 set to 1. It will be destroyed "soon", either by an explicit call to
6768 FREETMPS, or by an implicit call at places such as statement boundaries.
6769 See also C<sv_mortalcopy> and C<sv_2mortal>.
6770 
6771 =cut
6772 */
6773 
6774 SV *
Perl_sv_newmortal(pTHX)6775 Perl_sv_newmortal(pTHX)
6776 {
6777     register SV *sv;
6778 
6779     new_SV(sv);
6780     SvFLAGS(sv) = SVs_TEMP;
6781     EXTEND_MORTAL(1);
6782     PL_tmps_stack[++PL_tmps_ix] = sv;
6783     return sv;
6784 }
6785 
6786 /*
6787 =for apidoc sv_2mortal
6788 
6789 Marks an existing SV as mortal.  The SV will be destroyed "soon", either
6790 by an explicit call to FREETMPS, or by an implicit call at places such as
6791 statement boundaries.  See also C<sv_newmortal> and C<sv_mortalcopy>.
6792 
6793 =cut
6794 */
6795 
6796 SV *
Perl_sv_2mortal(pTHX_ register SV * sv)6797 Perl_sv_2mortal(pTHX_ register SV *sv)
6798 {
6799     if (!sv)
6800 	return sv;
6801     if (SvREADONLY(sv) && SvIMMORTAL(sv))
6802 	return sv;
6803     EXTEND_MORTAL(1);
6804     PL_tmps_stack[++PL_tmps_ix] = sv;
6805     SvTEMP_on(sv);
6806     return sv;
6807 }
6808 
6809 /*
6810 =for apidoc newSVpv
6811 
6812 Creates a new SV and copies a string into it.  The reference count for the
6813 SV is set to 1.  If C<len> is zero, Perl will compute the length using
6814 strlen().  For efficiency, consider using C<newSVpvn> instead.
6815 
6816 =cut
6817 */
6818 
6819 SV *
Perl_newSVpv(pTHX_ const char * s,STRLEN len)6820 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
6821 {
6822     register SV *sv;
6823 
6824     new_SV(sv);
6825     if (!len)
6826 	len = strlen(s);
6827     sv_setpvn(sv,s,len);
6828     return sv;
6829 }
6830 
6831 /*
6832 =for apidoc newSVpvn
6833 
6834 Creates a new SV and copies a string into it.  The reference count for the
6835 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
6836 string.  You are responsible for ensuring that the source string is at least
6837 C<len> bytes long.
6838 
6839 =cut
6840 */
6841 
6842 SV *
Perl_newSVpvn(pTHX_ const char * s,STRLEN len)6843 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
6844 {
6845     register SV *sv;
6846 
6847     new_SV(sv);
6848     sv_setpvn(sv,s,len);
6849     return sv;
6850 }
6851 
6852 /*
6853 =for apidoc newSVpvn_share
6854 
6855 Creates a new SV with its SvPVX pointing to a shared string in the string
6856 table. If the string does not already exist in the table, it is created
6857 first.  Turns on READONLY and FAKE.  The string's hash is stored in the UV
6858 slot of the SV; if the C<hash> parameter is non-zero, that value is used;
6859 otherwise the hash is computed.  The idea here is that as the string table
6860 is used for shared hash keys these strings will have SvPVX == HeKEY and
6861 hash lookup will avoid string compare.
6862 
6863 =cut
6864 */
6865 
6866 SV *
Perl_newSVpvn_share(pTHX_ const char * src,I32 len,U32 hash)6867 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
6868 {
6869     register SV *sv;
6870     bool is_utf8 = FALSE;
6871     if (len < 0) {
6872 	STRLEN tmplen = -len;
6873         is_utf8 = TRUE;
6874 	/* See the note in hv.c:hv_fetch() --jhi */
6875 	src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
6876 	len = tmplen;
6877     }
6878     if (!hash)
6879 	PERL_HASH(hash, src, len);
6880     new_SV(sv);
6881     sv_upgrade(sv, SVt_PVIV);
6882     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
6883     SvCUR(sv) = len;
6884     SvUVX(sv) = hash;
6885     SvLEN(sv) = 0;
6886     SvREADONLY_on(sv);
6887     SvFAKE_on(sv);
6888     SvPOK_on(sv);
6889     if (is_utf8)
6890         SvUTF8_on(sv);
6891     return sv;
6892 }
6893 
6894 
6895 #if defined(PERL_IMPLICIT_CONTEXT)
6896 
6897 /* pTHX_ magic can't cope with varargs, so this is a no-context
6898  * version of the main function, (which may itself be aliased to us).
6899  * Don't access this version directly.
6900  */
6901 
6902 SV *
Perl_newSVpvf_nocontext(const char * pat,...)6903 Perl_newSVpvf_nocontext(const char* pat, ...)
6904 {
6905     dTHX;
6906     register SV *sv;
6907     va_list args;
6908     va_start(args, pat);
6909     sv = vnewSVpvf(pat, &args);
6910     va_end(args);
6911     return sv;
6912 }
6913 #endif
6914 
6915 /*
6916 =for apidoc newSVpvf
6917 
6918 Creates a new SV and initializes it with the string formatted like
6919 C<sprintf>.
6920 
6921 =cut
6922 */
6923 
6924 SV *
Perl_newSVpvf(pTHX_ const char * pat,...)6925 Perl_newSVpvf(pTHX_ const char* pat, ...)
6926 {
6927     register SV *sv;
6928     va_list args;
6929     va_start(args, pat);
6930     sv = vnewSVpvf(pat, &args);
6931     va_end(args);
6932     return sv;
6933 }
6934 
6935 /* backend for newSVpvf() and newSVpvf_nocontext() */
6936 
6937 SV *
Perl_vnewSVpvf(pTHX_ const char * pat,va_list * args)6938 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
6939 {
6940     register SV *sv;
6941     new_SV(sv);
6942     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6943     return sv;
6944 }
6945 
6946 /*
6947 =for apidoc newSVnv
6948 
6949 Creates a new SV and copies a floating point value into it.
6950 The reference count for the SV is set to 1.
6951 
6952 =cut
6953 */
6954 
6955 SV *
Perl_newSVnv(pTHX_ NV n)6956 Perl_newSVnv(pTHX_ NV n)
6957 {
6958     register SV *sv;
6959 
6960     new_SV(sv);
6961     sv_setnv(sv,n);
6962     return sv;
6963 }
6964 
6965 /*
6966 =for apidoc newSViv
6967 
6968 Creates a new SV and copies an integer into it.  The reference count for the
6969 SV is set to 1.
6970 
6971 =cut
6972 */
6973 
6974 SV *
Perl_newSViv(pTHX_ IV i)6975 Perl_newSViv(pTHX_ IV i)
6976 {
6977     register SV *sv;
6978 
6979     new_SV(sv);
6980     sv_setiv(sv,i);
6981     return sv;
6982 }
6983 
6984 /*
6985 =for apidoc newSVuv
6986 
6987 Creates a new SV and copies an unsigned integer into it.
6988 The reference count for the SV is set to 1.
6989 
6990 =cut
6991 */
6992 
6993 SV *
Perl_newSVuv(pTHX_ UV u)6994 Perl_newSVuv(pTHX_ UV u)
6995 {
6996     register SV *sv;
6997 
6998     new_SV(sv);
6999     sv_setuv(sv,u);
7000     return sv;
7001 }
7002 
7003 /*
7004 =for apidoc newRV_noinc
7005 
7006 Creates an RV wrapper for an SV.  The reference count for the original
7007 SV is B<not> incremented.
7008 
7009 =cut
7010 */
7011 
7012 SV *
Perl_newRV_noinc(pTHX_ SV * tmpRef)7013 Perl_newRV_noinc(pTHX_ SV *tmpRef)
7014 {
7015     register SV *sv;
7016 
7017     new_SV(sv);
7018     sv_upgrade(sv, SVt_RV);
7019     SvTEMP_off(tmpRef);
7020     SvRV(sv) = tmpRef;
7021     SvROK_on(sv);
7022     return sv;
7023 }
7024 
7025 /* newRV_inc is the official function name to use now.
7026  * newRV_inc is in fact #defined to newRV in sv.h
7027  */
7028 
7029 SV *
Perl_newRV(pTHX_ SV * tmpRef)7030 Perl_newRV(pTHX_ SV *tmpRef)
7031 {
7032     return newRV_noinc(SvREFCNT_inc(tmpRef));
7033 }
7034 
7035 /*
7036 =for apidoc newSVsv
7037 
7038 Creates a new SV which is an exact duplicate of the original SV.
7039 (Uses C<sv_setsv>).
7040 
7041 =cut
7042 */
7043 
7044 SV *
Perl_newSVsv(pTHX_ register SV * old)7045 Perl_newSVsv(pTHX_ register SV *old)
7046 {
7047     register SV *sv;
7048 
7049     if (!old)
7050 	return Nullsv;
7051     if (SvTYPE(old) == SVTYPEMASK) {
7052         if (ckWARN_d(WARN_INTERNAL))
7053 	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
7054 	return Nullsv;
7055     }
7056     new_SV(sv);
7057     if (SvTEMP(old)) {
7058 	SvTEMP_off(old);
7059 	sv_setsv(sv,old);
7060 	SvTEMP_on(old);
7061     }
7062     else
7063 	sv_setsv(sv,old);
7064     return sv;
7065 }
7066 
7067 /*
7068 =for apidoc sv_reset
7069 
7070 Underlying implementation for the C<reset> Perl function.
7071 Note that the perl-level function is vaguely deprecated.
7072 
7073 =cut
7074 */
7075 
7076 void
Perl_sv_reset(pTHX_ register char * s,HV * stash)7077 Perl_sv_reset(pTHX_ register char *s, HV *stash)
7078 {
7079     register HE *entry;
7080     register GV *gv;
7081     register SV *sv;
7082     register I32 i;
7083     register PMOP *pm;
7084     register I32 max;
7085     char todo[PERL_UCHAR_MAX+1];
7086 
7087     if (!stash)
7088 	return;
7089 
7090     if (!*s) {		/* reset ?? searches */
7091 	for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
7092 	    pm->op_pmdynflags &= ~PMdf_USED;
7093 	}
7094 	return;
7095     }
7096 
7097     /* reset variables */
7098 
7099     if (!HvARRAY(stash))
7100 	return;
7101 
7102     Zero(todo, 256, char);
7103     while (*s) {
7104 	i = (unsigned char)*s;
7105 	if (s[1] == '-') {
7106 	    s += 2;
7107 	}
7108 	max = (unsigned char)*s++;
7109 	for ( ; i <= max; i++) {
7110 	    todo[i] = 1;
7111 	}
7112 	for (i = 0; i <= (I32) HvMAX(stash); i++) {
7113 	    for (entry = HvARRAY(stash)[i];
7114 		 entry;
7115 		 entry = HeNEXT(entry))
7116 	    {
7117 		if (!todo[(U8)*HeKEY(entry)])
7118 		    continue;
7119 		gv = (GV*)HeVAL(entry);
7120 		sv = GvSV(gv);
7121 		if (SvTHINKFIRST(sv)) {
7122 		    if (!SvREADONLY(sv) && SvROK(sv))
7123 			sv_unref(sv);
7124 		    continue;
7125 		}
7126 		(void)SvOK_off(sv);
7127 		if (SvTYPE(sv) >= SVt_PV) {
7128 		    SvCUR_set(sv, 0);
7129 		    if (SvPVX(sv) != Nullch)
7130 			*SvPVX(sv) = '\0';
7131 		    SvTAINT(sv);
7132 		}
7133 		if (GvAV(gv)) {
7134 		    av_clear(GvAV(gv));
7135 		}
7136 		if (GvHV(gv) && !HvNAME(GvHV(gv))) {
7137 		    hv_clear(GvHV(gv));
7138 #ifndef PERL_MICRO
7139 #ifdef USE_ENVIRON_ARRAY
7140 		    if (gv == PL_envgv
7141 #  ifdef USE_ITHREADS
7142 			&& PL_curinterp == aTHX
7143 #  endif
7144 		    )
7145 		    {
7146 			environ[0] = Nullch;
7147 		    }
7148 #endif
7149 #endif /* !PERL_MICRO */
7150 		}
7151 	    }
7152 	}
7153     }
7154 }
7155 
7156 /*
7157 =for apidoc sv_2io
7158 
7159 Using various gambits, try to get an IO from an SV: the IO slot if its a
7160 GV; or the recursive result if we're an RV; or the IO slot of the symbol
7161 named after the PV if we're a string.
7162 
7163 =cut
7164 */
7165 
7166 IO*
Perl_sv_2io(pTHX_ SV * sv)7167 Perl_sv_2io(pTHX_ SV *sv)
7168 {
7169     IO* io;
7170     GV* gv;
7171     STRLEN n_a;
7172 
7173     switch (SvTYPE(sv)) {
7174     case SVt_PVIO:
7175 	io = (IO*)sv;
7176 	break;
7177     case SVt_PVGV:
7178 	gv = (GV*)sv;
7179 	io = GvIO(gv);
7180 	if (!io)
7181 	    Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
7182 	break;
7183     default:
7184 	if (!SvOK(sv))
7185 	    Perl_croak(aTHX_ PL_no_usym, "filehandle");
7186 	if (SvROK(sv))
7187 	    return sv_2io(SvRV(sv));
7188 	gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
7189 	if (gv)
7190 	    io = GvIO(gv);
7191 	else
7192 	    io = 0;
7193 	if (!io)
7194 	    Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
7195 	break;
7196     }
7197     return io;
7198 }
7199 
7200 /*
7201 =for apidoc sv_2cv
7202 
7203 Using various gambits, try to get a CV from an SV; in addition, try if
7204 possible to set C<*st> and C<*gvp> to the stash and GV associated with it.
7205 
7206 =cut
7207 */
7208 
7209 CV *
Perl_sv_2cv(pTHX_ SV * sv,HV ** st,GV ** gvp,I32 lref)7210 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
7211 {
7212     GV *gv = Nullgv;
7213     CV *cv = Nullcv;
7214     STRLEN n_a;
7215 
7216     if (!sv)
7217 	return *gvp = Nullgv, Nullcv;
7218     switch (SvTYPE(sv)) {
7219     case SVt_PVCV:
7220 	*st = CvSTASH(sv);
7221 	*gvp = Nullgv;
7222 	return (CV*)sv;
7223     case SVt_PVHV:
7224     case SVt_PVAV:
7225 	*gvp = Nullgv;
7226 	return Nullcv;
7227     case SVt_PVGV:
7228 	gv = (GV*)sv;
7229 	*gvp = gv;
7230 	*st = GvESTASH(gv);
7231 	goto fix_gv;
7232 
7233     default:
7234 	if (SvGMAGICAL(sv))
7235 	    mg_get(sv);
7236 	if (SvROK(sv)) {
7237 	    SV **sp = &sv;		/* Used in tryAMAGICunDEREF macro. */
7238 	    tryAMAGICunDEREF(to_cv);
7239 
7240 	    sv = SvRV(sv);
7241 	    if (SvTYPE(sv) == SVt_PVCV) {
7242 		cv = (CV*)sv;
7243 		*gvp = Nullgv;
7244 		*st = CvSTASH(cv);
7245 		return cv;
7246 	    }
7247 	    else if(isGV(sv))
7248 		gv = (GV*)sv;
7249 	    else
7250 		Perl_croak(aTHX_ "Not a subroutine reference");
7251 	}
7252 	else if (isGV(sv))
7253 	    gv = (GV*)sv;
7254 	else
7255 	    gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
7256 	*gvp = gv;
7257 	if (!gv)
7258 	    return Nullcv;
7259 	*st = GvESTASH(gv);
7260     fix_gv:
7261 	if (lref && !GvCVu(gv)) {
7262 	    SV *tmpsv;
7263 	    ENTER;
7264 	    tmpsv = NEWSV(704,0);
7265 	    gv_efullname3(tmpsv, gv, Nullch);
7266 	    /* XXX this is probably not what they think they're getting.
7267 	     * It has the same effect as "sub name;", i.e. just a forward
7268 	     * declaration! */
7269 	    newSUB(start_subparse(FALSE, 0),
7270 		   newSVOP(OP_CONST, 0, tmpsv),
7271 		   Nullop,
7272 		   Nullop);
7273 	    LEAVE;
7274 	    if (!GvCVu(gv))
7275 		Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
7276 			   sv);
7277 	}
7278 	return GvCVu(gv);
7279     }
7280 }
7281 
7282 /*
7283 =for apidoc sv_true
7284 
7285 Returns true if the SV has a true value by Perl's rules.
7286 Use the C<SvTRUE> macro instead, which may call C<sv_true()> or may
7287 instead use an in-line version.
7288 
7289 =cut
7290 */
7291 
7292 I32
Perl_sv_true(pTHX_ register SV * sv)7293 Perl_sv_true(pTHX_ register SV *sv)
7294 {
7295     if (!sv)
7296 	return 0;
7297     if (SvPOK(sv)) {
7298 	register XPV* tXpv;
7299 	if ((tXpv = (XPV*)SvANY(sv)) &&
7300 		(tXpv->xpv_cur > 1 ||
7301 		(tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
7302 	    return 1;
7303 	else
7304 	    return 0;
7305     }
7306     else {
7307 	if (SvIOK(sv))
7308 	    return SvIVX(sv) != 0;
7309 	else {
7310 	    if (SvNOK(sv))
7311 		return SvNVX(sv) != 0.0;
7312 	    else
7313 		return sv_2bool(sv);
7314 	}
7315     }
7316 }
7317 
7318 /*
7319 =for apidoc sv_iv
7320 
7321 A private implementation of the C<SvIVx> macro for compilers which can't
7322 cope with complex macro expressions. Always use the macro instead.
7323 
7324 =cut
7325 */
7326 
7327 IV
Perl_sv_iv(pTHX_ register SV * sv)7328 Perl_sv_iv(pTHX_ register SV *sv)
7329 {
7330     if (SvIOK(sv)) {
7331 	if (SvIsUV(sv))
7332 	    return (IV)SvUVX(sv);
7333 	return SvIVX(sv);
7334     }
7335     return sv_2iv(sv);
7336 }
7337 
7338 /*
7339 =for apidoc sv_uv
7340 
7341 A private implementation of the C<SvUVx> macro for compilers which can't
7342 cope with complex macro expressions. Always use the macro instead.
7343 
7344 =cut
7345 */
7346 
7347 UV
Perl_sv_uv(pTHX_ register SV * sv)7348 Perl_sv_uv(pTHX_ register SV *sv)
7349 {
7350     if (SvIOK(sv)) {
7351 	if (SvIsUV(sv))
7352 	    return SvUVX(sv);
7353 	return (UV)SvIVX(sv);
7354     }
7355     return sv_2uv(sv);
7356 }
7357 
7358 /*
7359 =for apidoc sv_nv
7360 
7361 A private implementation of the C<SvNVx> macro for compilers which can't
7362 cope with complex macro expressions. Always use the macro instead.
7363 
7364 =cut
7365 */
7366 
7367 NV
Perl_sv_nv(pTHX_ register SV * sv)7368 Perl_sv_nv(pTHX_ register SV *sv)
7369 {
7370     if (SvNOK(sv))
7371 	return SvNVX(sv);
7372     return sv_2nv(sv);
7373 }
7374 
7375 /* sv_pv() is now a macro using SvPV_nolen();
7376  * this function provided for binary compatibility only
7377  */
7378 
7379 char *
Perl_sv_pv(pTHX_ SV * sv)7380 Perl_sv_pv(pTHX_ SV *sv)
7381 {
7382     STRLEN n_a;
7383 
7384     if (SvPOK(sv))
7385 	return SvPVX(sv);
7386 
7387     return sv_2pv(sv, &n_a);
7388 }
7389 
7390 /*
7391 =for apidoc sv_pv
7392 
7393 Use the C<SvPV_nolen> macro instead
7394 
7395 =for apidoc sv_pvn
7396 
7397 A private implementation of the C<SvPV> macro for compilers which can't
7398 cope with complex macro expressions. Always use the macro instead.
7399 
7400 =cut
7401 */
7402 
7403 char *
Perl_sv_pvn(pTHX_ SV * sv,STRLEN * lp)7404 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
7405 {
7406     if (SvPOK(sv)) {
7407 	*lp = SvCUR(sv);
7408 	return SvPVX(sv);
7409     }
7410     return sv_2pv(sv, lp);
7411 }
7412 
7413 
7414 char *
Perl_sv_pvn_nomg(pTHX_ register SV * sv,STRLEN * lp)7415 Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
7416 {
7417     if (SvPOK(sv)) {
7418 	*lp = SvCUR(sv);
7419 	return SvPVX(sv);
7420     }
7421     return sv_2pv_flags(sv, lp, 0);
7422 }
7423 
7424 /* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
7425  * this function provided for binary compatibility only
7426  */
7427 
7428 char *
Perl_sv_pvn_force(pTHX_ SV * sv,STRLEN * lp)7429 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
7430 {
7431     return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
7432 }
7433 
7434 /*
7435 =for apidoc sv_pvn_force
7436 
7437 Get a sensible string out of the SV somehow.
7438 A private implementation of the C<SvPV_force> macro for compilers which
7439 can't cope with complex macro expressions. Always use the macro instead.
7440 
7441 =for apidoc sv_pvn_force_flags
7442 
7443 Get a sensible string out of the SV somehow.
7444 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
7445 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
7446 implemented in terms of this function.
7447 You normally want to use the various wrapper macros instead: see
7448 C<SvPV_force> and C<SvPV_force_nomg>
7449 
7450 =cut
7451 */
7452 
7453 char *
Perl_sv_pvn_force_flags(pTHX_ SV * sv,STRLEN * lp,I32 flags)7454 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
7455 {
7456     char *s = NULL;
7457 
7458     if (SvTHINKFIRST(sv) && !SvROK(sv))
7459 	sv_force_normal(sv);
7460 
7461     if (SvPOK(sv)) {
7462 	*lp = SvCUR(sv);
7463     }
7464     else {
7465 	if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
7466 	    Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
7467 		OP_NAME(PL_op));
7468 	}
7469 	else
7470 	    s = sv_2pv_flags(sv, lp, flags);
7471 	if (s != SvPVX(sv)) {	/* Almost, but not quite, sv_setpvn() */
7472 	    STRLEN len = *lp;
7473 
7474 	    if (SvROK(sv))
7475 		sv_unref(sv);
7476 	    (void)SvUPGRADE(sv, SVt_PV);		/* Never FALSE */
7477 	    SvGROW(sv, len + 1);
7478 	    Move(s,SvPVX(sv),len,char);
7479 	    SvCUR_set(sv, len);
7480 	    *SvEND(sv) = '\0';
7481 	}
7482 	if (!SvPOK(sv)) {
7483 	    SvPOK_on(sv);		/* validate pointer */
7484 	    SvTAINT(sv);
7485 	    DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
7486 				  PTR2UV(sv),SvPVX(sv)));
7487 	}
7488     }
7489     return SvPVX(sv);
7490 }
7491 
7492 /* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
7493  * this function provided for binary compatibility only
7494  */
7495 
7496 char *
Perl_sv_pvbyte(pTHX_ SV * sv)7497 Perl_sv_pvbyte(pTHX_ SV *sv)
7498 {
7499     sv_utf8_downgrade(sv,0);
7500     return sv_pv(sv);
7501 }
7502 
7503 /*
7504 =for apidoc sv_pvbyte
7505 
7506 Use C<SvPVbyte_nolen> instead.
7507 
7508 =for apidoc sv_pvbyten
7509 
7510 A private implementation of the C<SvPVbyte> macro for compilers
7511 which can't cope with complex macro expressions. Always use the macro
7512 instead.
7513 
7514 =cut
7515 */
7516 
7517 char *
Perl_sv_pvbyten(pTHX_ SV * sv,STRLEN * lp)7518 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
7519 {
7520     sv_utf8_downgrade(sv,0);
7521     return sv_pvn(sv,lp);
7522 }
7523 
7524 /*
7525 =for apidoc sv_pvbyten_force
7526 
7527 A private implementation of the C<SvPVbytex_force> macro for compilers
7528 which can't cope with complex macro expressions. Always use the macro
7529 instead.
7530 
7531 =cut
7532 */
7533 
7534 char *
Perl_sv_pvbyten_force(pTHX_ SV * sv,STRLEN * lp)7535 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
7536 {
7537     sv_utf8_downgrade(sv,0);
7538     return sv_pvn_force(sv,lp);
7539 }
7540 
7541 /* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
7542  * this function provided for binary compatibility only
7543  */
7544 
7545 char *
Perl_sv_pvutf8(pTHX_ SV * sv)7546 Perl_sv_pvutf8(pTHX_ SV *sv)
7547 {
7548     sv_utf8_upgrade(sv);
7549     return sv_pv(sv);
7550 }
7551 
7552 /*
7553 =for apidoc sv_pvutf8
7554 
7555 Use the C<SvPVutf8_nolen> macro instead
7556 
7557 =for apidoc sv_pvutf8n
7558 
7559 A private implementation of the C<SvPVutf8> macro for compilers
7560 which can't cope with complex macro expressions. Always use the macro
7561 instead.
7562 
7563 =cut
7564 */
7565 
7566 char *
Perl_sv_pvutf8n(pTHX_ SV * sv,STRLEN * lp)7567 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
7568 {
7569     sv_utf8_upgrade(sv);
7570     return sv_pvn(sv,lp);
7571 }
7572 
7573 /*
7574 =for apidoc sv_pvutf8n_force
7575 
7576 A private implementation of the C<SvPVutf8_force> macro for compilers
7577 which can't cope with complex macro expressions. Always use the macro
7578 instead.
7579 
7580 =cut
7581 */
7582 
7583 char *
Perl_sv_pvutf8n_force(pTHX_ SV * sv,STRLEN * lp)7584 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
7585 {
7586     sv_utf8_upgrade(sv);
7587     return sv_pvn_force(sv,lp);
7588 }
7589 
7590 /*
7591 =for apidoc sv_reftype
7592 
7593 Returns a string describing what the SV is a reference to.
7594 
7595 =cut
7596 */
7597 
7598 char *
Perl_sv_reftype(pTHX_ SV * sv,int ob)7599 Perl_sv_reftype(pTHX_ SV *sv, int ob)
7600 {
7601     if (ob && SvOBJECT(sv)) {
7602         HV *svs = SvSTASH(sv);
7603         /* [20011101.072] This bandaid for C<package;> should eventually
7604            be removed. AMS 20011103 */
7605         return (svs ? HvNAME(svs) : "<none>");
7606     }
7607     else {
7608 	switch (SvTYPE(sv)) {
7609 	case SVt_NULL:
7610 	case SVt_IV:
7611 	case SVt_NV:
7612 	case SVt_RV:
7613 	case SVt_PV:
7614 	case SVt_PVIV:
7615 	case SVt_PVNV:
7616 	case SVt_PVMG:
7617 	case SVt_PVBM:
7618 				if (SvROK(sv))
7619 				    return "REF";
7620 				else
7621 				    return "SCALAR";
7622 
7623 	case SVt_PVLV:		return SvROK(sv) ? "REF"
7624 				/* tied lvalues should appear to be
7625 				 * scalars for backwards compatitbility */
7626 				: (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
7627 				    ? "SCALAR" : "LVALUE";
7628 	case SVt_PVAV:		return "ARRAY";
7629 	case SVt_PVHV:		return "HASH";
7630 	case SVt_PVCV:		return "CODE";
7631 	case SVt_PVGV:		return "GLOB";
7632 	case SVt_PVFM:		return "FORMAT";
7633 	case SVt_PVIO:		return "IO";
7634 	default:		return "UNKNOWN";
7635 	}
7636     }
7637 }
7638 
7639 /*
7640 =for apidoc sv_isobject
7641 
7642 Returns a boolean indicating whether the SV is an RV pointing to a blessed
7643 object.  If the SV is not an RV, or if the object is not blessed, then this
7644 will return false.
7645 
7646 =cut
7647 */
7648 
7649 int
Perl_sv_isobject(pTHX_ SV * sv)7650 Perl_sv_isobject(pTHX_ SV *sv)
7651 {
7652     if (!sv)
7653 	return 0;
7654     if (SvGMAGICAL(sv))
7655 	mg_get(sv);
7656     if (!SvROK(sv))
7657 	return 0;
7658     sv = (SV*)SvRV(sv);
7659     if (!SvOBJECT(sv))
7660 	return 0;
7661     return 1;
7662 }
7663 
7664 /*
7665 =for apidoc sv_isa
7666 
7667 Returns a boolean indicating whether the SV is blessed into the specified
7668 class.  This does not check for subtypes; use C<sv_derived_from> to verify
7669 an inheritance relationship.
7670 
7671 =cut
7672 */
7673 
7674 int
Perl_sv_isa(pTHX_ SV * sv,const char * name)7675 Perl_sv_isa(pTHX_ SV *sv, const char *name)
7676 {
7677     if (!sv)
7678 	return 0;
7679     if (SvGMAGICAL(sv))
7680 	mg_get(sv);
7681     if (!SvROK(sv))
7682 	return 0;
7683     sv = (SV*)SvRV(sv);
7684     if (!SvOBJECT(sv))
7685 	return 0;
7686 
7687     return strEQ(HvNAME(SvSTASH(sv)), name);
7688 }
7689 
7690 /*
7691 =for apidoc newSVrv
7692 
7693 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
7694 it will be upgraded to one.  If C<classname> is non-null then the new SV will
7695 be blessed in the specified package.  The new SV is returned and its
7696 reference count is 1.
7697 
7698 =cut
7699 */
7700 
7701 SV*
Perl_newSVrv(pTHX_ SV * rv,const char * classname)7702 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
7703 {
7704     SV *sv;
7705 
7706     new_SV(sv);
7707 
7708     SV_CHECK_THINKFIRST(rv);
7709     SvAMAGIC_off(rv);
7710 
7711     if (SvTYPE(rv) >= SVt_PVMG) {
7712 	U32 refcnt = SvREFCNT(rv);
7713 	SvREFCNT(rv) = 0;
7714 	sv_clear(rv);
7715 	SvFLAGS(rv) = 0;
7716 	SvREFCNT(rv) = refcnt;
7717     }
7718 
7719     if (SvTYPE(rv) < SVt_RV)
7720 	sv_upgrade(rv, SVt_RV);
7721     else if (SvTYPE(rv) > SVt_RV) {
7722 	(void)SvOOK_off(rv);
7723 	if (SvPVX(rv) && SvLEN(rv))
7724 	    Safefree(SvPVX(rv));
7725 	SvCUR_set(rv, 0);
7726 	SvLEN_set(rv, 0);
7727     }
7728 
7729     (void)SvOK_off(rv);
7730     SvRV(rv) = sv;
7731     SvROK_on(rv);
7732 
7733     if (classname) {
7734 	HV* stash = gv_stashpv(classname, TRUE);
7735 	(void)sv_bless(rv, stash);
7736     }
7737     return sv;
7738 }
7739 
7740 /*
7741 =for apidoc sv_setref_pv
7742 
7743 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
7744 argument will be upgraded to an RV.  That RV will be modified to point to
7745 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
7746 into the SV.  The C<classname> argument indicates the package for the
7747 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7748 will have a reference count of 1, and the RV will be returned.
7749 
7750 Do not use with other Perl types such as HV, AV, SV, CV, because those
7751 objects will become corrupted by the pointer copy process.
7752 
7753 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
7754 
7755 =cut
7756 */
7757 
7758 SV*
Perl_sv_setref_pv(pTHX_ SV * rv,const char * classname,void * pv)7759 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
7760 {
7761     if (!pv) {
7762 	sv_setsv(rv, &PL_sv_undef);
7763 	SvSETMAGIC(rv);
7764     }
7765     else
7766 	sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
7767     return rv;
7768 }
7769 
7770 /*
7771 =for apidoc sv_setref_iv
7772 
7773 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
7774 argument will be upgraded to an RV.  That RV will be modified to point to
7775 the new SV.  The C<classname> argument indicates the package for the
7776 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7777 will have a reference count of 1, and the RV will be returned.
7778 
7779 =cut
7780 */
7781 
7782 SV*
Perl_sv_setref_iv(pTHX_ SV * rv,const char * classname,IV iv)7783 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
7784 {
7785     sv_setiv(newSVrv(rv,classname), iv);
7786     return rv;
7787 }
7788 
7789 /*
7790 =for apidoc sv_setref_uv
7791 
7792 Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
7793 argument will be upgraded to an RV.  That RV will be modified to point to
7794 the new SV.  The C<classname> argument indicates the package for the
7795 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7796 will have a reference count of 1, and the RV will be returned.
7797 
7798 =cut
7799 */
7800 
7801 SV*
Perl_sv_setref_uv(pTHX_ SV * rv,const char * classname,UV uv)7802 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
7803 {
7804     sv_setuv(newSVrv(rv,classname), uv);
7805     return rv;
7806 }
7807 
7808 /*
7809 =for apidoc sv_setref_nv
7810 
7811 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
7812 argument will be upgraded to an RV.  That RV will be modified to point to
7813 the new SV.  The C<classname> argument indicates the package for the
7814 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
7815 will have a reference count of 1, and the RV will be returned.
7816 
7817 =cut
7818 */
7819 
7820 SV*
Perl_sv_setref_nv(pTHX_ SV * rv,const char * classname,NV nv)7821 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
7822 {
7823     sv_setnv(newSVrv(rv,classname), nv);
7824     return rv;
7825 }
7826 
7827 /*
7828 =for apidoc sv_setref_pvn
7829 
7830 Copies a string into a new SV, optionally blessing the SV.  The length of the
7831 string must be specified with C<n>.  The C<rv> argument will be upgraded to
7832 an RV.  That RV will be modified to point to the new SV.  The C<classname>
7833 argument indicates the package for the blessing.  Set C<classname> to
7834 C<Nullch> to avoid the blessing.  The new SV will have a reference count
7835 of 1, and the RV will be returned.
7836 
7837 Note that C<sv_setref_pv> copies the pointer while this copies the string.
7838 
7839 =cut
7840 */
7841 
7842 SV*
Perl_sv_setref_pvn(pTHX_ SV * rv,const char * classname,char * pv,STRLEN n)7843 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
7844 {
7845     sv_setpvn(newSVrv(rv,classname), pv, n);
7846     return rv;
7847 }
7848 
7849 /*
7850 =for apidoc sv_bless
7851 
7852 Blesses an SV into a specified package.  The SV must be an RV.  The package
7853 must be designated by its stash (see C<gv_stashpv()>).  The reference count
7854 of the SV is unaffected.
7855 
7856 =cut
7857 */
7858 
7859 SV*
Perl_sv_bless(pTHX_ SV * sv,HV * stash)7860 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
7861 {
7862     SV *tmpRef;
7863     if (!SvROK(sv))
7864         Perl_croak(aTHX_ "Can't bless non-reference value");
7865     tmpRef = SvRV(sv);
7866     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
7867 	if (SvREADONLY(tmpRef))
7868 	    Perl_croak(aTHX_ PL_no_modify);
7869 	if (SvOBJECT(tmpRef)) {
7870 	    if (SvTYPE(tmpRef) != SVt_PVIO)
7871 		--PL_sv_objcount;
7872 	    SvREFCNT_dec(SvSTASH(tmpRef));
7873 	}
7874     }
7875     SvOBJECT_on(tmpRef);
7876     if (SvTYPE(tmpRef) != SVt_PVIO)
7877 	++PL_sv_objcount;
7878     (void)SvUPGRADE(tmpRef, SVt_PVMG);
7879     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
7880 
7881     if (Gv_AMG(stash))
7882 	SvAMAGIC_on(sv);
7883     else
7884 	SvAMAGIC_off(sv);
7885 
7886     if(SvSMAGICAL(tmpRef))
7887         if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
7888             mg_set(tmpRef);
7889 
7890 
7891 
7892     return sv;
7893 }
7894 
7895 /* Downgrades a PVGV to a PVMG.
7896  */
7897 
7898 STATIC void
S_sv_unglob(pTHX_ SV * sv)7899 S_sv_unglob(pTHX_ SV *sv)
7900 {
7901     void *xpvmg;
7902 
7903     assert(SvTYPE(sv) == SVt_PVGV);
7904     SvFAKE_off(sv);
7905     if (GvGP(sv))
7906 	gp_free((GV*)sv);
7907     if (GvSTASH(sv)) {
7908 	SvREFCNT_dec(GvSTASH(sv));
7909 	GvSTASH(sv) = Nullhv;
7910     }
7911     sv_unmagic(sv, PERL_MAGIC_glob);
7912     Safefree(GvNAME(sv));
7913     GvMULTI_off(sv);
7914 
7915     /* need to keep SvANY(sv) in the right arena */
7916     xpvmg = new_XPVMG();
7917     StructCopy(SvANY(sv), xpvmg, XPVMG);
7918     del_XPVGV(SvANY(sv));
7919     SvANY(sv) = xpvmg;
7920 
7921     SvFLAGS(sv) &= ~SVTYPEMASK;
7922     SvFLAGS(sv) |= SVt_PVMG;
7923 }
7924 
7925 /*
7926 =for apidoc sv_unref_flags
7927 
7928 Unsets the RV status of the SV, and decrements the reference count of
7929 whatever was being referenced by the RV.  This can almost be thought of
7930 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
7931 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
7932 (otherwise the decrementing is conditional on the reference count being
7933 different from one or the reference being a readonly SV).
7934 See C<SvROK_off>.
7935 
7936 =cut
7937 */
7938 
7939 void
Perl_sv_unref_flags(pTHX_ SV * sv,U32 flags)7940 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
7941 {
7942     SV* rv = SvRV(sv);
7943 
7944     if (SvWEAKREF(sv)) {
7945     	sv_del_backref(sv);
7946 	SvWEAKREF_off(sv);
7947 	SvRV(sv) = 0;
7948 	return;
7949     }
7950     SvRV(sv) = 0;
7951     SvROK_off(sv);
7952     /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
7953        assigned to as BEGIN {$a = \"Foo"} will fail.  */
7954     if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
7955 	SvREFCNT_dec(rv);
7956     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
7957 	sv_2mortal(rv);		/* Schedule for freeing later */
7958 }
7959 
7960 /*
7961 =for apidoc sv_unref
7962 
7963 Unsets the RV status of the SV, and decrements the reference count of
7964 whatever was being referenced by the RV.  This can almost be thought of
7965 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
7966 being zero.  See C<SvROK_off>.
7967 
7968 =cut
7969 */
7970 
7971 void
Perl_sv_unref(pTHX_ SV * sv)7972 Perl_sv_unref(pTHX_ SV *sv)
7973 {
7974     sv_unref_flags(sv, 0);
7975 }
7976 
7977 /*
7978 =for apidoc sv_taint
7979 
7980 Taint an SV. Use C<SvTAINTED_on> instead.
7981 =cut
7982 */
7983 
7984 void
Perl_sv_taint(pTHX_ SV * sv)7985 Perl_sv_taint(pTHX_ SV *sv)
7986 {
7987     sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
7988 }
7989 
7990 /*
7991 =for apidoc sv_untaint
7992 
7993 Untaint an SV. Use C<SvTAINTED_off> instead.
7994 =cut
7995 */
7996 
7997 void
Perl_sv_untaint(pTHX_ SV * sv)7998 Perl_sv_untaint(pTHX_ SV *sv)
7999 {
8000     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8001 	MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8002 	if (mg)
8003 	    mg->mg_len &= ~1;
8004     }
8005 }
8006 
8007 /*
8008 =for apidoc sv_tainted
8009 
8010 Test an SV for taintedness. Use C<SvTAINTED> instead.
8011 =cut
8012 */
8013 
8014 bool
Perl_sv_tainted(pTHX_ SV * sv)8015 Perl_sv_tainted(pTHX_ SV *sv)
8016 {
8017     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
8018 	MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
8019 	if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
8020 	    return TRUE;
8021     }
8022     return FALSE;
8023 }
8024 
8025 /*
8026 =for apidoc sv_setpviv
8027 
8028 Copies an integer into the given SV, also updating its string value.
8029 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
8030 
8031 =cut
8032 */
8033 
8034 void
Perl_sv_setpviv(pTHX_ SV * sv,IV iv)8035 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
8036 {
8037     char buf[TYPE_CHARS(UV)];
8038     char *ebuf;
8039     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8040 
8041     sv_setpvn(sv, ptr, ebuf - ptr);
8042 }
8043 
8044 /*
8045 =for apidoc sv_setpviv_mg
8046 
8047 Like C<sv_setpviv>, but also handles 'set' magic.
8048 
8049 =cut
8050 */
8051 
8052 void
Perl_sv_setpviv_mg(pTHX_ SV * sv,IV iv)8053 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
8054 {
8055     char buf[TYPE_CHARS(UV)];
8056     char *ebuf;
8057     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
8058 
8059     sv_setpvn(sv, ptr, ebuf - ptr);
8060     SvSETMAGIC(sv);
8061 }
8062 
8063 #if defined(PERL_IMPLICIT_CONTEXT)
8064 
8065 /* pTHX_ magic can't cope with varargs, so this is a no-context
8066  * version of the main function, (which may itself be aliased to us).
8067  * Don't access this version directly.
8068  */
8069 
8070 void
Perl_sv_setpvf_nocontext(SV * sv,const char * pat,...)8071 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
8072 {
8073     dTHX;
8074     va_list args;
8075     va_start(args, pat);
8076     sv_vsetpvf(sv, pat, &args);
8077     va_end(args);
8078 }
8079 
8080 /* pTHX_ magic can't cope with varargs, so this is a no-context
8081  * version of the main function, (which may itself be aliased to us).
8082  * Don't access this version directly.
8083  */
8084 
8085 void
Perl_sv_setpvf_mg_nocontext(SV * sv,const char * pat,...)8086 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
8087 {
8088     dTHX;
8089     va_list args;
8090     va_start(args, pat);
8091     sv_vsetpvf_mg(sv, pat, &args);
8092     va_end(args);
8093 }
8094 #endif
8095 
8096 /*
8097 =for apidoc sv_setpvf
8098 
8099 Processes its arguments like C<sprintf> and sets an SV to the formatted
8100 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
8101 
8102 =cut
8103 */
8104 
8105 void
Perl_sv_setpvf(pTHX_ SV * sv,const char * pat,...)8106 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
8107 {
8108     va_list args;
8109     va_start(args, pat);
8110     sv_vsetpvf(sv, pat, &args);
8111     va_end(args);
8112 }
8113 
8114 /* backend for C<sv_setpvf> and C<sv_setpvf_nocontext> */
8115 
8116 void
Perl_sv_vsetpvf(pTHX_ SV * sv,const char * pat,va_list * args)8117 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8118 {
8119     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8120 }
8121 
8122 /*
8123 =for apidoc sv_setpvf_mg
8124 
8125 Like C<sv_setpvf>, but also handles 'set' magic.
8126 
8127 =cut
8128 */
8129 
8130 void
Perl_sv_setpvf_mg(pTHX_ SV * sv,const char * pat,...)8131 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8132 {
8133     va_list args;
8134     va_start(args, pat);
8135     sv_vsetpvf_mg(sv, pat, &args);
8136     va_end(args);
8137 }
8138 
8139 /* backend for C<sv_setpvf_mg> C<setpvf_mg_nocontext> */
8140 
8141 void
Perl_sv_vsetpvf_mg(pTHX_ SV * sv,const char * pat,va_list * args)8142 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8143 {
8144     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8145     SvSETMAGIC(sv);
8146 }
8147 
8148 #if defined(PERL_IMPLICIT_CONTEXT)
8149 
8150 /* pTHX_ magic can't cope with varargs, so this is a no-context
8151  * version of the main function, (which may itself be aliased to us).
8152  * Don't access this version directly.
8153  */
8154 
8155 void
Perl_sv_catpvf_nocontext(SV * sv,const char * pat,...)8156 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
8157 {
8158     dTHX;
8159     va_list args;
8160     va_start(args, pat);
8161     sv_vcatpvf(sv, pat, &args);
8162     va_end(args);
8163 }
8164 
8165 /* pTHX_ magic can't cope with varargs, so this is a no-context
8166  * version of the main function, (which may itself be aliased to us).
8167  * Don't access this version directly.
8168  */
8169 
8170 void
Perl_sv_catpvf_mg_nocontext(SV * sv,const char * pat,...)8171 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
8172 {
8173     dTHX;
8174     va_list args;
8175     va_start(args, pat);
8176     sv_vcatpvf_mg(sv, pat, &args);
8177     va_end(args);
8178 }
8179 #endif
8180 
8181 /*
8182 =for apidoc sv_catpvf
8183 
8184 Processes its arguments like C<sprintf> and appends the formatted
8185 output to an SV.  If the appended data contains "wide" characters
8186 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
8187 and characters >255 formatted with %c), the original SV might get
8188 upgraded to UTF-8.  Handles 'get' magic, but not 'set' magic.
8189 C<SvSETMAGIC()> must typically be called after calling this function
8190 to handle 'set' magic.
8191 
8192 =cut */
8193 
8194 void
Perl_sv_catpvf(pTHX_ SV * sv,const char * pat,...)8195 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
8196 {
8197     va_list args;
8198     va_start(args, pat);
8199     sv_vcatpvf(sv, pat, &args);
8200     va_end(args);
8201 }
8202 
8203 /* backend for C<sv_catpvf> and C<catpvf_mg_nocontext> */
8204 
8205 void
Perl_sv_vcatpvf(pTHX_ SV * sv,const char * pat,va_list * args)8206 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
8207 {
8208     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8209 }
8210 
8211 /*
8212 =for apidoc sv_catpvf_mg
8213 
8214 Like C<sv_catpvf>, but also handles 'set' magic.
8215 
8216 =cut
8217 */
8218 
8219 void
Perl_sv_catpvf_mg(pTHX_ SV * sv,const char * pat,...)8220 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
8221 {
8222     va_list args;
8223     va_start(args, pat);
8224     sv_vcatpvf_mg(sv, pat, &args);
8225     va_end(args);
8226 }
8227 
8228 /* backend for C<catpvf_mg> and C<catpvf_mg_nocontext> */
8229 
8230 void
Perl_sv_vcatpvf_mg(pTHX_ SV * sv,const char * pat,va_list * args)8231 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
8232 {
8233     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
8234     SvSETMAGIC(sv);
8235 }
8236 
8237 /*
8238 =for apidoc sv_vsetpvfn
8239 
8240 Works like C<vcatpvfn> but copies the text into the SV instead of
8241 appending it.
8242 
8243 Usually used via one of its frontends C<sv_setpvf> and C<sv_setpvf_mg>.
8244 
8245 =cut
8246 */
8247 
8248 void
Perl_sv_vsetpvfn(pTHX_ SV * sv,const char * pat,STRLEN patlen,va_list * args,SV ** svargs,I32 svmax,bool * maybe_tainted)8249 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8250 {
8251     sv_setpvn(sv, "", 0);
8252     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
8253 }
8254 
8255 /* private function for use in sv_vcatpvfn via the EXPECT_NUMBER macro */
8256 
8257 STATIC I32
S_expect_number(pTHX_ char ** pattern)8258 S_expect_number(pTHX_ char** pattern)
8259 {
8260     I32 var = 0;
8261     switch (**pattern) {
8262     case '1': case '2': case '3':
8263     case '4': case '5': case '6':
8264     case '7': case '8': case '9':
8265 	while (isDIGIT(**pattern))
8266 	    var = var * 10 + (*(*pattern)++ - '0');
8267     }
8268     return var;
8269 }
8270 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
8271 
8272 static char *
F0convert(NV nv,char * endbuf,STRLEN * len)8273 F0convert(NV nv, char *endbuf, STRLEN *len)
8274 {
8275     int neg = nv < 0;
8276     UV uv;
8277     char *p = endbuf;
8278 
8279     if (neg)
8280 	nv = -nv;
8281     if (nv < UV_MAX) {
8282 	nv += 0.5;
8283 	uv = (UV)nv;
8284 	if (uv & 1 && uv == nv)
8285 	    uv--;			/* Round to even */
8286 	do {
8287 	    unsigned dig = uv % 10;
8288 	    *--p = '0' + dig;
8289 	} while (uv /= 10);
8290 	if (neg)
8291 	    *--p = '-';
8292 	*len = endbuf - p;
8293 	return p;
8294     }
8295     return Nullch;
8296 }
8297 
8298 
8299 /*
8300 =for apidoc sv_vcatpvfn
8301 
8302 Processes its arguments like C<vsprintf> and appends the formatted output
8303 to an SV.  Uses an array of SVs if the C style variable argument list is
8304 missing (NULL).  When running with taint checks enabled, indicates via
8305 C<maybe_tainted> if results are untrustworthy (often due to the use of
8306 locales).
8307 
8308 Usually used via one of its frontends C<sv_catpvf> and C<sv_catpvf_mg>.
8309 
8310 =cut
8311 */
8312 
8313 void
Perl_sv_vcatpvfn(pTHX_ SV * sv,const char * pat,STRLEN patlen,va_list * args,SV ** svargs,I32 svmax,bool * maybe_tainted)8314 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
8315 {
8316     char *p;
8317     char *q;
8318     char *patend;
8319     STRLEN origlen;
8320     I32 svix = 0;
8321     static char nullstr[] = "(null)";
8322     SV *argsv = Nullsv;
8323     bool has_utf8; /* has the result utf8? */
8324     bool pat_utf8; /* the pattern is in utf8? */
8325     SV *nsv = Nullsv;
8326     /* Times 4: a decimal digit takes more than 3 binary digits.
8327      * NV_DIG: mantissa takes than many decimal digits.
8328      * Plus 32: Playing safe. */
8329     char ebuf[IV_DIG * 4 + NV_DIG + 32];
8330     /* large enough for "%#.#f" --chip */
8331     /* what about long double NVs? --jhi */
8332 
8333     has_utf8 = pat_utf8 = DO_UTF8(sv);
8334 
8335     /* no matter what, this is a string now */
8336     (void)SvPV_force(sv, origlen);
8337 
8338     /* special-case "", "%s", and "%_" */
8339     if (patlen == 0)
8340 	return;
8341     if (patlen == 2 && pat[0] == '%') {
8342 	switch (pat[1]) {
8343 	case 's':
8344 	    if (args) {
8345 		char *s = va_arg(*args, char*);
8346 		sv_catpv(sv, s ? s : nullstr);
8347 	    }
8348 	    else if (svix < svmax) {
8349 		sv_catsv(sv, *svargs);
8350 		if (DO_UTF8(*svargs))
8351 		    SvUTF8_on(sv);
8352 	    }
8353 	    return;
8354 	case '_':
8355 	    if (args) {
8356 		argsv = va_arg(*args, SV*);
8357 		sv_catsv(sv, argsv);
8358 		if (DO_UTF8(argsv))
8359 		    SvUTF8_on(sv);
8360 		return;
8361 	    }
8362 	    /* See comment on '_' below */
8363 	    break;
8364 	}
8365     }
8366 
8367 #ifndef USE_LONG_DOUBLE
8368     /* special-case "%.<number>[gf]" */
8369     if ( patlen <= 5 && pat[0] == '%' && pat[1] == '.'
8370 	 && (pat[patlen-1] == 'g' || pat[patlen-1] == 'f') ) {
8371 	unsigned digits = 0;
8372 	const char *pp;
8373 
8374 	pp = pat + 2;
8375 	while (*pp >= '0' && *pp <= '9')
8376 	    digits = 10 * digits + (*pp++ - '0');
8377 	if (pp - pat == (int)patlen - 1) {
8378 	    NV nv;
8379 
8380 	    if (args)
8381 		nv = (NV)va_arg(*args, double);
8382 	    else if (svix < svmax)
8383 		nv = SvNV(*svargs);
8384 	    else
8385 		return;
8386 	    if (*pp == 'g') {
8387 		/* Add check for digits != 0 because it seems that some
8388 		   gconverts are buggy in this case, and we don't yet have
8389 		   a Configure test for this.  */
8390 		if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
8391 		     /* 0, point, slack */
8392 		    Gconvert(nv, (int)digits, 0, ebuf);
8393 		    sv_catpv(sv, ebuf);
8394 		    if (*ebuf)	/* May return an empty string for digits==0 */
8395 			return;
8396 		}
8397 	    } else if (!digits) {
8398 		STRLEN l;
8399 
8400 		if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
8401 		    sv_catpvn(sv, p, l);
8402 		    return;
8403 		}
8404 	    }
8405 	}
8406     }
8407 #endif /* !USE_LONG_DOUBLE */
8408 
8409     if (!args && svix < svmax && DO_UTF8(*svargs))
8410 	has_utf8 = TRUE;
8411 
8412     patend = (char*)pat + patlen;
8413     for (p = (char*)pat; p < patend; p = q) {
8414 	bool alt = FALSE;
8415 	bool left = FALSE;
8416 	bool vectorize = FALSE;
8417 	bool vectorarg = FALSE;
8418 	bool vec_utf8 = FALSE;
8419 	char fill = ' ';
8420 	char plus = 0;
8421 	char intsize = 0;
8422 	STRLEN width = 0;
8423 	STRLEN zeros = 0;
8424 	bool has_precis = FALSE;
8425 	STRLEN precis = 0;
8426 	I32 osvix = svix;
8427 	bool is_utf8 = FALSE;  /* is this item utf8?   */
8428 #ifdef HAS_LDBL_SPRINTF_BUG
8429 	/* This is to try to fix a bug with irix/nonstop-ux/powerux and
8430 	   with sfio - Allen <allens@cpan.org> */
8431 	bool fix_ldbl_sprintf_bug = FALSE;
8432 #endif
8433 
8434 	char esignbuf[4];
8435 	U8 utf8buf[UTF8_MAXLEN+1];
8436 	STRLEN esignlen = 0;
8437 
8438 	char *eptr = Nullch;
8439 	STRLEN elen = 0;
8440 	SV *vecsv = Nullsv;
8441 	U8 *vecstr = Null(U8*);
8442 	STRLEN veclen = 0;
8443 	char c = 0;
8444 	int i;
8445 	unsigned base = 0;
8446 	IV iv = 0;
8447 	UV uv = 0;
8448 	/* we need a long double target in case HAS_LONG_DOUBLE but
8449 	   not USE_LONG_DOUBLE
8450 	*/
8451 #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
8452 	long double nv;
8453 #else
8454 	NV nv;
8455 #endif
8456 	STRLEN have;
8457 	STRLEN need;
8458 	STRLEN gap;
8459 	char *dotstr = ".";
8460 	STRLEN dotstrlen = 1;
8461 	I32 efix = 0; /* explicit format parameter index */
8462 	I32 ewix = 0; /* explicit width index */
8463 	I32 epix = 0; /* explicit precision index */
8464 	I32 evix = 0; /* explicit vector index */
8465 	bool asterisk = FALSE;
8466 
8467 	/* echo everything up to the next format specification */
8468 	for (q = p; q < patend && *q != '%'; ++q) ;
8469 	if (q > p) {
8470 	    if (has_utf8 && !pat_utf8)
8471 		sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
8472 	    else
8473 		sv_catpvn(sv, p, q - p);
8474 	    p = q;
8475 	}
8476 	if (q++ >= patend)
8477 	    break;
8478 
8479 /*
8480     We allow format specification elements in this order:
8481 	\d+\$              explicit format parameter index
8482 	[-+ 0#]+           flags
8483 	v|\*(\d+\$)?v      vector with optional (optionally specified) arg
8484 	0		   flag (as above): repeated to allow "v02"
8485 	\d+|\*(\d+\$)?     width using optional (optionally specified) arg
8486 	\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
8487 	[hlqLV]            size
8488     [%bcdefginopsux_DFOUX] format (mandatory)
8489 */
8490 	if (EXPECT_NUMBER(q, width)) {
8491 	    if (*q == '$') {
8492 		++q;
8493 		efix = width;
8494 	    } else {
8495 		goto gotwidth;
8496 	    }
8497 	}
8498 
8499 	/* FLAGS */
8500 
8501 	while (*q) {
8502 	    switch (*q) {
8503 	    case ' ':
8504 	    case '+':
8505 		plus = *q++;
8506 		continue;
8507 
8508 	    case '-':
8509 		left = TRUE;
8510 		q++;
8511 		continue;
8512 
8513 	    case '0':
8514 		fill = *q++;
8515 		continue;
8516 
8517 	    case '#':
8518 		alt = TRUE;
8519 		q++;
8520 		continue;
8521 
8522 	    default:
8523 		break;
8524 	    }
8525 	    break;
8526 	}
8527 
8528       tryasterisk:
8529 	if (*q == '*') {
8530 	    q++;
8531 	    if (EXPECT_NUMBER(q, ewix))
8532 		if (*q++ != '$')
8533 		    goto unknown;
8534 	    asterisk = TRUE;
8535 	}
8536 	if (*q == 'v') {
8537 	    q++;
8538 	    if (vectorize)
8539 		goto unknown;
8540 	    if ((vectorarg = asterisk)) {
8541 		evix = ewix;
8542 		ewix = 0;
8543 		asterisk = FALSE;
8544 	    }
8545 	    vectorize = TRUE;
8546 	    goto tryasterisk;
8547 	}
8548 
8549 	if (!asterisk)
8550 	    if( *q == '0' )
8551 		fill = *q++;
8552 	    EXPECT_NUMBER(q, width);
8553 
8554 	if (vectorize) {
8555 	    if (vectorarg) {
8556 		if (args)
8557 		    vecsv = va_arg(*args, SV*);
8558 		else if (evix) {
8559 		    vecsv = (evix > 0 && evix <= svmax)
8560 			? svargs[evix-1] : &PL_sv_undef;
8561 		} else {
8562 		    vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef;
8563 		}
8564 		dotstr = SvPVx(vecsv, dotstrlen);
8565 		if (DO_UTF8(vecsv))
8566 		    is_utf8 = TRUE;
8567 	    }
8568 	    if (args) {
8569 		vecsv = va_arg(*args, SV*);
8570 		vecstr = (U8*)SvPVx(vecsv,veclen);
8571 		vec_utf8 = DO_UTF8(vecsv);
8572 	    }
8573 	    else if (efix ? (efix > 0 && efix <= svmax) : svix < svmax) {
8574 		vecsv = svargs[efix ? efix-1 : svix++];
8575 		vecstr = (U8*)SvPVx(vecsv,veclen);
8576 		vec_utf8 = DO_UTF8(vecsv);
8577 	    }
8578 	    else {
8579 		vecsv = &PL_sv_undef;
8580 		vecstr = (U8*)"";
8581 		veclen = 0;
8582 	    }
8583 	}
8584 
8585 	if (asterisk) {
8586 	    if (args)
8587 		i = va_arg(*args, int);
8588 	    else
8589 		i = (ewix ? ewix <= svmax : svix < svmax) ?
8590 		    SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8591 	    left |= (i < 0);
8592 	    width = (i < 0) ? -i : i;
8593 	}
8594       gotwidth:
8595 
8596 	/* PRECISION */
8597 
8598 	if (*q == '.') {
8599 	    q++;
8600 	    if (*q == '*') {
8601 		q++;
8602 		if (EXPECT_NUMBER(q, epix) && *q++ != '$')
8603 		    goto unknown;
8604 		/* XXX: todo, support specified precision parameter */
8605 		if (epix)
8606 		    goto unknown;
8607 		if (args)
8608 		    i = va_arg(*args, int);
8609 		else
8610 		    i = (ewix ? ewix <= svmax : svix < svmax)
8611 			? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
8612 		precis = (i < 0) ? 0 : i;
8613 	    }
8614 	    else {
8615 		precis = 0;
8616 		while (isDIGIT(*q))
8617 		    precis = precis * 10 + (*q++ - '0');
8618 	    }
8619 	    has_precis = TRUE;
8620 	}
8621 
8622 	/* SIZE */
8623 
8624 	switch (*q) {
8625 #ifdef WIN32
8626 	case 'I':			/* Ix, I32x, and I64x */
8627 #  ifdef WIN64
8628 	    if (q[1] == '6' && q[2] == '4') {
8629 		q += 3;
8630 		intsize = 'q';
8631 		break;
8632 	    }
8633 #  endif
8634 	    if (q[1] == '3' && q[2] == '2') {
8635 		q += 3;
8636 		break;
8637 	    }
8638 #  ifdef WIN64
8639 	    intsize = 'q';
8640 #  endif
8641 	    q++;
8642 	    break;
8643 #endif
8644 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8645 	case 'L':			/* Ld */
8646 	    /* FALL THROUGH */
8647 #ifdef HAS_QUAD
8648 	case 'q':			/* qd */
8649 #endif
8650 	    intsize = 'q';
8651 	    q++;
8652 	    break;
8653 #endif
8654 	case 'l':
8655 #if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
8656 	    if (*(q + 1) == 'l') {	/* lld, llf */
8657 		intsize = 'q';
8658 		q += 2;
8659 		break;
8660 	     }
8661 #endif
8662 	    /* FALL THROUGH */
8663 	case 'h':
8664 	    /* FALL THROUGH */
8665 	case 'V':
8666 	    intsize = *q++;
8667 	    break;
8668 	}
8669 
8670 	/* CONVERSION */
8671 
8672 	if (*q == '%') {
8673 	    eptr = q++;
8674 	    elen = 1;
8675 	    goto string;
8676 	}
8677 
8678 	if (vectorize)
8679 	    argsv = vecsv;
8680 	else if (!args) {
8681 	    if (efix) {
8682 		const I32 i = efix-1;
8683 		argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef;
8684 	    } else {
8685 		argsv = (svix >= 0 && svix < svmax)
8686 		    ? svargs[svix++] : &PL_sv_undef;
8687 	    }
8688 	}
8689 
8690 	switch (c = *q++) {
8691 
8692 	    /* STRINGS */
8693 
8694 	case 'c':
8695 	    uv = (args && !vectorize) ? va_arg(*args, int) : SvIVx(argsv);
8696 	    if ((uv > 255 ||
8697 		 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
8698 		&& !IN_BYTES) {
8699 		eptr = (char*)utf8buf;
8700 		elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
8701 		is_utf8 = TRUE;
8702 	    }
8703 	    else {
8704 		c = (char)uv;
8705 		eptr = &c;
8706 		elen = 1;
8707 	    }
8708 	    goto string;
8709 
8710 	case 's':
8711 	    if (args && !vectorize) {
8712 		eptr = va_arg(*args, char*);
8713 		if (eptr)
8714 #ifdef MACOS_TRADITIONAL
8715 		  /* On MacOS, %#s format is used for Pascal strings */
8716 		  if (alt)
8717 		    elen = *eptr++;
8718 		  else
8719 #endif
8720 		    elen = strlen(eptr);
8721 		else {
8722 		    eptr = nullstr;
8723 		    elen = sizeof nullstr - 1;
8724 		}
8725 	    }
8726 	    else {
8727 		eptr = SvPVx(argsv, elen);
8728 		if (DO_UTF8(argsv)) {
8729 		    if (has_precis && precis < elen) {
8730 			I32 p = precis;
8731 			sv_pos_u2b(argsv, &p, 0); /* sticks at end */
8732 			precis = p;
8733 		    }
8734 		    if (width) { /* fudge width (can't fudge elen) */
8735 			width += elen - sv_len_utf8(argsv);
8736 		    }
8737 		    is_utf8 = TRUE;
8738 		}
8739 	    }
8740 	    goto string;
8741 
8742 	case '_':
8743 	    /*
8744 	     * The "%_" hack might have to be changed someday,
8745 	     * if ISO or ANSI decide to use '_' for something.
8746 	     * So we keep it hidden from users' code.
8747 	     */
8748 	    if (!args || vectorize)
8749 		goto unknown;
8750 	    argsv = va_arg(*args, SV*);
8751 	    eptr = SvPVx(argsv, elen);
8752 	    if (DO_UTF8(argsv))
8753 		is_utf8 = TRUE;
8754 
8755 	string:
8756 	    vectorize = FALSE;
8757 	    if (has_precis && elen > precis)
8758 		elen = precis;
8759 	    break;
8760 
8761 	    /* INTEGERS */
8762 
8763 	case 'p':
8764 	    if (alt || vectorize)
8765 		goto unknown;
8766 	    uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
8767 	    base = 16;
8768 	    goto integer;
8769 
8770 	case 'D':
8771 #ifdef IV_IS_QUAD
8772 	    intsize = 'q';
8773 #else
8774 	    intsize = 'l';
8775 #endif
8776 	    /* FALL THROUGH */
8777 	case 'd':
8778 	case 'i':
8779 	    if (vectorize) {
8780 		STRLEN ulen;
8781 		if (!veclen)
8782 		    continue;
8783 		if (vec_utf8)
8784 		    uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8785 					UTF8_ALLOW_ANYUV);
8786 		else {
8787 		    uv = *vecstr;
8788 		    ulen = 1;
8789 		}
8790 		vecstr += ulen;
8791 		veclen -= ulen;
8792 		if (plus)
8793 		     esignbuf[esignlen++] = plus;
8794 	    }
8795 	    else if (args) {
8796 		switch (intsize) {
8797 		case 'h':	iv = (short)va_arg(*args, int); break;
8798 		case 'l':	iv = va_arg(*args, long); break;
8799 		case 'V':	iv = va_arg(*args, IV); break;
8800 		default:	iv = va_arg(*args, int); break;
8801 #ifdef HAS_QUAD
8802 		case 'q':	iv = va_arg(*args, Quad_t); break;
8803 #endif
8804 		}
8805 	    }
8806 	    else {
8807 		IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */
8808 		switch (intsize) {
8809 		case 'h':	iv = (short)tiv; break;
8810 		case 'l':	iv = (long)tiv; break;
8811 		case 'V':
8812 		default:	iv = tiv; break;
8813 #ifdef HAS_QUAD
8814 		case 'q':	iv = (Quad_t)tiv; break;
8815 #endif
8816 		}
8817 	    }
8818 	    if ( !vectorize )	/* we already set uv above */
8819 	    {
8820 		if (iv >= 0) {
8821 		    uv = iv;
8822 		    if (plus)
8823 			esignbuf[esignlen++] = plus;
8824 		}
8825 		else {
8826 		    uv = -iv;
8827 		    esignbuf[esignlen++] = '-';
8828 		}
8829 	    }
8830 	    base = 10;
8831 	    goto integer;
8832 
8833 	case 'U':
8834 #ifdef IV_IS_QUAD
8835 	    intsize = 'q';
8836 #else
8837 	    intsize = 'l';
8838 #endif
8839 	    /* FALL THROUGH */
8840 	case 'u':
8841 	    base = 10;
8842 	    goto uns_integer;
8843 
8844 	case 'b':
8845 	    base = 2;
8846 	    goto uns_integer;
8847 
8848 	case 'O':
8849 #ifdef IV_IS_QUAD
8850 	    intsize = 'q';
8851 #else
8852 	    intsize = 'l';
8853 #endif
8854 	    /* FALL THROUGH */
8855 	case 'o':
8856 	    base = 8;
8857 	    goto uns_integer;
8858 
8859 	case 'X':
8860 	case 'x':
8861 	    base = 16;
8862 
8863 	uns_integer:
8864 	    if (vectorize) {
8865 		STRLEN ulen;
8866 	vector:
8867 		if (!veclen)
8868 		    continue;
8869 		if (vec_utf8)
8870 		    uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
8871 					UTF8_ALLOW_ANYUV);
8872 		else {
8873 		    uv = *vecstr;
8874 		    ulen = 1;
8875 		}
8876 		vecstr += ulen;
8877 		veclen -= ulen;
8878 	    }
8879 	    else if (args) {
8880 		switch (intsize) {
8881 		case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
8882 		case 'l':  uv = va_arg(*args, unsigned long); break;
8883 		case 'V':  uv = va_arg(*args, UV); break;
8884 		default:   uv = va_arg(*args, unsigned); break;
8885 #ifdef HAS_QUAD
8886 		case 'q':  uv = va_arg(*args, Uquad_t); break;
8887 #endif
8888 		}
8889 	    }
8890 	    else {
8891 		UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */
8892 		switch (intsize) {
8893 		case 'h':	uv = (unsigned short)tuv; break;
8894 		case 'l':	uv = (unsigned long)tuv; break;
8895 		case 'V':
8896 		default:	uv = tuv; break;
8897 #ifdef HAS_QUAD
8898 		case 'q':	uv = (Uquad_t)tuv; break;
8899 #endif
8900 		}
8901 	    }
8902 
8903 	integer:
8904 	    eptr = ebuf + sizeof ebuf;
8905 	    switch (base) {
8906 		unsigned dig;
8907 	    case 16:
8908 		if (!uv)
8909 		    alt = FALSE;
8910 		p = (char*)((c == 'X')
8911 			    ? "0123456789ABCDEF" : "0123456789abcdef");
8912 		do {
8913 		    dig = uv & 15;
8914 		    *--eptr = p[dig];
8915 		} while (uv >>= 4);
8916 		if (alt) {
8917 		    esignbuf[esignlen++] = '0';
8918 		    esignbuf[esignlen++] = c;  /* 'x' or 'X' */
8919 		}
8920 		break;
8921 	    case 8:
8922 		do {
8923 		    dig = uv & 7;
8924 		    *--eptr = '0' + dig;
8925 		} while (uv >>= 3);
8926 		if (alt && *eptr != '0')
8927 		    *--eptr = '0';
8928 		break;
8929 	    case 2:
8930 		if (!uv)
8931 		    alt = FALSE;
8932 		do {
8933 		    dig = uv & 1;
8934 		    *--eptr = '0' + dig;
8935 		} while (uv >>= 1);
8936 		if (alt) {
8937 		    esignbuf[esignlen++] = '0';
8938 		    esignbuf[esignlen++] = 'b';
8939 		}
8940 		break;
8941 	    default:		/* it had better be ten or less */
8942 #if defined(PERL_Y2KWARN)
8943 		if (ckWARN(WARN_Y2K)) {
8944 		    STRLEN n;
8945 		    char *s = SvPV(sv,n);
8946 		    if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
8947 			&& (n == 2 || !isDIGIT(s[n-3])))
8948 		    {
8949 			Perl_warner(aTHX_ packWARN(WARN_Y2K),
8950 				    "Possible Y2K bug: %%%c %s",
8951 				    c, "format string following '19'");
8952 		    }
8953 		}
8954 #endif
8955 		do {
8956 		    dig = uv % base;
8957 		    *--eptr = '0' + dig;
8958 		} while (uv /= base);
8959 		break;
8960 	    }
8961 	    elen = (ebuf + sizeof ebuf) - eptr;
8962 	    if (has_precis) {
8963 		if (precis > elen)
8964 		    zeros = precis - elen;
8965 		else if (precis == 0 && elen == 1 && *eptr == '0')
8966 		    elen = 0;
8967 	    }
8968 	    break;
8969 
8970 	    /* FLOATING POINT */
8971 
8972 	case 'F':
8973 	    c = 'f';		/* maybe %F isn't supported here */
8974 	    /* FALL THROUGH */
8975 	case 'e': case 'E':
8976 	case 'f':
8977 	case 'g': case 'G':
8978 
8979 	    /* This is evil, but floating point is even more evil */
8980 
8981 	    /* for SV-style calling, we can only get NV
8982 	       for C-style calling, we assume %f is double;
8983 	       for simplicity we allow any of %Lf, %llf, %qf for long double
8984 	    */
8985 	    switch (intsize) {
8986 	    case 'V':
8987 #if defined(USE_LONG_DOUBLE)
8988 		intsize = 'q';
8989 #endif
8990 		break;
8991 /* [perl #20339] - we should accept and ignore %lf rather than die */
8992 	    case 'l':
8993 		/* FALL THROUGH */
8994 	    default:
8995 #if defined(USE_LONG_DOUBLE)
8996 		intsize = args ? 0 : 'q';
8997 #endif
8998 		break;
8999 	    case 'q':
9000 #if defined(HAS_LONG_DOUBLE)
9001 		break;
9002 #else
9003 		/* FALL THROUGH */
9004 #endif
9005 	    case 'h':
9006 		goto unknown;
9007 	    }
9008 
9009 	    /* now we need (long double) if intsize == 'q', else (double) */
9010 	    nv = (args && !vectorize) ?
9011 #if LONG_DOUBLESIZE > DOUBLESIZE
9012 		intsize == 'q' ?
9013 		    va_arg(*args, long double) :
9014 		    va_arg(*args, double)
9015 #else
9016 		    va_arg(*args, double)
9017 #endif
9018 		: SvNVx(argsv);
9019 
9020 	    need = 0;
9021 	    vectorize = FALSE;
9022 	    if (c != 'e' && c != 'E') {
9023 		i = PERL_INT_MIN;
9024 		/* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
9025 		   will cast our (long double) to (double) */
9026 		(void)Perl_frexp(nv, &i);
9027 		if (i == PERL_INT_MIN)
9028 		    Perl_die(aTHX_ "panic: frexp");
9029 		if (i > 0)
9030 		    need = BIT_DIGITS(i);
9031 	    }
9032 	    need += has_precis ? precis : 6; /* known default */
9033 
9034 	    if (need < width)
9035 		need = width;
9036 
9037 #ifdef HAS_LDBL_SPRINTF_BUG
9038 	    /* This is to try to fix a bug with irix/nonstop-ux/powerux and
9039 	       with sfio - Allen <allens@cpan.org> */
9040 
9041 #  ifdef DBL_MAX
9042 #    define MY_DBL_MAX DBL_MAX
9043 #  else /* XXX guessing! HUGE_VAL may be defined as infinity, so not using */
9044 #    if DOUBLESIZE >= 8
9045 #      define MY_DBL_MAX 1.7976931348623157E+308L
9046 #    else
9047 #      define MY_DBL_MAX 3.40282347E+38L
9048 #    endif
9049 #  endif
9050 
9051 #  ifdef HAS_LDBL_SPRINTF_BUG_LESS1 /* only between -1L & 1L - Allen */
9052 #    define MY_DBL_MAX_BUG 1L
9053 #  else
9054 #    define MY_DBL_MAX_BUG MY_DBL_MAX
9055 #  endif
9056 
9057 #  ifdef DBL_MIN
9058 #    define MY_DBL_MIN DBL_MIN
9059 #  else  /* XXX guessing! -Allen */
9060 #    if DOUBLESIZE >= 8
9061 #      define MY_DBL_MIN 2.2250738585072014E-308L
9062 #    else
9063 #      define MY_DBL_MIN 1.17549435E-38L
9064 #    endif
9065 #  endif
9066 
9067 	    if ((intsize == 'q') && (c == 'f') &&
9068 		((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) &&
9069 		(need < DBL_DIG)) {
9070 		/* it's going to be short enough that
9071 		 * long double precision is not needed */
9072 
9073 		if ((nv <= 0L) && (nv >= -0L))
9074 		    fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */
9075 		else {
9076 		    /* would use Perl_fp_class as a double-check but not
9077 		     * functional on IRIX - see perl.h comments */
9078 
9079 		    if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) {
9080 			/* It's within the range that a double can represent */
9081 #if defined(DBL_MAX) && !defined(DBL_MIN)
9082 			if ((nv >= ((long double)1/DBL_MAX)) ||
9083 			    (nv <= (-(long double)1/DBL_MAX)))
9084 #endif
9085 			fix_ldbl_sprintf_bug = TRUE;
9086 		    }
9087 		}
9088 		if (fix_ldbl_sprintf_bug == TRUE) {
9089 		    double temp;
9090 
9091 		    intsize = 0;
9092 		    temp = (double)nv;
9093 		    nv = (NV)temp;
9094 		}
9095 	    }
9096 
9097 #  undef MY_DBL_MAX
9098 #  undef MY_DBL_MAX_BUG
9099 #  undef MY_DBL_MIN
9100 
9101 #endif /* HAS_LDBL_SPRINTF_BUG */
9102 
9103 	    need += 20; /* fudge factor */
9104 	    if (PL_efloatsize < need) {
9105 		Safefree(PL_efloatbuf);
9106 		PL_efloatsize = need + 20; /* more fudge */
9107 		New(906, PL_efloatbuf, PL_efloatsize, char);
9108 		PL_efloatbuf[0] = '\0';
9109 	    }
9110 
9111 	    if ( !(width || left || plus || alt) && fill != '0'
9112 		 && has_precis && intsize != 'q' ) {	/* Shortcuts */
9113 		/* See earlier comment about buggy Gconvert when digits,
9114 		   aka precis is 0  */
9115 		if ( c == 'g' && precis) {
9116 		    Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
9117 		    if (*PL_efloatbuf)	/* May return an empty string for digits==0 */
9118 			goto float_converted;
9119 		} else if ( c == 'f' && !precis) {
9120 		    if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
9121 			break;
9122 		}
9123 	    }
9124 	    eptr = ebuf + sizeof ebuf;
9125 	    *--eptr = '\0';
9126 	    *--eptr = c;
9127 	    /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
9128 #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
9129 	    if (intsize == 'q') {
9130 		/* Copy the one or more characters in a long double
9131 		 * format before the 'base' ([efgEFG]) character to
9132 		 * the format string. */
9133 		static char const prifldbl[] = PERL_PRIfldbl;
9134 		char const *p = prifldbl + sizeof(prifldbl) - 3;
9135 		while (p >= prifldbl) { *--eptr = *p--; }
9136 	    }
9137 #endif
9138 	    if (has_precis) {
9139 		base = precis;
9140 		do { *--eptr = '0' + (base % 10); } while (base /= 10);
9141 		*--eptr = '.';
9142 	    }
9143 	    if (width) {
9144 		base = width;
9145 		do { *--eptr = '0' + (base % 10); } while (base /= 10);
9146 	    }
9147 	    if (fill == '0')
9148 		*--eptr = fill;
9149 	    if (left)
9150 		*--eptr = '-';
9151 	    if (plus)
9152 		*--eptr = plus;
9153 	    if (alt)
9154 		*--eptr = '#';
9155 	    *--eptr = '%';
9156 
9157 	    /* No taint.  Otherwise we are in the strange situation
9158 	     * where printf() taints but print($float) doesn't.
9159 	     * --jhi */
9160 #if defined(HAS_LONG_DOUBLE)
9161 	    if (intsize == 'q')
9162 		(void)sprintf(PL_efloatbuf, eptr, nv);
9163 	    else
9164 		(void)sprintf(PL_efloatbuf, eptr, (double)nv);
9165 #else
9166 	    (void)sprintf(PL_efloatbuf, eptr, nv);
9167 #endif
9168 	float_converted:
9169 	    eptr = PL_efloatbuf;
9170 	    elen = strlen(PL_efloatbuf);
9171 	    break;
9172 
9173 	    /* SPECIAL */
9174 
9175 	case 'n':
9176 	    i = SvCUR(sv) - origlen;
9177 	    if (args && !vectorize) {
9178 		switch (intsize) {
9179 		case 'h':	*(va_arg(*args, short*)) = i; break;
9180 		default:	*(va_arg(*args, int*)) = i; break;
9181 		case 'l':	*(va_arg(*args, long*)) = i; break;
9182 		case 'V':	*(va_arg(*args, IV*)) = i; break;
9183 #ifdef HAS_QUAD
9184 		case 'q':	*(va_arg(*args, Quad_t*)) = i; break;
9185 #endif
9186 		}
9187 	    }
9188 	    else
9189 		sv_setuv_mg(argsv, (UV)i);
9190 	    vectorize = FALSE;
9191 	    continue;	/* not "break" */
9192 
9193 	    /* UNKNOWN */
9194 
9195 	default:
9196       unknown:
9197 	    if (!args && ckWARN(WARN_PRINTF) &&
9198 		  (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
9199 		SV *msg = sv_newmortal();
9200 		Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
9201 			  (PL_op->op_type == OP_PRTF) ? "" : "s");
9202 		if (c) {
9203 		    if (isPRINT(c))
9204 			Perl_sv_catpvf(aTHX_ msg,
9205 				       "\"%%%c\"", c & 0xFF);
9206 		    else
9207 			Perl_sv_catpvf(aTHX_ msg,
9208 				       "\"%%\\%03"UVof"\"",
9209 				       (UV)c & 0xFF);
9210 		} else
9211 		    sv_catpv(msg, "end of string");
9212 		Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
9213 	    }
9214 
9215 	    /* output mangled stuff ... */
9216 	    if (c == '\0')
9217 		--q;
9218 	    eptr = p;
9219 	    elen = q - p;
9220 
9221 	    /* ... right here, because formatting flags should not apply */
9222 	    SvGROW(sv, SvCUR(sv) + elen + 1);
9223 	    p = SvEND(sv);
9224 	    Copy(eptr, p, elen, char);
9225 	    p += elen;
9226 	    *p = '\0';
9227 	    SvCUR(sv) = p - SvPVX(sv);
9228 	    svix = osvix;
9229 	    continue;	/* not "break" */
9230 	}
9231 
9232 	/* calculate width before utf8_upgrade changes it */
9233 	have = esignlen + zeros + elen;
9234 	if (have < zeros)
9235 	    Perl_croak_nocontext(PL_memory_wrap);
9236 
9237 	if (is_utf8 != has_utf8) {
9238 	     if (is_utf8) {
9239 		  if (SvCUR(sv))
9240 		       sv_utf8_upgrade(sv);
9241 	     }
9242 	     else {
9243 		  SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
9244 		  sv_utf8_upgrade(nsv);
9245 		  eptr = SvPVX(nsv);
9246 		  elen = SvCUR(nsv);
9247 	     }
9248 	     SvGROW(sv, SvCUR(sv) + elen + 1);
9249 	     p = SvEND(sv);
9250 	     *p = '\0';
9251 	}
9252 	/* Use memchr() instead of strchr(), as eptr is not guaranteed */
9253 	/* to point to a null-terminated string.                       */
9254 	if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
9255 	    (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
9256 	    Perl_warner(aTHX_ packWARN(WARN_PRINTF),
9257 		"Newline in left-justified string for %sprintf",
9258 			(PL_op->op_type == OP_PRTF) ? "" : "s");
9259 
9260 	need = (have > width ? have : width);
9261 	gap = need - have;
9262 
9263 	if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1))
9264 	    Perl_croak_nocontext(PL_memory_wrap);
9265 	SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
9266 	p = SvEND(sv);
9267 	if (esignlen && fill == '0') {
9268 	    for (i = 0; i < (int)esignlen; i++)
9269 		*p++ = esignbuf[i];
9270 	}
9271 	if (gap && !left) {
9272 	    memset(p, fill, gap);
9273 	    p += gap;
9274 	}
9275 	if (esignlen && fill != '0') {
9276 	    for (i = 0; i < (int)esignlen; i++)
9277 		*p++ = esignbuf[i];
9278 	}
9279 	if (zeros) {
9280 	    for (i = zeros; i; i--)
9281 		*p++ = '0';
9282 	}
9283 	if (elen) {
9284 	    Copy(eptr, p, elen, char);
9285 	    p += elen;
9286 	}
9287 	if (gap && left) {
9288 	    memset(p, ' ', gap);
9289 	    p += gap;
9290 	}
9291 	if (vectorize) {
9292 	    if (veclen) {
9293 		Copy(dotstr, p, dotstrlen, char);
9294 		p += dotstrlen;
9295 	    }
9296 	    else
9297 		vectorize = FALSE;		/* done iterating over vecstr */
9298 	}
9299 	if (is_utf8)
9300 	    has_utf8 = TRUE;
9301 	if (has_utf8)
9302 	    SvUTF8_on(sv);
9303 	*p = '\0';
9304 	SvCUR(sv) = p - SvPVX(sv);
9305 	if (vectorize) {
9306 	    esignlen = 0;
9307 	    goto vector;
9308 	}
9309     }
9310 }
9311 
9312 /* =========================================================================
9313 
9314 =head1 Cloning an interpreter
9315 
9316 All the macros and functions in this section are for the private use of
9317 the main function, perl_clone().
9318 
9319 The foo_dup() functions make an exact copy of an existing foo thinngy.
9320 During the course of a cloning, a hash table is used to map old addresses
9321 to new addresses. The table is created and manipulated with the
9322 ptr_table_* functions.
9323 
9324 =cut
9325 
9326 ============================================================================*/
9327 
9328 
9329 #if defined(USE_ITHREADS)
9330 
9331 #if defined(USE_5005THREADS)
9332 #  include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
9333 #endif
9334 
9335 #ifndef GpREFCNT_inc
9336 #  define GpREFCNT_inc(gp)	((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
9337 #endif
9338 
9339 
9340 #define sv_dup_inc(s,t)	SvREFCNT_inc(sv_dup(s,t))
9341 #define av_dup(s,t)	(AV*)sv_dup((SV*)s,t)
9342 #define av_dup_inc(s,t)	(AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9343 #define hv_dup(s,t)	(HV*)sv_dup((SV*)s,t)
9344 #define hv_dup_inc(s,t)	(HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9345 #define cv_dup(s,t)	(CV*)sv_dup((SV*)s,t)
9346 #define cv_dup_inc(s,t)	(CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9347 #define io_dup(s,t)	(IO*)sv_dup((SV*)s,t)
9348 #define io_dup_inc(s,t)	(IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
9349 #define gv_dup(s,t)	(GV*)sv_dup((SV*)s,t)
9350 #define gv_dup_inc(s,t)	(GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
9351 #define SAVEPV(p)	(p ? savepv(p) : Nullch)
9352 #define SAVEPVN(p,n)	(p ? savepvn(p,n) : Nullch)
9353 
9354 
9355 /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
9356    regcomp.c. AMS 20010712 */
9357 
9358 REGEXP *
Perl_re_dup(pTHX_ REGEXP * r,CLONE_PARAMS * param)9359 Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
9360 {
9361     REGEXP *ret;
9362     int i, len, npar;
9363     struct reg_substr_datum *s;
9364 
9365     if (!r)
9366 	return (REGEXP *)NULL;
9367 
9368     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
9369 	return ret;
9370 
9371     len = r->offsets[0];
9372     npar = r->nparens+1;
9373 
9374     Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
9375     Copy(r->program, ret->program, len+1, regnode);
9376 
9377     New(0, ret->startp, npar, I32);
9378     Copy(r->startp, ret->startp, npar, I32);
9379     New(0, ret->endp, npar, I32);
9380     Copy(r->startp, ret->startp, npar, I32);
9381 
9382     New(0, ret->substrs, 1, struct reg_substr_data);
9383     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
9384 	s->min_offset = r->substrs->data[i].min_offset;
9385 	s->max_offset = r->substrs->data[i].max_offset;
9386 	s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
9387 	s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
9388     }
9389 
9390     ret->regstclass = NULL;
9391     if (r->data) {
9392 	struct reg_data *d;
9393 	int count = r->data->count;
9394 
9395 	Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
9396 		char, struct reg_data);
9397 	New(0, d->what, count, U8);
9398 
9399 	d->count = count;
9400 	for (i = 0; i < count; i++) {
9401 	    d->what[i] = r->data->what[i];
9402 	    switch (d->what[i]) {
9403 	    case 's':
9404 		d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
9405 		break;
9406 	    case 'p':
9407 		d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
9408 		break;
9409 	    case 'f':
9410 		/* This is cheating. */
9411 		New(0, d->data[i], 1, struct regnode_charclass_class);
9412 		StructCopy(r->data->data[i], d->data[i],
9413 			    struct regnode_charclass_class);
9414 		ret->regstclass = (regnode*)d->data[i];
9415 		break;
9416 	    case 'o':
9417 		/* Compiled op trees are readonly, and can thus be
9418 		   shared without duplication. */
9419 		d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
9420 		break;
9421 	    case 'n':
9422 		d->data[i] = r->data->data[i];
9423 		break;
9424 	    }
9425 	}
9426 
9427 	ret->data = d;
9428     }
9429     else
9430 	ret->data = NULL;
9431 
9432     New(0, ret->offsets, 2*len+1, U32);
9433     Copy(r->offsets, ret->offsets, 2*len+1, U32);
9434 
9435     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
9436     ret->refcnt         = r->refcnt;
9437     ret->minlen         = r->minlen;
9438     ret->prelen         = r->prelen;
9439     ret->nparens        = r->nparens;
9440     ret->lastparen      = r->lastparen;
9441     ret->lastcloseparen = r->lastcloseparen;
9442     ret->reganch        = r->reganch;
9443 
9444     ret->sublen         = r->sublen;
9445 
9446     if (RX_MATCH_COPIED(ret))
9447 	ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
9448     else
9449 	ret->subbeg = Nullch;
9450 
9451     ptr_table_store(PL_ptr_table, r, ret);
9452     return ret;
9453 }
9454 
9455 /* duplicate a file handle */
9456 
9457 PerlIO *
Perl_fp_dup(pTHX_ PerlIO * fp,char type,CLONE_PARAMS * param)9458 Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
9459 {
9460     PerlIO *ret;
9461     if (!fp)
9462 	return (PerlIO*)NULL;
9463 
9464     /* look for it in the table first */
9465     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
9466     if (ret)
9467 	return ret;
9468 
9469     /* create anew and remember what it is */
9470     ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
9471     ptr_table_store(PL_ptr_table, fp, ret);
9472     return ret;
9473 }
9474 
9475 /* duplicate a directory handle */
9476 
9477 DIR *
Perl_dirp_dup(pTHX_ DIR * dp)9478 Perl_dirp_dup(pTHX_ DIR *dp)
9479 {
9480     if (!dp)
9481 	return (DIR*)NULL;
9482     /* XXX TODO */
9483     return dp;
9484 }
9485 
9486 /* duplicate a typeglob */
9487 
9488 GP *
Perl_gp_dup(pTHX_ GP * gp,CLONE_PARAMS * param)9489 Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
9490 {
9491     GP *ret;
9492     if (!gp)
9493 	return (GP*)NULL;
9494     /* look for it in the table first */
9495     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
9496     if (ret)
9497 	return ret;
9498 
9499     /* create anew and remember what it is */
9500     Newz(0, ret, 1, GP);
9501     ptr_table_store(PL_ptr_table, gp, ret);
9502 
9503     /* clone */
9504     ret->gp_refcnt	= 0;			/* must be before any other dups! */
9505     ret->gp_sv		= sv_dup_inc(gp->gp_sv, param);
9506     ret->gp_io		= io_dup_inc(gp->gp_io, param);
9507     ret->gp_form	= cv_dup_inc(gp->gp_form, param);
9508     ret->gp_av		= av_dup_inc(gp->gp_av, param);
9509     ret->gp_hv		= hv_dup_inc(gp->gp_hv, param);
9510     ret->gp_egv	= gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
9511     ret->gp_cv		= cv_dup_inc(gp->gp_cv, param);
9512     ret->gp_cvgen	= gp->gp_cvgen;
9513     ret->gp_flags	= gp->gp_flags;
9514     ret->gp_line	= gp->gp_line;
9515     ret->gp_file	= gp->gp_file;		/* points to COP.cop_file */
9516     return ret;
9517 }
9518 
9519 /* duplicate a chain of magic */
9520 
9521 MAGIC *
Perl_mg_dup(pTHX_ MAGIC * mg,CLONE_PARAMS * param)9522 Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
9523 {
9524     MAGIC *mgprev = (MAGIC*)NULL;
9525     MAGIC *mgret;
9526     if (!mg)
9527 	return (MAGIC*)NULL;
9528     /* look for it in the table first */
9529     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
9530     if (mgret)
9531 	return mgret;
9532 
9533     for (; mg; mg = mg->mg_moremagic) {
9534 	MAGIC *nmg;
9535 	Newz(0, nmg, 1, MAGIC);
9536 	if (mgprev)
9537 	    mgprev->mg_moremagic = nmg;
9538 	else
9539 	    mgret = nmg;
9540 	nmg->mg_virtual	= mg->mg_virtual;	/* XXX copy dynamic vtable? */
9541 	nmg->mg_private	= mg->mg_private;
9542 	nmg->mg_type	= mg->mg_type;
9543 	nmg->mg_flags	= mg->mg_flags;
9544 	if (mg->mg_type == PERL_MAGIC_qr) {
9545 	    nmg->mg_obj	= (SV*)re_dup((REGEXP*)mg->mg_obj, param);
9546 	}
9547 	else if(mg->mg_type == PERL_MAGIC_backref) {
9548 	     AV *av = (AV*) mg->mg_obj;
9549 	     SV **svp;
9550 	     I32 i;
9551 	     nmg->mg_obj = (SV*)newAV();
9552 	     svp = AvARRAY(av);
9553 	     i = AvFILLp(av);
9554 	     while (i >= 0) {
9555 		  av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
9556 		  i--;
9557 	     }
9558 	}
9559 	else {
9560 	    nmg->mg_obj	= (mg->mg_flags & MGf_REFCOUNTED)
9561 			      ? sv_dup_inc(mg->mg_obj, param)
9562 			      : sv_dup(mg->mg_obj, param);
9563 	}
9564 	nmg->mg_len	= mg->mg_len;
9565 	nmg->mg_ptr	= mg->mg_ptr;	/* XXX random ptr? */
9566 	if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
9567 	    if (mg->mg_len > 0) {
9568 		nmg->mg_ptr	= SAVEPVN(mg->mg_ptr, mg->mg_len);
9569 		if (mg->mg_type == PERL_MAGIC_overload_table &&
9570 			AMT_AMAGIC((AMT*)mg->mg_ptr))
9571 		{
9572 		    AMT *amtp = (AMT*)mg->mg_ptr;
9573 		    AMT *namtp = (AMT*)nmg->mg_ptr;
9574 		    I32 i;
9575 		    for (i = 1; i < NofAMmeth; i++) {
9576 			namtp->table[i] = cv_dup_inc(amtp->table[i], param);
9577 		    }
9578 		}
9579 	    }
9580 	    else if (mg->mg_len == HEf_SVKEY)
9581 		nmg->mg_ptr	= (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
9582 	}
9583 	if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
9584 	    CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
9585 	}
9586 	mgprev = nmg;
9587     }
9588     return mgret;
9589 }
9590 
9591 /* create a new pointer-mapping table */
9592 
9593 PTR_TBL_t *
Perl_ptr_table_new(pTHX)9594 Perl_ptr_table_new(pTHX)
9595 {
9596     PTR_TBL_t *tbl;
9597     Newz(0, tbl, 1, PTR_TBL_t);
9598     tbl->tbl_max	= 511;
9599     tbl->tbl_items	= 0;
9600     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
9601     return tbl;
9602 }
9603 
9604 #if (PTRSIZE == 8)
9605 #  define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 3)
9606 #else
9607 #  define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2)
9608 #endif
9609 
9610 /* map an existing pointer using a table */
9611 
9612 void *
Perl_ptr_table_fetch(pTHX_ PTR_TBL_t * tbl,void * sv)9613 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
9614 {
9615     PTR_TBL_ENT_t *tblent;
9616     UV hash = PTR_TABLE_HASH(sv);
9617     assert(tbl);
9618     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
9619     for (; tblent; tblent = tblent->next) {
9620 	if (tblent->oldval == sv)
9621 	    return tblent->newval;
9622     }
9623     return (void*)NULL;
9624 }
9625 
9626 /* add a new entry to a pointer-mapping table */
9627 
9628 void
Perl_ptr_table_store(pTHX_ PTR_TBL_t * tbl,void * oldv,void * newv)9629 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
9630 {
9631     PTR_TBL_ENT_t *tblent, **otblent;
9632     /* XXX this may be pessimal on platforms where pointers aren't good
9633      * hash values e.g. if they grow faster in the most significant
9634      * bits */
9635     UV hash = PTR_TABLE_HASH(oldv);
9636     bool empty = 1;
9637 
9638     assert(tbl);
9639     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
9640     for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) {
9641 	if (tblent->oldval == oldv) {
9642 	    tblent->newval = newv;
9643 	    return;
9644 	}
9645     }
9646     Newz(0, tblent, 1, PTR_TBL_ENT_t);
9647     tblent->oldval = oldv;
9648     tblent->newval = newv;
9649     tblent->next = *otblent;
9650     *otblent = tblent;
9651     tbl->tbl_items++;
9652     if (!empty && tbl->tbl_items > tbl->tbl_max)
9653 	ptr_table_split(tbl);
9654 }
9655 
9656 /* double the hash bucket size of an existing ptr table */
9657 
9658 void
Perl_ptr_table_split(pTHX_ PTR_TBL_t * tbl)9659 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
9660 {
9661     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
9662     UV oldsize = tbl->tbl_max + 1;
9663     UV newsize = oldsize * 2;
9664     UV i;
9665 
9666     Renew(ary, newsize, PTR_TBL_ENT_t*);
9667     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
9668     tbl->tbl_max = --newsize;
9669     tbl->tbl_ary = ary;
9670     for (i=0; i < oldsize; i++, ary++) {
9671 	PTR_TBL_ENT_t **curentp, **entp, *ent;
9672 	if (!*ary)
9673 	    continue;
9674 	curentp = ary + oldsize;
9675 	for (entp = ary, ent = *ary; ent; ent = *entp) {
9676 	    if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) {
9677 		*entp = ent->next;
9678 		ent->next = *curentp;
9679 		*curentp = ent;
9680 		continue;
9681 	    }
9682 	    else
9683 		entp = &ent->next;
9684 	}
9685     }
9686 }
9687 
9688 /* remove all the entries from a ptr table */
9689 
9690 void
Perl_ptr_table_clear(pTHX_ PTR_TBL_t * tbl)9691 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
9692 {
9693     register PTR_TBL_ENT_t **array;
9694     register PTR_TBL_ENT_t *entry;
9695     register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
9696     UV riter = 0;
9697     UV max;
9698 
9699     if (!tbl || !tbl->tbl_items) {
9700         return;
9701     }
9702 
9703     array = tbl->tbl_ary;
9704     entry = array[0];
9705     max = tbl->tbl_max;
9706 
9707     for (;;) {
9708         if (entry) {
9709             oentry = entry;
9710             entry = entry->next;
9711             Safefree(oentry);
9712         }
9713         if (!entry) {
9714             if (++riter > max) {
9715                 break;
9716             }
9717             entry = array[riter];
9718         }
9719     }
9720 
9721     tbl->tbl_items = 0;
9722 }
9723 
9724 /* clear and free a ptr table */
9725 
9726 void
Perl_ptr_table_free(pTHX_ PTR_TBL_t * tbl)9727 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
9728 {
9729     if (!tbl) {
9730         return;
9731     }
9732     ptr_table_clear(tbl);
9733     Safefree(tbl->tbl_ary);
9734     Safefree(tbl);
9735 }
9736 
9737 #ifdef DEBUGGING
9738 char *PL_watch_pvx;
9739 #endif
9740 
9741 /* attempt to make everything in the typeglob readonly */
9742 
9743 STATIC SV *
S_gv_share(pTHX_ SV * sstr,CLONE_PARAMS * param)9744 S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
9745 {
9746     GV *gv = (GV*)sstr;
9747     SV *sv = &param->proto_perl->Isv_no; /* just need SvREADONLY-ness */
9748 
9749     if (GvIO(gv) || GvFORM(gv)) {
9750         GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
9751     }
9752     else if (!GvCV(gv)) {
9753         GvCV(gv) = (CV*)sv;
9754     }
9755     else {
9756         /* CvPADLISTs cannot be shared */
9757         if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
9758             GvUNIQUE_off(gv);
9759         }
9760     }
9761 
9762     if (!GvUNIQUE(gv)) {
9763 #if 0
9764         PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
9765                       HvNAME(GvSTASH(gv)), GvNAME(gv));
9766 #endif
9767         return Nullsv;
9768     }
9769 
9770     /*
9771      * write attempts will die with
9772      * "Modification of a read-only value attempted"
9773      */
9774     if (!GvSV(gv)) {
9775         GvSV(gv) = sv;
9776     }
9777     else {
9778         SvREADONLY_on(GvSV(gv));
9779     }
9780 
9781     if (!GvAV(gv)) {
9782         GvAV(gv) = (AV*)sv;
9783     }
9784     else {
9785         SvREADONLY_on(GvAV(gv));
9786     }
9787 
9788     if (!GvHV(gv)) {
9789         GvHV(gv) = (HV*)sv;
9790     }
9791     else {
9792         SvREADONLY_on(GvHV(gv));
9793     }
9794 
9795     return sstr; /* he_dup() will SvREFCNT_inc() */
9796 }
9797 
9798 /* duplicate an SV of any type (including AV, HV etc) */
9799 
9800 void
Perl_rvpv_dup(pTHX_ SV * dstr,SV * sstr,CLONE_PARAMS * param)9801 Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
9802 {
9803     if (SvROK(sstr)) {
9804         SvRV(dstr) = SvWEAKREF(sstr)
9805 		     ? sv_dup(SvRV(sstr), param)
9806 		     : sv_dup_inc(SvRV(sstr), param);
9807     }
9808     else if (SvPVX(sstr)) {
9809 	/* Has something there */
9810 	if (SvLEN(sstr)) {
9811 	    /* Normal PV - clone whole allocated space */
9812 	    SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
9813 	}
9814 	else {
9815 	    /* Special case - not normally malloced for some reason */
9816 	    if (SvREADONLY(sstr) && SvFAKE(sstr)) {
9817 		/* A "shared" PV - clone it as unshared string */
9818                 if(SvPADTMP(sstr)) {
9819                     /* However, some of them live in the pad
9820                        and they should not have these flags
9821                        turned off */
9822 
9823                     SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
9824                                            SvUVX(sstr));
9825                     SvUVX(dstr) = SvUVX(sstr);
9826                 } else {
9827 
9828                     SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
9829                     SvFAKE_off(dstr);
9830                     SvREADONLY_off(dstr);
9831                 }
9832 	    }
9833 	    else {
9834 		/* Some other special case - random pointer */
9835 		SvPVX(dstr) = SvPVX(sstr);
9836             }
9837 	}
9838     }
9839     else {
9840 	/* Copy the Null */
9841 	SvPVX(dstr) = SvPVX(sstr);
9842     }
9843 }
9844 
9845 SV *
Perl_sv_dup(pTHX_ SV * sstr,CLONE_PARAMS * param)9846 Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
9847 {
9848     SV *dstr;
9849 
9850     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
9851 	return Nullsv;
9852     /* look for it in the table first */
9853     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
9854     if (dstr)
9855 	return dstr;
9856 
9857     if(param->flags & CLONEf_JOIN_IN) {
9858         /** We are joining here so we don't want do clone
9859 	    something that is bad **/
9860 
9861         if(SvTYPE(sstr) == SVt_PVHV &&
9862 	   HvNAME(sstr)) {
9863 	    /** don't clone stashes if they already exist **/
9864 	    HV* old_stash = gv_stashpv(HvNAME(sstr),0);
9865 	    return (SV*) old_stash;
9866         }
9867     }
9868 
9869     /* create anew and remember what it is */
9870     new_SV(dstr);
9871     ptr_table_store(PL_ptr_table, sstr, dstr);
9872 
9873     /* clone */
9874     SvFLAGS(dstr)	= SvFLAGS(sstr);
9875     SvFLAGS(dstr)	&= ~SVf_OOK;		/* don't propagate OOK hack */
9876     SvREFCNT(dstr)	= 0;			/* must be before any other dups! */
9877 
9878 #ifdef DEBUGGING
9879     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
9880 	PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
9881 		      PL_watch_pvx, SvPVX(sstr));
9882 #endif
9883 
9884     switch (SvTYPE(sstr)) {
9885     case SVt_NULL:
9886 	SvANY(dstr)	= NULL;
9887 	break;
9888     case SVt_IV:
9889 	SvANY(dstr)	= new_XIV();
9890 	SvIVX(dstr)	= SvIVX(sstr);
9891 	break;
9892     case SVt_NV:
9893 	SvANY(dstr)	= new_XNV();
9894 	SvNVX(dstr)	= SvNVX(sstr);
9895 	break;
9896     case SVt_RV:
9897 	SvANY(dstr)	= new_XRV();
9898 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9899 	break;
9900     case SVt_PV:
9901 	SvANY(dstr)	= new_XPV();
9902 	SvCUR(dstr)	= SvCUR(sstr);
9903 	SvLEN(dstr)	= SvLEN(sstr);
9904 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9905 	break;
9906     case SVt_PVIV:
9907 	SvANY(dstr)	= new_XPVIV();
9908 	SvCUR(dstr)	= SvCUR(sstr);
9909 	SvLEN(dstr)	= SvLEN(sstr);
9910 	SvIVX(dstr)	= SvIVX(sstr);
9911 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9912 	break;
9913     case SVt_PVNV:
9914 	SvANY(dstr)	= new_XPVNV();
9915 	SvCUR(dstr)	= SvCUR(sstr);
9916 	SvLEN(dstr)	= SvLEN(sstr);
9917 	SvIVX(dstr)	= SvIVX(sstr);
9918 	SvNVX(dstr)	= SvNVX(sstr);
9919 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9920 	break;
9921     case SVt_PVMG:
9922 	SvANY(dstr)	= new_XPVMG();
9923 	SvCUR(dstr)	= SvCUR(sstr);
9924 	SvLEN(dstr)	= SvLEN(sstr);
9925 	SvIVX(dstr)	= SvIVX(sstr);
9926 	SvNVX(dstr)	= SvNVX(sstr);
9927 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
9928 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
9929 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9930 	break;
9931     case SVt_PVBM:
9932 	SvANY(dstr)	= new_XPVBM();
9933 	SvCUR(dstr)	= SvCUR(sstr);
9934 	SvLEN(dstr)	= SvLEN(sstr);
9935 	SvIVX(dstr)	= SvIVX(sstr);
9936 	SvNVX(dstr)	= SvNVX(sstr);
9937 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
9938 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
9939 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9940 	BmRARE(dstr)	= BmRARE(sstr);
9941 	BmUSEFUL(dstr)	= BmUSEFUL(sstr);
9942 	BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
9943 	break;
9944     case SVt_PVLV:
9945 	SvANY(dstr)	= new_XPVLV();
9946 	SvCUR(dstr)	= SvCUR(sstr);
9947 	SvLEN(dstr)	= SvLEN(sstr);
9948 	SvIVX(dstr)	= SvIVX(sstr);
9949 	SvNVX(dstr)	= SvNVX(sstr);
9950 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
9951 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
9952 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9953 	LvTARGOFF(dstr)	= LvTARGOFF(sstr);	/* XXX sometimes holds PMOP* when DEBUGGING */
9954 	LvTARGLEN(dstr)	= LvTARGLEN(sstr);
9955 	if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
9956 	    LvTARG(dstr) = dstr;
9957 	else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
9958 	    LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
9959 	else
9960 	    LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
9961 	LvTYPE(dstr)	= LvTYPE(sstr);
9962 	break;
9963     case SVt_PVGV:
9964 	if (GvUNIQUE((GV*)sstr)) {
9965             SV *share;
9966             if ((share = gv_share(sstr, param))) {
9967                 del_SV(dstr);
9968                 dstr = share;
9969                 ptr_table_store(PL_ptr_table, sstr, dstr);
9970 #if 0
9971                 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
9972                               HvNAME(GvSTASH(share)), GvNAME(share));
9973 #endif
9974                 break;
9975             }
9976 	}
9977 	SvANY(dstr)	= new_XPVGV();
9978 	SvCUR(dstr)	= SvCUR(sstr);
9979 	SvLEN(dstr)	= SvLEN(sstr);
9980 	SvIVX(dstr)	= SvIVX(sstr);
9981 	SvNVX(dstr)	= SvNVX(sstr);
9982 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
9983 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
9984 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
9985 	GvNAMELEN(dstr)	= GvNAMELEN(sstr);
9986 	GvNAME(dstr)	= SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
9987     	GvSTASH(dstr)	= hv_dup_inc(GvSTASH(sstr), param);
9988 	GvFLAGS(dstr)	= GvFLAGS(sstr);
9989 	GvGP(dstr)	= gp_dup(GvGP(sstr), param);
9990 	(void)GpREFCNT_inc(GvGP(dstr));
9991 	break;
9992     case SVt_PVIO:
9993 	SvANY(dstr)	= new_XPVIO();
9994 	SvCUR(dstr)	= SvCUR(sstr);
9995 	SvLEN(dstr)	= SvLEN(sstr);
9996 	SvIVX(dstr)	= SvIVX(sstr);
9997 	SvNVX(dstr)	= SvNVX(sstr);
9998 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
9999 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
10000 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10001 	IoIFP(dstr)	= fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
10002 	if (IoOFP(sstr) == IoIFP(sstr))
10003 	    IoOFP(dstr) = IoIFP(dstr);
10004 	else
10005 	    IoOFP(dstr)	= fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
10006 	/* PL_rsfp_filters entries have fake IoDIRP() */
10007 	if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
10008 	    IoDIRP(dstr)	= dirp_dup(IoDIRP(sstr));
10009 	else
10010 	    IoDIRP(dstr)	= IoDIRP(sstr);
10011 	IoLINES(dstr)		= IoLINES(sstr);
10012 	IoPAGE(dstr)		= IoPAGE(sstr);
10013 	IoPAGE_LEN(dstr)	= IoPAGE_LEN(sstr);
10014 	IoLINES_LEFT(dstr)	= IoLINES_LEFT(sstr);
10015         if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
10016             /* I have no idea why fake dirp (rsfps)
10017                should be treaded differently but otherwise
10018                we end up with leaks -- sky*/
10019             IoTOP_GV(dstr)      = gv_dup_inc(IoTOP_GV(sstr), param);
10020             IoFMT_GV(dstr)      = gv_dup_inc(IoFMT_GV(sstr), param);
10021             IoBOTTOM_GV(dstr)   = gv_dup_inc(IoBOTTOM_GV(sstr), param);
10022         } else {
10023             IoTOP_GV(dstr)      = gv_dup(IoTOP_GV(sstr), param);
10024             IoFMT_GV(dstr)      = gv_dup(IoFMT_GV(sstr), param);
10025             IoBOTTOM_GV(dstr)   = gv_dup(IoBOTTOM_GV(sstr), param);
10026         }
10027 	IoTOP_NAME(dstr)	= SAVEPV(IoTOP_NAME(sstr));
10028 	IoFMT_NAME(dstr)	= SAVEPV(IoFMT_NAME(sstr));
10029 	IoBOTTOM_NAME(dstr)	= SAVEPV(IoBOTTOM_NAME(sstr));
10030 	IoSUBPROCESS(dstr)	= IoSUBPROCESS(sstr);
10031 	IoTYPE(dstr)		= IoTYPE(sstr);
10032 	IoFLAGS(dstr)		= IoFLAGS(sstr);
10033 	break;
10034     case SVt_PVAV:
10035 	SvANY(dstr)	= new_XPVAV();
10036 	SvCUR(dstr)	= SvCUR(sstr);
10037 	SvLEN(dstr)	= SvLEN(sstr);
10038 	SvIVX(dstr)	= SvIVX(sstr);
10039 	SvNVX(dstr)	= SvNVX(sstr);
10040 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
10041 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
10042 	AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
10043 	AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
10044 	if (AvARRAY((AV*)sstr)) {
10045 	    SV **dst_ary, **src_ary;
10046 	    SSize_t items = AvFILLp((AV*)sstr) + 1;
10047 
10048 	    src_ary = AvARRAY((AV*)sstr);
10049 	    Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
10050 	    ptr_table_store(PL_ptr_table, src_ary, dst_ary);
10051 	    SvPVX(dstr)	= (char*)dst_ary;
10052 	    AvALLOC((AV*)dstr) = dst_ary;
10053 	    if (AvREAL((AV*)sstr)) {
10054 		while (items-- > 0)
10055 		    *dst_ary++ = sv_dup_inc(*src_ary++, param);
10056 	    }
10057 	    else {
10058 		while (items-- > 0)
10059 		    *dst_ary++ = sv_dup(*src_ary++, param);
10060 	    }
10061 	    items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
10062 	    while (items-- > 0) {
10063 		*dst_ary++ = &PL_sv_undef;
10064 	    }
10065 	}
10066 	else {
10067 	    SvPVX(dstr)		= Nullch;
10068 	    AvALLOC((AV*)dstr)	= (SV**)NULL;
10069 	}
10070 	break;
10071     case SVt_PVHV:
10072 	SvANY(dstr)	= new_XPVHV();
10073 	SvCUR(dstr)	= SvCUR(sstr);
10074 	SvLEN(dstr)	= SvLEN(sstr);
10075 	SvIVX(dstr)	= SvIVX(sstr);
10076 	SvNVX(dstr)	= SvNVX(sstr);
10077 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
10078 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
10079 	HvRITER((HV*)dstr)	= HvRITER((HV*)sstr);
10080 	if (HvARRAY((HV*)sstr)) {
10081 	    STRLEN i = 0;
10082 	    XPVHV *dxhv = (XPVHV*)SvANY(dstr);
10083 	    XPVHV *sxhv = (XPVHV*)SvANY(sstr);
10084 	    Newz(0, dxhv->xhv_array,
10085 		 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
10086 	    while (i <= sxhv->xhv_max) {
10087 		((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
10088 						    (bool)!!HvSHAREKEYS(sstr),
10089 						    param);
10090 		++i;
10091 	    }
10092 	    dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter,
10093 				     (bool)!!HvSHAREKEYS(sstr), param);
10094 	}
10095 	else {
10096 	    SvPVX(dstr)		= Nullch;
10097 	    HvEITER((HV*)dstr)	= (HE*)NULL;
10098 	}
10099 	HvPMROOT((HV*)dstr)	= HvPMROOT((HV*)sstr);		/* XXX */
10100 	HvNAME((HV*)dstr)	= SAVEPV(HvNAME((HV*)sstr));
10101     /* Record stashes for possible cloning in Perl_clone(). */
10102 	if(HvNAME((HV*)dstr))
10103 	    av_push(param->stashes, dstr);
10104 	break;
10105     case SVt_PVFM:
10106 	SvANY(dstr)	= new_XPVFM();
10107 	FmLINES(dstr)	= FmLINES(sstr);
10108 	goto dup_pvcv;
10109 	/* NOTREACHED */
10110     case SVt_PVCV:
10111 	SvANY(dstr)	= new_XPVCV();
10112         dup_pvcv:
10113 	SvCUR(dstr)	= SvCUR(sstr);
10114 	SvLEN(dstr)	= SvLEN(sstr);
10115 	SvIVX(dstr)	= SvIVX(sstr);
10116 	SvNVX(dstr)	= SvNVX(sstr);
10117 	SvMAGIC(dstr)	= mg_dup(SvMAGIC(sstr), param);
10118 	SvSTASH(dstr)	= hv_dup_inc(SvSTASH(sstr), param);
10119 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
10120 	CvSTASH(dstr)	= hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
10121 	CvSTART(dstr)	= CvSTART(sstr);
10122 	CvROOT(dstr)	= OpREFCNT_inc(CvROOT(sstr));
10123 	CvXSUB(dstr)	= CvXSUB(sstr);
10124 	CvXSUBANY(dstr)	= CvXSUBANY(sstr);
10125 	if (CvCONST(sstr)) {
10126 	    CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
10127                 SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
10128                 sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
10129 	}
10130 	/* don't dup if copying back - CvGV isn't refcounted, so the
10131 	 * duped GV may never be freed. A bit of a hack! DAPM */
10132 	CvGV(dstr)	= (param->flags & CLONEf_JOIN_IN) ?
10133 		Nullgv : gv_dup(CvGV(sstr), param) ;
10134 	if (param->flags & CLONEf_COPY_STACKS) {
10135 	  CvDEPTH(dstr)	= CvDEPTH(sstr);
10136 	} else {
10137 	  CvDEPTH(dstr) = 0;
10138 	}
10139 	PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
10140 	CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
10141 	CvOUTSIDE(dstr)	=
10142 		CvWEAKOUTSIDE(sstr)
10143 			? cv_dup(    CvOUTSIDE(sstr), param)
10144 			: cv_dup_inc(CvOUTSIDE(sstr), param);
10145 	CvFLAGS(dstr)	= CvFLAGS(sstr);
10146 	CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
10147 	break;
10148     default:
10149 	Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr));
10150 	break;
10151     }
10152 
10153     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
10154 	++PL_sv_objcount;
10155 
10156     return dstr;
10157  }
10158 
10159 /* duplicate a context */
10160 
10161 PERL_CONTEXT *
Perl_cx_dup(pTHX_ PERL_CONTEXT * cxs,I32 ix,I32 max,CLONE_PARAMS * param)10162 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
10163 {
10164     PERL_CONTEXT *ncxs;
10165 
10166     if (!cxs)
10167 	return (PERL_CONTEXT*)NULL;
10168 
10169     /* look for it in the table first */
10170     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
10171     if (ncxs)
10172 	return ncxs;
10173 
10174     /* create anew and remember what it is */
10175     Newz(56, ncxs, max + 1, PERL_CONTEXT);
10176     ptr_table_store(PL_ptr_table, cxs, ncxs);
10177 
10178     while (ix >= 0) {
10179 	PERL_CONTEXT *cx = &cxs[ix];
10180 	PERL_CONTEXT *ncx = &ncxs[ix];
10181 	ncx->cx_type	= cx->cx_type;
10182 	if (CxTYPE(cx) == CXt_SUBST) {
10183 	    Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
10184 	}
10185 	else {
10186 	    ncx->blk_oldsp	= cx->blk_oldsp;
10187 	    ncx->blk_oldcop	= cx->blk_oldcop;
10188 	    ncx->blk_oldretsp	= cx->blk_oldretsp;
10189 	    ncx->blk_oldmarksp	= cx->blk_oldmarksp;
10190 	    ncx->blk_oldscopesp	= cx->blk_oldscopesp;
10191 	    ncx->blk_oldpm	= cx->blk_oldpm;
10192 	    ncx->blk_gimme	= cx->blk_gimme;
10193 	    switch (CxTYPE(cx)) {
10194 	    case CXt_SUB:
10195 		ncx->blk_sub.cv		= (cx->blk_sub.olddepth == 0
10196 					   ? cv_dup_inc(cx->blk_sub.cv, param)
10197 					   : cv_dup(cx->blk_sub.cv,param));
10198 		ncx->blk_sub.argarray	= (cx->blk_sub.hasargs
10199 					   ? av_dup_inc(cx->blk_sub.argarray, param)
10200 					   : Nullav);
10201 		ncx->blk_sub.savearray	= av_dup_inc(cx->blk_sub.savearray, param);
10202 		ncx->blk_sub.olddepth	= cx->blk_sub.olddepth;
10203 		ncx->blk_sub.hasargs	= cx->blk_sub.hasargs;
10204 		ncx->blk_sub.lval	= cx->blk_sub.lval;
10205 		break;
10206 	    case CXt_EVAL:
10207 		ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
10208 		ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
10209 		ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);
10210 		ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
10211 		ncx->blk_eval.cur_text	= sv_dup(cx->blk_eval.cur_text, param);
10212 		break;
10213 	    case CXt_LOOP:
10214 		ncx->blk_loop.label	= cx->blk_loop.label;
10215 		ncx->blk_loop.resetsp	= cx->blk_loop.resetsp;
10216 		ncx->blk_loop.redo_op	= cx->blk_loop.redo_op;
10217 		ncx->blk_loop.next_op	= cx->blk_loop.next_op;
10218 		ncx->blk_loop.last_op	= cx->blk_loop.last_op;
10219 		ncx->blk_loop.iterdata	= (CxPADLOOP(cx)
10220 					   ? cx->blk_loop.iterdata
10221 					   : gv_dup((GV*)cx->blk_loop.iterdata, param));
10222 		ncx->blk_loop.oldcomppad
10223 		    = (PAD*)ptr_table_fetch(PL_ptr_table,
10224 					    cx->blk_loop.oldcomppad);
10225 		ncx->blk_loop.itersave	= sv_dup_inc(cx->blk_loop.itersave, param);
10226 		ncx->blk_loop.iterlval	= sv_dup_inc(cx->blk_loop.iterlval, param);
10227 		ncx->blk_loop.iterary	= av_dup_inc(cx->blk_loop.iterary, param);
10228 		ncx->blk_loop.iterix	= cx->blk_loop.iterix;
10229 		ncx->blk_loop.itermax	= cx->blk_loop.itermax;
10230 		break;
10231 	    case CXt_FORMAT:
10232 		ncx->blk_sub.cv		= cv_dup(cx->blk_sub.cv, param);
10233 		ncx->blk_sub.gv		= gv_dup(cx->blk_sub.gv, param);
10234 		ncx->blk_sub.dfoutgv	= gv_dup_inc(cx->blk_sub.dfoutgv, param);
10235 		ncx->blk_sub.hasargs	= cx->blk_sub.hasargs;
10236 		break;
10237 	    case CXt_BLOCK:
10238 	    case CXt_NULL:
10239 		break;
10240 	    }
10241 	}
10242 	--ix;
10243     }
10244     return ncxs;
10245 }
10246 
10247 /* duplicate a stack info structure */
10248 
10249 PERL_SI *
Perl_si_dup(pTHX_ PERL_SI * si,CLONE_PARAMS * param)10250 Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
10251 {
10252     PERL_SI *nsi;
10253 
10254     if (!si)
10255 	return (PERL_SI*)NULL;
10256 
10257     /* look for it in the table first */
10258     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
10259     if (nsi)
10260 	return nsi;
10261 
10262     /* create anew and remember what it is */
10263     Newz(56, nsi, 1, PERL_SI);
10264     ptr_table_store(PL_ptr_table, si, nsi);
10265 
10266     nsi->si_stack	= av_dup_inc(si->si_stack, param);
10267     nsi->si_cxix	= si->si_cxix;
10268     nsi->si_cxmax	= si->si_cxmax;
10269     nsi->si_cxstack	= cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
10270     nsi->si_type	= si->si_type;
10271     nsi->si_prev	= si_dup(si->si_prev, param);
10272     nsi->si_next	= si_dup(si->si_next, param);
10273     nsi->si_markoff	= si->si_markoff;
10274 
10275     return nsi;
10276 }
10277 
10278 #define POPINT(ss,ix)	((ss)[--(ix)].any_i32)
10279 #define TOPINT(ss,ix)	((ss)[ix].any_i32)
10280 #define POPLONG(ss,ix)	((ss)[--(ix)].any_long)
10281 #define TOPLONG(ss,ix)	((ss)[ix].any_long)
10282 #define POPIV(ss,ix)	((ss)[--(ix)].any_iv)
10283 #define TOPIV(ss,ix)	((ss)[ix].any_iv)
10284 #define POPBOOL(ss,ix)	((ss)[--(ix)].any_bool)
10285 #define TOPBOOL(ss,ix)	((ss)[ix].any_bool)
10286 #define POPPTR(ss,ix)	((ss)[--(ix)].any_ptr)
10287 #define TOPPTR(ss,ix)	((ss)[ix].any_ptr)
10288 #define POPDPTR(ss,ix)	((ss)[--(ix)].any_dptr)
10289 #define TOPDPTR(ss,ix)	((ss)[ix].any_dptr)
10290 #define POPDXPTR(ss,ix)	((ss)[--(ix)].any_dxptr)
10291 #define TOPDXPTR(ss,ix)	((ss)[ix].any_dxptr)
10292 
10293 /* XXXXX todo */
10294 #define pv_dup_inc(p)	SAVEPV(p)
10295 #define pv_dup(p)	SAVEPV(p)
10296 #define svp_dup_inc(p,pp)	any_dup(p,pp)
10297 
10298 /* map any object to the new equivent - either something in the
10299  * ptr table, or something in the interpreter structure
10300  */
10301 
10302 void *
Perl_any_dup(pTHX_ void * v,PerlInterpreter * proto_perl)10303 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
10304 {
10305     void *ret;
10306 
10307     if (!v)
10308 	return (void*)NULL;
10309 
10310     /* look for it in the table first */
10311     ret = ptr_table_fetch(PL_ptr_table, v);
10312     if (ret)
10313 	return ret;
10314 
10315     /* see if it is part of the interpreter structure */
10316     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
10317 	ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
10318     else {
10319 	ret = v;
10320     }
10321 
10322     return ret;
10323 }
10324 
10325 /* duplicate the save stack */
10326 
10327 ANY *
Perl_ss_dup(pTHX_ PerlInterpreter * proto_perl,CLONE_PARAMS * param)10328 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
10329 {
10330     ANY *ss	= proto_perl->Tsavestack;
10331     I32 ix	= proto_perl->Tsavestack_ix;
10332     I32 max	= proto_perl->Tsavestack_max;
10333     ANY *nss;
10334     SV *sv;
10335     GV *gv;
10336     AV *av;
10337     HV *hv;
10338     void* ptr;
10339     int intval;
10340     long longval;
10341     GP *gp;
10342     IV iv;
10343     I32 i;
10344     char *c = NULL;
10345     void (*dptr) (void*);
10346     void (*dxptr) (pTHX_ void*);
10347     OP *o;
10348 
10349     Newz(54, nss, max, ANY);
10350 
10351     while (ix > 0) {
10352 	i = POPINT(ss,ix);
10353 	TOPINT(nss,ix) = i;
10354 	switch (i) {
10355 	case SAVEt_ITEM:			/* normal string */
10356 	    sv = (SV*)POPPTR(ss,ix);
10357 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10358 	    sv = (SV*)POPPTR(ss,ix);
10359 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10360 	    break;
10361         case SAVEt_SV:				/* scalar reference */
10362 	    sv = (SV*)POPPTR(ss,ix);
10363 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10364 	    gv = (GV*)POPPTR(ss,ix);
10365 	    TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10366 	    break;
10367 	case SAVEt_GENERIC_PVREF:		/* generic char* */
10368 	    c = (char*)POPPTR(ss,ix);
10369 	    TOPPTR(nss,ix) = pv_dup(c);
10370 	    ptr = POPPTR(ss,ix);
10371 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10372 	    break;
10373 	case SAVEt_SHARED_PVREF:		/* char* in shared space */
10374 	    c = (char*)POPPTR(ss,ix);
10375 	    TOPPTR(nss,ix) = savesharedpv(c);
10376 	    ptr = POPPTR(ss,ix);
10377 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10378 	    break;
10379         case SAVEt_GENERIC_SVREF:		/* generic sv */
10380         case SAVEt_SVREF:			/* scalar reference */
10381 	    sv = (SV*)POPPTR(ss,ix);
10382 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10383 	    ptr = POPPTR(ss,ix);
10384 	    TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
10385 	    break;
10386         case SAVEt_AV:				/* array reference */
10387 	    av = (AV*)POPPTR(ss,ix);
10388 	    TOPPTR(nss,ix) = av_dup_inc(av, param);
10389 	    gv = (GV*)POPPTR(ss,ix);
10390 	    TOPPTR(nss,ix) = gv_dup(gv, param);
10391 	    break;
10392         case SAVEt_HV:				/* hash reference */
10393 	    hv = (HV*)POPPTR(ss,ix);
10394 	    TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10395 	    gv = (GV*)POPPTR(ss,ix);
10396 	    TOPPTR(nss,ix) = gv_dup(gv, param);
10397 	    break;
10398 	case SAVEt_INT:				/* int reference */
10399 	    ptr = POPPTR(ss,ix);
10400 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10401 	    intval = (int)POPINT(ss,ix);
10402 	    TOPINT(nss,ix) = intval;
10403 	    break;
10404 	case SAVEt_LONG:			/* long reference */
10405 	    ptr = POPPTR(ss,ix);
10406 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10407 	    longval = (long)POPLONG(ss,ix);
10408 	    TOPLONG(nss,ix) = longval;
10409 	    break;
10410 	case SAVEt_I32:				/* I32 reference */
10411 	case SAVEt_I16:				/* I16 reference */
10412 	case SAVEt_I8:				/* I8 reference */
10413 	    ptr = POPPTR(ss,ix);
10414 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10415 	    i = POPINT(ss,ix);
10416 	    TOPINT(nss,ix) = i;
10417 	    break;
10418 	case SAVEt_IV:				/* IV reference */
10419 	    ptr = POPPTR(ss,ix);
10420 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10421 	    iv = POPIV(ss,ix);
10422 	    TOPIV(nss,ix) = iv;
10423 	    break;
10424 	case SAVEt_SPTR:			/* SV* reference */
10425 	    ptr = POPPTR(ss,ix);
10426 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10427 	    sv = (SV*)POPPTR(ss,ix);
10428 	    TOPPTR(nss,ix) = sv_dup(sv, param);
10429 	    break;
10430 	case SAVEt_VPTR:			/* random* reference */
10431 	    ptr = POPPTR(ss,ix);
10432 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10433 	    ptr = POPPTR(ss,ix);
10434 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10435 	    break;
10436 	case SAVEt_PPTR:			/* char* reference */
10437 	    ptr = POPPTR(ss,ix);
10438 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10439 	    c = (char*)POPPTR(ss,ix);
10440 	    TOPPTR(nss,ix) = pv_dup(c);
10441 	    break;
10442 	case SAVEt_HPTR:			/* HV* reference */
10443 	    ptr = POPPTR(ss,ix);
10444 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10445 	    hv = (HV*)POPPTR(ss,ix);
10446 	    TOPPTR(nss,ix) = hv_dup(hv, param);
10447 	    break;
10448 	case SAVEt_APTR:			/* AV* reference */
10449 	    ptr = POPPTR(ss,ix);
10450 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10451 	    av = (AV*)POPPTR(ss,ix);
10452 	    TOPPTR(nss,ix) = av_dup(av, param);
10453 	    break;
10454 	case SAVEt_NSTAB:
10455 	    gv = (GV*)POPPTR(ss,ix);
10456 	    TOPPTR(nss,ix) = gv_dup(gv, param);
10457 	    break;
10458 	case SAVEt_GP:				/* scalar reference */
10459 	    gp = (GP*)POPPTR(ss,ix);
10460 	    TOPPTR(nss,ix) = gp = gp_dup(gp, param);
10461 	    (void)GpREFCNT_inc(gp);
10462 	    gv = (GV*)POPPTR(ss,ix);
10463 	    TOPPTR(nss,ix) = gv_dup_inc(gv, param);
10464             c = (char*)POPPTR(ss,ix);
10465 	    TOPPTR(nss,ix) = pv_dup(c);
10466 	    iv = POPIV(ss,ix);
10467 	    TOPIV(nss,ix) = iv;
10468 	    iv = POPIV(ss,ix);
10469 	    TOPIV(nss,ix) = iv;
10470             break;
10471 	case SAVEt_FREESV:
10472 	case SAVEt_MORTALIZESV:
10473 	    sv = (SV*)POPPTR(ss,ix);
10474 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10475 	    break;
10476 	case SAVEt_FREEOP:
10477 	    ptr = POPPTR(ss,ix);
10478 	    if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
10479 		/* these are assumed to be refcounted properly */
10480 		switch (((OP*)ptr)->op_type) {
10481 		case OP_LEAVESUB:
10482 		case OP_LEAVESUBLV:
10483 		case OP_LEAVEEVAL:
10484 		case OP_LEAVE:
10485 		case OP_SCOPE:
10486 		case OP_LEAVEWRITE:
10487 		    TOPPTR(nss,ix) = ptr;
10488 		    o = (OP*)ptr;
10489 		    OpREFCNT_inc(o);
10490 		    break;
10491 		default:
10492 		    TOPPTR(nss,ix) = Nullop;
10493 		    break;
10494 		}
10495 	    }
10496 	    else
10497 		TOPPTR(nss,ix) = Nullop;
10498 	    break;
10499 	case SAVEt_FREEPV:
10500 	    c = (char*)POPPTR(ss,ix);
10501 	    TOPPTR(nss,ix) = pv_dup_inc(c);
10502 	    break;
10503 	case SAVEt_CLEARSV:
10504 	    longval = POPLONG(ss,ix);
10505 	    TOPLONG(nss,ix) = longval;
10506 	    break;
10507 	case SAVEt_DELETE:
10508 	    hv = (HV*)POPPTR(ss,ix);
10509 	    TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10510 	    c = (char*)POPPTR(ss,ix);
10511 	    TOPPTR(nss,ix) = pv_dup_inc(c);
10512 	    i = POPINT(ss,ix);
10513 	    TOPINT(nss,ix) = i;
10514 	    break;
10515 	case SAVEt_DESTRUCTOR:
10516 	    ptr = POPPTR(ss,ix);
10517 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);	/* XXX quite arbitrary */
10518 	    dptr = POPDPTR(ss,ix);
10519 	    TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
10520 	    break;
10521 	case SAVEt_DESTRUCTOR_X:
10522 	    ptr = POPPTR(ss,ix);
10523 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);	/* XXX quite arbitrary */
10524 	    dxptr = POPDXPTR(ss,ix);
10525 	    TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
10526 	    break;
10527 	case SAVEt_REGCONTEXT:
10528 	case SAVEt_ALLOC:
10529 	    i = POPINT(ss,ix);
10530 	    TOPINT(nss,ix) = i;
10531 	    ix -= i;
10532 	    break;
10533 	case SAVEt_STACK_POS:		/* Position on Perl stack */
10534 	    i = POPINT(ss,ix);
10535 	    TOPINT(nss,ix) = i;
10536 	    break;
10537 	case SAVEt_AELEM:		/* array element */
10538 	    sv = (SV*)POPPTR(ss,ix);
10539 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10540 	    i = POPINT(ss,ix);
10541 	    TOPINT(nss,ix) = i;
10542 	    av = (AV*)POPPTR(ss,ix);
10543 	    TOPPTR(nss,ix) = av_dup_inc(av, param);
10544 	    break;
10545 	case SAVEt_HELEM:		/* hash element */
10546 	    sv = (SV*)POPPTR(ss,ix);
10547 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10548 	    sv = (SV*)POPPTR(ss,ix);
10549 	    TOPPTR(nss,ix) = sv_dup_inc(sv, param);
10550 	    hv = (HV*)POPPTR(ss,ix);
10551 	    TOPPTR(nss,ix) = hv_dup_inc(hv, param);
10552 	    break;
10553 	case SAVEt_OP:
10554 	    ptr = POPPTR(ss,ix);
10555 	    TOPPTR(nss,ix) = ptr;
10556 	    break;
10557 	case SAVEt_HINTS:
10558 	    i = POPINT(ss,ix);
10559 	    TOPINT(nss,ix) = i;
10560 	    break;
10561 	case SAVEt_COMPPAD:
10562 	    av = (AV*)POPPTR(ss,ix);
10563 	    TOPPTR(nss,ix) = av_dup(av, param);
10564 	    break;
10565 	case SAVEt_PADSV:
10566 	    longval = (long)POPLONG(ss,ix);
10567 	    TOPLONG(nss,ix) = longval;
10568 	    ptr = POPPTR(ss,ix);
10569 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10570 	    sv = (SV*)POPPTR(ss,ix);
10571 	    TOPPTR(nss,ix) = sv_dup(sv, param);
10572 	    break;
10573 	case SAVEt_BOOL:
10574 	    ptr = POPPTR(ss,ix);
10575 	    TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
10576 	    longval = (long)POPBOOL(ss,ix);
10577 	    TOPBOOL(nss,ix) = (bool)longval;
10578 	    break;
10579 	default:
10580 	    Perl_croak(aTHX_ "panic: ss_dup inconsistency");
10581 	}
10582     }
10583 
10584     return nss;
10585 }
10586 
10587 /*
10588 =for apidoc perl_clone
10589 
10590 Create and return a new interpreter by cloning the current one.
10591 
10592 perl_clone takes these flags as parameters:
10593 
10594 CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
10595 without it we only clone the data and zero the stacks,
10596 with it we copy the stacks and the new perl interpreter is
10597 ready to run at the exact same point as the previous one.
10598 The pseudo-fork code uses COPY_STACKS while the
10599 threads->new doesn't.
10600 
10601 CLONEf_KEEP_PTR_TABLE
10602 perl_clone keeps a ptr_table with the pointer of the old
10603 variable as a key and the new variable as a value,
10604 this allows it to check if something has been cloned and not
10605 clone it again but rather just use the value and increase the
10606 refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
10607 the ptr_table using the function
10608 C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
10609 reason to keep it around is if you want to dup some of your own
10610 variable who are outside the graph perl scans, example of this
10611 code is in threads.xs create
10612 
10613 CLONEf_CLONE_HOST
10614 This is a win32 thing, it is ignored on unix, it tells perls
10615 win32host code (which is c++) to clone itself, this is needed on
10616 win32 if you want to run two threads at the same time,
10617 if you just want to do some stuff in a separate perl interpreter
10618 and then throw it away and return to the original one,
10619 you don't need to do anything.
10620 
10621 =cut
10622 */
10623 
10624 /* XXX the above needs expanding by someone who actually understands it ! */
10625 EXTERN_C PerlInterpreter *
10626 perl_clone_host(PerlInterpreter* proto_perl, UV flags);
10627 
10628 PerlInterpreter *
perl_clone(PerlInterpreter * proto_perl,UV flags)10629 perl_clone(PerlInterpreter *proto_perl, UV flags)
10630 {
10631 #ifdef PERL_IMPLICIT_SYS
10632 
10633    /* perlhost.h so we need to call into it
10634    to clone the host, CPerlHost should have a c interface, sky */
10635 
10636    if (flags & CLONEf_CLONE_HOST) {
10637        return perl_clone_host(proto_perl,flags);
10638    }
10639    return perl_clone_using(proto_perl, flags,
10640 			    proto_perl->IMem,
10641 			    proto_perl->IMemShared,
10642 			    proto_perl->IMemParse,
10643 			    proto_perl->IEnv,
10644 			    proto_perl->IStdIO,
10645 			    proto_perl->ILIO,
10646 			    proto_perl->IDir,
10647 			    proto_perl->ISock,
10648 			    proto_perl->IProc);
10649 }
10650 
10651 PerlInterpreter *
perl_clone_using(PerlInterpreter * proto_perl,UV flags,struct IPerlMem * ipM,struct IPerlMem * ipMS,struct IPerlMem * ipMP,struct IPerlEnv * ipE,struct IPerlStdIO * ipStd,struct IPerlLIO * ipLIO,struct IPerlDir * ipD,struct IPerlSock * ipS,struct IPerlProc * ipP)10652 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
10653 		 struct IPerlMem* ipM, struct IPerlMem* ipMS,
10654 		 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
10655 		 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
10656 		 struct IPerlDir* ipD, struct IPerlSock* ipS,
10657 		 struct IPerlProc* ipP)
10658 {
10659     /* XXX many of the string copies here can be optimized if they're
10660      * constants; they need to be allocated as common memory and just
10661      * their pointers copied. */
10662 
10663     IV i;
10664     CLONE_PARAMS clone_params;
10665     CLONE_PARAMS* param = &clone_params;
10666 
10667     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
10668     PERL_SET_THX(my_perl);
10669 
10670 #  ifdef DEBUGGING
10671     Poison(my_perl, 1, PerlInterpreter);
10672     PL_markstack = 0;
10673     PL_scopestack = 0;
10674     PL_savestack = 0;
10675     PL_savestack_ix = 0;
10676     PL_savestack_max = -1;
10677     PL_retstack = 0;
10678     PL_sig_pending = 0;
10679     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10680 #  else	/* !DEBUGGING */
10681     Zero(my_perl, 1, PerlInterpreter);
10682 #  endif	/* DEBUGGING */
10683 
10684     /* host pointers */
10685     PL_Mem		= ipM;
10686     PL_MemShared	= ipMS;
10687     PL_MemParse		= ipMP;
10688     PL_Env		= ipE;
10689     PL_StdIO		= ipStd;
10690     PL_LIO		= ipLIO;
10691     PL_Dir		= ipD;
10692     PL_Sock		= ipS;
10693     PL_Proc		= ipP;
10694 #else		/* !PERL_IMPLICIT_SYS */
10695     IV i;
10696     CLONE_PARAMS clone_params;
10697     CLONE_PARAMS* param = &clone_params;
10698     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
10699     PERL_SET_THX(my_perl);
10700 
10701 
10702 
10703 #    ifdef DEBUGGING
10704     Poison(my_perl, 1, PerlInterpreter);
10705     PL_markstack = 0;
10706     PL_scopestack = 0;
10707     PL_savestack = 0;
10708     PL_savestack_ix = 0;
10709     PL_savestack_max = -1;
10710     PL_retstack = 0;
10711     PL_sig_pending = 0;
10712     Zero(&PL_debug_pad, 1, struct perl_debug_pad);
10713 #    else	/* !DEBUGGING */
10714     Zero(my_perl, 1, PerlInterpreter);
10715 #    endif	/* DEBUGGING */
10716 #endif		/* PERL_IMPLICIT_SYS */
10717     param->flags = flags;
10718     param->proto_perl = proto_perl;
10719 
10720     /* arena roots */
10721     PL_xiv_arenaroot	= NULL;
10722     PL_xiv_root		= NULL;
10723     PL_xnv_arenaroot	= NULL;
10724     PL_xnv_root		= NULL;
10725     PL_xrv_arenaroot	= NULL;
10726     PL_xrv_root		= NULL;
10727     PL_xpv_arenaroot	= NULL;
10728     PL_xpv_root		= NULL;
10729     PL_xpviv_arenaroot	= NULL;
10730     PL_xpviv_root	= NULL;
10731     PL_xpvnv_arenaroot	= NULL;
10732     PL_xpvnv_root	= NULL;
10733     PL_xpvcv_arenaroot	= NULL;
10734     PL_xpvcv_root	= NULL;
10735     PL_xpvav_arenaroot	= NULL;
10736     PL_xpvav_root	= NULL;
10737     PL_xpvhv_arenaroot	= NULL;
10738     PL_xpvhv_root	= NULL;
10739     PL_xpvmg_arenaroot	= NULL;
10740     PL_xpvmg_root	= NULL;
10741     PL_xpvlv_arenaroot	= NULL;
10742     PL_xpvlv_root	= NULL;
10743     PL_xpvbm_arenaroot	= NULL;
10744     PL_xpvbm_root	= NULL;
10745     PL_he_arenaroot	= NULL;
10746     PL_he_root		= NULL;
10747     PL_nice_chunk	= NULL;
10748     PL_nice_chunk_size	= 0;
10749     PL_sv_count		= 0;
10750     PL_sv_objcount	= 0;
10751     PL_sv_root		= Nullsv;
10752     PL_sv_arenaroot	= Nullsv;
10753 
10754     PL_debug		= proto_perl->Idebug;
10755 
10756 #ifdef USE_REENTRANT_API
10757     /* XXX: things like -Dm will segfault here in perlio, but doing
10758      *  PERL_SET_CONTEXT(proto_perl);
10759      * breaks too many other things
10760      */
10761     Perl_reentrant_init(aTHX);
10762 #endif
10763 
10764     /* create SV map for pointer relocation */
10765     PL_ptr_table = ptr_table_new();
10766 
10767     /* initialize these special pointers as early as possible */
10768     SvANY(&PL_sv_undef)		= NULL;
10769     SvREFCNT(&PL_sv_undef)	= (~(U32)0)/2;
10770     SvFLAGS(&PL_sv_undef)	= SVf_READONLY|SVt_NULL;
10771     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
10772 
10773     SvANY(&PL_sv_no)		= new_XPVNV();
10774     SvREFCNT(&PL_sv_no)		= (~(U32)0)/2;
10775     SvFLAGS(&PL_sv_no)		= SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10776     SvPVX(&PL_sv_no)		= SAVEPVN(PL_No, 0);
10777     SvCUR(&PL_sv_no)		= 0;
10778     SvLEN(&PL_sv_no)		= 1;
10779     SvNVX(&PL_sv_no)		= 0;
10780     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
10781 
10782     SvANY(&PL_sv_yes)		= new_XPVNV();
10783     SvREFCNT(&PL_sv_yes)	= (~(U32)0)/2;
10784     SvFLAGS(&PL_sv_yes)		= SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
10785     SvPVX(&PL_sv_yes)		= SAVEPVN(PL_Yes, 1);
10786     SvCUR(&PL_sv_yes)		= 1;
10787     SvLEN(&PL_sv_yes)		= 2;
10788     SvNVX(&PL_sv_yes)		= 1;
10789     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
10790 
10791     /* create (a non-shared!) shared string table */
10792     PL_strtab		= newHV();
10793     HvSHAREKEYS_off(PL_strtab);
10794     hv_ksplit(PL_strtab, 512);
10795     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
10796 
10797     PL_compiling = proto_perl->Icompiling;
10798 
10799     /* These two PVs will be free'd special way so must set them same way op.c does */
10800     PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
10801     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
10802 
10803     PL_compiling.cop_file    = savesharedpv(PL_compiling.cop_file);
10804     ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
10805 
10806     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
10807     if (!specialWARN(PL_compiling.cop_warnings))
10808 	PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
10809     if (!specialCopIO(PL_compiling.cop_io))
10810 	PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
10811     PL_curcop		= (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
10812 
10813     /* pseudo environmental stuff */
10814     PL_origargc		= proto_perl->Iorigargc;
10815     PL_origargv		= proto_perl->Iorigargv;
10816 
10817     param->stashes      = newAV();  /* Setup array of objects to call clone on */
10818 
10819 #ifdef PERLIO_LAYERS
10820     /* Clone PerlIO tables as soon as we can handle general xx_dup() */
10821     PerlIO_clone(aTHX_ proto_perl, param);
10822 #endif
10823 
10824     PL_envgv		= gv_dup(proto_perl->Ienvgv, param);
10825     PL_incgv		= gv_dup(proto_perl->Iincgv, param);
10826     PL_hintgv		= gv_dup(proto_perl->Ihintgv, param);
10827     PL_origfilename	= SAVEPV(proto_perl->Iorigfilename);
10828     PL_diehook		= sv_dup_inc(proto_perl->Idiehook, param);
10829     PL_warnhook		= sv_dup_inc(proto_perl->Iwarnhook, param);
10830 
10831     /* switches */
10832     PL_minus_c		= proto_perl->Iminus_c;
10833     PL_patchlevel	= sv_dup_inc(proto_perl->Ipatchlevel, param);
10834     PL_localpatches	= proto_perl->Ilocalpatches;
10835     PL_splitstr		= proto_perl->Isplitstr;
10836     PL_preprocess	= proto_perl->Ipreprocess;
10837     PL_minus_n		= proto_perl->Iminus_n;
10838     PL_minus_p		= proto_perl->Iminus_p;
10839     PL_minus_l		= proto_perl->Iminus_l;
10840     PL_minus_a		= proto_perl->Iminus_a;
10841     PL_minus_F		= proto_perl->Iminus_F;
10842     PL_doswitches	= proto_perl->Idoswitches;
10843     PL_dowarn		= proto_perl->Idowarn;
10844     PL_doextract	= proto_perl->Idoextract;
10845     PL_sawampersand	= proto_perl->Isawampersand;
10846     PL_unsafe		= proto_perl->Iunsafe;
10847     PL_inplace		= SAVEPV(proto_perl->Iinplace);
10848     PL_e_script		= sv_dup_inc(proto_perl->Ie_script, param);
10849     PL_perldb		= proto_perl->Iperldb;
10850     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
10851     PL_exit_flags       = proto_perl->Iexit_flags;
10852 
10853     /* magical thingies */
10854     /* XXX time(&PL_basetime) when asked for? */
10855     PL_basetime		= proto_perl->Ibasetime;
10856     PL_formfeed		= sv_dup(proto_perl->Iformfeed, param);
10857 
10858     PL_maxsysfd		= proto_perl->Imaxsysfd;
10859     PL_multiline	= proto_perl->Imultiline;
10860     PL_statusvalue	= proto_perl->Istatusvalue;
10861 #ifdef VMS
10862     PL_statusvalue_vms	= proto_perl->Istatusvalue_vms;
10863 #endif
10864     PL_encoding		= sv_dup(proto_perl->Iencoding, param);
10865 
10866     sv_setpvn(PERL_DEBUG_PAD(0), "", 0);	/* For regex debugging. */
10867     sv_setpvn(PERL_DEBUG_PAD(1), "", 0);	/* ext/re needs these */
10868     sv_setpvn(PERL_DEBUG_PAD(2), "", 0);	/* even without DEBUGGING. */
10869 
10870     /* Clone the regex array */
10871     PL_regex_padav = newAV();
10872     {
10873 	I32 len = av_len((AV*)proto_perl->Iregex_padav);
10874 	SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
10875 	av_push(PL_regex_padav,
10876 		sv_dup_inc(regexen[0],param));
10877 	for(i = 1; i <= len; i++) {
10878             if(SvREPADTMP(regexen[i])) {
10879 	      av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
10880             } else {
10881 	        av_push(PL_regex_padav,
10882                     SvREFCNT_inc(
10883                         newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
10884                              SvIVX(regexen[i])), param)))
10885                        ));
10886 	    }
10887 	}
10888     }
10889     PL_regex_pad = AvARRAY(PL_regex_padav);
10890 
10891     /* shortcuts to various I/O objects */
10892     PL_stdingv		= gv_dup(proto_perl->Istdingv, param);
10893     PL_stderrgv		= gv_dup(proto_perl->Istderrgv, param);
10894     PL_defgv		= gv_dup(proto_perl->Idefgv, param);
10895     PL_argvgv		= gv_dup(proto_perl->Iargvgv, param);
10896     PL_argvoutgv	= gv_dup(proto_perl->Iargvoutgv, param);
10897     PL_argvout_stack	= av_dup_inc(proto_perl->Iargvout_stack, param);
10898 
10899     /* shortcuts to regexp stuff */
10900     PL_replgv		= gv_dup(proto_perl->Ireplgv, param);
10901 
10902     /* shortcuts to misc objects */
10903     PL_errgv		= gv_dup(proto_perl->Ierrgv, param);
10904 
10905     /* shortcuts to debugging objects */
10906     PL_DBgv		= gv_dup(proto_perl->IDBgv, param);
10907     PL_DBline		= gv_dup(proto_perl->IDBline, param);
10908     PL_DBsub		= gv_dup(proto_perl->IDBsub, param);
10909     PL_DBsingle		= sv_dup(proto_perl->IDBsingle, param);
10910     PL_DBtrace		= sv_dup(proto_perl->IDBtrace, param);
10911     PL_DBsignal		= sv_dup(proto_perl->IDBsignal, param);
10912     PL_lineary		= av_dup(proto_perl->Ilineary, param);
10913     PL_dbargs		= av_dup(proto_perl->Idbargs, param);
10914 
10915     /* symbol tables */
10916     PL_defstash		= hv_dup_inc(proto_perl->Tdefstash, param);
10917     PL_curstash		= hv_dup(proto_perl->Tcurstash, param);
10918     PL_nullstash       = hv_dup(proto_perl->Inullstash, param);
10919     PL_debstash		= hv_dup(proto_perl->Idebstash, param);
10920     PL_globalstash	= hv_dup(proto_perl->Iglobalstash, param);
10921     PL_curstname	= sv_dup_inc(proto_perl->Icurstname, param);
10922 
10923     PL_beginav		= av_dup_inc(proto_perl->Ibeginav, param);
10924     PL_beginav_save	= av_dup_inc(proto_perl->Ibeginav_save, param);
10925     PL_checkav_save	= av_dup_inc(proto_perl->Icheckav_save, param);
10926     PL_endav		= av_dup_inc(proto_perl->Iendav, param);
10927     PL_checkav		= av_dup_inc(proto_perl->Icheckav, param);
10928     PL_initav		= av_dup_inc(proto_perl->Iinitav, param);
10929 
10930     PL_sub_generation	= proto_perl->Isub_generation;
10931 
10932     /* funky return mechanisms */
10933     PL_forkprocess	= proto_perl->Iforkprocess;
10934 
10935     /* subprocess state */
10936     PL_fdpid		= av_dup_inc(proto_perl->Ifdpid, param);
10937 
10938     /* internal state */
10939     PL_tainting		= proto_perl->Itainting;
10940     PL_taint_warn       = proto_perl->Itaint_warn;
10941     PL_maxo		= proto_perl->Imaxo;
10942     if (proto_perl->Iop_mask)
10943 	PL_op_mask	= SAVEPVN(proto_perl->Iop_mask, PL_maxo);
10944     else
10945 	PL_op_mask 	= Nullch;
10946 
10947     /* current interpreter roots */
10948     PL_main_cv		= cv_dup_inc(proto_perl->Imain_cv, param);
10949     PL_main_root	= OpREFCNT_inc(proto_perl->Imain_root);
10950     PL_main_start	= proto_perl->Imain_start;
10951     PL_eval_root	= proto_perl->Ieval_root;
10952     PL_eval_start	= proto_perl->Ieval_start;
10953 
10954     /* runtime control stuff */
10955     PL_curcopdb		= (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
10956     PL_copline		= proto_perl->Icopline;
10957 
10958     PL_filemode		= proto_perl->Ifilemode;
10959     PL_lastfd		= proto_perl->Ilastfd;
10960     PL_oldname		= proto_perl->Ioldname;		/* XXX not quite right */
10961     PL_Argv		= NULL;
10962     PL_Cmd		= Nullch;
10963     PL_gensym		= proto_perl->Igensym;
10964     PL_preambled	= proto_perl->Ipreambled;
10965     PL_preambleav	= av_dup_inc(proto_perl->Ipreambleav, param);
10966     PL_laststatval	= proto_perl->Ilaststatval;
10967     PL_laststype	= proto_perl->Ilaststype;
10968     PL_mess_sv		= Nullsv;
10969 
10970     PL_ors_sv		= sv_dup_inc(proto_perl->Iors_sv, param);
10971     PL_ofmt		= SAVEPV(proto_perl->Iofmt);
10972 
10973     /* interpreter atexit processing */
10974     PL_exitlistlen	= proto_perl->Iexitlistlen;
10975     if (PL_exitlistlen) {
10976 	New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10977 	Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
10978     }
10979     else
10980 	PL_exitlist	= (PerlExitListEntry*)NULL;
10981     PL_modglobal	= hv_dup_inc(proto_perl->Imodglobal, param);
10982     PL_custom_op_names  = hv_dup_inc(proto_perl->Icustom_op_names,param);
10983     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
10984 
10985     PL_profiledata	= NULL;
10986     PL_rsfp		= fp_dup(proto_perl->Irsfp, '<', param);
10987     /* PL_rsfp_filters entries have fake IoDIRP() */
10988     PL_rsfp_filters	= av_dup_inc(proto_perl->Irsfp_filters, param);
10989 
10990     PL_compcv			= cv_dup(proto_perl->Icompcv, param);
10991 
10992     PAD_CLONE_VARS(proto_perl, param);
10993 
10994 #ifdef HAVE_INTERP_INTERN
10995     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
10996 #endif
10997 
10998     /* more statics moved here */
10999     PL_generation	= proto_perl->Igeneration;
11000     PL_DBcv		= cv_dup(proto_perl->IDBcv, param);
11001 
11002     PL_in_clean_objs	= proto_perl->Iin_clean_objs;
11003     PL_in_clean_all	= proto_perl->Iin_clean_all;
11004 
11005     PL_uid		= proto_perl->Iuid;
11006     PL_euid		= proto_perl->Ieuid;
11007     PL_gid		= proto_perl->Igid;
11008     PL_egid		= proto_perl->Iegid;
11009     PL_nomemok		= proto_perl->Inomemok;
11010     PL_an		= proto_perl->Ian;
11011     PL_op_seqmax	= proto_perl->Iop_seqmax;
11012     PL_evalseq		= proto_perl->Ievalseq;
11013     PL_origenviron	= proto_perl->Iorigenviron;	/* XXX not quite right */
11014     PL_origalen		= proto_perl->Iorigalen;
11015     PL_pidstatus	= newHV();			/* XXX flag for cloning? */
11016     PL_osname		= SAVEPV(proto_perl->Iosname);
11017     PL_sh_path_compat	= proto_perl->Ish_path_compat; /* XXX never deallocated */
11018     PL_sighandlerp	= proto_perl->Isighandlerp;
11019 
11020 
11021     PL_runops		= proto_perl->Irunops;
11022 
11023     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
11024 
11025 #ifdef CSH
11026     PL_cshlen		= proto_perl->Icshlen;
11027     PL_cshname		= proto_perl->Icshname; /* XXX never deallocated */
11028 #endif
11029 
11030     PL_lex_state	= proto_perl->Ilex_state;
11031     PL_lex_defer	= proto_perl->Ilex_defer;
11032     PL_lex_expect	= proto_perl->Ilex_expect;
11033     PL_lex_formbrack	= proto_perl->Ilex_formbrack;
11034     PL_lex_dojoin	= proto_perl->Ilex_dojoin;
11035     PL_lex_starts	= proto_perl->Ilex_starts;
11036     PL_lex_stuff	= sv_dup_inc(proto_perl->Ilex_stuff, param);
11037     PL_lex_repl		= sv_dup_inc(proto_perl->Ilex_repl, param);
11038     PL_lex_op		= proto_perl->Ilex_op;
11039     PL_lex_inpat	= proto_perl->Ilex_inpat;
11040     PL_lex_inwhat	= proto_perl->Ilex_inwhat;
11041     PL_lex_brackets	= proto_perl->Ilex_brackets;
11042     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
11043     PL_lex_brackstack	= SAVEPVN(proto_perl->Ilex_brackstack,i);
11044     PL_lex_casemods	= proto_perl->Ilex_casemods;
11045     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
11046     PL_lex_casestack	= SAVEPVN(proto_perl->Ilex_casestack,i);
11047 
11048     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
11049     Copy(proto_perl->Inexttype, PL_nexttype, 5,	I32);
11050     PL_nexttoke		= proto_perl->Inexttoke;
11051 
11052     /* XXX This is probably masking the deeper issue of why
11053      * SvANY(proto_perl->Ilinestr) can be NULL at this point. For test case:
11054      * http://archive.develooper.com/perl5-porters%40perl.org/msg83298.html
11055      * (A little debugging with a watchpoint on it may help.)
11056      */
11057     if (SvANY(proto_perl->Ilinestr)) {
11058 	PL_linestr		= sv_dup_inc(proto_perl->Ilinestr, param);
11059 	i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
11060 	PL_bufptr		= SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11061 	i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
11062 	PL_oldbufptr	= SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11063 	i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
11064 	PL_oldoldbufptr	= SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11065 	i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
11066 	PL_linestart	= SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11067     }
11068     else {
11069         PL_linestr = NEWSV(65,79);
11070         sv_upgrade(PL_linestr,SVt_PVIV);
11071         sv_setpvn(PL_linestr,"",0);
11072 	PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
11073     }
11074     PL_bufend		= SvPVX(PL_linestr) + SvCUR(PL_linestr);
11075     PL_pending_ident	= proto_perl->Ipending_ident;
11076     PL_sublex_info	= proto_perl->Isublex_info;	/* XXX not quite right */
11077 
11078     PL_expect		= proto_perl->Iexpect;
11079 
11080     PL_multi_start	= proto_perl->Imulti_start;
11081     PL_multi_end	= proto_perl->Imulti_end;
11082     PL_multi_open	= proto_perl->Imulti_open;
11083     PL_multi_close	= proto_perl->Imulti_close;
11084 
11085     PL_error_count	= proto_perl->Ierror_count;
11086     PL_subline		= proto_perl->Isubline;
11087     PL_subname		= sv_dup_inc(proto_perl->Isubname, param);
11088 
11089     /* XXX See comment on SvANY(proto_perl->Ilinestr) above */
11090     if (SvANY(proto_perl->Ilinestr)) {
11091 	i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
11092 	PL_last_uni		= SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11093 	i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
11094 	PL_last_lop		= SvPVX(PL_linestr) + (i < 0 ? 0 : i);
11095 	PL_last_lop_op	= proto_perl->Ilast_lop_op;
11096     }
11097     else {
11098 	PL_last_uni	= SvPVX(PL_linestr);
11099 	PL_last_lop	= SvPVX(PL_linestr);
11100 	PL_last_lop_op	= 0;
11101     }
11102     PL_in_my		= proto_perl->Iin_my;
11103     PL_in_my_stash	= hv_dup(proto_perl->Iin_my_stash, param);
11104 #ifdef FCRYPT
11105     PL_cryptseen	= proto_perl->Icryptseen;
11106 #endif
11107 
11108     PL_hints		= proto_perl->Ihints;
11109 
11110     PL_amagic_generation	= proto_perl->Iamagic_generation;
11111 
11112 #ifdef USE_LOCALE_COLLATE
11113     PL_collation_ix	= proto_perl->Icollation_ix;
11114     PL_collation_name	= SAVEPV(proto_perl->Icollation_name);
11115     PL_collation_standard	= proto_perl->Icollation_standard;
11116     PL_collxfrm_base	= proto_perl->Icollxfrm_base;
11117     PL_collxfrm_mult	= proto_perl->Icollxfrm_mult;
11118 #endif /* USE_LOCALE_COLLATE */
11119 
11120 #ifdef USE_LOCALE_NUMERIC
11121     PL_numeric_name	= SAVEPV(proto_perl->Inumeric_name);
11122     PL_numeric_standard	= proto_perl->Inumeric_standard;
11123     PL_numeric_local	= proto_perl->Inumeric_local;
11124     PL_numeric_radix_sv	= sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
11125 #endif /* !USE_LOCALE_NUMERIC */
11126 
11127     /* utf8 character classes */
11128     PL_utf8_alnum	= sv_dup_inc(proto_perl->Iutf8_alnum, param);
11129     PL_utf8_alnumc	= sv_dup_inc(proto_perl->Iutf8_alnumc, param);
11130     PL_utf8_ascii	= sv_dup_inc(proto_perl->Iutf8_ascii, param);
11131     PL_utf8_alpha	= sv_dup_inc(proto_perl->Iutf8_alpha, param);
11132     PL_utf8_space	= sv_dup_inc(proto_perl->Iutf8_space, param);
11133     PL_utf8_cntrl	= sv_dup_inc(proto_perl->Iutf8_cntrl, param);
11134     PL_utf8_graph	= sv_dup_inc(proto_perl->Iutf8_graph, param);
11135     PL_utf8_digit	= sv_dup_inc(proto_perl->Iutf8_digit, param);
11136     PL_utf8_upper	= sv_dup_inc(proto_perl->Iutf8_upper, param);
11137     PL_utf8_lower	= sv_dup_inc(proto_perl->Iutf8_lower, param);
11138     PL_utf8_print	= sv_dup_inc(proto_perl->Iutf8_print, param);
11139     PL_utf8_punct	= sv_dup_inc(proto_perl->Iutf8_punct, param);
11140     PL_utf8_xdigit	= sv_dup_inc(proto_perl->Iutf8_xdigit, param);
11141     PL_utf8_mark	= sv_dup_inc(proto_perl->Iutf8_mark, param);
11142     PL_utf8_toupper	= sv_dup_inc(proto_perl->Iutf8_toupper, param);
11143     PL_utf8_totitle	= sv_dup_inc(proto_perl->Iutf8_totitle, param);
11144     PL_utf8_tolower	= sv_dup_inc(proto_perl->Iutf8_tolower, param);
11145     PL_utf8_tofold	= sv_dup_inc(proto_perl->Iutf8_tofold, param);
11146     PL_utf8_idstart	= sv_dup_inc(proto_perl->Iutf8_idstart, param);
11147     PL_utf8_idcont	= sv_dup_inc(proto_perl->Iutf8_idcont, param);
11148 
11149     /* Did the locale setup indicate UTF-8? */
11150     PL_utf8locale	= proto_perl->Iutf8locale;
11151     /* Unicode features (see perlrun/-C) */
11152     PL_unicode		= proto_perl->Iunicode;
11153 
11154     /* Pre-5.8 signals control */
11155     PL_signals		= proto_perl->Isignals;
11156 
11157     /* times() ticks per second */
11158     PL_clocktick	= proto_perl->Iclocktick;
11159 
11160     /* Recursion stopper for PerlIO_find_layer */
11161     PL_in_load_module	= proto_perl->Iin_load_module;
11162 
11163     /* sort() routine */
11164     PL_sort_RealCmp	= proto_perl->Isort_RealCmp;
11165 
11166     /* Not really needed/useful since the reenrant_retint is "volatile",
11167      * but do it for consistency's sake. */
11168     PL_reentrant_retint	= proto_perl->Ireentrant_retint;
11169 
11170     /* Hooks to shared SVs and locks. */
11171     PL_sharehook	= proto_perl->Isharehook;
11172     PL_lockhook		= proto_perl->Ilockhook;
11173     PL_unlockhook	= proto_perl->Iunlockhook;
11174     PL_threadhook	= proto_perl->Ithreadhook;
11175 
11176     PL_runops_std	= proto_perl->Irunops_std;
11177     PL_runops_dbg	= proto_perl->Irunops_dbg;
11178 
11179 #ifdef THREADS_HAVE_PIDS
11180     PL_ppid		= proto_perl->Ippid;
11181 #endif
11182 
11183     /* swatch cache */
11184     PL_last_swash_hv	= Nullhv;	/* reinits on demand */
11185     PL_last_swash_klen	= 0;
11186     PL_last_swash_key[0]= '\0';
11187     PL_last_swash_tmps	= (U8*)NULL;
11188     PL_last_swash_slen	= 0;
11189 
11190     /* perly.c globals */
11191     PL_yydebug		= proto_perl->Iyydebug;
11192     PL_yynerrs		= proto_perl->Iyynerrs;
11193     PL_yyerrflag	= proto_perl->Iyyerrflag;
11194     PL_yychar		= proto_perl->Iyychar;
11195     PL_yyval		= proto_perl->Iyyval;
11196     PL_yylval		= proto_perl->Iyylval;
11197 
11198     PL_glob_index	= proto_perl->Iglob_index;
11199     PL_srand_called	= proto_perl->Isrand_called;
11200     PL_hash_seed	= proto_perl->Ihash_seed;
11201     PL_rehash_seed	= proto_perl->Irehash_seed;
11202     PL_uudmap['M']	= 0;		/* reinits on demand */
11203     PL_bitcount		= Nullch;	/* reinits on demand */
11204 
11205     if (proto_perl->Ipsig_pend) {
11206 	Newz(0, PL_psig_pend, SIG_SIZE, int);
11207     }
11208     else {
11209 	PL_psig_pend	= (int*)NULL;
11210     }
11211 
11212     if (proto_perl->Ipsig_ptr) {
11213 	Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
11214 	Newz(0, PL_psig_name, SIG_SIZE, SV*);
11215 	for (i = 1; i < SIG_SIZE; i++) {
11216 	    PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
11217 	    PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
11218 	}
11219     }
11220     else {
11221 	PL_psig_ptr	= (SV**)NULL;
11222 	PL_psig_name	= (SV**)NULL;
11223     }
11224 
11225     /* thrdvar.h stuff */
11226 
11227     if (flags & CLONEf_COPY_STACKS) {
11228 	/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
11229 	PL_tmps_ix		= proto_perl->Ttmps_ix;
11230 	PL_tmps_max		= proto_perl->Ttmps_max;
11231 	PL_tmps_floor		= proto_perl->Ttmps_floor;
11232 	Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
11233 	i = 0;
11234 	while (i <= PL_tmps_ix) {
11235 	    PL_tmps_stack[i]	= sv_dup_inc(proto_perl->Ttmps_stack[i], param);
11236 	    ++i;
11237 	}
11238 
11239 	/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
11240 	i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
11241 	Newz(54, PL_markstack, i, I32);
11242 	PL_markstack_max	= PL_markstack + (proto_perl->Tmarkstack_max
11243 						  - proto_perl->Tmarkstack);
11244 	PL_markstack_ptr	= PL_markstack + (proto_perl->Tmarkstack_ptr
11245 						  - proto_perl->Tmarkstack);
11246 	Copy(proto_perl->Tmarkstack, PL_markstack,
11247 	     PL_markstack_ptr - PL_markstack + 1, I32);
11248 
11249 	/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
11250 	 * NOTE: unlike the others! */
11251 	PL_scopestack_ix	= proto_perl->Tscopestack_ix;
11252 	PL_scopestack_max	= proto_perl->Tscopestack_max;
11253 	Newz(54, PL_scopestack, PL_scopestack_max, I32);
11254 	Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
11255 
11256 	/* next push_return() sets PL_retstack[PL_retstack_ix]
11257 	 * NOTE: unlike the others! */
11258 	PL_retstack_ix		= proto_perl->Tretstack_ix;
11259 	PL_retstack_max		= proto_perl->Tretstack_max;
11260 	Newz(54, PL_retstack, PL_retstack_max, OP*);
11261 	Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*);
11262 
11263 	/* NOTE: si_dup() looks at PL_markstack */
11264 	PL_curstackinfo		= si_dup(proto_perl->Tcurstackinfo, param);
11265 
11266 	/* PL_curstack		= PL_curstackinfo->si_stack; */
11267 	PL_curstack		= av_dup(proto_perl->Tcurstack, param);
11268 	PL_mainstack		= av_dup(proto_perl->Tmainstack, param);
11269 
11270 	/* next PUSHs() etc. set *(PL_stack_sp+1) */
11271 	PL_stack_base		= AvARRAY(PL_curstack);
11272 	PL_stack_sp		= PL_stack_base + (proto_perl->Tstack_sp
11273 						   - proto_perl->Tstack_base);
11274 	PL_stack_max		= PL_stack_base + AvMAX(PL_curstack);
11275 
11276 	/* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
11277 	 * NOTE: unlike the others! */
11278 	PL_savestack_ix		= proto_perl->Tsavestack_ix;
11279 	PL_savestack_max	= proto_perl->Tsavestack_max;
11280 	/*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
11281 	PL_savestack		= ss_dup(proto_perl, param);
11282     }
11283     else {
11284 	init_stacks();
11285 	ENTER;			/* perl_destruct() wants to LEAVE; */
11286     }
11287 
11288     PL_start_env	= proto_perl->Tstart_env;	/* XXXXXX */
11289     PL_top_env		= &PL_start_env;
11290 
11291     PL_op		= proto_perl->Top;
11292 
11293     PL_Sv		= Nullsv;
11294     PL_Xpv		= (XPV*)NULL;
11295     PL_na		= proto_perl->Tna;
11296 
11297     PL_statbuf		= proto_perl->Tstatbuf;
11298     PL_statcache	= proto_perl->Tstatcache;
11299     PL_statgv		= gv_dup(proto_perl->Tstatgv, param);
11300     PL_statname		= sv_dup_inc(proto_perl->Tstatname, param);
11301 #ifdef HAS_TIMES
11302     PL_timesbuf		= proto_perl->Ttimesbuf;
11303 #endif
11304 
11305     PL_tainted		= proto_perl->Ttainted;
11306     PL_curpm		= proto_perl->Tcurpm;	/* XXX No PMOP ref count */
11307     PL_rs		= sv_dup_inc(proto_perl->Trs, param);
11308     PL_last_in_gv	= gv_dup(proto_perl->Tlast_in_gv, param);
11309     PL_ofs_sv		= sv_dup_inc(proto_perl->Tofs_sv, param);
11310     PL_defoutgv		= gv_dup_inc(proto_perl->Tdefoutgv, param);
11311     PL_chopset		= proto_perl->Tchopset;	/* XXX never deallocated */
11312     PL_toptarget	= sv_dup_inc(proto_perl->Ttoptarget, param);
11313     PL_bodytarget	= sv_dup_inc(proto_perl->Tbodytarget, param);
11314     PL_formtarget	= sv_dup(proto_perl->Tformtarget, param);
11315 
11316     PL_restartop	= proto_perl->Trestartop;
11317     PL_in_eval		= proto_perl->Tin_eval;
11318     PL_delaymagic	= proto_perl->Tdelaymagic;
11319     PL_dirty		= proto_perl->Tdirty;
11320     PL_localizing	= proto_perl->Tlocalizing;
11321 
11322 #ifdef PERL_FLEXIBLE_EXCEPTIONS
11323     PL_protect		= proto_perl->Tprotect;
11324 #endif
11325     PL_errors		= sv_dup_inc(proto_perl->Terrors, param);
11326     PL_hv_fetch_ent_mh	= Nullhe;
11327     PL_modcount		= proto_perl->Tmodcount;
11328     PL_lastgotoprobe	= Nullop;
11329     PL_dumpindent	= proto_perl->Tdumpindent;
11330 
11331     PL_sortcop		= (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
11332     PL_sortstash	= hv_dup(proto_perl->Tsortstash, param);
11333     PL_firstgv		= gv_dup(proto_perl->Tfirstgv, param);
11334     PL_secondgv		= gv_dup(proto_perl->Tsecondgv, param);
11335     PL_sortcxix		= proto_perl->Tsortcxix;
11336     PL_efloatbuf	= Nullch;		/* reinits on demand */
11337     PL_efloatsize	= 0;			/* reinits on demand */
11338 
11339     /* regex stuff */
11340 
11341     PL_screamfirst	= NULL;
11342     PL_screamnext	= NULL;
11343     PL_maxscream	= -1;			/* reinits on demand */
11344     PL_lastscream	= Nullsv;
11345 
11346     PL_watchaddr	= NULL;
11347     PL_watchok		= Nullch;
11348 
11349     PL_regdummy		= proto_perl->Tregdummy;
11350     PL_regcomp_parse	= Nullch;
11351     PL_regxend		= Nullch;
11352     PL_regcode		= (regnode*)NULL;
11353     PL_regnaughty	= 0;
11354     PL_regsawback	= 0;
11355     PL_regprecomp	= Nullch;
11356     PL_regnpar		= 0;
11357     PL_regsize		= 0;
11358     PL_regflags		= 0;
11359     PL_regseen		= 0;
11360     PL_seen_zerolen	= 0;
11361     PL_seen_evals	= 0;
11362     PL_regcomp_rx	= (regexp*)NULL;
11363     PL_extralen		= 0;
11364     PL_colorset		= 0;		/* reinits PL_colors[] */
11365     /*PL_colors[6]	= {0,0,0,0,0,0};*/
11366     PL_reg_whilem_seen	= 0;
11367     PL_reginput		= Nullch;
11368     PL_regbol		= Nullch;
11369     PL_regeol		= Nullch;
11370     PL_regstartp	= (I32*)NULL;
11371     PL_regendp		= (I32*)NULL;
11372     PL_reglastparen	= (U32*)NULL;
11373     PL_reglastcloseparen	= (U32*)NULL;
11374     PL_regtill		= Nullch;
11375     PL_reg_start_tmp	= (char**)NULL;
11376     PL_reg_start_tmpl	= 0;
11377     PL_regdata		= (struct reg_data*)NULL;
11378     PL_bostr		= Nullch;
11379     PL_reg_flags	= 0;
11380     PL_reg_eval_set	= 0;
11381     PL_regnarrate	= 0;
11382     PL_regprogram	= (regnode*)NULL;
11383     PL_regindent	= 0;
11384     PL_regcc		= (CURCUR*)NULL;
11385     PL_reg_call_cc	= (struct re_cc_state*)NULL;
11386     PL_reg_re		= (regexp*)NULL;
11387     PL_reg_ganch	= Nullch;
11388     PL_reg_sv		= Nullsv;
11389     PL_reg_match_utf8	= FALSE;
11390     PL_reg_magic	= (MAGIC*)NULL;
11391     PL_reg_oldpos	= 0;
11392     PL_reg_oldcurpm	= (PMOP*)NULL;
11393     PL_reg_curpm	= (PMOP*)NULL;
11394     PL_reg_oldsaved	= Nullch;
11395     PL_reg_oldsavedlen	= 0;
11396     PL_reg_maxiter	= 0;
11397     PL_reg_leftiter	= 0;
11398     PL_reg_poscache	= Nullch;
11399     PL_reg_poscache_size= 0;
11400 
11401     /* RE engine - function pointers */
11402     PL_regcompp		= proto_perl->Tregcompp;
11403     PL_regexecp		= proto_perl->Tregexecp;
11404     PL_regint_start	= proto_perl->Tregint_start;
11405     PL_regint_string	= proto_perl->Tregint_string;
11406     PL_regfree		= proto_perl->Tregfree;
11407 
11408     PL_reginterp_cnt	= 0;
11409     PL_reg_starttry	= 0;
11410 
11411     /* Pluggable optimizer */
11412     PL_peepp		= proto_perl->Tpeepp;
11413 
11414     PL_stashcache       = newHV();
11415 
11416     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
11417         ptr_table_free(PL_ptr_table);
11418         PL_ptr_table = NULL;
11419     }
11420 
11421     /* Call the ->CLONE method, if it exists, for each of the stashes
11422        identified by sv_dup() above.
11423     */
11424     while(av_len(param->stashes) != -1) {
11425         HV* stash = (HV*) av_shift(param->stashes);
11426 	GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
11427 	if (cloner && GvCV(cloner)) {
11428 	    dSP;
11429 	    ENTER;
11430 	    SAVETMPS;
11431 	    PUSHMARK(SP);
11432            XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
11433 	    PUTBACK;
11434 	    call_sv((SV*)GvCV(cloner), G_DISCARD);
11435 	    FREETMPS;
11436 	    LEAVE;
11437 	}
11438     }
11439 
11440     SvREFCNT_dec(param->stashes);
11441 
11442     return my_perl;
11443 }
11444 
11445 #endif /* USE_ITHREADS */
11446 
11447 /*
11448 =head1 Unicode Support
11449 
11450 =for apidoc sv_recode_to_utf8
11451 
11452 The encoding is assumed to be an Encode object, on entry the PV
11453 of the sv is assumed to be octets in that encoding, and the sv
11454 will be converted into Unicode (and UTF-8).
11455 
11456 If the sv already is UTF-8 (or if it is not POK), or if the encoding
11457 is not a reference, nothing is done to the sv.  If the encoding is not
11458 an C<Encode::XS> Encoding object, bad things will happen.
11459 (See F<lib/encoding.pm> and L<Encode>).
11460 
11461 The PV of the sv is returned.
11462 
11463 =cut */
11464 
11465 char *
Perl_sv_recode_to_utf8(pTHX_ SV * sv,SV * encoding)11466 Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
11467 {
11468     if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
11469 	SV *uni;
11470 	STRLEN len;
11471 	char *s;
11472 	dSP;
11473 	ENTER;
11474 	SAVETMPS;
11475 	save_re_context();
11476 	PUSHMARK(sp);
11477 	EXTEND(SP, 3);
11478 	XPUSHs(encoding);
11479 	XPUSHs(sv);
11480 /*
11481   NI-S 2002/07/09
11482   Passing sv_yes is wrong - it needs to be or'ed set of constants
11483   for Encode::XS, while UTf-8 decode (currently) assumes a true value means
11484   remove converted chars from source.
11485 
11486   Both will default the value - let them.
11487 
11488 	XPUSHs(&PL_sv_yes);
11489 */
11490 	PUTBACK;
11491 	call_method("decode", G_SCALAR);
11492 	SPAGAIN;
11493 	uni = POPs;
11494 	PUTBACK;
11495 	s = SvPV(uni, len);
11496 	if (s != SvPVX(sv)) {
11497 	    SvGROW(sv, len + 1);
11498 	    Move(s, SvPVX(sv), len, char);
11499 	    SvCUR_set(sv, len);
11500 	    SvPVX(sv)[len] = 0;
11501 	}
11502 	FREETMPS;
11503 	LEAVE;
11504 	SvUTF8_on(sv);
11505     }
11506     return SvPVX(sv);
11507 }
11508 
11509 /*
11510 =for apidoc sv_cat_decode
11511 
11512 The encoding is assumed to be an Encode object, the PV of the ssv is
11513 assumed to be octets in that encoding and decoding the input starts
11514 from the position which (PV + *offset) pointed to.  The dsv will be
11515 concatenated the decoded UTF-8 string from ssv.  Decoding will terminate
11516 when the string tstr appears in decoding output or the input ends on
11517 the PV of the ssv. The value which the offset points will be modified
11518 to the last input position on the ssv.
11519 
11520 Returns TRUE if the terminator was found, else returns FALSE.
11521 
11522 =cut */
11523 
11524 bool
Perl_sv_cat_decode(pTHX_ SV * dsv,SV * encoding,SV * ssv,int * offset,char * tstr,int tlen)11525 Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
11526 		   SV *ssv, int *offset, char *tstr, int tlen)
11527 {
11528     bool ret = FALSE;
11529     if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
11530 	SV *offsv;
11531 	dSP;
11532 	ENTER;
11533 	SAVETMPS;
11534 	save_re_context();
11535 	PUSHMARK(sp);
11536 	EXTEND(SP, 6);
11537 	XPUSHs(encoding);
11538 	XPUSHs(dsv);
11539 	XPUSHs(ssv);
11540 	XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
11541 	XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
11542 	PUTBACK;
11543 	call_method("cat_decode", G_SCALAR);
11544 	SPAGAIN;
11545 	ret = SvTRUE(TOPs);
11546 	*offset = SvIV(offsv);
11547 	PUTBACK;
11548 	FREETMPS;
11549 	LEAVE;
11550     }
11551     else
11552         Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
11553     return ret;
11554 }
11555 
11556