X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Flocal%2Flib.pm;h=2e477e66465043896e0a0ceb01f7dadac9d8ba0a;hb=1cd322bb6bfa4218fc286b356ee72a83ac8e18e1;hp=8712b9c00d06a3d1c8dc68609a1423c0c68e6ce3;hpb=a0b3d98ab56539e741db6aa32b1eaa64b24f72ac;p=p5sagit%2Flocal-lib.git diff --git a/lib/local/lib.pm b/lib/local/lib.pm index 8712b9c..2e477e6 100644 --- a/lib/local/lib.pm +++ b/lib/local/lib.pm @@ -8,16 +8,18 @@ use 5.008001; # probably works with earlier versions but I'm not supporting them use File::Spec (); use File::Path (); -use Carp (); use Config; -our $VERSION = '1.008001'; # 1.8.1 +our $VERSION = '1.008011'; # 1.8.11 our @KNOWN_FLAGS = qw(--self-contained --deactivate --deactivate-all); sub DEACTIVATE_ONE () { 1 } sub DEACTIVATE_ALL () { 2 } +sub INTERPOLATE_ENV () { 1 } +sub LITERAL_ENV () { 0 } + sub import { my ($class, @args) = @_; @@ -172,6 +174,7 @@ sub resolve_home_path { } }; unless (defined $homedir) { + require Carp; Carp::croak( "Couldn't resolve homedir for " .(defined $user ? $user : 'current user') @@ -200,13 +203,46 @@ is($c->resolve_relative_path('bar'),'FOObar'); sub setup_local_lib_for { my ($class, $path, $deactivating) = @_; - $path = $class->ensure_dir_structure_for($path) unless $deactivating; + + my $interpolate = LITERAL_ENV; + my @active_lls = $class->active_paths; + + $class->ensure_dir_structure_for($path); + + # On Win32 directories often contain spaces. But some parts of the CPAN + # toolchain don't like that. To avoid this, GetShortPathName() gives us + # an alternate representation that has none. + # This only works if the directory already exists. + $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32'; + + if (! $deactivating) { + if (@active_lls && $active_lls[-1] eq $path) { + exit 0 if $0 eq '-'; + return; # Asked to add what's already at the top of the stack + } elsif (grep { $_ eq $path} @active_lls) { + # Asked to add a dir that's lower in the stack -- so we remove it from + # where it is, and then add it back at the top. + $class->setup_env_hash_for($path, DEACTIVATE_ONE); + # Which means we can no longer output "PERL5LIB=...:$PERL5LIB" stuff + # anymore because we're taking something *out*. + $interpolate = INTERPOLATE_ENV; + } + } + if ($0 eq '-') { - $class->print_environment_vars_for($path, $deactivating); + $class->print_environment_vars_for($path, $deactivating, $interpolate); exit 0; } else { $class->setup_env_hash_for($path, $deactivating); - @INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC); + my $arch_dir = $Config{archname}; + @INC = _uniq( + ( + # Inject $path/$archname for each path in PERL5LIB + map { ( File::Spec->catdir($_, $arch_dir), $_ ) } + split($Config{path_sep}, $ENV{PERL5LIB}) + ), + @INC + ); } } @@ -231,16 +267,9 @@ sub ensure_dir_structure_for { warn "Attempting to create directory ${path}\n"; } File::Path::mkpath($path); - # Need to have the path exist to make a short name for it, so - # converting to a short name here. - $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32'; - - return $path; + return } -sub INTERPOLATE_ENV () { 1 } -sub LITERAL_ENV () { 0 } - sub guess_shelltype { my $shellbin = 'sh'; if(defined $ENV{'SHELL'}) { @@ -277,13 +306,13 @@ sub guess_shelltype { } sub print_environment_vars_for { - my ($class, $path, $deactivating) = @_; - print $class->environment_vars_string_for($path, $deactivating); + my ($class, $path, $deactivating, $interpolate) = @_; + print $class->environment_vars_string_for($path, $deactivating, $interpolate); } sub environment_vars_string_for { - my ($class, $path, $deactivating) = @_; - my @envs = $class->build_environment_vars_for($path, $deactivating, LITERAL_ENV); + my ($class, $path, $deactivating, $interpolate) = @_; + my @envs = $class->build_environment_vars_for($path, $deactivating, $interpolate); my $out = ''; # rather basic csh detection, goes on the assumption that something won't @@ -341,82 +370,127 @@ sub build_environment_vars_for { } } +# Build an environment value for a variable like PATH from a list of paths. +# References to existing variables are given as references to the variable name. +# Duplicates are removed. +# +# options: +# - interpolate: INTERPOLATE_ENV/LITERAL_ENV +# - exists: paths are included only if they exist (default: interpolate == INTERPOLATE_ENV) +# - filter: function to apply to each path do decide if it must be included +# - empty: the value to return in the case of empty value +my %ENV_LIST_VALUE_DEFAULTS = ( + interpolate => INTERPOLATE_ENV, + exists => undef, + filter => sub { 1 }, + empty => undef, +); +sub _env_list_value { + my $options = shift; + die(sprintf "unknown option '$_' at %s line %u\n", (caller)[1..2]) + for grep { !exists $ENV_LIST_VALUE_DEFAULTS{$_} } keys %$options; + my %options = (%ENV_LIST_VALUE_DEFAULTS, %{ $options }); + $options{exists} = $options{interpolate} == INTERPOLATE_ENV + unless defined $options{exists}; + + my %seen; + + my $value = join($Config{path_sep}, map { + ref $_ ? ($^O eq 'MSWin32' ? "%${$_}%" : "\$${$_}") : $_ + } grep { + ref $_ || (defined $_ + && length($_) > 0 + && !$seen{$_}++ + && $options{filter}->($_) + && (!$options{exists} || -e $_)) + } map { + if (ref $_ eq 'SCALAR' && $options{interpolate} == INTERPOLATE_ENV) { + defined $ENV{${$_}} ? (split /\Q$Config{path_sep}/, $ENV{${$_}}) : () + } else { + $_ + } + } @_); + return length($value) ? $value : $options{empty}; +} + sub build_activate_environment_vars_for { my ($class, $path, $interpolate) = @_; return ( - PERL_LOCAL_LIB_ROOT => join($Config{path_sep}, - (($ENV{PERL_LOCAL_LIB_ROOT}||()) ? - ($interpolate == INTERPOLATE_ENV - ? ($ENV{PERL_LOCAL_LIB_ROOT}||()) - : (($^O ne 'MSWin32') ? '$PERL_LOCAL_LIB_ROOT' - : '%PERL_LOCAL_LIB_ROOT%' )) - : ()), - $path + PERL_LOCAL_LIB_ROOT => + _env_list_value( + { interpolate => $interpolate, exists => 0, empty => '' }, + \'PERL_LOCAL_LIB_ROOT', + $path, ), PERL_MB_OPT => "--install_base ${path}", PERL_MM_OPT => "INSTALL_BASE=${path}", - PERL5LIB => join($Config{path_sep}, - $class->install_base_arch_path($path), - $class->install_base_perl_path($path), - (($ENV{PERL5LIB}||()) ? - ($interpolate == INTERPOLATE_ENV - ? ($ENV{PERL5LIB}) - : (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' )) - : ()) - ), - PATH => join($Config{path_sep}, - $class->install_base_bin_path($path), - ($interpolate == INTERPOLATE_ENV - ? ($ENV{PATH}||()) - : (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' )) - ), + PERL5LIB => + _env_list_value( + { interpolate => $interpolate, exists => 0, empty => '' }, + $class->install_base_perl_path($path), + \'PERL5LIB', + ), + PATH => _env_list_value( + { interpolate => $interpolate, exists => 0, empty => '' }, + $class->install_base_bin_path($path), + \'PATH', + ), ) } +sub active_paths { + my ($class) = @_; + + return () unless defined $ENV{PERL_LOCAL_LIB_ROOT}; + return grep { $_ ne '' } split /\Q$Config{path_sep}/, $ENV{PERL_LOCAL_LIB_ROOT}; +} + sub build_deactivate_environment_vars_for { my ($class, $path, $interpolate) = @_; - my @active_lls = split /\Q$Config{path_sep}/, $ENV{PERL_LOCAL_LIB_ROOT} || ''; + my @active_lls = $class->active_paths; if (!grep { $_ eq $path } @active_lls) { warn "Tried to deactivate inactive local::lib '$path'\n"; return (); } - my @new_ll_root = grep { $_ ne $path } @active_lls; - my @new_perl5lib = grep { - $_ ne $class->install_base_arch_path($path) && - $_ ne $class->install_base_perl_path($path) - } split /\Q$Config{path_sep}/, $ENV{PERL5LIB}; + my $perl_path = $class->install_base_perl_path($path); + my $arch_path = $class->install_base_arch_path($path); + my $bin_path = $class->install_base_bin_path($path); + my %env = ( - PERL_LOCAL_LIB_ROOT => (@new_ll_root ? - join($Config{path_sep}, @new_ll_root) : undef + PERL_LOCAL_LIB_ROOT => _env_list_value( + { + exists => 0, + }, + grep { $_ ne $path } @active_lls ), - PERL5LIB => (@new_perl5lib ? - join($Config{path_sep}, @new_perl5lib) : undef + PERL5LIB => _env_list_value( + { + exists => 0, + filter => sub { + $_ ne $perl_path && $_ ne $arch_path + }, + }, + \'PERL5LIB', ), - PATH => join($Config{path_sep}, - grep { $_ ne $class->install_base_bin_path($path) } - split /\Q$Config{path_sep}/, $ENV{PATH} + PATH => _env_list_value( + { + exists => 0, + filter => sub { $_ ne $bin_path }, + }, + \'PATH', ), ); # If removing ourselves from the "top of the stack", set install paths to # correspond with the new top of stack. if ($active_lls[-1] eq $path) { - if (@active_lls > 1) { - my $new_top = $active_lls[-2]; - %env = (%env, - PERL_MB_OPT => "--install_base ${new_top}", - PERL_MM_OPT => "INSTALL_BASE=${new_top}", - ); - } else { - %env = (%env, - PERL_MB_OPT => undef, - PERL_MM_OPT => undef, - ); - } + my $new_top = $active_lls[-2]; + $env{PERL_MB_OPT} = defined($new_top) ? "--install_base ${new_top}" : undef; + $env{PERL_MM_OPT} = defined($new_top) ? "INSTALL_BASE=${new_top}" : undef; } return %env; @@ -425,30 +499,38 @@ sub build_deactivate_environment_vars_for { sub build_deact_all_environment_vars_for { my ($class, $path, $interpolate) = @_; - my @active_lls = split /\Q$Config{path_sep}/, $ENV{PERL_LOCAL_LIB_ROOT} || ''; - - my @new_perl5lib = split /\Q$Config{path_sep}/, $ENV{PERL5LIB}; - my @new_path = split /\Q$Config{path_sep}/, $ENV{PATH}; + my @active_lls = $class->active_paths; - for my $path (@active_lls) { - @new_perl5lib = grep { - $_ ne $class->install_base_arch_path($path) && - $_ ne $class->install_base_perl_path($path) - } @new_perl5lib; - - @new_path = grep { - $_ ne $class->install_base_bin_path($path) - } @new_path; - } + my %perl_paths = map { ( + $class->install_base_perl_path($_) => 1, + $class->install_base_arch_path($_) => 1 + ) } @active_lls; + my %bin_paths = map { ( + $class->install_base_bin_path($_) => 1, + ) } @active_lls; my %env = ( PERL_LOCAL_LIB_ROOT => undef, PERL_MM_OPT => undef, PERL_MB_OPT => undef, - PERL5LIB => (@new_perl5lib ? - join($Config{path_sep}, @new_perl5lib) : undef + PERL5LIB => _env_list_value( + { + exists => 0, + filter => sub { + ! scalar grep { exists $perl_paths{$_} } $_[0] + }, + }, + \'PERL5LIB' + ), + PATH => _env_list_value( + { + exists => 0, + filter => sub { + ! scalar grep { exists $bin_paths{$_} } $_[0] + }, + }, + \'PATH' ), - PATH => join($Config{path_sep}, @new_path), ); return %env; @@ -619,7 +701,7 @@ C, you can use this: set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% ### To set the environment for this shell alone - C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat + C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat ### instead of $(perl -Mlocal::lib=./) If you want the environment entries to persist, you'll need to add then to the @@ -763,6 +845,19 @@ given path as the base directory. Constructs the C<%ENV> keys for the given path, by calling L. +=head2 active_paths + +=over 4 + +=item Arguments: None + +=item Return value: @paths + +=back + +Returns a list of active C paths, according to the +C environment variable. + =head2 install_base_perl_path =over 4 @@ -929,6 +1024,14 @@ On Win32 systems, C is also examined. =back +=head1 SEE ALSO + +=over 4 + +=item * L + +=back + =head1 SUPPORT IRC: @@ -976,6 +1079,8 @@ G. de Oliveira . Improvements to stacking multiple local::lib dirs and removing them from the environment later on contributed by Andrew Rodland . +Patch for Carp version mismatch contributed by Hakim Cassimally . + =head1 COPYRIGHT Copyright (c) 2007 - 2010 the local::lib L and L as