X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Flocal%2Flib.pm;h=e468dec45f420d0124c3ad3c70c7d11ec1f18113;hb=67734fdc4b05cd11bfec9954c77a3ea2309f34cb;hp=b3953b160375da73574b34c31e80b086d6432512;hpb=35f4f2618944442742df2cb7f492f66ec786ac55;p=p5sagit%2Flocal-lib.git

diff --git a/lib/local/lib.pm b/lib/local/lib.pm
index b3953b1..e468dec 100644
--- a/lib/local/lib.pm
+++ b/lib/local/lib.pm
@@ -67,11 +67,11 @@ DEATH
   }
 
   if ($0 eq '-') {
-    $self->print_environment_vars_for;
+    $self->print_environment_vars;
     exit 0;
   }
   else {
-    $self->setup_local_lib_for;
+    $self->setup_local_lib;
   }
 }
 
@@ -109,6 +109,8 @@ sub _as_list {
 }
 sub _remove_from {
   my ($list, @remove) = @_;
+  return @$list
+    if !@remove;
   my %remove = map { $_ => 1 } @remove;
   grep !$remove{$_}, _as_list($list);
 }
@@ -179,6 +181,7 @@ sub deactivate {
   my ($self, $path) = @_;
   $self = $self->new unless ref $self;
   $path = $self->resolve_path($path);
+  $path = $self->normalize_path($path);
 
   my @active_lls = $self->active_paths;
 
@@ -205,15 +208,18 @@ sub deactivate_all {
 
   my @active_lls = $self->active_paths;
 
-  my %args = (
-    bins => [ _remove_from($self->bins,
-      map $self->install_base_bin_path($_), @active_lls) ],
-    libs => [ _remove_from($self->libs,
-      map $self->install_base_perl_path($_), @active_lls) ],
-    inc => [ _remove_from($self->inc,
-      map $self->lib_paths_for($_), @active_lls) ],
-    roots => [ _remove_from($self->roots, @active_lls) ],
-  );
+  my %args;
+  if (@active_lls) {
+    %args = (
+      bins => [ _remove_from($self->bins,
+        map $self->install_base_bin_path($_), @active_lls) ],
+      libs => [ _remove_from($self->libs,
+        map $self->install_base_perl_path($_), @active_lls) ],
+      inc => [ _remove_from($self->inc,
+        map $self->lib_paths_for($_), @active_lls) ],
+      roots => [ _remove_from($self->roots, @active_lls) ],
+    );
+  }
 
   $args{extra} = $self->installer_options_for(undef);
 
@@ -227,38 +233,42 @@ sub activate {
   $self->ensure_dir_structure_for($path)
     unless $self->no_create;
 
-  $path = ( Win32::GetShortPathName($path) || $path )
-    if $^O eq 'MSWin32';
+  $path = $self->normalize_path($path);
 
   my @active_lls = $self->active_paths;
 
-  if (grep { $_ eq $path } @active_lls) {
+  if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) {
     $self = $self->deactivate($path);
   }
 
-  my %args = (
-    bins  => [ $self->install_base_bin_path($path), @{$self->bins} ],
-    libs  => [ $self->install_base_perl_path($path), @{$self->libs} ],
-    inc   => [ $self->lib_paths_for($path), @{$self->inc} ],
-    roots => [ $path, @{$self->roots} ],
-  );
+  my %args;
+  if (!@active_lls || $active_lls[0] ne $path) {
+    %args = (
+      bins  => [ $self->install_base_bin_path($path), @{$self->bins} ],
+      libs  => [ $self->install_base_perl_path($path), @{$self->libs} ],
+      inc   => [ $self->lib_paths_for($path), @{$self->inc} ],
+      roots => [ $path, @{$self->roots} ],
+    );
+  }
 
   $args{extra} = $self->installer_options_for($path);
 
   $self->clone(%args);
 }
 
-sub _legacy {
+sub normalize_path {
   my ($self, $path) = @_;
-  $self = $self->new unless ref $self;
-  if (defined $path) {
-    $self = $self->activate($path);
-  }
-  $self;
+  $path = ( Win32::GetShortPathName($path) || $path )
+    if $^O eq 'MSWin32';
+  return $path;
 }
 
 sub build_environment_vars_for {
-  my ($self) = _legacy(@_);
+  my $self = $_[0]->new->activate($_[1]);
+  $self->build_environment_vars;
+}
+sub build_environment_vars {
+  my $self = shift;
   (
     PATH                => join($_path_sep, _as_list($self->bins)),
     PERL5LIB            => join($_path_sep, _as_list($self->libs)),
@@ -268,14 +278,23 @@ sub build_environment_vars_for {
 }
 
 sub setup_local_lib_for {
-  my ($self) = _legacy(@_);
-  $self->setup_env_hash_for;
+  my $self = $_[0]->new->activate($_[1]);
+  $self->setup_local_lib;
+}
+
+sub setup_local_lib {
+  my $self = shift;
+  $self->setup_env_hash;
   @INC = @{$self->inc};
 }
 
 sub setup_env_hash_for {
+  my $self = $_[0]->new->activate($_[1]);
+  $self->setup_env_hash;
+}
+sub setup_env_hash {
   my $self = shift;
-  my %env = $self->build_environment_vars_for(@_);
+  my %env = $self->build_environment_vars;
   for my $key (keys %env) {
     if (defined $env{$key}) {
       $ENV{$key} = $env{$key};
@@ -287,12 +306,20 @@ sub setup_env_hash_for {
 }
 
 sub print_environment_vars_for {
+  my $self = $_[0]->new->activate($_[1]);
+  $self->print_environment_vars;
+}
+sub print_environment_vars {
   my $self = shift;
-  print $self->environment_vars_string_for(@_);
+  print $self->environment_vars_string;
 }
 
 sub environment_vars_string_for {
-  my $self = _legacy(@_);
+  my $self = $_[0]->new->activate($_[1]);
+  $self->environment_vars_string;
+}
+sub environment_vars_string {
+  my $self = shift;
 
   my $build_method = 'build_' . $self->shelltype . '_env_declaration';
 
@@ -313,72 +340,108 @@ sub environment_vars_string_for {
         && ${$value->[0]} eq $name) {
       next;
     }
-    if (!ref $value
-        && defined $value ? $value eq $ENV{$name} : !defined $ENV{$name}
+    if (
+        !ref $value
+        and defined $value
+          ? (defined $ENV{$name} && $value eq $ENV{$name})
+          : !defined $ENV{$name}
     ) {
       next;
     }
     $out .= $self->$build_method($name, $value);
   }
+  my $wrap_method = 'wrap_' . $self->shelltype . '_output';
+  if ($self->can($wrap_method)) {
+    return $self->$wrap_method($out);
+  }
   return $out;
 }
 
 sub build_bourne_env_declaration {
   my ($class, $name, $args) = @_;
-  my $value = $class->_interpolate($args);
-  defined $value
-    ? qq{export ${name}="${value}";\n}
-    : qq{unset ${name};\n};
+  my $value = $class->_interpolate($args, '$%s', '"', '\\%s');
+
+  if (!defined $value) {
+    return qq{unset $name;\n};
+  }
+
+  $value =~ s/(^|\G|$_path_sep)\$$name$_path_sep/$1\$$name\${$name+$_path_sep}/g;
+  $value =~ s/$_path_sep\$$name$/\${$name+$_path_sep}\$$name/;
+
+  qq{export ${name}="$value";\n}
 }
+
 sub build_csh_env_declaration {
   my ($class, $name, $args) = @_;
-  my ($value, @vars) = $class->_interpolate($args, undef, undef, '"', qq{"\\"});
-  (join '', map qq{if ! \$?$_ setenv $_ "";\n}, @vars)
-    . defined $value
-      ? qq{setenv $name "$value";\n}
-      : qq{unsetenv $name;\n};
+  my ($value, @vars) = $class->_interpolate($args, '$%s', '"', '"\\%s"');
+  if (!defined $value) {
+    return qq{unsetenv $name;\n};
+  }
+
+  my $out = '';
+  for my $var (@vars) {
+    $out .= qq{if ! \$?$name setenv $name '';\n};
+  }
+
+  my $value_without = $value;
+  if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
+    $out .= qq{if "\$$name" != '' setenv $name "$value";\n};
+    $out .= qq{if "\$$name" == '' };
+  }
+  $out .= qq{setenv $name "$value_without";\n};
+  return $out;
 }
+
 sub build_cmd_env_declaration {
   my ($class, $name, $args) = @_;
-  my $value = $class->_interpolate($args, '%', '%', qr([()!^"<>&|]), '^');
-  defined $value
-    ? qq{set $name=$value\n}
-    : qq{set $name=\n};
+  my $value = $class->_interpolate($args, '%%%s%%', qr([()!^"<>&|]), '^%s');
+  if (!$value) {
+    return qq{\@set $name=\n};
+  }
+
+  my $out = '';
+  my $value_without = $value;
+  if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) {
+    $out .= qq{\@if not "%$name%"=="" set $name=$value\n};
+    $out .= qq{\@if "%$name%"=="" };
+  }
+  $out .= qq{\@set $name=$value_without\n};
+  return $out;
 }
+
 sub build_powershell_env_declaration {
   my ($class, $name, $args) = @_;
-  my $value = $class->_interpolate($args, '$env:', '', '"', '`');
-  defined $value
-    ? qq{\$env:$name = "$value"\n}
-    : "Remove-Item Env:\\$name\n";
-}
+  my $value = $class->_interpolate($args, '$env:%s', '"', '`%s');
+
+  if (!$value) {
+    return qq{Remove-Item Env:\\$name;\n};
+  }
 
+  my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};
+  $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;
+  $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;
+
+  qq{\$env:$name = \$("$value");\n};
+}
+sub wrap_powershell_output {
+  my ($class, $out) = @_;
+  return $out || " \n";
+}
 
 sub _interpolate {
-  my ($class, $args, $start, $end, $escape, $escape_char) = @_;
+  my ($class, $args, $var_pat, $escape, $escape_pat) = @_;
   return
     unless defined $args;
-  return $args
-    unless ref $args;
+  my @args = ref $args ? @$args : $args;
   return
-    unless @$args;
-  $start = '$' unless defined $start;
-  $end = '' unless defined $end;
-  $escape = '"' unless defined $escape;
-  $escape_char = "\\" unless defined $escape_char;
-  my @vars;
-  my $string = join($Config{path_sep}, map {
-    if (ref $_ && ref $_ eq 'SCALAR') {
-      push @vars, $$_;
-      $start.$$_.$end;
-    }
-    else {
-      my $str = $_;
-      $str =~ s/($escape)/$escape_char$1/g;
-      $str;
-    }
-  } @$args);
-  return wantarray ? ($string, @vars) : $string;
+    unless @args;
+  my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args;
+  my $string = join $_path_sep, map {
+    ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do {
+      s/($escape)/sprintf($escape_pat, $1)/ge; $_;
+    };
+  } @args;
+  return wantarray ? ($string, \@vars) : $string;
 }
 
 sub pipeline;
@@ -537,12 +600,12 @@ sub guess_shelltype {
 
   for ($shellbin) {
     return
-        /csh/             ? 'csh'
-      : /command\.com/    ? 'cmd'
-      : /cmd\.exe/        ? 'cmd'
-      : /4nt\.exe/        ? 'cmd'
-      : /powershell\.exe/ ? 'powershell'
-                          : 'bourne';
+        /csh/              ? 'csh'
+      : /command\.com/i    ? 'cmd'
+      : /cmd\.exe/i        ? 'cmd'
+      : /4nt\.exe/i        ? 'cmd'
+      : /powershell\.exe/i ? 'powershell'
+                           : 'bourne';
   }
 }
 
@@ -628,7 +691,7 @@ If you are using C shell, you can do this as follows:
   /bin/csh
   echo $SHELL
   /bin/csh
-  perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc
+  echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc
 
 If you passed to bootstrap a directory other than default, you also need to
 give that as import parameter to the call of the local::lib module like this
@@ -706,7 +769,7 @@ C<CMD.exe>, you can use this:
   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
+If you want the environment entries to persist, you'll need to add them to the
 Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>.
 
 The "~" is translated to the user's profile directory (the directory named for
@@ -715,6 +778,13 @@ the user under "Documents and Settings" (Windows XP or earlier) or "Users"
 directory is translated to a short name (which means the directory must exist)
 and the subdirectories are created.
 
+=head3 PowerShell
+
+local::lib also supports PowerShell, and an be used with the
+C<Invoke-Expression> cmdlet.
+
+  Invoke-Expression "$(perl -Mlocal::lib)"
+
 =head1 RATIONALE
 
 The version of a Perl package on your machine is not always the version you