t/op/decl-refs.t

   1 BEGIN {
   2     chdir 't';
   3     require './test.pl';
   4     set_up_inc('../lib');
   5 }
   6
   7 plan 402;
   8
   9 for my $decl (qw< my CORE::state our local >) {
  10     for my $funny (qw< $ @ % >) {
  11         # Test three syntaxes with each declarator/funny char combination:
  12         #     my \$foo    my(\$foo)    my\($foo)    for my \$foo
  13
  14         for my $code("$decl \\${funny}x", "$decl\(\\${funny}x\)",
  15                      "$decl\\\(${funny}x\)",
  16                      "for $decl \\${funny}x (\\${funny}y) {}") {
  17           SKIP: {
  18             skip "for local is illegal", 3 if $code =~ /^for local/;
  19             eval $code;
  20             like
  21                 $@,
  22                 qr/^The experimental declared_refs feature is not enabled/,
  23                "$code error when feature is disabled";
  24
  25             use feature 'declared_refs';
  26
  27             my($w,$c);
  28             local $SIG{__WARN__} = sub { $c++; $w = shift };
  29             eval $code;
  30             is $c, 1, "one warning from $code";
  31             like $w, qr/^Declaring references is experimental at /,
  32                 "experimental warning for $code";
  33           }
  34         }
  35     }
  36 }
  37
  38 use feature 'declared_refs', 'state';
  39 no warnings 'experimental::declared_refs';
  40
  41 for $decl ('my', 'state', 'our', 'local') {
  42 for $sigl ('$', '@', '%') {
  43     # The weird code that follows uses ~ as a sigil placeholder and MY
  44     # as a declarator placeholder.
  45     my $code = '#line ' . (__LINE__+1) . ' ' . __FILE__ . "\n" . <<'END';
  46     my $ret = MY \~a;
  47     is $ret, \~a, 'MY \$a returns ref to $a';
  48     isnt $ret, \~::a, 'MY \$a ret val is not pkg var';
  49     my @ret = MY \(~b, ~c);
  50     is "@ret", \~b." ".\~c, 'MY \(~b, ~c) returns correct refs';
  51     isnt $ret[0], \~::b, 'first retval of MY \(~b, ~c) is not pkg var';
  52     isnt $ret[1], \~::c, '2nd retval of MY \(~b, ~c) is not pkg var';
  53     @ret = MY (\(~d, ~e));
  54     is "@ret", \~d." ".\~e, 'MY (\(~d, ~e)) returns correct refs';
  55     isnt $ret[0], \~::d, 'first retval of MY (\(~d, ~e)) is not pkg var';
  56     isnt $ret[1], \~::e, '2nd retval of MY (\(~d, ~e)) is not pkg var';
  57     @ret = \MY (\~f, ~g);
  58     is ${$ret[0]}, \~f, 'first retval of MY (\~f, ~g) is \~f';
  59     isnt ${$ret[0]}, \~::f, 'first retval of MY (\~f, ~g) is not \~::f';
  60     is $ret[1], \~g, '2nd retval of MY (\~f, ~g) is ~g';
  61     isnt $ret[1], \~::g, '2nd retval of MY (\~f, ~g) is not ~::g';
  62     *MODIFY_SCALAR_ATTRIBUTES = sub {
  63         is @_, 3, 'MY \~h : risible  calls handler with right no. of args';
  64         is $_[2], 'risible', 'correct attr passed by MY \~h : risible';
  65         return;
  66     };
  67     SKIP : {
  68         unless ('MY' eq 'local') {
  69             skip_if_miniperl "No attributes on miniperl", 2;
  70             eval 'MY \~h : risible' or die $@ unless 'MY' eq 'local';
  71         }
  72     }
  73     eval 'MY \~a ** 1';
  74     like $@,
  75         qr/^Can't (?:declare|modify) exponentiation \(\*\*\) in "?MY"? at/,
  76        'comp error for MY \~a ** 1';
  77     $ret = MY \\~i;
  78     is $$ret, \~i, 'retval of MY \\~i is ref to ref to ~i';
  79     $ret = MY \\~i;
  80     isnt $$ret, \~::i, 'retval of MY \\~i is ref to ref to ~::i';
  81     $ret = MY (\\~i);
  82     is $$ret, \~i, 'retval of MY (\\~i) is ref to ref to ~i';
  83     $ret = MY (\\~i);
  84     isnt $$ret, \~::i, 'retval of MY (\\~i) is ref to ref to ~::i';
  85     *MODIFY_SCALAR_ATTRIBUTES = sub {
  86         is @_, 3, 'MY (\~h) : bumpy  calls handler with right no. of args';
  87         is $_[2], 'bumpy', 'correct attr passed by MY (\~h) : bumpy';
  88         return;
  89     };
  90     SKIP : {
  91         unless ('MY' eq 'local') {
  92             skip_if_miniperl "No attributes on miniperl", 2;
  93             eval 'MY (\~h) : bumpy' or die $@;
  94         }
  95     }
  96     1;
  97 END
  98     $code =~ s/MY/$decl/g;
  99     $code =~ s/~/$sigl/g;
 100     $code =~ s/MODIFY_\KSCALAR/$sigl eq '@' ? "ARRAY" : "HASH"/eggnog
 101         if $sigl ne '$';
 102     if ($decl =~ /^(?:our|local)\z/) {
 103         $code =~ s/is ?no?t/is/g; # tests for package vars
 104     }
 105     eval $code or die $@;
 106 }}
 107
 108 use feature 'refaliasing'; no warnings "experimental::refaliasing";
 109 for $decl ('my', 'state', 'our') {
 110 for $sigl ('$', '@', '%') {
 111     my $code = '#line ' . (__LINE__+1) . ' ' . __FILE__ . "\n" . <<'ENE';
 112     for MY \~x (\~::y) {
 113         is \~x, \~::y, '\~x aliased by for MY \~x';
 114         isnt \~x, \~::x, '\~x is not equivalent to \~::x';
 115     }
 116     1;
 117 ENE
 118     $code =~ s/MY/$decl/g;
 119     $code =~ s/~/$sigl/g;
 120     $code =~ s/is ?no?t/is/g if $decl eq 'our';
 121     eval $code or die $@;
 122 }}