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