t/op/mydef.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 print "1..70\n";
  10
  11 my $test = 0;
  12 sub ok ($@) {
  13     my ($ok, $name) = @_;
  14     ++$test;
  15     print $ok ? "ok $test - $name\n" : "not ok $test - $name\n";
  16 }
  17
  18 $_ = 'global';
  19 ok( $_ eq 'global', '$_ initial value' );
  20 s/oba/abo/;
  21 ok( $_ eq 'glabol', 's/// on global $_' );
  22
  23 {
  24     my $_ = 'local';
  25     ok( $_ eq 'local', 'my $_ initial value' );
  26     s/oca/aco/;
  27     ok( $_ eq 'lacol', 's/// on my $_' );
  28     /(..)/;
  29     ok( $1 eq 'la', '// on my $_' );
  30     ok( tr/c/d/ == 1, 'tr/// on my $_ counts correctly' );
  31     ok( $_ eq 'ladol', 'tr/// on my $_' );
  32     {
  33         my $_ = 'nested';
  34         ok( $_ eq 'nested', 'my $_ nested' );
  35         chop;
  36         ok( $_ eq 'neste', 'chop on my $_' );
  37     }
  38     {
  39         our $_;
  40         ok( $_ eq 'glabol', 'gains access to our global $_' );
  41     }
  42     ok( $_ eq 'ladol', 'my $_ restored' );
  43 }
  44 ok( $_ eq 'glabol', 'global $_ restored' );
  45 s/abo/oba/;
  46 ok( $_ eq 'global', 's/// on global $_ again' );
  47 {
  48     my $_ = 11;
  49     our $_ = 22;
  50     ok( $_ eq 22, 'our $_ is seen explicitly' );
  51     chop;
  52     ok( $_ eq 2, '...default chop chops our $_' );
  53     /(.)/;
  54     ok( $1 eq 2, '...default match sees our $_' );
  55 }
  56
  57 $_ = "global";
  58 {
  59     my $_ = 'local';
  60     for my $_ ("foo") {
  61         ok( $_ eq "foo", 'for my $_' );
  62         /(.)/;
  63         ok( $1 eq "f", '...m// in for my $_' );
  64         ok( our $_ eq 'global', '...our $_ inside for my $_' );
  65     }
  66     ok( $_ eq 'local', '...my $_ restored outside for my $_' );
  67     ok( our $_ eq 'global', '...our $_ restored outside for my $_' );
  68 }
  69 {
  70     my $_ = 'local';
  71     for ("implicit foo") { # implicit "my $_"
  72         ok( $_ eq "implicit foo", 'for implicit my $_' );
  73         /(.)/;
  74         ok( $1 eq "i", '...m// in for implicity my $_' );
  75         ok( our $_ eq 'global', '...our $_ inside for implicit my $_' );
  76     }
  77     ok( $_ eq 'local', '...my $_ restored outside for implicit my $_' );
  78     ok( our $_ eq 'global', '...our $_ restored outside for implicit my $_' );
  79 }
  80 {
  81     my $_ = 'local';
  82     ok( $_ eq "postfix foo", 'postfix for' ) for 'postfix foo';
  83     ok( $_ eq 'local', '...my $_ restored outside postfix for' );
  84     ok( our $_ eq 'global', '...our $_ restored outside postfix for' );
  85 }
  86 {
  87     for our $_ ("bar") {
  88         ok( $_ eq "bar", 'for our $_' );
  89         /(.)/;
  90         ok( $1 eq "b", '...m// in for our $_' );
  91     }
  92     ok( $_ eq 'global', '...our $_ restored outside for our $_' );
  93 }
  94
  95 {
  96     my $buf = '';
  97     sub tmap1 { /(.)/; $buf .= $1 } # uses our $_
  98     my $_ = 'x';
  99     sub tmap2 { /(.)/; $buf .= $1 } # uses my $_
 100     map {
 101         tmap1();
 102         tmap2();
 103         ok( /^[67]\z/, 'local lexical $_ is seen in map' );
 104         { ok( our $_ eq 'global', 'our $_ still visible' ); }
 105         ok( $_ == 6 || $_ == 7, 'local lexical $_ is still seen in map' );
 106         { my $_ ; ok( !defined, 'nested my $_ is undefined' ); }
 107     } 6, 7;
 108     ok( $buf eq 'gxgx', q/...map doesn't modify outer lexical $_/ );
 109     ok( $_ eq 'x', '...my $_ restored outside map' );
 110     ok( our $_ eq 'global', '...our $_ restored outside map' );
 111     map { my $_; ok( !defined, 'redeclaring $_ in map block undefs it' ); } 1;
 112 }
 113 { map { my $_; ok( !defined, 'declaring $_ in map block undefs it' ); } 1; }
 114 {
 115     sub tmap3 () { return $_ };
 116     my $_ = 'local';
 117     sub tmap4 () { return $_ };
 118     my $x = join '-', map $_.tmap3.tmap4, 1 .. 2;
 119     ok( $x eq '1globallocal-2globallocal', 'map without {}' );
 120 }
 121 {
 122     for my $_ (1) {
 123         my $x = map $_, qw(a b);
 124         ok( $x == 2, 'map in scalar context' );
 125     }
 126 }
 127 {
 128     my $buf = '';
 129     sub tgrep1 { /(.)/; $buf .= $1 }
 130     my $_ = 'y';
 131     sub tgrep2 { /(.)/; $buf .= $1 }
 132     grep {
 133         tgrep1();
 134         tgrep2();
 135         ok( /^[89]\z/, 'local lexical $_ is seen in grep' );
 136         { ok( our $_ eq 'global', 'our $_ still visible' ); }
 137         ok( $_ == 8 || $_ == 9, 'local lexical $_ is still seen in grep' );
 138     } 8, 9;
 139     ok( $buf eq 'gygy', q/...grep doesn't modify outer lexical $_/ );
 140     ok( $_ eq 'y', '...my $_ restored outside grep' );
 141     ok( our $_ eq 'global', '...our $_ restored outside grep' );
 142 }
 143 {
 144     sub tgrep3 () { return $_ };
 145     my $_ = 'local';
 146     sub tgrep4 () { return $_ };
 147     my $x = join '-', grep $_=$_.tgrep3.tgrep4, 1 .. 2;
 148     ok( $x eq '1globallocal-2globallocal', 'grep without {} with side-effect' );
 149     ok( $_ eq 'local', '...but without extraneous side-effects' );
 150 }
 151 {
 152     for my $_ (1) {
 153         my $x = grep $_, qw(a b);
 154         ok( $x == 2, 'grep in scalar context' );
 155     }
 156 }
 157 {
 158     my $s = "toto";
 159     my $_ = "titi";
 160     $s =~ /to(?{ ok( $_ eq 'toto', 'my $_ in code-match # TODO' ) })to/
 161         or ok( 0, "\$s=$s should match!" );
 162     ok( our $_ eq 'global', '...our $_ restored outside code-match' );
 163 }
 164
 165 {
 166     my $_ = "abc";
 167     my $x = reverse;
 168     ok( $x eq "cba", 'reverse without arguments picks up $_' );
 169 }
 170
 171 {
 172     package notmain;
 173     our $_ = 'notmain';
 174     ::ok( $::_ eq 'notmain', 'our $_ forced into main::' );
 175     /(.*)/;
 176     ::ok( $1 eq 'notmain', '...m// defaults to our $_ in main::' );
 177 }
 178
 179 my $file = tempfile();
 180 {
 181     open my $_, '>', $file or die "Can't open $file: $!";
 182     print $_ "hello\n";
 183     close $_;
 184     ok( -s $file, 'writing to filehandle $_ works' );
 185 }
 186 {
 187     open my $_, $file or die "Can't open $file: $!";
 188     my $x = <$_>;
 189     ok( $x eq "hello\n", 'reading from <$_> works' );
 190     close $_;
 191 }
 192
 193 {
 194     $fqdb::_ = 'fqdb';
 195     ok( $fqdb::_ eq 'fqdb', 'fully qualified $_ is not in main' );
 196     ok( eval q/$fqdb::_/ eq 'fqdb', 'fully qualified, evaled $_ is not in main' );
 197     package fqdb;
 198     ::ok( $_ ne 'fqdb', 'unqualified $_ is in main' );
 199     ::ok( q/$_/ ne 'fqdb', 'unqualified, evaled $_ is in main' );
 200 }