[Module-build-checkins] Module-Build/lib/Module/Build Base.pm,1.429,1.430

[Michael G S. <sc...@us...>]

Update of /cvsroot/module-build/Module-Build/lib/Module/Build
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22032/lib/Module/Build

Modified Files:
	Base.pm 
Log Message:
Functionality:
Make prefixification guard against installing outside the prefix.
Add default handling to prefixifcation for such a case.  Defaults not yet
filled in.

Use the cross-platform _catprefix() from the VMS version.

Test changes:
Change global $m to $M.

Test that prefixification winds up with the right path under the prefix.  The
test is not exact but it'll hold for now.




Index: Base.pm
===================================================================
RCS file: /cvsroot/module-build/Module-Build/lib/Module/Build/Base.pm,v
retrieving revision 1.429
retrieving revision 1.430
diff -u -d -r1.429 -r1.430
--- Base.pm	21 Jun 2005 00:12:54 -0000	1.429
+++ Base.pm	21 Jun 2005 22:49:30 -0000	1.430
@@ -2587,13 +2587,19 @@
     );
     $prefixes{site} ||= $prefixes{core};
 
-    return $self->prefixify($map->{$installdirs}{$type}, $prefixes{$installdirs}, $prefix);
+    my $default;
+
+    return $self->_prefixify($map->{$installdirs}{$type},
+                             $prefixes{$installdirs}, 
+                             $prefix,
+                             $default
+                            );
 }
 
 
 # Translated from ExtUtils::MM_Unix::prefixify()
-sub prefixify {
-    my($self, $path, $sprefix, $rprefix) = @_;
+sub _prefixify {
+    my($self, $path, $sprefix, $rprefix, $default) = @_;
 
     $rprefix .= '/' if $sprefix =~ m|/$|;
 
@@ -2610,6 +2616,7 @@
     }
     elsif( $path !~ s{^\Q$sprefix\E\b}{$rprefix}s ) {
         $self->log_verbose("    cannot prefixify.\n");
+        $path = $self->_prefixify_default($rprefix, $default);
     }
 
     $self->log_verbose("    now $path\n");
@@ -2618,6 +2625,44 @@
 }
 
 
+sub _prefixify_default {
+    my($self, $rprefix, $default) = @_;
+
+    $self->log_verbose("    cannot prefix, trying default.\n");
+
+    if( !$default ) {
+        $self->log_verbose("    no default!  Using prefix '$rprefix'.\n");  
+        return $rprefix;
+    }
+    if( !$rprefix ) {
+        $self->log_verbose("    no replacement prefix!\n");
+        return;
+    }
+
+    $self->log_verbose("    using default '$default'.\n");
+
+    return $self->_catprefix($rprefix, $default);
+}
+
+
+# From ExtUtils::MM_VMS::_catpreifx() but its actually cross platform.
+sub _catprefix {
+    my($self, $rprefix, $default) = @_;
+
+    my($rvol, $rdirs) = File::Spec->splitpath($rprefix);
+    if( $rvol ) {
+        return File::Spec->catpath($rvol,
+                                   File::Spec->catdir($rdirs, $default),
+                                   ''
+                                  )
+    }
+    else {
+        return File::Spec->catdir($rdirs, $default);
+    }
+}
+
+
+
 sub install_destination {
   my ($self, $type) = @_;
   my $p = $self->{properties};