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