This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Deparse CORE::glob
[perl5.git] / dist / B-Deparse / t / core.t
1 #!./perl
2
3 BEGIN {
4     require Config;
5     if (($Config::Config{extensions} !~ /\bB\b/) ){
6         print "1..0 # Skip -- Perl configured without B module\n";
7         exit 0;
8     }
9 }
10
11 use strict;
12 use Test::More;
13
14 # Many functions appear in multiple lists, so that shift() and shift(foo)
15 # are both tested.
16 # For lists, we test 0 to 2 arguments.
17 my @nary = (
18  # nullary functions
19      [qw( abs alarm break chr cos chop close chdir chomp chmod chown
20           chroot caller continue die dump exp exit exec endgrent
21           endpwent endnetent endhostent endservent endprotoent fork glob
22           getppid getpwent getprotoent gethostent getnetent getservent
23           getgrent getlogin getc gmtime hex int lc log lstat length
24           lcfirst localtime mkdir ord oct pop quotemeta ref rand
25           rmdir reset reverse readlink select setpwent setgrent
26           shift sin sleep sqrt srand stat system tell time times
27           uc utime umask unlink ucfirst wantarray warn wait write    )],
28  # unary
29      [qw( abs alarm bless binmode chr cos chop close chdir chomp
30           chmod chown chroot closedir die dump exp exit exec
31           each fileno getpgrp getpwnam getpwuid getpeername
32           getprotobyname getprotobynumber gethostbyname
33           getnetbyname getsockname getgrnam getgrgid
34           getc glob gmtime hex int join keys kill lc
35           log lock lstat length lcfirst localtime
36           mkdir ord oct open pop push pack quotemeta
37           ref rand rmdir reset reverse readdir readlink
38           rewinddir select setnetent sethostent setservent
39           setprotoent shift sin sleep sprintf splice sqrt
40           srand stat system tell tied telldir uc utime umask
41           unpack unlink unshift untie ucfirst values warn write )],
42  # binary, but not infix
43      [qw( atan2 accept bind binmode chop chomp chmod chown crypt
44           connect die exec flock formline getpriority gethostbyaddr
45           getnetbyaddr getservbyname getservbyport index join kill
46           link listen mkdir msgget open opendir push pack pipe
47           rename rindex reverse seekdir semop setpgrp shutdown
48           sprintf splice substr system symlink syscall syswrite
49           tie truncate utime unpack unlink warn waitpid           )],
50  # ternary
51      [qw( fcntl getsockopt index ioctl join  kill  msgctl
52           msgsnd open push pack  read  rindex  seek  send
53           semget setpriority shmctl shmget sprintf splice
54           substr sysopen sysread sysseek syswrite tie vec )],
55  # quaternary
56      [qw( open read  recv  send  select  semctl  setsockopt  shmread
57           shmwrite socket splice substr sysopen sysread syswrite tie )],
58  # quinary
59      [qw( msgrcv open socketpair splice )]
60 );
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   ::like
71       $deparse->coderef2text(
72          eval "no strict 'vars'; sub { () = $expr }" or die "$@in $expr"
73       ),
74       qr/\sCORE::$keyword.*;/,
75       $name||$keyword  
76 }
77
78 for my $argc(0..$#nary) {
79  for(@{$nary[$argc]}) {
80   CORE_test
81      $_,
82     "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 CORE_test not => '3 unless CORE::not $a && $b', 'not';
100 CORE_test readline => 'CORE::readline $a.$b', 'readline';
101 CORE_test readpipe => 'CORE::readpipe $a+$b', 'readpipe';
102
103 # Tests for prefixing feature.pm-enabled keywords with CORE:: when
104 # feature.pm is not enabled are in deparse.t, as they fit that for-
105 # mat better.
106
107 done_testing();