#!perl
# DO NOT EDIT -- this is an auto generated file
# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;
$fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS';
package App::cpanminus;
our $VERSION = "1.0002";
=head1 NAME
App::cpanminus - get, unpack, build and install modules from CPAN
=head1 SYNOPSIS
cpanm Module
Run C<cpanm -h> for more options.
=head1 DESCRIPTION
cpanminus is a script to get, unpack, build and install modules from CPAN.
Why? It's dependency free, requires zero configuration, and stands
alone. When running, it requires only 10MB of RAM.
=head1 INSTALLATION
There are Debian packages, RPMs, FreeBSD ports, and packages for other
operation systems available. If you want to use the package management system,
search for cpanminus and use the appropriate command to install. This makes it
easy to install C<cpanm> to your system without thinking about where to
install, and later upgrade.
If you want to build the latest from source,
git clone git://github.com/miyagawa/cpanminus.git
cd cpanminus
perl Makefile.PL
make install # or sudo make install if you're non root
This will install C<cpanm> to your bin directory like
C</usr/local/bin> (unless you configured C<INSTALL_BASE> with
L<local::lib>), so you might need to sudo. Later you can say C<cpanm
--self-upgrade --sudo> to upgrade to the latest version.
Otherwise,
cd ~/bin
wget http://xrl.us/cpanm
chmod +x cpanm
# edit shebang if you don't have /usr/bin/env
just works, but be sure to grab the new version manually when you
upgrade (C<--self-upgrade> might not work).
=head1 DEPENDENCIES
perl 5.8 or later (Actually I believe it works with pre 5.8 too but
I haven't tested this).
=over 4
=item *
'tar' executable (bsdtar or GNU tar version 1.22 are rcommended) or Archive::Tar to unpack files.
=item *
C compiler, if you want to build XS modules.
=back
And optionally:
=over 4
=item *
make, if you want to reliably install MakeMaker based modules
=item *
Module::Build (core in 5.10) to install Build.PL based modules
=back
=head1 QUESTIONS
=head2 Another CPAN installer?
OK, the first motivation was this: the CPAN shell runs out of memory (or swaps
heavily and gets really slow) on Slicehost/linode's most affordable plan with
only 256MB RAM. Should I pay more to install perl modules from CPAN? I don't
think so.
=head2 But why a new client?
First of all, I have no intention to dis CPAN or CPANPLUS
developers. Don't get me wrong. They're great tools I've
used for I<literally> years (you know how many modules I have
on CPAN, right?). I really respect their efforts of maintaining the
most important tools in the CPAN toolchain ecosystem.
However, for less experienced users (mostly from outside the Perl community),
or even really experienced Perl developers who know how to shoot themselves in
their feet, setting up the CPAN toolchain often feels like yak shaving,
especially when all they want to do is just install some modules and start
writing code.
In particular, here are the few issues I've observed:
=over
=item *
They ask too many questions and do not provide enough sane defaults. A normal
user doesn't (and shouldn't have to) know what's the right answer for the
question C<Parameters for the 'perl Build.PL' command? []>
=item *
They provide very noisy output by default.
=item *
They fetch and rebuild their indexes almost every day, and this takes time.
=item *
... and they hog 200MB of memory and thrashes/OOMs on my 256MB VPS
=back
cpanminus is designed to be very quiet (but logs all output to
C<~/.cpanm/build.log>) and to pick the sanest possible defaults without asking
any questions -- to I<just work>.
Note that most of these problems with existing tools are rare, or are just
overstated. They might already be fixed, or can be configured to work nicer.
For instance, the latest CPAN.pm dev release has a much better first time
configuration experience than ever before.
I know there's a reason for them to have many options and questions, because
they're meant to work everywhere for everybody.
Of course I should have contributed back to CPAN/CPANPLUS
instead of writing a new client, but CPAN.pm is nearly impossible
(for anyone other than andk or xdg) to maintain (that's why CPANPLUS
was born, right?) and CPANPLUS is a huge beast for me to start working
on.
=head2 Are you on drugs?
Yeah, I think my brain has been damaged since I looked at PyPI,
gemcutter, pip and rip. They're quite nice and I really wanted
something as nice for CPAN which I love.
=head2 How does this thing work?
Imagine you don't have CPAN or CPANPLUS. You search for a module on the CPAN
search site, download a tarball, unpack it and then run C<perl Makefile.PL> (or
C<perl Build.PL>). If the module has dependencies you probably have to resolve
those dependencies by hand before doing so. Then you run the unit tests and
C<make install> (or C<./Build install>).
cpanminus automates that.
=head2 Zero-conf? How does this module get/parse/update the CPAN index?
It queries the CPAN Meta DB site running on Google AppEngine at
L<http://cpanmetadb.appspot.com/>. The site is updated every hour to reflect
the latest changes from fast syncing mirrors. The script then also falls back
to the site L<http://search.cpan.org/>. I've been talking to and working with
with the QA/toolchain people for building a more reliable CPAN DB website.
Fetched files are unpacked in C<~/.cpanm>. You can configure this with
the C<PERL_CPANM_HOME> environment variable.
=head2 Where does this install modules to? Do I need root access?
It installs to wherever ExtUtils::MakeMaker and Module::Build are
configured to (via C<PERL_MM_OPT> and C<MODULEBUILDRC>). So if
you're using local::lib, then it installs to your local perl5
directory. Otherwise it installs to the siteperl directory.
cpanminus at a boot time checks whether you have configured local::lib, or have
the permission to install modules to the sitelib directory. If neither, it
automatically sets up local::lib compatible installation path in a C<perl5>
directory under your home directory. To avoid this, run the script as the root
user, with C<--sudo> option or with C<--local-lib> option.
This L<local::lib> automatic integration is still considered alpha and
in the work -- more bootstrapping is under development. Stay tuned.
=head2 Does this really work?
I tested installing MojoMojo, Task::Kensho, KiokuDB, Catalyst, Jifty and Plack
using cpanminus and the installations including dependencies were mostly
successful. More than I<half of CPAN> behaves really nicely and appears to
work.
However, there might be some distributions that will miserably fail, because of
nasty edge cases. Here are some examples:
=over 4
=item *
Packages uploaded to PAUSE in 90s which don't live under the standard
C<authors/id/A/AA> directory hierarchy.
=item *
Distributions with a C<Makefile.PL> or C<Build.PL> that asks you questions
without using C<prompt> function. However cpanminus has a mechanism to kill
those questions with a timeout, and you can always say C<--interactive> to make
the configuration interactive.
=item *
Distributions that do not shipped with C<META.yml> file but do require
some specific version of toolchain for configuration.
=item *
Distributions that have a C<META.yml> file that is encoded in YAML 1.1 format
using L<YAML::XS>. This will be eventually solved once we move to C<META.json>.
=back
cpanminus intends to work for 99.9% of modules on CPAN for 99.9% of people. It
may not be perfect, but it should just work in most cases.
If this tool doesn't work for your very rare environment, then I'm sorry, but
you should use CPAN or CPANPLUS, or build and install modules manually.
=head2 That sounds fantastic. Should I switch to this from CPAN(PLUS)?
If you have CPAN or CPANPLUS working then you may want to keep using
CPAN or CPANPLUS in the longer term, but I hope this can be a
quite handy alternative to them for people in other situations. And
apparently, many people love (at least the idea of) this software :)
=head1 COPYRIGHT
Copyright 2010- Tatsuhiko Miyagawa
The standalone executable contains the following modules embedded.
=over 4
=item L<Parse::CPAN::Meta> Copyright 2006-2009 Adam Kennedy
=item L<local::lib> Copyright 2007-2009 Matt S Trout
=item L<HTTP::Lite> Copyright 2000-2002 Roy Hopper, 2009 Adam Kennedy
=item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout
=back
=head1 LICENSE
Same as Perl.
=head1 CREDITS
=head2 CONTRIBUTORS
Patches and code improvements were contributed by:
Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian
Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout, squeeky, horus
and Ingy dot Net.
=head2 ACKNOWLEDGEMENTS
Bug reports, suggestions and feedbacks were sent by, or general
acknowledgement goes to:
Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris
Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse
Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren,
Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar
Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron.
=head1 COMMUNITY
=over 4
=item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
=item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there.
=back
=head1 NO WARRANTY
This software is provided "as-is," without any express or implied
warranty. In no event shall the author be held liable for any damages
arising from the use of the software.
=head1 SEE ALSO
L<CPAN> L<CPANPLUS> L<pip>
=cut
1;
APP_CPANMINUS
$fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
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 Parse::CPAN::Meta;
use constant WIN32 => $^O eq 'MSWin32';
use constant SUNOS => $^O eq 'solaris';
our $VERSION = "1.0002";
$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 => [],
local_lib => undef,
self_contained => undef,
prompt_timeout => 0,
prompt => undef,
configure_timeout => 60,
try_lwp => 1,
uninstall_shadows => 1,
@_,
}, $class;
}
sub env {
my($self, $key) = @_;
$ENV{"PERL_CPANM_" . $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} = 'show_help' },
'V|version' => sub { $self->{action} = 'show_version' },
'perl=s' => \$self->{perl},
'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
'L|local-lib-contained=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]); $self->{self_contained} = 1 },
'mirror=s@' => $self->{mirrors},
'prompt!' => \$self->{prompt},
'installdeps' => \$self->{installdeps},
'skip-installed!' => \$self->{skip_installed},
'interactive!' => \$self->{interactive},
'i|install' => sub { $self->{cmd} = 'install' },
'info' => sub { $self->{cmd} = 'info' },
'look' => sub { $self->{cmd} = 'look' },
'self-upgrade' => sub { $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' },
'uninst-shadows!' => \$self->{uninstall_shadows},
'lwp!' => \$self->{try_lwp},
);
$self->{argv} = \@ARGV;
}
sub check_libs {
my $self = shift;
return if $self->{_checked}++;
$self->bootstrap_local_lib;
if (@{$self->{bootstrap_deps} || []}) {
local $self->{force} = 1; # to force install EUMM
$self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}});
}
}
sub doit {
my $self = shift;
$self->setup_home;
$self->init_tools;
if (my $action = $self->{action}) {
$self->$action() and return 1;
}
$self->show_help(1) unless @{$self->{argv}};
$self->configure_mirrors;
my @fail;
for my $module (@{$self->{argv}}) {
$self->install_module($module, 0)
or push @fail, $module;
}
return !@fail;
}
sub setup_home {
my $self = shift;
$self->{home} = $self->env('HOME') if $self->env('HOME');
unless (_writable($self->{home})) {
die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
}
$self->{base} = "$self->{home}/work/" . time . ".$$";
File::Path::mkpath([ $self->{base} ], 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 fetch_meta {
my($self, $dist) = @_;
my $meta_yml = $self->get("http://cpansearch.perl.org/src/$dist->{cpanid}/$dist->{distvname}/META.yml");
return $self->parse_meta_string($meta_yml);
}
sub search_module {
my($self, $module) = @_;
$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_module($module, $meta->{distfile}, $meta->{version});
}
$self->diag_fail("Finding $module on cpanmetadb failed.");
$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_module($module, $1);
$self->diag_fail("Finding $module on search.cpan.org failed.");
return;
}
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 show_version {
print "cpanm (App::cpanminus) version $VERSION\n";
return 1;
}
sub show_help {
my $self = shift;
if ($_[0]) {
die <<USAGE;
Usage: cpanm [options] Module [...]
Try `cpanm --help` or `man cpanm` for more options.
USAGE
}
print <<HELP;
Usage: cpanm [options] Module [...]
Options:
-v,--verbose Turns on chatty output
-q,--quiet Turns off all outpu
--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
--skip-installed Skip installation if you already have the latest version installed
--mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
--prompt Prompt when build/test fails
-l,--local-lib Specify the install base to install modules
-L,--local-lib-contained Specify the install base to install all non-core modules
Commands:
--self-upgrade upgrades itself
--info Displays distribution info on CPAN
--look Opens the distribution with your SHELL
-V,--version Displays software version
Examples:
cpanm Test::More # install Test::More
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
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
cpanm -L extlib Plack # install Plack and all non-core deps into extlib
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
export PERL_CPANM_OPT="--prompt --skip-installed -l ~/perl --mirror http://cpan.cpantesters.org"
Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
HELP
return 1;
}
sub _writable {
my $dir = shift;
my @dir = File::Spec->splitdir($dir);
while (@dir) {
$dir = File::Spec->catdir(@dir);
if (-e $dir) {
return -w _;
}
pop @dir;
}
return;
}
sub maybe_abs {
my($self, $lib) = @_;
$lib =~ /^~/ ? $lib : Cwd::abs_path($lib);
}
sub bootstrap_local_lib {
my $self = shift;
# If -l is specified, use that.
if ($self->{local_lib}) {
return $self->setup_local_lib($self->{local_lib});
}
# root, locally-installed perl or --sudo: don't care about install_base
return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));
# local::lib is configured in the shell -- yay
if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
$self->bootstrap_local_lib_deps;
return;
}
$self->setup_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 to do one of the following:
! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
| - run me with --local-lib option e.g. cpanm --local-lib=~/perl5
! - Set PERL_CPANM_OPT="--local-lib=~/perl5" environment variable (in your shell rc file)
! - Configure local::lib in your shell to set PERL_MM_OPT etc.
!
DIAG
sleep 2;
}
sub _core_only_inc {
my($self, $base) = @_;
require local::lib;
(
local::lib->install_base_perl_path($base),
local::lib->install_base_arch_path($base),
@Config{qw(privlibexp archlibexp)},
);
}
sub _dump_inc {
my($self, $inc) = @_;
my @inc = map { qq('$_') } (@$inc, '.'); # . for inc/Module/Install.pm
open my $out, ">$self->{base}/DumpedINC.pm" or die $!;
local $" = ",";
print $out "BEGIN { \@INC = (@inc) }\n1;\n";
}
sub _import_local_lib {
my($self, @args) = @_;
local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
local::lib->import(@args);
}
sub setup_local_lib {
my($self, $base) = @_;
require local::lib;
{
local $0 = 'cpanm'; # so curl/wget | perl works
$base ||= "~/perl5";
if ($self->{self_contained}) {
my @inc = $self->_core_only_inc($base);
$self->_dump_inc(\@inc);
$self->{search_inc} = [ @inc ];
}
$self->_import_local_lib($base);
}
$self->bootstrap_local_lib_deps;
}
sub bootstrap_local_lib_deps {
my $self = shift;
push @{$self->{bootstrap_deps}},
'ExtUtils::MakeMaker' => 6.31,
'ExtUtils::Install' => 1.46,
'Module::Build' => 0.28; # TODO: 0.36 or later for MYMETA.yml once we do --bootstrap command
}
sub prompt_bool {
my($self, $mess, $def) = @_;
my $val = $self->prompt($mess, $def);
return lc $val eq 'y';
}
sub prompt {
my($self, $mess, $def) = @_;
my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
my $dispdef = defined $def ? "[$def] " : " ";
$def = defined $def ? $def : "";
if ($self->{quiet} || !$self->{prompt} || (!$isa_tty && eof STDIN)) {
return $def;
}
local $|=1;
local $\;
my $ans;
eval {
local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
print STDOUT "$mess $dispdef";
alarm $self->{prompt_timeout} if $self->{prompt_timeout};
$ans = <STDIN>;
alarm 0;
};
if ( defined $ans ) {
chomp $ans;
} else { # user hit ctrl-D or alarm timeout
print STDOUT "\n";
}
return (!defined $ans || $ans eq '') ? $def : $ans;
}
sub diag_ok {
my($self, $msg) = @_;
chomp $msg;
$msg ||= "OK";
if ($self->{in_progress}) {
$self->_diag("$msg\n");
$self->{in_progress} = 0;
}
$self->log("-> $msg\n");
}
sub diag_fail {
my($self, $msg) = @_;
chomp $msg;
if ($self->{in_progress}) {
$self->_diag("FAIL\n");
$self->{in_progress} = 0;
}
if ($msg) {
$self->_diag("! $msg\n");
$self->log("-> FAIL $msg\n");
}
}
sub diag_progress {
my($self, $msg) = @_;
chomp $msg;
$self->{in_progress} = 1;
$self->_diag("$msg ... ");
$self->log("$msg\n");
}
sub _diag {
my $self = shift;
print STDERR @_ if $self->{verbose} or !$self->{quiet};
}
sub diag {
my($self, $msg) = @_;
$self->_diag($msg);
$self->log($msg);
}
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 {
$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;
close $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_fail("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} = $$;
# e.g. skip CPAN configuration on local::lib
local $ENV{PERL5_CPANM_IS_RUNNING} = $$;
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, $distname) = @_;
return 1 if $self->{notest};
local $ENV{AUTOMATED_TESTING} = 1;
return 1 if $self->run_timeout($cmd, $self->{test_timeout});
if ($self->{force}) {
$self->diag_fail("Testing $distname failed but installing it anyway.");
return 1;
} else {
$self->diag_fail;
while (1) {
my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install or l)ook ?", "s");
return if $ans eq 's';
return $self->test($cmd, $distname) if $ans eq 'r';
return 1 if $ans eq 'f';
$self->look if $ans eq 'l';
}
}
}
sub install {
my($self, $cmd, $uninst_opts) = @_;
if ($self->{sudo}) {
unshift @$cmd, "sudo";
}
if ($self->{uninstall_shadows}) {
push @$cmd, @$uninst_opts;
}
$self->run($cmd);
}
sub look {
my $self = shift;
my $shell = $ENV{SHELL};
$shell ||= $ENV{COMSPEC} if WIN32;
if ($shell) {
my $cwd = Cwd::cwd;
$self->diag("Entering $cwd with $shell\n");
system $shell;
} else {
$self->diag_fail("You don't seem to have a SHELL :/");
}
}
sub chdir {
my $self = shift;
chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
}
sub configure_mirrors {
my $self = shift;
unless (@{$self->{mirrors}}) {
$self->{mirrors} = [ 'http://search.cpan.org/CPAN' ];
}
for (@{$self->{mirrors}}) {
s!/$!!;
}
}
sub self_upgrade {
my $self = shift;
$self->{argv} = [ 'App::cpanminus' ];
return; # continue
}
sub install_module {
my($self, $module, $depth) = @_;
if ($self->{seen}{$module}++) {
$self->chat("Already tried $module. Skipping.\n");
return 1;
}
my $dist = $self->resolve_name($module);
unless ($dist) {
$self->diag_fail("Couldn't find module or a distribution $module");
return;
}
if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
$self->chat("Already tried $dist->{distvname}. Skipping.\n");
return 1;
}
if ($dist->{source} eq 'cpan') {
$dist->{meta} = $self->fetch_meta($dist);
}
if ($self->{cmd} eq 'info') {
print $dist->{cpanid}, "/", $dist->{filename}, "\n";
return 1;
}
if ($dist->{module}) {
my($ok, $local) = $self->check_module($dist->{module}, $dist->{module_version} || 0);
if ($self->{skip_installed} && $ok) {
$self->diag("$dist->{module} is up to date. ($local)\n");
return 1;
}
}
$dist->{dir} ||= $self->fetch_module($dist);
unless ($dist->{dir}) {
$self->diag_fail("Failed to fetch distribution $dist->{distvname}");
return;
}
$self->chat("Entering $dist->{dir}\n");
$self->chdir($self->{base});
$self->chdir($dist->{dir});
if ($self->{cmd} eq 'look') {
$self->look;
return 1;
}
$self->check_libs;
return $self->build_stuff($module, $dist, $depth);
}
sub fetch_module {
my($self, $dist) = @_;
if ($dist->{dist} eq 'perl'){
$self->diag("skip $dist->{dist}\n");
return;
}
$self->chdir($self->{base});
for my $uri (@{$dist->{uris}}) {
$self->diag_progress("Fetching $uri");
# Ugh, $dist->{filename} can contain sub directory
my $filename = $dist->{filename} || $uri;
my $name = File::Basename::basename($filename);
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("Download $uri failed. Retrying ... ");
}
if ($cancelled) {
$self->diag_fail("Download cancelled.");
return;
}
unless ($file) {
$self->diag_fail("Failed to download $uri");
next;
}
$self->diag_ok;
my $dir = $self->unpack($file);
next unless $dir; # unpack failed
return $dist, $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_fail("Failed to unpack $file: no directory");
}
return $dir;
}
sub resolve_name {
my($self, $module) = @_;
# URL
if ($module =~ /^(ftp|https?|file):/) {
if ($module =~ m!authors/id/!) {
return $self->cpan_dist($module, $module);
} else {
return { uris => [ $module ] };
}
}
# Directory
if ($module =~ m!^[\./]! && -d $module) {
return {
source => 'local',
dir => Cwd::abs_path($module),
};
}
# File
if (-f $module) {
return {
source => 'local',
uris => [ "file://" . Cwd::abs_path($module) ],
};
}
# cpan URI
if ($module =~ s!^cpan:///distfile/!!) {
return $self->cpan_dist($module);
}
# PAUSEID/foo
if ($module =~ m!([A-Z]{3,})/!) {
return $self->cpan_dist($module);
}
# Module name
return $self->search_module($module);
}
sub cpan_module {
my($self, $module, $dist, $version) = @_;
my $dist = $self->cpan_dist($dist);
$dist->{module} = $module;
$dist->{module_version} = $version if $version && $version ne 'undef';
return $dist;
}
sub cpan_dist {
my($self, $dist, $url) = @_;
$dist =~ s!^([A-Z]{3})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;
require CPAN::DistnameInfo;
my $d = CPAN::DistnameInfo->new($dist);
if ($url) {
$url = [ $url ] unless ref $url eq 'ARRAY';
} else {
my $id = $d->cpanid;
my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename;
my @mirrors = @{$self->{mirrors}};
my @urls = map "$_/authors/id/$fn", @mirrors;
$url = \@urls,
}
return {
$d->properties,
source => 'cpan',
uris => $url,
};
}
sub check_module {
my($self, $mod, $want_ver) = @_;
require Module::Metadata;
my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc})
or return 0, undef;
my $version = $meta->version;
$self->{local_versions}{$mod} = $version;
if ($self->is_deprecated($meta)){
return 0, $version;
} elsif (!$want_ver or $version >= Module::Metadata::Version->new($want_ver)) {
return 1, $version;
} else {
return 0, $version;
}
}
sub is_deprecated {
my($self, $meta) = @_;
my $deprecated = eval {
require Module::CoreList;
Module::CoreList::is_deprecated($meta->{module});
};
return unless $deprecated;
require Config;
for my $dir (qw(archlibexp privlibexp)) {
my $confdir = $Config{$dir};
if ($confdir eq substr($meta->filename, 0, length($confdir))) {
return 1;
}
}
return;
}
sub should_install {
my($self, $mod, $ver) = @_;
$self->chat("Checking if you have $mod $ver ... ");
my($ok, $local) = $self->check_module($mod, $ver);
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, %seen);
while (my($mod, $ver) = splice @deps, 0, 2) {
next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config';
if ($self->should_install($mod, $ver)) {
push @install, $mod;
$seen{$mod} = 1;
}
}
if (@install) {
$self->diag("==> Found dependencies: " . join(", ", @install) . "\n");
}
my @fail;
for my $mod (@install) {
$self->install_module($mod, $depth + 1)
or push @fail, $mod;
}
$self->chdir($self->{base});
$self->chdir($dir) if $dir;
return @fail;
}
sub install_deps_bailout {
my($self, $target, $dir, $depth, @deps) = @_;
my @fail = $self->install_deps($dir, $depth, @deps);
if (@fail) {
unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " .
join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) {
$self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.");
return;
}
}
return 1;
}
sub build_stuff {
my($self, $stuff, $dist, $depth) = @_;
my @config_deps;
if (!%{$dist->{meta} || {}} && -e 'META.yml') {
$self->chat("Checking configure dependencies from META.yml\n");
$dist->{meta} = $self->parse_meta('META.yml');
}
push @config_deps, %{$dist->{meta}{configure_requires} || {}};
my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
$self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
or return;
$self->diag_progress("Configuring $target");
my $configure_state = $self->configure_this($dist);
$self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
my @deps = $self->find_prereqs($dist->{meta});
my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
$self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
or return;
if ($self->{installdeps} && $depth == 0) {
$self->diag("<== Installed dependencies for $stuff. Finishing.\n");
return 1;
}
my $installed;
if ($configure_state->{use_module_build} && -e 'Build' && -f _) {
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . "$distname for $stuff");
$self->build([ $self->{perl}, "./Build" ]) &&
$self->test([ $self->{perl}, "./Build", "test" ], $distname) &&
$self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ]) &&
$installed++;
} elsif ($self->{make} && -e 'Makefile') {
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . "$distname for $stuff");
$self->build([ $self->{make} ]) &&
$self->test([ $self->{make}, "test" ], $distname) &&
$self->install([ $self->{make}, "install" ], [ "UNINST=1" ]) &&
$installed++;
} else {
my $why;
my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok};
if ($configure_failed) { $why = "Configure failed for $distname." }
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_fail("$why See $self->{log} for details.");
return;
}
if ($installed) {
my $local = $self->{local_versions}{$dist->{module} || ''};
my $version = $dist->{meta}{version} || $dist->{version};
my $reinstall = $local && ($local eq $version);
my $how = $reinstall ? "reinstalled $distname"
: $local ? "installed $distname (upgraded from $local)"
: "installed $distname" ;
my $msg = "Successfully $how";
$self->diag_ok;
$self->diag("$msg\n");
return 1;
} else {
my $msg = "Building $distname failed";
$self->diag_fail("Installing $stuff failed. See $self->{log} for details.");
return;
}
}
sub configure_this {
my($self, $dist) = @_;
my @switches;
@switches = ("-I$self->{base}", "-MDumpedINC") if $self->{self_contained};
local $ENV{PERL5LIB} = '' if $self->{self_contained};
my $state = {};
my $try_eumm = sub {
if (-e 'Makefile.PL') {
$self->chat("Running Makefile.PL\n");
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}, @switches, "Makefile.PL" ])) {
$state->{configured_ok} = -e 'Makefile';
}
$state->{configured}++;
}
};
my $try_mb = sub {
if (-e 'Build.PL') {
$self->chat("Running Build.PL\n");
if ($self->configure([ $self->{perl}, @switches, "Build.PL" ])) {
$state->{configured_ok} = -e 'Build' && -f _;
}
$state->{use_module_build}++;
$state->{configured}++;
}
};
# Module::Build deps should use MakeMaker because that causes circular deps and fail
# Otherwise we should prefer Build.PL
my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest );
my @try;
if ($dist->{dist} && $should_use_mm{$dist->{dist}}) {
@try = ($try_eumm, $try_mb);
} else {
@try = ($try_mb, $try_eumm);
}
for my $try (@try) {
$try->();
last if $state->{configured_ok};
}
return $state;
}
sub safe_eval {
my($self, $code) = @_;
eval $code;
}
sub find_prereqs {
my($self, $meta) = @_;
my @deps;
if (-e 'MYMETA.yml') {
$self->chat("Checking dependencies from MYMETA.yml ...\n");
my $mymeta = $self->parse_meta('MYMETA.yml');
@deps = $self->extract_requires($mymeta);
$meta->{$_} = $mymeta->{$_} for keys %$mymeta; # merge
} elsif (-e '_build/prereqs') {
$self->chat("Checking dependencies from _build/prereqs ...\n");
my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) };
@deps = $self->extract_requires($mymeta);
}
if (-e 'Makefile') {
$self->chat("Finding PREREQ from Makefile ...\n");
open my $mf, "Makefile";
while (<$mf>) {
if (/^\#\s+PREREQ_PM => ({.*?})/) {
my $prereq = $self->safe_eval("no strict; +$1");
push @deps, %$prereq if $prereq;
last;
}
}
}
# No need to remove, but this gets in the way of signature testing :/
unlink 'MYMETA.yml';
return @deps;
}
sub extract_requires {
my($self, $meta) = @_;
my @deps;
push @deps, %{$meta->{requires}} if $meta->{requires};
push @deps, %{$meta->{build_requires}} if $meta->{build_requires};
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;
return if $self->{initialized}++;
if ($self->{make} = $self->which($Config{make})) {
$self->chat("You have make $self->{make}\n");
}
# 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) }) {
$self->chat("You have LWP $LWP::VERSION\n");
my $ua = sub {
LWP::UserAgent->new(
parse_head => 0,
env_proxy => 1,
agent => "cpanminus/$VERSION",
timeout => 30,
@_,
);
};
$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->chat("You have $wget\n");
$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 --retry-connrefused $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->chat("You have $curl\n");
$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 {
require HTTP::Lite;
$self->chat("Falling back to HTTP::Lite $HTTP::Lite::VERSION\n");
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);
};
}
my $tar = $self->which('tar');
my $tar_ver;
my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
if ($tar && !$maybe_bad_tar->()) {
chomp $tar_ver;
$self->chat("You have $tar: $tar_ver\n");
$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_fail("Bad archive: $tarfile");
return undef;
}
} elsif ( $tar
and my $gzip = $self->which('gzip')
and my $bzip2 = $self->which('bzip2')) {
$self->chat("You have $tar, $gzip and $bzip2\n");
$self->{_backends}{untar} = sub {
my($self, $tarfile) = @_;
my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -";
my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip;
my($root, @others) = `$ar -dc $tarfile | $tar tf -`
or return undef;
chomp $root;
$root =~ s{^(.+)/[^/]*$}{$1};
system "$ar -dc $tarfile | $tar $x";
return $root if -d $root;
$self->diag_fail("Bad archive: $tarfile");
return undef;
}
} elsif (eval { require Archive::Tar }) { # uses too much memory!
$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");
$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->chat("You have $unzip\n");
$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_fail("Bad archive: [$root] $zipfile");
return undef;
}
} else {
$self->{_backends}{unzip} = sub {
eval { require Archive::Zip }
or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
my($self, $file) = @_;
my $zip = Archive::Zip->new();
my $status;
$status = $zip->read($file);
$self->diag_fail("Read of file[$file] failed")
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_fail("Extracting of file[$af] from zipfile[$file failed")
if $status != Archive::Zip::AZ_OK();
}
return -d $root ? $root : undef;
};
}
}
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] } || {};
}
1;
APP_CPANMINUS_SCRIPT
$fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO';
package CPAN::DistnameInfo;
$VERSION = "0.10";
use strict;
sub distname_info {
my $file = shift or return;
my ($dist, $version) = $file =~ /^
((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
(?:
[A-Za-z](?=[^A-Za-z]|$)
|
\d(?=-)
)(?<![._-][vV])
)+)(.*)
$/xs or return ($file,undef,undef);
if ($dist =~ /-undef\z/ and ! length $version) {
$dist =~ s/-undef\z//;
}
if ($version =~ /^(-[Vv].*)-(\d.*)/) {
# Catch names like Unicode-Collate-Standard-V3_1_1-0.1
# where the V3_1_1 is part of the distname
$dist .= $1;
$version = $2;
}
# Normalize the Dist.pm-1.23 convention which CGI.pm and
# a few others use.
$dist =~ s{\.pm$}{};
$version = $1
if !length $version and $dist =~ s/-(\d+\w)$//;
$version = $1 . $version
if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
if ($version =~ /\d\.\d/) {
$version =~ s/^[-_.]+//;
}
else {
$version =~ s/^[-_]+//;
}
my $dev;
if (length $version) {
if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
$dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
}
elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
$dev = 1;
}
}
else {
$version = undef;
}
($dist, $version, $dev);
}
sub new {
my $class = shift;
my $distfile = shift;
$distfile =~ s,//+,/,g;
my %info = ( pathname => $distfile );
($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
and $info{cpanid} = $6;
if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
$info{distvname} = $1;
$info{extension} = $2;
}
@info{qw(dist version beta)} = distname_info($info{distvname});
$info{maturity} = delete $info{beta} ? 'developer' : 'released';
return bless \%info, $class;
}
sub dist { shift->{dist} }
sub version { shift->{version} }
sub maturity { shift->{maturity} }
sub filename { shift->{filename} }
sub cpanid { shift->{cpanid} }
sub distvname { shift->{distvname} }
sub extension { shift->{extension} }
sub pathname { shift->{pathname} }
sub properties { %{ $_[0] } }
1;
__END__
=head1 NAME
CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
=head1 SYNOPSIS
my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
my $d = CPAN::DistnameInfo->new($pathname);
my $dist = $d->dist; # "CPAN-DistnameInfo"
my $version = $d->version; # "0.02"
my $maturity = $d->maturity; # "released"
my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
my $cpanid = $d->cpanid; # "GBARR"
my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
my $extension = $d->extension; # "tar.gz"
my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..."
my %prop = $d->properties;
=head1 DESCRIPTION
Many online services that are centered around CPAN attempt to
associate multiple uploads by extracting a distribution name from
the filename of the upload. For most distributions this is easy as
they have used ExtUtils::MakeMaker or Module::Build to create the
distribution, which results in a uniform name. But sadly not all
uploads are created in this way.
C<CPAN::DistnameInfo> uses heuristics that have been learnt by
L<http://search.cpan.org/> to extract the distribution name and
version from filenames and also report if the version is to be
treated as a developer release
The constructor takes a single pathname, returning an object with the following methods
=over
=item cpanid
If the path given looked like a CPAN authors directory path, then this will be the
the CPAN id of the author.
=item dist
The name of the distribution
=item distvname
The file name with any suffix and leading directory names removed
=item filename
If the path given looked like a CPAN authors directory path, then this will be the
path to the file relative to the detected CPAN author directory. Otherwise it is the path
that was passed in.
=item maturity
The maturity of the distribution. This will be either C<released> or C<developer>
=item extension
The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
=item pathname
The pathname that was passed to the constructor when creating the object.
=item properties
This will return a list of key-value pairs, suitable for assigning to a hash,
for the known properties.
=item version
The extracted version
=back
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
=head1 COPYRIGHT
Copyright (c) 2003 Graham Barr. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.
=cut
CPAN_DISTNAMEINFO
$fatpacked{"HTTP/Lite.pm"} = <<'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;
}
}
1;
__END__
=pod
=head1 NAME
HTTP::Lite - Lightweight HTTP implementation
=head1 SYNOPSIS
use HTTP::Lite;
$http = new HTTP::Lite;
$req = $http->request("http://www.cpan.org/")
or die "Unable to get document: $!";
print $http->body();
=head1 DESCRIPTION
HTTP::Lite is a stand-alone lightweight HTTP/1.1 implementation
for perl. It is not intended as a replacement for the
fully-features LWP module. Instead, it is intended for use in
situations where it is desirable to install the minimal number of
modules to achieve HTTP support, or where LWP is not a good
candidate due to CPU overhead, such as slower processors.
HTTP::Lite is also significantly faster than LWP.
HTTP::Lite is ideal for CGI (or mod_perl) programs or for bundling
for redistribution with larger packages where only HTTP GET and
POST functionality are necessary.
HTTP::Lite supports basic POST and GET operations only. As of
0.2.1, HTTP::Lite supports HTTP/1.1 and is compliant with the Host
header, necessary for name based virtual hosting. Additionally,
HTTP::Lite now supports Proxies.
As of 2.0.0 HTTP::Lite now supports a callback to allow processing
of request data as it arrives. This is useful for handling very
large files without consuming memory.
If you require more functionality, such as FTP or HTTPS, please
see libwwwperl (LWP). LWP is a significantly better and more
comprehensive package than HTTP::Lite, and should be used instead
of HTTP::Lite whenever possible.
=head1 CONSTRUCTOR
=over 4
=item new
This is the constructor for HTTP::Lite. It presently takes no
arguments. A future version of HTTP::Lite might accept parameters.
=back
=head1 METHODS
=over 4
=item request ( $url, $data_callback, $cbargs )
Initiates a request to the specified URL.
Returns undef if an I/O error is encountered, otherwise the HTTP
status code will be returned. 200 series status codes represent
success, 300 represent temporary errors, 400 represent permanent
errors, and 500 represent server errors.
See F<http://www.w3.org/Protocols/HTTP/HTRESP.html> for detailled
information about HTTP status codes.
The $data_callback parameter, if used, is a way to filter the data as it is
received or to handle large transfers. It must be a function reference, and
will be passed: a reference to the instance of the http request making the
callback, a reference to the current block of data about to be added to the
body, and the $cbargs parameter (which may be anything). It must return
either a reference to the data to add to the body of the document, or undef.
If set_callback is used, $data_callback and $cbargs are not used. $cbargs
may be either a scalar or a reference.
The data_callback is called as:
&$data_callback( $self, $dataref, $cbargs )
An example use to save a document to file is:
# Write the data to the filehandle $cbargs
sub savetofile {
my ($self,$phase,$dataref,$cbargs) = @_;
print $cbargs $$dataref;
return undef;
}
$url = "$testpath/bigbinary.dat";
open OUT, ">bigbinary.dat";
$res = $http->request($url, \&savetofile, OUT);
close OUT;
=item set_callback ( $functionref, $dataref )
At various stages of the request, callbacks may be used to modify the
behaviour or to monitor the status of the request. These work like the
$data_callback parameter to request(), but are more verstaile. Using
set_callback disables $data_callback in request()
The callbacks are called as:
callback ( $self, $phase, $dataref, $cbargs )
The current phases are:
connect - connection has been established and headers are being
transmitted.
content-length - return value is used as the content-length. If undef,
and prepare_post() was used, the content length is
calculated.
done-headers - all headers have been sent
content - return value is used as content and is sent to client. Return
undef to use the internal content defined by prepare_post().
content-done - content has been successfuly transmitted.
data - A block of data has been received. The data is referenced by
$dataref. The return value is dereferenced and replaces the
content passed in. Return undef to avoid using memory for large
documents.
done - Request is done.
=item prepare_post ( $hashref )
Takes a reference to a hashed array of post form variables to upload.
Create the HTTP body and sets the method to POST.
=item http11_mode ( 0 | 1 )
Turns on or off HTTP/1.1 support. This is off by default due to
broken HTTP/1.1 servers. Use 1 to enable HTTP/1.1 support.
=item add_req_header ( $header, $value )
=item get_req_header ( $header )
=item delete_req_header ( $header )
Add, Delete, or a HTTP header(s) for the request. These functions
allow you to override any header. Presently, Host, User-Agent,
Content-Type, Accept, and Connection are pre-defined by the HTTP::Lite
module. You may not override Host, Connection, or Accept.
To provide (proxy) authentication or authorization, you would use:
use HTTP::Lite;
use MIME::Base64;
$http = new HTTP::Lite;
$encoded = encode_base64('username:password');
$http->add_req_header("Authorization", $encoded);
B<NOTE>: The present implementation limits you to one instance
of each header.
=item body
Returns the body of the document retured by the remote server.
=item headers_array
Returns an array of the HTTP headers returned by the remote
server.
=item headers_string
Returns a string representation of the HTTP headers returned by
the remote server.
=item get_header ( $header )
Returns an array of values for the requested header.
B<NOTE>: HTTP requests are not limited to a single instance of
each header. As a result, there may be more than one entry for
every header.
=item protocol
Returns the HTTP protocol identifier, as reported by the remote
server. This will generally be either HTTP/1.0 or HTTP/1.1.
=item proxy ( $proxy_server )
The URL or hostname of the proxy to use for the next request.
=item status
Returns the HTTP status code returned by the server. This is
also reported as the return value of I<request()>.
=item status_message
Returns the textual description of the status code as returned
by the server. The status string is not required to adhere to
any particular format, although most HTTP servers use a standard
set of descriptions.
=item reset
You must call this prior to re-using an HTTP::Lite handle,
otherwise the results are undefined.
=item local_addr ( $ip )
Explicity select the local IP address. 0.0.0.0 (default) lets the system
choose.
=item local_port ( $port )
Explicity select the local port. 0 (default and reccomended) lets the
system choose.
=item method ( $method )
Explicity set the method. Using prepare_post or reset overrides this
setting. Usual choices are GET, POST, PUT, HEAD
=back
=head1 EXAMPLES
# Get and print out the headers and body of the CPAN homepage
use HTTP::Lite;
$http = new HTTP::Lite;
$req = $http->request("http://www.cpan.org/")
or die "Unable to get document: $!";
die "Request failed ($req): ".$http->status_message()
if $req ne "200";
@headers = $http->headers_array();
$body = $http->body();
foreach $header (@headers)
{
print "$header$CRLF";
}
print "$CRLF";
print "$body$CRLF";
# POST a query to the dejanews USENET search engine
use HTTP::Lite;
$http = new HTTP::Lite;
%vars = (
"QRY" => "perl",
"ST" => "MS",
"svcclass" => "dncurrent",
"DBS" => "2"
);
$http->prepare_post(\%vars);
$req = $http->request("http://www.deja.com/dnquery.xp")
or die "Unable to get document: $!";
print "req: $req\n";
print $http->body();
=head1 UNIMPLEMENTED
- FTP
- HTTPS (SSL)
- Authenitcation/Authorizaton/Proxy-Authorization
are not directly supported, and require MIME::Base64.
- Redirects (Location) are not automatically followed
- multipart/form-data POSTs are not directly supported (necessary
for File uploads).
=head1 BUGS
Some broken HTTP/1.1 servers send incorrect chunk sizes
when transferring files. HTTP/1.1 mode is now disabled by
default.
=head1 AUTHOR
Roy Hooper <rhooper@thetoybox.org>
=head1 SEE ALSO
L<LWP>
RFC 2068 - HTTP/1.1 -http://www.w3.org/
=head1 COPYRIGHT
Copyright (c) 2000-2002 Roy Hooper. All rights reserved.
Some parts copyright 2009 Adam Kennedy.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
HTTP_LITE
$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA';
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
# vim:ts=8:sw=2:et:sta:sts=2
package Module::Metadata;
# stolen from Module::Build::Version and ::Base - this is perl licensed code,
# copyright them.
# This module provides routines to gather information about
# perl modules (assuming this may be expanded in the distant
# parrot future to look at other types of modules).
use strict;
use vars qw($VERSION);
$VERSION = '0.36_04';
$VERSION = eval $VERSION;
use File::Spec;
use IO::File;
use Module::Metadata::Version;
BEGIN {
if ($INC{'Log/Contextual.pm'}) {
Log::Contextual->import('log_info');
} else {
*log_info = sub (&) { warn $_[0]->() };
}
}
use File::Find qw(find);
my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
my $PKG_REGEXP = qr{ # match a package declaration
^[\s\{;]* # intro chars on a line
package # the word 'package'
\s+ # whitespace
([\w:]+) # a package name
\s* # optional whitespace
($V_NUM_REGEXP)? # optional version number
\s* # optional whitesapce
; # semicolon line terminator
}x;
my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
([\$*]) # sigil - $ or *
(
( # optional leading package name
(?:::|\')? # possibly starting like just :: (Ì la $::VERSION)
(?:\w+(?:::|\'))* # Foo::Bar:: ...
)?
VERSION
)\b
}x;
my $VERS_REGEXP = qr{ # match a VERSION definition
(?:
\(\s*$VARNAME_REGEXP\s*\) # with parens
|
$VARNAME_REGEXP # without parens
)
\s*
=[^=~] # = but not ==, nor =~
}x;
sub new_from_file {
my $class = shift;
my $filename = File::Spec->rel2abs( shift );
return undef unless defined( $filename ) && -f $filename;
return $class->_init(undef, $filename, @_);
}
sub new_from_module {
my $class = shift;
my $module = shift;
my %props = @_;
$props{inc} ||= \@INC;
my $filename = $class->find_module_by_name( $module, $props{inc} );
return undef unless defined( $filename ) && -f $filename;
return $class->_init($module, $filename, %props);
}
{
my $compare_versions = sub {
my ($v1, $op, $v2) = @_;
$v1 = Module::Metadata::Version->new($v1)
unless UNIVERSAL::isa($v1,'Module::Metadata::Version');
my $eval_str = "\$v1 $op \$v2";
my $result = eval $eval_str;
log_info { "error comparing versions: '$eval_str' $@" } if $@;
return $result;
};
my $normalize_version = sub {
my ($version) = @_;
if ( $version =~ /[=<>!,]/ ) { # logic, not just version
# take as is without modification
}
elsif ( ref $version eq 'version' ||
ref $version eq 'Module::Metadata::Version' ) { # version objects
$version = $version->is_qv ? $version->normal : $version->stringify;
}
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
# normalize string tuples without "v": "1.2.3" -> "v1.2.3"
$version = "v$version";
}
else {
# leave alone
}
return $version;
};
# separate out some of the conflict resolution logic
my $resolve_module_versions = sub {
my $packages = shift;
my( $file, $version );
my $err = '';
foreach my $p ( @$packages ) {
if ( defined( $p->{version} ) ) {
if ( defined( $version ) ) {
if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
$err .= " $p->{file} ($p->{version})\n";
} else {
# same version declared multiple times, ignore
}
} else {
$file = $p->{file};
$version = $p->{version};
}
}
$file ||= $p->{file} if defined( $p->{file} );
}
if ( $err ) {
$err = " $file ($version)\n" . $err;
}
my %result = (
file => $file,
version => $version,
err => $err
);
return \%result;
};
sub package_versions_from_directory {
my ( $class, $dir, $files ) = @_;
my @files;
if ( $files ) {
@files = @$files;
} else {
find( {
wanted => sub {
push @files, $_ if -f $_ && /\.pm$/;
},
no_chdir => 1,
}, $dir );
}
# First, we enumerate all packages & versions,
# separating into primary & alternative candidates
my( %prime, %alt );
foreach my $file (@files) {
my $mapped_filename = File::Spec->abs2rel( $file, $dir );
my @path = split( /\//, $mapped_filename );
(my $prime_package = join( '::', @path )) =~ s/\.pm$//;
my $pm_info = $class->new_from_file( $file );
foreach my $package ( $pm_info->packages_inside ) {
next if $package eq 'main'; # main can appear numerous times, ignore
next if $package eq 'DB'; # special debugging package, ignore
next if grep /^_/, split( /::/, $package ); # private package, ignore
my $version = $pm_info->version( $package );
if ( $package eq $prime_package ) {
if ( exists( $prime{$package} ) ) {
# M::B::ModuleInfo will handle this conflict
die "Unexpected conflict in '$package'; multiple versions found.\n";
} else {
$prime{$package}{file} = $mapped_filename;
$prime{$package}{version} = $version if defined( $version );
}
} else {
push( @{$alt{$package}}, {
file => $mapped_filename,
version => $version,
} );
}
}
}
# Then we iterate over all the packages found above, identifying conflicts
# and selecting the "best" candidate for recording the file & version
# for each package.
foreach my $package ( keys( %alt ) ) {
my $result = $resolve_module_versions->( $alt{$package} );
if ( exists( $prime{$package} ) ) { # primary package selected
if ( $result->{err} ) {
# Use the selected primary package, but there are conflicting
# errors among multiple alternative packages that need to be
# reported
log_info {
"Found conflicting versions for package '$package'\n" .
" $prime{$package}{file} ($prime{$package}{version})\n" .
$result->{err}
};
} elsif ( defined( $result->{version} ) ) {
# There is a primary package selected, and exactly one
# alternative package
if ( exists( $prime{$package}{version} ) &&
defined( $prime{$package}{version} ) ) {
# Unless the version of the primary package agrees with the
# version of the alternative package, report a conflict
if ( $compare_versions->(
$prime{$package}{version}, '!=', $result->{version}
)
) {
log_info {
"Found conflicting versions for package '$package'\n" .
" $prime{$package}{file} ($prime{$package}{version})\n" .
" $result->{file} ($result->{version})\n"
};
}
} else {
# The prime package selected has no version so, we choose to
# use any alternative package that does have a version
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version};
}
} else {
# no alt package found with a version, but we have a prime
# package so we use it whether it has a version or not
}
} else { # No primary package was selected, use the best alternative
if ( $result->{err} ) {
log_info {
"Found conflicting versions for package '$package'\n" .
$result->{err}
};
}
# Despite possible conflicting versions, we choose to record
# something rather than nothing
$prime{$package}{file} = $result->{file};
$prime{$package}{version} = $result->{version}
if defined( $result->{version} );
}
}
# Normalize versions. Can't use exists() here because of bug in YAML::Node.
# XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
for (grep defined $_->{version}, values %prime) {
$_->{version} = $normalize_version->( $_->{version} );
}
return \%prime;
}
}
sub _init {
my $class = shift;
my $module = shift;
my $filename = shift;
my %props = @_;
my( %valid_props, @valid_props );
@valid_props = qw( collect_pod inc );
@valid_props{@valid_props} = delete( @props{@valid_props} );
warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
my %data = (
module => $module,
filename => $filename,
version => undef,
packages => [],
versions => {},
pod => {},
pod_headings => [],
collect_pod => 0,
%valid_props,
);
my $self = bless(\%data, $class);
$self->_parse_file();
unless($self->{module} and length($self->{module})) {
my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
if($f =~ /\.pm$/) {
$f =~ s/\..+$//;
my @candidates = grep /$f$/, @{$self->{packages}};
$self->{module} = shift(@candidates); # punt
}
else {
if(grep /main/, @{$self->{packages}}) {
$self->{module} = 'main';
}
else {
$self->{module} = $self->{packages}[0] || '';
}
}
}
$self->{version} = $self->{versions}{$self->{module}}
if defined( $self->{module} );
return $self;
}
# class method
sub _do_find_module {
my $class = shift;
my $module = shift || die 'find_module_by_name() requires a package name';
my $dirs = shift || \@INC;
my $file = File::Spec->catfile(split( /::/, $module));
foreach my $dir ( @$dirs ) {
my $testfile = File::Spec->catfile($dir, $file);
return [ File::Spec->rel2abs( $testfile ), $dir ]
if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
if -e "$testfile.pm";
}
return;
}
# class method
sub find_module_by_name {
my $found = shift()->_do_find_module(@_) or return;
return $found->[0];
}
# class method
sub find_module_dir_by_name {
my $found = shift()->_do_find_module(@_) or return;
return $found->[1];
}
# given a line of perl code, attempt to parse it if it looks like a
# $VERSION assignment, returning sigil, full name, & package name
sub _parse_version_expression {
my $self = shift;
my $line = shift;
my( $sig, $var, $pkg );
if ( $line =~ $VERS_REGEXP ) {
( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
if ( $pkg ) {
$pkg = ($pkg eq '::') ? 'main' : $pkg;
$pkg =~ s/::$//;
}
}
return ( $sig, $var, $pkg );
}
sub _parse_file {
my $self = shift;
my $filename = $self->{filename};
my $fh = IO::File->new( $filename )
or die( "Can't open '$filename': $!" );
$self->_parse_fh($fh);
}
sub _parse_fh {
my ($self, $fh) = @_;
my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
my( @pkgs, %vers, %pod, @pod );
my $pkg = 'main';
my $pod_sect = '';
my $pod_data = '';
while (defined( my $line = <$fh> )) {
my $line_num = $.;
chomp( $line );
next if $line =~ /^\s*#/;
$in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
# Would be nice if we could also check $in_string or something too
last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
if ( $in_pod || $line =~ /^=cut/ ) {
if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
push( @pod, $1 );
if ( $self->{collect_pod} && length( $pod_data ) ) {
$pod{$pod_sect} = $pod_data;
$pod_data = '';
}
$pod_sect = $1;
} elsif ( $self->{collect_pod} ) {
$pod_data .= "$line\n";
}
} else {
$pod_sect = '';
$pod_data = '';
# parse $line to see if it's a $VERSION declaration
my( $vers_sig, $vers_fullname, $vers_pkg ) =
$self->_parse_version_expression( $line );
if ( $line =~ $PKG_REGEXP ) {
$pkg = $1;
push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
$vers{$pkg} = (defined $2 ? $2 : undef) unless exists( $vers{$pkg} );
$need_vers = defined $2 ? 0 : 1;
# VERSION defined with full package spec, i.e. $Module::VERSION
} elsif ( $vers_fullname && $vers_pkg ) {
push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
$need_vers = 0 if $vers_pkg eq $pkg;
unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
$vers{$vers_pkg} =
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
} else {
# Warn unless the user is using the "$VERSION = eval
# $VERSION" idiom (though there are probably other idioms
# that we should watch out for...)
warn <<"EOM" unless $line =~ /=\s*eval/;
Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
ignoring subsequent declaration on line $line_num.
EOM
}
# first non-comment line in undeclared package main is VERSION
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
$need_vers = 0;
my $v =
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
$vers{$pkg} = $v;
push( @pkgs, 'main' );
# first non-comment line in undeclared package defines package main
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
$need_vers = 1;
$vers{main} = '';
push( @pkgs, 'main' );
# only keep if this is the first $VERSION seen
} elsif ( $vers_fullname && $need_vers ) {
$need_vers = 0;
my $v =
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
$vers{$pkg} = $v;
} else {
warn <<"EOM";
Package '$pkg' already declared with version '$vers{$pkg}'
ignoring new version '$v' on line $line_num.
EOM
}
}
}
}
if ( $self->{collect_pod} && length($pod_data) ) {
$pod{$pod_sect} = $pod_data;
}
$self->{versions} = \%vers;
$self->{packages} = \@pkgs;
$self->{pod} = \%pod;
$self->{pod_headings} = \@pod;
}
{
my $pn = 0;
sub _evaluate_version_line {
my $self = shift;
my( $sigil, $var, $line ) = @_;
# Some of this code came from the ExtUtils:: hierarchy.
# We compile into $vsub because 'use version' would cause
# compiletime/runtime issues with local()
my $vsub;
$pn++; # everybody gets their own package
my $eval = qq{BEGIN { q# Hide from _packages_inside()
#; package Module::Metadata::_version::p$pn;
use Module::Metadata::Version;
no strict;
local $sigil$var;
\$$var=undef;
\$vsub = sub {
$line;
\$$var
};
}};
local $^W;
# Try to get the $VERSION
eval $eval;
# some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
# installed, so we need to hunt in ./lib for it
if ( $@ =~ /Can't locate/ && -d 'lib' ) {
local @INC = ('lib',@INC);
eval $eval;
}
warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
if $@;
(ref($vsub) eq 'CODE') or
die "failed to build version sub for $self->{filename}";
my $result = eval { $vsub->() };
die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
if $@;
# Activestate apparently creates custom versions like '1.23_45_01', which
# cause M::B::Version to think it's an invalid alpha. So check for that
# and strip them
my $num_dots = () = $result =~ m{\.}g;
my $num_unders = () = $result =~ m{_}g;
if ( substr($result,0,1) ne 'v' && $num_dots < 2 && $num_unders > 1 ) {
$result =~ s{_}{}g;
}
# Bless it into our own version class
eval { $result = Module::Metadata::Version->new($result) };
die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
if $@;
return $result;
}
}
############################################################
# accessors
sub name { $_[0]->{module} }
sub filename { $_[0]->{filename} }
sub packages_inside { @{$_[0]->{packages}} }
sub pod_inside { @{$_[0]->{pod_headings}} }
sub contains_pod { $#{$_[0]->{pod_headings}} }
sub version {
my $self = shift;
my $mod = shift || $self->{module};
my $vers;
if ( defined( $mod ) && length( $mod ) &&
exists( $self->{versions}{$mod} ) ) {
return $self->{versions}{$mod};
} else {
return undef;
}
}
sub pod {
my $self = shift;
my $sect = shift;
if ( defined( $sect ) && length( $sect ) &&
exists( $self->{pod}{$sect} ) ) {
return $self->{pod}{$sect};
} else {
return undef;
}
}
1;
__END__
=for :stopwords ModuleInfo
=head1 NAME
ModuleInfo - Gather package and POD information from a perl module file
=head1 DESCRIPTION
=over 4
=item new_from_file($filename, collect_pod => 1)
Construct a C<ModuleInfo> object given the path to a file. Takes an optional
argument C<collect_pod> which is a boolean that determines whether
POD data is collected and stored for reference. POD data is not
collected by default. POD headings are always collected.
=item new_from_module($module, collect_pod => 1, inc => \@dirs)
Construct a C<ModuleInfo> object given a module or package name. In addition
to accepting the C<collect_pod> argument as described above, this
method accepts a C<inc> argument which is a reference to an array of
of directories to search for the module. If none are given, the
default is @INC.
=item name()
Returns the name of the package represented by this module. If there
are more than one packages, it makes a best guess based on the
filename. If it's a script (i.e. not a *.pm) the package name is
'main'.
=item version($package)
Returns the version as defined by the $VERSION variable for the
package as returned by the C<name> method if no arguments are
given. If given the name of a package it will attempt to return the
version of that package if it is specified in the file.
=item filename()
Returns the absolute path to the file.
=item packages_inside()
Returns a list of packages.
=item pod_inside()
Returns a list of POD sections.
=item contains_pod()
Returns true if there is any POD in the file.
=item pod($section)
Returns the POD data in the given section.
=item find_module_by_name($module, \@dirs)
Returns the path to a module given the module or package name. A list
of directories can be passed in as an optional parameter, otherwise
@INC is searched.
Can be called as either an object or a class method.
=item find_module_dir_by_name($module, \@dirs)
Returns the entry in C<@dirs> (or C<@INC> by default) that contains
the module C<$module>. A list of directories can be passed in as an
optional parameter, otherwise @INC is searched.
Can be called as either an object or a class method.
=back
=head1 AUTHOR
Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
=head1 COPYRIGHT
Copyright (c) 2001-2006 Ken Williams. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
perl(1), L<Module::Metadata>(3)
=cut
MODULE_METADATA
$fatpacked{"Module/Metadata/Version.pm"} = <<'MODULE_METADATA_VERSION';
package Module::Metadata::Version;
use strict;
# stolen from Module::Build::Version - this is perl licensed code,
# copyright them.
use vars qw($VERSION);
$VERSION = 0.77;
eval "use version $VERSION";
if ($@) { # can't locate version files, use our own
# Avoid redefined warnings if an old version.pm was available
delete $version::{$_} foreach keys %version::;
# first we get the stub version module
my $version;
while (<DATA>) {
s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
$version .= $_ if $_;
last if /^1;$/;
}
# and now get the current version::vpp code
my $vpp;
while (<DATA>) {
s/(\$VERSION)\s=\s\d+/\$VERSION = 0/;
$vpp .= $_ if $_;
last if /^1;$/;
}
# but we eval them in reverse order since version depends on
# version::vpp to already exist
eval $vpp; die $@ if $@;
$INC{'version/vpp.pm'} = 'inside Module::Metadata::Version';
eval $version; die $@ if $@;
$INC{'version.pm'} = 'inside Module::Metadata::Version';
}
# now we can safely subclass version, installed or not
use vars qw(@ISA);
@ISA = qw(version);
1;
__DATA__
# stub version module to make everything else happy
package version;
use 5.005_04;
use strict;
use vars qw(@ISA $VERSION $CLASS *declare *qv);
$VERSION = 0.77;
$CLASS = 'version';
push @ISA, "version::vpp";
local $^W;
*version::qv = \&version::vpp::qv;
*version::declare = \&version::vpp::declare;
*version::_VERSION = \&version::vpp::_VERSION;
if ($] > 5.009001 && $] <= 5.010000) {
no strict 'refs';
*{'version::stringify'} = \*version::vpp::stringify;
*{'version::(""'} = \*version::vpp::stringify;
*{'version::new'} = \*version::vpp::new;
}
# Preloaded methods go here.
sub import {
no strict 'refs';
my ($class) = shift;
# Set up any derived class
unless ($class eq 'version') {
local $^W;
*{$class.'::declare'} = \&version::declare;
*{$class.'::qv'} = \&version::qv;
}
my %args;
if (@_) { # any remaining terms are arguments
map { $args{$_} = 1 } @_
}
else { # no parameters at all on use line
%args =
(
qv => 1,
'UNIVERSAL::VERSION' => 1,
);
}
my $callpkg = caller();
if (exists($args{declare})) {
*{$callpkg."::declare"} =
sub {return $class->declare(shift) }
unless defined(&{$callpkg.'::declare'});
}
if (exists($args{qv})) {
*{$callpkg."::qv"} =
sub {return $class->qv(shift) }
unless defined(&{"$callpkg\::qv"});
}
if (exists($args{'UNIVERSAL::VERSION'})) {
local $^W;
*UNIVERSAL::VERSION = \&version::_VERSION;
}
if (exists($args{'VERSION'})) {
*{$callpkg."::VERSION"} = \&version::_VERSION;
}
}
1;
# replace everything from here to the end with the current version/vpp.pm
package version::vpp;
use strict;
use POSIX qw/locale_h/;
use locale;
use vars qw ($VERSION @ISA @REGEXS);
$VERSION = '0.77';
$VERSION = eval $VERSION;
push @REGEXS, qr/
^v? # optional leading 'v'
(\d*) # major revision not required
\. # requires at least one decimal
(?:(\d+)\.?){1,}
/x;
use overload (
'""' => \&stringify,
'0+' => \&numify,
'cmp' => \&vcmp,
'<=>' => \&vcmp,
'bool' => \&vbool,
'nomethod' => \&vnoop,
);
my $VERSION_MAX = 0x7FFFFFFF;
eval "use warnings";
if ($@) {
eval '
package warnings;
sub enabled {return $^W;}
1;
';
}
sub new
{
my ($class, $value) = @_;
my $self = bless ({}, ref ($class) || $class);
if ( ref($value) && eval('$value->isa("version")') ) {
# Can copy the elements directly
$self->{version} = [ @{$value->{version} } ];
$self->{qv} = 1 if $value->{qv};
$self->{alpha} = 1 if $value->{alpha};
$self->{original} = ''.$value->{original};
return $self;
}
my $currlocale = setlocale(LC_ALL);
# if the current locale uses commas for decimal points, we
# just replace commas with decimal places, rather than changing
# locales
if ( localeconv()->{decimal_point} eq ',' ) {
$value =~ tr/,/./;
}
if ( not defined $value or $value =~ /^undef$/ ) {
# RT #19517 - special case for undef comparison
# or someone forgot to pass a value
push @{$self->{version}}, 0;
$self->{original} = "0";
return ($self);
}
if ( $#_ == 2 ) { # must be CVS-style
$value = 'v'.$_[2];
}
$value = _un_vstring($value);
# exponential notation
if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
$value = sprintf("%.9f",$value);
$value =~ s/(0+)$//; # trim trailing zeros
}
# This is not very efficient, but it is morally equivalent
# to the XS code (as that is the reference implementation).
# See vutil/vutil.c for details
my $qv = 0;
my $alpha = 0;
my $width = 3;
my $saw_period = 0;
my $vinf = 0;
my ($start, $last, $pos, $s);
$s = 0;
while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK
$s++;
}
if (substr($value,$s,1) eq 'v') {
$s++; # get past 'v'
$qv = 1; # force quoted version processing
}
$start = $last = $pos = $s;
# pre-scan the input string to check for decimals/underbars
while ( substr($value,$pos,1) =~ /[._\d,]/ ) {
if ( substr($value,$pos,1) eq '.' ) {
if ($alpha) {
Carp::croak("Invalid version format ".
"(underscores before decimal)");
}
$saw_period++;
$last = $pos;
}
elsif ( substr($value,$pos,1) eq '_' ) {
if ($alpha) {
require Carp;
Carp::croak("Invalid version format ".
"(multiple underscores)");
}
$alpha = 1;
$width = $pos - $last - 1; # natural width of sub-version
}
elsif ( substr($value,$pos,1) eq ','
and substr($value,$pos+1,1) =~ /[0-9]/ ) {
# looks like an unhandled locale
$saw_period++;
$last = $pos;
}
$pos++;
}
if ( $alpha && !$saw_period ) {
require Carp;
Carp::croak("Invalid version format ".
"(alpha without decimal)");
}
if ( $alpha && $saw_period && $width == 0 ) {
require Carp;
Carp::croak("Invalid version format ".
"(misplaced _ in number)");
}
if ( $saw_period > 1 ) {
$qv = 1; # force quoted version processing
}
$last = $pos;
$pos = $s;
if ( $qv ) {
$self->{qv} = 1;
}
if ( $alpha ) {
$self->{alpha} = 1;
}
if ( !$qv && $width < 3 ) {
$self->{width} = $width;
}
while ( substr($value,$pos,1) =~ /\d/ ) {
$pos++;
}
if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ###
my $rev;
while (1) {
$rev = 0;
{
# this is atoi() that delimits on underscores
my $end = $pos;
my $mult = 1;
my $orev;
# the following if() will only be true after the decimal
# point of a version originally created with a bare
# floating point number, i.e. not quoted in any way
if ( !$qv && $s > $start && $saw_period == 1 ) {
$mult *= 100;
while ( $s < $end ) {
$orev = $rev;
$rev += substr($value,$s,1) * $mult;
$mult /= 10;
if ( abs($orev) > abs($rev)
|| abs($rev) > abs($VERSION_MAX) ) {
if ( warnings::enabled("overflow") ) {
require Carp;
Carp::carp("Integer overflow in version");
}
$s = $end - 1;
$rev = $VERSION_MAX;
}
$s++;
if ( substr($value,$s,1) eq '_' ) {
$s++;
}
}
}
else {
while (--$end >= $s) {
$orev = $rev;
$rev += substr($value,$end,1) * $mult;
$mult *= 10;
if ( abs($orev) > abs($rev)
|| abs($rev) > abs($VERSION_MAX) ) {
if ( warnings::enabled("overflow") ) {
require Carp;
Carp::carp("Integer overflow in version");
}
$end = $s - 1;
$rev = $VERSION_MAX;
}
}
}
}
# Append revision
push @{$self->{version}}, $rev;
if ( substr($value,$pos,1) eq '.'
&& substr($value,$pos+1,1) =~ /\d/ ) {
$s = ++$pos;
}
elsif ( substr($value,$pos,1) eq '_'
&& substr($value,$pos+1,1) =~ /\d/ ) {
$s = ++$pos;
}
elsif ( substr($value,$pos,1) eq ','
&& substr($value,$pos+1,1) =~ /\d/ ) {
$s = ++$pos;
}
elsif ( substr($value,$pos,1) =~ /\d/ ) {
$s = $pos;
}
else {
$s = $pos;
last;
}
if ( $qv ) {
while ( substr($value,$pos,1) =~ /\d/ ) {
$pos++;
}
}
else {
my $digits = 0;
while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) {
if ( substr($value,$pos,1) ne '_' ) {
$digits++;
}
$pos++;
}
}
}
}
if ( $qv ) { # quoted versions always get at least three terms
my $len = scalar @{$self->{version}};
$len = 3 - $len;
while ($len-- > 0) {
push @{$self->{version}}, 0;
}
}
if ( substr($value,$pos) ) { # any remaining text
if ( warnings::enabled("misc") ) {
require Carp;
Carp::carp("Version string '$value' contains invalid data; ".
"ignoring: '".substr($value,$pos)."'");
}
}
# cache the original value for use when stringification
if ( $vinf ) {
$self->{vinf} = 1;
$self->{original} = 'v.Inf';
}
else {
$self->{original} = substr($value,0,$pos);
}
return ($self);
}
*parse = \&new;
sub numify
{
my ($self) = @_;
unless (_verify($self)) {
require Carp;
Carp::croak("Invalid version object");
}
my $width = $self->{width} || 3;
my $alpha = $self->{alpha} || "";
my $len = $#{$self->{version}};
my $digit = $self->{version}[0];
my $string = sprintf("%d.", $digit );
for ( my $i = 1 ; $i < $len ; $i++ ) {
$digit = $self->{version}[$i];
if ( $width < 3 ) {
my $denom = 10**(3-$width);
my $quot = int($digit/$denom);
my $rem = $digit - ($quot * $denom);
$string .= sprintf("%0".$width."d_%d", $quot, $rem);
}
else {
$string .= sprintf("%03d", $digit);
}
}
if ( $len > 0 ) {
$digit = $self->{version}[$len];
if ( $alpha && $width == 3 ) {
$string .= "_";
}
$string .= sprintf("%0".$width."d", $digit);
}
else # $len = 0
{
$string .= sprintf("000");
}
return $string;
}
sub normal
{
my ($self) = @_;
unless (_verify($self)) {
require Carp;
Carp::croak("Invalid version object");
}
my $alpha = $self->{alpha} || "";
my $len = $#{$self->{version}};
my $digit = $self->{version}[0];
my $string = sprintf("v%d", $digit );
for ( my $i = 1 ; $i < $len ; $i++ ) {
$digit = $self->{version}[$i];
$string .= sprintf(".%d", $digit);
}
if ( $len > 0 ) {
$digit = $self->{version}[$len];
if ( $alpha ) {
$string .= sprintf("_%0d", $digit);
}
else {
$string .= sprintf(".%0d", $digit);
}
}
if ( $len <= 2 ) {
for ( $len = 2 - $len; $len != 0; $len-- ) {
$string .= sprintf(".%0d", 0);
}
}
return $string;
}
sub stringify
{
my ($self) = @_;
unless (_verify($self)) {
require Carp;
Carp::croak("Invalid version object");
}
return exists $self->{original}
? $self->{original}
: exists $self->{qv}
? $self->normal
: $self->numify;
}
sub vcmp
{
require UNIVERSAL;
my ($left,$right,$swap) = @_;
my $class = ref($left);
unless ( UNIVERSAL::isa($right, $class) ) {
$right = $class->new($right);
}
if ( $swap ) {
($left, $right) = ($right, $left);
}
unless (_verify($left)) {
require Carp;
Carp::croak("Invalid version object");
}
unless (_verify($right)) {
require Carp;
Carp::croak("Invalid version object");
}
my $l = $#{$left->{version}};
my $r = $#{$right->{version}};
my $m = $l < $r ? $l : $r;
my $lalpha = $left->is_alpha;
my $ralpha = $right->is_alpha;
my $retval = 0;
my $i = 0;
while ( $i <= $m && $retval == 0 ) {
$retval = $left->{version}[$i] <=> $right->{version}[$i];
$i++;
}
# tiebreaker for alpha with identical terms
if ( $retval == 0
&& $l == $r
&& $left->{version}[$m] == $right->{version}[$m]
&& ( $lalpha || $ralpha ) ) {
if ( $lalpha && !$ralpha ) {
$retval = -1;
}
elsif ( $ralpha && !$lalpha) {
$retval = +1;
}
}
# possible match except for trailing 0's
if ( $retval == 0 && $l != $r ) {
if ( $l < $r ) {
while ( $i <= $r && $retval == 0 ) {
if ( $right->{version}[$i] != 0 ) {
$retval = -1; # not a match after all
}
$i++;
}
}
else {
while ( $i <= $l && $retval == 0 ) {
if ( $left->{version}[$i] != 0 ) {
$retval = +1; # not a match after all
}
$i++;
}
}
}
return $retval;
}
sub vbool {
my ($self) = @_;
return vcmp($self,$self->new("0"),1);
}
sub vnoop {
require Carp;
Carp::croak("operation not supported with version object");
}
sub is_alpha {
my ($self) = @_;
return (exists $self->{alpha});
}
sub qv {
my $value = shift;
my $class = 'version';
if (@_) {
$class = ref($value) || $value;
$value = shift;
}
$value = _un_vstring($value);
$value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
my $version = $class->new($value);
return $version;
}
*declare = \&qv;
sub is_qv {
my ($self) = @_;
return (exists $self->{qv});
}
sub _verify {
my ($self) = @_;
if ( ref($self)
&& eval { exists $self->{version} }
&& ref($self->{version}) eq 'ARRAY'
) {
return 1;
}
else {
return 0;
}
}
sub _un_vstring {
my $value = shift;
# may be a v-string
if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) {
my $tvalue = sprintf("v%vd",$value);
if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) {
# must be a v-string
$value = $tvalue;
}
}
return $value;
}
sub _VERSION {
my ($obj, $req) = @_;
my $class = ref($obj) || $obj;
no strict 'refs';
if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
# file but no package
require Carp;
Carp::croak( "$class defines neither package nor VERSION"
."--version check failed");
}
my $version = eval "\$$class\::VERSION";
if ( defined $version ) {
local $^W if $] <= 5.008;
$version = version::vpp->new($version);
}
if ( defined $req ) {
unless ( defined $version ) {
require Carp;
my $msg = $] < 5.006
? "$class version $req required--this is only version "
: "$class does not define \$$class\::VERSION"
."--version check failed";
if ( $ENV{VERSION_DEBUG} ) {
Carp::confess($msg);
}
else {
Carp::croak($msg);
}
}
$req = version::vpp->new($req);
if ( $req > $version ) {
require Carp;
if ( $req->is_qv ) {
Carp::croak(
sprintf ("%s version %s required--".
"this is only version %s", $class,
$req->normal, $version->normal)
);
}
else {
Carp::croak(
sprintf ("%s version %s required--".
"this is only version %s", $class,
$req->stringify, $version->stringify)
);
}
}
}
return defined $version ? $version->stringify : undef;
}
1; #this line is important and will help the module return a true value
MODULE_METADATA_VERSION
$fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META';
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;
}
1;
__END__
=pod
=head1 NAME
Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files
=head1 SYNOPSIS
#############################################
# In your file
---
rootproperty: blah
section:
one: two
three: four
Foo: Bar
empty: ~
#############################################
# In your program
use Parse::CPAN::Meta;
# Create a YAML file
my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' );
# Reading properties
my $root = $yaml[0]->{rootproperty};
my $one = $yaml[0]->{section}->{one};
my $Foo = $yaml[0]->{section}->{Foo};
=head1 DESCRIPTION
B<Parse::CPAN::Meta> is a parser for F<META.yml> files, based on the
parser half of L<YAML::Tiny>.
It supports a basic subset of the full YAML specification, enough to
implement parsing of typical F<META.yml> files, and other similarly simple
YAML files.
If you need something with more power, move up to a full YAML parser such
as L<YAML>, L<YAML::Syck> or L<YAML::LibYAML>.
B<Parse::CPAN::Meta> provides a very simply API of only two functions,
based on the YAML functions of the same name. Wherever possible,
identical calling semantics are used.
All error reporting is done with exceptions (die'ing).
=head1 FUNCTIONS
For maintenance clarity, no functions are exported.
=head2 Load
my @yaml = Load( $string );
Parses a string containing a valid YAML stream into a list of Perl data
structures.
=head2 LoadFile
my @yaml = LoadFile( 'META.yml' );
Reads the YAML stream from a file instead of a string.
=head1 SUPPORT
Bugs should be reported via the CPAN bug tracker at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Parse-CPAN-Meta>
=head1 AUTHOR
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
=head1 SEE ALSO
L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
L<http://use.perl.org/~Alias/journal/29427>, L<http://ali.as/>
=head1 COPYRIGHT
Copyright 2006 - 2009 Adam Kennedy.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut
PARSE_CPAN_META
$fatpacked{"local/lib.pm"} = <<'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.006000'; # 1.6.0
our @KNOWN_FLAGS = qw(--self-contained);
sub import {
my ($class, @args) = @_;
# 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'}) {
die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n";
}
$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(@_);
};
}
}
=begin testing
#:: test pipeline
package local::lib;
{ package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } }
my $foo = bless({}, 'Foo');
Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15);
=end testing
=cut
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';
}
}
=begin testing
#:: test classmethod setup
my $c = 'local::lib';
=end testing
=begin testing
#:: test classmethod
is($c->resolve_empty_path, '~/perl5');
is($c->resolve_empty_path('foo'), 'foo');
=end testing
=cut
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);
}
=begin testing
#:: test classmethod
local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; };
is($c->resolve_relative_path('bar'),'FOObar');
=end testing
=cut
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%' ))
),
)
}
=begin testing
#:: test classmethod
File::Path::rmtree('t/var/splat');
$c->ensure_dir_structure_for('t/var/splat');
ok(-d 't/var/splat');
ok(-f 't/var/splat/.modulebuildrc');
=end testing
=head1 NAME
local::lib - create and use a local lib/ for perl modules with PERL5LIB
=head1 SYNOPSIS
In code -
use local::lib; # sets up a local lib at ~/perl5
use local::lib '~/foo'; # same, but ~/foo
# Or...
use FindBin;
use local::lib "$FindBin::Bin/../support"; # app-local support library
From the shell -
# Install LWP and its missing dependencies to the '~/perl5' directory
perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)'
# Just print out useful shell commands
$ perl -Mlocal::lib
export MODULEBUILDRC=/home/username/perl/.modulebuildrc
export PERL_MM_OPT='INSTALL_BASE=/home/username/perl'
export PERL5LIB='/home/username/perl/lib/perl5:/home/username/perl/lib/perl5/i386-linux'
export PATH="/home/username/perl/bin:$PATH"
=head2 The bootstrapping technique
A typical way to install local::lib is using what is known as the
"bootstrapping" technique. You would do this if your system administrator
hasn't already installed local::lib. In this case, you'll need to install
local::lib in your home directory.
1. Download and unpack the local::lib tarball from CPAN (search for "Download"
on the CPAN page about local::lib). Do this as an ordinary user, not as root
or administrator. Unpack the file in your home directory or in any other
convenient location.
2. Run this:
perl Makefile.PL --bootstrap
If the system asks you whether it should automatically configure as much
as possible, you would typically answer yes.
3. Run this:
make test && make install
4. Arrange for Perl to use your own packages instead of the system
packages. If you are using bash, you can do this as follows:
echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc
If you are using C shell, you can do this as follows:
/bin/csh
echo $SHELL
/bin/csh
perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc
You can also pass --bootstrap=~/foo to get a different location -
perl Makefile.PL --bootstrap=~/foo
make test && make install
echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc
After writing your shell configuration file, be sure to re-read it to get the
changed settings into your current shell's environment. Bourne shells use C<.
~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>. Replace .bashrc or
.cshrc with the name of the file you wrote above with the echo command.
If you're on a slower machine, or are operating under draconian disk space
limitations, you can disable the automatic generation of manpages from POD when
installing modules by using the C<--no-manpages> argument when bootstrapping:
perl Makefile.PL --bootstrap --no-manpages
If you want to install multiple Perl module environments, say for application development,
install local::lib globally and then:
cd ~/mydir1
perl -Mlocal::lib=./
eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone
printenv ### You will see that ~/mydir1 is in the PERL5LIB
perl -MCPAN -e install ... ### whatever modules you want
cd ../mydir2
... REPEAT ...
For multiple environments for multiple apps you may need to include a modified
version of the C<< use FindBin >> instructions in the "In code" sample above.
If you did something like the above, you have a set of Perl modules at C<<
~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>,
you need to tell it where to find the modules you installed for it at C<<
~/mydir1/lib >>.
In C<< ~/mydir1/scripts/myscript.pl >>:
use strict;
use warnings;
use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib
use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib
Put this before any BEGIN { ... } blocks that require the modules you installed.
=head2 Differences when using this module under Win32
C:\>perl -Mlocal::lib
set MODULEBUILDRC=C:\DOCUME~1\ADMINI~1\perl5\.modulebuildrc
set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5
set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread
set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH%
### To set the environment for this shell alone
C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat
### instead of $(perl -Mlocal::lib=./)
If you want the environment entries to persist, you'll need to add then to the
Control Panel's System applet yourself at the moment.
The "~" is translated to the user's profile directory (the directory named for
the user under "Documents and Settings" (Windows XP or earlier) or "Users"
(Windows Vista or later) unless $ENV{HOME} exists. After that, the home
directory is translated to a short name (which means the directory must exist)
and the subdirectories are created.
=head1 RATIONALE
The version of a Perl package on your machine is not always the version you
need. Obviously, the best thing to do would be to update to the version you
need. However, you might be in a situation where you're prevented from doing
this. Perhaps you don't have system administrator privileges; or perhaps you
are using a package management system such as Debian, and nobody has yet gotten
around to packaging up the version you need.
local::lib solves this problem by allowing you to create your own directory of
Perl packages downloaded from CPAN (in a multi-user system, this would typically
be within your own home directory). The existing system Perl installation is
not affected; you simply invoke Perl with special options so that Perl uses the
packages in your own local package directory rather than the system packages.
local::lib arranges things so that your locally installed version of the Perl
packages takes precedence over the system installation.
If you are using a package management system (such as Debian), you don't need to
worry about Debian and CPAN stepping on each other's toes. Your local version
of the packages will be written to an entirely separate directory from those
installed by Debian.
=head1 DESCRIPTION
This module provides a quick, convenient way of bootstrapping a user-local Perl
module library located within the user's home directory. It also constructs and
prints out for the user the list of environment variables using the syntax
appropriate for the user's current shell (as specified by the C<SHELL>
environment variable), suitable for directly adding to one's shell
configuration file.
More generally, local::lib allows for the bootstrapping and usage of a
directory containing Perl modules outside of Perl's C<@INC>. This makes it
easier to ship an application with an app-specific copy of a Perl module, or
collection of modules. Useful in cases like when an upstream maintainer hasn't
applied a patch to a module of theirs that you need for your application.
On import, local::lib sets the following environment variables to appropriate
values:
=over 4
=item MODULEBUILDRC
=item PERL_MM_OPT
=item PERL5LIB
=item PATH
PATH is appended to, rather than clobbered.
=back
These values are then available for reference by any code after import.
=head1 CREATING A SELF-CONTAINED SET OF MODULES
See L<lib::core::only|lib::core::only> for one way to do this - but note that
there are a number of caveats, and the best approach is always to perform a
build against a clean perl (i.e. site and vendor as close to empty as possible).
=head1 METHODS
=head2 ensure_directory_structure_for
=over 4
=item Arguments: path
=back
Attempts to create the given path, and all required parent directories. Throws
an exception on failure.
=head2 print_environment_vars_for
=over 4
=item Arguments: path
=back
Prints to standard output the variables listed above, properly set to use the
given path as the base directory.
=head2 setup_env_hash_for
=over 4
=item Arguments: path
=back
Constructs the C<%ENV> keys for the given path, by calling
C<build_environment_vars_for>.
=head2 install_base_perl_path
=over 4
=item Arguments: path
=back
Returns a path describing where to install the Perl modules for this local
library installation. Appends the directories C<lib> and C<perl5> to the given
path.
=head2 install_base_arch_path
=over 4
=item Arguments: path
=back
Returns a path describing where to install the architecture-specific Perl
modules for this local library installation. Based on the
L</install_base_perl_path> method's return value, and appends the value of
C<$Config{archname}>.
=head2 install_base_bin_path
=over 4
=item Arguments: path
=back
Returns a path describing where to install the executable programs for this
local library installation. Based on the L</install_base_perl_path> method's
return value, and appends the directory C<bin>.
=head2 modulebuildrc_path
=over 4
=item Arguments: path
=back
Returns a path describing where to install the C<.modulebuildrc> file, based on
the given path.
=head2 resolve_empty_path
=over 4
=item Arguments: path
=back
Builds and returns the base path into which to set up the local module
installation. Defaults to C<~/perl5>.
=head2 resolve_home_path
=over 4
=item Arguments: path
=back
Attempts to find the user's home directory. If installed, uses C<File::HomeDir>
for this purpose. If no definite answer is available, throws an exception.
=head2 resolve_relative_path
=over 4
=item Arguments: path
=back
Translates the given path into an absolute path.
=head2 resolve_path
=over 4
=item Arguments: path
=back
Calls the following in a pipeline, passing the result from the previous to the
next, in an attempt to find where to configure the environment for a local
library installation: L</resolve_empty_path>, L</resolve_home_path>,
L</resolve_relative_path>. Passes the given path argument to
L</resolve_empty_path> which then returns a result that is passed to
L</resolve_home_path>, which then has its result passed to
L</resolve_relative_path>. The result of this final call is returned from
L</resolve_path>.
=head1 A WARNING ABOUT UNINST=1
Be careful about using local::lib in combination with "make install UNINST=1".
The idea of this feature is that will uninstall an old version of a module
before installing a new one. However it lacks a safety check that the old
version and the new version will go in the same directory. Used in combination
with local::lib, you can potentially delete a globally accessible version of a
module while installing the new version in a local place. Only combine "make
install UNINST=1" and local::lib if you understand these possible consequences.
=head1 LIMITATIONS
Rather basic shell detection. Right now anything with csh in its name is
assumed to be a C shell or something compatible, and everything else is assumed
to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is
not set, a Bourne-compatible shell is assumed.
Bootstrap is a hack and will use CPAN.pm for ExtUtils::MakeMaker even if you
have CPANPLUS installed.
Kills any existing PERL5LIB, PERL_MM_OPT or MODULEBUILDRC.
Should probably auto-fixup CPAN config if not already done.
Patches very much welcome for any of the above.
On Win32 systems, does not have a way to write the created environment variables
to the registry, so that they can persist through a reboot.
=head1 TROUBLESHOOTING
If you've configured local::lib to install CPAN modules somewhere in to your
home directory, and at some point later you try to install a module with C<cpan
-i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
/usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an
error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then
you've somehow lost your updated ExtUtils::MakeMaker module.
To remedy this situation, rerun the bootstrapping procedure documented above.
Then, run C<rm -r ~/.cpan/build/Foo-Bar*>
Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
=head1 ENVIRONMENT
=over 4
=item SHELL
=item COMSPEC
local::lib looks at the user's C<SHELL> environment variable when printing out
commands to add to the shell configuration file.
On Win32 systems, C<COMSPEC> is also examined.
=back
=head1 AUTHOR
Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
auto_install fixes kindly sponsored by http://www.takkle.com/
=head1 CONTRIBUTORS
Patches to correctly output commands for csh style shells, as well as some
documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>.
Doc patches for a custom local::lib directory contributed by Torsten Raudssus
<torsten@raudssus.de>.
Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring
things will install properly, submitted a fix for the bug causing problems with
writing Makefiles during bootstrapping, contributed an example program, and
submitted yet another fix to ensure that local::lib can install and bootstrap
properly. Many, many thanks!
pattern of Freenode IRC contributed the beginnings of the Troubleshooting
section. Many thanks!
Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>.
Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
by a patch from Marco Emilio Poleggi.
Mark Stosberg <mark@summersault.com> provided the code for the now deleted
'--self-contained' option.
=head1 COPYRIGHT
Copyright (c) 2007 - 2009 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as
listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself.
=cut
1;
LOCAL_LIB
s/^ //mg for values %fatpacked;
unshift @INC, sub {
if (my $fat = $fatpacked{$_[1]}) {
open my $fh, '<', \$fat;
return $fh;
}
return
};
} # END OF FATPACK CODE
use strict;
use App::cpanminus::script;
unless (caller) {
my $app = App::cpanminus::script->new;
$app->parse_options(@ARGV);
$app->doit or exit(1);
}
__END__
=head1 NAME
cpanm - get, unpack build and install modules from CPAN
=head1 SYNOPSIS
cpanm Test::More # install Test::More
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
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
cpanm -L extlib Plack # install Plack and all non-core deps into extlib
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
=head1 COMMANDS
=over 4
=item -i, --install
Installs the modules. This is a default behavior and this is just a
compatibility option to make it work like L<cpan> or L<cpanp>.
=item --self-upgrade
Upgrades itself. It's just an alias for:
cpanm --skip-installed App::cpanminus
=item --info
Displays the distribution information in
C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out.
=item --installdeps
Installs the dependencies of the target distribution but won't build
itself. Handy if you want to try the application from a version
controlled repository such as git.
cpanm --installdeps .
=item --look
Download and unpack the distribution and then open the directory with
your shell. Handy to poke around the source code or do the manual
testing.
=item -h, --help
Displays the help message.
=item -V, --version
Displays the version number.
=back
=head1 OPTIONS
You can specify the default options in C<PERL_CPANM_OPT> environment variable.
=over 4
=item -f, --force
Force install modules even when testing failed.
Defaults to false, and you can say C<--no-force> to override when it
is set in the default options in C<PERL_CPANM_OPT>.
=item -n, --notest
Skip the testing of modules. Use this only when you just want to save
time for installing hundreds of distributions to the same perl and
architecture you've already tested to make sure it builds fine.
Defaults to false, and you can say C<--no-notest> to override when it
is set in the default options in C<PERL_CPANM_OPT>.
=item -S, --sudo
Switch to the root user with C<sudo> when installing modules. Use this
if you want to install modules to the system perl include path.
Defaults to false, and you can say C<--no-sudo> to override when it is
set in the default options in C<PERL_CPANM_OPT>.
=item -v, --verbose
Makes the output verbose. It also enables the interactive
configuration. (See --interactive)
=item -q, --quiet
Makes the output even more quiet than the default. It doesn't print
anything to the STDERR.
=item -l, --local-lib
Sets the L<local::lib> compatible path to install modules to. You
don't need to set this if you already configure the shell environment
variables using L<local::lib>, but this can be used to override that
as well.
=item -L, --local-lib-contained
Same with C<--local-lib> but when examining the dependencies, it
assumes no non-core modules are installed on the system. It's handy if
you want to bundle application dependencies in one directory so you
can distribute to other machines.
For instance,
cpanm -L extlib Plack
would install Plack and all of its non-core dependencies into the
directory C<extlib>, which can be loaded from your application with:
use local::lib '/path/to/extlib';
=item --mirror
Specifies the base URL for the CPAN mirror to use, such as
C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You
can specify multiple mirror URLs by repeating the command line option.
Defaults to C<http://search.cpan.org/CPAN> which is a geo location
aware redirector.
=item --prompt
Prompts when a test fails so that you can skip, force install, retry
or look in the shell to see what's going wrong. It also prompts when
one of the dependency failed if you want to proceed the installation.
Defaults to false, and you can say C<--no-prompt> to override if it's
set in the default options in C<PERL_CPANM_OPT>.
=item --skip-installed
cpanm by default reinstalls the given module even if the latest
version is already installed. This option makes it check the installed
version first and skips if it's already the latest.
Defaults to false, and you can say C<--no-skip-installed> to override
when it's set in the default options in C<PERL_CPANM_OPT>.
=item --interactive
Makes the configuration (such as C<Makefile.PL> and C<Build.PL>)
interactive, so you can answer questions in the distribution that
requires custom configuration or Task:: distributions.
Defaults to false, and you can say C<--no-interactive> to override
when it's set in the default options in C<PERL_CPANM_OPT>.
=item --uninst-shadows
Uninstalls the shadow files of the distribution that you're
installing. This eliminates the confusion if you're trying to install
core (dual-life) modules from CPAN against perl 5.10 or older, or
modules that used to be XS-based but switched to pure perl at some
version.
If you run cpanm as root and use C<INSTALL_BASE> or equivalent to
specify custom installation path, you SHOULD disable this option so
you won't accidentally uninstall dual-life modules from the core
include path.
Defaults to true, and you can disable that with
C<--no-uninst-shadows>.
=item --lwp
Uses L<LWP> module to download stuff over HTTP. Defaults to true, and
you can say C<--no-lwp> to disable using LWP, when you want to upgrade
LWP from CPAN on some broken perl systems.
=back
=head1 SEE ALSO
L<App::cpanminus>
=head1 COPYRIGHT
Copyright 2010 Tatsuhiko Miyagawa.
=head1 AUTHOR
Tatsuhiko Miyagawa
=cut