lib/ExtUtils/Packlist.pm

   1 package ExtUtils::Packlist;
   2
   3 use 5.006;
   4 use strict;
   5 use Carp qw();
   6 our $VERSION = '0.04';
   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) = $line;
  93    if ($key =~ /^(.*?)( \w+=.*)$/)
  94       {
  95       $key = $1;
  96       @kvs = split(' ', $2);
  97       }
  98    $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
  99    if (! @kvs)
 100       {
 101       $self->{data}->{$key} = undef;
 102       }
 103    else
 104       {
 105       my ($data) = {};
 106       foreach my $kv (@kvs)
 107          {
 108          my ($k, $v) = split('=', $kv);
 109          $data->{$k} = $v;
 110          }
 111       $self->{data}->{$key} = $data;
 112       }
 113    }
 114 close($fh);
 115 }
 116
 117 sub write($;$)
 118 {
 119 my ($self, $packfile) = @_;
 120 $self = tied(%$self) || $self;
 121 if (defined($packfile)) { $self->{packfile} = $packfile; }
 122 else { $packfile = $self->{packfile}; }
 123 Carp::croak("No packlist filename specified") if (! defined($packfile));
 124 my $fh = mkfh();
 125 open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
 126 foreach my $key (sort(keys(%{$self->{data}})))
 127    {
 128    print $fh ("$key");
 129    if (ref($self->{data}->{$key}))
 130       {
 131       my $data = $self->{data}->{$key};
 132       foreach my $k (sort(keys(%$data)))
 133          {
 134          print $fh (" $k=$data->{$k}");
 135          }
 136       }
 137    print $fh ("\n");
 138    }
 139 close($fh);
 140 }
 141
 142 sub validate($;$)
 143 {
 144 my ($self, $remove) = @_;
 145 $self = tied(%$self) || $self;
 146 my @missing;
 147 foreach my $key (sort(keys(%{$self->{data}})))
 148    {
 149    if (! -e $key)
 150       {
 151       push(@missing, $key);
 152       delete($self->{data}{$key}) if ($remove);
 153       }
 154    }
 155 return(@missing);
 156 }
 157
 158 sub packlist_file($)
 159 {
 160 my ($self) = @_;
 161 $self = tied(%$self) || $self;
 162 return($self->{packfile});
 163 }
 164
 165 1;
 166
 167 __END__
 168
 169 =head1 NAME
 170
 171 ExtUtils::Packlist - manage .packlist files
 172
 173 =head1 SYNOPSIS
 174
 175    use ExtUtils::Packlist;
 176    my ($pl) = ExtUtils::Packlist->new('.packlist');
 177    $pl->read('/an/old/.packlist');
 178    my @missing_files = $pl->validate();
 179    $pl->write('/a/new/.packlist');
 180
 181    $pl->{'/some/file/name'}++;
 182       or
 183    $pl->{'/some/other/file/name'} = { type => 'file',
 184                                       from => '/some/file' };
 185
 186 =head1 DESCRIPTION
 187
 188 ExtUtils::Packlist provides a standard way to manage .packlist files.
 189 Functions are provided to read and write .packlist files.  The original
 190 .packlist format is a simple list of absolute pathnames, one per line.  In
 191 addition, this package supports an extended format, where as well as a filename
 192 each line may contain a list of attributes in the form of a space separated
 193 list of key=value pairs.  This is used by the installperl script to
 194 differentiate between files and links, for example.
 195
 196 =head1 USAGE
 197
 198 The hash reference returned by the new() function can be used to examine and
 199 modify the contents of the .packlist.  Items may be added/deleted from the
 200 .packlist by modifying the hash.  If the value associated with a hash key is a
 201 scalar, the entry written to the .packlist by any subsequent write() will be a
 202 simple filename.  If the value is a hash, the entry written will be the
 203 filename followed by the key=value pairs from the hash.  Reading back the
 204 .packlist will recreate the original entries.
 205
 206 =head1 FUNCTIONS
 207
 208 =over 4
 209
 210 =item new()
 211
 212 This takes an optional parameter, the name of a .packlist.  If the file exists,
 213 it will be opened and the contents of the file will be read.  The new() method
 214 returns a reference to a hash.  This hash holds an entry for each line in the
 215 .packlist.  In the case of old-style .packlists, the value associated with each
 216 key is undef.  In the case of new-style .packlists, the value associated with
 217 each key is a hash containing the key=value pairs following the filename in the
 218 .packlist.
 219
 220 =item read()
 221
 222 This takes an optional parameter, the name of the .packlist to be read.  If
 223 no file is specified, the .packlist specified to new() will be read.  If the
 224 .packlist does not exist, Carp::croak will be called.
 225
 226 =item write()
 227
 228 This takes an optional parameter, the name of the .packlist to be written.  If
 229 no file is specified, the .packlist specified to new() will be overwritten.
 230
 231 =item validate()
 232
 233 This checks that every file listed in the .packlist actually exists.  If an
 234 argument which evaluates to true is given, any missing files will be removed
 235 from the internal hash.  The return value is a list of the missing files, which
 236 will be empty if they all exist.
 237
 238 =item packlist_file()
 239
 240 This returns the name of the associated .packlist file
 241
 242 =back
 243
 244 =head1 EXAMPLE
 245
 246 Here's C<modrm>, a little utility to cleanly remove an installed module.
 247
 248     #!/usr/local/bin/perl -w
 249
 250     use strict;
 251     use IO::Dir;
 252     use ExtUtils::Packlist;
 253     use ExtUtils::Installed;
 254
 255     sub emptydir($) {
 256         my ($dir) = @_;
 257         my $dh = IO::Dir->new($dir) || return(0);
 258         my @count = $dh->read();
 259         $dh->close();
 260         return(@count == 2 ? 1 : 0);
 261     }
 262
 263     # Find all the installed packages
 264     print("Finding all installed modules...\n");
 265     my $installed = ExtUtils::Installed->new();
 266
 267     foreach my $module (grep(!/^Perl$/, $installed->modules())) {
 268        my $version = $installed->version($module) || "???";
 269        print("Found module $module Version $version\n");
 270        print("Do you want to delete $module? [n] ");
 271        my $r = <STDIN>; chomp($r);
 272        if ($r && $r =~ /^y/i) {
 273           # Remove all the files
 274           foreach my $file (sort($installed->files($module))) {
 275              print("rm $file\n");
 276              unlink($file);
 277           }
 278           my $pf = $installed->packlist($module)->packlist_file();
 279           print("rm $pf\n");
 280           unlink($pf);
 281           foreach my $dir (sort($installed->directory_tree($module))) {
 282              if (emptydir($dir)) {
 283                 print("rmdir $dir\n");
 284                 rmdir($dir);
 285              }
 286           }
 287        }
 288     }
 289
 290 =head1 AUTHOR
 291
 292 Alan Burlison <Alan.Burlison@uk.sun.com>
 293
 294 =cut