lib/ExtUtils/Packlist.pm

   1 package ExtUtils::Packlist;
   2
   3 use 5.00503;
   4 use strict;
   5 use Carp qw();
   6 use vars qw($VERSION);
   7 $VERSION = '1.38';
   8 $VERSION = eval $VERSION;
   9
  10 # Used for generating filehandle globs.  IO::File might not be available!
  11 my $fhname = "FH1";
  12
  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
  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;
 104    my ($key, @kvs) = $line;
 105    if ($key =~ /^(.*?)( \w+=.*)$/)
 106       {
 107       $key = $1;
 108       @kvs = split(' ', $2);
 109       }
 110    $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
 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
 170 sub packlist_file($)
 171 {
 172 my ($self) = @_;
 173 $self = tied(%$self) || $self;
 174 return($self->{packfile});
 175 }
 176
 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
 220 =over 4
 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
 250 =item packlist_file()
 251
 252 This returns the name of the associated .packlist file
 253
 254 =back
 255
 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
 302 =head1 AUTHOR
 303
 304 Alan Burlison <Alan.Burlison@uk.sun.com>
 305
 306 =cut