Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 117 lines (91 sloc) 3.022 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
use v6;

use Test;

plan 14;

=begin description

Testing lvalue-returning subroutines

=end description

# L<S06/"Lvalue subroutines">

# Lvalue subrefs
{
  my $var1 = 1;
  my $var2 = 2;

  my $lastvar = sub () is rw { $var2 };
  my $prevvar = sub () is rw { $lastvar() };

  $lastvar() = 3;
  is $var2, 3, "lvalue subroutine references work (simple)";

  $prevvar() = 4;
  is $var2, 4, "lvalue subroutine references work (nested)";
}

{
  my $var = 42;
  my $notlvalue = sub () { $var };

  #?pugs 2 todo 'bug'
  #?niecza 2 todo 'rw checking'
  dies_ok { $notlvalue() = 23 },
    "assigning to non-rw subrefs should die";
  is $var, 42,
    "assigning to non-rw subrefs shouldn't modify the original variable";
}

  my $var1 = 1;
  my $var2 = 2;

  sub lastvar is rw { $var2; }
  sub prevvar is rw { lastvar(); }

  lastvar() = 3;
  is($var2, 3, "lvalue subroutines work (simple)");

  prevvar() = 4;
  is($var2, 4, "lvalue subroutines work (nested)");

{
  my $var = 42;

  # S6 says that lvalue subroutines are marked out by 'is rw'
  sub notlvalue { $var; } # without rw

  #?niecza 2 todo 'rw checking'
  dies_ok { notlvalue() = 5 },
    "assigning to non-rw subs should die";
  is $var, 42,
    "assigning to non-rw subs shouldn't modify the original variable";
}

sub check ($passwd) { $passwd eq "fish"; };

sub checklastval ($passwd) is rw {
    Proxy.new(
        FETCH => sub ($self) { #OK not used
                lastvar();
            },
        STORE => sub ($self, $val) { #OK not used
                die "wrong password" unless check($passwd);
                lastvar() = $val;
            }
        );
};

#?rakudo skip 'hangs, probably due to [RT #114134]'
dies_ok {checklastval("octopus") = 10 }, 'checklastval STORE can die';

# Above test may well die for the wrong reason, if the Proxy stuff didn't
# parse OK, it will complain that it couldn't find the desired subroutine
#?rakudo skip 'maximum recursion depth exceeded'
is((try { checklastval("fish") = 12 }), 12, 'proxy lvalue subroutine STORE works');
#?rakudo emit #
my $resultval = checklastval("fish");
#?rakudo skip 'maximum recursion depth exceeded'
is($resultval, 12, 'proxy lvalue subroutine FETCH works');

my $realvar = "foo";
sub proxyvar ($prefix) is rw {
    Proxy.new(
        FETCH => method () { $prefix ~ lc($realvar) },
        STORE => method ($val) { lc($realvar = $val) },
    );
}
is proxyvar("PRE"), 'PREfoo', 'proxy lvalue subroutine FETCH works';
# Return value of assignments of Proxy objects is decided now.
# See thread "Assigning Proxy objects" on p6l,
# L<"http://www.nntp.perl.org/group/perl.perl6.language/21838">.
# Quoting Larry:
# The intention is that lvalue subs behave in all respects as if they
# were variables.  So consider what
#
# say $nonproxy = 40;
#
# should do.
is (proxyvar("PRE") = "BAR"), 'PREbar',
    'proxy lvalue subroutine STORE works and returns the correct value';
#?pugs todo 'feature'
is $realvar, 'BAR', 'variable was modified';

# vim: ft=perl6
Something went wrong with that request. Please try again.