Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

executable file 1364 lines (1130 sloc) 33.57 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;
use File::Spec::Functions qw( catfile );
our $VERSION = "0.09";
our $CONF;
my $ROOT = $ENV{PERLBREW_ROOT} || "$ENV{HOME}/perl5/perlbrew";
my $CONF_FILE = catfile( $ROOT, 'Conf.pm' );
my $CURRENT_PERL = "$ROOT/perls/current";
sub get_current_perl {
return $CURRENT_PERL;
}
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.3
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) {
my $mirror = $self->conf->{mirror};
my $header = $mirror ? { 'Cookie' => "cpan=$mirror->{url}" } : undef;
my $html = $self->_http_get("http://search.cpan.org/dist/$dist", undef, $header);
($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";
$self->_http_get(
"http://search.cpan.org${dist_path}",
sub {
my ($body) = @_;
open my $BALL, "> $dist_tarball_path";
print $BALL $body;
close $BALL;
},
$header
);
}
}
my @d_options = @{ $self->{D} };
my @u_options = @{ $self->{U} };
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 $dist_version =~ /5\.1[13579]|git/ ? "-Dusedevel" : "";
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 ),
( map { "-U$_" } @u_options ),
),
$dist_version =~ /^5\.(\d+)\.(\d+)/
&& ($1 < 8 || $1 == 8 && $2 < 9)
? ("$^X -i -nle 'print unless /command-line/' makefile x2p/makefile")
: (),
"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 calc_installed {
my $self = shift;
my $current = readlink("$ROOT/perls/current");
my @result;
for (<$ROOT/perls/*>) {
next if m/current/;
my ($name) = $_ =~ m/\/([^\/]+$)/;
push @result, { name => $name, is_current => ($name eq $current ? 1 : 0) };
}
my $current_perl_executable = readlink("$ROOT/bin/perl");
for ( grep { -f $_ && -x $_ } map { "$_/perl" } split(":", $ENV{PATH}) ) {
push @result, {
name => $_,
is_current => ($_ eq $current_perl_executable ? 1 : 0),
};
}
return @result;
}
sub run_command_installed {
my $self = shift;
my @installed = $self->calc_installed(@_);
for my $installed (@installed) {
my $name = $installed->{name};
my $cur = $installed->{is_current};
print $name, ($cur ? '(*)' : ''), "\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;
}
}
sub run_command_mirror {
my($self) = @_;
print "Fetching mirror list\n";
my $raw = $self->_http_get("http://search.cpan.org/mirror");
my $found;
my @mirrors;
foreach my $line ( split m{\n}, $raw ) {
$found = 1 if $line =~ m{<select name="mirror">};
next if ! $found;
last if $line =~ m{</select>};
if ( $line =~ m{<option value="(.+?)">(.+?)</option>} ) {
my $url = $1;
(my $name = $2) =~ s/&#(\d+);/chr $1/seg;
push @mirrors, { url => $url, name => $name };
}
}
my $select;
require ExtUtils::MakeMaker;
MIRROR: foreach my $id ( 0..$#mirrors ) {
my $mirror = $mirrors[$id];
printf "[% 3d] %s\n", $id + 1, $mirror->{name};
if ( $id > 0 ) {
my $test = $id / 19;
if ( $test == int $test ) {
my $remaining = $#mirrors - $id;
my $ask = "Select a mirror by number or press enter to see the rest "
. "($remaining more) [q to quit]";
my $val = ExtUtils::MakeMaker::prompt( $ask );
next MIRROR if ! $val;
last MIRROR if $val eq 'q';
$select = $val + 0;
if ( ! $select || $select - 1 > $#mirrors ) {
die "Bogus mirror ID: $select";
}
$select = $mirrors[$select];
die "Mirror ID is invalid" if ! $select;
last MIRROR;
}
}
}
die "You didn't select a mirror!\n" if ! $select;
print "Selected $select->{name} ($select->{url}) as the mirror\n";
my $conf = $self->conf;
$conf->{mirror} = $select;
$self->_save_conf;
return;
}
sub _http_get {
my ($self, $url, $cb, $header) = @_;
require HTTP::Lite;
my $ua = HTTP::Lite->new;
if ( $header && ref $header eq 'HASH') {
foreach my $name ( keys %{ $header} ) {
$ua->add_req_header( $name, $header->{ $name } );
}
}
$ua->proxy($ENV{http_proxy}) if $ENV{http_proxy};
my $loc = $url;
my $status = $ua->request($loc) or die "Fail to get $loc (error: $!)";
my $redir_count = 0;
while ($status == 302 || $status == 301) {
last if $redir_count++ > 5;
for ($ua->headers_array) {
/Location: (\S+)/ and $loc = $1, last;
}
last if ! $loc;
$status = $ua->request($loc) or die "Fail to get $loc (error: $!)";
die "Failed to get $loc (404 not found). Please try again latter." if $status == 404;
}
return $cb ? $cb->($ua->body) : $ua->body;
}
sub conf {
my($self) = @_;
$self->_get_conf if ! $CONF;
return $CONF;
}
sub _save_conf {
my($self) = @_;
require Data::Dumper;
open my $FH, '>', $CONF_FILE or die "Unable to open conf ($CONF_FILE): $!";
my $d = Data::Dumper->new([$CONF],['App::perlbrew::CONF']);
print $FH $d->Dump;
close $FH;
}
sub _get_conf {
my($self) = @_;
print "Attempting to load conf from $CONF_FILE\n";
if ( ! -e $CONF_FILE ) {
local $CONF = {} if ! $CONF;
$self->_save_conf;
}
open my $FH, '<', $CONF_FILE or die "Unable to open conf ($CONF_FILE): $!";
my $raw = do { local $/; my $rv = <$FH>; $rv };
close $FH;
my $rv = eval $raw;
if ( $@ ) {
warn "Error loading conf: $@";
$CONF = {};
return;
}
$CONF = {} if ! $CONF;
return;
}
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 => [],
U => [],
};
GetOptions(
'f|force!' => \$opt->{force},
'q|quiet!' => \$opt->{quiet},
'v|verbose' => \$opt->{verbose},
'as=s' => \$opt->{as},
'D|D=s@' => $opt->{D},
'U|U=s@' => $opt->{U},
'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
# Pick a prefered CPAN mirror
perlbrew mirror
# Install some Perls
perlbrew install perl-5.12.1
perlbrew install perl-5.13.3
# Install from a git checkout
cd /path/to/src/perl
perlbrew install .
# List which perls are installed
perlbrew installed
# Switch perl in the $PATH (hash -r clears the PATH cache in the shell)
perlbrew switch perl-5.13.3
hash -r
perl -v
# Turn it off. Disable it.
perlbrew off
# Turn it back on. Re-enable it.
perlbrew switch perl-5.13.3
=head1 CONFIGURATION
By default perlbrew builds and installs copies of perl into
C<$ENV{HOME}/perl5/perlbrew>. To use a different directory, set the
C<PERLBREW_ROOT> shell variable before running perlbrew.
=head1 COMMANDS
=over 4
=item init
Run this once to setup the C<perlbrew> directory ready for installing
perls into. Run it again if you decide to change C<PERLBREW_ROOT>.
=item mirror
Run this if you want to choose a specific CPAN mirror to install the
perls from. It will display a list of mirrors for you to pick
from. Hit 'q' to cancel the selection.
=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' (or 'hash
-r') after this command.
=item off
Disable perlbrew. Use C<switch> command to re-enable it. Use 'rehash'
or 'hash -r' again to clear the cache.
=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. The log file is saved in F<$ROOT/build.log>
=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>, B<-U>
pass through switches to the perl Configure script.
perlbrew install perl-5.10.1 -D usemymalloc -U uselargefiles
=back
=head1 DESCRIPTION
Read L<App::perlbrew> for more complete documentation.
=cut
Jump to Line
Something went wrong with that request. Please try again.