perl：如何让“警告”认为我们从文件中读取？

Question

我有一个函数（string++ 的变体）：

sub inc
{
  $_[0] =~ /^(.*?)([0-9]+)$/;
  my ($a,$b)=($1,$2);
  die "cannot increment [$_[0]]" unless defined $b;
  warn "increment overflow [$_[0]]" if length(++$b) != length($2);
  $a.$b;
}

在脚本的许多地方，不同的数据（有时来自文件，有时来自数据库）上调用它。

当我从文件句柄中读取时，die 和 warn 会打印这样的消息：

cannot increment [abc] at script line 5, <filehandle> line 123.

否则会打印一条较短的消息：

cannot increment [abc] at script line 5.

当我从数据库中读取数据时，我希望收到这样的消息：

cannot increment [abc] at script line 5, <SELECT...> line 123.

有可能吗？

设置行号非常简单：可以对$. 进行赋值。但是如何设置“文件句柄”部分并使其可见？

我找到了这样的解决方法：

my $fh = "SELECT...";
open $fh, "/dev/null";
<$fh>;

但它有点长，而且它确实打开了一个文件。

Answer 1

出现在warn 和die 消息中的文件句柄信息仅在调用<HANDLE>、readline、tell、eof 和seek 之后设置。例如，当您使用 DBI 从数据库中获取数据时，您不会调用其中任何一个，因此您必须自己传递额外的数据。

一种方法是编写一个自定义异常类，将其字符串化为您想要的文本：

package MyException;

use strict;
use warnings 'all';
use v5.18.0;

use overload '""' => \&as_string;

sub new {
    my ($self, $message, $src, $src_line) = @_;
    my ($package, $file, $line) = caller;

    if (! defined $src && ref ${^LAST_FH} eq 'GLOB') {
        $src = *${^LAST_FH}{NAME};
        $src_line = $.;
    }

    bless { message  => $message,
            file     => $file,
            line     => $line,
            src      => $src,
            src_line => $src_line }, $self;
}

sub as_string {
    my ($self) = @_;

    my $message = "$self->{message} at $self->{file} line $self->{line}";

    if (defined $self->{src} && defined $self->{src_line}) {
        $message .= ", <$self->{src}> line $self->{src_line}";
    }

    $message .= "\n";
}

1;

请注意，需要 Perl 5.18.0 或更高版本才能使用只读的 ${^LAST_FH} 变量，该变量包含对上次读取文件句柄的引用。

---

这是从文件中读取时的使用方法：

use strict;
use warnings 'all';

use MyException;

while (<DATA>) {
    warn MyException->new('foo'); # equivalent to warn 'foo'
}

__DATA__
first
second

输出：

foo at ./myscript line 9, <DATA> line 1
foo at ./myscript line 9, <DATA> line 2

---

以下是从数据库中获取记录时的使用方法：

use strict;
use warnings 'all';

use DBI;
use MyException;

my $dbh = DBI->connect('dbi:mysql:test', 'user', 'pass', {
    RaiseError => 1
});

my $sql = 'SELECT * FROM test';
my $sth = $dbh->prepare($sql);
$sth->execute;

my $count;
while (my $row = $sth->fetch) {
    warn MyException->new('foo', $sql, ++$count);
}

输出：

foo at ./myscript line 19, <SELECT * FROM test> line 1
foo at ./myscript line 19, <SELECT * FROM test> line 2

（很遗憾，DBI 并没有提供获取目前已经获取的行数的方法，所以你必须自己数数。）

---

由于您尝试从子例程内部warn 或die，您必须做更多的工作。 die 最简单的方法是使用 eval 从您的子例程中捕获异常并重新抛出它们：

my $count = 1;
while (my $row = $sth->fetch) {
    eval {
        inc($row[0]);
    };

    if ($@ =~ /^(cannot increment \[.*?\])/) {
        die MyException->new($1, $sql, $count);
    }
    elsif ($@) {
        die $@;
    }

    $count++;
}

您可以通过创建__WARN__ 处理程序以类似的方式处理警告：

{
    my $count = 1;

    local $SIG{__WARN__} = sub {
        if ($_[0] =~ /^(increment overflow \[.*?\])/) {
            warn MyException->new($1, $sql, $count);
        }
        else {
            warn @_;
        }
    };

    while (my $row = $sth->fetch) {
        inc($row[0]);
        $count++;
    }
}

Answer 2

您可能更喜欢inc 子例程的这种实现。您自己使用保留变量$a 和$b，以及保存和检索字符串的初始非数字部分

请注意，STDERR 输出与 STDOUT 不同步，因此警告会过早出现在聚合文本中。实际上，仅当传递的字符串具有全为 9 的数字字段时才会发出警告

use strict;
use warnings 'all';

my $s = 'ZZ90';

for ( 1 .. 20 ) {
    $s = inc_str($s);
    print $s, "\n";
}

sub inc_str {

    my ($str) = @_;

    $str =~ s{([0-9]+)$}{
        my $num = $1;
        warn "Increment overflow [$str]"  unless $num =~ /[^9]/;
        sprintf '%0*d', length($num), $num+1;
    }e or die "Cannot increment [$str]";

    return $str;
}

输出

Increment overflow [ZZ99] at E:\Perl\source\inc_str.pl line 18.
ZZ91
ZZ92
ZZ93
ZZ94
ZZ95
ZZ96
ZZ97
ZZ98
ZZ99
ZZ100
ZZ101
ZZ102
ZZ103
ZZ104
ZZ105
ZZ106
ZZ107
ZZ108
ZZ109
ZZ110