Permalink
Fetching contributors…
Cannot retrieve contributors at this time
executable file 1214 lines (1000 sloc) 28.5 KB
#!/usr/bin/env perl
# DO NOT EDIT -- this is an auto generated file
package HTTP::Lite;
use 5.005;
use strict;
use Socket 1.3;
use Fcntl;
use Errno qw(EAGAIN);
use vars qw($VERSION);
BEGIN {
$VERSION = "2.2";
}
my $BLOCKSIZE = 65536;
my $CRLF = "\r\n";
my $URLENCODE_VALID = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-.";
# Forward declarations
sub prepare_post;
sub http_write;
sub http_readline;
sub http_read;
sub http_readbytes;
# Prepare the urlencode validchars lookup hash
my @urlencode_valid;
foreach my $char (split('', $URLENCODE_VALID)) {
$urlencode_valid[ord $char]=$char;
}
for (my $n=0;$n<255;$n++) {
if (!defined($urlencode_valid[$n])) {
$urlencode_valid[$n]=sprintf("%%%02X", $n);
}
}
sub new
{
my $self = {};
bless $self;
$self->initialize();
return $self;
}
sub initialize
{
my $self = shift;
$self->reset;
$self->{timeout} = 120;
$self->{HTTP11} = 0;
$self->{DEBUG} = 0;
$self->{header_at_once} = 0;
$self->{holdback} = 0; # needed for http_write
}
sub header_at_once
{
my $self=shift;
$self->{header_at_once} = 1;
}
sub local_addr
{
my $self = shift;
my $val = shift;
my $oldval = $self->{'local_addr'};
if (defined($val)) {
$self->{'local_addr'} = $val;
}
return $oldval;
}
sub local_port
{
my $self = shift;
my $val = shift;
my $oldval = $self->{'local_port'};
if (defined($val)) {
$self->{'local_port'} = $val;
}
return $oldval;
}
sub method
{
my $self = shift;
my $method = shift;
$method = uc($method);
$self->{method} = $method;
}
sub DEBUG
{
my $self = shift;
if ($self->{DEBUG}) {
print STDERR join(" ", @_),"\n";
}
}
sub reset
{
my $self = shift;
foreach my $var ("body", "request", "content", "status", "proxy",
"proxyport", "resp-protocol", "error-message",
"resp-headers", "CBARGS", "callback_function", "callback_params")
{
$self->{$var} = undef;
}
$self->{HTTPReadBuffer} = "";
$self->{method} = "GET";
$self->{headers} = { 'user-agent' => "HTTP::Lite/$VERSION" };
$self->{headermap} = { 'user-agent' => 'User-Agent' };
}
# URL-encode data
sub escape {
my $toencode = shift;
return join('',
map { $urlencode_valid[ord $_] } split('', $toencode));
}
sub set_callback {
my ($self, $callback, @callbackparams) = @_;
$self->{'callback_function'} = $callback;
$self->{'callback_params'} = [ @callbackparams ];
}
sub request
{
my ($self, $url, $data_callback, $cbargs) = @_;
my $method = $self->{method};
if (defined($cbargs)) {
$self->{CBARGS} = $cbargs;
}
my $callback_func = $self->{'callback_function'};
my $callback_params = $self->{'callback_params'};
# Parse URL
my ($protocol,$host,$junk,$port,$object) =
$url =~ m{^([^:/]+)://([^/:]*)(:(\d+))?(/.*)$};
# Only HTTP is supported here
if ($protocol ne "http")
{
warn "Only http is supported by HTTP::Lite";
return undef;
}
# Setup the connection
my $proto = getprotobyname('tcp');
local *FH;
socket(FH, PF_INET, SOCK_STREAM, $proto);
$port = 80 if !$port;
my $connecthost = $self->{'proxy'} || $host;
$connecthost = $connecthost ? $connecthost : $host;
my $connectport = $self->{'proxyport'} || $port;
$connectport = $connectport ? $connectport : $port;
my $addr = inet_aton($connecthost);
if (!$addr) {
close(FH);
return undef;
}
if ($connecthost ne $host)
{
# if proxy active, use full URL as object to request
$object = "$url";
}
# choose local port and address
my $local_addr = INADDR_ANY;
my $local_port = "0";
if (defined($self->{'local_addr'})) {
$local_addr = $self->{'local_addr'};
if ($local_addr eq "0.0.0.0" || $local_addr eq "0") {
$local_addr = INADDR_ANY;
} else {
$local_addr = inet_aton($local_addr);
}
}
if (defined($self->{'local_port'})) {
$local_port = $self->{'local_port'};
}
my $paddr = pack_sockaddr_in($local_port, $local_addr);
bind(FH, $paddr) || return undef; # Failing to bind is fatal.
my $sin = sockaddr_in($connectport,$addr);
connect(FH, $sin) || return undef;
# Set nonblocking IO on the handle to allow timeouts
if ( $^O ne "MSWin32" ) {
fcntl(FH, F_SETFL, O_NONBLOCK);
}
if (defined($callback_func)) {
&$callback_func($self, "connect", undef, @$callback_params);
}
if ($self->{header_at_once}) {
$self->{holdback} = 1; # http_write should buffer only, no sending yet
}
# Start the request (HTTP/1.1 mode)
if ($self->{HTTP11}) {
$self->http_write(*FH, "$method $object HTTP/1.1$CRLF");
} else {
$self->http_write(*FH, "$method $object HTTP/1.0$CRLF");
}
# Add some required headers
# we only support a single transaction per request in this version.
$self->add_req_header("Connection", "close");
if ($port != 80) {
$self->add_req_header("Host", "$host:$port");
} else {
$self->add_req_header("Host", $host);
}
if (!defined($self->get_req_header("Accept"))) {
$self->add_req_header("Accept", "*/*");
}
if ($method eq 'POST') {
$self->http_write(*FH, "Content-Type: application/x-www-form-urlencoded$CRLF");
}
# Purge a couple others
$self->delete_req_header("Content-Type");
$self->delete_req_header("Content-Length");
# Output headers
foreach my $header ($self->enum_req_headers())
{
my $value = $self->get_req_header($header);
$self->http_write(*FH, $self->{headermap}{$header}.": ".$value."$CRLF");
}
my $content_length;
if (defined($self->{content}))
{
$content_length = length($self->{content});
}
if (defined($callback_func)) {
my $ncontent_length = &$callback_func($self, "content-length", undef, @$callback_params);
if (defined($ncontent_length)) {
$content_length = $ncontent_length;
}
}
if ($content_length) {
$self->http_write(*FH, "Content-Length: $content_length$CRLF");
}
if (defined($callback_func)) {
&$callback_func($self, "done-headers", undef, @$callback_params);
}
# End of headers
$self->http_write(*FH, "$CRLF");
if ($self->{header_at_once}) {
$self->{holdback} = 0;
$self->http_write(*FH, ""); # pseudocall to get http_write going
}
my $content_out = 0;
if (defined($callback_func)) {
while (my $content = &$callback_func($self, "content", undef, @$callback_params)) {
$self->http_write(*FH, $content);
$content_out++;
}
}
# Output content, if any
if (!$content_out && defined($self->{content}))
{
$self->http_write(*FH, $self->{content});
}
if (defined($callback_func)) {
&$callback_func($self, "content-done", undef, @$callback_params);
}
# Read response from server
my $headmode=1;
my $chunkmode=0;
my $chunksize=0;
my $chunklength=0;
my $chunk;
my $line = 0;
my $data;
while ($data = $self->http_read(*FH,$headmode,$chunkmode,$chunksize))
{
$self->{DEBUG} && $self->DEBUG("reading: $chunkmode, $chunksize, $chunklength, $headmode, ".
length($self->{'body'}));
if ($self->{DEBUG}) {
foreach my $var ("body", "request", "content", "status", "proxy",
"proxyport", "resp-protocol", "error-message",
"resp-headers", "CBARGS", "HTTPReadBuffer")
{
$self->DEBUG("state $var ".length($self->{$var}));
}
}
$line++;
if ($line == 1)
{
my ($proto,$status,$message) = split(' ', $$data, 3);
$self->{DEBUG} && $self->DEBUG("header $$data");
$self->{status}=$status;
$self->{'resp-protocol'}=$proto;
$self->{'error-message'}=$message;
next;
}
if (($headmode || $chunkmode eq "entity-header") && $$data =~ /^[\r\n]*$/)
{
if ($chunkmode)
{
$chunkmode = 0;
}
$headmode = 0;
# Check for Transfer-Encoding
my $te = $self->get_header("Transfer-Encoding");
if (defined($te)) {
my $header = join(' ',@{$te});
if ($header =~ /chunked/i)
{
$chunkmode = "chunksize";
}
}
next;
}
if ($headmode || $chunkmode eq "entity-header")
{
my ($var,$datastr) = $$data =~ /^([^:]*):\s*(.*)$/;
if (defined($var))
{
$datastr =~s/[\r\n]$//g;
$var = lc($var);
$var =~ s/^(.)/&upper($1)/ge;
$var =~ s/(-.)/&upper($1)/ge;
my $hr = ${$self->{'resp-headers'}}{$var};
if (!ref($hr))
{
$hr = [ $datastr ];
}
else
{
push @{ $hr }, $datastr;
}
${$self->{'resp-headers'}}{$var} = $hr;
}
} elsif ($chunkmode)
{
if ($chunkmode eq "chunksize")
{
$chunksize = $$data;
$chunksize =~ s/^\s*|;.*$//g;
$chunksize =~ s/\s*$//g;
my $cshx = $chunksize;
if (length($chunksize) > 0) {
# read another line
if ($chunksize !~ /^[a-f0-9]+$/i) {
$self->{DEBUG} && $self->DEBUG("chunksize not a hex string");
}
$chunksize = hex($chunksize);
$self->{DEBUG} && $self->DEBUG("chunksize was $chunksize (HEX was $cshx)");
if ($chunksize == 0)
{
$chunkmode = "entity-header";
} else {
$chunkmode = "chunk";
$chunklength = 0;
}
} else {
$self->{DEBUG} && $self->DEBUG("chunksize empty string, checking next line!");
}
} elsif ($chunkmode eq "chunk")
{
$chunk .= $$data;
$chunklength += length($$data);
if ($chunklength >= $chunksize)
{
$chunkmode = "chunksize";
if ($chunklength > $chunksize)
{
$chunk = substr($chunk,0,$chunksize);
}
elsif ($chunklength == $chunksize && $chunk !~ /$CRLF$/)
{
# chunk data is exactly chunksize -- need CRLF still
$chunkmode = "ignorecrlf";
}
$self->add_to_body(\$chunk, $data_callback);
$chunk="";
$chunklength = 0;
$chunksize = "";
}
} elsif ($chunkmode eq "ignorecrlf")
{
$chunkmode = "chunksize";
}
} else {
$self->add_to_body($data, $data_callback);
}
}
if (defined($callback_func)) {
&$callback_func($self, "done", undef, @$callback_params);
}
close(FH);
return $self->{status};
}
sub add_to_body
{
my $self = shift;
my ($dataref, $data_callback) = @_;
my $callback_func = $self->{'callback_function'};
my $callback_params = $self->{'callback_params'};
if (!defined($data_callback) && !defined($callback_func)) {
$self->{DEBUG} && $self->DEBUG("no callback");
$self->{'body'}.=$$dataref;
} else {
my $newdata;
if (defined($callback_func)) {
$newdata = &$callback_func($self, "data", $dataref, @$callback_params);
} else {
$newdata = &$data_callback($self, $dataref, $self->{CBARGS});
}
if ($self->{DEBUG}) {
$self->DEBUG("callback got back a ".ref($newdata));
if (ref($newdata) eq "SCALAR") {
$self->DEBUG("callback got back ".length($$newdata)." bytes");
}
}
if (defined($newdata) && ref($newdata) eq "SCALAR") {
$self->{'body'} .= $$newdata;
}
}
}
sub add_req_header
{
my $self = shift;
my ($header, $value) = @_;
my $lcheader = lc($header);
$self->{DEBUG} && $self->DEBUG("add_req_header $header $value");
${$self->{headers}}{$lcheader} = $value;
${$self->{headermap}}{$lcheader} = $header;
}
sub get_req_header
{
my $self = shift;
my ($header) = @_;
return $self->{headers}{lc($header)};
}
sub delete_req_header
{
my $self = shift;
my ($header) = @_;
my $exists;
if ($exists=defined(${$self->{headers}}{lc($header)}))
{
delete ${$self->{headers}}{lc($header)};
delete ${$self->{headermap}}{lc($header)};
}
return $exists;
}
sub enum_req_headers
{
my $self = shift;
my ($header) = @_;
my $exists;
return keys %{$self->{headermap}};
}
sub body
{
my $self = shift;
return $self->{'body'};
}
sub status
{
my $self = shift;
return $self->{status};
}
sub protocol
{
my $self = shift;
return $self->{'resp-protocol'};
}
sub status_message
{
my $self = shift;
return $self->{'error-message'};
}
sub proxy
{
my $self = shift;
my ($value) = @_;
# Parse URL
my ($protocol,$host,$junk,$port,$object) =
$value =~ m{^(\S+)://([^/:]*)(:(\d+))?(/.*)$};
if (!$host)
{
($host,$port) = $value =~ /^([^:]+):(.*)$/;
}
$self->{'proxy'} = $host || $value;
$self->{'proxyport'} = $port || 80;
}
sub headers_array
{
my $self = shift;
my @array = ();
foreach my $header (keys %{$self->{'resp-headers'}})
{
my $aref = ${$self->{'resp-headers'}}{$header};
foreach my $value (@$aref)
{
push @array, "$header: $value";
}
}
return @array;
}
sub headers_string
{
my $self = shift;
my $string = "";
foreach my $header (keys %{$self->{'resp-headers'}})
{
my $aref = ${$self->{'resp-headers'}}{$header};
foreach my $value (@$aref)
{
$string .= "$header: $value\n";
}
}
return $string;
}
sub get_header
{
my $self = shift;
my $header = shift;
return $self->{'resp-headers'}{$header};
}
sub http11_mode
{
my $self = shift;
my $mode = shift;
$self->{HTTP11} = $mode;
}
sub prepare_post
{
my $self = shift;
my $varref = shift;
my $body = "";
while (my ($var,$value) = map { escape($_) } each %$varref)
{
if ($body)
{
$body .= "&$var=$value";
} else {
$body = "$var=$value";
}
}
$self->{content} = $body;
$self->{headers}{'Content-Type'} = "application/x-www-form-urlencoded"
unless defined ($self->{headers}{'Content-Type'}) and
$self->{headers}{'Content-Type'};
$self->{method} = "POST";
}
sub http_write
{
my $self = shift;
my ($fh,$line) = @_;
if ($self->{holdback}) {
$self->{HTTPWriteBuffer} .= $line;
return;
} else {
if (defined $self->{HTTPWriteBuffer}) { # copy previously buffered, if any
$line = $self->{HTTPWriteBuffer} . $line;
}
}
my $size = length($line);
my $bytes = syswrite($fh, $line, length($line) , 0 ); # please double check new length limit
# is this ok?
while ( ($size - $bytes) > 0) {
$bytes += syswrite($fh, $line, length($line)-$bytes, $bytes ); # also here
}
}
sub http_read
{
my $self = shift;
my ($fh,$headmode,$chunkmode,$chunksize) = @_;
$self->{DEBUG} && $self->DEBUG("read handle=$fh, headm=$headmode, chunkm=$chunkmode, chunksize=$chunksize");
my $res;
if (($headmode == 0 && $chunkmode eq "0") || ($chunkmode eq "chunk")) {
my $bytes_to_read = $chunkmode eq "chunk" ?
($chunksize < $BLOCKSIZE ? $chunksize : $BLOCKSIZE) :
$BLOCKSIZE;
$res = $self->http_readbytes($fh,$self->{timeout},$bytes_to_read);
} else {
$res = $self->http_readline($fh,$self->{timeout});
}
if ($res) {
if ($self->{DEBUG}) {
$self->DEBUG("read got ".length($$res)." bytes");
my $str = $$res;
$str =~ s{([\x00-\x1F\x7F-\xFF])}{.}g;
$self->DEBUG("read: ".$str);
}
}
return $res;
}
sub http_readline
{
my $self = shift;
my ($fh, $timeout) = @_;
my $EOL = "\n";
$self->{DEBUG} && $self->DEBUG("readline handle=$fh, timeout=$timeout");
# is there a line in the buffer yet?
while ($self->{HTTPReadBuffer} !~ /$EOL/)
{
# nope -- wait for incoming data
my ($inbuf,$bits,$chars) = ("","",0);
vec($bits,fileno($fh),1)=1;
my $nfound = select($bits, undef, $bits, $timeout);
if ($nfound == 0)
{
# Timed out
return undef;
} else {
# Get the data
$chars = sysread($fh, $inbuf, $BLOCKSIZE);
$self->{DEBUG} && $self->DEBUG("sysread $chars bytes");
}
# End of stream?
if ($chars <= 0 && !$!{EAGAIN})
{
last;
}
# tag data onto end of buffer
$self->{HTTPReadBuffer}.=$inbuf;
}
# get a single line from the buffer
my $nlat = index($self->{HTTPReadBuffer}, $EOL);
my $newline;
my $oldline;
if ($nlat > -1)
{
$newline = substr($self->{HTTPReadBuffer},0,$nlat+1);
$oldline = substr($self->{HTTPReadBuffer},$nlat+1);
} else {
$newline = substr($self->{HTTPReadBuffer},0);
$oldline = "";
}
# and update the buffer
$self->{HTTPReadBuffer}=$oldline;
return length($newline) ? \$newline : 0;
}
sub http_readbytes
{
my $self = shift;
my ($fh, $timeout, $bytes) = @_;
my $EOL = "\n";
$self->{DEBUG} && $self->DEBUG("readbytes handle=$fh, timeout=$timeout, bytes=$bytes");
# is there enough data in the buffer yet?
while (length($self->{HTTPReadBuffer}) < $bytes)
{
# nope -- wait for incoming data
my ($inbuf,$bits,$chars) = ("","",0);
vec($bits,fileno($fh),1)=1;
my $nfound = select($bits, undef, $bits, $timeout);
if ($nfound == 0)
{
# Timed out
return undef;
} else {
# Get the data
$chars = sysread($fh, $inbuf, $BLOCKSIZE);
$self->{DEBUG} && $self->DEBUG("sysread $chars bytes");
}
# End of stream?
if ($chars <= 0 && !$!{EAGAIN})
{
last;
}
# tag data onto end of buffer
$self->{HTTPReadBuffer}.=$inbuf;
}
my $newline;
my $buflen;
if (($buflen=length($self->{HTTPReadBuffer})) >= $bytes)
{
$newline = substr($self->{HTTPReadBuffer},0,$bytes+1);
if ($bytes+1 < $buflen) {
$self->{HTTPReadBuffer} = substr($self->{HTTPReadBuffer},$bytes+1);
} else {
$self->{HTTPReadBuffer} = "";
}
} else {
$newline = substr($self->{HTTPReadBuffer},0);
$self->{HTTPReadBuffer} = "";
}
return length($newline) ? \$newline : 0;
}
sub upper
{
my ($str) = @_;
if (defined($str)) {
return uc($str);
} else {
return undef;
}
}
1;
$INC{'HTTP/Lite.pm'} = __FILE__;
package App::perlbrew;
use strict;
use 5.8.0;
our $VERSION = "0.07";
my $ROOT = $ENV{PERLBREW_ROOT} || "$ENV{HOME}/perl5/perlbrew";
my $CURRENT_PERL = "$ROOT/perls/current";
sub run_command {
my ( undef, $opt, $x, @args ) = @_;
$opt->{log_file} = "$ROOT/build.log";
my $self = bless $opt, __PACKAGE__;
$x ||= "help";
my $s = $self->can("run_command_$x") or die "Unknown command: `$x`. Typo?";
$self->$s(@args);
}
sub run_command_help {
print <<HELP;
perlbrew - $VERSION
Usage:
# Read more help
perlbrew -h
perlbrew init
perlbrew install perl-5.12.1
perlbrew install perl-5.13.0
perlbrew installed
perlbrew switch perl-5.12.1
perlbrew switch /usr/bin/perl
perlbrew off
HELP
}
sub run_command_init {
require File::Path;
File::Path::mkpath($_) for (
"$ROOT/perls", "$ROOT/dists", "$ROOT/build", "$ROOT/etc",
"$ROOT/bin"
);
system <<RC;
echo 'export PATH=$ROOT/bin:$ROOT/perls/current/bin:\${PATH}' > $ROOT/etc/bashrc
echo 'setenv PATH $ROOT/bin:$ROOT/perls/current/bin:\$PATH' > $ROOT/etc/cshrc
RC
my ( $shrc, $yourshrc );
if ( $ENV{SHELL} =~ /(t?csh)/ ) {
$shrc = 'cshrc';
$yourshrc = $1 . "rc";
}
else {
$shrc = $yourshrc = 'bashrc';
}
print <<INSTRUCTION;
Perlbrew environment initiated, required directories are created under
$ROOT
Well-done! Congratulations! Please add the following line to the end
of your ~/.${yourshrc}
source $ROOT/etc/${shrc}
After that, exit this shell, start a new one, and install some fresh
perls:
perlbrew install perl-5.12.1
perlbrew install perl-5.10.1
For further instructions, simply run:
perlbrew
The default help messages will popup and tell you what to do!
Enjoy perlbrew at \$HOME!!
INSTRUCTION
}
sub run_command_install {
my ( $self, $dist, $opts ) = @_;
unless ($dist) {
require File::Spec;
require File::Path;
require File::Copy;
my $executable = $0;
unless (File::Spec->file_name_is_absolute($executable)) {
$executable = File::Spec->rel2abs($executable);
}
my $target = File::Spec->catfile($ROOT, "bin", "perlbrew");
if ($executable eq $target) {
print "You are already running the installed perlbrew:\n\n $executable\n";
exit;
}
File::Path::mkpath("$ROOT/bin");
File::Copy::copy($executable, $target);
chmod(0755, $target);
print <<HELP;
The perlbrew is installed as:
$target
You may trash the downloaded $executable from now on.
Next, if this is the first time you've run perlbrew installation, run:
$target init
And follow the instruction on screen.
HELP
return;
}
my ($dist_name, $dist_version) = $dist =~ m/^(.*)-([\d.]+(?:-RC\d+)?|git)$/;
my $dist_git_describe;
if (-d $dist && !$dist_name || !$dist_version) {
if (-d "$dist/.git") {
if (`git describe` =~ /v((5\.\d+\.\d+)(-\d+-\w+)?)$/) {
$dist_name = "perl";
$dist_git_describe = "v$1";
$dist_version = $2;
}
}
else {
print <<HELP;
The given directory $dist is not a git checkout of perl repository. To
brew a perl from git, clone it first:
git clone git://github.com/mirrors/perl.git
perlbrew install perl
HELP
return;
}
}
if ($dist_name eq 'perl') {
my ($dist_path, $dist_tarball, $dist_commit);
unless ($dist_git_describe) {
require HTTP::Lite;
my $http_get = sub {
my ($url, $cb) = @_;
my $ua = HTTP::Lite->new;
my $loc = $url;
my $status = $ua->request($loc) or die "Fail to get $loc";
my $redir_count = 0;
while ($status == 302 || $status == 301) {
last if $redir_count++ > 5;
for ($ua->headers_array) {
/Location: (\S+)/ and $loc = $1, last;
}
$loc or last;
$status = $ua->request($loc) or die "Fail to get $loc";
die "Failed to get $loc (404 not found). Please try again latter." if $status == 404;
}
if ($cb) {
return $cb->($ua->body);
}
return $ua->body;
};
my $html = $http_get->("http://search.cpan.org/dist/$dist");
($dist_path, $dist_tarball) =
$html =~ m[<a href="(/CPAN/authors/id/.+/(${dist}.tar.(gz|bz2)))">Download</a>];
my $dist_tarball_path = "${ROOT}/dists/${dist_tarball}";
if (-f $dist_tarball_path) {
print "Use the previously fetched ${dist_tarball}\n";
}
else {
print "Fetching $dist as $dist_tarball_path\n";
$http_get->(
"http://search.cpan.org${dist_path}",
sub {
my ($body) = @_;
open my $BALL, "> $dist_tarball_path";
print $BALL $body;
close $BALL;
}
);
}
}
my $usedevel = $dist_version =~ /5\.1[13579]|git/ ? "-Dusedevel" : "";
my @d_options = @{ $self->{D} };
my $as = $self->{as} || ($dist_git_describe ? "perl-$dist_git_describe" : $dist);
unshift @d_options, qq(prefix=$ROOT/perls/$as);
push @d_options, "usedevel" if $usedevel;
print "Installing $dist into $ROOT/perls/$as\n";
print <<INSTALL if $self->{quiet} && !$self->{verbose};
This could take a while. You can run the following command on another shell to track the status:
tail -f $self->{log_file}
INSTALL
my ($extract_command, $configure_flags) = ("", "-des");
my $dist_extracted_dir;
if ($dist_git_describe) {
$extract_command = "echo 'Building perl in the git checkout dir'";
$dist_extracted_dir = File::Spec->rel2abs( $dist );
} else {
$dist_extracted_dir = "$ROOT/build/${dist}";
my $tarx = "tar " . ( $dist_tarball =~ /bz2/ ? "xjf" : "xzf" );
$extract_command = "cd $ROOT/build; $tarx $ROOT/dists/${dist_tarball}";
$configure_flags = '-de';
}
my $cmd = join ";",
(
$extract_command,
"cd $dist_extracted_dir",
"rm -f config.sh Policy.sh",
"sh Configure $configure_flags " . join( ' ', map { "-D$_" } @d_options ),
"make",
(
$self->{force}
? ( 'make test', 'make install' )
: "make test && make install"
)
);
$cmd = "($cmd) >> '$self->{log_file}' 2>&1 "
if ( $self->{quiet} && !$self->{verbose} );
print $cmd, "\n";
delete $ENV{$_} for qw(PERL5LIB PERL5OPT);
print !system($cmd) ? <<SUCCESS : <<FAIL;
Installed $dist as $as successfully. Run the following command to switch to it.
perlbrew switch $as
SUCCESS
Installing $dist failed. See $self->{log_file} to see why.
If you want to force install the distribution, try:
perlbrew --force install $dist_name
FAIL
}
}
sub run_command_installed {
my $self = shift;
my $current = readlink("$ROOT/perls/current");
for (<$ROOT/perls/*>) {
next if m/current/;
my ($name) = $_ =~ m/\/([^\/]+$)/;
print $name, ( $name eq $current ? '(*)' : '' ), "\n";
}
my $current_perl_executable = readlink("$ROOT/bin/perl");
for ( grep { -x $_ && !-l $_ } map { "$_/perl" } split(":", $ENV{PATH}) ) {
print $_, ($current_perl_executable eq $_ ? "(*)" : ""), "\n";
}
}
sub run_command_switch {
my ( $self, $dist ) = @_;
unless ( $dist ) {
# If no args were given to switch, show the current perl.
my $current = readlink ( -d "$ROOT/perls/current"
? "$ROOT/perls/current"
: "$ROOT/bin/perl" );
printf "Currently switched %s\n",
( $current ? "to $current" : 'off' );
return;
}
if (-x $dist) {
unlink "$ROOT/perls/current";
system "ln -fs $dist $ROOT/bin/perl";
print "Switched to $dist\n";
return;
}
die "${dist} is not installed\n" unless -d "$ROOT/perls/${dist}";
unlink "$ROOT/perls/current";
system "cd $ROOT/perls; ln -s $dist current";
for my $executable (<$ROOT/perls/current/bin/*>) {
my ($name) = $executable =~ m/bin\/(.+?)(5\.\d.*)?$/;
my $target = "$ROOT/bin/${name}";
next unless -l $target || !-e $target;
system("ln -fs $executable $target");
}
}
sub run_command_off {
local $_ = "$ROOT/perls/current";
unlink if -l;
for my $executable (<$ROOT/bin/*>) {
unlink($executable) if -l $executable;
}
}
1;
$INC{'App/perlbrew.pm'} = __FILE__;
package main;
#!perl
use strict;
use Getopt::Long qw(:config pass_through);
use Pod::Usage;
require App::perlbrew;
my $opt = {
force => undef,
quiet => 1,
D => [],
};
GetOptions(
'f|force!' => \$opt->{force},
'q|quiet!' => \$opt->{quiet},
'v|verbose' => \$opt->{verbose},
'as=s' => \$opt->{as},
'D|D=s@' => $opt->{D},
'help|?' => sub { pod2usage(1) },
) or pod2usage(2);
App::perlbrew->run_command( $opt, @ARGV );
__END__
=head1 NAME
perlbrew - Perl Environment manager.
=head1 SYNOPSIS
perlbrew [options] [init|install|installed|switch]
# Initialize
perlbrew init
# Install some Perls
perlbrew install perl-5.12.0
perlbrew install perl-5.13.0
# Install from a git checkout
cd /path/to/src/perl
perlbrew install .
# See what were installed
perlbrew installed
# Switch perl in the $PATH
perlbrew switch perl-5.13.0
perl -v
# Turn it off. Disable it.
perlbrew off
# Turn it back on. Re-enable it.
perlbrew switch perl-5.13.0
=head1 COMMANDS
=over 4
=item install perl-<version>
Build and install the given version of perl.
=item install /path/to/perl/git/checkout/dir
Build and install from the given git checkout dir.
=item installed
List the installed versions of perl.
=item switch perl-<version>
Switch to the given version. You may need to run 'rehash' after this command.
=item off
Disable perlbrew. Use C<switch> command to re-enable it.
=head1 OPTIONS
=over 4
=item B<-?|help>
prints this help
=item B<-f|force>
Force installation of a perl
=item B<-q|quiet>
Log output to a log file rather than STDOUT. This is the default.
=item B<-v|verbose>
Log output to STDOUT rather than a logfile
=item B<-as>
Install a given perl under an alias.
perlbrew install perl-5.6.2 -as legacy-perl
=item B<-D>
pass through switches to the perl Configure script
perlbrew install perl-5.10.1 -D=usemymalloc
=back
=head1 DESCRIPTION
B<This program> will read the given input file(s) and do something
useful with the contents thereof.
=cut