1 /* scope.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 */
10
11 /*
12 * For the fashion of Minas Tirith was such that it was built on seven
13 * levels...
14 *
15 * [p.751 of _The Lord of the Rings_, V/i: "Minas Tirith"]
16 */
17
18 /* This file contains functions to manipulate several of Perl's stacks;
19 * in particular it contains code to push various types of things onto
20 * the savestack, then to pop them off and perform the correct restorative
21 * action for each one. This corresponds to the cleanup Perl does at
22 * each scope exit.
23 */
24
25 #include "EXTERN.h"
26 #define PERL_IN_SCOPE_C
27 #include "perl.h"
28 #include "feature.h"
29
30 SV**
Perl_stack_grow(pTHX_ SV ** sp,SV ** p,SSize_t n)31 Perl_stack_grow(pTHX_ SV **sp, SV **p, SSize_t n)
32 {
33 SSize_t extra;
34 SSize_t current = (p - PL_stack_base);
35
36 PERL_ARGS_ASSERT_STACK_GROW;
37
38 if (UNLIKELY(n < 0))
39 Perl_croak(aTHX_
40 "panic: stack_grow() negative count (%" IVdf ")", (IV)n);
41
42 PL_stack_sp = sp;
43 extra =
44 #ifdef STRESS_REALLOC
45 1;
46 #else
47 128;
48 #endif
49 /* If the total might wrap, panic instead. This is really testing
50 * that (current + n + extra < SSize_t_MAX), but done in a way that
51 * can't wrap */
52 if (UNLIKELY( current > SSize_t_MAX - extra
53 || current + extra > SSize_t_MAX - n
54 ))
55 /* diag_listed_as: Out of memory during %s extend */
56 Perl_croak(aTHX_ "Out of memory during stack extend");
57
58 av_extend(PL_curstack, current + n + extra);
59 #ifdef DEBUGGING
60 PL_curstackinfo->si_stack_hwm = current + n + extra;
61 #endif
62
63 return PL_stack_sp;
64 }
65
66 #ifdef STRESS_REALLOC
67 #define GROW(old) ((old) + 1)
68 #else
69 #define GROW(old) ((old) * 3 / 2)
70 #endif
71
72 PERL_SI *
Perl_new_stackinfo(pTHX_ I32 stitems,I32 cxitems)73 Perl_new_stackinfo(pTHX_ I32 stitems, I32 cxitems)
74 {
75 PERL_SI *si;
76 Newx(si, 1, PERL_SI);
77 si->si_stack = newAV();
78 AvREAL_off(si->si_stack);
79 av_extend(si->si_stack, stitems > 0 ? stitems-1 : 0);
80 AvALLOC(si->si_stack)[0] = &PL_sv_undef;
81 AvFILLp(si->si_stack) = 0;
82 si->si_prev = 0;
83 si->si_next = 0;
84 si->si_cxmax = cxitems - 1;
85 si->si_cxix = -1;
86 si->si_cxsubix = -1;
87 si->si_type = PERLSI_UNDEF;
88 Newx(si->si_cxstack, cxitems, PERL_CONTEXT);
89 /* Without any kind of initialising CX_PUSHSUBST()
90 * in pp_subst() will read uninitialised heap. */
91 PoisonNew(si->si_cxstack, cxitems, PERL_CONTEXT);
92 return si;
93 }
94
95 I32
Perl_cxinc(pTHX)96 Perl_cxinc(pTHX)
97 {
98 const IV old_max = cxstack_max;
99 const IV new_max = GROW(cxstack_max);
100 Renew(cxstack, new_max + 1, PERL_CONTEXT);
101 cxstack_max = new_max;
102 /* Without any kind of initialising deep enough recursion
103 * will end up reading uninitialised PERL_CONTEXTs. */
104 PoisonNew(cxstack + old_max + 1, new_max - old_max, PERL_CONTEXT);
105 return cxstack_ix + 1;
106 }
107
108 /*
109 =for apidoc_section $callback
110 =for apidoc push_scope
111
112 Implements L<perlapi/C<ENTER>>
113
114 =cut
115 */
116
117 void
Perl_push_scope(pTHX)118 Perl_push_scope(pTHX)
119 {
120 if (UNLIKELY(PL_scopestack_ix == PL_scopestack_max)) {
121 const IV new_max = GROW(PL_scopestack_max);
122 Renew(PL_scopestack, new_max, I32);
123 #ifdef DEBUGGING
124 Renew(PL_scopestack_name, new_max, const char*);
125 #endif
126 PL_scopestack_max = new_max;
127 }
128 #ifdef DEBUGGING
129 PL_scopestack_name[PL_scopestack_ix] = "unknown";
130 #endif
131 PL_scopestack[PL_scopestack_ix++] = PL_savestack_ix;
132
133 }
134
135 /*
136 =for apidoc_section $callback
137 =for apidoc pop_scope
138
139 Implements L<perlapi/C<LEAVE>>
140
141 =cut
142 */
143
144 void
Perl_pop_scope(pTHX)145 Perl_pop_scope(pTHX)
146 {
147 const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
148 LEAVE_SCOPE(oldsave);
149 }
150
151 I32 *
Perl_markstack_grow(pTHX)152 Perl_markstack_grow(pTHX)
153 {
154 const I32 oldmax = PL_markstack_max - PL_markstack;
155 const I32 newmax = GROW(oldmax);
156
157 Renew(PL_markstack, newmax, I32);
158 PL_markstack_max = PL_markstack + newmax;
159 PL_markstack_ptr = PL_markstack + oldmax;
160 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
161 "MARK grow %p %" IVdf " by %" IVdf "\n",
162 PL_markstack_ptr, (IV)*PL_markstack_ptr, (IV)oldmax)));
163 return PL_markstack_ptr;
164 }
165
166 void
Perl_savestack_grow(pTHX)167 Perl_savestack_grow(pTHX)
168 {
169 const I32 by = PL_savestack_max - PL_savestack_ix;
170 Perl_savestack_grow_cnt(aTHX_ by);
171 }
172
173 void
Perl_savestack_grow_cnt(pTHX_ I32 need)174 Perl_savestack_grow_cnt(pTHX_ I32 need)
175 {
176 /* NOTE: PL_savestack_max and PL_savestack_ix are I32.
177 *
178 * This makes sense when you consider that having I32_MAX items on
179 * the stack would be quite large.
180 *
181 * However, we use IV here so that we can detect if the new requested
182 * amount is larger than I32_MAX.
183 */
184 const IV new_floor = PL_savestack_max + need; /* what we need */
185 /* the GROW() macro normally does scales by 1.5 but under
186 * STRESS_REALLOC it simply adds 1 */
187 IV new_max = GROW(new_floor); /* and some extra */
188
189 /* the new_max < PL_savestack_max is for cases where IV is I32
190 * and we have rolled over from I32_MAX to a small value */
191 if (new_max > I32_MAX || new_max < PL_savestack_max) {
192 if (new_floor > I32_MAX || new_floor < PL_savestack_max) {
193 Perl_croak(aTHX_ "panic: savestack overflows I32_MAX");
194 }
195 new_max = new_floor;
196 }
197
198 /* Note that we add an additional SS_MAXPUSH slots on top of
199 * PL_savestack_max so that SS_ADD_END(), SSGROW() etc can do
200 * a simper check and if necessary realloc *after* apparently
201 * overwriting the current PL_savestack_max. See scope.h.
202 *
203 * The +1 is because new_max/PL_savestack_max is the highest
204 * index, by Renew needs the number of items, which is one
205 * larger than the highest index. */
206 Renew(PL_savestack, new_max + SS_MAXPUSH + 1, ANY);
207 PL_savestack_max = new_max;
208 }
209
210 #undef GROW
211
212 /* The original function was called Perl_tmps_grow and was removed from public
213 API, Perl_tmps_grow_p is the replacement and it used in public macros but
214 isn't public itself.
215
216 Perl_tmps_grow_p takes a proposed ix. A proposed ix is PL_tmps_ix + extend_by,
217 where the result of (PL_tmps_ix + extend_by) is >= PL_tmps_max
218 Upon return, PL_tmps_stack[ix] will be a valid address. For machine code
219 optimization and register usage reasons, the proposed ix passed into
220 tmps_grow is returned to the caller which the caller can then use to write
221 an SV * to PL_tmps_stack[ix]. If the caller was using tmps_grow in
222 pre-extend mode (EXTEND_MORTAL macro), then it ignores the return value of
223 tmps_grow. Note, tmps_grow DOES NOT write ix to PL_tmps_ix, the caller
224 must assign ix or ret val of tmps_grow to PL_temps_ix themselves if that is
225 appropriate. The assignment to PL_temps_ix can happen before or after
226 tmps_grow call since tmps_grow doesn't look at PL_tmps_ix.
227 */
228
229 SSize_t
Perl_tmps_grow_p(pTHX_ SSize_t ix)230 Perl_tmps_grow_p(pTHX_ SSize_t ix)
231 {
232 SSize_t extend_to = ix;
233 #ifndef STRESS_REALLOC
234 if (ix - PL_tmps_max < 128)
235 extend_to += (PL_tmps_max < 512) ? 128 : 512;
236 #endif
237 Renew(PL_tmps_stack, extend_to + 1, SV*);
238 PL_tmps_max = extend_to + 1;
239 return ix;
240 }
241
242
243 void
Perl_free_tmps(pTHX)244 Perl_free_tmps(pTHX)
245 {
246 /* XXX should tmps_floor live in cxstack? */
247 const SSize_t myfloor = PL_tmps_floor;
248 while (PL_tmps_ix > myfloor) { /* clean up after last statement */
249 SV* const sv = PL_tmps_stack[PL_tmps_ix--];
250 #ifdef PERL_POISON
251 PoisonWith(PL_tmps_stack + PL_tmps_ix + 1, 1, SV *, 0xAB);
252 #endif
253 if (LIKELY(sv)) {
254 SvTEMP_off(sv);
255 SvREFCNT_dec_NN(sv); /* note, can modify tmps_ix!!! */
256 }
257 }
258 }
259
260 /*
261 =for apidoc save_scalar_at
262
263 A helper function for localizing the SV referenced by C<*sptr>.
264
265 If C<SAVEf_KEEPOLDELEM> is set in in C<flags>, the function returns the input
266 scalar untouched.
267
268 Otherwise it replaces C<*sptr> with a new C<undef> scalar, and returns that.
269 The new scalar will have the old one's magic (if any) copied to it.
270 If there is such magic, and C<SAVEf_SETMAGIC> is set in in C<flags>, 'set'
271 magic will be processed on the new scalar. If unset, 'set' magic will be
272 skipped. The latter typically means that assignment will soon follow (I<e.g.>,
273 S<C<'local $x = $y'>>), and that will handle the magic.
274
275 =for apidoc Amnh ||SAVEf_KEEPOLDELEM
276 =for apidoc Amnh ||SAVEf_SETMAGIC
277
278 =cut
279 */
280
281 STATIC SV *
S_save_scalar_at(pTHX_ SV ** sptr,const U32 flags)282 S_save_scalar_at(pTHX_ SV **sptr, const U32 flags)
283 {
284 SV * osv;
285 SV *sv;
286
287 PERL_ARGS_ASSERT_SAVE_SCALAR_AT;
288
289 osv = *sptr;
290 if (flags & SAVEf_KEEPOLDELEM)
291 sv = osv;
292 else {
293 sv = (*sptr = newSV_type(SVt_NULL));
294 if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv))
295 mg_localize(osv, sv, cBOOL(flags & SAVEf_SETMAGIC));
296 }
297
298 return sv;
299 }
300
301 void
Perl_save_pushptrptr(pTHX_ void * const ptr1,void * const ptr2,const int type)302 Perl_save_pushptrptr(pTHX_ void *const ptr1, void *const ptr2, const int type)
303 {
304 dSS_ADD;
305 SS_ADD_PTR(ptr1);
306 SS_ADD_PTR(ptr2);
307 SS_ADD_UV(type);
308 SS_ADD_END(3);
309 }
310
311 SV *
Perl_save_scalar(pTHX_ GV * gv)312 Perl_save_scalar(pTHX_ GV *gv)
313 {
314 SV ** const sptr = &GvSVn(gv);
315
316 PERL_ARGS_ASSERT_SAVE_SCALAR;
317
318 if (UNLIKELY(SvGMAGICAL(*sptr))) {
319 PL_localizing = 1;
320 (void)mg_get(*sptr);
321 PL_localizing = 0;
322 }
323 save_pushptrptr(SvREFCNT_inc_simple(gv), SvREFCNT_inc(*sptr), SAVEt_SV);
324 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
325 }
326
327 /*
328 =for apidoc save_generic_svref
329
330 Implements C<SAVEGENERICSV>.
331
332 Like save_sptr(), but also SvREFCNT_dec()s the new value. Can be used to
333 restore a global SV to its prior contents, freeing new value.
334
335 =cut
336 */
337
338 void
Perl_save_generic_svref(pTHX_ SV ** sptr)339 Perl_save_generic_svref(pTHX_ SV **sptr)
340 {
341 PERL_ARGS_ASSERT_SAVE_GENERIC_SVREF;
342
343 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_GENERIC_SVREF);
344 }
345
346
347 /*
348 =for apidoc save_rcpv
349
350 Implements C<SAVERCPV>.
351
352 Saves and restores a refcounted string, similar to what
353 save_generic_svref would do for a SV*. Can be used to restore
354 a refcounted string to its previous state. Performs the
355 appropriate refcount counting so that nothing should leak
356 or be prematurely freed.
357
358 =cut
359 */
360 void
Perl_save_rcpv(pTHX_ char ** prcpv)361 Perl_save_rcpv(pTHX_ char **prcpv) {
362 PERL_ARGS_ASSERT_SAVE_RCPV;
363 save_pushptrptr(prcpv, rcpv_copy(*prcpv), SAVEt_RCPV);
364 }
365
366 /*
367 =for apidoc save_freercpv
368
369 Implements C<SAVEFREERCPV>.
370
371 Saves and frees a refcounted string. Calls rcpv_free()
372 on the argument when the current pseudo block is finished.
373
374 =cut
375 */
376 void
Perl_save_freercpv(pTHX_ char * rcpv)377 Perl_save_freercpv(pTHX_ char *rcpv) {
378 PERL_ARGS_ASSERT_SAVE_FREERCPV;
379 save_pushptr(rcpv, SAVEt_FREERCPV);
380 }
381
382
383 /*
384 =for apidoc_section $callback
385 =for apidoc save_generic_pvref
386
387 Implements C<SAVEGENERICPV>.
388
389 Like save_pptr(), but also Safefree()s the new value if it is different
390 from the old one. Can be used to restore a global char* to its prior
391 contents, freeing new value.
392
393 =cut
394 */
395
396 void
Perl_save_generic_pvref(pTHX_ char ** str)397 Perl_save_generic_pvref(pTHX_ char **str)
398 {
399 PERL_ARGS_ASSERT_SAVE_GENERIC_PVREF;
400
401 save_pushptrptr(*str, str, SAVEt_GENERIC_PVREF);
402 }
403
404 /*
405 =for apidoc_section $callback
406 =for apidoc save_shared_pvref
407
408 Implements C<SAVESHAREDPV>.
409
410 Like save_generic_pvref(), but uses PerlMemShared_free() rather than Safefree().
411 Can be used to restore a shared global char* to its prior
412 contents, freeing new value.
413
414 =cut
415 */
416
417 void
Perl_save_shared_pvref(pTHX_ char ** str)418 Perl_save_shared_pvref(pTHX_ char **str)
419 {
420 PERL_ARGS_ASSERT_SAVE_SHARED_PVREF;
421
422 save_pushptrptr(str, *str, SAVEt_SHARED_PVREF);
423 }
424
425
426 /*
427 =for apidoc_section $callback
428 =for apidoc save_set_svflags
429
430 Implements C<SAVESETSVFLAGS>.
431
432 Set the SvFLAGS specified by mask to the values in val
433
434 =cut
435 */
436
437 void
Perl_save_set_svflags(pTHX_ SV * sv,U32 mask,U32 val)438 Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
439 {
440 dSS_ADD;
441
442 PERL_ARGS_ASSERT_SAVE_SET_SVFLAGS;
443
444 SS_ADD_PTR(sv);
445 SS_ADD_INT(mask);
446 SS_ADD_INT(val);
447 SS_ADD_UV(SAVEt_SET_SVFLAGS);
448 SS_ADD_END(4);
449 }
450
451 /*
452
453 =for apidoc_section $GV
454
455 =for apidoc save_gp
456
457 Saves the current GP of gv on the save stack to be restored on scope exit.
458
459 If C<empty> is true, replace the GP with a new GP.
460
461 If C<empty> is false, mark C<gv> with C<GVf_INTRO> so the next reference
462 assigned is localized, which is how S<C< local *foo = $someref; >> works.
463
464 =cut
465 */
466
467 void
Perl_save_gp(pTHX_ GV * gv,I32 empty)468 Perl_save_gp(pTHX_ GV *gv, I32 empty)
469 {
470 PERL_ARGS_ASSERT_SAVE_GP;
471
472 /* XXX For now, we just upgrade any coderef in the stash to a full GV
473 during localisation. Maybe at some point we could make localis-
474 ation work without needing the upgrade. (In which case our
475 callers should probably call a different function, not save_gp.)
476 */
477 if (!isGV(gv)) {
478 assert(isGV_or_RVCV(gv));
479 (void)CvGV(SvRV((SV *)gv)); /* CvGV does the upgrade */
480 assert(isGV(gv));
481 }
482
483 save_pushptrptr(SvREFCNT_inc(gv), GvGP(gv), SAVEt_GP);
484
485 if (empty) {
486 GP *gp = Perl_newGP(aTHX_ gv);
487 HV * const stash = GvSTASH(gv);
488 bool isa_changed = 0;
489
490 if (stash && HvHasENAME(stash)) {
491 if (memEQs(GvNAME(gv), GvNAMELEN(gv), "ISA"))
492 isa_changed = TRUE;
493 else if (GvCVu(gv))
494 /* taking a method out of circulation ("local")*/
495 mro_method_changed_in(stash);
496 }
497 if (GvIOp(gv) && (IoFLAGS(GvIOp(gv)) & IOf_ARGV)) {
498 gp->gp_io = newIO();
499 IoFLAGS(gp->gp_io) |= IOf_ARGV|IOf_START;
500 }
501 GvGP_set(gv,gp);
502 if (isa_changed) mro_isa_changed_in(stash);
503 }
504 else {
505 gp_ref(GvGP(gv));
506 GvINTRO_on(gv);
507 }
508 }
509
510 AV *
Perl_save_ary(pTHX_ GV * gv)511 Perl_save_ary(pTHX_ GV *gv)
512 {
513 AV * const oav = GvAVn(gv);
514 AV *av;
515
516 PERL_ARGS_ASSERT_SAVE_ARY;
517
518 if (UNLIKELY(!AvREAL(oav) && AvREIFY(oav)))
519 av_reify(oav);
520 save_pushptrptr(SvREFCNT_inc_simple_NN(gv), oav, SAVEt_AV);
521
522 GvAV(gv) = NULL;
523 av = GvAVn(gv);
524 if (UNLIKELY(SvMAGIC(oav)))
525 mg_localize(MUTABLE_SV(oav), MUTABLE_SV(av), TRUE);
526 return av;
527 }
528
529 HV *
Perl_save_hash(pTHX_ GV * gv)530 Perl_save_hash(pTHX_ GV *gv)
531 {
532 HV *ohv, *hv;
533
534 PERL_ARGS_ASSERT_SAVE_HASH;
535
536 save_pushptrptr(
537 SvREFCNT_inc_simple_NN(gv), (ohv = GvHVn(gv)), SAVEt_HV
538 );
539
540 GvHV(gv) = NULL;
541 hv = GvHVn(gv);
542 if (UNLIKELY(SvMAGIC(ohv)))
543 mg_localize(MUTABLE_SV(ohv), MUTABLE_SV(hv), TRUE);
544 return hv;
545 }
546
547 void
Perl_save_item(pTHX_ SV * item)548 Perl_save_item(pTHX_ SV *item)
549 {
550 SV * const sv = newSVsv(item);
551
552 PERL_ARGS_ASSERT_SAVE_ITEM;
553
554 save_pushptrptr(item, /* remember the pointer */
555 sv, /* remember the value */
556 SAVEt_ITEM);
557 }
558
559 void
Perl_save_bool(pTHX_ bool * boolp)560 Perl_save_bool(pTHX_ bool *boolp)
561 {
562 dSS_ADD;
563
564 PERL_ARGS_ASSERT_SAVE_BOOL;
565
566 SS_ADD_PTR(boolp);
567 SS_ADD_UV(SAVEt_BOOL | (*boolp << 8));
568 SS_ADD_END(2);
569 }
570
571 void
Perl_save_pushi32ptr(pTHX_ const I32 i,void * const ptr,const int type)572 Perl_save_pushi32ptr(pTHX_ const I32 i, void *const ptr, const int type)
573 {
574 dSS_ADD;
575
576 SS_ADD_INT(i);
577 SS_ADD_PTR(ptr);
578 SS_ADD_UV(type);
579 SS_ADD_END(3);
580 }
581
582 void
Perl_save_int(pTHX_ int * intp)583 Perl_save_int(pTHX_ int *intp)
584 {
585 const int i = *intp;
586 UV type = ((UV)((UV)i << SAVE_TIGHT_SHIFT) | SAVEt_INT_SMALL);
587 int size = 2;
588 dSS_ADD;
589
590 PERL_ARGS_ASSERT_SAVE_INT;
591
592 if (UNLIKELY((int)(type >> SAVE_TIGHT_SHIFT) != i)) {
593 SS_ADD_INT(i);
594 type = SAVEt_INT;
595 size++;
596 }
597 SS_ADD_PTR(intp);
598 SS_ADD_UV(type);
599 SS_ADD_END(size);
600 }
601
602 void
Perl_save_I8(pTHX_ I8 * bytep)603 Perl_save_I8(pTHX_ I8 *bytep)
604 {
605 dSS_ADD;
606
607 PERL_ARGS_ASSERT_SAVE_I8;
608
609 SS_ADD_PTR(bytep);
610 SS_ADD_UV(SAVEt_I8 | ((UV)*bytep << 8));
611 SS_ADD_END(2);
612 }
613
614 void
Perl_save_I16(pTHX_ I16 * intp)615 Perl_save_I16(pTHX_ I16 *intp)
616 {
617 dSS_ADD;
618
619 PERL_ARGS_ASSERT_SAVE_I16;
620
621 SS_ADD_PTR(intp);
622 SS_ADD_UV(SAVEt_I16 | ((UV)*intp << 8));
623 SS_ADD_END(2);
624 }
625
626 void
Perl_save_I32(pTHX_ I32 * intp)627 Perl_save_I32(pTHX_ I32 *intp)
628 {
629 const I32 i = *intp;
630 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_I32_SMALL);
631 int size = 2;
632 dSS_ADD;
633
634 PERL_ARGS_ASSERT_SAVE_I32;
635
636 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
637 SS_ADD_INT(i);
638 type = SAVEt_I32;
639 size++;
640 }
641 SS_ADD_PTR(intp);
642 SS_ADD_UV(type);
643 SS_ADD_END(size);
644 }
645
646 void
Perl_save_strlen(pTHX_ STRLEN * ptr)647 Perl_save_strlen(pTHX_ STRLEN *ptr)
648 {
649 const IV i = *ptr;
650 UV type = ((I32)((U32)i << SAVE_TIGHT_SHIFT) | SAVEt_STRLEN_SMALL);
651 int size = 2;
652 dSS_ADD;
653
654 PERL_ARGS_ASSERT_SAVE_STRLEN;
655
656 if (UNLIKELY((I32)(type >> SAVE_TIGHT_SHIFT) != i)) {
657 SS_ADD_IV(*ptr);
658 type = SAVEt_STRLEN;
659 size++;
660 }
661
662 SS_ADD_PTR(ptr);
663 SS_ADD_UV(type);
664 SS_ADD_END(size);
665 }
666
667 void
Perl_save_iv(pTHX_ IV * ivp)668 Perl_save_iv(pTHX_ IV *ivp)
669 {
670 PERL_ARGS_ASSERT_SAVE_IV;
671
672 SSGROW(3);
673 SSPUSHIV(*ivp);
674 SSPUSHPTR(ivp);
675 SSPUSHUV(SAVEt_IV);
676 }
677
678 /* Cannot use save_sptr() to store a char* since the SV** cast will
679 * force word-alignment and we'll miss the pointer.
680 */
681 void
Perl_save_pptr(pTHX_ char ** pptr)682 Perl_save_pptr(pTHX_ char **pptr)
683 {
684 PERL_ARGS_ASSERT_SAVE_PPTR;
685
686 save_pushptrptr(*pptr, pptr, SAVEt_PPTR);
687 }
688
689 /*
690 =for apidoc_section $callback
691 =for apidoc save_vptr
692
693 Implements C<SAVEVPTR>.
694
695 =cut
696 */
697
698 void
Perl_save_vptr(pTHX_ void * ptr)699 Perl_save_vptr(pTHX_ void *ptr)
700 {
701 PERL_ARGS_ASSERT_SAVE_VPTR;
702
703 save_pushptrptr(*(char**)ptr, ptr, SAVEt_VPTR);
704 }
705
706 void
Perl_save_sptr(pTHX_ SV ** sptr)707 Perl_save_sptr(pTHX_ SV **sptr)
708 {
709 PERL_ARGS_ASSERT_SAVE_SPTR;
710
711 save_pushptrptr(*sptr, sptr, SAVEt_SPTR);
712 }
713
714 /*
715 =for apidoc_section $callback
716 =for apidoc save_padsv_and_mortalize
717
718 Implements C<SAVEPADSVANDMORTALIZE>.
719
720 =cut
721 */
722
723 void
Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)724 Perl_save_padsv_and_mortalize(pTHX_ PADOFFSET off)
725 {
726 dSS_ADD;
727
728 ASSERT_CURPAD_ACTIVE("save_padsv");
729 SS_ADD_PTR(SvREFCNT_inc_simple_NN(PL_curpad[off]));
730 SS_ADD_PTR(PL_comppad);
731 SS_ADD_UV((UV)off);
732 SS_ADD_UV(SAVEt_PADSV_AND_MORTALIZE);
733 SS_ADD_END(4);
734 }
735
736 void
Perl_save_hptr(pTHX_ HV ** hptr)737 Perl_save_hptr(pTHX_ HV **hptr)
738 {
739 PERL_ARGS_ASSERT_SAVE_HPTR;
740
741 save_pushptrptr(*hptr, hptr, SAVEt_HPTR);
742 }
743
744 void
Perl_save_aptr(pTHX_ AV ** aptr)745 Perl_save_aptr(pTHX_ AV **aptr)
746 {
747 PERL_ARGS_ASSERT_SAVE_APTR;
748
749 save_pushptrptr(*aptr, aptr, SAVEt_APTR);
750 }
751
752 /*
753 =for apidoc_section $callback
754 =for apidoc save_pushptr
755
756 The refcnt of object C<ptr> will be decremented at the end of the current
757 I<pseudo-block>. C<type> gives the type of C<ptr>, expressed as one of the
758 constants in F<scope.h> whose name begins with C<SAVEt_>.
759
760 This is the underlying implementation of several macros, like
761 C<SAVEFREESV>.
762
763 =cut
764 */
765
766 void
Perl_save_pushptr(pTHX_ void * const ptr,const int type)767 Perl_save_pushptr(pTHX_ void *const ptr, const int type)
768 {
769 dSS_ADD;
770 SS_ADD_PTR(ptr);
771 SS_ADD_UV(type);
772 SS_ADD_END(2);
773 }
774
775 void
Perl_save_clearsv(pTHX_ SV ** svp)776 Perl_save_clearsv(pTHX_ SV **svp)
777 {
778 const UV offset = svp - PL_curpad;
779 const UV offset_shifted = offset << SAVE_TIGHT_SHIFT;
780
781 PERL_ARGS_ASSERT_SAVE_CLEARSV;
782
783 ASSERT_CURPAD_ACTIVE("save_clearsv");
784 assert(*svp);
785 SvPADSTALE_off(*svp); /* mark lexical as active */
786 if (UNLIKELY((offset_shifted >> SAVE_TIGHT_SHIFT) != offset)) {
787 Perl_croak(aTHX_ "panic: pad offset %" UVuf " out of range (%p-%p)",
788 offset, svp, PL_curpad);
789 }
790
791 {
792 dSS_ADD;
793 SS_ADD_UV(offset_shifted | SAVEt_CLEARSV);
794 SS_ADD_END(1);
795 }
796 }
797
798 void
Perl_save_delete(pTHX_ HV * hv,char * key,I32 klen)799 Perl_save_delete(pTHX_ HV *hv, char *key, I32 klen)
800 {
801 PERL_ARGS_ASSERT_SAVE_DELETE;
802
803 save_pushptri32ptr(key, klen, SvREFCNT_inc_simple(hv), SAVEt_DELETE);
804 }
805
806 /*
807 =for apidoc_section $callback
808 =for apidoc save_hdelete
809
810 Implements C<SAVEHDELETE>.
811
812 =cut
813 */
814
815 void
Perl_save_hdelete(pTHX_ HV * hv,SV * keysv)816 Perl_save_hdelete(pTHX_ HV *hv, SV *keysv)
817 {
818 STRLEN len;
819 I32 klen;
820 const char *key;
821
822 PERL_ARGS_ASSERT_SAVE_HDELETE;
823
824 key = SvPV_const(keysv, len);
825 klen = SvUTF8(keysv) ? -(I32)len : (I32)len;
826 SvREFCNT_inc_simple_void_NN(hv);
827 save_pushptri32ptr(savepvn(key, len), klen, hv, SAVEt_DELETE);
828 }
829
830 /*
831 =for apidoc_section $callback
832 =for apidoc save_adelete
833
834 Implements C<SAVEADELETE>.
835
836 =cut
837 */
838
839 void
Perl_save_adelete(pTHX_ AV * av,SSize_t key)840 Perl_save_adelete(pTHX_ AV *av, SSize_t key)
841 {
842 dSS_ADD;
843
844 PERL_ARGS_ASSERT_SAVE_ADELETE;
845
846 SvREFCNT_inc_void(av);
847 SS_ADD_UV(key);
848 SS_ADD_PTR(av);
849 SS_ADD_IV(SAVEt_ADELETE);
850 SS_ADD_END(3);
851 }
852
853 void
Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f,void * p)854 Perl_save_destructor(pTHX_ DESTRUCTORFUNC_NOCONTEXT_t f, void* p)
855 {
856 dSS_ADD;
857 PERL_ARGS_ASSERT_SAVE_DESTRUCTOR;
858
859 SS_ADD_DPTR(f);
860 SS_ADD_PTR(p);
861 SS_ADD_UV(SAVEt_DESTRUCTOR);
862 SS_ADD_END(3);
863 }
864
865 void
Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f,void * p)866 Perl_save_destructor_x(pTHX_ DESTRUCTORFUNC_t f, void* p)
867 {
868 dSS_ADD;
869
870 SS_ADD_DXPTR(f);
871 SS_ADD_PTR(p);
872 SS_ADD_UV(SAVEt_DESTRUCTOR_X);
873 SS_ADD_END(3);
874 }
875
876 /*
877 =for apidoc_section $callback
878 =for apidoc save_hints
879
880 Implements C<SAVEHINTS>.
881
882 =cut
883 */
884
885 void
Perl_save_hints(pTHX)886 Perl_save_hints(pTHX)
887 {
888 COPHH *save_cophh = cophh_copy(CopHINTHASH_get(&PL_compiling));
889 if (PL_hints & HINT_LOCALIZE_HH) {
890 HV *oldhh = GvHV(PL_hintgv);
891 {
892 dSS_ADD;
893 SS_ADD_INT(PL_hints);
894 SS_ADD_PTR(save_cophh);
895 SS_ADD_PTR(oldhh);
896 SS_ADD_UV(SAVEt_HINTS_HH | (PL_prevailing_version << 8));
897 SS_ADD_END(4);
898 }
899 GvHV(PL_hintgv) = NULL; /* in case copying dies */
900 GvHV(PL_hintgv) = hv_copy_hints_hv(oldhh);
901 SAVEFEATUREBITS();
902 } else {
903 save_pushi32ptr(PL_hints, save_cophh, SAVEt_HINTS | (PL_prevailing_version << 8));
904 }
905 }
906
907 static void
S_save_pushptri32ptr(pTHX_ void * const ptr1,const I32 i,void * const ptr2,const int type)908 S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
909 const int type)
910 {
911 dSS_ADD;
912 SS_ADD_PTR(ptr1);
913 SS_ADD_INT(i);
914 SS_ADD_PTR(ptr2);
915 SS_ADD_UV(type);
916 SS_ADD_END(4);
917 }
918
919 /*
920 =for apidoc_section $callback
921 =for apidoc save_aelem
922 =for apidoc_item save_aelem_flags
923
924 These each arrange for the value of the array element C<av[idx]> to be restored
925 at the end of the enclosing I<pseudo-block>.
926
927 In C<save_aelem>, the SV at C**sptr> will be replaced by a new C<undef>
928 scalar. That scalar will inherit any magic from the original C<**sptr>,
929 and any 'set' magic will be processed.
930
931 In C<save_aelem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes
932 the function to forgo all that: the scalar at C<**sptr> is untouched.
933 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a
934 new C<undef> scalar. That scalar will inherit any magic from the original
935 C<**sptr>. Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC>
936 is set in in C<flags>.
937
938 =cut
939 */
940
941 void
Perl_save_aelem_flags(pTHX_ AV * av,SSize_t idx,SV ** sptr,const U32 flags)942 Perl_save_aelem_flags(pTHX_ AV *av, SSize_t idx, SV **sptr,
943 const U32 flags)
944 {
945 dSS_ADD;
946 SV *sv;
947
948 PERL_ARGS_ASSERT_SAVE_AELEM_FLAGS;
949
950 SvGETMAGIC(*sptr);
951 SS_ADD_PTR(SvREFCNT_inc_simple(av));
952 SS_ADD_IV(idx);
953 SS_ADD_PTR(SvREFCNT_inc(*sptr));
954 SS_ADD_UV(SAVEt_AELEM);
955 SS_ADD_END(4);
956 /* The array needs to hold a reference count on its new element, so it
957 must be AvREAL. */
958 if (UNLIKELY(!AvREAL(av) && AvREIFY(av)))
959 av_reify(av);
960 save_scalar_at(sptr, flags); /* XXX - FIXME - see #60360 */
961 if (flags & SAVEf_KEEPOLDELEM)
962 return;
963 sv = *sptr;
964 /* If we're localizing a tied array element, this new sv
965 * won't actually be stored in the array - so it won't get
966 * reaped when the localize ends. Ensure it gets reaped by
967 * mortifying it instead. DAPM */
968 if (UNLIKELY(SvTIED_mg((const SV *)av, PERL_MAGIC_tied)))
969 sv_2mortal(sv);
970 }
971
972 /*
973 =for apidoc_section $callback
974 =for apidoc save_helem
975 =for apidoc_item save_helem_flags
976
977 These each arrange for the value of the hash element (in Perlish terms)
978 C<$hv{key}]> to be restored at the end of the enclosing I<pseudo-block>.
979
980 In C<save_helem>, the SV at C**sptr> will be replaced by a new C<undef>
981 scalar. That scalar will inherit any magic from the original C<**sptr>,
982 and any 'set' magic will be processed.
983
984 In C<save_helem_flags>, C<SAVEf_KEEPOLDELEM> being set in C<flags> causes
985 the function to forgo all that: the scalar at C<**sptr> is untouched.
986 If C<SAVEf_KEEPOLDELEM> is not set, the SV at C**sptr> will be replaced by a
987 new C<undef> scalar. That scalar will inherit any magic from the original
988 C<**sptr>. Any 'set' magic will be processed if and only if C<SAVEf_SETMAGIC>
989 is set in in C<flags>.
990
991 =cut
992 */
993
994 void
Perl_save_helem_flags(pTHX_ HV * hv,SV * key,SV ** sptr,const U32 flags)995 Perl_save_helem_flags(pTHX_ HV *hv, SV *key, SV **sptr, const U32 flags)
996 {
997 SV *sv;
998
999 PERL_ARGS_ASSERT_SAVE_HELEM_FLAGS;
1000
1001 SvGETMAGIC(*sptr);
1002 {
1003 dSS_ADD;
1004 SS_ADD_PTR(SvREFCNT_inc_simple(hv));
1005 SS_ADD_PTR(newSVsv(key));
1006 SS_ADD_PTR(SvREFCNT_inc(*sptr));
1007 SS_ADD_UV(SAVEt_HELEM);
1008 SS_ADD_END(4);
1009 }
1010 save_scalar_at(sptr, flags);
1011 if (flags & SAVEf_KEEPOLDELEM)
1012 return;
1013 sv = *sptr;
1014 /* If we're localizing a tied hash element, this new sv
1015 * won't actually be stored in the hash - so it won't get
1016 * reaped when the localize ends. Ensure it gets reaped by
1017 * mortifying it instead. DAPM */
1018 if (UNLIKELY(SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)))
1019 sv_2mortal(sv);
1020 }
1021
1022 SV*
Perl_save_svref(pTHX_ SV ** sptr)1023 Perl_save_svref(pTHX_ SV **sptr)
1024 {
1025 PERL_ARGS_ASSERT_SAVE_SVREF;
1026
1027 SvGETMAGIC(*sptr);
1028 save_pushptrptr(sptr, SvREFCNT_inc(*sptr), SAVEt_SVREF);
1029 return save_scalar_at(sptr, SAVEf_SETMAGIC); /* XXX - FIXME - see #60360 */
1030 }
1031
1032
1033 void
Perl_savetmps(pTHX)1034 Perl_savetmps(pTHX)
1035 {
1036 dSS_ADD;
1037 SS_ADD_IV(PL_tmps_floor);
1038 PL_tmps_floor = PL_tmps_ix;
1039 SS_ADD_UV(SAVEt_TMPSFLOOR);
1040 SS_ADD_END(2);
1041 }
1042
1043 /*
1044 =for apidoc_section $stack
1045 =for apidoc save_alloc
1046
1047 Implements L<perlapi/C<SSNEW>> and kin, which should be used instead of this
1048 function.
1049
1050 =cut
1051 */
1052
1053 SSize_t
Perl_save_alloc(pTHX_ SSize_t size,I32 pad)1054 Perl_save_alloc(pTHX_ SSize_t size, I32 pad)
1055 {
1056 const SSize_t start = pad + ((char*)&PL_savestack[PL_savestack_ix]
1057 - (char*)PL_savestack);
1058 const UV elems = 1 + ((size + pad - 1) / sizeof(*PL_savestack));
1059 const UV elems_shifted = elems << SAVE_TIGHT_SHIFT;
1060
1061 if (UNLIKELY((elems_shifted >> SAVE_TIGHT_SHIFT) != elems))
1062 Perl_croak(aTHX_
1063 "panic: save_alloc elems %" UVuf " out of range (%" IVdf "-%" IVdf ")",
1064 elems, (IV)size, (IV)pad);
1065
1066 SSGROW(elems + 1);
1067
1068 PL_savestack_ix += elems;
1069 SSPUSHUV(SAVEt_ALLOC | elems_shifted);
1070 return start;
1071 }
1072
1073
1074
1075 /*
1076 =for apidoc_section $callback
1077 =for apidoc leave_scope
1078
1079 Implements C<LEAVE_SCOPE> which you should use instead.
1080
1081 =cut
1082 */
1083
1084 void
Perl_leave_scope(pTHX_ I32 base)1085 Perl_leave_scope(pTHX_ I32 base)
1086 {
1087 /* Localise the effects of the TAINT_NOT inside the loop. */
1088 bool was = TAINT_get;
1089
1090 if (UNLIKELY(base < -1))
1091 Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base);
1092 DEBUG_l(Perl_deb(aTHX_ "savestack: releasing items %ld -> %ld\n",
1093 (long)PL_savestack_ix, (long)base));
1094 while (PL_savestack_ix > base) {
1095 UV uv;
1096 U8 type;
1097 ANY *ap; /* arg pointer */
1098 ANY a0, a1, a2; /* up to 3 args */
1099
1100 TAINT_NOT;
1101
1102 {
1103 U8 argcount;
1104 I32 ix = PL_savestack_ix - 1;
1105
1106 ap = &PL_savestack[ix];
1107 uv = ap->any_uv;
1108 type = (U8)uv & SAVE_MASK;
1109 argcount = leave_scope_arg_counts[type];
1110 PL_savestack_ix = ix - argcount;
1111 ap -= argcount;
1112 }
1113
1114 switch (type) {
1115 case SAVEt_ITEM: /* normal string */
1116 a0 = ap[0]; a1 = ap[1];
1117 sv_replace(a0.any_sv, a1.any_sv);
1118 if (UNLIKELY(SvSMAGICAL(a0.any_sv))) {
1119 PL_localizing = 2;
1120 mg_set(a0.any_sv);
1121 PL_localizing = 0;
1122 }
1123 break;
1124
1125 /* This would be a mathom, but Perl_save_svref() calls a static
1126 function, S_save_scalar_at(), so has to stay in this file. */
1127 case SAVEt_SVREF: /* scalar reference */
1128 a0 = ap[0]; a1 = ap[1];
1129 a2.any_svp = a0.any_svp;
1130 a0.any_sv = NULL; /* what to refcnt_dec */
1131 goto restore_sv;
1132
1133 case SAVEt_SV: /* scalar reference */
1134 a0 = ap[0]; a1 = ap[1];
1135 a2.any_svp = &GvSV(a0.any_gv);
1136 restore_sv:
1137 {
1138 /* do *a2.any_svp = a1 and free a0 */
1139 SV * const sv = *a2.any_svp;
1140 *a2.any_svp = a1.any_sv;
1141 SvREFCNT_dec(sv);
1142 if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1143 /* mg_set could die, skipping the freeing of a0 and
1144 * a1; Ensure that they're always freed in that case */
1145 dSS_ADD;
1146 SS_ADD_PTR(a1.any_sv);
1147 SS_ADD_UV(SAVEt_FREESV);
1148 SS_ADD_PTR(a0.any_sv);
1149 SS_ADD_UV(SAVEt_FREESV);
1150 SS_ADD_END(4);
1151 PL_localizing = 2;
1152 mg_set(a1.any_sv);
1153 PL_localizing = 0;
1154 break;
1155 }
1156 SvREFCNT_dec_NN(a1.any_sv);
1157 SvREFCNT_dec(a0.any_sv);
1158 break;
1159 }
1160
1161 case SAVEt_GENERIC_PVREF: /* generic pv */
1162 a0 = ap[0]; a1 = ap[1];
1163 if (*a1.any_pvp != a0.any_pv) {
1164 Safefree(*a1.any_pvp);
1165 *a1.any_pvp = a0.any_pv;
1166 }
1167 break;
1168
1169 case SAVEt_SHARED_PVREF: /* shared pv */
1170 a0 = ap[0]; a1 = ap[1];
1171 if (*a0.any_pvp != a1.any_pv) {
1172 PerlMemShared_free(*a0.any_pvp);
1173 *a0.any_pvp = a1.any_pv;
1174 }
1175 break;
1176
1177 case SAVEt_GVSV: /* scalar slot in GV */
1178 a0 = ap[0]; a1 = ap[1];
1179 a0.any_svp = &GvSV(a0.any_gv);
1180 goto restore_svp;
1181
1182
1183 case SAVEt_GENERIC_SVREF: /* generic sv */
1184 a0 = ap[0]; a1 = ap[1];
1185 restore_svp:
1186 {
1187 /* do *a0.any_svp = a1 */
1188 SV * const sv = *a0.any_svp;
1189 *a0.any_svp = a1.any_sv;
1190 SvREFCNT_dec(sv);
1191 SvREFCNT_dec(a1.any_sv);
1192 break;
1193 }
1194
1195 case SAVEt_RCPV: /* like generic sv, but for struct rcpv */
1196 {
1197 a0 = ap[0]; a1 = ap[1];
1198 char *old = *a0.any_pvp;
1199 *a0.any_pvp = a1.any_pv;
1200 (void)rcpv_free(old);
1201 (void)rcpv_free(a1.any_pv);
1202 break;
1203 }
1204
1205 case SAVEt_FREERCPV: /* like SAVEt_FREEPV but for a RCPV */
1206 {
1207 a0 = ap[0];
1208 char *rcpv = a0.any_pv;
1209 (void)rcpv_free(rcpv);
1210 break;
1211 }
1212
1213 case SAVEt_GVSLOT: /* any slot in GV */
1214 {
1215 HV * hv;
1216 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1217 hv = GvSTASH(a0.any_gv);
1218 if (hv && HvHasENAME(hv) && (
1219 (a2.any_sv && SvTYPE(a2.any_sv) == SVt_PVCV)
1220 || (*a1.any_svp && SvTYPE(*a1.any_svp) == SVt_PVCV)
1221 ))
1222 {
1223 if ((char *)a1.any_svp < (char *)GvGP(a0.any_gv)
1224 || (char *)a1.any_svp > (char *)GvGP(a0.any_gv) + sizeof(struct gp)
1225 || GvREFCNT(a0.any_gv) > 2) /* "> 2" to ignore savestack's ref */
1226 PL_sub_generation++;
1227 else mro_method_changed_in(hv);
1228 }
1229 a0.any_svp = a1.any_svp;
1230 a1.any_sv = a2.any_sv;
1231 goto restore_svp;
1232 }
1233
1234 case SAVEt_AV: /* array reference */
1235 a0 = ap[0]; a1 = ap[1];
1236 SvREFCNT_dec(GvAV(a0.any_gv));
1237 GvAV(a0.any_gv) = a1.any_av;
1238 avhv_common:
1239 if (UNLIKELY(SvSMAGICAL(a1.any_sv))) {
1240 /* mg_set might die, so make sure a0 isn't leaked */
1241 dSS_ADD;
1242 SS_ADD_PTR(a0.any_sv);
1243 SS_ADD_UV(SAVEt_FREESV);
1244 SS_ADD_END(2);
1245 PL_localizing = 2;
1246 mg_set(a1.any_sv);
1247 PL_localizing = 0;
1248 break;
1249 }
1250 SvREFCNT_dec_NN(a0.any_sv);
1251 break;
1252
1253 case SAVEt_HV: /* hash reference */
1254 a0 = ap[0]; a1 = ap[1];
1255 SvREFCNT_dec(GvHV(a0.any_gv));
1256 GvHV(a0.any_gv) = a1.any_hv;
1257 goto avhv_common;
1258
1259 case SAVEt_INT_SMALL:
1260 a0 = ap[0];
1261 *(int*)a0.any_ptr = (int)(uv >> SAVE_TIGHT_SHIFT);
1262 break;
1263
1264 case SAVEt_INT: /* int reference */
1265 a0 = ap[0]; a1 = ap[1];
1266 *(int*)a1.any_ptr = (int)a0.any_i32;
1267 break;
1268
1269 case SAVEt_STRLEN_SMALL:
1270 a0 = ap[0];
1271 *(STRLEN*)a0.any_ptr = (STRLEN)(uv >> SAVE_TIGHT_SHIFT);
1272 break;
1273
1274 case SAVEt_STRLEN: /* STRLEN/size_t ref */
1275 a0 = ap[0]; a1 = ap[1];
1276 *(STRLEN*)a1.any_ptr = (STRLEN)a0.any_iv;
1277 break;
1278
1279 case SAVEt_TMPSFLOOR: /* restore PL_tmps_floor */
1280 a0 = ap[0];
1281 PL_tmps_floor = (SSize_t)a0.any_iv;
1282 break;
1283
1284 case SAVEt_BOOL: /* bool reference */
1285 a0 = ap[0];
1286 *(bool*)a0.any_ptr = cBOOL(uv >> 8);
1287 #ifdef NO_TAINT_SUPPORT
1288 PERL_UNUSED_VAR(was);
1289 #else
1290 if (UNLIKELY(a0.any_ptr == &(PL_tainted))) {
1291 /* If we don't update <was>, to reflect what was saved on the
1292 * stack for PL_tainted, then we will overwrite this attempt to
1293 * restore it when we exit this routine. Note that this won't
1294 * work if this value was saved in a wider-than necessary type,
1295 * such as I32 */
1296 was = *(bool*)a0.any_ptr;
1297 }
1298 #endif
1299 break;
1300
1301 case SAVEt_I32_SMALL:
1302 a0 = ap[0];
1303 *(I32*)a0.any_ptr = (I32)(uv >> SAVE_TIGHT_SHIFT);
1304 break;
1305
1306 case SAVEt_I32: /* I32 reference */
1307 a0 = ap[0]; a1 = ap[1];
1308 #ifdef PERL_DEBUG_READONLY_OPS
1309 if (*(I32*)a1.any_ptr != a0.any_i32)
1310 #endif
1311 *(I32*)a1.any_ptr = a0.any_i32;
1312 break;
1313
1314 case SAVEt_SPTR: /* SV* reference */
1315 case SAVEt_VPTR: /* random* reference */
1316 case SAVEt_PPTR: /* char* reference */
1317 case SAVEt_HPTR: /* HV* reference */
1318 case SAVEt_APTR: /* AV* reference */
1319 a0 = ap[0]; a1 = ap[1];
1320 *a1.any_svp= a0.any_sv;
1321 break;
1322
1323 case SAVEt_GP: /* scalar reference */
1324 {
1325 HV *hv;
1326 bool had_method;
1327
1328 a0 = ap[0]; a1 = ap[1];
1329 /* possibly taking a method out of circulation */
1330 had_method = cBOOL(GvCVu(a0.any_gv));
1331 gp_free(a0.any_gv);
1332 GvGP_set(a0.any_gv, (GP*)a1.any_ptr);
1333 if ((hv=GvSTASH(a0.any_gv)) && HvHasENAME(hv)) {
1334 if (memEQs(GvNAME(a0.any_gv), GvNAMELEN(a0.any_gv), "ISA"))
1335 mro_isa_changed_in(hv);
1336 else if (had_method || GvCVu(a0.any_gv))
1337 /* putting a method back into circulation ("local")*/
1338 gv_method_changed(a0.any_gv);
1339 }
1340 SvREFCNT_dec_NN(a0.any_gv);
1341 break;
1342 }
1343
1344 case SAVEt_FREESV:
1345 a0 = ap[0];
1346 SvREFCNT_dec(a0.any_sv);
1347 break;
1348
1349 case SAVEt_FREEPADNAME:
1350 a0 = ap[0];
1351 PadnameREFCNT_dec((PADNAME *)a0.any_ptr);
1352 break;
1353
1354 case SAVEt_FREECOPHH:
1355 a0 = ap[0];
1356 cophh_free((COPHH *)a0.any_ptr);
1357 break;
1358
1359 case SAVEt_MORTALIZESV:
1360 a0 = ap[0];
1361 sv_2mortal(a0.any_sv);
1362 break;
1363
1364 case SAVEt_FREEOP:
1365 a0 = ap[0];
1366 ASSERT_CURPAD_LEGAL("SAVEt_FREEOP");
1367 op_free(a0.any_op);
1368 break;
1369
1370 case SAVEt_FREEPV:
1371 a0 = ap[0];
1372 Safefree(a0.any_ptr);
1373 break;
1374
1375 case SAVEt_CLEARPADRANGE:
1376 {
1377 I32 i;
1378 SV **svp;
1379 i = (I32)((uv >> SAVE_TIGHT_SHIFT) & OPpPADRANGE_COUNTMASK);
1380 svp = &PL_curpad[uv >>
1381 (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT)] + i - 1;
1382 goto clearsv;
1383 case SAVEt_CLEARSV:
1384 svp = &PL_curpad[uv >> SAVE_TIGHT_SHIFT];
1385 i = 1;
1386 clearsv:
1387 for (; i; i--, svp--) {
1388 SV *sv = *svp;
1389
1390 DEBUG_Xv(PerlIO_printf(Perl_debug_log,
1391 "Pad 0x%" UVxf "[0x%" UVxf "] clearsv: %ld sv=0x%" UVxf "<%" IVdf "> %s\n",
1392 PTR2UV(PL_comppad), PTR2UV(PL_curpad),
1393 (long)(svp-PL_curpad), PTR2UV(sv), (IV)SvREFCNT(sv),
1394 (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) ? "clear" : "abandon"
1395 ));
1396
1397 /* Can clear pad variable in place? */
1398 if (SvREFCNT(sv) == 1 && !SvOBJECT(sv)) {
1399
1400 /* these flags are the union of all the relevant flags
1401 * in the individual conditions within */
1402 if (UNLIKELY(SvFLAGS(sv) & (
1403 SVf_READONLY|SVf_PROTECT /*for SvREADONLY_off*/
1404 | (SVs_GMG|SVs_SMG|SVs_RMG) /* SvMAGICAL() */
1405 | SVf_OOK
1406 | SVf_THINKFIRST)))
1407 {
1408 /* if a my variable that was made readonly is
1409 * going out of scope, we want to remove the
1410 * readonlyness so that it can go out of scope
1411 * quietly
1412 */
1413 if (SvREADONLY(sv))
1414 SvREADONLY_off(sv);
1415
1416 if (SvTYPE(sv) == SVt_PVHV && HvHasAUX(sv))
1417 Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv));
1418 else if(SvOOK(sv))
1419 sv_backoff(sv);
1420
1421 if (SvMAGICAL(sv)) {
1422 /* note that backrefs (either in HvAUX or magic)
1423 * must be removed before other magic */
1424 sv_unmagic(sv, PERL_MAGIC_backref);
1425 if (SvTYPE(sv) != SVt_PVCV)
1426 mg_free(sv);
1427 }
1428 if (SvTHINKFIRST(sv))
1429 sv_force_normal_flags(sv, SV_IMMEDIATE_UNREF
1430 |SV_COW_DROP_PV);
1431
1432 }
1433 switch (SvTYPE(sv)) {
1434 case SVt_NULL:
1435 break;
1436 case SVt_PVAV:
1437 av_clear(MUTABLE_AV(sv));
1438 break;
1439 case SVt_PVHV:
1440 hv_clear(MUTABLE_HV(sv));
1441 break;
1442 case SVt_PVCV:
1443 {
1444 HEK *hek = CvGvNAME_HEK(sv);
1445 assert(hek);
1446 (void)share_hek_hek(hek);
1447 cv_undef((CV *)sv);
1448 CvNAME_HEK_set(sv, hek);
1449 CvLEXICAL_on(sv);
1450 break;
1451 }
1452 default:
1453 /* This looks odd, but these two macros are for use in
1454 expressions and finish with a trailing comma, so
1455 adding a ; after them would be wrong. */
1456 assert_not_ROK(sv)
1457 assert_not_glob(sv)
1458 SvFLAGS(sv) &=~ (SVf_OK|SVf_IVisUV|SVf_UTF8);
1459 break;
1460 }
1461 SvPADTMP_off(sv);
1462 SvPADSTALE_on(sv); /* mark as no longer live */
1463 }
1464 else { /* Someone has a claim on this, so abandon it. */
1465 switch (SvTYPE(sv)) { /* Console ourselves with a new value */
1466 case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
1467 case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
1468 case SVt_PVCV:
1469 {
1470 HEK * const hek = CvGvNAME_HEK(sv);
1471
1472 /* Create a stub */
1473 *svp = newSV_type(SVt_PVCV);
1474
1475 /* Share name */
1476 CvNAME_HEK_set(*svp,
1477 share_hek_hek(hek));
1478 CvLEXICAL_on(*svp);
1479 break;
1480 }
1481 default: *svp = newSV_type(SVt_NULL); break;
1482 }
1483 SvREFCNT_dec_NN(sv); /* Cast current value to the winds. */
1484 /* preserve pad nature, but also mark as not live
1485 * for any closure capturing */
1486 SvFLAGS(*svp) |= SVs_PADSTALE;
1487 }
1488 }
1489 break;
1490 }
1491
1492 case SAVEt_DELETE:
1493 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1494 /* hv_delete could die, so free the key and SvREFCNT_dec the
1495 * hv by pushing new save actions
1496 */
1497 /* ap[0] is the key */
1498 ap[1].any_uv = SAVEt_FREEPV; /* was len */
1499 /* ap[2] is the hv */
1500 ap[3].any_uv = SAVEt_FREESV; /* was SAVEt_DELETE */
1501 PL_savestack_ix += 4;
1502 (void)hv_delete(a2.any_hv, a0.any_pv, a1.any_i32, G_DISCARD);
1503 break;
1504
1505 case SAVEt_ADELETE:
1506 a0 = ap[0]; a1 = ap[1];
1507 /* av_delete could die, so SvREFCNT_dec the av by pushing a
1508 * new save action
1509 */
1510 ap[0].any_av = a1.any_av;
1511 ap[1].any_uv = SAVEt_FREESV;
1512 PL_savestack_ix += 2;
1513 (void)av_delete(a1.any_av, a0.any_iv, G_DISCARD);
1514 break;
1515
1516 case SAVEt_DESTRUCTOR_X:
1517 a0 = ap[0]; a1 = ap[1];
1518 (*a0.any_dxptr)(aTHX_ a1.any_ptr);
1519 break;
1520
1521 case SAVEt_REGCONTEXT:
1522 /* regexp must have croaked */
1523 case SAVEt_ALLOC:
1524 PL_savestack_ix -= uv >> SAVE_TIGHT_SHIFT;
1525 break;
1526
1527 case SAVEt_STACK_POS: /* Position on Perl stack */
1528 a0 = ap[0];
1529 PL_stack_sp = PL_stack_base + a0.any_i32;
1530 break;
1531
1532 case SAVEt_AELEM: /* array element */
1533 {
1534 SV **svp;
1535 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1536 svp = av_fetch(a0.any_av, a1.any_iv, 1);
1537 if (UNLIKELY(!AvREAL(a0.any_av) && AvREIFY(a0.any_av))) /* undo reify guard */
1538 SvREFCNT_dec(a2.any_sv);
1539 if (LIKELY(svp)) {
1540 SV * const sv = *svp;
1541 if (LIKELY(sv && sv != &PL_sv_undef)) {
1542 if (UNLIKELY(SvTIED_mg((const SV *)a0.any_av, PERL_MAGIC_tied)))
1543 SvREFCNT_inc_void_NN(sv);
1544 a1.any_sv = a2.any_sv;
1545 a2.any_svp = svp;
1546 goto restore_sv;
1547 }
1548 }
1549 SvREFCNT_dec(a0.any_av);
1550 SvREFCNT_dec(a2.any_sv);
1551 break;
1552 }
1553
1554 case SAVEt_HELEM: /* hash element */
1555 {
1556 HE *he;
1557
1558 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1559 he = hv_fetch_ent(a0.any_hv, a1.any_sv, 1, 0);
1560 SvREFCNT_dec(a1.any_sv);
1561 if (LIKELY(he)) {
1562 const SV * const oval = HeVAL(he);
1563 if (LIKELY(oval && oval != &PL_sv_undef)) {
1564 SV **svp = &HeVAL(he);
1565 if (UNLIKELY(SvTIED_mg((const SV *)a0.any_hv, PERL_MAGIC_tied)))
1566 SvREFCNT_inc_void(*svp);
1567 a1.any_sv = a2.any_sv;
1568 a2.any_svp = svp;
1569 goto restore_sv;
1570 }
1571 }
1572 SvREFCNT_dec(a0.any_hv);
1573 SvREFCNT_dec(a2.any_sv);
1574 break;
1575 }
1576
1577 case SAVEt_OP:
1578 a0 = ap[0];
1579 PL_op = (OP*)a0.any_ptr;
1580 break;
1581
1582 case SAVEt_HINTS_HH:
1583 a2 = ap[2];
1584 /* FALLTHROUGH */
1585 case SAVEt_HINTS:
1586 a0 = ap[0]; a1 = ap[1];
1587 if ((PL_hints & HINT_LOCALIZE_HH)) {
1588 while (GvHV(PL_hintgv)) {
1589 HV *hv = GvHV(PL_hintgv);
1590 GvHV(PL_hintgv) = NULL;
1591 SvREFCNT_dec(MUTABLE_SV(hv));
1592 }
1593 }
1594 cophh_free(CopHINTHASH_get(&PL_compiling));
1595 CopHINTHASH_set(&PL_compiling, (COPHH*)a1.any_ptr);
1596 *(I32*)&PL_hints = a0.any_i32;
1597 PL_prevailing_version = (U16)(uv >> 8);
1598 if (type == SAVEt_HINTS_HH) {
1599 SvREFCNT_dec(MUTABLE_SV(GvHV(PL_hintgv)));
1600 GvHV(PL_hintgv) = MUTABLE_HV(a2.any_ptr);
1601 }
1602 if (!GvHV(PL_hintgv)) {
1603 /* Need to add a new one manually, else rv2hv can
1604 add one via GvHVn and it won't have the magic set. */
1605 HV *const hv = newHV();
1606 hv_magic(hv, NULL, PERL_MAGIC_hints);
1607 GvHV(PL_hintgv) = hv;
1608 }
1609 assert(GvHV(PL_hintgv));
1610 break;
1611
1612 case SAVEt_COMPPAD:
1613 a0 = ap[0];
1614 PL_comppad = (PAD*)a0.any_ptr;
1615 if (LIKELY(PL_comppad))
1616 PL_curpad = AvARRAY(PL_comppad);
1617 else
1618 PL_curpad = NULL;
1619 break;
1620
1621 case SAVEt_PADSV_AND_MORTALIZE:
1622 {
1623 SV **svp;
1624
1625 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1626 assert (a1.any_ptr);
1627 svp = AvARRAY((PAD*)a1.any_ptr) + (PADOFFSET)a2.any_uv;
1628 /* This mortalizing used to be done by CX_POOPLOOP() via
1629 itersave. But as we have all the information here, we
1630 can do it here, save even having to have itersave in
1631 the struct.
1632 */
1633 sv_2mortal(*svp);
1634 *svp = a0.any_sv;
1635 }
1636 break;
1637
1638 case SAVEt_SAVESWITCHSTACK:
1639 {
1640 dSP;
1641
1642 a0 = ap[0]; a1 = ap[1];
1643 SWITCHSTACK(a1.any_av, a0.any_av);
1644 PL_curstackinfo->si_stack = a0.any_av;
1645 }
1646 break;
1647
1648 case SAVEt_SET_SVFLAGS:
1649 a0 = ap[0]; a1 = ap[1]; a2 = ap[2];
1650 SvFLAGS(a0.any_sv) &= ~(a1.any_u32);
1651 SvFLAGS(a0.any_sv) |= a2.any_u32;
1652 break;
1653
1654 /* These are only saved in mathoms.c */
1655 case SAVEt_NSTAB:
1656 a0 = ap[0];
1657 (void)sv_clear(a0.any_sv);
1658 break;
1659
1660 case SAVEt_LONG: /* long reference */
1661 a0 = ap[0]; a1 = ap[1];
1662 *(long*)a1.any_ptr = a0.any_long;
1663 break;
1664
1665 case SAVEt_IV: /* IV reference */
1666 a0 = ap[0]; a1 = ap[1];
1667 *(IV*)a1.any_ptr = a0.any_iv;
1668 break;
1669
1670 case SAVEt_I16: /* I16 reference */
1671 a0 = ap[0];
1672 *(I16*)a0.any_ptr = (I16)(uv >> 8);
1673 break;
1674
1675 case SAVEt_I8: /* I8 reference */
1676 a0 = ap[0];
1677 *(I8*)a0.any_ptr = (I8)(uv >> 8);
1678 break;
1679
1680 case SAVEt_DESTRUCTOR:
1681 a0 = ap[0]; a1 = ap[1];
1682 (*a0.any_dptr)(a1.any_ptr);
1683 break;
1684
1685 case SAVEt_COMPILE_WARNINGS:
1686 /* NOTE: we can't put &PL_compiling or PL_curcop on the save
1687 * stack directly, as we currently cannot translate
1688 * them to the correct addresses after a thread start
1689 * or win32 fork start. - Yves
1690 */
1691 a0 = ap[0];
1692 free_and_set_cop_warnings(&PL_compiling, a0.any_pv);
1693 break;
1694
1695 case SAVEt_CURCOP_WARNINGS:
1696 /* NOTE: see comment above about SAVEt_COMPILE_WARNINGS */
1697 a0 = ap[0];
1698 free_and_set_cop_warnings(PL_curcop, a0.any_pv);
1699 break;
1700
1701 case SAVEt_PARSER:
1702 a0 = ap[0];
1703 parser_free((yy_parser *)a0.any_ptr);
1704 break;
1705
1706 case SAVEt_READONLY_OFF:
1707 a0 = ap[0];
1708 SvREADONLY_off(a0.any_sv);
1709 break;
1710
1711 default:
1712 Perl_croak(aTHX_ "panic: leave_scope inconsistency %u",
1713 (U8)uv & SAVE_MASK);
1714 }
1715 }
1716
1717 TAINT_set(was);
1718 }
1719
1720 void
Perl_cx_dump(pTHX_ PERL_CONTEXT * cx)1721 Perl_cx_dump(pTHX_ PERL_CONTEXT *cx)
1722 {
1723 PERL_ARGS_ASSERT_CX_DUMP;
1724
1725 #ifdef DEBUGGING
1726 PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), PL_block_type[CxTYPE(cx)]);
1727 if (CxTYPE(cx) != CXt_SUBST) {
1728 const char *gimme_text;
1729 PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
1730 PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%" UVxf "\n",
1731 PTR2UV(cx->blk_oldcop));
1732 PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
1733 PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
1734 PerlIO_printf(Perl_debug_log, "BLK_OLDSAVEIX = %ld\n", (long)cx->blk_oldsaveix);
1735 PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%" UVxf "\n",
1736 PTR2UV(cx->blk_oldpm));
1737 switch (cx->blk_gimme) {
1738 case G_VOID:
1739 gimme_text = "VOID";
1740 break;
1741 case G_SCALAR:
1742 gimme_text = "SCALAR";
1743 break;
1744 case G_LIST:
1745 gimme_text = "LIST";
1746 break;
1747 default:
1748 gimme_text = "UNKNOWN";
1749 break;
1750 }
1751 PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", gimme_text);
1752 }
1753 switch (CxTYPE(cx)) {
1754 case CXt_NULL:
1755 case CXt_BLOCK:
1756 case CXt_DEFER:
1757 break;
1758 case CXt_FORMAT:
1759 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.CV = 0x%" UVxf "\n",
1760 PTR2UV(cx->blk_format.cv));
1761 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.GV = 0x%" UVxf "\n",
1762 PTR2UV(cx->blk_format.gv));
1763 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.DFOUTGV = 0x%" UVxf "\n",
1764 PTR2UV(cx->blk_format.dfoutgv));
1765 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.HASARGS = %d\n",
1766 (int)CxHASARGS(cx));
1767 PerlIO_printf(Perl_debug_log, "BLK_FORMAT.RETOP = 0x%" UVxf "\n",
1768 PTR2UV(cx->blk_format.retop));
1769 break;
1770 case CXt_SUB:
1771 PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%" UVxf "\n",
1772 PTR2UV(cx->blk_sub.cv));
1773 PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
1774 (long)cx->blk_sub.olddepth);
1775 PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
1776 (int)CxHASARGS(cx));
1777 PerlIO_printf(Perl_debug_log, "BLK_SUB.LVAL = %d\n", (int)CxLVAL(cx));
1778 PerlIO_printf(Perl_debug_log, "BLK_SUB.RETOP = 0x%" UVxf "\n",
1779 PTR2UV(cx->blk_sub.retop));
1780 break;
1781 case CXt_EVAL:
1782 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
1783 (long)CxOLD_IN_EVAL(cx));
1784 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
1785 PL_op_name[CxOLD_OP_TYPE(cx)],
1786 PL_op_desc[CxOLD_OP_TYPE(cx)]);
1787 if (cx->blk_eval.old_namesv)
1788 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
1789 SvPVX_const(cx->blk_eval.old_namesv));
1790 PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%" UVxf "\n",
1791 PTR2UV(cx->blk_eval.old_eval_root));
1792 PerlIO_printf(Perl_debug_log, "BLK_EVAL.RETOP = 0x%" UVxf "\n",
1793 PTR2UV(cx->blk_eval.retop));
1794 break;
1795
1796 case CXt_LOOP_PLAIN:
1797 case CXt_LOOP_LAZYIV:
1798 case CXt_LOOP_LAZYSV:
1799 case CXt_LOOP_LIST:
1800 case CXt_LOOP_ARY:
1801 PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", CxLABEL(cx));
1802 PerlIO_printf(Perl_debug_log, "BLK_LOOP.MY_OP = 0x%" UVxf "\n",
1803 PTR2UV(cx->blk_loop.my_op));
1804 if (CxTYPE(cx) != CXt_LOOP_PLAIN) {
1805 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%" UVxf "\n",
1806 PTR2UV(CxITERVAR(cx)));
1807 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%" UVxf "\n",
1808 PTR2UV(cx->blk_loop.itersave));
1809 }
1810 if (CxTYPE(cx) == CXt_LOOP_ARY) {
1811 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%" UVxf "\n",
1812 PTR2UV(cx->blk_loop.state_u.ary.ary));
1813 PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
1814 (long)cx->blk_loop.state_u.ary.ix);
1815 }
1816 break;
1817
1818 case CXt_SUBST:
1819 PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
1820 (long)cx->sb_iters);
1821 PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
1822 (long)cx->sb_maxiters);
1823 PerlIO_printf(Perl_debug_log, "SB_RFLAGS = %ld\n",
1824 (long)cx->sb_rflags);
1825 PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
1826 (long)CxONCE(cx));
1827 PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
1828 cx->sb_orig);
1829 PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%" UVxf "\n",
1830 PTR2UV(cx->sb_dstr));
1831 PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%" UVxf "\n",
1832 PTR2UV(cx->sb_targ));
1833 PerlIO_printf(Perl_debug_log, "SB_S = 0x%" UVxf "\n",
1834 PTR2UV(cx->sb_s));
1835 PerlIO_printf(Perl_debug_log, "SB_M = 0x%" UVxf "\n",
1836 PTR2UV(cx->sb_m));
1837 PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%" UVxf "\n",
1838 PTR2UV(cx->sb_strend));
1839 PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%" UVxf "\n",
1840 PTR2UV(cx->sb_rxres));
1841 break;
1842 }
1843 #else
1844 PERL_UNUSED_CONTEXT;
1845 PERL_UNUSED_ARG(cx);
1846 #endif /* DEBUGGING */
1847 }
1848
1849 /*
1850 =for apidoc_section $callback
1851 =for apidoc mortal_destructor_sv
1852
1853 This function arranges for either a Perl code reference, or a C function
1854 reference to be called at the B<end of the current statement>.
1855
1856 The C<coderef> argument determines the type of function that will be
1857 called. If it is C<SvROK()> it is assumed to be a reference to a CV and
1858 will arrange for the coderef to be called. If it is not SvROK() then it
1859 is assumed to be a C<SvIV()> which is C<SvIOK()> whose value is a pointer
1860 to a C function of type C<DESTRUCTORFUNC_t> created using C<PTR2INT()>.
1861 Either way the C<args> parameter will be provided to the callback as a
1862 parameter, although the rules for doing so differ between the Perl and
1863 C mode. Normally this function is only used directly for the Perl case
1864 and the wrapper C<mortal_destructor_x()> is used for the C function case.
1865
1866 When operating in Perl callback mode the C<args> parameter may be NULL
1867 in which case the code reference is called with no arguments, otherwise
1868 if it is an AV (SvTYPE(args) == SVt_PVAV) then the contents of the AV
1869 will be used as the arguments to the code reference, and if it is any
1870 other type then the C<args> SV will be provided as a single argument to
1871 the code reference.
1872
1873 When operating in a C callback mode the C<args> parameter will be passed
1874 directly to the C function as a C<void *> pointer. No additional
1875 processing of the argument will be peformed, and it is the callers
1876 responsibility to free the C<args> parameter if necessary.
1877
1878 Be aware that there is a signficant difference in timing between the
1879 I<end of the current statement> and the I<end of the current pseudo
1880 block>. If you are looking for a mechanism to trigger a function at the
1881 end of the B<current pseudo block> you should look at
1882 C<SAVEDESTRUCTORX()> instead of this function.
1883
1884 =for apidoc mortal_svfunc_x
1885
1886 This function arranges for a C function reference to be called at the
1887 B<end of the current statement> with the arguments provided. It is a
1888 wrapper around C<mortal_destructor_sv()> which ensures that the latter
1889 function is called appropriately.
1890
1891 Be aware that there is a signficant difference in timing between the
1892 I<end of the current statement> and the I<end of the current pseudo
1893 block>. If you are looking for a mechanism to trigger a function at the
1894 end of the B<current pseudo block> you should look at
1895 C<SAVEDESTRUCTORX()> instead of this function.
1896
1897 =for apidoc magic_freedestruct
1898
1899 This function is called via magic to implement the
1900 C<mortal_destructor_sv()> and C<mortal_destructor_x()> functions. It
1901 should not be called directly and has no user servicable parts.
1902
1903 =cut
1904 */
1905
1906 void
Perl_mortal_destructor_sv(pTHX_ SV * coderef,SV * args)1907 Perl_mortal_destructor_sv(pTHX_ SV *coderef, SV *args) {
1908 PERL_ARGS_ASSERT_MORTAL_DESTRUCTOR_SV;
1909 assert(
1910 (SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) /* perl coderef */
1911 ||
1912 (SvIOK(coderef) && !SvROK(coderef)) /* C function ref */
1913 );
1914 SV *variable = newSV_type_mortal(SVt_IV);
1915 (void)sv_magicext(variable, coderef, PERL_MAGIC_destruct,
1916 &PL_vtbl_destruct, (char *)args, args ? HEf_SVKEY : 0);
1917 }
1918
1919
1920 void
Perl_mortal_svfunc_x(pTHX_ SVFUNC_t f,SV * sv)1921 Perl_mortal_svfunc_x(pTHX_ SVFUNC_t f, SV *sv) {
1922 PERL_ARGS_ASSERT_MORTAL_SVFUNC_X;
1923 SV *sviv = newSViv(PTR2IV(f));
1924 mortal_destructor_sv(sviv,sv);
1925 }
1926
1927
1928 int
Perl_magic_freedestruct(pTHX_ SV * sv,MAGIC * mg)1929 Perl_magic_freedestruct(pTHX_ SV* sv, MAGIC* mg) {
1930 PERL_ARGS_ASSERT_MAGIC_FREEDESTRUCT;
1931 dSP;
1932 union {
1933 SV *sv;
1934 AV *av;
1935 char *pv;
1936 } args_any;
1937 SV *coderef;
1938
1939 IV nargs = 0;
1940 if (PL_phase == PERL_PHASE_DESTRUCT) {
1941 Perl_warn(aTHX_ "Can't call destructor for 0x%p in global destruction\n", sv);
1942 return 1;
1943 }
1944
1945 args_any.pv = mg->mg_ptr;
1946 coderef = mg->mg_obj;
1947
1948 /* Deal with C function destructor */
1949 if (SvTYPE(coderef) == SVt_IV && !SvROK(coderef)) {
1950 SVFUNC_t f = INT2PTR(SVFUNC_t, SvIV(coderef));
1951 (f)(aTHX_ args_any.sv);
1952 return 0;
1953 }
1954
1955 if (args_any.sv) {
1956 if (SvTYPE(args_any.sv) == SVt_PVAV) {
1957 nargs = av_len(args_any.av) + 1;
1958 } else {
1959 nargs = 1;
1960 }
1961 }
1962 PUSHSTACKi(PERLSI_MAGIC);
1963 ENTER_with_name("call_freedestruct");
1964 SAVETMPS;
1965 EXTEND(SP, nargs);
1966 PUSHMARK(SP);
1967 if (args_any.sv) {
1968 if (SvTYPE(args_any.sv) == SVt_PVAV) {
1969 IV n;
1970 for (n = 0 ; n < nargs ; n++ ) {
1971 SV **argp = av_fetch(args_any.av, n, 0);
1972 if (argp && *argp)
1973 PUSHs(*argp);
1974 }
1975 } else {
1976 PUSHs(args_any.sv);
1977 }
1978 }
1979 PUTBACK;
1980 (void)call_sv(coderef, G_VOID | G_EVAL | G_KEEPERR);
1981 FREETMPS;
1982 LEAVE_with_name("call_freedestruct");
1983 POPSTACK;
1984 return 0;
1985 }
1986
1987
1988 /*
1989 * ex: set ts=8 sts=4 sw=4 et:
1990 */
1991