X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Flocal%2Flib.pm;h=ee36e1ad92201e190ed380169994398cb1a201dc;hb=45277afe3312a0bd747cc1a8770c8c385a34b59a;hp=40fcf683d834b3158dc4a6b16d4342924c1c6cbd;hpb=f643299c81fd737426ee00cec6882f3ab0579811;p=p5sagit%2Flocal-lib.git diff --git a/lib/local/lib.pm b/lib/local/lib.pm index 40fcf68..ee36e1a 100644 --- a/lib/local/lib.pm +++ b/lib/local/lib.pm @@ -45,6 +45,9 @@ DEATH my $shell = defined $1 ? $1 : shift @args; $opts{shelltype} = $shell; } + elsif ( $arg eq '--no-create' ) { + $opts{no_create} = 1; + } elsif ( $arg =~ /^--/ ) { die "Unknown import argument: $arg"; } @@ -88,6 +91,7 @@ sub bins { $_[0]->{bins} ||= [ \'PATH' ] } sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] } sub extra { $_[0]->{extra} ||= {} } sub shelltype { $_[0]->{shelltype} ||= $_[0]->guess_shelltype } +sub no_create { $_[0]->{no_create} } my $_archname = $Config{archname}; my $_version = $Config{version}; @@ -105,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); } @@ -180,7 +186,7 @@ sub deactivate { if (!grep { $_ eq $path } @active_lls) { warn "Tried to deactivate inactive local::lib '$path'\n"; - return; + return $self; } my %args = ( @@ -201,15 +207,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); @@ -220,20 +229,27 @@ sub activate { my ($self, $path) = @_; $self = $self->new unless ref $self; $path = $self->resolve_path($path); - $self->ensure_dir_structure_for($path); + $self->ensure_dir_structure_for($path) + unless $self->no_create; + + $path = ( Win32::GetShortPathName($path) || $path ) + if $^O eq 'MSWin32'; 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); @@ -305,54 +321,60 @@ sub environment_vars_string_for { && ${$value->[0]} eq $name) { next; } - if (!ref $value - && $value eq $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); - $value =~ s/"/\\"/g - if defined $value; - return defined($value) ? qq{export ${name}="${value}"\n} : qq{unset ${name}\n}; + defined $value + ? qq{export ${name}="${value}";\n} + : qq{unset ${name};\n}; } sub build_csh_env_declaration { my ($class, $name, $args) = @_; - my ($value, @vars) = $class->_interpolate($args); - @vars = grep { $_ ne $name || defined $value } @vars; - $value =~ s/"/"\\""/g - if defined $value; - join '', - (map qq{if ! \$?$_ setenv $_ "";\n}, @vars), - (defined($value) + 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}); + : qq{unsetenv $name;\n}; } sub build_cmd_env_declaration { my ($class, $name, $args) = @_; - my $value = $class->_interpolate($args, '%', '%'); - $value =~ s/"/\\"/g - if defined $value; - return qq{set $name=} . (defined($value) ? qq{"$value"} : '') . "\n"; + my $value = $class->_interpolate($args, '%', '%', qr([()!^"<>&|]), '^'); + defined $value + ? qq{\@set $name=$value\n} + : qq{\@set $name=\n}; } sub build_powershell_env_declaration { my ($class, $name, $args) = @_; - my $value = $class->_interpolate($args, '$env:'); - if (defined $value) { - $value =~ s/"/\\"/g; - return qq{\$env:$name = "$value"\n}; - } - return "Remove-Item Env:\\$name\n"; + my $value = $class->_interpolate($args, '$env:', '', '"', '`'); + defined $value + ? qq{\$env:$name = "$value";\n} + : "Remove-Item Env:\\$name;\n"; +} +sub wrap_powershell_output { + my ($class, $out) = @_; + return $out || " \n"; } sub _interpolate { - my ($class, $args, $start, $end) = @_; + my ($class, $args, $start, $end, $escape, $escape_char) = @_; return unless defined $args; return $args @@ -361,10 +383,19 @@ sub _interpolate { 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 { - (ref $_ && ref $_ eq 'SCALAR') ? do { push @vars, $$_; $start.$$_.$end } - : $_ + 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; } @@ -411,9 +442,6 @@ sub resolve_path { resolve_empty_path )}($path); - $path = Win32::GetShortPathName($path) - if $^O eq 'MSWin32'; - $path; } @@ -515,38 +543,26 @@ ok(-d 't/var/splat'); =cut sub guess_shelltype { - my $shellbin = 'sh'; - if(defined $ENV{'SHELL'}) { - my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'}); - $shellbin = $shell_bin_path_parts[-1]; - } - my $shelltype = do { - local $_ = $shellbin; - if(/csh/) { - 'csh' - } else { - 'bourne' - } - }; - - # Both Win32 and Cygwin have $ENV{COMSPEC} set. - if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') { - my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'}); - $shellbin = $shell_bin_path_parts[-1]; - $shelltype = do { - local $_ = $shellbin; - if(/command\.com/) { - 'cmd' - } elsif(/cmd\.exe/) { - 'cmd' - } elsif(/4nt\.exe/) { - 'cmd' - } else { - $shelltype - } - }; + my $shellbin + = defined $ENV{SHELL} + ? (File::Spec->splitpath($ENV{SHELL}))[-1] + : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} ) + ? 'bash' + : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} ) + ? (File::Spec->splitpath($ENV{COMSPEC}))[-1] + : ( $^O eq 'MSWin32' && !$ENV{PROMPT} ) + ? 'powershell.exe' + : 'sh'; + + for ($shellbin) { + return + /csh/ ? 'csh' + : /command\.com/ ? 'cmd' + : /cmd\.exe/ ? 'cmd' + : /4nt\.exe/ ? 'cmd' + : /powershell\.exe/ ? 'powershell' + : 'bourne'; } - return $shelltype; } 1; @@ -796,6 +812,17 @@ was added by C, instead of adding it. Remove all directories that were added to search paths by C from the search paths. +=head2 --shelltype + +Specify the shell type to use for output. By default, the shell will be +detected based on the environment. Should be one of: C, C, +C, or C. + +=head2 --no-create + +Prevents C from creating directories when activating dirs. This is +likely to cause issues on Win32 systems. + =head1 METHODS =head2 ensure_dir_structure_for @@ -828,7 +855,7 @@ given path as the base directory. =over 4 -=item Arguments: $path, $interpolate +=item Arguments: $path =item Return value: %environment_vars