1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
|
#!/usr/bin/perl -w
################################################################################
#
# regenerate -- regenerate baseline and todo files
#
################################################################################
#
# Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
# Version 2.x, Copyright (C) 2001, Paul Marquess.
# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
################################################################################
use strict;
use File::Path;
use File::Copy;
use Getopt::Long;
use Pod::Usage;
require './devel/devtools.pl';
require './parts/ppptools.pl';
our %opt = (
check => 1,
debug => 0,
verbose => 0,
yes => 0,
);
GetOptions(\%opt, qw( check! verbose yes install=s blead=s blead-version=s
debug=i debug-start=s)) or die pod2usage();
identify();
unless (-e 'parts/embed.fnc' and -e 'parts/apidoc.fnc') {
print "\nOooops, $0 must be run from the Devel::PPPort root directory.\n";
quit_now();
}
if (! $opt{'yes'}) {
ask_or_quit("Are you SURE you have:\n1) updated parts/embed.fnc to latest blead?\n2) run devel/mkapidoc.pl to update parts/apidoc.fnc?\n3) run devel/mkppport_fnc.pl to update parts/ppport.fnc?\n");
}
my $files_glob_pattern = '[12345789]*';
my %files = map { ($_ => [glob "parts/$_/$files_glob_pattern"]) } qw( base todo );
my(@notwr, @wr);
for my $f (map @$_, values %files) {
push @{-w $f ? \@wr : \@notwr}, $f;
}
if (@notwr) {
if (@wr) {
print "\nThe following files are not writable:\n\n";
print " $_\n" for @notwr;
print "\nAre you sure you have checked out these files?\n";
}
else {
print "\nAll baseline / todo file are not writable.\n";
ask_or_quit("Do you want to try to check out these files?");
unless (runtool("wco", "-l", "-t", "locked by $0", @notwr)) {
print "\nSomething went wrong while checking out the files.\n";
quit_now();
}
}
}
# Check that there is only one entry in the whole system for each item
my @embeds = parse_embed(qw(parts/embed.fnc parts/apidoc.fnc parts/ppport.fnc));
my %seen;
for my $entry (@embeds) {
my $Mflag = defined $entry->{flags}{M};
$seen{"$entry->{name}/$entry->{cond}/$Mflag"}++;
}
my %bads = grep { $seen{$_} > 1 } keys %seen;
if (keys %bads) {
print "The following items have multiple entries in the parts/*.fnc files.\n",
" Regenerate apidoc.fnc, then ppport.fnc and try again. If this\n",
" doesn't work, choose the best version for each symbol and delete\n",
" the others: ",
join "\n", keys %bads, "\n";
quit_now();
}
if (-e 'ppport.h') {
my $blead = $opt{blead};
$blead = get_and_sort_perls(\%opt)->[0]->{path} unless $blead;
# Get list of things we provide
my %provided = map { /^(\w+)/ ? ( $1 => 1 ) : () }
`$blead ppport.h --list-provided`;
# Get the list of macros that are hard to test.
my @unorthodox = map { exists $_->{flags}{u} ? $_->{name} : () } @embeds;
# Keep on that list only the things we provide
@unorthodox = grep { exists $provided{$_} } @unorthodox;
# And get the list of known hard things.
my $hard_ref = &known_but_hard_to_test_for;
# If we provide something, it better be on the known things list
my @bad = grep { ! exists $hard_ref->{$_} } @unorthodox;
undef @bad;
if (@bad) {
print "The following items need to be manually added to the list in",
" parts/ppptools.pl: known_but_hard_to_test_for(): ",
join ", ", @bad, "\n";
quit_now();
}
}
# If starting in the middle, don't zap what we've already done
if (! $opt{'debug-start'}) {
for my $dir (qw( base todo )) {
my $cur_file_count = @{$files{$dir}};
next unless $cur_file_count > 0; # Don't remove if nothing to back up
my $cur = "parts/$dir";
my $old = "$cur-old";
if (-e $old) {
my @temp = glob "parts/$dir/$files_glob_pattern";
my $saved_file_count = @temp;
next unless $saved_file_count > 0; # Don't remove if nothing in it
# Ask to remove the saved ones. If there are already many saved
# files, ask even if the parameter says the answer is always yes.
# (The criteria here for "many" could be profitably revised)
if ($saved_file_count > $cur_file_count || ! $opt{'yes'}) {
my $message = "";;
$message .= "There are $saved_file_count already saved files,"
. " and $cur_file_count new ones\n"
if $cur_file_count > 0;
$message .= "Do you want me to remove the old $old directory?";
ask_or_quit($message);
}
rmtree($old);
}
mkdir $old;
print "\nBacking up $cur in $old.\n";
for my $src (@{$files{$dir}}) {
my $dst = $src;
$dst =~ s/\Q$cur/$old/ or die "Ooops!";
move($src, $dst) or die "Moving $src to $dst failed: $!\n";
}
}
}
my @perlargs;
push @perlargs, "--debug=$opt{debug}" if $opt{debug};
push @perlargs, "--install=$opt{install}" if $opt{install};
push @perlargs, "--blead=$opt{blead}" if $opt{blead};
push @perlargs, "--debug-start=$opt{'debug-start'}" if $opt{'debug-start'};
my $T0 = time;
my @args = ddverbose();
push @args, '--nocheck' unless $opt{check};
push @args, "--blead-version=$opt{'blead-version'}" if $opt{'blead-version'};
push @args, @perlargs;
# Look for all the NEED_foo macros
my @NEED;
for my $file (all_files_in_dir('parts/inc')) {
my $spec = parse_partspec($file);
next unless $spec->{'xsinit'};
while ($spec->{'xsinit'} =~ / ^ ( \# \s* define \s+ NEED_ \w+ ) \s /xmg) {
push @NEED, "$1";
}
}
# Make the list available to parts/apicheck.pl
$ENV{'DPPP_NEED'} = join "\n", sort @NEED;
# Find out what symbols were in what releases
print "\nBuilding baseline files...\n\n";
unless (runperl('devel/mktodo', '--base', @args)) {
print "\nSomething went wrong while building the baseline files.\n";
quit_now();
}
# Then find out what ppport.h buys us by repeating the process above, but
# using ppport.h
print "\nBuilding todo files...\n\n";
unless (runperl('devel/mktodo', @args)) {
print "\nSomething went wrong while building the todo files.\n";
quit_now();
}
print "\nAdding remaining info...\n\n";
unless (runperl('Makefile.PL') and
runtool('make') and
runperl('devel/scanprov', '--mode=write', @perlargs)) {
print "\nSomething went wrong while adding the baseline info.\n";
quit_now();
}
my($wall, $usr, $sys, $cusr, $csys) = (time - $T0, times);
my $cpu = sprintf "%.2f", $usr + $sys + $cusr + $csys;
$usr = sprintf "%.2f", $usr + $cusr;
$sys = sprintf "%.2f", $sys + $csys;
print <<END;
API info regenerated successfully.
Finished in $wall wallclock secs ($usr usr + $sys sys = $cpu CPU)
Don't forget to check in the files in parts/base and parts/todo.
END
__END__
=head1 NAME
regenerate - Automatically regenerate Devel::PPPort's API information
=head1 SYNOPSIS
regenerate [options]
--nocheck don't recheck symbols that caused an error
--verbose show verbose output
--yes the answer to all the standard questions is 'yes',
can be used to nohup this.
=head1 COPYRIGHT
Copyright (c) 2006-2013, Marcus Holland-Moritz.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
See L<Devel::PPPort> and L<HACKERS>.
=cut
|
