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