Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

executable file 5829 lines (4586 sloc) 167.859 kb
#!/usr/bin/env 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.0003";
=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.0003";
$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 (WIN32 && ref $cmd eq 'ARRAY') {
$cmd = join q{ }, map { $self->shell_quote($_) } @$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);