From c4782cf33da57b01b29c5a1df4a56b7ffd2e5686 Mon Sep 17 00:00:00 2001 From: Kang-min Liu Date: Mon, 21 Jul 2014 07:43:18 +0200 Subject: [PATCH] rebuild the dev version. --- perlbrew | 6107 ++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 5654 insertions(+), 453 deletions(-) diff --git a/perlbrew b/perlbrew index 1e53f296..9f06310d 100755 --- a/perlbrew +++ b/perlbrew @@ -1,292 +1,2663 @@ #!/usr/bin/perl +BEGIN { use Config; @INC = @Config{qw(privlibexp archlibexp sitelibexp sitearchexp)} }; + + # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; -$fatpacked{"App/perlbrew.pm"} = <<'APP_PERLBREW'; - package App::perlbrew;use strict;use warnings;use 5.008;our$VERSION="0.69";use Config;BEGIN {my@oldinc=@INC;@INC=($Config{sitelibexp}."/".$Config{archname},$Config{sitelibexp},@Config{qw},);require Cwd;@INC=@oldinc}use List::Util qw/min/;use Getopt::Long ();local$SIG{__DIE__}=sub {my$message=shift;warn$message;exit(1)};our$CONFIG;our$PERLBREW_ROOT=$ENV{PERLBREW_ROOT}|| joinpath($ENV{HOME},"perl5","perlbrew");our$PERLBREW_HOME=$ENV{PERLBREW_HOME}|| joinpath($ENV{HOME},".perlbrew");my@flavors=({d_option=>'usethreads',implies=>'multi',common=>1,opt=>'thread|threads' },{d_option=>'usemultiplicity',opt=>'multi' },{d_option=>'uselongdouble',common=>1,opt=>'ld' },{d_option=>'use64bitint',common=>1,opt=>'64int' },{d_option=>'use64bitall',implies=>'64int',opt=>'64all' },{d_option=>'DEBUGGING',opt=>'debug' },{d_option=>'cc=clang',opt=>'clang' },);my%flavor;my$flavor_ix=0;for (@flavors){my ($name)=$_->{opt}=~ /([^|]+)/;$_->{name}=$name;$_->{ix}=++$flavor_ix;$flavor{$name}=$_}for (@flavors){if (my$implies=$_->{implies}){$flavor{$implies}{implied_by}=$_->{name}}}sub joinpath {join "/",@_}sub mkpath {require File::Path;File::Path::mkpath([@_],0,0777)}sub rmpath {require File::Path;File::Path::rmtree([@_],0,0)}sub files_are_the_same {my@files=@_;my@stats=map {[stat($_)]}@files;my$stats0=join " ",@{$stats[0]}[0,1];for (@stats){return 0 if ((!defined($_->[1]))|| $_->[1]==0);unless ($stats0 eq join(" ",$_->[0],$_->[1])){return 0}}return 1}{my%commands=(curl=>{test=>'--version >/dev/null 2>&1',get=>'--insecure --silent --location --fail -o - {url}',download=>'--insecure --silent --location --fail -o {output} {url}',order=>1,},wget=>{test=>'--version >/dev/null 2>&1',get=>'--no-check-certificate --quiet -O - {url}',download=>'--no-check-certificate --quiet -O {output} {url}',order=>2,},fetch=>{test=>'--version >/dev/null 2>&1',get=>'--no-verify-peer -o - {url}',download=>'--no-verify-peer {url}',order=>3,});our$HTTP_USER_AGENT_PROGRAM;sub http_user_agent_program {$HTTP_USER_AGENT_PROGRAM ||=do {my$program;for my$p (sort {$commands{$a}<=>$commands{$b}}keys%commands){my$code=system("$p $commands{$p}->{test}")>> 8;if ($code!=127){$program=$p;last}}unless($program){die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n"}$program};die "[ERROR] Unrecognized http user agent program: $HTTP_USER_AGENT_PROGRAM. It can only be one of: ".join(",",keys%commands)."\n" unless$commands{$HTTP_USER_AGENT_PROGRAM};return$HTTP_USER_AGENT_PROGRAM}sub http_user_agent_command {my ($purpose,$params)=@_;my$ua=http_user_agent_program;my$cmd=$ua ." " .$commands{$ua }->{$purpose };for (keys %$params){$cmd =~ s!{$_}!$params->{$_}!g}return ($ua,$cmd)if wantarray;return$cmd}sub http_download {my ($url,$path)=@_;if (-e $path){die "ERROR: The download target < $path > already exists.\n"}my$download_command=http_user_agent_command(download=>{url=>$url,output=>$path });my$status=system($download_command);unless ($status==0){return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$?"}return 0}sub http_get {my ($url,$header,$cb)=@_;if (ref($header)eq 'CODE'){$cb=$header;$header=undef}my ($program,$command)=http_user_agent_command(get=>{url=>$url });open my$fh,'-|',$command or die "open() for '$command': $!";local $/;my$body=<$fh>;close$fh;die 'Page not retrieved; HTTP error code 400 or above.' if$program eq 'curl' and $? >> 8==22;die 'Page not retrieved: fetch failed.' if$program eq 'fetch' and $?;die 'Server issued an error response.' if$program eq 'wget' and $? >> 8==8;return$cb ? $cb->($body): $body}}sub perl_version_to_integer {my$version=shift;my@v=split(/[\.\-_]/,$version);return undef if@v < 2;if ($v[1]<= 5){$v[2]||=0;$v[3]=0}else {$v[3]||=$v[1]>= 6 ? 9 : 0;$v[3]=~ s/[^0-9]//g}return$v[1]*1000000 + $v[2]*1000 + $v[3]}sub editdist {my@a=split //,shift;my@b=split //,shift;my@d;$d[$_][0]=$_ for (0 .. @a);$d[0][$_]=$_ for (0 .. @b);for my$i (1 .. @a){for my$j (1 .. @b){$d[$i][$j]=($a[$i-1]eq $b[$j-1]? $d[$i-1][$j-1]: 1 + min($d[$i-1][$j],$d[$i][$j-1],$d[$i-1][$j-1]))}}return$d[@a][@b]}sub new {my($class,@argv)=@_;my%opt=(original_argv=>\@argv,args=>[],force=>0,quiet=>0,D=>[],U=>[],A=>[],sitecustomize=>'',noman=>'',variation=>'',both=>[],append=>'',);$opt{$_}='' for keys%flavor;if (@argv){local (@ARGV)=@argv;Getopt::Long::Configure('pass_through','no_ignore_case','bundling','permute',);$class->parse_cmdline(\%opt);$opt{args}=\@ARGV;for my$flags (@opt{qw(D U A)}){for my$value (@{$flags}){$value =~ s/^=//}}}return bless \%opt,$class}sub parse_cmdline {my ($self,$params,@ext)=@_;my@f=map {$flavor{$_}{opt}|| $_}keys%flavor;return Getopt::Long::GetOptions($params,'force|f!','notest|n!','quiet|q!','verbose|v','as=s','append=s','help|h','version','root=s','switch','all','D=s@','U=s@','A=s@','j=i','sitecustomize=s','noman','both|b=s@','all-variations','common-variations',@f,@ext)}sub root {my ($self,$new_root)=@_;if (defined($new_root)){$self->{root}=$new_root}return$self->{root}|| $PERLBREW_ROOT}sub current_perl {my ($self,$v)=@_;$self->{current_perl}=$v if$v;return$self->{current_perl}|| $self->env('PERLBREW_PERL')|| ''}sub current_lib {my ($self,$v)=@_;$self->{current_lib}=$v if$v;return$self->{current_lib}|| $self->env('PERLBREW_LIB')|| ''}sub current_env {my ($self)=@_;my$l=$self->current_lib;$l="@" .$l if$l;return$self->current_perl .$l}sub installed_perl_executable {my ($self,$name)=@_;die unless$name;my$executable=joinpath($self->root,"perls",$name,"bin","perl");return$executable if -e $executable;return ""}sub configure_args {my ($self,$name)=@_;my$perl_cmd=$self->installed_perl_executable($name);my$code='while(($_,$v)=each(%Config)){print"$_ $v" if /config_arg/}';my@output=split "\n"=>$self->do_capture($perl_cmd,'-MConfig','-wle',$code);my%arg;for(@output){my ($k,$v)=split " ",$_,2;$arg{$k}=$v}if (wantarray){return map {$arg{"config_arg$_"}}(1 .. $arg{config_argc})}return$arg{config_args}}sub cpan_mirror {my ($self,$v)=@_;unless($self->{cpan_mirror}){$self->{cpan_mirror}=$self->env("PERLBREW_CPAN_MIRROR")|| "http://www.cpan.org";$self->{cpan_mirror}=~ s{/+$}{}}return$self->{cpan_mirror}}sub env {my ($self,$name)=@_;return$ENV{$name}if$name;return \%ENV}sub path_with_tilde {my ($self,$dir)=@_;my$home=$self->env('HOME');$dir =~ s/^\Q$home\E/~/ if$home;return$dir}sub is_shell_csh {my ($self)=@_;return 1 if$self->env('SHELL')=~ /(t?csh)/;return 0}sub run {my($self)=@_;$self->run_command($self->args)}sub args {my ($self)=@_;return @{$self->{args}}}sub commands {my ($self)=@_;my$package=ref$self ? ref$self : $self;my@commands;my$symtable=do {no strict 'refs';\%{$package .'::'}};for my$sym (keys %$symtable){if($sym =~ /^run_command_/){my$glob=$symtable->{$sym};if(defined *$glob{CODE}){$sym =~ s/^run_command_//;$sym =~ s/_/-/g;push@commands,$sym}}}return@commands}sub find_similar_commands {my ($self,$command)=@_;my$SIMILAR_DISTANCE=6;my@commands=sort {$a->[1]<=> $b->[1]}grep {defined}map {my$d=editdist($_,$command);($d < $SIMILAR_DISTANCE)? [$_,$d ]: undef}$self->commands;if(@commands){my$best=$commands[0][1];@commands=map {$_->[0]}grep {$_->[1]==$best}@commands}return@commands}sub run_command {my ($self,$x,@args)=@_;my$command=$x;if($self->{version}){$x='version'}elsif(!$x){$x='help';@args=(0,$self->{help}? 2 : 0)}elsif($x eq 'help'){@args=(0,2)unless@args}my$s=$self->can("run_command_$x");unless ($s){$x =~ y/-/_/;$s=$self->can("run_command_$x")}unless($s){my@commands=$self->find_similar_commands($x);if(@commands > 1){@commands=map {' ' .$_}@commands;die "Unknown command: `$command`. Did you mean one of the following?\n" .join("\n",@commands)."\n"}elsif(@commands==1){die "Unknown command: `$command`. Did you mean `$commands[0]`?\n"}else {die "Unknown command: `$command`. Typo?\n"}}$self->$s(@args)}sub run_command_version {my ($self)=@_;my$package=ref$self;my$version=$self->VERSION;print "$0 - $package/$version\n"}sub run_command_help {my ($self,$status,$verbose)=@_;require Pod::Usage;if ($status &&!defined($verbose)){if ($self->can("run_command_help_${status}")){$self->can("run_command_help_${status}")->($self)}else {my$out="";open my$fh,">",\$out;Pod::Usage::pod2usage(-exitval=>"NOEXIT",-verbose=>99,-sections=>"COMMAND: " .uc($status),-output=>$fh,-noperldoc=>1);$out =~ s/\A[^\n]+\n//s;$out =~ s/^ //gm;if ($out =~ /\A\s*\Z/){$out="Cannot find documentation for '$status'\n\n"}print "\n$out";close$fh}}else {Pod::Usage::pod2usage(-noperldoc=>1,-verbose=>$verbose||0,-exitval=>(defined$status ? $status : 1))}}my%comp_installed=(use=>1,switch=>1,);sub run_command_compgen {my($self,$cur,@args)=@_;$cur=0 unless defined($cur);if($self->env('PERLBREW_DEBUG_COMPLETION')){open my$log,'>>','bashcomp.log';print$log "[$$] $cur of [@args]\n"}my$subcommand=$args[1];my$subcommand_completed=($cur >= 2);if(!$subcommand_completed){$self->_compgen($subcommand,$self->commands)}else {if($comp_installed{$subcommand}){if($cur <= 2){my$part;if(defined($part=$args[2])){$part=qr/ \Q$part\E /xms}$self->_compgen($part,map{$_->{name}}$self->installed_perls())}}elsif($subcommand eq 'help'){if($cur <= 2){$self->_compgen($args[2],$self->commands())}}else {}}}sub _compgen {my($self,$part,@reply)=@_;if(defined$part){$part=qr/\A \Q$part\E /xms if ref($part)ne ref(qr//);@reply=grep {/$part/}@reply}for my$word(@reply){print$word,"\n"}}sub run_command_available {my ($self,$dist,$opts)=@_;my@available=$self->available_perls(@_);my@installed=$self->installed_perls(@_);my$is_installed;for my$available (@available){$is_installed=0;for my$installed (@installed){my$name=$installed->{name};my$cur=$installed->{is_current};if ($available eq $installed->{name}){$is_installed=1;last}}print$is_installed ? 'i ' : ' ',$available,"\n"}}sub available_perls {my ($self,$dist,$opts)=@_;my$url=$self->{all}? "http://www.cpan.org/src/5.0/" : "http://www.cpan.org/src/README.html" ;my$html=http_get($url,undef,undef);unless($html){die "\nERROR: Unable to retrieve the list of perls.\n\n"}my@available_versions;for (split "\n",$html){if ($self->{all}){push@available_versions,$1 if m|(.+?)|}else {push@available_versions,$1 if m|(.+?)|}}s/\.tar\.gz// for@available_versions;return@available_versions}sub perl_release {my ($self,$version)=@_;my$index=http_get("http://www.cpan.org/src/5.0/");if ($index){for my$prefix ("perl-","perl"){for my$suffix (".tar.bz2",".tar.gz"){my$dist_tarball="$prefix$version$suffix";my$dist_tarball_url=$self->cpan_mirror()."/src/5.0/$dist_tarball";return ($dist_tarball,$dist_tarball_url)if ($index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms)}}}require CPAN::Perl::Releases;my$tarballs=CPAN::Perl::Releases::perl_tarballs($version);my$x=(values %$tarballs)[0];if ($x){my$dist_tarball=(split("/",$x))[-1];my$dist_tarball_url=$self->cpan_mirror()."/authors/id/$x";return ($dist_tarball,$dist_tarball_url)}my$mirror=$self->config->{mirror};my$header=$mirror ? {'Cookie'=>"cpan=$mirror->{url}"}: undef;my$html=http_get("http://search.cpan.org/dist/perl-${version}",$header);unless ($html){die "ERROR: Failed to locate perl-${version} tarball."}my ($dist_path,$dist_tarball)=$html =~ m[Download];die "ERROR: Cannot find the tarball for perl-$version\n" if!$dist_path and!$dist_tarball;my$dist_tarball_url="http://search.cpan.org${dist_path}";return ($dist_tarball,$dist_tarball_url)}sub run_command_init {my$self=shift;my@args=@_;if (@args && $args[0]eq '-'){if ($self->is_shell_csh){}else {$self->run_command_init_in_bash}exit 0}mkpath($_)for (grep {!-d $_}map {joinpath($self->root,$_)}qw(perls dists build etc bin));my ($f,$fh)=@_;my$etc_dir=joinpath($self->root,"etc");for (["bashrc","BASHRC_CONTENT"],["cshrc","CSHRC_CONTENT"],["csh_reinit","CSH_REINIT_CONTENT"],["csh_wrapper","CSH_WRAPPER_CONTENT"],["csh_set_path","CSH_SET_PATH_CONTENT"],["perlbrew-completion.bash","BASH_COMPLETION_CONTENT"],["perlbrew.fish","PERLBREW_FISH_CONTENT" ],){my ($file_name,$method)=@$_;my$path=joinpath($etc_dir,$file_name);if (!-f $path){open($fh,">",$path)or die "Fail to create $path. Please check the permission of $etc_dir and try `perlbrew init` again.";print$fh $self->$method;close$fh}else {if (-w $path && open($fh,">",$path)){print$fh $self->$method;close$fh}else {print "NOTICE: $path already exists and not updated.\n" unless$self->{quiet}}}}my ($shrc,$yourshrc);if ($self->is_shell_csh){$shrc='cshrc';$self->env("SHELL")=~ m/(t?csh)/;$yourshrc=$1 ."rc"}elsif ($self->env("SHELL")=~ m/zsh\d?$/){$shrc="bashrc";$yourshrc='zshenv'}elsif($self->env('SHELL')=~ m/fish/){$shrc="perlbrew.fish";$yourshrc='config/fish/config.fish'}else {$shrc="bashrc";$yourshrc="bash_profile"}my$root_dir=$self->path_with_tilde($self->root);my$pb_home_dir=$self->path_with_tilde($PERLBREW_HOME);my$code=qq( source $root_dir/etc/${shrc});if ($PERLBREW_HOME ne joinpath($ENV{HOME},".perlbrew")){$code=" export PERLBREW_HOME=$pb_home_dir\n" .$code}if ($self->env('SHELL')=~ m/fish/){$code =~ s/source/./;$code =~ s/export (\S+)=(\S+)/set -x $1 $2/}print <root,"bin","perlbrew");if (files_are_the_same($executable,$target)){print "You are already running the installed perlbrew:\n\n $executable\n";exit}mkpath(joinpath($self->root,"bin"));open my$fh,"<",$executable;my@lines=<$fh>;close$fh;$lines[0]=$self->system_perl_shebang ."\n";open$fh,">",$target;print$fh $_ for@lines;close$fh;chmod(0755,$target);my$path=$self->path_with_tilde($target);print "perlbrew is installed: $path\n" unless$self->{quiet};$self->run_command_init();return}sub do_install_git {my$self=shift;my$dist=shift;my$dist_name;my$dist_git_describe;my$dist_version;opendir my$cwd_orig,".";chdir$dist;if (`git describe` =~ /v((5\.\d+\.\d+(?:-RC\d)?)(-\d+-\w+)?)$/){$dist_name='perl';$dist_git_describe="v$1";$dist_version=$2}chdir$cwd_orig;require File::Spec;my$dist_extracted_dir=File::Spec->rel2abs($dist);$self->do_install_this($dist_extracted_dir,$dist_version,"$dist_name-$dist_version");return}sub do_install_url {my$self=shift;my$dist=shift;my$dist_name='perl';my ($dist_version)=$dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./;my ($dist_tarball)=$dist =~ m{/([^/]*)$};my$dist_tarball_path=joinpath($self->root,"dists",$dist_tarball);my$dist_tarball_url=$dist;$dist="$dist_name-$dist_version";if ($dist_tarball_url =~ m/^file/){print "Installing $dist from local archive $dist_tarball_url\n";$dist_tarball_url =~ s/^file:\/+/\//;$dist_tarball_path=$dist_tarball_url}else {print "Fetching $dist as $dist_tarball_path\n";my$error=http_download($dist_tarball_url,$dist_tarball_path);die "ERROR: Failed to download $dist_tarball_url\n" if$error}my$dist_extracted_path=$self->do_extract_tarball($dist_tarball_path);$self->do_install_this($dist_extracted_path,$dist_version,$dist);return}sub do_extract_tarball {my$self=shift;my$dist_tarball=shift;my$dist_tarball_basename=$dist_tarball;$dist_tarball_basename =~ s{.*/([^/]+)\.tar\.(?:gz|bz2)$}{$1};my$extracted_dir="@{[ $self->root ]}/build/$dist_tarball_basename";my$tarx=($^O eq 'solaris' ? 'gtar ' : 'tar ').($dist_tarball =~ m/bz2$/ ? 'xjf' : 'xzf');if (-d $extracted_dir){rmpath($extracted_dir)}my$extract_command="cd @{[ $self->root ]}/build; $tarx $dist_tarball";die "Failed to extract $dist_tarball" if system($extract_command);return$extracted_dir}sub do_install_blead {my$self=shift;my$dist=shift;my$dist_name='perl';my$dist_git_describe='blead';my$dist_version='blead';my$dist_tarball='blead.tar.gz';my$dist_tarball_path=joinpath($self->root,"dists",$dist_tarball);print "Fetching $dist_git_describe as $dist_tarball_path\n";my$error=http_download("http://perl5.git.perl.org/perl.git/snapshot/$dist_tarball",$dist_tarball_path);if ($error){die "\nERROR: Failed to download perl-blead tarball.\n\n"}$self->do_extract_tarball($dist_tarball_path);my$build_dir=joinpath($self->root,"build");local*DIRH;opendir DIRH,$build_dir or die "Couldn't open ${build_dir}: $!";my@contents=readdir DIRH;closedir DIRH or warn "Couldn't close ${build_dir}: $!";my@candidates=grep {m/^perl-[0-9a-f]{7,8}$/}@contents;@candidates=map {$_->[0]}sort {$b->[1]<=> $a->[1]}map {[$_,(stat(joinpath($build_dir,$_)))[9]]}@candidates;my$dist_extracted_dir=joinpath($self->root,"build",$candidates[0]);$self->do_install_this($dist_extracted_dir,$dist_version,"$dist_name-$dist_version");return}sub resolve_stable_version {my ($self)=@_;my ($latest_ver,$latest_minor);for my$cand ($self->available_perls){my ($ver,$minor)=$cand =~ m/^perl-(5\.(6|8|[0-9]+[02468])\.[0-9]+)$/ or next;($latest_ver,$latest_minor)=($ver,$minor)if!defined$latest_minor || $latest_minor < $minor}die "Can't determine latest stable Perl release\n" if!defined$latest_ver;return$latest_ver}sub do_install_release {my ($self,$dist,$dist_version)=@_;my ($dist_tarball,$dist_tarball_url)=$self->perl_release($dist_version);my$dist_tarball_path=joinpath($self->root,"dists",$dist_tarball);if (-f $dist_tarball_path){print "Using the previously fetched ${dist_tarball}\n" if$self->{verbose}}else {print "Fetching perl $dist_version as $dist_tarball_path\n" unless$self->{quiet};$self->run_command_download($dist)}my$dist_extracted_path=$self->do_extract_tarball($dist_tarball_path);$self->do_install_this($dist_extracted_path,$dist_version,$dist);return}sub run_command_install {my ($self,$dist,$opts)=@_;unless($dist){$self->run_command_help("install");exit(-1)}$self->{dist_name}=$dist;if ($dist =~ /^(?:perl-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/){my$version=($1 eq 'stable' ? $self->resolve_stable_version : $1);$dist="perl-$version";my$installation_name=($self->{as}|| $dist).$self->{variation}.$self->{append};if (not $self->{force}and $self->is_installed($installation_name)){die "\nABORT: $installation_name is already installed.\n\n"}if ($version eq 'blead'){$self->do_install_blead($dist)}else {$self->do_install_release($dist,$version)}}elsif (-d "$dist/.git"){$self->do_install_git($dist)}elsif (-f $dist){$self->do_install_archive($dist)}elsif ($dist =~ m/^(?:https?|ftp|file)/){$self->do_install_url($dist)}else {die "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` " ."for the instruction on using the install command.\n\n"}if ($self->{switch}){if (defined(my$installation_name=$self->{installation_name})){$self->switch_to($installation_name)}else {warn "can't switch, unable to infer final destination name.\n\n"}}return}sub check_and_calculate_variations {my$self=shift;my@both=@{$self->{both}};if ($self->{'all-variations'}){@both=keys%flavor}elsif ($self->{'common-variations'}){push@both,grep$flavor{$_}{common},keys%flavor}for my$both (@both){$flavor{$both}or die "$both is not a supported flavor.\n\n";$self->{$both}and die "options --both $both and --$both can not be used together";if (my$implied_by=$flavor{$both}{implied_by}){$self->{$implied_by}and die "options --both $both and --$implied_by can not be used together"}}my$start='';$start .= "-$_" for grep$self->{$_},keys%flavor;my@var=$start;for my$both (@both){my$append=join('-',$both,grep defined,$flavor{$both}{implies});push@var,map "$_-$append",@var}@var=map {join '-','',sort {$flavor{$a}{ix}<=> $flavor{$b}{ix}}grep length,split /-+/,$_}@var;s/(\b\w+\b)(?:-\1)+/$1/g for@var;if ($Config::Config{longsize}>= 8){s/-64\w+//g for@var}my%var=map {$_=>1}@var;sort keys%var}sub run_command_install_multiple {my ($self,@dists)=@_;unless(@dists){$self->run_command_help("install-multiple");exit(-1)}die "--switch can not be used with command install-multiple.\n\n" if$self->{switch};die "--as can not be used when more than one distribution is given.\n\n" if$self->{as}and @dists > 1;my@variations=$self->check_and_calculate_variations;print join("\n","Compiling the following distributions:",map(" $_$self->{append}",@dists)," with the following variations:",map((/-(.*)/ ? " $1" : " default"),@variations),"","");my@ok;for my$dist (@dists){for my$variation (@variations){local $@;eval {$self->{$_}='' for keys%flavor;$self->{$_}=1 for split /-/,$variation;$self->{variation}=$variation;$self->{installation_name}=undef;$self->run_command_install($dist);push@ok,$self->{installation_name}};if ($@){$@ =~ s/\n+$/\n/;print "Installation of $dist$variation failed: $@"}}}print join("\n","","The following perls have been installed:",map (" $_",grep defined,@ok),"","");return}sub run_command_download {my ($self,$dist)=@_;$dist=$self->resolve_stable_version if$dist && $dist eq 'stable';my ($dist_version)=$dist =~ /^ (?:perl-?)? (.*) $/xs;die "\"$dist\" does not look like a perl distribution name. " unless$dist_version =~ /^\d\./;my ($dist_tarball,$dist_tarball_url)=$self->perl_release($dist_version);my$dist_tarball_path=joinpath($self->root,"dists",$dist_tarball);if (-f $dist_tarball_path &&!$self->{force}){print "$dist_tarball already exists\n"}else {print "Download $dist_tarball_url to $dist_tarball_path\n" unless$self->{quiet};my$error=http_download($dist_tarball_url,$dist_tarball_path);if ($error){die "ERROR: Failed to download $dist_tarball_url\n"}}}sub purify {my ($self,$envname)=@_;my@paths=grep {index($_,$PERLBREW_HOME)< 0 && index($_,$self->root)< 0}split /:/,$self->env($envname);return wantarray ? @paths : join(":",@paths)}sub system_perl_executable {my ($self)=@_;my$system_perl_executable=do {local$ENV{PATH}=$self->pristine_path;`perl -MConfig -e 'print \$Config{perlpath}'`};return$system_perl_executable}sub system_perl_shebang {my ($self)=@_;return$Config{sharpbang}.$self->system_perl_executable}sub pristine_path {my ($self)=@_;return$self->purify("PATH")}sub pristine_manpath {my ($self)=@_;return$self->purify("MANPATH")}sub run_command_display_system_perl_executable {print $_[0]->system_perl_executable ."\n"}sub run_command_display_system_perl_shebang {print $_[0]->system_perl_shebang ."\n"}sub run_command_display_pristine_path {print $_[0]->pristine_path ."\n"}sub run_command_display_pristine_manpath {print $_[0]->pristine_manpath ."\n"}sub do_install_archive {require File::Basename;my$self=shift;my$dist_tarball_path=shift;my$dist_version;my$installation_name;if (File::Basename::basename($dist_tarball_path)=~ m{perl-?(5.+)\.tar\.(gz|bz2)\Z}){$dist_version=$1;$installation_name="perl-${dist_version}"}unless ($dist_version && $installation_name){die "Unable to determine perl version from archive filename.\n\nThe archive name should look like perl-5.x.y.tar.gz or perl-5.x.y.tar.bz2\n"}my$dist_extracted_path=$self->do_extract_tarball($dist_tarball_path);$self->do_install_this($dist_extracted_path,$dist_version,$installation_name);return}sub do_install_this {my ($self,$dist_extracted_dir,$dist_version,$installation_name)=@_;my$variation=$self->{variation};my$append=$self->{append};$self->{dist_extracted_dir}=$dist_extracted_dir;$self->{log_file}=joinpath($self->root,"build.${installation_name}${variation}${append}.log");my@d_options=@{$self->{D}};my@u_options=@{$self->{U}};my@a_options=@{$self->{A}};my$sitecustomize=$self->{sitecustomize};$installation_name=$self->{as}if$self->{as};$installation_name .= "$variation$append";$self->{installation_name}=$installation_name;if ($sitecustomize){die "Could not read sitecustomize file '$sitecustomize'\n" unless -r $sitecustomize;push@d_options,"usesitecustomize"}if ($self->{noman}){push@d_options,qw/man1dir=none man3dir=none/}for my$flavor (keys%flavor){$self->{$flavor}and push@d_options,$flavor{$flavor}{d_option}}my$perlpath=$self->root ."/perls/$installation_name";my$patchperl=$self->root ."/bin/patchperl";unless (-x $patchperl && -f _){$patchperl="patchperl"}unshift@d_options,qq(prefix=$perlpath);push@d_options,"usedevel" if$dist_version =~ /5\.\d[13579]|git|blead/;unless (grep {/eval:scriptdir=/}@a_options){push@a_options,"'eval:scriptdir=${perlpath}/bin'"}my$version=perl_version_to_integer($dist_version);if (defined$version and $version < perl_version_to_integer('5.6.0')){@a_options=()}print "Installing $dist_extracted_dir into " .$self->path_with_tilde("@{[ $self->root ]}/perls/$installation_name")."\n\n";print <{verbose};my@preconfigure_commands=("cd $dist_extracted_dir","rm -f config.sh Policy.sh",$patchperl,);my$configure_flags=$self->env("PERLBREW_CONFIGURE_FLAGS")|| '-de';my@configure_commands=("sh Configure $configure_flags " .join(' ',(map {qq{'-D$_'}}@d_options),(map {qq{'-U$_'}}@u_options),(map {qq{'-A$_'}}@a_options),),(defined$version and $version < perl_version_to_integer('5.8.9'))? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile"): ());my@build_commands=("make " .($self->{j}? "-j$self->{j}" : ""));my$test_target="test";if ($dist_version =~ /^5\.(\d+)\.(\d+)/ && ($1 >= 8 || $1==7 && $2==3)){$test_target="test_harness"}local$ENV{TEST_JOBS}=$self->{j}if$test_target eq "test_harness" && ($self->{j}||1)> 1;my@install_commands=$self->{notest}? "make install" : ("make $test_target","make install");@install_commands=join " && ",@install_commands unless($self->{force});my$cmd=join " && ",(@preconfigure_commands,@configure_commands,@build_commands,@install_commands);unlink($self->{log_file});if($self->{verbose}){$cmd="($cmd) 2>&1 | tee $self->{log_file}";print "$cmd\n" if$self->{verbose}}else {$cmd="($cmd) >> '$self->{log_file}' 2>&1 "}delete$ENV{$_}for qw(PERL5LIB PERL5OPT);if ($self->do_system($cmd)){my$newperl=joinpath($self->root,"perls",$installation_name,"bin","perl");unless (-e $newperl){$self->run_command_symlink_executables($installation_name)}if ($sitecustomize){my$capture=$self->do_capture("$newperl -V:sitelib");my ($sitelib)=$capture =~ /sitelib='(.*)';/;mkpath($sitelib)unless -d $sitelib;my$target="$sitelib/sitecustomize.pl";open my$dst,">",$target or die "Could not open '$target' for writing: $!\n";open my$src,"<",$sitecustomize or die "Could not open '$sitecustomize' for reading: $!\n";print {$dst}do {local $/;<$src>}}print "$installation_name is successfully installed.\n"}else {die$self->INSTALLATION_FAILURE_MESSAGE}return}sub do_install_program_from_url {my ($self,$url,$program_name,$body_filter)=@_;my$out=$self->root ."/bin/" .$program_name;if (-f $out &&!$self->{force}){require ExtUtils::MakeMaker;my$ans=ExtUtils::MakeMaker::prompt("\n$out already exists, are you sure to override ? [y/N]","N");if ($ans !~ /^Y/i){print "\n$program_name installation skipped.\n\n" unless$self->{quiet};return}}my$body=http_get($url)or die "\nERROR: Failed to retrieve $program_name executable.\n\n";unless ($body =~ m{\A#!/}s){my$x=joinpath($ENV{TMPDIR}|| "/tmp","${program_name}.downloaded.$$");my$message="\nERROR: The downloaded $program_name program seem to be invalid. Please check if the following URL can be reached correctly\n\n\t$url\n\n...and try again latter.";unless (-f $x){open my$OUT,">",$x;print$OUT $body;close($OUT);$message .= "\n\nThe previously downloaded file is saved at $x for manual inspection.\n\n"}die$message}if ($body_filter && ref($body_filter)eq "CODE"){$body=$body_filter->($body)}mkpath("@{[ $self->root ]}/bin")unless -d "@{[ $self->root ]}/bin";open my$OUT,'>',$out or die "cannot open file($out): $!";print$OUT $body;close$OUT;chmod 0755,$out;print "\n$program_name is installed to\n\n $out\n\n" unless$self->{quiet}}sub do_exit_with_error_code {my ($self,$code)=@_;exit($code)}sub do_system_with_exit_code {my ($self,@cmd)=@_;return system(@cmd)}sub do_system {my ($self,@cmd)=@_;return!$self->do_system_with_exit_code(@cmd)}sub do_capture {my ($self,@cmd)=@_;require Capture::Tiny;return Capture::Tiny::capture(sub {$self->do_system(@cmd)})}sub format_perl_version {my$self=shift;my$version=shift;return sprintf "%d.%d.%d",substr($version,0,1),substr($version,2,3),substr($version,5)|| 0}sub installed_perls {my$self=shift;my@result;my$root=$self->root;for (<$root/perls/*>){my ($name)=$_ =~ m/\/([^\/]+$)/;my$executable=joinpath($_,'bin','perl');my$version_file=joinpath($_,'.version');my$orig_version;if (-e $version_file){open my$fh,'<',$version_file;local $/;$orig_version=<$fh>;chomp$orig_version}else {$orig_version=`$executable -e 'print \$]'`;if (defined$orig_version and length$orig_version){open my$fh,'>',$version_file;print {$fh}$orig_version}}push@result,{name=>$name,orig_version=>$orig_version,version=>$self->format_perl_version($orig_version),is_current=>($self->current_perl eq $name)&&!$self->env("PERLBREW_LIB"),libs=>[$self->local_libs($name)],executable=>$executable }}return sort {$a->{orig_version}<=> $b->{orig_version}or $a->{name}cmp $b->{name}}@result}sub local_libs {my ($self,$perl_name)=@_;my@libs=map {substr($_,length($PERLBREW_HOME)+ 6)}<$PERLBREW_HOME/libs/*>;if ($perl_name){@libs=grep {/^$perl_name\@/}@libs}my$current=$self->current_perl .'@' .($self->env("PERLBREW_LIB")|| '');@libs=map {my ($p,$l)=split(/@/,$_);+{name=>$_,is_current=>$_ eq $current,perl_name=>$p,lib_name=>$l }}@libs;return@libs}sub is_installed {my ($self,$name)=@_;return grep {$name eq $_->{name}}$self->installed_perls}sub assert_known_installation {my ($self,$name)=@_;return 1 if$self->is_installed($name);die "ERROR: The installation \"$name\" is unknown\n\n"}sub perlbrew_env {my ($self,$name)=@_;my ($perl_name,$lib_name);if ($name){($perl_name,$lib_name)=$self->resolve_installation_name($name);unless ($perl_name){die "\nERROR: The installation \"$name\" is unknown.\n\n"}}my%env=(PERLBREW_VERSION=>$VERSION,PERLBREW_PATH=>joinpath($self->root,"bin"),PERLBREW_MANPATH=>"",PERLBREW_ROOT=>$self->root);if ($perl_name){if(-d "@{[ $self->root ]}/perls/$perl_name/bin"){$env{PERLBREW_PERL}=$perl_name;$env{PERLBREW_PATH}.= ":" .joinpath($self->root,"perls",$perl_name,"bin");$env{PERLBREW_MANPATH}=joinpath($self->root,"perls",$perl_name,"man")}if ($lib_name){require local::lib;if ($ENV{PERL_LOCAL_LIB_ROOT}&& $ENV{PERL_LOCAL_LIB_ROOT}=~ /^\Q$PERLBREW_HOME\E/){my%deactivate_env=local::lib->build_deact_all_environment_vars_for($ENV{PERL_LOCAL_LIB_ROOT});@env{keys%deactivate_env}=values%deactivate_env}my$base="$PERLBREW_HOME/libs/${perl_name}\@${lib_name}";if (-d $base){delete$ENV{PERL_LOCAL_LIB_ROOT};@ENV{keys%env}=values%env;while (my ($k,$v)=each%ENV){delete$ENV{$k}unless defined($v)}my%lib_env=local::lib->build_environment_vars_for($base,0,1);$env{PERLBREW_PATH}=joinpath($base,"bin").":" .$env{PERLBREW_PATH};$env{PERLBREW_MANPATH}=joinpath($base,"man").":" .$env{PERLBREW_MANPATH};$env{PERLBREW_LIB}=$lib_name;$env{PERL_MM_OPT}=$lib_env{PERL_MM_OPT};$env{PERL_MB_OPT}=$lib_env{PERL_MB_OPT};$env{PERL5LIB}=$lib_env{PERL5LIB};$env{PERL_LOCAL_LIB_ROOT}=$lib_env{PERL_LOCAL_LIB_ROOT}}}else {my$libroot=$self->env("PERL_LOCAL_LIB_ROOT");if ($libroot && $libroot =~ /^\Q$PERLBREW_HOME\E/){require local::lib;my%deactivate_env=local::lib->build_deact_all_environment_vars_for($libroot);@env{keys%deactivate_env}=values%deactivate_env;$env{PERLBREW_LIB}=undef}if (my$perl5lib=$self->env("PERL5LIB")){my@perl5libs=split$Config{path_sep}=>$perl5lib;my@pristine_perl5libs=grep {!/^\Q$PERLBREW_HOME\E/}@perl5libs;if (@pristine_perl5libs){$env{PERL5LIB}=join$Config{path_sep},@pristine_perl5libs}else {$env{PERL5LIB}=undef}}}}else {my$libroot=$self->env("PERL_LOCAL_LIB_ROOT");if ($libroot && $libroot =~ /^\Q$PERLBREW_HOME\E/){require local::lib;my%deactivate_env=local::lib->build_deact_all_environment_vars_for($libroot);@env{keys%deactivate_env}=values%deactivate_env;$env{PERLBREW_LIB}=undef}$env{PERLBREW_PERL}=undef}return%env}sub run_command_list {my$self=shift;for my$i ($self->installed_perls){print$i->{is_current}? '* ': ' ',$i->{name},(index($i->{name},$i->{version})< 0)? " ($i->{version})" : "","\n";for my$lib (@{$i->{libs}}){print$lib->{is_current}? "* " : " ",$lib->{name},"\n"}}return 0}sub launch_sub_shell {my ($self,$name)=@_;my$shell=$self->env('SHELL');my$shell_opt="";if ($shell =~ /\/zsh\d?$/){$shell_opt="-d -f";if ($^O eq 'darwin'){my$root_dir=$self->root;print <<"WARNINGONMAC"}}elsif ($shell =~ /\/bash$/){$shell_opt="--noprofile --norc"}my%env=($self->perlbrew_env($name),PERLBREW_SKIP_INIT=>1);unless ($ENV{PERLBREW_VERSION}){my$root=$self->root;$env{PATH}=$env{PERLBREW_PATH}.":" .join ":",grep {!/$root\/bin/}split ":",$ENV{PATH};$env{MANPATH}=$env{PERLBREW_MANPATH}.":" .join ":",grep {!/$root\/man/}(defined($ENV{MANPATH})? split(":",$ENV{MANPATH}): ())}my$command="env ";while (my ($k,$v)=each(%env)){no warnings "uninitialized";$command .= "$k=\"$v\" "}$command .= " $shell $shell_opt";my$pretty_name=defined($name)? $name : "the default perl";print "\nA sub-shell is launched with $pretty_name as the activated perl. Run 'exit' to finish it.\n\n";exec($command)}sub run_command_use {my$self=shift;my$perl=shift;if (!$perl){my$current=$self->current_perl;if ($current){print "Currently using $current\n"}else {print "No version in use; defaulting to system\n"}return}$self->launch_sub_shell($perl)}sub run_command_switch {my ($self,$dist,$alias)=@_;unless ($dist){my$current=$self->current_perl;printf "Currently switched %s\n",($current ? "to $current" : 'off');return}$self->switch_to($dist,$alias)}sub switch_to {my ($self,$dist,$alias)=@_;die "Cannot use for alias something that starts with 'perl-'\n" if$alias && $alias =~ /^perl-/;die "${dist} is not installed\n" unless -d joinpath($self->root,"perls",$dist);if ($self->env("PERLBREW_BASHRC_VERSION")){local$ENV{PERLBREW_PERL}=$dist;my$HOME=$self->env('HOME');my$pb_home=$self->env("PERLBREW_HOME")|| $PERLBREW_HOME;mkpath($pb_home);system("$0 env $dist > " .joinpath($pb_home,"init"));print "Switched to $dist.\n\n"}else {$self->launch_sub_shell($dist)}}sub run_command_off {my$self=shift;$self->launch_sub_shell}sub run_command_switch_off {my$self=shift;my$pb_home=$self->env("PERLBREW_HOME")|| $PERLBREW_HOME;mkpath($pb_home);system("env PERLBREW_PERL= $0 env > " .joinpath($pb_home,"init"));print "\nperlbrew is switched off. Please exit this shell and start a new one to make it effective.\n";print "To immediately make it effective, run this line in this terminal:\n\n exec @{[ $self->env('SHELL') ]}\n\n"}sub run_command_mirror {my($self)=@_;print "Fetching mirror list\n";my$raw=http_get("http://search.cpan.org/mirror");unless ($raw){die "\nERROR: Failed to retrieve the mirror list.\n\n"}my$found;my@mirrors;for my$line (split m{\n},$raw){$found=1 if$line =~ m{};if ($line =~ m{}){my$url=$1;my$name=$2;$name =~ s/&#(\d+);/chr $1/seg;$url =~ s/&#(\d+);/chr $1/seg;push@mirrors,{url=>$url,name=>$name }}}require ExtUtils::MakeMaker;my$select;my$max=@mirrors;my$id=0;while (@mirrors){my@page=splice(@mirrors,0,20);my$base=$id;printf "[% 3d] %s\n",++$id,$_->{name}for@page;my$remaining=$max - $id;my$ask="Select a mirror by number or press enter to see the rest " ."($remaining more) [q to quit, m for manual entry]";my$val=ExtUtils::MakeMaker::prompt($ask);if (!length$val){next}elsif ($val eq 'q'){last}elsif ($val eq 'm'){my$url=ExtUtils::MakeMaker::prompt("Enter the URL of your CPAN mirror:");my$name=ExtUtils::MakeMaker::prompt("Enter a Name: [default: My CPAN Mirror]")|| "My CPAN Mirror";$select={name=>$name,url=>$url };last}elsif (not $val =~ /\s*(\d+)\s*/){die "Invalid answer: must be 'q', 'm' or a number\n"}elsif (1 <= $val and $val <= $max){$select=$page[$val - 1 - $base ];last}else {die "Invalid ID: must be between 1 and $max\n"}}die "You didn't select a mirror!\n" if!$select;print "Selected $select->{name} ($select->{url}) as the mirror\n";my$conf=$self->config;$conf->{mirror}=$select;$self->_save_config;return}sub run_command_env {my($self,$name)=@_;my%env=$self->perlbrew_env($name);if ($self->env('SHELL')=~ /(ba|k|z|\/)sh\d?$/){for my$k (sort keys%env){my$v=$env{$k};if (defined$v){$v =~ s/(\\")/\\$1/g;print "export $k=\"$v\"\n"}else {print "unset $k\n"}}}else {for my$k (sort keys%env){my$v=$env{$k};if (defined$v){$v =~ s/(\\")/\\$1/g;print "setenv $k \"$v\"\n"}else {print "unsetenv $k\n"}}}}sub run_command_symlink_executables {my($self,@perls)=@_;my$root=$self->root;unless (@perls){@perls=map {m{/([^/]+)$}}grep {-d $_ &&!-l $_}<$root/perls/*>}for my$perl (@perls){for my$executable (<$root/perls/$perl/bin/*>){my ($name,$version)=$executable =~ m/bin\/(.+?)(5\.\d.*)?$/;system("ln -fs $executable $root/perls/$perl/bin/$name")if$version}}}sub run_command_install_patchperl {my ($self)=@_;$self->do_install_program_from_url('https://raw.githubusercontent.com/gugod/patchperl-packing/master/patchperl','patchperl',sub {my ($body)=@_;$body =~ s/\A#!.+?\n/ $self->system_perl_shebang . "\n" /se;return$body})}sub run_command_install_cpanm {my ($self)=@_;$self->do_install_program_from_url('https://raw.githubusercontent.com/miyagawa/cpanminus/master/cpanm'=>'cpanm')}sub run_command_self_upgrade {my ($self)=@_;my$TMPDIR=$ENV{TMPDIR}|| "/tmp";my$TMP_PERLBREW=joinpath($TMPDIR,"perlbrew");require FindBin;unless(-w $FindBin::Bin){die "Your perlbrew installation appears to be system-wide. Please upgrade through your package manager.\n"}http_get('http://get.perlbrew.pl',undef,sub {my ($body)=@_;open my$fh,'>',$TMP_PERLBREW or die "Unable to write perlbrew: $!";print$fh $body;close$fh});chmod 0755,$TMP_PERLBREW;my$new_version=qx($TMP_PERLBREW version);chomp$new_version;if($new_version =~ /App::perlbrew\/(\d+\.\d+)$/){$new_version=$1}else {die "Unable to detect version of new perlbrew!\n"}if($new_version <= $VERSION){print "Your perlbrew is up-to-date.\n";return}system$TMP_PERLBREW,"self-install";unlink$TMP_PERLBREW}sub run_command_uninstall {my ($self,$target)=@_;unless($target){$self->run_command_help("uninstall");exit(-1)}my$dir="@{[ $self->root ]}/perls/$target";if (-l $dir){die "\nThe given name `$target` is an alias, not a real installation. Cannot perform uninstall.\nTo delete the alias, run:\n\n perlbrew alias delete $target\n\n"}unless(-d $dir){die "'$target' is not installed\n"}exec 'rm','-rf',$dir}sub run_command_exec {my$self=shift;my%opts;local (@ARGV)=@{$self->{original_argv}};Getopt::Long::Configure ('require_order');my@command_options=('with=s','halt-on-error');$self->parse_cmdline (\%opts,@command_options);shift@ARGV;$self->parse_cmdline (\%opts,@command_options);my@exec_with;if ($opts{with}){my%installed=map {$_->{name}=>$_}map {($_,@{$_->{libs}})}$self->installed_perls;my$d=($opts{with}=~ / /)? qr( +) : qr(,+);my@with=grep {$_}map {my ($p,$l)=$self->resolve_installation_name($_);$p .= "\@$l" if$l;$p}split$d,$opts{with};@exec_with=map {$installed{$_}}@with}else {@exec_with=map {($_,@{$_->{libs}})}$self->installed_perls}if (0==@exec_with){print "No perl installation found.\n" unless$self->{quiet}}my$overall_success=1;for my$i (@exec_with){next if -l $self->root .'/perls/' .$i->{name};my%env=$self->perlbrew_env($i->{name});next if!$env{PERLBREW_PERL};local@ENV{keys%env }=values%env;local$ENV{PATH}=join(':',$env{PERLBREW_PATH},$ENV{PATH});local$ENV{MANPATH}=join(':',$env{PERLBREW_MANPATH},$ENV{MANPATH}||"");local$ENV{PERL5LIB}=$env{PERL5LIB}|| "";print "$i->{name}\n==========\n" unless$self->{quiet};if (my$err=$self->do_system_with_exit_code(@ARGV)){my$exit_code=$err >> 8;$exit_code=255 if$exit_code > 255;$overall_success=0;print "Command terminated with non-zero status.\n" unless$self->{quiet};print STDERR "Command [" .join(' ',map {/\s/ ? "'$_'" : $_}@ARGV)."] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n";print STDERR$self->format_info_output;$self->do_exit_with_error_code($exit_code)if ($opts{'halt-on-error'})}print "\n\n" unless$self->{quiet}}$self->do_exit_with_error_code(1)unless$overall_success}sub run_command_clean {my ($self)=@_;my$root=$self->root;my@build_dirs=<$root/build/*>;for my$dir (@build_dirs){print "Removing $dir\n";rmpath($dir)}my@tarballs=<$root/dists/*>;for my$file (@tarballs){print "Removing $file\n";unlink($file)}print "\nDone\n"}sub run_command_alias {my ($self,$cmd,$name,$alias)=@_;if (!$cmd){print <root,"perls",$name);my$path_alias=joinpath($self->root,"perls",$alias)if$alias;if ($alias && -e $path_alias &&!-l $path_alias){die "\nABORT: The installation name `$alias` is not an alias, cannot override.\n\n"}if ($cmd eq 'create'){$self->assert_known_installation($name);if ($self->is_installed($alias)&&!$self->{force}){die "\nABORT: The installation `${alias}` already exists. Cannot override.\n\n"}unlink($path_alias)if -e $path_alias;symlink($path_name,$path_alias)}elsif($cmd eq 'delete'){$self->assert_known_installation($name);unless (-l $path_name){die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n"}unlink($path_name)}elsif($cmd eq 'rename'){$self->assert_known_installation($name);unless (-l $path_name){die "\nABORT: The installation name `$name` is not an alias, cannot rename.\n\n"}if (-l $path_alias &&!$self->{force}){die "\nABORT: The alias `$alias` already exists, cannot rename to it.\n\n"}rename($path_name,$path_alias)}elsif($cmd eq 'help'){$self->run_command_help("alias")}else {die "\nERROR: Unrecognized action: `${cmd}`.\n\n"}}sub run_command_display_bashrc {print BASHRC_CONTENT()}sub run_command_display_cshrc {print CSHRC_CONTENT()}sub run_command_display_installation_failure_message {my ($self)=@_}sub lib_usage {my$usage=<<'USAGE';return$usage}sub run_command_lib {my ($self,$subcommand,@args)=@_;unless ($subcommand){print lib_usage;return}my$sub="run_command_lib_$subcommand";if ($self->can($sub)){$self->$sub(@args)}else {print "Unknown command: $subcommand\n"}}sub run_command_lib_create {my ($self,$name)=@_;die "ERROR: No lib name\n",lib_usage unless$name;$name =~ s/^/@/ unless$name =~ /@/;my ($perl_name,$lib_name)=$self->resolve_installation_name($name);if (!$perl_name){my ($perl_name,$lib_name)=split('@',$name);die "ERROR: '$perl_name' is not installed yet, '$name' cannot be created.\n"}my$fullname=$perl_name .'@' .$lib_name;my$dir=joinpath($PERLBREW_HOME,"libs",$fullname);if (-d $dir){die "$fullname is already there.\n"}mkpath($dir);print "lib '$fullname' is created.\n" unless$self->{quiet};return}sub run_command_lib_delete {my ($self,$name)=@_;die "ERROR: No lib to delete\n",lib_usage unless$name;$name =~ s/^/@/ unless$name =~ /@/;my ($perl_name,$lib_name)=$self->resolve_installation_name($name);my$fullname=$perl_name .'@' .$lib_name;my$current=$self->current_perl .'@' .($self->env("PERLBREW_LIB")|| "");my$dir=joinpath($PERLBREW_HOME,"libs",$fullname);if (-d $dir){if ($fullname eq $current){die "$fullname is currently being used in the current shell, it cannot be deleted.\n"}rmpath($dir);print "lib '$fullname' is deleted.\n" unless$self->{quiet}}else {die "ERROR: '$fullname' does not exist.\n"}return}sub run_command_lib_list {my ($self)=@_;my$current="";if ($self->current_perl && $self->env("PERLBREW_LIB")){$current=$self->current_perl ."@" .$self->env("PERLBREW_LIB")}my$dir=joinpath($PERLBREW_HOME,"libs");return unless -d $dir;opendir my$dh,$dir or die "open $dir failed: $!";my@libs=grep {!/^\./ && /\@/}readdir($dh);for (@libs){print$current eq $_ ? "* " : " ";print "$_\n"}}sub run_command_upgrade_perl {my ($self)=@_;my$PERL_VERSION_RE=qr/(\d+)\.(\d+)\.(\d+)/;my ($current)=grep {$_->{is_current}}$self->installed_perls;unless(defined$current){print "no perlbrew environment is currently in use\n";exit(1)}my ($major,$minor,$release);if($current->{version}=~ /^$PERL_VERSION_RE$/){($major,$minor,$release)=($1,$2,$3)}else {print "unable to parse version '$current->{version}'\n";exit(1)}my@available=grep {/^perl-$major\.$minor/}$self->available_perls;my$latest_available_perl=$release;for my$perl (@available){if($perl =~ /^perl-$PERL_VERSION_RE$/){my$this_release=$3;if($this_release > $latest_available_perl){$latest_available_perl=$this_release}}}if($latest_available_perl==$release){print "This perlbrew environment ($current->{name}) is already up-to-date.\n";exit(0)}my$dist_version="$major.$minor.$latest_available_perl";my$dist="perl-$dist_version";print "Upgrading $current->{name} to $dist_version\n" unless$self->{quiet};local$self->{as}=$current->{name};local$self->{dist_name}=$dist;$self->do_install_release($dist,$dist_version)}sub run_command_list_modules {my ($self)=@_;my$class=ref($self)|| __PACKAGE__;my$app=$class->new(qw(--quiet exec --with),$self->current_env,'perl','-MExtUtils::Installed','-le','BEGIN{@INC=grep {$_ ne q!.!} @INC}; print for ExtUtils::Installed->new->modules;');$app->run}sub resolve_installation_name {my ($self,$name)=@_;die "App::perlbrew->resolve_installation_name requires one argument." unless$name;my ($perl_name,$lib_name)=split('@',$name);$perl_name=$name unless$lib_name;$perl_name ||=$self->current_perl;if (!$self->is_installed($perl_name)){if ($self->is_installed("perl-${perl_name}")){$perl_name="perl-${perl_name}"}else {return undef}}return wantarray ? ($perl_name,$lib_name): $perl_name}sub format_info_output {my ($self,$module)=@_;my$out='';$out .= "Current perl:\n";if ($self->current_perl){$out .= " Name: " .$self->current_env ."\n";$out .= " Path: " .$self->installed_perl_executable($self->current_perl)."\n";$out .= " Config: " .$self->configure_args($self->current_perl)."\n";$out .= join(''," Compiled at: ",(map {/ Compiled at (.+)\n/ ? $1 : ()}`@{[ $self->installed_perl_executable($self->current_perl) ]} -V`),"\n")}else {$out .= "Using system perl." ."\n";$out .= "Shebang: " .$self->system_perl_shebang ."\n"}$out .= "\nperlbrew:\n";$out .= " version: " .$self->VERSION ."\n";$out .= " ENV:\n";for(map{"PERLBREW_$_"}qw(ROOT HOME PATH MANPATH)){$out .= " $_: " .($self->env($_)||"")."\n"}if ($module){my$code=qq{eval "require $module" and do { (my \$f = "$module") =~ s<::>g; \$f .= ".pm"; print "$module\n Location: \$INC{\$f}\n Version: " . ($module->VERSION ? $module->VERSION : "no VERSION specified" ) } or do { print "$module could not be found, is it installed?" } };$out .= "\nModule: ".$self->do_capture($self->installed_perl_executable($self->current_perl),"-le",$code)}$out}sub run_command_info {my ($self)=shift;print$self->format_info_output(@_)}sub config {my($self)=@_;$self->_load_config if!$CONFIG;return$CONFIG}sub config_file {my ($self)=@_;joinpath($self->root,'Config.pm')}sub _save_config {my($self)=@_;require Data::Dumper;open my$FH,'>',$self->config_file or die "Unable to open config (@{[ $self->config_file ]}): $!";my$d=Data::Dumper->new([$CONFIG],['App::perlbrew::CONFIG']);print$FH $d->Dump;close$FH}sub _load_config {my($self)=@_;if (!-e $self->config_file){local$CONFIG={}if!$CONFIG;$self->_save_config}open my$FH,'<',$self->config_file or die "Unable to open config (@{[ $self->config_file ]}): $!\n";my$raw=do {local $/;my$rv=<$FH>;$rv};close$FH;my$rv=eval$raw;if ($@){warn "Error loading conf: $@\n";$CONFIG={};return}$CONFIG={}if!$CONFIG;return}sub BASHRC_CONTENT() {return "export PERLBREW_BASHRC_VERSION=$VERSION\n\n" .sprintf <<'RC',$PERLBREW_ROOT}sub BASH_COMPLETION_CONTENT() {return <<'COMPLETION'}sub PERLBREW_FISH_CONTENT {return "set -x PERLBREW_FISH_VERSION $VERSION\n" .<<'END'}sub CSH_WRAPPER_CONTENT {return <<'WRAPPER'}sub CSH_REINIT_CONTENT {return <<'REINIT'}sub CSH_SET_PATH_CONTENT {return <<'SETPATH'}sub CSHRC_CONTENT {return "setenv PERLBREW_CSHRC_VERSION $VERSION\n\n" .<<'CSHRC'}sub INSTALLATION_FAILURE_MESSAGE {my ($self)=@_;return <}, + ); - $code + require Cwd; + @INC = @oldinc; + } - Simply run `perlbrew` for usage details. + use List::Util qw/min/; + use Getopt::Long (); - Happy brewing! + ### global variables - INSTRUCTION - This could take a while. You can run the following command on another shell to track the status: + local $SIG{__DIE__} = sub { + my $message = shift; + warn $message; + exit(1); + }; - tail -f @{[ $self->path_with_tilde($self->{log_file}) ]} + our $CONFIG; + our $PERLBREW_ROOT = $ENV{PERLBREW_ROOT} || joinpath($ENV{HOME}, "perl5", "perlbrew"); + our $PERLBREW_HOME = $ENV{PERLBREW_HOME} || joinpath($ENV{HOME}, ".perlbrew"); - INSTALL - -------------------------------------------------------------------------------- - WARNING: zsh perlbrew sub-shell is not working on Mac OSX Lion. + my @flavors = ( { d_option => 'usethreads', + implies => 'multi', + common => 1, + opt => 'thread|threads' }, # threads is for backward compatibility - It is known that on MacOS Lion, zsh always resets the value of PATH on launching - a sub-shell. Effectively nullify the changes required by perlbrew sub-shell. You - may `echo \$PATH` to examine it and if you see perlbrew related paths are in the - end, instead of in the beginning, you are unfortunate. + { d_option => 'usemultiplicity', + opt => 'multi' }, - You are advised to include the following line to your ~/.zshenv as a better - way to work with perlbrew: + { d_option => 'uselongdouble', + common => 1, + opt => 'ld' }, - source $root_dir/etc/bashrc + { d_option => 'use64bitint', + common => 1, + opt => '64int' }, - -------------------------------------------------------------------------------- - WARNINGONMAC + { d_option => 'use64bitall', + implies => '64int', + opt => '64all' }, - Usage: perlbrew alias [-f] [] + { d_option => 'DEBUGGING', + opt => 'debug' }, - perlbrew alias create - perlbrew alias delete - perlbrew alias rename + { d_option => 'cc=clang', + opt => 'clang' }, + ); - USAGE - Usage: perlbrew lib [ ...] + my %flavor; + my $flavor_ix = 0; + for (@flavors) { + my ($name) = $_->{opt} =~ /([^|]+)/; + $_->{name} = $name; + $_->{ix} = ++$flavor_ix; + $flavor{$name} = $_; + } + for (@flavors) { + if (my $implies = $_->{implies}) { + $flavor{$implies}{implied_by} = $_->{name}; + } + } - perlbrew lib list - perlbrew lib create nobita - perlbrew lib create perl-5.14.2@nobita + ### functions - perlbrew use perl-5.14.2@nobita - perlbrew lib delete perl-5.12.3@nobita shizuka + sub joinpath { join "/", @_ } - USAGE + sub mkpath { + require File::Path; + File::Path::mkpath([@_], 0, 0777); + } - __perlbrew_reinit() { - if [[ ! -d "$PERLBREW_HOME" ]]; then - mkdir -p "$PERLBREW_HOME" - fi + sub rmpath { + require File::Path; + File::Path::rmtree([@_], 0, 0); + } - echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init" - command perlbrew env $1 | \grep PERLBREW_ >> "$PERLBREW_HOME/init" - . "$PERLBREW_HOME/init" - __perlbrew_set_path + sub files_are_the_same { + ## Check dev and inode num. Not useful on Win32. + ## The for loop should always return false on Win32, as a result. + + my @files = @_; + my @stats = map {[ stat($_) ]} @files; + + my $stats0 = join " ", @{$stats[0]}[0,1]; + for (@stats) { + return 0 if ((! defined($_->[1])) || $_->[1] == 0); + unless ($stats0 eq join(" ", $_->[0], $_->[1])) { + return 0; + } + } + return 1 } - __perlbrew_set_path () { - MANPATH_WITHOUT_PERLBREW=`perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);'` - if [ -n "$PERLBREW_MANPATH" ]; then - export MANPATH="$PERLBREW_MANPATH:$MANPATH_WITHOUT_PERLBREW" - else - export MANPATH="$MANPATH_WITHOUT_PERLBREW" - fi - unset MANPATH_WITHOUT_PERLBREW + { + my %commands = ( + curl => { + test => '--version >/dev/null 2>&1', + get => '--insecure --silent --location --fail -o - {url}', + download => '--insecure --silent --location --fail -o {output} {url}', + order => 1, + }, + wget => { + test => '--version >/dev/null 2>&1', + get => '--no-check-certificate --quiet -O - {url}', + download => '--no-check-certificate --quiet -O {output} {url}', + order => 2, + }, + fetch => { + test => '--version >/dev/null 2>&1', + get => '--no-verify-peer -o - {url}', + download => '--no-verify-peer {url}', + order => 3, + } + ); - PATH_WITHOUT_PERLBREW=$(eval $perlbrew_command display-pristine-path) - if [ -n "$PERLBREW_PATH" ]; then - export PATH=${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW} - else - export PATH=${PERLBREW_ROOT}/bin:${PATH_WITHOUT_PERLBREW} - fi - unset PATH_WITHOUT_PERLBREW + our $HTTP_USER_AGENT_PROGRAM; + sub http_user_agent_program { + $HTTP_USER_AGENT_PROGRAM ||= do { + my $program; - hash -r + for my $p (sort {$commands{$a}<=>$commands{$b}} keys %commands) { + my $code = system("$p $commands{$p}->{test}") >> 8; + if ($code != 127) { + $program = $p; + last; + } + } + + unless($program) { + die "[ERROR] Cannot find a proper http user agent program. Please install curl or wget.\n"; + } + + $program; + }; + + die "[ERROR] Unrecognized http user agent program: $HTTP_USER_AGENT_PROGRAM. It can only be one of: ".join(",", keys %commands)."\n" unless $commands{$HTTP_USER_AGENT_PROGRAM}; + + return $HTTP_USER_AGENT_PROGRAM; + } + + sub http_user_agent_command { + my ($purpose, $params) = @_; + my $ua = http_user_agent_program; + my $cmd = $ua . " " . $commands{ $ua }->{ $purpose }; + for (keys %$params) { + $cmd =~ s!{$_}!$params->{$_}!g; + } + return ($ua, $cmd) if wantarray; + return $cmd; + } + + sub http_download { + my ($url, $path) = @_; + + if (-e $path) { + die "ERROR: The download target < $path > already exists.\n"; + } + + my $download_command = http_user_agent_command( download => { url => $url, output => $path } ); + + my $status = system($download_command); + unless ($status == 0) { + return "ERROR: Failed to execute the command\n\n\t$download_command\n\nReason:\n\n\t$?"; + } + return 0; + } + + sub http_get { + my ($url, $header, $cb) = @_; + + if (ref($header) eq 'CODE') { + $cb = $header; + $header = undef; + } + + my ($program, $command) = http_user_agent_command( get => { url => $url } ); + + open my $fh, '-|', $command + or die "open() for '$command': $!"; + + local $/; + my $body = <$fh>; + close $fh; + + die 'Page not retrieved; HTTP error code 400 or above.' + if $program eq 'curl' # Exit code is 22 on 404s etc + and $? >> 8 == 22; # exit code is packed into $?; see perlvar + die 'Page not retrieved: fetch failed.' + if $program eq 'fetch' # Exit code is not 0 on error + and $?; + die 'Server issued an error response.' + if $program eq 'wget' # Exit code is 8 on 404s etc + and $? >> 8 == 8; + + return $cb ? $cb->($body) : $body; + } } - __perlbrew_set_env() { - local code="$($perlbrew_command env $@)" - local exit_status="$?" - if [[ $exit_status -eq 0 ]] ; then - eval "$code" - else - return $exit_status - fi + sub perl_version_to_integer { + my $version = shift; + my @v = split(/[\.\-_]/, $version); + return undef if @v < 2; + if ($v[1] <= 5) { + $v[2] ||= 0; + $v[3] = 0; + } + else { + $v[3] ||= $v[1] >= 6 ? 9 : 0; + $v[3] =~ s/[^0-9]//g; + } + + return $v[1]*1000000 + $v[2]*1000 + $v[3]; } - __perlbrew_activate() { - [[ -n $(alias perl 2>/dev/null) ]] && unalias perl 2>/dev/null + # straight copy of Wikipedia's "Levenshtein Distance" + sub editdist { + my @a = split //, shift; + my @b = split //, shift; - if [[ -n "$PERLBREW_PERL" ]]; then - if [[ -z "$PERLBREW_LIB" ]]; then - __perlbrew_set_env $PERLBREW_PERL - else - __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB - fi - fi + # There is an extra row and column in the matrix. This is the + # distance from the empty string to a substring of the target. + my @d; + $d[$_][0] = $_ for (0 .. @a); + $d[0][$_] = $_ for (0 .. @b); - __perlbrew_set_path - } + for my $i (1 .. @a) { + for my $j (1 .. @b) { + $d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1] + : 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1])); + } + } - __perlbrew_deactivate() { - __perlbrew_set_env - unset PERLBREW_PERL - unset PERLBREW_LIB - __perlbrew_set_path + return $d[@a][@b]; } - perlbrew () { - local exit_status - local short_option - export SHELL + ### methods - if [[ $1 == -* ]]; then - short_option=$1 - shift - else - short_option="" - fi + sub new { + my($class, @argv) = @_; - case $1 in - (use) - if [[ -z "$2" ]] ; then - if [[ -z "$PERLBREW_PERL" ]] ; then - echo "Currently using system perl" - else - echo "Currently using $PERLBREW_PERL" - fi - else - __perlbrew_set_env "$2" - exit_status="$?" - if [[ $exit_status -eq 0 ]] - then - __perlbrew_set_path - fi - fi - ;; + my %opt = ( + original_argv => \@argv, + args => [], + force => 0, + quiet => 0, + D => [], + U => [], + A => [], + sitecustomize => '', + noman => '', + variation => '', + both => [], + append => '', + ); - (switch) - if [[ -z "$2" ]] ; then - command perlbrew switch - else - perlbrew use $2 - exit_status=$? - if [[ ${exit_status} -eq 0 ]]; then - __perlbrew_reinit $2 - fi - fi - ;; + $opt{$_} = '' for keys %flavor; - (off) - __perlbrew_deactivate - echo "perlbrew is turned off." - ;; + if (@argv) { + # build a local @ARGV to allow us to use an older + # Getopt::Long API in case we are building on an older system + local (@ARGV) = @argv; - (switch-off) - __perlbrew_deactivate - __perlbrew_reinit - echo "perlbrew is switched off." - ;; + Getopt::Long::Configure( + 'pass_through', + 'no_ignore_case', + 'bundling', + 'permute', # default behaviour except 'exec' + ); - (*) - command perlbrew $short_option "$@" - exit_status=$? - ;; - esac - hash -r - return ${exit_status:-0} + $class->parse_cmdline(\%opt); + + $opt{args} = \@ARGV; + + # fix up the effect of 'bundling' + foreach my $flags (@opt{qw(D U A)}) { + foreach my $value (@{$flags}) { + $value =~ s/^=//; + } + } + } + + return bless \%opt, $class; } - [[ -z "$PERLBREW_ROOT" ]] && export PERLBREW_ROOT="%s" - [[ -z "$PERLBREW_HOME" ]] && export PERLBREW_HOME="$HOME/.perlbrew" + sub parse_cmdline { + my ($self, $params, @ext) = @_; - if [[ ! -n "$PERLBREW_SKIP_INIT" ]]; then - if [[ -f "$PERLBREW_HOME/init" ]]; then - . "$PERLBREW_HOME/init" - fi - fi + my @f = map { $flavor{$_}{opt} || $_ } keys %flavor; - perlbrew_bin_path="${PERLBREW_ROOT}/bin" - if [[ -f $perlbrew_bin_path/perlbrew ]]; then - perlbrew_command="$perlbrew_bin_path/perlbrew" - else - perlbrew_command="perlbrew" - fi - unset perlbrew_bin_path + return Getopt::Long::GetOptions( + $params, - __perlbrew_activate + 'force|f!', + 'notest|n!', + 'quiet|q!', + 'verbose|v', + 'as=s', + 'append=s', + 'help|h', + 'version', + 'root=s', + 'switch', + 'all', - RC - if [[ -n ${ZSH_VERSION-} ]]; then - autoload -U +X bashcompinit && bashcompinit - fi + # options passed directly to Configure + 'D=s@', + 'U=s@', + 'A=s@', - export PERLBREW="command perlbrew" - _perlbrew_compgen() - { - COMPREPLY=( $($PERLBREW compgen $COMP_CWORD ${COMP_WORDS[*]}) ) + 'j=i', + # options that affect Configure and customize post-build + 'sitecustomize=s', + 'noman', + + # flavors support + 'both|b=s@', + 'all-variations', + 'common-variations', + @f, + + @ext + ) } - complete -F _perlbrew_compgen perlbrew - COMPLETION - function __perlbrew_reinit - if not test -d "$PERLBREW_HOME" - mkdir -p "$PERLBREW_HOME" - end + sub root { + my ($self, $new_root) = @_; - echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init" - command perlbrew env $argv[1] | \grep PERLBREW_ >> "$PERLBREW_HOME/init" - __source_init - __perlbrew_set_path - end + if (defined($new_root)) { + $self->{root} = $new_root; + } - function __perlbrew_set_path - set -l MANPATH_WITHOUT_PERLBREW (perl -e 'print join " ", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);') + return $self->{root} || $PERLBREW_ROOT; + } - if test -n "$PERLBREW_MANPATH" - set -x MANPATH $PERLBREW_MANPATH $MANPATH_WITHOUT_PERLBREW - else - set -x MANPATH $MANPATH_WITHOUT_PERLBREW - end + sub current_perl { + my ($self, $v) = @_; + $self->{current_perl} = $v if $v; + return $self->{current_perl} || $self->env('PERLBREW_PERL') || ''; + } - set -l PATH_WITHOUT_PERLBREW (eval $perlbrew_command display-pristine-path | perl -pe'y/:/ /') + sub current_lib { + my ($self, $v) = @_; + $self->{current_lib} = $v if $v; + return $self->{current_lib} || $self->env('PERLBREW_LIB') || ''; + } - if test -n "$PERLBREW_PATH" - set -x PERLBREW_PATH (echo $PERLBREW_PATH | perl -pe 'y/:/ /' ) - eval set -x PATH $PERLBREW_PATH $PATH_WITHOUT_PERLBREW - else - eval set -x PATH $PERLBREW_ROOT/bin $PATH_WITHOUT_PERLBREW - end - end + sub current_env { + my ($self) = @_; + my $l = $self->current_lib; + $l = "@" . $l if $l; + return $self->current_perl . $l; + } - function __perlbrew_set_env - set -l code (eval $perlbrew_command env $argv | perl -pe 's/export\s+(\S+)="(\S*)"/set -x $1 $2;/g; y/:/ /') + sub installed_perl_executable { + my ($self, $name) = @_; + die unless $name; - if test -z "$code" - return 0; - else - eval $code - end - end + my $executable = joinpath($self->root, "perls", $name, "bin", "perl"); + return $executable if -e $executable; + return ""; + } - function __perlbrew_activate - functions -e perl + sub configure_args { + my ($self, $name) = @_; - if test -n "$PERLBREW_PERL" - if test -z "$PERLBREW_LIB" - __perlbrew_set_env $PERLBREW_PERL - else - __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB - end - end + my $perl_cmd = $self->installed_perl_executable( $name ); + my $code = 'while(($_,$v)=each(%Config)){print"$_ $v" if /config_arg/}'; - __perlbrew_set_path - end + my @output = split "\n" => $self->do_capture($perl_cmd, '-MConfig', '-wle', $code); - function __perlbrew_deactivate - __perlbrew_set_env - set -x PERLBREW_PERL - set -x PERLBREW_LIB - set -x PERLBREW_PATH - __perlbrew_set_path - end + my %arg; + for(@output) { + my ($k,$v) = split " ", $_, 2; + $arg{$k} = $v; + } - function perlbrew + if (wantarray) { + return map { $arg{"config_arg$_"} } (1 .. $arg{config_argc}) + } - test -z "$argv" - and echo " Usage: perlbrew [options] [arguments]" - and echo " or: perlbrew help" - and return 1 + return $arg{config_args} + } - switch $argv[1] - case use + sub cpan_mirror { + my ($self, $v) = @_; + unless($self->{cpan_mirror}) { + $self->{cpan_mirror} = $self->env("PERLBREW_CPAN_MIRROR") || "http://www.cpan.org"; + $self->{cpan_mirror} =~ s{/+$}{}; + } + return $self->{cpan_mirror}; + } + + sub env { + my ($self, $name) = @_; + return $ENV{$name} if $name; + return \%ENV; + } + + sub path_with_tilde { + my ($self, $dir) = @_; + my $home = $self->env('HOME'); + $dir =~ s/^\Q$home\E/~/ if $home; + return $dir; + } + + sub is_shell_csh { + my ($self) = @_; + return 1 if $self->env('SHELL') =~ /(t?csh)/; + return 0; + } + + sub run { + my($self) = @_; + $self->run_command($self->args); + } + + sub args { + my ( $self ) = @_; + return @{ $self->{args} }; + } + + sub commands { + my ( $self ) = @_; + + my $package = ref $self ? ref $self : $self; + + my @commands; + my $symtable = do { + no strict 'refs'; + \%{$package . '::'}; + }; + + foreach my $sym (keys %$symtable) { + if($sym =~ /^run_command_/) { + my $glob = $symtable->{$sym}; + if(defined *$glob{CODE}) { + $sym =~ s/^run_command_//; + $sym =~ s/_/-/g; + push @commands, $sym; + } + } + } + + return @commands; + } + + sub find_similar_commands { + my ( $self, $command ) = @_; + my $SIMILAR_DISTANCE = 6; + + my @commands = sort { + $a->[1] <=> $b->[1] + } grep { + defined + } map { + my $d = editdist($_, $command); + + ($d < $SIMILAR_DISTANCE) ? [ $_, $d ] : undef + } $self->commands; + + if(@commands) { + my $best = $commands[0][1]; + @commands = map { $_->[0] } grep { $_->[1] == $best } @commands; + } + + return @commands; + } + + sub run_command { + my ( $self, $x, @args ) = @_; + my $command = $x; + + if($self->{version}) { + $x = 'version'; + } + elsif(!$x) { + $x = 'help'; + @args = (0, $self->{help} ? 2 : 0); + } + elsif($x eq 'help') { + @args = (0, 2) unless @args; + } + + my $s = $self->can("run_command_$x"); + unless ($s) { + $x =~ y/-/_/; + $s = $self->can("run_command_$x"); + } + + unless($s) { + my @commands = $self->find_similar_commands($x); + + if(@commands > 1) { + @commands = map { ' ' . $_ } @commands; + die "Unknown command: `$command`. Did you mean one of the following?\n" . join("\n", @commands) . "\n"; + } elsif(@commands == 1) { + die "Unknown command: `$command`. Did you mean `$commands[0]`?\n"; + } else { + die "Unknown command: `$command`. Typo?\n"; + } + } + + $self->$s(@args); + } + + sub run_command_version { + my ( $self ) = @_; + my $package = ref $self; + my $version = $self->VERSION; + print "$0 - $package/$version\n"; + } + + sub run_command_help { + my ($self, $status, $verbose) = @_; + + require Pod::Usage; + + if ($status && !defined($verbose)) { + if ($self->can("run_command_help_${status}")) { + $self->can("run_command_help_${status}")->($self); + } + else { + my $out = ""; + open my $fh, ">", \$out; + + Pod::Usage::pod2usage( + -exitval => "NOEXIT", + -verbose => 99, + -sections => "COMMAND: " . uc($status), + -output => $fh, + -noperldoc => 1 + ); + $out =~ s/\A[^\n]+\n//s; + $out =~ s/^ //gm; + + if ($out =~ /\A\s*\Z/) { + $out = "Cannot find documentation for '$status'\n\n"; + } + + print "\n$out"; + close $fh; + } + } + else { + Pod::Usage::pod2usage( + -noperldoc => 1, + -verbose => $verbose||0, + -exitval => (defined $status ? $status : 1) + ); + } + } + + # introspection for compgen + my %comp_installed = ( + use => 1, + switch => 1, + ); + + sub run_command_compgen { + my($self, $cur, @args) = @_; + + $cur = 0 unless defined($cur); + + # do `tail -f bashcomp.log` for debugging + if($self->env('PERLBREW_DEBUG_COMPLETION')) { + open my $log, '>>', 'bashcomp.log'; + print $log "[$$] $cur of [@args]\n"; + } + my $subcommand = $args[1]; + my $subcommand_completed = ( $cur >= 2 ); + + if(!$subcommand_completed) { + $self->_compgen($subcommand, $self->commands); + } + else { # complete args of a subcommand + if($comp_installed{$subcommand}) { + if($cur <= 2) { + my $part; + if(defined($part = $args[2])) { + $part = qr/ \Q$part\E /xms; + } + $self->_compgen($part, + map{ $_->{name} } $self->installed_perls()); + } + } + elsif($subcommand eq 'help') { + if($cur <= 2) { + $self->_compgen($args[2], $self->commands()); + } + } + else { + # TODO + } + } + } + + sub _compgen { + my($self, $part, @reply) = @_; + if(defined $part) { + $part = qr/\A \Q$part\E /xms if ref($part) ne ref(qr//); + @reply = grep { /$part/ } @reply; + } + foreach my $word(@reply) { + print $word, "\n"; + } + } + + sub run_command_available { + my ( $self, $dist, $opts ) = @_; + + my @available = $self->available_perls(@_); + my @installed = $self->installed_perls(@_); + + my $is_installed; + for my $available (@available) { + $is_installed = 0; + for my $installed (@installed) { + my $name = $installed->{name}; + my $cur = $installed->{is_current}; + if ( $available eq $installed->{name} ) { + $is_installed = 1; + last; + } + } + print $is_installed ? 'i ' : ' ', $available, "\n"; + } + } + + sub available_perls { + my ( $self, $dist, $opts ) = @_; + + my $url = $self->{all} ? "http://www.cpan.org/src/5.0/" + : "http://www.cpan.org/src/README.html" ; + + my $html = http_get( $url, undef, undef ); + + unless($html) { + die "\nERROR: Unable to retrieve the list of perls.\n\n"; + } + + my @available_versions; + + for ( split "\n", $html ) { + if ( $self->{all} ) { + push @available_versions, $1 + if m|(.+?)|; + } + else { + push @available_versions, $1 + if m|(.+?)|; + } + } + s/\.tar\.gz// for @available_versions; + + return @available_versions; + } + + sub perl_release { + my ($self, $version) = @_; + + # try src/5.0 symlinks, either perl-5.X or perl5.X; favor .tar.bz2 over .tar.gz + my $index = http_get("http://www.cpan.org/src/5.0/"); + if ($index) { + for my $prefix ( "perl-", "perl" ){ + for my $suffix ( ".tar.bz2", ".tar.gz" ) { + my $dist_tarball = "$prefix$version$suffix"; + my $dist_tarball_url = $self->cpan_mirror() . "/src/5.0/$dist_tarball"; + return ( $dist_tarball, $dist_tarball_url ) + if ( $index =~ /href\s*=\s*"\Q$dist_tarball\E"/ms ); + } + } + } + + # try CPAN::Perl::Releases + require CPAN::Perl::Releases; + my $tarballs = CPAN::Perl::Releases::perl_tarballs($version); + + my $x = (values %$tarballs)[0]; + + if ($x) { + my $dist_tarball = (split("/", $x))[-1]; + my $dist_tarball_url = $self->cpan_mirror() . "/authors/id/$x"; + return ($dist_tarball, $dist_tarball_url); + } + + # try to find it on search.cpan.org + my $mirror = $self->config->{mirror}; + my $header = $mirror ? { 'Cookie' => "cpan=$mirror->{url}" } : undef; + my $html = http_get("http://search.cpan.org/dist/perl-${version}", $header); + + unless ($html) { + die "ERROR: Failed to locate perl-${version} tarball."; + } + + my ($dist_path, $dist_tarball) = + $html =~ m[Download]; + die "ERROR: Cannot find the tarball for perl-$version\n" + if !$dist_path and !$dist_tarball; + my $dist_tarball_url = "http://search.cpan.org${dist_path}"; + return ($dist_tarball, $dist_tarball_url); + } + + sub run_command_init { + my $self = shift; + my @args = @_; + + if (@args && $args[0] eq '-') { + if ($self->is_shell_csh) { + } + else { + $self->run_command_init_in_bash; + } + exit 0; + } + + mkpath($_) for (grep { ! -d $_ } map { joinpath($self->root, $_) } qw(perls dists build etc bin)); + + my ($f, $fh) = @_; + + my $etc_dir = joinpath($self->root, "etc"); + + for (["bashrc", "BASHRC_CONTENT"], + ["cshrc", "CSHRC_CONTENT"], + ["csh_reinit", "CSH_REINIT_CONTENT"], + ["csh_wrapper", "CSH_WRAPPER_CONTENT"], + ["csh_set_path", "CSH_SET_PATH_CONTENT"], + ["perlbrew-completion.bash", "BASH_COMPLETION_CONTENT"], + ["perlbrew.fish", "PERLBREW_FISH_CONTENT" ], + ) { + my ($file_name, $method) = @$_; + my $path = joinpath($etc_dir, $file_name); + if (! -f $path) { + open($fh, ">", $path) or die "Fail to create $path. Please check the permission of $etc_dir and try `perlbrew init` again."; + print $fh $self->$method; + close $fh; + } + else { + if (-w $path && open($fh, ">", $path)) { + print $fh $self->$method; + close $fh; + } + else { + print "NOTICE: $path already exists and not updated.\n" unless $self->{quiet}; + } + } + } + + my ( $shrc, $yourshrc ); + if ( $self->is_shell_csh) { + $shrc = 'cshrc'; + $self->env("SHELL") =~ m/(t?csh)/; + $yourshrc = $1 . "rc"; + } + elsif ($self->env("SHELL") =~ m/zsh\d?$/) { + $shrc = "bashrc"; + $yourshrc = 'zshenv'; + } + elsif( $self->env('SHELL') =~ m/fish/ ) { + $shrc = "perlbrew.fish"; + $yourshrc = 'config/fish/config.fish'; + } + else { + $shrc = "bashrc"; + $yourshrc = "bash_profile"; + } + + my $root_dir = $self->path_with_tilde($self->root); + my $pb_home_dir = $self->path_with_tilde($PERLBREW_HOME); + + my $code = qq( source $root_dir/etc/${shrc}); + if ($PERLBREW_HOME ne joinpath($ENV{HOME}, ".perlbrew")) { + $code = " export PERLBREW_HOME=$pb_home_dir\n" . $code; + } + + if ( $self->env('SHELL') =~ m/fish/ ) { + $code =~ s/source/./; + $code =~ s/export (\S+)=(\S+)/set -x $1 $2/; + } + + print <root, "bin", "perlbrew"); + + if (files_are_the_same($executable, $target)) { + print "You are already running the installed perlbrew:\n\n $executable\n"; + exit; + } + + mkpath( joinpath($self->root, "bin" )); + + open my $fh, "<", $executable; + my @lines = <$fh>; + close $fh; + + $lines[0] = $self->system_perl_shebang . "\n"; + + open $fh, ">", $target; + print $fh $_ for @lines; + close $fh; + + chmod(0755, $target); + + my $path = $self->path_with_tilde($target); + + print "perlbrew is installed: $path\n" unless $self->{quiet}; + + $self->run_command_init(); + return; + } + + sub do_install_git { + my $self = shift; + my $dist = shift; + + my $dist_name; + my $dist_git_describe; + my $dist_version; + + opendir my $cwd_orig, "."; + + chdir $dist; + + if (`git describe` =~ /v((5\.\d+\.\d+(?:-RC\d)?)(-\d+-\w+)?)$/) { + $dist_name = 'perl'; + $dist_git_describe = "v$1"; + $dist_version = $2; + } + + chdir $cwd_orig; + + require File::Spec; + my $dist_extracted_dir = File::Spec->rel2abs( $dist ); + $self->do_install_this($dist_extracted_dir, $dist_version, "$dist_name-$dist_version"); + return; + } + + sub do_install_url { + my $self = shift; + my $dist = shift; + + my $dist_name = 'perl'; + # need the period to account for the file extension + my ($dist_version) = $dist =~ m/-([\d.]+(?:-RC\d+)?|git)\./; + my ($dist_tarball) = $dist =~ m{/([^/]*)$}; + + my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball); + my $dist_tarball_url = $dist; + $dist = "$dist_name-$dist_version"; # we install it as this name later + + if ($dist_tarball_url =~ m/^file/) { + print "Installing $dist from local archive $dist_tarball_url\n"; + $dist_tarball_url =~ s/^file:\/+/\//; + $dist_tarball_path = $dist_tarball_url; + } + else { + print "Fetching $dist as $dist_tarball_path\n"; + my $error = http_download($dist_tarball_url, $dist_tarball_path); + die "ERROR: Failed to download $dist_tarball_url\n" if $error; + } + + my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path); + $self->do_install_this($dist_extracted_path, $dist_version, $dist); + return; + } + + sub do_extract_tarball { + my $self = shift; + my $dist_tarball = shift; + + # Assuming the dir extracted from the tarball is named after the tarball. + my $dist_tarball_basename = $dist_tarball; + $dist_tarball_basename =~ s{.*/([^/]+)\.tar\.(?:gz|bz2)$}{$1}; + + # Note that this is incorrect for blead. + my $extracted_dir = "@{[ $self->root ]}/build/$dist_tarball_basename"; + + # Was broken on Solaris, where GNU tar is probably + # installed as 'gtar' - RT #61042 + my $tarx = + ($^O eq 'solaris' ? 'gtar ' : 'tar ') . + ( $dist_tarball =~ m/bz2$/ ? 'xjf' : 'xzf' ); + + if (-d $extracted_dir) { + rmpath($extracted_dir); + } + + my $extract_command = "cd @{[ $self->root ]}/build; $tarx $dist_tarball"; + die "Failed to extract $dist_tarball" if system($extract_command); + return $extracted_dir; + } + + sub do_install_blead { + my $self = shift; + my $dist = shift; + + my $dist_name = 'perl'; + my $dist_git_describe = 'blead'; + my $dist_version = 'blead'; + + # We always blindly overwrite anything that's already there, + # because blead is a moving target. + my $dist_tarball = 'blead.tar.gz'; + my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball); + print "Fetching $dist_git_describe as $dist_tarball_path\n"; + + my $error = http_download("http://perl5.git.perl.org/perl.git/snapshot/$dist_tarball", $dist_tarball_path); + + if ($error) { + die "\nERROR: Failed to download perl-blead tarball.\n\n"; + } + + # Returns the wrong extracted dir for blead + $self->do_extract_tarball($dist_tarball_path); + + my $build_dir = joinpath($self->root, "build"); + local *DIRH; + opendir DIRH, $build_dir or die "Couldn't open ${build_dir}: $!"; + my @contents = readdir DIRH; + closedir DIRH or warn "Couldn't close ${build_dir}: $!"; + my @candidates = grep { m/^perl-[0-9a-f]{7,8}$/ } @contents; + # Use a Schwartzian Transform in case there are lots of dirs that + # look like "perl-$SHA1", which is what's inside blead.tar.gz, + # so we stat each one only once. + @candidates = map { $_->[0] } + sort { $b->[1] <=> $a->[1] } # descending + map { [ $_, (stat( joinpath($build_dir, $_) ))[9] ] } @candidates; + my $dist_extracted_dir = joinpath($self->root, "build", $candidates[0]); # take the newest one + $self->do_install_this($dist_extracted_dir, $dist_version, "$dist_name-$dist_version"); + return; + } + + sub resolve_stable_version { + my ($self) = @_; + + my ($latest_ver, $latest_minor); + for my $cand ($self->available_perls) { + my ($ver, $minor) = $cand =~ m/^perl-(5\.(6|8|[0-9]+[02468])\.[0-9]+)$/ + or next; + ($latest_ver, $latest_minor) = ($ver, $minor) + if !defined $latest_minor + || $latest_minor < $minor; + } + + die "Can't determine latest stable Perl release\n" + if !defined $latest_ver; + + return $latest_ver; + } + + sub do_install_release { + my ($self, $dist, $dist_version) = @_; + + my ($dist_tarball, $dist_tarball_url) = $self->perl_release($dist_version); + my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball); + + if (-f $dist_tarball_path) { + print "Using the previously fetched ${dist_tarball}\n" + if $self->{verbose}; + } + else { + print "Fetching perl $dist_version as $dist_tarball_path\n" unless $self->{quiet}; + $self->run_command_download($dist); + } + + my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path); + $self->do_install_this( $dist_extracted_path, $dist_version, $dist ); + return; + } + + sub run_command_install { + my ( $self, $dist, $opts ) = @_; + + unless($dist) { + $self->run_command_help("install"); + exit(-1); + } + + $self->{dist_name} = $dist; # for help msg generation, set to non + # normalized name + + if ($dist =~ /^(?:perl-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/) { + my $version = ($1 eq 'stable' ? $self->resolve_stable_version : $1); + $dist = "perl-$version"; # normalize dist name + + my $installation_name = ($self->{as} || $dist) . $self->{variation} . $self->{append}; + if (not $self->{force} and $self->is_installed( $installation_name )) { + die "\nABORT: $installation_name is already installed.\n\n"; + } + + if ($version eq 'blead') { + $self->do_install_blead($dist); + } + else { + $self->do_install_release( $dist, $version ); + } + + } + # else it is some kind of special install: + elsif (-d "$dist/.git") { + $self->do_install_git($dist); + } + elsif (-f $dist) { + $self->do_install_archive($dist); + } + elsif ($dist =~ m/^(?:https?|ftp|file)/) { # more protocols needed? + $self->do_install_url($dist); + } + else { + die "Unknown installation target \"$dist\", abort.\nPlease see `perlbrew help` " . + "for the instruction on using the install command.\n\n"; + } + + if ($self->{switch}) { + if (defined(my $installation_name = $self->{installation_name})) { + $self->switch_to($installation_name) + } + else { + warn "can't switch, unable to infer final destination name.\n\n"; + } + } + return; + } + + sub check_and_calculate_variations { + my $self = shift; + my @both = @{$self->{both}}; + + if ($self->{'all-variations'}) { + @both = keys %flavor; + } + elsif ($self->{'common-variations'}) { + push @both, grep $flavor{$_}{common}, keys %flavor; + } + + # check the validity of the varitions given via 'both' + for my $both (@both) { + $flavor{$both} or die "$both is not a supported flavor.\n\n"; + $self->{$both} and die "options --both $both and --$both can not be used together"; + if (my $implied_by = $flavor{$both}{implied_by}) { + $self->{$implied_by} and die "options --both $both and --$implied_by can not be used together"; + } + } + + # flavors selected always + my $start = ''; + $start .= "-$_" for grep $self->{$_}, keys %flavor; + + # make variations + my @var = $start; + for my $both (@both) { + my $append = join('-', $both, grep defined, $flavor{$both}{implies}); + push @var, map "$_-$append", @var; + } + + # normalize the variation names + @var = map { join '-', '', sort { $flavor{$a}{ix} <=> $flavor{$b}{ix} } grep length, split /-+/, $_ } @var; + s/(\b\w+\b)(?:-\1)+/$1/g for @var; # remove duplicate flavors + + # After inspecting perl Configure script this seems to be the most + # reliable heuristic to determine if perl would have 64bit IVs by + # default or not: + if ($Config::Config{longsize} >= 8) { + # We are in a 64bit platform. 64int and 64all are always set but + # we don't want them to appear on the final perl name + s/-64\w+//g for @var; + } + + # remove duplicated variations + my %var = map { $_ => 1 } @var; + sort keys %var; + } + + sub run_command_install_multiple { + my ( $self, @dists) = @_; + + unless(@dists) { + $self->run_command_help("install-multiple"); + exit(-1); + } + + die "--switch can not be used with command install-multiple.\n\n" + if $self->{switch}; + die "--as can not be used when more than one distribution is given.\n\n" + if $self->{as} and @dists > 1; + + my @variations = $self->check_and_calculate_variations; + print join("\n", + "Compiling the following distributions:", + map(" $_$self->{append}", @dists), + " with the following variations:", + map((/-(.*)/ ? " $1" : " default"), @variations), + "", ""); + + my @ok; + for my $dist (@dists) { + for my $variation (@variations) { + local $@; + eval { + $self->{$_} = '' for keys %flavor; + $self->{$_} = 1 for split /-/, $variation; + $self->{variation} = $variation; + $self->{installation_name} = undef; + + $self->run_command_install($dist); + push @ok, $self->{installation_name}; + }; + if ($@) { + $@ =~ s/\n+$/\n/; + print "Installation of $dist$variation failed: $@"; + } + } + } + + print join("\n", + "", + "The following perls have been installed:", + map (" $_", grep defined, @ok), + "", ""); + return + } + + sub run_command_download { + my ($self, $dist) = @_; + + $dist = $self->resolve_stable_version + if $dist && $dist eq 'stable'; + + my ($dist_version) = $dist =~ /^ (?:perl-?)? (.*) $/xs; + + die "\"$dist\" does not look like a perl distribution name. " unless $dist_version =~ /^\d\./; + + my ($dist_tarball, $dist_tarball_url) = $self->perl_release($dist_version); + my $dist_tarball_path = joinpath($self->root, "dists", $dist_tarball); + + if (-f $dist_tarball_path && !$self->{force}) { + print "$dist_tarball already exists\n"; + } + else { + print "Download $dist_tarball_url to $dist_tarball_path\n" unless $self->{quiet}; + my $error = http_download($dist_tarball_url, $dist_tarball_path); + if ($error) { + die "ERROR: Failed to download $dist_tarball_url\n"; + } + } + } + + sub purify { + my ($self, $envname) = @_; + my @paths = grep { index($_, $PERLBREW_HOME) < 0 && index($_, $self->root) < 0 } split /:/, $self->env($envname); + return wantarray ? @paths : join(":", @paths); + } + + sub system_perl_executable { + my ($self) = @_; + + my $system_perl_executable = do { + local $ENV{PATH} = $self->pristine_path; + `perl -MConfig -e 'print \$Config{perlpath}'` + }; + + return $system_perl_executable; + } + + sub system_perl_shebang { + my ($self) = @_; + return $Config{sharpbang}. $self->system_perl_executable; + } + + sub pristine_path { + my ($self) = @_; + return $self->purify("PATH"); + } + + sub pristine_manpath { + my ($self) = @_; + return $self->purify("MANPATH"); + } + + sub run_command_display_system_perl_executable { + print $_[0]->system_perl_executable . "\n"; + } + + sub run_command_display_system_perl_shebang { + print $_[0]->system_perl_shebang . "\n"; + } + + sub run_command_display_pristine_path { + print $_[0]->pristine_path . "\n"; + } + + sub run_command_display_pristine_manpath { + print $_[0]->pristine_manpath . "\n"; + } + + sub do_install_archive { + require File::Basename; + + my $self = shift; + my $dist_tarball_path = shift; + my $dist_version; + my $installation_name; + + if (File::Basename::basename($dist_tarball_path) =~ m{perl-?(5.+)\.tar\.(gz|bz2)\Z}) { + $dist_version = $1; + $installation_name = "perl-${dist_version}"; + } + + unless ($dist_version && $installation_name) { + die "Unable to determine perl version from archive filename.\n\nThe archive name should look like perl-5.x.y.tar.gz or perl-5.x.y.tar.bz2\n"; + } + + my $dist_extracted_path = $self->do_extract_tarball($dist_tarball_path); + $self->do_install_this($dist_extracted_path, $dist_version, $installation_name); + return; + } + + sub do_install_this { + my ($self, $dist_extracted_dir, $dist_version, $installation_name) = @_; + + my $variation = $self->{variation}; + my $append = $self->{append}; + + $self->{dist_extracted_dir} = $dist_extracted_dir; + $self->{log_file} = joinpath($self->root, "build.${installation_name}${variation}${append}.log"); + + my @d_options = @{ $self->{D} }; + my @u_options = @{ $self->{U} }; + my @a_options = @{ $self->{A} }; + my $sitecustomize = $self->{sitecustomize}; + $installation_name = $self->{as} if $self->{as}; + $installation_name .= "$variation$append"; + + $self->{installation_name} = $installation_name; + + if ( $sitecustomize ) { + die "Could not read sitecustomize file '$sitecustomize'\n" + unless -r $sitecustomize; + push @d_options, "usesitecustomize"; + } + + if ( $self->{noman} ) { + push @d_options, qw/man1dir=none man3dir=none/; + } + + for my $flavor (keys %flavor) { + $self->{$flavor} and push @d_options, $flavor{$flavor}{d_option} + } + + my $perlpath = $self->root . "/perls/$installation_name"; + my $patchperl = $self->root . "/bin/patchperl"; + + unless (-x $patchperl && -f _) { + $patchperl = "patchperl"; + } + + unshift @d_options, qq(prefix=$perlpath); + push @d_options, "usedevel" if $dist_version =~ /5\.\d[13579]|git|blead/; + + unless (grep { /eval:scriptdir=/} @a_options) { + push @a_options, "'eval:scriptdir=${perlpath}/bin'"; + } + + my $version = perl_version_to_integer($dist_version); + if (defined $version and $version < perl_version_to_integer( '5.6.0' ) ) { + # ancient perls do not support -A for Configure + @a_options = (); + } + + print "Installing $dist_extracted_dir into " . $self->path_with_tilde("@{[ $self->root ]}/perls/$installation_name") . "\n\n"; + print <{verbose}; + This could take a while. You can run the following command on another shell to track the status: + + tail -f @{[ $self->path_with_tilde($self->{log_file}) ]} + + INSTALL + + my @preconfigure_commands = ( + "cd $dist_extracted_dir", + "rm -f config.sh Policy.sh", + $patchperl, + ); + + my $configure_flags = $self->env("PERLBREW_CONFIGURE_FLAGS") || '-de'; + + my @configure_commands = ( + "sh Configure $configure_flags " . + join( ' ', + ( map { qq{'-D$_'} } @d_options ), + ( map { qq{'-U$_'} } @u_options ), + ( map { qq{'-A$_'} } @a_options ), + ), + (defined $version and $version < perl_version_to_integer( '5.8.9' )) + ? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile") + : () + ); + + my @build_commands = ( + "make " . ($self->{j} ? "-j$self->{j}" : "") + ); + + # Test via "make test_harness" if available so we'll get + # automatic parallel testing via $HARNESS_OPTIONS. The + # "test_harness" target was added in 5.7.3, which was the last + # development release before 5.8.0. + my $test_target = "test"; + if ($dist_version =~ /^5\.(\d+)\.(\d+)/ + && ($1 >= 8 || $1 == 7 && $2 == 3)) { + $test_target = "test_harness"; + } + local $ENV{TEST_JOBS}=$self->{j} + if $test_target eq "test_harness" && ($self->{j}||1) > 1; + + my @install_commands = $self->{notest} ? "make install" : ("make $test_target", "make install"); + @install_commands = join " && ", @install_commands unless($self->{force}); + + my $cmd = join " && ", + ( + @preconfigure_commands, + @configure_commands, + @build_commands, + @install_commands + ); + + unlink($self->{log_file}); + + if($self->{verbose}) { + $cmd = "($cmd) 2>&1 | tee $self->{log_file}"; + print "$cmd\n" if $self->{verbose}; + } else { + $cmd = "($cmd) >> '$self->{log_file}' 2>&1 "; + } + + delete $ENV{$_} for qw(PERL5LIB PERL5OPT); + + if ($self->do_system($cmd)) { + my $newperl = joinpath($self->root, "perls", $installation_name, "bin", "perl"); + unless (-e $newperl) { + $self->run_command_symlink_executables($installation_name); + } + if ( $sitecustomize ) { + my $capture = $self->do_capture("$newperl -V:sitelib"); + my ($sitelib) = $capture =~ /sitelib='(.*)';/; + mkpath($sitelib) unless -d $sitelib; + my $target = "$sitelib/sitecustomize.pl"; + open my $dst, ">", $target + or die "Could not open '$target' for writing: $!\n"; + open my $src, "<", $sitecustomize + or die "Could not open '$sitecustomize' for reading: $!\n"; + print {$dst} do { local $/; <$src> }; + } + print "$installation_name is successfully installed.\n"; + } + else { + die $self->INSTALLATION_FAILURE_MESSAGE; + } + return; + } + + sub do_install_program_from_url { + my ($self, $url, $program_name, $body_filter) = @_; + + my $out = $self->root . "/bin/" . $program_name; + + if (-f $out && !$self->{force}) { + require ExtUtils::MakeMaker; + + my $ans = ExtUtils::MakeMaker::prompt("\n$out already exists, are you sure to override ? [y/N]", "N"); + + if ($ans !~ /^Y/i) { + print "\n$program_name installation skipped.\n\n" unless $self->{quiet}; + return; + } + } + + my $body = http_get($url) or die "\nERROR: Failed to retrieve $program_name executable.\n\n"; + + unless ($body =~ m{\A#!/}s) { + my $x = joinpath($ENV{TMPDIR} || "/tmp", "${program_name}.downloaded.$$"); + my $message = "\nERROR: The downloaded $program_name program seem to be invalid. Please check if the following URL can be reached correctly\n\n\t$url\n\n...and try again latter."; + + unless (-f $x) { + open my $OUT, ">", $x; + print $OUT $body; + close($OUT); + $message .= "\n\nThe previously downloaded file is saved at $x for manual inspection.\n\n"; + } + + die $message; + } + + if ($body_filter && ref($body_filter) eq "CODE") { + $body = $body_filter->($body); + } + + mkpath("@{[ $self->root ]}/bin") unless -d "@{[ $self->root ]}/bin"; + open my $OUT, '>', $out or die "cannot open file($out): $!"; + print $OUT $body; + close $OUT; + chmod 0755, $out; + print "\n$program_name is installed to\n\n $out\n\n" unless $self->{quiet}; + } + + sub do_exit_with_error_code { + my ($self, $code) = @_; + exit($code); + } + + sub do_system_with_exit_code { + my ($self, @cmd) = @_; + return system(@cmd); + } + + sub do_system { + my ($self, @cmd) = @_; + return ! $self->do_system_with_exit_code(@cmd); + } + + sub do_capture { + my ($self, @cmd) = @_; + require Capture::Tiny; + return Capture::Tiny::capture( sub { + $self->do_system(@cmd); + }); + } + + sub format_perl_version { + my $self = shift; + my $version = shift; + return sprintf "%d.%d.%d", + substr( $version, 0, 1 ), + substr( $version, 2, 3 ), + substr( $version, 5 ) || 0; + + } + + sub installed_perls { + my $self = shift; + + my @result; + my $root = $self->root; + + for (<$root/perls/*>) { + my ($name) = $_ =~ m/\/([^\/]+$)/; + my $executable = joinpath($_, 'bin', 'perl'); + my $version_file = joinpath($_,'.version'); + my $orig_version; + if ( -e $version_file ){ + open my $fh, '<', $version_file; + local $/; + $orig_version = <$fh>; + chomp $orig_version; + } else { + $orig_version = `$executable -e 'print \$]'`; + if ( defined $orig_version and length $orig_version ){ + if (open my $fh, '>', $version_file ){ + print {$fh} $orig_version; + } + } + } + + push @result, { + name => $name, + orig_version=> $orig_version, + version => $self->format_perl_version($orig_version), + is_current => ($self->current_perl eq $name) && !$self->env("PERLBREW_LIB"), + libs => [ $self->local_libs($name) ], + executable => $executable + }; + } + + return sort { $a->{orig_version} <=> $b->{orig_version} or $a->{name} cmp $b->{name} } @result; + } + + sub local_libs { + my ($self, $perl_name) = @_; + + my @libs = map { substr($_, length($PERLBREW_HOME) + 6) } <$PERLBREW_HOME/libs/*>; + + if ($perl_name) { + @libs = grep { /^$perl_name\@/ } @libs; + } + + my $current = $self->current_perl . '@' . ($self->env("PERLBREW_LIB") || ''); + + @libs = map { + my ($p, $l) = split(/@/, $_); + + +{ + name => $_, + is_current => $_ eq $current, + perl_name => $p, + lib_name => $l + } + } @libs; + return @libs; + } + + sub is_installed { + my ($self, $name) = @_; + + return grep { $name eq $_->{name} } $self->installed_perls; + } + + sub assert_known_installation { + my ($self, $name) = @_; + return 1 if $self->is_installed($name); + die "ERROR: The installation \"$name\" is unknown\n\n"; + } + + # Return a hash of PERLBREW_* variables + sub perlbrew_env { + my ($self, $name) = @_; + my ($perl_name, $lib_name); + + if ($name) { + ($perl_name, $lib_name) = $self->resolve_installation_name($name); + + unless ($perl_name) { + die "\nERROR: The installation \"$name\" is unknown.\n\n"; + } + } + + my %env = ( + PERLBREW_VERSION => $VERSION, + PERLBREW_PATH => joinpath($self->root, "bin"), + PERLBREW_MANPATH => "", + PERLBREW_ROOT => $self->root + ); + + if ($perl_name) { + if(-d "@{[ $self->root ]}/perls/$perl_name/bin") { + $env{PERLBREW_PERL} = $perl_name; + $env{PERLBREW_PATH} .= ":" . joinpath($self->root, "perls", $perl_name, "bin"); + $env{PERLBREW_MANPATH} = joinpath($self->root, "perls", $perl_name, "man") + } + + if ($lib_name) { + require local::lib; + + if ($ENV{PERL_LOCAL_LIB_ROOT} + && $ENV{PERL_LOCAL_LIB_ROOT} =~ /^\Q$PERLBREW_HOME\E/ + ) { + my %deactivate_env = local::lib->build_deact_all_environment_vars_for($ENV{PERL_LOCAL_LIB_ROOT}); + @env{keys %deactivate_env} = values %deactivate_env; + } + + my $base = "$PERLBREW_HOME/libs/${perl_name}\@${lib_name}"; + + if (-d $base) { + delete $ENV{PERL_LOCAL_LIB_ROOT}; + @ENV{keys %env} = values %env; + while (my ($k,$v) = each %ENV) { + delete $ENV{$k} unless defined($v); + } + my %lib_env = local::lib->build_environment_vars_for($base, 0, 1); + $env{PERLBREW_PATH} = joinpath($base, "bin") . ":" . $env{PERLBREW_PATH}; + $env{PERLBREW_MANPATH} = joinpath($base, "man") . ":" . $env{PERLBREW_MANPATH}; + $env{PERLBREW_LIB} = $lib_name; + + $env{PERL_MM_OPT} = $lib_env{PERL_MM_OPT}; + $env{PERL_MB_OPT} = $lib_env{PERL_MB_OPT}; + $env{PERL5LIB} = $lib_env{PERL5LIB}; + $env{PERL_LOCAL_LIB_ROOT} = $lib_env{PERL_LOCAL_LIB_ROOT}; + } + } + else { + my $libroot = $self->env("PERL_LOCAL_LIB_ROOT"); + if ($libroot && $libroot =~ /^\Q$PERLBREW_HOME\E/) { + require local::lib; + my %deactivate_env = local::lib->build_deact_all_environment_vars_for($libroot); + @env{keys %deactivate_env} = values %deactivate_env; + $env{PERLBREW_LIB} = undef; + } + if (my $perl5lib = $self->env("PERL5LIB")) { + my @perl5libs = split $Config{path_sep} => $perl5lib; + my @pristine_perl5libs = grep { !/^\Q$PERLBREW_HOME\E/ } @perl5libs; + if (@pristine_perl5libs) { + $env{PERL5LIB} = join $Config{path_sep}, @pristine_perl5libs; + } + else { + $env{PERL5LIB} = undef; + } + } + } + } + else { + my $libroot = $self->env("PERL_LOCAL_LIB_ROOT"); + if ($libroot && $libroot =~ /^\Q$PERLBREW_HOME\E/) { + require local::lib; + my %deactivate_env = local::lib->build_deact_all_environment_vars_for($libroot); + @env{keys %deactivate_env} = values %deactivate_env; + $env{PERLBREW_LIB} = undef; + } + + $env{PERLBREW_PERL} = undef; + } + + return %env; + } + + sub run_command_list { + my $self = shift; + + for my $i ( $self->installed_perls ) { + print $i->{is_current} ? '* ': ' ', + $i->{name}, + (index($i->{name}, $i->{version}) < 0) ? " ($i->{version})" : "", + "\n"; + + for my $lib (@{$i->{libs}}) { + print $lib->{is_current} ? "* " : " ", + $lib->{name}, "\n" + } + } + + return 0; + } + + sub launch_sub_shell { + my ($self, $name) = @_; + my $shell = $self->env('SHELL'); + + my $shell_opt = ""; + + if ($shell =~ /\/zsh\d?$/) { + $shell_opt = "-d -f"; + + if ($^O eq 'darwin') { + my $root_dir = $self->root; + print <<"WARNINGONMAC" + -------------------------------------------------------------------------------- + WARNING: zsh perlbrew sub-shell is not working on Mac OSX Lion. + + It is known that on MacOS Lion, zsh always resets the value of PATH on launching + a sub-shell. Effectively nullify the changes required by perlbrew sub-shell. You + may `echo \$PATH` to examine it and if you see perlbrew related paths are in the + end, instead of in the beginning, you are unfortunate. + + You are advised to include the following line to your ~/.zshenv as a better + way to work with perlbrew: + + source $root_dir/etc/bashrc + + -------------------------------------------------------------------------------- + WARNINGONMAC + + + } + } + elsif ($shell =~ /\/bash$/) { + $shell_opt = "--noprofile --norc"; + } + + my %env = ($self->perlbrew_env($name), PERLBREW_SKIP_INIT => 1); + + unless ($ENV{PERLBREW_VERSION}) { + my $root = $self->root; + # The user does not source bashrc/csh in their shell initialization. + $env{PATH} = $env{PERLBREW_PATH} . ":" . join ":", grep { !/$root\/bin/ } split ":", $ENV{PATH}; + $env{MANPATH} = $env{PERLBREW_MANPATH} . ":" . join ":", grep { !/$root\/man/ } + ( defined($ENV{MANPATH}) ? split(":", $ENV{MANPATH}) : () ); + } + + my $command = "env "; + while (my ($k, $v) = each(%env)) { + no warnings "uninitialized"; + $command .= "$k=\"$v\" "; + } + $command .= " $shell $shell_opt"; + + my $pretty_name = defined($name) ? $name : "the default perl"; + print "\nA sub-shell is launched with $pretty_name as the activated perl. Run 'exit' to finish it.\n\n"; + exec($command); + } + + sub run_command_use { + my $self = shift; + my $perl = shift; + + if ( !$perl ) { + my $current = $self->current_perl; + if ($current) { + print "Currently using $current\n"; + } else { + print "No version in use; defaulting to system\n"; + } + return; + } + + $self->launch_sub_shell($perl); + + } + + sub run_command_switch { + my ( $self, $dist, $alias ) = @_; + + unless ( $dist ) { + my $current = $self->current_perl; + printf "Currently switched %s\n", + ( $current ? "to $current" : 'off' ); + return; + } + + $self->switch_to($dist, $alias); + } + + sub switch_to { + my ( $self, $dist, $alias ) = @_; + + die "Cannot use for alias something that starts with 'perl-'\n" + if $alias && $alias =~ /^perl-/; + + die "${dist} is not installed\n" unless -d joinpath($self->root, "perls", $dist); + + if ($self->env("PERLBREW_BASHRC_VERSION")) { + local $ENV{PERLBREW_PERL} = $dist; + my $HOME = $self->env('HOME'); + my $pb_home = $self->env("PERLBREW_HOME") || $PERLBREW_HOME; + + mkpath($pb_home); + system("$0 env $dist > " . joinpath($pb_home, "init")); + + print "Switched to $dist.\n\n"; + } + else { + $self->launch_sub_shell($dist); + } + } + + sub run_command_off { + my $self = shift; + $self->launch_sub_shell; + } + + sub run_command_switch_off { + my $self = shift; + my $pb_home = $self->env("PERLBREW_HOME") || $PERLBREW_HOME; + + mkpath($pb_home); + system("env PERLBREW_PERL= $0 env > " . joinpath($pb_home, "init")); + + print "\nperlbrew is switched off. Please exit this shell and start a new one to make it effective.\n"; + print "To immediately make it effective, run this line in this terminal:\n\n exec @{[ $self->env('SHELL') ]}\n\n"; + } + + sub run_command_mirror { + my($self) = @_; + print "Fetching mirror list\n"; + my $raw = http_get("http://search.cpan.org/mirror"); + + unless ($raw) { + die "\nERROR: Failed to retrieve the mirror list.\n\n"; + } + + my $found; + my @mirrors; + foreach my $line ( split m{\n}, $raw ) { + $found = 1 if $line =~ m{}; + if ( $line =~ m{} ) { + my $url = $1; + my $name = $2; + $name =~ s/&#(\d+);/chr $1/seg; + $url =~ s/&#(\d+);/chr $1/seg; + push @mirrors, { url => $url, name => $name }; + } + } + + require ExtUtils::MakeMaker; + my $select; + my $max = @mirrors; + my $id = 0; + while ( @mirrors ) { + my @page = splice(@mirrors,0,20); + my $base = $id; + printf "[% 3d] %s\n", ++$id, $_->{name} for @page; + my $remaining = $max - $id; + my $ask = "Select a mirror by number or press enter to see the rest " + . "($remaining more) [q to quit, m for manual entry]"; + my $val = ExtUtils::MakeMaker::prompt( $ask ); + if ( ! length $val ) { next } + elsif ( $val eq 'q' ) { last } + elsif ( $val eq 'm' ) { + my $url = ExtUtils::MakeMaker::prompt("Enter the URL of your CPAN mirror:"); + my $name = ExtUtils::MakeMaker::prompt("Enter a Name: [default: My CPAN Mirror]") || "My CPAN Mirror"; + $select = { name => $name, url => $url }; + last; + } + elsif ( not $val =~ /\s*(\d+)\s*/ ) { + die "Invalid answer: must be 'q', 'm' or a number\n"; + } + elsif (1 <= $val and $val <= $max) { + $select = $page[ $val - 1 - $base ]; + last; + } + else { + die "Invalid ID: must be between 1 and $max\n"; + } + } + die "You didn't select a mirror!\n" if ! $select; + print "Selected $select->{name} ($select->{url}) as the mirror\n"; + my $conf = $self->config; + $conf->{mirror} = $select; + $self->_save_config; + return; + } + + sub run_command_env { + my($self, $name) = @_; + + my %env = $self->perlbrew_env($name); + + if ($self->env('SHELL') =~ /(ba|k|z|\/)sh\d?$/) { + for my $k (sort keys %env) { + my $v = $env{$k}; + if (defined $v) { + $v =~ s/(\\")/\\$1/g; + print "export $k=\"$v\"\n"; + } + else { + print "unset $k\n"; + } + } + } + else { + for my $k (sort keys %env) { + my $v = $env{$k}; + if (defined $v) { + $v =~ s/(\\")/\\$1/g; + print "setenv $k \"$v\"\n"; + } + else { + print "unsetenv $k\n"; + } + } + } + } + + sub run_command_symlink_executables { + my($self, @perls) = @_; + my $root = $self->root; + + unless (@perls) { + @perls = map { m{/([^/]+)$} } grep { -d $_ && ! -l $_ } <$root/perls/*>; + } + + for my $perl (@perls) { + for my $executable (<$root/perls/$perl/bin/*>) { + my ($name, $version) = $executable =~ m/bin\/(.+?)(5\.\d.*)?$/; + system("ln -fs $executable $root/perls/$perl/bin/$name") if $version; + } + } + } + + sub run_command_install_patchperl { + my ($self) = @_; + $self->do_install_program_from_url( + 'https://raw.githubusercontent.com/gugod/patchperl-packing/master/patchperl', + 'patchperl', + sub { + my ($body) = @_; + $body =~ s/\A#!.+?\n/ $self->system_perl_shebang . "\n" /se; + return $body; + } + ); + } + + sub run_command_install_cpanm { + my ($self) = @_; + $self->do_install_program_from_url('https://raw.githubusercontent.com/miyagawa/cpanminus/master/cpanm' => 'cpanm'); + } + + sub run_command_self_upgrade { + my ($self) = @_; + my $TMPDIR = $ENV{TMPDIR} || "/tmp"; + my $TMP_PERLBREW = joinpath($TMPDIR, "perlbrew"); + + require FindBin; + unless(-w $FindBin::Bin) { + die "Your perlbrew installation appears to be system-wide. Please upgrade through your package manager.\n"; + } + + http_get('http://get.perlbrew.pl', undef, sub { + my ( $body ) = @_; + + open my $fh, '>', $TMP_PERLBREW or die "Unable to write perlbrew: $!"; + print $fh $body; + close $fh; + }); + + chmod 0755, $TMP_PERLBREW; + my $new_version = qx($TMP_PERLBREW version); + chomp $new_version; + if($new_version =~ /App::perlbrew\/(\d+\.\d+)$/) { + $new_version = $1; + } else { + die "Unable to detect version of new perlbrew!\n"; + } + if($new_version <= $VERSION) { + print "Your perlbrew is up-to-date.\n"; + return; + } + system $TMP_PERLBREW, "self-install"; + unlink $TMP_PERLBREW; + } + + sub run_command_uninstall { + my ( $self, $target ) = @_; + + unless($target) { + $self->run_command_help("uninstall"); + exit(-1); + } + + my $dir = "@{[ $self->root ]}/perls/$target"; + + if (-l $dir) { + die "\nThe given name `$target` is an alias, not a real installation. Cannot perform uninstall.\nTo delete the alias, run:\n\n perlbrew alias delete $target\n\n"; + } + + unless(-d $dir) { + die "'$target' is not installed\n"; + } + exec 'rm', '-rf', $dir; + } + + sub run_command_exec { + my $self = shift; + my %opts; + + local (@ARGV) = @{$self->{original_argv}}; + + Getopt::Long::Configure ('require_order'); + my @command_options = ('with=s', 'halt-on-error'); + + $self->parse_cmdline (\%opts, @command_options); + shift @ARGV; # "exec" + $self->parse_cmdline (\%opts, @command_options); + + my @exec_with; + if ($opts{with}) { + my %installed = map { $_->{name} => $_ } map { ($_, @{$_->{libs}}) } $self->installed_perls; + + my $d = ($opts{with} =~ / /) ? qr( +) : qr(,+); + my @with = grep { $_ } map { + my ($p,$l) = $self->resolve_installation_name($_); + $p .= "\@$l" if $l; + $p; + } split $d, $opts{with}; + + @exec_with = map { $installed{$_} } @with; + } + else { + @exec_with = map { ($_, @{$_->{libs}}) } $self->installed_perls; + } + + if (0 == @exec_with) { + print "No perl installation found.\n" unless $self->{quiet}; + } + + my $overall_success = 1; + for my $i ( @exec_with ) { + next if -l $self->root . '/perls/' . $i->{name}; # Skip Aliases + my %env = $self->perlbrew_env($i->{name}); + next if !$env{PERLBREW_PERL}; + + local @ENV{ keys %env } = values %env; + local $ENV{PATH} = join(':', $env{PERLBREW_PATH}, $ENV{PATH}); + local $ENV{MANPATH} = join(':', $env{PERLBREW_MANPATH}, $ENV{MANPATH}||""); + local $ENV{PERL5LIB} = $env{PERL5LIB} || ""; + + print "$i->{name}\n==========\n" unless $self->{quiet}; + + + if (my $err = $self->do_system_with_exit_code(@ARGV)) { + my $exit_code = $err >> 8; + # return 255 for case when process was terminated with signal, in that case real exit code is useless and weird + $exit_code = 255 if $exit_code > 255; + $overall_success = 0; + print "Command terminated with non-zero status.\n" unless $self->{quiet}; + + print STDERR "Command [" . + join(' ', map { /\s/ ? "'$_'" : $_ } @ARGV) . # trying reverse shell escapes - quote arguments containing spaces + "] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n"; + print STDERR $self->format_info_output; + + $self->do_exit_with_error_code($exit_code) if ($opts{'halt-on-error'}); + } + print "\n\n" unless $self->{quiet}; + } + $self->do_exit_with_error_code(1) unless $overall_success; + } + + sub run_command_clean { + my ($self) = @_; + my $root = $self->root; + my @build_dirs = <$root/build/*>; + + for my $dir (@build_dirs) { + print "Removing $dir\n"; + rmpath($dir); + } + + my @tarballs = <$root/dists/*>; + for my $file ( @tarballs ) { + print "Removing $file\n"; + unlink($file); + } + + print "\nDone\n"; + } + + sub run_command_alias { + my ($self, $cmd, $name, $alias) = @_; + + if (!$cmd) { + print < [] + + perlbrew alias create + perlbrew alias delete + perlbrew alias rename + + USAGE + + return; + } + + my $path_name = joinpath($self->root, "perls", $name); + my $path_alias = joinpath($self->root, "perls", $alias) if $alias; + + if ($alias && -e $path_alias && !-l $path_alias) { + die "\nABORT: The installation name `$alias` is not an alias, cannot override.\n\n"; + } + + if ($cmd eq 'create') { + $self->assert_known_installation($name); + + if ( $self->is_installed($alias) && !$self->{force} ) { + die "\nABORT: The installation `${alias}` already exists. Cannot override.\n\n"; + } + + + unlink($path_alias) if -e $path_alias; + symlink($path_name, $path_alias); + } + elsif($cmd eq 'delete') { + $self->assert_known_installation($name); + + unless (-l $path_name) { + die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n"; + } + + unlink($path_name); + } + elsif($cmd eq 'rename') { + $self->assert_known_installation($name); + + unless (-l $path_name) { + die "\nABORT: The installation name `$name` is not an alias, cannot rename.\n\n"; + } + + if (-l $path_alias && !$self->{force}) { + die "\nABORT: The alias `$alias` already exists, cannot rename to it.\n\n"; + } + + rename($path_name, $path_alias); + } + elsif($cmd eq 'help') { + $self->run_command_help("alias"); + } + else { + die "\nERROR: Unrecognized action: `${cmd}`.\n\n"; + } + } + + sub run_command_display_bashrc { + print BASHRC_CONTENT(); + } + + sub run_command_display_cshrc { + print CSHRC_CONTENT(); + } + + sub run_command_display_installation_failure_message { + my ($self) = @_; + } + + sub lib_usage { + my $usage = <<'USAGE'; + + Usage: perlbrew lib [ ...] + + perlbrew lib list + perlbrew lib create nobita + perlbrew lib create perl-5.14.2@nobita + + perlbrew use perl-5.14.2@nobita + perlbrew lib delete perl-5.12.3@nobita shizuka + + USAGE + + + return $usage; + } + + sub run_command_lib { + my ($self, $subcommand, @args) = @_; + unless ($subcommand) { + print lib_usage; + return; + } + + my $sub = "run_command_lib_$subcommand"; + if ($self->can($sub)) { + $self->$sub( @args ); + } + else { + print "Unknown command: $subcommand\n"; + } + } + + sub run_command_lib_create { + my ($self, $name) = @_; + + die "ERROR: No lib name\n", lib_usage unless $name; + + $name =~ s/^/@/ unless $name =~ /@/; + + my ($perl_name, $lib_name) = $self->resolve_installation_name($name); + + if (!$perl_name) { + my ($perl_name, $lib_name) = split('@', $name); + die "ERROR: '$perl_name' is not installed yet, '$name' cannot be created.\n"; + } + + my $fullname = $perl_name . '@' . $lib_name; + my $dir = joinpath($PERLBREW_HOME, "libs", $fullname); + + if (-d $dir) { + die "$fullname is already there.\n"; + } + + mkpath($dir); + + print "lib '$fullname' is created.\n" + unless $self->{quiet}; + + return; + } + + sub run_command_lib_delete { + my ($self, $name) = @_; + + die "ERROR: No lib to delete\n", lib_usage unless $name; + + $name =~ s/^/@/ unless $name =~ /@/; + + my ($perl_name, $lib_name) = $self->resolve_installation_name($name); + + my $fullname = $perl_name . '@' . $lib_name; + + my $current = $self->current_perl . '@' . ($self->env("PERLBREW_LIB") || ""); + + my $dir = joinpath($PERLBREW_HOME, "libs", $fullname); + + if (-d $dir) { + + if ($fullname eq $current) { + die "$fullname is currently being used in the current shell, it cannot be deleted.\n"; + } + + rmpath($dir); + + print "lib '$fullname' is deleted.\n" + unless $self->{quiet}; + } + else { + die "ERROR: '$fullname' does not exist.\n"; + } + + return; + } + + sub run_command_lib_list { + my ($self) = @_; + + my $current = ""; + if ($self->current_perl && $self->env("PERLBREW_LIB")) { + $current = $self->current_perl . "@" . $self->env("PERLBREW_LIB"); + } + + my $dir = joinpath($PERLBREW_HOME, "libs"); + return unless -d $dir; + + opendir my $dh, $dir or die "open $dir failed: $!"; + my @libs = grep { !/^\./ && /\@/ } readdir($dh); + + for (@libs) { + print $current eq $_ ? "* " : " "; + print "$_\n"; + } + } + + sub run_command_upgrade_perl { + my ($self) = @_; + + my $PERL_VERSION_RE = qr/(\d+)\.(\d+)\.(\d+)/; + + my ( $current ) = grep { $_->{is_current} } $self->installed_perls; + + unless(defined $current) { + print "no perlbrew environment is currently in use\n"; + exit(1); + } + + my ( $major, $minor, $release ); + + if($current->{version} =~ /^$PERL_VERSION_RE$/) { + ( $major, $minor, $release ) = ( $1, $2, $3 ); + } else { + print "unable to parse version '$current->{version}'\n"; + exit(1); + } + + my @available = grep { + /^perl-$major\.$minor/ + } $self->available_perls; + + my $latest_available_perl = $release; + + foreach my $perl (@available) { + if($perl =~ /^perl-$PERL_VERSION_RE$/) { + my $this_release = $3; + if($this_release > $latest_available_perl) { + $latest_available_perl = $this_release; + } + } + } + + if($latest_available_perl == $release) { + print "This perlbrew environment ($current->{name}) is already up-to-date.\n"; + exit(0); + } + + my $dist_version = "$major.$minor.$latest_available_perl"; + my $dist = "perl-$dist_version"; + + print "Upgrading $current->{name} to $dist_version\n" unless $self->{quiet}; + local $self->{as} = $current->{name}; + local $self->{dist_name} = $dist; + $self->do_install_release($dist, $dist_version); + } + + sub run_command_list_modules { + my ($self) = @_; + my $class = ref($self) || __PACKAGE__; + my $app = $class->new( + qw(--quiet exec --with), + $self->current_env, + 'perl', '-MExtUtils::Installed', '-le', + 'BEGIN{@INC=grep {$_ ne q!.!} @INC}; print for ExtUtils::Installed->new->modules;' + ); + $app->run; + } + + sub resolve_installation_name { + my ($self, $name) = @_; + die "App::perlbrew->resolve_installation_name requires one argument." unless $name; + + my ($perl_name, $lib_name) = split('@', $name); + $perl_name = $name unless $lib_name; + $perl_name ||= $self->current_perl; + + if ( !$self->is_installed($perl_name) ) { + if ($self->is_installed("perl-${perl_name}") ) { + $perl_name = "perl-${perl_name}"; + } + else { + return undef; + } + } + + return wantarray ? ($perl_name, $lib_name) : $perl_name; + } + + sub format_info_output + { + my ($self, $module) = @_; + + my $out = ''; + + $out .= "Current perl:\n"; + if ($self->current_perl) { + $out .= " Name: " . $self->current_env . "\n"; + $out .= " Path: " . $self->installed_perl_executable($self->current_perl) . "\n"; + $out .= " Config: " . $self->configure_args( $self->current_perl ) . "\n"; + $out .= join('', " Compiled at: ", (map { + / Compiled at (.+)\n/ ? $1 : () + } `@{[ $self->installed_perl_executable($self->current_perl) ]} -V`), "\n"); + } + else { + $out .= "Using system perl." . "\n"; + $out .= "Shebang: " . $self->system_perl_shebang . "\n"; + } + + $out .= "\nperlbrew:\n"; + $out .= " version: " . $self->VERSION . "\n"; + $out .= " ENV:\n"; + for(map{"PERLBREW_$_"}qw(ROOT HOME PATH MANPATH)) { + $out .= " $_: " . ($self->env($_)||"") . "\n"; + } + + if ( $module ) { + my $code = qq{eval "require $module" and do { (my \$f = "$module") =~ s<::>g; \$f .= ".pm"; print "$module\n Location: \$INC{\$f}\n Version: " . ($module->VERSION ? $module->VERSION : "no VERSION specified" ) } or do { print "$module could not be found, is it installed?" } }; + $out .= "\nModule: ".$self->do_capture( $self->installed_perl_executable($self->current_perl), "-le", $code ); + } + + $out; + } + + sub run_command_info { + my ($self) = shift; + print $self->format_info_output(@_); + } + + + sub config { + my($self) = @_; + $self->_load_config if ! $CONFIG; + return $CONFIG; + } + + sub config_file { + my ($self) = @_; + joinpath( $self->root, 'Config.pm' ); + } + + sub _save_config { + my($self) = @_; + require Data::Dumper; + open my $FH, '>', $self->config_file or die "Unable to open config (@{[ $self->config_file ]}): $!"; + my $d = Data::Dumper->new([$CONFIG],['App::perlbrew::CONFIG']); + print $FH $d->Dump; + close $FH; + } + + sub _load_config { + my($self) = @_; + + if ( ! -e $self->config_file ) { + local $CONFIG = {} if ! $CONFIG; + $self->_save_config; + } + + open my $FH, '<', $self->config_file or die "Unable to open config (@{[ $self->config_file ]}): $!\n"; + my $raw = do { local $/; my $rv = <$FH>; $rv }; + close $FH; + + my $rv = eval $raw; + if ( $@ ) { + warn "Error loading conf: $@\n"; + $CONFIG = {}; + return; + } + $CONFIG = {} if ! $CONFIG; + return; + } + + sub BASHRC_CONTENT() { + return "export PERLBREW_BASHRC_VERSION=$VERSION\n\n" . sprintf <<'RC', $PERLBREW_ROOT; + + __perlbrew_reinit() { + if [[ ! -d "$PERLBREW_HOME" ]]; then + mkdir -p "$PERLBREW_HOME" + fi + + echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init" + command perlbrew env $1 | \grep PERLBREW_ >> "$PERLBREW_HOME/init" + . "$PERLBREW_HOME/init" + __perlbrew_set_path + } + + __perlbrew_set_path () { + MANPATH_WITHOUT_PERLBREW=`perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);'` + if [ -n "$PERLBREW_MANPATH" ]; then + export MANPATH="$PERLBREW_MANPATH:$MANPATH_WITHOUT_PERLBREW" + else + export MANPATH="$MANPATH_WITHOUT_PERLBREW" + fi + unset MANPATH_WITHOUT_PERLBREW + + PATH_WITHOUT_PERLBREW=$(eval $perlbrew_command display-pristine-path) + if [ -n "$PERLBREW_PATH" ]; then + export PATH=${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW} + else + export PATH=${PERLBREW_ROOT}/bin:${PATH_WITHOUT_PERLBREW} + fi + unset PATH_WITHOUT_PERLBREW + + hash -r + } + + __perlbrew_set_env() { + local code="$($perlbrew_command env $@)" + local exit_status="$?" + if [[ $exit_status -eq 0 ]] ; then + eval "$code" + else + return $exit_status + fi + } + + __perlbrew_activate() { + [[ -n $(alias perl 2>/dev/null) ]] && unalias perl 2>/dev/null + + if [[ -n "$PERLBREW_PERL" ]]; then + if [[ -z "$PERLBREW_LIB" ]]; then + __perlbrew_set_env $PERLBREW_PERL + else + __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB + fi + fi + + __perlbrew_set_path + } + + __perlbrew_deactivate() { + __perlbrew_set_env + unset PERLBREW_PERL + unset PERLBREW_LIB + __perlbrew_set_path + } + + perlbrew () { + local exit_status + local short_option + export SHELL + + if [[ $1 == -* ]]; then + short_option=$1 + shift + else + short_option="" + fi + + case $1 in + (use) + if [[ -z "$2" ]] ; then + if [[ -z "$PERLBREW_PERL" ]] ; then + echo "Currently using system perl" + else + echo "Currently using $PERLBREW_PERL" + fi + else + __perlbrew_set_env "$2" + exit_status="$?" + if [[ $exit_status -eq 0 ]] + then + __perlbrew_set_path + fi + fi + ;; + + (switch) + if [[ -z "$2" ]] ; then + command perlbrew switch + else + perlbrew use $2 + exit_status=$? + if [[ ${exit_status} -eq 0 ]]; then + __perlbrew_reinit $2 + fi + fi + ;; + + (off) + __perlbrew_deactivate + echo "perlbrew is turned off." + ;; + + (switch-off) + __perlbrew_deactivate + __perlbrew_reinit + echo "perlbrew is switched off." + ;; + + (*) + command perlbrew $short_option "$@" + exit_status=$? + ;; + esac + hash -r + return ${exit_status:-0} + } + + [[ -z "$PERLBREW_ROOT" ]] && export PERLBREW_ROOT="%s" + [[ -z "$PERLBREW_HOME" ]] && export PERLBREW_HOME="$HOME/.perlbrew" + + if [[ ! -n "$PERLBREW_SKIP_INIT" ]]; then + if [[ -f "$PERLBREW_HOME/init" ]]; then + . "$PERLBREW_HOME/init" + fi + fi + + perlbrew_bin_path="${PERLBREW_ROOT}/bin" + if [[ -f $perlbrew_bin_path/perlbrew ]]; then + perlbrew_command="$perlbrew_bin_path/perlbrew" + else + perlbrew_command="perlbrew" + fi + unset perlbrew_bin_path + + __perlbrew_activate + + RC + + } + + sub BASH_COMPLETION_CONTENT() { + return <<'COMPLETION'; + if [[ -n ${ZSH_VERSION-} ]]; then + autoload -U +X bashcompinit && bashcompinit + fi + + export PERLBREW="command perlbrew" + _perlbrew_compgen() + { + COMPREPLY=( $($PERLBREW compgen $COMP_CWORD ${COMP_WORDS[*]}) ) + } + complete -F _perlbrew_compgen perlbrew + COMPLETION + } + + sub PERLBREW_FISH_CONTENT { + return "set -x PERLBREW_FISH_VERSION $VERSION\n" . <<'END'; + + function __perlbrew_reinit + if not test -d "$PERLBREW_HOME" + mkdir -p "$PERLBREW_HOME" + end + + echo '# DO NOT EDIT THIS FILE' > "$PERLBREW_HOME/init" + command perlbrew env $argv[1] | \grep PERLBREW_ >> "$PERLBREW_HOME/init" + __source_init + __perlbrew_set_path + end + + function __perlbrew_set_path + set -l MANPATH_WITHOUT_PERLBREW (perl -e 'print join " ", grep { index($_, $ENV{PERLBREW_HOME}) < 0 } grep { index($_, $ENV{PERLBREW_ROOT}) < 0 } split/:/,qx(manpath 2> /dev/null);') + + if test -n "$PERLBREW_MANPATH" + set -x MANPATH $PERLBREW_MANPATH $MANPATH_WITHOUT_PERLBREW + else + set -x MANPATH $MANPATH_WITHOUT_PERLBREW + end + + set -l PATH_WITHOUT_PERLBREW (eval $perlbrew_command display-pristine-path | perl -pe'y/:/ /') + + if test -n "$PERLBREW_PATH" + set -x PERLBREW_PATH (echo $PERLBREW_PATH | perl -pe 'y/:/ /' ) + eval set -x PATH $PERLBREW_PATH $PATH_WITHOUT_PERLBREW + else + eval set -x PATH $PERLBREW_ROOT/bin $PATH_WITHOUT_PERLBREW + end + end + + function __perlbrew_set_env + set -l code (eval $perlbrew_command env $argv | perl -pe 's/export\s+(\S+)="(\S*)"/set -x $1 $2;/g; y/:/ /') + + if test -z "$code" + return 0; + else + eval $code + end + end + + function __perlbrew_activate + functions -e perl + + if test -n "$PERLBREW_PERL" + if test -z "$PERLBREW_LIB" + __perlbrew_set_env $PERLBREW_PERL + else + __perlbrew_set_env $PERLBREW_PERL@$PERLBREW_LIB + end + end + + __perlbrew_set_path + end + + function __perlbrew_deactivate + __perlbrew_set_env + set -x PERLBREW_PERL + set -x PERLBREW_LIB + set -x PERLBREW_PATH + __perlbrew_set_path + end + + function perlbrew + + test -z "$argv" + and echo " Usage: perlbrew [options] [arguments]" + and echo " or: perlbrew help" + and return 1 + + switch $argv[1] + case use if test ( count $argv ) -eq 1 if test -z "$PERLBREW_PERL" echo "Currently using system perl" @@ -300,286 +2671,3116 @@ $fatpacked{"App/perlbrew.pm"} = <<'APP_PERLBREW'; end end - case switch - if test ( count $argv ) -eq 1 - command perlbrew switch - else - perlbrew use $argv[2] - if test "$status" -eq 0 - __perlbrew_reinit $argv[2] - end - end + case switch + if test ( count $argv ) -eq 1 + command perlbrew switch + else + perlbrew use $argv[2] + if test "$status" -eq 0 + __perlbrew_reinit $argv[2] + end + end + + case off + __perlbrew_deactivate + echo "perlbrew is turned off." + + case switch-off + __perlbrew_deactivate + __perlbrew_reinit + echo "perlbrew is switched off." + + case '*' + command perlbrew $argv + end + end + + function __source_init + perl -pe's/^export/set -x/; s/=/ /; s/$/;/;' "$PERLBREW_HOME/init" | . - + end + + if test -z "$PERLBREW_ROOT" + set -x PERLBREW_ROOT "$HOME/perl5/perlbrew" + end + + if test -z "$PERLBREW_HOME" + set -x PERLBREW_HOME "$HOME/.perlbrew" + end + + if test -z "$PERLBREW_SKIP_INIT" -a -f "$PERLBREW_HOME/init" + __source_init + end + + set perlbrew_bin_path "$PERLBREW_ROOT/bin" + + if test -f "$perlbrew_bin_path/perlbrew" + set perlbrew_command "$perlbrew_bin_path/perlbrew" + else + set perlbrew_command perlbrew + end + + set -e perlbrew_bin_path + + __perlbrew_activate + + ## autocomplete stuff ############################################# + + function __fish_perlbrew_needs_command + set cmd (commandline -opc) + if test (count $cmd) -eq 1 -a $cmd[1] = 'perlbrew' + return 0 + end + return 1 + end + + function __fish_perlbrew_using_command + set cmd (commandline -opc) + if test (count $cmd) -gt 1 + if [ $argv[1] = $cmd[2] ] + return 0 + end + end + end + + for com in (perlbrew help | perl -ne'print lc if s/^COMMAND:\s+//') + complete -f -c perlbrew -n '__fish_perlbrew_needs_command' -a $com + end + + for com in switch use; + complete -f -c perlbrew -n "__fish_perlbrew_using_command $com" \ + -a '(perlbrew list | perl -pe\'s/\*?\s*(\S+).*/$1/\')' + end + + END + } + + sub CSH_WRAPPER_CONTENT { + return <<'WRAPPER'; + set perlbrew_exit_status=0 + + if ( $1 =~ -* ) then + set perlbrew_short_option=$1 + shift + else + set perlbrew_short_option="" + endif + + switch ( $1 ) + case use: + if ( $%2 == 0 ) then + if ( $?PERLBREW_PERL == 0 ) then + echo "Currently using system perl" + else + if ( $%PERLBREW_PERL == 0 ) then + echo "Currently using system perl" + else + echo "Currently using $PERLBREW_PERL" + endif + endif + else + set perlbrew_line_count=0 + foreach perlbrew_line ( "`\perlbrew env $2`" ) + eval $perlbrew_line + @ perlbrew_line_count++ + end + if ( $perlbrew_line_count == 0 ) then + set perlbrew_exit_status=1 + else + source "$PERLBREW_ROOT/etc/csh_set_path" + endif + endif + breaksw + + case switch: + if ( $%2 == 0 ) then + \perlbrew switch + else + perlbrew use $2 && source $PERLBREW_ROOT/etc/csh_reinit $2 + endif + breaksw + + case off: + unsetenv PERLBREW_PERL + foreach perlbrew_line ( "`\perlbrew env`" ) + eval $perlbrew_line + end + source $PERLBREW_ROOT/etc/csh_set_path + echo "perlbrew is turned off." + breaksw + + case switch-off: + unsetenv PERLBREW_PERL + source $PERLBREW_ROOT/etc/csh_reinit '' + echo "perlbrew is switched off." + breaksw + + default: + \perlbrew $perlbrew_short_option $argv + set perlbrew_exit_status=$? + breaksw + endsw + rehash + exit $perlbrew_exit_status + WRAPPER + } + + sub CSH_REINIT_CONTENT { + return <<'REINIT'; + if ( ! -d "$PERLBREW_HOME" ) then + mkdir -p "$PERLBREW_HOME" + endif + + echo '# DO NOT EDIT THIS FILE' >! "$PERLBREW_HOME/init" + \perlbrew env $1 >> "$PERLBREW_HOME/init" + source "$PERLBREW_HOME/init" + source "$PERLBREW_ROOT/etc/csh_set_path" + REINIT + } + + sub CSH_SET_PATH_CONTENT { + return <<'SETPATH'; + unalias perl + + if ( $?PERLBREW_PATH == 0 ) then + setenv PERLBREW_PATH "$PERLBREW_ROOT/bin" + endif + + setenv PATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,$ENV{PATH};'` + setenv PATH ${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW} + + setenv MANPATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,qx(manpath 2> /dev/null);'` + if ( $?PERLBREW_MANPATH == 1 ) then + setenv MANPATH ${PERLBREW_MANPATH}:${MANPATH_WITHOUT_PERLBREW} + else + setenv MANPATH ${MANPATH_WITHOUT_PERLBREW} + endif + SETPATH + } + + sub CSHRC_CONTENT { + return "setenv PERLBREW_CSHRC_VERSION $VERSION\n\n" . <<'CSHRC'; + + if ( $?PERLBREW_HOME == 0 ) then + setenv PERLBREW_HOME "$HOME/.perlbrew" + endif + + if ( $?PERLBREW_ROOT == 0 ) then + setenv PERLBREW_ROOT "$HOME/perl5/perlbrew" + endif + + if ( $?PERLBREW_SKIP_INIT == 0 ) then + if ( -f "$PERLBREW_HOME/init" ) then + source "$PERLBREW_HOME/init" + endif + endif + + if ( $?PERLBREW_PATH == 0 ) then + setenv PERLBREW_PATH "$PERLBREW_ROOT/bin" + endif + + source "$PERLBREW_ROOT/etc/csh_set_path" + alias perlbrew 'source $PERLBREW_ROOT/etc/csh_wrapper' + CSHRC + + } + + sub INSTALLATION_FAILURE_MESSAGE { + my ($self) = @_; + return <{log_file} + + If some perl tests failed and you still want install this distribution anyway, + do: + + (cd $self->{dist_extracted_dir}; make install) + + You might also want to try upgrading patchperl before trying again: + + perlbrew install-patchperl + + Generally, if you need to install a perl distribution known to have minor test + failures, do one of these command to avoid seeing this message + + perlbrew --notest install $self->{dist_name} + perlbrew --force install $self->{dist_name} + + FAIL + + } + + 1; + + __END__ + + =encoding utf8 + + =head1 NAME + + App::perlbrew - Manage perl installations in your $HOME + + =head1 SYNOPSIS + + # Installation + curl -kL http://install.perlbrew.pl | bash + + # Initialize + perlbrew init + + # Pick a preferred CPAN mirror + perlbrew mirror + + # See what is available + perlbrew available + + # Install some Perls + perlbrew install 5.18.2 + perlbrew install perl-5.8.1 + perlbrew install perl-5.19.9 + + # See what were installed + perlbrew list + + # Swith to an installation and set it as default + perlbrew switch perl-5.18.2 + + # Temporarily use another version only in current shell. + perlbrew use perl-5.8.1 + perl -v + + # Or turn it off completely. Useful when you messed up too deep. + # Or want to go back to the system Perl. + perlbrew off + + # Use 'switch' command to turn it back on. + perlbrew switch perl-5.12.2 + + # Exec something with all perlbrew-ed perls + perlbrew exec -- perl -E 'say $]' + + =head1 DESCRIPTION + + perlbrew is a program to automate the building and installation of perl in an + easy way. It provides multiple isolated perl environments, and a mechanism + for you to switch between them. + + Everything are installed unter C<~/perl5/perlbrew>. You then need to include a + bashrc/cshrc provided by perlbrew to tweak the PATH for you. You then can + benefit from not having to run 'sudo' commands to install + cpan modules because those are installed inside your HOME too. + + For the documentation of perlbrew usage see L command + on CPAN, or by running C. The following documentation + features the API of C module, and may not be remotely + close to what your want to read. + + =head1 INSTALLATION + + It is the simplest to use the perlbrew installer, just paste this statement to + your terminal: + + curl -kL http://install.perlbrew.pl | bash + + Or this one, if you have C (default on FreeBSD): + + fetch -o- http://install.perlbrew.pl | sh + + After that, C installs itself to C<~/perl5/perlbrew/bin>, and you + should follow the instruction on screen to modify your shell rc file to put it + in your PATH. + + The installed perlbrew command is a standalone executable that can be run with + system perl. The minimum system perl version requirement is 5.8.0, which should + be good enough for most of the OSes these days. + + A fat-packed version of C is also installed to + C<~/perl5/perlbrew/bin>, which is required to build old perls. + + The directory C<~/perl5/perlbrew> will contain all install perl executables, + libraries, documentations, lib, site_libs. In the documentation, that directory + is referred as "perlbrew root". If you need to set it to somewhere else because, + say, your HOME has limited quota, you can do that by setting C + environment variable before running the installer: + + export PERLBREW_ROOT=/opt/perl5 + curl -kL http://install.perlbrew.pl | bash + + As a result, different users on the same machine can all share the same perlbrew + root directory (although only original user that made the installation would + have the permission to perform perl installations.) + + You may also install perlbrew from CPAN: + + cpan App::perlbrew + + In this case, the perlbrew command is installed as C or + C or others, depending on the location of your system + perl installation. + + Please make sure not to run this with one of the perls brewed with + perlbrew. It's the best to turn perlbrew off before you run that, if you're + upgrading. + + perlbrew off + cpan App::perlbrew + + You should always use system cpan (like /usr/bin/cpan) to install + C because it will be installed under a system PATH like + C, which is not affected by perlbrew C or C command. + + The C command will not upgrade the perlbrew installed by cpan + command, but it is also easy to upgrade perlbrew by running `cpan App::perlbrew` + again. + + =head1 METHODS + + =over 4 + + =item (Str) current_perl + + Return the "current perl" object attribute string, or, if absent, the value of + PERLBREW_PERL environment variable. + + =item (Str) current_perl (Str) + + Set the "current_perl" object attribute to the given value. + + =back + + =head1 PROJECT DEVELOPMENT + + perlbrew project uses github + L and RT + for issue + tracking. Issues sent to these two systems will eventually be reviewed + and handled. + + See L for a list + of project contributors. + + =head1 AUTHOR + + Kang-min Liu C<< >> + + =head1 COPYRIGHT + + Copyright (c) 2010,2011,2012,2013,2014 Kang-min Liu C<< >>. + + =head1 LICENCE + + The MIT License + + =head1 DISCLAIMER OF WARRANTY + + BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY + FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN + OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES + PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER + EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE + ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH + YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL + NECESSARY SERVICING, REPAIR, OR CORRECTION. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING + WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR + REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE + LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, + OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE + THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING + RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A + FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF + SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF + SUCH DAMAGES. + + =cut +APP_PERLBREW + +$fatpacked{"CPAN/Perl/Releases.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_PERL_RELEASES'; + package CPAN::Perl::Releases; + $CPAN::Perl::Releases::VERSION = '1.76'; + #ABSTRACT: Mapping Perl releases on CPAN to the location of the tarballs + + use strict; + use warnings; + use vars qw[@ISA @EXPORT_OK]; + + use Exporter; + + @ISA = qw(Exporter); + @EXPORT_OK = qw(perl_tarballs perl_versions perl_pumpkins); + + # Data gathered from using findlinks.pl script in this dists tools/ + # directory, run over the src/5.0 of a local CPAN mirror. + our $cache = { }; + our $data = + { + "5.003_07" => { id => 'ANDYD' }, + "5.004" => { id => 'CHIPS' }, + "5.004_01" => { id => 'TIMB' }, + "5.004_02" => { id => 'TIMB' }, + "5.004_03" => { id => 'TIMB' }, + "5.004_04" => { id => 'TIMB' }, + "5.004_05" => { id => 'CHIPS' }, + "5.005" => { id => 'GSAR' }, + "5.005_01" => { id => 'GSAR' }, + "5.005_02" => { id => 'GSAR' }, + "5.005_03" => { id => 'GBARR' }, + "5.005_04" => { id => 'LBROCARD' }, + "5.6.0" => { id => 'GSAR' }, + "5.6.1-TRIAL1" => { id => 'GSAR' }, + "5.6.1-TRIAL2" => { id => 'GSAR' }, + "5.6.1-TRIAL3" => { id => 'GSAR' }, + "5.6.1" => { id => 'GSAR' }, + "5.6.2" => { id => 'RGARCIA' }, + "5.7.0" => { id => 'JHI' }, + "5.7.1" => { id => 'JHI' }, + "5.7.2" => { id => 'JHI' }, + "5.7.3" => { id => 'JHI' }, + "5.8.0" => { id => 'JHI' }, + "5.8.1" => { id => 'JHI' }, + "5.8.2" => { id => 'NWCLARK' }, + "5.8.3" => { id => 'NWCLARK' }, + "5.8.4" => { id => 'NWCLARK' }, + "5.8.5" => { id => 'NWCLARK' }, + "5.8.6" => { id => 'NWCLARK' }, + "5.8.7" => { id => 'NWCLARK' }, + "5.8.8" => { id => 'NWCLARK' }, + "5.8.9" => { id => 'NWCLARK' }, + "5.9.0" => { id => 'HVDS' }, + "5.9.1" => { id => 'RGARCIA' }, + "5.9.2" => { id => 'RGARCIA' }, + "5.9.3" => { id => 'RGARCIA' }, + "5.9.4" => { id => 'RGARCIA' }, + "5.9.5" => { id => 'RGARCIA' }, + "5.10.0" => { id => 'RGARCIA' }, + "5.10.1" => { id => 'DAPM' }, + "5.11.0" => { id => 'JESSE' }, + "5.11.1" => { id => 'JESSE' }, + "5.11.2" => { id => 'LBROCARD' }, + "5.11.3" => { id => 'JESSE' }, + "5.11.4" => { id => 'RJBS' }, + "5.11.5" => { id => 'SHAY' }, + "5.12.0" => { id => 'JESSE' }, + "5.12.1" => { id => 'JESSE' }, + "5.12.2" => { id => 'JESSE' }, + "5.12.3" => { id => 'RJBS' }, + "5.12.4" => { id => 'LBROCARD' }, + "5.12.5" => { id => 'DOM' }, + "5.13.0" => { id => 'LBROCARD' }, + "5.13.1" => { id => 'RJBS' }, + "5.13.2" => { id => 'MSTROUT' }, + "5.13.3" => { id => 'DAGOLDEN' }, + "5.13.4" => { id => 'FLORA' }, + "5.13.5" => { id => 'SHAY' }, + "5.13.6" => { id => 'MIYAGAWA' }, + "5.13.7" => { id => 'BINGOS' }, + "5.13.8" => { id => 'ZEFRAM' }, + "5.13.9" => { id => 'JESSE' }, + "5.13.10" => { id => 'AVAR' }, + "5.13.11" => { id => 'FLORA' }, + "5.14.0" => { id => 'JESSE' }, + "5.14.1" => { id => 'JESSE' }, + "5.14.2-RC1" => { id => 'FLORA' }, + "5.14.2" => { id => 'FLORA' }, + "5.14.3" => { id => 'DOM' }, + "5.14.4-RC1" => { id => 'DAPM' }, + "5.14.4-RC2" => { id => 'DAPM' }, + "5.14.4" => { id => 'DAPM' }, + "5.15.0" => { id => 'DAGOLDEN' }, + "5.15.1" => { id => 'ZEFRAM' }, + "5.15.2" => { id => 'RJBS' }, + "5.15.3" => { id => 'STEVAN' }, + "5.15.4" => { id => 'FLORA' }, + "5.15.5" => { id => 'SHAY' }, + "5.15.6" => { id => 'DROLSKY' }, + "5.15.7" => { id => 'BINGOS' }, + "5.15.8" => { id => 'CORION' }, + "5.15.9" => { id => 'ABIGAIL' }, + "5.16.0" => { id => 'RJBS' }, + "5.16.1" => { id => 'RJBS' }, + "5.16.2" => { id => 'RJBS' }, + "5.16.3" => { id => 'RJBS' }, + "5.17.0" => { id => 'ZEFRAM' }, + "5.17.1" => { id => 'DOY' }, + "5.17.2" => { id => 'TONYC' }, + "5.17.3" => { id => 'SHAY' }, + "5.17.4" => { id => 'FLORA' }, + "5.17.5" => { id => 'FLORA' }, + "5.17.6" => { id => 'RJBS' }, + "5.17.7" => { id => 'DROLSKY' }, + "5.17.8" => { id => 'ARC' }, + "5.17.9" => { id => 'BINGOS' }, + "5.17.10" => { id => 'CORION' }, + "5.17.11" => { id => 'RJBS' }, + "5.18.0-RC1" => { id => 'RJBS' }, + "5.18.0-RC2" => { id => 'RJBS' }, + "5.18.0-RC3" => { id => 'RJBS' }, + "5.18.0-RC4" => { id => 'RJBS' }, + "5.18.0" => { id => 'RJBS' }, + "5.18.1-RC1" => { id => 'RJBS' }, + "5.18.1-RC2" => { id => 'RJBS' }, + "5.18.1-RC3" => { id => 'RJBS' }, + "5.18.1" => { id => 'RJBS' }, + "5.19.0" => { id => 'RJBS' }, + "5.19.1" => { id => 'DAGOLDEN' }, + "5.19.2" => { id => 'ARISTOTLE' }, + "5.19.3" => { id => 'SHAY' }, + "5.19.4" => { id => 'SHAY' }, + "5.19.5" => { id => 'SHAY' }, + "5.19.6" => { id => 'BINGOS' }, + "5.18.2-RC1" => { id => 'RJBS' }, + "5.18.2-RC2" => { id => 'RJBS' }, + "5.18.2-RC3" => { id => 'RJBS' }, + "5.19.7" => { id => 'ABIGAIL' }, + "5.18.2-RC4" => { id => 'RJBS' }, + "5.18.2" => { id => 'RJBS' }, + "5.19.8" => { id => 'RJBS' }, + "5.19.9" => { id => 'TONYC' }, + "5.19.10" => { id => 'ARC' }, + "5.19.11" => { id => 'SHAY' }, + "5.20.0-RC1" => { id => 'RJBS' }, + "5.20.0" => { id => 'RJBS' }, + "5.21.0" => { id => 'RJBS' }, + "5.21.1" => { id => 'WOLFSAGE' }, + }; + + sub perl_tarballs { + my $vers = shift; + $vers = shift if eval { $vers->isa(__PACKAGE__) }; + return unless exists $data->{ $vers }; + if ( exists $cache->{ $vers } ) { + return { %{ $cache->{ $vers } } }; + } + my $pumpkin = $data->{ $vers }->{id}; + my $path = join '/', substr( $pumpkin, 0, 1 ), substr( $pumpkin, 0, 2 ), $pumpkin; + my $sep = ( $vers =~ m!^5\.0! ? '' : '-' ); + my $perl = join $sep, 'perl', $vers; + my $onlygz = 1 if $vers =~ m!(?-xism:5.(?:00(?:4(?:_0[12345])?|5(?:_0[1234])?|3_07)|1(?:0.0(?:-RC[12])?|6.0-RC0)|6.(?:[02]|1(?:-TRIAL[123])?)|9.[12345]|7.[0123]|8.[01]))! || $data->{ $vers }->{onlygz}; + my $onlybz2 = 1 if $data->{ $vers }->{onlybz2}; + my $foo = { }; + $foo->{'tar.gz'} = "$path/$perl.tar.gz" unless $onlybz2; + $foo->{'tar.bz2'} = "$path/$perl.tar.bz2" unless $onlygz; + $cache->{ $vers } = $foo; + return { %$foo }; + } + + sub perl_versions { + return sort _by_version keys %$data; + } + + + sub _by_version { + my %v = map { + my @v = split(qr/[-._]0*/, $_); + $v[2] ||= 0; + $v[3] ||= 'Z'; + ($_ => sprintf '%d.%03d%03d-%s', @v) + } $a, $b; + $v{$a} cmp $v{$b}; + } + + sub perl_pumpkins { + my %pumps = map { ( $data->{$_}->{id} => 1 ) } keys %$data; + return sort keys %pumps; + } + + q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|; + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Perl::Releases - Mapping Perl releases on CPAN to the location of the tarballs + + =head1 VERSION + + version 1.76 + + =head1 SYNOPSIS + + use CPAN::Perl::Releases qw[perl_tarballs]; + + my $perl = '5.14.0'; + + my $hashref = perl_tarballs( $perl ); + + print "Location: ", $_, "\n" for values %{ $hashref }; + + =head1 DESCRIPTION + + CPAN::Perl::Releases is a module that contains the mappings of all C releases that have been uploaded to CPAN to the + C path that the tarballs reside in. + + This is static data, but newer versions of this module will be made available as new releases of C are uploaded to CPAN. + + =head1 FUNCTIONS + + =over + + =item C + + Takes one parameter, a C version to search for. Returns an hashref on success or C otherwise. + + The returned hashref will have a key/value for each type of tarball. A key of C indicates the location + of a gzipped tar file and C of a bzip2'd tar file. The values will be the relative path under C + on CPAN where the indicated tarball will be located. + + perl_tarballs( '5.14.0' ); + + Returns a hashref like: + + { + "tar.bz2" => "J/JE/JESSE/perl-5.14.0.tar.bz2", + "tar.gz" => "J/JE/JESSE/perl-5.14.0.tar.gz" + } + + Not all C releases had C, but only a C. + + =item C + + Returns the list of all the perl versions supported by the module in ascending order. C and C will be lower + than an actual release. + + =item C + + Returns a sorted list of all PAUSE IDs of Perl pumpkins. + + =back + + =head1 SEE ALSO + + L + + L + + =head1 AUTHOR + + Chris Williams + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2014 by Chris Williams. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_PERL_RELEASES + +$fatpacked{"Capture/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAPTURE_TINY'; + use 5.006; + use strict; + use warnings; + package Capture::Tiny; + # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs + our $VERSION = '0.24'; # VERSION + use Carp (); + use Exporter (); + use IO::Handle (); + use File::Spec (); + use File::Temp qw/tempfile tmpnam/; + use Scalar::Util qw/reftype blessed/; + # Get PerlIO or fake it + BEGIN { + local $@; + eval { require PerlIO; PerlIO->can('get_layers') } + or *PerlIO::get_layers = sub { return () }; + } + + #--------------------------------------------------------------------------# + # create API subroutines and export them + # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] + #--------------------------------------------------------------------------# + + my %api = ( + capture => [1,1,0,0], + capture_stdout => [1,0,0,0], + capture_stderr => [0,1,0,0], + capture_merged => [1,1,1,0], + tee => [1,1,0,1], + tee_stdout => [1,0,0,1], + tee_stderr => [0,1,0,1], + tee_merged => [1,1,1,1], + ); + + for my $sub ( keys %api ) { + my $args = join q{, }, @{$api{$sub}}; + eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic + } + + our @ISA = qw/Exporter/; + our @EXPORT_OK = keys %api; + our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); + + #--------------------------------------------------------------------------# + # constants and fixtures + #--------------------------------------------------------------------------# + + my $IS_WIN32 = $^O eq 'MSWin32'; + + ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; + ## + ##my $DEBUGFH; + ##open $DEBUGFH, "> DEBUG" if $DEBUG; + ## + ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; + + our $TIMEOUT = 30; + + #--------------------------------------------------------------------------# + # command to tee output -- the argument is a filename that must + # be opened to signal that the process is ready to receive input. + # This is annoying, but seems to be the best that can be done + # as a simple, portable IPC technique + #--------------------------------------------------------------------------# + my @cmd = ($^X, '-C0', '-e', <<'HERE'); + use Fcntl; + $SIG{HUP}=sub{exit}; + if ( my $fn=shift ) { + sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; + print {$fh} $$; + close $fh; + } + my $buf; while (sysread(STDIN, $buf, 2048)) { + syswrite(STDOUT, $buf); syswrite(STDERR, $buf); + } + HERE + + #--------------------------------------------------------------------------# + # filehandle manipulation + #--------------------------------------------------------------------------# + + sub _relayer { + my ($fh, $layers) = @_; + # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); + my %seen = ( unix => 1, perlio => 1 ); # filter these out + my @unique = grep { !$seen{$_}++ } @$layers; + # _debug("# applying unique layers (@unique) to @{[fileno $fh]}\n"); + binmode($fh, join(":", ":raw", @unique)); + } + + sub _name { + my $glob = shift; + no strict 'refs'; ## no critic + return *{$glob}{NAME}; + } + + sub _open { + open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; + # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); + } + + sub _close { + # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); + close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; + } + + my %dup; # cache this so STDIN stays fd0 + my %proxy_count; + sub _proxy_std { + my %proxies; + if ( ! defined fileno STDIN ) { + $proxy_count{stdin}++; + if (defined $dup{stdin}) { + _open \*STDIN, "<&=" . fileno($dup{stdin}); + # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); + } + else { + _open \*STDIN, "<" . File::Spec->devnull; + # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); + _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; + } + $proxies{stdin} = \*STDIN; + binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic + } + if ( ! defined fileno STDOUT ) { + $proxy_count{stdout}++; + if (defined $dup{stdout}) { + _open \*STDOUT, ">&=" . fileno($dup{stdout}); + # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); + } + else { + _open \*STDOUT, ">" . File::Spec->devnull; + # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); + _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; + } + $proxies{stdout} = \*STDOUT; + binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic + } + if ( ! defined fileno STDERR ) { + $proxy_count{stderr}++; + if (defined $dup{stderr}) { + _open \*STDERR, ">&=" . fileno($dup{stderr}); + # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); + } + else { + _open \*STDERR, ">" . File::Spec->devnull; + # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); + _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; + } + $proxies{stderr} = \*STDERR; + binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic + } + return %proxies; + } + + sub _unproxy { + my (%proxies) = @_; + # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); + for my $p ( keys %proxies ) { + $proxy_count{$p}--; + # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); + if ( ! $proxy_count{$p} ) { + _close $proxies{$p}; + _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup + delete $dup{$p}; + } + } + } + + sub _copy_std { + my %handles; + for my $h ( qw/stdout stderr stdin/ ) { + next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied + my $redir = $h eq 'stdin' ? "<&" : ">&"; + _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" + } + return \%handles; + } + + # In some cases we open all (prior to forking) and in others we only open + # the output handles (setting up redirection) + sub _open_std { + my ($handles) = @_; + _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; + _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; + _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; + } + + #--------------------------------------------------------------------------# + # private subs + #--------------------------------------------------------------------------# + + sub _start_tee { + my ($which, $stash) = @_; # $which is "stdout" or "stderr" + # setup pipes + $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; + pipe $stash->{reader}{$which}, $stash->{tee}{$which}; + # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); + select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush + # setup desired redirection for parent and child + $stash->{new}{$which} = $stash->{tee}{$which}; + $stash->{child}{$which} = { + stdin => $stash->{reader}{$which}, + stdout => $stash->{old}{$which}, + stderr => $stash->{capture}{$which}, + }; + # flag file is used to signal the child is ready + $stash->{flag_files}{$which} = scalar tmpnam(); + # execute @cmd as a separate process + if ( $IS_WIN32 ) { + local $@; + eval "use Win32API::File qw/CloseHandle GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; + # _debug( "# Win32API::File loaded\n") unless $@; + my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); + # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); + my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); + # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); + _open_std( $stash->{child}{$which} ); + $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); + # not restoring std here as it all gets redirected again shortly anyway + } + else { # use fork + _fork_exec( $which, $stash ); + } + } + + sub _fork_exec { + my ($which, $stash) = @_; # $which is "stdout" or "stderr" + my $pid = fork; + if ( not defined $pid ) { + Carp::confess "Couldn't fork(): $!"; + } + elsif ($pid == 0) { # child + # _debug( "# in child process ...\n" ); + untie *STDIN; untie *STDOUT; untie *STDERR; + _close $stash->{tee}{$which}; + # _debug( "# redirecting handles in child ...\n" ); + _open_std( $stash->{child}{$which} ); + # _debug( "# calling exec on command ...\n" ); + exec @cmd, $stash->{flag_files}{$which}; + } + $stash->{pid}{$which} = $pid + } + + my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; + sub _files_exist { + return 1 if @_ == grep { -f } @_; + Time::HiRes::usleep(1000) if $have_usleep; + return 0; + } + + sub _wait_for_tees { + my ($stash) = @_; + my $start = time; + my @files = values %{$stash->{flag_files}}; + my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} + ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; + 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); + Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); + unlink $_ for @files; + } + + sub _kill_tees { + my ($stash) = @_; + if ( $IS_WIN32 ) { + # _debug( "# closing handles with CloseHandle\n"); + CloseHandle( GetOsFHandle($_) ) for values %{ $stash->{tee} }; + # _debug( "# waiting for subprocesses to finish\n"); + my $start = time; + 1 until wait == -1 || (time - $start > 30); + } + else { + _close $_ for values %{ $stash->{tee} }; + waitpid $_, 0 for values %{ $stash->{pid} }; + } + } + + sub _slurp { + my ($name, $stash) = @_; + my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; + # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); + seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; + my $text = do { local $/; scalar readline $fh }; + return defined($text) ? $text : ""; + } + + #--------------------------------------------------------------------------# + # _capture_tee() -- generic main sub for capturing or teeing + #--------------------------------------------------------------------------# + + sub _capture_tee { + # _debug( "# starting _capture_tee with (@_)...\n" ); + my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; + my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); + Carp::confess("Custom capture options must be given as key/value pairs\n") + unless @opts % 2 == 0; + my $stash = { capture => { @opts } }; + for ( keys %{$stash->{capture}} ) { + my $fh = $stash->{capture}{$_}; + Carp::confess "Custom handle for $_ must be seekable\n" + unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); + } + # save existing filehandles and setup captures + local *CT_ORIG_STDIN = *STDIN ; + local *CT_ORIG_STDOUT = *STDOUT; + local *CT_ORIG_STDERR = *STDERR; + # find initial layers + my %layers = ( + stdin => [PerlIO::get_layers(\*STDIN) ], + stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], + stderr => [PerlIO::get_layers(\*STDERR, output => 1)], + ); + # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # get layers from underlying glob of tied filehandles if we can + # (this only works for things that work like Tie::StdHandle) + $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] + if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); + $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] + if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); + # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # bypass scalar filehandles and tied handles + # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN + my %localize; + $localize{stdin}++, local(*STDIN) + if grep { $_ eq 'scalar' } @{$layers{stdin}}; + $localize{stdout}++, local(*STDOUT) + if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; + $localize{stderr}++, local(*STDERR) + if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; + $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") + if tied *STDIN && $] >= 5.008; + $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") + if $do_stdout && tied *STDOUT && $] >= 5.008; + $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") + if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; + # _debug( "# localized $_\n" ) for keys %localize; + # proxy any closed/localized handles so we don't use fds 0, 1 or 2 + my %proxy_std = _proxy_std(); + # _debug( "# proxy std: @{ [%proxy_std] }\n" ); + # update layers after any proxying + $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; + $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; + # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # store old handles and setup handles for capture + $stash->{old} = _copy_std(); + $stash->{new} = { %{$stash->{old}} }; # default to originals + for ( keys %do ) { + $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); + seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; + $stash->{pos}{$_} = tell $stash->{capture}{$_}; + # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); + _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} + } + _wait_for_tees( $stash ) if $do_tee; + # finalize redirection + $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; + # _debug( "# redirecting in parent ...\n" ); + _open_std( $stash->{new} ); + # execute user provided code + my ($exit_code, $inner_error, $outer_error, @result); + { + local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN + # _debug( "# finalizing layers ...\n" ); + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; + # _debug( "# running code $code ...\n" ); + local $@; + eval { @result = $code->(); $inner_error = $@ }; + $exit_code = $?; # save this for later + $outer_error = $@; # save this for later + } + # restore prior filehandles and shut down tees + # _debug( "# restoring filehandles ...\n" ); + _open_std( $stash->{old} ); + _close( $_ ) for values %{$stash->{old}}; # don't leak fds + # shouldn't need relayering originals, but see rt.perl.org #114404 + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; + _unproxy( %proxy_std ); + # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; + _kill_tees( $stash ) if $do_tee; + # return captured output, but shortcut in void context + # unless we have to echo output to tied/scalar handles; + my %got; + if ( defined wantarray or ($do_tee && keys %localize) ) { + for ( keys %do ) { + _relayer($stash->{capture}{$_}, $layers{$_}); + $got{$_} = _slurp($_, $stash); + # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); + } + print CT_ORIG_STDOUT $got{stdout} + if $do_stdout && $do_tee && $localize{stdout}; + print CT_ORIG_STDERR $got{stderr} + if $do_stderr && $do_tee && $localize{stderr}; + } + $? = $exit_code; + $@ = $inner_error if $inner_error; + die $outer_error if $outer_error; + # _debug( "# ending _capture_tee with (@_)...\n" ); + return unless defined wantarray; + my @return; + push @return, $got{stdout} if $do_stdout; + push @return, $got{stderr} if $do_stderr && ! $do_merge; + push @return, @result; + return wantarray ? @return : $return[0]; + } + + 1; + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs + + =head1 VERSION + + version 0.24 + + =head1 SYNOPSIS + + use Capture::Tiny ':all'; + + # capture from external command + + ($stdout, $stderr, $exit) = capture { + system( $cmd, @args ); + }; + + # capture from arbitrary code (Perl or external) + + ($stdout, $stderr, @result) = capture { + # your code here + }; + + # capture partial or merged output + + $stdout = capture_stdout { ... }; + $stderr = capture_stderr { ... }; + $merged = capture_merged { ... }; + + # tee output + + ($stdout, $stderr) = tee { + # your code here + }; + + $stdout = tee_stdout { ... }; + $stderr = tee_stderr { ... }; + $merged = tee_merged { ... }; + + =head1 DESCRIPTION + + Capture::Tiny provides a simple, portable way to capture almost anything sent + to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or + from an external program. Optionally, output can be teed so that it is + captured while being passed through to the original filehandles. Yes, it even + works on Windows (usually). Stop guessing which of a dozen capturing modules + to use in any particular situation and just use this one. + + =head1 USAGE + + The following functions are available. None are exported by default. + + =head2 capture + + ($stdout, $stderr, @result) = capture \&code; + $stdout = capture \&code; + + The C<<< capture >>> function takes a code reference and returns what is sent to + STDOUT and STDERR as well as any return values from the code reference. In + scalar context, it returns only STDOUT. If no output was received for a + filehandle, it returns an empty string for that filehandle. Regardless of calling + context, all output is captured -- nothing is passed to the existing filehandles. + + It is prototyped to take a subroutine reference as an argument. Thus, it + can be called in block form: + + ($stdout, $stderr) = capture { + # your code here ... + }; + + Note that the coderef is evaluated in list context. If you wish to force + scalar context on the return value, you must use the C<<< scalar >>> keyword. + + ($stdout, $stderr, $count) = capture { + my @list = qw/one two three/; + return scalar @list; # $count will be 3 + }; + + Also note that within the coderef, the C<<< @_ >>> variable will be empty. So don't + use arguments from a surrounding subroutine without copying them to an array + first: + + sub wont_work { + my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG + ... + } + + sub will_work { + my @args = @_; + my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT + ... + } + + Captures are normally done to an anonymous temporary filehandle. To + capture via a named file (e.g. to externally monitor a long-running capture), + provide custom filehandles as a trailing list of option pairs: + + my $out_fh = IO::File->new("out.txt", "w+"); + my $err_fh = IO::File->new("out.txt", "w+"); + capture { ... } stdout => $out_fh, stderr => $err_fh; + + The filehandles must be readEwrite and seekable. Modifying the files or + filehandles during a capture operation will give unpredictable results. + Existing IO layers on them may be changed by the capture. + + When called in void context, C<<< capture >>> saves memory and time by + not reading back from the capture handles. + + =head2 capture_stdout + + ($stdout, @result) = capture_stdout \&code; + $stdout = capture_stdout \&code; + + The C<<< capture_stdout >>> function works just like C<<< capture >>> except only + STDOUT is captured. STDERR is not captured. + + =head2 capture_stderr + + ($stderr, @result) = capture_stderr \&code; + $stderr = capture_stderr \&code; + + The C<<< capture_stderr >>> function works just like C<<< capture >>> except only + STDERR is captured. STDOUT is not captured. + + =head2 capture_merged + + ($merged, @result) = capture_merged \&code; + $merged = capture_merged \&code; + + The C<<< capture_merged >>> function works just like C<<< capture >>> except STDOUT and + STDERR are merged. (Technically, STDERR is redirected to the same capturing + handle as STDOUT before executing the function.) + + Caution: STDOUT and STDERR output in the merged result are not guaranteed to be + properly ordered due to buffering. + + =head2 tee + + ($stdout, $stderr, @result) = tee \&code; + $stdout = tee \&code; + + The C<<< tee >>> function works just like C<<< capture >>>, except that output is captured + as well as passed on to the original STDOUT and STDERR. + + When called in void context, C<<< tee >>> saves memory and time by + not reading back from the capture handles, except when the + original STDOUT OR STDERR were tied or opened to a scalar + handle. + + =head2 tee_stdout + + ($stdout, @result) = tee_stdout \&code; + $stdout = tee_stdout \&code; + + The C<<< tee_stdout >>> function works just like C<<< tee >>> except only + STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). + + =head2 tee_stderr + + ($stderr, @result) = tee_stderr \&code; + $stderr = tee_stderr \&code; + + The C<<< tee_stderr >>> function works just like C<<< tee >>> except only + STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). + + =head2 tee_merged + + ($merged, @result) = tee_merged \&code; + $merged = tee_merged \&code; + + The C<<< tee_merged >>> function works just like C<<< capture_merged >>> except that output + is captured as well as passed on to STDOUT. + + Caution: STDOUT and STDERR output in the merged result are not guaranteed to be + properly ordered due to buffering. + + =head1 LIMITATIONS + + =head2 Portability + + Portability is a goal, not a guarantee. C<<< tee >>> requires fork, except on + Windows where C<<< system(1, @cmd) >>> is used instead. Not tested on any + particularly esoteric platforms yet. See the + L + for test result by platform. + + =head2 PerlIO layers + + Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or + ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to + STDOUT or STDERR I the call to C<<< capture >>> or C<<< tee >>>. This may not work + for tied filehandles (see below). + + =head2 Modifying filehandles before capturing + + Generally speaking, you should do little or no manipulation of the standard IO + filehandles prior to using Capture::Tiny. In particular, closing, reopening, + localizing or tying standard filehandles prior to capture may cause a variety of + unexpected, undesirable andEor unreliable behaviors, as described below. + Capture::Tiny does its best to compensate for these situations, but the + results may not be what you desire. + + B + + Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously + closed. However, since they will be reopened to capture or tee output, any + code within the captured block that depends on finding them closed will, of + course, not find them to be closed. If they started closed, Capture::Tiny will + close them again when the capture block finishes. + + Note that this reopening will happen even for STDIN or a filehandle not being + captured to ensure that the filehandle used for capture is not opened to file + descriptor 0, as this causes problems on various platforms. + + Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles + and also breaks tee() for undiagnosed reasons. So don't do that. + + B + + If code localizes any of Perl's standard filehandles before capturing, the capture + will affect the localized filehandles and not the original ones. External system + calls are not affected by localizing a filehandle in Perl and will continue + to send output to the original filehandles (which will thus not be captured). + + B + + If STDOUT or STDERR are reopened to scalar filehandles prior to the call to + C<<< capture >>> or C<<< tee >>>, then Capture::Tiny will override the output filehandle for + the duration of the C<<< capture >>> or C<<< tee >>> call and then, for C<<< tee >>>, send captured + output to the output filehandle after the capture is complete. (Requires Perl + 5.8) + + Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar + reference, but note that external processes will not be able to read from such + a handle. Capture::Tiny tries to ensure that external processes will read from + the null device instead, but this is not guaranteed. + + B + + If STDOUT or STDERR are tied prior to the call to C<<< capture >>> or C<<< tee >>>, then + Capture::Tiny will attempt to override the tie for the duration of the + C<<< capture >>> or C<<< tee >>> call and then send captured output to the tied filehandle after + the capture is complete. (Requires Perl 5.8) + + Capture::Tiny may not succeed resending UTF-8 encoded data to a tied + STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle + is based on L, then Capture::Tiny will attempt to determine + appropriate layers like C<<< :utf8 >>> from the underlying filehandle and do the right + thing. + + B + + Capture::Tiny attempts to preserve the semantics of tied STDIN, but this + requires Perl 5.8 and is not entirely predictable. External processes + will not be able to read from such a handle. + + Unless having STDIN tied is crucial, it may be safest to localize STDIN when + capturing: + + my ($out, $err) = do { local *STDIN; capture { ... } }; + + =head2 Modifying filehandles during a capture + + Attempting to modify STDIN, STDOUT or STDERR I C<<< capture >>> or C<<< tee >>> is + almost certainly going to cause problems. Don't do that. + + =head2 No support for Perl 5.8.0 + + It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later + is recommended. + + =head2 Limited support for Perl 5.6 + + Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. + + =head1 ENVIRONMENT + + =head2 PERL_CAPTURE_TINY_TIMEOUT + + Capture::Tiny uses subprocesses for C<<< tee >>>. By default, Capture::Tiny will + timeout with an error if the subprocesses are not ready to receive data within + 30 seconds (or whatever is the value of C<<< $Capture::Tiny::TIMEOUT >>>). An + alternate timeout may be specified by setting the C<<< PERL_CAPTURE_TINY_TIMEOUT >>> + environment variable. Setting it to zero will disable timeouts. + + =head1 SEE ALSO + + This module was, inspired by L, which provides + similar functionality without the ability to tee output and with more + complicated code and API. L does not handle layers + or most of the unusual cases described in the L section and + I no longer recommend it. + + There are many other CPAN modules that provide some sort of output capture, + albeit with various limitations that make them appropriate only in particular + circumstances. I'm probably missing some. The long list is provided to show + why I felt Capture::Tiny was necessary. + + =over + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =back + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/dagolden/Capture-Tiny.git + + =head1 AUTHOR + + David Golden + + =head1 CONTRIBUTOR + + Dagfinn Ilmari Mannsåker + + =head1 COPYRIGHT AND LICENSE + + This software is Copyright (c) 2009 by David Golden. + + This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + + =cut +CAPTURE_TINY + +$fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY'; + package lib::core::only; + + use strict; + use warnings FATAL => 'all'; + use Config; + + sub import { + @INC = @Config{qw(privlibexp archlibexp)}; + return + } + + =head1 NAME + + lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs + + =head1 SYNOPSIS + + use lib::core::only; # now @INC contains only the two core directories + + To get only the core directories plus the ones for the local::lib in scope: + + $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl + + To attempt to do a self-contained build (but note this will not reliably + propagate into subprocesses, see the CAVEATS below): + + $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan + + Please note that it is necessary to use C twice for this to work. + First so that C doesn't prevent C from loading + (it's not currently in core) and then again after C so that + the local paths are not removed. + + =head1 DESCRIPTION + + lib::core::only is simply a shortcut to say "please reduce my @INC to only + the core lib and archlib (architecture-specific lib) directories of this perl". + + You might want to do this to ensure a local::lib contains only the code you + need, or to test an L tree, or to avoid known + bad vendor packages. + + You might want to use this to try and install a self-contained tree of perl + modules. Be warned that that probably won't work (see L). + + This module was extracted from L's --self-contained + feature, and contains the only part that ever worked. I apologise to anybody + who thought anything else did. + + =head1 CAVEATS + + This does B propagate properly across perl invocations like local::lib's + stuff does. It can't. It's only a module import, so it B. + + If you want to cascade it across invocations, you can set the PERL5OPT + environment variable to '-Mlib::core::only' and it'll sort of work. But be + aware that taint mode ignores this, so some modules' build and test code + probably will as well. + + You also need to be aware that perl's command line options are not processed + in order - -I options take effect before -M options, so + + perl -Mlib::core::only -Ilib + + is unlike to do what you want - it's exactly equivalent to: + + perl -Mlib::core::only + + If you want to combine a core-only @INC with additional paths, you need to + add the additional paths using -M options and the L module: + + perl -Mlib::core::only -Mlib=lib + + # or if you're trying to test compiled code: + + perl -Mlib::core::only -Mblib + + For more information on the impossibility of sanely propagating this across + module builds without help from the build program, see + L - and for ways + to achieve the old --self-contained feature's results, look at + L's tree function, and at + L's --local-lib-contained feature. + + =head1 AUTHOR + + Matt S. Trout + + =head1 LICENSE + + This library is free software under the same terms as perl itself. + + =head1 COPYRIGHT + + (c) 2010 the lib::core::only L as specified above. + + =cut + + 1; +LIB_CORE_ONLY + +$fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB'; + package local::lib; + use 5.006; + use strict; + use warnings; + use Config; + + our $VERSION = '2.000012'; + $VERSION = eval $VERSION; + + BEGIN { + *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian') + ? sub(){1} : sub(){0}; + # punt on these systems + *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'}) + ? sub(){1} : sub(){0}; + } + our $_DIR_JOIN = _WIN32 ? '\\' : '/'; + our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]} + : qr{/}; + our $_ROOT = _WIN32 ? do { + my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+}; + qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}; + } : qr{^/}; + our $_PERL; + + sub _cwd { + my $drive = shift; + if (!$_PERL) { + ($_PERL) = $^X =~ /(.+)/; # $^X is internal how could it be tainted?! + if (_is_abs($_PERL)) { + } + elsif (-x $Config{perlpath}) { + $_PERL = $Config{perlpath}; + } + else { + ($_PERL) = + map { /(.*)/ } + grep { -x $_ } + map { join($_DIR_JOIN, $_, $_PERL) } + split /\Q$Config{path_sep}\E/, $ENV{PATH}; + } + } + local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; + my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }" + : 'getcwd'; + my $cwd = `"$_PERL" -MCwd -le "print $cmd"`; + chomp $cwd; + if (!length $cwd && $drive) { + $cwd = $drive; + } + $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/; + $cwd; + } + + sub _catdir { + if (_USE_FSPEC) { + require File::Spec; + File::Spec->catdir(@_); + } + else { + my $dir = join($_DIR_JOIN, @_); + $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g; + $dir; + } + } + + sub _is_abs { + if (_USE_FSPEC) { + require File::Spec; + File::Spec->file_name_is_absolute($_[0]); + } + else { + $_[0] =~ $_ROOT; + } + } + + sub _rel2abs { + my ($dir, $base) = @_; + return $dir + if _is_abs($dir); + + $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1") + : $base ? $base + : _cwd; + return _catdir($base, $dir); + } + + sub import { + my ($class, @args) = @_; + push @args, @ARGV + if $0 eq '-'; + + my @steps; + my %opts; + my $shelltype; + + while (@args) { + my $arg = shift @args; + # check for lethal dash first to stop processing before causing problems + # the fancy dash is U+2212 or \xE2\x88\x92 + if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/) { + die <<'DEATH'; + WHOA THERE! It looks like you've got some fancy dashes in your commandline! + These are *not* the traditional -- dashes that software recognizes. You + probably got these by copy-pasting from the perldoc for this module as + rendered by a UTF8-capable formatter. This most typically happens on an OS X + terminal, but can happen elsewhere too. Please try again after replacing the + dashes with normal minus signs. + DEATH + } + elsif ($arg eq '--self-contained') { + die <<'DEATH'; + FATAL: The local::lib --self-contained flag has never worked reliably and the + original author, Mark Stosberg, was unable or unwilling to maintain it. As + such, this flag has been removed from the local::lib codebase in order to + prevent misunderstandings and potentially broken builds. The local::lib authors + recommend that you look at the lib::core::only module shipped with this + distribution in order to create a more robust environment that is equivalent to + what --self-contained provided (although quite possibly not what you originally + thought it provided due to the poor quality of the documentation, for which we + apologise). + DEATH + } + elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) { + my $path = defined $1 ? $1 : shift @args; + push @steps, ['deactivate', $path]; + } + elsif ( $arg eq '--deactivate-all' ) { + push @steps, ['deactivate_all']; + } + elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) { + $shelltype = defined $1 ? $1 : shift @args; + } + elsif ( $arg eq '--no-create' ) { + $opts{no_create} = 1; + } + elsif ( $arg =~ /^--/ ) { + die "Unknown import argument: $arg"; + } + else { + push @steps, ['activate', $arg]; + } + } + if (!@steps) { + push @steps, ['activate', undef]; + } + + my $self = $class->new(%opts); + + for (@steps) { + my ($method, @args) = @$_; + $self = $self->$method(@args); + } + + if ($0 eq '-') { + print $self->environment_vars_string($shelltype); + exit 0; + } + else { + $self->setup_local_lib; + } + } + + sub new { + my $class = shift; + bless {@_}, $class; + } + + sub clone { + my $self = shift; + bless {%$self, @_}, ref $self; + } + + sub inc { $_[0]->{inc} ||= \@INC } + sub libs { $_[0]->{libs} ||= [ \'PERL5LIB' ] } + sub bins { $_[0]->{bins} ||= [ \'PATH' ] } + sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] } + sub extra { $_[0]->{extra} ||= {} } + sub no_create { $_[0]->{no_create} } + + my $_archname = $Config{archname}; + my $_version = $Config{version}; + my @_inc_version_list = reverse split / /, $Config{inc_version_list}; + my $_path_sep = $Config{path_sep}; + + sub _as_list { + my $list = shift; + grep length, map { + !(ref $_ && ref $_ eq 'SCALAR') ? $_ : ( + defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_}) + : () + ) + } ref $list ? @$list : $list; + } + sub _remove_from { + my ($list, @remove) = @_; + return @$list + if !@remove; + my %remove = map { $_ => 1 } @remove; + grep !$remove{$_}, _as_list($list); + } + + my @_lib_subdirs = ( + [$_version, $_archname], + [$_version], + [$_archname], + (@_inc_version_list ? \@_inc_version_list : ()), + [], + ); + + sub install_base_bin_path { + my ($class, $path) = @_; + return _catdir($path, 'bin'); + } + sub install_base_perl_path { + my ($class, $path) = @_; + return _catdir($path, 'lib', 'perl5'); + } + sub install_base_arch_path { + my ($class, $path) = @_; + _catdir($class->install_base_perl_path($path), $_archname); + } + + sub lib_paths_for { + my ($class, $path) = @_; + my $base = $class->install_base_perl_path($path); + return map { _catdir($base, @$_) } @_lib_subdirs; + } + + sub _mm_escape_path { + my $path = shift; + $path =~ s/\\/\\\\\\\\/g; + if ($path =~ s/ /\\ /g) { + $path = qq{"\\"$path\\""}; + } + return $path; + } + + sub _mb_escape_path { + my $path = shift; + $path =~ s/\\/\\\\/g; + return qq{"$path"}; + } + + sub installer_options_for { + my ($class, $path) = @_; + return ( + PERL_MM_OPT => + defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef, + PERL_MB_OPT => + defined $path ? "--install_base "._mb_escape_path($path) : undef, + ); + } + + sub active_paths { + my ($self) = @_; + $self = ref $self ? $self : $self->new; + + return grep { + # screen out entries that aren't actually reflected in @INC + my $active_ll = $self->install_base_perl_path($_); + grep { $_ eq $active_ll } @{$self->inc}; + } _as_list($self->roots); + } + + + 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; + + if (!grep { $_ eq $path } @active_lls) { + warn "Tried to deactivate inactive local::lib '$path'\n"; + return $self; + } + + my %args = ( + bins => [ _remove_from($self->bins, + $self->install_base_bin_path($path)) ], + libs => [ _remove_from($self->libs, + $self->install_base_perl_path($path)) ], + inc => [ _remove_from($self->inc, + $self->lib_paths_for($path)) ], + roots => [ _remove_from($self->roots, $path) ], + ); + + $args{extra} = { $self->installer_options_for($args{roots}[0]) }; + + $self->clone(%args); + } + + sub deactivate_all { + my ($self) = @_; + $self = $self->new unless ref $self; + + my @active_lls = $self->active_paths; + + 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) }; + + $self->clone(%args); + } + + sub activate { + my ($self, $path) = @_; + $self = $self->new unless ref $self; + $path = $self->resolve_path($path); + $self->ensure_dir_structure_for($path) + unless $self->no_create; + + $path = $self->normalize_path($path); + + my @active_lls = $self->active_paths; + + if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) { + $self = $self->deactivate($path); + } + + 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 normalize_path { + my ($self, $path) = @_; + $path = ( Win32::GetShortPathName($path) || $path ) + if $^O eq 'MSWin32'; + return $path; + } + + sub build_environment_vars_for { + my $self = $_[0]->new->activate($_[1]); + $self->build_environment_vars; + } + sub build_activate_environment_vars_for { + my $self = $_[0]->new->activate($_[1]); + $self->build_environment_vars; + } + sub build_deactivate_environment_vars_for { + my $self = $_[0]->new->deactivate($_[1]); + $self->build_environment_vars; + } + sub build_deact_all_environment_vars_for { + my $self = $_[0]->new->deactivate_all; + $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)), + PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)), + %{$self->extra}, + ); + } + + sub setup_local_lib_for { + my $self = $_[0]->new->activate($_[1]); + $self->setup_local_lib; + } + + sub setup_local_lib { + my $self = shift; + + # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid + # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to + # check in the other direction) + require Carp::Heavy if $INC{'Carp.pm'}; + + $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 $key (keys %env) { + if (defined $env{$key}) { + $ENV{$key} = $env{$key}; + } + else { + delete $ENV{$key}; + } + } + } + + sub print_environment_vars_for { + print $_[0]->environment_vars_string_for(@_[1..$#_]); + } + + sub environment_vars_string_for { + my $self = $_[0]->new->activate($_[1]); + $self->environment_vars_string; + } + sub environment_vars_string { + my ($self, $shelltype) = @_; + + $shelltype ||= $self->guess_shelltype; + + my $build_method = "build_${shelltype}_env_declaration"; + + my $extra = $self->extra; + my @envs = ( + PATH => $self->bins, + PERL5LIB => $self->libs, + PERL_LOCAL_LIB_ROOT => $self->roots, + map { $_ => $extra->{$_} } sort keys %$extra, + ); + my $out = ''; + while (@envs) { + my ($name, $value) = (shift(@envs), shift(@envs)); + if ( + ref $value + && @$value == 1 + && ref $value->[0] + && ref $value->[0] eq 'SCALAR' + && ${$value->[0]} eq $name) { + next; + } + $out .= $self->$build_method($name, $value); + } + my $wrap_method = "wrap_${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, '$%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{${name}="$value"; export ${name};\n} + } + + sub build_csh_env_declaration { + my ($class, $name, $args) = @_; + 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, '%%%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:%s', '"', '`%s'); + + if (!$value) { + return qq{Remove-Item -ErrorAction 0 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 build_fish_env_declaration { + my ($class, $name, $args) = @_; + my $value = $class->_interpolate($args, '$%s', qr/[" ]/, '\\%s'); + if (!defined $value) { + return qq{set -e $name;\n}; + } + $value =~ s/$_path_sep/ /g; + qq{set -x $name $value;\n}; + } + + sub _interpolate { + my ($class, $args, $var_pat, $escape, $escape_pat) = @_; + return + unless defined $args; + my @args = ref $args ? @$args : $args; + return + 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; + + sub pipeline { + my @methods = @_; + my $last = pop(@methods); + if (@methods) { + \sub { + my ($obj, @args) = @_; + $obj->${pipeline @methods}( + $obj->$last(@args) + ); + }; + } else { + \sub { + shift->$last(@_); + }; + } + } + + sub resolve_path { + my ($class, $path) = @_; + + $path = $class->${pipeline qw( + resolve_relative_path + resolve_home_path + resolve_empty_path + )}($path); + + $path; + } + + sub resolve_empty_path { + my ($class, $path) = @_; + if (defined $path) { + $path; + } else { + '~/perl5'; + } + } + + sub resolve_home_path { + my ($class, $path) = @_; + $path =~ /^~([^\/]*)/ or return $path; + my $user = $1; + my $homedir = do { + if (! length($user) && defined $ENV{HOME}) { + $ENV{HOME}; + } + else { + require File::Glob; + File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE()); + } + }; + unless (defined $homedir) { + require Carp; require Carp::Heavy; + Carp::croak( + "Couldn't resolve homedir for " + .(defined $user ? $user : 'current user') + ); + } + $path =~ s/^~[^\/]*/$homedir/; + $path; + } + + sub resolve_relative_path { + my ($class, $path) = @_; + _rel2abs($path); + } + + sub ensure_dir_structure_for { + my ($class, $path) = @_; + unless (-d $path) { + warn "Attempting to create directory ${path}\n"; + } + require File::Basename; + my @dirs; + while(!-d $path) { + push @dirs, $path; + $path = File::Basename::dirname($path); + } + mkdir $_ for reverse @dirs; + return; + } + + sub guess_shelltype { + my $shellbin + = defined $ENV{SHELL} + ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1] + : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} ) + ? 'bash' + : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} ) + ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1] + : ( $^O eq 'MSWin32' && !$ENV{PROMPT} ) + ? 'powershell.exe' + : 'sh'; + + for ($shellbin) { + return + /csh$/ ? 'csh' + : /fish/ ? 'fish' + : /command(?:\.com)?$/i ? 'cmd' + : /cmd(?:\.exe)?$/i ? 'cmd' + : /4nt(?:\.exe)?$/i ? 'cmd' + : /powershell(?:\.exe)?$/i ? 'powershell' + : 'bourne'; + } + } + + 1; + __END__ + + =encoding utf8 + + =head1 NAME + + local::lib - create and use a local lib/ for perl modules with PERL5LIB + + =head1 SYNOPSIS + + In code - + + use local::lib; # sets up a local lib at ~/perl5 + + use local::lib '~/foo'; # same, but ~/foo + + # Or... + use FindBin; + use local::lib "$FindBin::Bin/../support"; # app-local support library + + From the shell - + + # Install LWP and its missing dependencies to the '~/perl5' directory + perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' + + # Just print out useful shell commands + $ perl -Mlocal::lib + PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT; + PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT; + PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB; + PATH="/home/username/perl5/bin:$PATH"; export PATH; + PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT; + + From a .bashrc file - + + [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)" + + =head2 The bootstrapping technique + + A typical way to install local::lib is using what is known as the + "bootstrapping" technique. You would do this if your system administrator + hasn't already installed local::lib. In this case, you'll need to install + local::lib in your home directory. + + Even if you do have administrative privileges, you will still want to set up your + environment variables, as discussed in step 4. Without this, you would still + install the modules into the system CPAN installation and also your Perl scripts + will not use the lib/ path you bootstrapped with local::lib. + + By default local::lib installs itself and the CPAN modules into ~/perl5. + + Windows users must also see L. + + =over 4 + + =item 1. + + Download and unpack the local::lib tarball from CPAN (search for "Download" + on the CPAN page about local::lib). Do this as an ordinary user, not as root + or administrator. Unpack the file in your home directory or in any other + convenient location. + + =item 2. + + Run this: + + perl Makefile.PL --bootstrap + + If the system asks you whether it should automatically configure as much + as possible, you would typically answer yes. + + In order to install local::lib into a directory other than the default, you need + to specify the name of the directory when you call bootstrap, as follows: + + perl Makefile.PL --bootstrap=~/foo + + =item 3. + + Run this: (local::lib assumes you have make installed on your system) + + make test && make install + + =item 4. + + Now we need to setup the appropriate environment variables, so that Perl + starts using our newly generated lib/ directory. If you are using bash or + any other Bourne shells, you can add this to your shell startup script this + way: + + echo '[ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"' >>~/.bashrc + + If you are using C shell, you can do this as follows: + + /bin/csh + echo $SHELL + /bin/csh + 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 + way: + + echo '[ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc + + After writing your shell configuration file, be sure to re-read it to get the + changed settings into your current shell's environment. Bourne shells use + C<. ~/.bashrc> for this, whereas C shells use C. + + =back + + If you're on a slower machine, or are operating under draconian disk space + limitations, you can disable the automatic generation of manpages from POD when + installing modules by using the C<--no-manpages> argument when bootstrapping: + + perl Makefile.PL --bootstrap --no-manpages + + To avoid doing several bootstrap for several Perl module environments on the + same account, for example if you use it for several different deployed + applications independently, you can use one bootstrapped local::lib + installation to install modules in different directories directly this way: + + cd ~/mydir1 + perl -Mlocal::lib=./ + eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone + printenv ### You will see that ~/mydir1 is in the PERL5LIB + perl -MCPAN -e install ... ### whatever modules you want + cd ../mydir2 + ... REPEAT ... + + When used in a C<.bashrc> file, it is recommended that you protect against + re-activating a directory in a sub-shell. This can be done by checking the + C<$SHLVL> variable as shown in synopsis. Without this, sub-shells created by + the user or other programs will override changes made to the parent shell's + environment. + + If you are working with several C environments, you may want to + remove some of them from the current environment without disturbing the others. + You can deactivate one environment like this (using bourne sh): + + eval $(perl -Mlocal::lib=--deactivate,~/path) + + which will generate and run the commands needed to remove C<~/path> from your + various search paths. Whichever environment was B will + remain the target for module installations. That is, if you activate + C<~/path_A> and then you activate C<~/path_B>, new modules you install will go + in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed + into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be + installed in C<~/pathB> because pathB was activated later. + + You can also ask C to clean itself completely out of the current + shell's environment with the C<--deactivate-all> option. + For multiple environments for multiple apps you may need to include a modified + version of the C<< use FindBin >> instructions in the "In code" sample above. + If you did something like the above, you have a set of Perl modules at C<< + ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, + you need to tell it where to find the modules you installed for it at C<< + ~/mydir1/lib >>. + + In C<< ~/mydir1/scripts/myscript.pl >>: + + use strict; + use warnings; + use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib + use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib + + Put this before any BEGIN { ... } blocks that require the modules you installed. + + =head2 Differences when using this module under Win32 + + To set up the proper environment variables for your current session of + C, you can use this: + + C:\>perl -Mlocal::lib + set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 + set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 + set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5 + 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%\tmp.bat + ### instead of $(perl -Mlocal::lib=./) + + 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. + + The "~" is translated to the user's profile directory (the directory named for + the user under "Documents and Settings" (Windows XP or earlier) or "Users" + (Windows Vista or later)) unless $ENV{HOME} exists. After that, the home + 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 can be used with the + C cmdlet. + + Invoke-Expression "$(perl -Mlocal::lib)" + + =head1 RATIONALE + + The version of a Perl package on your machine is not always the version you + need. Obviously, the best thing to do would be to update to the version you + need. However, you might be in a situation where you're prevented from doing + this. Perhaps you don't have system administrator privileges; or perhaps you + are using a package management system such as Debian, and nobody has yet gotten + around to packaging up the version you need. + + local::lib solves this problem by allowing you to create your own directory of + Perl packages downloaded from CPAN (in a multi-user system, this would typically + be within your own home directory). The existing system Perl installation is + not affected; you simply invoke Perl with special options so that Perl uses the + packages in your own local package directory rather than the system packages. + local::lib arranges things so that your locally installed version of the Perl + packages takes precedence over the system installation. + + If you are using a package management system (such as Debian), you don't need to + worry about Debian and CPAN stepping on each other's toes. Your local version + of the packages will be written to an entirely separate directory from those + installed by Debian. + + =head1 DESCRIPTION + + This module provides a quick, convenient way of bootstrapping a user-local Perl + module library located within the user's home directory. It also constructs and + prints out for the user the list of environment variables using the syntax + appropriate for the user's current shell (as specified by the C + environment variable), suitable for directly adding to one's shell + configuration file. + + More generally, local::lib allows for the bootstrapping and usage of a + directory containing Perl modules outside of Perl's C<@INC>. This makes it + easier to ship an application with an app-specific copy of a Perl module, or + collection of modules. Useful in cases like when an upstream maintainer hasn't + applied a patch to a module of theirs that you need for your application. + + On import, local::lib sets the following environment variables to appropriate + values: + + =over 4 + + =item PERL_MB_OPT + + =item PERL_MM_OPT + + =item PERL5LIB + + =item PATH + + =item PERL_LOCAL_LIB_ROOT + + =back + + When possible, these will be appended to instead of overwritten entirely. + + These values are then available for reference by any code after import. + + =head1 CREATING A SELF-CONTAINED SET OF MODULES + + See L for one way to do this - but note that + there are a number of caveats, and the best approach is always to perform a + build against a clean perl (i.e. site and vendor as close to empty as possible). + + =head1 IMPORT OPTIONS + + Options are values that can be passed to the C import besides the + directory to use. They are specified as C + or C. + + =head2 --deactivate + + Remove the chosen path (or the default path) from the module search paths if it + was added by C, instead of adding it. + + =head2 --deactivate-all + + 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 CLASS METHODS + + =head2 ensure_dir_structure_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Attempts to create the given path, and all required parent directories. Throws + an exception on failure. + + =head2 print_environment_vars_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Prints to standard output the variables listed above, properly set to use the + given path as the base directory. + + =head2 build_environment_vars_for + + =over 4 + + =item Arguments: $path + + =item Return value: %environment_vars + + =back + + Returns a hash with the variables listed above, properly set to use the + given path as the base directory. + + =head2 setup_env_hash_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + 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 and verified against + what is really in C<@INC>. + + =head2 install_base_perl_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_perl_path + + =back + + Returns a path describing where to install the Perl modules for this local + library installation. Appends the directories C and C to the given + path. + + =head2 lib_paths_for + + =over 4 + + =item Arguments: $path + + =item Return value: @lib_paths + + =back + + Returns the list of paths perl will search for libraries, given a base path. + This includes the base path itself, the architecture specific subdirectory, and + perl version specific subdirectories. These paths may not all exist. + + =head2 install_base_bin_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_bin_path + + =back + + Returns a path describing where to install the executable programs for this + local library installation. Appends the directory C to the given path. + + =head2 installer_options_for + + =over 4 + + =item Arguments: $path + + =item Return value: %installer_env_vars + + =back + + Returns a hash of environment variables that should be set to cause + installation into the given path. + + =head2 resolve_empty_path + + =over 4 + + =item Arguments: $path + + =item Return value: $base_path + + =back + + Builds and returns the base path into which to set up the local module + installation. Defaults to C<~/perl5>. + + =head2 resolve_home_path + + =over 4 + + =item Arguments: $path + + =item Return value: $home_path + + =back + + Attempts to find the user's home directory. If installed, uses C + for this purpose. If no definite answer is available, throws an exception. + + =head2 resolve_relative_path + + =over 4 + + =item Arguments: $path + + =item Return value: $absolute_path + + =back + + Translates the given path into an absolute path. + + =head2 resolve_path + + =over 4 + + =item Arguments: $path + + =item Return value: $absolute_path + + =back + + Calls the following in a pipeline, passing the result from the previous to the + next, in an attempt to find where to configure the environment for a local + library installation: L, L, + L. Passes the given path argument to + L which then returns a result that is passed to + L, which then has its result passed to + L. The result of this final call is returned from + L. + + =head1 OBJECT INTERFACE + + =head2 new + + =over 4 + + =item Arguments: %attributes + + =item Return value: $local_lib + + =back + + Constructs a new C object, representing the current state of + C<@INC> and the relevant environment variables. + + =head1 ATTRIBUTES + + =head2 roots + + An arrayref representing active C directories. + + =head2 inc + + An arrayref representing C<@INC>. + + =head2 libs + + An arrayref representing the PERL5LIB environment variable. + + =head2 bins + + An arrayref representing the PATH environment variable. + + =head2 extra + + A hashref of extra environment variables (e.g. C and + C) + + =head2 no_create + + If set, C will not try to create directories when activating them. + + =head1 OBJECT METHODS + + =head2 clone + + =over 4 + + =item Arguments: %attributes + + =item Return value: $local_lib + + =back + + Constructs a new C object based on the existing one, overriding the + specified attributes. + + =head2 activate + + =over 4 + + =item Arguments: $path + + =item Return value: $new_local_lib + + =back + + Constructs a new instance with the specified path active. + + =head2 deactivate + + =over 4 + + =item Arguments: $path + + =item Return value: $new_local_lib - case off - __perlbrew_deactivate - echo "perlbrew is turned off." + =back - case switch-off - __perlbrew_deactivate - __perlbrew_reinit - echo "perlbrew is switched off." + Constructs a new instance with the specified path deactivated. - case '*' - command perlbrew $argv - end - end + =head2 deactivate_all - function __source_init - perl -pe's/^export/set -x/; s/=/ /; s/$/;/;' "$PERLBREW_HOME/init" | . - - end + =over 4 - if test -z "$PERLBREW_ROOT" - set -x PERLBREW_ROOT "$HOME/perl5/perlbrew" - end + =item Arguments: None - if test -z "$PERLBREW_HOME" - set -x PERLBREW_HOME "$HOME/.perlbrew" - end + =item Return value: $new_local_lib - if test -z "$PERLBREW_SKIP_INIT" -a -f "$PERLBREW_HOME/init" - __source_init - end + =back - set perlbrew_bin_path "$PERLBREW_ROOT/bin" + Constructs a new instance with all C directories deactivated. - if test -f "$perlbrew_bin_path/perlbrew" - set perlbrew_command "$perlbrew_bin_path/perlbrew" - else - set perlbrew_command perlbrew - end + =head2 environment_vars_string - set -e perlbrew_bin_path + =over 4 - __perlbrew_activate + =item Arguments: [ $shelltype ] - ## autocomplete stuff ############################################# + =item Return value: $shell_env_string - function __fish_perlbrew_needs_command - set cmd (commandline -opc) - if test (count $cmd) -eq 1 -a $cmd[1] = 'perlbrew' - return 0 - end - return 1 - end + =back - function __fish_perlbrew_using_command - set cmd (commandline -opc) - if test (count $cmd) -gt 1 - if [ $argv[1] = $cmd[2] ] - return 0 - end - end - end + Returns a string to set up the C, meant to be run by a shell. - for com in (perlbrew help | perl -ne'print lc if s/^COMMAND:\s+//') - complete -f -c perlbrew -n '__fish_perlbrew_needs_command' -a $com - end + =head2 build_environment_vars - for com in switch use; - complete -f -c perlbrew -n "__fish_perlbrew_using_command $com" \ - -a '(perlbrew list | perl -pe\'s/\*?\s*(\S+).*/$1/\')' - end + =over 4 - END - set perlbrew_exit_status=0 + =item Arguments: None - if ( $1 =~ -* ) then - set perlbrew_short_option=$1 - shift - else - set perlbrew_short_option="" - endif + =item Return value: %environment_vars - switch ( $1 ) - case use: - if ( $%2 == 0 ) then - if ( $?PERLBREW_PERL == 0 ) then - echo "Currently using system perl" - else - if ( $%PERLBREW_PERL == 0 ) then - echo "Currently using system perl" - else - echo "Currently using $PERLBREW_PERL" - endif - endif - else - set perlbrew_line_count=0 - foreach perlbrew_line ( "`\perlbrew env $2`" ) - eval $perlbrew_line - @ perlbrew_line_count++ - end - if ( $perlbrew_line_count == 0 ) then - set perlbrew_exit_status=1 - else - source "$PERLBREW_ROOT/etc/csh_set_path" - endif - endif - breaksw + =back - case switch: - if ( $%2 == 0 ) then - \perlbrew switch - else - perlbrew use $2 && source $PERLBREW_ROOT/etc/csh_reinit $2 - endif - breaksw + Returns a hash with the variables listed above, properly set to use the + given path as the base directory. - case off: - unsetenv PERLBREW_PERL - foreach perlbrew_line ( "`\perlbrew env`" ) - eval $perlbrew_line - end - source $PERLBREW_ROOT/etc/csh_set_path - echo "perlbrew is turned off." - breaksw + =head2 setup_env_hash - case switch-off: - unsetenv PERLBREW_PERL - source $PERLBREW_ROOT/etc/csh_reinit '' - echo "perlbrew is switched off." - breaksw + =over 4 - default: - \perlbrew $perlbrew_short_option $argv - set perlbrew_exit_status=$? - breaksw - endsw - rehash - exit $perlbrew_exit_status - WRAPPER - if ( ! -d "$PERLBREW_HOME" ) then - mkdir -p "$PERLBREW_HOME" - endif + =item Arguments: None - echo '# DO NOT EDIT THIS FILE' >! "$PERLBREW_HOME/init" - \perlbrew env $1 >> "$PERLBREW_HOME/init" - source "$PERLBREW_HOME/init" - source "$PERLBREW_ROOT/etc/csh_set_path" - REINIT - unalias perl + =item Return value: None - if ( $?PERLBREW_PATH == 0 ) then - setenv PERLBREW_PATH "$PERLBREW_ROOT/bin" - endif + =back - setenv PATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,$ENV{PATH};'` - setenv PATH ${PERLBREW_PATH}:${PATH_WITHOUT_PERLBREW} + Constructs the C<%ENV> keys for the given path, by calling + L. - setenv MANPATH_WITHOUT_PERLBREW `perl -e 'print join ":", grep { index($_, $ENV{PERLBREW_ROOT}) } split/:/,qx(manpath 2> /dev/null);'` - if ( $?PERLBREW_MANPATH == 1 ) then - setenv MANPATH ${PERLBREW_MANPATH}:${MANPATH_WITHOUT_PERLBREW} - else - setenv MANPATH ${MANPATH_WITHOUT_PERLBREW} - endif - SETPATH + =head2 setup_local_lib - if ( $?PERLBREW_HOME == 0 ) then - setenv PERLBREW_HOME "$HOME/.perlbrew" - endif + Constructs the C<%ENV> hash using L, and set up C<@INC>. - if ( $?PERLBREW_ROOT == 0 ) then - setenv PERLBREW_ROOT "$HOME/perl5/perlbrew" - endif + =head1 A WARNING ABOUT UNINST=1 - if ( $?PERLBREW_SKIP_INIT == 0 ) then - if ( -f "$PERLBREW_HOME/init" ) then - source "$PERLBREW_HOME/init" - endif - endif + Be careful about using local::lib in combination with "make install UNINST=1". + The idea of this feature is that will uninstall an old version of a module + before installing a new one. However it lacks a safety check that the old + version and the new version will go in the same directory. Used in combination + with local::lib, you can potentially delete a globally accessible version of a + module while installing the new version in a local place. Only combine "make + install UNINST=1" and local::lib if you understand these possible consequences. - if ( $?PERLBREW_PATH == 0 ) then - setenv PERLBREW_PATH "$PERLBREW_ROOT/bin" - endif + =head1 LIMITATIONS - source "$PERLBREW_ROOT/etc/csh_set_path" - alias perlbrew 'source $PERLBREW_ROOT/etc/csh_wrapper' - CSHRC - Installation process failed. To spot any issues, check + =over 4 - $self->{log_file} + =item * Directory names with spaces in them are not well supported by the perl + toolchain and the programs it uses. Pure-perl distributions should support + spaces, but problems are more likely with dists that require compilation. A + workaround you can do is moving your local::lib to a directory with spaces + B you installed all modules inside your local::lib bootstrap. But be + aware that you can't update or install CPAN modules after the move. - If some perl tests failed and you still want install this distribution anyway, - do: + =item * Rather basic shell detection. Right now anything with csh in its name is + assumed to be a C shell or something compatible, and everything else is assumed + to be Bourne, except on Win32 systems. If the C environment variable is + not set, a Bourne-compatible shell is assumed. - (cd $self->{dist_extracted_dir}; make install) + =item * Kills any existing PERL_MM_OPT or PERL_MB_OPT. - You might also want to try upgrading patchperl before trying again: + =item * Should probably auto-fixup CPAN config if not already done. - perlbrew install-patchperl + =item * On VMS and MacOS Classic (pre-OS X), local::lib loads L. + This means any L version installed in the local::lib will be + ignored by scripts using local::lib. A workaround for this is using + C instead of using C directly. - Generally, if you need to install a perl distribution known to have minor test - failures, do one of these command to avoid seeing this message + =item * Conflicts with L's C option. + C uses the C option, as it has more predictable and + sane behavior. If something attempts to use the C option when running + a F, L will refuse to run, as the two + options conflict. This can be worked around by temporarily unsetting the + C environment variable. - perlbrew --notest install $self->{dist_name} - perlbrew --force install $self->{dist_name} + =item * Conflicts with L's C<--prefix> option. Similar to the + previous limitation, but any C<--prefix> option specified will be ignored. + This can be worked around by temporarily unsetting the C + environment variable. - FAIL -APP_PERLBREW - -$fatpacked{"CPAN/Perl/Releases.pm"} = <<'CPAN_PERL_RELEASES'; - package CPAN::Perl::Releases;$CPAN::Perl::Releases::VERSION='1.74';use strict;use warnings;use vars qw[@ISA @EXPORT_OK];use Exporter;@ISA=qw(Exporter);@EXPORT_OK=qw(perl_tarballs perl_versions perl_pumpkins);our$cache={};our$data={"5.003_07"=>{id=>'ANDYD' },"5.004"=>{id=>'CHIPS' },"5.004_01"=>{id=>'TIMB' },"5.004_02"=>{id=>'TIMB' },"5.004_03"=>{id=>'TIMB' },"5.004_04"=>{id=>'TIMB' },"5.004_05"=>{id=>'CHIPS' },"5.005"=>{id=>'GSAR' },"5.005_01"=>{id=>'GSAR' },"5.005_02"=>{id=>'GSAR' },"5.005_03"=>{id=>'GBARR' },"5.005_04"=>{id=>'LBROCARD' },"5.6.0"=>{id=>'GSAR' },"5.6.1-TRIAL1"=>{id=>'GSAR' },"5.6.1-TRIAL2"=>{id=>'GSAR' },"5.6.1-TRIAL3"=>{id=>'GSAR' },"5.6.1"=>{id=>'GSAR' },"5.6.2"=>{id=>'RGARCIA' },"5.7.0"=>{id=>'JHI' },"5.7.1"=>{id=>'JHI' },"5.7.2"=>{id=>'JHI' },"5.7.3"=>{id=>'JHI' },"5.8.0"=>{id=>'JHI' },"5.8.1"=>{id=>'JHI' },"5.8.2"=>{id=>'NWCLARK' },"5.8.3"=>{id=>'NWCLARK' },"5.8.4"=>{id=>'NWCLARK' },"5.8.5"=>{id=>'NWCLARK' },"5.8.6"=>{id=>'NWCLARK' },"5.8.7"=>{id=>'NWCLARK' },"5.8.8"=>{id=>'NWCLARK' },"5.8.9"=>{id=>'NWCLARK' },"5.9.0"=>{id=>'HVDS' },"5.9.1"=>{id=>'RGARCIA' },"5.9.2"=>{id=>'RGARCIA' },"5.9.3"=>{id=>'RGARCIA' },"5.9.4"=>{id=>'RGARCIA' },"5.9.5"=>{id=>'RGARCIA' },"5.10.0"=>{id=>'RGARCIA' },"5.10.1"=>{id=>'DAPM' },"5.11.0"=>{id=>'JESSE' },"5.11.1"=>{id=>'JESSE' },"5.11.2"=>{id=>'LBROCARD' },"5.11.3"=>{id=>'JESSE' },"5.11.4"=>{id=>'RJBS' },"5.11.5"=>{id=>'SHAY' },"5.12.0"=>{id=>'JESSE' },"5.12.1"=>{id=>'JESSE' },"5.12.2"=>{id=>'JESSE' },"5.12.3"=>{id=>'RJBS' },"5.12.4"=>{id=>'LBROCARD' },"5.12.5"=>{id=>'DOM' },"5.13.0"=>{id=>'LBROCARD' },"5.13.1"=>{id=>'RJBS' },"5.13.2"=>{id=>'MSTROUT' },"5.13.3"=>{id=>'DAGOLDEN' },"5.13.4"=>{id=>'FLORA' },"5.13.5"=>{id=>'SHAY' },"5.13.6"=>{id=>'MIYAGAWA' },"5.13.7"=>{id=>'BINGOS' },"5.13.8"=>{id=>'ZEFRAM' },"5.13.9"=>{id=>'JESSE' },"5.13.10"=>{id=>'AVAR' },"5.13.11"=>{id=>'FLORA' },"5.14.0"=>{id=>'JESSE' },"5.14.1"=>{id=>'JESSE' },"5.14.2-RC1"=>{id=>'FLORA' },"5.14.2"=>{id=>'FLORA' },"5.14.3"=>{id=>'DOM' },"5.14.4-RC1"=>{id=>'DAPM' },"5.14.4-RC2"=>{id=>'DAPM' },"5.14.4"=>{id=>'DAPM' },"5.15.0"=>{id=>'DAGOLDEN' },"5.15.1"=>{id=>'ZEFRAM' },"5.15.2"=>{id=>'RJBS' },"5.15.3"=>{id=>'STEVAN' },"5.15.4"=>{id=>'FLORA' },"5.15.5"=>{id=>'SHAY' },"5.15.6"=>{id=>'DROLSKY' },"5.15.7"=>{id=>'BINGOS' },"5.15.8"=>{id=>'CORION' },"5.15.9"=>{id=>'ABIGAIL' },"5.16.0"=>{id=>'RJBS' },"5.16.1"=>{id=>'RJBS' },"5.16.2"=>{id=>'RJBS' },"5.16.3"=>{id=>'RJBS' },"5.17.0"=>{id=>'ZEFRAM' },"5.17.1"=>{id=>'DOY' },"5.17.2"=>{id=>'TONYC' },"5.17.3"=>{id=>'SHAY' },"5.17.4"=>{id=>'FLORA' },"5.17.5"=>{id=>'FLORA' },"5.17.6"=>{id=>'RJBS' },"5.17.7"=>{id=>'DROLSKY' },"5.17.8"=>{id=>'ARC' },"5.17.9"=>{id=>'BINGOS' },"5.17.10"=>{id=>'CORION' },"5.17.11"=>{id=>'RJBS' },"5.18.0-RC1"=>{id=>'RJBS' },"5.18.0-RC2"=>{id=>'RJBS' },"5.18.0-RC3"=>{id=>'RJBS' },"5.18.0-RC4"=>{id=>'RJBS' },"5.18.0"=>{id=>'RJBS' },"5.18.1-RC1"=>{id=>'RJBS' },"5.18.1-RC2"=>{id=>'RJBS' },"5.18.1-RC3"=>{id=>'RJBS' },"5.18.1"=>{id=>'RJBS' },"5.19.0"=>{id=>'RJBS' },"5.19.1"=>{id=>'DAGOLDEN' },"5.19.2"=>{id=>'ARISTOTLE' },"5.19.3"=>{id=>'SHAY' },"5.19.4"=>{id=>'SHAY' },"5.19.5"=>{id=>'SHAY' },"5.19.6"=>{id=>'BINGOS' },"5.18.2-RC1"=>{id=>'RJBS' },"5.18.2-RC2"=>{id=>'RJBS' },"5.18.2-RC3"=>{id=>'RJBS' },"5.19.7"=>{id=>'ABIGAIL' },"5.18.2-RC4"=>{id=>'RJBS' },"5.18.2"=>{id=>'RJBS' },"5.19.8"=>{id=>'RJBS' },"5.19.9"=>{id=>'TONYC' },"5.19.10"=>{id=>'ARC' },"5.19.11"=>{id=>'SHAY' },"5.20.0-RC1"=>{id=>'RJBS' },"5.20.0"=>{id=>'RJBS' },"5.21.0"=>{id=>'RJBS' },};sub perl_tarballs {my$vers=shift;$vers=shift if eval {$vers->isa(__PACKAGE__)};return unless exists$data->{$vers };if (exists$cache->{$vers }){return {%{$cache->{$vers }}}}my$pumpkin=$data->{$vers }->{id};my$path=join '/',substr($pumpkin,0,1),substr($pumpkin,0,2),$pumpkin;my$sep=($vers =~ m!^5\.0! ? '' : '-');my$perl=join$sep,'perl',$vers;my$onlygz=1 if$vers =~ m!(?-xism:5.(?:00(?:4(?:_0[12345])?|5(?:_0[1234])?|3_07)|1(?:0.0(?:-RC[12])?|6.0-RC0)|6.(?:[02]|1(?:-TRIAL[123])?)|9.[12345]|7.[0123]|8.[01]))! || $data->{$vers }->{onlygz};my$onlybz2=1 if$data->{$vers }->{onlybz2};my$foo={};$foo->{'tar.gz'}="$path/$perl.tar.gz" unless$onlybz2;$foo->{'tar.bz2'}="$path/$perl.tar.bz2" unless$onlygz;$cache->{$vers }=$foo;return {%$foo }}sub perl_versions {return sort _by_version keys %$data}sub _by_version {my%v=map {my@v=split(qr/[-._]0*/,$_);$v[2]||=0;$v[3]||='Z';($_=>sprintf '%d.%03d%03d-%s',@v)}$a,$b;$v{$a}cmp $v{$b}}sub perl_pumpkins {my%pumps=map {($data->{$_}->{id}=>1)}keys %$data;return sort keys%pumps}q|Acme::Why::Did::I::Not::Read::The::Fecking::Memo|; -CPAN_PERL_RELEASES - -$fatpacked{"Capture/Tiny.pm"} = <<'CAPTURE_TINY'; - use 5.006;use strict;use warnings;package Capture::Tiny;our$VERSION='0.24';use Carp ();use Exporter ();use IO::Handle ();use File::Spec ();use File::Temp qw/tempfile tmpnam/;use Scalar::Util qw/reftype blessed/;BEGIN {local $@;eval {require PerlIO;PerlIO->can('get_layers')}or *PerlIO::get_layers=sub {return ()}}my%api=(capture=>[1,1,0,0],capture_stdout=>[1,0,0,0],capture_stderr=>[0,1,0,0],capture_merged=>[1,1,1,0],tee=>[1,1,0,1],tee_stdout=>[1,0,0,1],tee_stderr=>[0,1,0,1],tee_merged=>[1,1,1,1],);for my$sub (keys%api){my$args=join q{, },@{$api{$sub}};eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"}our@ISA=qw/Exporter/;our@EXPORT_OK=keys%api;our%EXPORT_TAGS=('all'=>\@EXPORT_OK);my$IS_WIN32=$^O eq 'MSWin32';our$TIMEOUT=30;my@cmd=($^X,'-C0','-e',<<'HERE');sub _relayer {my ($fh,$layers)=@_;my%seen=(unix=>1,perlio=>1);my@unique=grep {!$seen{$_}++}@$layers;binmode($fh,join(":",":raw",@unique))}sub _name {my$glob=shift;no strict 'refs';return *{$glob}{NAME}}sub _open {open $_[0],$_[1]or Carp::confess "Error from open(" .join(q{, },@_)."): $!"}sub _close {close $_[0]or Carp::confess "Error from close(" .join(q{, },@_)."): $!"}my%dup;my%proxy_count;sub _proxy_std {my%proxies;if (!defined fileno STDIN){$proxy_count{stdin}++;if (defined$dup{stdin}){_open \*STDIN,"<&=" .fileno($dup{stdin})}else {_open \*STDIN,"<" .File::Spec->devnull;_open$dup{stdin}=IO::Handle->new,"<&=STDIN"}$proxies{stdin}=\*STDIN;binmode(STDIN,':utf8')if $] >= 5.008}if (!defined fileno STDOUT){$proxy_count{stdout}++;if (defined$dup{stdout}){_open \*STDOUT,">&=" .fileno($dup{stdout})}else {_open \*STDOUT,">" .File::Spec->devnull;_open$dup{stdout}=IO::Handle->new,">&=STDOUT"}$proxies{stdout}=\*STDOUT;binmode(STDOUT,':utf8')if $] >= 5.008}if (!defined fileno STDERR){$proxy_count{stderr}++;if (defined$dup{stderr}){_open \*STDERR,">&=" .fileno($dup{stderr})}else {_open \*STDERR,">" .File::Spec->devnull;_open$dup{stderr}=IO::Handle->new,">&=STDERR"}$proxies{stderr}=\*STDERR;binmode(STDERR,':utf8')if $] >= 5.008}return%proxies}sub _unproxy {my (%proxies)=@_;for my$p (keys%proxies){$proxy_count{$p}--;if (!$proxy_count{$p}){_close$proxies{$p};_close$dup{$p}unless $] < 5.008;delete$dup{$p}}}}sub _copy_std {my%handles;for my$h (qw/stdout stderr stdin/){next if$h eq 'stdin' &&!$IS_WIN32;my$redir=$h eq 'stdin' ? "<&" : ">&";_open$handles{$h}=IO::Handle->new(),$redir .uc($h)}return \%handles}sub _open_std {my ($handles)=@_;_open \*STDIN,"<&" .fileno$handles->{stdin}if defined$handles->{stdin};_open \*STDOUT,">&" .fileno$handles->{stdout}if defined$handles->{stdout};_open \*STDERR,">&" .fileno$handles->{stderr}if defined$handles->{stderr}}sub _start_tee {my ($which,$stash)=@_;$stash->{$_}{$which}=IO::Handle->new for qw/tee reader/;pipe$stash->{reader}{$which},$stash->{tee}{$which};select((select($stash->{tee}{$which}),$|=1)[0]);$stash->{new}{$which}=$stash->{tee}{$which};$stash->{child}{$which}={stdin=>$stash->{reader}{$which},stdout=>$stash->{old}{$which},stderr=>$stash->{capture}{$which},};$stash->{flag_files}{$which}=scalar tmpnam();if ($IS_WIN32){local $@;eval "use Win32API::File qw/CloseHandle GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";my$os_fhandle=GetOsFHandle($stash->{tee}{$which});my$result=SetHandleInformation($os_fhandle,HANDLE_FLAG_INHERIT(),0);_open_std($stash->{child}{$which});$stash->{pid}{$which}=system(1,@cmd,$stash->{flag_files}{$which})}else {_fork_exec($which,$stash)}}sub _fork_exec {my ($which,$stash)=@_;my$pid=fork;if (not defined$pid){Carp::confess "Couldn't fork(): $!"}elsif ($pid==0){untie*STDIN;untie*STDOUT;untie*STDERR;_close$stash->{tee}{$which};_open_std($stash->{child}{$which});exec@cmd,$stash->{flag_files}{$which}}$stash->{pid}{$which}=$pid}my$have_usleep=eval "use Time::HiRes 'usleep'; 1";sub _files_exist {return 1 if @_==grep {-f}@_;Time::HiRes::usleep(1000)if$have_usleep;return 0}sub _wait_for_tees {my ($stash)=@_;my$start=time;my@files=values %{$stash->{flag_files}};my$timeout=defined$ENV{PERL_CAPTURE_TINY_TIMEOUT}? $ENV{PERL_CAPTURE_TINY_TIMEOUT}: $TIMEOUT;1 until _files_exist(@files)|| ($timeout && (time - $start > $timeout));Carp::confess "Timed out waiting for subprocesses to start" if!_files_exist(@files);unlink $_ for@files}sub _kill_tees {my ($stash)=@_;if ($IS_WIN32){CloseHandle(GetOsFHandle($_))for values %{$stash->{tee}};my$start=time;1 until wait==-1 || (time - $start > 30)}else {_close $_ for values %{$stash->{tee}};waitpid $_,0 for values %{$stash->{pid}}}}sub _slurp {my ($name,$stash)=@_;my ($fh,$pos)=map {$stash->{$_}{$name}}qw/capture pos/;seek($fh,$pos,0)or die "Couldn't seek on capture handle for $name\n";my$text=do {local $/;scalar readline$fh};return defined($text)? $text : ""}sub _capture_tee {my ($do_stdout,$do_stderr,$do_merge,$do_tee,$code,@opts)=@_;my%do=($do_stdout ? (stdout=>1): (),$do_stderr ? (stderr=>1): ());Carp::confess("Custom capture options must be given as key/value pairs\n")unless@opts % 2==0;my$stash={capture=>{@opts }};for (keys %{$stash->{capture}}){my$fh=$stash->{capture}{$_};Carp::confess "Custom handle for $_ must be seekable\n" unless ref($fh)eq 'GLOB' || (blessed($fh)&& $fh->isa("IO::Seekable"))}local*CT_ORIG_STDIN=*STDIN ;local*CT_ORIG_STDOUT=*STDOUT;local*CT_ORIG_STDERR=*STDERR;my%layers=(stdin=>[PerlIO::get_layers(\*STDIN)],stdout=>[PerlIO::get_layers(\*STDOUT,output=>1)],stderr=>[PerlIO::get_layers(\*STDERR,output=>1)],);$layers{stdout}=[PerlIO::get_layers(tied*STDOUT)]if tied(*STDOUT)&& (reftype tied*STDOUT eq 'GLOB');$layers{stderr}=[PerlIO::get_layers(tied*STDERR)]if tied(*STDERR)&& (reftype tied*STDERR eq 'GLOB');my%localize;$localize{stdin}++,local(*STDIN)if grep {$_ eq 'scalar'}@{$layers{stdin}};$localize{stdout}++,local(*STDOUT)if$do_stdout && grep {$_ eq 'scalar'}@{$layers{stdout}};$localize{stderr}++,local(*STDERR)if ($do_stderr || $do_merge)&& grep {$_ eq 'scalar'}@{$layers{stderr}};$localize{stdin}++,local(*STDIN),_open(\*STDIN,"<&=0")if tied*STDIN && $] >= 5.008;$localize{stdout}++,local(*STDOUT),_open(\*STDOUT,">&=1")if$do_stdout && tied*STDOUT && $] >= 5.008;$localize{stderr}++,local(*STDERR),_open(\*STDERR,">&=2")if ($do_stderr || $do_merge)&& tied*STDERR && $] >= 5.008;my%proxy_std=_proxy_std();$layers{stdout}=[PerlIO::get_layers(\*STDOUT,output=>1)]if$proxy_std{stdout};$layers{stderr}=[PerlIO::get_layers(\*STDERR,output=>1)]if$proxy_std{stderr};$stash->{old}=_copy_std();$stash->{new}={%{$stash->{old}}};for (keys%do){$stash->{new}{$_}=($stash->{capture}{$_}||=File::Temp->new);seek($stash->{capture}{$_},0,2)or die "Could not seek on capture handle for $_\n";$stash->{pos}{$_}=tell$stash->{capture}{$_};_start_tee($_=>$stash)if$do_tee}_wait_for_tees($stash)if$do_tee;$stash->{new}{stderr}=$stash->{new}{stdout}if$do_merge;_open_std($stash->{new});my ($exit_code,$inner_error,$outer_error,@result);{local*STDIN=*CT_ORIG_STDIN if$localize{stdin};_relayer(\*STDOUT,$layers{stdout})if$do_stdout;_relayer(\*STDERR,$layers{stderr})if$do_stderr;local $@;eval {@result=$code->();$inner_error=$@};$exit_code=$?;$outer_error=$@}_open_std($stash->{old});_close($_)for values %{$stash->{old}};_relayer(\*STDOUT,$layers{stdout})if$do_stdout;_relayer(\*STDERR,$layers{stderr})if$do_stderr;_unproxy(%proxy_std);_kill_tees($stash)if$do_tee;my%got;if (defined wantarray or ($do_tee && keys%localize)){for (keys%do){_relayer($stash->{capture}{$_},$layers{$_});$got{$_}=_slurp($_,$stash)}print CT_ORIG_STDOUT$got{stdout}if$do_stdout && $do_tee && $localize{stdout};print CT_ORIG_STDERR$got{stderr}if$do_stderr && $do_tee && $localize{stderr}}$?=$exit_code;$@=$inner_error if$inner_error;die$outer_error if$outer_error;return unless defined wantarray;my@return;push@return,$got{stdout}if$do_stdout;push@return,$got{stderr}if$do_stderr &&!$do_merge;push@return,@result;return wantarray ? @return : $return[0]}1; - use Fcntl; - $SIG{HUP}=sub{exit}; - if ( my $fn=shift ) { - sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; - print {$fh} $$; - close $fh; - } - my $buf; while (sysread(STDIN, $buf, 2048)) { - syswrite(STDOUT, $buf); syswrite(STDERR, $buf); - } - HERE -CAPTURE_TINY - -$fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY'; - package lib::core::only;use strict;use warnings FATAL=>'all';use Config;sub import {@INC=@Config{qw(privlibexp archlibexp)};return}1; -LIB_CORE_ONLY - -$fatpacked{"local/lib.pm"} = <<'LOCAL_LIB'; - package local::lib;use 5.006;use strict;use warnings;use Config;our$VERSION='2.000012';$VERSION=eval$VERSION;BEGIN {*_WIN32=($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')? sub(){1}: sub(){0};*_USE_FSPEC=($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})? sub(){1}: sub(){0}}our$_DIR_JOIN=_WIN32 ? '\\' : '/';our$_DIR_SPLIT=(_WIN32 || $^O eq 'cygwin')? qr{[\\/]} : qr{/};our$_ROOT=_WIN32 ? do {my$UNC=qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}}: qr{^/};our$_PERL;sub _cwd {my$drive=shift;if (!$_PERL){($_PERL)=$^X =~ /(.+)/;if (_is_abs($_PERL)){}elsif (-x $Config{perlpath}){$_PERL=$Config{perlpath}}else {($_PERL)=map {/(.*)/}grep {-x $_}map {join($_DIR_JOIN,$_,$_PERL)}split /\Q$Config{path_sep}\E/,$ENV{PATH}}}local@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};my$cmd=$drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd';my$cwd=`"$_PERL" -MCwd -le "print $cmd"`;chomp$cwd;if (!length$cwd && $drive){$cwd=$drive}$cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;$cwd}sub _catdir {if (_USE_FSPEC){require File::Spec;File::Spec->catdir(@_)}else {my$dir=join($_DIR_JOIN,@_);$dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;$dir}}sub _is_abs {if (_USE_FSPEC){require File::Spec;File::Spec->file_name_is_absolute($_[0])}else {$_[0]=~ $_ROOT}}sub _rel2abs {my ($dir,$base)=@_;return$dir if _is_abs($dir);$base=_WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1"): $base ? $base : _cwd;return _catdir($base,$dir)}sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||=\@INC}sub libs {$_[0]->{libs}||=[\'PERL5LIB' ]}sub bins {$_[0]->{bins}||=[\'PATH' ]}sub roots {$_[0]->{roots}||=[\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||={}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return _catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return _catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;_catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {_catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"\\"$path\\""}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}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;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;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)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}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 normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_activate_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_deactivate_environment_vars_for {my$self=$_[0]->new->deactivate($_[1]);$self->build_environment_vars}sub build_deact_all_environment_vars_for {my$self=$_[0]->new->deactivate_all;$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)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;require Carp::Heavy if$INC{'Carp.pm'};$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$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||=$self->guess_shelltype;my$build_method="build_${shelltype}_env_declaration";my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${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,'$%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{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;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,'%%%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:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 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 build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s',qr/[" ]/,'\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return 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;sub pipeline {my@methods=@_;my$last=pop(@methods);if (@methods){\sub {my ($obj,@args)=@_;$obj->${pipeline@methods}($obj->$last(@args))}}else {\sub {shift->$last(@_)}}}sub resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;require Carp::Heavy;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;_rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}1; - WHOA THERE! It looks like you've got some fancy dashes in your commandline! - These are *not* the traditional -- dashes that software recognizes. You - probably got these by copy-pasting from the perldoc for this module as - rendered by a UTF8-capable formatter. This most typically happens on an OS X - terminal, but can happen elsewhere too. Please try again after replacing the - dashes with normal minus signs. - DEATH - FATAL: The local::lib --self-contained flag has never worked reliably and the - original author, Mark Stosberg, was unable or unwilling to maintain it. As - such, this flag has been removed from the local::lib codebase in order to - prevent misunderstandings and potentially broken builds. The local::lib authors - recommend that you look at the lib::core::only module shipped with this - distribution in order to create a more robust environment that is equivalent to - what --self-contained provided (although quite possibly not what you originally - thought it provided due to the poor quality of the documentation, for which we - apologise). - DEATH + =back + + Patches very much welcome for any of the above. + + =over 4 + + =item * On Win32 systems, does not have a way to write the created environment + variables to the registry, so that they can persist through a reboot. + + =back + + =head1 TROUBLESHOOTING + + If you've configured local::lib to install CPAN modules somewhere in to your + home directory, and at some point later you try to install a module with C, but it fails with an error like: C and buried within the install log is an + error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then + you've somehow lost your updated ExtUtils::MakeMaker module. + + To remedy this situation, rerun the bootstrapping procedure documented above. + + Then, run C + + Finally, re-run C and it should install without problems. + + =head1 ENVIRONMENT + + =over 4 + + =item SHELL + + =item COMSPEC + + local::lib looks at the user's C environment variable when printing out + commands to add to the shell configuration file. + + On Win32 systems, C is also examined. + + =back + + =head1 SEE ALSO + + =over 4 + + =item * L + + =back + + =head1 SUPPORT + + IRC: + + Join #local-lib on irc.perl.org. + + =head1 AUTHOR + + Matt S Trout http://www.shadowcat.co.uk/ + + auto_install fixes kindly sponsored by http://www.takkle.com/ + + =head1 CONTRIBUTORS + + Patches to correctly output commands for csh style shells, as well as some + documentation additions, contributed by Christopher Nehren . + + Doc patches for a custom local::lib directory, more cleanups in the english + documentation and a L contributed by + Torsten Raudssus . + + Hans Dieter Pearcey sent in some additional tests for ensuring + things will install properly, submitted a fix for the bug causing problems with + writing Makefiles during bootstrapping, contributed an example program, and + submitted yet another fix to ensure that local::lib can install and bootstrap + properly. Many, many thanks! + + pattern of Freenode IRC contributed the beginnings of the Troubleshooting + section. Many thanks! + + Patch to add Win32 support contributed by Curtis Jewell . + + Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced + by a patch from Marco Emilio Poleggi. + + Mark Stosberg provided the code for the now deleted + '--self-contained' option. + + Documentation patches to make win32 usage clearer by + David Mertens (run4flat). + + Brazilian L and minor doc + patches contributed by Breno 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 + . + + Rewrite of internals and numerous bug fixes and added features contributed by + Graham Knop . + + =head1 COPYRIGHT + + Copyright (c) 2007 - 2013 the local::lib L and L as + listed above. + + =head1 LICENSE + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut LOCAL_LIB s/^ //mg for values %fatpacked; -unshift @INC, sub { - if (my $fat = $fatpacked{$_[1]}) { - if ($] < 5.008) { - return sub { - return 0 unless length $fat; - $fat =~ s/^([^\n]*\n?)//; - $_ = $1; - return 1; - }; +my $class = 'FatPacked::'.(0+\%fatpacked); +no strict 'refs'; +*{"${class}::files"} = sub { keys %{$_[0]} }; + +if ($] < 5.008) { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + return sub { + return 0 unless length $fat; + $fat =~ s/^([^\n]*\n?)//; + $_ = $1; + return 1; + }; + } + return; + }; +} + +else { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + open my $fh, '<', \$fat + or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; + return $fh; } - open my $fh, '<', \$fat - or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; - return $fh; - } - return -}; + return; + }; +} -} # END OF FATPACK CODE +unshift @INC, bless \%fatpacked, $class; + } # END OF FATPACK CODE #!/usr/bin/perl use strict;