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

Question

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

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, но все-таки получить надлежащее лечение от while (<...>) идиомы? Нецелесообразно явно преобразовывать все в while (defined($_=<...>)) во все устаревший код.

Answer 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>) {...} набор $_. Я не знаю, есть ли способ ограничить магию только while петлями.

Answer 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"