[Summary view] [Print] [Text view]

   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