#!/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.3001"; =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 and does nothing else. It's dependency free (can bootstrap itself), requires zero configuration, and stands alone. When running, it requires only 10MB of RAM. =head1 INSTALLATION There are several ways to install cpanminus to your system. =head2 Package management system 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. =head2 Installing to system perl You can also use the latest cpanminus to install cpanminus itself: 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 probably need the C<--sudo> option. =head2 Installing to local perl (perlbrew) If you have perl in your home directory, which is the case if you use tools like L, you don't need the C<--sudo> option, since you're most likely to have a write permission to the perl's library path. You can just do: curl -L http://cpanmin.us | perl - App::cpanminus to install the C executable to the perl's bin path, like C<~/perl5/perlbrew/bin/cpanm>. =head2 Downloaing the standalone executable You can also copy the standalone executable to whatever location you'd like. cd ~/bin curl -LO http://xrl.us/cpanm chmod +x cpanm # edit shebang if you don't have /usr/bin/env This just works, but be sure to grab the new version manually when you upgrade because C<--self-upgrade> might not work for this. =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. =item * make =item * Module::Build (core in 5.10) =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, let me be clear that CPAN and CPANPLUS are 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. =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 scrape the site L. Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up periodically. You can configure the location of 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 site_perl directory that belongs to your perl. cpanminus at a boot time checks whether you have configured local::lib, or have the permission to install modules to the site_perl 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. =head2 cpanminus can't install the module XYZ. Is it a bug? It is more likely a problem with the distribution itself. cpanminus doesn't support or is known to have issues with distributions like as follows: =over 4 =item * Tests that require input from STDIN. =item * Tests that might fail when C is enabled. =item * Modules that have invalid numeric values as VERSION (such as C<1.1a>) =back These failures can be reported back to the author of the module so that they can fix it accordingly, rather than me. =head2 Does cpanm support the feature XYZ of L and L? Most likely not. Here are the things that cpanm doesn't do by itself. And it's a feature - you got that from the name I, right? If you need these features, use L, L or the standalone tools that are mentioned. =over 4 =item * Bundle:: module dependencies =item * CPAN testers reporting =item * Building RPM packages from CPAN modules =item * Listing the outdated modules that needs upgrading. See L =item * Uninstalling modules. See L. =item * Showing the changes of the modules you're about to upgrade. See L =item * Patching CPAN modules with distroprefs. =back See L or C to see what cpanminus I do :) =head1 COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa The standalone executable contains the following modules embedded. =over 4 =item L Copyright 2003 Graham Barr =item L Copyright 2006-2009 Adam Kennedy =item L Copyright 2007-2009 Matt S Trout =item L Copyright 2011 Christian Hansen =item L Copyright 2001-2006 Ken Williams. 2010 Matt S Trout =item L Copyright 2004-2010 John Peacock =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.3001"; 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 => [], mirror_only => undef, perl => $^X, argv => [], local_lib => undef, self_contained => undef, prompt_timeout => 0, prompt => undef, configure_timeout => 60, try_lwp => 1, try_wget => 1, try_curl => 1, uninstall_shadows => ($] < 5.012), skip_installed => 1, auto_cleanup => 7, # days @_, }, $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}, 'mirror-only!' => \$self->{mirror_only}, '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}, 'wget!' => \$self->{try_wget}, 'curl!' => \$self->{try_curl}, 'auto-cleanup=s' => \$self->{auto_cleanup}, ); $self->{argv} = \@ARGV; } sub check_libs { my $self = shift; return if $self->{_checked}++; $self->bootstrap_local_lib; if (@{$self->{bootstrap_deps} || []}) { local $self->{notest} = 1; # test failure in bootstrap should be tolerated $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}}) { if ($module =~ s/\.pm$//i) { my ($volume, $dirs, $file) = File::Spec->splitpath($module); $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file; } $self->install_module($module, 0) or push @fail, $module; } if ($self->{base} && $self->{auto_cleanup}) { $self->cleanup_workdirs; } 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) = @_; unless ($self->{mirror_only}) { my $meta_yml = $self->get("http://cpansearch.perl.org/src/$dist->{cpanid}/$dist->{distvname}/META.yml"); return $self->parse_meta_string($meta_yml); } return undef; } sub package_index_for { my ($self, $mirror) = @_; return $self->source_for($mirror) . "/02packages.details.txt"; } sub generate_mirror_index { my ($self, $mirror) = @_; my $file = $self->package_index_for($mirror); my $gz_file = $file . '.gz'; my $index_mtime = (stat $gz_file)[9]; unless (-e $file && (stat $file)[9] >= $index_mtime) { $self->chat("Uncompressing index file...\n"); if (eval {require Compress::Zlib}) { my $gz = Compress::Zlib::gzopen($gz_file, "rb") or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return}; open my $fh, '>', $file or do { $self->diag_fail("$! opening uncompressed index for write"); return }; my $buffer; while (my $status = $gz->gzread($buffer)) { if ($status < 0) { $self->diag_fail($gz->gzerror . " reading compressed index"); return; } print $fh $buffer; } } else { unless (system("gunzip -c $gz_file > $file")) { $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib"); return; } } utime $index_mtime, $index_mtime, $file; } return 1; } sub search_mirror_index { my ($self, $mirror, $module) = @_; open my $fh, '<', $self->package_index_for($mirror) or return; while (<$fh>) { if (m!^\Q$module\E\s+([\w\.]+)\s+(.*)!m) { return $self->cpan_module($module, $2, $1); } } return; } sub search_module { my($self, $module) = @_; unless ($self->{mirror_only}) { $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."); } MIRROR: for my $mirror (@{ $self->{mirrors} }) { $self->chat("Searching $module on mirror $mirror ...\n"); my $name = '02packages.details.txt.gz'; my $uri = "$mirror/modules/$name"; my $gz_file = $self->package_index_for($mirror) . '.gz'; unless ($self->{pkgs}{$uri}) { $self->chat("Downloading index file $uri ...\n"); $self->mirror($uri, $gz_file); $self->generate_mirror_index($mirror) or next MIRROR; $self->{pkgs}{$uri} = "!!retrieved!!"; } my $pkg = $self->search_mirror_index($mirror, $module); return $pkg if $pkg; $self->diag_fail("Finding $module on mirror $mirror failed."); } return; } sub source_for { my($self, $mirror) = @_; $mirror =~ s/[^\w\.\-]+/%/g; my $dir = "$self->{home}/sources/$mirror"; File::Path::mkpath([ $dir ], 0, 0777); return $dir; } 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.36; } 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} = local $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}; # http://www.nntp.perl.org/group/perl.perl5.porters/2009/10/msg152656.html local $ENV{AUTOMATED_TESTING} = 1 unless $self->env('NO_AUTOMATED_TESTING'); 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!^/!file:///!; 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; } $self->diag("--> Working on $module\n"); $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; # When -L is in use, the version loaded from 'perl' library path # might be newer than the version that is shipped with the current perl if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) { require Module::CoreList; $version = $Module::CoreList::version{$]}{$mod}; } $self->{local_versions}{$mod} = $version; if ($self->is_deprecated($meta)){ return 0, $version; } elsif (!$want_ver or $version >= 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; return $self->loaded_from_perl_lib($meta); } sub loaded_from_perl_lib { my($self, $meta) = @_; 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 _patch_module_build_config_deps { my($self, $config_deps) = @_; # Crazy hack to auto-add Module::Build dependencies into # configure_requires if Module::Build is there, since there's a # possibility where Module::Build is in 'perl' library path while # the dependencies are in 'site' and can't be loaded when -L # (--local-lib-contained) is in effect. my %config_deps = (@{$config_deps}); if ($config_deps{"Module::Build"}) { push @{$config_deps}, ( 'Perl::OSType' => 1, 'Module::Metadata' => 1.000002, 'version' => 0.87, ); } } 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->_patch_module_build_config_deps(\@config_deps) if $self->{self_contained}; $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); $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); $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 cleanup_workdirs { my $self = shift; my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup}; my @targets; opendir my $dh, "$self->{home}/work"; while (my $e = readdir $dh) { next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID} my $time = $1; if ($time < $expire) { push @targets, "$self->{home}/work/$e"; } } if (@targets) { $self->chat("Expiring ", scalar(@targets), " work directories.\n"); File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits } } 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 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; }; } elsif ($self->{try_wget} and 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"; }; } elsif ($self->{try_curl} and 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"; }; } else { require HTTP::Tiny; $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n"); $self->{_backends}{get} = sub { my $self = shift; my $res = HTTP::Tiny->new->get($_[0]); return unless $res->{success}; return $res->{content}; }; $self->{_backends}{mirror} = sub { my $self = shift; my $res = HTTP::Tiny->new->mirror(@_); return $res->{status}; }; } 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.11"; 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/Tiny.pm"} = <<'HTTP_TINY'; # vim: ts=4 sts=4 sw=4 et: # # This file is part of HTTP-Tiny # # This software is copyright (c) 2011 by Christian Hansen. # # This is free software; you can redistribute it and/or modify it under # the same terms as the Perl 5 programming language system itself. # package HTTP::Tiny; BEGIN { $HTTP::Tiny::VERSION = '0.009'; } use strict; use warnings; # ABSTRACT: A small, simple, correct HTTP/1.1 client use Carp (); my @attributes; BEGIN { @attributes = qw(agent default_headers max_redirect max_size proxy timeout); no strict 'refs'; for my $accessor ( @attributes ) { *{$accessor} = sub { @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; }; } } sub new { my($class, %args) = @_; (my $agent = $class) =~ s{::}{-}g; my $self = { agent => $agent . "/" . ($class->VERSION || 0), max_redirect => 5, timeout => 60, }; for my $key ( @attributes ) { $self->{$key} = $args{$key} if exists $args{$key} } return bless $self, $class; } sub get { my ($self, $url, $args) = @_; @_ == 2 || (@_ == 3 && ref $args eq 'HASH') or Carp::croak(q/Usage: $http->get(URL, [HASHREF])/); return $self->request('GET', $url, $args || {}); } sub mirror { my ($self, $url, $file, $args) = @_; @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/); if ( -e $file and my $mtime = (stat($file))[9] ) { $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); } my $tempfile = $file . int(rand(2**31)); open my $fh, ">", $tempfile or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!/); $args->{data_callback} = sub { print {$fh} $_[0] }; my $response = $self->request('GET', $url, $args); close $fh or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!/); if ( $response->{success} ) { rename $tempfile, $file or Carp::croak "Error replacing $file with $tempfile: $!\n"; my $lm = $response->{headers}{'last-modified'}; if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { utime $mtime, $mtime, $file; } } $response->{success} ||= $response->{status} eq '304'; unlink $tempfile; return $response; } my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; sub request { my ($self, $method, $url, $args) = @_; @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/); $args ||= {}; # we keep some state in this during _request # RFC 2616 Section 8.1.4 mandates a single retry on broken socket my $response; for ( 0 .. 1 ) { $response = eval { $self->_request($method, $url, $args) }; last unless $@ && $idempotent{$method} && $@ =~ m{^(?:Socket closed|Unexpected end)}; } if (my $e = "$@") { $response = { success => q{}, status => 599, reason => 'Internal Exception', content => $e, headers => { 'content-type' => 'text/plain', 'content-length' => length $e, } }; } return $response; } my %DefaultPort = ( http => 80, https => 443, ); sub _request { my ($self, $method, $url, $args) = @_; my ($scheme, $host, $port, $path_query) = $self->_split_url($url); my $request = { method => $method, scheme => $scheme, host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), uri => $path_query, headers => {}, }; my $handle = HTTP::Tiny::Handle->new(timeout => $self->{timeout}); if ($self->{proxy}) { $request->{uri} = "$scheme://$request->{host_port}$path_query"; croak(qq/HTTPS via proxy is not supported/) if $request->{scheme} eq 'https'; $handle->connect(($self->_split_url($self->{proxy}))[0..2]); } else { $handle->connect($scheme, $host, $port); } $self->_prepare_headers_and_cb($request, $args); $handle->write_request($request); my $response; do { $response = $handle->read_response_header } until (substr($response->{status},0,1) ne '1'); if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) { $handle->close; return $self->_request(@redir_args, $args); } if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { # response has no message body } else { my $data_cb = $self->_prepare_data_cb($response, $args); $handle->read_body($data_cb, $response); } $handle->close; $response->{success} = substr($response->{status},0,1) eq '2'; return $response; } sub _prepare_headers_and_cb { my ($self, $request, $args) = @_; for ($self->{default_headers}, $args->{headers}) { next unless defined; while (my ($k, $v) = each %$_) { $request->{headers}{lc $k} = $v; } } $request->{headers}{'host'} = $request->{host_port}; $request->{headers}{'connection'} = "close"; $request->{headers}{'user-agent'} ||= $self->{agent}; if (defined $args->{content}) { $request->{headers}{'content-type'} ||= "application/octet-stream"; if (ref $args->{content} eq 'CODE') { $request->{headers}{'transfer-encoding'} = 'chunked' unless $request->{headers}{'content-length'} || $request->{headers}{'transfer-encoding'}; $request->{cb} = $args->{content}; } else { my $content = $args->{content}; if ( $] ge '5.008' ) { utf8::downgrade($content, 1) or Carp::croak(q/Wide character in request message body/); } $request->{headers}{'content-length'} = length $content unless $request->{headers}{'content-length'} || $request->{headers}{'transfer-encoding'}; $request->{cb} = sub { substr $content, 0, length $content, '' }; } $request->{trailer_cb} = $args->{trailer_callback} if ref $args->{trailer_callback} eq 'CODE'; } return; } sub _prepare_data_cb { my ($self, $response, $args) = @_; my $data_cb = $args->{data_callback}; $response->{content} = ''; if (!$data_cb || $response->{status} !~ /^2/) { if (defined $self->{max_size}) { $data_cb = sub { $_[1]->{content} .= $_[0]; die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) if length $_[1]->{content} > $self->{max_size}; }; } else { $data_cb = sub { $_[1]->{content} .= $_[0] }; } } return $data_cb; } sub _maybe_redirect { my ($self, $request, $response, $args) = @_; my $headers = $response->{headers}; my ($status, $method) = ($response->{status}, $request->{method}); if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/)) and $headers->{location} and ++$args->{redirects} <= $self->{max_redirect} ) { my $location = ($headers->{location} =~ /^\//) ? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location} ; return (($status eq '303' ? 'GET' : $method), $location); } return; } sub _split_url { my $url = pop; # URI regex adapted from the URI module my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or Carp::croak(qq/Cannot parse URL: '$url'/); $scheme = lc $scheme; $path_query = "/$path_query" unless $path_query =~ m<\A/>; my $host = (length($authority)) ? lc $authority : 'localhost'; $host =~ s/\A[^@]*@//; # userinfo my $port = do { $host =~ s/:([0-9]*)\z// && length $1 ? $1 : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef); }; return ($scheme, $host, $port, $path_query); } # Date conversions adapted from HTTP::Date my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; sub _http_date { my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", substr($DoW,$wday*4,3), $mday, substr($MoY,$mon*4,3), $year+1900, $hour, $min, $sec ); } sub _parse_http_date { my ($self, $str) = @_; require Time::Local; my @tl_parts; if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); } elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); } elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); } return eval { my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; $t < 0 ? undef : $t; }; } package HTTP::Tiny::Handle; # hide from PAUSE/indexers use strict; use warnings; use Carp qw[croak]; use Errno qw[EINTR EPIPE]; use IO::Socket qw[SOCK_STREAM]; sub BUFSIZE () { 32768 } my $Printable = sub { local $_ = shift; s/\r/\\r/g; s/\n/\\n/g; s/\t/\\t/g; s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; $_; }; my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; sub new { my ($class, %args) = @_; return bless { rbuf => '', timeout => 60, max_line_size => 16384, max_header_lines => 64, %args }, $class; } my $ssl_verify_args = { check_cn => "when_only", wildcards_in_alt => "anywhere", wildcards_in_cn => "anywhere" }; sub connect { @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/); my ($self, $scheme, $host, $port) = @_; if ( $scheme eq 'https' ) { eval "require IO::Socket::SSL" unless exists $INC{'IO/Socket/SSL.pm'}; croak(qq/IO::Socket::SSL must be installed for https support\n/) unless $INC{'IO/Socket/SSL.pm'}; } elsif ( $scheme ne 'http' ) { croak(qq/Unsupported URL scheme '$scheme'/); } $self->{fh} = 'IO::Socket::INET'->new( PeerHost => $host, PeerPort => $port, Proto => 'tcp', Type => SOCK_STREAM, Timeout => $self->{timeout} ) or croak(qq/Could not connect to '$host:$port': $@/); binmode($self->{fh}) or croak(qq/Could not binmode() socket: '$!'/); if ( $scheme eq 'https') { IO::Socket::SSL->start_SSL($self->{fh}); ref($self->{fh}) eq 'IO::Socket::SSL' or die(qq/SSL connection failed for $host\n/); $self->{fh}->verify_hostname( $host, $ssl_verify_args ) or die(qq/SSL certificate not valid for $host\n/); } $self->{host} = $host; $self->{port} = $port; return $self; } sub close { @_ == 1 || croak(q/Usage: $handle->close()/); my ($self) = @_; CORE::close($self->{fh}) or croak(qq/Could not close socket: '$!'/); } sub write { @_ == 2 || croak(q/Usage: $handle->write(buf)/); my ($self, $buf) = @_; if ( $] ge '5.008' ) { utf8::downgrade($buf, 1) or croak(q/Wide character in write()/); } my $len = length $buf; my $off = 0; local $SIG{PIPE} = 'IGNORE'; while () { $self->can_write or croak(q/Timed out while waiting for socket to become ready for writing/); my $r = syswrite($self->{fh}, $buf, $len, $off); if (defined $r) { $len -= $r; $off += $r; last unless $len > 0; } elsif ($! == EPIPE) { croak(qq/Socket closed by remote server: $!/); } elsif ($! != EINTR) { croak(qq/Could not write to socket: '$!'/); } } return $off; } sub read { @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len [, allow_partial])/); my ($self, $len, $allow_partial) = @_; my $buf = ''; my $got = length $self->{rbuf}; if ($got) { my $take = ($got < $len) ? $got : $len; $buf = substr($self->{rbuf}, 0, $take, ''); $len -= $take; } while ($len > 0) { $self->can_read or croak(q/Timed out while waiting for socket to become ready for reading/); my $r = sysread($self->{fh}, $buf, $len, length $buf); if (defined $r) { last unless $r; $len -= $r; } elsif ($! != EINTR) { croak(qq/Could not read from socket: '$!'/); } } if ($len && !$allow_partial) { croak(q/Unexpected end of stream/); } return $buf; } sub readline { @_ == 1 || croak(q/Usage: $handle->readline()/); my ($self) = @_; while () { if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { return $1; } if (length $self->{rbuf} >= $self->{max_line_size}) { croak(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}/); } $self->can_read or croak(q/Timed out while waiting for socket to become ready for reading/); my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); if (defined $r) { last unless $r; } elsif ($! != EINTR) { croak(qq/Could not read from socket: '$!'/); } } croak(q/Unexpected end of stream while looking for line/); } sub read_header_lines { @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/); my ($self, $headers) = @_; $headers ||= {}; my $lines = 0; my $val; while () { my $line = $self->readline; if (++$lines >= $self->{max_header_lines}) { croak(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}/); } elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { my ($field_name) = lc $1; if (exists $headers->{$field_name}) { for ($headers->{$field_name}) { $_ = [$_] unless ref $_ eq "ARRAY"; push @$_, $2; $val = \$_->[-1]; } } else { $val = \($headers->{$field_name} = $2); } } elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { $val or croak(q/Unexpected header continuation line/); next unless length $1; $$val .= ' ' if length $$val; $$val .= $1; } elsif ($line =~ /\A \x0D?\x0A \z/x) { last; } else { croak(q/Malformed header line: / . $Printable->($line)); } } return $headers; } sub write_request { @_ == 2 || croak(q/Usage: $handle->write_request(request)/); my($self, $request) = @_; $self->write_request_header(@{$request}{qw/method uri headers/}); $self->write_body($request) if $request->{cb}; return; } my %HeaderCase = ( 'content-md5' => 'Content-MD5', 'etag' => 'ETag', 'te' => 'TE', 'www-authenticate' => 'WWW-Authenticate', 'x-xss-protection' => 'X-XSS-Protection', ); sub write_header_lines { (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/); my($self, $headers) = @_; my $buf = ''; while (my ($k, $v) = each %$headers) { my $field_name = lc $k; if (exists $HeaderCase{$field_name}) { $field_name = $HeaderCase{$field_name}; } else { $field_name =~ /\A $Token+ \z/xo or croak(q/Invalid HTTP header field name: / . $Printable->($field_name)); $field_name =~ s/\b(\w)/\u$1/g; $HeaderCase{lc $field_name} = $field_name; } for (ref $v eq 'ARRAY' ? @$v : $v) { /[^\x0D\x0A]/ or croak(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_)); $buf .= "$field_name: $_\x0D\x0A"; } } $buf .= "\x0D\x0A"; return $self->write($buf); } sub read_body { @_ == 3 || croak(q/Usage: $handle->read_body(callback, response)/); my ($self, $cb, $response) = @_; my $te = $response->{headers}{'transfer-encoding'} || ''; if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) { $self->read_chunked_body($cb, $response); } else { $self->read_content_body($cb, $response); } return; } sub write_body { @_ == 2 || croak(q/Usage: $handle->write_body(request)/); my ($self, $request) = @_; if ($request->{headers}{'content-length'}) { return $self->write_content_body($request); } else { return $self->write_chunked_body($request); } } sub read_content_body { @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/); my ($self, $cb, $response, $content_length) = @_; $content_length ||= $response->{headers}{'content-length'}; if ( $content_length ) { my $len = $content_length; while ($len > 0) { my $read = ($len > BUFSIZE) ? BUFSIZE : $len; $cb->($self->read($read, 0), $response); $len -= $read; } } else { my $chunk; $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); } return; } sub write_content_body { @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/); my ($self, $request) = @_; my ($len, $content_length) = (0, $request->{headers}{'content-length'}); while () { my $data = $request->{cb}->(); defined $data && length $data or last; if ( $] ge '5.008' ) { utf8::downgrade($data, 1) or croak(q/Wide character in write_content()/); } $len += $self->write($data); } $len == $content_length or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/); return $len; } sub read_chunked_body { @_ == 3 || croak(q/Usage: $handle->read_chunked_body(callback, $response)/); my ($self, $cb, $response) = @_; while () { my $head = $self->readline; $head =~ /\A ([A-Fa-f0-9]+)/x or croak(q/Malformed chunk head: / . $Printable->($head)); my $len = hex($1) or last; $self->read_content_body($cb, $response, $len); $self->read(2) eq "\x0D\x0A" or croak(q/Malformed chunk: missing CRLF after chunk data/); } $self->read_header_lines($response->{headers}); return; } sub write_chunked_body { @_ == 2 || croak(q/Usage: $handle->write_chunked_body(request)/); my ($self, $request) = @_; my $len = 0; while () { my $data = $request->{cb}->(); defined $data && length $data or last; if ( $] ge '5.008' ) { utf8::downgrade($data, 1) or croak(q/Wide character in write_chunked_body()/); } $len += length $data; my $chunk = sprintf '%X', length $data; $chunk .= "\x0D\x0A"; $chunk .= $data; $chunk .= "\x0D\x0A"; $self->write($chunk); } $self->write("0\x0D\x0A"); $self->write_header_lines($request->{trailer_cb}->()) if ref $request->{trailer_cb} eq 'CODE'; return $len; } sub read_response_header { @_ == 1 || croak(q/Usage: $handle->read_response_header()/); my ($self) = @_; my $line = $self->readline; $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or croak(q/Malformed Status-Line: / . $Printable->($line)); my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); croak (qq/Unsupported HTTP protocol: $protocol/) unless $version =~ /0*1\.0*[01]/; return { status => $status, reason => $reason, headers => $self->read_header_lines, protocol => $protocol, }; } sub write_request_header { @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/); my ($self, $method, $request_uri, $headers) = @_; return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") + $self->write_header_lines($headers); } sub _do_timeout { my ($self, $type, $timeout) = @_; $timeout = $self->{timeout} unless defined $timeout && $timeout >= 0; my $fd = fileno $self->{fh}; defined $fd && $fd >= 0 or croak(q/select(2): 'Bad file descriptor'/); my $initial = time; my $pending = $timeout; my $nfound; vec(my $fdset = '', $fd, 1) = 1; while () { $nfound = ($type eq 'read') ? select($fdset, undef, undef, $pending) : select(undef, $fdset, undef, $pending) ; if ($nfound == -1) { $! == EINTR or croak(qq/select(2): '$!'/); redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; $nfound = 0; } last; } $! = 0; return $nfound; } sub can_read { @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/); my $self = shift; return $self->_do_timeout('read', @_) } sub can_write { @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/); my $self = shift; return $self->_do_timeout('write', @_) } 1; __END__ =pod =head1 NAME HTTP::Tiny - A small, simple, correct HTTP/1.1 client =head1 VERSION version 0.009 =head1 SYNOPSIS use HTTP::Tiny; my $response = HTTP::Tiny->new->get('http://example.com/'); die "Failed!\n" unless $response->{success}; print "$response->{status} $response->{reason}\n"; while (my ($k, $v) = each %{$response->{headers}}) { for (ref $v eq 'ARRAY' ? @$v : $v) { print "$k: $_\n"; } } print $response->{content} if length $response->{content}; =head1 DESCRIPTION This is a very simple HTTP/1.1 client, designed primarily for doing simple GET requests without the overhead of a large framework like L. It is more correct and more complete than L. It supports proxies (currently only non-authenticating ones) and redirection. It also correctly resumes after EINTR. =head1 METHODS =head2 new $http = HTTP::Tiny->new( %attributes ); This constructor returns a new HTTP::Tiny object. Valid attributes include: =over 4 =item * agent A user-agent string (defaults to 'HTTP::Tiny/$VERSION') =item * default_headers A hashref of default headers to apply to requests =item * max_redirect Maximum number of redirects allowed (defaults to 5) =item * max_size Maximum response size (only when not using a data callback). If defined, responses larger than this will die with an error message =item * proxy URL of a proxy server to use. =item * timeout Request timeout in seconds (default is 60) =back =head2 get $response = $http->get($url); $response = $http->get($url, \%options); Executes a C request for the given URL. The URL must have unsafe characters escaped and international domain names encoded. Internally, it just calls C with 'GET' as the method. See C for valid options and a description of the response. =head2 mirror $response = $http->mirror($url, $file, \%options) if ( $response->{success} ) { print "$file is up to date\n"; } Executes a C request for the URL and saves the response body to the file name provided. The URL must have unsafe characters escaped and international domain names encoded. If the file already exists, the request will includes an C header with the modification timestamp of the file. You may specificy a different C header yourself in the C<< $options->{headers} >> hash. The C field of the response will be true if the status code is 2XX or 304 (unmodified). If the file was modified and the server response includes a properly formatted C header, the file modification time will be updated accordingly. =head2 request $response = $http->request($method, $url); $response = $http->request($method, $url, \%options); Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and international domain names encoded. A hashref of options may be appended to modify the request. Valid options are: =over 4 =item * headers A hashref containing headers to include with the request. If the value for a header is an array reference, the header will be output multiple times with each value in the array. These headers over-write any default headers. =item * content A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the response =item * trailer_callback A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding) =item * data_callback A code reference that will be called for each chunks of the response body received. =back If the C option is a code reference, it will be called iteratively to provide the content body of the request. It should return the empty string or undef when the iterator is exhausted. If the C option is provided, it will be called iteratively until the entire response body is received. The first argument will be a string containing a chunk of the response body, the second argument will be the in-progress response hash reference, as described below. (This allows customizing the action of the callback based on the C or C received prior to the content body.) The C method returns a hashref containing the response. The hashref will have the following keys: =over 4 =item * success Boolean indicating whether the operation returned a 2XX status code =item * status The HTTP status code of the response =item * reason The response phrase returned by the server =item * content The body of the response. If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string =item * headers A hashref of header fields. All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value =back On an exception during the execution of the request, the C field will contain 599, and the C field will contain the text of the exception. =for Pod::Coverage agent default_headers max_redirect max_size proxy timeout =head1 LIMITATIONS HTTP::Tiny is I with the L. It attempts to meet all "MUST" requirements of the specification, but does not implement all "SHOULD" requirements. Some particular limitations of note include: =over =item * HTTP::Tiny focuses on correct transport. Users are responsible for ensuring that user-defined headers and content are compliant with the HTTP/1.1 specification. =item * Users must ensure that URLs are properly escaped for unsafe characters and that international domain names are properly encoded to ASCII. See L, L and L. =item * Redirection is very strict against the specification. Redirection is only automatic for response codes 301, 302 and 307 if the request method is 'GET' or 'HEAD'. Response code 303 is always converted into a 'GET' redirection, as mandated by the specification. There is no automatic support for status 305 ("Use proxy") redirections. =item * Persistant connections are not supported. The C header will always be set to C. =item * Direct C connections are supported only if L is installed. There is no support for C connections via proxy. =item * Cookies are not directly supported. Users that set a C header should also set C to zero to ensure cookies are not inappropriately re-transmitted. =item * Proxy environment variables are not supported. =item * There is no provision for delaying a request body using an C header. Unexpected C<1XX> responses are silently ignored as per the specification. =item * Only 'chunked' C is supported. =item * There is no support for a Request-URI of '*' for the 'OPTIONS' request. =back =head1 SEE ALSO =over 4 =item * L =back =head1 AUTHORS =over 4 =item * Christian Hansen =item * David Golden =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011 by Christian Hansen. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut HTTP_TINY $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; # Adapted from Perl-licensed code originally distributed with # Module-Build by Ken Williams # 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 = '1.000003'; $VERSION = eval $VERSION; use File::Spec; use IO::File; use version 0.87; 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 = version->new($v1) unless UNIVERSAL::isa($v1,'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' ) { # 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 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 $@; # Upgrade it into a version object my $version = eval { _dwim_version($result) }; die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined $version; # "0" is OK! return $version; } } # Try to DWIM when things fail the lax version test in obvious ways { my @version_prep = ( # Best case, it just works sub { return shift }, # If we still don't have a version, try stripping any # trailing junk that is prohibited by lax rules sub { my $v = shift; $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b return $v; }, # Activestate apparently creates custom versions like '1.23_45_01', which # cause version.pm to think it's an invalid alpha. So check for that # and strip them sub { my $v = shift; my $num_dots = () = $v =~ m{(\.)}g; my $num_unders = () = $v =~ m{(_)}g; my $leading_v = substr($v,0,1) eq 'v'; if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { $v =~ s{_}{}g; $num_unders = () = $v =~ m{(_)}g; } return $v; }, # Worst case, try numifying it like we would have before version objects sub { my $v = shift; no warnings 'numeric'; return 0 + $v; }, ); sub _dwim_version { my ($result) = shift; return $result if ref($result) eq 'version'; my ($version, $error); for my $f (@version_prep) { $result = $f->($result); $version = eval { version->new($result) }; $error ||= $@ if $@; # capture first failure last if defined $version; } die $error unless defined $version; return $version; } } ############################################################ # 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; =head1 NAME Module::Metadata - Gather package and POD information from perl module files =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. =item package_versions_from_directory($dir, \@files?) Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks for those files in C<$dir> - and reads each file for packages and versions, returning a hashref of the form: { 'Package::Name' => { version => '0.123', file => 'Package/Name.pm' }, 'OtherPackage::Name' => ... } =item log_info (internal) Used internally to perform logging; imported from Log::Contextual if Log::Contextual has already been loaded, otherwise simply calls warn. =back =head1 AUTHOR Ken Williams , Randy W. Sims Released as Module::Metadata by Matt S Trout (mst) with assistance from David Golden (xdg) =head1 COPYRIGHT Copyright (c) 2001-2011 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. =cut MODULE_METADATA $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{"lib/core/only.pm"} = <<'LIB_CORE_ONLY'; package lib::core::only; use strict; use warnings FATAL => 'all'; use Config; sub import { @INC = @Config{qw(privlibexp archlibexp)}; return } =head1 NAME lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs =head1 SYNOPSIS use lib::core::only; # now @INC contains only the two core directories To get only the core directories plus the ones for the local::lib in scope: $ perl -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl To attempt to do a self-contained build (but note this will not reliably propagate into subprocesses, see the CAVEATS below): $ PERL5OPT='-Mlib::core::only -Mlocal::lib=~/perl5' cpan =head1 DESCRIPTION lib::core::only is simply a shortcut to say "please reduce my @INC to only the core lib and archlib (architecture-specific lib) directories of this perl". You might want to do this to ensure a local::lib contains only the code you need, or to test an L tree, or to avoid known bad vendor packages. You might want to use this to try and install a self-contained tree of perl modules. Be warned that that probably won't work (see L). This module was extracted from L's --self-contained feature, and contains the only part that ever worked. I apologise to anybody who thought anything else did. =head1 CAVEATS This does B propagate properly across perl invocations like local::lib's stuff does. It can't. It's only a module import, so it B. If you want to cascade it across invocations, you can set the PERL5OPT environment variable to '-Mlib::core::only' and it'll sort of work. But be aware that taint mode ignores this, so some modules' build and test code probably will as well. You also need to be aware that perl's command line options are not processed in order - -I options take effect before -M options, so perl -Mlib::core::only -Ilib is unlike to do what you want - it's exactly equivalent to: perl -Mlib::core::only If you want to combine a core-only @INC with additional paths, you need to add the additional paths using -M options and the L module: perl -Mlib::core::only -Mlib=lib # or if you're trying to test compiled code: perl -Mlib::core::only -Mblib For more information on the impossibility of sanely propagating this across module builds without help from the build program, see L - and for ways to achieve the old --self-contained feature's results, look at L's tree function, and at L's --local-lib-contained feature. =head1 AUTHOR Matt S. Trout =head1 LICENSE This library is free software under the same terms as perl itself. =head1 COPYRIGHT (c) 2010 the lib::core::only L as specified above. =cut 1; LIB_CORE_ONLY $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.008001'; # 1.8.1 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 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'; return $path; } sub INTERPOLATE_ENV () { 1 } sub LITERAL_ENV () { 0 } sub guess_shelltype { 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 } }; } return $shelltype; } sub print_environment_vars_for { my ($class, $path) = @_; print $class->environment_vars_string_for($path); } sub environment_vars_string_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 $shelltype = $class->guess_shelltype; while (@envs) { my ($name, $value) = (shift(@envs), shift(@envs)); $value =~ s/(\\")/\\$1/g; $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value); } return $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 ( PERL_LOCAL_LIB_ROOT => $path, PERL_MB_OPT => "--install_base ${path}", PERL_MM_OPT => "INSTALL_BASE=${path}", PERL5LIB => join($Config{path_sep}, $class->install_base_arch_path($path), $class->install_base_perl_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'); =end testing =encoding utf8 =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 PERL_MB_OPT='--install_base /home/username/perl5' export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5' export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5' export PATH="/home/username/perl5/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. If you do have administrative privileges, you will still want to set up your environment variables, as discussed in step 4. Without this, you would still install the modules into the system CPAN installation and also your Perl scripts will not use the lib/ path you bootstrapped with local::lib. By default local::lib installs itself and the CPAN modules into ~/perl5. Windows users must also see L. 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. In order to install local::lib into a directory other than the default, you need to specify the name of the directory when you call bootstrap, as follows: perl Makefile.PL --bootstrap=~/foo 3. Run this: (local::lib assumes you have make installed on your system) make test && make install 4. Now we need to setup the appropriate environment variables, so that Perl starts using our newly generated lib/ directory. If you are using bash or any other Bourne shells, you can add this to your shell startup script this way: 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 If you passed to bootstrap a directory other than default, you also need to give that as import parameter to the call of the local::lib module like this way: 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. 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 To avoid doing several bootstrap for several Perl module environments on the same account, for example if you use it for several different deployed applications independently, you can use one bootstrapped local::lib installation to install modules in different directories directly this way: 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 To set up the proper environment variables for your current session of C, you can use this: C:\>perl -Mlocal::lib set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 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 or use L. 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 PERL_MB_OPT =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_dir_structure_for =over 4 =item Arguments: $path =item Return value: None =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 =item Return value: None =back Prints to standard output the variables listed above, properly set to use the given path as the base directory. =head2 build_environment_vars_for =over 4 =item Arguments: $path, $interpolate =item Return value: \%environment_vars =back Returns a hash with 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 =item Return value: None =back Constructs the C<%ENV> keys for the given path, by calling L. =head2 install_base_perl_path =over 4 =item Arguments: $path =item Return value: $install_base_perl_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 =item Return value: $install_base_arch_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 =item Return value: $install_base_bin_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 resolve_empty_path =over 4 =item Arguments: $path =item Return value: $base_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 =item Return value: $home_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 =item Return value: $absolute_path =back Translates the given path into an absolute path. =head2 resolve_path =over 4 =item Arguments: $path =item Return value: $absolute_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 The perl toolchain is unable to handle directory names with spaces in it, so you cant put your local::lib bootstrap into a directory with spaces. What you can do is moving your local::lib to a directory with spaces B you installed all modules inside your local::lib bootstrap. But be aware that you cant update or install CPAN modules after the move. 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 PERL_MB_OPT. 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 SUPPORT IRC: Join #local-lib on irc.perl.org. =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, more cleanups in the english documentation and a L 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. Documentation patches to make win32 usage clearer by David Mertens (run4flat). Brazilian L and minor doc patches contributed by Breno G. de Oliveira . =head1 COPYRIGHT Copyright (c) 2007 - 2010 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 $fatpacked{"version.pm"} = <<'VERSION'; #!perl -w package version; use 5.005_04; use strict; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); $VERSION = 0.88; $CLASS = 'version'; #--------------------------------------------------------------------------# # Version regexp components #--------------------------------------------------------------------------# # Fraction part of a decimal version number. This is a common part of # both strict and lax decimal versions my $FRACTION_PART = qr/\.[0-9]+/; # First part of either decimal or dotted-decimal strict version number. # Unsigned integer with no leading zeroes (except for zero itself) to # avoid confusion with octal. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; # First part of either decimal or dotted-decimal lax version number. # Unsigned integer, but allowing leading zeros. Always interpreted # as decimal. However, some forms of the resulting syntax give odd # results if used as ordinary Perl expressions, due to how perl treats # octals. E.g. # version->new("010" ) == 10 # version->new( 010 ) == 8 # version->new( 010.2) == 82 # "8" . "2" my $LAX_INTEGER_PART = qr/[0-9]+/; # Second and subsequent part of a strict dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. # Limited to three digits to avoid overflow when converting to decimal # form and also avoid problematic style with excessive leading zeroes. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; # Second and subsequent part of a lax dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. No # limit on the numerical value or number of digits, so there is the # possibility of overflow when converting to decimal form. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; # Alpha suffix part of lax version number syntax. Acts like a # dotted-decimal part. my $LAX_ALPHA_PART = qr/_[0-9]+/; #--------------------------------------------------------------------------# # Strict version regexp definitions #--------------------------------------------------------------------------# # Strict decimal version number. my $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; # Strict dotted-decimal version number. Must have both leading "v" and # at least three parts, to avoid confusion with decimal syntax. my $STRICT_DOTTED_DECIMAL_VERSION = qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; # Complete strict version number syntax -- should generally be used # anchored: qr/ \A $STRICT \z /x $STRICT = qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Lax version regexp definitions #--------------------------------------------------------------------------# # Lax decimal version number. Just like the strict one except for # allowing an alpha suffix or allowing a leading or trailing # decimal-point my $LAX_DECIMAL_VERSION = qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | $FRACTION_PART $LAX_ALPHA_PART? /x; # Lax dotted-decimal version number. Distinguished by having either # leading "v" or at least three non-alpha parts. Alpha part is only # permitted if there are at least two non-alpha parts. Strangely # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, # so when there is no "v", the leading part is optional my $LAX_DOTTED_DECIMAL_VERSION = qr/ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? /x; # Complete lax version number syntax -- should generally be used # anchored: qr/ \A $LAX \z /x # # The string 'undef' is a special case to make for easier handling # of return values from ExtUtils::MM->parse_version $LAX = qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# eval "use version::vxs $VERSION"; if ( $@ ) { # don't have the XS version installed eval "use version::vpp $VERSION"; # don't tempt fate die "$@" if ( $@ ); push @ISA, "version::vpp"; local $^W; *version::qv = \&version::vpp::qv; *version::declare = \&version::vpp::declare; *version::_VERSION = \&version::vpp::_VERSION; if ($] >= 5.009000 && $] < 5.011004) { no strict 'refs'; *version::stringify = \&version::vpp::stringify; *{'version::(""'} = \&version::vpp::stringify; *version::new = \&version::vpp::new; *version::parse = \&version::vpp::parse; } } else { # use XS module push @ISA, "version::vxs"; local $^W; *version::declare = \&version::vxs::declare; *version::qv = \&version::vxs::qv; *version::_VERSION = \&version::vxs::_VERSION; *version::vcmp = \&version::vxs::VCMP; if ($] >= 5.009000 && $] < 5.011004) { no strict 'refs'; *version::stringify = \&version::vxs::stringify; *{'version::(""'} = \&version::vxs::stringify; *version::new = \&version::vxs::new; *version::parse = \&version::vxs::parse; } } # 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; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&version::is_strict unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&version::is_lax unless defined(&{$callpkg.'::is_lax'}); } } sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } 1; VERSION $fatpacked{"version/vpp.pm"} = <<'VERSION_VPP'; package charstar; # a little helper class to emulate C char* semantics in Perl # so that prescan_version can use the same code as in C use overload ( '""' => \&thischar, '0+' => \&thischar, '++' => \&increment, '--' => \&decrement, '+' => \&plus, '-' => \&minus, '*' => \&multiply, 'cmp' => \&cmp, '<=>' => \&spaceship, 'bool' => \&thischar, '=' => \&clone, ); sub new { my ($self, $string) = @_; my $class = ref($self) || $self; my $obj = { string => [split(//,$string)], current => 0, }; return bless $obj, $class; } sub thischar { my ($self) = @_; my $last = $#{$self->{string}}; my $curr = $self->{current}; if ($curr >= 0 && $curr <= $last) { return $self->{string}->[$curr]; } else { return ''; } } sub increment { my ($self) = @_; $self->{current}++; } sub decrement { my ($self) = @_; $self->{current}--; } sub plus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} += $offset; return $rself; } sub minus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} -= $offset; return $rself; } sub multiply { my ($left, $right, $swapped) = @_; my $char = $left->thischar(); return $char * $right; } sub spaceship { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already $right = $left->new($right); } return $left->{current} <=> $right->{current}; } sub cmp { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already if (length($right) == 1) { # comparing single character only return $left->thischar cmp $right; } $right = $left->new($right); } return $left->currstr cmp $right->currstr; } sub bool { my ($self) = @_; my $char = $self->thischar; return ($char ne ''); } sub clone { my ($left, $right, $swapped) = @_; $right = { string => [@{$left->{string}}], current => $left->{current}, }; return bless $right, ref($left); } sub currstr { my ($self, $s) = @_; my $curr = $self->{current}; my $last = $#{$self->{string}}; if (defined($s) && $s->{current} < $last) { $last = $s->{current}; } my $string = join('', @{$self->{string}}[$curr..$last]); return $string; } package version::vpp; use strict; use POSIX qw/locale_h/; use locale; use vars qw ($VERSION @ISA @REGEXS); $VERSION = 0.88; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, 'nomethod' => \&vnoop, ); eval "use warnings"; if ($@) { eval ' package warnings; sub enabled {return $^W;} 1; '; } my $VERSION_MAX = 0x7FFFFFFF; # implement prescan_version as closely to the C version as possible use constant TRUE => 1; use constant FALSE => 0; sub isDIGIT { my ($char) = shift->thischar(); return ($char =~ /\d/); } sub isALPHA { my ($char) = shift->thischar(); return ($char =~ /[a-zA-Z]/); } sub isSPACE { my ($char) = shift->thischar(); return ($char =~ /\s/); } sub BADVERSION { my ($s, $errstr, $error) = @_; if ($errstr) { $$errstr = $error; } return $s; } sub prescan_version { my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; my $qv = defined $sqv ? $$sqv : FALSE; my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; my $width = defined $swidth ? $$swidth : 3; my $alpha = defined $salpha ? $$salpha : FALSE; my $d = $s; if ($qv && isDIGIT($d)) { goto dotted_decimal_version; } if ($d eq 'v') { # explicit v-string $d++; if (isDIGIT($d)) { $qv = TRUE; } else { # degenerate v-string # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)) { # no leading zeros allowed return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } while (isDIGIT($d)) { # integer part $d++; } if ($d eq '.') { $saw_decimal++; $d++; # decimal point } else { if ($strict) { # require v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } else { goto version_prescan_finish; } } { my $i = 0; my $j = 0; while (isDIGIT($d)) { # just keep reading $i++; while (isDIGIT($d)) { $d++; $j++; # maximum 3 digits between decimal if ($strict && $j > 3) { return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); } } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } $d++; $alpha = TRUE; } elsif ($d eq '.') { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } $saw_decimal++; $d++; } elsif (!isDIGIT($d)) { last; } $j = 0; } if ($strict && $i < 2) { # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } } } # end if dotted-decimal else { # decimal versions # special $strict case for leading '.' or '0' if ($strict) { if ($d eq '.') { return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); } if ($d eq '0' && isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } } # consume all of the integer part while (isDIGIT($d)) { $d++; } # look for a fractional part if ($d eq '.') { # we found it, so consume it $saw_decimal++; $d++; } elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { if ( $d == $s ) { # found nothing return BADVERSION($s,$errstr,"Invalid version format (version required)"); } # found just an integer goto version_prescan_finish; } elsif ( $d == $s ) { # didn't find either integer or period return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } elsif ($d eq '_') { # underscore can't come after integer part if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } elsif (isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); } else { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } } elsif ($d) { # anything else after integer part is just invalid data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } # scan the fractional part after the decimal point if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { # $strict or lax-but-not-the-end return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); } while (isDIGIT($d)) { $d++; if ($d eq '.' && isDIGIT($d-1)) { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); } $d = $s; # start all over again $qv = TRUE; goto dotted_decimal_version; } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } if ( ! isDIGIT($d+1) ) { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } $d++; $alpha = TRUE; } } } version_prescan_finish: while (isSPACE($d)) { $d++; } if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { # trailing non-numeric data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } if (defined $sqv) { $$sqv = $qv; } if (defined $swidth) { $$swidth = $width; } if (defined $ssaw_decimal) { $$ssaw_decimal = $saw_decimal; } if (defined $salpha) { $$salpha = $alpha; } return $d; } sub scan_version { my ($s, $rv, $qv) = @_; my $start; my $pos; my $last; my $errstr; my $saw_decimal = 0; my $width = 3; my $alpha = FALSE; my $vinf = FALSE; my @av; $s = new charstar $s; while (isSPACE($s)) { # leading whitespace is OK $s++; } $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, \$width, \$alpha); if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { use Carp; Carp::croak($errstr); } } $start = $s; if ($s eq 'v') { $s++; } $pos = $s; if ( $qv ) { $$rv->{qv} = $qv; } if ( $alpha ) { $$rv->{alpha} = $alpha; } if ( !$qv && $width < 3 ) { $$rv->{width} = $width; } while (isDIGIT($pos)) { $pos++; } if (!isALPHA($pos)) { my $rev; for (;;) { $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_decimal == 1 ) { $mult *= 100; while ( $s < $end ) { $orev = $rev; $rev += $s * $mult; $mult /= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version %d", $VERSION_MAX); $s = $end - 1; $rev = $VERSION_MAX; $vinf = 1; } $s++; if ( $s eq '_' ) { $s++; } } } else { while (--$end >= $s) { $orev = $rev; $rev += $end * $mult; $mult *= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version"); $end = $s - 1; $rev = $VERSION_MAX; $vinf = 1; } } } } # Append revision push @av, $rev; if ( $vinf ) { $s = $last; last; } elsif ( $pos eq '.' ) { $s = ++$pos; } elsif ( $pos eq '_' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( $pos eq ',' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( isDIGIT($pos) ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( isDIGIT($pos) ) { $pos++; } } else { my $digits = 0; while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { if ( $pos ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = $#av; # This for loop appears to trigger a compiler bug on OS X, as it # loops infinitely. Yes, len is negative. No, it makes no sense. # Compiler in question is: # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) # for ( len = 2 - len; len > 0; len-- ) # av_push(MUTABLE_AV(sv), newSViv(0)); # $len = 2 - $len; while ($len-- > 0) { push @av, 0; } } # need to save off the current version string for later if ( $vinf ) { $$rv->{original} = "v.Inf"; $$rv->{vinf} = 1; } elsif ( $s > $start ) { $$rv->{original} = $start->currstr($s); if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { # need to insert a v to be consistent $$rv->{original} = 'v' . $$rv->{original}; } } else { $$rv->{original} = '0'; push(@av, 0); } # And finally, store the AV in the hash $$rv->{version} = \@av; # fix RT#19517 - special case 'undef' as string if ($s eq 'undef') { $s += 5; } return $s; } sub new { my ($class, $value) = @_; my $self = bless ({}, ref ($class) || $class); my $qv = FALSE; 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 = $_[2]; $qv = TRUE; } $value = _un_vstring($value); # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } my $s = scan_version($value, \$self, $qv); if ($s) { # must be something left over warn("Version string '%s' contains invalid data; " ."ignoring: '%s'", $value, $s); } 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 _is_non_alphanumeric { my $s = shift; $s = new charstar $s; while ($s) { return 0 if isSPACE($s); # early out return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); $s++; } return 0; } sub _un_vstring { my $value = shift; # may be a v-string if ( length($value) >= 3 && $value !~ /[._]/ && _is_non_alphanumeric($value)) { my $tvalue; if ( $] ge 5.008_001 ) { $tvalue = _find_magic_vstring($value); $value = $tvalue if length $tvalue; } elsif ( $] ge 5.006_000 ) { $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) { # must be a v-string $value = $tvalue; } } } return $value; } sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } 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 VERSION_VPP s/^ //mg for values %fatpacked; unshift @INC, sub { if (my $fat = $fatpacked{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; 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 --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of querying the CPAN Meta DB. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). B It might be useful if you name these mirror options with your shell aliases, like: alias minicpanm='cpanm --mirror ~/minicpan --mirror-only' alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only' =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 if your perl version is smaller than 5.12, and you can disable that with C<--no-uninst-shadows>. B: Since version 1.3000 this flag is turned off by default for perl newer than 5.12, since with 5.12 @INC contains site_perl directory I the perl core library path, and uninstalling shadows is not necessary anymore and does more harm by deleting files from the core library path. =item --auto-cleanup Specifies the number of days in whcih cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. You can set the value to C<0> to make cpan never cleanup those directories. =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. =item --wget Uses GNU Wget (if available) to download stuff. Defaults to true, and you can say C<--no-wget> to disable using Wget (versions of Wget older than 1.9 don't support the C<--retry-connrefused> option used by cpanm). =item --curl Uses cURL (if available) to download stuff. Defaults to true, and you can say C<--no-curl> to disable using cURL. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true (which is the default) cpanm tries L, Wget, cURL and L (in that order) and uses the first one available. =back =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2010 Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut