mkppport

   1 use strict;
   2 use warnings;
   3
   4 use Getopt::Long;
   5 use File::Spec;
   6 use File::Compare qw( compare );
   7 use File::Copy qw( copy );
   8 use File::Basename qw( dirname );
   9
  10 use feature 'signatures';
  11 no warnings 'experimental::signatures';
  12
  13 my $rootdir = dirname($0);
  14
  15 unshift @INC, File::Spec->catdir($rootdir, qw(cpan ExtUtils-MakeMaker t lib));
  16
  17 eval q{ use MakeMaker::Test::Utils qw( which_perl ) };
  18 $@ and die $@;
  19
  20 my %opt = (
  21   list   => File::Spec->catfile($rootdir, 'mkppport.lst'),
  22   clean  => 0,
  23 );
  24
  25 unless ( GetOptions(\%opt, qw( clean list=s )) ) {
  26   require Pod::Usage;
  27   Pod::Usage::pod2usage(2);
  28 }
  29
  30 my $absroot = File::Spec->rel2abs($rootdir);
  31 my @destdirs = readlist($opt{list});
  32
  33 # Nothing to do...
  34 unless (@destdirs) {
  35   print "no destination directories found in $opt{list}\n";
  36   exit 0;
  37 }
  38
  39 # Remove all installed ppport.h files
  40 if ($opt{clean}) {
  41   iterdirs( sub ($dir, $fulldir) {
  42     my $dest = File::Spec->catfile($fulldir, 'ppport.h');
  43     if (-f $dest) {
  44       print "removing ppport.h for $dir\n";
  45       unlink $dest or warn "WARNING: could not remove $dest: $!\n";
  46       1 while unlink $dest;  # remove any remaining versions
  47     }
  48   } );
  49   exit 0;
  50 }
  51
  52 # Determine full perl location
  53 my $perl = which_perl();
  54
  55 # We're now changing the directory, which confuses the deferred
  56 # loading in Config.pm, so we better use an absolute @INC path
  57 unshift @INC, File::Spec->catdir($absroot, 'lib');
  58
  59 # Change to Devel::PPPort directory, as it needs the stuff
  60 # from the parts/ directory
  61 chdir File::Spec->catdir($rootdir, 'dist', 'Devel-PPPort');
  62
  63 # Capture and remove temporary files
  64 my @unlink;
  65
  66 END {
  67   for my $file (@unlink) {
  68     print "removing temporary file $file\n";
  69     unlink $file or warn "WARNING: could not remove $file: $!\n";
  70     1 while unlink $file;  # remove any remaining versions
  71   }
  72 }
  73
  74 # Try to create a ppport.h if it doesn't exist yet, and
  75 # remember all files that need to be removed later.
  76 unless (-e 'ppport.h') {
  77   unless (-e 'PPPort.pm') {
  78     run('PPPort_pm.PL');
  79     push @unlink, 'PPPort.pm';
  80   }
  81   run('ppport_h.PL');
  82   push @unlink, 'ppport.h';
  83 }
  84
  85 # Now install the created ppport.h into extension directories
  86 iterdirs( sub ($dir, $fulldir) {
  87   my $dest = File::Spec->catfile($fulldir, 'ppport.h');
  88   if (compare('ppport.h', $dest)) {
  89     print "installing ppport.h for $dir\n";
  90     copy('ppport.h', $dest) or die "copying ppport.h to $dest failed: $!\n";
  91   }
  92   else {
  93     print "ppport.h in $dir is up-to-date\n";
  94   }
  95 } );
  96
  97 exit 0;
  98
  99 #---------------------------------------
 100 # Iterate through extension directories
 101 #---------------------------------------
 102 sub iterdirs($code)
 103 {
 104   for my $dir (@destdirs) {
 105     my $fulldir = File::Spec->catdir($absroot, $dir);
 106     if (-d $fulldir) {
 107       $code->($dir, $fulldir);
 108     }
 109     else {
 110       warn "WARNING: no such directory: $fulldir\n";
 111     }
 112   }
 113 }
 114
 115 #----------------------------------------
 116 # Read the list of extension directories
 117 #----------------------------------------
 118 sub readlist($list)
 119 {
 120   my @dirs;
 121   open LIST, $list or die "$list: $!\n";
 122   while (<LIST>) {
 123     chomp;
 124     /^\s*(?:$|#)/ or push @dirs, $_;
 125   }
 126   close LIST;
 127   return @dirs;
 128 }
 129
 130 #----------------------------------------------
 131 # Runs a script in the Devel::PPPort directory
 132 #----------------------------------------------
 133 sub run
 134 {
 135   my @args = ("-I" . File::Spec->catdir((File::Spec->updir) x 2, 'lib'), @_);
 136   my $run = $perl =~ m/\s/ ? qq("$perl") : $perl;
 137   for (@args) {
 138     $_ = qq("$_") if $^O eq 'VMS' && /^[^"]/;
 139     $run .= " $_";
 140   }
 141   print "running $run\n";
 142   system $run and die "$run failed: $?\n";
 143 }
 144
 145 __END__
 146
 147 =head1 NAME
 148
 149 mkppport - distribute ppport.h among extensions
 150
 151 =head1 SYNOPSIS
 152
 153 mkppport [B<--list>=I<file>] [B<--clean>]
 154
 155 =head1 DESCRIPTION
 156
 157 B<mkppport> generates a I<ppport.h> file using Devel::PPPort
 158 and distributes it to the various extension directories that
 159 need it to build.  On certain Win32 builds, this script is not
 160 used and an alternative mechanism is used to create I<ppport.h>.
 161
 162 =head1 OPTIONS
 163
 164 =over 4
 165
 166 =item B<--list>=I<file>
 167
 168 Name of the file that holds the list of extension directories
 169 that I<ppport.h> should be distributed to.
 170 This defaults to I<mkppport.lst> in the same directory as this
 171 script.
 172
 173 =item B<--clean>
 174
 175 Run with this option to clean out all distributed I<ppport.h> files.
 176
 177 =back
 178
 179 =head1 COPYRIGHT
 180
 181 Copyright 2006 by Marcus Holland-Moritz <mhx@cpan.org>.
 182
 183 This program is free software; you may redistribute it
 184 and/or modify it under the same terms as Perl itself.
 185
 186 =cut