This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
123767cc35e01b481b5bca5ad376abf090dafeef
[perl5.git] / 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..72\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 implicit 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( eval q/$_/ ne 'fqdb', 'unqualified, evaled $_ is in main' );
200 }
201
202 {
203     $clank_est::qunckkk = 3;
204     our $qunckkk;
205     $qunckkk = 4;
206     package clank_est;
207     our $qunckkk;
208     ::ok($qunckkk == 3, 'regular variables are not forced to main');
209 }
210
211 {
212     $whack::_ = 3;
213     our $_;
214     $_ = 4;
215     package whack;
216     our $_;
217     ::ok($_ == 4, '$_ is "special", and always forced to main');
218 }