I'm forwarding this commit message to the full Module::Build list as I
consider it a relative 'big' change with some degree of risk that
everyone needs to be aware of.
Please read the extensive log message. Anyone who knows this code
passably well, please skim the commit. Anyone who does any custom
install path work with Module::Build or does custom install
configuration, please check out trunk and give it a try with your
code/site.
Thank you,
David
---------- Forwarded message ----------
From: <dagol...@cvs.perl.org>
Date: Wed, Aug 19, 2009 at 11:26 AM
Subject: [svn:Module-Build] r13208 - in Module-Build/trunk: . lib/Module/Build t
To: svn-commit-modules-module-bu...@perl.org
Author: dagolden
Date: Wed Aug 19 08:26:19 2009
New Revision: 13208
Modified:
Module-Build/trunk/Changes
Module-Build/trunk/lib/Module/Build/Base.pm
Module-Build/trunk/t/install_extra_target.t
Log:
Fixed preservation of custom install_paths on resume (RT#41166)
This required a fairly sweeping change to calculation of install paths.
Old way: Generate default install paths from config and store them
in the object properties during object creation. User modifications are
made directly to these object properties. The problem is in the timing.
Creation of defaults need to happen 'late' after any --config options are
processed, but this was overwriting any custom install paths restored from
_build (which happens "early")
New way: Default install paths are generated "on demand" based on whatever
config values are in force and are not stored in the object. Accessors for all
the install path properties now merge custom install paths in object
properties with the generated defaults on the fly. Among other things, this
allows config values to be changed programatically after object construction
and change the resulting install paths.
There is a subtle semantic change in that setting an install path to "undef"
stores that in the object properties. This ensures the generated default
is masked, giving an "undef" result. (The old way deleted the install path
from the object properties.) I think the end result is the same -- asking
for a "deleted" path returns an undef value.
Special thanks to Thorben Jaendling for writing a new test file to help me
confirm the bug and the subsequent fix.
Modified: Module-Build/trunk/Changes
==============================================================================
--- Module-Build/trunk/Changes (original)
+++ Module-Build/trunk/Changes Wed Aug 19 08:26:19 2009
@@ -5,6 +5,7 @@
Bug fixes:
- Multiple test fixes for OS2 [Ilya Zakharevich]
- Generated.ppd files use :utf8 if possible (RT#48827) [Olivier Mengue]
+ - Fixed preservation of custom install_paths on resume (RT#41166)
0.34_05 - Sun Aug 9 22:31:37 EDT 2009
Modified: Module-Build/trunk/lib/Module/Build/Base.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/Base.pm (original)
+++ Module-Build/trunk/lib/Module/Build/Base.pm Wed Aug 19 08:26:19 2009
@@ -42,7 +42,6 @@
$self->dist_name;
$self->dist_version;
- $self->_set_install_paths;
$self->_find_nested_builds;
return $self;
@@ -86,8 +85,6 @@
$self->{invoked_action} = $self->{action} ||= 'build';
- $self->_set_install_paths;
-
return $self;
}
@@ -208,10 +205,12 @@
}
-sub _set_install_paths {
+# install paths must be generated when requested to be sure all changes
+# to config (from various sources) are included
+sub _default_install_paths {
my $self = shift;
my $c = $self->{config};
- my $p = $self->{properties};
+ my $p = {};
my @libstyle = $c->get('installstyle') ?
File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
@@ -318,7 +317,7 @@
libhtml => ['html'],
},
};
-
+ return $p
}
sub _find_nested_builds {
@@ -1839,6 +1838,8 @@
sub _merge_arglist {
my( $self, $opts1, $opts2 ) = @_;
+ $opts1 ||= {};
+ $opts2 ||= {};
my %new_opts = %$opts1;
while (my ($key, $val) = each %$opts2) {
if ( exists( $opts1->{$key} ) ) {
@@ -4022,73 +4023,118 @@
return $map->{$type} = $value;
}
+sub install_sets {
+ # Usage: install_sets('site'), install_sets('site', 'lib'),
+ # or install_sets('site', 'lib' => $value);
+ my ($self, $dirs, $key, $value) = @_;
+ $dirs = $self->installdirs unless defined $dirs;
+ # update property before merging with defaults
+ if ( @_ == 4 && defined $dirs && defined $key) {
+ # $value can be undef; will mask default
+ $self->{properties}{install_sets}{$dirs}{$key} = $value;
+ }
+ my $map = { $self->_merge_arglist(
+ $self->{properties}{install_sets},
+ $self->_default_install_paths->{install_sets}
+ )};
+ if ( defined $dirs && defined $key ) {
+ return $map->{$dirs}{$key};
+ }
+ elsif ( defined $dirs ) {
+ return $map->{$dirs};
+ }
+ else {
+ croak "Can't determine installdirs for install_sets()";
+ }
+}
+
+sub original_prefix {
+ # Usage: original_prefix(), original_prefix('lib'),
+ # or original_prefix('lib' => $value);
+ my ($self, $key, $value) = @_;
+ # update property before merging with defaults
+ if ( @_ == 3 && defined $key) {
+ # $value can be undef; will mask default
+ $self->{properties}{original_prefix}{$key} = $value;
+ }
+ my $map = { $self->_merge_arglist(
+ $self->{properties}{original_prefix},
+ $self->_default_install_paths->{original_prefix}
+ )};
+ return $map unless defined $key;
+ return $map->{$key}
+}
+
sub install_base_relpaths {
# Usage: install_base_relpaths(), install_base_relpaths('lib'),
# or install_base_relpaths('lib' => $value);
my $self = shift;
- my $map = $self->{properties}{install_base_relpaths};
+ if ( @_ > 1 ) { # change values before merge
+ $self->_set_relpaths($self->{properties}{install_base_relpaths}, @_);
+ }
+ my $map = { $self->_merge_arglist(
+ $self->{properties}{install_base_relpaths},
+ $self->_default_install_paths->{install_base_relpaths}
+ )};
return $map unless @_;
- return $self->_relpaths($map, @_);
+ my $relpath = $map->{$_[0]};
+ return defined $relpath ? File::Spec->catdir( @$relpath ) : undef;
}
-
-# Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
-sub prefix_relative {
- my ($self, $type) = @_;
- my $installdirs = $self->installdirs;
-
- my $relpath = $self->install_sets($installdirs)->{$type};
-
- return $self->_prefixify($relpath,
- $self->original_prefix($installdirs),
- $type,
- );
+# Defaults to use in case the config install paths cannot be prefixified.
+sub prefix_relpaths {
+ # Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'),
+ # or prefix_relpaths('site', 'lib' => $value);
+ my $self = shift;
+ my $installdirs = shift || $self->installdirs
+ or croak "Can't determine installdirs for prefix_relpaths()";
+ if ( @_ > 1 ) { # change values before merge
+ $self->{properties}{prefix_relpaths}{$installdirs} ||= {};
+ $self->_set_relpaths($self->{properties}{prefix_relpaths}{$installdirs},
@_);
+ }
+ my $map = {$self->_merge_arglist(
+ $self->{properties}{prefix_relpaths}{$installdirs},
+ $self->_default_install_paths->{prefix_relpaths}{$installdirs}
+ )};
+ return $map unless @_;
+ my $relpath = $map->{$_[0]};
+ return defined $relpath ? File::Spec->catdir( @$relpath ) : undef;
}
-sub _relpaths {
+sub _set_relpaths {
my $self = shift;
- my( $map, $type, $value ) = ( @_, '<empty>' );
+ my( $map, $type, $value ) = @_;
Carp::croak( 'Type argument missing' )
unless defined( $type );
- my @value = ();
-
- # delete existing value if $value is literal undef()
- unless ( defined( $value ) ) {
- delete( $map->{$type} );
- return undef;
- }
-
- # return existing value if no new $value is given
- elsif ( $value eq '<empty>' ) {
- return undef unless exists $map->{$type};
- �...@value = @{ $map->{$type} };
+ # set undef if $value is literal undef()
+ if ( ! defined( $value ) ) {
+ $map->{$type} = undef;
+ return;
}
-
# set value if $value is a valid relative path
else {
Carp::croak( "Value must be a relative path" )
if File::Spec::Unix->file_name_is_absolute($value);
- �...@value = split( /\//, $value );
+ my @value = split( /\//, $value );
$map->{$type} = \...@value;
}
-
- return File::Spec->catdir( @value );
}
-# Defaults to use in case the config install paths cannot be prefixified.
-sub prefix_relpaths {
- # Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'),
- # or prefix_relpaths('site', 'lib' => $value);
- my $self = shift;
- my $installdirs = shift || $self->installdirs;
- my $map = $self->{properties}{prefix_relpaths}{$installdirs};
- return $map unless @_;
- return $self->_relpaths($map, @_);
-}
+# Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
+sub prefix_relative {
+ my ($self, $type) = @_;
+ my $installdirs = $self->installdirs;
+ my $relpath = $self->install_sets($installdirs)->{$type};
+
+ return $self->_prefixify($relpath,
+ $self->original_prefix($installdirs),
+ $type,
+ );
+}
# Translated from ExtUtils::MM_Unix::prefixify()
sub _prefixify {
Modified: Module-Build/trunk/t/install_extra_target.t
==============================================================================
--- Module-Build/trunk/t/install_extra_target.t (original)
+++ Module-Build/trunk/t/install_extra_target.t Wed Aug 19 08:26:19 2009
@@ -128,13 +128,10 @@
$output = stdout_of sub { $dist->run_build('install') };
-TODO: {
- local $TODO = "RT#4116 not fixed";
- $error = 0;
- $error++ unless ok(-e "$installdest/etc/simple/config", "installed
etc/config");
- $error++ unless ok(-e "$installdest/share/simple/data", "installed
share/data");
- $error++ unless ok(-e "$installdest/share/simple/html/index.html",
"installed share/html");
- diag "OUTPUT:\n$output" if $error;
-}
+$error = 0;
+$error++ unless ok(-e "$installdest/etc/simple/config", "installed
etc/config");
+$error++ unless ok(-e "$installdest/share/simple/data", "installed
share/data");
+$error++ unless ok(-e "$installdest/share/simple/html/index.html",
"installed share/html");
+diag "OUTPUT:\n$output" if $error;
$dist->remove();
