dist/Devel-PPPort/devel/regenerate

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