Author: kwilliams
Date: Mon May 7 20:05:53 2007
New Revision: 9510
Modified:
Module-Build/trunk/Changes
Module-Build/trunk/lib/Module/Build/Base.pm
Module-Build/trunk/lib/Module/Build/Platform/Unix.pm
Module-Build/trunk/lib/Module/Build/Platform/Windows.pm
Module-Build/trunk/t/tilde.t
Log:
Revamp tilde-expansion to support userdirs
Modified: Module-Build/trunk/Changes
==============================================================================
--- Module-Build/trunk/Changes (original)
+++ Module-Build/trunk/Changes Mon May 7 20:05:53 2007
@@ -1,5 +1,10 @@
Revision history for Perl extension Module::Build.
+ - Reworked the _detildefy() method so it doesn't depend on glob()
+ anymore. This gets rid of a problem with spaces or other special
+ shell characters in things like 'prefix' or 'install_path'
+ entries. [Prodding by Eric Wilhelm]
+
0.2808 - Sat Apr 28 12:59:43 2007
- Added is_vmsish(), is_windowsish(), and is_unixish() boolean
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 Mon May 7 20:05:53 2007
@@ -1654,7 +1654,7 @@
# De-tilde-ify any path parameters
for my $key (qw(prefix install_base destdir)) {
next if !defined $args{$key};
- $args{$key} = _detildefy($args{$key});
+ $args{$key} = $self->_detildefy($args{$key});
}
for my $key (qw(install_path)) {
@@ -1662,7 +1662,7 @@
for my $subkey (keys %{$args{$key}}) {
next if !defined $args{$key}{$subkey};
- my $subkey_ext = _detildefy($args{$key}{$subkey});
+ my $subkey_ext = $self->_detildefy($args{$key}{$subkey});
if ( $subkey eq 'html' ) { # translate for compatability
$args{$key}{binhtml} = $subkey_ext;
$args{$key}{libhtml} = $subkey_ext;
@@ -1680,14 +1680,8 @@
return \%args, $action;
}
-
-# (bash shell won't expand tildes mid-word: "--foo=~/thing")
-# TODO: handle ~user/foo
-sub _detildefy {
- my $arg = shift;
-
- return $arg =~ /^~/ ? (glob $arg)[0] : $arg;
-}
+# Default: do nothing. Overridden for Unix & Windows.
+sub _detildefy {}
# merge Module::Build argument lists that have already been parsed
Modified: Module-Build/trunk/lib/Module/Build/Platform/Unix.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/Platform/Unix.pm (original)
+++ Module-Build/trunk/lib/Module/Build/Platform/Unix.pm Mon May 7
20:05:53 2007
@@ -39,6 +39,16 @@
return $self;
}
+sub _detildefy {
+ my ($self, $value) = @_;
+ $value =~ s[^~(\w*)(?=/|$)] # tilde with optional username
+ [$1 ?
+ ((getpwnam $1)[7] || "~$1") :
+ (getpwuid $>)[7]
+ ]ex;
+ return $value;
+}
+
1;
__END__
Modified: Module-Build/trunk/lib/Module/Build/Platform/Windows.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/Platform/Windows.pm (original)
+++ Module-Build/trunk/lib/Module/Build/Platform/Windows.pm Mon May 7
20:05:53 2007
@@ -19,6 +19,13 @@
sub have_forkpipe { 0 }
+sub _detildefy {
+ my ($self, $value) = @_;
+ $value =~ s,^~(?= [/\\] | $ ),$ENV{HOME},x
+ if $ENV{HOME};
+ return $value;
+}
+
sub ACTION_realclean {
my ($self) = @_;
Modified: Module-Build/trunk/t/tilde.t
==============================================================================
--- Module-Build/trunk/t/tilde.t (original)
+++ Module-Build/trunk/t/tilde.t Mon May 7 20:05:53 2007
@@ -4,7 +4,7 @@
use strict;
use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
-use MBTest tests => 14;
+use MBTest tests => 15;
use Cwd ();
my $cwd = Cwd::cwd;
@@ -35,56 +35,58 @@
}
-{
- local $ENV{HOME} = 'home';
+my $p = 'install_base';
- my $mb;
-
- $mb = run_sample( install_base => '~' );
- is( $mb->install_base, $ENV{HOME} );
-
- $mb = run_sample( install_base => '~/foo' );
- is( $mb->install_base, "$ENV{HOME}/foo" );
+SKIP: {
+ my $home = $ENV{HOME} ? $ENV{HOME} : undef;
+ unless (defined $home) {
+ my @info = eval { getpwuid $> };
+ skip "No home directory for tilde-expansion tests", 14 if $@;
+ $home = $info[7];
+ }
- $mb = run_sample( install_base => '~~' );
- is( $mb->install_base, '~~' );
+ is( run_sample( $p => '~' )->$p, $home );
- TODO: {
- local $TODO = "Not handling spaces in _detildefy() properly yet";
+ is( run_sample( $p => '~/foo' )->$p, "$home/foo" );
- $mb = run_sample( install_base => '~ foo' );
- is( $mb->install_base, '~ foo' );
+ is( run_sample( $p => '~~' )->$p, '~~' );
- # glob() doesn't work on non-existent paths with spaces
- $mb = run_sample( install_base => '~/ foo' );
- is( $mb->install_base, "$ENV{HOME}/ foo" );
+ is( run_sample( $p => '~ foo' )->$p, '~ foo' );
- $mb = run_sample( install_base => '~/fo o' );
- is( $mb->install_base, "$ENV{HOME}/fo o" );
- }
+ is( run_sample( $p => '~/ foo')->$p, "$home/ foo" );
+
+ is( run_sample( $p => '~/fo o')->$p, "$home/fo o" );
- $mb = run_sample( install_base => 'foo~' );
- is( $mb->install_base, 'foo~' );
+ is( run_sample( $p => 'foo~' )->$p, 'foo~' );
- $mb = run_sample( prefix => '~' );
- is( $mb->prefix, $ENV{HOME} );
+ is( run_sample( prefix => '~' )->prefix,
+ $home );
- $mb = run_sample( install_path => { html => '~/html',
- lib => '~/lib' }
- );
- is( $mb->install_destination('lib'), "$ENV{HOME}/lib" );
+ my $mb = run_sample( install_path => { html => '~/html',
+ lib => '~/lib' }
+ );
+ is( $mb->install_destination('lib'), "$home/lib" );
# 'html' is translated to 'binhtml' & 'libhtml'
- is( $mb->install_destination('binhtml'), "$ENV{HOME}/html" );
- is( $mb->install_destination('libhtml'), "$ENV{HOME}/html" );
+ is( $mb->install_destination('binhtml'), "$home/html" );
+ is( $mb->install_destination('libhtml'), "$home/html" );
$mb = run_sample( install_path => { lib => '~/lib' } );
- is( $mb->install_destination('lib'), "$ENV{HOME}/lib" );
+ is( $mb->install_destination('lib'), "$home/lib" );
$mb = run_sample( destdir => '~' );
- is( $mb->destdir, $ENV{HOME} );
+ is( $mb->destdir, $home );
+
+ $mb->$p('~');
+ is( $mb->$p, '~', 'API does not expand tildes' );
+}
- $mb->install_base('~');
- is( $mb->install_base, '~', 'API does not expand tildes' );
+# Again, with named users
+SKIP: {
+ my @info = eval { getpwuid $> };
+ skip "No home directory for tilde-expansion tests", 1 if $@;
+ my ($me, $home) = @info[0,7];
+
+ is( run_sample( $p => "~$me/foo")->$p, "$home/foo" );
}
