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