lib/ExtUtils/Packlist.pm

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