t/op/postfixderef.t

   1 #!./perl
   2
   3 =head postfixderef
   4
   5 this file contains all dereferencing tests from ref.t but using postfix instead of prefix or circumfix syntax.
   6
   7 =cut
   8
   9
  10
  11 BEGIN {
  12     chdir 't' if -d 't';
  13     @INC = qw(. ../lib);
  14     require 'test.pl';
  15 }
  16
  17 use strict qw(refs subs);
  18
  19 plan(125);
  20
  21 {
  22     no warnings qw 'deprecated syntax';
  23     eval '[]->$*';
  24     like $@, qr/Can't call method/, '->$* outside of feature scope';
  25     eval '[]->@*';
  26     like $@, qr/syntax error/, '->@* outside of feature scope';
  27     eval '[]->@[1]';
  28     like $@, qr/syntax error/, '->@[ outside of feature scope';
  29     eval '[]->@{1}';
  30     like $@, qr/syntax error/, '->@{ outside of feature scope';
  31     eval '[]->%*';
  32     like $@, qr/syntax error/, '->%* outside of feature scope';
  33     eval '[]->%[1]';
  34     like $@, qr/syntax error/, '->%[ outside of feature scope';
  35     eval '[]->%{1}';
  36     like $@, qr/syntax error/, '->%{ outside of feature scope';
  37     eval '[]->&*';
  38     like $@, qr/syntax error/, '->&* outside of feature scope';
  39     eval '[]->**';
  40     like $@, qr/syntax error/, '->** outside of feature scope';
  41     eval '[]->*{';
  42     like $@, qr/syntax error/, '->*{ outside of feature scope';
  43 }
  44
  45 use feature 'postderef';
  46 no warnings 'experimental::postderef';
  47
  48 {
  49     no strict 'refs';
  50 # Test fake references.
  51
  52     $baz = "valid";
  53     $bar = 'baz';
  54     $foo = 'bar';
  55     # is ($$$foo, 'valid');
  56     is ($$foo->$*, 'valid');
  57     is ($foo->$*->$*, 'valid');
  58 }
  59
  60 # Test real references.
  61
  62 $FOO = \$BAR;
  63 $BAR = \$BAZ;
  64 $BAZ = "hit";
  65 # is ($$$FOO, 'hit');
  66 is ($$FOO ->$*, 'hit');
  67 is ($FOO-> $* ->$*, 'hit');
  68
  69 # Test references to real arrays.
  70
  71 my $test = curr_test();
  72 @ary = ($test,$test+1,$test+2,$test+3);
  73 $ref[0] = \@a;
  74 $ref[1] = \@b;
  75 $ref[2] = \@c;
  76 $ref[3] = \@d;
  77 for $i (3,1,2,0) {
  78     # push(@{$ref[$i]}, "ok $ary[$i]\n");
  79     push($ref[$i]-> @*, "ok $ary[$i]\n");
  80 }
  81 print @a;
  82 #print ${$ref[1]}[0];
  83 #print @{$ref[2]}[0];
  84 print $ref[1]->[0];
  85 print $ref[2]->@[0];
  86 {
  87     no strict 'refs';
  88     print 'd'->@*; # print @{'d'};
  89 }
  90 curr_test($test+4);
  91
  92 # Test references to references.
  93
  94 $refref = \\$x;
  95 $x = "Good";
  96 is ($refref->$*->$*, 'Good'); # is ($$$refref, 'Good');
  97
  98
  99 # Test nested anonymous lists.
 100
 101 $ref = [[],2,[3,4,5,]];
 102 is (scalar $ref->@*, 3); # is (scalar @$ref, 3);
 103 is ($ref->[1], 2); # is ($$ref[1], 2);
 104 # is (${$$ref[2]}[2], 5);
 105 is (${$ref->[2]}[2], 5);
 106 is ($ref->[2]->[2], 5);
 107 is ($ref->[2][2], 5);
 108 is  (scalar $ref->[0]->@*, 0); # is (scalar @{$$ref[0]}, 0);
 109
 110 is ($ref->[1], 2);
 111 is ($ref->[2]->[0], 3);
 112
 113 # Test references to hashes of references.
 114
 115 $refref = \%whatever;
 116 $refref->{"key"} = $ref;
 117 is ($refref->{"key"}->[2]->[0], 3);
 118 is ($refref->{"key"}->[2][0], 3);
 119 is ($refref->{"key"}[2]->[0], 3);
 120 is ($refref->{"key"}[2][0], 3);
 121
 122 # Test to see if anonymous subarrays spring into existence.
 123
 124 $spring[5]->[0] = 123;
 125 $spring[5]->[1] = 456;
 126 push($spring[5]->@*, 789); # push(@{$spring[5]}, 789);
 127 is (join(':',$spring[5]->@*), "123:456:789"); # is (join(':',@{$spring[5]}), "123:456:789");
 128
 129 # Test to see if anonymous subhashes spring into existence.
 130
 131 $spring2{"foo"}->@* = (1,2,3); # @{$spring2{"foo"}} = (1,2,3);
 132 $spring2{"foo"}->[3] = 4;
 133 is (join(':',$spring2{"foo"}->@*), "1:2:3:4");
 134
 135 # Test references to subroutines.
 136
 137 {
 138     my $called;
 139     sub mysub { $called++; }
 140     local $subref = \&mysub;
 141     &$subref;
 142     is ($called, 1);
 143     ok(eval '$subref->&*',"ampersand-star runs coderef: syntax");
 144     is ($called, 2);
 145     local *mysubalias;
 146     ok(eval q{'mysubalias'->** = 'mysub'->**->*{CODE}}, "glob access syntax");
 147     is ( eval 'mysubalias()', 2);
 148     is($called, 3);
 149
 150 }
 151 is ref eval {\&{""}}, "CODE", 'reference to &{""} [perl #94476]';
 152
 153 # Test references to return values of operators (TARGs/PADTMPs)
 154 {
 155     my @refs;
 156     for("a", "b") {
 157         push @refs, \"$_"
 158     }
 159     # is join(" ", map $$_, @refs), "a b", 'refgen+PADTMP';
 160     is join(" ", map $_->$*, @refs), "a b", 'refgen+PADTMP';
 161 }
 162
 163 $subrefref = \\&mysub2;
 164 is ($subrefref->$*->("GOOD"), "good"); # is ($$subrefref->("GOOD"), "good");
 165 sub mysub2 { lc shift }
 166
 167
 168 # Test anonymous hash syntax.
 169
 170 $anonhash = {};
 171 is (ref $anonhash, 'HASH');
 172 $anonhash2 = {FOO => 'BAR', ABC => 'XYZ',};
 173 is (join('', sort values $anonhash2->%*), 'BARXYZ'); # is (join('', sort values %$anonhash2), 'BARXYZ');
 174 $anonhash2->{23} = 'tt';@$anonhash2{skiddoo=> 99} = qw/rr nn/;
 175 is(join(':',$anonhash2->@{23 => skiddoo => 99}), 'tt:rr:nn', 'pf hash slice');
 176
 177 # test immediate destruction of lexical objects (op/ref.t tests LIFO order)
 178 { my $test = curr_test();
 179 my ($ScopeMark, $Stoogetime) = (1,$test);
 180 sub InScope() { $ScopeMark ? "ok " : "not ok " }
 181 sub shoulda::DESTROY  { print InScope,$test++," - Larry\n"; }
 182 sub coulda::DESTROY   { print InScope,$test++," - Curly\n"; }
 183 sub woulda::DESTROY   { print InScope,$test++," - Moe\n"; }
 184 sub frieda::DESTROY   { print InScope,$test++," - Shemp\n"; }
 185 sub spr::DESTROY   { print InScope,$test++," - postfix scalar reference\n"; }
 186 sub apr::DESTROY   { print InScope,$test++," - postfix array reference\n"; }
 187 sub hpr::DESTROY   { print InScope,$test++," - postfix hash reference\n"; }
 188
 189 {
 190     no strict 'refs';
 191     # and real references taken from symbolic postfix dereferences
 192     local ($joe, @curly, %larry, $momo);
 193     my ($s,@a,%h);
 194     my $woulda = bless \'joe'->$*, 'woulda';
 195     my $frieda = bless \'momo'->$*, 'frieda';
 196     my $coulda  = eval q{bless \'curly'->@*, 'coulda' } or print "# $@","not ok ",$test++,"\n";
 197     my $shoulda = eval q{bless \'larry'->%*, 'shoulda'} or print "# $@","not ok ",$test++,"\n";
 198 #    print "# postfix whack-star instead of prefix whack\n";
 199 #    my $spr = eval q/ bless $s->\* , "spr"/; $@ and print "# $@","not ok ",$test++,"\n";
 200 #    my $apr = eval q/ bless @a->\* , 'apr'/; $@ and print "# $@","not ok ",$test++,"\n";
 201 #    my $hpr = eval q/ bless %h->\* , 'hpr'/; $@ and print "# $@","not ok ",$test++,"\n";
 202     print "# leaving block: we want (larry, curly, moe, shemp)\n";
 203 }
 204
 205 print "# left block\n";
 206 $ScopeMark = 0;
 207 curr_test($test);
 208 is ($test, $Stoogetime + 4, "no stooges outlast their scope");
 209 }
 210
 211 {
 212     no strict 'refs';
 213     $name8 = chr 163;
 214     $name_utf8 = $name8 . chr 256;
 215     chop $name_utf8;
 216
 217 #    is ($$name8, undef, 'Nothing before we start');
 218 #    is ($$name_utf8, undef, 'Nothing before we start');
 219 #    $$name8 = "Pound";
 220 #    is ($$name8, "Pound", 'Accessing via 8 bit symref works');
 221 #    is ($$name_utf8, "Pound", 'Accessing via UTF8 symref works');
 222
 223     is ($name8->$*, undef, 'Nothing before we start');
 224     is ($name_utf8->$*, undef, 'Nothing before we start');
 225     $name8->$* = "Pound";
 226     is ($name8->$*, "Pound", 'Accessing via 8 bit symref works');
 227     is ($name_utf8->$*, "Pound", 'Accessing via UTF8 symref works');
 228 }
 229
 230 {
 231     no strict 'refs';
 232     $name_utf8 = $name = chr 9787;
 233     utf8::encode $name_utf8;
 234
 235     is (length $name, 1, "Name is 1 char");
 236     is (length $name_utf8, 3, "UTF8 representation is 3 chars");
 237
 238     is ($name->$*, undef, 'Nothing before we start');
 239     is ($name_utf8->$*, undef, 'Nothing before we start');
 240     $name->$* = "Face";
 241     is ($name->$*, "Face", 'Accessing via Unicode symref works');
 242     is ($name_utf8->$*, undef,
 243         'Accessing via the UTF8 byte sequence still gives nothing');
 244 }
 245
 246 {
 247     no strict 'refs';
 248     $name1 = "\0Chalk";
 249     $name2 = "\0Cheese";
 250
 251     is ($ $name1, undef, 'Nothing before we start (scalars)');
 252     is ($name2 -> $* , undef, 'Nothing before we start');
 253     $name1 ->$*  = "Yummy";
 254     is ($name1-> $*, "Yummy", 'Accessing via the correct name works');
 255     is ($$name2, undef,
 256         'Accessing via a different NUL-containing name gives nothing');
 257     # defined uses a different code path
 258     ok (defined $name1->$*, 'defined via the correct name works');
 259     ok (!defined $name2->$*,
 260         'defined via a different NUL-containing name gives nothing');
 261
 262     my (undef, $one) = $name1 ->@[2,3];
 263     my (undef, $two) = $name2-> @[2,3];
 264     is ($one, undef, 'Nothing before we start (array slices)');
 265     is ($two, undef, 'Nothing before we start');
 266     $name1->@[2,3] = ("Very", "Yummy");
 267     (undef, $one) = $name1 -> @[2,3];
 268     (undef, $two) = $name2 -> @[2,3];
 269     is ($one, "Yummy", 'Accessing via the correct name works');
 270     is ($two, undef,
 271         'Accessing via a different NUL-containing name gives nothing');
 272     ok (defined $one, 'defined via the correct name works');
 273     ok (!defined $two,
 274         'defined via a different NUL-containing name gives nothing');
 275
 276 }
 277
 278
 279 # test dereferencing errors
 280 {
 281     format STDERR =
 282 .
 283     my $ref;
 284     foreach $ref (*STDOUT{IO}, *STDERR{FORMAT}) {
 285         eval q/ $ref->$* /;
 286         like($@, qr/Not a SCALAR reference/, "Scalar dereference");
 287         eval q/ $ref->@* /;
 288         like($@, qr/Not an ARRAY reference/, "Array dereference");
 289         eval q/ $ref->%* /;
 290         like($@, qr/Not a HASH reference/, "Hash dereference");
 291         eval q/ $ref->() /;
 292         like($@, qr/Not a CODE reference/, "Code dereference");
 293     }
 294
 295     $ref = *STDERR{FORMAT};
 296     eval q/ $ref->** /; # postfix GLOB dereference ?
 297     like($@, qr/Not a GLOB reference/, "Glob dereference");
 298
 299     $ref = *STDOUT{IO};
 300     eval q/ $ref->** /;
 301     is($@, '', "Glob dereference of PVIO is acceptable");
 302
 303     is($ref, (eval '$ref->*{IO}'), "IO slot of the temporary glob is set correctly");
 304 }
 305
 306 # these will segfault if they fail
 307 sub PVBM () { 'foo' }
 308 my $pvbm_r;
 309 ok(eval q/ $pvbm_r = \'PVBM'->&* /, "postfix symref to sub name");
 310 is("$pvbm_r", "".\&PVBM, "postfix and prefix mechanisms provide same result");
 311 my $pvbm = PVBM;
 312 my $rpvbm = \$pvbm;
 313 {
 314 my $SynCtr;
 315 ok (!eval q{ $SynCtr++; $rpvbm->** }, 'PVBM ref is not a GLOB ref');
 316 ok (!eval q{ $SynCtr++; $pvbm->** }, 'PVBM is not a GLOB ref');
 317 is ($SynCtr, 2, "starstar GLOB postderef parses");
 318 }
 319 ok (!eval { $pvbm->$* }, 'PVBM is not a SCALAR ref');
 320 ok (!eval { $pvbm->@* }, 'PVBM is not an ARRAY ref');
 321 ok (!eval { $pvbm->%* }, 'PVBM is not a HASH ref');
 322
 323 # Test undefined hash references as arguments to %{} in boolean context
 324 # [perl #81750]
 325 {
 326  no strict 'refs';
 327  eval { my $foo; $foo->%*;             }; ok !$@, '%$undef';
 328  eval { my $foo; scalar $foo->%*;      }; ok !$@, 'scalar %$undef';
 329  eval { my $foo; !$foo->%*;            }; ok !$@, '!%$undef';
 330  eval { my $foo; if ( $foo->%*) {}     }; ok !$@, 'if ( %$undef) {}';
 331  eval { my $foo; if (!$foo->%*) {}     }; ok !$@, 'if (!%$undef) {}';
 332  eval { my $foo; unless ( $foo->%*) {} }; ok !$@, 'unless ( %$undef) {}';
 333  eval { my $foo; unless (!$foo->%*) {} }; ok !$@, 'unless (!%$undef) {}';
 334  eval { my $foo; 1 if $foo->%*;        }; ok !$@, '1 if %$undef';
 335  eval { my $foo; 1 if !$foo->%*;       }; ok !$@, '1 if !%$undef';
 336  eval { my $foo; 1 unless $foo->%*;    }; ok !$@, '1 unless %$undef;';
 337  eval { my $foo; 1 unless ! $foo->%*;  }; ok !$@, '1 unless ! %$undef';
 338  eval { my $foo;  $foo->%* ? 1 : 0;    }; ok !$@, ' %$undef ? 1 : 0';
 339  eval { my $foo; !$foo->%* ? 1 : 0;    }; ok !$@, '!%$undef ? 1 : 0';
 340 }
 341
 342 # Postfix key/value slices
 343 is join(" ", {1..10}->%{1, 7, 3}), "1 2 7 8 3 4", '->%{';
 344 is join(" ", ['a'..'z']->%[1, 7, 3]), "1 b 7 h 3 d", '->%[';
 345
 346 # Array length
 347 is [1..10]->$#*, 9, 'rvalue ->$#*';
 348 @foo = 1..10;
 349 (\@foo)->$#*--;
 350 is "@foo", "1 2 3 4 5 6 7 8 9", 'lvalue ->$#*';
 351
 352 # Interpolation
 353 $_ = "foo";
 354 @foo = 7..9;
 355 %foo = qw( foo oof );
 356 {
 357     no warnings 'deprecated';
 358     $* = 42;
 359     is "$_->$*", 'foo->42', '->$* interpolation without feature';
 360     $# = 43;
 361     is "$_->$#*", 'foo->43*', '->$#* interpolation without feature';
 362 }
 363 is "$_->@*", 'foo->@*', '->@* does not interpolate without feature';
 364 is "$_->@[0]", 'foo->@[0]', '->@[ does not interpolate without feature';
 365 is "$_->@{foo}", "foo->7 8 9", '->@{ does not interpolate without feature';
 366 {
 367     use feature 'postderef_qq';
 368     no strict 'refs';
 369     $foo = 43;
 370     is "$_->$*", "43", '->$* interpolated';
 371     is "$_->$#*", "2", '->$#* interpolated';
 372     is "$_->@*", "7 8 9", '->@* interpolated';
 373     is "$_->@[0,1]", "7 8", '->@[ interpolated';
 374     is "$_->@{foo}", "oof", '->@{ interpolated';
 375     is "foo$_->$*bar", "foo43bar", '->$* interpolated w/other stuff';
 376     is "foo$_->@*bar", "foo7 8 9bar", '->@* interpolated w/other stuff';
 377     is "foo$_->@[0,1]bar", "foo7 8bar", '->@[ interpolated w/other stuff';
 378     is "foo$_->@{foo}bar", "foooofbar", '->@{ interpolated w/other stuff';
 379     is "@{[foo->@*]}", "7 8 9", '->@* inside "@{...}"';
 380     is "@{[foo->@[0,1]]}", "7 8", '->@[ inside "@{...}"';
 381     is "@{[foo->@{foo}]}", "oof", '->@{ inside "@{...}"';
 382 }