| #!/usr/bin/perl -w |
| |
| # Test ~ expansion from command line arguments. |
| |
| use strict; |
| use lib 't/lib'; |
| use MBTest tests => 16; |
| |
| blib_load('Module::Build'); |
| |
| my $tmp = MBTest->tmpdir; |
| |
| use DistGen; |
| my $dist = DistGen->new( dir => $tmp ); |
| $dist->regen; |
| |
| $dist->chdir_in; |
| |
| |
| sub run_sample { |
| my @args = @_; |
| |
| local $Test::Builder::Level = $Test::Builder::Level + 1; |
| |
| $dist->clean; |
| |
| my $mb; |
| stdout_of( sub { |
| $mb = Module::Build->new_from_context( @args ); |
| } ); |
| |
| return $mb; |
| } |
| |
| |
| my $p = 'install_base'; |
| |
| SKIP: { |
| my $home = $ENV{HOME} ? $ENV{HOME} : undef; |
| |
| if ($^O eq 'VMS') { |
| # Convert the path to UNIX format, trim off the trailing slash |
| $home = VMS::Filespec::unixify($home); |
| $home =~ s#/$##; |
| } |
| |
| unless (defined $home) { |
| my @info = eval { getpwuid $> }; |
| skip "No home directory for tilde-expansion tests", 15 if $@ |
| or !defined $info[7]; |
| $home = $info[7]; |
| } |
| |
| is( run_sample( $p => '~' )->$p(), $home ); |
| |
| is( run_sample( $p => '~/fooxzy' )->$p(), "$home/fooxzy" ); |
| |
| is( run_sample( $p => '~/ fooxzy')->$p(), "$home/ fooxzy" ); |
| |
| is( run_sample( $p => '~/fo o')->$p(), "$home/fo o" ); |
| |
| is( run_sample( $p => 'fooxzy~' )->$p(), 'fooxzy~' ); |
| |
| is( run_sample( prefix => '~' )->prefix, |
| $home ); |
| |
| # Test when HOME is different from getpwuid(), as in sudo. |
| { |
| local $ENV{HOME} = '/wibble/whomp'; |
| |
| is( run_sample( $p => '~' )->$p(), "/wibble/whomp" ); |
| } |
| |
| 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'), "$home/html" ); |
| is( $mb->install_destination('libhtml'), "$home/html" ); |
| |
| $mb = run_sample( install_path => { lib => '~/lib' } ); |
| is( $mb->install_destination('lib'), "$home/lib" ); |
| |
| $mb = run_sample( destdir => '~' ); |
| is( $mb->destdir, $home ); |
| |
| $mb->$p('~'); |
| is( $mb->$p(), '~', 'API does not expand tildes' ); |
| |
| skip "On OS/2 EMX all users are equal", 2 if $^O eq 'os2'; |
| is( run_sample( $p => '~~' )->$p(), '~~' ); |
| is( run_sample( $p => '~ fooxzy' )->$p(), '~ fooxzy' ); |
| } |
| |
| # Again, with named users |
| SKIP: { |
| my @info = eval { getpwuid $> }; |
| skip "No home directory for tilde-expansion tests", 1 if $@ |
| or !defined $info[7] or !defined $info[0]; |
| my ($me, $home) = @info[0,7]; |
| |
| my $expected = "$home/fooxzy"; |
| |
| if ($^O eq 'VMS') { |
| # Convert the path to UNIX format and trim off the trailing slash |
| $home = VMS::Filespec::unixify($home); |
| $home =~ s#/$##; |
| $expected = $home . '/../[^/]+' . '/fooxzy'; |
| } |
| |
| like( run_sample( $p => "~$me/fooxzy")->$p(), qr(\Q$expected\E)i ); |
| } |
| |