|
| 1 | +#!./perl |
| 2 | + |
| 3 | +BEGIN { |
| 4 | + chdir 't' if -d 't'; |
| 5 | + require "./test.pl"; |
| 6 | + set_up_inc( qw(. ../lib) ); |
| 7 | + require './charset_tools.pl'; |
| 8 | +} |
| 9 | + |
| 10 | +use warnings; |
| 11 | +use strict; |
| 12 | +use Config; |
| 13 | +#plan tests => 'no_plan'; # yet |
| 14 | +plan tests => 11; |
| 15 | +our $TODO; |
| 16 | + |
| 17 | +# Excerpts from 'perldoc -f goto' as of perl-5.40.1 (Aug 2025) |
| 18 | +# |
| 19 | +# The "goto &NAME" form is quite different from the other forms of |
| 20 | +# "goto". In fact, it isn't a goto in the normal sense at all, and |
| 21 | +# doesn't have the stigma associated with other gotos. Instead, it |
| 22 | +# exits the current subroutine (losing any changes set by "local") |
| 23 | +# and immediately calls in its place the named subroutine using |
| 24 | +# the current value of @_. This is used by "AUTOLOAD" subroutines |
| 25 | +# that wish to load another subroutine and then pretend that the |
| 26 | +# other subroutine had been called in the first place (except that |
| 27 | +# any modifications to @_ in the current subroutine are propagated |
| 28 | +# to the other subroutine.) After the "goto", not even "caller" |
| 29 | +# will be able to tell that this routine was called first. |
| 30 | +# |
| 31 | +# NAME needn't be the name of a subroutine; it can be a scalar |
| 32 | +# variable containing a code reference or a block that evaluates |
| 33 | +# to a code reference. |
| 34 | + |
| 35 | +# but earlier, we see: |
| 36 | +# |
| 37 | +# The "goto EXPR" form expects to evaluate "EXPR" to a code |
| 38 | +# reference or a label name. If it evaluates to a code reference, |
| 39 | +# it will be handled like "goto &NAME", below. This is especially |
| 40 | +# useful for implementing tail recursion via "goto __SUB__". |
| 41 | +# |
| 42 | +# The purpose this test file is to consolidate all tests formerly found in |
| 43 | +# t/op/goto.t that exercise the "goto &NAME" functionality. These should be |
| 44 | +# outside the scope of the current (5.42) deprecation of aspects of "goto |
| 45 | +# LABEL" (GH #23618) now scheduled for 5.44. If we have done that |
| 46 | +# successfully, then during the 5.43 dev cycle we shouldn't see any instances |
| 47 | +# of this warning (or of its fatalization replacement). |
| 48 | + |
| 49 | +my $deprecated = 0; |
| 50 | + |
| 51 | +local $SIG{__WARN__} = sub { |
| 52 | + if ($_[0] =~ m/jump into a construct.*?, and will become fatal in Perl 5\.42/) { |
| 53 | + $deprecated++; |
| 54 | + } |
| 55 | + else { warn $_[0] } |
| 56 | +}; |
| 57 | + |
| 58 | +our $foo; |
| 59 | + |
| 60 | +# v5.31.3-198-gd2cd363728 broke this. goto &XS_sub wasn't restoring |
| 61 | +# cx->blk_sub.old_cxsubix. Would panic in pp_return |
| 62 | + |
| 63 | +{ |
| 64 | + # isa is an XS sub |
| 65 | + sub g198 { goto &UNIVERSAL::isa } |
| 66 | + |
| 67 | + sub f198 { |
| 68 | + g198([], 1 ); |
| 69 | + { |
| 70 | + return 1; |
| 71 | + } |
| 72 | + } |
| 73 | + eval { f198(); }; |
| 74 | + is $@, "", "v5.31.3-198-gd2cd363728"; |
| 75 | +} |
| 76 | + |
| 77 | +# GH #19188 |
| 78 | +# |
| 79 | +# 'goto &xs_sub' should provide the correct caller context to an XS sub |
| 80 | + |
| 81 | +SKIP: |
| 82 | +{ |
| 83 | + skip "No XS::APItest in miniperl", 6 if is_miniperl(); |
| 84 | + skip "No XS::APItest in static perl", 6 if not $Config{usedl}; |
| 85 | + |
| 86 | + require XS::APItest; |
| 87 | + |
| 88 | + sub f_19188 { goto &XS::APItest::gimme } |
| 89 | + sub g_19188{ f_19188(); } |
| 90 | + my ($s, @a); |
| 91 | + |
| 92 | + f_19188(); |
| 93 | + is ($XS::APItest::GIMME_V, 1, 'xs_goto void (#19188)'); |
| 94 | + |
| 95 | + $s = f_19188(); |
| 96 | + is ($XS::APItest::GIMME_V, 2, 'xs_goto scalar (#19188)'); |
| 97 | + |
| 98 | + @a = f_19188(); |
| 99 | + is ($XS::APItest::GIMME_V, 3, 'xs_goto list (#19188)'); |
| 100 | + |
| 101 | + g_19188(); |
| 102 | + is ($XS::APItest::GIMME_V, 1, 'xs_goto indirect void (#19188)'); |
| 103 | + |
| 104 | + $s = g_19188(); |
| 105 | + is ($XS::APItest::GIMME_V, 2, 'xs_goto indirect scalar (#19188)'); |
| 106 | + |
| 107 | + @a = g_19188(); |
| 108 | + is ($XS::APItest::GIMME_V, 3, 'xs_goto indirect list (#19188)'); |
| 109 | +} |
| 110 | + |
| 111 | +# GH #19936 segfault on goto &xs_sub when calling sub is replaced |
| 112 | +SKIP: |
| 113 | +{ |
| 114 | + skip "No XS::APItest in miniperl", 2 if is_miniperl(); |
| 115 | + skip "No XS::APItest in static perl", 2 if not $Config{usedl}; |
| 116 | + |
| 117 | + # utf8::is_utf8() is just an example of an XS sub |
| 118 | + sub foo_19936 { *foo_19936 = {}; goto &utf8::is_utf8 } |
| 119 | + ok(foo_19936("\x{100}"), "GH #19936 utf8 XS call"); |
| 120 | + |
| 121 | + # the gimme XS function accesses PL_op, which was null before the fix |
| 122 | + sub bar_19936 { *bar_19936 = {}; goto &XS::APItest::gimme } |
| 123 | + my @a = bar_19936(); |
| 124 | + is($XS::APItest::GIMME_V, 3, "GH #19936 gimme XS call"); |
| 125 | +} |
| 126 | + |
| 127 | +# goto &sub could leave AvARRAY() slots of @_ uninitialised. |
| 128 | + |
| 129 | +{ |
| 130 | + my $i = 0; |
| 131 | + my $f = sub { |
| 132 | + goto &{ sub {} } unless $i++; |
| 133 | + $_[1] = 1; # create a hole |
| 134 | + # accessing $_[0] is more for valgrind/ASAN to chew on rather than |
| 135 | + # we're too concerned about its value. Or it might give "bizarre |
| 136 | + # copy" errors. |
| 137 | + is($_[0], undef, "goto and AvARRAY"); |
| 138 | + }; |
| 139 | + |
| 140 | + # first call does goto, which gives &$f a fresh AV in pad[0], |
| 141 | + # which formerly allocated an AvARRAY for it, but didn't zero it |
| 142 | + $f->(); |
| 143 | + # second call creates hole in @_ which used to to be a wild SV pointer |
| 144 | + $f->(); |
| 145 | +} |
| 146 | + |
| 147 | + |
| 148 | +# Final test: ensure that we saw no deprecation warnings |
| 149 | +# ... but rework this to count fatalizations once work is more developed |
| 150 | + |
| 151 | +is($deprecated, 0, "No 'jump into a construct' warnings seen"); |
0 commit comments