Commit | Line | Data |
93cd2f30 |
1 | package ExtUtils::Packlist; |
17f410f9 |
2 | |
57b1a898 |
3 | use 5.00503; |
93cd2f30 |
4 | use strict; |
5 | use Carp qw(); |
2670f2fb |
6 | use Config; |
c776f839 |
7 | use vars qw($VERSION $Relocations); |
060fb22c |
8 | $VERSION = '1.43'; |
3a465856 |
9 | $VERSION = eval $VERSION; |
93cd2f30 |
10 | |
11 | # Used for generating filehandle globs. IO::File might not be available! |
12 | my $fhname = "FH1"; |
13 | |
3a465856 |
14 | =begin _undocumented |
15 | |
16 | =item mkfh() |
17 | |
18 | Make a filehandle. Same kind of idea as Symbol::gensym(). |
19 | |
3a465856 |
20 | =cut |
21 | |
93cd2f30 |
22 | sub mkfh() |
23 | { |
24 | no strict; |
25 | my $fh = \*{$fhname++}; |
26 | use strict; |
27 | return($fh); |
28 | } |
29 | |
c776f839 |
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 | |
93cd2f30 |
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; |
2670f2fb |
127 | my ($key, $data) = $line; |
411cc70a |
128 | if ($key =~ /^(.*?)( \w+=.*)$/) |
129 | { |
130 | $key = $1; |
2670f2fb |
131 | $data = { map { split('=', $_) } split(' ', $2)}; |
c776f839 |
132 | |
133 | if ($Config{userelocatableinc} && $data->{relocate_as}) |
060fb22c |
134 | { |
c776f839 |
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); |
411cc70a |
140 | } |
060fb22c |
141 | } |
9b604809 |
142 | $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths |
060fb22c |
143 | $self->{data}->{$key} = $data; |
144 | } |
93cd2f30 |
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 | { |
c776f839 |
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 | } |
93cd2f30 |
183 | print $fh ("$key"); |
c776f839 |
184 | if (ref($data)) |
93cd2f30 |
185 | { |
93cd2f30 |
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 | |
9b604809 |
212 | sub packlist_file($) |
213 | { |
214 | my ($self) = @_; |
215 | $self = tied(%$self) || $self; |
216 | return($self->{packfile}); |
217 | } |
218 | |
93cd2f30 |
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 | |
bbc7dcd2 |
262 | =over 4 |
93cd2f30 |
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 | |
9b604809 |
292 | =item packlist_file() |
293 | |
294 | This returns the name of the associated .packlist file |
295 | |
93cd2f30 |
296 | =back |
297 | |
ddf41153 |
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 | |
93cd2f30 |
344 | =head1 AUTHOR |
345 | |
346 | Alan Burlison <Alan.Burlison@uk.sun.com> |
347 | |
348 | =cut |