File Coverage

lib/CPANPLUS/YACSmoke/locallib.pm
Criterion Covered Total %
statement 117 338 34.6
branch 27 166 16.2
condition 19 79 24.0
subroutine 37 63 58.7
pod 27 43 62.7
total 227 689 32.9


line stmt bran cond sub pod time code
1             package CPANPLUS::YACSmoke::locallib;
2             $CPANPLUS::YACSmoke::locallib::VERSION = '1.04';
3              
4 1     1   25 use 5.006;
  1         4  
5             BEGIN {
6 1 50   1   20 if ($ENV{RELEASE_TESTING}) {
7 0         0 require strict;
8 0         0 strict->import;
9 0         0 require warnings;
10 0         0 warnings->import;
11             }
12             }
13 1     1   14 use Config ();
  1         2  
  1         127  
14              
15             BEGIN {
16             *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')
17 1 50 33 1   33 ? sub(){1} : sub(){0};
18             # punt on these systems
19             *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})
20 1 50 33     560 ? sub(){1} : sub(){0};
21             }
22             my $_archname = $Config::Config{archname};
23             my $_version = $Config::Config{version};
24             my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list};
25             my $_path_sep = $Config::Config{path_sep};
26              
27             our $_DIR_JOIN = _WIN32 ? '\\' : '/';
28             our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]}
29             : qr{/};
30             our $_ROOT = _WIN32 ? do {
31             my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};
32             qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT};
33             } : qr{^/};
34             our $_PERL;
35              
36             sub _perl {
37 0 0   0   0 if (!$_PERL) {
38             # untaint and validate
39 0         0 ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/;
40 0 0       0 $_PERL = 'perl'
41             if $exe !~ /perl/;
42 0 0 0     0 if (_is_abs($_PERL)) {
    0          
    0          
43             }
44             elsif (-x $Config::Config{perlpath}) {
45 0         0 $_PERL = $Config::Config{perlpath};
46             }
47             elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) {
48 0         0 $_PERL = _rel2abs($_PERL);
49             }
50             else {
51             ($_PERL) =
52 0         0 map { /(.*)/ }
53 0         0 grep { -x $_ }
54 0         0 map { ($_, _WIN32 ? ("$_.exe") : ()) }
55 0         0 map { join($_DIR_JOIN, $_, $_PERL) }
56 0         0 split /\Q$_path_sep\E/, $ENV{PATH};
57             }
58             }
59 0         0 $_PERL;
60             }
61              
62             sub _cwd {
63 0 0   0   0 if (my $cwd
    0          
    0          
64             = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd
65             : defined &Cwd::cwd ? \&Cwd::cwd
66             : undef
67             ) {
68 1     1   8 no warnings 'redefine';
  1         2  
  1         5371  
69 0         0 *_cwd = $cwd;
70 0         0 goto &$cwd;
71             }
72 0         0 my $drive = shift;
73 0         0 return Win32::Cwd()
74             if _WIN32 && defined &Win32::Cwd && !$drive;
75 0         0 local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
76 0 0       0 my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }"
77             : 'getcwd';
78 0         0 my $perl = _perl;
79 0         0 my $cwd = `"$perl" -MCwd -le "print $cmd"`;
80 0         0 chomp $cwd;
81 0 0 0     0 if (!length $cwd && $drive) {
82 0         0 $cwd = $drive;
83             }
84 0         0 $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;
85 0         0 $cwd;
86             }
87              
88             sub _catdir {
89 19     19   55 if (_USE_FSPEC) {
90 19         66 require File::Spec;
91 19         121 File::Spec->catdir(@_);
92             }
93             else {
94             my $dir = join($_DIR_JOIN, @_);
95             $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;
96             $dir;
97             }
98             }
99              
100             sub _is_abs {
101 1     1   2 if (_USE_FSPEC) {
102 1         6 require File::Spec;
103 1         16 File::Spec->file_name_is_absolute($_[0]);
104             }
105             else {
106             $_[0] =~ $_ROOT;
107             }
108             }
109              
110             sub _rel2abs {
111 1     1   2 my ($dir, $base) = @_;
112 1 50       2 return $dir
113             if _is_abs($dir);
114              
115 0 0       0 $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1")
116             : $base ? _rel2abs($base)
117             : _cwd;
118 0         0 return _catdir($base, $dir);
119             }
120              
121             our $_DEVNULL;
122             sub _devnull {
123 0   0 0   0 return $_DEVNULL ||=
124             _USE_FSPEC ? (require File::Spec, File::Spec->devnull)
125             : _WIN32 ? 'nul'
126             : $^O eq 'os2' ? '/dev/nul'
127             : '/dev/null';
128             }
129              
130             sub import {
131 0     0   0 my ($class, @args) = @_;
132 0 0       0 if ($0 eq '-') {
133 0         0 push @args, @ARGV;
134 0         0 require Cwd;
135             }
136              
137 0         0 my @steps;
138             my %opts;
139 0         0 my %attr;
140 0         0 my $shelltype;
141              
142 0         0 while (@args) {
143 0         0 my $arg = shift @args;
144             # check for lethal dash first to stop processing before causing problems
145             # the fancy dash is U+2212 or \xE2\x88\x92
146 0 0       0 if ($arg =~ /\xE2\x88\x92/) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
147 0         0 die <<'DEATH';
148             WHOA THERE! It looks like you've got some fancy dashes in your commandline!
149             These are *not* the traditional -- dashes that software recognizes. You
150             probably got these by copy-pasting from the perldoc for this module as
151             rendered by a UTF8-capable formatter. This most typically happens on an OS X
152             terminal, but can happen elsewhere too. Please try again after replacing the
153             dashes with normal minus signs.
154             DEATH
155             }
156             elsif ($arg eq '--self-contained') {
157 0         0 die <<'DEATH';
158             FATAL: The local::lib --self-contained flag has never worked reliably and the
159             original author, Mark Stosberg, was unable or unwilling to maintain it. As
160             such, this flag has been removed from the local::lib codebase in order to
161             prevent misunderstandings and potentially broken builds. The local::lib authors
162             recommend that you look at the lib::core::only module shipped with this
163             distribution in order to create a more robust environment that is equivalent to
164             what --self-contained provided (although quite possibly not what you originally
165             thought it provided due to the poor quality of the documentation, for which we
166             apologise).
167             DEATH
168             }
169             elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) {
170 0 0       0 my $path = defined $1 ? $1 : shift @args;
171 0         0 push @steps, ['deactivate', $path];
172             }
173             elsif ( $arg eq '--deactivate-all' ) {
174 0         0 push @steps, ['deactivate_all'];
175             }
176             elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) {
177 0 0       0 $shelltype = defined $1 ? $1 : shift @args;
178             }
179             elsif ( $arg eq '--no-create' ) {
180 0         0 $opts{no_create} = 1;
181             }
182             elsif ( $arg eq '--quiet' ) {
183 0         0 $attr{quiet} = 1;
184             }
185             elsif ( $arg =~ /^--/ ) {
186 0         0 die "Unknown import argument: $arg";
187             }
188             else {
189 0         0 push @steps, ['activate', $arg, \%opts];
190             }
191             }
192 0 0       0 if (!@steps) {
193 0         0 push @steps, ['activate', undef, \%opts];
194             }
195              
196 0         0 my $self = $class->new(%attr);
197              
198 0         0 for (@steps) {
199 0         0 my ($method, @args) = @$_;
200 0         0 $self = $self->$method(@args);
201             }
202              
203 0 0       0 if ($0 eq '-') {
204 0         0 print $self->environment_vars_string($shelltype);
205 0         0 exit 0;
206             }
207             else {
208 0         0 $self->setup_local_lib;
209             }
210             }
211              
212             sub new {
213 1     1 1 3 my $class = shift;
214 1         4 bless {@_}, $class;
215             }
216              
217             sub clone {
218 1     1 1 2 my $self = shift;
219 1         7 bless {%$self, @_}, ref $self;
220             }
221              
222 1   50 1 1 20 sub inc { $_[0]->{inc} ||= \@INC }
223 2   100 2 1 14 sub libs { $_[0]->{libs} ||= [ \'PERL5LIB' ] }
224 2   100 2 1 18 sub bins { $_[0]->{bins} ||= [ \'PATH' ] }
225 3   100 3 1 16 sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] }
226 1   50 1 1 16 sub extra { $_[0]->{extra} ||= {} }
227 1     1 0 8 sub quiet { $_[0]->{quiet} }
228              
229             sub _as_list {
230 4     4   8 my $list = shift;
231             grep length, map {
232 4 50       20 !(ref $_ && ref $_ eq 'SCALAR') ? $_ : (
233 7 100 66     76 defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_})
    100          
234             : ()
235             )
236             } ref $list ? @$list : $list;
237             }
238             sub _remove_from {
239 0     0   0 my ($list, @remove) = @_;
240 0 0       0 return @$list
241             if !@remove;
242 0         0 my %remove = map { $_ => 1 } @remove;
  0         0  
243 0         0 grep !$remove{$_}, _as_list($list);
244             }
245              
246             my @_lib_subdirs = (
247             [$_version, $_archname],
248             [$_version],
249             [$_archname],
250             (map [$_], @_inc_version_list),
251             [],
252             );
253              
254             sub install_base_bin_path {
255 3     3 1 9 my ($class, $path) = @_;
256 3         7 return _catdir($path, 'bin');
257             }
258             sub install_base_perl_path {
259 4     4 1 9 my ($class, $path) = @_;
260 4         9 return _catdir($path, 'lib', 'perl5');
261             }
262             sub install_base_arch_path {
263 0     0 0 0 my ($class, $path) = @_;
264 0         0 _catdir($class->install_base_perl_path($path), $_archname);
265             }
266              
267             sub lib_paths_for {
268 3     3 1 7 my ($class, $path) = @_;
269 3         6 my $base = $class->install_base_perl_path($path);
270 3         8 return map { _catdir($base, @$_) } @_lib_subdirs;
  12         26  
271             }
272              
273             sub _mm_escape_path {
274 1     1   2 my $path = shift;
275 1         3 $path =~ s/\\/\\\\/g;
276 1 50       3 if ($path =~ s/ /\\ /g) {
277 0         0 $path = qq{"$path"};
278             }
279 1         12 return $path;
280             }
281              
282             sub _mb_escape_path {
283 1     1   2 my $path = shift;
284 1         2 $path =~ s/\\/\\\\/g;
285 1         11 return qq{"$path"};
286             }
287              
288             sub installer_options_for {
289 1     1 1 2 my ($class, $path) = @_;
290             return (
291 1 50       5 PERL_MM_OPT =>
    50          
292             defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef,
293             PERL_MB_OPT =>
294             defined $path ? "--install_base "._mb_escape_path($path) : undef,
295             );
296             }
297              
298             sub active_paths {
299 1     1 1 2 my ($self) = @_;
300 1 50       3 $self = ref $self ? $self : $self->new;
301              
302             return grep {
303             # screen out entries that aren't actually reflected in @INC
304 1         3 my $active_ll = $self->install_base_perl_path($_);
  0         0  
305 0         0 grep { $_ eq $active_ll } @{$self->inc};
  0         0  
  0         0  
306             } _as_list($self->roots);
307             }
308              
309              
310             sub deactivate {
311 0     0 1 0 my ($self, $path) = @_;
312 0 0       0 $self = $self->new unless ref $self;
313 0         0 $path = $self->resolve_path($path);
314 0         0 $path = $self->normalize_path($path);
315              
316 0         0 my @active_lls = $self->active_paths;
317              
318 0 0       0 if (!grep { $_ eq $path } @active_lls) {
  0         0  
319 0         0 warn "Tried to deactivate inactive local::lib '$path'\n";
320 0         0 return $self;
321             }
322              
323 0         0 my %args = (
324             bins => [ _remove_from($self->bins,
325             $self->install_base_bin_path($path)) ],
326             libs => [ _remove_from($self->libs,
327             $self->install_base_perl_path($path)) ],
328             inc => [ _remove_from($self->inc,
329             $self->lib_paths_for($path)) ],
330             roots => [ _remove_from($self->roots, $path) ],
331             );
332              
333 0         0 $args{extra} = { $self->installer_options_for($args{roots}[0]) };
334              
335 0         0 $self->clone(%args);
336             }
337              
338             sub deactivate_all {
339 0     0 1 0 my ($self) = @_;
340 0 0       0 $self = $self->new unless ref $self;
341              
342 0         0 my @active_lls = $self->active_paths;
343              
344 0         0 my %args;
345 0 0       0 if (@active_lls) {
346 0         0 %args = (
347             bins => [ _remove_from($self->bins,
348             map $self->install_base_bin_path($_), @active_lls) ],
349             libs => [ _remove_from($self->libs,
350             map $self->install_base_perl_path($_), @active_lls) ],
351             inc => [ _remove_from($self->inc,
352             map $self->lib_paths_for($_), @active_lls) ],
353             roots => [ _remove_from($self->roots, @active_lls) ],
354             );
355             }
356              
357 0         0 $args{extra} = { $self->installer_options_for(undef) };
358              
359 0         0 $self->clone(%args);
360             }
361              
362             sub activate {
363 1     1 1 3 my ($self, $path, $opts) = @_;
364 1   50     7 $opts ||= {};
365 1 50       5 $self = $self->new unless ref $self;
366 1         4 $path = $self->resolve_path($path);
367             $self->ensure_dir_structure_for($path, { quiet => $self->quiet })
368 1 50       5 unless $opts->{no_create};
369              
370 1         5 $path = $self->normalize_path($path);
371              
372 1         3 my @active_lls = $self->active_paths;
373              
374 1 50       5 if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) {
  0         0  
375 0         0 $self = $self->deactivate($path);
376             }
377              
378 1         2 my %args;
379 1 50 33     6 if ($opts->{always} || !@active_lls || $active_lls[0] ne $path) {
      33        
380             %args = (
381 1         4 bins => [ $self->install_base_bin_path($path), @{$self->bins} ],
382 1         18 libs => [ $self->install_base_perl_path($path), @{$self->libs} ],
383 1         3 inc => [ $self->lib_paths_for($path), @{$self->inc} ],
384 1         3 roots => [ $path, @{$self->roots} ],
  1         4  
385             );
386             }
387              
388 1         4 $args{extra} = { $self->installer_options_for($path) };
389              
390 1         6 $self->clone(%args);
391             }
392              
393             sub normalize_path {
394 1     1 0 2 my ($self, $path) = @_;
395 1 50 0     4 $path = ( Win32::GetShortPathName($path) || $path )
396             if $^O eq 'MSWin32';
397 1         3 return $path;
398             }
399              
400             sub build_environment_vars_for {
401 0     0 1 0 my $self = $_[0]->new->activate($_[1], { always => 1 });
402 0         0 $self->build_environment_vars;
403             }
404             sub build_activate_environment_vars_for {
405 0     0 0 0 my $self = $_[0]->new->activate($_[1], { always => 1 });
406 0         0 $self->build_environment_vars;
407             }
408             sub build_deactivate_environment_vars_for {
409 0     0 0 0 my $self = $_[0]->new->deactivate($_[1]);
410 0         0 $self->build_environment_vars;
411             }
412             sub build_deact_all_environment_vars_for {
413 0     0 0 0 my $self = $_[0]->new->deactivate_all;
414 0         0 $self->build_environment_vars;
415             }
416             sub build_environment_vars {
417 1     1 1 2 my $self = shift;
418             (
419             PATH => join($_path_sep, _as_list($self->bins)),
420             PERL5LIB => join($_path_sep, _as_list($self->libs)),
421             PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)),
422 1         2 %{$self->extra},
  1         3  
423             );
424             }
425              
426             sub setup_local_lib_for {
427 0     0 0 0 my $self = $_[0]->new->activate($_[1]);
428 0         0 $self->setup_local_lib;
429             }
430              
431             sub setup_local_lib {
432 0     0 1 0 my $self = shift;
433              
434             # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid
435             # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to
436             # check in the other direction)
437 0 0       0 require Carp::Heavy if $INC{'Carp.pm'};
438              
439 0         0 $self->setup_env_hash;
440 0         0 @INC = @{$self->inc};
  0         0  
441             }
442              
443             sub setup_env_hash_for {
444 1     1 1 4 my $self = $_[0]->new->activate($_[1]);
445 1         9 $self->setup_env_hash;
446             }
447             sub setup_env_hash {
448 1     1 1 2 my $self = shift;
449 1         3 my %env = $self->build_environment_vars;
450 1         6 for my $key (keys %env) {
451 5 50       12 if (defined $env{$key}) {
452 5         29 $ENV{$key} = $env{$key};
453             }
454             else {
455 0         0 delete $ENV{$key};
456             }
457             }
458             }
459              
460             sub print_environment_vars_for {
461 0     0 1 0 print $_[0]->environment_vars_string_for(@_[1..$#_]);
462             }
463              
464             sub environment_vars_string_for {
465 0     0 0 0 my $self = $_[0]->new->activate($_[1], { always => 1});
466 0         0 $self->environment_vars_string;
467             }
468             sub environment_vars_string {
469 0     0 1 0 my ($self, $shelltype) = @_;
470              
471 0   0     0 $shelltype ||= $self->guess_shelltype;
472              
473 0         0 my $extra = $self->extra;
474             my @envs = (
475             PATH => $self->bins,
476             PERL5LIB => $self->libs,
477             PERL_LOCAL_LIB_ROOT => $self->roots,
478 0         0 map { $_ => $extra->{$_} } sort keys %$extra,
  0         0  
479             );
480 0         0 $self->_build_env_string($shelltype, \@envs);
481             }
482              
483             sub _build_env_string {
484 0     0   0 my ($self, $shelltype, $envs) = @_;
485 0         0 my @envs = @$envs;
486              
487 0         0 my $build_method = "build_${shelltype}_env_declaration";
488              
489 0         0 my $out = '';
490 0         0 while (@envs) {
491 0         0 my ($name, $value) = (shift(@envs), shift(@envs));
492 0 0 0     0 if (
      0        
      0        
      0        
493             ref $value
494             && @$value == 1
495             && ref $value->[0]
496             && ref $value->[0] eq 'SCALAR'
497 0         0 && ${$value->[0]} eq $name) {
498 0         0 next;
499             }
500 0         0 $out .= $self->$build_method($name, $value);
501             }
502 0         0 my $wrap_method = "wrap_${shelltype}_output";
503 0 0       0 if ($self->can($wrap_method)) {
504 0         0 return $self->$wrap_method($out);
505             }
506 0         0 return $out;
507             }
508              
509             sub build_bourne_env_declaration {
510 0     0 0 0 my ($class, $name, $args) = @_;
511 0         0 my $value = $class->_interpolate($args, '${%s:-}', qr/["\\\$!`]/, '\\%s');
512              
513 0 0       0 if (!defined $value) {
514 0         0 return qq{unset $name;\n};
515             }
516              
517 0         0 $value =~ s/(^|\G|$_path_sep)\$\{$name:-\}$_path_sep/$1\${$name}\${$name:+$_path_sep}/g;
518 0         0 $value =~ s/$_path_sep\$\{$name:-\}$/\${$name:+$_path_sep\${$name}}/;
519              
520 0         0 qq{${name}="$value"; export ${name};\n}
521             }
522              
523             sub build_csh_env_declaration {
524 0     0 0 0 my ($class, $name, $args) = @_;
525 0         0 my ($value, @vars) = $class->_interpolate($args, '${%s}', qr/["\$]/, '"\\%s"');
526 0 0       0 if (!defined $value) {
527 0         0 return qq{unsetenv $name;\n};
528             }
529              
530 0         0 my $out = '';
531 0         0 for my $var (@vars) {
532 0         0 $out .= qq{if ! \$?$name setenv $name '';\n};
533             }
534              
535 0         0 my $value_without = $value;
536 0 0       0 if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) {
537 0         0 $out .= qq{if "\${$name}" != '' setenv $name "$value";\n};
538 0         0 $out .= qq{if "\${$name}" == '' };
539             }
540 0         0 $out .= qq{setenv $name "$value_without";\n};
541 0         0 return $out;
542             }
543              
544             sub build_cmd_env_declaration {
545 0     0 0 0 my ($class, $name, $args) = @_;
546 0         0 my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s');
547 0 0       0 if (!$value) {
548 0         0 return qq{\@set $name=\n};
549             }
550              
551 0         0 my $out = '';
552 0         0 my $value_without = $value;
553 0 0       0 if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) {
554 0         0 $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};
555 0         0 $out .= qq{\@if "%$name%"=="" };
556             }
557 0         0 $out .= qq{\@set "$name=$value_without"\n};
558 0         0 return $out;
559             }
560              
561             sub build_powershell_env_declaration {
562 0     0 0 0 my ($class, $name, $args) = @_;
563 0         0 my $value = $class->_interpolate($args, '$env:%s', qr/["\$]/, '`%s');
564              
565 0 0       0 if (!$value) {
566 0         0 return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n};
567             }
568              
569 0         0 my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};
570 0         0 $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;
571 0         0 $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;
572              
573 0         0 qq{\$env:$name = \$("$value");\n};
574             }
575             sub wrap_powershell_output {
576 0     0 0 0 my ($class, $out) = @_;
577 0   0     0 return $out || " \n";
578             }
579              
580             sub build_fish_env_declaration {
581 0     0 0 0 my ($class, $name, $args) = @_;
582 0         0 my $value = $class->_interpolate($args, '$%s', qr/[\\"'$ ]/, '\\%s');
583 0 0       0 if (!defined $value) {
584 0         0 return qq{set -e $name;\n};
585             }
586              
587             # fish has special handling for PATH, CDPATH, and MANPATH. They are always
588             # treated as arrays, and joined with ; when storing the environment. Other
589             # env vars can be arrays, but will be joined without a separator. We only
590             # really care about PATH, but might as well make this routine more general.
591 0 0       0 if ($name =~ /^(?:CD|MAN)?PATH$/) {
592 0         0 $value =~ s/$_path_sep/ /g;
593 0 0       0 my $silent = $name =~ /^(?:CD)?PATH$/ ? " ^"._devnull : '';
594 0         0 return qq{set -x $name $value$silent;\n};
595             }
596              
597 0         0 my $out = '';
598 0         0 my $value_without = $value;
599 0 0       0 if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
600 0         0 $out .= qq{set -q $name; and set -x $name $value;\n};
601 0         0 $out .= qq{set -q $name; or };
602             }
603 0         0 $out .= qq{set -x $name $value_without;\n};
604 0         0 $out;
605             }
606              
607             sub _interpolate {
608 0     0   0 my ($class, $args, $var_pat, $escape, $escape_pat) = @_;
609             return
610 0 0       0 unless defined $args;
611 0 0       0 my @args = ref $args ? @$args : $args;
612             return
613 0 0       0 unless @args;
614 0         0 my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args;
  0         0  
  0         0  
615             my $string = join $_path_sep, map {
616 0 0       0 ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do {
  0         0  
617 0         0 s/($escape)/sprintf($escape_pat, $1)/ge; $_;
  0         0  
  0         0  
618             };
619             } @args;
620 0 0       0 return wantarray ? ($string, \@vars) : $string;
621             }
622              
623             sub pipeline;
624              
625             sub pipeline {
626 3     3 0 7 my @methods = @_;
627 3         6 my $last = pop(@methods);
628 3 100       8 if (@methods) {
629             \sub {
630 2     2   4 my ($obj, @args) = @_;
631 2         6 $obj->${pipeline @methods}(
  2         3  
632             $obj->$last(@args)
633             );
634 2         11 };
635             } else {
636             \sub {
637 1     1   3 shift->$last(@_);
638 1         4 };
639             }
640             }
641              
642             sub resolve_path {
643 1     1 1 2 my ($class, $path) = @_;
644              
645 1         2 $path = $class->${pipeline qw(
  1         3  
646             resolve_relative_path
647             resolve_home_path
648             resolve_empty_path
649             )}($path);
650              
651 1         4 $path;
652             }
653              
654             sub resolve_empty_path {
655 1     1 1 2 my ($class, $path) = @_;
656 1 50       3 if (defined $path) {
657 1         3 $path;
658             } else {
659 0         0 '~/perl5';
660             }
661             }
662              
663             sub resolve_home_path {
664 1     1 1 2 my ($class, $path) = @_;
665 1 50       5 $path =~ /^~([^\/]*)/ or return $path;
666 0         0 my $user = $1;
667 0         0 my $homedir = do {
668 0 0 0     0 if (! length($user) && defined $ENV{HOME}) {
669 0         0 $ENV{HOME};
670             }
671             else {
672 0         0 require File::Glob;
673 0         0 File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE());
674             }
675             };
676 0 0       0 unless (defined $homedir) {
677 0         0 require Carp; require Carp::Heavy;
  0         0  
678 0 0       0 Carp::croak(
679             "Couldn't resolve homedir for "
680             .(defined $user ? $user : 'current user')
681             );
682             }
683 0         0 $path =~ s/^~[^\/]*/$homedir/;
684 0         0 $path;
685             }
686              
687             sub resolve_relative_path {
688 1     1 1 2 my ($class, $path) = @_;
689 1         3 _rel2abs($path);
690             }
691              
692             sub ensure_dir_structure_for {
693 2     2 1 5 my ($class, $path, $opts) = @_;
694 2   50     7 $opts ||= {};
695 2         3 my @dirs;
696 2         5 foreach my $dir (
697             $class->lib_paths_for($path),
698             $class->install_base_bin_path($path),
699             ) {
700 10         57 my $d = $dir;
701 10         135 while (!-d $d) {
702 13         43 push @dirs, $d;
703 13         59 require File::Basename;
704 13         646 $d = File::Basename::dirname($d);
705             }
706             }
707              
708             warn "Attempting to create directory ${path}\n"
709 2 50 66     16 if !$opts->{quiet} && @dirs;
710              
711 2         5 my %seen;
712 2         4 foreach my $dir (reverse @dirs) {
713             next
714 13 100       44 if $seen{$dir}++;
715              
716 6 50 33     242 mkdir $dir
717             or -d $dir
718             or die "Unable to create $dir: $!"
719             }
720 2         11 return;
721             }
722              
723             sub guess_shelltype {
724             my $shellbin
725             = defined $ENV{SHELL} && length $ENV{SHELL}
726             ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1]
727             : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} )
728             ? 'bash'
729             : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} )
730             ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1]
731             : ( $^O eq 'MSWin32' && !$ENV{PROMPT} )
732 0 0 0 0 0   ? 'powershell.exe'
    0 0        
    0 0        
    0 0        
733             : 'sh';
734              
735 0           for ($shellbin) {
736             return
737 0 0         /csh$/ ? 'csh'
    0          
    0          
    0          
    0          
    0          
738             : /fish$/ ? 'fish'
739             : /command(?:\.com)?$/i ? 'cmd'
740             : /cmd(?:\.exe)?$/i ? 'cmd'
741             : /4nt(?:\.exe)?$/i ? 'cmd'
742             : /powershell(?:\.exe)?$/i ? 'powershell'
743             : 'bourne';
744             }
745             }
746              
747             1;
748             __END__