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 = '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 Alan Burlison <Alan.Burlison@uk.sun.com>
 294
 295 =cut