This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Devel::PPPort 3.00.
[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#
8# $Revision: 6 $
9# $Author: mhx $
10# $Date: 2004/08/13 12:50:23 +0200 $
11#
12################################################################################
13#
14# Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz.
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;
28
29my %opt = (
30 debug => 0,
31 base => 0,
32);
33
34print "\n$0 @ARGV\n\n";
35
36GetOptions(\%opt, qw(
37 perl=s todo=s version=s debug base
38 )) or die;
39
40my $fullperl = `which $opt{perl}`;
41chomp $fullperl;
42
43regen_all();
44
45my %sym;
46for (`nm $fullperl`) {
47 chomp;
48 /\s+T\s+(\w+)\s*$/ and $sym{$1}++;
49}
50keys %sym >= 50 or die "less than 50 symbols found in $fullperl\n";
51
52my %all = %{load_todo($opt{todo}, $opt{version})};
53my @recheck;
54
55for (;;) {
56 my $retry = 1;
57 regen_apicheck();
58retry:
59 my $r = run(qw(make test));
60 $r->{didnotrun} and die "couldn't run make test: $!\n";
61 $r->{status} == 0 and last;
62 my(@new, @tmp, %seen);
63 for my $l (@{$r->{stderr}}) {
64 if ($l =~ /_DPPP_test_(\w+)/) {
65 if (!$seen{$1}++) {
66 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
67 if (@s) {
68 push @tmp, [$1, "E (@s)"];
69 }
70 else {
71 push @new, [$1, "E"];
72 }
73 }
74 }
75 if ($l =~ /undefined symbol: (?:[Pp]erl_)?(\w+)/) {
76 if (!$seen{$1}++) {
77 my @s = grep { exists $sym{$_} } $1, "Perl_$1", "perl_$1";
78 push @new, [$1, @s ? "U (@s)" : "U"];
79 }
80 }
81 }
82 @new = grep !$all{$_->[0]}, @new;
83 unless (@new) {
84 @new = grep !$all{$_->[0]}, @tmp;
85 # TODO: @recheck was here, find a better way to get recheck syms
86 # * we definitely don't have to check (U) symbols
87 # * try to grep out warnings before making symlist ?
88 }
89 unless (@new) {
90 if ($retry > 0) {
91 $retry--;
92 regen_all();
93 goto retry;
94 }
95 print Dumper($r);
96 die "no new TODO symbols found...";
97 }
98 push @recheck, map { $_->[0] } @new;
99 for (@new) {
100 printf "[$opt{version}] new symbol: %-30s # %s\n", @$_;
101 $all{$_->[0]} = $_->[1];
102 }
103 write_todo($opt{todo}, $opt{version}, \%all);
104}
105
106for my $sym (@recheck) {
107 my $cur = delete $all{$sym};
108 printf "[$opt{version}] chk symbol: %-30s # %s\n", $sym, $cur;
109 write_todo($opt{todo}, $opt{version}, \%all);
110 regen_all();
111 my $r = run(qw(make test));
112 $r->{didnotrun} and die "couldn't run make test: $!\n";
113 if ($r->{status} == 0) {
114 printf "[$opt{version}] del symbol: %-30s # %s\n", $sym, $cur;
115 }
116 else {
117 $all{$sym} = $cur;
118 }
119}
120
121write_todo($opt{todo}, $opt{version}, \%all);
122
123run(qw(make realclean));
124
125exit 0;
126
127sub regen_all
128{
129 my @mf_arg = qw( --with-apicheck OPTIMIZE=-O0 );
130 push @mf_arg, qw( DEFINE=-DDPPP_APICHECK_NO_PPPORT_H ) if $opt{base};
131
132 # just to be sure
133 run(qw(make realclean));
134 run($fullperl, "Makefile.PL", @mf_arg)->{status} == 0
135 or die "cannot run Makefile.PL: $!\n";
136}
137
138sub regen_apicheck
139{
140 unlink qw(apicheck.c apicheck.o);
141 system "$fullperl apicheck_c.PL >/dev/null";
142}
143
144sub load_todo
145{
146 my($file, $expver) = @_;
147
148 if (-e $file) {
149 my $f = new IO::File $file or die "cannot open $file: $!\n";
150 my $ver = <$f>;
151 chomp $ver;
152 if ($ver eq $expver) {
153 my %sym;
154 while (<$f>) {
155 chomp;
156 /^(\w+)\s+#\s+(.*)/ or goto nuke_file;
157 exists $sym{$1} and goto nuke_file;
158 $sym{$1} = $2;
159 }
160 return \%sym;
161 }
162
163nuke_file:
164 undef $f;
165 unlink $file or die "cannot remove $file: $!\n";
166 }
167
168 return {};
169}
170
171sub write_todo
172{
173 my($file, $ver, $sym) = @_;
174 my $f;
175
176 $f = new IO::File ">$file" or die "cannot open $file: $!\n";
177 $f->print("$ver\n");
178
179 for (sort keys %$sym) {
180 $f->print(sprintf "%-30s # %s\n", $_, $sym->{$_});
181 }
182}
183
184sub run
185{
186 my $prog = shift;
187 my @args = @_;
188
189 # print "[$prog @args]\n";
190
191 system "$prog @args >tmp.out 2>tmp.err";
192
193 my $out = new IO::File "tmp.out" || die "tmp.out: $!\n";
194 my $err = new IO::File "tmp.err" || die "tmp.err: $!\n";
195
196 my %rval = (
197 status => $? >> 8,
198 stdout => [<$out>],
199 stderr => [<$err>],
200 didnotrun => 0,
201 );
202
203 unlink "tmp.out", "tmp.err";
204
205 $? & 128 and $rval{core} = 1;
206 $? & 127 and $rval{signal} = $? & 127;
207
208 \%rval;
209}
210