ext/Devel-PPPort/devel/regenerate

   1 #!/usr/bin/perl -w
   2 ################################################################################
   3 #
   4 #  regenerate -- regenerate baseline and todo files
   5 #
   6 ################################################################################
   7 #
   8 #  $Revision: 8 $
   9 #  $Author: mhx $
  10 #  $Date: 2009/01/18 14:10:50 +0100 $
  11 #
  12 ################################################################################
  13 #
  14 #  Version 3.x, Copyright (C) 2004-2009, 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
  23 use strict;
  24 use File::Path;
  25 use File::Copy;
  26 use Getopt::Long;
  27 use Pod::Usage;
  28
  29 require 'devel/devtools.pl';
  30
  31 our %opt = (
  32   check   => 1,
  33   verbose => 0,
  34 );
  35
  36 GetOptions(\%opt, qw( check! verbose )) or die pod2usage();
  37
  38 identify();
  39
  40 unless (-e 'parts/embed.fnc' and -e 'parts/apidoc.fnc') {
  41   print "\nOooops, $0 must be run from the Devel::PPPort root directory.\n";
  42   quit_now();
  43 }
  44
  45 ask_or_quit("Are you sure you have updated parts/embed.fnc and parts/apidoc.fnc?");
  46
  47 my %files = map { ($_ => [glob "parts/$_/5*"]) } qw( base todo );
  48
  49 my(@notwr, @wr);
  50 for my $f (map @$_, values %files) {
  51   push @{-w $f ? \@wr : \@notwr}, $f;
  52 }
  53
  54 if (@notwr) {
  55   if (@wr) {
  56     print "\nThe following files are not writable:\n\n";
  57     print "    $_\n" for @notwr;
  58     print "\nAre you sure you have checked out these files?\n";
  59   }
  60   else {
  61     print "\nAll baseline / todo file are not writable.\n";
  62     ask_or_quit("Do you want to try to check out these files?");
  63     unless (runtool("wco", "-l", "-t", "locked by $0", @notwr)) {
  64       print "\nSomething went wrong while checking out the files.\n";
  65       quit_now();
  66     }
  67   }
  68 }
  69
  70 for my $dir (qw( base todo )) {
  71   my $cur = "parts/$dir";
  72   my $old = "$cur-old";
  73   if (-e $old) {
  74     ask_or_quit("Do you want me to remove the old $old directory?");
  75     rmtree($old);
  76   }
  77   mkdir $old;
  78   print "\nBacking up $cur in $old.\n";
  79   for my $src (@{$files{$dir}}) {
  80     my $dst = $src;
  81     $dst =~ s/\E$cur/$old/ or die "Ooops!";
  82     move($src, $dst) or die "Moving $src to $dst failed: $!\n";
  83   }
  84 }
  85
  86 my $T0 = time;
  87 my @args = ddverbose();
  88 push @args, '--nocheck' unless $opt{check};
  89
  90 print "\nBuilding baseline files...\n\n";
  91
  92 unless (runperl('devel/mktodo', '--base', @args)) {
  93   print "\nSomething went wrong while building the baseline files.\n";
  94   quit_now();
  95 }
  96
  97 print "\nMoving baseline files...\n\n";
  98
  99 for my $src (glob 'parts/todo/5*') {
 100   my $dst = $src;
 101   $dst =~ s/todo/base/ or die "Ooops!";
 102   move($src, $dst) or die "Moving $src to $dst failed: $!\n";
 103 }
 104
 105 print "\nBuilding todo files...\n\n";
 106
 107 unless (runperl('devel/mktodo', @args)) {
 108   print "\nSomething went wrong while building the baseline files.\n";
 109   quit_now();
 110 }
 111
 112 print "\nAdding remaining baseline info...\n\n";
 113
 114 unless (runperl('Makefile.PL') and
 115         runtool('make') and
 116         runperl('devel/scanprov', 'write')) {
 117   print "\nSomething went wrong while adding the baseline info.\n";
 118   quit_now();
 119 }
 120
 121 my($wall, $usr, $sys, $cusr, $csys) = (time - $T0, times);
 122 my $cpu = sprintf "%.2f", $usr + $sys + $cusr + $csys;
 123 $usr = sprintf "%.2f", $usr + $cusr;
 124 $sys = sprintf "%.2f", $sys + $csys;
 125
 126 print <<END;
 127
 128 API info regenerated successfully.
 129
 130 Finished in $wall wallclock secs ($usr usr + $sys sys = $cpu CPU)
 131
 132 Don't forget to check in the files in parts/base and parts/todo.
 133
 134 END
 135
 136 __END__
 137
 138 =head1 NAME
 139
 140 regenerate - Automatically regeneate Devel::PPPort's API information
 141
 142 =head1 SYNOPSIS
 143
 144   regenerate [options]
 145
 146   --nocheck      don't recheck symbols that caused an error
 147   --verbose      show verbose output
 148
 149 =head1 COPYRIGHT
 150
 151 Copyright (c) 2006-2009, Marcus Holland-Moritz.
 152
 153 This program is free software; you can redistribute it and/or
 154 modify it under the same terms as Perl itself.
 155
 156 =head1 SEE ALSO
 157
 158 See L<Devel::PPPort> and L<HACKERS>.
 159
 160 =cut
 161