#!/usr/bin/env perl # # You want to install cpanminus? Run the following command and it will # install itself for you. You might want to run it as a root with sudo # if you want to install to places like /usr/local/bin. # # % curl -L http://cpanmin.us | perl - --self-upgrade # # If you don't have curl but wget, replace `curl -L` with `wget -O -`. # # For more details about this program, visit http://search.cpan.org/dist/App-cpanminus # # 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.0012"; =head1 NAME App::cpanminus - get, unpack, build and install modules from CPAN =head1 SYNOPSIS cpanm Module Run C 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 to your system without thinking about where to install, and later upgrade. You can also use the latest cpanminus to install cpanminus itself (aka bootstrap): curl -L http://cpanmin.us | perl - --sudo App::cpanminus This will install C to your bin directory like C (unless you configured C with L), so you might need the C<--sudo> option. Later you can say C 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. =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 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 =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. 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 (or C). 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 (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. 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. 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 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 and C). 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 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 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 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 directory hierarchy. =item * Distributions with a C or C that asks you questions without using C 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 file but do require some specific version of toolchain for configuration. =item * Distributions that have a C file that is encoded in YAML 1.1 format using L. This will be eventually solved once we move to C. =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 Copyright 2006-2009 Adam Kennedy =item L Copyright 2007-2009 Matt S Trout =item L Copyright 2000-2002 Roy Hopper, 2009 Adam Kennedy =item L 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 - source code repository, issue tracker =item L - 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 L L =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.0012"; $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, skip_installed => 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' => sub { $self->{skip_installed} = 0; $self->{force} = 1 }, '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}, 'reinstall' => sub { $self->{skip_installed} = 0 }, 'interactive!' => \$self->{interactive}, 'i|install' => sub { $self->{cmd} = 'install' }, 'info' => sub { $self->{cmd} = 'info' }, 'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 }, '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!! 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 <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(<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 = ; 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, $distname) = @_; return 1 if $self->run_timeout($cmd, $self->{build_timeout}); while (1) { my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry or l)ook ?", "s"); return if $ans eq 's'; return $self->build($cmd, $distname) if $ans eq 'r'; $self->look if $ans eq 'l'; } } 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} && !$ENV{PERL_MM_OPT}) { 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; } $self->check_libs; 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; } } if ($dist->{dist} eq 'perl'){ $self->diag("skipping $dist->{pathname}\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; } return $self->build_stuff($module, $dist, $depth); } sub fetch_module { my($self, $dist) = @_; $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" ], $distname) && $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} ], $distname) && $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->{module_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}; } unless ($state->{configured_ok}) { while (1) { my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry or l)ook ?", "s"); last if $ans eq 's'; return $self->configure_this($dist) if $ans eq 'r'; $self->look if $ans eq 'l'; } } 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 => {\s*(.*?)\s*}/) { my @all; my @pairs = split ', ', $1; for (@pairs) { my ($pkg, $v) = split '=>', $_; push @all, [ $pkg, $v ]; } my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all; my $prereq = $self->safe_eval("no strict; +{ $list }"); 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]; $root =~ s{^(.+?)/.*$}{$1}; $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(?=-) )(? 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 uses heuristics that have been learnt by L 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 or C =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 =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 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: 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: 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. =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 =head1 SEE ALSO L 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 object given the path to a file. Takes an optional argument C 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 object given a module or package name. In addition to accepting the C argument as described above, this method accepts a C 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 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 , Randy W. Sims =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(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 () { s/(\$VERSION)\s=\s\d+/\$VERSION = 0/; $version .= $_ if $_; last if /^1;$/; } # and now get the current version::vpp code my $vpp; while () { s/(\$VERSION)\s=\s\d+/\$VERSION = 0/; $vpp .= $_ if $_; last if /^1;$/; } # but we eval them in reverse order since version depends on # version::vpp to already exist eval $vpp; die $@ if $@; $INC{'version/vpp.pm'} = 'inside Module::Metadata::Version'; eval $version; die $@ if $@; $INC{'version.pm'} = 'inside Module::Metadata::Version'; } # now we can safely subclass version, installed or not use vars qw(@ISA); @ISA = qw(version); 1; __DATA__ # stub version module to make everything else happy package version; use 5.005_04; use strict; use vars qw(@ISA $VERSION $CLASS *declare *qv); $VERSION = 0.77; $CLASS = 'version'; push @ISA, "version::vpp"; local $^W; *version::qv = \&version::vpp::qv; *version::declare = \&version::vpp::declare; *version::_VERSION = \&version::vpp::_VERSION; if ($] > 5.009001 && $] <= 5.010000) { no strict 'refs'; *{'version::stringify'} = \*version::vpp::stringify; *{'version::(""'} = \*version::vpp::stringify; *{'version::new'} = \*version::vpp::new; } # Preloaded methods go here. sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq 'version') { local $^W; *{$class.'::declare'} = \&version::declare; *{$class.'::qv'} = \&version::qv; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg."::declare"} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg."::qv"} = sub {return $class->qv(shift) } unless defined(&{"$callpkg\::qv"}); } if (exists($args{'UNIVERSAL::VERSION'})) { local $^W; *UNIVERSAL::VERSION = \&version::_VERSION; } if (exists($args{'VERSION'})) { *{$callpkg."::VERSION"} = \&version::_VERSION; } } 1; # replace everything from here to the end with the current version/vpp.pm package version::vpp; use strict; use POSIX qw/locale_h/; use locale; use vars qw ($VERSION @ISA @REGEXS); $VERSION = '0.77'; $VERSION = eval $VERSION; push @REGEXS, qr/ ^v? # optional leading 'v' (\d*) # major revision not required \. # requires at least one decimal (?:(\d+)\.?){1,} /x; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, 'nomethod' => \&vnoop, ); my $VERSION_MAX = 0x7FFFFFFF; eval "use warnings"; if ($@) { eval ' package warnings; sub enabled {return $^W;} 1; '; } sub new { my ($class, $value) = @_; my $self = bless ({}, ref ($class) || $class); if ( ref($value) && eval('$value->isa("version")') ) { # Can copy the elements directly $self->{version} = [ @{$value->{version} } ]; $self->{qv} = 1 if $value->{qv}; $self->{alpha} = 1 if $value->{alpha}; $self->{original} = ''.$value->{original}; return $self; } my $currlocale = setlocale(LC_ALL); # if the current locale uses commas for decimal points, we # just replace commas with decimal places, rather than changing # locales if ( localeconv()->{decimal_point} eq ',' ) { $value =~ tr/,/./; } if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison # or someone forgot to pass a value push @{$self->{version}}, 0; $self->{original} = "0"; return ($self); } if ( $#_ == 2 ) { # must be CVS-style $value = 'v'.$_[2]; } $value = _un_vstring($value); # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } # This is not very efficient, but it is morally equivalent # to the XS code (as that is the reference implementation). # See vutil/vutil.c for details my $qv = 0; my $alpha = 0; my $width = 3; my $saw_period = 0; my $vinf = 0; my ($start, $last, $pos, $s); $s = 0; while ( substr($value,$s,1) =~ /\s/ ) { # leading whitespace is OK $s++; } if (substr($value,$s,1) eq 'v') { $s++; # get past 'v' $qv = 1; # force quoted version processing } $start = $last = $pos = $s; # pre-scan the input string to check for decimals/underbars while ( substr($value,$pos,1) =~ /[._\d,]/ ) { if ( substr($value,$pos,1) eq '.' ) { if ($alpha) { Carp::croak("Invalid version format ". "(underscores before decimal)"); } $saw_period++; $last = $pos; } elsif ( substr($value,$pos,1) eq '_' ) { if ($alpha) { require Carp; Carp::croak("Invalid version format ". "(multiple underscores)"); } $alpha = 1; $width = $pos - $last - 1; # natural width of sub-version } elsif ( substr($value,$pos,1) eq ',' and substr($value,$pos+1,1) =~ /[0-9]/ ) { # looks like an unhandled locale $saw_period++; $last = $pos; } $pos++; } if ( $alpha && !$saw_period ) { require Carp; Carp::croak("Invalid version format ". "(alpha without decimal)"); } if ( $alpha && $saw_period && $width == 0 ) { require Carp; Carp::croak("Invalid version format ". "(misplaced _ in number)"); } if ( $saw_period > 1 ) { $qv = 1; # force quoted version processing } $last = $pos; $pos = $s; if ( $qv ) { $self->{qv} = 1; } if ( $alpha ) { $self->{alpha} = 1; } if ( !$qv && $width < 3 ) { $self->{width} = $width; } while ( substr($value,$pos,1) =~ /\d/ ) { $pos++; } if ( substr($value,$pos,1) !~ /[a-z]/ ) { ### FIX THIS ### my $rev; while (1) { $rev = 0; { # this is atoi() that delimits on underscores my $end = $pos; my $mult = 1; my $orev; # the following if() will only be true after the decimal # point of a version originally created with a bare # floating point number, i.e. not quoted in any way if ( !$qv && $s > $start && $saw_period == 1 ) { $mult *= 100; while ( $s < $end ) { $orev = $rev; $rev += substr($value,$s,1) * $mult; $mult /= 10; if ( abs($orev) > abs($rev) || abs($rev) > abs($VERSION_MAX) ) { if ( warnings::enabled("overflow") ) { require Carp; Carp::carp("Integer overflow in version"); } $s = $end - 1; $rev = $VERSION_MAX; } $s++; if ( substr($value,$s,1) eq '_' ) { $s++; } } } else { while (--$end >= $s) { $orev = $rev; $rev += substr($value,$end,1) * $mult; $mult *= 10; if ( abs($orev) > abs($rev) || abs($rev) > abs($VERSION_MAX) ) { if ( warnings::enabled("overflow") ) { require Carp; Carp::carp("Integer overflow in version"); } $end = $s - 1; $rev = $VERSION_MAX; } } } } # Append revision push @{$self->{version}}, $rev; if ( substr($value,$pos,1) eq '.' && substr($value,$pos+1,1) =~ /\d/ ) { $s = ++$pos; } elsif ( substr($value,$pos,1) eq '_' && substr($value,$pos+1,1) =~ /\d/ ) { $s = ++$pos; } elsif ( substr($value,$pos,1) eq ',' && substr($value,$pos+1,1) =~ /\d/ ) { $s = ++$pos; } elsif ( substr($value,$pos,1) =~ /\d/ ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( substr($value,$pos,1) =~ /\d/ ) { $pos++; } } else { my $digits = 0; while (substr($value,$pos,1) =~ /[\d_]/ && $digits < 3) { if ( substr($value,$pos,1) ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = scalar @{$self->{version}}; $len = 3 - $len; while ($len-- > 0) { push @{$self->{version}}, 0; } } if ( substr($value,$pos) ) { # any remaining text if ( warnings::enabled("misc") ) { require Carp; Carp::carp("Version string '$value' contains invalid data; ". "ignoring: '".substr($value,$pos)."'"); } } # cache the original value for use when stringification if ( $vinf ) { $self->{vinf} = 1; $self->{original} = 'v.Inf'; } else { $self->{original} = substr($value,0,$pos); } return ($self); } *parse = \&new; sub numify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $width = $self->{width} || 3; my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("%d.", $digit ); for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; if ( $width < 3 ) { my $denom = 10**(3-$width); my $quot = int($digit/$denom); my $rem = $digit - ($quot * $denom); $string .= sprintf("%0".$width."d_%d", $quot, $rem); } else { $string .= sprintf("%03d", $digit); } } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha && $width == 3 ) { $string .= "_"; } $string .= sprintf("%0".$width."d", $digit); } else # $len = 0 { $string .= sprintf("000"); } return $string; } sub normal { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("v%d", $digit ); for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf(".%d", $digit); } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha ) { $string .= sprintf("_%0d", $digit); } else { $string .= sprintf(".%0d", $digit); } } if ( $len <= 2 ) { for ( $len = 2 - $len; $len != 0; $len-- ) { $string .= sprintf(".%0d", 0); } } return $string; } sub stringify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } return exists $self->{original} ? $self->{original} : exists $self->{qv} ? $self->normal : $self->numify; } sub vcmp { require UNIVERSAL; my ($left,$right,$swap) = @_; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } if ( $swap ) { ($left, $right) = ($right, $left); } unless (_verify($left)) { require Carp; Carp::croak("Invalid version object"); } unless (_verify($right)) { require Carp; Carp::croak("Invalid version object"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; my $m = $l < $r ? $l : $r; my $lalpha = $left->is_alpha; my $ralpha = $right->is_alpha; my $retval = 0; my $i = 0; while ( $i <= $m && $retval == 0 ) { $retval = $left->{version}[$i] <=> $right->{version}[$i]; $i++; } # tiebreaker for alpha with identical terms if ( $retval == 0 && $l == $r && $left->{version}[$m] == $right->{version}[$m] && ( $lalpha || $ralpha ) ) { if ( $lalpha && !$ralpha ) { $retval = -1; } elsif ( $ralpha && !$lalpha) { $retval = +1; } } # possible match except for trailing 0's if ( $retval == 0 && $l != $r ) { if ( $l < $r ) { while ( $i <= $r && $retval == 0 ) { if ( $right->{version}[$i] != 0 ) { $retval = -1; # not a match after all } $i++; } } else { while ( $i <= $l && $retval == 0 ) { if ( $left->{version}[$i] != 0 ) { $retval = +1; # not a match after all } $i++; } } } return $retval; } sub vbool { my ($self) = @_; return vcmp($self,$self->new("0"),1); } sub vnoop { require Carp; Carp::croak("operation not supported with version object"); } sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); } sub qv { my $value = shift; my $class = 'version'; if (@_) { $class = ref($value) || $value; $value = shift; } $value = _un_vstring($value); $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; my $version = $class->new($value); return $version; } *declare = \&qv; sub is_qv { my ($self) = @_; return (exists $self->{qv}); } sub _verify { my ($self) = @_; if ( ref($self) && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; } else { return 0; } } sub _un_vstring { my $value = shift; # may be a v-string if ( $] >= 5.006_000 && length($value) >= 3 && $value !~ /[._]/ ) { my $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+\.\d+\.\d+$/ ) { # must be a v-string $value = $tvalue; } } return $value; } sub _VERSION { my ($obj, $req) = @_; my $class = ref($obj) || $obj; no strict 'refs'; if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { # file but no package require Carp; Carp::croak( "$class defines neither package nor VERSION" ."--version check failed"); } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { local $^W if $] <= 5.008; $version = version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { require Carp; my $msg = $] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed"; if ( $ENV{VERSION_DEBUG} ) { Carp::confess($msg); } else { Carp::croak($msg); } } $req = version::vpp->new($req); if ( $req > $version ) { require Carp; if ( $req->is_qv ) { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->normal, $version->normal) ); } else { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->stringify, $version->stringify) ); } } } return defined $version ? $version->stringify : undef; } 1; #this line is important and will help the module return a true value MODULE_METADATA_VERSION $fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META'; package Parse::CPAN::Meta; use strict; use Carp 'croak'; # UTF Support? sub HAVE_UTF8 () { $] >= 5.007003 } BEGIN { if ( HAVE_UTF8 ) { # The string eval helps hide this from Test::MinimumVersion eval "require utf8;"; die "Failed to load UTF-8 support" if $@; } # Class structure require 5.004; require Exporter; $Parse::CPAN::Meta::VERSION = '1.40'; @Parse::CPAN::Meta::ISA = qw{ Exporter }; @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile }; } # Prototypes sub LoadFile ($); sub Load ($); sub _scalar ($$$); sub _array ($$$); sub _hash ($$$); # Printable characters for escapes my %UNESCAPES = ( z => "\x00", a => "\x07", t => "\x09", n => "\x0a", v => "\x0b", f => "\x0c", r => "\x0d", e => "\x1b", '\\' => '\\', ); ##################################################################### # Implementation # Create an object from a file sub LoadFile ($) { # Check the file my $file = shift; croak('You did not specify a file name') unless $file; croak( "File '$file' does not exist" ) unless -e $file; croak( "'$file' is a directory, not a file" ) unless -f _; croak( "Insufficient permissions to read '$file'" ) unless -r _; # Slurp in the file local $/ = undef; local *CFG; unless ( open( CFG, $file ) ) { croak("Failed to open file '$file': $!"); } my $yaml = ; unless ( close(CFG) ) { croak("Failed to close file '$file': $!"); } # Hand off to the actual parser Load( $yaml ); } # Parse a document from a string. # Doing checks on $_[0] prevents us having to do a string copy. sub Load ($) { my $string = $_[0]; unless ( defined $string ) { croak("Did not provide a string to load"); } # Byte order marks if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { croak("Stream has a non UTF-8 Unicode Byte Order Mark"); } else { # Strip UTF-8 bom if found, we'll just ignore it $string =~ s/^\357\273\277//; } # Try to decode as utf8 utf8::decode($string) if HAVE_UTF8; # Check for some special cases return () unless length $string; unless ( $string =~ /[\012\015]+\z/ ) { croak("Stream does not end with newline character"); } # Split the file into lines my @lines = grep { ! /^\s*(?:\#.*)?\z/ } split /(?:\015{1,2}\012|\015|\012)/, $string; # Strip the initial YAML header @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; # A nibbling parser my @documents = (); while ( @lines ) { # Do we have a document header? if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { # Handle scalar documents shift @lines; if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { push @documents, _scalar( "$1", [ undef ], \@lines ); next; } } if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { # A naked document push @documents, undef; while ( @lines and $lines[0] !~ /^---/ ) { shift @lines; } } elsif ( $lines[0] =~ /^\s*\-/ ) { # An array at the root my $document = [ ]; push @documents, $document; _array( $document, [ 0 ], \@lines ); } elsif ( $lines[0] =~ /^(\s*)\S/ ) { # A hash at the root my $document = { }; push @documents, $document; _hash( $document, [ length($1) ], \@lines ); } else { croak("Parse::CPAN::Meta failed to classify line '$lines[0]'"); } } if ( wantarray ) { return @documents; } else { return $documents[-1]; } } # Deparse a scalar string to the actual scalar sub _scalar ($$$) { my ($string, $indent, $lines) = @_; # Trim trailing whitespace $string =~ s/\s*\z//; # Explitic null/undef return undef if $string eq '~'; # Quotes if ( $string =~ /^\'(.*?)\'\z/ ) { return '' unless defined $1; $string = $1; $string =~ s/\'\'/\'/g; return $string; } if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { # Reusing the variable is a little ugly, # but avoids a new variable and a string copy. $string = $1; $string =~ s/\\"/"/g; $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; return $string; } # Special cases if ( $string =~ /^[\'\"!&]/ ) { croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'"); } return {} if $string eq '{}'; return [] if $string eq '[]'; # Regular unquoted string return $string unless $string =~ /^[>|]/; # Error croak("Parse::CPAN::Meta failed to find multi-line scalar content") unless @$lines; # Check the indent depth $lines->[0] =~ /^(\s*)/; $indent->[-1] = length("$1"); if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'"); } # Pull the lines my @multiline = (); while ( @$lines ) { $lines->[0] =~ /^(\s*)/; last unless length($1) >= $indent->[-1]; push @multiline, substr(shift(@$lines), length($1)); } my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; return join( $j, @multiline ) . $t; } # Parse an array sub _array ($$$) { my ($array, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'"); } if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { # Inline nested hash my $indent2 = length("$1"); $lines->[0] =~ s/-/ /; push @$array, { }; _hash( $array->[-1], [ @$indent, $indent2 ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { # Array entry with a value shift @$lines; push @$array, _scalar( "$2", [ @$indent, undef ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { shift @$lines; unless ( @$lines ) { push @$array, undef; return 1; } if ( $lines->[0] =~ /^(\s*)\-/ ) { my $indent2 = length("$1"); if ( $indent->[-1] == $indent2 ) { # Null array entry push @$array, undef; } else { # Naked indenter push @$array, [ ]; _array( $array->[-1], [ @$indent, $indent2 ], $lines ); } } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { push @$array, { }; _hash( $array->[-1], [ @$indent, length("$1") ], $lines ); } else { croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'"); } } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { # This is probably a structure like the following... # --- # foo: # - list # bar: value # # ... so lets return and let the hash parser handle it return 1; } else { croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'"); } } return 1; } # Parse an array sub _hash ($$$) { my ($hash, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { croak("Parse::CPAN::Meta found bad indenting in line '$lines->[0]'"); } # Get the key unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) { if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { croak("Parse::CPAN::Meta does not support a feature in line '$lines->[0]'"); } croak("Parse::CPAN::Meta failed to classify line '$lines->[0]'"); } my $key = $1; # Do we have a value? if ( length $lines->[0] ) { # Yes $hash->{$key} = _scalar( shift(@$lines), [ @$indent, undef ], $lines ); } else { # An indent shift @$lines; unless ( @$lines ) { $hash->{$key} = undef; return 1; } if ( $lines->[0] =~ /^(\s*)-/ ) { $hash->{$key} = []; _array( $hash->{$key}, [ @$indent, length($1) ], $lines ); } elsif ( $lines->[0] =~ /^(\s*)./ ) { my $indent2 = length("$1"); if ( $indent->[-1] >= $indent2 ) { # Null hash entry $hash->{$key} = undef; } else { $hash->{$key} = {}; _hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); } } } } return 1; } 1; __END__ =pod =head1 NAME Parse::CPAN::Meta - Parse META.yml and other similar CPAN metadata files =head1 SYNOPSIS ############################################# # In your file --- rootproperty: blah section: one: two three: four Foo: Bar empty: ~ ############################################# # In your program use Parse::CPAN::Meta; # Create a YAML file my @yaml = Parse::CPAN::Meta::LoadFile( 'Meta.yml' ); # Reading properties my $root = $yaml[0]->{rootproperty}; my $one = $yaml[0]->{section}->{one}; my $Foo = $yaml[0]->{section}->{Foo}; =head1 DESCRIPTION B is a parser for F files, based on the parser half of L. It supports a basic subset of the full YAML specification, enough to implement parsing of typical F files, and other similarly simple YAML files. If you need something with more power, move up to a full YAML parser such as L, L or L. B provides a very simply API of only two functions, based on the YAML functions of the same name. Wherever possible, identical calling semantics are used. All error reporting is done with exceptions (die'ing). =head1 FUNCTIONS For maintenance clarity, no functions are exported. =head2 Load my @yaml = Load( $string ); Parses a string containing a valid YAML stream into a list of Perl data structures. =head2 LoadFile my @yaml = LoadFile( 'META.yml' ); Reads the YAML stream from a file instead of a string. =head1 SUPPORT Bugs should be reported via the CPAN bug tracker at L =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 SEE ALSO L, L, L, L, L, L =head1 COPYRIGHT Copyright 2006 - 2009 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PARSE_CPAN_META $fatpacked{"local/lib.pm"} = <<'LOCAL_LIB'; use strict; use warnings; package local::lib; use 5.008001; # probably works with earlier versions but I'm not supporting them # (patches would, of course, be welcome) use File::Spec (); use File::Path (); use Carp (); use Config; our $VERSION = '1.006000'; # 1.6.0 our @KNOWN_FLAGS = qw(--self-contained); sub import { my ($class, @args) = @_; # Remember what PERL5LIB was when we started my $perl5lib = $ENV{PERL5LIB} || ''; my %arg_store; for my $arg (@args) { # check for lethal dash first to stop processing before causing problems if ($arg =~ /−/) { die <<'DEATH'; WHOA THERE! It looks like you've got some fancy dashes in your commandline! These are *not* the traditional -- dashes that software recognizes. You probably got these by copy-pasting from the perldoc for this module as rendered by a UTF8-capable formatter. This most typically happens on an OS X terminal, but can happen elsewhere too. Please try again after replacing the dashes with normal minus signs. DEATH } elsif(grep { $arg eq $_ } @KNOWN_FLAGS) { (my $flag = $arg) =~ s/--//; $arg_store{$flag} = 1; } elsif($arg =~ /^--/) { die "Unknown import argument: $arg"; } else { # assume that what's left is a path $arg_store{path} = $arg; } } if($arg_store{'self-contained'}) { die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n"; } $arg_store{path} = $class->resolve_path($arg_store{path}); $class->setup_local_lib_for($arg_store{path}); for (@INC) { # Untaint @INC next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc. m/(.*)/ and $_ = $1; } } sub pipeline; sub pipeline { my @methods = @_; my $last = pop(@methods); if (@methods) { \sub { my ($obj, @args) = @_; $obj->${pipeline @methods}( $obj->$last(@args) ); }; } else { \sub { shift->$last(@_); }; } } =begin testing #:: test pipeline package local::lib; { package Foo; sub foo { -$_[1] } sub bar { $_[1]+2 } sub baz { $_[1]+3 } } my $foo = bless({}, 'Foo'); Test::More::ok($foo->${pipeline qw(foo bar baz)}(10) == -15); =end testing =cut sub _uniq { my %seen; grep { ! $seen{$_}++ } @_; } sub resolve_path { my ($class, $path) = @_; $class->${pipeline qw( resolve_relative_path resolve_home_path resolve_empty_path )}($path); } sub resolve_empty_path { my ($class, $path) = @_; if (defined $path) { $path; } else { '~/perl5'; } } =begin testing #:: test classmethod setup my $c = 'local::lib'; =end testing =begin testing #:: test classmethod is($c->resolve_empty_path, '~/perl5'); is($c->resolve_empty_path('foo'), 'foo'); =end testing =cut sub resolve_home_path { my ($class, $path) = @_; return $path unless ($path =~ /^~/); my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us' my $tried_file_homedir; my $homedir = do { if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) { $tried_file_homedir = 1; if (defined $user) { File::HomeDir->users_home($user); } else { File::HomeDir->my_home; } } else { if (defined $user) { (getpwnam $user)[7]; } else { if (defined $ENV{HOME}) { $ENV{HOME}; } else { (getpwuid $<)[7]; } } } }; unless (defined $homedir) { Carp::croak( "Couldn't resolve homedir for " .(defined $user ? $user : 'current user') .($tried_file_homedir ? '' : ' - consider installing File::HomeDir') ); } $path =~ s/^~[^\/]*/$homedir/; $path; } sub resolve_relative_path { my ($class, $path) = @_; $path = File::Spec->rel2abs($path); } =begin testing #:: test classmethod local *File::Spec::rel2abs = sub { shift; 'FOO'.shift; }; is($c->resolve_relative_path('bar'),'FOObar'); =end testing =cut sub setup_local_lib_for { my ($class, $path) = @_; $path = $class->ensure_dir_structure_for($path); if ($0 eq '-') { $class->print_environment_vars_for($path); exit 0; } else { $class->setup_env_hash_for($path); @INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC); } } sub modulebuildrc_path { my ($class, $path) = @_; File::Spec->catfile($path, '.modulebuildrc'); } sub install_base_bin_path { my ($class, $path) = @_; File::Spec->catdir($path, 'bin'); } sub install_base_perl_path { my ($class, $path) = @_; File::Spec->catdir($path, 'lib', 'perl5'); } sub install_base_arch_path { my ($class, $path) = @_; File::Spec->catdir($class->install_base_perl_path($path), $Config{archname}); } sub ensure_dir_structure_for { my ($class, $path) = @_; unless (-d $path) { warn "Attempting to create directory ${path}\n"; } File::Path::mkpath($path); # Need to have the path exist to make a short name for it, so # converting to a short name here. $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32'; my $modulebuildrc_path = $class->modulebuildrc_path($path); if (-e $modulebuildrc_path) { unless (-f _) { Carp::croak("${modulebuildrc_path} exists but is not a plain file"); } } else { warn "Attempting to create file ${modulebuildrc_path}\n"; open MODULEBUILDRC, '>', $modulebuildrc_path || Carp::croak("Couldn't open ${modulebuildrc_path} for writing: $!"); print MODULEBUILDRC qq{install --install_base ${path}\n} || Carp::croak("Couldn't write line to ${modulebuildrc_path}: $!"); close MODULEBUILDRC || Carp::croak("Couldn't close file ${modulebuildrc_path}: $@"); } return $path; } sub INTERPOLATE_ENV () { 1 } sub LITERAL_ENV () { 0 } sub print_environment_vars_for { my ($class, $path) = @_; my @envs = $class->build_environment_vars_for($path, LITERAL_ENV); my $out = ''; # rather basic csh detection, goes on the assumption that something won't # call itself csh unless it really is. also, default to bourne in the # pathological situation where a user doesn't have $ENV{SHELL} defined. # note also that shells with funny names, like zoid, are assumed to be # bourne. my $shellbin = 'sh'; if(defined $ENV{'SHELL'}) { my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'}); $shellbin = $shell_bin_path_parts[-1]; } my $shelltype = do { local $_ = $shellbin; if(/csh/) { 'csh' } else { 'bourne' } }; # Both Win32 and Cygwin have $ENV{COMSPEC} set. if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') { my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'}); $shellbin = $shell_bin_path_parts[-1]; $shelltype = do { local $_ = $shellbin; if(/command\.com/) { 'win32' } elsif(/cmd\.exe/) { 'win32' } elsif(/4nt\.exe/) { 'win32' } else { $shelltype } }; } while (@envs) { my ($name, $value) = (shift(@envs), shift(@envs)); $value =~ s/(\\")/\\$1/g; $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value); } print $out; } # simple routines that take two arguments: an %ENV key and a value. return # strings that are suitable for passing directly to the relevant shell to set # said key to said value. sub build_bourne_env_declaration { my $class = shift; my($name, $value) = @_; return qq{export ${name}="${value}"\n}; } sub build_csh_env_declaration { my $class = shift; my($name, $value) = @_; return qq{setenv ${name} "${value}"\n}; } sub build_win32_env_declaration { my $class = shift; my($name, $value) = @_; return qq{set ${name}=${value}\n}; } sub setup_env_hash_for { my ($class, $path) = @_; my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV); @ENV{keys %envs} = values %envs; } sub build_environment_vars_for { my ($class, $path, $interpolate) = @_; return ( MODULEBUILDRC => $class->modulebuildrc_path($path), PERL_MM_OPT => "INSTALL_BASE=${path}", PERL5LIB => join($Config{path_sep}, $class->install_base_perl_path($path), $class->install_base_arch_path($path), (($ENV{PERL5LIB}||()) ? ($interpolate == INTERPOLATE_ENV ? ($ENV{PERL5LIB}) : (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' )) : ()) ), PATH => join($Config{path_sep}, $class->install_base_bin_path($path), ($interpolate == INTERPOLATE_ENV ? ($ENV{PATH}||()) : (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' )) ), ) } =begin testing #:: test classmethod File::Path::rmtree('t/var/splat'); $c->ensure_dir_structure_for('t/var/splat'); ok(-d 't/var/splat'); ok(-f 't/var/splat/.modulebuildrc'); =end testing =head1 NAME local::lib - create and use a local lib/ for perl modules with PERL5LIB =head1 SYNOPSIS In code - use local::lib; # sets up a local lib at ~/perl5 use local::lib '~/foo'; # same, but ~/foo # Or... use FindBin; use local::lib "$FindBin::Bin/../support"; # app-local support library From the shell - # Install LWP and its missing dependencies to the '~/perl5' directory perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' # Just print out useful shell commands $ perl -Mlocal::lib export MODULEBUILDRC=/home/username/perl/.modulebuildrc export PERL_MM_OPT='INSTALL_BASE=/home/username/perl' export PERL5LIB='/home/username/perl/lib/perl5:/home/username/perl/lib/perl5/i386-linux' export PATH="/home/username/perl/bin:$PATH" =head2 The bootstrapping technique A typical way to install local::lib is using what is known as the "bootstrapping" technique. You would do this if your system administrator hasn't already installed local::lib. In this case, you'll need to install local::lib in your home directory. 1. Download and unpack the local::lib tarball from CPAN (search for "Download" on the CPAN page about local::lib). Do this as an ordinary user, not as root or administrator. Unpack the file in your home directory or in any other convenient location. 2. Run this: perl Makefile.PL --bootstrap If the system asks you whether it should automatically configure as much as possible, you would typically answer yes. 3. Run this: make test && make install 4. Arrange for Perl to use your own packages instead of the system packages. If you are using bash, you can do this as follows: echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc If you are using C shell, you can do this as follows: /bin/csh echo $SHELL /bin/csh perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc You can also pass --bootstrap=~/foo to get a different location - perl Makefile.PL --bootstrap=~/foo make test && make install echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc After writing your shell configuration file, be sure to re-read it to get the changed settings into your current shell's environment. Bourne shells use C<. ~/.bashrc> for this, whereas C shells use C. Replace .bashrc or .cshrc with the name of the file you wrote above with the echo command. If you're on a slower machine, or are operating under draconian disk space limitations, you can disable the automatic generation of manpages from POD when installing modules by using the C<--no-manpages> argument when bootstrapping: perl Makefile.PL --bootstrap --no-manpages If you want to install multiple Perl module environments, say for application development, install local::lib globally and then: cd ~/mydir1 perl -Mlocal::lib=./ eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone printenv ### You will see that ~/mydir1 is in the PERL5LIB perl -MCPAN -e install ... ### whatever modules you want cd ../mydir2 ... REPEAT ... For multiple environments for multiple apps you may need to include a modified version of the C<< use FindBin >> instructions in the "In code" sample above. If you did something like the above, you have a set of Perl modules at C<< ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, you need to tell it where to find the modules you installed for it at C<< ~/mydir1/lib >>. In C<< ~/mydir1/scripts/myscript.pl >>: use strict; use warnings; use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib Put this before any BEGIN { ... } blocks that require the modules you installed. =head2 Differences when using this module under Win32 C:\>perl -Mlocal::lib set MODULEBUILDRC=C:\DOCUME~1\ADMINI~1\perl5\.modulebuildrc set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% ### To set the environment for this shell alone C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat ### instead of $(perl -Mlocal::lib=./) If you want the environment entries to persist, you'll need to add then to the Control Panel's System applet yourself at the moment. The "~" is translated to the user's profile directory (the directory named for the user under "Documents and Settings" (Windows XP or earlier) or "Users" (Windows Vista or later) unless $ENV{HOME} exists. After that, the home directory is translated to a short name (which means the directory must exist) and the subdirectories are created. =head1 RATIONALE The version of a Perl package on your machine is not always the version you need. Obviously, the best thing to do would be to update to the version you need. However, you might be in a situation where you're prevented from doing this. Perhaps you don't have system administrator privileges; or perhaps you are using a package management system such as Debian, and nobody has yet gotten around to packaging up the version you need. local::lib solves this problem by allowing you to create your own directory of Perl packages downloaded from CPAN (in a multi-user system, this would typically be within your own home directory). The existing system Perl installation is not affected; you simply invoke Perl with special options so that Perl uses the packages in your own local package directory rather than the system packages. local::lib arranges things so that your locally installed version of the Perl packages takes precedence over the system installation. If you are using a package management system (such as Debian), you don't need to worry about Debian and CPAN stepping on each other's toes. Your local version of the packages will be written to an entirely separate directory from those installed by Debian. =head1 DESCRIPTION This module provides a quick, convenient way of bootstrapping a user-local Perl module library located within the user's home directory. It also constructs and prints out for the user the list of environment variables using the syntax appropriate for the user's current shell (as specified by the C environment variable), suitable for directly adding to one's shell configuration file. More generally, local::lib allows for the bootstrapping and usage of a directory containing Perl modules outside of Perl's C<@INC>. This makes it easier to ship an application with an app-specific copy of a Perl module, or collection of modules. Useful in cases like when an upstream maintainer hasn't applied a patch to a module of theirs that you need for your application. On import, local::lib sets the following environment variables to appropriate values: =over 4 =item MODULEBUILDRC =item PERL_MM_OPT =item PERL5LIB =item PATH PATH is appended to, rather than clobbered. =back These values are then available for reference by any code after import. =head1 CREATING A SELF-CONTAINED SET OF MODULES See L for one way to do this - but note that there are a number of caveats, and the best approach is always to perform a build against a clean perl (i.e. site and vendor as close to empty as possible). =head1 METHODS =head2 ensure_directory_structure_for =over 4 =item Arguments: path =back Attempts to create the given path, and all required parent directories. Throws an exception on failure. =head2 print_environment_vars_for =over 4 =item Arguments: path =back Prints to standard output the variables listed above, properly set to use the given path as the base directory. =head2 setup_env_hash_for =over 4 =item Arguments: path =back Constructs the C<%ENV> keys for the given path, by calling C. =head2 install_base_perl_path =over 4 =item Arguments: path =back Returns a path describing where to install the Perl modules for this local library installation. Appends the directories C and C to the given path. =head2 install_base_arch_path =over 4 =item Arguments: path =back Returns a path describing where to install the architecture-specific Perl modules for this local library installation. Based on the L method's return value, and appends the value of C<$Config{archname}>. =head2 install_base_bin_path =over 4 =item Arguments: path =back Returns a path describing where to install the executable programs for this local library installation. Based on the L method's return value, and appends the directory C. =head2 modulebuildrc_path =over 4 =item Arguments: path =back Returns a path describing where to install the C<.modulebuildrc> file, based on the given path. =head2 resolve_empty_path =over 4 =item Arguments: path =back Builds and returns the base path into which to set up the local module installation. Defaults to C<~/perl5>. =head2 resolve_home_path =over 4 =item Arguments: path =back Attempts to find the user's home directory. If installed, uses C for this purpose. If no definite answer is available, throws an exception. =head2 resolve_relative_path =over 4 =item Arguments: path =back Translates the given path into an absolute path. =head2 resolve_path =over 4 =item Arguments: path =back Calls the following in a pipeline, passing the result from the previous to the next, in an attempt to find where to configure the environment for a local library installation: L, L, L. Passes the given path argument to L which then returns a result that is passed to L, which then has its result passed to L. The result of this final call is returned from L. =head1 A WARNING ABOUT UNINST=1 Be careful about using local::lib in combination with "make install UNINST=1". The idea of this feature is that will uninstall an old version of a module before installing a new one. However it lacks a safety check that the old version and the new version will go in the same directory. Used in combination with local::lib, you can potentially delete a globally accessible version of a module while installing the new version in a local place. Only combine "make install UNINST=1" and local::lib if you understand these possible consequences. =head1 LIMITATIONS Rather basic shell detection. Right now anything with csh in its name is assumed to be a C shell or something compatible, and everything else is assumed to be Bourne, except on Win32 systems. If the C environment variable is not set, a Bourne-compatible shell is assumed. Bootstrap is a hack and will use CPAN.pm for ExtUtils::MakeMaker even if you have CPANPLUS installed. Kills any existing PERL5LIB, PERL_MM_OPT or MODULEBUILDRC. Should probably auto-fixup CPAN config if not already done. Patches very much welcome for any of the above. On Win32 systems, does not have a way to write the created environment variables to the registry, so that they can persist through a reboot. =head1 TROUBLESHOOTING If you've configured local::lib to install CPAN modules somewhere in to your home directory, and at some point later you try to install a module with C, but it fails with an error like: C and buried within the install log is an error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then you've somehow lost your updated ExtUtils::MakeMaker module. To remedy this situation, rerun the bootstrapping procedure documented above. Then, run C Finally, re-run C and it should install without problems. =head1 ENVIRONMENT =over 4 =item SHELL =item COMSPEC local::lib looks at the user's C environment variable when printing out commands to add to the shell configuration file. On Win32 systems, C is also examined. =back =head1 AUTHOR Matt S Trout http://www.shadowcat.co.uk/ auto_install fixes kindly sponsored by http://www.takkle.com/ =head1 CONTRIBUTORS Patches to correctly output commands for csh style shells, as well as some documentation additions, contributed by Christopher Nehren . Doc patches for a custom local::lib directory contributed by Torsten Raudssus . Hans Dieter Pearcey sent in some additional tests for ensuring things will install properly, submitted a fix for the bug causing problems with writing Makefiles during bootstrapping, contributed an example program, and submitted yet another fix to ensure that local::lib can install and bootstrap properly. Many, many thanks! pattern of Freenode IRC contributed the beginnings of the Troubleshooting section. Many thanks! Patch to add Win32 support contributed by Curtis Jewell . Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced by a patch from Marco Emilio Poleggi. Mark Stosberg provided the code for the now deleted '--self-contained' option. =head1 COPYRIGHT Copyright (c) 2007 - 2009 the local::lib L and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. =cut 1; LOCAL_LIB s/^ //mg for values %fatpacked; unshift @INC, sub { if (my $fat = $fatpacked{$_[1]}) { open my $fh, '<', \$fat; return $fh; } return }; } # END OF FATPACK CODE use strict; use App::cpanminus::script; unless (caller) { my $app = App::cpanminus::script->new; $app->parse_options(@ARGV); $app->doit or exit(1); } __END__ =head1 NAME cpanm - get, unpack build and install modules from CPAN =head1 SYNOPSIS cpanm Test::More # install Test::More cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file cpanm --interactive Task::Kensho # Configure interactively cpanm . # install from local directory cpanm --installdeps . # install all the deps for the current directory cpanm -L extlib Plack # install Plack and all non-core deps into extlib cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror =head1 COMMANDS =over 4 =item -i, --install Installs the modules. This is a default behavior and this is just a compatibility option to make it work like L or L. =item --self-upgrade Upgrades itself. It's just an alias for: cpanm App::cpanminus =item --info Displays the distribution information in C format in the standard out. =item --installdeps Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. cpanm --installdeps . =item --look Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do the manual testing. =item -h, --help Displays the help message. =item -V, --version Displays the version number. =back =head1 OPTIONS You can specify the default options in C environment variable. =over 4 =item -f, --force Force install modules even when testing failed. =item -n, --notest Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C. =item -S, --sudo Switch to the root user with C when installing modules. Use this if you want to install modules to the system perl include path. Defaults to false, and you can say C<--no-sudo> to override when it is set in the default options in C. =item -v, --verbose Makes the output verbose. It also enables the interactive configuration. (See --interactive) =item -q, --quiet Makes the output even more quiet than the default. It doesn't print anything to the STDERR. =item -l, --local-lib Sets the L compatible path to install modules to. You don't need to set this if you already configure the shell environment variables using L, but this can be used to override that as well. =item -L, --local-lib-contained Same with C<--local-lib> but when examining the dependencies, it assumes no non-core modules are installed on the system. It's handy if you want to bundle application dependencies in one directory so you can distribute to other machines. For instance, cpanm -L extlib Plack would install Plack and all of its non-core dependencies into the directory C, which can be loaded from your application with: use local::lib '/path/to/extlib'; =item --mirror Specifies the base URL for the CPAN mirror to use, such as C (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. Defaults to C which is a geo location aware redirector. =item --prompt Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C. =item --reinstall cpanm, when given a module name in the command line (i.e. C), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: cpanm --reinstall Plack would reinstall L even if your locally installed version is latest, or even newer (which would happen if you install a developer release from version control repositories). Defaults to false. =item --interactive Makes the configuration (such as C and C) interactive, so you can answer questions in the distribution that requires custom configuration or Task:: distributions. Defaults to false, and you can say C<--no-interactive> to override when it's set in the default options in C. =item --uninst-shadows Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from CPAN against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. If you run cpanm as root and use C or equivalent to specify custom installation path, you SHOULD disable this option so you won't accidentally uninstall dual-life modules from the core include path. Defaults to true, and you can disable that with C<--no-uninst-shadows>. =item --lwp Uses L module to download stuff over HTTP. Defaults to true, and you can say C<--no-lwp> to disable using LWP, when you want to upgrade LWP from CPAN on some broken perl systems. =back =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2010 Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut