coresubs.t: Minor clean-up
[perl.git] / t / op / coresubs.t
1 #!./perl
2
3 # This file tests the results of calling subroutines in the CORE::
4 # namespace with ampersand syntax.  In other words, it tests the bodies of
5 # the subroutines themselves, not the ops that they might inline themselves
6 # as when called as barewords.
7
8 # coreinline.t tests the inlining of these subs as ops.  Since it was
9 # convenient, I also put the prototype and undefinedness checking in that
10 # file, even though those have nothing to do with inlining.  (coreinline.t
11 # reads the list in keywords.pl, which is why it’s convenient.)
12
13 BEGIN {
14     chdir 't' if -d 't';
15     @INC = qw(. ../lib);
16     require "test.pl";
17     $^P |= 0x100;
18 }
19 # Since tests inside evals can too easily fail silently, we cannot rely
20 # on done_testing. It’s much easier to count the tests as we go than to
21 # declare the plan up front, so this script ends with a test that makes
22 # sure the right number of tests have happened.
23
24 sub lis($$;$) {
25   &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]);
26 }
27
28 my %op_desc = (
29  readpipe => 'quoted execution (``, qx)',
30  ref      => 'reference-type operator',
31 );
32 sub op_desc($) {
33   return $op_desc{$_[0]} || $_[0];
34 }
35
36
37 # This tests that the &{} syntax respects the number of arguments implied
38 # by the prototype, plus some extra tests for the (_) prototype.
39 sub test_proto {
40   my($o) = shift;
41
42   # Create an alias, for the caller’s convenience.
43   *{"my$o"} = \&{"CORE::$o"};
44
45   my $p = prototype "CORE::$o";
46
47   if ($p eq '') {
48     $tests ++;
49
50     eval " &CORE::$o(1) ";
51     like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
52
53   }
54   elsif ($p eq '_') {
55     $tests ++;
56
57     eval " &CORE::$o(1,2) ";
58     my $desc = quotemeta op_desc($o);
59     like $@, qr/^Too many arguments for $desc at /,
60       "&$o with too many args";
61
62     if (!@_) { return }
63
64     $tests += 6;
65
66     my($in,$out) = @_; # for testing implied $_
67
68     # Since we have $in and $out values, we might as well test basic amper-
69     # sand calls, too.
70
71     is &{"CORE::$o"}($in), $out, "&$o";
72     lis [&{"CORE::$o"}($in)], [$out], "&$o in list context";
73
74     $_ = $in;
75     is &{"CORE::$o"}(), $out, "&$o with no args";
76
77     # Since there is special code to deal with lexical $_, make sure it
78     # works in all cases.
79     undef $_;
80     {
81       my $_ = $in;
82       is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_";
83     }
84     # Make sure we get the right pad under recursion
85     my $r;
86     $r = sub {
87       if($_[0]) {
88         my $_ = $in;
89         is &{"CORE::$o"}(), $out,
90            "&$o with no args uses the right lexical \$_ under recursion";
91       }
92       else {
93         &$r(1)
94       }
95     };
96     &$r(0);
97     my $_ = $in;
98     eval {
99        is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval"
100     };   
101   }
102   elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or ***
103     my $args = length $1;
104     $tests += 2;    
105     eval " &CORE::$o((1)x($args-1)) ";
106     like $@, qr/^Not enough arguments for $o at /, "&$o with too few args";
107     eval " &CORE::$o((1)x($args+1)) ";
108     like $@, qr/^Too many arguments for $o at /, "&$o with too many args";
109   }
110
111   else {
112     die "Please add tests for the $p prototype";
113   }
114 }
115
116 test_proto '__FILE__';
117 test_proto '__LINE__';
118 test_proto '__PACKAGE__';
119
120 is file(), 'frob'    , '__FILE__ does check its caller'   ; ++ $tests;
121 is line(),  5        , '__LINE__ does check its caller'   ; ++ $tests;
122 is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests;
123
124 test_proto 'abs', -5, 5;
125 test_proto 'alarm';
126 test_proto 'atan2';
127
128 test_proto 'break';
129 { $tests ++;
130   my $tmp;
131   CORE::given(1) {
132     CORE::when(1) {
133       &mybreak;
134       $tmp = 'bad';
135     }
136   }
137   is $tmp, undef, '&break';
138 }
139
140 test_proto 'chr', 5, "\5";
141 test_proto 'chroot';
142 test_proto 'continue';
143 $tests ++;
144 CORE::given(1) {
145   CORE::when(1) {
146     &mycontinue();
147   }
148   pass "&continue";
149 }
150
151 test_proto 'cos';
152 test_proto 'crypt';
153
154 test_proto $_ for qw(
155  endgrent endhostent endnetent endprotoent endpwent endservent
156 );
157
158 test_proto 'fork';
159 test_proto 'exp';
160
161 test_proto "get$_" for qw '
162   grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
163   netent ppid priority protobyname protobynumber protoent
164   pwent pwnam pwuid servbyname servbyport servent
165 ';
166
167 test_proto 'hex', ff=>255;
168 test_proto 'int', 1.5=>1;
169 test_proto 'lc', 'A', 'a';
170 test_proto 'lcfirst', 'AA', 'aA';
171 test_proto 'length', 'aaa', 3;
172 test_proto 'link';
173 test_proto 'log';
174 test_proto "msg$_" for qw( ctl get rcv snd );
175
176 test_proto 'not';
177 $tests += 2;
178 is &mynot(1), !1, '&not';
179 lis [&mynot(0)], [!0], '&not in list context';
180
181 test_proto 'oct', '666', 438;
182 test_proto 'ord', chr(64), 64;
183 test_proto 'quotemeta', '$', '\$';
184 test_proto 'readlink';
185 test_proto 'readpipe';
186
187 use if !is_miniperl, File::Spec::Functions, qw "catfile";
188 use if !is_miniperl, File::Temp, 'tempdir';
189
190 test_proto 'rename';
191 {
192     last if is_miniperl;
193     $tests ++;
194     my $dir = tempdir(uc cleanup => 1);
195     my $tmpfilenam = catfile $dir, 'aaa';
196     open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!";
197     close $fh or die "cannot close $tmpfilenam: $!";
198     &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb');
199     ok open(my $fh, '>', $tmpfilenam), '&rename';
200 }
201
202 test_proto 'ref', [], 'ARRAY';
203 test_proto 'rmdir';
204 test_proto "sem$_" for qw "ctl get op";
205
206 test_proto "set$_" for qw '
207   grent hostent netent priority protoent pwent servent
208 ';
209
210 test_proto "shm$_" for qw "ctl get read write";
211 test_proto 'sin';
212 test_proto 'sqrt', 4, 2;
213 test_proto 'symlink';
214
215 test_proto 'time';
216 $tests += 2;
217 like &mytime, '^\d+\z', '&time in scalar context';
218 like join('-', &mytime), '^\d+\z', '&time in list context';
219
220 test_proto 'times';
221 $tests += 2;
222 like &mytimes, '^[\d.]+\z', '&times in scalar context';
223 like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
224    '&times in list context';
225
226 test_proto 'uc', 'aa', 'AA';
227 test_proto 'ucfirst', 'aa', "Aa";
228
229 test_proto 'vec';
230 $tests += 3;
231 is &myvec("foo", 0, 4), 6, '&vec';
232 lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
233 $tmp = "foo";
234 ++&myvec($tmp,0,4);
235 is $tmp, "goo", 'lvalue &vec';
236
237 test_proto 'wait';
238 test_proto 'waitpid';
239
240 test_proto 'wantarray';
241 $tests += 4;
242 my $context;
243 my $cx_sub = sub {
244   $context = qw[void scalar list][&mywantarray + defined mywantarray()]
245 };
246 () = &$cx_sub;
247 is $context, 'list', '&wantarray with caller in list context';
248 scalar &$cx_sub;
249 is($context, 'scalar', '&wantarray with caller in scalar context');
250 &$cx_sub;
251 is($context, 'void', '&wantarray with caller in void context');
252 lis [&mywantarray],[wantarray], '&wantarray itself in list context';
253
254 # This is just a check to make sure we have tested everything.  If we
255 # haven’t, then either the sub needs to be tested or the list in
256 # gv.c is wrong.
257 {
258   last if is_miniperl;
259   require File::Spec::Functions;
260   my $keywords_file =
261    File::Spec::Functions::catfile(
262       File::Spec::Functions::updir,'regen','keywords.pl'
263    );
264   open my $kh, $keywords_file
265     or die "$0 cannot open $keywords_file: $!";
266   while(<$kh>) {
267     if (m?__END__?..${\0} and /^[-](.*)/) {
268       my $word = $1;
269       next if
270        $word =~ /^(?:CORE|and|cmp|dump|eq|ge|gt|le|lt|ne|or|x|xor)\z/;
271       $tests ++;
272       ok   exists &{"my$word"}
273         || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/),
274      "$word either has been tested or is not ampable";
275     }
276   }
277 }
278
279 # Add new tests above this line.
280
281 # ------------ END TESTING ----------- #
282
283 is curr_test, $tests+1, 'right number of tests';
284 done_testing;
285
286 #line 3 frob
287
288 sub file { &CORE::__FILE__ }
289 sub line { &CORE::__LINE__ } # 5
290 package stribble;
291 sub main::pakg { &CORE::__PACKAGE__ }
292
293 # Please do not add new tests here.