t/op/mydef.t

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