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