lib/ExtUtils/Packlist.pm

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