1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 /* The most popular error message */
6 #define TOO_FAR \
7 croak("want: Called from outside a subroutine")
8
9 /* Between 5.9.1 and 5.9.2 the retstack was removed, and the
10 return op is now stored on the cxstack. */
11 #define HAS_RETSTACK (\
12 PERL_REVISION < 5 || \
13 (PERL_REVISION == 5 && PERL_VERSION < 9) || \
14 (PERL_REVISION == 5 && PERL_VERSION == 9 && PERL_SUBVERSION < 2) \
15 )
16
17 /* After 5.10, the CxLVAL macro was added. */
18 #ifndef CxLVAL
19 # define CxLVAL(cx) cx->blk_sub.lval
20 #endif
21
22 #ifndef OpSIBLING
23 # define OpSIBLING(o) o->op_sibling
24 #endif
25
26 /* Stolen from B.xs */
27
28 #ifdef PERL_OBJECT
29 #undef PL_op_name
30 #undef PL_opargs
31 #undef PL_op_desc
32 #define PL_op_name (get_op_names())
33 #define PL_opargs (get_opargs())
34 #define PL_op_desc (get_op_descs())
35 #endif
36
37
38 /* Stolen from pp_ctl.c (with modifications) */
39
40 I32
dopoptosub_at(pTHX_ PERL_CONTEXT * cxstk,I32 startingblock)41 dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
42 {
43 dTHR;
44 I32 i;
45 PERL_CONTEXT *cx;
46 for (i = startingblock; i >= 0; i--) {
47 cx = &cxstk[i];
48 switch (CxTYPE(cx)) {
49 default:
50 continue;
51 /*case CXt_EVAL:*/
52 case CXt_SUB:
53 case CXt_FORMAT:
54 DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
55 return i;
56 }
57 }
58 return i;
59 }
60
61 I32
dopoptosub(pTHX_ I32 startingblock)62 dopoptosub(pTHX_ I32 startingblock)
63 {
64 dTHR;
65 return dopoptosub_at(aTHX_ cxstack, startingblock);
66 }
67
68 PERL_CONTEXT*
upcontext(pTHX_ I32 count)69 upcontext(pTHX_ I32 count)
70 {
71 PERL_SI *top_si = PL_curstackinfo;
72 I32 cxix = dopoptosub(aTHX_ cxstack_ix);
73 PERL_CONTEXT *cx;
74 PERL_CONTEXT *ccstack = cxstack;
75 I32 dbcxix;
76
77 for (;;) {
78 /* we may be in a higher stacklevel, so dig down deeper */
79 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
80 top_si = top_si->si_prev;
81 ccstack = top_si->si_cxstack;
82 cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
83 }
84 if (cxix < 0) {
85 return (PERL_CONTEXT *)0;
86 }
87 if (PL_DBsub && cxix >= 0 &&
88 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
89 count++;
90 if (!count--)
91 break;
92 cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
93 }
94 cx = &ccstack[cxix];
95 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
96 dbcxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
97 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
98 field below is defined for any cx. */
99 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
100 cx = &ccstack[dbcxix];
101 }
102 }
103 return cx;
104 }
105
106 /* This one is like upcontext except that, when it's found the
107 sub context, it keeps looking to see if the sub was called
108 from within a loop. If it was, it returns the loop context
109 instead.
110
111 Prior to 0.09, find_ancestors_from was called with start equal
112 to the oldcop of the sub we're looking for. Unfortunately it's not
113 guaranteed that we'll be able to find the sub just by
114 traversing the tree from there: Damian Conway reported
115 a bug against 0.08, where code like while(foo) {...}
116 -- where foo calls want -- causes a crash on the second
117 iteration of the loop. That is because oldcop then
118 points to the last cop in the body of the loop, which
119 is lexically *ahead* of the calling point.
120
121 Another change in 0.13: if end_of_block == TRUE, then go
122 up another level beyond the sub.
123 */
124 PERL_CONTEXT*
upcontext_plus(pTHX_ I32 count,bool end_of_block)125 upcontext_plus(pTHX_ I32 count, bool end_of_block)
126 {
127 PERL_SI *top_si = PL_curstackinfo;
128 I32 cxix = dopoptosub(aTHX_ cxstack_ix);
129 PERL_CONTEXT *cx, *tcx;
130 PERL_CONTEXT *ccstack = cxstack;
131 I32 dbcxix, i;
132 bool debugger_trouble;
133
134 for (;;) {
135 /* we may be in a higher stacklevel, so dig down deeper */
136 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
137 top_si = top_si->si_prev;
138 ccstack = top_si->si_cxstack;
139 cxix = dopoptosub_at(aTHX_ ccstack, top_si->si_cxix);
140 }
141 if (cxix < 0) {
142 return (PERL_CONTEXT *)0;
143 }
144 if (PL_DBsub && cxix >= 0 &&
145 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
146 count++;
147 if (!count--)
148 break;
149 cxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
150 }
151 cx = &ccstack[cxix];
152 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
153 dbcxix = dopoptosub_at(aTHX_ ccstack, cxix - 1);
154 /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
155 field below is defined for any cx. */
156 if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
157 {
158 cxix = dbcxix;
159 cx = &ccstack[cxix];
160 }
161 }
162
163 /* Now for the extra bit */
164 debugger_trouble = (cx->blk_oldcop->op_type == OP_DBSTATE);
165
166 for (i = cxix-1; i>=0 ; i--) {
167 tcx = &ccstack[i];
168 switch (CxTYPE(tcx)) {
169 case CXt_BLOCK:
170 if (debugger_trouble && i > 0) return tcx;
171 default:
172 continue;
173 #ifdef CXt_LOOP_PLAIN
174 case CXt_LOOP_PLAIN:
175 #endif
176 #ifdef CXt_LOOP_FOR
177 case CXt_LOOP_FOR:
178 #endif
179 #ifdef CXt_LOOP_LIST
180 case CXt_LOOP_LIST:
181 #endif
182 #ifdef CXt_LOOP_ARY
183 case CXt_LOOP_ARY:
184 #endif
185 #ifdef CXt_LOOP
186 case CXt_LOOP:
187 #endif
188 return tcx;
189 case CXt_SUB:
190 case CXt_FORMAT:
191 return cx;
192 }
193 }
194 return ((end_of_block && cxix > 1) ? &ccstack[cxix-1] : cx);
195 }
196
197 /* inspired (loosely) by pp_wantarray */
198
199 U8
want_gimme(I32 uplevel)200 want_gimme (I32 uplevel)
201 {
202 PERL_CONTEXT* cx = upcontext(aTHX_ uplevel);
203 if (!cx) TOO_FAR;
204 return cx->blk_gimme;
205 }
206
207 /* end thievery and "inspiration" */
208
209 #define OPLIST_MAX 50
210 typedef struct {
211 U16 numop_num;
212 OP* numop_op;
213 } numop;
214
215 typedef struct {
216 U16 length;
217 numop ops[OPLIST_MAX];
218 } oplist;
219
220 #define new_oplist (oplist*) malloc(sizeof(oplist))
221 #define init_oplist(l) l->length = 0
222
223 numop*
lastnumop(oplist * l)224 lastnumop(oplist* l)
225 {
226 U16 i;
227 numop* ret;
228
229 if (!l) die("Want panicked: null list in lastnumop");
230 i = l->length;
231 while (i-- > 0) {
232 ret = &(l->ops)[i];
233 if (ret->numop_op->op_type != OP_NULL && ret->numop_op->op_type != OP_SCOPE) {
234 return ret;
235 }
236 }
237 return (numop*)0;
238 }
239
240 /* NB: unlike lastnumop, lastop frees the oplist */
241 OP*
lastop(oplist * l)242 lastop(oplist* l)
243 {
244 U16 i;
245 OP* ret;
246
247 if (!l) die("Want panicked: null list in lastop");
248 i = l->length;
249 while (i-- > 0) {
250 ret = (l->ops)[i].numop_op;
251 if (ret->op_type != OP_NULL
252 && ret->op_type != OP_SCOPE
253 && ret->op_type != OP_LEAVE) {
254 free(l);
255 return ret;
256 }
257 }
258 free(l);
259 return Nullop;
260 }
261
262 oplist*
pushop(oplist * l,OP * o,U16 i)263 pushop(oplist* l, OP* o, U16 i)
264 {
265 I16 len = l->length;
266 if (o && len < OPLIST_MAX) {
267 ++ l->length;
268 l->ops[len].numop_op = o;
269 l->ops[len].numop_num = -1;
270 }
271 if (len > 0)
272 l->ops[len-1].numop_num = i;
273
274 return l;
275 }
276
277 oplist*
find_ancestors_from(OP * start,OP * next,oplist * l)278 find_ancestors_from(OP* start, OP* next, oplist* l)
279 {
280 OP *o, *p;
281 U16 cn = 0;
282 U16 ll;
283 bool outer_call = FALSE;
284
285 if (!next)
286 die("want panicked: I've been asked to find a null return address.\n"
287 " (Are you trying to call me from inside a tie handler?)\n ");
288
289 if (!l) {
290 outer_call = TRUE;
291 l = new_oplist;
292 init_oplist(l);
293 ll = 0;
294 }
295 else ll = l->length;
296
297 /* printf("Looking for 0x%x starting at 0x%x\n", next, start); */
298 for (o = start; o; p = o, o = OpSIBLING(o), ++cn) {
299 /* printf("(0x%x) %s -> 0x%x\n", o, PL_op_name[o->op_type], o->op_next);*/
300
301 if (o->op_type == OP_ENTERSUB && o->op_next == next)
302 return pushop(l, Nullop, cn);
303
304 if (o->op_flags & OPf_KIDS) {
305 U16 ll = l->length;
306
307 pushop(l, o, cn);
308 if (find_ancestors_from(cUNOPo->op_first, next, l))
309 return l;
310 else
311 l->length = ll;
312 }
313
314 }
315 return 0;
316 }
317
318 OP*
find_return_op(pTHX_ I32 uplevel)319 find_return_op(pTHX_ I32 uplevel)
320 {
321 PERL_CONTEXT *cx = upcontext(aTHX_ uplevel);
322 if (!cx) TOO_FAR;
323 #if HAS_RETSTACK
324 return PL_retstack[cx->blk_oldretsp - 1];
325 #else
326 return cx->blk_sub.retop;
327 #endif
328 }
329
330 OP*
find_start_cop(pTHX_ I32 uplevel,bool end_of_block)331 find_start_cop(pTHX_ I32 uplevel, bool end_of_block)
332 {
333 PERL_CONTEXT* cx = upcontext_plus(aTHX_ uplevel, end_of_block);
334 if (!cx) TOO_FAR;
335 return (OP*) cx->blk_oldcop;
336 }
337
338 /**
339 * Return the whole oplist leading down to the subcall.
340 * It's the caller's responsibility to free the returned oplist.
341 */
342 oplist*
ancestor_ops(I32 uplevel,OP ** return_op_out)343 ancestor_ops (I32 uplevel, OP** return_op_out)
344 {
345 OP* return_op = find_return_op(aTHX_ uplevel);
346 OP* start_cop = find_start_cop(aTHX_ uplevel,
347 return_op->op_type == OP_LEAVE);
348
349 if (return_op_out)
350 *return_op_out = return_op;
351
352 return find_ancestors_from(start_cop, return_op, 0);
353 }
354
355 /** Return the parent of the OP_ENTERSUB, or the grandparent if the parent
356 * is an OP_NULL or OP_SCOPE. If the parent precedes the last COP, then return Nullop.
357 * (In that last case, we must be in void context.)
358 */
359 OP*
parent_op(I32 uplevel,OP ** return_op_out)360 parent_op (I32 uplevel, OP** return_op_out)
361 {
362 return lastop(ancestor_ops(uplevel, return_op_out));
363 }
364
365 /* forward declaration - mutual recursion */
366 I32 count_list (OP* parent, OP* returnop);
367
count_slice(OP * o)368 I32 count_slice (OP* o) {
369 OP* pm = cUNOPo->op_first;
370 OP* l = Nullop;
371
372 if (pm->op_type != OP_PUSHMARK)
373 die("%s", "Want panicked: slice doesn't start with pushmark\n");
374
375 if ( (l = OpSIBLING(pm)) && (l->op_type == OP_LIST || (l->op_type == OP_NULL && l->op_targ == OP_LIST)))
376 return count_list(l, Nullop);
377
378 else if (l)
379 switch (l->op_type) {
380 case OP_RV2AV:
381 case OP_PADAV:
382 case OP_PADHV:
383 case OP_RV2HV:
384 return 0;
385 case OP_HSLICE:
386 case OP_ASLICE:
387 return count_slice(l);
388 case OP_STUB:
389 return 1;
390 default:
391 die("Want panicked: Unexpected op in slice (%s)\n", PL_op_name[l->op_type]);
392 }
393
394 else
395 die("Want panicked: Nothing follows pushmark in slice\n");
396
397 return -999; /* Should never get here - silence compiler warning */
398 }
399
400 /** Count the number of children of this OP.
401 * Except if any of them is OP_RV2AV or OP_ENTERSUB, return 0 instead.
402 * Also, stop counting if an OP_ENTERSUB is reached whose op_next is <returnop>.
403 */
404 I32
count_list(OP * parent,OP * returnop)405 count_list (OP* parent, OP* returnop)
406 {
407 OP* o;
408 I32 i = 0;
409
410 if (! (parent->op_flags & OPf_KIDS))
411 return 0;
412
413 /*printf("count_list: returnop = 0x%x\n", returnop);*/
414 for(o = cUNOPx(parent)->op_first; o; o=OpSIBLING(o)) {
415 /* printf("\t%-8s\t(0x%x)\n", PL_op_name[o->op_type], o->op_next);*/
416 if (returnop && o->op_type == OP_ENTERSUB && o->op_next == returnop)
417 return i;
418 if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV
419 || o->op_type == OP_PADAV || o->op_type == OP_PADHV
420 || o->op_type == OP_ENTERSUB)
421 return 0;
422
423 if (o->op_type == OP_HSLICE || o->op_type == OP_ASLICE) {
424 I32 slice_length = count_slice(o);
425 if (slice_length == 0)
426 return 0;
427 else
428 i += slice_length - 1;
429 }
430 else ++i;
431 }
432
433 return i;
434 }
435
436 I32
countstack(I32 uplevel)437 countstack(I32 uplevel)
438 {
439 PERL_CONTEXT* cx = upcontext(aTHX_ uplevel);
440 I32 oldmarksp;
441 I32 mark_from;
442 I32 mark_to;
443
444 if (!cx) return -1;
445
446 oldmarksp = cx->blk_oldmarksp;
447 mark_from = PL_markstack[oldmarksp];
448 mark_to = PL_markstack[oldmarksp+1];
449 return (mark_to - mark_from);
450 }
451
452 AV*
copy_rvals(I32 uplevel,I32 skip)453 copy_rvals(I32 uplevel, I32 skip)
454 {
455 PERL_CONTEXT* cx = upcontext(aTHX_ uplevel);
456 I32 oldmarksp;
457 I32 mark_from;
458 I32 mark_to;
459 I32 i;
460 AV* a;
461
462 oldmarksp = cx->blk_oldmarksp;
463 mark_from = PL_markstack[oldmarksp-1];
464 mark_to = PL_markstack[oldmarksp];
465
466 /*printf("\t(%d -> %d) %d skipping %d\n", mark_from, mark_to, oldmarksp, skip);*/
467
468 if (!cx) return Nullav;
469 a = newAV();
470 for(i=mark_from+1; i<=mark_to; ++i)
471 if (skip-- <= 0) av_push(a, newSVsv(PL_stack_base[i]));
472 /* printf("avlen = %d\n", av_len(a)); */
473
474 return a;
475 }
476
477 AV*
copy_rval(I32 uplevel)478 copy_rval(I32 uplevel)
479 {
480 PERL_CONTEXT* cx = upcontext(aTHX_ uplevel);
481 I32 oldmarksp;
482 AV* a;
483
484 oldmarksp = cx->blk_oldmarksp;
485 if (!cx) return Nullav;
486 a = newAV();
487 /* printf("oldmarksp = %d\n", oldmarksp); */
488 av_push(a, newSVsv(PL_stack_base[PL_markstack[oldmarksp+1]]));
489
490 return a;
491 }
492
493
494 MODULE = Want PACKAGE = Want
495 PROTOTYPES: ENABLE
496
497 SV*
498 wantarray_up(uplevel)
499 I32 uplevel;
500 PREINIT:
501 U8 gimme = want_gimme(uplevel);
502 CODE:
503 switch(gimme) {
504 case G_ARRAY:
505 RETVAL = &PL_sv_yes;
506 break;
507 case G_SCALAR:
508 RETVAL = &PL_sv_no;
509 break;
510 default:
511 RETVAL = &PL_sv_undef;
512 }
513 OUTPUT:
514 RETVAL
515
516 U8
517 want_lvalue(uplevel)
518 I32 uplevel;
519 PREINIT:
520 PERL_CONTEXT* cx;
521 CODE:
522 cx = upcontext(aTHX_ uplevel);
523 if (!cx) TOO_FAR;
524
525 if (CvLVALUE(cx->blk_sub.cv))
526 RETVAL = CxLVAL(cx);
527 else
528 RETVAL = 0;
529 OUTPUT:
530 RETVAL
531
532
533 char*
534 parent_op_name(uplevel)
535 I32 uplevel;
536 PREINIT:
537 OP *r;
538 OP *o = parent_op(uplevel, &r);
539 OP *first, *second;
540 char *retval;
541 PPCODE:
542 /* This is a bit of a cheat, admittedly... */
543 if (o && o->op_type == OP_ENTERSUB && (first = cUNOPo->op_first)
544 && (second = OpSIBLING(first)) && OpSIBLING(second) != Nullop)
545 retval = "method_call";
546 else {
547 retval = o ? (char *)PL_op_name[o->op_type] : "(none)";
548 }
549 if (GIMME == G_ARRAY) {
550 EXTEND(SP, 2);
551 PUSHs(sv_2mortal(newSVpv(retval, 0)));
552 PUSHs(sv_2mortal(newSVpv(PL_op_name[r->op_type], 0)));
553 }
554 else {
555 EXTEND(SP, 1);
556 PUSHs(sv_2mortal(newSVpv(retval, 0)));
557 }
558
559 #ifdef OPpMULTIDEREF_EXISTS
560 char*
561 first_multideref_type(uplevel)
562 I32 uplevel;
563 PREINIT:
564 OP *r;
565 OP *o = parent_op(uplevel, &r);
566 UNOP_AUX_item *items;
567 UV actions;
568 bool repeat;
569 char *retval;
570 PPCODE:
571 if (o->op_type != OP_MULTIDEREF) Perl_croak(aTHX_ "Not a multideref op!");
572 items = cUNOP_AUXx(o)->op_aux;
573 actions = items->uv;
574
575 do {
576 repeat = FALSE;
577 switch (actions & MDEREF_ACTION_MASK) {
578 case MDEREF_reload:
579 actions = (++items)->uv;
580 repeat = TRUE;
581 continue;
582
583 case MDEREF_AV_pop_rv2av_aelem:
584 case MDEREF_AV_gvsv_vivify_rv2av_aelem:
585 case MDEREF_AV_padsv_vivify_rv2av_aelem:
586 case MDEREF_AV_vivify_rv2av_aelem:
587 case MDEREF_AV_padav_aelem:
588 case MDEREF_AV_gvav_aelem:
589 retval = "ARRAY";
590 break;
591
592 case MDEREF_HV_pop_rv2hv_helem:
593 case MDEREF_HV_gvsv_vivify_rv2hv_helem:
594 case MDEREF_HV_padsv_vivify_rv2hv_helem:
595 case MDEREF_HV_vivify_rv2hv_helem:
596 case MDEREF_HV_padhv_helem:
597 case MDEREF_HV_gvhv_helem:
598 retval = "HASH";
599 break;
600
601 default:
602 Perl_croak(aTHX_ "Unrecognised OP_MULTIDEREF action (%lu)!", actions & MDEREF_ACTION_MASK);
603 }
604 } while (repeat);
605
606 EXTEND(SP, 1);
607 PUSHs(sv_2mortal(newSVpv(retval, 0)));
608
609 #endif
610
611 I32
612 want_count(uplevel)
613 I32 uplevel;
614 PREINIT:
615 OP* returnop;
616 OP* o = parent_op(uplevel, &returnop);
617 U8 gimme = want_gimme(uplevel);
618 CODE:
619 if (o && o->op_type == OP_AASSIGN) {
620 I32 lhs = count_list(cBINOPo->op_last, Nullop );
621 I32 rhs = countstack(uplevel);
622 /* printf("lhs = %d, rhs = %d\n", lhs, rhs); */
623 if (lhs == 0) RETVAL = -1; /* (..@x..) = (..., foo(), ...); */
624 else if (rhs >= lhs-1) RETVAL = 0;
625 else RETVAL = lhs - rhs - 1;
626 }
627
628 else switch(gimme) {
629 case G_ARRAY:
630 RETVAL = -1;
631 break;
632
633 case G_SCALAR:
634 RETVAL = 1;
635 break;
636
637 default:
638 RETVAL = 0;
639 }
640 OUTPUT:
641 RETVAL
642
643 bool
644 want_boolean(uplevel)
645 I32 uplevel;
646 PREINIT:
647 oplist* l = ancestor_ops(uplevel, 0);
648 U16 i;
649 bool truebool = FALSE, pseudobool = FALSE;
650 CODE:
651 for(i=0; i < l->length; ++i) {
652 OP* o = l->ops[i].numop_op;
653 U16 n = l->ops[i].numop_num;
654 bool v = (OP_GIMME(o, -1) == G_VOID);
655
656 /* printf("%-8s %c %d\n", PL_op_name[o->op_type], (v ? 'v' : ' '), n); */
657
658 switch(o->op_type) {
659 case OP_NOT:
660 case OP_XOR:
661 truebool = TRUE;
662 break;
663
664 case OP_AND:
665 if (truebool || v)
666 truebool = TRUE;
667 else
668 pseudobool = (pseudobool || n == 0);
669 break;
670
671 case OP_OR:
672 if (truebool || v)
673 truebool = TRUE;
674 else
675 truebool = FALSE;
676 break;
677
678 case OP_COND_EXPR:
679 truebool = (truebool || n == 0);
680 break;
681
682 case OP_NULL:
683 break;
684
685 default:
686 truebool = FALSE;
687 pseudobool = FALSE;
688 }
689 }
690 free(l);
691 RETVAL = truebool || pseudobool;
692 OUTPUT:
693 RETVAL
694
695 SV*
696 want_assign(uplevel)
697 U32 uplevel;
698 PREINIT:
699 AV* r;
700 OP* returnop;
701 oplist* os = ancestor_ops(uplevel, &returnop);
702 numop* lno = os ? lastnumop(os) : (numop*)0;
703 OPCODE type;
704 PPCODE:
705 if (lno) type = lno->numop_op->op_type;
706 if (lno && (type == OP_AASSIGN || type == OP_SASSIGN) && lno->numop_num == 1)
707 if (type == OP_AASSIGN) {
708 I32 lhs_count = count_list(cBINOPx(lno->numop_op)->op_last, returnop);
709 if (lhs_count == 0) r = newAV();
710 else {
711 r = copy_rvals(uplevel, lhs_count-1);
712 }
713 }
714 else r = copy_rval(uplevel);
715
716 else {
717 /* Not an assignment */
718 r = Nullav;
719 }
720
721 if (os) free(os);
722 EXTEND(SP, 1);
723 PUSHs(r ? sv_2mortal(newRV_noinc((SV*) r)) : &PL_sv_undef);
724
725 void
726 double_return(...)
727 PREINIT:
728 PERL_CONTEXT *ourcx, *cx;
729 PPCODE:
730 ourcx = upcontext(aTHX_ 0);
731 cx = upcontext(aTHX_ 1);
732 if (!cx)
733 Perl_croak(aTHX_ "Can't return outside a subroutine");
734 #ifdef POPBLOCK
735 ourcx->cx_type = CXt_NULL;
736 CvDEPTH(ourcx->blk_sub.cv)--;
737 # if HAS_RETSTACK
738 if (PL_retstack_ix > 0)
739 --PL_retstack_ix;
740 # endif
741 #else
742 /* In 5.23.8 or later, PL_curpad is saved in the context stack and
743 * restored by cx_popsub(), rather than being saved on the savestack
744 * and restored by LEAVE; so just CXt_NULLing the parent sub
745 * skips the PL_curpad restore and so everything done during the
746 * second part of the return will have the wrong PL_curpad.
747 * So instead, fix up the first return so that it thinks the
748 * op to continue at is iteself, forcing it to do a double return.
749 */
750 assert(PL_op->op_next->op_type == OP_RETURN);
751 /* force the op following the 'return' to be 'return' again */
752 ourcx->blk_sub.retop = PL_op->op_next;
753 assert(PL_markstack + ourcx->blk_oldmarksp + 1 == PL_markstack_ptr);
754 ourcx->blk_oldmarksp++;
755 ourcx->blk_gimme = cx->blk_gimme;
756 #endif
757
758 return;
759
760 SV *
761 disarm_temp(sv)
762 SV *sv;
763 CODE:
764 RETVAL = sv_2mortal(SvREFCNT_inc(SvREFCNT_inc(sv)));
765 OUTPUT:
766 RETVAL
767