in reply to Local for lexicals

It appears to be possible by messing with the opcode tree (based on what Data::Alias is capable of doing), but it's not possible in Perl.

Update: The following would also do if you could localise through a reference: 

sub lambda {
    my $f = $_[1];
    my $xr = \$_[0];
    return sub {
        local $$xr = $_[0];
        return $f->();
    }
}

[download]

So how about emulating local using alias: 

use Data::Alias       qw( alias );
use Object::Destroyer qw( );

sub lambda {
    my $f = $_[1];
    my $xr = \$_[0];
    return sub {
        alias my $temp = $$xr;
        alias $$xr = $_[0];
        my $sentry = Object::Destroyer->new(
            sub { alias $$xr = $temp; }
        );
        return $f->();
    }
}

[download]

This should work whether $x is a lexical or a package variable. This should work whether $x is tied or not. In fact, it works better than local with tied variables and creates an alias unlike local.

Untested.

Replies are listed 'Best First'.
Re^2: Local for lexicals
by ikegami (Patriarch) on Aug 12, 2009 at 16:56 UTC

    Tested the parent: Doesn't work. (Specifically, my $xr = \$x; alias $$xr = $_[0]; isn't equivalent to alias $x = $_[0]; as I had hoped.) The best I can get using an arbitrary variable is: 

    package Lambda;

use strict;
use warnings;

use Exporter qw( import );

our @EXPORT = qw( lambda );

sub _on_destroy(&@) {
    return bless([@_], 'Lambda::OnDestroy');
}

sub Lambda::OnDestroy::DESTROY {
    my ($self) = @_;
    my ($cb, @args) = @$self;
    $cb->(@args) if $cb;
}

sub lambda {
    my $xr = \$_[0];
    my $f  =  $_[1];
    return sub {
        my $temp = $$xr;
        $$xr = $_[0];
        my $sentry = _on_destroy { $$xr = $temp; };
        return $f->();
    }
}

1;

    [download]
    use strict;
use warnings;

use Test::More tests => 10;

BEGIN { use_ok('Lambda') }

{
   my $x;
   my $f = lambda($x => sub { $x });
   is($f->('lex'), 'lex', 'lex1');
   is($f->('LEX'), 'LEX', 'lex2');
   is($x, undef, 'lex restore');
}

{
   local our $x;
   my $f = lambda($x => sub { $x });
   is($f->('pkg'), 'pkg', 'pkg1');
   is($f->('PKG'), 'PKG', 'pkg2');
   is($x, undef, 'pkg restore');
}

{
    my $f = do {
        my $x;
        lambda($x => sub { $x })
    };

    is($f->('out of scope'), 'out of scope', 'out of scope');
}

{
   my $y = 'test';
   my $x;
   lambda($x => sub { $x = uc($x) })->($y);
   is($y, 'TEST', 'alias');
}

{
    package Unfetchable;
    use Tie::Scalar qw( );
    our @ISA = 'Tie::StdScalar';
    sub FETCH { }
}

{
   tie my $x, 'Unfetchable';
   my $f = lambda($x => sub { $x });
   is($f->('test'), 'test', 'tied');
}

    [download]
    1..10
ok 1 - use Lambda;
ok 2 - lex1
ok 3 - lex2
ok 4 - lex restore
ok 5 - pkg1
ok 6 - pkg2
ok 7 - pkg restore
ok 8 - out of scope
not ok 9 - alias
#   Failed test 'alias'
#   at a.pl line 37.
#          got: 'test'
#     expected: 'TEST'
not ok 10 - tied
#   Failed test 'tied'
#   at a.pl line 50.
#          got: undef
#     expected: 'test'
# Looks like you failed 2 tests of 10.

    [download]

    Now, if you were ok with using $_ instead of using an arbitrary variable ($x), that's another story. 

    package Lambda;

use strict;
use warnings;

use Exporter qw( import );

our @EXPORT = qw( lambda );

sub lambda(&) {
    my ($f) = @_;
    return sub {
        return $f->() for $_[0];
    }
}

1;

    [download]
    use strict;
use warnings;

use Test::More tests => 6;

BEGIN { use_ok('Lambda') }

{
   local $_;
   my $f = lambda { $_ };
   is($f->('test'), 'test', 'test1');
   is($f->('TEST'), 'TEST', 'test2');
   is($_, undef, 'restore');
}

{
   my $y = 'test';
   ( lambda { $_ = uc($_) } )->($y);
   is($y, 'TEST', 'alias');
}

{
    package Unfetchable;
    use Tie::Scalar qw( );
    our @ISA = 'Tie::StdScalar';
    sub FETCH { }
}

{
   local $_;
   tie $_, 'Unfetchable';
   my $f = lambda { $_ };
   is($f->('test'), 'test', 'tied');
}

    [download]
    1..6
ok 1 - use Lambda;
ok 2 - test1
ok 3 - test2
ok 4 - restore
ok 5 - alias
ok 6 - tied

    [download]
[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom