perl - How can I still get automatic assignment to '$_' with a mocked 'readline' function?

Question

Perl has some special handling for the readline function (and the equivalent <> I/O operator) where it treats the expressions

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

as equivalent to

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

cf.

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

But this automatic assignment doesn't seem to happen if you hijack the readline function:

$ 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

Of course, this will make the custom readline function work incorrectly for a lot of legacy code. The output of this code is "foo" with the BEGIN block and "bar" without it, but I want it to be "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
", "bar
");
open X, '<', $bar;
while (<X>) {
  print $_;           # want and expect to see  "BAR
"
}

What options do I have to hijack the readline function but still get the proper treatment of the while (<...>) idiom? It's not practical to explicitly convert everything to while (defined($_=<...>)) in all the legacy code.

Answer 1

This is a fairly dirty hack using overloading to detect boolean context, but it seems to do the trick. It certainly needs more testing than I have given it before using this solution in a production environment:

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
", "bar
");
open X, '<', $bar;
while (<X>) {
  print $_;           # want and expect to see  "BAR
"
}

which prints:

BAR

This will also make if (<X>) {...} set $_. I don't know if there is a way to limit the magic to only while loops.