This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make require report too many open files error
[perl5.git] / ext / Devel / PPPort / devel / mktodo.pl
CommitLineData
adfe19db
MHM
1#!/usr/bin/perl -w
2################################################################################
3#
4# mktodo.pl -- generate baseline and todo files
5#
6################################################################################
7#
0c96388f 8# $Revision: 11 $
adfe19db 9# $Author: mhx $
0c96388f 10# $Date: 2006/05/25 17:22:32 +0200 $
adfe19db
MHM
11#
12################################################################################
13#
0d0f8426 14# Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
adfe19db
MHM
15# Version 2.x, Copyright (C) 2001, Paul Marquess.
16# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
17#
18# This program is free software; you can redistribute it and/or
19# modify it under the same terms as Perl itself.
20#
21################################################################################
22
23use strict;
24use Getopt::Long;
25use Data::Dumper;
26use IO::File;
27use IO::Select;
0c96388f 28use Time::HiRes qw( gettimeofday tv_interval );
adfe19db 29
0c96388f 30require 'devel/devtools.pl';
adfe19db 31
0c96388f
MHM
32our %opt = (
33 debug => 0,
34 base => 0,
35 verbose => 0,
36);
adfe19db
MHM
37
38GetOptions(\%opt, qw(
0c96388f 39 perl=s todo=s version=s debug base verbose
adfe19db
MHM
40 )) or die;
41
0c96388f
MHM
42identify();
43
44print "\n", ident_str(), "\n\n";
45
adfe19db
MHM
46my $fullperl = `which $opt{perl}`;
47chomp $fullperl;
48
0c96388f
MHM
49$ENV{SKIP_SLOW_TESTS} = 1;
50
adfe19db
MHM
51regen_all();
52
53my %sym;
54for (`nm $fullperl`) {
55 chomp;
56 /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
57}
58keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
59
60my %all = %{load_todo($opt{todo}, $opt{version})};
61my @recheck;
62
63for (;;) {
64 my $retry = 1;
65 regen_apicheck();
66retry:
67 my $r = run(qw(make test));
68 $r->{didnotrun} and die "couldn't run make test: $!\n";
69 $r->{status} == 0 and last;
70 my(@new, @tmp, %seen);
71 for my $l (@{$r->{stderr}}) {
72 if ($l =~ /_DPPP_test_(\w+)/) {
73 if (!$seen{$1}++) {
74 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
75 if (@s) {
76 push @tmp, [$1, "E (@s)"];
77 }
78 else {
79 push @new, [$1, "E"];
80 }
81 }
82 }
83 if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) {
84 if (!$seen{$1}++) {
85 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
86 push @new, [$1, @s ? "U (@s)" : "U"];
87 }
88 }
89 }
90 @new = grep !$all{$_->[0]}, @new;
91 unless (@new) {
92 @new = grep !$all{$_->[0]}, @tmp;
93 # TODO: @recheck was here, find a better way to get recheck syms
adfe19db
MHM
94 # * try to grep out warnings before making symlist ?
95 }
96 unless (@new) {
97 if ($retry > 0) {
98 $retry--;
99 regen_all();
100 goto retry;
101 }
102 print Dumper($r);
103 die "no new TODO symbols found...";
104 }
0c96388f
MHM
105 # don't recheck undefined symbols reported by the dynamic linker
106 push @recheck, map { $_->[0] } grep { $_->[1] !~ /^U/ } @new;
adfe19db
MHM
107 for (@new) {
108 printf "[$opt{version}] new symbol: %-30s # %s\n", @$_;
109 $all{$_->[0]} = $_->[1];
110 }
111 write_todo($opt{todo}, $opt{version}, \%all);
112}
113
0c96388f
MHM
114my $ifmt = '%' . length(scalar @recheck) . 'd';
115my $t0 = [gettimeofday];
116
117RECHECK: for my $i (0 .. $#recheck) {
118 my $sym = $recheck[$i];
adfe19db 119 my $cur = delete $all{$sym};
0c96388f
MHM
120
121 printf "[$opt{version}] chk symbol: %-30s # %s [$ifmt/$ifmt, ETA %s]\n",
122 $sym, $cur, $i + 1, scalar @recheck, eta($t0, $i, scalar @recheck);
123
adfe19db 124 write_todo($opt{todo}, $opt{version}, \%all);
0c96388f
MHM
125
126 if ($cur eq "E (Perl_$sym)") {
127 # we can try a shortcut here
128 regen_apicheck($sym);
129
130 my $r = run(qw(make test));
131
132 if (!$r->{didnotrun} && $r->{status} == 0) {
133 printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur;
134 next RECHECK;
135 }
136 }
137
138 # run the full test
adfe19db 139 regen_all();
0c96388f 140
adfe19db 141 my $r = run(qw(make test));
0c96388f 142
adfe19db 143 $r->{didnotrun} and die "couldn't run make test: $!\n";
0c96388f 144
adfe19db
MHM
145 if ($r->{status} == 0) {
146 printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur;
147 }
148 else {
149 $all{$sym} = $cur;
150 }
151}
152
153write_todo($opt{todo}, $opt{version}, \%all);
154
155run(qw(make realclean));
156
157exit 0;
158
159sub regen_all
160{
0c96388f 161 my @mf_arg = ('--with-apicheck', 'OPTIMIZE=-O0');
adfe19db
MHM
162 push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
163
164 # just to be sure
165 run(qw(make realclean));
166 run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
167 or die "cannot run Makefile.PL: $!\n";
168}
169
170sub regen_apicheck
171{
172 unlink qw(apicheck.c apicheck.o);
0c96388f
MHM
173 runtool({ out => '/dev/null' }, $fullperl, 'apicheck_c.PL', map { "--api=$_" } @_)
174 or die "cannot regenerate apicheck.c\n";
adfe19db
MHM
175}
176
177sub load_todo
178{
179 my($file, $expver) = @_;
180
181 if (-e $file) {
182 my $f = new IO::File $file or die "cannot open $file: $!\n";
183 my $ver = <$f>;
184 chomp $ver;
185 if ($ver eq $expver) {
186 my %sym;
187 while (<$f>) {
188 chomp;
189 /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
190 exists $sym{$1} and goto nuke_file;
191 $sym{$1} = $2;
192 }
193 return \%sym;
194 }
195
196nuke_file:
197 undef $f;
198 unlink $file or die "cannot remove $file: $!\n";
199 }
200
201 return {};
202}
203
204sub write_todo
205{
206 my($file, $ver, $sym) = @_;
207 my $f;
208
209 $f = new IO::File ">$file" or die "cannot open $file: $!\n";
210 $f->print("$ver\n");
211
212 for (sort keys %$sym) {
213 $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
214 }
215}
216