dist/B-Deparse/t/core.t

   1 #!./perl
   2
   3 BEGIN {
   4     unshift @INC, 't','../../t';
   5     require 'test.pl';
   6     skip_all_without_dynamic_extension('B');
   7 }
   8
   9
  10 # Many functions appear in multiple lists, so that shift() and shift(foo)
  11 # are both tested.
  12 # For lists, we test 0 to 2 arguments.
  13 my @nary = (
  14  # nullary functions
  15      [qw( abs alarm break chr cos chop close chdir chomp chmod chown
  16           chroot caller continue die dump exp exit exec endgrent
  17           endpwent endnetent endhostent endservent endprotoent fork
  18           getppid getpwent getprotoent gethostent getnetent getservent
  19           getgrent getlogin getc gmtime hex int lc log lstat length
  20           lcfirst localtime mkdir ord oct pop quotemeta ref rand
  21           rmdir reset reverse readlink select setpwent setgrent
  22           shift sin sleep sqrt srand stat system tell time times
  23           uc utime umask unlink ucfirst wantarray warn wait write    )],
  24  # unary
  25      [qw( abs alarm bless binmode chr cos chop close chdir chomp
  26           chmod chown chroot closedir die dump exp exit exec
  27           each fileno getpgrp getpwnam getpwuid getpeername
  28           getprotobyname getprotobynumber gethostbyname
  29           getnetbyname getsockname getgrnam getgrgid
  30           getc gmtime hex int join keys kill lc
  31           log lock lstat length lcfirst localtime
  32           mkdir ord oct open pop push pack quotemeta
  33           ref rand rmdir reset reverse readdir readlink
  34           rewinddir select setnetent sethostent setservent
  35           setprotoent shift sin sleep sprintf splice sqrt
  36           srand stat system tell tied telldir uc utime umask
  37           unpack unlink unshift untie ucfirst values warn write )],
  38  # binary, but not circumfix
  39      [qw( atan2 accept bind binmode chop chomp chmod chown crypt
  40           connect die exec flock formline getpriority gethostbyaddr
  41           getnetbyaddr getservbyname getservbyport index join kill
  42           link listen mkdir msgget open opendir push pack pipe
  43           rename rindex reverse seekdir semop setpgrp shutdown
  44           sprintf splice substr system symlink syscall syswrite
  45           tie truncate utime unpack unlink warn waitpid           )],
  46  # ternary
  47      [qw( fcntl getsockopt index ioctl join  kill  msgctl
  48           msgsnd open push pack  read  rindex  seek  send
  49           semget setpriority shmctl shmget sprintf splice
  50           substr sysopen sysread sysseek syswrite tie vec )],
  51  # quaternary
  52      [qw( open read  recv  send  select  semctl  setsockopt  shmread
  53           shmwrite socket splice substr sysopen sysread syswrite tie )],
  54  # quinary
  55      [qw( msgrcv open socketpair splice )]
  56 );
  57
  58 my $tests = @bin + 13;
  59 $tests += @$_ for @nary;
  60 plan $tests;
  61
  62 use B::Deparse;
  63 my $deparse = new B::Deparse;
  64
  65 sub CORE_test {
  66   my($keyword,$expr,$name) = @_;
  67   package test;
  68   use subs ();
  69   import subs $keyword;
  70   use feature 'switch';
  71   ::like
  72       $deparse->coderef2text(
  73          eval "sub { () = $expr }" or die "$@in $expr"
  74       ),
  75       qr/\sCORE::$keyword.*;/,
  76       $name||$keyword
  77 }
  78
  79 for my $argc(0..$#nary) {
  80  for(@{$nary[$argc]}) {
  81   CORE_test
  82      $_,\r    "CORE::$_(" . join(',',map "\$$_", (undef,"a".."z")[1..$argc]) . ")",
  83     "$_, $argc argument" . "s"x($argc != 1);
  84  }
  85 }
  86
  87 # Special cases
  88 CORE_test dbmopen => 'CORE::dbmopen %foo, $bar, $baz';
  89 CORE_test dbmclose => 'CORE::dbmclose %foo';
  90 CORE_test eof => 'CORE::eof $foo', 'eof $arg';
  91 CORE_test eof => 'CORE::eof', 'eof';
  92 CORE_test eof => 'CORE::eof()', 'eof()';
  93 CORE_test exec => 'CORE::exec $foo $bar', 'exec PROGRAM LIST';
  94 CORE_test each => 'CORE::each %bar', 'each %hash';
  95 CORE_test keys => 'CORE::keys %bar', 'keys %hash';
  96 CORE_test reverse => 'CORE::reverse sort @foo', 'reverse sort';
  97 CORE_test system => 'CORE::system $foo $bar', 'system PROGRAM LIST';
  98 CORE_test values => 'CORE::values %bar', 'values %hash';
  99 # This test does not work. How do I get Deparse to output a not?
 100 #CORE_test not => 'CORE::not $a, $b', 'not';
 101 CORE_test readline => 'CORE::readline $a.$b', 'readline';
 102 CORE_test readpipe => 'CORE::readpipe $a+$b', 'readpipe';