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
 126 test_proto 'accept';
 127 $tests += 6; eval q{
 128   is &CORE::accept(qw{foo bar}), undef, "&accept";
 129   lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context";
 130
 131   &myaccept(my $foo, my $bar);
 132   is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument';
 133   is $bar, undef, 'CORE::accept does not autovivify its second argument';
 134   use strict;
 135   undef $foo;
 136   eval { 'myaccept'->($foo, $bar) };
 137   like $@, qr/^Can't use an undefined value as a symbol reference at/,
 138       'CORE::accept will not accept undef 2nd arg under strict';
 139   is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict';
 140 };
 141
 142 test_proto 'alarm';
 143 test_proto 'atan2';
 144
 145 test_proto 'bind';
 146 $tests += 3;
 147 is &CORE::bind('foo', 'bear'), undef, "&bind";
 148 lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context";
 149 eval { &mybind(my $foo, "bear") };
 150 like $@, qr/^Bad symbol for filehandle at/,
 151      'CORE::bind dies with undef first arg';
 152
 153 test_proto 'break';
 154 { $tests ++;
 155   my $tmp;
 156   CORE::given(1) {
 157     CORE::when(1) {
 158       &mybreak;
 159       $tmp = 'bad';
 160     }
 161   }
 162   is $tmp, undef, '&break';
 163 }
 164
 165 test_proto 'chr', 5, "\5";
 166 test_proto 'chroot';
 167
 168 test_proto 'closedir';
 169 $tests += 2;
 170 is &CORE::closedir(foo), undef, '&CORE::closedir';
 171 lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context';
 172
 173 test_proto 'connect';
 174 $tests += 2;
 175 is &CORE::connect('foo','bar'), undef, '&connect';
 176 lis [&myconnect('foo','bar')], [undef], '&connect in list context';
 177
 178 test_proto 'continue';
 179 $tests ++;
 180 CORE::given(1) {
 181   CORE::when(1) {
 182     &mycontinue();
 183   }
 184   pass "&continue";
 185 }
 186
 187 test_proto 'cos';
 188 test_proto 'crypt';
 189
 190 test_proto $_ for qw(
 191  endgrent endhostent endnetent endprotoent endpwent endservent
 192 );
 193
 194 test_proto 'fork';
 195 test_proto 'exp';
 196 test_proto 'fcntl';
 197
 198 test_proto 'fileno';
 199 $tests += 2;
 200 is &CORE::fileno(\*STDIN), fileno STDIN, '&CORE::fileno';
 201 lis [&CORE::fileno(\*STDIN)], [fileno STDIN], '&CORE::fileno in list cx';
 202
 203 test_proto 'flock';
 204 test_proto 'fork';
 205
 206 test_proto "get$_" for qw '
 207   grent grgid grnam hostbyaddr hostbyname hostent login netbyaddr netbyname
 208   netent peername ppid priority protobyname protobynumber protoent
 209   pwent pwnam pwuid servbyname servbyport servent sockname sockopt
 210 ';
 211
 212 test_proto 'hex', ff=>255;
 213 test_proto 'int', 1.5=>1;
 214 test_proto 'ioctl';
 215 test_proto 'lc', 'A', 'a';
 216 test_proto 'lcfirst', 'AA', 'aA';
 217 test_proto 'length', 'aaa', 3;
 218 test_proto 'link';
 219 test_proto 'listen';
 220 test_proto 'log';
 221 test_proto "msg$_" for qw( ctl get rcv snd );
 222
 223 test_proto 'not';
 224 $tests += 2;
 225 is &mynot(1), !1, '&not';
 226 lis [&mynot(0)], [!0], '&not in list context';
 227
 228 test_proto 'oct', '666', 438;
 229 test_proto 'opendir';
 230 test_proto 'ord', chr(64), 64;
 231 test_proto 'pipe';
 232 test_proto 'quotemeta', '$', '\$';
 233 test_proto 'readdir';
 234 test_proto 'readlink';
 235 test_proto 'readpipe';
 236
 237 use if !is_miniperl, File::Spec::Functions, qw "catfile";
 238 use if !is_miniperl, File::Temp, 'tempdir';
 239
 240 test_proto 'rename';
 241 {
 242     last if is_miniperl;
 243     $tests ++;
 244     my $dir = tempdir(uc cleanup => 1);
 245     my $tmpfilenam = catfile $dir, 'aaa';
 246     open my $fh, ">", $tmpfilenam or die "cannot open $tmpfilenam: $!";
 247     close $fh or die "cannot close $tmpfilenam: $!";
 248     &myrename("$tmpfilenam", $tmpfilenam = catfile $dir,'bbb');
 249     ok open(my $fh, '>', $tmpfilenam), '&rename';
 250 }
 251
 252 test_proto 'ref', [], 'ARRAY';
 253 test_proto 'rewinddir';
 254 test_proto 'rmdir';
 255
 256 test_proto 'seek';
 257 {
 258     last if is_miniperl;
 259     $tests += 1;
 260     open my $fh, "<", \"misled" or die $!;
 261     &myseek($fh, 2, 0);
 262     is <$fh>, 'sled', '&seek in action';
 263 }
 264
 265 test_proto 'seekdir';
 266 test_proto "sem$_" for qw "ctl get op";
 267
 268 test_proto "set$_" for qw '
 269   grent hostent netent priority protoent pwent servent sockopt
 270 ';
 271
 272 test_proto "shm$_" for qw "ctl get read write";
 273 test_proto 'shutdown';
 274 test_proto 'sin';
 275 test_proto "socket$_" for "", "pair";
 276 test_proto 'sqrt', 4, 2;
 277 test_proto 'symlink';
 278 test_proto 'sysseek';
 279 test_proto 'telldir';
 280
 281 test_proto 'time';
 282 $tests += 2;
 283 like &mytime, '^\d+\z', '&time in scalar context';
 284 like join('-', &mytime), '^\d+\z', '&time in list context';
 285
 286 test_proto 'times';
 287 $tests += 2;
 288 like &mytimes, '^[\d.]+\z', '&times in scalar context';
 289 like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z',
 290    '&times in list context';
 291
 292 test_proto 'uc', 'aa', 'AA';
 293 test_proto 'ucfirst', 'aa', "Aa";
 294
 295 test_proto 'vec';
 296 $tests += 3;
 297 is &myvec("foo", 0, 4), 6, '&vec';
 298 lis [&myvec("foo", 0, 4)], [6], '&vec in list context';
 299 $tmp = "foo";
 300 ++&myvec($tmp,0,4);
 301 is $tmp, "goo", 'lvalue &vec';
 302
 303 test_proto 'wait';
 304 test_proto 'waitpid';
 305
 306 test_proto 'wantarray';
 307 $tests += 4;
 308 my $context;
 309 my $cx_sub = sub {
 310   $context = qw[void scalar list][&mywantarray + defined mywantarray()]
 311 };
 312 () = &$cx_sub;
 313 is $context, 'list', '&wantarray with caller in list context';
 314 scalar &$cx_sub;
 315 is($context, 'scalar', '&wantarray with caller in scalar context');
 316 &$cx_sub;
 317 is($context, 'void', '&wantarray with caller in void context');
 318 lis [&mywantarray],[wantarray], '&wantarray itself in list context';
 319
 320 # This is just a check to make sure we have tested everything.  If we
 321 # haven’t, then either the sub needs to be tested or the list in
 322 # gv.c is wrong.
 323 {
 324   last if is_miniperl;
 325   require File::Spec::Functions;
 326   my $keywords_file =
 327    File::Spec::Functions::catfile(
 328       File::Spec::Functions::updir,'regen','keywords.pl'
 329    );
 330   open my $kh, $keywords_file
 331     or die "$0 cannot open $keywords_file: $!";
 332   while(<$kh>) {
 333     if (m?__END__?..${\0} and /^[-](.*)/) {
 334       my $word = $1;
 335       next if
 336        $word =~ /^(?:CORE|and|cmp|dump|eq|ge|gt|le|lt|ne|or|x|xor)\z/;
 337       $tests ++;
 338       ok   exists &{"my$word"}
 339         || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/),
 340      "$word either has been tested or is not ampable";
 341     }
 342   }
 343 }
 344
 345 # Add new tests above this line.
 346
 347 # ------------ END TESTING ----------- #
 348
 349 is curr_test, $tests+1, 'right number of tests';
 350 done_testing;
 351
 352 #line 3 frob
 353
 354 sub file { &CORE::__FILE__ }
 355 sub line { &CORE::__LINE__ } # 5
 356 package stribble;
 357 sub main::pakg { &CORE::__PACKAGE__ }
 358
 359 # Please do not add new tests here.