如何通过 last/next 强制退出 perl 子例程/关闭以使程序自动失败？

Question

鉴于以下功能齐全的 perl 脚本和模块：

tx_exec.pl :

#!/usr/bin/perl

use strict; # make sure $PWD is in your PERL5LIB
# no warnings!

use tx_exec qw(tx_exec);

tx_exec ("normal", sub { return "foobar"; });
tx_exec ("die", sub { die "barbaz\n"; });
tx_exec ("last", sub { last; });
tx_exec ("next", sub { next; });

tx_exec.pm :

package tx_exec;

use strict;
use warnings;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(tx_exec);

my $MAX_TRIES = 3;

sub tx_exec {
    my ($desc, $sub, $args) = @_;
    print "\ntx_exec($desc):\n";
    my $try = 0;
    while (1) {
        $try++;
        my $sub_ret;
        my $ok = eval {
            # start transaction
            $sub_ret = $sub->($args);
            # commit transaction
            1;
        };

        unless ($ok) {
            print "failed with error: $@";
            # rollback transaction
            if ($try >= $MAX_TRIES) {
                print "failed after $try tries\n";
                return (undef, undef);
            }
            print "try #$try failed, retrying...\n";
            next;
        }
        # some cleanup
        print "returning (1, ".($sub_ret//'<undef>').")\n";
        return (1, $sub_ret);
    }
}

我得到以下输出：

$ ./tx_exec.pl
tx_exec(normal):
returning (1, foobar)

tx_exec(die):
failed with error: barbaz
try #1 failed, retrying...
failed with error: barbaz
try #2 failed, retrying...
failed with error: barbaz
failed after 3 tries

tx_exec(last):

tx_exec(next):
# infinite loop

我明白发生了什么，如果我在定义闭包的脚本中打开警告，我会收到警告。但是，在以下严格情况下，我是否可以强制程序自动/惯用地失败/死亡，当 next/last 将退出像这里这样的闭包子例程时：

• 的$sub传递存在是一个闭合，而不是一个简单的函数（在裸一个简单的函数模具next/last无论如何，这是微不足道的手柄）
• 库代码 ( tx_exec) 和客户端代码（调用它）位于不同的编译单元中，客户端不使用警告。

使用 perl 5.16.2（无法升级）。

这是一个github 要点，记录了迄今为止的所有方法：

• use warnings FATAL => qw(exiting) 对库代码没有影响
• local $SIG如果呼叫站点未FATAL => qw(exiting)启用警告，处理程序将不起作用
• 手动检测有效，但有点麻烦且到处都是（非本地化）
• ysth 使用裸块的方法效果最好，因为它捕获最后一个/下一个，完全本地化手动检测并保证不会出错（除了带有标签的下一个/最后一个，这更容易避免）。

Answer 1

由于缺乏 @ysth 参与编写答案，我正在编写迄今为止找到的最佳解决方案，灵感来自于他对问题的评论的第一次尝试。（如果他稍后发布，我会重新接受 ysth 的答案）。

调用evalcoderef 需要如下所示：

my $ok = eval {
    # start transaction
    my $proper_return = 0;
    {
        $sub_ret = $sub->($args);
        $proper_return = 1;
    }
    die "Usage of `next` or `last` disallowed in coderef passed to tx_exec\n" unless $proper_return;
    # commit transaction
    1;
};

裸块充当一个循环，它将立即在next或处退出last，因此无论我们是在裸块之后还是在其中，通过调用 coderef，我们都可以推断出 coderef 是否执行next/last并正确执行。

有关裸块语义及其交互的更多信息可以在此处next/last找到。

留给读者作为练习来处理redo上面代码中很少出现的情况。