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