Fixes for the test suite on OS/2

[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / Packlist.pm

diff --git a/lib/ExtUtils/Packlist.pm b/lib/ExtUtils/Packlist.pm
index a012849..5965bbc 100644 (file)
--- a/lib/ExtUtils/Packlist.pm
+++ b/lib/ExtUtils/Packlist.pm
@@ -1,12 +1,24 @@
 package ExtUtils::Packlist;
+
+use 5.00503;
 use strict;
 use Carp qw();
-use vars qw($VERSION);
-$VERSION = '0.02';
+use Config;
+use vars qw($VERSION $Relocations);
+$VERSION = '1.41';
+$VERSION = eval $VERSION;
 
 # Used for generating filehandle globs.  IO::File might not be available!
 my $fhname = "FH1";
 
+=begin _undocumented
+
+=item mkfh()
+
+Make a filehandle. Same kind of idea as Symbol::gensym().
+
+=cut
+
 sub mkfh()
 {
 no strict;
@@ -15,6 +27,30 @@ use strict;
 return($fh);
 }
 
+=item __find_relocations
+
+Works out what absolute paths in the configuration have been located at run
+time relative to $^X, and generates a regexp that matches them
+
+=end _undocumented
+
+=cut
+
+sub __find_relocations
+{
+    my %paths;
+    while (my ($raw_key, $raw_val) = each %Config) {
+       my $exp_key = $raw_key . "exp";
+       next unless exists $Config{$exp_key};
+       next unless $raw_val =~ m!\.\.\./!;
+       $paths{$Config{$exp_key}}++;
+    }
+    # Longest prefixes go first in the alternatives
+    my $alternations = join "|", map {quotemeta $_}
+    sort {length $b <=> length $a} keys %paths;
+    qr/^($alternations)/o;
+}
+
 sub new($$)
 {
 my ($class, $packfile) = @_;
@@ -88,22 +124,23 @@ my ($line);
 while (defined($line = <$fh>))
    {
    chomp $line;
-   my ($key, @kvs) = split(' ', $line);
-   $key =~ s!/./!/!g;   # Some .packlists have spurious '/./' bits in the paths
-   if (! @kvs)
-      {
-      $self->{data}->{$key} = undef;
-      }
-   else
+   my ($key, $data) = $line;
+   if ($key =~ /^(.*?)( \w+=.*)$/)
       {
-      my ($data) = {};
-      foreach my $kv (@kvs)
-         {
-         my ($k, $v) = split('=', $kv);
-         $data->{$k} = $v;
-         }
-      $self->{data}->{$key} = $data;
+      $key = $1;
+      $data = { map { split('=', $_) } split(' ', $2)};
+
+      if ($Config{userelocatableinc} && $data->{relocate_as})
+          {
+         require File::Spec;
+         require Cwd;
+         my ($vol, $dir) = File::Spec->splitpath($packfile);
+         my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as});
+         $key = Cwd::realpath($newpath);
+          }
       }
+   $key =~ s!/\./!/!g;   # Some .packlists have spurious '/./' bits in the paths
+   $self->{data}->{$key} = $data;
    }
 close($fh);
 }
@@ -119,10 +156,33 @@ my $fh = mkfh();
 open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!");
 foreach my $key (sort(keys(%{$self->{data}})))
    {
+       my $data = $self->{data}->{$key};
+       if ($Config{userelocatableinc}) {
+          $Relocations ||= __find_relocations();
+          if ($packfile =~ $Relocations) {
+              # We are writing into a subdirectory of a run-time relocated
+              # path. Figure out if the this file is also within a subdir.
+              my $prefix = $1;
+              if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix)))
+              {
+                  # The relocated path is within the found prefix
+                  my $packfile_prefix;
+                  (undef, $packfile_prefix)
+                      = File::Spec->splitpath($packfile);
+
+                  my $relocate_as
+                      = File::Spec->abs2rel($key, $packfile_prefix);
+
+                  if (!ref $data) {
+                      $data = {};
+                  }
+                  $data->{relocate_as} = $relocate_as;
+              }
+          }
+       }
    print $fh ("$key");
-   if (ref($self->{data}->{$key}))
+   if (ref($data))
       {
-      my $data = $self->{data}->{$key};
       foreach my $k (sort(keys(%$data)))
          {
          print $fh (" $k=$data->{$k}");
@@ -149,6 +209,13 @@ foreach my $key (sort(keys(%{$self->{data}})))
 return(@missing);
 }
 
+sub packlist_file($)
+{
+my ($self) = @_;
+$self = tied(%$self) || $self;
+return($self->{packfile});
+}
+
 1;
 
 __END__
@@ -192,7 +259,7 @@ filename followed by the key=value pairs from the hash.  Reading back the
 
 =head1 FUNCTIONS
 
-=over
+=over 4
 
 =item new()
 
@@ -222,8 +289,58 @@ argument which evaluates to true is given, any missing files will be removed
 from the internal hash.  The return value is a list of the missing files, which
 will be empty if they all exist.
 
+=item packlist_file()
+
+This returns the name of the associated .packlist file
+
 =back
 
+=head1 EXAMPLE
+
+Here's C<modrm>, a little utility to cleanly remove an installed module.
+
+    #!/usr/local/bin/perl -w
+
+    use strict;
+    use IO::Dir;
+    use ExtUtils::Packlist;
+    use ExtUtils::Installed;
+
+    sub emptydir($) {
+       my ($dir) = @_;
+       my $dh = IO::Dir->new($dir) || return(0);
+       my @count = $dh->read();
+       $dh->close();
+       return(@count == 2 ? 1 : 0);
+    }
+
+    # Find all the installed packages
+    print("Finding all installed modules...\n");
+    my $installed = ExtUtils::Installed->new();
+
+    foreach my $module (grep(!/^Perl$/, $installed->modules())) {
+       my $version = $installed->version($module) || "???";
+       print("Found module $module Version $version\n");
+       print("Do you want to delete $module? [n] ");
+       my $r = <STDIN>; chomp($r);
+       if ($r && $r =~ /^y/i) {
+         # Remove all the files
+         foreach my $file (sort($installed->files($module))) {
+            print("rm $file\n");
+            unlink($file);
+         }
+         my $pf = $installed->packlist($module)->packlist_file();
+         print("rm $pf\n");
+         unlink($pf);
+         foreach my $dir (sort($installed->directory_tree($module))) {
+            if (emptydir($dir)) {
+               print("rmdir $dir\n");
+               rmdir($dir);
+            }
+         }
+       }
+    }
+
 =head1 AUTHOR
 
 Alan Burlison <Alan.Burlison@uk.sun.com>