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