Move ExtUtils::Install from ext/ to dist/
[perl.git] / dist / ExtUtils-Install / lib / ExtUtils / Packlist.pm
1 package ExtUtils::Packlist;
2
3 use 5.00503;
4 use strict;
5 use Carp qw();
6 use Config;
7 use vars qw($VERSION $Relocations);
8 $VERSION = '1.43';
9 $VERSION = eval $VERSION;
10
11 # Used for generating filehandle globs.  IO::File might not be available!
12 my $fhname = "FH1";
13
14 =begin _undocumented
15
16 =item mkfh()
17
18 Make a filehandle. Same kind of idea as Symbol::gensym().
19
20 =cut
21
22 sub mkfh()
23 {
24 no strict;
25 my $fh = \*{$fhname++};
26 use strict;
27 return($fh);
28 }
29
30 =item __find_relocations
31
32 Works out what absolute paths in the configuration have been located at run
33 time relative to $^X, and generates a regexp that matches them
34
35 =end _undocumented
36
37 =cut
38
39 sub __find_relocations
40 {
41     my %paths;
42     while (my ($raw_key, $raw_val) = each %Config) {
43         my $exp_key = $raw_key . "exp";
44         next unless exists $Config{$exp_key};
45         next unless $raw_val =~ m!\.\.\./!;
46         $paths{$Config{$exp_key}}++;
47     }
48     # Longest prefixes go first in the alternatives
49     my $alternations = join "|", map {quotemeta $_}
50     sort {length $b <=> length $a} keys %paths;
51     qr/^($alternations)/o;
52 }
53
54 sub new($$)
55 {
56 my ($class, $packfile) = @_;
57 $class = ref($class) || $class;
58 my %self;
59 tie(%self, $class, $packfile);
60 return(bless(\%self, $class));
61 }
62
63 sub TIEHASH
64 {
65 my ($class, $packfile) = @_;
66 my $self = { packfile => $packfile };
67 bless($self, $class);
68 $self->read($packfile) if (defined($packfile) && -f $packfile);
69 return($self);
70 }
71
72 sub STORE
73 {
74 $_[0]->{data}->{$_[1]} = $_[2];
75 }
76
77 sub FETCH
78 {
79 return($_[0]->{data}->{$_[1]});
80 }
81
82 sub FIRSTKEY
83 {
84 my $reset = scalar(keys(%{$_[0]->{data}}));
85 return(each(%{$_[0]->{data}}));
86 }
87
88 sub NEXTKEY
89 {
90 return(each(%{$_[0]->{data}}));
91 }
92
93 sub EXISTS
94 {
95 return(exists($_[0]->{data}->{$_[1]}));
96 }
97
98 sub DELETE
99 {
100 return(delete($_[0]->{data}->{$_[1]}));
101 }
102
103 sub CLEAR
104 {
105 %{$_[0]->{data}} = ();
106 }
107
108 sub DESTROY
109 {
110 }
111
112 sub read($;$)
113 {
114 my ($self, $packfile) = @_;
115 $self = tied(%$self) || $self;
116
117 if (defined($packfile)) { $self->{packfile} = $packfile; }
118 else { $packfile = $self->{packfile}; }
119 Carp::croak("No packlist filename specified") if (! defined($packfile));
120 my $fh = mkfh();
121 open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!");
122 $self->{data} = {};
123 my ($line);
124 while (defined($line = <$fh>))
125    {
126    chomp $line;
127    my ($key, $data) = $line;
128    if ($key =~ /^(.*?)( \w+=.*)$/)
129       {
130       $key = $1;
131       $data = { map { split('=', $_) } split(' ', $2)};
132
133       if ($Config{userelocatableinc} && $data->{relocate_as})
134       {
135           require File::Spec;
136           require Cwd;
137           my ($vol, $dir) = File::Spec->splitpath($packfile);
138           my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
139           $key = Cwd::realpath($newpath);
140       }
141          }
142    $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
143       $self->{data}->{$key} = $data;
144       }
145 close($fh);
146 }
147
148 sub write($;$)
149 {
150 my ($self, $packfile) = @_;
151 $self = tied(%$self) || $self;
152 if (defined($packfile)) { $self->{packfile} = $packfile; }
153 else { $packfile = $self->{packfile}; }
154 Carp::croak("No packlist filename specified") if (! defined($packfile));
155 my $fh = mkfh();
156 open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
157 foreach my $key (sort(keys(%{$self->{data}})))
158    {
159        my $data = $self->{data}->{$key};
160        if ($Config{userelocatableinc}) {
161            $Relocations ||= __find_relocations();
162            if ($packfile =~ $Relocations) {
163                # We are writing into a subdirectory of a run-time relocated
164                # path. Figure out if the this file is also within a subdir.
165                my $prefix = $1;
166                if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
167                {
168                    # The relocated path is within the found prefix
169                    my $packfile_prefix;
170                    (undef, $packfile_prefix)
171                        = File::Spec->splitpath($packfile);
172
173                    my $relocate_as
174                        = File::Spec->abs2rel($key, $packfile_prefix);
175
176                    if (!ref $data) {
177                        $data = {};
178                    }
179                    $data->{relocate_as} = $relocate_as;
180                }
181            }
182        }
183    print $fh ("$key");
184    if (ref($data))
185       {
186       foreach my $k (sort(keys(%$data)))
187          {
188          print $fh (" $k=$data->{$k}");
189          }
190       }
191    print $fh ("\n");
192    }
193 close($fh);
194 }
195
196 sub validate($;$)
197 {
198 my ($self, $remove) = @_;
199 $self = tied(%$self) || $self;
200 my @missing;
201 foreach my $key (sort(keys(%{$self->{data}})))
202    {
203    if (! -e $key)
204       {
205       push(@missing, $key);
206       delete($self->{data}{$key}) if ($remove);
207       }
208    }
209 return(@missing);
210 }
211
212 sub packlist_file($)
213 {
214 my ($self) = @_;
215 $self = tied(%$self) || $self;
216 return($self->{packfile});
217 }
218
219 1;
220
221 __END__
222
223 =head1 NAME
224
225 ExtUtils::Packlist - manage .packlist files
226
227 =head1 SYNOPSIS
228
229    use ExtUtils::Packlist;
230    my ($pl) = ExtUtils::Packlist->new('.packlist');
231    $pl->read('/an/old/.packlist');
232    my @missing_files = $pl->validate();
233    $pl->write('/a/new/.packlist');
234
235    $pl->{'/some/file/name'}++;
236       or
237    $pl->{'/some/other/file/name'} = { type => 'file',
238                                       from => '/some/file' };
239
240 =head1 DESCRIPTION
241
242 ExtUtils::Packlist provides a standard way to manage .packlist files.
243 Functions are provided to read and write .packlist files.  The original
244 .packlist format is a simple list of absolute pathnames, one per line.  In
245 addition, this package supports an extended format, where as well as a filename
246 each line may contain a list of attributes in the form of a space separated
247 list of key=value pairs.  This is used by the installperl script to
248 differentiate between files and links, for example.
249
250 =head1 USAGE
251
252 The hash reference returned by the new() function can be used to examine and
253 modify the contents of the .packlist.  Items may be added/deleted from the
254 .packlist by modifying the hash.  If the value associated with a hash key is a
255 scalar, the entry written to the .packlist by any subsequent write() will be a
256 simple filename.  If the value is a hash, the entry written will be the
257 filename followed by the key=value pairs from the hash.  Reading back the
258 .packlist will recreate the original entries.
259
260 =head1 FUNCTIONS
261
262 =over 4
263
264 =item new()
265
266 This takes an optional parameter, the name of a .packlist.  If the file exists,
267 it will be opened and the contents of the file will be read.  The new() method
268 returns a reference to a hash.  This hash holds an entry for each line in the
269 .packlist.  In the case of old-style .packlists, the value associated with each
270 key is undef.  In the case of new-style .packlists, the value associated with
271 each key is a hash containing the key=value pairs following the filename in the
272 .packlist.
273
274 =item read()
275
276 This takes an optional parameter, the name of the .packlist to be read.  If
277 no file is specified, the .packlist specified to new() will be read.  If the
278 .packlist does not exist, Carp::croak will be called.
279
280 =item write()
281
282 This takes an optional parameter, the name of the .packlist to be written.  If
283 no file is specified, the .packlist specified to new() will be overwritten.
284
285 =item validate()
286
287 This checks that every file listed in the .packlist actually exists.  If an
288 argument which evaluates to true is given, any missing files will be removed
289 from the internal hash.  The return value is a list of the missing files, which
290 will be empty if they all exist.
291
292 =item packlist_file()
293
294 This returns the name of the associated .packlist file
295
296 =back
297
298 =head1 EXAMPLE
299
300 Here's C<modrm>, a little utility to cleanly remove an installed module.
301
302     #!/usr/local/bin/perl -w
303
304     use strict;
305     use IO::Dir;
306     use ExtUtils::Packlist;
307     use ExtUtils::Installed;
308
309     sub emptydir($) {
310         my ($dir) = @_;
311         my $dh = IO::Dir->new($dir) || return(0);
312         my @count = $dh->read();
313         $dh->close();
314         return(@count == 2 ? 1 : 0);
315     }
316
317     # Find all the installed packages
318     print("Finding all installed modules...\n");
319     my $installed = ExtUtils::Installed->new();
320
321     foreach my $module (grep(!/^Perl$/, $installed->modules())) {
322        my $version = $installed->version($module) || "???";
323        print("Found module $module Version $version\n");
324        print("Do you want to delete $module? [n] ");
325        my $r = <STDIN>; chomp($r);
326        if ($r && $r =~ /^y/i) {
327           # Remove all the files
328           foreach my $file (sort($installed->files($module))) {
329              print("rm $file\n");
330              unlink($file);
331           }
332           my $pf = $installed->packlist($module)->packlist_file();
333           print("rm $pf\n");
334           unlink($pf);
335           foreach my $dir (sort($installed->directory_tree($module))) {
336              if (emptydir($dir)) {
337                 print("rmdir $dir\n");
338                 rmdir($dir);
339              }
340           }
341        }
342     }
343
344 =head1 AUTHOR
345
346 Alan Burlison <Alan.Burlison@uk.sun.com>
347
348 =cut