Test for namedprotos: @_ should be a valid slurpy param
[perl.git] / 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 sub iterdirs(&);
11
12 my $rootdir = dirname($0);
13
14 unshift @INC, File::Spec->catdir($rootdir, qw(cpan ExtUtils-MakeMaker t lib));
15
16 eval q{ use MakeMaker::Test::Utils qw( which_perl ) };
17 $@ and die $@;
18
19 my %opt = (
20   list   => File::Spec->catfile($rootdir, 'mkppport.lst'),
21   clean  => 0,
22 );
23
24 unless ( GetOptions(\%opt, qw( clean list=s )) ) {
25   require Pod::Usage;
26   Pod::Usage::pod2usage(2);
27 }
28
29 my $absroot = File::Spec->rel2abs($rootdir);
30 my @destdirs = readlist($opt{list});
31
32 # Nothing to do...
33 unless (@destdirs) {
34   print "no destination directories found in $opt{list}\n";
35   exit 0;
36 }
37
38 # Remove all installed ppport.h files
39 if ($opt{clean}) {
40   iterdirs {
41     my($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, 'cpan', '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 {
87   my($dir, $fulldir) = @_;
88   my $dest = File::Spec->catfile($fulldir, 'ppport.h');
89   if (compare('ppport.h', $dest)) {
90     print "installing ppport.h for $dir\n";
91     copy('ppport.h', $dest) or die "copying ppport.h to $dest failed: $!\n";
92   }
93   else {
94     print "ppport.h in $dir is up-to-date\n";
95   }
96 };
97
98 exit 0;
99
100 #---------------------------------------
101 # Iterate through extension directories
102 #---------------------------------------
103 sub iterdirs(&)
104 {
105   my $code = shift;
106   
107   for my $dir (@destdirs) {
108     my $fulldir = File::Spec->catdir($absroot, $dir);
109     if (-d $fulldir) {
110       $code->($dir, $fulldir);
111     }
112     else {
113       warn "WARNING: no such directory: $fulldir\n";
114     }
115   }
116 }
117
118 #----------------------------------------
119 # Read the list of extension directories
120 #----------------------------------------
121 sub readlist
122 {
123   my $list = shift;
124   my @dirs;
125   open LIST, $list or die "$list: $!\n";
126   while (<LIST>) {
127     chomp;
128     /^\s*(?:$|#)/ or push @dirs, $_;
129   }
130   close LIST;
131   return @dirs;
132 }
133
134 #----------------------------------------------
135 # Runs a script in the Devel::PPPort directory
136 #----------------------------------------------
137 sub run
138 {
139   my @args = ("-I" . File::Spec->catdir((File::Spec->updir) x 2, 'lib'), @_);
140   my $run = $perl =~ m/\s/ ? qq("$perl") : $perl;
141   for (@args) {
142     $_ = qq("$_") if $^O eq 'VMS' && /^[^"]/;
143     $run .= " $_";
144   }
145   print "running $run\n";
146   system $run and die "$run failed: $?\n";
147 }
148
149 __END__
150
151 =head1 NAME
152
153 mkppport - distribute ppport.h among extensions
154
155 =head1 SYNOPSIS
156
157 mkppport [B<--list>=I<file>] [B<--clean>]
158
159 =head1 DESCRIPTION
160
161 B<mkppport> generates a I<ppport.h> file using Devel::PPPort
162 and distributes it to the various extension directories that
163 need it to build.
164
165 =head1 OPTIONS
166
167 =over 4
168
169 =item B<--list>=I<file>
170
171 Name of the file that holds the list of extension directories
172 that I<ppport.h> should be distributed to.
173 This defaults to I<mkppport.lst> in the same directory as this
174 script.
175
176 =item B<--clean>
177
178 Run with this option to clean out all distributed I<ppport.h> files.
179
180 =back
181
182 =head1 COPYRIGHT
183
184 Copyright 2006 by Marcus Holland-Moritz <mhx@cpan.org>.
185
186 This program is free software; you may redistribute it
187 and/or modify it under the same terms as Perl itself.
188
189 =cut