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