Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
executable file 2735 lines (2316 sloc) 71.5 KB
#!/usr/bin/env perl
# DO NOT EDIT -- this is an auto generated file
use strict;
# App::cpanminus::script 0.9917 (auto embedded by script/build.PL)
package App::cpanminus::script;
use strict;
use Config;
use Cwd ();
use File::Basename ();
use File::Path ();
use File::Spec ();
use File::Copy ();
use Getopt::Long ();
use constant WIN32 => $^O eq 'MSWin32';
use constant PLUGIN_API_VERSION => 0.1;
our $VERSION = "0.9917";
$VERSION = eval $VERSION;
my $quote = WIN32 ? q/"/ : q/'/;
sub new {
my $class = shift;
bless {
home => "$ENV{HOME}/.cpanm",
cmd => 'install',
seen => {},
notest => undef,
installdeps => undef,
force => undef,
sudo => undef,
make => undef,
verbose => undef,
quiet => undef,
interactive => undef,
log => undef,
mirrors => [],
perl => $^X,
argv => [],
hooks => {},
plugins => [],
local_lib => undef,
configure_timeout => 60,
try_lwp => 1,
@_,
}, $class;
}
sub env {
my($self, $key) = @_;
$ENV{"PERL_CPANM_" . $key} || $ENV{"CPANMINUS_" . $key};
}
sub parse_options {
my $self = shift;
local @ARGV = @{$self->{argv}};
push @ARGV, split /\s+/, $self->env('OPT');
push @ARGV, @_;
if ($0 ne '-' && !-t STDIN){ # e.g. $ cpanm < author/requires.cpanm
push @ARGV, $self->load_argv_from_fh(\*STDIN);
}
Getopt::Long::Configure("bundling");
Getopt::Long::GetOptions(
'f|force!' => \$self->{force},
'n|notest!' => \$self->{notest},
'S|sudo!' => \$self->{sudo},
'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 },
'q|quiet' => \$self->{quiet},
'h|help' => sub { $self->{action} = 'help' },
'V|version' => sub { $self->{action} = 'version' },
'perl=s' => \$self->{perl},
'l|local-lib=s' => \$self->{local_lib},
'recent' => sub { $self->{action} = 'show_recent' },
'list-plugins' => sub { $self->{action} = 'list_plugins' },
'installdeps' => \$self->{installdeps},
'skip-installed!' => \$self->{skip_installed},
'interactive!' => \$self->{interactive},
'i|install' => sub { $self->{cmd} = 'install' },
'look' => sub { $self->{cmd} = 'look' },
'info' => sub { $self->{cmd} = 'info' },
'self-upgrade' => sub { $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' },
'disable-plugins!' => \$self->{disable_plugins},
'lwp!' => \$self->{try_lwp},
);
$self->{argv} = \@ARGV;
}
sub init {
my $self = shift;
$self->setup_home;
$self->load_plugins;
$self->bootstrap;
$self->{make} = $self->which($Config{make});
$self->init_tools;
if (@{$self->{bootstrap_deps} || []}) {
$self->configure_mirrors;
local $self->{force} = 1; # to force install EUMM
$self->install_deps($self->{base}, 0, @{$self->{bootstrap_deps}});
}
}
sub doit {
my $self = shift;
if ($self->should_init) {
$self->init;
$self->configure_mirrors;
}
if (my $action = $self->{action}) {
$self->$action() and return;
}
$self->help(1) unless @{$self->{argv}};
for my $module (@{$self->{argv}}) {
$self->install_module($module, 0);
}
$self->run_hooks(finalize => {});
}
sub should_init {
my $self = shift;
my $action = $self->{action} or return 1;
return (grep $action eq $_, qw(help version)) ? 0 : 1;
}
sub setup_home {
my $self = shift;
$self->{home} = $self->env('HOME') if $self->env('HOME');
$self->{base} = "$self->{home}/work/" . time . ".$$";
$self->{plugin_dir} = "$self->{home}/plugins";
File::Path::mkpath([ $self->{base}, $self->{plugin_dir} ], 0, 0777);
my $link = "$self->{home}/latest-build";
eval { unlink $link; symlink $self->{base}, $link };
$self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect
{
my $log = $self->{log}; my $base = $self->{base};
$self->{at_exit} = sub {
my $self = shift;
File::Copy::copy($self->{log}, "$self->{base}/build.log");
};
}
open my $out, ">$self->{log}" or die "$self->{log}: $!";
print $out "cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n";
print $out "Work directory is $self->{base}\n";
}
sub register_core_hooks {
my $self = shift;
$self->hook('core', search_module => sub {
my $args = shift;
my $self = $args->{app};
my $module = $args->{module};
push @{$args->{uris}}, sub {
$self->chat("Searching $module on cpanmetadb ...\n");
my $uri = "http://cpanmetadb.appspot.com/v1.0/package/$module";
my $yaml = $self->get($uri);
my $meta = $self->parse_meta_string($yaml);
if ($meta->{distfile}) {
return $self->cpan_uri($meta->{distfile});
}
$self->diag("! Finding $module on cpanmetadb failed.\n");
return;
};
});
$self->hook('core', search_module => sub {
my $args = shift;
my $self = $args->{app};
my $module = $args->{module};
push @{$args->{uris}}, sub {
$self->chat("Searching $module on search.cpan.org ...\n");
my $uri = "http://search.cpan.org/perldoc?$module";
my $html = $self->get($uri);
$html =~ m!<a href="/CPAN/authors/id/(.*?\.(?:tar\.gz|tgz|tar\.bz2|zip))">!
and return $self->cpan_uri($1);
$self->diag("! Finding $module on search.cpan.org failed.\n");
return;
};
});
$self->hook('core', show_recent => sub {
my $args = shift;
my $self = $args->{app};
$self->chat("Fetching recent feed from search.cpan.org ...\n");
my $feed = $self->get("http://search.cpan.org/uploads.rdf");
my @dists;
while ($feed =~ m!<link>http://search\.cpan\.org/~([a-z_\-0-9]+)/(.*?)/</link>!g) {
my($pause_id, $dist) = (uc $1, $2);
# FIXME Yes, it doesn't always have to be 'tar.gz'
push @dists, substr($pause_id, 0, 1) . "/" . substr($pause_id, 0, 2) . "/" . $pause_id . "/$dist.tar.gz";
last if @dists >= 50;
}
return \@dists;
});
}
sub load_plugins {
my $self = shift;
$self->_load_plugins;
$self->register_core_hooks;
for my $hook (keys %{$self->{hooks}}) {
$self->{hooks}->{$hook} = [ sort { $a->[0] <=> $b->[0] } @{$self->{hooks}->{$hook}} ];
}
$self->run_hooks(init => {});
}
sub _load_plugins {
my $self = shift;
return if $self->{disable_plugins};
return unless $self->{plugin_dir} && -e $self->{plugin_dir};
opendir my $dh, $self->{plugin_dir} or return;
my @plugins;
while (my $e = readdir $dh) {
my $f = "$self->{plugin_dir}/$e";
next unless -f $f && $e =~ /^[A-Za-z0-9_]+$/ && $e ne 'README';
push @plugins, [ $f, $e ];
}
for my $plugin (sort { $a->[1] <=> $b->[1] } @plugins) {
$self->load_plugin(@$plugin);
}
}
sub load_plugin {
my($self, $file, $name) = @_;
# TODO remove this once plugin API is official
unless ($self->env('DEV')) {
$self->chat("! Found plugin $file but PERL_CPANM_DEV is not set. Skipping.\n");
return;
}
$self->chat("Loading plugin $file\n");
my $plugin = { name => $name, file => $file };
my @attr = qw( name description author version synopsis );
my $dsl = join "\n", map "sub $_ { \$plugin->{$_} = shift }", @attr;
(my $package = $file) =~ s/[^a-zA-Z0-9_]/_/g;
my $code = do { open my $io, "<$file"; local $/; <$io> };
my $api_version = PLUGIN_API_VERSION;
my @hooks;
eval "package App::cpanplus::plugin::$package;\n".
"use strict;\n$dsl\n" .
'sub api_version { die "API_COMPAT: $_[0]" if $_[0] < $api_version }' . "\n" .
"sub hook { push \@hooks, [\@_] };\n$code";
if ($@ =~ /API_COMPAT: (\S+)/) {
$self->diag("! $plugin->{name} plugin API version is outdated ($1 < $api_version) and needs an update.\n");
return;
} elsif ($@) {
$self->diag("! Loading $name plugin failed. See $self->{log} for details.\n");
$self->chat($@);
return;
}
for my $hook (@hooks) {
$self->hook($plugin->{name}, @$hook);
}
push @{$self->{plugins}}, $plugin;
}
sub load_argv_from_fh {
my($self, $fh) = @_;
my @argv;
while(defined(my $line = <$fh>)){
chomp $line;
$line =~ s/#.+$//; # comment
$line =~ s/^\s+//; # trim spaces
$line =~ s/\s+$//; # trim spaces
push @argv, split ' ', $line if $line;
}
return @argv;
}
sub hook {
my $cb = pop;
my($self, $name, $hook, $order) = @_;
$order = 50 unless defined $order;
push @{$self->{hooks}->{$hook}}, [ $order, $cb, $name ];
}
sub run_hook {
my($self, $hook, $args) = @_;
$self->run_hooks($hook, $args, 1);
}
sub run_hooks {
my($self, $hook, $args, $first) = @_;
$args->{app} = $self;
my $res;
for my $plugin (@{$self->{hooks}->{$hook} || []}) {
$res = eval { $plugin->[1]->($args) };
$self->chat("Running hook '$plugin->[2]' error: $@") if $@;
last if $res && $first;
}
return $res;
}
sub version {
print "cpanm (App::cpanminus) version $VERSION\n";
return 1;
}
sub help {
my $self = shift;
if ($_[0]) {
die <<USAGE;
Usage: cpanm [options] Module [...]
Try `cpanm --help` for more options.
USAGE
}
print <<HELP;
Usage: cpanm [options] Module [...]
Options:
-v,--verbose Turns on chatty output
--interactive Turns on interactive configure (required for Task:: modules)
-f,--force force install
-n,--notest Do not run unit tests
-S,--sudo sudo to run install commands
--installdeps Only install dependencies
--disable-plugins Disable plugin loading
Commands:
--self-upgrade upgrades itself
--look Download the tarball and open the directory with your shell
--info Displays distribution info on CPAN
--recent Show recently updated modules
Examples:
cpanm CGI # install CGI
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution name
cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
cpanm --interactive Task::Kensho # Configure interactively
cpanm . # install from local directory
cpanm --installdeps . # install all the deps for the current directory
HELP
return 1;
}
sub bootstrap {
my $self = shift;
# If -l is specified, use that.
if ($self->{local_lib}) {
return $self->_try_local_lib($self->{local_lib});
}
# root, locally-installed perl or --sudo: don't care about install_base
return if $self->{sudo} or (-w $Config{installsitelib} and -w $Config{installsitebin});
# local::lib is configured in the shell -- yay
return if $ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT});
$self->_try_local_lib;
$self->diag(<<DIAG);
!
! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
! To turn off this warning, you have 3 options:
! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
! - Configure local::lib in your shell to set PERL_MM_OPT etc.
! - Set PERL_CPANM_OPT="--local-lib=~/perl5" in your shell
!
DIAG
sleep 2;
}
sub _try_local_lib {
my($self, $base) = @_;
my $bootstrap;
eval { require local::lib };
if ($@) { $self->_bootstrap_local_lib; $bootstrap = 1 };
# TODO -L option should remove PERL5LIB here
{ local $0 = 'cpanm'; local::lib->import($base || "~/perl5") };
if ($bootstrap) {
push @{$self->{bootstrap_deps}},
'ExtUtils::MakeMaker' => 6.31,
'ExtUtils::Install' => 1.43;
}
}
# XXX Installing local::lib using cpanm causes CPAN.pm configuration
# as of 1.4.9, so avoid that until it can be bypassed
sub _bootstrap_local_lib {
my $self = shift;
$self->_require('local::lib');
}
sub _require {
my($self, $module) = @_;
$self->{_embed_cache} ||= do {
my($cache, $curr);
while (<::DATA>) {
if (/^# CPANM_EMBED_BEGIN (\S+)/) { $curr = $1 }
elsif (/^# CPANM_EMBED_END (\S+)/) { $curr = undef }
elsif ($curr) {
$cache->{$curr} .= $_;
}
}
$cache || {};
};
eval $self->{_embed_cache}{$module};
}
sub diag {
my $self = shift;
print STDERR @_ if $self->{verbose} or !$self->{quiet};
$self->log(@_);
}
sub chat {
my $self = shift;
print STDERR @_ if $self->{verbose};
$self->log(@_);
}
sub log {
my $self = shift;
open my $out, ">>$self->{log}";
print $out @_;
}
sub run {
my($self, $cmd) = @_;
if (ref $cmd eq 'ARRAY') {
my $pid = fork;
if ($pid) {
waitpid $pid, 0;
return !$?;
} else {
close STDIN unless $self->{verbose};
$self->run_exec($cmd);
}
} else {
unless ($self->{verbose}) {
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
}
!system $cmd;
}
}
sub run_exec {
my($self, $cmd) = @_;
if (ref $cmd eq 'ARRAY') {
unless ($self->{verbose}) {
open my $logfh, ">>", $self->{log};
open STDERR, '>&', $logfh;
open STDOUT, '>&', $logfh;
}
exec @$cmd;
} else {
unless ($self->{verbose}) {
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
}
exec $cmd;
}
}
sub run_timeout {
my($self, $cmd, $timeout) = @_;
return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout;
my $pid = fork;
if ($pid) {
eval {
local $SIG{ALRM} = sub { die "alarm\n" };
alarm $timeout;
waitpid $pid, 0;
alarm 0;
};
if ($@ && $@ eq "alarm\n") {
$self->diag("Timed out (> ${timeout}s). Use --verbose to retry. ");
local $SIG{TERM} = 'IGNORE';
kill TERM => 0;
waitpid $pid, 0;
return;
}
return !$?;
} elsif ($pid == 0) {
$self->run_exec($cmd);
} else {
$self->chat("! fork failed: falling back to system()\n");
$self->run($cmd);
}
}
sub configure {
my($self, $cmd) = @_;
# trick AutoInstall
local $ENV{PERL5_CPAN_IS_RUNNING} = $ENV{PERL5_CPANPLUS_IS_RUNNING} = 1;
my $use_default = !$self->{interactive};
local $ENV{PERL_MM_USE_DEFAULT} = $use_default;
local $self->{verbose} = $self->{verbose} || $self->{interactive};
$self->run_timeout($cmd, $self->{configure_timeout});
}
sub build {
my($self, $cmd) = @_;
$self->run_timeout($cmd, $self->{build_timeout});
}
sub test {
my($self, $cmd) = @_;
return 1 if $self->{notest};
return $self->run_timeout($cmd, $self->{test_timeout}) || $self->{force};
}
sub install {
my($self, $cmd) = @_;
$cmd = "sudo $cmd" if $self->{sudo};
$self->run($cmd);
}
sub chdir {
my $self = shift;
chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
}
sub configure_mirrors {
my $self = shift;
my @mirrors;
$self->run_hook(configure_mirrors => { mirrors => \@mirrors });
@mirrors = ('http://search.cpan.org/CPAN') unless @mirrors;
$self->{mirrors} = \@mirrors;
}
sub show_recent {
my $self = shift;
my $dists = $self->run_hook(show_recent => {});
for my $dist (@$dists) {
print $dist, "\n";
}
return 1;
}
sub list_plugins {
my $self = shift;
for my $plugin (@{$self->{plugins}}) {
print "$plugin->{name} - $plugin->{description}\n";
}
return 1;
}
sub self_upgrade {
my $self = shift;
$self->{argv} = [ 'App::cpanminus' ];
return; # continue
}
sub install_module {
my($self, $module, $depth) = @_;
if ($self->{seen}{$module}++) {
$self->diag("Already tried $module. Skipping.\n");
return;
}
# FIXME return richer data strture including version number here
# so --skip-installed option etc. can skip it
my $dir = $self->fetch_module($module);
return if $self->{cmd} eq 'info';
unless ($dir) {
$self->diag("! Couldn't find module or a distribution $module\n");
return;
}
if ($self->{seen}{$dir}++) {
$self->diag("Already built the distribution $dir. Skipping.\n");
return;
}
$self->chat("Entering $dir\n");
$self->chdir($self->{base});
$self->chdir($dir);
if ($self->{cmd} eq 'look') {
my $shell = $ENV{SHELL};
$shell ||= $ENV{COMSPEC} if WIN32;
if ($shell) {
$self->diag("Entering $dir with $shell\n");
system $shell;
} else {
$self->diag("! You don't seem to have a SHELL :/\n");
}
} else {
$self->build_stuff($module, $dir, $depth);
}
}
sub generator_cb {
my($self, $ref) = @_;
$ref = [ $ref ] unless ref $ref eq 'ARRAY';
my @stack;
return sub {
if (@stack) {
return shift @stack;
}
return -1 unless @$ref;
my $curr = (shift @$ref)->();
if (ref $curr eq 'ARRAY') {
@stack = @$curr;
return shift @stack;
} else {
return $curr;
}
};
}
sub fetch_module {
my($self, $module) = @_;
my($uris, $local_dir) = $self->locate_dist($module);
return $local_dir if $local_dir;
return unless $uris;
my $iter = $self->generator_cb($uris);
while (1) {
my $uri = $iter->();
last if $uri == -1;
next unless $uri;
# Yikes this is dirty
if ($self->{cmd} eq 'info') {
$uri =~ s!.*authors/id/!!;
print $uri, "\n";
return;
}
if ($uri =~ m{/perl-5}){
$self->diag("skip $uri\n");
next;
}
$self->chdir($self->{base});
$self->diag("Fetching $uri ... ");
my $name = File::Basename::basename $uri;
my $cancelled;
my $fetch = sub {
my $file;
eval {
local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
$self->mirror($uri, $name);
$file = $name if -e $name;
};
$self->chat("$@") if $@ && $@ ne "SIGINT\n";
return $file;
};
my($try, $file);
while ($try++ < 3) {
$file = $fetch->();
last if $cancelled or $file;
$self->diag("FAIL\nDownload $uri failed. Retrying ... ");
}
if ($cancelled) {
$self->diag("\n! Download cancelled.\n");
return;
}
unless ($file) {
$self->diag("FAIL\n! Failed to download $uri\n");
next;
}
$self->diag("OK\n");
# TODO add more metadata so plugins can tell how to verify and pass through
my $args = { file => $file, uri => $uri, fail => 0 };
$self->run_hooks(verify_archive => $args);
if ($args->{fail} && !$self->{force}) {
$self->diag("! Verifying the archive $file failed. Skipping. (use --force to install)\n");
next;
}
my $dir = $self->unpack($file);
next unless $dir; # unpack failed
return $dir;
}
}
sub unpack {
my($self, $file) = @_;
$self->chat("Unpacking $file\n");
my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file);
unless ($dir) {
$self->diag("! Failed to unpack $file: no directory\n");
}
return $dir;
}
sub locate_dist {
my($self, $module) = @_;
if (my $located = $self->run_hook(locate_dist => { module => $module })) {
return ref $located eq 'ARRAY' ? @$located :
ref $located eq 'CODE' ? $located : sub { $located };
}
# URL
return sub { $module } if $module =~ /^(ftp|https?|file):/;
# Directory
return undef, Cwd::abs_path($module) if $module =~ m!^[\./]! && -d $module;
# File
return sub { "file://" . Cwd::abs_path($module) } if -f $module;
# cpan URI
$module =~ s!^cpan:///distfile/!!;
# PAUSEID/foo
$module =~ s!^([A-Z]{3,})/!substr($1, 0, 1)."/".substr($1, 0, 2) ."/" . $1 . "/"!e;
# CPAN tarball
return sub { $self->cpan_uri($module) } if $module =~ m!^[A-Z]/[A-Z]{2}/!;
# Module name -- search.cpan.org
return $self->search_module($module);
}
sub cpan_uri {
my($self, $dist) = @_;
my @mirrors = @{$self->{mirrors}};
my @urls = map "$_/authors/id/$dist", @mirrors;
return wantarray ? @urls : $urls[int(rand($#urls))];
}
sub search_module {
my($self, $module) = @_;
my @cbs;
$self->run_hooks(search_module => { module => $module, uris => \@cbs });
return \@cbs;
}
sub check_module {
my($self, $mod, $ver) = @_;
$ver = '' if $ver == 0;
my $test = `$self->{perl} -e ${quote}eval q{use $mod $ver (); print q{OK:}, $mod\::->VERSION};print \$\@ if \$\@${quote}`;
if ($test =~ s/^\s*OK://) {
$self->{local_versions}{$mod} = $test;
return 1, $test;
} elsif ($test =~ /^Can't locate|required--this is only version (\S+)/) {
$self->{local_versions}{$mod} = $1;
return 0, $1;
} else {
return 0, undef, $test;
}
}
sub should_install {
my($self, $mod, $ver) = @_;
$self->chat("Checking if you have $mod $ver ... ");
my($ok, $local, $err) = $self->check_module($mod, $ver);
if ($err) {
$self->chat("Unknown ($err)\n");
return;
}
if ($ok) { $self->chat("Yes ($local)\n") }
elsif ($local) { $self->chat("No ($local < $ver)\n") }
else { $self->chat("No\n") }
return $mod unless $ok;
return;
}
sub install_deps {
my($self, $dir, $depth, %deps) = @_;
my @install;
while (my($mod, $ver) = each %deps) {
next if $mod eq 'perl' or $mod eq 'Config';
push @install, $self->should_install($mod, $ver);
}
if (@install) {
$self->diag("==> Found dependencies: ", join(", ", @install), "\n");
}
for my $mod (@install) {
$self->install_module($mod, $depth + 1);
}
$self->chdir($self->{base});
$self->chdir($dir) if $dir;
}
sub build_stuff {
my($self, $module, $dir, $depth) = @_;
my $args = { module => $module, dir => $dir };
$self->run_hooks(verify_dist => $args);
if ($args->{fail} && !$self->{force}) {
$self->diag("! Verifying the module $module failed. Skipping. (use --force to install)\n");
return;
}
my($meta, @config_deps);
if (-e 'META.yml') {
$self->chat("Checking configure dependencies from META.yml ...\n");
$meta = $self->parse_meta('META.yml');
push @config_deps, %{$meta->{configure_requires} || {}};
}
# TODO yikes, $module doesn't always have to be CPAN module
# TODO extract/fetch meta info earlier so you don't need to download tarballs
if ($depth == 0 && $meta->{version} && $module =~ /^[a-zA-Z0-9_:]+$/) {
my($ok, $local, $err) = $self->check_module($module, $meta->{version});
if ($self->{skip_installed} && $ok) {
$self->diag("$module is up to date. ($local)\n");
return;
}
}
$self->run_hooks(pre_configure => { meta => $meta, deps => \@config_deps });
$self->install_deps($dir, $depth, @config_deps);
my $target = $meta->{name} ? "$meta->{name}-$meta->{version}" : $dir;
$self->diag("Configuring $target ... ");
my($use_module_build, $configured, $configured_ok);
my $configure_state = $self->configure_this;
$self->diag($configure_state->{configured_ok} ? "OK\n" : "N/A\n");
my %deps = $self->find_prereqs;
$self->run_hooks(find_deps => { deps => \%deps, module => $module, meta => $meta });
$self->install_deps($dir, $depth, %deps);
if ($self->{installdeps} && $depth == 0) {
$self->diag("<== Installed dependencies for $module. Finishing.\n");
return 1;
}
my $installed;
if ($use_module_build && -e 'Build' && -f _) {
$self->diag("Building ", ($self->{notest} ? "" : "and testing "), "$target for $module ... ");
$self->build([ $self->{perl}, "./Build" ]) &&
$self->test([ $self->{perl}, "./Build", "test" ]) &&
$self->install([ $self->{perl}, "./Build", "install" ]) &&
$installed++;
} elsif ($self->{make} && -e 'Makefile') {
$self->diag("Building ", ($self->{notest} ? "" : "and testing "), "$target for $module ... ");
$self->build([ $self->{make} ]) &&
$self->test([ $self->{make}, "test" ]) &&
$self->install([ $self->{make}, "install" ]) &&
$installed++;
} else {
my $why;
if ($configured && !$configured_ok) { $why = "Configure failed on $dir." }
elsif ($self->{make}) { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" }
else { $why = "Can't configure the distribution. You probably need to have 'make'." }
$self->diag("! $why See $self->{log} for details.\n");
$self->run_hooks(configure_failure => { module => $module, build_dir => $dir, meta => $meta });
return;
}
# TODO calculate this earlier and put it in the stash
my $distname = $meta->{name} ? "$meta->{name}-$meta->{version}" : $module;
if ($installed) {
my $local = $self->{local_versions}{$module};
my $reinstall = $local && $local eq $meta->{version};
my $how = $reinstall ? "reinstalled $distname"
: $local ? "installed $distname (upgraded from $local)"
: "installed $distname" ;
my $msg = "Successfully $how";
$self->diag("OK\n$msg\n");
$self->run_hooks(install_success => {
module => $module, build_dir => $dir, meta => $meta,
local => $local, reinstall => $reinstall, depth => $depth,
message => $msg, dist => $distname
});
return 1;
} else {
my $msg = "Building $distname failed";
$self->diag("FAIL\n! Installing $module failed. See $self->{log} for details.\n");
$self->run_hooks(build_failure => {
module => $module, build_dir => $dir, meta => $meta,
message => $msg, dist => $distname,
});
return;
}
}
sub configure_this {
my($self) = @_;
my $state = {};
if (-e 'Makefile.PL') {
local $ENV{X_MYMETA} = 'YAML';
# NOTE: according to Devel::CheckLib, most XS modules exit
# with 0 even if header files are missing, to avoid receiving
# tons of FAIL reports in such cases. So exit code can't be
# trusted if it went well.
if ($self->configure([ $self->{perl}, "Makefile.PL" ])) {
$state->{configured_ok} = -e 'Makefile';
}
$state->{configured}++;
}
if ((!$self->{make} or !$state->{configured_ok}) and -e 'Build.PL') {
if ($self->configure([ $self->{perl}, "Build.PL" ])) {
$state->{configured_ok} = -e 'Build' && -f _;
}
$state->{use_module_build}++;
$state->{configured}++;
}
return $state;
}
sub find_prereqs {
my($self) = @_;
my %deps;
if (-e 'MYMETA.yml') {
$self->chat("Checking dependencies from MYMETA.yml ...\n");
my $meta = $self->parse_meta('MYMETA.yml');
%deps = (%{$meta->{requires} || {}});
unless ($self->{notest}) {
%deps = (%deps, %{$meta->{build_requires} || {}}, %{$meta->{test_requires} || {}});
}
}
if (-e 'Makefile') {
$self->chat("Finding PREREQ from Makefile ...\n");
open my $mf, "Makefile";
while (<$mf>) {
if (/^\#\s+PREREQ_PM => ({.*?})/) {
no strict; # WTF bareword keys
my $prereq = eval "+$1";
%deps = (%deps, %$prereq) if $prereq;
last;
}
}
}
return %deps;
}
sub DESTROY {
my $self = shift;
$self->{at_exit}->($self) if $self->{at_exit};
}
# Utils
sub shell_quote {
my($self, $stuff) = @_;
$quote . $stuff . $quote;
}
sub which {
my($self, $name) = @_;
my $exe_ext = $Config{_exe};
for my $dir (File::Spec->path) {
my $fullpath = File::Spec->catfile($dir, $name);
if (-x $fullpath || -x ($fullpath .= $exe_ext)) {
if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) {
$fullpath = $self->shell_quote($fullpath);
}
return $fullpath;
}
}
return;
}
sub get { $_[0]->{_backends}{get}->(@_) };
sub mirror { $_[0]->{_backends}{mirror}->(@_) };
sub redirect { $_[0]->{_backends}{redirect}->(@_) };
sub untar { $_[0]->{_backends}{untar}->(@_) };
sub unzip { $_[0]->{_backends}{unzip}->(@_) };
sub file_get {
my($self, $uri) = @_;
open my $fh, "<$uri" or return;
join '', <$fh>;
}
sub file_mirror {
my($self, $uri, $path) = @_;
File::Copy::copy($uri, $path);
}
sub init_tools {
my $self = shift;
# use --no-lwp if they have a broken LWP, to upgrade LWP
if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION >= 5.802 }) {
my $ua = sub {
LWP::UserAgent->new(
parse_head => 0,
env_proxy => 1,
agent => "cpanminus/$VERSION",
@_,
);
};
$self->{_backends}{get} = sub {
my $self = shift;
my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
return unless $res->is_success;
return $res->decoded_content;
};
$self->{_backends}{mirror} = sub {
my $self = shift;
my $res = $ua->()->mirror(@_);
$res->code;
};
$self->{_backends}{redirect} = sub {
my $self = shift;
my $res = $ua->(max_redirect => 1)->simple_request(HTTP::Request->new(GET => $_[0]));
return $res->header('Location') if $res->is_redirect;
return;
};
} elsif (my $wget = $self->which('wget')) {
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
my $q = $self->{verbose} ? '' : '-q';
open my $fh, "$wget $uri $q -O - |" or die "wget $uri: $!";
local $/;
<$fh>;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
my $q = $self->{verbose} ? '' : '-q';
system "$wget $uri $q -O $path";
};
$self->{_backends}{redirect} = sub {
my($self, $uri) = @_;
my $out = `$wget --max-redirect=0 $uri 2>&1`;
if ($out =~ /^Location: (\S+)/m) {
return $1;
}
return;
};
} elsif (my $curl = $self->which('curl')) {
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
my $q = $self->{verbose} ? '' : '-s';
open my $fh, "$curl -L $q $uri |" or die "curl $uri: $!";
local $/;
<$fh>;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
my $q = $self->{verbose} ? '' : '-s';
system "$curl -L $uri $q -# -o $path";
};
$self->{_backends}{redirect} = sub {
my($self, $uri) = @_;
my $out = `$curl -I -s $uri 2>&1`;
if ($out =~ /^Location: (\S+)/m) {
return $1;
}
return;
};
} else {
eval { require HTTP::Lite };
if ($@) { $self->_require('HTTP::Lite') }
my $http_cb = sub {
my($uri, $redir, $cb_gen) = @_;
my $http = HTTP::Lite->new;
my($data_cb, $done_cb) = $cb_gen ? $cb_gen->() : ();
my $req = $http->request($uri, $data_cb);
$done_cb->($req) if $done_cb;
my $redir_count;
while ($req == 302 or $req == 301) {
last if $redir_count++ > 5;
my $loc;
for ($http->headers_array) {
/Location: (\S+)/ and $loc = $1, last;
}
$loc or last;
if ($loc =~ m!^/!) {
$uri =~ s!^(\w+?://[^/]+)/.*$!$1!;
$uri .= $loc;
} else {
$uri = $loc;
}
return $uri if $redir;
my($data_cb, $done_cb) = $cb_gen ? $cb_gen->() : ();
$req = $http->request($uri, $data_cb);
$done_cb->($req) if $done_cb;
}
return if $redir;
return ($http, $req);
};
$self->{_backends}{get} = sub {
my($self, $uri) = @_;
return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
my($http, $req) = $http_cb->($uri);
return $http->body;
};
$self->{_backends}{mirror} = sub {
my($self, $uri, $path) = @_;
return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
my($http, $req) = $http_cb->($uri, undef, sub {
open my $out, ">$path" or die "$path: $!";
binmode $out;
sub { print $out ${$_[1]} }, sub { close $out };
});
return $req;
};
$self->{_backends}{redirect} = sub {
my($self, $uri) = @_;
return $http_cb->($uri, 1);
};
}
if (my $tar = $self->which('tar')) {
$self->{_backends}{untar} = sub {
my($self, $tarfile) = @_;
my $xf = "xf" . ($self->{verbose} ? 'v' : '');
my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
my($root, @others) = `$tar tf$ar $tarfile`
or return undef;
chomp $root;
$root =~ s{^(.+)/[^/]*$}{$1};
system "$tar $xf$ar $tarfile";
return $root if -d $root;
$self->diag("! Bad archive: $tarfile\n");
return undef;
}
} elsif (eval { require Archive::Tar }) { # uses too much memory!
$self->{_backends}{untar} = sub {
my $self = shift;
my $t = Archive::Tar->new($_[0]);
my $root = ($t->list_files)[0];
$t->extract;
return -d $root ? $root : undef;
};
} else {
$self->{_backends}{untar} = sub {
die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n";
};
}
if (my $unzip = $self->which('unzip')) {
$self->{_backends}{unzip} = sub {
my($self, $zipfile) = @_;
my $opt = $self->{verbose} ? '' : '-q';
my(undef, $root, @others) = `$unzip -t $zipfile`
or return undef;
chomp $root;
$root =~ s{^\s+testing:\s+(.+?)/\s+OK$}{$1};
system "$unzip $opt $zipfile";
return $root if -d $root;
$self->diag("! Bad archive: [$root] $zipfile\n");
return undef;
}
} elsif (eval { require Archive::Zip }) {
$self->{_backends}{unzip} = sub {
my($self, $file) = @_;
my $zip = Archive::Zip->new();
my $status;
$status = $zip->read($file);
$self->diag("Read of file[$file] failed\n")
if $status != Archive::Zip::AZ_OK();
my @members = $zip->members();
my $root;
for my $member ( @members ) {
my $af = $member->fileName();
next if ($af =~ m!^(/|\.\./)!);
$root = $af unless $root;
$status = $member->extractToFileNamed( $af );
$self->diag("Extracting of file[$af] from zipfile[$file failed\n") if $status != Archive::Zip::AZ_OK();
}
return -d $root ? $root : undef;
};
} else {
$self->{_backends}{unzip} = sub {
die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
};
}
}
sub parse_meta {
my($self, $file) = @_;
return eval { (Parse::CPAN::Meta::LoadFile($file))[0] } || {};
}
sub parse_meta_string {
my($self, $yaml) = @_;
return eval { (Parse::CPAN::Meta::Load($yaml))[0] } || {};
}
# Parse::CPAN::Meta 1.40 (auto embedded by script/build.PL)
package Parse::CPAN::Meta;
use strict;
use Carp 'croak';
# UTF Support?
sub HAVE_UTF8 () { $] >= 5.007003 }
BEGIN {
if ( HAVE_UTF8 ) {
# The string eval helps hide this from Test::MinimumVersion
eval "require utf8;";
die "Failed to load UTF-8 support" if $@;
}
# Class structure
require 5.004;
require Exporter;
$Parse::CPAN::Meta::VERSION = '1.40';
@Parse::CPAN::Meta::ISA = qw{ Exporter };
@Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
}
# Prototypes
sub LoadFile ($);
sub Load ($);
sub _scalar ($$$);
sub _array ($$$);
sub _hash ($$$);
# Printable characters for escapes
my %UNESCAPES = (
z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
#####################################################################
# Implementation
# Create an object from a file
sub LoadFile ($) {
# Check the file
my $file = shift;
croak('You did not specify a file name') unless $file;
croak( "File '$file' does not exist" ) unless -e $file;
croak( "'$file' is a directory, not a file" ) unless -f _;
croak( "Insufficient permissions to read '$file'" ) unless -r _;
# Slurp in the file
local $/ = undef;
local *CFG;
unless ( open( CFG, $file ) ) {
croak("Failed to open file '$file': $!");
}
my $yaml = <CFG>;
unless ( close(CFG) ) {
croak("Failed to close file '$file': $!");
}
# Hand off to the actual parser
Load( $yaml );
}
# Parse a document from a string.
# Doing checks on $_[0] prevents us having to do a string copy.
sub Load ($) {
my $string = $_[0];
unless ( defined $string ) {
croak("Did not provide a string to load");
}
# Byte order marks
if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
croak("Stream has a non UTF-8 Unicode Byte Order Mark");
} else {
# Strip UTF-8 bom if found, we'll just ignore it
$string =~ s/^\357\273\277//;
}
# Try to decode as utf8
utf8::decode($string) if HAVE_UTF8;
# Check for some special cases
return () unless length $string;
unless ( $string =~ /[\012\015]+\z/ ) {
croak("Stream does not end with newline character");
}
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
split /(?:\015{1,2}\012|\015|\012)/, $string;
# Strip the initial YAML header
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
my @documents = ();
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
push @documents, _scalar( "$1", [ undef ], \@lines );
next;
}
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
# A naked document
push @documents, undef;
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
} elsif ( $lines[0] =~ /^\s*\-/ ) {
# An array at the root
my $document = [ ];
push @documents, $document;
_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @documents, $document;
_hash( $document, [ length($1) ], \@lines );
} else {
croak("Parse::CPAN::Meta failed to classify line '$lines[0]'");
}
}
if ( wantarray ) {
return @documents;
} else {
return $documents[-1];
}
}
# Deparse a scalar string to the actual scalar
sub _scalar ($$$) {
my ($string, $indent, $lines) = @_;
# Trim trailing whitespace
$string =~ s/\s*\z//;
# Explitic null/undef
return undef if $string eq '~';
# Quotes
if ( $string =~ /^\'(.*?)\'\z/ ) {
return '' unless defined $1;
$string = $1;
$string =~ s/\'\'/\'/g;
return $string;
}
if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
# Reusing the variable is a little ugly,
# but avoids a new variable and a string copy.
$string = $1;
$string =~ s/\\"/"/g;
$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
return $string;
}
# Special cases
if ( $string =~ /^[\'\"!&]/ ) {
croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
}
return {} if $string eq '{}';
return [] if $string eq '[]';
# Regular unquoted string
return $string unless $string =~ /^[>|]/;
# Error
croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines;
# Check the indent depth
$lines->[0] =~ /^(\s*)/;
$indent->[-1] = length("$1");
if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
}
# Pull the lines
my @multiline = ();
while ( @$lines ) {
$lines->[0] =~ /^(\s*)/;
last unless length($1) >= $indent->[-1];
push @multiline, substr(shift(@$lines), length($1));
}
my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
return join( $j, @multiline ) . $t;
}
# Parse an array
sub _array ($$$) {
my ($array, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
}
if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
# Inline nested hash
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
# Array entry with a value
shift @$lines;
push @$array, _scalar( "$2", [ @$indent, undef ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
unless ( @$lines ) {
push @$array, undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)\-/ ) {
my $indent2 = length("$1");
if ( $indent->[-1] == $indent2 ) {
# Null array entry
push @$array, undef;
} else {
# Naked indenter
push @$array, [ ];
_array( $array->[-1], [ @$indent, $indent2 ], $lines );
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
} else {
croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
}
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
# foo:
# - list
# bar: value
#
# ... so lets return and let the hash parser handle it
return 1;
} else {
croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
}
}
return 1;
}
# Parse an array
sub _hash ($$$) {
my ($hash, $indent, $lines) = @_;
while ( @$lines ) {
# Check for a new document
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
while ( @$lines and $lines->[0] !~ /^---/ ) {
shift @$lines;
}
return 1;
}
# Check the indent level
$lines->[0] =~ /^(\s*)/;
if ( length($1) < $indent->[-1] ) {
return 1;
} elsif ( length($1) > $indent->[-1] ) {
croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'");
}
# Get the key
unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'");
}
croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'");
}
my $key = $1;
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
$hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines );
} else {
# An indent
shift @$lines;
unless ( @$lines ) {
$hash->{$key} = undef;
return 1;
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
# Null hash entry
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
}
}
}
}
return 1;
}
package main;
unless (caller) {
my $app = App::cpanminus::script->new;
$app->parse_options(@ARGV);
$app->doit;
}
__DATA__
# local::lib 1.004009 (auto embedded by script/build.PL)
# CPANM_EMBED_BEGIN local::lib
use strict;
use warnings;
package local::lib;
use 5.008001; # probably works with earlier versions but I'm not supporting them
# (patches would, of course, be welcome)
use File::Spec ();
use File::Path ();
use Carp ();
use Config;
our $VERSION = '1.004009'; # 1.4.9
my @KNOWN_FLAGS = (qw/--self-contained/);
sub import {
my ($class, @args) = @_;
@args <= 1 + @KNOWN_FLAGS or die <<'DEATH';
Please see `perldoc local::lib` for directions on using this module.
DEATH
# Remember what PERL5LIB was when we started
my $perl5lib = $ENV{PERL5LIB} || '';
my %arg_store;
for my $arg (@args) {
# check for lethal dash first to stop processing before causing problems
if ($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(grep { $arg eq $_ } @KNOWN_FLAGS) {
(my $flag = $arg) =~ s/--//;
$arg_store{$flag} = 1;
}
elsif($arg =~ /^--/) {
die "Unknown import argument: $arg";
}
else {
# assume that what's left is a path
$arg_store{path} = $arg;
}
}
if($arg_store{'self-contained'}) {
# The only directories that remain are those that we just defined and those
# where core modules are stored. We put PERL5LIB first, so it'll be favored
# over privlibexp and archlibexp
@INC = _uniq(
$class->install_base_arch_path($arg_store{path}),
$class->install_base_perl_path($arg_store{path}),
split( $Config{path_sep}, $perl5lib ),
$Config::Config{archlibexp},
$Config::Config{privlibexp},
);
# We explicitly set PERL5LIB here to the above de-duped list to prevent
# @INC from growing with each invocation
$ENV{PERL5LIB} = join( $Config{path_sep}, @INC );
}
$arg_store{path} = $class->resolve_path($arg_store{path});
$class->setup_local_lib_for($arg_store{path});
for (@INC) { # Untaint @INC
next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc.
m/(.*)/ and $_ = $1;
}
}
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 _uniq {
my %seen;
grep { ! $seen{$_}++ } @_;
}
sub resolve_path {
my ($class, $path) = @_;
$class->${pipeline qw(
resolve_relative_path
resolve_home_path
resolve_empty_path
)}($path);
}
sub resolve_empty_path {
my ($class, $path) = @_;
if (defined $path) {
$path;
} else {
'~/perl5';
}
}
sub resolve_home_path {
my ($class, $path) = @_;
return $path unless ($path =~ /^~/);
my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us'
my $tried_file_homedir;
my $homedir = do {
if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) {
$tried_file_homedir = 1;
if (defined $user) {
File::HomeDir->users_home($user);
} else {
File::HomeDir->my_home;
}
} else {
if (defined $user) {
(getpwnam $user)[7];
} else {
if (defined $ENV{HOME}) {
$ENV{HOME};
} else {
(getpwuid $<)[7];
}
}
}
};
unless (defined $homedir) {
Carp::croak(
"Couldn't resolve homedir for "
.(defined $user ? $user : 'current user')
.($tried_file_homedir ? '' : ' - consider installing File::HomeDir')
);
}
$path =~ s/^~[^\/]*/$homedir/;
$path;
}
sub resolve_relative_path {
my ($class, $path) = @_;
$path = File::Spec->rel2abs($path);
}
sub setup_local_lib_for {
my ($class, $path) = @_;
$path = $class->ensure_dir_structure_for($path);
if ($0 eq '-') {
$class->print_environment_vars_for($path);
exit 0;
} else {
$class->setup_env_hash_for($path);
@INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC);
}
}
sub modulebuildrc_path {
my ($class, $path) = @_;
File::Spec->catfile($path, '.modulebuildrc');
}
sub install_base_bin_path {
my ($class, $path) = @_;
File::Spec->catdir($path, 'bin');
}
sub install_base_perl_path {
my ($class, $path) = @_;
File::Spec->catdir($path, 'lib', 'perl5');
}
sub install_base_arch_path {
my ($class, $path) = @_;
File::Spec->catdir($class->install_base_perl_path($path), $Config{archname});
}
sub ensure_dir_structure_for {
my ($class, $path) = @_;
unless (-d $path) {
warn "Attempting to create directory ${path}\n";
}
File::Path::mkpath($path);
# Need to have the path exist to make a short name for it, so
# converting to a short name here.
$path = Win32::GetShortPathName($path) if $^O eq 'MSWin32';
my $modulebuildrc_path = $class->modulebuildrc_path($path);
if (-e $modulebuildrc_path) {
unless (-f _) {
Carp::croak("${modulebuildrc_path} exists but is not a plain file");
}
} else {
warn "Attempting to create file ${modulebuildrc_path}\n";
open MODULEBUILDRC, '>', $modulebuildrc_path
|| Carp::croak("Couldn't open ${modulebuildrc_path} for writing: $!");
print MODULEBUILDRC qq{install --install_base ${path}\n}
|| Carp::croak("Couldn't write line to ${modulebuildrc_path}: $!");
close MODULEBUILDRC
|| Carp::croak("Couldn't close file ${modulebuildrc_path}: $@");
}
return $path;
}
sub INTERPOLATE_ENV () { 1 }
sub LITERAL_ENV () { 0 }
sub print_environment_vars_for {
my ($class, $path) = @_;
my @envs = $class->build_environment_vars_for($path, LITERAL_ENV);
my $out = '';
# rather basic csh detection, goes on the assumption that something won't
# call itself csh unless it really is. also, default to bourne in the
# pathological situation where a user doesn't have $ENV{SHELL} defined.
# note also that shells with funny names, like zoid, are assumed to be
# bourne.
my $shellbin = 'sh';
if(defined $ENV{'SHELL'}) {
my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'});
$shellbin = $shell_bin_path_parts[-1];
}
my $shelltype = do {
local $_ = $shellbin;
if(/csh/) {
'csh'
} else {
'bourne'
}
};
# Both Win32 and Cygwin have $ENV{COMSPEC} set.
if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') {
my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'});
$shellbin = $shell_bin_path_parts[-1];
$shelltype = do {
local $_ = $shellbin;
if(/command\.com/) {
'win32'
} elsif(/cmd\.exe/) {
'win32'
} elsif(/4nt\.exe/) {
'win32'
} else {
$shelltype
}
};
}
while (@envs) {
my ($name, $value) = (shift(@envs), shift(@envs));
$value =~ s/(\\")/\\$1/g;
$out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value);
}
print $out;
}
# simple routines that take two arguments: an %ENV key and a value. return
# strings that are suitable for passing directly to the relevant shell to set
# said key to said value.
sub build_bourne_env_declaration {
my $class = shift;
my($name, $value) = @_;
return qq{export ${name}="${value}"\n};
}
sub build_csh_env_declaration {
my $class = shift;
my($name, $value) = @_;
return qq{setenv ${name} "${value}"\n};
}
sub build_win32_env_declaration {
my $class = shift;
my($name, $value) = @_;
return qq{set ${name}=${value}\n};
}
sub setup_env_hash_for {
my ($class, $path) = @_;
my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV);
@ENV{keys %envs} = values %envs;
}
sub build_environment_vars_for {
my ($class, $path, $interpolate) = @_;
return (
MODULEBUILDRC => $class->modulebuildrc_path($path),
PERL_MM_OPT => "INSTALL_BASE=${path}",
PERL5LIB => join($Config{path_sep},
$class->install_base_perl_path($path),
$class->install_base_arch_path($path),
($ENV{PERL5LIB} ?
($interpolate == INTERPOLATE_ENV
? ($ENV{PERL5LIB})
: (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' ))
: ())
),
PATH => join($Config{path_sep},
$class->install_base_bin_path($path),
($interpolate == INTERPOLATE_ENV
? $ENV{PATH}
: (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' ))
),
)
}
# CPANM_EMBED_END local::lib
# HTTP::Lite 2.2 (auto embedded by script/build.PL)
# CPANM_EMBED_BEGIN HTTP::Lite
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;
}
}
# CPANM_EMBED_END HTTP::Lite
Something went wrong with that request. Please try again.