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