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