Как я могу получить автоматическое присвоение '$ _' с посмеянной функцией readline?

Perl имеет специальную обработку для функции readline (и эквивалентного оператора ввода/вывода <>), где он обрабатывает выражения

while (<HANDLE>)
while (readline(HANDLE))

как эквивалент

while (defined($_ = <HANDLE>))

ср.

$ perl -MO=Deparse -e 'f($_) while <>'
f($_) while defined($_ = <ARGV>);      <--- implicitly sets $_
-e syntax OK

Но это автоматическое присваивание не происходит, если вы увлекаете функцию readline:

$ perl -MO=Deparse -e 'BEGIN {
> *CORE::GLOBAL::readline = sub { }
> }
> f($_) while <>'
sub BEGIN {
    *CORE::GLOBAL::readline = sub {
    };
}
f($_) while readline(ARGV);            <--- doesn't set $_ !
-e syntax OK

Конечно, это заставит пользовательскую функцию readline работать некорректно для большого количества устаревшего кода. Вывод, если этот код "foo" с блоком BEGIN и "bar" без него, но я хочу, чтобы он был "bar".

use warnings;
BEGIN { *CORE::GLOBAL::readline = \&uc_readline; }
sub uc_readline {
    my $line = CORE::readline(shift || *ARGV);
    return uc $line if defined $line;
    return;
}
($_, $bar) = ("foo\n", "bar\n");
open X, '<', \$bar;
while (<X>) {
  print $_;           # want and expect to see  "BAR\n"
}

Какие параметры у меня есть, чтобы захватить функцию readline, но все же получить правильное обращение к idiom while (<...>)? Нецелесообразно явно преобразовывать все в while (defined($_=<...>)) во все устаревший код.

Ответы

Ответ 1

Это довольно грязный взлом, использующий перегрузку для обнаружения булевского контекста, но, похоже, это трюк. Это, конечно, требует больше тестирования, чем я дал, прежде чем использовать это решение в рабочей среде:

use warnings;
BEGIN { *CORE::GLOBAL::readline = \&uc_readline; }
sub uc_readline {
    my $line = CORE::readline(shift || *ARGV);
    return Readline->new(uc $line) if defined $line;
    return;
}

{package Readline;
    sub new {shift; bless [@_]}
    use overload fallback => 1,
        'bool' => sub {defined($_ = $_[0][0])},  # set $_ in bool context
        '""'   => sub {$_[0][0]},
        '+0'   => sub {$_[0][0]};
}

my $bar;
($_, $bar) = ("foo\n", "bar\n");
open X, '<', \$bar;
while (<X>) {
  print $_;           # want and expect to see  "BAR\n"
}

который печатает:

BAR

Это также сделает if (<X>) {...} set $_. Я не знаю, есть ли способ ограничить магию только контурами while.

Ответ 2

Этот код:

use warnings;
BEGIN { *CORE::GLOBAL::readline = \&uc_readline; }
sub uc_readline {
    my $line = CORE::readline(shift || *ARGV);
    return unless defined $line;
    $line = uc $line;
    $_ = $line;
    return $line;
}
($_, $bar) = ("foo\n", "bar\n");
open X, '<', \$bar;
while (<X>) {
  print $_;           # want and expect to see  "BAR\n"
}
print "$_";           # prints "BAR" instad of "foo"

делает почти правильную вещь, но $_ не локализуется, поэтому после цикла значение $_ устанавливается на последнее значение, считанное из дескриптора файла. Добавление Scope:: Upper в микс исправляет:

use warnings;
use Scope::Upper qw/localize SCOPE/;
BEGIN { *CORE::GLOBAL::readline = \&uc_readline; }
sub uc_readline {
    my $line = CORE::readline(shift || *ARGV);
    return unless defined $line;
    $line = uc $line;
    local $_ = $line;
    # localize $_ in the scope of the while
    localize *main::_, \$line, SCOPE(1);
    return $line;
}
($_, $bar) = ("foo\n", "bar\n");
open X, '<', \$bar;
while (<X>) {
  print "$_";           # want and expect to see  "BAR\n"
}
print "$_";             # will print 'foo', not "BAR"