lib/ExtUtils/Packlist.pm

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