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