--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use App::cpm::CLI;
+exit App::cpm::CLI->new->run(@ARGV);
+
+__END__
+
+=head1 NAME
+
+cpm - a fast CPAN module installer
+
+=head1 SYNOPSIS
+
+ # install modules into local/
+ > cpm install Module1 Module2 ...
+
+ # install modules with verbose messages
+ > cpm install -v Module
+
+ # from cpanfile (with cpanfile.snapshot if any)
+ > cpm install
+
+ # install module into current @INC instead of local/
+ > cpm install -g Module
+
+ # read modules from STDIN by specifying "-" as an argument
+ > echo Module1 Module2 | cpm install -
+
+ # prefer TRIAL release
+ > cpm install --dev Moose
+
+ # install modules as if version of your perl is 5.8.5
+ # so that modules which are not core in 5.8.5 will be installed
+ > cpm install --target-perl 5.8.5
+
+ # resolve distribution names from DARKPAN/modules/02packages.details.txt.gz
+ # and fetch distibutions from DARKPAN/authors/id/...
+ > cpm install --resolver 02packages,http://example.com/darkpan Your::Module
+ > cpm install --resolver 02packages,file:///path/to/darkpan Your::Module
+
+ # use darkpan first, and if it fails, use metadb and normal CPAN
+ > cpm install --resolver 02packages,http://example.com/darkpan --resolver metadb Your::Module
+
+ # specify types/phases in cpanfile by "--with-*" and "--without-*" options
+ > cpm install --with-recommends --without-test
+
+=head1 OPTIONS
+
+ -w, --workers=N
+ number of workers, default: 5
+ -L, --local-lib-contained=DIR
+ directory to install modules into, default: local/
+ -g, --global
+ install modules into current @INC instead of local/
+ -v, --verbose
+ verbose mode; you can see what is going on
+ --prebuilt, --no-prebuilt
+ save builds for CPAN distributions; and later, install the prebuilts if available
+ default: on; you can also set $ENV{PERL_CPM_PREBUILT} false to disable this option
+ --target-perl=VERSION (EXPERIMENTAL)
+ install modules as if verison is your perl is VERSION
+ --mirror=URL
+ base url for the CPAN mirror to use, cannot be used multiple times. Use --resolver instead.
+ default: https://cpan.metacpan.org
+ --pp, --pureperl-only
+ prefer pureperl only build
+ --static-install, --no-static-install
+ enable/disable the static install, default: enable
+ -r, --resolver=class,args (EXPERIMENTAL, will be removed or renamed)
+ specify resolvers, you can use --resolver multiple times
+ available classes: metadb/metacpan/02packages/snapshot
+ --reinstall
+ reinstall the distribution even if you already have the latest version installed
+ --dev (EXPERIMENTAL)
+ resolve TRIAL distributions too
+ --color, --no-color
+ turn on/off color output, default: on
+ --test, --no-test
+ run test cases, default: no
+ --man-pages
+ generate man pages
+ --retry, --no-retry
+ retry configure/build/test/install if fails, default: retry
+ --show-build-log-on-failure
+ show build.log on failure, default: off
+ --configure-timeout=sec, --build-timeout=sec, --test-timeout=sec
+ specify configure/build/test timeout second, default: 60sec, 3600sec, 1800sec
+ --show-progress, --no-show-progress
+ show progress, default: on
+ --cpanfile=path
+ specify cpanfile path, default: ./cpanfile
+ --snapshot=path
+ specify cpanfile.snapshot path, default: ./cpanfile.snapshot
+ -V, --version
+ show version
+ -h, --help
+ show this help
+ --feature=identifier
+ specify the feature to enable in cpanfile; you can use --feature multiple times
+ --with-requires, --without-requires (default: with)
+ --with-recommends, --without-recommends (default: without)
+ --with-suggests, --without-suggests (default: without)
+ --with-configure, --without-configure (default: without)
+ --with-build, --without-build (default: with)
+ --with-test, --without-test (default: with)
+ --with-runtime, --without-runtime (default: with)
+ --with-develop, --without-develop (default: without)
+ specify types/phases of dependencies in cpanfile to be installed
+ --with-all
+ shortcut for --with-requires, --with-recommends, --with-suggests,
+ --with-configure, --with-build, --with-test, --with-runtime and --with-develop
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2015 Shoichi Kaji E<lt>skaji@cpan.orgE<gt>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package App::cpm;
+use strict;
+use warnings;
+
+our $VERSION = '0.993';
+our ($GIT_DESCRIBE, $GIT_URL);
+
+1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+App::cpm - a fast CPAN module installer
+
+=head1 SYNOPSIS
+
+ > cpm install Module
+
+=head1 DESCRIPTION
+
+=for html
+<a href="https://skaji.github.io/images/cpm-Plack.svg"><img src="https://skaji.github.io/images/cpm-Plack.svg" alt="demo" style="max-width:100%;"></a>
+
+cpm is a fast CPAN module installer, which uses L<Menlo> in parallel.
+
+Moreover cpm keeps the each builds of distributions in your home directory,
+and reuses them later.
+That is, if prebuilts are available, cpm never builds distributions again, just copies the prebuilts into an appropriate directory.
+This is (of course!) inspired by L<Carmel>.
+
+For tutorial, check out L<App::cpm::Tutorial>.
+
+=head1 MOTIVATION
+
+Why do we need a new CPAN client?
+
+I used L<cpanm> a lot, and it's totally awesome.
+
+But if your Perl project has hundreds of CPAN module dependencies,
+then it takes quite a lot of time to install them.
+
+So my motivation is simple: I want to install CPAN modules as fast as possible.
+
+=head2 HOW FAST?
+
+Just an example:
+
+ > time cpanm -nq -Lextlib Plack
+ real 0m47.705s
+
+ > time cpm install Plack
+ real 0m16.629s
+
+This shows cpm is 3x faster than cpanm.
+
+=head1 CAVEATS
+
+L<eserte|https://github.com/skaji/cpm/issues/71> reported that
+the parallel feature of cpm yielded a new type of failure for CPAN module installation.
+That is,
+if B<ModuleA> implicitly requires B<ModuleB> in configure/build phase,
+and B<ModuleB> is about to be installed,
+then it may happen that the installation of B<ModuleA> fails.
+
+I can say that it hardly happens especially if you use a new Perl.
+Moreover, for a workaround, cpm automatically retries the installation if it fails.
+
+I hope that
+if almost all CPAN modules are distributed with L<static install enabled|http://blogs.perl.org/users/shoichi_kaji1/2017/03/make-your-cpan-module-static-installable.html>,
+then cpm will parallelize the installation for these CPAN modules safely and we can eliminate this new type of failure completely.
+
+=head1 ROADMAP
+
+If you all find cpm useful,
+then cpm should be merged into cpanm 2.0. How exciting!
+
+To merge cpm into cpanm, there are several TODOs:
+
+=over 4
+
+=item * (DONE) Win32? - support platforms that do not have fork(2) system call
+
+=item * (DONE) Logging? - the parallel feature makes log really messy
+
+=back
+
+Your feedback is highly appreciated.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2015 Shoichi Kaji E<lt>skaji@cpan.orgE<gt>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Perl Advent Calendar 2015|http://www.perladvent.org/2015/2015-12-02.html>
+
+L<App::cpanminus>
+
+L<Menlo>
+
+L<Carton>
+
+L<Carmel>
+
+=cut
--- /dev/null
+package App::cpm::CLI;
+use 5.008001;
+use strict;
+use warnings;
+
+use App::cpm::DistNotation;
+use App::cpm::Distribution;
+use App::cpm::Logger::File;
+use App::cpm::Logger;
+use App::cpm::Master;
+use App::cpm::Requirement;
+use App::cpm::Resolver::Cascade;
+use App::cpm::Resolver::MetaCPAN;
+use App::cpm::Resolver::MetaDB;
+use App::cpm::Util qw(WIN32 determine_home maybe_abs);
+use App::cpm::Worker;
+use App::cpm::version;
+use App::cpm;
+use Config;
+use Cwd ();
+use File::Copy ();
+use File::Path ();
+use File::Spec;
+use Getopt::Long qw(:config no_auto_abbrev no_ignore_case bundling);
+use List::Util ();
+use Parallel::Pipes;
+use Pod::Text ();
+
+sub new {
+ my ($class, %option) = @_;
+ my $prebuilt = exists $ENV{PERL_CPM_PREBUILT} && !$ENV{PERL_CPM_PREBUILT} ? 0 : 1;
+ bless {
+ home => determine_home,
+ cwd => Cwd::cwd(),
+ workers => WIN32 ? 1 : 5,
+ snapshot => "cpanfile.snapshot",
+ cpanfile => "cpanfile",
+ local_lib => "local",
+ cpanmetadb => "https://cpanmetadb.plackperl.org/v1.0/",
+ _default_mirror => 'https://cpan.metacpan.org/',
+ retry => 1,
+ configure_timeout => 60,
+ build_timeout => 3600,
+ test_timeout => 1800,
+ with_requires => 1,
+ with_recommends => 0,
+ with_suggests => 0,
+ with_configure => 0,
+ with_build => 1,
+ with_test => 1,
+ with_runtime => 1,
+ with_develop => 0,
+ feature => [],
+ notest => 1,
+ prebuilt => $] >= 5.012 && $prebuilt,
+ pureperl_only => 0,
+ static_install => 1,
+ %option
+ }, $class;
+}
+
+sub parse_options {
+ my $self = shift;
+ local @ARGV = @_;
+ my ($mirror, @resolver, @feature);
+ my $with_option = sub {
+ my $n = shift;
+ ("with-$n", \$self->{"with_$n"}, "without-$n", sub { $self->{"with_$n"} = 0 });
+ };
+ my @type = qw(requires recommends suggests);
+ my @phase = qw(configure build test runtime develop);
+
+ GetOptions
+ "L|local-lib-contained=s" => \($self->{local_lib}),
+ "color!" => \($self->{color}),
+ "g|global" => \($self->{global}),
+ "mirror=s" => \$mirror,
+ "v|verbose" => \($self->{verbose}),
+ "w|workers=i" => \($self->{workers}),
+ "target-perl=s" => \my $target_perl,
+ "test!" => sub { $self->{notest} = $_[1] ? 0 : 1 },
+ "cpanfile=s" => \($self->{cpanfile}),
+ "snapshot=s" => \($self->{snapshot}),
+ "sudo" => \($self->{sudo}),
+ "r|resolver=s@" => \@resolver,
+ "mirror-only" => \($self->{mirror_only}),
+ "dev" => \($self->{dev}),
+ "man-pages" => \($self->{man_pages}),
+ "home=s" => \($self->{home}),
+ "retry!" => \($self->{retry}),
+ "exclude-vendor!" => \($self->{exclude_vendor}),
+ "configure-timeout=i" => \($self->{configure_timeout}),
+ "build-timeout=i" => \($self->{build_timeout}),
+ "test-timeout=i" => \($self->{test_timeout}),
+ "show-progress!" => \($self->{show_progress}),
+ "prebuilt!" => \($self->{prebuilt}),
+ "reinstall" => \($self->{reinstall}),
+ "pp|pureperl|pureperl-only" => \($self->{pureperl_only}),
+ "static-install!" => \($self->{static_install}),
+ "with-all" => sub { map { $self->{"with_$_"} = 1 } @type, @phase },
+ (map $with_option->($_), @type),
+ (map $with_option->($_), @phase),
+ "feature=s@" => \@feature,
+ "show-build-log-on-failure" => \($self->{show_build_log_on_failure}),
+ or return 0;
+
+ $self->{local_lib} = maybe_abs($self->{local_lib}, $self->{cwd}) unless $self->{global};
+ $self->{home} = maybe_abs($self->{home}, $self->{cwd});
+ $self->{resolver} = \@resolver;
+ $self->{feature} = \@feature if @feature;
+ $self->{mirror} = $self->normalize_mirror($mirror) if $mirror;
+ $self->{color} = 1 if !defined $self->{color} && -t STDOUT;
+ $self->{show_progress} = 1 if !WIN32 && !defined $self->{show_progress} && -t STDOUT;
+ if ($target_perl) {
+ die "--target-perl option conflicts with --global option\n" if $self->{global};
+ die "--target-perl option can be used only if perl version >= 5.16.0\n" if $] < 5.016;
+ # 5.8 is interpreted as 5.800, fix it
+ $target_perl = "v$target_perl" if $target_perl =~ /^5\.[1-9]\d*$/;
+ $target_perl = sprintf '%0.6f', App::cpm::version->parse($target_perl)->numify;
+ $target_perl = '5.008' if $target_perl eq '5.008000';
+ $self->{target_perl} = $target_perl;
+ }
+ if (WIN32 and $self->{workers} != 1) {
+ die "The number of workers must be 1 under WIN32 environment.\n";
+ }
+ if ($self->{sudo}) {
+ !system "sudo", $^X, "-e1" or exit 1;
+ }
+ if ($self->{pureperl_only} or $self->{sudo} or !$self->{notest} or $self->{man_pages} or $] < 5.012) {
+ $self->{prebuilt} = 0;
+ }
+
+ $App::cpm::Logger::COLOR = 1 if $self->{color};
+ $App::cpm::Logger::VERBOSE = 1 if $self->{verbose};
+ $App::cpm::Logger::SHOW_PROGRESS = 1 if $self->{show_progress};
+
+ if (@ARGV && $ARGV[0] eq "-") {
+ my $argv = $self->read_argv_from_stdin;
+ return -1 if @$argv == 0;
+ $self->{argv} = $argv;
+ $self->{cpanfile} = undef;
+ } else {
+ $self->{argv} = \@ARGV;
+ }
+ return 1;
+}
+
+sub read_argv_from_stdin {
+ my $self = shift;
+ my @argv;
+ while (my $line = <STDIN>) {
+ next if $line !~ /\S/;
+ next if $line =~ /^\s*#/;
+ $line =~ s/^\s*//;
+ $line =~ s/\s*$//;
+ push @argv, split /\s+/, $line;
+ }
+ return \@argv;
+}
+
+sub _core_inc {
+ my $self = shift;
+ [
+ (!$self->{exclude_vendor} ? grep {$_} @Config{qw(vendorarch vendorlibexp)} : ()),
+ @Config{qw(archlibexp privlibexp)},
+ ];
+}
+
+sub _search_inc {
+ my $self = shift;
+ return \@INC if $self->{global};
+
+ my $base = $self->{local_lib};
+ require local::lib;
+ my @local_lib = (
+ local::lib->resolve_path(local::lib->install_base_arch_path($base)),
+ local::lib->resolve_path(local::lib->install_base_perl_path($base)),
+ );
+ if ($self->{target_perl}) {
+ return [@local_lib];
+ } else {
+ return [@local_lib, @{$self->_core_inc}];
+ }
+}
+
+sub normalize_mirror {
+ my ($self, $mirror) = @_;
+ $mirror =~ s{/*$}{/};
+ return $mirror if $mirror =~ m{^https?://};
+ $mirror =~ s{^file://}{};
+ die "$mirror: No such directory.\n" unless -d $mirror;
+ "file://" . maybe_abs($mirror, $self->{cwd});
+}
+
+sub run {
+ my ($self, @argv) = @_;
+ my $cmd = shift @argv or die "Need subcommand, try `cpm --help`\n";
+ $cmd = "help" if $cmd =~ /^(-h|--help)$/;
+ $cmd = "version" if $cmd =~ /^(-V|--version)$/;
+ if (my $sub = $self->can("cmd_$cmd")) {
+ return $self->$sub(@argv) if $cmd eq "exec";
+ my $ok = $self->parse_options(@argv);
+ return 1 if !$ok;
+ return 0 if $ok == -1;
+ return $self->$sub;
+ } else {
+ my $message = $cmd =~ /^-/ ? "Missing subcommand" : "Unknown subcommand '$cmd'";
+ die "$message, try `cpm --help`\n";
+ }
+}
+
+sub cmd_help {
+ open my $fh, ">", \my $out;
+ Pod::Text->new->parse_from_file($0, $fh);
+ $out =~ s/^[ ]{6}/ /mg;
+ print $out;
+ return 0;
+}
+
+sub cmd_version {
+ print "cpm $App::cpm::VERSION ($0)\n";
+ if ($App::cpm::GIT_DESCRIBE) {
+ print "This is a self-contained version, $App::cpm::GIT_DESCRIBE ($App::cpm::GIT_URL)\n";
+ }
+ return 0;
+}
+
+sub cmd_install {
+ my $self = shift;
+ die "Need arguments or cpanfile.\n"
+ if !@{$self->{argv}} && (!$self->{cpanfile} || !-f $self->{cpanfile});
+
+ local %ENV = %ENV;
+
+ File::Path::mkpath($self->{home}) unless -d $self->{home};
+ my $logger = App::cpm::Logger::File->new("$self->{home}/build.log.@{[time]}");
+ $logger->symlink_to("$self->{home}/build.log");
+ $logger->log("Running cpm $App::cpm::VERSION ($0) on perl $Config{version} built for $Config{archname} ($^X)");
+ $logger->log("This is a self-contained version, $App::cpm::GIT_DESCRIBE ($App::cpm::GIT_URL)") if $App::cpm::GIT_DESCRIBE;
+ $logger->log("Command line arguments are: @ARGV");
+
+ my $master = App::cpm::Master->new(
+ logger => $logger,
+ core_inc => $self->_core_inc,
+ search_inc => $self->_search_inc,
+ global => $self->{global},
+ show_progress => $self->{show_progress},
+ (exists $self->{target_perl} ? (target_perl => $self->{target_perl}) : ()),
+ );
+
+ my ($packages, $dists, $resolver) = $self->initial_job($master);
+ return 0 unless $packages;
+
+ my $worker = App::cpm::Worker->new(
+ verbose => $self->{verbose},
+ home => $self->{home},
+ logger => $logger,
+ notest => $self->{notest},
+ sudo => $self->{sudo},
+ resolver => $self->generate_resolver($resolver),
+ man_pages => $self->{man_pages},
+ retry => $self->{retry},
+ prebuilt => $self->{prebuilt},
+ pureperl_only => $self->{pureperl_only},
+ static_install => $self->{static_install},
+ configure_timeout => $self->{configure_timeout},
+ build_timeout => $self->{build_timeout},
+ test_timeout => $self->{test_timeout},
+ ($self->{global} ? () : (local_lib => $self->{local_lib})),
+ );
+
+ {
+ last if $] >= 5.016;
+ my $requirement = App::cpm::Requirement->new('ExtUtils::MakeMaker' => '6.58', 'ExtUtils::ParseXS' => '3.16');
+ for my $name ('ExtUtils::MakeMaker', 'ExtUtils::ParseXS') {
+ if (my ($i) = grep { $packages->[$_]{package} eq $name } 0..$#{$packages}) {
+ $requirement->add($name, $packages->[$i]{version_range})
+ or die sprintf "We have to install newer $name first: $@\n";
+ splice @$packages, $i, 1;
+ }
+ }
+ my ($is_satisfied, @need_resolve) = $master->is_satisfied($requirement->as_array);
+ last if $is_satisfied;
+ $master->add_job(type => "resolve", %$_) for @need_resolve;
+
+ $self->install($master, $worker, 1);
+ if (my $fail = $master->fail) {
+ local $App::cpm::Logger::VERBOSE = 0;
+ for my $type (qw(install resolve)) {
+ App::cpm::Logger->log(result => "FAIL", type => $type, message => $_) for @{$fail->{$type}};
+ }
+ print STDERR "\r" if $self->{show_progress};
+ warn sprintf "%d distribution%s installed.\n",
+ $master->installed_distributions, $master->installed_distributions > 1 ? "s" : "";
+ if ($self->{show_build_log_on_failure}) {
+ File::Copy::copy($logger->file, \*STDERR);
+ } else {
+ warn "See $self->{home}/build.log for details.\n";
+ }
+ return 1;
+ }
+ }
+
+ $master->add_job(type => "resolve", %$_) for @$packages;
+ $master->add_distribution($_) for @$dists;
+ $self->install($master, $worker, $self->{workers});
+ my $fail = $master->fail;
+ if ($fail) {
+ local $App::cpm::Logger::VERBOSE = 0;
+ for my $type (qw(install resolve)) {
+ App::cpm::Logger->log(result => "FAIL", type => $type, message => $_) for @{$fail->{$type}};
+ }
+ }
+ print STDERR "\r" if $self->{show_progress};
+ warn sprintf "%d distribution%s installed.\n",
+ $master->installed_distributions, $master->installed_distributions > 1 ? "s" : "";
+ $self->cleanup;
+
+ if ($fail) {
+ if ($self->{show_build_log_on_failure}) {
+ File::Copy::copy($logger->file, \*STDERR);
+ } else {
+ warn "See $self->{home}/build.log for details.\n";
+ }
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub install {
+ my ($self, $master, $worker, $num) = @_;
+
+ my $pipes = Parallel::Pipes->new($num, sub {
+ my $job = shift;
+ return $worker->work($job);
+ });
+ my $get_job; $get_job = sub {
+ my $master = shift;
+ if (my @job = $master->get_job) {
+ return @job;
+ }
+ if (my @written = $pipes->is_written) {
+ my @ready = $pipes->is_ready(@written);
+ $master->register_result($_->read) for @ready;
+ return $master->$get_job;
+ } else {
+ return;
+ }
+ };
+ while (my @job = $master->$get_job) {
+ my @ready = $pipes->is_ready;
+ $master->register_result($_->read) for grep $_->is_written, @ready;
+ for my $i (0 .. List::Util::min($#job, $#ready)) {
+ $job[$i]->in_charge(1);
+ $ready[$i]->write($job[$i]);
+ }
+ }
+ $pipes->close;
+}
+
+sub cleanup {
+ my $self = shift;
+ my $week = time - 7*24*60*60;
+ my @entry = glob "$self->{home}/build.log.*";
+ if (opendir my $dh, "$self->{home}/work") {
+ push @entry,
+ map File::Spec->catdir("$self->{home}/work", $_),
+ grep !/^\.{1,2}$/,
+ readdir $dh;
+ }
+ for my $entry (@entry) {
+ my $mtime = (stat $entry)[9];
+ if ($mtime < $week) {
+ if (-d $entry) {
+ File::Path::rmtree($entry);
+ } else {
+ unlink $entry;
+ }
+ }
+ }
+}
+
+sub initial_job {
+ my ($self, $master) = @_;
+
+ my (@package, @dist, $resolver);
+
+ if (!@{$self->{argv}}) {
+ my ($requirement, $reinstall);
+ ($requirement, $reinstall, $resolver) = $self->load_cpanfile($self->{cpanfile});
+ my ($is_satisfied, @need_resolve) = $master->is_satisfied($requirement);
+ if (!@$reinstall and $is_satisfied) {
+ warn "All requirements are satisfied.\n";
+ return;
+ } elsif (!defined $is_satisfied) {
+ my ($req) = grep { $_->{package} eq "perl" } @$requirement;
+ die sprintf "%s requires perl %s, but you have only %s\n",
+ $self->{cpanfile}, $req->{version_range}, $self->{target_perl} || $];
+ }
+ push @package, @need_resolve, @$reinstall;
+ return (\@package, \@dist, $resolver);
+ }
+
+ $self->{mirror} ||= $self->{_default_mirror};
+ for (@{$self->{argv}}) {
+ my $arg = $_; # copy
+ my ($package, $dist);
+ if (-d $arg || -f $arg || $arg =~ s{^file://}{}) {
+ $arg = maybe_abs($arg, $self->{cwd});
+ $dist = App::cpm::Distribution->new(source => "local", uri => "file://$arg", provides => []);
+ } elsif ($arg =~ /(?:^git:|\.git(?:@.+)?$)/) {
+ my %ref = $arg =~ s/(?<=\.git)@(.+)$// ? (ref => $1) : ();
+ $dist = App::cpm::Distribution->new(source => "git", uri => $arg, provides => [], %ref);
+ } elsif ($arg =~ m{^(https?|file)://}) {
+ my ($source, $distfile) = ($1 eq "file" ? "local" : "http", undef);
+ if (my $d = App::cpm::DistNotation->new_from_uri($arg)) {
+ ($source, $distfile) = ("cpan", $d->distfile);
+ }
+ $dist = App::cpm::Distribution->new(
+ source => $source,
+ uri => $arg,
+ $distfile ? (distfile => $distfile) : (),
+ provides => [],
+ );
+ } elsif (my $d = App::cpm::DistNotation->new_from_dist($arg)) {
+ $dist = App::cpm::Distribution->new(
+ source => "cpan",
+ uri => $d->cpan_uri($self->{mirror}),
+ distfile => $d->distfile,
+ provides => [],
+ );
+ } else {
+ my ($name, $version_range, $dev);
+ # copy from Menlo
+ # Plack@1.2 -> Plack~"==1.2"
+ $arg =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
+ # support Plack~1.20, DBI~"> 1.0, <= 2.0"
+ if ($arg =~ /\~[v\d\._,\!<>= ]+$/) {
+ ($name, $version_range) = split '~', $arg, 2;
+ } else {
+ $arg =~ s/[~@]dev$// and $dev++;
+ $name = $arg;
+ }
+ $package = +{
+ package => $name,
+ version_range => $version_range || 0,
+ dev => $dev,
+ reinstall => $self->{reinstall},
+ };
+ }
+ push @package, $package if $package;
+ push @dist, $dist if $dist;
+ }
+
+ return (\@package, \@dist, $resolver);
+}
+
+sub load_cpanfile {
+ my ($self, $file) = @_;
+ require Module::CPANfile;
+ my $cpanfile = Module::CPANfile->load($file);
+ if (!$self->{mirror}) {
+ my $mirrors = $cpanfile->mirrors;
+ if (@$mirrors) {
+ $self->{mirror} = $self->normalize_mirror($mirrors->[0]);
+ } else {
+ $self->{mirror} = $self->{_default_mirror};
+ }
+ }
+ my $prereqs = $cpanfile->prereqs_with(@{ $self->{"feature"} });
+ my @phase = grep $self->{"with_$_"}, qw(configure build test runtime develop);
+ my @type = grep $self->{"with_$_"}, qw(requires recommends suggests);
+ my $reqs = $prereqs->merged_requirements(\@phase, \@type)->as_string_hash;
+
+ my (@package, @reinstall);
+ for my $package (sort keys %$reqs) {
+ my $option = $cpanfile->options_for_module($package) || {};
+ my $req = {
+ package => $package,
+ version_range => $reqs->{$package},
+ dev => $option->{dev},
+ reinstall => $option->{git} ? 1 : 0,
+ };
+ if ($option->{git}) {
+ push @reinstall, $req;
+ } else {
+ push @package, $req;
+ }
+ }
+
+ require App::cpm::Resolver::CPANfile;
+ my $resolver = App::cpm::Resolver::CPANfile->new(
+ cpanfile => $cpanfile,
+ mirror => $self->{mirror},
+ );
+
+ (\@package, \@reinstall, $resolver);
+}
+
+sub generate_resolver {
+ my ($self, $initial) = @_;
+
+ my $cascade = App::cpm::Resolver::Cascade->new;
+ $cascade->add($initial) if $initial;
+ if (@{$self->{resolver}}) {
+ for (@{$self->{resolver}}) {
+ my ($klass, @arg) = split /,/, $_;
+ my $resolver;
+ if ($klass =~ /^metadb$/i) {
+ my ($uri, $mirror);
+ if (@arg > 1) {
+ ($uri, $mirror) = @arg;
+ } elsif (@arg == 1) {
+ $mirror = $arg[0];
+ } else {
+ $mirror = $self->{mirror};
+ }
+ $resolver = App::cpm::Resolver::MetaDB->new(
+ $uri ? (uri => $uri) : (),
+ mirror => $self->normalize_mirror($mirror),
+ );
+ } elsif ($klass =~ /^metacpan$/i) {
+ $resolver = App::cpm::Resolver::MetaCPAN->new(dev => $self->{dev});
+ } elsif ($klass =~ /^02packages?$/i) {
+ require App::cpm::Resolver::02Packages;
+ my ($path, $mirror);
+ if (@arg > 1) {
+ ($path, $mirror) = @arg;
+ } elsif (@arg == 1) {
+ $mirror = $arg[0];
+ } else {
+ $mirror = $self->{mirror};
+ }
+ $resolver = App::cpm::Resolver::02Packages->new(
+ $path ? (path => $path) : (),
+ cache => "$self->{home}/sources",
+ mirror => $self->normalize_mirror($mirror),
+ );
+ } elsif ($klass =~ /^snapshot$/i) {
+ require App::cpm::Resolver::Snapshot;
+ $resolver = App::cpm::Resolver::Snapshot->new(
+ path => $self->{snapshot},
+ mirror => @arg ? $self->normalize_mirror($arg[0]) : $self->{mirror},
+ );
+ } else {
+ my $full_klass = $klass =~ s/^\+// ? $klass : "App::cpm::Resolver::$klass";
+ (my $file = $full_klass) =~ s{::}{/}g;
+ require "$file.pm"; # may die
+ $resolver = $full_klass->new(@arg);
+ }
+ $cascade->add($resolver);
+ }
+ return $cascade;
+ }
+
+ if ($self->{mirror_only}) {
+ require App::cpm::Resolver::02Packages;
+ my $resolver = App::cpm::Resolver::02Packages->new(
+ mirror => $self->{mirror},
+ cache => "$self->{home}/sources",
+ );
+ $cascade->add($resolver);
+ return $cascade;
+ }
+
+ if (!@{$self->{argv}} and -f $self->{snapshot}) {
+ if (!eval { require App::cpm::Resolver::Snapshot }) {
+ die "To load $self->{snapshot}, you need to install Carton::Snapshot.\n";
+ }
+ warn "Loading distributions from $self->{snapshot}...\n";
+ my $resolver = App::cpm::Resolver::Snapshot->new(
+ path => $self->{snapshot},
+ mirror => $self->{mirror},
+ );
+ $cascade->add($resolver);
+ }
+
+ my $resolver = App::cpm::Resolver::MetaCPAN->new(
+ $self->{dev} ? (dev => 1) : (only_dev => 1)
+ );
+ $cascade->add($resolver);
+ $resolver = App::cpm::Resolver::MetaDB->new(
+ uri => $self->{cpanmetadb},
+ mirror => $self->{mirror},
+ );
+ $cascade->add($resolver);
+ if (!$self->{dev}) {
+ $resolver = App::cpm::Resolver::MetaCPAN->new;
+ $cascade->add($resolver);
+ }
+
+ $cascade;
+}
+
+1;
--- /dev/null
+package App::cpm::CircularDependency;
+use strict;
+use warnings;
+
+{
+ package
+ App::cpm::CircularDependency::OrderedSet;
+ sub new {
+ my $class = shift;
+ bless { index => 0, hash => +{} }, $class;
+ }
+ sub add {
+ my ($self, $name) = @_;
+ $self->{hash}{$name} = $self->{index}++;
+ }
+ sub exists {
+ my ($self, $name) = @_;
+ exists $self->{hash}{$name};
+ }
+ sub values {
+ my $self = shift;
+ sort { $self->{hash}{$a} <=> $self->{hash}{$b} } keys %{$self->{hash}};
+ }
+ sub clone {
+ my $self = shift;
+ my $new = (ref $self)->new;
+ $new->add($_) for $self->values;
+ $new;
+ }
+}
+
+sub _uniq {
+ my %u;
+ grep !$u{$_}++, @_;
+}
+
+sub new {
+ my $class = shift;
+ bless { _tmp => {} }, $class;
+}
+
+sub add {
+ my ($self, $distfile, $provides, $requirements) = @_;
+ $self->{_tmp}{$distfile} = +{
+ provides => [ map $_->{package}, @$provides ],
+ requirements => [ map $_->{package}, @$requirements ],
+ };
+}
+
+sub finalize {
+ my $self = shift;
+ for my $distfile (sort keys %{$self->{_tmp}}) {
+ $self->{$distfile} = [
+ _uniq map $self->_find($_), @{$self->{_tmp}{$distfile}{requirements}}
+ ];
+ }
+ delete $self->{_tmp};
+ return;
+}
+
+sub _find {
+ my ($self, $package) = @_;
+ for my $distfile (sort keys %{$self->{_tmp}}) {
+ if (grep { $_ eq $package } @{$self->{_tmp}{$distfile}{provides}}) {
+ return $distfile;
+ }
+ }
+ return;
+}
+
+sub detect {
+ my $self = shift;
+
+ my %result;
+ for my $distfile (sort keys %$self) {
+ my $seen = App::cpm::CircularDependency::OrderedSet->new;
+ $seen->add($distfile);
+ if (my $detected = $self->_detect($distfile, $seen)) {
+ $result{$distfile} = $detected;
+ }
+ }
+ return \%result;
+}
+
+sub _detect {
+ my ($self, $distfile, $seen) = @_;
+
+ for my $req (@{$self->{$distfile}}) {
+ if ($seen->exists($req)) {
+ return [$seen->values, $req];
+ }
+
+ my $clone = $seen->clone;
+ $clone->add($req);
+ if (my $detected = $self->_detect($req, $clone)) {
+ return $detected;
+ }
+ }
+ return;
+}
+
+1;
--- /dev/null
+package App::cpm::DistNotation;
+use strict;
+use warnings;
+
+my $A1 = q{[A-Z]};
+my $A2 = q{[A-Z]{2}};
+my $AUTHOR = qr{[A-Z]{2}[\-A-Z0-9]*};
+
+our $CPAN_URI = qr{^(.*)/authors/id/($A1/$A2/$AUTHOR/.*)$}o;
+our $DISTFILE = qr{^(?:$A1/$A2/)?($AUTHOR)/(.*)$}o;
+
+sub new {
+ my $class = shift;
+ bless {
+ mirror => '',
+ distfile => '',
+ }, $class;
+}
+
+sub new_from_dist {
+ my $self = shift->new;
+ my $dist = shift;
+ if ($dist =~ $DISTFILE) {
+ my $author = $1;
+ my $rest = $2;
+ $self->{distfile} = sprintf "%s/%s/%s/%s",
+ substr($author, 0, 1), substr($author, 0, 2), $author, $rest;
+ return $self;
+ }
+ return;
+}
+
+sub new_from_uri {
+ my $self = shift->new;
+ my $uri = shift;
+ if ($uri =~ $CPAN_URI) {
+ $self->{mirror} = $1;
+ $self->{distfile} = $2;
+ return $self;
+ }
+ return;
+}
+
+sub cpan_uri {
+ my $self = shift;
+ my $mirror = shift || $self->{mirror};
+ $mirror =~ s{/+$}{};
+ sprintf "%s/authors/id/%s", $mirror, $self->{distfile};
+}
+
+sub distfile {
+ shift->{distfile};
+}
+
+1;
--- /dev/null
+package App::cpm::Distribution;
+use strict;
+use warnings;
+
+use App::cpm::Logger;
+use App::cpm::Requirement;
+use App::cpm::version;
+use CPAN::DistnameInfo;
+
+use constant STATE_REGISTERED => 0b000001;
+use constant STATE_DEPS_REGISTERED => 0b000010;
+use constant STATE_RESOLVED => 0b000100; # default
+use constant STATE_FETCHED => 0b001000;
+use constant STATE_CONFIGURED => 0b010000;
+use constant STATE_INSTALLED => 0b100000;
+
+sub new {
+ my ($class, %option) = @_;
+ my $uri = delete $option{uri};
+ my $distfile = delete $option{distfile};
+ my $source = delete $option{source} || "cpan";
+ my $provides = delete $option{provides} || [];
+ bless {
+ %option,
+ provides => $provides,
+ uri => $uri,
+ distfile => $distfile,
+ source => $source,
+ _state => STATE_RESOLVED,
+ requirements => {},
+ }, $class;
+}
+
+sub requirements {
+ my ($self, $phase, $req) = @_;
+ if (ref $phase) {
+ my $req = App::cpm::Requirement->new;
+ for my $p (@$phase) {
+ if (my $r = $self->{requirements}{$p}) {
+ $req->merge($r);
+ }
+ }
+ return $req;
+ }
+ $self->{requirements}{$phase} = $req if $req;
+ $self->{requirements}{$phase} || App::cpm::Requirement->new;
+}
+
+for my $attr (qw(
+ source
+ directory
+ distdata
+ meta
+ uri
+ provides
+ ref
+ static_builder
+ prebuilt
+)) {
+ no strict 'refs';
+ *$attr = sub {
+ my $self = shift;
+ $self->{$attr} = shift if @_;
+ $self->{$attr};
+ };
+}
+sub distfile {
+ my $self = shift;
+ $self->{distfile} = shift if @_;
+ $self->{distfile} || $self->{uri};
+}
+
+sub distvname {
+ my $self = shift;
+ $self->{distvname} ||= do {
+ CPAN::DistnameInfo->new($self->{distfile})->distvname || $self->distfile;
+ };
+}
+
+sub overwrite_provide {
+ my ($self, $provide) = @_;
+ my $overwrote;
+ for my $exist (@{$self->{provides}}) {
+ if ($exist->{package} eq $provide->{package}) {
+ $exist = $provide;
+ $overwrote++;
+ }
+ }
+ if (!$overwrote) {
+ push @{$self->{provides}}, $provide;
+ }
+ return 1;
+}
+
+sub registered {
+ my $self = shift;
+ if (@_ && $_[0]) {
+ $self->{_state} |= STATE_REGISTERED;
+ }
+ $self->{_state} & STATE_REGISTERED;
+}
+
+sub deps_registered {
+ my $self = shift;
+ if (@_ && $_[0]) {
+ $self->{_state} |= STATE_DEPS_REGISTERED;
+ }
+ $self->{_state} & STATE_DEPS_REGISTERED;
+}
+
+sub resolved {
+ my $self = shift;
+ if (@_ && $_[0]) {
+ $self->{_state} = STATE_RESOLVED;
+ }
+ $self->{_state} & STATE_RESOLVED;
+}
+
+sub fetched {
+ my $self = shift;
+ if (@_ && $_[0]) {
+ $self->{_state} = STATE_FETCHED;
+ }
+ $self->{_state} & STATE_FETCHED;
+}
+
+sub configured {
+ my $self = shift;
+ if (@_ && $_[0]) {
+ $self->{_state} = STATE_CONFIGURED
+ }
+ $self->{_state} & STATE_CONFIGURED;
+}
+
+sub installed {
+ my $self = shift;
+ if (@_ && $_[0]) {
+ $self->{_state} = STATE_INSTALLED;
+ }
+ $self->{_state} & STATE_INSTALLED;
+}
+
+sub providing {
+ my ($self, $package, $version_range) = @_;
+ for my $provide (@{$self->provides}) {
+ if ($provide->{package} eq $package) {
+ if (!$version_range or App::cpm::version->parse($provide->{version})->satisfy($version_range)) {
+ return 1;
+ } else {
+ my $message = sprintf "%s provides %s (%s), but needs %s\n",
+ $self->distfile, $package, $provide->{version} || 0, $version_range;
+ App::cpm::Logger->log(result => "WARN", message => $message);
+ last;
+ }
+ }
+ }
+ return;
+}
+
+sub equals {
+ my ($self, $that) = @_;
+ $self->distfile && $that->distfile and $self->distfile eq $that->distfile;
+}
+
+1;
--- /dev/null
+package App::cpm::HTTP;
+use strict;
+use warnings;
+
+use App::cpm;
+use HTTP::Tinyish;
+
+sub create {
+ my ($class, %args) = @_;
+ my $wantarray = wantarray;
+
+ my @try = $args{prefer} ? @{$args{prefer}} : qw(HTTPTiny LWP Curl Wget);
+
+ my ($backend, $tool, $desc);
+ for my $try (map "HTTP::Tinyish::$_", @try) {
+ my $meta = HTTP::Tinyish->configure_backend($try) or next;
+ $try->supports("https") or next;
+ ($tool) = sort keys %$meta;
+ ($desc = $meta->{$tool}) =~ s/^(.*?)\n.*/$1/s;
+ $backend = $try, last;
+ }
+ die "Couldn't find HTTP Clients that support https" unless $backend;
+
+ my $http = $backend->new(
+ agent => "App::cpm/$App::cpm::VERSION",
+ timeout => 60,
+ verify_SSL => 1,
+ %args,
+ );
+ my $keep_alive = exists $args{keep_alive} ? $args{keep_alive} : 1;
+ if ($keep_alive and $backend =~ /LWP$/) {
+ $http->{ua}->conn_cache({ total_capacity => 1 });
+ }
+
+ $wantarray ? ($http, "$tool $desc") : $http;
+}
+
+1;
--- /dev/null
+package App::cpm::Installer::Unpacker;
+
+# Based on https://github.com/miyagawa/cpanminus/blob/7b574ede70cebce3709743ec1727f90d745e8580/Menlo-Legacy/lib/Menlo/CLI/Compat.pm#L2756-L2891
+use strict;
+use warnings;
+
+use File::Basename ();
+use File::Temp ();
+use File::Which ();
+use IPC::Run3 ();
+
+sub run3 {
+ my ($cmd, $outfile) = @_;
+ my $out;
+ IPC::Run3::run3 $cmd, \undef, ($outfile ? $outfile : \$out), \my $err;
+ return ($?, $out, $err);
+}
+
+sub new {
+ my ($class, %argv) = @_;
+ my $self = bless \%argv, $class;
+ $self->_init_untar;
+ $self->_init_unzip;
+ $self;
+}
+
+sub unpack {
+ my ($self, $file) = @_;
+ my $method = $file =~ /\.zip$/ ? $self->{method}{unzip} : $self->{method}{untar};
+ $self->$method($file);
+}
+
+sub describe {
+ my $self = shift;
+ +{
+ map { ($_, $self->{$_}) }
+ grep $self->{$_},
+ qw(tar gzip bzip2 Archive::Tar unzip Archive::Zip),
+ };
+}
+
+sub _init_untar {
+ my $self = shift;
+
+ my $tar = $self->{tar} = File::Which::which('gtar') || File::Which::which("tar");
+ if ($tar) {
+ my ($exit, $out, $err) = run3 [$tar, '--version'];
+ $self->{tar_kind} = $out =~ /bsdtar/ ? "bsd" : "gnu";
+ $self->{tar_bad} = 1 if $out =~ /GNU.*1\.13/i || $^O eq 'MSWin32' || $^O eq 'solaris' || $^O eq 'hpux';
+ }
+
+ if ($tar and !$self->{tar_bad}) {
+ $self->{method}{untar} = *_untar;
+ return if !$self->{_init_all};
+ }
+
+ my $gzip = $self->{gzip} = File::Which::which("gzip");
+ my $bzip2 = $self->{bzip2} = File::Which::which("bzip2");
+
+ if ($tar && $gzip && $bzip2) {
+ $self->{method}{untar} = *_untar_bad;
+ return if !$self->{_init_all};
+ }
+
+ if (eval { require Archive::Tar }) {
+ $self->{"Archive::Tar"} = Archive::Tar->VERSION;
+ $self->{method}{untar} = *_untar_module;
+ return if !$self->{_init_all};
+ }
+
+ return if $self->{_init_all};
+ $self->{method}{untar} = sub { die "There is no backend for untar" };
+}
+
+sub _init_unzip {
+ my $self = shift;
+
+ my $unzip = $self->{unzip} = File::Which::which("unzip");
+ if ($unzip) {
+ $self->{method}{unzip} = *_unzip;
+ return if !$self->{_init_all};
+ }
+
+ if (eval { require Archive::Zip }) {
+ $self->{"Archive::Zip"} = Archive::Zip->VERSION;
+ $self->{method}{unzip} = *_unzip_module;
+ return if !$self->{_init_all};
+ }
+
+ return if $self->{_init_all};
+ $self->{method}{unzip} = sub { die "There is no backend for unzip" };
+}
+
+sub _untar {
+ my ($self, $file) = @_;
+ my $wantarray = wantarray;
+
+ my ($exit, $out, $err);
+ {
+ my $ar = $file =~ /\.bz2$/ ? 'j' : 'z';
+ ($exit, $out, $err) = run3 [$self->{tar}, "${ar}tf", $file];
+ last if $exit != 0;
+ my $root = $self->_find_tarroot(split /\r?\n/, $out);
+ ($exit, $out, $err) = run3 [$self->{tar}, "${ar}xf", $file, "-o"];
+ return $root if $exit == 0 and -d $root;
+ }
+ return if !$wantarray;
+ return (undef, $err || $out);
+}
+
+sub _untar_bad {
+ my ($self, $file) = @_;
+ my $wantarray = wantarray;
+ my ($exit, $out, $err);
+ {
+ my $ar = $file =~ /\.bz2$/ ? $self->{bzip2} : $self->{gzip};
+ my $temp = File::Temp->new(SUFFIX => '.tar', EXLOCK => 0);
+ ($exit, $out, $err) = run3 [$ar, "-dc", $file], $temp->filename;
+ last if $exit != 0;
+
+ # XXX /usr/bin/tar: Cannot connect to C: resolve failed
+ my @opt = $^O eq 'MSWin32' && $self->{tar_kind} ne "bsd" ? ('--force-local') : ();
+ ($exit, $out, $err) = run3 [$self->{tar}, @opt, "-tf", $temp->filename];
+ last if $exit != 0 || !$out;
+ my $root = $self->_find_tarroot(split /\r?\n/, $out);
+ ($exit, $out, $err) = run3 [$self->{tar}, @opt, "-xf", $temp->filename, "-o"];
+ return $root if $exit == 0 and -d $root;
+ }
+ return if !$wantarray;
+ return (undef, $err || $out);
+}
+
+sub _untar_module {
+ my ($self, $file) = @_;
+ my $wantarray = wantarray;
+ no warnings 'once';
+ local $Archive::Tar::WARN = 0;
+ my $t = Archive::Tar->new;
+ {
+ my $ok = $t->read($file);
+ last if !$ok;
+ my $root = $self->_find_tarroot($t->list_files);
+ my @file = $t->extract;
+ return $root if @file and -d $root;
+ }
+ return if !$wantarray;
+ return (undef, $t->error);
+}
+
+sub _find_tarroot {
+ my ($self, $root, @others) = @_;
+ FILE: {
+ chomp $root;
+ $root =~ s!^\./!!;
+ $root =~ s{^(.+?)/.*$}{$1};
+ if (!length $root) { # archive had ./ as the first entry, so try again
+ $root = shift @others;
+ redo FILE if $root;
+ }
+ }
+ $root;
+}
+
+sub _unzip {
+ my ($self, $file) = @_;
+ my $wantarray = wantarray;
+
+ my ($exit, $out, $err);
+ {
+ ($exit, $out, $err) = run3 [$self->{unzip}, '-t', $file];
+ last if $exit != 0;
+ my $root = $self->_find_ziproot(split /\r?\n/, $out);
+ ($exit, $out, $err) = run3 [$self->{unzip}, '-q', $file];
+ return $root if $exit == 0 and -d $root;
+ }
+ return if !$wantarray;
+ return (undef, $err || $out);
+}
+
+sub _unzip_module {
+ my ($self, $file) = @_;
+ my $wantarray = wantarray;
+
+ no warnings 'once';
+ my $err = ''; local $Archive::Zip::ErrorHandler = sub { $err .= "@_" };
+ my $zip = Archive::Zip->new;
+ UNZIP: {
+ my $status = $zip->read($file);
+ last UNZIP if $status != Archive::Zip::AZ_OK();
+ for my $member ($zip->members) {
+ my $af = $member->fileName;
+ next if $af =~ m!^(/|\.\./)!;
+ my $status = $member->extractToFileNamed($af);
+ last UNZIP if $status != Archive::Zip::AZ_OK();
+ }
+ my ($root) = $zip->membersMatching(qr{^[^/]+/$});
+ last UNZIP if !$root;
+ $root = $root->fileName;
+ $root =~ s{/$}{};
+ return $root if -d $root;
+ }
+ return if !$wantarray;
+ return (undef, $err);
+}
+
+sub _find_ziproot {
+ my ($self, undef, $root, @others) = @_;
+ FILE: {
+ chomp $root;
+ if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
+ $root = shift @others;
+ redo FILE if $root;
+ }
+ }
+ $root;
+}
+
+1;
--- /dev/null
+package App::cpm::Job;
+use strict;
+use warnings;
+use CPAN::DistnameInfo;
+
+sub new {
+ my ($class, %option) = @_;
+ my $self = bless {%option}, $class;
+ $self->{uid} = $self->_uid;
+ $self;
+}
+
+sub uid { shift->{uid} }
+
+sub _uid {
+ my $self = shift;
+ my $type = $self->type;
+ if (grep { $type eq $_ } qw(fetch configure install)) {
+ "$type " . $self->distfile;
+ } elsif ($type eq "resolve") {
+ "$type " . $self->{package};
+ } else {
+ die "unknown type: " . ($type || "(undef)");
+ }
+}
+
+sub distfile {
+ my $self = shift;
+ $self->{distfile} || $self->{uri};
+}
+
+sub distvname {
+ my $self = shift;
+ return $self->{_distvname} if $self->{_distvname};
+ if ($self->{distfile}) {
+ $self->{_distvname} ||= CPAN::DistnameInfo->new($self->{distfile})->distvname;
+ } elsif ($self->{uri}) {
+ $self->{uri};
+ } elsif ($self->{package}) {
+ $self->{package};
+ } else {
+ "UNKNOWN";
+ }
+}
+
+sub distname {
+ my $self = shift;
+ $self->{_distname} ||= CPAN::DistnameInfo->new($self->distfile)->dist || 'UNKNOWN';
+}
+
+sub cpanid {
+ my $self = shift;
+ $self->{_cpanid} ||= CPAN::DistnameInfo->new($self->distfile)->cpanid || 'UNKNOWN';
+}
+
+sub type {
+ my $self = shift;
+ $self->{type};
+}
+
+sub in_charge {
+ my $self = shift;
+ @_ ? $self->{in_charge} = shift : $self->{in_charge};
+}
+
+sub is_success {
+ my $self = shift;
+ $self->{ok};
+}
+
+sub equals {
+ my ($self, $that) = @_;
+ $self->uid eq $that->uid;
+}
+
+sub merge {
+ my ($self, $that) = @_;
+ for my $key (keys %$that) {
+ $self->{$key} = $that->{$key};
+ }
+ $self;
+}
+
+1;
--- /dev/null
+package App::cpm::Logger;
+use strict;
+use warnings;
+
+use App::cpm::Util 'WIN32';
+use List::Util 'max';
+
+our $COLOR;
+our $VERBOSE;
+our $SHOW_PROGRESS;
+
+my %color = (
+ resolve => 33,
+ fetch => 34,
+ configure => 35,
+ install => 36,
+ FAIL => 31,
+ DONE => 32,
+ WARN => 33,
+);
+
+our $HAS_WIN32_COLOR;
+
+sub new {
+ my $class = shift;
+ bless {@_}, $class;
+}
+
+sub log {
+ my ($self, %option) = @_;
+ my $type = $option{type} || "";
+ my $message = $option{message};
+ chomp $message;
+ my $optional = $option{optional} ? " ($option{optional})" : "";
+ my $result = $option{result};
+ my $is_color = ref $self ? $self->{color} : $COLOR;
+ my $verbose = ref $self ? $self->{verbose} : $VERBOSE;
+ my $show_progress = ref $self ? $self->{show_progress} : $SHOW_PROGRESS;
+
+ if ($is_color and WIN32) {
+ if (!defined $HAS_WIN32_COLOR) {
+ $HAS_WIN32_COLOR = eval { require Win32::Console::ANSI; 1 } ? 1 : 0;
+ }
+ $is_color = 0 unless $HAS_WIN32_COLOR;
+ }
+
+ if ($is_color) {
+ $type = "\e[$color{$type}m$type\e[m" if $type && $color{$type};
+ $result = "\e[$color{$result}m$result\e[m" if $result && $color{$result};
+ $optional = "\e[1;37m$optional\e[m" if $optional;
+ }
+
+ my $r = $show_progress ? "\r" : "";
+ if ($verbose) {
+ # type -> 5 + 9 + 3
+ $type = $is_color && $type ? sprintf("%-17s", $type) : sprintf("%-9s", $type || "");
+ warn $r . sprintf "%d %s %s %s%s\n", $option{pid} || $$, $result, $type, $message, $optional;
+ } else {
+ warn $r . join(" ", $result, $type ? $type : (), $message . $optional) . "\n";
+ }
+}
+
+1;
--- /dev/null
+package App::cpm::Logger::File;
+use strict;
+use warnings;
+
+use App::cpm::Util 'WIN32';
+use File::Temp ();
+use POSIX ();
+
+sub new {
+ my ($class, $file) = @_;
+ my $fh;
+ if (WIN32) {
+ require IO::File;
+ $file ||= File::Temp::tmpnam();
+ } elsif ($file) {
+ open $fh, ">>:unix", $file or die "$file: $!";
+ } else {
+ ($fh, $file) = File::Temp::tempfile(UNLINK => 1);
+ }
+ bless {
+ context => '',
+ fh => $fh,
+ file => $file,
+ pid => '',
+ }, $class;
+}
+
+sub symlink_to {
+ my ($self, $dest) = @_;
+ unlink $dest;
+ if (!eval { symlink $self->file, $dest }) {
+ $self->{file} = $dest;
+ }
+}
+
+sub file {
+ shift->{file};
+}
+
+sub prefix {
+ my $self = shift;
+ my $pid = $self->{pid} || $$;
+ $self->{context} ? "$pid,$self->{context}" : $pid;
+}
+
+sub log {
+ my ($self, @line) = @_;
+ my $now = POSIX::strftime('%Y-%m-%dT%H:%M:%S', localtime);
+ my $prefix = $self->prefix;
+ local $self->{fh} = IO::File->new($self->{file}, 'a') if WIN32;
+ for my $line (@line) {
+ chomp $line;
+ print { $self->{fh} } "$now,$prefix| $_\n" for split /\n/, $line;
+ }
+}
+
+sub log_with_fh {
+ my ($self, $fh) = @_;
+ my $prefix = $self->prefix;
+ local $self->{fh} = IO::File->new($self->{file}, 'a') if WIN32;
+ while (my $line = <$fh>) {
+ chomp $line;
+ print { $self->{fh} } "@{[POSIX::strftime('%Y-%m-%dT%H:%M:%S', localtime)]},$prefix| $line\n";
+ }
+}
+
+1;
--- /dev/null
+package App::cpm::Master;
+use strict;
+use warnings;
+
+use App::cpm::CircularDependency;
+use App::cpm::Distribution;
+use App::cpm::Job;
+use App::cpm::Logger;
+use App::cpm::version;
+use CPAN::DistnameInfo;
+use IO::Handle;
+use Module::Metadata;
+
+sub new {
+ my ($class, %option) = @_;
+ my $self = bless {
+ %option,
+ installed_distributions => 0,
+ jobs => +{},
+ distributions => +{},
+ _fail_resolve => +{},
+ _fail_install => +{},
+ _is_installed => +{},
+ }, $class;
+ if ($self->{target_perl}) {
+ require Module::CoreList;
+ if (!exists $Module::CoreList::version{$self->{target_perl}}) {
+ die "Module::CoreList does not have target perl $self->{target_perl} entry, abort.\n";
+ }
+ if (!exists $Module::CoreList::version{$]}) {
+ die "Module::CoreList does not have our perl $] entry, abort.\n";
+ }
+ }
+ if (!$self->{global}) {
+ if (eval { require Module::CoreList }) {
+ if (!exists $Module::CoreList::version{$]}) {
+ die "Module::CoreList does not have our perl $] entry, abort.\n";
+ }
+ $self->{_has_corelist} = 1;
+ } else {
+ my $msg = "You don't have Module::CoreList. "
+ . "The local-lib may result in incomplete self-contained directory.";
+ App::cpm::Logger->log(result => "WARN", message => $msg);
+ }
+ }
+ $self;
+}
+
+sub fail {
+ my $self = shift;
+
+ my @fail_resolve = sort keys %{$self->{_fail_resolve}};
+ my @fail_install = sort keys %{$self->{_fail_install}};
+ my @not_installed = grep { !$self->{_fail_install}{$_->distfile} && !$_->installed } $self->distributions;
+ return if !@fail_resolve && !@fail_install && !@not_installed;
+
+ my $detector = App::cpm::CircularDependency->new;
+ for my $dist (@not_installed) {
+ my $req = $dist->requirements([qw(configure build test runtime)])->as_array;
+ $detector->add($dist->distfile, $dist->provides, $req);
+ }
+ $detector->finalize;
+
+ my $detected = $detector->detect;
+ for my $distfile (sort keys %$detected) {
+ my $distvname = $self->distribution($distfile)->distvname;
+ my @circular = @{$detected->{$distfile}};
+ my $msg = join " -> ", map { $self->distribution($_)->distvname } @circular;
+ local $self->{logger}{context} = $distvname;
+ $self->{logger}->log("Detected circular dependencies $msg");
+ $self->{logger}->log("Failed to install distribution");
+ }
+ for my $dist (sort { $a->distvname cmp $b->distvname } grep { !$detected->{$_->distfile} } @not_installed) {
+ local $self->{logger}{context} = $dist->distvname;
+ $self->{logger}->log("Failed to install distribution, "
+ ."because of installing some dependencies failed");
+ }
+
+ my @name = (
+ (map { CPAN::DistnameInfo->new($_)->distvname || $_ } @fail_install),
+ (map { $_->distvname } @not_installed),
+ );
+ { resolve => \@fail_resolve, install => [sort @name] };
+}
+
+sub jobs { values %{shift->{jobs}} }
+
+sub add_job {
+ my ($self, %job) = @_;
+ my $new = App::cpm::Job->new(%job);
+ if (grep { $_->equals($new) } $self->jobs) {
+ return 0;
+ } else {
+ $self->{jobs}{$new->uid} = $new;
+ return 1;
+ }
+}
+
+sub get_job {
+ my $self = shift;
+ if (my @job = grep { !$_->in_charge } $self->jobs) {
+ return @job;
+ }
+ $self->_calculate_jobs;
+ return unless $self->jobs;
+ if (my @job = grep { !$_->in_charge } $self->jobs) {
+ return @job;
+ }
+ return;
+}
+
+sub register_result {
+ my ($self, $result) = @_;
+ my ($job) = grep { $_->uid eq $result->{uid} } $self->jobs;
+ die "Missing job that has uid=$result->{uid}" unless $job;
+
+ %{$job} = %{$result}; # XXX
+
+ my $logged = $self->info($job);
+ my $method = "_register_@{[$job->{type}]}_result";
+ $self->$method($job);
+ $self->remove_job($job);
+ $self->_show_progress if $logged && $self->{show_progress};
+
+ return 1;
+}
+
+sub info {
+ my ($self, $job) = @_;
+ my $type = $job->type;
+ return if !$App::cpm::Logger::VERBOSE && $type ne "install";
+ my $name = $job->distvname;
+ my ($message, $optional);
+ if ($type eq "resolve") {
+ $message = $job->{package};
+ $message .= " -> $name" . ($job->{ref} ? "\@$job->{ref}" : "") if $job->{ok};
+ $optional = "from $job->{from}" if $job->{ok} and $job->{from};
+ } else {
+ $message = $name;
+ $optional = "using cache" if $type eq "fetch" and $job->{using_cache};
+ $optional = "using prebuilt" if $job->{prebuilt};
+ }
+ my $elapsed = defined $job->{elapsed} ? sprintf "(%.3fsec) ", $job->{elapsed} : "";
+
+ App::cpm::Logger->log(
+ pid => $job->{pid},
+ type => $type,
+ result => $job->{ok} ? "DONE" : "FAIL",
+ message => "$elapsed$message",
+ optional => $optional,
+ );
+ return 1;
+}
+
+sub _show_progress {
+ my $self = shift;
+ my $all = keys %{$self->{distributions}};
+ my $num = $self->installed_distributions;
+ print STDERR "--- $num/$all ---";
+ STDERR->flush; # this is needed at least with perl <= 5.24
+}
+
+sub remove_job {
+ my ($self, $job) = @_;
+ delete $self->{jobs}{$job->uid};
+}
+
+sub distributions { values %{shift->{distributions}} }
+
+sub distribution {
+ my ($self, $distfile) = @_;
+ $self->{distributions}{$distfile};
+}
+
+sub _calculate_jobs {
+ my $self = shift;
+
+ my @distributions
+ = grep { !$self->{_fail_install}{$_->distfile} } $self->distributions;
+
+ if (my @dists = grep { $_->resolved && !$_->registered } @distributions) {
+ for my $dist (@dists) {
+ $dist->registered(1);
+ $self->add_job(
+ type => "fetch",
+ distfile => $dist->{distfile},
+ source => $dist->source,
+ uri => $dist->uri,
+ ref => $dist->ref,
+ );
+ }
+ }
+
+ if (my @dists = grep { $_->fetched && !$_->registered } @distributions) {
+ for my $dist (@dists) {
+ local $self->{logger}->{context} = $dist->distvname;
+ my $dist_requirements = $dist->requirements('configure')->as_array;
+ my ($is_satisfied, @need_resolve) = $self->is_satisfied($dist_requirements);
+ if ($is_satisfied) {
+ $dist->registered(1);
+ $self->add_job(
+ type => "configure",
+ meta => $dist->meta,
+ directory => $dist->directory,
+ distfile => $dist->{distfile},
+ source => $dist->source,
+ uri => $dist->uri,
+ distvname => $dist->distvname,
+ );
+ } elsif (@need_resolve and !$dist->deps_registered) {
+ $dist->deps_registered(1);
+ my $msg = sprintf "Found configure dependencies: %s",
+ join(", ", map { sprintf "%s (%s)", $_->{package}, $_->{version_range} || 0 } @need_resolve);
+ $self->{logger}->log($msg);
+ my $ok = $self->_register_resolve_job(@need_resolve);
+ $self->{_fail_install}{$dist->distfile}++ unless $ok;
+ } elsif (!defined $is_satisfied) {
+ my ($req) = grep { $_->{package} eq "perl" } @$dist_requirements;
+ my $msg = sprintf "%s requires perl %s, but you have only %s",
+ $dist->distvname, $req->{version_range}, $self->{target_perl} || $];
+ $self->{logger}->log($msg);
+ App::cpm::Logger->log(result => "FAIL", message => $msg);
+ $self->{_fail_install}{$dist->distfile}++;
+ }
+ }
+ }
+
+ if (my @dists = grep { $_->configured && !$_->registered } @distributions) {
+ for my $dist (@dists) {
+ local $self->{logger}->{context} = $dist->distvname;
+
+ my @phase = qw(build test runtime);
+ push @phase, 'configure' if $dist->prebuilt;
+ my $dist_requirements = $dist->requirements(\@phase)->as_array;
+ my ($is_satisfied, @need_resolve) = $self->is_satisfied($dist_requirements);
+ if ($is_satisfied) {
+ $dist->registered(1);
+ $self->add_job(
+ type => "install",
+ meta => $dist->meta,
+ distdata => $dist->distdata,
+ directory => $dist->directory,
+ distfile => $dist->{distfile},
+ uri => $dist->uri,
+ static_builder => $dist->static_builder,
+ prebuilt => $dist->prebuilt,
+ );
+ } elsif (@need_resolve and !$dist->deps_registered) {
+ $dist->deps_registered(1);
+ my $msg = sprintf "Found dependencies: %s",
+ join(", ", map { sprintf "%s (%s)", $_->{package}, $_->{version_range} || 0 } @need_resolve);
+ $self->{logger}->log($msg);
+ my $ok = $self->_register_resolve_job(@need_resolve);
+ $self->{_fail_install}{$dist->distfile}++ unless $ok;
+ } elsif (!defined $is_satisfied) {
+ my ($req) = grep { $_->{package} eq "perl" } @$dist_requirements;
+ my $msg = sprintf "%s requires perl %s, but you have only %s",
+ $dist->distvname, $req->{version_range}, $self->{target_perl} || $];
+ $self->{logger}->log($msg);
+ App::cpm::Logger->log(result => "FAIL", message => $msg);
+ $self->{_fail_install}{$dist->distfile}++;
+ }
+ }
+ }
+}
+
+sub _register_resolve_job {
+ my ($self, @package) = @_;
+ my $ok = 1;
+ for my $package (@package) {
+ if ($self->{_fail_resolve}{$package->{package}}
+ || $self->{_fail_install}{$package->{package}}
+ ) {
+ $ok = 0;
+ next;
+ }
+
+ $self->add_job(
+ type => "resolve",
+ package => $package->{package},
+ version_range => $package->{version_range},
+ );
+ }
+ return $ok;
+}
+
+sub is_satisfied_perl_version {
+ my ($self, $version_range) = @_;
+ App::cpm::version->parse($self->{target_perl} || $])->satisfy($version_range);
+}
+
+sub is_installed {
+ my ($self, $package, $version_range) = @_;
+ my $wantarray = wantarray;
+ if (exists $self->{_is_installed}{$package}) {
+ if ($self->{_is_installed}{$package}->satisfy($version_range)) {
+ return $wantarray ? (1, $self->{_is_installed}{$package}) : 1;
+ }
+ }
+ my $info = Module::Metadata->new_from_module($package, inc => $self->{search_inc});
+ return unless $info;
+
+ if (!$self->{global} and $self->{_has_corelist} and $self->_in_core_inc($info->filename)) {
+ # https://github.com/miyagawa/cpanminus/blob/7b574ede70cebce3709743ec1727f90d745e8580/Menlo-Legacy/lib/Menlo/CLI/Compat.pm#L1783-L1786
+ # if found package in core inc,
+ # but it does not list in CoreList,
+ # we should treat it as not being installed
+ return if !exists $Module::CoreList::version{$]}{$info->name};
+ }
+ my $current_version = $self->{_is_installed}{$package}
+ = App::cpm::version->parse($info->version);
+ my $ok = $current_version->satisfy($version_range);
+ $wantarray ? ($ok, $current_version) : $ok;
+}
+
+sub _in_core_inc {
+ my ($self, $file) = @_;
+ !!grep { $file =~ /^\Q$_/ } @{$self->{core_inc}};
+}
+
+sub is_core {
+ my ($self, $package, $version_range) = @_;
+ my $target_perl = $self->{target_perl};
+ if (exists $Module::CoreList::version{$target_perl}{$package}) {
+ if (!exists $Module::CoreList::version{$]}{$package}) {
+ if (!$self->{_removed_core}{$package}++) {
+ my $t = App::cpm::version->parse($target_perl)->normal;
+ my $v = App::cpm::version->parse($])->normal;
+ App::cpm::Logger->log(
+ result => "WARN",
+ message => "$package used to be core in $t, but not in $v, so will be installed",
+ );
+ }
+ return;
+ }
+ return 1 unless $version_range;
+ my $core_version = $Module::CoreList::version{$target_perl}{$package};
+ return App::cpm::version->parse($core_version)->satisfy($version_range);
+ }
+ return;
+}
+
+# 0: not satisfied, need wait for satisfying requirements
+# 1: satisfied, ready to install
+# undef: not satisfied because of perl version
+sub is_satisfied {
+ my ($self, $requirements) = @_;
+ my $is_satisfied = 1;
+ my @need_resolve;
+ my @distributions = $self->distributions;
+ for my $req (@$requirements) {
+ my ($package, $version_range) = @{$req}{qw(package version_range)};
+ if ($package eq "perl") {
+ $is_satisfied = undef if !$self->is_satisfied_perl_version($version_range);
+ next;
+ }
+ next if $self->{target_perl} and $self->is_core($package, $version_range);
+ next if $self->is_installed($package, $version_range);
+ my ($resolved) = grep { $_->providing($package, $version_range) } @distributions;
+ next if $resolved && $resolved->installed;
+
+ $is_satisfied = 0 if defined $is_satisfied;
+ if (!$resolved) {
+ push @need_resolve, $req;
+ }
+ }
+ return ($is_satisfied, @need_resolve);
+}
+
+sub add_distribution {
+ my ($self, $distribution) = @_;
+ my $distfile = $distribution->distfile;
+ if (my $already = $self->{distributions}{$distfile}) {
+ $already->overwrite_provide($_) for @{ $distribution->provides };
+ return 0;
+ } else {
+ $self->{distributions}{$distfile} = $distribution;
+ return 1;
+ }
+}
+
+sub _register_resolve_result {
+ my ($self, $job) = @_;
+ if (!$job->is_success) {
+ $self->{_fail_resolve}{$job->{package}}++;
+ return;
+ }
+
+ local $self->{logger}{context} = $job->{package};
+ if ($job->{distfile} and $job->{distfile} =~ m{/perl-5[^/]+$}) {
+ my $message = "Cannot upgrade core module $job->{package}.";
+ $self->{logger}->log($message);
+ App::cpm::Logger->log(
+ result => "FAIL",
+ type => "install",
+ message => $message,
+ );
+ $self->{_fail_install}{$job->{package}}++; # XXX
+ return;
+ }
+
+ if (!$job->{reinstall}) {
+ my $want = $job->{version_range} || $job->{version};
+ my ($ok, $local) = $self->is_installed($job->{package}, $want);
+ if ($ok) {
+ my $message = $job->{package} . (
+ App::cpm::version->parse($job->{version}) != $local
+ ? ", you already have $local"
+ : " is up to date. ($local)"
+ );
+ $self->{logger}->log($message);
+ App::cpm::Logger->log(
+ result => "DONE",
+ type => "install",
+ message => $message,
+ );
+ return;
+ }
+ }
+
+ my $provides = $job->{provides};
+ if (!$provides or @$provides == 0) {
+ my $version = App::cpm::version->parse($job->{version}) || 0;
+ $provides = [{package => $job->{package}, version => $version}];
+ }
+ my $distribution = App::cpm::Distribution->new(
+ source => $job->{source},
+ uri => $job->{uri},
+ provides => $provides,
+ distfile => $job->{distfile},
+ ref => $job->{ref},
+ );
+ $self->add_distribution($distribution);
+}
+
+sub _register_fetch_result {
+ my ($self, $job) = @_;
+ if (!$job->is_success) {
+ $self->{_fail_install}{$job->distfile}++;
+ return;
+ }
+ my $distribution = $self->distribution($job->distfile);
+ $distribution->directory($job->{directory});
+ $distribution->meta($job->{meta});
+ $distribution->provides($job->{provides});
+
+ if ($job->{prebuilt}) {
+ $distribution->configured(1);
+ $distribution->requirements($_ => $job->{requirements}{$_}) for keys %{$job->{requirements}};
+ $distribution->prebuilt(1);
+ local $self->{logger}{context} = $distribution->distvname;
+ my $msg = join ", ", map { sprintf "%s (%s)", $_->{package}, $_->{version} || 0 } @{$distribution->provides};
+ $self->{logger}->log("Distribution provides: $msg");
+ } else {
+ $distribution->fetched(1);
+ $distribution->requirements($_ => $job->{requirements}{$_}) for keys %{$job->{requirements}};
+ }
+ return 1;
+}
+
+sub _register_configure_result {
+ my ($self, $job) = @_;
+ if (!$job->is_success) {
+ $self->{_fail_install}{$job->distfile}++;
+ return;
+ }
+ my $distribution = $self->distribution($job->distfile);
+ $distribution->configured(1);
+ $distribution->requirements($_ => $job->{requirements}{$_}) for keys %{$job->{requirements}};
+ $distribution->static_builder($job->{static_builder});
+ $distribution->distdata($job->{distdata});
+
+ # After configuring, the final "provides" is fixed.
+ # So we need to re-define "provides" here
+ my $p = $job->{distdata}{provides};
+ my @provide = map +{ package => $_, version => $p->{$_}{version} }, sort keys %$p;
+ $distribution->provides(\@provide);
+ local $self->{logger}{context} = $distribution->distvname;
+ my $msg = join ", ", map { sprintf "%s (%s)", $_->{package}, $_->{version} || 0 } @{$distribution->provides};
+ $self->{logger}->log("Distribution provides: $msg");
+
+ return 1;
+}
+
+sub _register_install_result {
+ my ($self, $job) = @_;
+ if (!$job->is_success) {
+ $self->{_fail_install}{$job->distfile}++;
+ return;
+ }
+ my $distribution = $self->distribution($job->distfile);
+ $distribution->installed(1);
+ $self->{installed_distributions}++;
+ return 1;
+}
+
+sub installed_distributions {
+ shift->{installed_distributions};
+}
+
+1;
--- /dev/null
+package App::cpm::Requirement;
+use strict;
+use warnings;
+
+use App::cpm::version;
+
+sub new {
+ my $class = shift;
+ my $self = bless { requirement => [] }, $class;
+ $self->add(@_) if @_;
+ $self;
+}
+
+sub empty {
+ my $self = shift;
+ @{$self->{requirement}} == 0;
+}
+
+sub has {
+ my ($self, $package) = @_;
+ my ($found) = grep { $_->{package} eq $package } @{$self->{requirement}};
+ $found;
+}
+
+sub add {
+ my $self = shift;
+ my %package = (@_, @_ % 2 ? (0) : ());
+ for my $package (sort keys %package) {
+ my $version_range = $package{$package};
+ if (my ($found) = grep { $_->{package} eq $package } @{$self->{requirement}}) {
+ my $merged = eval {
+ App::cpm::version::range_merge($found->{version_range}, $version_range);
+ };
+ if (my $err = $@) {
+ if ($err =~ /illegal requirements/) {
+ $@ = "Couldn't merge version range '$version_range' with '$found->{version_range}' for package '$package'";
+ warn $@; # XXX
+ return; # should check $@ in caller side
+ } else {
+ die $err;
+ }
+ }
+ $found->{version_range} = $merged;
+ } else {
+ push @{$self->{requirement}}, { package => $package, version_range => $version_range };
+ }
+ }
+ return 1;
+}
+
+sub merge {
+ my ($self, $other) = @_;
+ $self->add(map { ($_->{package}, $_->{version_range}) } @{ $other->as_array });
+}
+
+sub delete :method {
+ my ($self, @package) = @_;
+ for my $i (reverse 0 .. $#{ $self->{requirement} }) {
+ my $current = $self->{requirement}[$i]{package};
+ if (grep { $current eq $_ } @package) {
+ splice @{$self->{requirement}}, $i, 1;
+ }
+ }
+}
+
+sub as_array {
+ my $self = shift;
+ $self->{requirement};
+}
+
+1;
--- /dev/null
+package App::cpm::Resolver;
+use strict;
+use warnings;
+
+1;
--- /dev/null
+package App::cpm::Resolver::02Packages;
+use strict;
+use warnings;
+
+use App::cpm::DistNotation;
+use App::cpm::version;
+use Cwd ();
+use File::Path ();
+
+{
+ package
+ App::cpm::Resolver::02Packages::Impl;
+ use parent 'CPAN::Common::Index::Mirror';
+ use App::cpm::HTTP;
+ use Class::Tiny qw(path);
+ use File::Basename ();
+ use File::Copy ();
+ use File::Spec;
+
+ our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
+
+ sub BUILD {
+ my $self = shift;
+ if ($self->path =~ /\.gz$/ and !$HAS_IO_UNCOMPRESS_GUNZIP) {
+ die "Can't load gz index file without IO::Uncompress::Gunzip";
+ }
+ return;
+ }
+
+ sub cached_package { shift->{cached_package} }
+
+ sub refresh_index {
+ my $self = shift;
+ my $path = $self->path;
+ my $dest = File::Spec->catfile($self->cache, File::Basename::basename($path));
+ if ($path =~ m{^https?://}) {
+ my $res = App::cpm::HTTP->create->mirror($path => $dest);
+ die "$res->{status} $res->{reason}, $path\n" unless $res->{success};
+ } else {
+ $path =~ s{^file://}{};
+ die "$path: No such file.\n" unless -f $path;
+ if (!-f $dest or (stat $dest)[9] <= (stat $path)[9]) {
+ File::Copy::copy($path, $dest) or die "Copy $path $dest: $!\n";
+ my $mtime = (stat $path)[9];
+ utime $mtime, $mtime, $dest;
+ }
+ }
+
+ if ($dest =~ /\.gz$/) {
+ ( my $uncompressed = File::Basename::basename($dest) ) =~ s/\.gz$//;
+ $uncompressed = File::Spec->catfile( $self->cache, $uncompressed );
+ if ( !-f $uncompressed or (stat $uncompressed)[9] <= (stat $dest)[9] ) {
+ no warnings 'once';
+ IO::Uncompress::Gunzip::gunzip($dest, $uncompressed)
+ or die "Gunzip $dest: $IO::Uncompress::Gunzip::GunzipError";
+ }
+ $self->{cached_package} = $uncompressed;
+ } else {
+ $self->{cached_package} = $dest;
+ }
+ }
+}
+
+sub new {
+ my ($class, %option) = @_;
+ my $cache_base = $option{cache} or die "cache option is required\n";
+ my $mirror = $option{mirror} or die "mirror option is required\n";
+ $mirror =~ s{/*$}{/};
+
+ my ($path, $cache);
+ if ($option{path}) {
+ $path = $option{path};
+ } else {
+ $path = "${mirror}modules/02packages.details.txt.gz";
+ $cache = $class->cache_for($mirror, $cache_base);
+ }
+
+ my $impl = App::cpm::Resolver::02Packages::Impl->new(
+ path => $path, $cache ? (cache => $cache) : (),
+ );
+ $impl->refresh_index; # refresh_index first
+ bless { mirror => $mirror, impl => $impl }, $class;
+}
+
+sub cache_for {
+ my ($class, $mirror, $cache) = @_;
+ if ($mirror !~ m{^https?://}) {
+ $mirror =~ s{^file://}{};
+ $mirror = Cwd::abs_path($mirror);
+ $mirror =~ s{^/}{};
+ }
+ $mirror =~ s{/$}{};
+ $mirror =~ s/[^\w\.\-]+/%/g;
+ my $dir = "$cache/$mirror";
+ File::Path::mkpath([ $dir ], 0, 0777);
+ return $dir;
+}
+
+sub cached_package { shift->{impl}->cached_package }
+
+sub resolve {
+ my ($self, $job) = @_;
+ my $result = $self->{impl}->search_packages({package => $job->{package}});
+ if (!$result) {
+ return { error => "not found, @{[$self->cached_package]}" };
+ }
+
+ if (my $version_range = $job->{version_range}) {
+ my $version = $result->{version};
+ if (!App::cpm::version->parse($version)->satisfy($version_range)) {
+ return { error => "found version $version, but it does not satisfy $version_range, @{[$self->cached_package]}" };
+ }
+ }
+ my $uri = $result->{uri};
+ $uri =~ s{^cpan:///distfile/}{};
+ my $dist = App::cpm::DistNotation->new_from_dist($uri);
+ return +{
+ source => "cpan", # XXX
+ distfile => $dist->distfile,
+ uri => $dist->cpan_uri($self->{mirror}),
+ version => $result->{version} || 0,
+ package => $result->{package},
+ };
+}
+
+1;
--- /dev/null
+package App::cpm::Resolver::CPANfile;
+use strict;
+use warnings;
+
+use App::cpm::DistNotation;
+use Module::CPANfile;
+
+sub new {
+ my ($class, %args) = @_;
+
+ my $cpanfile = $args{cpanfile} || Module::CPANfile->load($args{path});
+ my $mirror = $args{mirror} || 'https://cpan.metacpan.org/';
+ $mirror =~ s{/*$}{/};
+ my $self = bless {
+ %args,
+ cpanfile => $cpanfile,
+ mirror => $mirror,
+ }, $class;
+ $self->_load;
+ $self;
+}
+
+sub _load {
+ my $self = shift;
+
+ my $cpanfile = $self->{cpanfile};
+ my $specs = $cpanfile->prereq_specs;
+ my %package;
+ for my $phase (keys %$specs) {
+ for my $type (keys %{$specs->{$phase}}) {
+ $package{$_}++ for keys %{$specs->{$phase}{$type}};
+ }
+ }
+
+ my %resolve;
+ for my $package (keys %package) {
+ my $option = $cpanfile->options_for_module($package);
+ next if !$option;
+
+ my $uri;
+ if ($uri = $option->{git}) {
+ $resolve{$package} = {
+ source => 'git',
+ uri => $uri,
+ ref => $option->{ref},
+ provides => [{package => $package}],
+ };
+ } elsif ($uri = $option->{dist}) {
+ my $dist = App::cpm::DistNotation->new_from_dist($uri);
+ die "Unsupported dist '$uri' found in cpanfile\n" if !$dist;
+ my $cpan_uri = $dist->cpan_uri($option->{mirror} || $self->{mirror});
+ $resolve{$package} = {
+ source => 'cpan',
+ uri => $cpan_uri,
+ distfile => $dist->distfile,
+ provides => [{package => $package}],
+ };
+ } elsif ($uri = $option->{url}) {
+ die "Unsupported url '$uri' found in cpanfile\n" if $uri !~ m{^(?:https?|file)://};
+ my $dist = App::cpm::DistNotation->new_from_uri($uri);
+ my $source = $dist ? 'cpan' : $uri =~ m{^file://} ? 'local' : 'http';
+ $resolve{$package} = {
+ source => $source,
+ uri => $dist ? $dist->cpan_uri : $uri,
+ ($dist ? (distfile => $dist->distfile) : ()),
+ provides => [{package => $package}],
+ };
+ }
+ }
+ $self->{_resolve} = \%resolve;
+
+}
+
+sub resolve {
+ my ($self, $job) = @_;
+ my $found = $self->{_resolve}{$job->{package}};
+ if (!$found) {
+ return { error => "not found" };
+ }
+ $found; # TODO handle version
+}
+
+1;
--- /dev/null
+package App::cpm::Resolver::Cascade;
+use strict;
+use warnings;
+
+sub new {
+ my $class = shift;
+ bless { backends => [] }, $class;
+}
+
+sub add {
+ my ($self, $resolver) = @_;
+ push @{ $self->{backends} }, $resolver;
+ $self;
+}
+
+sub resolve {
+ my ($self, $job) = @_;
+ # here job = { package => "Plack", version_range => ">= 1.000, < 1.0030" }
+
+ my @error;
+ for my $backend (@{ $self->{backends} }) {
+ my $result = $backend->resolve($job);
+ next unless $result;
+
+ my $klass = ref $backend;
+ $klass = $1 if $klass =~ /^App::cpm::Resolver::(.*)$/;
+ if (my $error = $result->{error}) {
+ push @error, "$klass, $error";
+ } else {
+ $result->{from} = $klass;
+ return $result;
+ }
+ }
+ return { error => join("\n", @error) };
+}
+
+1;
--- /dev/null
+package App::cpm::Resolver::MetaCPAN;
+use strict;
+use warnings;
+
+use App::cpm::DistNotation;
+use App::cpm::HTTP;
+use JSON::PP ();
+
+sub new {
+ my ($class, %option) = @_;
+ my $uri = $option{uri} || "https://fastapi.metacpan.org/v1/download_url/";
+ $uri =~ s{/*$}{/};
+ my $http = App::cpm::HTTP->create;
+ bless { %option, uri => $uri, http => $http }, $class;
+}
+
+sub _encode {
+ my $str = shift;
+ $str =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
+ $str;
+}
+
+sub resolve {
+ my ($self, $job) = @_;
+ if ($self->{only_dev} and !$job->{dev}) {
+ return { error => "skip, because MetaCPAN is configured to resolve dev releases only" };
+ }
+
+ my %query = (
+ ( ($self->{dev} || $job->{dev}) ? (dev => 1) : () ),
+ ( $job->{version_range} ? (version => $job->{version_range}) : () ),
+ );
+ my $query = join "&", map { "$_=" . _encode($query{$_}) } sort keys %query;
+ my $uri = "$self->{uri}$job->{package}" . ($query ? "?$query" : "");
+ my $res;
+ for (1..2) {
+ $res = $self->{http}->get($uri);
+ last if $res->{success} or $res->{status} == 404;
+ }
+ if (!$res->{success}) {
+ my $error = "$res->{status} $res->{reason}, $uri";
+ $error .= ", $res->{content}" if $res->{status} == 599;
+ return { error => $error };
+ }
+
+ my $hash = eval { JSON::PP::decode_json($res->{content}) } or return;
+ my $dist = App::cpm::DistNotation->new_from_uri($hash->{download_url});
+ return {
+ source => "cpan", # XXX
+ distfile => $dist->distfile,
+ package => $job->{package},
+ version => $hash->{version} || 0,
+ uri => $hash->{download_url},
+ };
+}
+
+1;
--- /dev/null
+package App::cpm::Resolver::MetaDB;
+use strict;
+use warnings;
+
+use App::cpm::DistNotation;
+use App::cpm::HTTP;
+use App::cpm::version;
+use CPAN::Meta::YAML;
+
+sub new {
+ my ($class, %option) = @_;
+ my $uri = $option{uri} || "https://cpanmetadb.plackperl.org/v1.0/";
+ my $mirror = $option{mirror} || "https://cpan.metacpan.org/";
+ s{/*$}{/} for $uri, $mirror;
+ my $http = App::cpm::HTTP->create;
+ bless {
+ %option,
+ http => $http,
+ uri => $uri,
+ mirror => $mirror,
+ }, $class;
+}
+
+sub _get {
+ my ($self, $uri) = @_;
+ my $res;
+ for (1..2) {
+ $res = $self->{http}->get($uri);
+ last if $res->{success} or $res->{status} == 404;
+ }
+ $res;
+}
+
+sub _uniq {
+ my %x; grep { !$x{$_ || ""}++ } @_;
+}
+
+sub resolve {
+ my ($self, $job) = @_;
+
+ if (defined $job->{version_range} and $job->{version_range} =~ /(?:<|!=|==)/) {
+ my $uri = "$self->{uri}history/$job->{package}";
+ my $res = $self->_get($uri);
+ if (!$res->{success}) {
+ my $error = "$res->{status} $res->{reason}, $uri";
+ $error .= ", $res->{content}" if $res->{status} == 599;
+ return { error => $error };
+ }
+
+ my @found;
+ for my $line ( split /\r?\n/, $res->{content} ) {
+ if ($line =~ /^$job->{package}\s+(\S+)\s+(\S+)$/) {
+ push @found, {
+ version => $1,
+ version_o => App::cpm::version->parse($1),
+ distfile => $2,
+ };
+ }
+ }
+
+ $found[-1]->{latest} = 1;
+
+ my $match;
+ for my $try (sort { $b->{version_o} <=> $a->{version_o} } @found) {
+ if ($try->{version_o}->satisfy($job->{version_range})) {
+ $match = $try, last;
+ }
+ }
+
+ if ($match) {
+ my $dist = App::cpm::DistNotation->new_from_dist($match->{distfile});
+ return {
+ source => "cpan",
+ package => $job->{package},
+ version => $match->{version},
+ uri => $dist->cpan_uri($self->{mirror}),
+ distfile => $dist->distfile,
+ };
+ } else {
+ return { error => "found versions @{[join ',', _uniq map $_->{version}, @found]}, but they do not satisfy $job->{version_range}, $uri" };
+ }
+ } else {
+ my $uri = "$self->{uri}package/$job->{package}";
+ my $res = $self->_get($uri);
+ if (!$res->{success}) {
+ my $error = "$res->{status} $res->{reason}, $uri";
+ $error .= ", $res->{content}" if $res->{status} == 599;
+ return { error => $error };
+ }
+
+ my $yaml = CPAN::Meta::YAML->read_string($res->{content});
+ my $meta = $yaml->[0];
+ if (!App::cpm::version->parse($meta->{version})->satisfy($job->{version_range})) {
+ return { error => "found version $meta->{version}, but it does not satisfy $job->{version_range}, $uri" };
+ }
+ my @provides = map {
+ my $package = $_;
+ my $version = $meta->{provides}{$_};
+ $version = undef if $version eq "undef";
+ +{ package => $package, version => $version };
+ } sort keys %{$meta->{provides}};
+
+ my $dist = App::cpm::DistNotation->new_from_dist($meta->{distfile});
+ return {
+ source => "cpan",
+ distfile => $dist->distfile,
+ uri => $dist->cpan_uri($self->{mirror}),
+ version => $meta->{version},
+ provides => \@provides,
+ };
+ }
+ return;
+}
+
+1;
--- /dev/null
+package App::cpm::Resolver::Snapshot;
+use strict;
+use warnings;
+
+use App::cpm::DistNotation;
+use App::cpm::version;
+use Carton::Snapshot;
+
+sub new {
+ my ($class, %option) = @_;
+ my $snapshot = Carton::Snapshot->new(path => $option{path} || "cpanfile.snapshot");
+ $snapshot->load;
+ my $mirror = $option{mirror} || "https://cpan.metacpan.org/";
+ $mirror =~ s{/*$}{/};
+ bless {
+ %option,
+ mirror => $mirror,
+ snapshot => $snapshot
+ }, $class;
+}
+
+sub snapshot { shift->{snapshot} }
+
+sub resolve {
+ my ($self, $job) = @_;
+ my $package = $job->{package};
+ my $found = $self->snapshot->find($package);
+ if (!$found) {
+ return { error => "not found, @{[$self->snapshot->path]}" };
+ }
+
+ my $version = $found->version_for($package);
+ if (my $version_range = $job->{version_range}) {
+ if (!App::cpm::version->parse($version)->satisfy($version_range)) {
+ return { error => "found version $version, but it does not satisfy $version_range, @{[$self->snapshot->path]}" };
+ }
+ }
+
+ my @provides = map {
+ my $package = $_;
+ my $version = $found->provides->{$_}{version};
+ +{ package => $package, version => $version };
+ } sort keys %{$found->provides};
+
+ my $dist = App::cpm::DistNotation->new_from_dist($found->distfile);
+ return {
+ source => "cpan",
+ distfile => $dist->distfile,
+ uri => $dist->cpan_uri($self->{mirror}),
+ version => $version || 0,
+ provides => \@provides,
+ };
+}
+
+1;
--- /dev/null
+package App::cpm::Tutorial;
+use strict;
+use warnings;
+
+1;
+__END__
+
+=head1 NAME
+
+App::cpm::Tutorial - How to use cpm
+
+=head1 SYNOPSIS
+
+ $ cpm install Module
+
+=head1 DESCRIPTION
+
+cpm is yet another CPAN client (like L<cpan>, L<cpanp>, and L<cpanm>),
+which is fast!
+
+=head2 How to install cpm
+
+From CPAN:
+
+ $ cpanm -nq App::cpm
+
+Or, download a I<self-contained> cpm:
+
+ $ curl -fsSL --compressed https://git.io/cpm > cpm
+ $ chmod +x cpm
+ $ ./cpm --version
+
+ # you can even install modules without installing cpm
+ $ curl -fsSL --compressed https://git.io/cpm | perl - install Plack
+
+=head2 First step
+
+ $ cpm install Plack
+
+This command installs Plack into C<./local>, and you can use it by
+
+ $ perl -I$PWD/local/lib/perl5 -MPlack -E 'say Plack->VERSION'
+
+If you want to install modules into current INC instead of C<./local>,
+then use C<--global/-g> option.
+
+ $ cpm install --global Plack
+
+By default, cpm outputs only C<DONE install Module> things.
+If you want more verbose messages, use C<--verbose/-v> option.
+
+ $ cpm install --verbose Plack
+
+=head2 Second step
+
+cpm can handle version range notation like L<cpanm>. Let's see some examples.
+
+ $ cpm install Plack~'> 1.000, <= 2.000'
+ $ cpm install Plack~'== 1.0030'
+ $ cpm install Plack@1.0030 # this is an alias of ~'== 1.0030'
+
+cpm can install dev releases (TRIAL releases).
+
+ $ cpm install Moose@dev
+
+ # if you prefer dev releases for not only Moose,
+ # but also its dependencies, then use global --dev option
+ $ cpm install --dev Moose
+
+And cpm can install modules from git repositories directly.
+
+ $ cpm install git://github.com/skaji/Carl.git
+
+=head2 cpanfile and dist/url/mirror/git syntax
+
+If you omit arguments, and there exists C<cpanfile> in the current directory,
+then cpm loads modules from cpanfile, and install them
+
+ $ cat cpanfile
+ requires 'Moose', '2.000';
+ requires 'Plack', '> 1.000, <= 2.000';
+ $ cpm install
+
+If you have C<cpanfile.snapshot>,
+then cpm tries to resolve distribution names from it
+
+ $ cpm install -v
+ 30186 DONE resolve (0.001sec) Plack -> Plack-1.0030 (from Snapshot)
+ ...
+
+cpm supports dist/url/mirror syntax in cpanfile just like cpanminus:
+
+ requires 'Path::Class', 0.26,
+ dist => "KWILLIAMS/Path-Class-0.26.tar.gz";
+
+ # use dist + mirror
+ requires 'Cookie::Baker',
+ dist => "KAZEBURO/Cookie-Baker-0.08.tar.gz",
+ mirror => "http://cpan.cpantesters.org/";
+
+ # use the full URL
+ requires 'Try::Tiny', 0.28,
+ url => "http://backpan.perl.org/authors/id/E/ET/ETHER/Try-Tiny-0.28.tar.gz";
+
+And yes, this is an experimental and fun part! cpm also supports git syntax in cpanfile.
+
+ requires 'Carl', git => 'git://github.com/skaji/Carl.git';
+ requires 'App::cpm', git => 'https://login:password@github.com/skaji/cpm.git';
+ requires 'Perl::PrereqDistributionGatherer',
+ git => 'https://github.com/skaji/Perl-PrereqDistributionGatherer',
+ ref => '3850305'; # ref can be revision/branch/tag
+
+Please note that to support git syntax in cpanfile wholly,
+there are several TODOs.
+
+=head2 Darkpan integration
+
+There are CPAN modules that create I<darkpans>
+(minicpan, CPAN mirror) such as L<CPAN::Mini>, L<OrePAN2>, L<Pinto>.
+
+Such darkpans store distribution tarballs in
+
+ DARKPAN/authors/id/A/AU/AUTHOR/Module-0.01.tar.gz
+
+and create the I<de facto standard> index file C<02packages.details.txt.gz> in
+
+ DARKPAN/modules/02packages.details.txt.gz
+
+If you want to use cpm against such darkpans,
+change the cpm resolver by C<--resolver/-r> option:
+
+ $ cpm install --resolver 02packages,http://example.com/darkpan Module
+ $ cpm install --resolver 02packages,file::///path/to/darkpan Module
+
+Sometimes, your darkpan is not whole CPAN mirror, but partial,
+so some modules are missing in it.
+Then append C<--resolver metadb> option to fall back to normal MetaDB resolver:
+
+ $ cpm install \
+ --resolver 02packages,http://example.com/darkpan \
+ --resolver metadb \
+ Module
+
+If you host your own darkmetadb for your own darkpan, you can use it too.
+Then append C<--resolver metadb> option to fall back to normal MetaDB resolver:
+
+ $ cpm install \
+ --resolver metadb,http://example.com/darkmetadb,http://example.com/darkpan \
+ --resolver metadb \
+ Module
+
+=cut
--- /dev/null
+package App::cpm::Util;
+use strict;
+use warnings;
+
+use Config;
+use Cwd ();
+use Digest::MD5 ();
+use File::Spec;
+
+use Exporter 'import';
+
+our @EXPORT_OK = qw(perl_identity maybe_abs WIN32 determine_home);
+
+use constant WIN32 => $^O eq 'MSWin32';
+
+sub perl_identity {
+ my $digest = Digest::MD5::md5_hex($Config{perlpath} . Config->myconfig);
+ $digest = substr $digest, 0, 8;
+ join '-', $Config{version}, $Config{archname}, $digest
+}
+
+sub maybe_abs {
+ my $path = shift;
+ if (File::Spec->file_name_is_absolute($path)) {
+ return $path;
+ }
+ my $cwd = shift || Cwd::cwd();
+ File::Spec->canonpath(File::Spec->catdir($cwd, $path));
+}
+
+sub determine_home { # taken from Menlo
+ my $homedir = $ENV{HOME}
+ || eval { require File::HomeDir; File::HomeDir->my_home }
+ || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
+
+ if (WIN32) {
+ require Win32; # no fatpack
+ $homedir = Win32::GetShortPathName($homedir);
+ }
+
+ File::Spec->catdir($homedir, ".perl-cpm");
+}
+
+1;
--- /dev/null
+package App::cpm::Worker;
+use strict;
+use warnings;
+
+use App::cpm::Logger::File;
+use App::cpm::Util;
+use App::cpm::Worker::Installer;
+use App::cpm::Worker::Resolver;
+use Config;
+use File::Path ();
+use File::Spec;
+use Time::HiRes qw(gettimeofday tv_interval);
+
+sub new {
+ my ($class, %option) = @_;
+ my $home = $option{home};
+ my $logger = $option{logger} || App::cpm::Logger::File->new("$home/build.log.@{[time]}");
+ my $prebuilt_base;
+ if ($option{prebuilt}) {
+ $prebuilt_base = $class->prebuilt_base($home);
+ File::Path::mkpath($prebuilt_base) if !-d $prebuilt_base;
+ my $file = "$prebuilt_base/version";
+ if (!-f $file) {
+ open my $fh, ">", $file or die "$file: $!";
+ print {$fh} "$Config{perlpath}\n";
+ }
+ }
+ %option = (
+ %option,
+ logger => $logger,
+ base => "$home/work/" . time . ".$$",
+ cache => "$home/cache",
+ $prebuilt_base ? (prebuilt_base => $prebuilt_base) : (),
+ );
+ my $installer = App::cpm::Worker::Installer->new(%option);
+ my $resolver = App::cpm::Worker::Resolver->new(%option, impl => $option{resolver});
+ bless { %option, installer => $installer, resolver => $resolver }, $class;
+}
+
+sub prebuilt_base {
+ my ($class, $home) = @_;
+ my $identity = App::cpm::Util::perl_identity;
+ File::Spec->catdir($home, "builds", $identity);
+}
+
+sub work {
+ my ($self, $job) = @_;
+ my $type = $job->{type} || "(undef)";
+ my $result;
+ my $start = $self->{verbose} ? [gettimeofday] : undef;
+ if (grep {$type eq $_} qw(fetch configure install)) {
+ $result = eval { $self->{installer}->work($job) };
+ warn $@ if $@;
+ } elsif ($type eq "resolve") {
+ $result = eval { $self->{resolver}->work($job) };
+ warn $@ if $@;
+ } else {
+ die "Unknown type: $type\n";
+ }
+ my $elapsed = $start ? tv_interval($start) : undef;
+ $result ||= { ok => 0 };
+ $job->merge({%$result, pid => $$, elapsed => $elapsed});
+ return $job;
+}
+
+1;
--- /dev/null
+package App::cpm::Worker::Installer;
+use strict;
+use warnings;
+
+use App::cpm::Logger::File;
+use App::cpm::Requirement;
+use App::cpm::Worker::Installer::Menlo;
+use App::cpm::Worker::Installer::Prebuilt;
+use App::cpm::version;
+use CPAN::DistnameInfo;
+use CPAN::Meta;
+use Config;
+use ExtUtils::Install ();
+use ExtUtils::InstallPaths ();
+use File::Basename 'basename';
+use File::Copy ();
+use File::Copy::Recursive ();
+use File::Path qw(mkpath rmtree);
+use File::Spec;
+use File::Temp ();
+use File::pushd 'pushd';
+use JSON::PP ();
+use Time::HiRes ();
+
+use constant NEED_INJECT_TOOLCHAIN_REQUIREMENTS => $] < 5.016;
+
+my $TRUSTED_MIRROR = sub {
+ my $uri = shift;
+ !!( $uri =~ m{^https?://(?:www.cpan.org|backpan.perl.org|cpan.metacpan.org)} );
+};
+
+sub work {
+ my ($self, $job) = @_;
+ my $type = $job->{type} || "(undef)";
+ local $self->{logger}{context} = $job->distvname;
+ if ($type eq "fetch") {
+ if (my $result = $self->fetch($job)) {
+ return +{
+ ok => 1,
+ directory => $result->{directory},
+ meta => $result->{meta},
+ requirements => $result->{requirements},
+ provides => $result->{provides},
+ using_cache => $result->{using_cache},
+ prebuilt => $result->{prebuilt},
+ };
+ } else {
+ $self->{logger}->log("Failed to fetch/configure distribution");
+ }
+ } elsif ($type eq "configure") {
+ # $job->{directory}, $job->{distfile}, $job->{meta});
+ if (my $result = $self->configure($job)) {
+ return +{
+ ok => 1,
+ distdata => $result->{distdata},
+ requirements => $result->{requirements},
+ static_builder => $result->{static_builder},
+ };
+ } else {
+ $self->{logger}->log("Failed to configure distribution");
+ }
+ } elsif ($type eq "install") {
+ my $ok = $self->install($job);
+ my $message = $ok ? "Successfully installed distribution" : "Failed to install distribution";
+ $self->{logger}->log($message);
+ return { ok => $ok, directory => $job->{directory} };
+ } else {
+ die "Unknown type: $type\n";
+ }
+ return { ok => 0 };
+}
+
+sub new {
+ my ($class, %option) = @_;
+ $option{logger} ||= App::cpm::Logger::File->new;
+ $option{base} or die "base option is required\n";
+ $option{cache} or die "cache option is required\n";
+ mkpath $_ for grep !-d, $option{base}, $option{cache};
+ $option{logger}->log("Work directory is $option{base}");
+
+ my $menlo = App::cpm::Worker::Installer::Menlo->new(
+ static_install => $option{static_install},
+ base => $option{base},
+ logger => $option{logger},
+ quiet => 1,
+ pod2man => $option{man_pages},
+ notest => $option{notest},
+ sudo => $option{sudo},
+ mirrors => ["https://cpan.metacpan.org/"], # this is dummy
+ configure_timeout => $option{configure_timeout},
+ build_timeout => $option{build_timeout},
+ test_timeout => $option{test_timeout},
+ );
+ if ($option{local_lib}) {
+ my $local_lib = $option{local_lib} = $menlo->maybe_abs($option{local_lib});
+ $menlo->{self_contained} = 1;
+ $menlo->log("Setup local::lib $local_lib");
+ $menlo->setup_local_lib($local_lib);
+ }
+ $menlo->log("--", `$^X -V`, "--");
+ $option{prebuilt} = App::cpm::Worker::Installer::Prebuilt->new if $option{prebuilt};
+ bless { %option, menlo => $menlo }, $class;
+}
+
+sub menlo { shift->{menlo} }
+
+sub _fetch_git {
+ my ($self, $uri, $ref) = @_;
+ my $basename = File::Basename::basename($uri);
+ $basename =~ s/\.git$//;
+ $basename =~ s/[^a-zA-Z0-9_.-]/-/g;
+ my $dir = File::Temp::tempdir(
+ "$basename-XXXXX",
+ CLEANUP => 0,
+ DIR => $self->menlo->{base},
+ );
+ $self->menlo->mask_output( diag_progress => "Cloning $uri" );
+ $self->menlo->run_command([ 'git', 'clone', $uri, $dir ]);
+
+ unless (-e "$dir/.git") {
+ $self->menlo->diag_fail("Failed cloning git repository $uri", 1);
+ return;
+ }
+ my $guard = pushd $dir;
+ if ($ref) {
+ unless ($self->menlo->run_command([ 'git', 'checkout', $ref ])) {
+ $self->menlo->diag_fail("Failed to checkout '$ref' in git repository $uri\n");
+ return;
+ }
+ }
+ $self->menlo->diag_ok;
+ chomp(my $rev = `git rev-parse --short HEAD`);
+ ($dir, $rev);
+}
+
+sub enable_prebuilt {
+ my ($self, $uri) = @_;
+ $self->{prebuilt} && !$self->{prebuilt}->skip($uri) && $TRUSTED_MIRROR->($uri);
+}
+
+sub fetch {
+ my ($self, $job) = @_;
+ my $guard = pushd;
+
+ my $source = $job->{source};
+ my $distfile = $job->{distfile};
+ my $uri = $job->{uri};
+
+ if ($self->enable_prebuilt($uri)) {
+ if (my $result = $self->find_prebuilt($uri)) {
+ $self->{logger}->log("Using prebuilt $result->{directory}");
+ return $result;
+ }
+ }
+
+ my ($dir, $rev, $using_cache);
+ if ($source eq "git") {
+ ($dir, $rev) = $self->_fetch_git($uri, $job->{ref});
+ } elsif ($source eq "local") {
+ $self->{logger}->log("Copying $uri");
+ $uri =~ s{^file://}{};
+ $uri = $self->menlo->maybe_abs($uri);
+ my $basename = basename $uri;
+ my $g = pushd $self->menlo->{base};
+ if (-d $uri) {
+ my $dest = File::Temp::tempdir(
+ "$basename-XXXXX",
+ CLEANUP => 0,
+ DIR => $self->menlo->{base},
+ );
+ File::Copy::Recursive::dircopy($uri, $dest);
+ $dir = $dest;
+ } elsif (-f $uri) {
+ my $dest = $basename;
+ File::Copy::copy($uri, $dest);
+ $dir = $self->menlo->unpack($basename);
+ $dir = File::Spec->catdir($self->menlo->{base}, $dir) if $dir;
+ }
+ } elsif ($source =~ /^(?:cpan|https?)$/) {
+ my $g = pushd $self->menlo->{base};
+
+ FETCH: {
+ my $basename = basename $uri;
+ if ($uri =~ s{^file://}{}) {
+ $self->{logger}->log("Copying $uri");
+ File::Copy::copy($uri, $basename)
+ or last FETCH;
+ $dir = $self->menlo->unpack($basename);
+ } else {
+ local $self->menlo->{save_dists};
+ if ($distfile and $TRUSTED_MIRROR->($uri)) {
+ my $cache = File::Spec->catfile($self->{cache}, "authors/id/$distfile");
+ if (-f $cache) {
+ $self->{logger}->log("Using cache $cache");
+ File::Copy::copy($cache, $basename);
+ $dir = $self->menlo->unpack($basename);
+ if ($dir) {
+ $using_cache++;
+ last FETCH;
+ }
+ unlink $cache;
+ }
+ $self->menlo->{save_dists} = $self->{cache};
+ }
+ $dir = $self->menlo->fetch_module({uris => [$uri], pathname => $distfile})
+ }
+ }
+ $dir = File::Spec->catdir($self->menlo->{base}, $dir) if $dir;
+ }
+ return unless $dir;
+
+ chdir $dir or die;
+
+ my $meta = $self->_load_metafile($distfile, 'META.json', 'META.yml');
+ if (!$meta) {
+ $self->{logger}->log("Distribution does not have META.json nor META.yml");
+ return;
+ }
+ my $p = $meta->{provides} || $self->menlo->extract_packages($meta, ".");
+ my $provides = [ map +{ package => $_, version => $p->{$_}{version} }, sort keys %$p ];
+
+ my $req = { configure => App::cpm::Requirement->new };
+ if ($self->menlo->opts_in_static_install($meta)) {
+ $self->{logger}->log("Distribution opts in x_static_install: $meta->{x_static_install}");
+ } else {
+ $req = { configure => $self->_extract_configure_requirements($meta, $distfile) };
+ }
+
+ return +{
+ directory => $dir,
+ meta => $meta,
+ requirements => $req,
+ provides => $provides,
+ using_cache => $using_cache,
+ };
+}
+
+sub find_prebuilt {
+ my ($self, $uri) = @_;
+ my $info = CPAN::DistnameInfo->new($uri);
+ my $dir = File::Spec->catdir($self->{prebuilt_base}, $info->cpanid, $info->distvname);
+ return unless -f File::Spec->catfile($dir, ".prebuilt");
+
+ my $guard = pushd $dir;
+
+ my $meta = $self->_load_metafile($uri, 'META.json', 'META.yml');
+ my $mymeta = $self->_load_metafile($uri, 'blib/meta/MYMETA.json');
+ my $phase = $self->{notest} ? [qw(build runtime)] : [qw(build test runtime)];
+
+ my %req;
+ if (!$self->menlo->opts_in_static_install($meta)) {
+ # XXX Actually we don't need configure requirements for prebuilt.
+ # But requires them for consistency for now.
+ %req = ( configure => $self->_extract_configure_requirements($meta, $uri) );
+ }
+ %req = (%req, %{$self->_extract_requirements($mymeta, $phase)});
+
+ my $provides = do {
+ open my $fh, "<", 'blib/meta/install.json' or die;
+ my $json = JSON::PP::decode_json(do { local $/; <$fh> });
+ my $provides = $json->{provides};
+ [ map +{ package => $_, version => $provides->{$_}{version} }, sort keys %$provides ];
+ };
+ return +{
+ directory => $dir,
+ meta => $meta->as_struct,
+ provides => $provides,
+ prebuilt => 1,
+ requirements => \%req,
+ };
+}
+
+sub save_prebuilt {
+ my ($self, $job) = @_;
+ my $dir = File::Spec->catdir($self->{prebuilt_base}, $job->cpanid, $job->distvname);
+
+ if (-d $dir and !File::Path::rmtree($dir)) {
+ return;
+ }
+
+ my $parent = File::Basename::dirname($dir);
+ for (1..3) {
+ last if -d $parent;
+ eval { File::Path::mkpath($parent) };
+ }
+ return unless -d $parent;
+
+ $self->{logger}->log("Saving the build $job->{directory} in $dir");
+ if (File::Copy::Recursive::dircopy($job->{directory}, $dir)) {
+ open my $fh, ">", File::Spec->catfile($dir, ".prebuilt") or die $!;
+ } else {
+ warn "dircopy $job->{directory} $dir: $!";
+ }
+}
+
+sub _inject_toolchain_requirements {
+ my ($self, $distfile, $requirement) = @_;
+ $distfile ||= "";
+
+ if ( -f "Makefile.PL"
+ and !$requirement->has('ExtUtils::MakeMaker')
+ and !-f "Build.PL"
+ and $distfile !~ m{/ExtUtils-MakeMaker-[0-9v]}
+ ) {
+ $requirement->add('ExtUtils::MakeMaker');
+ }
+ if ($requirement->has('Module::Build')) {
+ $requirement->add('ExtUtils::Install');
+ }
+
+ my %inject = (
+ 'Module::Build' => '0.38',
+ 'ExtUtils::MakeMaker' => '6.58',
+ 'ExtUtils::Install' => '1.46',
+ );
+
+ for my $package (sort keys %inject) {
+ $requirement->has($package) or next;
+ $requirement->add($package, $inject{$package});
+ }
+ $requirement;
+}
+
+sub _load_metafile {
+ my ($self, $distfile, @file) = @_;
+ my $meta;
+ if (my ($file) = grep -f, @file) {
+ $meta = eval { CPAN::Meta->load_file($file) };
+ $self->{logger}->log("Invalid $file: $@") if $@;
+ }
+
+ if (!$meta and $distfile) {
+ my $d = CPAN::DistnameInfo->new($distfile);
+ $meta = CPAN::Meta->new({name => $d->dist, version => $d->version});
+ }
+ $meta;
+}
+
+# XXX Assume current directory is distribution directory
+# because the test "-f Build.PL" or similar is present
+sub _extract_configure_requirements {
+ my ($self, $meta, $distfile) = @_;
+ my $requirement = $self->_extract_requirements($meta, [qw(configure)])->{configure};
+ if ($requirement->empty and -f "Build.PL" and ($distfile || "") !~ m{/Module-Build-[0-9v]}) {
+ $requirement->add("Module::Build" => "0.38");
+ }
+ if (NEED_INJECT_TOOLCHAIN_REQUIREMENTS) {
+ $self->_inject_toolchain_requirements($distfile, $requirement);
+ }
+ return $requirement;
+}
+
+sub _extract_requirements {
+ my ($self, $meta, $phases) = @_;
+ $phases = [$phases] unless ref $phases;
+ my $hash = $meta->effective_prereqs->as_string_hash;
+
+ my %req;
+ for my $phase (@$phases) {
+ my $req = App::cpm::Requirement->new;
+ my $from = ($hash->{$phase} || +{})->{requires} || +{};
+ for my $package (sort keys %$from) {
+ $req->add($package, $from->{$package});
+ }
+ $req{$phase} = $req;
+ }
+ \%req;
+}
+
+sub _retry {
+ my ($self, $sub) = @_;
+ return 1 if $sub->();
+ return unless $self->{retry};
+ Time::HiRes::sleep(0.1);
+ $self->{logger}->log("! Retrying (you can turn off this behavior by --no-retry)");
+ return $sub->();
+}
+
+sub configure {
+ my ($self, $job) = @_;
+ my ($dir, $distfile, $meta, $source) = @{$job}{qw(directory distfile meta source)};
+ my $guard = pushd $dir;
+ my $menlo = $self->menlo;
+ my $menlo_dist = { meta => $meta, cpanmeta => $meta }; # XXX
+
+ $self->{logger}->log("Configuring distribution");
+ my ($static_builder, $configure_ok);
+ {
+ if ($menlo->opts_in_static_install($meta)) {
+ my $state = {};
+ $menlo->static_install_configure($state, $menlo_dist, 1);
+ $static_builder = $state->{static_install};
+ ++$configure_ok and last;
+ }
+ if (-f 'Build.PL') {
+ my @cmd = ($menlo->{perl}, 'Build.PL');
+ push @cmd, '--pureperl-only' if $self->{pureperl_only};
+ $self->_retry(sub {
+ $menlo->configure(\@cmd, $menlo_dist, 1);
+ -f 'Build';
+ }) and ++$configure_ok and last;
+ }
+ if (-f 'Makefile.PL') {
+ my @cmd = ($menlo->{perl}, 'Makefile.PL');
+ push @cmd, 'PUREPERL_ONLY=1' if $self->{pureperl_only};
+ $self->_retry(sub {
+ $menlo->configure(\@cmd, $menlo_dist, 1); # XXX depth == 1?
+ -f 'Makefile';
+ }) and ++$configure_ok and last;
+ }
+ }
+ return unless $configure_ok;
+
+ my $distdata = $self->_build_distdata($source, $distfile, $meta);
+ my $phase = $self->{notest} ? [qw(build runtime)] : [qw(build test runtime)];
+ my $mymeta = $self->_load_metafile($distfile, 'MYMETA.json', 'MYMETA.yml');
+ my $req = $self->_extract_requirements($mymeta, $phase);
+ return +{
+ distdata => $distdata,
+ requirements => $req,
+ static_builder => $static_builder,
+ };
+}
+
+sub _build_distdata {
+ my ($self, $source, $distfile, $meta) = @_;
+
+ my $menlo = $self->menlo;
+ my $fake_state = { configured_ok => 1, use_module_build => -f "Build" };
+ my $module_name = $menlo->find_module_name($fake_state) || $meta->{name};
+ $module_name =~ s/-/::/g;
+
+ # XXX: if $source ne "cpan", then menlo->save_meta does nothing.
+ # Moreover, if $distfile is git url, CPAN::DistnameInfo->distvname returns undef.
+ # Then menlo->save_meta does nothing.
+ my $distvname = CPAN::DistnameInfo->new($distfile)->distvname;
+ my $provides = $meta->{provides} || $menlo->extract_packages($meta, ".");
+ +{
+ distvname => $distvname,
+ pathname => $distfile,
+ provides => $provides,
+ version => $meta->{version} || 0,
+ source => $source,
+ module_name => $module_name,
+ };
+}
+
+sub install {
+ my ($self, $job) = @_;
+ return $self->install_prebuilt($job) if $job->{prebuilt};
+
+ my ($dir, $distdata, $static_builder, $distvname, $meta)
+ = @{$job}{qw(directory distdata static_builder distvname meta)};
+ my $guard = pushd $dir;
+ my $menlo = $self->menlo;
+ my $menlo_dist = { meta => $meta }; # XXX
+
+ $self->{logger}->log("Building " . ($menlo->{notest} ? "" : "and testing ") . "distribution");
+ my $installed;
+ if ($static_builder) {
+ $menlo->build(sub { $static_builder->build }, $distvname, $menlo_dist)
+ && $menlo->test(sub { $static_builder->build("test") }, $distvname, $menlo_dist)
+ && $menlo->install(sub { $static_builder->build("install") }, [], $distvname, $menlo_dist)
+ && $installed++;
+ } elsif (-f 'Build') {
+ $self->_retry(sub { $menlo->build([ $menlo->{perl}, "./Build" ], $distvname, $menlo_dist) })
+ && $self->_retry(sub { $menlo->test([ $menlo->{perl}, "./Build", "test" ], $distvname, $menlo_dist) })
+ && $self->_retry(sub { $menlo->install([ $menlo->{perl}, "./Build", "install" ], [], $distvname, $menlo_dist) })
+ && $installed++;
+ } else {
+ $self->_retry(sub { $menlo->build([ $menlo->{make} ], $distvname, $menlo_dist) })
+ && $self->_retry(sub { $menlo->test([ $menlo->{make}, "test" ], $distvname, $menlo_dist) })
+ && $self->_retry(sub { $menlo->install([ $menlo->{make}, "install" ], [], $distvname, $menlo_dist) })
+ && $installed++;
+ }
+
+ if ($installed && $distdata) {
+ $menlo->save_meta(
+ $distdata->{module_name},
+ $distdata,
+ $distdata->{module_name},
+ );
+ $self->save_prebuilt($job) if $self->enable_prebuilt($job->{uri});
+ }
+ return $installed;
+}
+
+sub install_prebuilt {
+ my ($self, $job) = @_;
+
+ my $install_base = $self->{local_lib};
+ if (!$install_base && ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=(\S+)/) {
+ $install_base = $1;
+ }
+
+ $self->{logger}->log("Copying prebuilt $job->{directory}/blib");
+ my $guard = pushd $job->{directory};
+ my $paths = ExtUtils::InstallPaths->new(
+ dist_name => $job->distname, # this enables the installation of packlist
+ $install_base ? (install_base => $install_base) : (),
+ );
+ my $install_base_meta = $install_base ? "$install_base/lib/perl5" : $Config{sitelibexp};
+ my $distvname = $job->distvname;
+ open my $fh, ">", \my $stdout;
+ {
+ local *STDOUT = $fh;
+ ExtUtils::Install::install([
+ from_to => $paths->install_map,
+ verbose => 0,
+ dry_run => 0,
+ uninstall_shadows => 0,
+ skip => undef,
+ always_copy => 1,
+ result => \my %result,
+ ]);
+ ExtUtils::Install::install({
+ 'blib/meta' => "$install_base_meta/$Config{archname}/.meta/$distvname",
+ });
+ }
+ $self->{logger}->log($stdout);
+ return 1;
+}
+
+1;
--- /dev/null
+package App::cpm::Worker::Installer::Menlo;
+use strict;
+use warnings;
+
+use parent 'Menlo::CLI::Compat';
+
+use App::cpm::HTTP;
+use App::cpm::Installer::Unpacker;
+use App::cpm::Logger::File;
+use App::cpm::Util 'WIN32';
+use Command::Runner;
+use Config;
+use File::Which ();
+use Menlo::Builder::Static;
+
+sub new {
+ my ($class, %option) = @_;
+ $option{log} ||= $option{logger}->file;
+ my $self = $class->SUPER::new(%option);
+
+ if ($self->{make} = File::Which::which($Config{make})) {
+ $self->{logger}->log("You have make $self->{make}");
+ }
+ {
+ my ($http, $desc) = App::cpm::HTTP->create;
+ $self->{http} = $http;
+ $self->{logger}->log("You have $desc");
+ }
+ {
+ $self->{unpacker} = App::cpm::Installer::Unpacker->new;
+ my $desc = $self->{unpacker}->describe;
+ for my $key (sort keys %$desc) {
+ $self->{logger}->log("You have $key $desc->{$key}");
+ }
+ }
+
+ $self->{initialized} = 1; # XXX
+
+ $self;
+}
+
+sub unpack {
+ my ($self, $file) = @_;
+ $self->{logger}->log("Unpacking $file");
+ my ($dir, $err) = $self->{unpacker}->unpack($file);
+ $self->{logger}->log($err) if !$dir && $err;
+ $dir;
+}
+
+sub log {
+ my $self = shift;
+ $self->{logger}->log(@_);
+}
+
+sub run_command {
+ my ($self, $cmd) = @_;
+ $self->run_timeout($cmd, 0);
+
+}
+
+sub run_timeout {
+ my ($self, $cmd, $timeout) = @_;
+
+ my $str = ref $cmd eq 'CODE' ? '' : ref $cmd eq 'ARRAY' ? "@$cmd" : $cmd;
+ $self->{logger}->log("Executing $str") if $str;
+
+ my $runner = Command::Runner->new(
+ command => $cmd,
+ keep => 0,
+ redirect => 1,
+ timeout => $timeout,
+ stdout => sub { $self->log(@_) },
+ );
+ my $res = $runner->run;
+ if ($res->{timeout}) {
+ $self->diag_fail("Timed out (> ${timeout}s).");
+ return;
+ }
+ my $result = $res->{result};
+ ref $cmd eq 'CODE' ? $result : $result == 0;
+}
+
+1;
--- /dev/null
+package App::cpm::Worker::Installer::Prebuilt;
+use strict;
+use warnings;
+
+my @SKIP = (
+ qr{/XML-SAX-v?[0-9\.]+\.tar\.gz$},
+);
+
+sub new {
+ my $class = shift;
+ bless {}, $class;
+}
+
+sub skip {
+ my ($self, $uri) = @_;
+ !!grep { $uri =~ $_ } @SKIP;
+}
+
+1;
--- /dev/null
+package App::cpm::Worker::Resolver;
+use strict;
+use warnings;
+
+use App::cpm::Logger::File;
+
+sub new {
+ my ($class, %option) = @_;
+ my $logger = $option{logger} || App::cpm::Logger::File->new;
+ bless { impl => $option{impl}, logger => $logger }, $class;
+}
+
+sub work {
+ my ($self, $job) = @_;
+
+ local $self->{logger}->{context} = $job->{package};
+ my $result = $self->{impl}->resolve($job);
+ if ($result and !$result->{error}) {
+ $result->{ok} = 1;
+ my $msg = sprintf "Resolved %s (%s) -> %s", $job->{package}, $job->{version_range} || 0,
+ $result->{uri} . ($result->{from} ? " from $result->{from}" : "");
+ $self->{logger}->log($msg);
+ return $result;
+ } else {
+ $self->{logger}->log($result->{error}) if $result and $result->{error};
+ $self->{logger}->log(sprintf "Failed to resolve %s", $job->{package});
+ return { ok => 0 };
+ }
+}
+
+1;
--- /dev/null
+package App::cpm::version;
+use strict;
+use warnings;
+
+use CPAN::Meta::Requirements;
+
+use parent 'version';
+
+sub satisfy {
+ my ($self, $version_range) = @_;
+
+ return 1 unless $version_range;
+ return $self >= (ref $self)->parse($version_range) if $version_range =~ /^v?[\d_.]+$/;
+
+ my $requirements = CPAN::Meta::Requirements->new;
+ $requirements->add_string_requirement('DummyModule', $version_range);
+ $requirements->accepts_module('DummyModule', $self->numify);
+}
+
+# suppress warnings
+# > perl -Mwarnings -Mversion -e 'print version->parse("1.02_03")->numify'
+# alpha->numify() is lossy at -e line 1.
+# 1.020300
+sub numify {
+ local $SIG{__WARN__} = sub {};
+ shift->SUPER::numify(@_);
+}
+sub parse {
+ local $SIG{__WARN__} = sub {};
+ shift->SUPER::parse(@_);
+}
+
+# utility function
+sub range_merge {
+ my ($range1, $range2) = @_;
+ my $req = CPAN::Meta::Requirements->new;
+ $req->add_string_requirement('DummyModule', $_) for $range1, $range2; # may die
+ $req->requirements_for_module('DummyModule');
+}
+
+1;
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package CPAN::Common::Index;
+# ABSTRACT: Common library for searching CPAN modules, authors and distributions
+
+our $VERSION = '0.010';
+
+use Carp ();
+
+use Class::Tiny;
+
+#--------------------------------------------------------------------------#
+# Document abstract methods
+#--------------------------------------------------------------------------#
+
+#pod =method search_packages (ABSTRACT)
+#pod
+#pod $result = $index->search_packages( { package => "Moose" });
+#pod @result = $index->search_packages( \%advanced_query );
+#pod
+#pod Searches the index for a package such as listed in the CPAN
+#pod F<02packages.details.txt> file. The query must be provided as a hash
+#pod reference. Valid keys are
+#pod
+#pod =for :list
+#pod * package -- a string, regular expression or code reference
+#pod * version -- a version number or code reference
+#pod * dist -- a string, regular expression or code reference
+#pod
+#pod If the query term is a string or version number, the query will be for an exact
+#pod match. If a code reference, the code will be called with the value of the
+#pod field for each potential match. It should return true if it matches.
+#pod
+#pod Not all backends will implement support for all fields or all types of queries.
+#pod If it does not implement either, it should "decline" the query with an empty
+#pod return.
+#pod
+#pod The return should be context aware, returning either a
+#pod single result or a list of results.
+#pod
+#pod The result must be formed as follows:
+#pod
+#pod {
+#pod package => 'MOOSE',
+#pod version => '2.0802',
+#pod uri => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
+#pod }
+#pod
+#pod The C<uri> field should be a valid URI. It may be a L<URI::cpan> or any other
+#pod URI. (It is up to a client to do something useful with any given URI scheme.)
+#pod
+#pod =method search_authors (ABSTRACT)
+#pod
+#pod $result = $index->search_authors( { id => "DAGOLDEN" });
+#pod @result = $index->search_authors( \%advanced_query );
+#pod
+#pod Searches the index for author data such as from the CPAN F<01mailrc.txt> file.
+#pod The query must be provided as a hash reference. Valid keys are
+#pod
+#pod =for :list
+#pod * id -- a string, regular expression or code reference
+#pod * fullname -- a string, regular expression or code reference
+#pod * email -- a string, regular expression or code reference
+#pod
+#pod If the query term is a string, the query will be for an exact match. If a code
+#pod reference, the code will be called with the value of the field for each
+#pod potential match. It should return true if it matches.
+#pod
+#pod Not all backends will implement support for all fields or all types of queries.
+#pod If it does not implement either, it should "decline" the query with an empty
+#pod return.
+#pod
+#pod The return should be context aware, returning either a single result or a list
+#pod of results.
+#pod
+#pod The result must be formed as follows:
+#pod
+#pod {
+#pod id => 'DAGOLDEN',
+#pod fullname => 'David Golden',
+#pod email => 'dagolden@cpan.org',
+#pod }
+#pod
+#pod The C<email> field may not reflect an actual email address. The 01mailrc file
+#pod on CPAN often shows "CENSORED" when email addresses are concealed.
+#pod
+#pod =cut
+
+#--------------------------------------------------------------------------#
+# stub methods
+#--------------------------------------------------------------------------#
+
+#pod =method index_age
+#pod
+#pod $epoch = $index->index_age;
+#pod
+#pod Returns the modification time of the index in epoch seconds. This may not make sense
+#pod for some backends. By default it returns the current time.
+#pod
+#pod =cut
+
+sub index_age { time }
+
+#pod =method refresh_index
+#pod
+#pod $index->refresh_index;
+#pod
+#pod This ensures the index source is up to date. For example, a remote
+#pod mirror file would be re-downloaded. By default, it does nothing.
+#pod
+#pod =cut
+
+sub refresh_index { 1 }
+
+#pod =method attributes
+#pod
+#pod Return attributes and default values as a hash reference. By default
+#pod returns an empty hash reference.
+#pod
+#pod =cut
+
+sub attributes { {} }
+
+#pod =method validate_attributes
+#pod
+#pod $self->validate_attributes;
+#pod
+#pod This is called by the constructor to validate any arguments. Subclasses
+#pod should override the default one to perform validation. It should not be
+#pod called by application code. By default, it does nothing.
+#pod
+#pod =cut
+
+sub validate_attributes { 1 }
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Common::Index - Common library for searching CPAN modules, authors and distributions
+
+=head1 VERSION
+
+version 0.010
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::Mux::Ordered;
+ use Data::Dumper;
+
+ $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ MetaDB => {},
+ Mirror => { mirror => "http://cpan.cpantesters.org" },
+ );
+
+ $result = $index->search_packages( { package => "Moose" } );
+
+ print Dumper($result);
+
+ # {
+ # package => 'MOOSE',
+ # version => '2.0802',
+ # uri => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
+ # }
+
+=head1 DESCRIPTION
+
+This module provides a common library for working with a variety of CPAN index
+services. It is intentionally minimalist, trying to use as few non-core
+modules as possible.
+
+The C<CPAN::Common::Index> module is an abstract base class that defines a
+common API. Individual backends deliver the API for a particular index.
+
+As shown in the SYNOPSIS, one interesting application is multiplexing -- using
+different index backends, querying each in turn, and returning the first
+result.
+
+=head1 METHODS
+
+=head2 search_packages (ABSTRACT)
+
+ $result = $index->search_packages( { package => "Moose" });
+ @result = $index->search_packages( \%advanced_query );
+
+Searches the index for a package such as listed in the CPAN
+F<02packages.details.txt> file. The query must be provided as a hash
+reference. Valid keys are
+
+=over 4
+
+=item *
+
+package -- a string, regular expression or code reference
+
+=item *
+
+version -- a version number or code reference
+
+=item *
+
+dist -- a string, regular expression or code reference
+
+=back
+
+If the query term is a string or version number, the query will be for an exact
+match. If a code reference, the code will be called with the value of the
+field for each potential match. It should return true if it matches.
+
+Not all backends will implement support for all fields or all types of queries.
+If it does not implement either, it should "decline" the query with an empty
+return.
+
+The return should be context aware, returning either a
+single result or a list of results.
+
+The result must be formed as follows:
+
+ {
+ package => 'MOOSE',
+ version => '2.0802',
+ uri => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
+ }
+
+The C<uri> field should be a valid URI. It may be a L<URI::cpan> or any other
+URI. (It is up to a client to do something useful with any given URI scheme.)
+
+=head2 search_authors (ABSTRACT)
+
+ $result = $index->search_authors( { id => "DAGOLDEN" });
+ @result = $index->search_authors( \%advanced_query );
+
+Searches the index for author data such as from the CPAN F<01mailrc.txt> file.
+The query must be provided as a hash reference. Valid keys are
+
+=over 4
+
+=item *
+
+id -- a string, regular expression or code reference
+
+=item *
+
+fullname -- a string, regular expression or code reference
+
+=item *
+
+email -- a string, regular expression or code reference
+
+=back
+
+If the query term is a string, the query will be for an exact match. If a code
+reference, the code will be called with the value of the field for each
+potential match. It should return true if it matches.
+
+Not all backends will implement support for all fields or all types of queries.
+If it does not implement either, it should "decline" the query with an empty
+return.
+
+The return should be context aware, returning either a single result or a list
+of results.
+
+The result must be formed as follows:
+
+ {
+ id => 'DAGOLDEN',
+ fullname => 'David Golden',
+ email => 'dagolden@cpan.org',
+ }
+
+The C<email> field may not reflect an actual email address. The 01mailrc file
+on CPAN often shows "CENSORED" when email addresses are concealed.
+
+=head2 index_age
+
+ $epoch = $index->index_age;
+
+Returns the modification time of the index in epoch seconds. This may not make sense
+for some backends. By default it returns the current time.
+
+=head2 refresh_index
+
+ $index->refresh_index;
+
+This ensures the index source is up to date. For example, a remote
+mirror file would be re-downloaded. By default, it does nothing.
+
+=head2 attributes
+
+Return attributes and default values as a hash reference. By default
+returns an empty hash reference.
+
+=head2 validate_attributes
+
+ $self->validate_attributes;
+
+This is called by the constructor to validate any arguments. Subclasses
+should override the default one to perform validation. It should not be
+called by application code. By default, it does nothing.
+
+=for Pod::Coverage method_names_here
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index>
+
+ git clone https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index.git
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 CONTRIBUTORS
+
+=for stopwords David Golden Helmut Wollmersdorfer Kenichi Ishigaki Shoichi Kaji Tatsuhiko Miyagawa
+
+=over 4
+
+=item *
+
+David Golden <xdg@xdg.me>
+
+=item *
+
+Helmut Wollmersdorfer <helmut@wollmersdorfer.at>
+
+=item *
+
+Kenichi Ishigaki <ishigaki@cpan.org>
+
+=item *
+
+Shoichi Kaji <skaji@cpan.org>
+
+=item *
+
+Tatsuhiko Miyagawa <miyagawa@bulknews.net>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package CPAN::Common::Index::LocalPackage;
+# ABSTRACT: Search index via custom local CPAN package flatfile
+
+our $VERSION = '0.010';
+
+use parent 'CPAN::Common::Index::Mirror';
+
+use Class::Tiny qw/source/;
+
+use Carp;
+use File::Basename ();
+use File::Copy ();
+use File::Spec;
+use File::stat ();
+
+#pod =attr source (REQUIRED)
+#pod
+#pod Path to a local file in the form of 02packages.details.txt. It may
+#pod be compressed with a ".gz" suffix or it may be uncompressed.
+#pod
+#pod =attr cache
+#pod
+#pod Path to a local directory to store a (possibly uncompressed) copy
+#pod of the source index. Defaults to a temporary directory if not
+#pod specified.
+#pod
+#pod =cut
+
+sub BUILD {
+ my $self = shift;
+
+ my $file = $self->source;
+ if ( !defined $file ) {
+ Carp::croak("'source' parameter must be provided");
+ }
+ elsif ( !-f $file ) {
+ Carp::croak("index file '$file' does not exist");
+ }
+
+ return;
+}
+
+sub cached_package {
+ my ($self) = @_;
+ my $package = File::Spec->catfile(
+ $self->cache, File::Basename::basename($self->source)
+ );
+ $package =~ s/\.gz$//;
+ $self->refresh_index unless -r $package;
+ return $package;
+}
+
+sub refresh_index {
+ my ($self) = @_;
+ my $source = $self->source;
+ my $basename = File::Basename::basename($source);
+ if ( $source =~ /\.gz$/ ) {
+ Carp::croak "can't load gz source files without IO::Uncompress::Gunzip\n"
+ unless $CPAN::Common::Index::Mirror::HAS_IO_UNCOMPRESS_GUNZIP;
+ ( my $uncompressed = $basename ) =~ s/\.gz$//;
+ $uncompressed = File::Spec->catfile( $self->cache, $uncompressed );
+ if ( !-f $uncompressed
+ or File::stat::stat($source)->mtime > File::stat::stat($uncompressed)->mtime ) {
+ no warnings 'once';
+ IO::Uncompress::Gunzip::gunzip( map { "$_" } $source, $uncompressed )
+ or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
+ }
+ }
+ else {
+ my $dest = File::Spec->catfile( $self->cache, $basename );
+ File::Copy::copy($source, $dest)
+ if !-e $dest || File::stat::stat($source)->mtime > File::stat::stat($dest)->mtime;
+ }
+ return 1;
+}
+
+sub search_authors { return }; # this package handles packages only
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Common::Index::LocalPackage - Search index via custom local CPAN package flatfile
+
+=head1 VERSION
+
+version 0.010
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::LocalPackage;
+
+ $index = CPAN::Common::Index::LocalPackage->new(
+ { source => "mypackages.details.txt" }
+ );
+
+=head1 DESCRIPTION
+
+This module implements a CPAN::Common::Index that searches for packages in a local
+index file in the same form as the CPAN 02packages.details.txt file.
+
+There is no support for searching on authors.
+
+=head1 ATTRIBUTES
+
+=head2 source (REQUIRED)
+
+Path to a local file in the form of 02packages.details.txt. It may
+be compressed with a ".gz" suffix or it may be uncompressed.
+
+=head2 cache
+
+Path to a local directory to store a (possibly uncompressed) copy
+of the source index. Defaults to a temporary directory if not
+specified.
+
+=for Pod::Coverage attributes validate_attributes search_packages search_authors
+cached_package BUILD
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package CPAN::Common::Index::MetaDB;
+# ABSTRACT: Search index via CPAN MetaDB
+
+our $VERSION = '0.010';
+
+use parent 'CPAN::Common::Index';
+
+use Class::Tiny qw/uri/;
+
+use Carp;
+use CPAN::Meta::YAML;
+use HTTP::Tiny;
+
+#pod =attr uri
+#pod
+#pod A URI for the endpoint of a CPAN MetaDB server. The
+#pod default is L<http://cpanmetadb.plackperl.org/v1.0/>.
+#pod
+#pod =cut
+
+sub BUILD {
+ my $self = shift;
+ my $uri = $self->uri;
+ $uri = "http://cpanmetadb.plackperl.org/v1.0/"
+ unless defined $uri;
+ # ensure URI ends in '/'
+ $uri =~ s{/?$}{/};
+ $self->uri($uri);
+ return;
+}
+
+sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+
+ # only support direct package query
+ return
+ unless keys %$args == 1 && exists $args->{package} && ref $args->{package} eq '';
+
+ my $mod = $args->{package};
+ my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
+ return unless $res->{success};
+
+ if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
+ my $meta = $yaml->[0];
+ if ( $meta && $meta->{distfile} ) {
+ my $file = $meta->{distfile};
+ $file =~ s{^./../}{}; # strip leading
+ return {
+ package => $mod,
+ version => $meta->{version},
+ uri => "cpan:///distfile/$file",
+ };
+ }
+ }
+
+ return;
+}
+
+sub index_age { return time }; # pretend always current
+
+sub search_authors { return }; # not supported
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Common::Index::MetaDB - Search index via CPAN MetaDB
+
+=head1 VERSION
+
+version 0.010
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::MetaDB;
+
+ $index = CPAN::Common::Index::MetaDB->new;
+
+=head1 DESCRIPTION
+
+This module implements a CPAN::Common::Index that searches for packages against
+the same CPAN MetaDB API used by L<cpanminus>.
+
+There is no support for advanced package queries or searching authors. It just
+takes a package name and returns the corresponding version and distribution.
+
+=head1 ATTRIBUTES
+
+=head2 uri
+
+A URI for the endpoint of a CPAN MetaDB server. The
+default is L<http://cpanmetadb.plackperl.org/v1.0/>.
+
+=for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package CPAN::Common::Index::Mirror;
+# ABSTRACT: Search index via CPAN mirror flatfiles
+
+our $VERSION = '0.010';
+
+use parent 'CPAN::Common::Index';
+
+use Class::Tiny qw/cache mirror/;
+
+use Carp;
+use CPAN::DistnameInfo;
+use File::Basename ();
+use File::Fetch;
+use File::Temp 0.19; # newdir
+use Search::Dict 1.07;
+use Tie::Handle::SkipHeader;
+use URI;
+
+our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
+
+#pod =attr mirror
+#pod
+#pod URI to a CPAN mirror. Defaults to C<http://www.cpan.org/>.
+#pod
+#pod =attr cache
+#pod
+#pod Path to a local directory to store copies of the source indices. Defaults to a
+#pod temporary directory if not specified.
+#pod
+#pod =cut
+
+sub BUILD {
+ my $self = shift;
+
+ # cache directory needs to exist
+ my $cache = $self->cache;
+ $cache = File::Temp->newdir
+ unless defined $cache;
+ if ( !-d $cache ) {
+ Carp::croak("Cache directory '$cache' does not exist");
+ }
+ $self->cache($cache);
+
+ # ensure mirror URL ends in '/'
+ my $mirror = $self->mirror;
+ $mirror = "http://www.cpan.org/"
+ unless defined $mirror;
+ $mirror =~ s{/?$}{/};
+ $self->mirror($mirror);
+
+ return;
+}
+
+my %INDICES = (
+ mailrc => 'authors/01mailrc.txt.gz',
+ packages => 'modules/02packages.details.txt.gz',
+);
+
+# XXX refactor out from subs below
+my %TEST_GENERATORS = (
+ regexp_nocase => sub {
+ my $arg = shift;
+ my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/i;
+ return sub { $_[0] =~ $re };
+ },
+ regexp => sub {
+ my $arg = shift;
+ my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/;
+ return sub { $_[0] =~ $re };
+ },
+ version => sub {
+ my $arg = shift;
+ my $v = version->parse($arg);
+ return sub {
+ eval { version->parse( $_[0] ) == $v };
+ };
+ },
+);
+
+my %QUERY_TYPES = (
+ # package search
+ package => 'regexp',
+ version => 'version',
+ dist => 'regexp',
+
+ # author search
+ id => 'regexp_nocase', # XXX need to add "alias " first
+ fullname => 'regexp_nocase',
+ email => 'regexp_nocase',
+);
+
+sub cached_package {
+ my ($self) = @_;
+ my $package = File::Spec->catfile( $self->cache,
+ File::Basename::basename( $INDICES{packages} ) );
+ $package =~ s/\.gz$//;
+ $self->refresh_index unless -r $package;
+ return $package;
+}
+
+sub cached_mailrc {
+ my ($self) = @_;
+ my $mailrc =
+ File::Spec->catfile( $self->cache, File::Basename::basename( $INDICES{mailrc} ) );
+ $mailrc =~ s/\.gz$//;
+ $self->refresh_index unless -r $mailrc;
+ return $mailrc;
+}
+
+sub refresh_index {
+ my ($self) = @_;
+ for my $file ( values %INDICES ) {
+ my $remote = URI->new_abs( $file, $self->mirror );
+ $remote =~ s/\.gz$//
+ unless $HAS_IO_UNCOMPRESS_GUNZIP;
+ my $ff = File::Fetch->new( uri => $remote );
+ my $where = $ff->fetch( to => $self->cache )
+ or Carp::croak( $ff->error );
+ if ($HAS_IO_UNCOMPRESS_GUNZIP) {
+ ( my $uncompressed = $where ) =~ s/\.gz$//;
+ no warnings 'once';
+ IO::Uncompress::Gunzip::gunzip( $where, $uncompressed )
+ or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
+ }
+ }
+ return 1;
+}
+
+# epoch secs
+sub index_age {
+ my ($self) = @_;
+ my $package = $self->cached_package;
+ return ( -r $package ? ( stat($package) )[9] : 0 ); # mtime if readable
+}
+
+sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+
+ my $index_path = $self->cached_package;
+ die "Can't read $index_path" unless -r $index_path;
+
+ my $fh = IO::Handle->new;
+ tie *$fh, 'Tie::Handle::SkipHeader', "<", $index_path
+ or die "Can't tie $index_path: $!";
+
+ # Convert scalars or regexps to subs
+ my $rules;
+ while ( my ( $k, $v ) = each %$args ) {
+ $rules->{$k} = _rulify( $k, $v );
+ }
+
+ my @found;
+ if ( $args->{package} and ref $args->{package} eq '' ) {
+ # binary search 02packages on package
+ my $pos = look $fh, $args->{package}, { xfrm => \&_xform_package, fold => 1 };
+ return if $pos == -1;
+ # loop over any case-insensitive matching lines
+ LINE: while ( my $line = <$fh> ) {
+ last unless $line =~ /\A\Q$args->{package}\E\s+/i;
+ push @found, _match_package_line( $line, $rules );
+ }
+ }
+ else {
+ # iterate all lines looking for match
+ LINE: while ( my $line = <$fh> ) {
+ push @found, _match_package_line( $line, $rules );
+ }
+ }
+ return wantarray ? @found : $found[0];
+}
+
+sub search_authors {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_authors must be hash reference")
+ unless ref $args eq 'HASH';
+
+ my $index_path = $self->cached_mailrc;
+ die "Can't read $index_path" unless -r $index_path;
+ open my $fh, $index_path or die "Can't open $index_path: $!";
+
+ # Convert scalars or regexps to subs
+ my $rules;
+ while ( my ( $k, $v ) = each %$args ) {
+ $rules->{$k} = _rulify( $k, $v );
+ }
+
+ my @found;
+ if ( $args->{id} and ref $args->{id} eq '' ) {
+ # binary search mailrec on package
+ my $pos = look $fh, $args->{id}, { xfrm => \&_xform_mailrc, fold => 1 };
+ return if $pos == -1;
+ my $line = <$fh>;
+ push @found, _match_mailrc_line( $line, $rules );
+ }
+ else {
+ # iterate all lines looking for match
+ LINE: while ( my $line = <$fh> ) {
+ push @found, _match_mailrc_line( $line, $rules );
+ }
+ }
+ return wantarray ? @found : $found[0];
+}
+
+sub _rulify {
+ my ( $key, $arg ) = @_;
+ return $arg if ref($arg) eq 'CODE';
+ return $TEST_GENERATORS{ $QUERY_TYPES{$key} }->($arg);
+}
+
+sub _xform_package {
+ my @fields = split " ", $_[0], 2;
+ return $fields[0];
+}
+
+sub _xform_mailrc {
+ my @fields = split " ", $_[0], 3;
+ return $fields[1];
+}
+
+sub _match_package_line {
+ my ( $line, $rules ) = @_;
+ return unless defined $line;
+ my ( $mod, $version, $dist, $comment ) = split " ", $line, 4;
+ if ( $rules->{package} ) {
+ return unless $rules->{package}->($mod);
+ }
+ if ( $rules->{version} ) {
+ return unless $rules->{version}->($version);
+ }
+ if ( $rules->{dist} ) {
+ return unless $rules->{dist}->($dist);
+ }
+ $dist =~ s{\A./../}{};
+ return {
+ package => $mod,
+ version => $version,
+ uri => "cpan:///distfile/$dist",
+ };
+}
+
+sub _match_mailrc_line {
+ my ( $line, $rules ) = @_;
+ return unless defined $line;
+ my ( $id, $address ) = $line =~ m{\Aalias\s+(\S+)\s+"(.*)"};
+ my ( $fullname, $email ) = $address =~ m{([^<]+)<([^>]+)>};
+ $fullname =~ s/\s*$//;
+ if ( $rules->{id} ) {
+ return unless $rules->{id}->($id);
+ }
+ if ( $rules->{fullname} ) {
+ return unless $rules->{fullname}->($fullname);
+ }
+ if ( $rules->{email} ) {
+ return unless $rules->{email}->($email);
+ }
+ return {
+ id => $id,
+ fullname => $fullname,
+ email => $email,
+ };
+}
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Common::Index::Mirror - Search index via CPAN mirror flatfiles
+
+=head1 VERSION
+
+version 0.010
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::Mirror;
+
+ # default mirror is http://www.cpan.org/
+ $index = CPAN::Common::Index::Mirror->new;
+
+ # custom mirror
+ $index = CPAN::Common::Index::Mirror->new(
+ { mirror => "http://cpan.cpantesters.org" }
+ );
+
+=head1 DESCRIPTION
+
+This module implements a CPAN::Common::Index that retrieves and searches
+02packages.details.txt and 01mailrc.txt indices.
+
+The default mirror is L<http://www.cpan.org/>. This is a globally balanced
+fast mirror and is a great choice if you don't have a local fast mirror.
+
+=head1 ATTRIBUTES
+
+=head2 mirror
+
+URI to a CPAN mirror. Defaults to C<http://www.cpan.org/>.
+
+=head2 cache
+
+Path to a local directory to store copies of the source indices. Defaults to a
+temporary directory if not specified.
+
+=for Pod::Coverage attributes validate_attributes search_packages search_authors
+cached_package cached_mailrc BUILD
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package CPAN::Common::Index::Mux::Ordered;
+# ABSTRACT: Consult indices in order and return the first result
+
+our $VERSION = '0.010';
+
+use parent 'CPAN::Common::Index';
+
+use Class::Tiny qw/resolvers/;
+
+use Module::Load ();
+
+#pod =attr resolvers
+#pod
+#pod An array reference of CPAN::Common::Index::* objects
+#pod
+#pod =cut
+
+sub BUILD {
+ my $self = shift;
+
+ my $resolvers = $self->resolvers;
+ $resolvers = [] unless defined $resolvers;
+ if ( ref $resolvers ne 'ARRAY' ) {
+ Carp::croak("The 'resolvers' argument must be an array reference");
+ }
+ for my $r (@$resolvers) {
+ if ( !eval { $r->isa("CPAN::Common::Index") } ) {
+ Carp::croak("Resolver '$r' is not a CPAN::Common::Index object");
+ }
+ }
+ $self->resolvers($resolvers);
+
+ return;
+}
+
+#pod =method assemble
+#pod
+#pod $index = CPAN::Common::Index::Mux::Ordered->assemble(
+#pod MetaDB => {},
+#pod Mirror => { mirror => "http://www.cpan.org" },
+#pod );
+#pod
+#pod This class method provides a shorthand for constructing a multiplexer.
+#pod The arguments must be pairs of subclass suffixes and arguments. For
+#pod example, "MetaDB" means to use "CPAN::Common::Index::MetaDB". Empty
+#pod arguments must be given as an empty hash reference.
+#pod
+#pod =cut
+
+sub assemble {
+ my ( $class, @backends ) = @_;
+
+ my @resolvers;
+
+ while (@backends) {
+ my ( $subclass, $config ) = splice @backends, 0, 2;
+ my $full_class = "CPAN::Common::Index::${subclass}";
+ eval { Module::Load::load($full_class); 1 }
+ or Carp::croak($@);
+ my $object = $full_class->new($config);
+ push @resolvers, $object;
+ }
+
+ return $class->new( { resolvers => \@resolvers } );
+}
+
+sub validate_attributes {
+ my ($self) = @_;
+ my $resolvers = $self->resolvers;
+ return 1;
+}
+
+# have to think carefully about the sematics of regex search when indices
+# are stacked; only one result for any given package (or package/version)
+sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+ my @found;
+ if ( $args->{name} and ref $args->{name} eq '' ) {
+ # looking for exact match, so we just want the first hit
+ for my $source ( @{ $self->resolvers } ) {
+ if ( my @result = $source->search_packages($args) ) {
+ # XXX double check against remaining $args
+ push @found, @result;
+ last;
+ }
+ }
+ }
+ else {
+ # accumulate results from all resolvers
+ my %seen;
+ for my $source ( @{ $self->resolvers } ) {
+ my @result = $source->search_packages($args);
+ push @found, grep { !$seen{ $_->{package} }++ } @result;
+ }
+ }
+ return wantarray ? @found : $found[0];
+}
+
+# have to think carefully about the sematics of regex search when indices
+# are stacked; only one result for any given package (or package/version)
+sub search_authors {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_authors must be hash reference")
+ unless ref $args eq 'HASH';
+ my @found;
+ if ( $args->{name} and ref $args->{name} eq '' ) {
+ # looking for exact match, so we just want the first hit
+ for my $source ( @{ $self->resolvers } ) {
+ if ( my @result = $source->search_authors($args) ) {
+ # XXX double check against remaining $args
+ push @found, @result;
+ last;
+ }
+ }
+ }
+ else {
+ # accumulate results from all resolvers
+ my %seen;
+ for my $source ( @{ $self->resolvers } ) {
+ my @result = $source->search_authors($args);
+ push @found, grep { !$seen{ $_->{package} }++ } @result;
+ }
+ }
+ return wantarray ? @found : $found[0];
+}
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Common::Index::Mux::Ordered - Consult indices in order and return the first result
+
+=head1 VERSION
+
+version 0.010
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::Mux::Ordered;
+ use Data::Dumper;
+
+ $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ MetaDB => {},
+ Mirror => { mirror => "http://cpan.cpantesters.org" },
+ );
+
+=head1 DESCRIPTION
+
+This module multiplexes multiple CPAN::Common::Index objects, returning
+results in order.
+
+For exact match queries, the first result is returned. For search queries,
+results from each index object are concatenated.
+
+=head1 ATTRIBUTES
+
+=head2 resolvers
+
+ An array reference of CPAN::Common::Index::* objects
+
+=head1 METHODS
+
+=head2 assemble
+
+ $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ MetaDB => {},
+ Mirror => { mirror => "http://www.cpan.org" },
+ );
+
+This class method provides a shorthand for constructing a multiplexer.
+The arguments must be pairs of subclass suffixes and arguments. For
+example, "MetaDB" means to use "CPAN::Common::Index::MetaDB". Empty
+arguments must be given as an empty hash reference.
+
+=for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+
+package CPAN::DistnameInfo;
+
+$VERSION = "0.12";
+use strict;
+
+sub distname_info {
+ my $file = shift or return;
+
+ my ($dist, $version) = $file =~ /^
+ ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
+ (?:
+ [A-Za-z](?=[^A-Za-z]|$)
+ |
+ \d(?=-)
+ )(?<![._-][vV])
+ )+)(.*)
+ $/xs or return ($file,undef,undef);
+
+ if ($dist =~ /-undef\z/ and ! length $version) {
+ $dist =~ s/-undef\z//;
+ }
+
+ # Remove potential -withoutworldwriteables suffix
+ $version =~ s/-withoutworldwriteables$//;
+
+ if ($version =~ /^(-[Vv].*)-(\d.*)/) {
+
+ # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
+ # where the V3_1_1 is part of the distname
+ $dist .= $1;
+ $version = $2;
+ }
+
+ if ($version =~ /(.+_.*)-(\d.*)/) {
+ # Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
+ # part of the distname. However, names like libao-perl_0.03-1.tar.gz
+ # should still have 0.03-1 as their version.
+ $dist .= $1;
+ $version = $2;
+ }
+
+ # Normalize the Dist.pm-1.23 convention which CGI.pm and
+ # a few others use.
+ $dist =~ s{\.pm$}{};
+
+ $version = $1
+ if !length $version and $dist =~ s/-(\d+\w)$//;
+
+ $version = $1 . $version
+ if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
+
+ if ($version =~ /\d\.\d/) {
+ $version =~ s/^[-_.]+//;
+ }
+ else {
+ $version =~ s/^[-_]+//;
+ }
+
+ my $dev;
+ if (length $version) {
+ if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
+ $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
+ }
+ elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
+ $dev = 1;
+ }
+ }
+ else {
+ $version = undef;
+ }
+
+ ($dist, $version, $dev);
+}
+
+sub new {
+ my $class = shift;
+ my $distfile = shift;
+
+ $distfile =~ s,//+,/,g;
+
+ my %info = ( pathname => $distfile );
+
+ ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
+ and $info{cpanid} = $6;
+
+ if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
+ $info{distvname} = $1;
+ $info{extension} = $2;
+ }
+
+ @info{qw(dist version beta)} = distname_info($info{distvname});
+ $info{maturity} = delete $info{beta} ? 'developer' : 'released';
+
+ return bless \%info, $class;
+}
+
+sub dist { shift->{dist} }
+sub version { shift->{version} }
+sub maturity { shift->{maturity} }
+sub filename { shift->{filename} }
+sub cpanid { shift->{cpanid} }
+sub distvname { shift->{distvname} }
+sub extension { shift->{extension} }
+sub pathname { shift->{pathname} }
+
+sub properties { %{ $_[0] } }
+
+1;
+
+__END__
+
+=head1 NAME
+
+CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
+
+=head1 SYNOPSIS
+
+ my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
+
+ my $d = CPAN::DistnameInfo->new($pathname);
+
+ my $dist = $d->dist; # "CPAN-DistnameInfo"
+ my $version = $d->version; # "0.02"
+ my $maturity = $d->maturity; # "released"
+ my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz"
+ my $cpanid = $d->cpanid; # "GBARR"
+ my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02"
+ my $extension = $d->extension; # "tar.gz"
+ my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..."
+
+ my %prop = $d->properties;
+
+=head1 DESCRIPTION
+
+Many online services that are centered around CPAN attempt to
+associate multiple uploads by extracting a distribution name from
+the filename of the upload. For most distributions this is easy as
+they have used ExtUtils::MakeMaker or Module::Build to create the
+distribution, which results in a uniform name. But sadly not all
+uploads are created in this way.
+
+C<CPAN::DistnameInfo> uses heuristics that have been learnt by
+L<http://search.cpan.org/> to extract the distribution name and
+version from filenames and also report if the version is to be
+treated as a developer release
+
+The constructor takes a single pathname, returning an object with the following methods
+
+=over
+
+=item cpanid
+
+If the path given looked like a CPAN authors directory path, then this will be the
+the CPAN id of the author.
+
+=item dist
+
+The name of the distribution
+
+=item distvname
+
+The file name with any suffix and leading directory names removed
+
+=item filename
+
+If the path given looked like a CPAN authors directory path, then this will be the
+path to the file relative to the detected CPAN author directory. Otherwise it is the path
+that was passed in.
+
+=item maturity
+
+The maturity of the distribution. This will be either C<released> or C<developer>
+
+=item extension
+
+The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
+
+=item pathname
+
+The pathname that was passed to the constructor when creating the object.
+
+=item properties
+
+This will return a list of key-value pairs, suitable for assigning to a hash,
+for the known properties.
+
+=item version
+
+The extracted version
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2003 Graham Barr. All rights reserved. This program is
+free software; you can redistribute it and/or modify it under the same
+terms as Perl itself.
+
+=cut
+
--- /dev/null
+package CPAN::Meta::Check;
+$CPAN::Meta::Check::VERSION = '0.014';
+use strict;
+use warnings;
+
+use base 'Exporter';
+our @EXPORT = qw//;
+our @EXPORT_OK = qw/check_requirements requirements_for verify_dependencies/;
+our %EXPORT_TAGS = (all => [ @EXPORT, @EXPORT_OK ] );
+
+use CPAN::Meta::Prereqs '2.132830';
+use CPAN::Meta::Requirements 2.121;
+use Module::Metadata 1.000023;
+
+sub _check_dep {
+ my ($reqs, $module, $dirs) = @_;
+
+ $module eq 'perl' and return ($reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module));
+
+ my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
+ return "Module '$module' is not installed" if not defined $metadata;
+
+ my $version = eval { $metadata->version };
+ return sprintf 'Installed version (%s) of %s is not in range \'%s\'',
+ (defined $version ? $version : 'undef'), $module, $reqs->requirements_for_module($module)
+ if not $reqs->accepts_module($module, $version || 0);
+ return;
+}
+
+sub _check_conflict {
+ my ($reqs, $module, $dirs) = @_;
+ my $metadata = Module::Metadata->new_from_module($module, inc => $dirs);
+ return if not defined $metadata;
+
+ my $version = eval { $metadata->version };
+ return sprintf 'Installed version (%s) of %s is in range \'%s\'',
+ (defined $version ? $version : 'undef'), $module, $reqs->requirements_for_module($module)
+ if $reqs->accepts_module($module, $version);
+ return;
+}
+
+sub requirements_for {
+ my ($meta, $phases, $type) = @_;
+ my $prereqs = ref($meta) eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;
+ return $prereqs->merged_requirements(ref($phases) ? $phases : [ $phases ], [ $type ]);
+}
+
+sub check_requirements {
+ my ($reqs, $type, $dirs) = @_;
+
+ return +{
+ map {
+ $_ => $type ne 'conflicts'
+ ? scalar _check_dep($reqs, $_, $dirs)
+ : scalar _check_conflict($reqs, $_, $dirs)
+ } $reqs->required_modules
+ };
+}
+
+sub verify_dependencies {
+ my ($meta, $phases, $type, $dirs) = @_;
+ my $reqs = requirements_for($meta, $phases, $type);
+ my $issues = check_requirements($reqs, $type, $dirs);
+ return grep { defined } values %{ $issues };
+}
+
+1;
+
+#ABSTRACT: Verify requirements in a CPAN::Meta object
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Check - Verify requirements in a CPAN::Meta object
+
+=head1 VERSION
+
+version 0.014
+
+=head1 SYNOPSIS
+
+ warn "$_\n" for verify_dependencies($meta, [qw/runtime build test/], 'requires');
+
+=head1 DESCRIPTION
+
+This module verifies if requirements described in a CPAN::Meta object are present.
+
+=head1 FUNCTIONS
+
+=head2 check_requirements($reqs, $type, $incdirs)
+
+This function checks if all dependencies in C<$reqs> (a L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object) are met, taking into account that 'conflicts' dependencies have to be checked in reverse. It returns a hash with the modules as keys and any problems as values; the value for a successfully found module will be undef. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>.
+
+=head2 verify_dependencies($meta, $phases, $types, $incdirs)
+
+Check all requirements in C<$meta> for phases C<$phases> and type C<$type>. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
+
+=head2 requirements_for($meta, $phases, $types)
+
+B<< This function is deprecated and may be removed at some point in the future, please use CPAN::Meta::Prereqs->merged_requirements instead. >>
+
+This function returns a unified L<CPAN::Meta::Requirements|CPAN::Meta::Requirements> object for all C<$type> requirements for C<$phases>. C<$phases> may be either one (scalar) value or an arrayref of valid values as defined by the L<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item * L<Test::CheckDeps|Test::CheckDeps>
+
+=item * L<CPAN::Meta|CPAN::Meta>
+
+=for comment # vi:noet:sts=2:sw=2:ts=2
+
+=back
+
+=head1 AUTHOR
+
+Leon Timmermans <leont@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2012 by Leon Timmermans.
+
+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
--- /dev/null
+use 5.006;
+use strict;
+use warnings;
+package Capture::Tiny;
+# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
+our $VERSION = '0.48';
+use Carp ();
+use Exporter ();
+use IO::Handle ();
+use File::Spec ();
+use File::Temp qw/tempfile tmpnam/;
+use Scalar::Util qw/reftype blessed/;
+# Get PerlIO or fake it
+BEGIN {
+ local $@;
+ eval { require PerlIO; PerlIO->can('get_layers') }
+ or *PerlIO::get_layers = sub { return () };
+}
+
+#--------------------------------------------------------------------------#
+# create API subroutines and export them
+# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
+#--------------------------------------------------------------------------#
+
+my %api = (
+ capture => [1,1,0,0],
+ capture_stdout => [1,0,0,0],
+ capture_stderr => [0,1,0,0],
+ capture_merged => [1,1,1,0],
+ tee => [1,1,0,1],
+ tee_stdout => [1,0,0,1],
+ tee_stderr => [0,1,0,1],
+ tee_merged => [1,1,1,1],
+);
+
+for my $sub ( keys %api ) {
+ my $args = join q{, }, @{$api{$sub}};
+ eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
+}
+
+our @ISA = qw/Exporter/;
+our @EXPORT_OK = keys %api;
+our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
+
+#--------------------------------------------------------------------------#
+# constants and fixtures
+#--------------------------------------------------------------------------#
+
+my $IS_WIN32 = $^O eq 'MSWin32';
+
+##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
+##
+##my $DEBUGFH;
+##open $DEBUGFH, "> DEBUG" if $DEBUG;
+##
+##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};
+
+our $TIMEOUT = 30;
+
+#--------------------------------------------------------------------------#
+# command to tee output -- the argument is a filename that must
+# be opened to signal that the process is ready to receive input.
+# This is annoying, but seems to be the best that can be done
+# as a simple, portable IPC technique
+#--------------------------------------------------------------------------#
+my @cmd = ($^X, '-C0', '-e', <<'HERE');
+use Fcntl;
+$SIG{HUP}=sub{exit};
+if ( my $fn=shift ) {
+ sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
+ print {$fh} $$;
+ close $fh;
+}
+my $buf; while (sysread(STDIN, $buf, 2048)) {
+ syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
+}
+HERE
+
+#--------------------------------------------------------------------------#
+# filehandle manipulation
+#--------------------------------------------------------------------------#
+
+sub _relayer {
+ my ($fh, $apply_layers) = @_;
+ # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
+
+ # eliminate pseudo-layers
+ binmode( $fh, ":raw" );
+ # strip off real layers until only :unix is left
+ while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
+ binmode( $fh, ":pop" );
+ }
+ # apply other layers
+ my @to_apply = @$apply_layers;
+ shift @to_apply; # eliminate initial :unix
+ # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n");
+ binmode($fh, ":" . join(":",@to_apply));
+}
+
+sub _name {
+ my $glob = shift;
+ no strict 'refs'; ## no critic
+ return *{$glob}{NAME};
+}
+
+sub _open {
+ open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
+ # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
+}
+
+sub _close {
+ # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" );
+ close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
+}
+
+my %dup; # cache this so STDIN stays fd0
+my %proxy_count;
+sub _proxy_std {
+ my %proxies;
+ if ( ! defined fileno STDIN ) {
+ $proxy_count{stdin}++;
+ if (defined $dup{stdin}) {
+ _open \*STDIN, "<&=" . fileno($dup{stdin});
+ # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
+ }
+ else {
+ _open \*STDIN, "<" . File::Spec->devnull;
+ # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
+ _open $dup{stdin} = IO::Handle->new, "<&=STDIN";
+ }
+ $proxies{stdin} = \*STDIN;
+ binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
+ }
+ if ( ! defined fileno STDOUT ) {
+ $proxy_count{stdout}++;
+ if (defined $dup{stdout}) {
+ _open \*STDOUT, ">&=" . fileno($dup{stdout});
+ # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
+ }
+ else {
+ _open \*STDOUT, ">" . File::Spec->devnull;
+ # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
+ _open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
+ }
+ $proxies{stdout} = \*STDOUT;
+ binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
+ }
+ if ( ! defined fileno STDERR ) {
+ $proxy_count{stderr}++;
+ if (defined $dup{stderr}) {
+ _open \*STDERR, ">&=" . fileno($dup{stderr});
+ # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
+ }
+ else {
+ _open \*STDERR, ">" . File::Spec->devnull;
+ # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
+ _open $dup{stderr} = IO::Handle->new, ">&=STDERR";
+ }
+ $proxies{stderr} = \*STDERR;
+ binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
+ }
+ return %proxies;
+}
+
+sub _unproxy {
+ my (%proxies) = @_;
+ # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
+ for my $p ( keys %proxies ) {
+ $proxy_count{$p}--;
+ # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
+ if ( ! $proxy_count{$p} ) {
+ _close $proxies{$p};
+ _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
+ delete $dup{$p};
+ }
+ }
+}
+
+sub _copy_std {
+ my %handles;
+ for my $h ( qw/stdout stderr stdin/ ) {
+ next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
+ my $redir = $h eq 'stdin' ? "<&" : ">&";
+ _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
+ }
+ return \%handles;
+}
+
+# In some cases we open all (prior to forking) and in others we only open
+# the output handles (setting up redirection)
+sub _open_std {
+ my ($handles) = @_;
+ _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
+ _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
+ _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
+}
+
+#--------------------------------------------------------------------------#
+# private subs
+#--------------------------------------------------------------------------#
+
+sub _start_tee {
+ my ($which, $stash) = @_; # $which is "stdout" or "stderr"
+ # setup pipes
+ $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
+ pipe $stash->{reader}{$which}, $stash->{tee}{$which};
+ # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" );
+ select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
+ # setup desired redirection for parent and child
+ $stash->{new}{$which} = $stash->{tee}{$which};
+ $stash->{child}{$which} = {
+ stdin => $stash->{reader}{$which},
+ stdout => $stash->{old}{$which},
+ stderr => $stash->{capture}{$which},
+ };
+ # flag file is used to signal the child is ready
+ $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$;
+ # execute @cmd as a separate process
+ if ( $IS_WIN32 ) {
+ my $old_eval_err=$@;
+ undef $@;
+
+ eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
+ # _debug( "# Win32API::File loaded\n") unless $@;
+ my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
+ # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
+ my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
+ # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n"));
+ _open_std( $stash->{child}{$which} );
+ $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
+ # not restoring std here as it all gets redirected again shortly anyway
+ $@=$old_eval_err;
+ }
+ else { # use fork
+ _fork_exec( $which, $stash );
+ }
+}
+
+sub _fork_exec {
+ my ($which, $stash) = @_; # $which is "stdout" or "stderr"
+ my $pid = fork;
+ if ( not defined $pid ) {
+ Carp::confess "Couldn't fork(): $!";
+ }
+ elsif ($pid == 0) { # child
+ # _debug( "# in child process ...\n" );
+ untie *STDIN; untie *STDOUT; untie *STDERR;
+ _close $stash->{tee}{$which};
+ # _debug( "# redirecting handles in child ...\n" );
+ _open_std( $stash->{child}{$which} );
+ # _debug( "# calling exec on command ...\n" );
+ exec @cmd, $stash->{flag_files}{$which};
+ }
+ $stash->{pid}{$which} = $pid
+}
+
+my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
+sub _files_exist {
+ return 1 if @_ == grep { -f } @_;
+ Time::HiRes::usleep(1000) if $have_usleep;
+ return 0;
+}
+
+sub _wait_for_tees {
+ my ($stash) = @_;
+ my $start = time;
+ my @files = values %{$stash->{flag_files}};
+ my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
+ ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
+ 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
+ Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
+ unlink $_ for @files;
+}
+
+sub _kill_tees {
+ my ($stash) = @_;
+ if ( $IS_WIN32 ) {
+ # _debug( "# closing handles\n");
+ close($_) for values %{ $stash->{tee} };
+ # _debug( "# waiting for subprocesses to finish\n");
+ my $start = time;
+ 1 until wait == -1 || (time - $start > 30);
+ }
+ else {
+ _close $_ for values %{ $stash->{tee} };
+ waitpid $_, 0 for values %{ $stash->{pid} };
+ }
+}
+
+sub _slurp {
+ my ($name, $stash) = @_;
+ my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
+ # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
+ seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
+ my $text = do { local $/; scalar readline $fh };
+ return defined($text) ? $text : "";
+}
+
+#--------------------------------------------------------------------------#
+# _capture_tee() -- generic main sub for capturing or teeing
+#--------------------------------------------------------------------------#
+
+sub _capture_tee {
+ # _debug( "# starting _capture_tee with (@_)...\n" );
+ my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
+ my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ());
+ Carp::confess("Custom capture options must be given as key/value pairs\n")
+ unless @opts % 2 == 0;
+ my $stash = { capture => { @opts } };
+ for ( keys %{$stash->{capture}} ) {
+ my $fh = $stash->{capture}{$_};
+ Carp::confess "Custom handle for $_ must be seekable\n"
+ unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
+ }
+ # save existing filehandles and setup captures
+ local *CT_ORIG_STDIN = *STDIN ;
+ local *CT_ORIG_STDOUT = *STDOUT;
+ local *CT_ORIG_STDERR = *STDERR;
+ # find initial layers
+ my %layers = (
+ stdin => [PerlIO::get_layers(\*STDIN) ],
+ stdout => [PerlIO::get_layers(\*STDOUT, output => 1)],
+ stderr => [PerlIO::get_layers(\*STDERR, output => 1)],
+ );
+ # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
+ # get layers from underlying glob of tied filehandles if we can
+ # (this only works for things that work like Tie::StdHandle)
+ $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
+ if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
+ $layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
+ if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
+ # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
+ # bypass scalar filehandles and tied handles
+ # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
+ my %localize;
+ $localize{stdin}++, local(*STDIN)
+ if grep { $_ eq 'scalar' } @{$layers{stdin}};
+ $localize{stdout}++, local(*STDOUT)
+ if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
+ $localize{stderr}++, local(*STDERR)
+ if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
+ $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
+ if tied *STDIN && $] >= 5.008;
+ $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
+ if $do_stdout && tied *STDOUT && $] >= 5.008;
+ $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
+ if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
+ # _debug( "# localized $_\n" ) for keys %localize;
+ # proxy any closed/localized handles so we don't use fds 0, 1 or 2
+ my %proxy_std = _proxy_std();
+ # _debug( "# proxy std: @{ [%proxy_std] }\n" );
+ # update layers after any proxying
+ $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
+ $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
+ # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
+ # store old handles and setup handles for capture
+ $stash->{old} = _copy_std();
+ $stash->{new} = { %{$stash->{old}} }; # default to originals
+ for ( keys %do ) {
+ $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
+ seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
+ $stash->{pos}{$_} = tell $stash->{capture}{$_};
+ # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
+ _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
+ }
+ _wait_for_tees( $stash ) if $do_tee;
+ # finalize redirection
+ $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
+ # _debug( "# redirecting in parent ...\n" );
+ _open_std( $stash->{new} );
+ # execute user provided code
+ my ($exit_code, $inner_error, $outer_error, $orig_pid, @result);
+ {
+ $orig_pid = $$;
+ local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
+ # _debug( "# finalizing layers ...\n" );
+ _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
+ _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
+ # _debug( "# running code $code ...\n" );
+ my $old_eval_err=$@;
+ undef $@;
+ eval { @result = $code->(); $inner_error = $@ };
+ $exit_code = $?; # save this for later
+ $outer_error = $@; # save this for later
+ STDOUT->flush if $do_stdout;
+ STDERR->flush if $do_stderr;
+ $@ = $old_eval_err;
+ }
+ # restore prior filehandles and shut down tees
+ # _debug( "# restoring filehandles ...\n" );
+ _open_std( $stash->{old} );
+ _close( $_ ) for values %{$stash->{old}}; # don't leak fds
+ # shouldn't need relayering originals, but see rt.perl.org #114404
+ _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
+ _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
+ _unproxy( %proxy_std );
+ # _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
+ _kill_tees( $stash ) if $do_tee;
+ # return captured output, but shortcut in void context
+ # unless we have to echo output to tied/scalar handles;
+ my %got;
+ if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) {
+ for ( keys %do ) {
+ _relayer($stash->{capture}{$_}, $layers{$_});
+ $got{$_} = _slurp($_, $stash);
+ # _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
+ }
+ print CT_ORIG_STDOUT $got{stdout}
+ if $do_stdout && $do_tee && $localize{stdout};
+ print CT_ORIG_STDERR $got{stderr}
+ if $do_stderr && $do_tee && $localize{stderr};
+ }
+ $? = $exit_code;
+ $@ = $inner_error if $inner_error;
+ die $outer_error if $outer_error;
+ # _debug( "# ending _capture_tee with (@_)...\n" );
+ return unless defined wantarray;
+ my @return;
+ push @return, $got{stdout} if $do_stdout;
+ push @return, $got{stderr} if $do_stderr && ! $do_merge;
+ push @return, @result;
+ return wantarray ? @return : $return[0];
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
+
+=head1 VERSION
+
+version 0.48
+
+=head1 SYNOPSIS
+
+ use Capture::Tiny ':all';
+
+ # capture from external command
+
+ ($stdout, $stderr, $exit) = capture {
+ system( $cmd, @args );
+ };
+
+ # capture from arbitrary code (Perl or external)
+
+ ($stdout, $stderr, @result) = capture {
+ # your code here
+ };
+
+ # capture partial or merged output
+
+ $stdout = capture_stdout { ... };
+ $stderr = capture_stderr { ... };
+ $merged = capture_merged { ... };
+
+ # tee output
+
+ ($stdout, $stderr) = tee {
+ # your code here
+ };
+
+ $stdout = tee_stdout { ... };
+ $stderr = tee_stderr { ... };
+ $merged = tee_merged { ... };
+
+=head1 DESCRIPTION
+
+Capture::Tiny provides a simple, portable way to capture almost anything sent
+to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
+from an external program. Optionally, output can be teed so that it is
+captured while being passed through to the original filehandles. Yes, it even
+works on Windows (usually). Stop guessing which of a dozen capturing modules
+to use in any particular situation and just use this one.
+
+=head1 USAGE
+
+The following functions are available. None are exported by default.
+
+=head2 capture
+
+ ($stdout, $stderr, @result) = capture \&code;
+ $stdout = capture \&code;
+
+The C<capture> function takes a code reference and returns what is sent to
+STDOUT and STDERR as well as any return values from the code reference. In
+scalar context, it returns only STDOUT. If no output was received for a
+filehandle, it returns an empty string for that filehandle. Regardless of calling
+context, all output is captured -- nothing is passed to the existing filehandles.
+
+It is prototyped to take a subroutine reference as an argument. Thus, it
+can be called in block form:
+
+ ($stdout, $stderr) = capture {
+ # your code here ...
+ };
+
+Note that the coderef is evaluated in list context. If you wish to force
+scalar context on the return value, you must use the C<scalar> keyword.
+
+ ($stdout, $stderr, $count) = capture {
+ my @list = qw/one two three/;
+ return scalar @list; # $count will be 3
+ };
+
+Also note that within the coderef, the C<@_> variable will be empty. So don't
+use arguments from a surrounding subroutine without copying them to an array
+first:
+
+ sub wont_work {
+ my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG
+ ...
+ }
+
+ sub will_work {
+ my @args = @_;
+ my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
+ ...
+ }
+
+Captures are normally done to an anonymous temporary filehandle. To
+capture via a named file (e.g. to externally monitor a long-running capture),
+provide custom filehandles as a trailing list of option pairs:
+
+ my $out_fh = IO::File->new("out.txt", "w+");
+ my $err_fh = IO::File->new("out.txt", "w+");
+ capture { ... } stdout => $out_fh, stderr => $err_fh;
+
+The filehandles must be read/write and seekable. Modifying the files or
+filehandles during a capture operation will give unpredictable results.
+Existing IO layers on them may be changed by the capture.
+
+When called in void context, C<capture> saves memory and time by
+not reading back from the capture handles.
+
+=head2 capture_stdout
+
+ ($stdout, @result) = capture_stdout \&code;
+ $stdout = capture_stdout \&code;
+
+The C<capture_stdout> function works just like C<capture> except only
+STDOUT is captured. STDERR is not captured.
+
+=head2 capture_stderr
+
+ ($stderr, @result) = capture_stderr \&code;
+ $stderr = capture_stderr \&code;
+
+The C<capture_stderr> function works just like C<capture> except only
+STDERR is captured. STDOUT is not captured.
+
+=head2 capture_merged
+
+ ($merged, @result) = capture_merged \&code;
+ $merged = capture_merged \&code;
+
+The C<capture_merged> function works just like C<capture> except STDOUT and
+STDERR are merged. (Technically, STDERR is redirected to the same capturing
+handle as STDOUT before executing the function.)
+
+Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
+properly ordered due to buffering.
+
+=head2 tee
+
+ ($stdout, $stderr, @result) = tee \&code;
+ $stdout = tee \&code;
+
+The C<tee> function works just like C<capture>, except that output is captured
+as well as passed on to the original STDOUT and STDERR.
+
+When called in void context, C<tee> saves memory and time by
+not reading back from the capture handles, except when the
+original STDOUT OR STDERR were tied or opened to a scalar
+handle.
+
+=head2 tee_stdout
+
+ ($stdout, @result) = tee_stdout \&code;
+ $stdout = tee_stdout \&code;
+
+The C<tee_stdout> function works just like C<tee> except only
+STDOUT is teed. STDERR is not teed (output goes to STDERR as usual).
+
+=head2 tee_stderr
+
+ ($stderr, @result) = tee_stderr \&code;
+ $stderr = tee_stderr \&code;
+
+The C<tee_stderr> function works just like C<tee> except only
+STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual).
+
+=head2 tee_merged
+
+ ($merged, @result) = tee_merged \&code;
+ $merged = tee_merged \&code;
+
+The C<tee_merged> function works just like C<capture_merged> except that output
+is captured as well as passed on to STDOUT.
+
+Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
+properly ordered due to buffering.
+
+=head1 LIMITATIONS
+
+=head2 Portability
+
+Portability is a goal, not a guarantee. C<tee> requires fork, except on
+Windows where C<system(1, @cmd)> is used instead. Not tested on any
+particularly esoteric platforms yet. See the
+L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
+for test result by platform.
+
+=head2 PerlIO layers
+
+Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or
+':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to
+STDOUT or STDERR I<before> the call to C<capture> or C<tee>. This may not work
+for tied filehandles (see below).
+
+=head2 Modifying filehandles before capturing
+
+Generally speaking, you should do little or no manipulation of the standard IO
+filehandles prior to using Capture::Tiny. In particular, closing, reopening,
+localizing or tying standard filehandles prior to capture may cause a variety of
+unexpected, undesirable and/or unreliable behaviors, as described below.
+Capture::Tiny does its best to compensate for these situations, but the
+results may not be what you desire.
+
+=head3 Closed filehandles
+
+Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
+closed. However, since they will be reopened to capture or tee output, any
+code within the captured block that depends on finding them closed will, of
+course, not find them to be closed. If they started closed, Capture::Tiny will
+close them again when the capture block finishes.
+
+Note that this reopening will happen even for STDIN or a filehandle not being
+captured to ensure that the filehandle used for capture is not opened to file
+descriptor 0, as this causes problems on various platforms.
+
+Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
+and also breaks tee() for undiagnosed reasons. So don't do that.
+
+=head3 Localized filehandles
+
+If code localizes any of Perl's standard filehandles before capturing, the capture
+will affect the localized filehandles and not the original ones. External system
+calls are not affected by localizing a filehandle in Perl and will continue
+to send output to the original filehandles (which will thus not be captured).
+
+=head3 Scalar filehandles
+
+If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
+C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for
+the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured
+output to the output filehandle after the capture is complete. (Requires Perl
+5.8)
+
+Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
+reference, but note that external processes will not be able to read from such
+a handle. Capture::Tiny tries to ensure that external processes will read from
+the null device instead, but this is not guaranteed.
+
+=head3 Tied output filehandles
+
+If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then
+Capture::Tiny will attempt to override the tie for the duration of the
+C<capture> or C<tee> call and then send captured output to the tied filehandle after
+the capture is complete. (Requires Perl 5.8)
+
+Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
+STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle
+is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
+appropriate layers like C<:utf8> from the underlying filehandle and do the right
+thing.
+
+=head3 Tied input filehandle
+
+Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
+requires Perl 5.8 and is not entirely predictable. External processes
+will not be able to read from such a handle.
+
+Unless having STDIN tied is crucial, it may be safest to localize STDIN when
+capturing:
+
+ my ($out, $err) = do { local *STDIN; capture { ... } };
+
+=head2 Modifying filehandles during a capture
+
+Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is
+almost certainly going to cause problems. Don't do that.
+
+=head3 Forking inside a capture
+
+Forks aren't portable. The behavior of filehandles during a fork is even
+less so. If Capture::Tiny detects that a fork has occurred within a
+capture, it will shortcut in the child process and return empty strings for
+captures. Other problems may occur in the child or parent, as well.
+Forking in a capture block is not recommended.
+
+=head3 Using threads
+
+Filehandles are global. Mixing up I/O and captures in different threads
+without coordination is going to cause problems. Besides, threads are
+officially discouraged.
+
+=head3 Dropping privileges during a capture
+
+If you drop privileges during a capture, temporary files created to
+facilitate the capture may not be cleaned up afterwards.
+
+=head2 No support for Perl 5.8.0
+
+It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later
+is recommended.
+
+=head2 Limited support for Perl 5.6
+
+Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly.
+
+=head1 ENVIRONMENT
+
+=head2 PERL_CAPTURE_TINY_TIMEOUT
+
+Capture::Tiny uses subprocesses internally for C<tee>. By default,
+Capture::Tiny will timeout with an error if such subprocesses are not ready to
+receive data within 30 seconds (or whatever is the value of
+C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting
+the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable. Setting it to zero will
+disable timeouts. B<NOTE>, this does not timeout the code reference being
+captured -- this only prevents Capture::Tiny itself from hanging your process
+waiting for its child processes to be ready to proceed.
+
+=head1 SEE ALSO
+
+This module was inspired by L<IO::CaptureOutput>, which provides
+similar functionality without the ability to tee output and with more
+complicated code and API. L<IO::CaptureOutput> does not handle layers
+or most of the unusual cases described in the L</Limitations> section and
+I no longer recommend it.
+
+There are many other CPAN modules that provide some sort of output capture,
+albeit with various limitations that make them appropriate only in particular
+circumstances. I'm probably missing some. The long list is provided to show
+why I felt Capture::Tiny was necessary.
+
+=over 4
+
+=item *
+
+L<IO::Capture>
+
+=item *
+
+L<IO::Capture::Extended>
+
+=item *
+
+L<IO::CaptureOutput>
+
+=item *
+
+L<IPC::Capture>
+
+=item *
+
+L<IPC::Cmd>
+
+=item *
+
+L<IPC::Open2>
+
+=item *
+
+L<IPC::Open3>
+
+=item *
+
+L<IPC::Open3::Simple>
+
+=item *
+
+L<IPC::Open3::Utils>
+
+=item *
+
+L<IPC::Run>
+
+=item *
+
+L<IPC::Run::SafeHandles>
+
+=item *
+
+L<IPC::Run::Simple>
+
+=item *
+
+L<IPC::Run3>
+
+=item *
+
+L<IPC::System::Simple>
+
+=item *
+
+L<Tee>
+
+=item *
+
+L<IO::Tee>
+
+=item *
+
+L<File::Tee>
+
+=item *
+
+L<Filter::Handle>
+
+=item *
+
+L<Tie::STDERR>
+
+=item *
+
+L<Tie::STDOUT>
+
+=item *
+
+L<Test::Output>
+
+=back
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/dagolden/Capture-Tiny/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/dagolden/Capture-Tiny>
+
+ git clone https://github.com/dagolden/Capture-Tiny.git
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson
+
+=over 4
+
+=item *
+
+Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+=item *
+
+David E. Wheeler <david@justatheory.com>
+
+=item *
+
+fecundf <not.com+github@gmail.com>
+
+=item *
+
+Graham Knop <haarg@haarg.org>
+
+=item *
+
+Peter Rabbitson <ribasushi@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2009 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+package Carton;
+use strict;
+use 5.008_005;
+use version; our $VERSION = version->declare("v1.0.34");
+
+1;
+__END__
+
+=head1 NAME
+
+Carton - Perl module dependency manager (aka Bundler for Perl)
+
+=head1 SYNOPSIS
+
+ # On your development environment
+ > cat cpanfile
+ requires 'Plack', '0.9980';
+ requires 'Starman', '0.2000';
+
+ > carton install
+ > git add cpanfile cpanfile.snapshot
+ > git commit -m "add Plack and Starman"
+
+ # Other developer's machine, or on a deployment box
+ > carton install
+ > carton exec starman -p 8080 myapp.psgi
+
+ # carton exec is optional
+ > perl -Ilocal/lib/perl5 local/bin/starman -p 8080 myapp.psgi
+ > PERL5LIB=/path/to/local/lib/perl5 /path/to/local/bin/starman -p 8080 myapp.psgi
+
+=head1 AVAILABILITY
+
+Carton only works with perl installation with the complete set of core
+modules. If you use perl installed by a vendor package with modules
+stripped from core, Carton is not expected to work correctly.
+
+Also, Carton requires you to run your command/application with
+C<carton exec> command or to include the I<local/lib/perl5> directory
+in your Perl library search path (using C<PERL5LIB>, C<-I>, or
+L<lib>).
+
+=head1 DESCRIPTION
+
+carton is a command line tool to track the Perl module dependencies
+for your Perl application. Dependencies are declared using L<cpanfile>
+format, and the managed dependencies are tracked in a
+I<cpanfile.snapshot> file, which is meant to be version controlled,
+and the snapshot file allows other developers of your application will
+have the exact same versions of the modules.
+
+For C<cpanfile> syntax, see L<cpanfile> documentation.
+
+=head1 TUTORIAL
+
+=head2 Initializing the environment
+
+carton will use the I<local> directory to install modules into. You're
+recommended to exclude these directories from the version control
+system.
+
+ > echo local/ >> .gitignore
+ > git add cpanfile cpanfile.snapshot
+ > git commit -m "Start using carton"
+
+=head2 Tracking the dependencies
+
+You can manage the dependencies of your application via C<cpanfile>.
+
+ # cpanfile
+ requires 'Plack', '0.9980';
+ requires 'Starman', '0.2000';
+
+And then you can install these dependencies via:
+
+ > carton install
+
+The modules are installed into your I<local> directory, and the
+dependencies tree and version information are analyzed and saved into
+I<cpanfile.snapshot> in your directory.
+
+Make sure you add I<cpanfile> and I<cpanfile.snapshot> to your version
+controlled repository and commit changes as you update
+dependencies. This will ensure that other developers on your app, as
+well as your deployment environment, use exactly the same versions of
+the modules you just installed.
+
+ > git add cpanfile cpanfile.snapshot
+ > git commit -m "Added Plack and Starman"
+
+=head2 Specifying a CPAN distribution
+
+You can pin a module resolution to a specific distribution using a
+combination of C<dist>, C<mirror> and C<url> options in C<cpanfile>.
+
+ # specific distribution on PAUSE
+ requires 'Plack', '== 0.9980',
+ dist => 'MIYAGAWA/Plack-0.9980.tar.gz';
+
+ # local mirror (darkpan)
+ requires 'Plack', '== 0.9981',
+ dist => 'MYCOMPANY/Plack-0.9981-p1.tar.gz',
+ mirror => 'https://pause.local/';
+
+ # URL
+ requires 'Plack', '== 1.1000',
+ url => 'https://pause.local/authors/id/M/MY/MYCOMPANY/Plack-1.1000.tar.gz';
+
+=head2 Deploying your application
+
+Once you've done installing all the dependencies, you can push your
+application directory to a remote machine (excluding I<local> and
+I<.carton>) and run the following command:
+
+ > carton install --deployment
+
+This will look at the I<cpanfile.snapshot> and install the exact same
+versions of the dependencies into I<local>, and now your application
+is ready to run.
+
+The C<--deployment> flag makes sure that carton will only install
+modules and versions available in your snapshot, and won't fallback to
+query for CPAN Meta DB for missing modules.
+
+=head2 Bundling modules
+
+carton can bundle all the tarballs for your dependencies into a
+directory so that you can even install dependencies that are not
+available on CPAN, such as internal distribution aka DarkPAN.
+
+ > carton bundle
+
+will bundle these tarballs into I<vendor/cache> directory, and
+
+ > carton install --cached
+
+will install modules using this local cache. Combined with
+C<--deployment> option, you can avoid querying for a database like
+CPAN Meta DB or downloading files from CPAN mirrors upon deployment
+time.
+
+As of Carton v1.0.32, the bundle also includes a package index
+allowing you to simply use L<cpanm> (which has a
+L<standalone version|App::cpanminus/"Downloading the standalone executable">)
+instead of installing Carton on a remote machine.
+
+ > cpanm -L local --from "$PWD/vendor/cache" --installdeps --notest --quiet .
+
+=head1 PERL VERSIONS
+
+When you take a snapshot in one perl version and deploy on another
+(different) version, you might have troubles with core modules.
+
+The simplest solution, which might not work for everybody, is to use
+the same version of perl in the development and deployment.
+
+To enforce that, you're recommended to use L<plenv> and
+C<.perl-version> to lock perl versions in development.
+
+You can also specify the minimum perl required in C<cpanfile>:
+
+ requires 'perl', '5.16.3';
+
+and carton (and cpanm) will give you errors when deployed on hosts
+with perl lower than the specified version.
+
+=head1 COMMUNITY
+
+=over 4
+
+=item L<https://github.com/perl-carton/carton>
+
+Code repository, Wiki and Issue Tracker
+
+=item L<irc://irc.perl.org/#cpanm>
+
+IRC chat room
+
+=back
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 COPYRIGHT
+
+Tatsuhiko Miyagawa 2011-
+
+=head1 LICENSE
+
+This software is licensed under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<cpanm>
+
+L<cpanfile>
+
+L<Bundler|http://gembundler.com/>
+
+L<pip|http://pypi.python.org/pypi/pip>
+
+L<npm|http://npmjs.org/>
+
+L<perlrocks|https://github.com/gugod/perlrocks>
+
+L<only>
+
+=cut
--- /dev/null
+package Carton::Builder;
+use strict;
+use Class::Tiny {
+ mirror => undef,
+ index => undef,
+ cascade => sub { 1 },
+ without => sub { [] },
+ cpanfile => undef,
+};
+
+sub effective_mirrors {
+ my $self = shift;
+
+ # push default CPAN mirror always, as a fallback
+ # TODO don't pass fallback if --cached is set?
+
+ my @mirrors = ($self->mirror);
+ push @mirrors, Carton::Mirror->default if $self->custom_mirror;
+ push @mirrors, Carton::Mirror->new('http://backpan.perl.org/');
+
+ @mirrors;
+}
+
+sub custom_mirror {
+ my $self = shift;
+ ! $self->mirror->is_default;
+}
+
+sub bundle {
+ my($self, $path, $cache_path, $snapshot) = @_;
+
+ for my $dist ($snapshot->distributions) {
+ my $source = $path->child("cache/authors/id/" . $dist->pathname);
+ my $target = $cache_path->child("authors/id/" . $dist->pathname);
+
+ if ($source->exists) {
+ warn "Copying ", $dist->pathname, "\n";
+ $target->parent->mkpath;
+ $source->copy($target) or warn "$target: $!";
+ } else {
+ warn "Couldn't find @{[ $dist->pathname ]}\n";
+ }
+ }
+
+ my $has_io_gzip = eval { require IO::Compress::Gzip; 1 };
+
+ my $ext = $has_io_gzip ? ".txt.gz" : ".txt";
+ my $index = $cache_path->child("modules/02packages.details$ext");
+ $index->parent->mkpath;
+
+ warn "Writing $index\n";
+
+ my $out = $index->openw;
+ if ($has_io_gzip) {
+ $out = IO::Compress::Gzip->new($out)
+ or die "gzip failed: $IO::Compress::Gzip::GzipError";
+ }
+
+ $snapshot->index->write($out);
+ close $out;
+
+ unless ($has_io_gzip) {
+ unlink "$index.gz";
+ !system 'gzip', $index
+ or die "Running gzip command failed: $!";
+ }
+}
+
+sub install {
+ my($self, $path) = @_;
+
+ $self->run_install(
+ "-L", $path,
+ (map { ("--mirror", $_->url) } $self->effective_mirrors),
+ ( $self->index ? ("--mirror-index", $self->index) : () ),
+ ( $self->cascade ? "--cascade-search" : () ),
+ ( $self->custom_mirror ? "--mirror-only" : () ),
+ "--save-dists", "$path/cache",
+ $self->groups,
+ "--cpanfile", $self->cpanfile,
+ "--installdeps", $self->cpanfile->dirname,
+ ) or die "Installing modules failed\n";
+}
+
+sub groups {
+ my $self = shift;
+
+ # TODO support --without test (don't need test on deployment)
+ my @options = ('--with-all-features', '--with-develop');
+
+ for my $group (@{$self->without}) {
+ push @options, '--without-develop' if $group eq 'develop';
+ push @options, "--without-feature=$group";
+ }
+
+ return @options;
+}
+
+sub update {
+ my($self, $path, @modules) = @_;
+
+ $self->run_install(
+ "-L", $path,
+ (map { ("--mirror", $_->url) } $self->effective_mirrors),
+ ( $self->custom_mirror ? "--mirror-only" : () ),
+ "--save-dists", "$path/cache",
+ @modules
+ ) or die "Updating modules failed\n";
+}
+
+sub run_install {
+ my($self, @args) = @_;
+
+ require Menlo::CLI::Compat;
+ local $ENV{PERL_CPANM_OPT};
+
+ my $cli = Menlo::CLI::Compat->new;
+ $cli->parse_options("--quiet", "--notest", @args);
+ $cli->run;
+
+ !$cli->status;
+}
+
+1;
--- /dev/null
+package Carton::CLI;
+use strict;
+use warnings;
+use Config;
+use Getopt::Long;
+use Path::Tiny;
+use Try::Tiny;
+use Module::CoreList;
+use Scalar::Util qw(blessed);
+
+use Carton;
+use Carton::Builder;
+use Carton::Mirror;
+use Carton::Snapshot;
+use Carton::Util;
+use Carton::Environment;
+use Carton::Error;
+
+use constant { SUCCESS => 0, INFO => 1, WARN => 2, ERROR => 3 };
+
+our $UseSystem = 0; # 1 for unit testing
+
+use Class::Tiny {
+ verbose => undef,
+ carton => sub { $_[0]->_build_carton },
+ mirror => sub { $_[0]->_build_mirror },
+};
+
+sub _build_mirror {
+ my $self = shift;
+ Carton::Mirror->new($ENV{PERL_CARTON_MIRROR} || $Carton::Mirror::DefaultMirror);
+}
+
+sub run {
+ my($self, @args) = @_;
+
+ my @commands;
+ my $p = Getopt::Long::Parser->new(
+ config => [ "no_ignore_case", "pass_through" ],
+ );
+ $p->getoptionsfromarray(
+ \@args,
+ "h|help" => sub { unshift @commands, 'help' },
+ "v|version" => sub { unshift @commands, 'version' },
+ "verbose!" => sub { $self->verbose($_[1]) },
+ );
+
+ push @commands, @args;
+
+ my $cmd = shift @commands || 'install';
+
+ my $code = try {
+ my $call = $self->can("cmd_$cmd")
+ or Carton::Error::CommandNotFound->throw(error => "Could not find command '$cmd'");
+ $self->$call(@commands);
+ return 0;
+ } catch {
+ die $_ unless blessed $_ && $_->can('rethrow');
+
+ if ($_->isa('Carton::Error::CommandExit')) {
+ return $_->code || 255;
+ } elsif ($_->isa('Carton::Error::CommandNotFound')) {
+ warn $_->error, "\n\n";
+ $self->cmd_usage;
+ return 255;
+ } elsif ($_->isa('Carton::Error')) {
+ warn $_->error, "\n";
+ return 255;
+ }
+ };
+
+ return $code;
+}
+
+sub commands {
+ my $self = shift;
+
+ no strict 'refs';
+ map { s/^cmd_//; $_ }
+ grep { /^cmd_.*/ && $self->can($_) } sort keys %{__PACKAGE__."::"};
+}
+
+sub cmd_usage {
+ my $self = shift;
+ $self->print(<<HELP);
+Usage: carton <command>
+
+where <command> is one of:
+ @{[ join ", ", $self->commands ]}
+
+Run carton -h <command> for help.
+HELP
+}
+
+sub parse_options {
+ my($self, $args, @spec) = @_;
+ my $p = Getopt::Long::Parser->new(
+ config => [ "no_auto_abbrev", "no_ignore_case" ],
+ );
+ $p->getoptionsfromarray($args, @spec);
+}
+
+sub parse_options_pass_through {
+ my($self, $args, @spec) = @_;
+
+ my $p = Getopt::Long::Parser->new(
+ config => [ "no_auto_abbrev", "no_ignore_case", "pass_through" ],
+ );
+ $p->getoptionsfromarray($args, @spec);
+
+ # with pass_through keeps -- in args
+ shift @$args if $args->[0] && $args->[0] eq '--';
+}
+
+sub printf {
+ my $self = shift;
+ my $type = pop;
+ my($temp, @args) = @_;
+ $self->print(sprintf($temp, @args), $type);
+}
+
+sub print {
+ my($self, $msg, $type) = @_;
+ my $fh = $type && $type >= WARN ? *STDERR : *STDOUT;
+ print {$fh} $msg;
+}
+
+sub error {
+ my($self, $msg) = @_;
+ $self->print($msg, ERROR);
+ Carton::Error::CommandExit->throw;
+}
+
+sub cmd_help {
+ my $self = shift;
+ my $module = $_[0] ? ("Carton::Doc::" . ucfirst $_[0]) : "Carton.pm";
+ system "perldoc", $module;
+}
+
+sub cmd_version {
+ my $self = shift;
+ $self->print("carton $Carton::VERSION\n");
+}
+
+sub cmd_bundle {
+ my($self, @args) = @_;
+
+ my $env = Carton::Environment->build;
+ $env->snapshot->load;
+
+ $self->print("Bundling modules using @{[$env->cpanfile]}\n");
+
+ my $builder = Carton::Builder->new(
+ mirror => $self->mirror,
+ cpanfile => $env->cpanfile,
+ );
+ $builder->bundle($env->install_path, $env->vendor_cache, $env->snapshot);
+
+ $self->printf("Complete! Modules were bundled into %s\n", $env->vendor_cache, SUCCESS);
+}
+
+sub cmd_fatpack {
+ my($self, @args) = @_;
+
+ my $env = Carton::Environment->build;
+ require Carton::Packer;
+ Carton::Packer->new->fatpack_carton($env->vendor_bin);
+}
+
+sub cmd_install {
+ my($self, @args) = @_;
+
+ my($install_path, $cpanfile_path, @without);
+
+ $self->parse_options(
+ \@args,
+ "p|path=s" => \$install_path,
+ "cpanfile=s" => \$cpanfile_path,
+ "without=s" => sub { push @without, split /,/, $_[1] },
+ "deployment!" => \my $deployment,
+ "cached!" => \my $cached,
+ );
+
+ my $env = Carton::Environment->build($cpanfile_path, $install_path);
+ $env->snapshot->load_if_exists;
+
+ if ($deployment && !$env->snapshot->loaded) {
+ $self->error("--deployment requires cpanfile.snapshot: Run `carton install` and make sure cpanfile.snapshot is checked into your version control.\n");
+ }
+
+ my $builder = Carton::Builder->new(
+ cascade => 1,
+ mirror => $self->mirror,
+ without => \@without,
+ cpanfile => $env->cpanfile,
+ );
+
+ # TODO: --without with no .lock won't fetch the groups, resulting in insufficient requirements
+
+ if ($deployment) {
+ $self->print("Installing modules using @{[$env->cpanfile]} (deployment mode)\n");
+ $builder->cascade(0);
+ } else {
+ $self->print("Installing modules using @{[$env->cpanfile]}\n");
+ }
+
+ # TODO merge CPANfile git to mirror even if lock doesn't exist
+ if ($env->snapshot->loaded) {
+ my $index_file = $env->install_path->child("cache/modules/02packages.details.txt");
+ $index_file->parent->mkpath;
+
+ $env->snapshot->write_index($index_file);
+ $builder->index($index_file);
+ }
+
+ if ($cached) {
+ $builder->mirror(Carton::Mirror->new($env->vendor_cache));
+ }
+
+ $builder->install($env->install_path);
+
+ unless ($deployment) {
+ $env->cpanfile->load;
+ $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements);
+ $env->snapshot->save;
+ }
+
+ $self->print("Complete! Modules were installed into @{[$env->install_path]}\n", SUCCESS);
+}
+
+sub cmd_show {
+ my($self, @args) = @_;
+
+ my $env = Carton::Environment->build;
+ $env->snapshot->load;
+
+ for my $module (@args) {
+ my $dist = $env->snapshot->find($module)
+ or $self->error("Couldn't locate $module in cpanfile.snapshot\n");
+ $self->print( $dist->name . "\n" );
+ }
+}
+
+sub cmd_list {
+ my($self, @args) = @_;
+
+ my $format = 'name';
+
+ $self->parse_options(
+ \@args,
+ "distfile" => sub { $format = 'distfile' },
+ );
+
+ my $env = Carton::Environment->build;
+ $env->snapshot->load;
+
+ for my $dist ($env->snapshot->distributions) {
+ $self->print($dist->$format . "\n");
+ }
+}
+
+sub cmd_tree {
+ my($self, @args) = @_;
+
+ my $env = Carton::Environment->build;
+ $env->snapshot->load;
+ $env->cpanfile->load;
+
+ my %seen;
+ my $dumper = sub {
+ my($dependency, $reqs, $level) = @_;
+ return if $level == 0;
+ return Carton::Tree::STOP if $dependency->dist->is_core;
+ return Carton::Tree::STOP if $seen{$dependency->distname}++;
+ $self->printf( "%s%s (%s)\n", " " x ($level - 1), $dependency->module, $dependency->distname, INFO );
+ };
+
+ $env->tree->walk_down($dumper);
+}
+
+sub cmd_check {
+ my($self, @args) = @_;
+
+ my $cpanfile_path;
+ $self->parse_options(
+ \@args,
+ "cpanfile=s" => \$cpanfile_path,
+ );
+
+ my $env = Carton::Environment->build($cpanfile_path);
+ $env->snapshot->load;
+ $env->cpanfile->load;
+
+ # TODO remove snapshot
+ # TODO pass git spec to Requirements?
+ my $merged_reqs = $env->tree->merged_requirements;
+
+ my @missing;
+ for my $module ($merged_reqs->required_modules) {
+ my $install = $env->snapshot->find_or_core($module);
+ if ($install) {
+ unless ($merged_reqs->accepts_module($module => $install->version_for($module))) {
+ push @missing, [ $module, 1, $install->version_for($module) ];
+ }
+ } else {
+ push @missing, [ $module, 0 ];
+ }
+ }
+
+ if (@missing) {
+ $self->print("Following dependencies are not satisfied.\n", INFO);
+ for my $missing (@missing) {
+ my($module, $unsatisfied, $version) = @$missing;
+ if ($unsatisfied) {
+ $self->printf(" %s has version %s. Needs %s\n",
+ $module, $version, $merged_reqs->requirements_for_module($module), INFO);
+ } else {
+ $self->printf(" %s is not installed. Needs %s\n",
+ $module, $merged_reqs->requirements_for_module($module), INFO);
+ }
+ }
+ $self->printf("Run `carton install` to install them.\n", INFO);
+ Carton::Error::CommandExit->throw;
+ } else {
+ $self->print("cpanfile's dependencies are satisfied.\n", INFO);
+ }
+}
+
+sub cmd_update {
+ my($self, @args) = @_;
+
+ my $env = Carton::Environment->build;
+ $env->cpanfile->load;
+
+
+ my $cpanfile = Module::CPANfile->load($env->cpanfile);
+ @args = grep { $_ ne 'perl' } $env->cpanfile->required_modules unless @args;
+
+ $env->snapshot->load;
+
+ my @modules;
+ for my $module (@args) {
+ my $dist = $env->snapshot->find_or_core($module)
+ or $self->error("Could not find module $module.\n");
+ next if $dist->is_core;
+ push @modules, "$module~" . $env->cpanfile->requirements_for_module($module);
+ }
+
+ return unless @modules;
+
+ my $builder = Carton::Builder->new(
+ mirror => $self->mirror,
+ cpanfile => $env->cpanfile,
+ );
+ $builder->update($env->install_path, @modules);
+
+ $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements);
+ $env->snapshot->save;
+}
+
+sub cmd_run {
+ my($self, @args) = @_;
+
+ local $UseSystem = 1;
+ $self->cmd_exec(@args);
+}
+
+sub cmd_exec {
+ my($self, @args) = @_;
+
+ my $env = Carton::Environment->build;
+ $env->snapshot->load;
+
+ # allows -Ilib
+ @args = map { /^(-[I])(.+)/ ? ($1,$2) : $_ } @args;
+
+ while (@args) {
+ if ($args[0] eq '-I') {
+ warn "exec -Ilib is deprecated. You might want to run: carton exec perl -Ilib ...\n";
+ splice(@args, 0, 2);
+ } else {
+ last;
+ }
+ }
+
+ $self->parse_options_pass_through(\@args); # to handle --
+
+ unless (@args) {
+ $self->error("carton exec needs a command to run.\n");
+ }
+
+ # PERL5LIB takes care of arch
+ my $path = $env->install_path;
+ local $ENV{PERL5LIB} = "$path/lib/perl5";
+ local $ENV{PATH} = "$path/bin:$ENV{PATH}";
+
+ if ($UseSystem) {
+ system @args;
+ } else {
+ exec @args;
+ exit 127; # command not found
+ }
+}
+
+1;
--- /dev/null
+package Carton::CPANfile;
+use Path::Tiny ();
+use Module::CPANfile;
+
+use overload q{""} => sub { $_[0]->stringify }, fallback => 1;
+
+use subs 'path';
+
+use Class::Tiny {
+ path => undef,
+ _cpanfile => undef,
+ requirements => sub { $_[0]->_build_requirements },
+};
+
+sub stringify { shift->path->stringify(@_) }
+sub dirname { shift->path->dirname(@_) }
+sub prereqs { shift->_cpanfile->prereqs(@_) }
+sub required_modules { shift->requirements->required_modules(@_) }
+sub requirements_for_module { shift->requirements->requirements_for_module(@_) }
+
+sub path {
+ my $self = shift;
+ if (@_) {
+ $self->{path} = Path::Tiny->new($_[0]);
+ } else {
+ $self->{path};
+ }
+}
+
+sub load {
+ my $self = shift;
+ $self->_cpanfile( Module::CPANfile->load($self->path) );
+}
+
+sub _build_requirements {
+ my $self = shift;
+ my $reqs = CPAN::Meta::Requirements->new;
+ $reqs->add_requirements($self->prereqs->requirements_for($_, 'requires'))
+ for qw( configure build runtime test develop );
+ $reqs->clear_requirement('perl');
+ $reqs;
+}
+
+1;
--- /dev/null
+package Carton::Dependency;
+use strict;
+use Class::Tiny {
+ module => undef,
+ requirement => undef,
+ dist => undef,
+};
+
+sub requirements { shift->dist->requirements(@_) }
+
+sub distname {
+ my $self = shift;
+ $self->dist->name;
+}
+
+sub version {
+ my $self = shift;
+ $self->dist->version_for($self->module);
+}
+
+1;
--- /dev/null
+package Carton::Dist;
+use strict;
+use Class::Tiny {
+ name => undef,
+ pathname => undef,
+ provides => sub { +{} },
+ requirements => sub { $_[0]->_build_requirements },
+};
+
+use CPAN::Meta;
+
+sub add_string_requirement { shift->requirements->add_string_requirement(@_) }
+sub required_modules { shift->requirements->required_modules(@_) }
+sub requirements_for_module { shift->requirements->requirements_for_module(@_) }
+
+sub is_core { 0 }
+
+sub distfile {
+ my $self = shift;
+ $self->pathname;
+}
+
+sub _build_requirements {
+ CPAN::Meta::Requirements->new;
+}
+
+sub provides_module {
+ my($self, $module) = @_;
+ exists $self->provides->{$module};
+}
+
+sub version_for {
+ my($self, $module) = @_;
+ $self->provides->{$module}{version};
+}
+
+1;
--- /dev/null
+package Carton::Dist::Core;
+use strict;
+use parent 'Carton::Dist';
+
+use Class::Tiny qw( module_version );
+
+sub BUILDARGS {
+ my($class, %args) = @_;
+
+ # TODO represent dual-life
+ $args{name} =~ s/::/-/g;
+
+ \%args;
+}
+
+sub is_core { 1 }
+
+sub version_for {
+ my($self, $module) = @_;
+ $self->module_version;
+}
+
+1;
--- /dev/null
+package Carton::Environment;
+use strict;
+use Carton::CPANfile;
+use Carton::Snapshot;
+use Carton::Error;
+use Carton::Tree;
+use Path::Tiny;
+
+use Class::Tiny {
+ cpanfile => undef,
+ snapshot => sub { $_[0]->_build_snapshot },
+ install_path => sub { $_[0]->_build_install_path },
+ vendor_cache => sub { $_[0]->_build_vendor_cache },
+ tree => sub { $_[0]->_build_tree },
+};
+
+sub _build_snapshot {
+ my $self = shift;
+ Carton::Snapshot->new(path => $self->cpanfile . ".snapshot");
+}
+
+sub _build_install_path {
+ my $self = shift;
+ if ($ENV{PERL_CARTON_PATH}) {
+ return Path::Tiny->new($ENV{PERL_CARTON_PATH});
+ } else {
+ return $self->cpanfile->path->parent->child("local");
+ }
+}
+
+sub _build_vendor_cache {
+ my $self = shift;
+ Path::Tiny->new($self->install_path->dirname . "/vendor/cache");
+}
+
+sub _build_tree {
+ my $self = shift;
+ Carton::Tree->new(cpanfile => $self->cpanfile, snapshot => $self->snapshot);
+}
+
+sub vendor_bin {
+ my $self = shift;
+ $self->vendor_cache->parent->child('bin');
+}
+
+sub build_with {
+ my($class, $cpanfile) = @_;
+
+ $cpanfile = Path::Tiny->new($cpanfile)->absolute;
+ if ($cpanfile->is_file) {
+ return $class->new(cpanfile => Carton::CPANfile->new(path => $cpanfile));
+ } else {
+ Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: $cpanfile");
+ }
+}
+
+sub build {
+ my($class, $cpanfile_path, $install_path) = @_;
+
+ my $self = $class->new;
+
+ $cpanfile_path &&= Path::Tiny->new($cpanfile_path)->absolute;
+
+ my $cpanfile = $self->locate_cpanfile($cpanfile_path || $ENV{PERL_CARTON_CPANFILE});
+ if ($cpanfile && $cpanfile->is_file) {
+ $self->cpanfile( Carton::CPANfile->new(path => $cpanfile) );
+ } else {
+ Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: (@{[ $cpanfile_path || 'cpanfile' ]})");
+ }
+
+ $self->install_path( Path::Tiny->new($install_path)->absolute ) if $install_path;
+
+ $self;
+}
+
+sub locate_cpanfile {
+ my($self, $path) = @_;
+
+ if ($path) {
+ return Path::Tiny->new($path)->absolute;
+ }
+
+ my $current = Path::Tiny->cwd;
+ my $previous = '';
+
+ until ($current eq '/' or $current eq $previous) {
+ # TODO support PERL_CARTON_CPANFILE
+ my $try = $current->child('cpanfile');
+ if ($try->is_file) {
+ return $try->absolute;
+ }
+
+ ($previous, $current) = ($current, $current->parent);
+ }
+
+ return;
+}
+
+1;
+
--- /dev/null
+package Carton::Error;
+use strict;
+use overload '""' => sub { $_[0]->error };
+use Carp;
+
+sub throw {
+ my($class, @args) = @_;
+ die $class->new(@args);
+}
+
+sub rethrow {
+ die $_[0];
+}
+
+sub new {
+ my($class, %args) = @_;
+ bless \%args, $class;
+}
+
+sub error {
+ $_[0]->{error} || ref $_[0];
+}
+
+package Carton::Error::CommandNotFound;
+use parent 'Carton::Error';
+
+package Carton::Error::CommandExit;
+use parent 'Carton::Error';
+sub code { $_[0]->{code} }
+
+package Carton::Error::CPANfileNotFound;
+use parent 'Carton::Error';
+
+package Carton::Error::SnapshotParseError;
+use parent 'Carton::Error';
+sub path { $_[0]->{path} }
+
+package Carton::Error::SnapshotNotFound;
+use parent 'Carton::Error';
+sub path { $_[0]->{path} }
+
+1;
--- /dev/null
+package Carton::Index;
+use strict;
+use Class::Tiny {
+ _packages => sub { +{} },
+ generator => sub { require Carton; "Carton $Carton::VERSION" },
+};
+
+sub add_package {
+ my($self, $package) = @_;
+ $self->_packages->{$package->name} = $package; # XXX ||=
+}
+
+sub count {
+ my $self = shift;
+ scalar keys %{$self->_packages};
+}
+
+sub packages {
+ my $self = shift;
+ sort { lc $a->name cmp lc $b->name } values %{$self->_packages};
+}
+
+sub write {
+ my($self, $fh) = @_;
+
+ print $fh <<EOF;
+File: 02packages.details.txt
+URL: http://www.perl.com/CPAN/modules/02packages.details.txt
+Description: Package names found in cpanfile.snapshot
+Columns: package name, version, path
+Intended-For: Automated fetch routines, namespace documentation.
+Written-By: @{[ $self->generator ]}
+Line-Count: @{[ $self->count ]}
+Last-Updated: @{[ scalar localtime ]}
+
+EOF
+ for my $p ($self->packages) {
+ print $fh $self->_format_line($p->name, $p->version_format, $p->pathname);
+ }
+}
+
+sub _format_line {
+ my($self, @row) = @_;
+
+ # from PAUSE::mldistwatch::rewrite02
+ my $one = 30;
+ my $two = 8;
+
+ if (length $row[0] > $one) {
+ $one += 8 - length $row[1];
+ $two = length $row[1];
+ }
+
+ sprintf "%-${one}s %${two}s %s\n", @row;
+}
+
+sub pad {
+ my($str, $len, $left) = @_;
+
+ my $howmany = $len - length($str);
+ return $str if $howmany <= 0;
+
+ my $pad = " " x $howmany;
+ return $left ? "$pad$str" : "$str$pad";
+}
+
+
+1;
--- /dev/null
+package Carton::Mirror;
+use strict;
+use Class::Tiny qw( url );
+
+our $DefaultMirror = 'http://cpan.metacpan.org/';
+
+sub BUILDARGS {
+ my($class, $url) = @_;
+ return { url => $url };
+}
+
+sub default {
+ my $class = shift;
+ $class->new($DefaultMirror);
+}
+
+sub is_default {
+ my $self = shift;
+ $self->url eq $DefaultMirror;
+}
+
+1;
+
--- /dev/null
+package Carton::Package;
+use strict;
+use Class::Tiny qw( name version pathname );
+
+sub BUILDARGS {
+ my($class, @args) = @_;
+ return { name => $args[0], version => $args[1], pathname => $args[2] };
+}
+
+sub version_format {
+ my $self = shift;
+ defined $self->version ? $self->version : 'undef';
+}
+
+1;
+
+
--- /dev/null
+package Carton::Packer;
+use Class::Tiny;
+use warnings NONFATAL => 'all';
+use App::FatPacker;
+use File::pushd ();
+use Path::Tiny ();
+use CPAN::Meta ();
+use File::Find ();
+
+sub fatpack_carton {
+ my($self, $dir) = @_;
+
+ my $temp = Path::Tiny->tempdir;
+ my $pushd = File::pushd::pushd $temp;
+
+ my $file = $temp->child('carton.pre.pl');
+
+ $file->spew(<<'EOF');
+#!/usr/bin/env perl
+use strict;
+use 5.008001;
+use Carton::CLI;
+$Carton::Fatpacked = 1;
+exit Carton::CLI->new->run(@ARGV);
+EOF
+
+ my $fatpacked = $self->do_fatpack($file);
+
+ my $executable = $dir->child('carton');
+ warn "Bundling $executable\n";
+
+ $dir->mkpath;
+ $executable->spew($fatpacked);
+ chmod 0755, $executable;
+}
+
+sub do_fatpack {
+ my($self, $file) = @_;
+
+ my $packer = App::FatPacker->new;
+
+ my @modules = split /\r?\n/, $packer->trace(args => [$file], use => $self->required_modules);
+ my @packlists = $packer->packlists_containing(\@modules);
+ $packer->packlists_to_tree(Path::Tiny->new('fatlib')->absolute, \@packlists);
+
+ my $fatpacked = do {
+ local $SIG{__WARN__} = sub {};
+ $packer->fatpack_file($file);
+ };
+
+ # HACK: File::Spec bundled into arch in < 5.16, but is loadable as pure-perl
+ use Config;
+ $fatpacked =~ s/\$fatpacked\{"$Config{archname}\/(Cwd|File)/\$fatpacked{"$1/g;
+
+ $fatpacked;
+}
+
+sub required_modules {
+ my $self = shift;
+
+ my %requirements;
+ for my $dist (qw( Carton Menlo-Legacy Menlo )) {
+ $requirements{$_} = 1 for $self->required_modules_for($dist);
+ }
+
+ # these modules are needed, but lazy-loaded, so FatPacker wont bundle them by default.
+ my @extra = qw(Menlo::Index::Mirror);
+
+ [ keys %requirements, @extra ];
+}
+
+sub required_modules_for {
+ my($self, $dist) = @_;
+
+ my $meta = $self->installed_meta($dist)
+ or die "Couldn't find install metadata for $dist";
+
+ my %excludes = (
+ perl => 1,
+ 'ExtUtils::MakeMaker' => 1,
+ 'Module::Build' => 1,
+ );
+
+ grep !$excludes{$_},
+ $meta->effective_prereqs->requirements_for('runtime', 'requires')->required_modules;
+}
+
+sub installed_meta {
+ my($self, $dist) = @_;
+
+ my @meta;
+ my $finder = sub {
+ if (m!\b$dist-.*[\\/]MYMETA.json!) {
+ my $meta = CPAN::Meta->load_file($_);
+ push @meta, $meta if $meta->name eq $dist;
+ }
+ };
+
+ my @meta_dirs = grep -d, map "$_/.meta", @INC;
+ File::Find::find({ wanted => $finder, no_chdir => 1 }, @meta_dirs)
+ if @meta_dirs;
+
+ # return the latest version
+ @meta = sort { version->new($b->version) cmp version->new($a->version) } @meta;
+
+ return $meta[0];
+}
+
+1;
--- /dev/null
+package Carton::Snapshot;
+use strict;
+use Config;
+use Carton::Dist;
+use Carton::Dist::Core;
+use Carton::Error;
+use Carton::Package;
+use Carton::Index;
+use Carton::Util;
+use Carton::Snapshot::Emitter;
+use Carton::Snapshot::Parser;
+use CPAN::Meta;
+use CPAN::Meta::Requirements;
+use File::Find ();
+use Try::Tiny;
+use Path::Tiny ();
+use Module::CoreList;
+
+use constant CARTON_SNAPSHOT_VERSION => '1.0';
+
+use subs 'path';
+use Class::Tiny {
+ path => undef,
+ version => sub { CARTON_SNAPSHOT_VERSION },
+ loaded => undef,
+ _distributions => sub { +[] },
+};
+
+sub BUILD {
+ my $self = shift;
+ $self->path( $self->{path} );
+}
+
+sub path {
+ my $self = shift;
+ if (@_) {
+ $self->{path} = Path::Tiny->new($_[0]);
+ } else {
+ $self->{path};
+ }
+}
+
+sub load_if_exists {
+ my $self = shift;
+ $self->load if $self->path->is_file;
+}
+
+sub load {
+ my $self = shift;
+
+ return 1 if $self->loaded;
+
+ if ($self->path->is_file) {
+ my $parser = Carton::Snapshot::Parser->new;
+ $parser->parse($self->path->slurp_utf8, $self);
+ $self->loaded(1);
+
+ return 1;
+ } else {
+ Carton::Error::SnapshotNotFound->throw(
+ error => "Can't find cpanfile.snapshot: Run `carton install` to build the snapshot file.",
+ path => $self->path,
+ );
+ }
+}
+
+sub save {
+ my $self = shift;
+ $self->path->spew_utf8( Carton::Snapshot::Emitter->new->emit($self) );
+}
+
+sub find {
+ my($self, $module) = @_;
+ (grep $_->provides_module($module), $self->distributions)[0];
+}
+
+sub find_or_core {
+ my($self, $module) = @_;
+ $self->find($module) || $self->find_in_core($module);
+}
+
+sub find_in_core {
+ my($self, $module) = @_;
+
+ if (exists $Module::CoreList::version{$]}{$module}) {
+ my $version = $Module::CoreList::version{$]}{$module}; # maybe undef
+ return Carton::Dist::Core->new(name => $module, module_version => $version);
+ }
+
+ return;
+}
+
+sub index {
+ my $self = shift;
+
+ my $index = Carton::Index->new;
+ for my $package ($self->packages) {
+ $index->add_package($package);
+ }
+
+ return $index;
+}
+
+sub distributions {
+ @{$_[0]->_distributions};
+}
+
+sub add_distribution {
+ my($self, $dist) = @_;
+ push @{$self->_distributions}, $dist;
+}
+
+sub packages {
+ my $self = shift;
+
+ my @packages;
+ for my $dist ($self->distributions) {
+ while (my($package, $provides) = each %{$dist->provides}) {
+ # TODO what if duplicates?
+ push @packages, Carton::Package->new($package, $provides->{version}, $dist->pathname);
+ }
+ }
+
+ return @packages;
+}
+
+sub write_index {
+ my($self, $file) = @_;
+
+ open my $fh, ">", $file or die $!;
+ $self->index->write($fh);
+}
+
+sub find_installs {
+ my($self, $path, $reqs) = @_;
+
+ my $libdir = "$path/lib/perl5/$Config{archname}/.meta";
+ return {} unless -e $libdir;
+
+ my @installs;
+ my $wanted = sub {
+ if ($_ eq 'install.json') {
+ push @installs, [ $File::Find::name, "$File::Find::dir/MYMETA.json" ];
+ }
+ };
+ File::Find::find($wanted, $libdir);
+
+ my %installs;
+
+ my $accepts = sub {
+ my $module = shift;
+
+ return 0 unless $reqs->accepts_module($module->{name}, $module->{provides}{$module->{name}}{version});
+
+ if (my $exist = $installs{$module->{name}}) {
+ my $old_ver = version::->new($exist->{provides}{$module->{name}}{version});
+ my $new_ver = version::->new($module->{provides}{$module->{name}}{version});
+ return $new_ver >= $old_ver;
+ } else {
+ return 1;
+ }
+ };
+
+ for my $file (@installs) {
+ my $module = Carton::Util::load_json($file->[0]);
+ my $prereqs = -f $file->[1] ? CPAN::Meta->load_file($file->[1])->effective_prereqs : CPAN::Meta::Prereqs->new;
+
+ my $reqs = CPAN::Meta::Requirements->new;
+ $reqs->add_requirements($prereqs->requirements_for($_, 'requires'))
+ for qw( configure build runtime );
+
+ if ($accepts->($module)) {
+ $installs{$module->{name}} = Carton::Dist->new(
+ name => $module->{dist},
+ pathname => $module->{pathname},
+ provides => $module->{provides},
+ version => $module->{version},
+ requirements => $reqs,
+ );
+ }
+ }
+
+ my @new_dists;
+ for my $module (sort keys %installs) {
+ push @new_dists, $installs{$module};
+ }
+
+ $self->_distributions(\@new_dists);
+}
+
+1;
--- /dev/null
+package Carton::Snapshot::Emitter;
+use Class::Tiny;
+use warnings NONFATAL => 'all';
+
+sub emit {
+ my($self, $snapshot) = @_;
+
+ my $data = '';
+ $data .= "# carton snapshot format: version @{[$snapshot->version]}\n";
+ $data .= "DISTRIBUTIONS\n";
+
+ for my $dist (sort { $a->name cmp $b->name } $snapshot->distributions) {
+ $data .= " @{[$dist->name]}\n";
+ $data .= " pathname: @{[$dist->pathname]}\n";
+
+ $data .= " provides:\n";
+ for my $package (sort keys %{$dist->provides}) {
+ my $version = $dist->provides->{$package}{version};
+ $version = 'undef' unless defined $version;
+ $data .= " $package $version\n";
+ }
+
+ $data .= " requirements:\n";
+ for my $module (sort $dist->required_modules) {
+ $data .= " $module @{[ $dist->requirements_for_module($module) || '0' ]}\n";
+ }
+ }
+
+ $data;
+}
+
+1;
--- /dev/null
+package Carton::Snapshot::Parser;
+use Class::Tiny;
+use warnings NONFATAL => 'all';
+use Carton::Dist;
+use Carton::Error;
+
+my $machine = {
+ init => [
+ {
+ re => qr/^\# carton snapshot format: version (1\.0)/,
+ code => sub {
+ my($stash, $snapshot, $ver) = @_;
+ $snapshot->version($ver);
+ },
+ goto => 'section',
+ },
+ # TODO support pasing error and version mismatch etc.
+ ],
+ section => [
+ {
+ re => qr/^DISTRIBUTIONS$/,
+ goto => 'dists',
+ },
+ {
+ re => qr/^__EOF__$/,
+ done => 1,
+ },
+ ],
+ dists => [
+ {
+ re => qr/^ (\S+)$/,
+ code => sub { $_[0]->{dist} = Carton::Dist->new(name => $1) },
+ goto => 'distmeta',
+ },
+ {
+ re => qr/^\S/,
+ goto => 'section',
+ redo => 1,
+ },
+ ],
+ distmeta => [
+ {
+ re => qr/^ pathname: (.*)$/,
+ code => sub { $_[0]->{dist}->pathname($1) },
+ },
+ {
+ re => qr/^\s{4}provides:$/,
+ code => sub { $_[0]->{property} = 'provides' },
+ goto => 'properties',
+ },
+ {
+ re => qr/^\s{4}requirements:$/,
+ code => sub {
+ $_[0]->{property} = 'requirements';
+ },
+ goto => 'properties',
+ },
+ {
+ re => qr/^\s{0,2}\S/,
+ code => sub {
+ my($stash, $snapshot) = @_;
+ $snapshot->add_distribution($stash->{dist});
+ %$stash = (); # clear
+ },
+ goto => 'dists',
+ redo => 1,
+ },
+ ],
+ properties => [
+ {
+ re => qr/^\s{6}([0-9A-Za-z_:]+) ([v0-9\._,=\!<>\s]+|undef)/,
+ code => sub {
+ my($stash, $snapshot, $module, $version) = @_;
+ if ($stash->{property} eq 'provides') {
+ $stash->{dist}->provides->{$module} = { version => $version };
+ } else {
+ $stash->{dist}->add_string_requirement($module, $version);
+ }
+ },
+ },
+ {
+ re => qr/^\s{0,4}\S/,
+ goto => 'distmeta',
+ redo => 1,
+ },
+ ],
+};
+
+sub parse {
+ my($self, $data, $snapshot) = @_;
+
+ my @lines = split /\r?\n/, $data;
+
+ my $state = $machine->{init};
+ my $stash = {};
+
+ LINE:
+ for my $line (@lines, '__EOF__') {
+ last LINE unless @$state;
+
+ STATE: {
+ for my $trans (@{$state}) {
+ if (my @match = $line =~ $trans->{re}) {
+ if (my $code = $trans->{code}) {
+ $code->($stash, $snapshot, @match);
+ }
+ if (my $goto = $trans->{goto}) {
+ $state = $machine->{$goto};
+ if ($trans->{redo}) {
+ redo STATE;
+ } else {
+ next LINE;
+ }
+ }
+
+ last STATE;
+ }
+ }
+
+ Carton::Error::SnapshotParseError->throw(error => "Could not parse snapshot file: $line");
+ }
+ }
+}
+
+1;
--- /dev/null
+package Carton::Tree;
+use strict;
+use Carton::Dependency;
+
+use Class::Tiny qw( cpanfile snapshot );
+
+use constant STOP => -1;
+
+sub walk_down {
+ my($self, $cb) = @_;
+
+ my $dumper; $dumper = sub {
+ my($dependency, $reqs, $level, $parent) = @_;
+
+ my $ret = $cb->($dependency, $reqs, $level);
+ return if $ret && $ret == STOP;
+
+ local $parent->{$dependency->distname} = 1 if $dependency;
+
+ for my $module (sort $reqs->required_modules) {
+ my $dependency = $self->dependency_for($module, $reqs);
+ if ($dependency->dist) {
+ next if $parent->{$dependency->distname};
+ $dumper->($dependency, $dependency->requirements, $level + 1, $parent);
+ } else {
+ # no dist found in lock
+ }
+ }
+ };
+
+ $dumper->(undef, $self->cpanfile->requirements, 0, {});
+ undef $dumper;
+}
+
+sub dependency_for {
+ my($self, $module, $reqs) = @_;
+
+ my $requirement = $reqs->requirements_for_module($module);
+
+ my $dep = Carton::Dependency->new;
+ $dep->module($module);
+ $dep->requirement($requirement);
+
+ if (my $dist = $self->snapshot->find_or_core($module)) {
+ $dep->dist($dist);
+ }
+
+ return $dep;
+}
+
+sub merged_requirements {
+ my $self = shift;
+
+ my $merged_reqs = CPAN::Meta::Requirements->new;
+
+ my %seen;
+ $self->walk_down(sub {
+ my($dependency, $reqs, $level) = @_;
+ return Carton::Tree::STOP if $dependency && $seen{$dependency->distname}++;
+ $merged_reqs->add_requirements($reqs);
+ });
+
+ $merged_reqs->clear_requirement('perl');
+ $merged_reqs->finalize;
+
+ $merged_reqs;
+}
+
+1;
--- /dev/null
+package Carton::Util;
+use strict;
+use warnings;
+
+sub load_json {
+ my $file = shift;
+
+ open my $fh, "<", $file or die "$file: $!";
+ from_json(join '', <$fh>);
+}
+
+sub dump_json {
+ my($data, $file) = @_;
+
+ open my $fh, ">", $file or die "$file: $!";
+ binmode $fh;
+ print $fh to_json($data);
+}
+
+sub from_json {
+ require JSON::PP;
+ JSON::PP->new->utf8->decode($_[0])
+}
+
+sub to_json {
+ my($data) = @_;
+ require JSON::PP;
+ JSON::PP->new->utf8->pretty->canonical->encode($data);
+}
+
+1;
--- /dev/null
+use 5.006;
+use strict;
+no strict 'refs';
+use warnings;
+
+package Class::Tiny;
+# ABSTRACT: Minimalist class construction
+
+our $VERSION = '1.006';
+
+use Carp ();
+
+# load as .pm to hide from min version scanners
+require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic:
+
+my %CLASS_ATTRIBUTES;
+
+sub import {
+ my $class = shift;
+ my $pkg = caller;
+ $class->prepare_class($pkg);
+ $class->create_attributes( $pkg, @_ ) if @_;
+}
+
+sub prepare_class {
+ my ( $class, $pkg ) = @_;
+ @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"};
+}
+
+# adapted from Object::Tiny and Object::Tiny::RW
+sub create_attributes {
+ my ( $class, $pkg, @spec ) = @_;
+ my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec;
+ my @attr = grep {
+ defined and !ref and /^[^\W\d]\w*$/s
+ or Carp::croak "Invalid accessor name '$_'"
+ } keys %defaults;
+ $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr;
+ $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr;
+ Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
+}
+
+sub _gen_accessor {
+ my ( $class, $pkg, $name ) = @_;
+ my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name};
+
+ my $sub =
+ $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) );
+
+ # default = outer_default avoids "won't stay shared" bug
+ eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic
+ Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@;
+}
+
+# NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and
+# could break if the internals of Class::Tiny need to change for any
+# reason. That said, I currently see no reason why this would be likely to
+# change.
+#
+# The generated sub body should assume that a '$default' variable will be
+# in scope (i.e. when the sub is evaluated) with any default value/coderef
+sub __gen_sub_body {
+ my ( $self, $name, $has_default, $default_type ) = @_;
+
+ if ( $has_default && $default_type eq 'CODE' ) {
+ return << "HERE";
+sub $name {
+ return (
+ ( \@_ == 1 && exists \$_[0]{$name} )
+ ? ( \$_[0]{$name} )
+ : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) )
+ );
+}
+HERE
+ }
+ elsif ($has_default) {
+ return << "HERE";
+sub $name {
+ return (
+ ( \@_ == 1 && exists \$_[0]{$name} )
+ ? ( \$_[0]{$name} )
+ : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default )
+ );
+}
+HERE
+ }
+ else {
+ return << "HERE";
+sub $name {
+ return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} = \$_[1] );
+}
+HERE
+ }
+}
+
+sub get_all_attributes_for {
+ my ( $class, $pkg ) = @_;
+ my %attr =
+ map { $_ => undef }
+ map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) };
+ return keys %attr;
+}
+
+sub get_all_attribute_defaults_for {
+ my ( $class, $pkg ) = @_;
+ my $defaults = {};
+ for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) {
+ while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) {
+ $defaults->{$k} = $v;
+ }
+ }
+ return $defaults;
+}
+
+package Class::Tiny::Object;
+# ABSTRACT: Base class for classes built with Class::Tiny
+
+our $VERSION = '1.006';
+
+my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE );
+
+my $_PRECACHE = sub {
+ no warnings 'once'; # needed to avoid downstream warnings
+ my ($class) = @_;
+ my $linear_isa =
+ @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object"
+ ? [$class]
+ : mro::get_linear_isa($class);
+ $DEMOLISH_CACHE{$class} = [
+ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
+ map { "$_\::DEMOLISH" } @$linear_isa
+ ];
+ $BUILD_CACHE{$class} = [
+ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () }
+ map { "$_\::BUILD" } reverse @$linear_isa
+ ];
+ $HAS_BUILDARGS{$class} = $class->can("BUILDARGS");
+ return $ATTR_CACHE{$class} =
+ { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) };
+};
+
+sub new {
+ my $class = shift;
+ my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class);
+
+ # handle hash ref or key/value arguments
+ my $args;
+ if ( $HAS_BUILDARGS{$class} ) {
+ $args = $class->BUILDARGS(@_);
+ }
+ else {
+ if ( @_ == 1 && ref $_[0] ) {
+ my %copy = eval { %{ $_[0] } }; # try shallow copy
+ Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@;
+ $args = \%copy;
+ }
+ elsif ( @_ % 2 == 0 ) {
+ $args = {@_};
+ }
+ else {
+ Carp::croak("$class->new() got an odd number of elements");
+ }
+ }
+
+ # create object and invoke BUILD (unless we were given __no_BUILD__)
+ my $self =
+ bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args },
+ $class;
+ $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} };
+
+ return $self;
+}
+
+sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } }
+
+# Adapted from Moo and its dependencies
+require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE};
+
+sub DESTROY {
+ my $self = shift;
+ my $class = ref $self;
+ my $in_global_destruction =
+ defined ${^GLOBAL_PHASE}
+ ? ${^GLOBAL_PHASE} eq 'DESTRUCT'
+ : Devel::GlobalDestruction::in_global_destruction();
+ for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) {
+ my $e = do {
+ local ( $?, $@ );
+ eval { $demolisher->( $self, $in_global_destruction ) };
+ $@;
+ };
+ no warnings 'misc'; # avoid (in cleanup) warnings
+ die $e if $e; # rethrow
+ }
+}
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Class::Tiny - Minimalist class construction
+
+=head1 VERSION
+
+version 1.006
+
+=head1 SYNOPSIS
+
+In F<Person.pm>:
+
+ package Person;
+
+ use Class::Tiny qw( name );
+
+ 1;
+
+In F<Employee.pm>:
+
+ package Employee;
+ use parent 'Person';
+
+ use Class::Tiny qw( ssn ), {
+ timestamp => sub { time } # attribute with default
+ };
+
+ 1;
+
+In F<example.pl>:
+
+ use Employee;
+
+ my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" );
+
+ # unknown attributes are ignored
+ my $obj = Employee->new( name => "Larry", OS => "Linux" );
+ # $obj->{OS} does not exist
+
+=head1 DESCRIPTION
+
+This module offers a minimalist class construction kit in around 120 lines of
+code. Here is a list of features:
+
+=over 4
+
+=item *
+
+defines attributes via import arguments
+
+=item *
+
+generates read-write accessors
+
+=item *
+
+supports lazy attribute defaults
+
+=item *
+
+supports custom accessors
+
+=item *
+
+superclass provides a standard C<new> constructor
+
+=item *
+
+C<new> takes a hash reference or list of key/value pairs
+
+=item *
+
+C<new> supports providing C<BUILDARGS> to customize constructor options
+
+=item *
+
+C<new> calls C<BUILD> for each class from parent to child
+
+=item *
+
+superclass provides a C<DESTROY> method
+
+=item *
+
+C<DESTROY> calls C<DEMOLISH> for each class from child to parent
+
+=back
+
+Multiple-inheritance is possible, with superclass order determined via
+L<mro::get_linear_isa|mro/Functions>.
+
+It uses no non-core modules for any recent Perl. On Perls older than v5.10 it
+requires L<MRO::Compat>. On Perls older than v5.14, it requires
+L<Devel::GlobalDestruction>.
+
+=head1 USAGE
+
+=head2 Defining attributes
+
+Define attributes as a list of import arguments:
+
+ package Foo::Bar;
+
+ use Class::Tiny qw(
+ name
+ id
+ height
+ weight
+ );
+
+For each attribute, a read-write accessor is created unless a subroutine of that
+name already exists:
+
+ $obj->name; # getter
+ $obj->name( "John Doe" ); # setter
+
+Attribute names must be valid subroutine identifiers or an exception will
+be thrown.
+
+You can specify lazy defaults by defining attributes with a hash reference.
+Keys define attribute names and values are constants or code references that
+will be evaluated when the attribute is first accessed if no value has been
+set. The object is passed as an argument to a code reference.
+
+ package Foo::WithDefaults;
+
+ use Class::Tiny qw/name id/, {
+ title => 'Peon',
+ skills => sub { [] },
+ hire_date => sub { $_[0]->_build_hire_date },
+ };
+
+When subclassing, if multiple accessors of the same name exist in different
+classes, any default (or lack of default) is determined by standard
+method resolution order.
+
+To make your own custom accessors, just pre-declare the method name before
+loading Class::Tiny:
+
+ package Foo::Bar;
+
+ use subs 'id';
+
+ use Class::Tiny qw( name id );
+
+ sub id { ... }
+
+Even if you pre-declare a method name, you must include it in the attribute
+list for Class::Tiny to register it as a valid attribute.
+
+If you set a default for a custom accessor, your accessor will need to retrieve
+the default and do something with it:
+
+ package Foo::Bar;
+
+ use subs 'id';
+
+ use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } };
+
+ sub id {
+ my $self = shift;
+ if (@_) {
+ return $self->{id} = shift;
+ }
+ elsif ( exists $self->{id} ) {
+ return $self->{id};
+ }
+ else {
+ my $defaults =
+ Class::Tiny->get_all_attribute_defaults_for( ref $self );
+ return $self->{id} = $defaults->{id}->();
+ }
+ }
+
+=head2 Class::Tiny::Object is your base class
+
+If your class B<does not> already inherit from some class, then
+Class::Tiny::Object will be added to your C<@ISA> to provide C<new> and
+C<DESTROY>.
+
+If your class B<does> inherit from something, then no additional inheritance is
+set up. If the parent subclasses Class::Tiny::Object, then all is well. If
+not, then you'll get accessors set up but no constructor or destructor. Don't
+do that unless you really have a special need for it.
+
+Define subclasses as normal. It's best to define them with L<base>, L<parent>
+or L<superclass> before defining attributes with Class::Tiny so the C<@ISA>
+array is already populated at compile-time:
+
+ package Foo::Bar::More;
+
+ use parent 'Foo::Bar';
+
+ use Class::Tiny qw( shoe_size );
+
+=head2 Object construction
+
+If your class inherits from Class::Tiny::Object (as it should if you followed
+the advice above), it provides the C<new> constructor for you.
+
+Objects can be created with attributes given as a hash reference or as a list
+of key/value pairs:
+
+ $obj = Foo::Bar->new( name => "David" );
+
+ $obj = Foo::Bar->new( { name => "David" } );
+
+If a reference is passed as a single argument, it must be able to be
+dereferenced as a hash or an exception is thrown.
+
+Unknown attributes in the constructor arguments will be ignored. Prior to
+version 1.000, unknown attributes were an error, but this made it harder for
+people to cleanly subclass Class::Tiny classes so this feature was removed.
+
+You can define a C<BUILDARGS> method to change how arguments to new are
+handled. It will receive the constructor arguments as they were provided and
+must return a hash reference of key/value pairs (or else throw an
+exception).
+
+ sub BUILDARGS {
+ my $class = shift;
+ my $name = shift || "John Doe";
+ return { name => $name };
+ };
+
+ Foo::Bar->new( "David" );
+ Foo::Bar->new(); # "John Doe"
+
+Unknown attributes returned from C<BUILDARGS> will be ignored.
+
+=head2 BUILD
+
+If your class or any superclass defines a C<BUILD> method, it will be called
+by the constructor from the furthest parent class down to the child class after
+the object has been created.
+
+It is passed the constructor arguments as a hash reference. The return value
+is ignored. Use C<BUILD> for validation, checking required attributes or
+setting default values that depend on other attributes.
+
+ sub BUILD {
+ my ($self, $args) = @_;
+
+ for my $req ( qw/name age/ ) {
+ croak "$req attribute required" unless defined $self->$req;
+ }
+
+ croak "Age must be non-negative" if $self->age < 0;
+
+ $self->msg( "Hello " . $self->name );
+ }
+
+The argument reference is a copy, so deleting elements won't affect data in the
+original (but changes will be passed to other BUILD methods in C<@ISA>).
+
+=head2 DEMOLISH
+
+Class::Tiny provides a C<DESTROY> method. If your class or any superclass
+defines a C<DEMOLISH> method, they will be called from the child class to the
+furthest parent class during object destruction. It is provided a single
+boolean argument indicating whether Perl is in global destruction. Return
+values and errors are ignored.
+
+ sub DEMOLISH {
+ my ($self, $global_destruct) = @_;
+ $self->cleanup();
+ }
+
+=head2 Introspection and internals
+
+You can retrieve an unsorted list of valid attributes known to Class::Tiny
+for a class and its superclasses with the C<get_all_attributes_for> class
+method.
+
+ my @attrs = Class::Tiny->get_all_attributes_for("Employee");
+ # returns qw/name ssn timestamp/
+
+Likewise, a hash reference of all valid attributes and default values (or code
+references) may be retrieved with the C<get_all_attribute_defaults_for> class
+method. Any attributes without a default will be C<undef>.
+
+ my $def = Class::Tiny->get_all_attribute_defaults_for("Employee");
+ # returns {
+ # name => undef,
+ # ssn => undef
+ # timestamp => $coderef
+ # }
+
+The C<import> method uses two class methods, C<prepare_class> and
+C<create_attributes> to set up the C<@ISA> array and attributes. Anyone
+attempting to extend Class::Tiny itself should use these instead of mocking up
+a call to C<import>.
+
+When the first object is created, linearized C<@ISA>, the valid attribute list
+and various subroutine references are cached for speed. Ensure that all
+inheritance and methods are in place before creating objects. (You don't want
+to be changing that once you create objects anyway, right?)
+
+=for Pod::Coverage new get_all_attributes_for get_all_attribute_defaults_for
+prepare_class create_attributes
+
+=head1 RATIONALE
+
+=head2 Why this instead of Object::Tiny or Class::Accessor or something else?
+
+I wanted something so simple that it could potentially be used by core Perl
+modules I help maintain (or hope to write), most of which either use
+L<Class::Struct> or roll-their-own OO framework each time.
+
+L<Object::Tiny> and L<Object::Tiny::RW> were close to what I wanted, but
+lacking some features I deemed necessary, and their maintainers have an even
+more strict philosophy against feature creep than I have.
+
+I also considered L<Class::Accessor>, which has been around a long time and is
+heavily used, but it, too, lacked features I wanted and did things in ways I
+considered poor design.
+
+I looked for something else on CPAN, but after checking a dozen class creators
+I realized I could implement exactly what I wanted faster than I could search
+CPAN for something merely sufficient.
+
+In general, compared to most things on CPAN (other than Object::Tiny),
+Class::Tiny is smaller in implementation and simpler in API.
+
+Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny
+("O::T") and Class::Accessor ("C::A"):
+
+ FEATURE C::T O::T C::A
+ --------------------------------------------------------------
+ attributes defined via import yes yes no
+ read/write accessors yes no yes
+ lazy attribute defaults yes no no
+ provides new yes yes yes
+ provides DESTROY yes no no
+ new takes either hashref or list yes no (list) no (hash)
+ Moo(se)-like BUILD/DEMOLISH yes no no
+ Moo(se)-like BUILDARGS yes no no
+ no extraneous methods via @ISA yes yes no
+
+=head2 Why this instead of Moose or Moo?
+
+L<Moose> and L<Moo> are both excellent OO frameworks. Moose offers a powerful
+meta-object protocol (MOP), but is slow to start up and has about 30 non-core
+dependencies including XS modules. Moo is faster to start up and has about 10
+pure Perl dependencies but provides no true MOP, relying instead on its ability
+to transparently upgrade Moo to Moose when Moose's full feature set is
+required.
+
+By contrast, Class::Tiny has no MOP and has B<zero> non-core dependencies for
+Perls in the L<support window|perlpolicy>. It has far less code, less
+complexity and no learning curve. If you don't need or can't afford what Moo or
+Moose offer, this is intended to be a reasonable fallback.
+
+That said, Class::Tiny offers Moose-like conventions for things like C<BUILD>
+and C<DEMOLISH> for some minimal interoperability and an easier upgrade path.
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/dagolden/Class-Tiny/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/dagolden/Class-Tiny>
+
+ git clone https://github.com/dagolden/Class-Tiny.git
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Dagfinn Ilmari Mannsåker David Golden Gelu Lupas Karen Etheridge Olivier Mengué Toby Inkster
+
+=over 4
+
+=item *
+
+Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+=item *
+
+David Golden <xdg@xdg.me>
+
+=item *
+
+Gelu Lupas <gelu@devnull.ro>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Olivier Mengué <dolmen@cpan.org>
+
+=item *
+
+Toby Inkster <tobyink@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2013 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+package Command::Runner;
+use strict;
+use warnings;
+
+use Capture::Tiny ();
+use Command::Runner::Format ();
+use Command::Runner::LineBuffer;
+use Command::Runner::Quote ();
+use Config ();
+use IO::Select;
+use POSIX ();
+use Time::HiRes ();
+
+use constant WIN32 => $^O eq 'MSWin32';
+
+our $VERSION = '0.102';
+our $TICK = 0.02;
+
+sub new {
+ my ($class, %option) = @_;
+ my $command = delete $option{command};
+ my $commandf = delete $option{commandf};
+ die "Cannot specify both command and commandf" if $command && $commandf;
+ if (!$command && $commandf) {
+ $command = Command::Runner::Format::commandf @$commandf;
+ }
+ bless {
+ keep => 1,
+ _buffer => {},
+ %option,
+ ($command ? (command => $command) : ()),
+ }, $class;
+}
+
+for my $attr (qw(command redirect timeout keep stdout stderr env)) {
+ no strict 'refs';
+ *$attr = sub {
+ my $self = shift;
+ $self->{$attr} = $_[0];
+ $self;
+ };
+}
+
+sub commandf {
+ my ($self, $format, @args) = @_;
+ $self->{command} = Command::Runner::Format::commandf $format, @args;
+ $self;
+}
+
+sub run {
+ my $self = shift;
+ local %ENV = %{$self->{env}} if $self->{env};
+ my $command = $self->{command};
+ if (ref $command eq 'CODE') {
+ $self->_wrap(sub { $self->_run_code($command) });
+ } elsif (WIN32) {
+ $self->_wrap(sub { $self->_system_win32($command) });
+ } else {
+ $self->_exec($command);
+ }
+}
+
+sub _wrap {
+ my ($self, $code) = @_;
+
+ my ($stdout, $stderr, $res);
+ if ($self->{redirect}) {
+ ($stdout, $res) = &Capture::Tiny::capture_merged($code);
+ } else {
+ ($stdout, $stderr, $res) = &Capture::Tiny::capture($code);
+ }
+
+ if (length $stdout and my $sub = $self->{stdout}) {
+ my $buffer = Command::Runner::LineBuffer->new(buffer => $stdout);
+ my @line = $buffer->get(1);
+ $sub->($_) for @line;
+ }
+ if (!$self->{redirect} and length $stderr and my $sub = $self->{stderr}) {
+ my $buffer = Command::Runner::LineBuffer->new(buffer => $stderr);
+ my @line = $buffer->get(1);
+ $sub->($_) for @line;
+ }
+
+ if ($self->{keep}) {
+ $res->{stdout} = $stdout;
+ $res->{stderr} = $stderr;
+ }
+
+ return $res;
+}
+
+sub _run_code {
+ my ($self, $code) = @_;
+
+ if (!$self->{timeout}) {
+ my $result = $code->();
+ return { pid => $$, result => $result };
+ }
+
+ my ($result, $err);
+ {
+ local $SIG{__DIE__} = 'DEFAULT';
+ local $SIG{ALRM} = sub { die "__TIMEOUT__\n" };
+ eval {
+ alarm $self->{timeout};
+ $result = $code->();
+ };
+ $err = $@;
+ alarm 0;
+ }
+ if (!$err) {
+ return { pid => $$, result => $result, };
+ } elsif ($err eq "__TIMEOUT__\n") {
+ return { pid => $$, result => $result, timeout => 1 };
+ } else {
+ die $err;
+ }
+}
+
+sub _system_win32 {
+ my ($self, $command) = @_;
+
+ my $pid;
+ if (ref $command) {
+ my @cmd = map { Command::Runner::Quote::quote_win32($_) } @$command;
+ $pid = system { $command->[0] } 1, @cmd;
+ } else {
+ $pid = system 1, $command;
+ }
+
+ my $timeout_at = $self->{timeout} ? Time::HiRes::time() + $self->{timeout} : undef;
+ my $INT; local $SIG{INT} = sub { $INT++ };
+ my ($result, $timeout);
+ while (1) {
+ if ($INT) {
+ kill INT => $pid;
+ $INT = 0;
+ }
+
+ my $res = waitpid $pid, POSIX::WNOHANG();
+ if ($res == -1) {
+ warn "waitpid($pid, POSIX::WNOHANG()) returns unexpectedly -1";
+ last;
+ } elsif ($res > 0) {
+ $result = $?;
+ last;
+ } else {
+ if ($timeout_at) {
+ my $now = Time::HiRes::time();
+ if ($timeout_at <= $now) {
+ $timeout = 1;
+ kill TERM => $pid;
+ }
+ }
+ Time::HiRes::sleep($TICK);
+ }
+ }
+ return { pid => $pid, result => $result, timeout => $timeout };
+}
+
+sub _exec {
+ my ($self, $command) = @_;
+
+ pipe my $stdout_read, my $stdout_write;
+ $self->{_buffer}{stdout} = Command::Runner::LineBuffer->new(keep => $self->{keep});
+
+ my ($stderr_read, $stderr_write);
+ if (!$self->{redirect}) {
+ pipe $stderr_read, $stderr_write;
+ $self->{_buffer}{stderr} = Command::Runner::LineBuffer->new(keep => $self->{keep});
+ }
+
+ my $pid = fork;
+ die "fork: $!" unless defined $pid;
+ if ($pid == 0) {
+ close $_ for grep $_, $stdout_read, $stderr_read;
+ open STDOUT, ">&", $stdout_write;
+ if ($self->{redirect}) {
+ open STDERR, ">&", \*STDOUT;
+ } else {
+ open STDERR, ">&", $stderr_write;
+ }
+ if ($Config::Config{d_setpgrp}) {
+ POSIX::setpgid(0, 0) or die "setpgid: $!";
+ }
+
+ if (ref $command) {
+ exec { $command->[0] } @$command;
+ } else {
+ exec $command;
+ }
+ exit 127;
+ }
+ close $_ for grep $_, $stdout_write, $stderr_write;
+
+ my $signal_pid = $Config::Config{d_setpgrp} ? -$pid : $pid;
+
+ my $INT; local $SIG{INT} = sub { $INT++ };
+ my $timeout;
+ my $timeout_at = $self->{timeout} ? Time::HiRes::time() + $self->{timeout} : undef;
+ my $select = IO::Select->new(grep $_, $stdout_read, $stderr_read);
+
+ while ($select->count) {
+ if ($INT) {
+ kill INT => $signal_pid;
+ $INT = 0;
+ }
+ if ($timeout_at and !$timeout) {
+ my $now = Time::HiRes::time();
+ if ($now > $timeout_at) {
+ $timeout++;
+ kill TERM => $signal_pid;
+ }
+ }
+
+ for my $ready ($select->can_read($TICK)) {
+ my $type = $ready == $stdout_read ? "stdout" : "stderr";
+ my $len = sysread $ready, my $buf, 64*1024;
+ if ($len) {
+ my $buffer = $self->{_buffer}{$type};
+ $buffer->add($buf);
+ next unless my @line = $buffer->get;
+ next unless my $sub = $self->{$type};
+ $sub->($_) for @line;
+ } else {
+ warn "sysread $type pipe failed: $!" unless defined $len;
+ $select->remove($ready);
+ close $ready;
+ }
+ }
+ }
+ for my $type (qw(stdout stderr)) {
+ next unless my $sub = $self->{$type};
+ my $buffer = $self->{_buffer}{$type} or next;
+ my @line = $buffer->get(1) or next;
+ $sub->($_) for @line;
+ }
+ close $_ for $select->handles;
+ waitpid $pid, 0;
+ my $res = {
+ pid => $pid,
+ result => $?,
+ timeout => $timeout,
+ stdout => $self->{_buffer}{stdout} ? $self->{_buffer}{stdout}->raw : "",
+ stderr => $self->{_buffer}{stderr} ? $self->{_buffer}{stderr}->raw : "",
+ };
+ $self->{_buffer} = +{}; # cleanup
+ return $res;
+}
+
+1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+Command::Runner - run external commands and Perl code refs
+
+=head1 SYNOPSIS
+
+ use Command::Runner;
+
+ my $cmd = Command::Runner->new(
+ command => ['ls', '-al'],
+ timeout => 10,
+ stdout => sub { warn "out: $_[0]\n" },
+ stderr => sub { warn "err: $_[0]\n" },
+ );
+ my $res = $cmd->run;
+
+ my $untar = Command::Runner->new;
+ $untar->commandf(
+ '%q -dc %q | %q tf -',
+ 'C:\\Program Files (x86)\\GnuWin32\\bin\\gzip.EXE',
+ 'File-ShareDir-Install-0.13.tar.gz'
+ 'C:\\Program Files (x86)\\GnuWin32\\bin\\tar.EXE',
+ );
+ my $capture = $untar->run->{stdout};
+
+=head1 DESCRIPTION
+
+Command::Runner runs external commands and Perl code refs
+
+=head1 METHODS
+
+=head2 new
+
+A constructor, which takes:
+
+=over 4
+
+=item command
+
+an array of external commands, a string of external programs, or a Perl code ref.
+If an array of external commands is specified, it is automatically quoted on Windows.
+
+=item commandf
+
+a command string by C<sprintf>-like syntax.
+You can use positional formatting together with a conversion C<%q> (with quoting).
+
+Here is an example:
+
+ my $cmd = Command::Runner->new(
+ commandf => [ '%q %q >> %q', '/path/to/cat', 'foo bar.txt', 'out.txt' ],
+ );
+
+ # or, you can set it separately
+ my $cmd = Command::Runner->new;
+ $cmd->commandf('%q %q >> %q', '/path/to/cat', 'foo bar.txt', 'out.txt');
+
+=item timeout
+
+timeout second. You can set float second.
+
+=item redirect
+
+if this is true, stderr redirects to stdout
+
+=item keep
+
+by default, even if stdout/stderr is consumed, it is preserved for return value.
+You can disable this behavior by setting keep option false.
+
+=item stdout / stderr
+
+a code ref that will be called whenever stdout/stderr is available
+
+=item env
+
+set environment variables.
+
+ Command::Runner->new(..., env => \%env)->run
+
+is equivalent to
+
+ {
+ local %ENV = %env;
+ Command::Runner->new(...)->run;
+ }
+
+=back
+
+=head2 run
+
+Run command. It returns a hash reference, which contains:
+
+=over 4
+
+=item result
+
+=item timeout
+
+=item stdout
+
+=item stderr
+
+=item pid
+
+=back
+
+=head1 MOTIVATION
+
+I develop a CPAN client L<App::cpm>, where I need to execute external commands and Perl code refs with:
+
+=over 4
+
+=item timeout
+
+=item quoting
+
+=item flexible logging
+
+=back
+
+While L<App::cpanminus> has excellent APIs for such use, I still needed to tweak them in L<App::cpm>.
+
+So I ended up creating a seperate module, Command::Runner.
+
+=head1 AUTHOR
+
+Shoichi Kaji <skaji@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2017 Shoichi Kaji <skaji@cpan.org>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package Command::Runner::Format;
+use strict;
+use warnings;
+
+use Command::Runner::Quote 'quote';
+
+use Exporter 'import';
+our @EXPORT_OK = qw(commandf);
+
+# taken from String::Format
+my $regex = qr/
+ (% # leading '%' $1
+ (-)? # left-align, rather than right $2
+ (\d*)? # (optional) minimum field width $3
+ (?:\.(\d*))? # (optional) maximum field width $4
+ (\{.*?\})? # (optional) stuff inside $5
+ (\S) # actual format character $6
+ )/x;
+
+sub commandf {
+ my ($format, @args) = @_;
+ my $i = 0;
+ $format =~ s{$regex}{
+ $6 eq '%' ? '%' : _replace($args[$i++], $1, $6)
+ }ge;
+ $format;
+}
+
+sub _replace {
+ my ($arg, $all, $char) = @_;
+ if ($char eq 'q') {
+ return quote $arg;
+ } else {
+ return sprintf $all, $arg;
+ }
+}
+
+1;
--- /dev/null
+package Command::Runner::LineBuffer;
+use strict;
+use warnings;
+
+sub new {
+ my ($class, %args) = @_;
+ my $buffer = exists $args{buffer} ? $args{buffer} : "";
+ bless {
+ buffer => $buffer,
+ $args{keep} ? (keep => $buffer) : (),
+ }, $class;
+}
+
+sub raw {
+ my $self = shift;
+ exists $self->{keep} ? $self->{keep} : undef;
+}
+
+sub add {
+ my ($self, $buffer) = @_;
+ $self->{buffer} .= $buffer;
+ $self->{keep} .= $buffer if exists $self->{keep};
+ $self;
+}
+
+sub get {
+ my ($self, $drain) = @_;
+ if ($drain) {
+ if (length $self->{buffer}) {
+ my @line = $self->get;
+ if (length $self->{buffer} and $self->{buffer} ne "\x0d") {
+ $self->{buffer} =~ s/[\x0d\x0a]+\z//;
+ push @line, $self->{buffer};
+ }
+ $self->{buffer} = "";
+ return @line;
+ } else {
+ return;
+ }
+ }
+ my @line;
+ while ($self->{buffer} =~ s/\A(.*?(?:\x0d\x0a|\x0d|\x0a))//sm) {
+ my $line = $1;
+ next if $line eq "\x0d";
+ $line =~ s/[\x0d\x0a]+\z//;
+ push @line, $line;
+ }
+ return @line;
+}
+
+1;
--- /dev/null
+package Command::Runner::Quote;
+use strict;
+use warnings;
+
+use Win32::ShellQuote ();
+use String::ShellQuote ();
+
+use Exporter 'import';
+our @EXPORT_OK = qw(quote quote_win32 quote_unix);
+
+sub quote_win32 {
+ my $str = shift;
+ Win32::ShellQuote::quote_literal($str, 1);
+}
+
+sub quote_unix {
+ my $str = shift;
+ String::ShellQuote::shell_quote_best_effort($str);
+}
+
+if ($^O eq 'MSWin32') {
+ *quote = \"e_win32;
+} else {
+ *quote = \"e_unix;
+}
+
+1;
--- /dev/null
+package ExtUtils::Config;
+$ExtUtils::Config::VERSION = '0.008';
+use strict;
+use warnings;
+use Config;
+use Data::Dumper ();
+
+sub new {
+ my ($pack, $args) = @_;
+ return bless {
+ values => ($args ? { %$args } : {}),
+ }, $pack;
+}
+
+sub get {
+ my ($self, $key) = @_;
+ return exists $self->{values}{$key} ? $self->{values}{$key} : $Config{$key};
+}
+
+sub exists {
+ my ($self, $key) = @_;
+ return exists $self->{values}{$key} || exists $Config{$key};
+}
+
+sub values_set {
+ my $self = shift;
+ return { %{$self->{values}} };
+}
+
+sub all_config {
+ my $self = shift;
+ return { %Config, %{ $self->{values}} };
+}
+
+sub serialize {
+ my $self = shift;
+ return $self->{serialized} ||= Data::Dumper->new([$self->values_set])->Terse(1)->Sortkeys(1)->Dump;
+}
+
+1;
+
+# ABSTRACT: A wrapper for perl's configuration
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+ExtUtils::Config - A wrapper for perl's configuration
+
+=head1 VERSION
+
+version 0.008
+
+=head1 SYNOPSIS
+
+ my $config = ExtUtils::Config->new();
+ $config->get('installsitelib');
+
+=head1 DESCRIPTION
+
+ExtUtils::Config is an abstraction around the %Config hash. By itself it is not a particularly interesting module by any measure, however it ties together a family of modern toolchain modules.
+
+=head1 METHODS
+
+=head2 new(\%config)
+
+Create a new ExtUtils::Config object. The values in C<\%config> are used to initialize the object.
+
+=head2 get($key)
+
+Get the value of C<$key>. If not overridden it will return the value in %Config.
+
+=head2 exists($key)
+
+Tests for the existence of $key.
+
+=head2 values_set()
+
+Get a hashref of all overridden values.
+
+=head2 all_config()
+
+Get a hashref of the complete configuration, including overrides.
+
+=head2 serialize()
+
+This method serializes the object to some kind of string.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2006 by Ken Williams, Leon Timmermans.
+
+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
--- /dev/null
+package ExtUtils::Helpers;
+$ExtUtils::Helpers::VERSION = '0.026';
+use strict;
+use warnings FATAL => 'all';
+use Exporter 5.57 'import';
+
+use Config;
+use File::Basename qw/basename/;
+use File::Spec::Functions qw/splitpath canonpath abs2rel splitdir/;
+use Text::ParseWords 3.24 ();
+
+our @EXPORT_OK = qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
+
+BEGIN {
+ my %impl_for = ( MSWin32 => 'Windows', VMS => 'VMS');
+ my $package = 'ExtUtils::Helpers::' . ($impl_for{$^O} || 'Unix');
+ my $impl = $impl_for{$^O} || 'Unix';
+ require "ExtUtils/Helpers/$impl.pm";
+ "ExtUtils::Helpers::$impl"->import();
+}
+
+sub split_like_shell {
+ my ($string) = @_;
+
+ return if not defined $string;
+ $string =~ s/^\s+|\s+$//g;
+ return if not length $string;
+
+ return Text::ParseWords::shellwords($string);
+}
+
+sub man1_pagename {
+ my $filename = shift;
+ return basename($filename).".$Config{man1ext}";
+}
+
+my %separator = (
+ MSWin32 => '.',
+ VMS => '__',
+ os2 => '.',
+ cygwin => '.',
+);
+my $separator = $separator{$^O} || '::';
+
+sub man3_pagename {
+ my ($filename, $base) = @_;
+ $base ||= 'lib';
+ my ($vols, $dirs, $file) = splitpath(canonpath(abs2rel($filename, $base)));
+ $file = basename($file, qw/.pm .pod/);
+ my @dirs = grep { length } splitdir($dirs);
+ return join $separator, @dirs, "$file.$Config{man3ext}";
+}
+
+1;
+
+# ABSTRACT: Various portability utilities for module builders
+
+__END__
+
+=pod
+
+=encoding utf-8
+
+=head1 NAME
+
+ExtUtils::Helpers - Various portability utilities for module builders
+
+=head1 VERSION
+
+version 0.026
+
+=head1 SYNOPSIS
+
+ use ExtUtils::Helpers qw/make_executable split_like_shell/;
+
+ unshift @ARGV, split_like_shell($ENV{PROGRAM_OPTS});
+ write_script_to('Build');
+ make_executable('Build');
+
+=head1 DESCRIPTION
+
+This module provides various portable helper functions for module building modules.
+
+=head1 FUNCTIONS
+
+=head2 make_executable($filename)
+
+This makes a perl script executable.
+
+=head2 split_like_shell($string)
+
+This function splits a string the same way as the local platform does.
+
+=head2 detildefy($path)
+
+This function substitutes a tilde at the start of a path with the users homedir in an appropriate manner.
+
+=head2 man1_pagename($filename)
+
+Returns the man page filename for a script.
+
+=head2 man3_pagename($filename, $basedir)
+
+Returns the man page filename for a Perl library.
+
+=head1 ACKNOWLEDGEMENTS
+
+Olivier Mengué and Christian Walde made C<make_executable> work on Windows.
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2004 by Ken Williams, Leon Timmermans.
+
+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
--- /dev/null
+package ExtUtils::Helpers::Unix;
+$ExtUtils::Helpers::Unix::VERSION = '0.026';
+use strict;
+use warnings FATAL => 'all';
+
+use Exporter 5.57 'import';
+our @EXPORT = qw/make_executable detildefy/;
+
+use Carp qw/croak/;
+use Config;
+
+my $layer = $] >= 5.008001 ? ":raw" : "";
+
+sub make_executable {
+ my $filename = shift;
+ my $current_mode = (stat $filename)[2] + 0;
+ if (-T $filename) {
+ open my $fh, "<$layer", $filename;
+ my @lines = <$fh>;
+ if (@lines and $lines[0] =~ s{ \A \#! \s* (?:/\S+/)? perl \b (.*) \z }{$Config{startperl}$1}xms) {
+ open my $out, ">$layer", "$filename.new" or croak "Couldn't open $filename.new: $!";
+ print $out @lines;
+ close $out;
+ rename $filename, "$filename.bak" or croak "Couldn't rename $filename to $filename.bak";
+ rename "$filename.new", $filename or croak "Couldn't rename $filename.new to $filename";
+ unlink "$filename.bak";
+ }
+ }
+ chmod $current_mode | oct(111), $filename;
+ return;
+}
+
+sub detildefy {
+ my $value = shift;
+ # tilde with optional username
+ for ($value) {
+ s{ ^ ~ (?= /|$)} [ $ENV{HOME} || (getpwuid $>)[7] ]ex or # tilde without user name
+ s{ ^ ~ ([^/]+) (?= /|$) } { (getpwnam $1)[7] || "~$1" }ex; # tilde with user name
+ }
+ return $value;
+}
+
+1;
+
+# ABSTRACT: Unix specific helper bits
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+ExtUtils::Helpers::Unix - Unix specific helper bits
+
+=head1 VERSION
+
+version 0.026
+
+=for Pod::Coverage make_executable
+split_like_shell
+detildefy
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2004 by Ken Williams, Leon Timmermans.
+
+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
--- /dev/null
+package ExtUtils::Helpers::VMS;
+$ExtUtils::Helpers::VMS::VERSION = '0.026';
+use strict;
+use warnings FATAL => 'all';
+
+use Exporter 5.57 'import';
+our @EXPORT = qw/make_executable detildefy/;
+
+use File::Copy qw/copy/;
+
+sub make_executable {
+ my $filename = shift;
+ my $batchname = "$filename.com";
+ copy($filename, $batchname);
+ ExtUtils::Helpers::Unix::make_executable($batchname);
+ return;
+}
+
+sub detildefy {
+ my $arg = shift;
+
+ # Apparently double ~ are not translated.
+ return $arg if ($arg =~ /^~~/);
+
+ # Apparently ~ followed by whitespace are not translated.
+ return $arg if ($arg =~ /^~ /);
+
+ if ($arg =~ /^~/) {
+ my $spec = $arg;
+
+ # Remove the tilde
+ $spec =~ s/^~//;
+
+ # Remove any slash following the tilde if present.
+ $spec =~ s#^/##;
+
+ # break up the paths for the merge
+ my $home = VMS::Filespec::unixify($ENV{HOME});
+
+ # In the default VMS mode, the trailing slash is present.
+ # In Unix report mode it is not. The parsing logic assumes that
+ # it is present.
+ $home .= '/' unless $home =~ m#/$#;
+
+ # Trivial case of just ~ by it self
+ if ($spec eq '') {
+ $home =~ s#/$##;
+ return $home;
+ }
+
+ my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
+ if ($hdir eq '') {
+ # Someone has tampered with $ENV{HOME}
+ # So hfile is probably the directory since this should be
+ # a path.
+ $hdir = $hfile;
+ }
+
+ my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
+
+ my @hdirs = File::Spec::Unix->splitdir($hdir);
+ my @dirs = File::Spec::Unix->splitdir($dir);
+
+ unless ($arg =~ m#^~/#) {
+ # There is a home directory after the tilde, but it will already
+ # be present in in @hdirs so we need to remove it by from @dirs.
+
+ shift @dirs;
+ }
+ my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
+
+ $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
+ }
+ return $arg;
+}
+
+# ABSTRACT: VMS specific helper bits
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+ExtUtils::Helpers::VMS - VMS specific helper bits
+
+=head1 VERSION
+
+version 0.026
+
+=for Pod::Coverage make_executable
+detildefy
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2004 by Ken Williams, Leon Timmermans.
+
+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
--- /dev/null
+package ExtUtils::Helpers::Windows;
+$ExtUtils::Helpers::Windows::VERSION = '0.026';
+use strict;
+use warnings FATAL => 'all';
+
+use Exporter 5.57 'import';
+our @EXPORT = qw/make_executable detildefy/;
+
+use Config;
+use Carp qw/carp croak/;
+use ExtUtils::PL2Bat 'pl2bat';
+
+sub make_executable {
+ my $script = shift;
+ if (-T $script && $script !~ / \. (?:bat|cmd) $ /x) {
+ pl2bat(in => $script, update => 1);
+ }
+ return;
+}
+
+sub detildefy {
+ my $value = shift;
+ $value =~ s{ ^ ~ (?= [/\\] | $ ) }[$ENV{USERPROFILE}]x if $ENV{USERPROFILE};
+ return $value;
+}
+
+1;
+
+# ABSTRACT: Windows specific helper bits
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+ExtUtils::Helpers::Windows - Windows specific helper bits
+
+=head1 VERSION
+
+version 0.026
+
+=for Pod::Coverage make_executable
+split_like_shell
+detildefy
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2004 by Ken Williams, Leon Timmermans.
+
+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
--- /dev/null
+package ExtUtils::InstallPaths;
+$ExtUtils::InstallPaths::VERSION = '0.012';
+use 5.006;
+use strict;
+use warnings;
+
+use File::Spec ();
+use Carp ();
+use ExtUtils::Config 0.002;
+
+my %complex_accessors = map { $_ => 1 } qw/prefix_relpaths install_sets/;
+my %hash_accessors = map { $_ => 1 } qw/install_path install_base_relpaths original_prefix /;
+
+my %defaults = (
+ installdirs => 'site',
+ install_base => undef,
+ prefix => undef,
+ verbose => 0,
+ create_packlist => 1,
+ dist_name => undef,
+ module_name => undef,
+ destdir => undef,
+ install_path => sub { {} },
+ install_sets => \&_default_install_sets,
+ original_prefix => \&_default_original_prefix,
+ install_base_relpaths => \&_default_base_relpaths,
+ prefix_relpaths => \&_default_prefix_relpaths,
+);
+
+sub _merge_shallow {
+ my ($name, $filter) = @_;
+ return sub {
+ my ($override, $config) = @_;
+ my $defaults = $defaults{$name}->($config);
+ $filter->($_) for grep $filter, values %$override;
+ return { %$defaults, %$override };
+ }
+}
+
+sub _merge_deep {
+ my ($name, $filter) = @_;
+ return sub {
+ my ($override, $config) = @_;
+ my $defaults = $defaults{$name}->($config);
+ my $pair_for = sub {
+ my $key = shift;
+ my %override = %{ $override->{$key} || {} };
+ $filter && $filter->($_) for values %override;
+ return $key => { %{ $defaults->{$key} }, %override };
+ };
+ return { map { $pair_for->($_) } keys %$defaults };
+ }
+}
+
+my %allowed_installdir = map { $_ => 1 } qw/core site vendor/;
+my $must_be_relative = sub { Carp::croak('Value must be a relative path') if File::Spec->file_name_is_absolute($_[0]) };
+my %deep_filter = map { $_ => $must_be_relative } qw/install_base_relpaths prefix_relpaths/;
+my %filter = (
+ installdirs => sub {
+ my $value = shift;
+ $value = 'core', Carp::carp('Perhaps you meant installdirs to be "core" rather than "perl"?') if $value eq 'perl';
+ Carp::croak('installdirs must be one of "core", "site", or "vendor"') if not $allowed_installdir{$value};
+ return $value;
+ },
+ (map { $_ => _merge_shallow($_, $deep_filter{$_}) } qw/original_prefix install_base_relpaths/),
+ (map { $_ => _merge_deep($_, $deep_filter{$_}) } qw/install_sets prefix_relpaths/),
+);
+
+sub new {
+ my ($class, %args) = @_;
+ my $config = $args{config} || ExtUtils::Config->new;
+ my %self = (
+ config => $config,
+ map { $_ => exists $args{$_} ? $filter{$_} ? $filter{$_}->($args{$_}, $config) : $args{$_} : ref $defaults{$_} ? $defaults{$_}->($config) : $defaults{$_} } keys %defaults,
+ );
+ $self{module_name} ||= do { my $module_name = $self{dist_name}; $module_name =~ s/-/::/g; $module_name } if defined $self{dist_name};
+ return bless \%self, $class;
+}
+
+for my $attribute (keys %defaults) {
+ no strict qw/refs/;
+ *{$attribute} = $hash_accessors{$attribute} ?
+ sub {
+ my ($self, $key) = @_;
+ Carp::confess("$attribute needs key") if not defined $key;
+ return $self->{$attribute}{$key};
+ } :
+ $complex_accessors{$attribute} ?
+ sub {
+ my ($self, $installdirs, $key) = @_;
+ Carp::confess("$attribute needs installdir") if not defined $installdirs;
+ Carp::confess("$attribute needs key") if not defined $key;
+ return $self->{$attribute}{$installdirs}{$key};
+ } :
+ sub {
+ my $self = shift;
+ return $self->{$attribute};
+ };
+}
+
+my $script = $] > 5.008000 ? 'script' : 'bin';
+my @install_sets_keys = qw/lib arch bin script bindoc libdoc binhtml libhtml/;
+my @install_sets_tail = ('bin', $script, qw/man1dir man3dir html1dir html3dir/);
+my %install_sets_values = (
+ core => [ qw/privlib archlib /, @install_sets_tail ],
+ site => [ map { "site$_" } qw/lib arch/, @install_sets_tail ],
+ vendor => [ map { "vendor$_" } qw/lib arch/, @install_sets_tail ],
+);
+
+sub _default_install_sets {
+ my $c = shift;
+
+ my %ret;
+ for my $installdir (qw/core site vendor/) {
+ @{$ret{$installdir}}{@install_sets_keys} = map { $c->get("install$_") } @{ $install_sets_values{$installdir} };
+ }
+ return \%ret;
+}
+
+sub _default_base_relpaths {
+ my $config = shift;
+ return {
+ lib => ['lib', 'perl5'],
+ arch => ['lib', 'perl5', $config->get('archname')],
+ bin => ['bin'],
+ script => ['bin'],
+ bindoc => ['man', 'man1'],
+ libdoc => ['man', 'man3'],
+ binhtml => ['html'],
+ libhtml => ['html'],
+ };
+}
+
+my %common_prefix_relpaths = (
+ bin => ['bin'],
+ script => ['bin'],
+ bindoc => ['man', 'man1'],
+ libdoc => ['man', 'man3'],
+ binhtml => ['html'],
+ libhtml => ['html'],
+);
+
+sub _default_prefix_relpaths {
+ my $c = shift;
+
+ my @libstyle = $c->get('installstyle') ? File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
+ my $arch = $c->get('archname');
+ my $version = $c->get('version');
+
+ return {
+ core => {
+ lib => [@libstyle],
+ arch => [@libstyle, $version, $arch],
+ %common_prefix_relpaths,
+ },
+ vendor => {
+ lib => [@libstyle],
+ arch => [@libstyle, $version, $arch],
+ %common_prefix_relpaths,
+ },
+ site => {
+ lib => [@libstyle, 'site_perl'],
+ arch => [@libstyle, 'site_perl', $version, $arch],
+ %common_prefix_relpaths,
+ },
+ };
+}
+
+sub _default_original_prefix {
+ my $c = shift;
+
+ my %ret = (
+ core => $c->get('installprefixexp'),
+ site => $c->get('siteprefixexp'),
+ vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
+ );
+
+ return \%ret;
+}
+
+sub _log_verbose {
+ my $self = shift;
+ print @_ if $self->verbose;
+ return;
+}
+
+# Given a file type, will return true if the file type would normally
+# be installed when neither install-base nor prefix has been set.
+# I.e. it will be true only if the path is set from Config.pm or
+# set explicitly by the user via install-path.
+sub is_default_installable {
+ my $self = shift;
+ my $type = shift;
+ my $installable = $self->install_destination($type) && ( $self->install_path($type) || $self->install_sets($self->installdirs, $type));
+ return $installable ? 1 : 0;
+}
+
+sub _prefixify_default {
+ my $self = shift;
+ my $type = shift;
+ my $rprefix = shift;
+
+ my $default = $self->prefix_relpaths($self->installdirs, $type);
+ if( !$default ) {
+ $self->_log_verbose(" no default install location for type '$type', using prefix '$rprefix'.\n");
+ return $rprefix;
+ } else {
+ return File::Spec->catdir(@{$default});
+ }
+}
+
+# Translated from ExtUtils::MM_Unix::prefixify()
+sub _prefixify_novms {
+ my($self, $path, $sprefix, $type) = @_;
+
+ my $rprefix = $self->prefix;
+ $rprefix .= '/' if $sprefix =~ m{/$};
+
+ $self->_log_verbose(" prefixify $path from $sprefix to $rprefix\n") if defined $path && length $path;
+
+ if (not defined $path or length $path == 0 ) {
+ $self->_log_verbose(" no path to prefixify, falling back to default.\n");
+ return $self->_prefixify_default( $type, $rprefix );
+ } elsif( !File::Spec->file_name_is_absolute($path) ) {
+ $self->_log_verbose(" path is relative, not prefixifying.\n");
+ } elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) {
+ $self->_log_verbose(" cannot prefixify, falling back to default.\n");
+ return $self->_prefixify_default( $type, $rprefix );
+ }
+
+ $self->_log_verbose(" now $path in $rprefix\n");
+
+ return $path;
+}
+
+sub _catprefix_vms {
+ my ($self, $rprefix, $default) = @_;
+
+ my ($rvol, $rdirs) = File::Spec->splitpath($rprefix);
+ if ($rvol) {
+ return File::Spec->catpath($rvol, File::Spec->catdir($rdirs, $default), '');
+ }
+ else {
+ return File::Spec->catdir($rdirs, $default);
+ }
+}
+sub _prefixify_vms {
+ my($self, $path, $sprefix, $type) = @_;
+ my $rprefix = $self->prefix;
+
+ return '' unless defined $path;
+
+ $self->_log_verbose(" prefixify $path from $sprefix to $rprefix\n");
+
+ require VMS::Filespec;
+ # Translate $(PERLPREFIX) to a real path.
+ $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
+ $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
+
+ $self->_log_verbose(" rprefix translated to $rprefix\n sprefix translated to $sprefix\n");
+
+ if (length($path) == 0 ) {
+ $self->_log_verbose(" no path to prefixify.\n")
+ }
+ elsif (!File::Spec->file_name_is_absolute($path)) {
+ $self->_log_verbose(" path is relative, not prefixifying.\n");
+ }
+ elsif ($sprefix eq $rprefix) {
+ $self->_log_verbose(" no new prefix.\n");
+ }
+ else {
+ my ($path_vol, $path_dirs) = File::Spec->splitpath( $path );
+ my $vms_prefix = $self->config->get('vms_prefix');
+ if ($path_vol eq $vms_prefix.':') {
+ $self->_log_verbose(" $vms_prefix: seen\n");
+
+ $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
+ $path = $self->_catprefix_vms($rprefix, $path_dirs);
+ }
+ else {
+ $self->_log_verbose(" cannot prefixify.\n");
+ return File::Spec->catdir($self->prefix_relpaths($self->installdirs, $type));
+ }
+ }
+
+ $self->_log_verbose(" now $path\n");
+
+ return $path;
+}
+
+BEGIN { *_prefixify = $^O eq 'VMS' ? \&_prefixify_vms : \&_prefixify_novms }
+
+# Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
+sub prefix_relative {
+ my ($self, $installdirs, $type) = @_;
+
+ my $relpath = $self->install_sets($installdirs, $type);
+
+ return $self->_prefixify($relpath, $self->original_prefix($installdirs), $type);
+}
+
+sub install_destination {
+ my ($self, $type) = @_;
+
+ return $self->install_path($type) if $self->install_path($type);
+
+ if ( $self->install_base ) {
+ my $relpath = $self->install_base_relpaths($type);
+ return $relpath ? File::Spec->catdir($self->install_base, @{$relpath}) : undef;
+ }
+
+ if ( $self->prefix ) {
+ my $relpath = $self->prefix_relative($self->installdirs, $type);
+ return $relpath ? File::Spec->catdir($self->prefix, $relpath) : undef;
+ }
+ return $self->install_sets($self->installdirs, $type);
+}
+
+sub install_types {
+ my $self = shift;
+
+ my %types = ( %{ $self->{install_path} },
+ $self->install_base ? %{ $self->{install_base_relpaths} }
+ : $self->prefix ? %{ $self->{prefix_relpaths}{ $self->installdirs } }
+ : %{ $self->{install_sets}{ $self->installdirs } });
+
+ return sort keys %types;
+}
+
+sub install_map {
+ my ($self, $dirs) = @_;
+
+ my %localdir_for;
+ if ($dirs && %$dirs) {
+ %localdir_for = %$dirs;
+ }
+ else {
+ foreach my $type ($self->install_types) {
+ $localdir_for{$type} = File::Spec->catdir('blib', $type);
+ }
+ }
+
+ my (%map, @skipping);
+ foreach my $type (keys %localdir_for) {
+ next if not -e $localdir_for{$type};
+ if (my $dest = $self->install_destination($type)) {
+ $map{$localdir_for{$type}} = $dest;
+ } else {
+ push @skipping, $type;
+ }
+ }
+
+ warn "WARNING: Can't figure out install path for types: @skipping\nFiles will not be installed.\n" if @skipping;
+
+ # Write the packlist into the same place as ExtUtils::MakeMaker.
+ if ($self->create_packlist and my $module_name = $self->module_name) {
+ my $archdir = $self->install_destination('arch');
+ my @ext = split /::/, $module_name;
+ $map{write} = File::Spec->catfile($archdir, 'auto', @ext, '.packlist');
+ }
+
+ # Handle destdir
+ if (length(my $destdir = $self->destdir || '')) {
+ foreach (keys %map) {
+ # Need to remove volume from $map{$_} using splitpath, or else
+ # we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
+ # VMS will always have the file separate than the path.
+ my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 0 );
+
+ # catdir needs a list of directories, or it will create something
+ # crazy like volume:[Foo.Bar.volume.Baz.Quux]
+ my @dirs = File::Spec->splitdir($path);
+
+ # First merge the directories
+ $path = File::Spec->catdir($destdir, @dirs);
+
+ # Then put the file back on if there is one.
+ if ($file ne '') {
+ $map{$_} = File::Spec->catfile($path, $file)
+ } else {
+ $map{$_} = $path;
+ }
+ }
+ }
+
+ $map{read} = ''; # To keep ExtUtils::Install quiet
+
+ return \%map;
+}
+
+1;
+
+# ABSTRACT: Build.PL install path logic made easy
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+ExtUtils::InstallPaths - Build.PL install path logic made easy
+
+=head1 VERSION
+
+version 0.012
+
+=head1 SYNOPSIS
+
+ use ExtUtils::InstallPaths;
+ use ExtUtils::Install 'install';
+ GetOptions(\my %opt, 'install_base=s', 'install_path=s%', 'installdirs=s', 'destdir=s', 'prefix=s', 'uninst:1', 'verbose:1');
+ my $paths = ExtUtils::InstallPaths->new(%opt, dist_name => $dist_name);
+ install($paths->install_map, $opt{verbose}, 0, $opt{uninst});
+
+=head1 DESCRIPTION
+
+This module tries to make install path resolution as easy as possible.
+
+When you want to install a module, it needs to figure out where to install things. The nutshell version of how this works is that default installation locations are determined from L<ExtUtils::Config>, and they may be individually overridden by using the C<install_path> attribute. An C<install_base> attribute lets you specify an alternative installation root like F</home/foo> and C<prefix> does something similar in a rather different (and more complicated) way. C<destdir> lets you specify a temporary installation directory like F</tmp/install> in case you want to create bundled-up installable packages.
+
+The following types are supported by default.
+
+=over 4
+
+=item * lib
+
+Usually pure-Perl module files ending in F<.pm> or F<.pod>.
+
+=item * arch
+
+"Architecture-dependent" module files, usually produced by compiling XS, L<Inline>, or similar code.
+
+=item * script
+
+Programs written in pure Perl. In order to improve reuse, you may want to make these as small as possible - put the code into modules whenever possible.
+
+=item * bin
+
+"Architecture-dependent" executable programs, i.e. compiled C code or something. Pretty rare to see this in a perl distribution, but it happens.
+
+=item * bindoc
+
+Documentation for the stuff in C<script> and C<bin>. Usually generated from the POD in those files. Under Unix, these are manual pages belonging to the 'man1' category. Unless explicitly set, this is only available on platforms supporting manpages.
+
+=item * libdoc
+
+Documentation for the stuff in C<lib> and C<arch>. This is usually generated from the POD in F<.pm> and F<.pod> files. Under Unix, these are manual pages belonging to the 'man3' category. Unless explicitly set, this is only available on platforms supporting manpages.
+
+=item * binhtml
+
+This is the same as C<bindoc> above, but applies to HTML documents. Unless explicitly set, this is only available when perl was configured to do so.
+
+=item * libhtml
+
+This is the same as C<libdoc> above, but applies to HTML documents. Unless explicitly set, this is only available when perl was configured to do so.
+
+=back
+
+=head1 ATTRIBUTES
+
+=head2 installdirs
+
+The default destinations for these installable things come from entries in your system's configuration. You can select from three different sets of default locations by setting the C<installdirs> parameter as follows:
+
+ 'installdirs' set to:
+ core site vendor
+
+ uses the following defaults from ExtUtils::Config:
+
+ lib => installprivlib installsitelib installvendorlib
+ arch => installarchlib installsitearch installvendorarch
+ script => installscript installsitescript installvendorscript
+ bin => installbin installsitebin installvendorbin
+ bindoc => installman1dir installsiteman1dir installvendorman1dir
+ libdoc => installman3dir installsiteman3dir installvendorman3dir
+ binhtml => installhtml1dir installsitehtml1dir installvendorhtml1dir [*]
+ libhtml => installhtml3dir installsitehtml3dir installvendorhtml3dir [*]
+
+ * Under some OS (eg. MSWin32) the destination for HTML documents is determined by the C<Config.pm> entry C<installhtmldir>.
+
+The default value of C<installdirs> is "site".
+
+=head2 install_base
+
+You can also set the whole bunch of installation paths by supplying the C<install_base> parameter to point to a directory on your system. For instance, if you set C<install_base> to "/home/ken" on a Linux system, you'll install as follows:
+
+ lib => /home/ken/lib/perl5
+ arch => /home/ken/lib/perl5/i386-linux
+ script => /home/ken/bin
+ bin => /home/ken/bin
+ bindoc => /home/ken/man/man1
+ libdoc => /home/ken/man/man3
+ binhtml => /home/ken/html
+ libhtml => /home/ken/html
+
+=head2 prefix
+
+This sets a prefix, identical to ExtUtils::MakeMaker's PREFIX option. This does something similar to C<install_base> in a much more complicated way.
+
+=head2 config()
+
+The L<ExtUtils::Config|ExtUtils::Config> object used for this object.
+
+=head2 verbose
+
+The verbosity of ExtUtils::InstallPaths. It defaults to 0
+
+=head2 create_packlist
+
+Together with C<module_name> this controls whether a packlist will be added; it defaults to 1.
+
+=head2 dist_name
+
+The name of the current module.
+
+=head2 module_name
+
+The name of the main module of the package. This is required for packlist creation, but in the future it may be replaced by dist_name. It defaults to C<dist_name =~ s/-/::/gr> if dist_name is set.
+
+=head2 destdir
+
+If you want to install everything into a temporary directory first (for instance, if you want to create a directory tree that a package manager like C<rpm> or C<dpkg> could create a package from), you can use the C<destdir> parameter. E.g. Setting C<destdir> to C<"/tmp/foo"> will effectively install to "/tmp/foo/$sitelib", "/tmp/foo/$sitearch", and the like, except that it will use C<File::Spec> to make the pathnames work correctly on whatever platform you're installing on.
+
+=head1 METHODS
+
+=head2 new
+
+Create a new ExtUtils::InstallPaths object. B<All attributes are valid arguments> to the constructor, as well as this:
+
+=over 4
+
+=item * install_path
+
+This must be a hashref with the type as keys and the destination as values.
+
+=item * install_base_relpaths
+
+This must be a hashref with types as keys and a path relative to the install_base as value.
+
+=item * prefix_relpaths
+
+This must be a hashref any of these three keys: core, vendor, site. Each of the values mush be a hashref with types as keys and a path relative to the prefix as value. You probably want to make these three hashrefs identical.
+
+=item * original_prefix
+
+This must be a hashref with the legal installdirs values as keys and the prefix directories as values.
+
+=item * install_sets
+
+This mush be a hashref with the legal installdirs are keys, and the values being hashrefs with types as keys and locations as values.
+
+=back
+
+=head2 install_map()
+
+Return a map suitable for use with L<ExtUtils::Install>. B<In most cases, this is the only method you'll need>.
+
+=head2 install_destination($type)
+
+Returns the destination of a certain type.
+
+=head2 install_types()
+
+Return a list of all supported install types in the current configuration.
+
+=head2 is_default_installable($type)
+
+Given a file type, will return true if the file type would normally be installed when neither install-base nor prefix has been set. I.e. it will be true only if the path is set from the configuration object or set explicitly by the user via install_path.
+
+=head2 install_path($type)
+
+Gets the install path for a certain type.
+
+=head2 install_sets($installdirs, $type)
+
+Get the path for a certain C<$type> with a certain C<$installdirs>.
+
+=head2 install_base_relpaths($type, $relpath)
+
+Get the relative paths for use with install_base for a certain type.
+
+=head2 prefix_relative($installdirs, $type)
+
+Gets the path of a certain C<$type> and C<$installdirs> relative to the prefix.
+
+=head2 prefix_relpaths($install_dirs, $type)
+
+Get the default relative path to use in case the config install paths cannot be prefixified. You do not want to use this to get any relative path, but may require it to set it for custom types.
+
+=head2 original_prefix($installdirs)
+
+Get the original prefix for a certain type of $installdirs.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item * L<Build.PL spec|http://github.com/dagolden/cpan-api-buildpl/blob/master/lib/CPAN/API/BuildPL.pm>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Ken Williams <kwilliams@cpan.org>
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2011 by Ken Williams, Leon Timmermans.
+
+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
--- /dev/null
+package ExtUtils::MakeMaker::CPANfile;
+
+use strict;
+use warnings;
+use ExtUtils::MakeMaker ();
+use File::Spec::Functions qw/catfile rel2abs/;
+use Module::CPANfile;
+use version;
+
+our $VERSION = "0.09";
+
+sub import {
+ my $class = shift;
+ my $orig = \&ExtUtils::MakeMaker::WriteMakefile;
+ my $writer = sub {
+ my %params = @_;
+
+ # Do nothing if not called from Makefile.PL
+ my ($caller, $file, $line) = caller;
+ (my $root = rel2abs($file)) =~ s/Makefile\.PL$//i or return;
+
+ if (my $file = eval { Module::CPANfile->load(catfile($root, "cpanfile")) }) {
+ my $prereqs = $file->prereqs;
+
+ # Runtime requires => PREREQ_PM
+ _merge(
+ \%params,
+ _get($prereqs, 'runtime', 'requires'),
+ 'PREREQ_PM',
+ );
+
+ # Build requires => BUILD_REQUIRES / PREREQ_PM
+ _merge(
+ \%params,
+ _get($prereqs, 'build', 'requires'),
+ _eumm('6.56') ? 'BUILD_REQUIRES' : 'PREREQ_PM',
+ );
+
+ # Test requires => TEST_REQUIRES / BUILD_REQUIRES / PREREQ_PM
+ _merge(
+ \%params,
+ _get($prereqs, 'test', 'requires'),
+ _eumm('6.63_03') ? 'TEST_REQUIRES' :
+ _eumm('6.56') ? 'BUILD_REQUIRES' : 'PREREQ_PM',
+ );
+
+ # Configure requires => CONFIGURE_REQUIRES / ignored
+ _merge(
+ \%params,
+ _get($prereqs, 'configure', 'requires'),
+ _eumm('6.52') ? 'CONFIGURE_REQUIRES' : undef,
+ );
+
+ # Add myself to configure requires (if possible)
+ _merge(
+ \%params,
+ {'ExtUtils::MakeMaker::CPANfile' => $VERSION},
+ _eumm('6.52') ? 'CONFIGURE_REQUIRES' : undef,
+ );
+
+ # Set dynamic_config to 0 if not set explicitly
+ if (!exists $params{META_ADD}{dynamic_config} &&
+ !exists $params{META_MERGE}{dynamic_config}) {
+ $params{META_MERGE}{dynamic_config} = 0;
+ }
+
+ # recommends, suggests, conflicts
+ my $requires_2_0;
+ for my $type (qw/recommends suggests conflicts/) {
+ for my $phase (qw/configure build test runtime develop/) {
+ my %tmp = %{$params{META_MERGE}{prereqs}{$phase} || {}};
+ _merge(
+ \%tmp,
+ _get($prereqs, $phase, $type),
+ $type,
+ );
+ if ($tmp{$type}) {
+ $params{META_MERGE}{prereqs}{$phase} = \%tmp;
+ $requires_2_0 = 1;
+ }
+ }
+ }
+ if ($requires_2_0) { # for better recommends support
+ # stash prereqs, which is already converted
+ my $tmp_prereqs = delete $params{META_MERGE}{prereqs};
+
+ require CPAN::Meta::Converter;
+ for my $key (qw/META_ADD META_MERGE/) {
+ next unless %{$params{$key} || {}};
+ my $converter = CPAN::Meta::Converter->new($params{$key}, default_version => 1.4);
+ $params{$key} = $converter->upgrade_fragment;
+ }
+
+ if ($params{META_MERGE}{prereqs}) {
+ require CPAN::Meta::Requirements;
+ for my $phase (keys %{$tmp_prereqs || {}}) {
+ for my $rel (keys %{$tmp_prereqs->{$phase} || {}}) {
+ my $req1 = CPAN::Meta::Requirements->from_string_hash($tmp_prereqs->{$phase}{$rel});
+ my $req2 = CPAN::Meta::Requirements->from_string_hash($params{META_MERGE}{prereqs}{$phase}{$rel});
+ $req1->add_requirements($req2);
+ $params{META_MERGE}{prereqs}{$phase} = $req1->as_string_hash;
+ }
+ }
+ } else {
+ $params{META_MERGE}{prereqs} = $tmp_prereqs;
+ }
+ }
+
+ # XXX: better to use also META_MERGE when applicable?
+
+ # As a small bonus, remove params that the installed version
+ # of EUMM doesn't know, so that we can always write them
+ # in Makefile.PL without caring about EUMM version.
+ # (EUMM warns if it finds unknown parameters.)
+ # As EUMM 6.17 is our prereq, we can safely ignore the keys
+ # defined before 6.17.
+ {
+ last if _eumm('6.66_03');
+ if (my $r = delete $params{TEST_REQUIRES}) {
+ _merge(\%params, $r, 'BUILD_REQUIRES');
+ }
+ last if _eumm('6.56');
+ if (my $r = delete $params{BUILD_REQUIRES}) {
+ _merge(\%params, $r, 'PREREQ_PM');
+ }
+
+ last if _eumm('6.52');
+ delete $params{CONFIGURE_REQUIRES};
+
+ last if _eumm('6.47_01');
+ delete $params{MIN_PERL_VERSION};
+
+ last if _eumm('6.45_01');
+ delete $params{META_ADD};
+ delete $params{META_MERGE};
+
+ last if _eumm('6.30_01');
+ delete $params{LICENSE};
+ }
+ } else {
+ print "cpanfile is not available: $@\n";
+ exit 0; # N/A
+ }
+
+ $orig->(%params);
+ };
+ {
+ no warnings 'redefine';
+ *main::WriteMakefile =
+ *ExtUtils::MakeMaker::WriteMakefile = $writer;
+ }
+}
+
+sub _eumm {
+ my $version = shift;
+ eval { ExtUtils::MakeMaker->VERSION($version) } ? 1 : 0;
+}
+
+sub _get {
+ my $prereqs = shift;
+ eval { $prereqs->requirements_for(@_)->as_string_hash };
+}
+
+sub _merge {
+ my ($params, $requires, $key) = @_;
+
+ return unless $key;
+
+ for (keys %{$requires || {}}) {
+ my $version = _normalize_version($requires->{$_});
+ next unless defined $version;
+
+ if (not exists $params->{$key}{$_}) {
+ $params->{$key}{$_} = $version;
+ } else {
+ my $prev = $params->{$key}{$_};
+ if (version->parse($prev) < version->parse($version)) {
+ $params->{$key}{$_} = $version;
+ }
+ }
+ }
+}
+
+sub _normalize_version {
+ my $version = shift;
+
+ # shortcuts
+ return unless defined $version;
+ return $version unless $version =~ /\s/;
+
+ # TODO: better range handling
+ $version =~ s/(?:>=|==)\s*//;
+ $version =~ s/,.+$//;
+
+ return $version unless $version =~ /\s/;
+ return;
+}
+
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+ExtUtils::MakeMaker::CPANfile - cpanfile support for EUMM
+
+=head1 SYNOPSIS
+
+ # Makefile.PL
+ use ExtUtils::MakeMaker::CPANfile;
+
+ WriteMakefile(
+ NAME => 'Foo::Bar',
+ AUTHOR => 'A.U.Thor <author@cpan.org>',
+ );
+
+ # cpanfile
+ requires 'ExtUtils::MakeMaker' => '6.17';
+ on test => sub {
+ requires 'Test::More' => '0.88';
+ };
+
+=head1 DESCRIPTION
+
+ExtUtils::MakeMaker::CPANfile loads C<cpanfile> in your distribution
+and modifies parameters for C<WriteMakefile> in your Makefile.PL.
+Just use it instead of L<ExtUtils::MakeMaker> (which should be
+loaded internally), and prepare C<cpanfile>.
+
+As of version 0.03, ExtUtils::MakeMaker::CPANfile also removes
+WriteMakefile parameters that the installed version of
+ExtUtils::MakeMaker doesn't know, to avoid warnings.
+
+=head1 LIMITATION
+
+=head2 complex version ranges
+
+As of this writing, complex version ranges are simply ignored.
+
+=head2 dynamic config
+
+Strictly speaking, C<cpanfile> is a Perl script, and may have some
+conditions in it. That said, you don't need to run Makefile.PL
+to determine prerequisites in most cases. Hence, as of 0.06,
+ExtUtils::MakeMaker::CPANfile sets C<dynamic_config> to false
+by default. If you do need a CPAN installer to run Makefile.PL
+to customize prerequisites dynamically, set C<dynamic_config>
+to true explicitly (via META_ADD/META_MERGE).
+
+=head1 FOR MODULE AUTHORS
+
+Though the minimum version requirement of ExtUtils::MakeMaker is
+arbitrary set to 6.17 (the one bundled in Perl 5.8.1), you need
+at least EUMM 6.52 (with CONFIGURE_REQUIRES support) when you
+release a distribution.
+
+=head1 LICENSE
+
+Copyright (C) Kenichi Ishigaki.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Kenichi Ishigaki E<lt>ishigaki@cpan.orgE<gt>
+
+=cut
+
--- /dev/null
+package File::Copy::Recursive;
+
+use strict;
+
+BEGIN {
+ # Keep older versions of Perl from trying to use lexical warnings
+ $INC{'warnings.pm'} = "fake warnings entry for < 5.6 perl ($])" if $] < 5.006;
+}
+use warnings;
+
+use Carp;
+use File::Copy;
+use File::Spec; #not really needed because File::Copy already gets it, but for good measure :)
+use Cwd ();
+
+use vars qw(
+ @ISA @EXPORT_OK $VERSION $MaxDepth $KeepMode $CPRFComp $CopyLink
+ $PFSCheck $RemvBase $NoFtlPth $ForcePth $CopyLoop $RMTrgFil $RMTrgDir
+ $CondCopy $BdTrgWrn $SkipFlop $DirPerms
+);
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(fcopy rcopy dircopy fmove rmove dirmove pathmk pathrm pathempty pathrmdir rcopy_glob rmove_glob);
+
+$VERSION = '0.45';
+
+$MaxDepth = 0;
+$KeepMode = 1;
+$CPRFComp = 0;
+$CopyLink = eval { local $SIG{'__DIE__'}; symlink '', ''; 1 } || 0;
+$PFSCheck = 1;
+$RemvBase = 0;
+$NoFtlPth = 0;
+$ForcePth = 0;
+$CopyLoop = 0;
+$RMTrgFil = 0;
+$RMTrgDir = 0;
+$CondCopy = {};
+$BdTrgWrn = 0;
+$SkipFlop = 0;
+$DirPerms = 0777;
+
+my $samecheck = sub {
+ return 1 if $^O eq 'MSWin32'; # need better way to check for this on winders...
+ return if @_ != 2 || !defined $_[0] || !defined $_[1];
+ return if $_[0] eq $_[1];
+
+ my $one = '';
+ if ($PFSCheck) {
+ $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) || '';
+ my $two = join( '-', ( stat $_[1] )[ 0, 1 ] ) || '';
+ if ( $one eq $two && $one ) {
+ carp "$_[0] and $_[1] are identical";
+ return;
+ }
+ }
+
+ if ( -d $_[0] && !$CopyLoop ) {
+ $one = join( '-', ( stat $_[0] )[ 0, 1 ] ) if !$one;
+ my $abs = File::Spec->rel2abs( $_[1] );
+ my @pth = File::Spec->splitdir($abs);
+ while (@pth) {
+ if ( $pth[-1] eq '..' ) { # cheaper than Cwd::realpath() plus we don't want to resolve symlinks at this point, right?
+ pop @pth;
+ pop @pth unless -l File::Spec->catdir(@pth);
+ next;
+ }
+ my $cur = File::Spec->catdir(@pth);
+ last if !$cur; # probably not necessary, but nice to have just in case :)
+ my $two = join( '-', ( stat $cur )[ 0, 1 ] ) || '';
+ if ( $one eq $two && $one ) {
+
+ # $! = 62; # Too many levels of symbolic links
+ carp "Caught Deep Recursion Condition: $_[0] contains $_[1]";
+ return;
+ }
+
+ pop @pth;
+ }
+ }
+
+ return 1;
+};
+
+my $glob = sub {
+ my ( $do, $src_glob, @args ) = @_;
+
+ local $CPRFComp = 1;
+ require File::Glob;
+
+ my @rt;
+ for my $path ( File::Glob::bsd_glob($src_glob) ) {
+ my @call = [ $do->( $path, @args ) ] or return;
+ push @rt, \@call;
+ }
+
+ return @rt;
+};
+
+my $move = sub {
+ my $fl = shift;
+ my @x;
+ if ($fl) {
+ @x = fcopy(@_) or return;
+ }
+ else {
+ @x = dircopy(@_) or return;
+ }
+ if (@x) {
+ if ($fl) {
+ unlink $_[0] or return;
+ }
+ else {
+ pathrmdir( $_[0] ) or return;
+ }
+ if ($RemvBase) {
+ my ( $volm, $path ) = File::Spec->splitpath( $_[0] );
+ pathrm( File::Spec->catpath( $volm, $path, '' ), $ForcePth, $NoFtlPth ) or return;
+ }
+ }
+ return wantarray ? @x : $x[0];
+};
+
+my $ok_todo_asper_condcopy = sub {
+ my $org = shift;
+ my $copy = 1;
+ if ( exists $CondCopy->{$org} ) {
+ if ( $CondCopy->{$org}{'md5'} ) {
+
+ }
+ if ($copy) {
+
+ }
+ }
+ return $copy;
+};
+
+sub fcopy {
+ $samecheck->(@_) or return;
+ if ( $RMTrgFil && ( -d $_[1] || -e $_[1] ) ) {
+ my $trg = $_[1];
+ if ( -d $trg ) {
+ my @trgx = File::Spec->splitpath( $_[0] );
+ $trg = File::Spec->catfile( $_[1], $trgx[$#trgx] );
+ }
+ $samecheck->( $_[0], $trg ) or return;
+ if ( -e $trg ) {
+ if ( $RMTrgFil == 1 ) {
+ unlink $trg or carp "\$RMTrgFil failed: $!";
+ }
+ else {
+ unlink $trg or return;
+ }
+ }
+ }
+ my ( $volm, $path ) = File::Spec->splitpath( $_[1] );
+ if ( $path && !-d $path ) {
+ pathmk( File::Spec->catpath( $volm, $path, '' ), $NoFtlPth );
+ }
+ if ( -l $_[0] && $CopyLink ) {
+ my $target = readlink( shift() );
+ ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
+ carp "Copying a symlink ($_[0]) whose target does not exist"
+ if !-e $target && $BdTrgWrn;
+ my $new = shift();
+ unlink $new if -l $new;
+ symlink( $target, $new ) or return;
+ }
+ elsif ( -d $_[0] && -f $_[1] ) {
+ return;
+ }
+ else {
+ return if -d $_[0]; # address File::Copy::copy() bug outlined in https://rt.perl.org/Public/Bug/Display.html?id=132866
+ copy(@_) or return;
+
+ my @base_file = File::Spec->splitpath( $_[0] );
+ my $mode_trg = -d $_[1] ? File::Spec->catfile( $_[1], $base_file[$#base_file] ) : $_[1];
+
+ chmod scalar( ( stat( $_[0] ) )[2] ), $mode_trg if $KeepMode;
+ }
+ return wantarray ? ( 1, 0, 0 ) : 1; # use 0's incase they do math on them and in case rcopy() is called in list context = no uninit val warnings
+}
+
+sub rcopy {
+ if ( -l $_[0] && $CopyLink ) {
+ goto &fcopy;
+ }
+
+ goto &dircopy if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
+ goto &fcopy;
+}
+
+sub rcopy_glob {
+ $glob->( \&rcopy, @_ );
+}
+
+sub dircopy {
+ if ( $RMTrgDir && -d $_[1] ) {
+ if ( $RMTrgDir == 1 ) {
+ pathrmdir( $_[1] ) or carp "\$RMTrgDir failed: $!";
+ }
+ else {
+ pathrmdir( $_[1] ) or return;
+ }
+ }
+ my $globstar = 0;
+ my $_zero = $_[0];
+ my $_one = $_[1];
+ if ( substr( $_zero, ( 1 * -1 ), 1 ) eq '*' ) {
+ $globstar = 1;
+ $_zero = substr( $_zero, 0, ( length($_zero) - 1 ) );
+ }
+
+ $samecheck->( $_zero, $_[1] ) or return;
+ if ( !-d $_zero || ( -e $_[1] && !-d $_[1] ) ) {
+ $! = 20;
+ return;
+ }
+
+ if ( !-d $_[1] ) {
+ pathmk( $_[1], $NoFtlPth ) or return;
+ }
+ else {
+ if ( $CPRFComp && !$globstar ) {
+ my @parts = File::Spec->splitdir($_zero);
+ while ( $parts[$#parts] eq '' ) { pop @parts; }
+ $_one = File::Spec->catdir( $_[1], $parts[$#parts] );
+ }
+ }
+ my $baseend = $_one;
+ my $level = 0;
+ my $filen = 0;
+ my $dirn = 0;
+
+ my $recurs; #must be my()ed before sub {} since it calls itself
+ $recurs = sub {
+ my ( $str, $end, $buf ) = @_;
+ $filen++ if $end eq $baseend;
+ $dirn++ if $end eq $baseend;
+
+ $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
+ mkdir( $end, $DirPerms ) or return if !-d $end;
+ if ( $MaxDepth && $MaxDepth =~ m/^\d+$/ && $level >= $MaxDepth ) {
+ chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
+ return ( $filen, $dirn, $level ) if wantarray;
+ return $filen;
+ }
+
+ $level++;
+
+ my @files;
+ if ( $] < 5.006 ) {
+ opendir( STR_DH, $str ) or return;
+ @files = grep( $_ ne '.' && $_ ne '..', readdir(STR_DH) );
+ closedir STR_DH;
+ }
+ else {
+ opendir( my $str_dh, $str ) or return;
+ @files = grep( $_ ne '.' && $_ ne '..', readdir($str_dh) );
+ closedir $str_dh;
+ }
+
+ for my $file (@files) {
+ my ($file_ut) = $file =~ m{ (.*) }xms;
+ my $org = File::Spec->catfile( $str, $file_ut );
+ my $new = File::Spec->catfile( $end, $file_ut );
+ if ( -l $org && $CopyLink ) {
+ my $target = readlink($org);
+ ($target) = $target =~ m/(.*)/; # mass-untaint is OK since we have to allow what the file system does
+ carp "Copying a symlink ($org) whose target does not exist"
+ if !-e $target && $BdTrgWrn;
+ unlink $new if -l $new;
+ symlink( $target, $new ) or return;
+ }
+ elsif ( -d $org ) {
+ my $rc;
+ if ( !-w $org && $KeepMode ) {
+ local $KeepMode = 0;
+ $rc = $recurs->( $org, $new, $buf ) if defined $buf;
+ $rc = $recurs->( $org, $new ) if !defined $buf;
+ chmod scalar( ( stat($org) )[2] ), $new;
+ }
+ else {
+ $rc = $recurs->( $org, $new, $buf ) if defined $buf;
+ $rc = $recurs->( $org, $new ) if !defined $buf;
+ }
+ if ( !$rc ) {
+ if ($SkipFlop) {
+ next;
+ }
+ else {
+ return;
+ }
+ }
+ $filen++;
+ $dirn++;
+ }
+ else {
+ if ( $ok_todo_asper_condcopy->($org) ) {
+ if ($SkipFlop) {
+ fcopy( $org, $new, $buf ) or next if defined $buf;
+ fcopy( $org, $new ) or next if !defined $buf;
+ }
+ else {
+ fcopy( $org, $new, $buf ) or return if defined $buf;
+ fcopy( $org, $new ) or return if !defined $buf;
+ }
+ chmod scalar( ( stat($org) )[2] ), $new if $KeepMode;
+ $filen++;
+ }
+ }
+ }
+ $level--;
+ chmod scalar( ( stat($str) )[2] ), $end if $KeepMode;
+ 1;
+
+ };
+
+ $recurs->( $_zero, $_one, $_[2] ) or return;
+ return wantarray ? ( $filen, $dirn, $level ) : $filen;
+}
+
+sub fmove { $move->( 1, @_ ) }
+
+sub rmove {
+ if ( -l $_[0] && $CopyLink ) {
+ goto &fmove;
+ }
+
+ goto &dirmove if -d $_[0] || substr( $_[0], ( 1 * -1 ), 1 ) eq '*';
+ goto &fmove;
+}
+
+sub rmove_glob {
+ $glob->( \&rmove, @_ );
+}
+
+sub dirmove { $move->( 0, @_ ) }
+
+sub pathmk {
+ my ( $vol, $dir, $file ) = File::Spec->splitpath( shift() );
+ my $nofatal = shift;
+
+ $DirPerms = oct($DirPerms) if substr( $DirPerms, 0, 1 ) eq '0';
+
+ if ( defined($dir) ) {
+ my (@dirs) = File::Spec->splitdir($dir);
+
+ for ( my $i = 0; $i < scalar(@dirs); $i++ ) {
+ my $newdir = File::Spec->catdir( @dirs[ 0 .. $i ] );
+ my $newpth = File::Spec->catpath( $vol, $newdir, "" );
+
+ mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
+ mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
+ }
+ }
+
+ if ( defined($file) ) {
+ my $newpth = File::Spec->catpath( $vol, $dir, $file );
+
+ mkdir( $newpth, $DirPerms ) or return if !-d $newpth && !$nofatal;
+ mkdir( $newpth, $DirPerms ) if !-d $newpth && $nofatal;
+ }
+
+ 1;
+}
+
+sub pathempty {
+ my $pth = shift;
+
+ my ( $orig_dev, $orig_ino ) = ( lstat $pth )[ 0, 1 ];
+ return 2 if !-d _ || !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino ); #stat.inode is 0 on Windows
+
+ my $starting_point = Cwd::cwd();
+ my ( $starting_dev, $starting_ino ) = ( lstat $starting_point )[ 0, 1 ];
+ chdir($pth) or Carp::croak("Failed to change directory to “$pth”: $!");
+ $pth = '.';
+ _bail_if_changed( $pth, $orig_dev, $orig_ino );
+
+ my @names;
+ my $pth_dh;
+ if ( $] < 5.006 ) {
+ opendir( PTH_DH, $pth ) or return;
+ @names = grep !/^\.\.?$/, readdir(PTH_DH);
+ closedir PTH_DH;
+ }
+ else {
+ opendir( $pth_dh, $pth ) or return;
+ @names = grep !/^\.\.?$/, readdir($pth_dh);
+ closedir $pth_dh;
+ }
+ _bail_if_changed( $pth, $orig_dev, $orig_ino );
+
+ for my $name (@names) {
+ my ($name_ut) = $name =~ m{ (.*) }xms;
+ my $flpth = File::Spec->catdir( $pth, $name_ut );
+
+ if ( -l $flpth ) {
+ _bail_if_changed( $pth, $orig_dev, $orig_ino );
+ unlink $flpth or return;
+ }
+ elsif ( -d $flpth ) {
+ _bail_if_changed( $pth, $orig_dev, $orig_ino );
+ pathrmdir($flpth) or return;
+ }
+ else {
+ _bail_if_changed( $pth, $orig_dev, $orig_ino );
+ unlink $flpth or return;
+ }
+ }
+
+ chdir($starting_point) or Carp::croak("Failed to change directory to “$starting_point”: $!");
+ _bail_if_changed( ".", $starting_dev, $starting_ino );
+
+ return 1;
+}
+
+sub pathrm {
+ my ( $path, $force, $nofail ) = @_;
+
+ my ( $orig_dev, $orig_ino ) = ( lstat $path )[ 0, 1 ];
+ return 2 if !-d _ || !defined($orig_dev) || !$orig_ino;
+
+ # Manual test (I hate this function :/):
+ # sudo mkdir /foo && perl -MFile::Copy::Recursive=pathrm -le 'print pathrm("/foo",1)' && sudo rm -rf /foo
+ if ( $force && File::Spec->file_name_is_absolute($path) ) {
+ Carp::croak("pathrm() w/ force on abspath is not allowed");
+ }
+
+ my @pth = File::Spec->splitdir($path);
+
+ my %fs_check;
+ my $aggregate_path;
+ for my $part (@pth) {
+ $aggregate_path = defined $aggregate_path ? File::Spec->catdir( $aggregate_path, $part ) : $part;
+ $fs_check{$aggregate_path} = [ ( lstat $aggregate_path )[ 0, 1 ] ];
+ }
+
+ while (@pth) {
+ my $cur = File::Spec->catdir(@pth);
+ last if !$cur; # necessary ???
+
+ if ($force) {
+ _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
+ if ( !pathempty($cur) ) {
+ return unless $nofail;
+ }
+ }
+ _bail_if_changed( $cur, $fs_check{$cur}->[0], $fs_check{$cur}->[1] );
+ if ($nofail) {
+ rmdir $cur;
+ }
+ else {
+ rmdir $cur or return;
+ }
+ pop @pth;
+ }
+
+ return 1;
+}
+
+sub pathrmdir {
+ my $dir = shift;
+ if ( -e $dir ) {
+ return if !-d $dir;
+ }
+ else {
+ return 2;
+ }
+
+ my ( $orig_dev, $orig_ino ) = ( lstat $dir )[ 0, 1 ];
+ return 2 if !defined($orig_dev) || ( $^O ne 'MSWin32' && !$orig_ino );
+
+ pathempty($dir) or return;
+ _bail_if_changed( $dir, $orig_dev, $orig_ino );
+ rmdir $dir or return;
+
+ return 1;
+}
+
+sub _bail_if_changed {
+ my ( $path, $orig_dev, $orig_ino ) = @_;
+
+ my ( $cur_dev, $cur_ino ) = ( lstat $path )[ 0, 1 ];
+
+ if ( !defined $cur_dev || !defined $cur_ino ) {
+ $cur_dev ||= "undef(path went away?)";
+ $cur_ino ||= "undef(path went away?)";
+ }
+ else {
+ $path = Cwd::abs_path($path);
+ }
+
+ if ( $orig_dev ne $cur_dev || $orig_ino ne $cur_ino ) {
+ local $Carp::CarpLevel += 1;
+ Carp::croak("directory $path changed: expected dev=$orig_dev ino=$orig_ino, actual dev=$cur_dev ino=$cur_ino, aborting");
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::Copy::Recursive - Perl extension for recursively copying files and directories
+
+=head1 SYNOPSIS
+
+ use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove);
+
+ fcopy($orig,$new[,$buf]) or die $!;
+ rcopy($orig,$new[,$buf]) or die $!;
+ dircopy($orig,$new[,$buf]) or die $!;
+
+ fmove($orig,$new[,$buf]) or die $!;
+ rmove($orig,$new[,$buf]) or die $!;
+ dirmove($orig,$new[,$buf]) or die $!;
+
+ rcopy_glob("orig/stuff-*", $trg [, $buf]) or die $!;
+ rmove_glob("orig/stuff-*", $trg [,$buf]) or die $!;
+
+=head1 DESCRIPTION
+
+This module copies and moves directories recursively (or single files, well... singley) to an optional depth and attempts to preserve each file or directory's mode.
+
+=head1 EXPORT
+
+None by default. But you can export all the functions as in the example above and the path* functions if you wish.
+
+=head2 fcopy()
+
+This function uses File::Copy's copy() function to copy a file but not a directory. Any directories are recursively created if need be.
+One difference to File::Copy::copy() is that fcopy attempts to preserve the mode (see Preserving Mode below)
+The optional $buf in the synopsis is the same as File::Copy::copy()'s 3rd argument.
+This function returns the same as File::Copy::copy() in scalar context and 1,0,0 in list context to accomodate rcopy()'s list context on regular files. (See below for more info)
+
+=head2 dircopy()
+
+This function recursively traverses the $orig directory's structure and recursively copies it to the $new directory.
+$new is created if necessary (multiple non existent directories is ok (i.e. foo/bar/baz). The script logically and portably creates all of them if necessary).
+It attempts to preserve the mode (see Preserving Mode below) and
+by default it copies all the way down into the directory (see Managing Depth, below).
+If a directory is not specified it croaks just like fcopy croaks if its not a file that is specified.
+
+This function returns true or false: for true in scalar context it returns the number of files and directories copied,
+whereas in list context it returns the number of files and directories, number of directories only, depth level traversed.
+
+ my $num_of_files_and_dirs = dircopy($orig,$new);
+ my($num_of_files_and_dirs,$num_of_dirs,$depth_traversed) = dircopy($orig,$new);
+
+Normally it stops and returns if a copy fails. To continue on regardless, set $File::Copy::Recursive::SkipFlop to true.
+
+ local $File::Copy::Recursive::SkipFlop = 1;
+
+That way it will copy everythging it can in a directory and won't stop because of permissions, etc...
+
+=head2 rcopy()
+
+This function will allow you to specify a file *or* a directory. It calls fcopy() if you passed file and dircopy() if you passed a directory.
+If you call rcopy() (or fcopy() for that matter) on a file in list context, the values will be 1,0,0 since no directories and no depth are used.
+This is important because if it's a directory in list context and there is only the initial directory the return value is 1,1,1.
+
+=head2 rcopy_glob()
+
+This function lets you specify a pattern suitable for perl's File::Glob::bsd_glob() as the first argument. Subsequently each path returned by perl's File::Glob::bsd_glob() gets rcopy()ied.
+
+It returns and array whose items are array refs that contain the return value of each rcopy() call.
+
+It forces behavior as if $File::Copy::Recursive::CPRFComp is true.
+
+=head2 fmove()
+
+Copies the file then removes the original. You can manage the path the original file is in according to $RemvBase.
+
+=head2 dirmove()
+
+Uses dircopy() to copy the directory then removes the original. You can manage the path the original directory is in according to $RemvBase.
+
+=head2 rmove()
+
+Like rcopy() but calls fmove() or dirmove() instead.
+
+=head2 rmove_glob()
+
+Like rcopy_glob() but calls rmove() instead of rcopy()
+
+=head3 $RemvBase
+
+Default is false. When set to true the *move() functions will not only attempt to remove the original file or directory but will remove the given path it is in.
+
+So if you:
+
+ rmove('foo/bar/baz', '/etc/');
+ # "baz" is removed from foo/bar after it is successfully copied to /etc/
+
+ local $File::Copy::Recursive::Remvbase = 1;
+ rmove('foo/bar/baz','/etc/');
+ # if baz is successfully copied to /etc/ :
+ # first "baz" is removed from foo/bar
+ # then "foo/bar is removed via pathrm()
+
+=head4 $ForcePth
+
+Default is false. When set to true it calls pathempty() before any directories are removed to empty the directory so it can be rmdir()'ed when $RemvBase is in effect.
+
+=head2 Creating and Removing Paths
+
+=head3 $NoFtlPth
+
+Default is false. If set to true rmdir(), mkdir(), and pathempty() calls in pathrm() and pathmk() do not return() on failure.
+
+If its set to true they just silently go about their business regardless. This isn't a good idea but it's there if you want it.
+
+=head3 $DirPerms
+
+Mode to pass to any mkdir() calls. Defaults to 0777 as per umask()'s POD. Explicitly having this allows older perls to be able to use FCR and might add a bit of flexibility for you.
+
+Any value you set it to should be suitable for oct().
+
+=head3 Path functions
+
+These functions exist solely because they were necessary for the move and copy functions to have the features they do and not because they are of themselves the purpose of this module. That being said, here is how they work so you can understand how the copy and move functions work and use them by themselves if you wish.
+
+=head4 pathrm()
+
+Removes a given path recursively. It removes the *entire* path so be careful!!!
+
+Returns 2 if the given path is not a directory.
+
+ File::Copy::Recursive::pathrm('foo/bar/baz') or die $!;
+ # foo no longer exists
+
+Same as:
+
+ rmdir 'foo/bar/baz' or die $!;
+ rmdir 'foo/bar' or die $!;
+ rmdir 'foo' or die $!;
+
+An optional second argument makes it call pathempty() before any rmdir()'s when set to true.
+
+ File::Copy::Recursive::pathrm('foo/bar/baz', 1) or die $!;
+ # foo no longer exists
+
+Same as:PFSCheck
+
+ File::Copy::Recursive::pathempty('foo/bar/baz') or die $!;
+ rmdir 'foo/bar/baz' or die $!;
+ File::Copy::Recursive::pathempty('foo/bar/') or die $!;
+ rmdir 'foo/bar' or die $!;
+ File::Copy::Recursive::pathempty('foo/') or die $!;
+ rmdir 'foo' or die $!;
+
+An optional third argument acts like $File::Copy::Recursive::NoFtlPth, again probably not a good idea.
+
+=head4 pathempty()
+
+Recursively removes the given directory's contents so it is empty. Returns 2 if the given argument is not a directory, 1 on successfully emptying the directory.
+
+ File::Copy::Recursive::pathempty($pth) or die $!;
+ # $pth is now an empty directory
+
+=head4 pathmk()
+
+Creates a given path recursively. Creates foo/bar/baz even if foo does not exist.
+
+ File::Copy::Recursive::pathmk('foo/bar/baz') or die $!;
+
+An optional second argument if true acts just like $File::Copy::Recursive::NoFtlPth, which means you'd never get your die() if something went wrong. Again, probably a *bad* idea.
+
+=head4 pathrmdir()
+
+Same as rmdir() but it calls pathempty() first to recursively empty it first since rmdir can not remove a directory with contents.
+Just removes the top directory the path given instead of the entire path like pathrm(). Returns 2 if the given argument does not exist (i.e. it's already gone). Returns false if it exists but is not a directory.
+
+=head2 Preserving Mode
+
+By default a quiet attempt is made to change the new file or directory to the mode of the old one.
+To turn this behavior off set
+ $File::Copy::Recursive::KeepMode
+to false;
+
+=head2 Managing Depth
+
+You can set the maximum depth a directory structure is recursed by setting:
+ $File::Copy::Recursive::MaxDepth
+to a whole number greater than 0.
+
+=head2 SymLinks
+
+If your system supports symlinks then symlinks will be copied as symlinks instead of as the target file.
+Perl's symlink() is used instead of File::Copy's copy().
+You can customize this behavior by setting $File::Copy::Recursive::CopyLink to a true or false value.
+It is already set to true or false depending on your system's support of symlinks so you can check it with an if statement to see how it will behave:
+
+ if($File::Copy::Recursive::CopyLink) {
+ print "Symlinks will be preserved\n";
+ } else {
+ print "Symlinks will not be preserved because your system does not support it\n";
+ }
+
+If symlinks are being copied you can set $File::Copy::Recursive::BdTrgWrn to true to make it carp when it copies a link whose target does not exist. It's false by default.
+
+ local $File::Copy::Recursive::BdTrgWrn = 1;
+
+=head2 Removing existing target file or directory before copying.
+
+This can be done by setting $File::Copy::Recursive::RMTrgFil or $File::Copy::Recursive::RMTrgDir for file or directory behavior respectively.
+
+0 = off (This is the default)
+
+1 = carp() $! if removal fails
+
+2 = return if removal fails
+
+ local $File::Copy::Recursive::RMTrgFil = 1;
+ fcopy($orig, $target) or die $!;
+ # if it fails it does warn() and keeps going
+
+ local $File::Copy::Recursive::RMTrgDir = 2;
+ dircopy($orig, $target) or die $!;
+ # if it fails it does your "or die"
+
+This should be unnecessary most of the time but it's there if you need it :)
+
+=head2 Turning off stat() check
+
+By default the files or directories are checked to see if they are the same (i.e. linked, or two paths (absolute/relative or different relative paths) to the same file) by comparing the file's stat() info.
+It's a very efficient check that croaks if they are and shouldn't be turned off but if you must for some weird reason just set $File::Copy::Recursive::PFSCheck to a false value. ("PFS" stands for "Physical File System")
+
+=head2 Emulating cp -rf dir1/ dir2/
+
+By default dircopy($dir1,$dir2) will put $dir1's contents right into $dir2 whether $dir2 exists or not.
+
+You can make dircopy() emulate cp -rf by setting $File::Copy::Recursive::CPRFComp to true.
+
+NOTE: This only emulates -f in the sense that it does not prompt. It does not remove the target file or directory if it exists.
+If you need to do that then use the variables $RMTrgFil and $RMTrgDir described in "Removing existing target file or directory before copying" above.
+
+That means that if $dir2 exists it puts the contents into $dir2/$dir1 instead of $dir2 just like cp -rf.
+If $dir2 does not exist then the contents go into $dir2 like normal (also like cp -rf).
+
+So assuming 'foo/file':
+
+ dircopy('foo', 'bar') or die $!;
+ # if bar does not exist the result is bar/file
+ # if bar does exist the result is bar/file
+
+ $File::Copy::Recursive::CPRFComp = 1;
+ dircopy('foo', 'bar') or die $!;
+ # if bar does not exist the result is bar/file
+ # if bar does exist the result is bar/foo/file
+
+You can also specify a star for cp -rf glob type behavior:
+
+ dircopy('foo/*', 'bar') or die $!;
+ # if bar does not exist the result is bar/file
+ # if bar does exist the result is bar/file
+
+ $File::Copy::Recursive::CPRFComp = 1;
+ dircopy('foo/*', 'bar') or die $!;
+ # if bar does not exist the result is bar/file
+ # if bar does exist the result is bar/file
+
+NOTE: The '*' is only like cp -rf foo/* and *DOES NOT EXPAND PARTIAL DIRECTORY NAMES LIKE YOUR SHELL DOES* (i.e. not like cp -rf fo* to copy foo/*).
+
+=head2 Allowing Copy Loops
+
+If you want to allow:
+
+ cp -rf . foo/
+
+type behavior set $File::Copy::Recursive::CopyLoop to true.
+
+This is false by default so that a check is done to see if the source directory will contain the target directory and croaks to avoid this problem.
+
+If you ever find a situation where $CopyLoop = 1 is desirable let me know. (i.e. it's a bad bad idea but is there if you want it)
+
+(Note: On Windows this was necessary since it uses stat() to determine sameness and stat() is essentially useless for this on Windows.
+The test is now simply skipped on Windows but I'd rather have an actual reliable check if anyone in Microsoft land would care to share)
+
+=head1 SEE ALSO
+
+L<File::Copy> L<File::Spec>
+
+=head1 TO DO
+
+I am currently working on and reviewing some other modules to use in the new interface so we can lose the horrid globals as well as some other undesirable traits and also more easily make available some long standing requests.
+
+Tests will be easier to do with the new interface and hence the testing focus will shift to the new interface and aim to be comprehensive.
+
+The old interface will work, it just won't be brought in until it is used, so it will add no overhead for users of the new interface.
+
+I'll add this after the latest version has been out for a while with no new features or issues found :)
+
+=head1 AUTHOR
+
+Daniel Muey, L<http://drmuey.com/cpan_contact.pl>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2004 by Daniel Muey
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package File::Which;
+
+use strict;
+use warnings;
+use Exporter ();
+use File::Spec ();
+
+# ABSTRACT: Perl implementation of the which utility as an API
+our $VERSION = '1.23'; # VERSION
+
+
+our @ISA = 'Exporter';
+our @EXPORT = 'which';
+our @EXPORT_OK = 'where';
+
+use constant IS_VMS => ($^O eq 'VMS');
+use constant IS_MAC => ($^O eq 'MacOS');
+use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
+use constant IS_DOS => IS_WIN();
+use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys');
+
+our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC;
+
+# For Win32 systems, stores the extensions used for
+# executable files
+# For others, the empty string is used
+# because 'perl' . '' eq 'perl' => easier
+my @PATHEXT = ('');
+if ( IS_WIN ) {
+ # WinNT. PATHEXT might be set on Cygwin, but not used.
+ if ( $ENV{PATHEXT} ) {
+ push @PATHEXT, split ';', $ENV{PATHEXT};
+ } else {
+ # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
+ push @PATHEXT, qw{.com .exe .bat};
+ }
+} elsif ( IS_VMS ) {
+ push @PATHEXT, qw{.exe .com};
+} elsif ( IS_CYG ) {
+ # See this for more info
+ # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe
+ push @PATHEXT, qw{.exe .com};
+}
+
+
+sub which {
+ my ($exec) = @_;
+
+ return undef unless defined $exec;
+ return undef if $exec eq '';
+
+ my $all = wantarray;
+ my @results = ();
+
+ # check for aliases first
+ if ( IS_VMS ) {
+ my $symbol = `SHOW SYMBOL $exec`;
+ chomp($symbol);
+ unless ( $? ) {
+ return $symbol unless $all;
+ push @results, $symbol;
+ }
+ }
+ if ( IS_MAC ) {
+ my @aliases = split /\,/, $ENV{Aliases};
+ foreach my $alias ( @aliases ) {
+ # This has not been tested!!
+ # PPT which says MPW-Perl cannot resolve `Alias $alias`,
+ # let's just hope it's fixed
+ if ( lc($alias) eq lc($exec) ) {
+ chomp(my $file = `Alias $alias`);
+ last unless $file; # if it failed, just go on the normal way
+ return $file unless $all;
+ push @results, $file;
+ # we can stop this loop as if it finds more aliases matching,
+ # it'll just be the same result anyway
+ last;
+ }
+ }
+ }
+
+ return $exec
+ if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec;
+
+ my @path;
+ if($^O eq 'MSWin32') {
+ # File::Spec (at least recent versions)
+ # add the implicit . for you on MSWin32,
+ # but we may or may not want to include
+ # that.
+ @path = split(';', $ENV{PATH});
+ s/"//g for @path;
+ @path = grep length, @path;
+ } else {
+ @path = File::Spec->path;
+ }
+ if ( $IMPLICIT_CURRENT_DIR ) {
+ unshift @path, File::Spec->curdir;
+ }
+
+ foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
+ for my $ext ( @PATHEXT ) {
+ my $file = $base.$ext;
+
+ # We don't want dirs (as they are -x)
+ next if -d $file;
+
+ if (
+ # Executable, normal case
+ -x _
+ or (
+ # MacOS doesn't mark as executable so we check -e
+ IS_MAC
+ ||
+ (
+ ( IS_WIN or IS_CYG )
+ and
+ grep {
+ $file =~ /$_\z/i
+ } @PATHEXT[1..$#PATHEXT]
+ )
+ # DOSish systems don't pass -x on
+ # non-exe/bat/com files. so we check -e.
+ # However, we don't want to pass -e on files
+ # that aren't in PATHEXT, like README.
+ and -e _
+ )
+ ) {
+ return $file unless $all;
+ push @results, $file;
+ }
+ }
+ }
+
+ if ( $all ) {
+ return @results;
+ } else {
+ return undef;
+ }
+}
+
+
+sub where {
+ # force wantarray
+ my @res = which($_[0]);
+ return @res;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::Which - Perl implementation of the which utility as an API
+
+=head1 VERSION
+
+version 1.23
+
+=head1 SYNOPSIS
+
+ use File::Which; # exports which()
+ use File::Which qw(which where); # exports which() and where()
+
+ my $exe_path = which 'perldoc';
+
+ my @paths = where 'perl';
+ # Or
+ my @paths = which 'perl'; # an array forces search for all of them
+
+=head1 DESCRIPTION
+
+L<File::Which> finds the full or relative paths to executable programs on
+the system. This is normally the function of C<which> utility. C<which> is
+typically implemented as either a program or a built in shell command. On
+some platforms, such as Microsoft Windows it is not provided as part of the
+core operating system. This module provides a consistent API to this
+functionality regardless of the underlying platform.
+
+The focus of this module is correctness and portability. As a consequence
+platforms where the current directory is implicitly part of the search path
+such as Microsoft Windows will find executables in the current directory,
+whereas on platforms such as UNIX where this is not the case executables
+in the current directory will only be found if the current directory is
+explicitly added to the path.
+
+If you need a portable C<which> on the command line in an environment that
+does not provide it, install L<App::pwhich> which provides a command line
+interface to this API.
+
+=head2 Implementations
+
+L<File::Which> searches the directories of the user's C<PATH> (the current
+implementation uses L<File::Spec#path> to determine the correct C<PATH>),
+looking for executable files having the name specified as a parameter to
+L</which>. Under Win32 systems, which do not have a notion of directly
+executable files, but uses special extensions such as C<.exe> and C<.bat>
+to identify them, C<File::Which> takes extra steps to assure that
+you will find the correct file (so for example, you might be searching for
+C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)
+
+=head3 Linux, *BSD and other UNIXes
+
+There should not be any surprises here. The current directory will not be
+searched unless it is explicitly added to the path.
+
+=head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc)
+
+Windows NT has a special environment variable called C<PATHEXT>, which is used
+by the shell to look for executable files. Usually, it will contain a list in
+the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
+environment variable, it parses the list and uses it as the different
+extensions.
+
+=head3 Cygwin
+
+Cygwin provides a Unix-like environment for Microsoft Windows users. In most
+ways it works like other Unix and Unix-like environments, but in a few key
+aspects it works like Windows. As with other Unix environments, the current
+directory is not included in the search unless it is explicitly included in
+the search path. Like on Windows, files with C<.EXE> or <.BAT> extensions will
+be discovered even if they are not part of the query. C<.COM> or extensions
+specified using the C<PATHEXT> environment variable will NOT be discovered
+without the fully qualified name, however.
+
+=head3 Windows ME, 98, 95, MS-DOS, OS/2
+
+This set of operating systems don't have the C<PATHEXT> variable, and usually
+you will find executable files there with the extensions C<.exe>, C<.bat> and
+(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
+under Win32 but does not find a C<PATHEXT> variable.
+
+As of 2015 none of these platforms are tested frequently (or perhaps ever),
+but the current maintainer is determined not to intentionally remove support
+for older operating systems.
+
+=head3 VMS
+
+Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
+
+As of 2015 the current maintainer does not test on VMS, and is in fact not
+certain it has ever been tested on VMS. If this platform is important to you
+and you can help me verify and or support it on that platform please contact
+me.
+
+=head1 FUNCTIONS
+
+=head2 which
+
+ my $path = which $short_exe_name;
+ my @paths = which $short_exe_name;
+
+Exported by default.
+
+C<$short_exe_name> is the name used in the shell to call the program (for
+example, C<perl>).
+
+If it finds an executable with the name you specified, C<which()> will return
+the absolute path leading to this executable (for example, F</usr/bin/perl> or
+F<C:\Perl\Bin\perl.exe>).
+
+If it does I<not> find the executable, it returns C<undef>.
+
+If C<which()> is called in list context, it will return I<all> the
+matches.
+
+=head2 where
+
+ my @paths = where $short_exe_name;
+
+Not exported by default.
+
+Same as L</which> in array context. Similar to the C<where> csh
+built-in command or C<which -a> command for platforms that support the
+C<-a> option. Will return an array containing all the path names
+matching C<$short_exe_name>.
+
+=head1 GLOBALS
+
+=head2 $IMPLICIT_CURRENT_DIR
+
+True if the current directory is included in the search implicitly on
+whatever platform you are using. Normally the default is reasonable,
+but on Windows the current directory is included implicitly for older
+shells like C<cmd.exe> and C<command.com>, but not for newer shells
+like PowerShell. If you overrule this default, you should ALWAYS
+localize the variable to the tightest scope possible, since setting
+this variable from a module can affect other modules. Thus on Windows
+you can get the correct result if the user is running either C<cmd.exe>
+or PowerShell on Windows you can do this:
+
+ use File::Which qw( which );
+ use Shell::Guess;
+
+ my $path = do {
+ my $is_power = Shell::Guess->running_shell->is_power;
+ local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power;
+ which 'foo';
+ };
+
+For a variety of reasons it is difficult to accurately compute the
+shell that a user is using, but L<Shell::Guess> makes a reasonable
+effort.
+
+=head1 CAVEATS
+
+This module has no non-core requirements for Perl 5.6.2 and better.
+
+This module is fully supported back to Perl 5.8.1. It may work on 5.8.0.
+It should work on Perl 5.6.x and I may even test on 5.6.2. I will accept
+patches to maintain compatibility for such older Perls, but you may
+need to fix it on 5.6.x / 5.8.0 and send me a patch.
+
+Not tested on VMS although there is platform specific code
+for those. Anyone who haves a second would be very kind to send me a
+report of how it went.
+
+=head1 SUPPORT
+
+Bugs should be reported via the GitHub issue tracker
+
+L<https://github.com/plicease/File-Which/issues>
+
+For other issues, contact the maintainer.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<pwhich>, L<App::pwhich>
+
+Command line interface to this module.
+
+=item L<IPC::Cmd>
+
+This module provides (among other things) a C<can_run> function, which is
+similar to C<which>. It is a much heavier module since it does a lot more,
+and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>. This combination
+may be overkill for applications which do not need L<IPC::Cmd>'s complicated
+interface for running programs, or do not need the memory overhead required
+for installing Perl modules.
+
+At least some older versions will find executables in the current directory,
+even if the current directory is not in the search path (which is the default
+on modern Unix).
+
+C<can_run> converts directory path name to the 8.3 version on Windows using
+C<Win32::GetShortPathName> in some cases. This is frequently useful for tools
+that just need to run something using C<system> in scalar mode, but may be
+inconvenient for tools like L<App::pwhich> where user readability is a premium.
+Relying on C<Win32::GetShortPathName> to produce filenames without spaces
+is problematic, as 8.3 filenames can be turned off with tweaks to the
+registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>).
+
+=item L<Devel::CheckBin>
+
+This module purports to "check that a command is available", but does not
+provide any documentation on how you might use it.
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Per Einar Ellefsen <pereinar@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=item *
+
+Graham Ollis <plicease@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@cpan.org>.
+
+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
--- /dev/null
+use strict;
+use warnings;
+
+package File::pushd;
+# ABSTRACT: change directory temporarily for a limited scope
+
+our $VERSION = '1.016';
+
+our @EXPORT = qw( pushd tempd );
+our @ISA = qw( Exporter );
+
+use Exporter;
+use Carp;
+use Cwd qw( getcwd abs_path );
+use File::Path qw( rmtree );
+use File::Temp qw();
+use File::Spec;
+
+use overload
+ q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
+ fallback => 1;
+
+#--------------------------------------------------------------------------#
+# pushd()
+#--------------------------------------------------------------------------#
+
+sub pushd {
+ # Called in void context?
+ unless (defined wantarray) {
+ warnings::warnif(void => 'Useless use of File::pushd::pushd in void context');
+ return
+ }
+
+ my ( $target_dir, $options ) = @_;
+ $options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
+
+ $target_dir = "." unless defined $target_dir;
+ croak "Can't locate directory $target_dir" unless -d $target_dir;
+
+ my $tainted_orig = getcwd;
+ my $orig;
+ if ( $tainted_orig =~ $options->{untaint_pattern} ) {
+ $orig = $1;
+ }
+ else {
+ $orig = $tainted_orig;
+ }
+
+ my $tainted_dest;
+ eval { $tainted_dest = $target_dir ? abs_path($target_dir) : $orig };
+ croak "Can't locate absolute path for $target_dir: $@" if $@;
+
+ my $dest;
+ if ( $tainted_dest =~ $options->{untaint_pattern} ) {
+ $dest = $1;
+ }
+ else {
+ $dest = $tainted_dest;
+ }
+
+ if ( $dest ne $orig ) {
+ chdir $dest or croak "Can't chdir to $dest\: $!";
+ }
+
+ my $self = bless {
+ _pushd => $dest,
+ _original => $orig
+ },
+ __PACKAGE__;
+
+ return $self;
+}
+
+#--------------------------------------------------------------------------#
+# tempd()
+#--------------------------------------------------------------------------#
+
+sub tempd {
+ # Called in void context?
+ unless (defined wantarray) {
+ warnings::warnif(void => 'Useless use of File::pushd::tempd in void context');
+ return
+ }
+
+ my ($options) = @_;
+ my $dir;
+ eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
+ croak $@ if $@;
+ $dir->{_tempd} = 1;
+ $dir->{_owner} = $$;
+ return $dir;
+}
+
+#--------------------------------------------------------------------------#
+# preserve()
+#--------------------------------------------------------------------------#
+
+sub preserve {
+ my $self = shift;
+ return 1 if !$self->{"_tempd"};
+ if ( @_ == 0 ) {
+ return $self->{_preserve} = 1;
+ }
+ else {
+ return $self->{_preserve} = $_[0] ? 1 : 0;
+ }
+}
+
+#--------------------------------------------------------------------------#
+# DESTROY()
+# Revert to original directory as object is destroyed and cleanup
+# if necessary
+#--------------------------------------------------------------------------#
+
+sub DESTROY {
+ my ($self) = @_;
+ my $orig = $self->{_original};
+ chdir $orig if $orig; # should always be so, but just in case...
+ if ( $self->{_tempd}
+ && $self->{_owner} == $$
+ && !$self->{_preserve} )
+ {
+ # don't destroy existing $@ if there is no error.
+ my $err = do {
+ local $@;
+ eval { rmtree( $self->{_pushd} ) };
+ $@;
+ };
+ carp $err if $err;
+ }
+}
+
+1;
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+File::pushd - change directory temporarily for a limited scope
+
+=head1 VERSION
+
+version 1.016
+
+=head1 SYNOPSIS
+
+ use File::pushd;
+
+ chdir $ENV{HOME};
+
+ # change directory again for a limited scope
+ {
+ my $dir = pushd( '/tmp' );
+ # working directory changed to /tmp
+ }
+ # working directory has reverted to $ENV{HOME}
+
+ # tempd() is equivalent to pushd( File::Temp::tempdir )
+ {
+ my $dir = tempd();
+ }
+
+ # object stringifies naturally as an absolute path
+ {
+ my $dir = pushd( '/tmp' );
+ my $filename = File::Spec->catfile( $dir, "somefile.txt" );
+ # gives /tmp/somefile.txt
+ }
+
+=head1 DESCRIPTION
+
+File::pushd does a temporary C<chdir> that is easily and automatically
+reverted, similar to C<pushd> in some Unix command shells. It works by
+creating an object that caches the original working directory. When the object
+is destroyed, the destructor calls C<chdir> to revert to the original working
+directory. By storing the object in a lexical variable with a limited scope,
+this happens automatically at the end of the scope.
+
+This is very handy when working with temporary directories for tasks like
+testing; a function is provided to streamline getting a temporary
+directory from L<File::Temp>.
+
+For convenience, the object stringifies as the canonical form of the absolute
+pathname of the directory entered.
+
+B<Warning>: if you create multiple C<pushd> objects in the same lexical scope,
+their destruction order is not guaranteed and you might not wind up in the
+directory you expect.
+
+=head1 USAGE
+
+ use File::pushd;
+
+Using File::pushd automatically imports the C<pushd> and C<tempd> functions.
+
+=head2 pushd
+
+ {
+ my $dir = pushd( $target_directory );
+ }
+
+Caches the current working directory, calls C<chdir> to change to the target
+directory, and returns a File::pushd object. When the object is
+destroyed, the working directory reverts to the original directory.
+
+The provided target directory can be a relative or absolute path. If
+called with no arguments, it uses the current directory as its target and
+returns to the current directory when the object is destroyed.
+
+If the target directory does not exist or if the directory change fails
+for some reason, C<pushd> will die with an error message.
+
+Can be given a hashref as an optional second argument. The only supported
+option is C<untaint_pattern>, which is used to untaint file paths involved.
+It defaults to {qr{^(L<-+@\w./>+)$}}, which is reasonably restrictive (e.g.
+it does not even allow spaces in the path). Change this to suit your
+circumstances and security needs if running under taint mode. *Note*: you
+must include the parentheses in the pattern to capture the untainted
+portion of the path.
+
+=head2 tempd
+
+ {
+ my $dir = tempd();
+ }
+
+This function is like C<pushd> but automatically creates and calls C<chdir> to
+a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
+cleanup which happens at the end of the program, this temporary directory is
+removed when the object is destroyed. (But also see C<preserve>.) A warning
+will be issued if the directory cannot be removed.
+
+As with C<pushd>, C<tempd> will die if C<chdir> fails.
+
+It may be given a single options hash that will be passed internally
+to C<pushd>.
+
+=head2 preserve
+
+ {
+ my $dir = tempd();
+ $dir->preserve; # mark to preserve at end of scope
+ $dir->preserve(0); # mark to delete at end of scope
+ }
+
+Controls whether a temporary directory will be cleaned up when the object is
+destroyed. With no arguments, C<preserve> sets the directory to be preserved.
+With an argument, the directory will be preserved if the argument is true, or
+marked for cleanup if the argument is false. Only C<tempd> objects may be
+marked for cleanup. (Target directories to C<pushd> are always preserved.)
+C<preserve> returns true if the directory will be preserved, and false
+otherwise.
+
+=head1 DIAGNOSTICS
+
+C<pushd> and C<tempd> warn with message
+C<"Useless use of File::pushd::I<%s> in void context"> if called in
+void context and the warnings category C<void> is enabled.
+
+ {
+ use warnings 'void';
+
+ pushd();
+ }
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L<File::chdir>
+
+=back
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/dagolden/File-pushd/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/dagolden/File-pushd>
+
+ git clone https://github.com/dagolden/File-pushd.git
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Diab Jerius Graham Ollis Olivier Mengué Shoichi Kaji
+
+=over 4
+
+=item *
+
+Diab Jerius <djerius@cfa.harvard.edu>
+
+=item *
+
+Graham Ollis <plicease@cpan.org>
+
+=item *
+
+Olivier Mengué <dolmen@cpan.org>
+
+=item *
+
+Shoichi Kaji <skaji@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2018 by David A Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
+
+__END__
+
+
+# vim: ts=4 sts=4 sw=4 et:
--- /dev/null
+package HTTP::Tinyish;
+use strict;
+use warnings;
+use Carp ();
+
+our $VERSION = '0.16';
+
+our $PreferredBackend; # for tests
+our @Backends = map "HTTP::Tinyish::$_", qw( LWP HTTPTiny Curl Wget );
+my %configured;
+
+sub new {
+ my($class, %attr) = @_;
+ bless \%attr, $class;
+}
+
+for my $method (qw/get head put post delete mirror patch/) {
+ no strict 'refs';
+ eval <<"HERE";
+ sub $method {
+ my \$self = shift;
+ \$self->_backend_for(\$_[0])->$method(\@_);
+ }
+HERE
+}
+
+sub request {
+ my $self = shift;
+ $self->_backend_for($_[1])->request(@_);
+}
+
+sub _backend_for {
+ my($self, $url) = @_;
+
+ my($scheme) = $url =~ m!^(https?):!;
+ Carp::croak "URL Scheme '$url' not supported." unless $scheme;
+
+ for my $backend ($self->backends) {
+ $self->configure_backend($backend) or next;
+ if ($backend->supports($scheme)) {
+ return $backend->new(%$self);
+ }
+ }
+
+ Carp::croak "No backend configured for scheme $scheme";
+}
+
+sub backends {
+ $PreferredBackend ? ($PreferredBackend) : @Backends;
+}
+
+sub configure_backend {
+ my($self, $backend) = @_;
+ unless (exists $configured{$backend}) {
+ $configured{$backend} =
+ eval { require_module($backend); $backend->configure };
+ }
+ $configured{$backend};
+}
+
+sub require_module {
+ local $_ = shift;
+ s!::!/!g;
+ require "$_.pm";
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Tinyish - HTTP::Tiny compatible HTTP client wrappers
+
+=head1 SYNOPSIS
+
+ my $http = HTTP::Tinyish->new(agent => "Mozilla/4.0");
+
+ my $res = $http->get("http://www.cpan.org/");
+ warn $res->{status};
+
+ $http->post("http://example.com/post", {
+ headers => { "Content-Type" => "application/x-www-form-urlencoded" },
+ content => "foo=bar&baz=quux",
+ });
+
+ $http->mirror("http://www.cpan.org/modules/02packages.details.txt.gz", "./02packages.details.txt.gz");
+
+=head1 DESCRIPTION
+
+HTTP::Tinyish is a wrapper module for HTTP client modules
+L<LWP>, L<HTTP::Tiny> and HTTP client software C<curl> and C<wget>.
+
+It provides an API compatible to HTTP::Tiny, and the implementation
+has been extracted out of L<App::cpanminus>. This module can be useful
+in a restrictive environment where you need to be able to download
+CPAN modules without an HTTPS support in built-in HTTP library.
+
+=head1 BACKEND SELECTION
+
+Backends are searched in the order of: C<LWP>, L<HTTP::Tiny>, L<Curl>
+and L<Wget>. HTTP::Tinyish will auto-detect if the backend also
+supports HTTPS, and use the appropriate backend based on the given
+URL to the request methods.
+
+For example, if you only have HTTP::Tiny but without SSL related
+modules, it is possible that:
+
+ my $http = HTTP::Tinyish->new;
+
+ $http->get("http://example.com"); # uses HTTP::Tiny
+ $http->get("https://example.com"); # uses curl
+
+=head1 COMPATIBILITIES
+
+All request related methods such as C<get>, C<post>, C<put>,
+C<delete>, C<request>, C<patch> and C<mirror> are supported.
+
+=head2 LWP
+
+=over 4
+
+=item *
+
+L<LWP> backend requires L<LWP> 5.802 or over to be functional, and L<LWP::Protocol::https> to send HTTPS requests.
+
+=item *
+
+C<mirror> method doesn't consider third options hash into account (i.e. you can't override the HTTP headers).
+
+=item *
+
+proxy is automatically detected from environment variables.
+
+=item *
+
+C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are translated.
+
+=back
+
+=head2 HTTP::Tiny
+
+Because the actual HTTP::Tiny backend is used, all APIs are supported.
+
+=head2 Curl
+
+=over
+
+=item *
+
+This module has been tested with curl 7.22 and later.
+
+=item *
+
+HTTPS support is automatically detected by running C<curl --version> and see its protocol output.
+
+=item *
+
+C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are supported.
+
+=back
+
+=head2 Wget
+
+=over 4
+
+=item *
+
+This module requires Wget 1.12 and later.
+
+=item *
+
+Wget prior to 1.15 doesn't support sending custom HTTP methods, so if you use C<< $http->put >> for example, you'll get an internal error response (599).
+
+=item *
+
+HTTPS support is automatically detected.
+
+=item *
+
+C<mirror()> method doesn't send C<If-Modified-Since> header to the server, which will result in full-download every time because C<wget> doesn't support C<--timestamping> combined with C<-O> option.
+
+=item *
+
+C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are supported.
+
+=back
+
+=head1 SIMILAR MODULES
+
+=over 4
+
+=item *
+
+L<File::Fetch> - is core since 5.10. Has support for non-HTTP protocols such as ftp and git. Does not support HTTPS or basic authentication as of this writing.
+
+=item *
+
+L<Plient> - provides more complete runtime API, but seems only compatible on Unix environments. Does not support mirror() method.
+
+=back
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 COPYRIGHT
+
+Tatsuhiko Miyagawa, 2015-
+
+=head1 LICENSE
+
+This module is licensed under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+package HTTP::Tinyish::Base;
+use strict;
+use warnings;
+
+for my $sub_name ( qw/get head put post delete patch/ ) {
+ my $req_method = uc $sub_name;
+ eval <<"HERE";
+ sub $sub_name {
+ my (\$self, \$url, \$args) = \@_;
+ \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
+ or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
+ return \$self->request('$req_method', \$url, \$args || {});
+ }
+
+HERE
+}
+
+sub parse_http_header {
+ my($self, $header, $res) = @_;
+
+ # it might have multiple headers in it because of redirects
+ $header =~ s/.*^(HTTP\/\d(?:\.\d)?)/$1/ms;
+
+ # grab the first chunk until the line break
+ if ($header =~ /^(.*?\x0d?\x0a\x0d?\x0a)/) {
+ $header = $1;
+ }
+
+ # parse into lines
+ my @header = split /\x0d?\x0a/,$header;
+ my $status_line = shift @header;
+
+ # join folded lines
+ my @out;
+ for (@header) {
+ if(/^[ \t]+/) {
+ return -1 unless @out;
+ $out[-1] .= $_;
+ } else {
+ push @out, $_;
+ }
+ }
+
+ my($proto, $status, $reason) = split / /, $status_line, 3;
+ return unless $proto and $proto =~ /^HTTP\/(\d+)(\.(\d+))?$/i;
+
+ $res->{status} = $status;
+ $res->{reason} = $reason;
+ $res->{success} = $status =~ /^(?:2|304)/;
+ $res->{protocol} = $proto;
+
+ # import headers
+ my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
+ my $k;
+ for my $header (@out) {
+ if ( $header =~ s/^($token): ?// ) {
+ $k = lc $1;
+ } elsif ( $header =~ /^\s+/) {
+ # multiline header
+ } else {
+ return -1;
+ }
+
+ if (exists $res->{headers}{$k}) {
+ $res->{headers}{$k} = [$res->{headers}{$k}]
+ unless ref $res->{headers}{$k};
+ push @{$res->{headers}{$k}}, $header;
+ } else {
+ $res->{headers}{$k} = $header;
+ }
+ }
+}
+
+sub internal_error {
+ my($self, $url, $message) = @_;
+
+ return {
+ content => $message,
+ headers => { "content-length" => length($message), "content-type" => "text/plain" },
+ reason => "Internal Exception",
+ status => 599,
+ success => "",
+ url => $url,
+ };
+}
+
+1;
--- /dev/null
+package HTTP::Tinyish::Curl;
+use strict;
+use warnings;
+use parent qw(HTTP::Tinyish::Base);
+
+use IPC::Run3 qw(run3);
+use File::Which qw(which);
+use File::Temp ();
+
+my %supports;
+my $curl;
+
+sub _slurp {
+ open my $fh, "<", shift or die $!;
+ local $/;
+ <$fh>;
+}
+
+sub configure {
+ my $class = shift;
+
+ my %meta;
+ $curl = which('curl');
+
+ eval {
+ run3([$curl, '--version'], \undef, \my $version, \my $error);
+ if ($version =~ /^Protocols: (.*)/m) {
+ my %protocols = map { $_ => 1 } split /\s/, $1;
+ $supports{http} = 1 if $protocols{http};
+ $supports{https} = 1 if $protocols{https};
+ }
+
+ $meta{$curl} = $version;
+ };
+
+ \%meta;
+}
+
+sub supports { $supports{$_[1]} }
+
+sub new {
+ my($class, %attr) = @_;
+ bless \%attr, $class;
+}
+
+sub request {
+ my($self, $method, $url, $opts) = @_;
+ $opts ||= {};
+
+ my(undef, $temp) = File::Temp::tempfile(UNLINK => 1);
+
+ my($output, $error);
+ eval {
+ run3 [
+ $curl,
+ '-X', $method,
+ ($method eq 'HEAD' ? ('--head') : ()),
+ $self->build_options($url, $opts),
+ '--dump-header', $temp,
+ $url,
+ ], \undef, \$output, \$error;
+ };
+
+ if ($@ or $?) {
+ return $self->internal_error($url, $@ || $error);
+ }
+
+ my $res = { url => $url, content => $output };
+ $self->parse_http_header( _slurp($temp), $res );
+ $res;
+}
+
+sub mirror {
+ my($self, $url, $file, $opts) = @_;
+ $opts ||= {};
+
+ my(undef, $temp) = File::Temp::tempfile(UNLINK => 1);
+
+ my($output, $error);
+ eval {
+ run3 [
+ $curl,
+ $self->build_options($url, $opts),
+ '-z', $file,
+ '-o', $file,
+ '--dump-header', $temp,
+ '--remote-time',
+ $url,
+ ], \undef, \$output, \$error;
+ };
+
+ if ($@ or $?) {
+ return $self->internal_error($url, $@ || $error);
+ }
+
+ my $res = { url => $url, content => $output };
+ $self->parse_http_header( _slurp($temp), $res );
+ $res;
+}
+
+sub build_options {
+ my($self, $url, $opts) = @_;
+
+ my @options = (
+ '--location',
+ '--silent',
+ '--max-time', ($self->{timeout} || 60),
+ '--max-redirs', ($self->{max_redirect} || 5),
+ '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
+ );
+
+ my %headers;
+ if ($self->{default_headers}) {
+ %headers = %{$self->{default_headers}};
+ }
+ if ($opts->{headers}) {
+ %headers = (%headers, %{$opts->{headers}});
+ }
+ $self->_translate_headers(\%headers, \@options);
+
+ unless ($self->{verify_SSL}) {
+ push @options, '--insecure';
+ }
+
+ if ($opts->{content}) {
+ my $content;
+ if (ref $opts->{content} eq 'CODE') {
+ while (my $chunk = $opts->{content}->()) {
+ $content .= $chunk;
+ }
+ } else {
+ $content = $opts->{content};
+ }
+ push @options, '--data', $content;
+ }
+
+ @options;
+}
+
+sub _translate_headers {
+ my($self, $headers, $options) = @_;
+
+ for my $field (keys %$headers) {
+ my $value = $headers->{$field};
+ if (ref $value eq 'ARRAY') {
+ push @$options, map { ('-H', "$field:$_") } @$value;
+ } else {
+ push @$options, '-H', "$field:$value";
+ }
+ }
+}
+
+1;
--- /dev/null
+package HTTP::Tinyish::HTTPTiny;
+use strict;
+use parent qw(HTTP::Tinyish::Base);
+use HTTP::Tiny;
+
+my %supports = (http => 1);
+
+sub configure {
+ my %meta = ("HTTP::Tiny" => $HTTP::Tiny::VERSION);
+
+ $supports{https} = HTTP::Tiny->can_ssl;
+
+ \%meta;
+}
+
+sub supports { $supports{$_[1]} }
+
+sub new {
+ my($class, %attrs) = @_;
+ bless {
+ tiny => HTTP::Tiny->new(%attrs),
+ }, $class;
+}
+
+sub request {
+ my $self = shift;
+ $self->{tiny}->request(@_);
+}
+
+sub mirror {
+ my $self = shift;
+ $self->{tiny}->mirror(@_);
+}
+
+1;
+
--- /dev/null
+package HTTP::Tinyish::LWP;
+use strict;
+use parent qw(HTTP::Tinyish::Base);
+
+use LWP 5.802;
+use LWP::UserAgent;
+
+my %supports = (http => 1);
+
+sub configure {
+ my %meta = (
+ LWP => $LWP::VERSION,
+ );
+
+ if (eval { require LWP::Protocol::https; require Mozilla::CA; 1 }) {
+ $supports{https} = 1;
+ $meta{"LWP::Protocol::https"} = $LWP::Protocol::https::VERSION;
+ }
+
+ \%meta;
+}
+
+sub supports {
+ $supports{$_[1]};
+}
+
+sub new {
+ my($class, %attr) = @_;
+
+ my $ua = LWP::UserAgent->new;
+
+ bless {
+ ua => $class->translate_lwp($ua, %attr),
+ }, $class;
+}
+
+sub _headers_to_hashref {
+ my($self, $hdrs) = @_;
+
+ my %headers;
+ for my $field ($hdrs->header_field_names) {
+ $headers{lc $field} = $hdrs->header($field); # could be an array ref
+ }
+
+ \%headers;
+}
+
+sub request {
+ my($self, $method, $url, $opts) = @_;
+ $opts ||= {};
+
+ my $req = HTTP::Request->new($method => $url);
+
+ if ($opts->{headers}) {
+ $req->header(%{$opts->{headers}});
+ }
+
+ if ($opts->{content}) {
+ $req->content($opts->{content});
+ }
+
+ my $res = $self->{ua}->request($req);
+
+ if ($self->is_internal_response($res)) {
+ return $self->internal_error($url, $res->content);
+ }
+
+ return {
+ url => $url,
+ content => $res->decoded_content(charset => 'none'),
+ success => $res->is_success,
+ status => $res->code,
+ reason => $res->message,
+ headers => $self->_headers_to_hashref($res->headers),
+ protocol => $res->protocol,
+ };
+}
+
+sub mirror {
+ my($self, $url, $file) = @_;
+
+ # TODO support optional headers
+ my $res = $self->{ua}->mirror($url, $file);
+
+ if ($self->is_internal_response($res)) {
+ return $self->internal_error($url, $res->content);
+ }
+
+ return {
+ url => $url,
+ content => $res->decoded_content,
+ success => $res->is_success || $res->code == 304,
+ status => $res->code,
+ reason => $res->message,
+ headers => $self->_headers_to_hashref($res->headers),
+ protocol => $res->protocol,
+ };
+}
+
+sub translate_lwp {
+ my($class, $agent, %attr) = @_;
+
+ $agent->parse_head(0);
+ $agent->env_proxy;
+ $agent->timeout(delete $attr{timeout} || 60);
+ $agent->max_redirect(delete $attr{max_redirect} || 5);
+ $agent->agent(delete $attr{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION");
+
+ # LWP default is to verify, HTTP::Tiny isn't
+ unless ($attr{verify_SSL}) {
+ if ($agent->can("ssl_opts")) {
+ $agent->ssl_opts(verify_hostname => 0);
+ }
+ }
+
+ if ($attr{default_headers}) {
+ $agent->default_headers( HTTP::Headers->new(%{$attr{default_headers}}) );
+ }
+
+ $agent;
+}
+
+sub is_internal_response {
+ my($self, $res) = @_;
+
+ $res->code == 500 &&
+ ( $res->header('Client-Warning') || '' ) eq 'Internal response';
+}
+
+1;
--- /dev/null
+package HTTP::Tinyish::Wget;
+use strict;
+use warnings;
+use parent qw(HTTP::Tinyish::Base);
+
+use IPC::Run3 qw(run3);
+use File::Which qw(which);
+
+my %supports;
+my $wget;
+my $method_supported;
+
+sub _run_wget {
+ run3([$wget, @_], \undef, \my $out, \my $err);
+ wantarray ? ($out, $err) : $out;
+}
+
+sub configure {
+ my $class = shift;
+ my %meta;
+
+ $wget = which('wget');
+
+ eval {
+ local $ENV{LC_ALL} = 'en_US';
+
+ $meta{$wget} = _run_wget('--version');
+ unless ($meta{$wget} =~ /GNU Wget 1\.(\d+)/ and $1 >= 12) {
+ die "Wget version is too old. $meta{$wget}";
+ }
+
+ my $config = $class->new(agent => __PACKAGE__);
+ my @options = grep { $_ ne '--quiet' } $config->build_options("GET");
+
+ my(undef, $err) = _run_wget(@options, 'https://');
+ if ($err && $err =~ /HTTPS support not compiled/) {
+ $supports{http} = 1;
+ } elsif ($err && $err =~ /Invalid host/) {
+ $supports{http} = $supports{https} = 1;
+ }
+
+ (undef, $err) = _run_wget('--method', 'GET', 'http://');
+ if ($err && $err =~ /Invalid host/) {
+ $method_supported = $meta{method_supported} = 1;
+ }
+
+ };
+
+ \%meta;
+}
+
+sub supports { $supports{$_[1]} }
+
+sub new {
+ my($class, %attr) = @_;
+ bless \%attr, $class;
+}
+
+sub request {
+ my($self, $method, $url, $opts) = @_;
+ $opts ||= {};
+
+ my($stdout, $stderr);
+ eval {
+ run3 [
+ $wget,
+ $self->build_options($method, $url, $opts),
+ $url,
+ '-O', '-',
+ ], \undef, \$stdout, \$stderr;
+ };
+
+ # wget exit codes: (man wget)
+ # 4 Network failure.
+ # 5 SSL verification failure.
+ # 6 Username/password authentication failure.
+ # 7 Protocol errors.
+ # 8 Server issued an error response.
+ if ($@ or $? && ($? >> 8) <= 5) {
+ return $self->internal_error($url, $@ || $stderr);
+ }
+
+ my $header = '';
+ $stderr =~ s{^ (\S.*)$}{ $header .= $1."\n" }gem;
+
+ my $res = { url => $url, content => $stdout };
+ $self->parse_http_header($header, $res);
+ $res;
+}
+
+sub mirror {
+ my($self, $url, $file, $opts) = @_;
+ $opts ||= {};
+
+ # This doesn't send If-Modified-Since because -O and -N are mutually exclusive :(
+ my($stdout, $stderr);
+ eval {
+ run3 [$wget, $self->build_options("GET", $url, $opts), $url, '-O', $file], \undef, \$stdout, \$stderr;
+ };
+
+ if ($@ or $?) {
+ return $self->internal_error($url, $@ || $stderr);
+ }
+
+ $stderr =~ s/^ //gm;
+
+ my $res = { url => $url, content => $stdout };
+ $self->parse_http_header($stderr, $res);
+ $res;
+}
+
+sub build_options {
+ my($self, $method, $url, $opts) = @_;
+
+ my @options = (
+ '--retry-connrefused',
+ '--server-response',
+ '--timeout', ($self->{timeout} || 60),
+ '--tries', 1,
+ '--max-redirect', ($self->{max_redirect} || 5),
+ '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
+ );
+
+ if ($method_supported) {
+ push @options, "--method", $method;
+ } else {
+ if ($method eq 'GET' or $method eq 'POST') {
+ # OK
+ } elsif ($method eq 'HEAD') {
+ push @options, '--spider';
+ } else {
+ die "This version of wget doesn't support specifying HTTP method '$method'";
+ }
+ }
+
+ if ($self->{agent}) {
+ push @options, '--user-agent', $self->{agent};
+ }
+
+ my %headers;
+ if ($self->{default_headers}) {
+ %headers = %{$self->{default_headers}};
+ }
+ if ($opts->{headers}) {
+ %headers = (%headers, %{$opts->{headers}});
+ }
+ $self->_translate_headers(\%headers, \@options);
+
+ if ($supports{https} && !$self->{verify_SSL}) {
+ push @options, '--no-check-certificate';
+ }
+
+ if ($opts->{content}) {
+ my $content;
+ if (ref $opts->{content} eq 'CODE') {
+ while (my $chunk = $opts->{content}->()) {
+ $content .= $chunk;
+ }
+ } else {
+ $content = $opts->{content};
+ }
+
+ if ($method_supported) {
+ push @options, '--body-data', $content;
+ } else {
+ push @options, '--post-data', $content;
+ }
+ }
+
+ @options;
+}
+
+sub _translate_headers {
+ my($self, $headers, $options) = @_;
+
+ for my $field (keys %$headers) {
+ my $value = $headers->{$field};
+ if (ref $value eq 'ARRAY') {
+ # wget doesn't honor multiple header fields
+ push @$options, '--header', "$field:" . join(",", @$value);
+ } else {
+ push @$options, '--header', "$field:$value";
+ }
+ }
+}
+
+1;
--- /dev/null
+package IPC::Run3;
+BEGIN { require 5.006_000; } # i.e. 5.6.0
+use strict;
+
+=head1 NAME
+
+IPC::Run3 - run a subprocess with input/ouput redirection
+
+=head1 VERSION
+
+version 0.048
+
+=cut
+
+our $VERSION = '0.048';
+
+=head1 SYNOPSIS
+
+ use IPC::Run3; # Exports run3() by default
+
+ run3 \@cmd, \$in, \$out, \$err;
+
+=head1 DESCRIPTION
+
+This module allows you to run a subprocess and redirect stdin, stdout,
+and/or stderr to files and perl data structures. It aims to satisfy 99% of the
+need for using C<system>, C<qx>, and C<open3>
+with a simple, extremely Perlish API.
+
+Speed, simplicity, and portability are paramount. (That's speed of Perl code;
+which is often much slower than the kind of buffered I/O that this module uses
+to spool input to and output from the child command.)
+
+=cut
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw( run3 );
+our %EXPORT_TAGS = ( all => \@EXPORT );
+
+use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
+use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
+use constant is_win32 => 0 <= index $^O, "Win32";
+
+BEGIN {
+ if ( is_win32 ) {
+ eval "use Win32 qw( GetOSName ); use Win32::ShellQuote qw(quote_native); 1" or die $@;
+ }
+}
+
+#use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
+#use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;
+
+use Carp qw( croak );
+use File::Temp qw( tempfile );
+use POSIX qw( dup dup2 );
+
+# We cache the handles of our temp files in order to
+# keep from having to incur the (largish) overhead of File::Temp
+my %fh_cache;
+my $fh_cache_pid = $$;
+
+my $profiler;
+
+sub _profiler { $profiler } # test suite access
+
+BEGIN {
+ if ( profiling ) {
+ eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
+ if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
+ require IPC::Run3::ProfPP;
+ IPC::Run3::ProfPP->import;
+ $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
+ } else {
+ my ( $dest, undef, $class ) =
+ reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
+ $class = "IPC::Run3::ProfLogger"
+ unless defined $class && length $class;
+ if ( not eval "require $class" ) {
+ my $e = $@;
+ $class = "IPC::Run3::$class";
+ eval "require IPC::Run3::$class" or die $e;
+ }
+ $profiler = $class->new( Destination => $dest );
+ }
+ $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
+ }
+}
+
+
+END {
+ $profiler->app_exit( scalar gettimeofday() ) if profiling;
+}
+
+sub _binmode {
+ my ( $fh, $mode, $what ) = @_;
+ # if $mode is not given, then default to ":raw", except on Windows,
+ # where we default to ":crlf";
+ # otherwise if a proper layer string was given, use that,
+ # else use ":raw"
+ my $layer = !$mode
+ ? (is_win32 ? ":crlf" : ":raw")
+ : ($mode =~ /^:/ ? $mode : ":raw");
+ warn "binmode $what, $layer\n" if debugging >= 2;
+
+ binmode $fh, ":raw" unless $layer eq ":raw"; # remove all layers first
+ binmode $fh, $layer or croak "binmode $layer failed: $!";
+}
+
+sub _spool_data_to_child {
+ my ( $type, $source, $binmode_it ) = @_;
+
+ # If undef (not \undef) passed, they want the child to inherit
+ # the parent's STDIN.
+ return undef unless defined $source;
+
+ my $fh;
+ if ( ! $type ) {
+ open $fh, "<", $source or croak "$!: $source";
+ _binmode($fh, $binmode_it, "STDIN");
+ warn "run3(): feeding file '$source' to child STDIN\n"
+ if debugging >= 2;
+ } elsif ( $type eq "FH" ) {
+ $fh = $source;
+ warn "run3(): feeding filehandle '$source' to child STDIN\n"
+ if debugging >= 2;
+ } else {
+ $fh = $fh_cache{in} ||= tempfile;
+ truncate $fh, 0;
+ seek $fh, 0, 0;
+ _binmode($fh, $binmode_it, "STDIN");
+ my $seekit;
+ if ( $type eq "SCALAR" ) {
+
+ # When the run3()'s caller asks to feed an empty file
+ # to the child's stdin, we want to pass a live file
+ # descriptor to an empty file (like /dev/null) so that
+ # they don't get surprised by invalid fd errors and get
+ # normal EOF behaviors.
+ return $fh unless defined $$source; # \undef passed
+
+ warn "run3(): feeding SCALAR to child STDIN",
+ debugging >= 3
+ ? ( ": '", $$source, "' (", length $$source, " chars)" )
+ : (),
+ "\n"
+ if debugging >= 2;
+
+ $seekit = length $$source;
+ print $fh $$source or die "$! writing to temp file";
+
+ } elsif ( $type eq "ARRAY" ) {
+ warn "run3(): feeding ARRAY to child STDIN",
+ debugging >= 3 ? ( ": '", @$source, "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ print $fh @$source or die "$! writing to temp file";
+ $seekit = grep length, @$source;
+ } elsif ( $type eq "CODE" ) {
+ warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
+ if debugging >= 2;
+ my $parms = []; # TODO: get these from $options
+ while (1) {
+ my $data = $source->( @$parms );
+ last unless defined $data;
+ print $fh $data or die "$! writing to temp file";
+ $seekit = length $data;
+ }
+ }
+
+ seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
+ if $seekit;
+ }
+
+ croak "run3() can't redirect $type to child stdin"
+ unless defined $fh;
+
+ return $fh;
+}
+
+sub _fh_for_child_output {
+ my ( $what, $type, $dest, $options ) = @_;
+
+ my $fh;
+ if ( $type eq "SCALAR" && $dest == \undef ) {
+ warn "run3(): redirecting child $what to oblivion\n"
+ if debugging >= 2;
+
+ $fh = $fh_cache{nul} ||= do {
+ open $fh, ">", File::Spec->devnull;
+ $fh;
+ };
+ } elsif ( $type eq "FH" ) {
+ $fh = $dest;
+ warn "run3(): redirecting $what to filehandle '$dest'\n"
+ if debugging >= 3;
+ } elsif ( !$type ) {
+ warn "run3(): feeding child $what to file '$dest'\n"
+ if debugging >= 2;
+
+ open $fh, $options->{"append_$what"} ? ">>" : ">", $dest
+ or croak "$!: $dest";
+ } else {
+ warn "run3(): capturing child $what\n"
+ if debugging >= 2;
+
+ $fh = $fh_cache{$what} ||= tempfile;
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ }
+
+ my $binmode_it = $options->{"binmode_$what"};
+ _binmode($fh, $binmode_it, uc $what);
+
+ return $fh;
+}
+
+sub _read_child_output_fh {
+ my ( $what, $type, $dest, $fh, $options ) = @_;
+
+ return if $type eq "SCALAR" && $dest == \undef;
+
+ seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";
+
+ if ( $type eq "SCALAR" ) {
+ warn "run3(): reading child $what to SCALAR\n"
+ if debugging >= 3;
+
+ # two read()s are used instead of 1 so that the first will be
+ # logged even it reads 0 bytes; the second won't.
+ my $count = read $fh, $$dest, 10_000,
+ $options->{"append_$what"} ? length $$dest : 0;
+ while (1) {
+ croak "$! reading child $what from temp file"
+ unless defined $count;
+
+ last unless $count;
+
+ warn "run3(): read $count bytes from child $what",
+ debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ $count = read $fh, $$dest, 10_000, length $$dest;
+ }
+ } elsif ( $type eq "ARRAY" ) {
+ if ($options->{"append_$what"}) {
+ push @$dest, <$fh>;
+ } else {
+ @$dest = <$fh>;
+ }
+ if ( debugging >= 2 ) {
+ my $count = 0;
+ $count += length for @$dest;
+ warn
+ "run3(): read ",
+ scalar @$dest,
+ " records, $count bytes from child $what",
+ debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
+ "\n";
+ }
+ } elsif ( $type eq "CODE" ) {
+ warn "run3(): capturing child $what to CODE ref\n"
+ if debugging >= 3;
+
+ local $_;
+ while ( <$fh> ) {
+ warn
+ "run3(): read ",
+ length,
+ " bytes from child $what",
+ debugging >= 3 ? ( ": '", $_, "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ $dest->( $_ );
+ }
+ } else {
+ croak "run3() can't redirect child $what to a $type";
+ }
+
+}
+
+sub _type {
+ my ( $redir ) = @_;
+
+ return "FH" if eval {
+ local $SIG{'__DIE__'};
+ $redir->isa("IO::Handle")
+ };
+
+ my $type = ref $redir;
+ return $type eq "GLOB" ? "FH" : $type;
+}
+
+sub _max_fd {
+ my $fd = dup(0);
+ POSIX::close $fd;
+ return $fd;
+}
+
+my $run_call_time;
+my $sys_call_time;
+my $sys_exit_time;
+
+sub run3 {
+ $run_call_time = gettimeofday() if profiling;
+
+ my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};
+
+ my ( $cmd, $stdin, $stdout, $stderr ) = @_;
+
+ print STDERR "run3(): running ",
+ join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
+ "\n"
+ if debugging;
+
+ if ( ref $cmd ) {
+ croak "run3(): empty command" unless @$cmd;
+ croak "run3(): undefined command" unless defined $cmd->[0];
+ croak "run3(): command name ('')" unless length $cmd->[0];
+ } else {
+ croak "run3(): missing command" unless @_;
+ croak "run3(): undefined command" unless defined $cmd;
+ croak "run3(): command ('')" unless length $cmd;
+ }
+
+ foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) {
+ if (my $mode = $options->{$_}) {
+ croak qq[option $_ must be a number or a proper layer string: "$mode"]
+ unless $mode =~ /^(:|\d+$)/;
+ }
+ }
+
+ my $in_type = _type $stdin;
+ my $out_type = _type $stdout;
+ my $err_type = _type $stderr;
+
+ if ($fh_cache_pid != $$) {
+ # fork detected, close all cached filehandles and clear the cache
+ close $_ foreach values %fh_cache;
+ %fh_cache = ();
+ $fh_cache_pid = $$;
+ }
+
+ # This routine proceeds in stages so that a failure in an early
+ # stage prevents later stages from running, and thus from needing
+ # cleanup.
+
+ my $in_fh = _spool_data_to_child $in_type, $stdin,
+ $options->{binmode_stdin} if defined $stdin;
+
+ my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
+ $options if defined $stdout;
+
+ my $tie_err_to_out =
+ defined $stderr && defined $stdout && $stderr eq $stdout;
+
+ my $err_fh = $tie_err_to_out
+ ? $out_fh
+ : _fh_for_child_output "stderr", $err_type, $stderr,
+ $options if defined $stderr;
+
+ # this should make perl close these on exceptions
+# local *STDIN_SAVE;
+ local *STDOUT_SAVE;
+ local *STDERR_SAVE;
+
+ my $saved_fd0 = dup( 0 ) if defined $in_fh;
+
+# open STDIN_SAVE, "<&STDIN"# or croak "run3(): $! saving STDIN"
+# if defined $in_fh;
+ open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
+ if defined $out_fh;
+ open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
+ if defined $err_fh;
+
+ my $errno;
+ my $ok = eval {
+ # The open() call here seems to not force fd 0 in some cases;
+ # I ran in to trouble when using this in VCP, not sure why.
+ # the dup2() seems to work.
+ dup2( fileno $in_fh, 0 )
+# open STDIN, "<&=" . fileno $in_fh
+ or croak "run3(): $! redirecting STDIN"
+ if defined $in_fh;
+
+# close $in_fh or croak "$! closing STDIN temp file"
+# if ref $stdin;
+
+ open STDOUT, ">&" . fileno $out_fh
+ or croak "run3(): $! redirecting STDOUT"
+ if defined $out_fh;
+
+ open STDERR, ">&" . fileno $err_fh
+ or croak "run3(): $! redirecting STDERR"
+ if defined $err_fh;
+
+ $sys_call_time = gettimeofday() if profiling;
+
+ my $r = ref $cmd
+ ? system { $cmd->[0] } is_win32 ? quote_native( @$cmd ) : @$cmd
+ : system $cmd;
+
+ $errno = $!; # save $!, because later failures will overwrite it
+ $sys_exit_time = gettimeofday() if profiling;
+ if ( debugging ) {
+ my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
+ if ( defined $r && $r != -1 ) {
+ print $err_fh "run3(): \$? is $?\n";
+ } else {
+ print $err_fh "run3(): \$? is $?, \$! is $errno\n";
+ }
+ }
+
+ if (
+ defined $r
+ && ( $r == -1 || ( is_win32 && $r == 0xFF00 ) )
+ && !$options->{return_if_system_error}
+ ) {
+ croak( $errno );
+ }
+
+ 1;
+ };
+ my $x = $@;
+
+ my @errs;
+
+ if ( defined $saved_fd0 ) {
+ dup2( $saved_fd0, 0 );
+ POSIX::close( $saved_fd0 );
+ }
+
+# open STDIN, "<&STDIN_SAVE"# or push @errs, "run3(): $! restoring STDIN"
+# if defined $in_fh;
+ open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
+ if defined $out_fh;
+ open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
+ if defined $err_fh;
+
+ croak join ", ", @errs if @errs;
+
+ die $x unless $ok;
+
+ _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
+ if defined $out_fh && $out_type && $out_type ne "FH";
+ _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
+ if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
+ $profiler->run_exit(
+ $cmd,
+ $run_call_time,
+ $sys_call_time,
+ $sys_exit_time,
+ scalar gettimeofday()
+ ) if profiling;
+
+ $! = $errno; # restore $! from system()
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=head2 C<< run3($cmd, $stdin, $stdout, $stderr, \%options) >>
+
+All parameters after C<$cmd> are optional.
+
+The parameters C<$stdin>, C<$stdout> and C<$stderr> indicate how the child's
+corresponding filehandle (C<STDIN>, C<STDOUT> and C<STDERR>, resp.) will be
+redirected. Because the redirects come last, this allows C<STDOUT> and
+C<STDERR> to default to the parent's by just not specifying them -- a common
+use case.
+
+C<run3> throws an exception if the wrapped C<system> call returned -1 or
+anything went wrong with C<run3>'s processing of filehandles. Otherwise it
+returns true. It leaves C<$?> intact for inspection of exit and wait status.
+
+Note that a true return value from C<run3> doesn't mean that the command had a
+successful exit code. Hence you should always check C<$?>.
+
+See L</%options> for an option to handle the case of C<system> returning -1
+yourself.
+
+=head3 C<$cmd>
+
+Usually C<$cmd> will be an ARRAY reference and the child is invoked via
+
+ system @$cmd;
+
+But C<$cmd> may also be a string in which case the child is invoked via
+
+ system $cmd;
+
+(cf. L<perlfunc/system> for the difference and the pitfalls of using
+the latter form).
+
+=head3 C<$stdin>, C<$stdout>, C<$stderr>
+
+The parameters C<$stdin>, C<$stdout> and C<$stderr> can take one of the
+following forms:
+
+=over 4
+
+=item C<undef> (or not specified at all)
+
+The child inherits the corresponding filehandle from the parent.
+
+ run3 \@cmd, $stdin; # child writes to same STDOUT and STDERR as parent
+ run3 \@cmd, undef, $stdout, $stderr; # child reads from same STDIN as parent
+
+=item C<\undef>
+
+The child's filehandle is redirected from or to the local equivalent of
+C</dev/null> (as returned by C<< File::Spec->devnull() >>).
+
+ run3 \@cmd, \undef, $stdout, $stderr; # child reads from /dev/null
+
+=item a simple scalar
+
+The parameter is taken to be the name of a file to read from
+or write to. In the latter case, the file will be opened via
+
+ open FH, ">", ...
+
+i.e. it is created if it doesn't exist and truncated otherwise.
+Note that the file is opened by the parent which will L<croak|Carp/croak>
+in case of failure.
+
+ run3 \@cmd, \undef, "out.txt"; # child writes to file "out.txt"
+
+=item a filehandle (either a reference to a GLOB or an C<IO::Handle>)
+
+The filehandle is inherited by the child.
+
+ open my $fh, ">", "out.txt";
+ print $fh "prologue\n";
+ ...
+ run3 \@cmd, \undef, $fh; # child writes to $fh
+ ...
+ print $fh "epilogue\n";
+ close $fh;
+
+=item a SCALAR reference
+
+The referenced scalar is treated as a string to be read from or
+written to. In the latter case, the previous content of the string
+is overwritten.
+
+ my $out;
+ run3 \@cmd, \undef, \$out; # child writes into string
+ run3 \@cmd, \<<EOF; # child reads from string (can use "here" notation)
+ Input
+ to
+ child
+ EOF
+
+=item an ARRAY reference
+
+For C<$stdin>, the elements of C<@$stdin> are simply spooled to the child.
+
+For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
+is read line by line (as determined by the current setting of C<$/>)
+into C<@$stdout> or C<@$stderr>, resp. The previous content of the array
+is overwritten.
+
+ my @lines;
+ run3 \@cmd, \undef, \@lines; # child writes into array
+
+=item a CODE reference
+
+For C<$stdin>, C<&$stdin> will be called repeatedly (with no arguments) and
+the return values are spooled to the child. C<&$stdin> must signal the end of
+input by returning C<undef>.
+
+For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
+is read line by line (as determined by the current setting of C<$/>)
+and C<&$stdout> or C<&$stderr>, resp., is called with the contents of the line.
+Note that there's no end-of-file indication.
+
+ my $i = 0;
+ sub producer {
+ return $i < 10 ? "line".$i++."\n" : undef;
+ }
+
+ run3 \@cmd, \&producer; # child reads 10 lines
+
+Note that this form of redirecting the child's I/O doesn't imply
+any form of concurrency between parent and child - run3()'s method of
+operation is the same no matter which form of redirection you specify.
+
+=back
+
+If the same value is passed for C<$stdout> and C<$stderr>, then the child
+will write both C<STDOUT> and C<STDERR> to the same filehandle.
+In general, this means that
+
+ run3 \@cmd, \undef, "foo.txt", "foo.txt";
+ run3 \@cmd, \undef, \$both, \$both;
+
+will DWIM and pass a single file handle to the child for both C<STDOUT> and
+C<STDERR>, collecting all into file "foo.txt" or C<$both>.
+
+=head3 C<\%options>
+
+The last parameter, C<\%options>, must be a hash reference if present.
+
+Currently the following keys are supported:
+
+=over 4
+
+=item C<binmode_stdin>, C<binmode_stdout>, C<binmode_stderr>
+
+The value must a "layer" as described in L<perlfunc/binmode>. If specified the
+corresponding parameter C<$stdin>, C<$stdout> or C<$stderr>, resp., operates
+with the given layer.
+
+For backward compatibility, a true value that doesn't start with ":"
+(e.g. a number) is interpreted as ":raw". If the value is false
+or not specified, the default is ":crlf" on Windows and ":raw" otherwise.
+
+Don't expect that values other than the built-in layers ":raw", ":crlf",
+and (on newer Perls) ":bytes", ":utf8", ":encoding(...)" will work.
+
+=item C<append_stdout>, C<append_stderr>
+
+If their value is true then the corresponding parameter C<$stdout> or
+C<$stderr>, resp., will append the child's output to the existing "contents" of
+the redirector. This only makes sense if the redirector is a simple scalar (the
+corresponding file is opened in append mode), a SCALAR reference (the output is
+appended to the previous contents of the string) or an ARRAY reference (the
+output is C<push>ed onto the previous contents of the array).
+
+=item C<return_if_system_error>
+
+If this is true C<run3> does B<not> throw an exception if C<system> returns -1
+(cf. L<perlfunc/system> for possible failure scenarios.), but returns true
+instead. In this case C<$?> has the value -1 and C<$!> contains the errno of
+the failing C<system> call.
+
+=back
+
+=head1 HOW IT WORKS
+
+=over 4
+
+=item (1)
+
+For each redirector C<$stdin>, C<$stdout>, and C<$stderr>, C<run3()> furnishes
+a filehandle:
+
+=over 4
+
+=item *
+
+if the redirector already specifies a filehandle it just uses that
+
+=item *
+
+if the redirector specifies a filename, C<run3()> opens the file
+in the appropriate mode
+
+=item *
+
+in all other cases, C<run3()> opens a temporary file (using
+L<tempfile|Temp/tempfile>)
+
+=back
+
+=item (2)
+
+If C<run3()> opened a temporary file for C<$stdin> in step (1),
+it writes the data using the specified method (either
+from a string, an array or returned by a function) to the temporary file and rewinds it.
+
+=item (3)
+
+C<run3()> saves the parent's C<STDIN>, C<STDOUT> and C<STDERR> by duplicating
+them to new filehandles. It duplicates the filehandles from step (1)
+to C<STDIN>, C<STDOUT> and C<STDERR>, resp.
+
+=item (4)
+
+C<run3()> runs the child by invoking L<system|perlfunc/system> with C<$cmd> as
+specified above.
+
+=item (5)
+
+C<run3()> restores the parent's C<STDIN>, C<STDOUT> and C<STDERR> saved in step (3).
+
+=item (6)
+
+If C<run3()> opened a temporary file for C<$stdout> or C<$stderr> in step (1),
+it rewinds it and reads back its contents using the specified method (either to
+a string, an array or by calling a function).
+
+=item (7)
+
+C<run3()> closes all filehandles that it opened explicitly in step (1).
+
+=back
+
+Note that when using temporary files, C<run3()> tries to amortize the overhead
+by reusing them (i.e. it keeps them open and rewinds and truncates them
+before the next operation).
+
+=head1 LIMITATIONS
+
+Often uses intermediate files (determined by File::Temp, and thus by the
+File::Spec defaults and the TMPDIR env. variable) for speed, portability and
+simplicity.
+
+Use extreme caution when using C<run3> in a threaded environment if concurrent
+calls of C<run3> are possible. Most likely, I/O from different invocations will
+get mixed up. The reason is that in most thread implementations all threads in
+a process share the same STDIN/STDOUT/STDERR. Known failures are Perl ithreads
+on Linux and Win32. Note that C<fork> on Win32 is emulated via Win32 threads
+and hence I/O mix up is possible between forked children here (C<run3> is "fork
+safe" on Unix, though).
+
+=head1 DEBUGGING
+
+To enable debugging use the IPCRUN3DEBUG environment variable to
+a non-zero integer value:
+
+ $ IPCRUN3DEBUG=1 myapp
+
+=head1 PROFILING
+
+To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
+information to STDERR (1 to get timestamps, 2 to get a summary report at the
+END of the program, 3 to get mini reports after each run) or to a filename to
+emit raw data to a file for later analysis.
+
+=head1 COMPARISON
+
+Here's how it stacks up to existing APIs:
+
+=head2 compared to C<system()>, C<qx''>, C<open "...|">, C<open "|...">
+
+=over
+
+=item *
+
+better: redirects more than one file descriptor
+
+=item *
+
+better: returns TRUE on success, FALSE on failure
+
+=item *
+
+better: throws an error if problems occur in the parent process (or the
+pre-exec child)
+
+=item *
+
+better: allows a very perlish interface to Perl data structures and subroutines
+
+=item *
+
+better: allows 1 word invocations to avoid the shell easily:
+
+ run3 ["foo"]; # does not invoke shell
+
+=item *
+
+worse: does not return the exit code, leaves it in $?
+
+=back
+
+=head2 compared to C<open2()>, C<open3()>
+
+=over
+
+=item *
+
+better: no lengthy, error prone polling/select loop needed
+
+=item *
+
+better: hides OS dependencies
+
+=item *
+
+better: allows SCALAR, ARRAY, and CODE references to source and sink I/O
+
+=item *
+
+better: I/O parameter order is like C<open3()> (not like C<open2()>).
+
+=item *
+
+worse: does not allow interaction with the subprocess
+
+=back
+
+=head2 compared to L<IPC::Run::run()|IPC::Run/run>
+
+=over
+
+=item *
+
+better: smaller, lower overhead, simpler, more portable
+
+=item *
+
+better: no select() loop portability issues
+
+=item *
+
+better: does not fall prey to Perl closure leaks
+
+=item *
+
+worse: does not allow interaction with the subprocess (which IPC::Run::run()
+allows by redirecting subroutines)
+
+=item *
+
+worse: lacks many features of C<IPC::Run::run()> (filters, pipes, redirects,
+pty support)
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>C<barries@slaysys.com>E<gt>
+
+Ricardo SIGNES E<lt>C<rjbs@cpan.org>E<gt> performed routine maintenance since
+2010, thanks to help from the following ticket and/or patch submitters: Jody
+Belka, Roderich Schupp, David Morel, Jeff Lavallee, and anonymous others.
+
+=cut
--- /dev/null
+package IPC::Run3::ProfArrayBuffer;
+
+$VERSION = 0.048;
+
+=head1 NAME
+
+IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=over
+
+=item C<< IPC::Run3::ProfArrayBuffer->new() >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ my $self = bless { @_ }, $class;
+
+ $self->{Events} = [];
+
+ return $self;
+}
+
+=item C<< $buffer->app_call(@events) >>
+
+=item C<< $buffer->app_exit(@events) >>
+
+=item C<< $buffer->run_exit(@events) >>
+
+The three above methods push the given events onto the stack of recorded
+events.
+
+=cut
+
+for my $subname ( qw(app_call app_exit run_exit) ) {
+ no strict 'refs';
+ *{$subname} = sub {
+ push @{shift->{Events}}, [ $subname => @_ ];
+ };
+}
+
+=item get_events
+
+Returns a list of all the events. Each event is an ARRAY reference
+like:
+
+ [ "app_call", 1.1, ... ];
+
+=cut
+
+sub get_events {
+ my $self = shift;
+ @{$self->{Events}};
+}
+
+=back
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
--- /dev/null
+package IPC::Run3::ProfLogReader;
+
+$VERSION = 0.048;
+
+=head1 NAME
+
+IPC::Run3::ProfLogReader - read and process a ProfLogger file
+
+=head1 SYNOPSIS
+
+ use IPC::Run3::ProfLogReader;
+
+ my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out"
+ my $reader = IPC::Run3::ProfLogReader->new( Source => $fn );
+
+ my $profiler = IPC::Run3::ProfPP; ## For example
+ my $reader = IPC::Run3::ProfLogReader->new( ..., Handler => $p );
+
+ $reader->read;
+ $eaderr->read_all;
+
+=head1 DESCRIPTION
+
+Reads a log file. Use the filename "-" to read from STDIN.
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfLogReader->new( ... ) >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+
+ $self->{Source} = "run3.out"
+ unless defined $self->{Source} && length $self->{Source};
+
+ my $source = $self->{Source};
+
+ if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) {
+ $self->{FH} = $source;
+ }
+ elsif ( $source eq "-" ) {
+ $self->{FH} = \*STDIN;
+ }
+ else {
+ open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n";
+ $self->{FH} = *PROFILE{IO};
+ }
+ return $self;
+}
+
+
+=head2 C<< $reader->set_handler( $handler ) >>
+
+=cut
+
+sub set_handler { $_[0]->{Handler} = $_[1] }
+
+=head2 C<< $reader->get_handler() >>
+
+=cut
+
+sub get_handler { $_[0]->{Handler} }
+
+=head2 C<< $reader->read() >>
+
+=cut
+
+sub read {
+ my $self = shift;
+
+ my $fh = $self->{FH};
+ my @ln = split / /, <$fh>;
+
+ return 0 unless @ln;
+ return 1 unless $self->{Handler};
+
+ chomp $ln[-1];
+
+ ## Ignore blank and comment lines.
+ return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#";
+
+ if ( $ln[0] eq "\\app_call" ) {
+ shift @ln;
+ my @times = split /,/, pop @ln;
+ $self->{Handler}->app_call(
+ [
+ map {
+ s/\\\\/\\/g;
+ s/\\_/ /g;
+ $_;
+ } @ln
+ ],
+ @times
+ );
+ }
+ elsif ( $ln[0] eq "\\app_exit" ) {
+ shift @ln;
+ $self->{Handler}->app_exit( pop @ln, @ln );
+ }
+ else {
+ my @times = split /,/, pop @ln;
+ $self->{Handler}->run_exit(
+ [
+ map {
+ s/\\\\/\\/g;
+ s/\\_/ /g;
+ $_;
+ } @ln
+ ],
+ @times
+ );
+ }
+
+ return 1;
+}
+
+
+=head2 C<< $reader->read_all() >>
+
+This method reads until there is nothing left to read, and then returns true.
+
+=cut
+
+sub read_all {
+ my $self = shift;
+
+ 1 while $self->read;
+
+ return 1;
+}
+
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
--- /dev/null
+package IPC::Run3::ProfLogger;
+
+$VERSION = 0.048;
+
+=head1 NAME
+
+IPC::Run3::ProfLogger - write profiling data to a log file
+
+=head1 SYNOPSIS
+
+ use IPC::Run3::ProfLogger;
+
+ my $logger = IPC::Run3::ProfLogger->new; ## write to "run3.out"
+ my $logger = IPC::Run3::ProfLogger->new( Destination => $fn );
+
+ $logger->app_call( \@cmd, $time );
+
+ $logger->run_exit( \@cmd1, @times1 );
+ $logger->run_exit( \@cmd1, @times1 );
+
+ $logger->app_exit( $time );
+
+=head1 DESCRIPTION
+
+Used by IPC::Run3 to write a profiling log file. Does not
+generate reports or maintain statistics; its meant to have minimal
+overhead.
+
+Its API is compatible with a tiny subset of the other IPC::Run profiling
+classes.
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfLogger->new( ... ) >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+
+ $self->{Destination} = "run3.out"
+ unless defined $self->{Destination} && length $self->{Destination};
+
+ open PROFILE, ">$self->{Destination}"
+ or die "$!: $self->{Destination}\n";
+ binmode PROFILE;
+ $self->{FH} = *PROFILE{IO};
+
+ $self->{times} = [];
+ return $self;
+}
+
+=head2 C<< $logger->run_exit( ... ) >>
+
+=cut
+
+sub run_exit {
+ my $self = shift;
+ my $fh = $self->{FH};
+ print( $fh
+ join(
+ " ",
+ (
+ map {
+ my $s = $_;
+ $s =~ s/\\/\\\\/g;
+ $s =~ s/ /_/g;
+ $s;
+ } @{shift()}
+ ),
+ join(
+ ",",
+ @{$self->{times}},
+ @_,
+ ),
+ ),
+ "\n"
+ );
+}
+
+=head2 C<< $logger->app_exit( $arg ) >>
+
+=cut
+
+sub app_exit {
+ my $self = shift;
+ my $fh = $self->{FH};
+ print $fh "\\app_exit ", shift, "\n";
+}
+
+=head2 C<< $logger->app_call( $t, @args) >>
+
+=cut
+
+sub app_call {
+ my $self = shift;
+ my $fh = $self->{FH};
+ my $t = shift;
+ print( $fh
+ join(
+ " ",
+ "\\app_call",
+ (
+ map {
+ my $s = $_;
+ $s =~ s/\\\\/\\/g;
+ $s =~ s/ /\\_/g;
+ $s;
+ } @_
+ ),
+ $t,
+ ),
+ "\n"
+ );
+}
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
--- /dev/null
+package IPC::Run3::ProfPP;
+
+$VERSION = 0.048;
+
+=head1 NAME
+
+IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Used by IPC::Run3 and/or run3profpp to print out profiling reports for
+human readers. Use other classes for extracting data in other ways.
+
+The output methods are plain text, override these (see the source for
+now) to provide other formats.
+
+This class generates reports on each run3_exit() and app_exit() call.
+
+=cut
+
+require IPC::Run3::ProfReporter;
+@ISA = qw( IPC::Run3::ProfReporter );
+
+use strict;
+use POSIX qw( floor );
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfPP->new() >>
+
+Returns a new profile reporting object.
+
+=cut
+
+sub _emit { shift; warn @_ }
+
+sub _t {
+ sprintf "%10.6f secs", @_;
+}
+
+sub _r {
+ my ( $num, $denom ) = @_;
+ return () unless $denom;
+ sprintf "%10.6f", $num / $denom;
+}
+
+sub _pct {
+ my ( $num, $denom ) = @_;
+ return () unless $denom;
+ sprintf " (%3d%%)", floor( 100 * $num / $denom + 0.5 );
+}
+
+=head2 C<< $profpp->handle_app_call() >>
+
+=cut
+
+sub handle_app_call {
+ my $self = shift;
+ $self->_emit("IPC::Run3 parent: ",
+ join( " ", @{$self->get_app_cmd} ),
+ "\n",
+ );
+
+ $self->{NeedNL} = 1;
+}
+
+=head2 C<< $profpp->handle_app_exit() >>
+
+=cut
+
+sub handle_app_exit {
+ my $self = shift;
+
+ $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1;
+
+ $self->_emit( "IPC::Run3 total elapsed: ",
+ _t( $self->get_app_cumulative_time ),
+ "\n");
+ $self->_emit( "IPC::Run3 calls to run3(): ",
+ sprintf( "%10d", $self->get_run_count ),
+ "\n");
+ $self->_emit( "IPC::Run3 total spent in run3(): ",
+ _t( $self->get_run_cumulative_time ),
+ _pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ),
+ ", ",
+ _r( $self->get_run_cumulative_time, $self->get_run_count ),
+ " per call",
+ "\n");
+ my $exclusive =
+ $self->get_app_cumulative_time - $self->get_run_cumulative_time;
+ $self->_emit( "IPC::Run3 total spent not in run3(): ",
+ _t( $exclusive ),
+ _pct( $exclusive, $self->get_app_cumulative_time ),
+ "\n");
+ $self->_emit( "IPC::Run3 total spent in children: ",
+ _t( $self->get_sys_cumulative_time ),
+ _pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ),
+ ", ",
+ _r( $self->get_sys_cumulative_time, $self->get_run_count ),
+ " per call",
+ "\n");
+ my $overhead =
+ $self->get_run_cumulative_time - $self->get_sys_cumulative_time;
+ $self->_emit( "IPC::Run3 total overhead: ",
+ _t( $overhead ),
+ _pct(
+ $overhead,
+ $self->get_sys_cumulative_time
+ ),
+ ", ",
+ _r( $overhead, $self->get_run_count ),
+ " per call",
+ "\n");
+}
+
+=head2 C<< $profpp->handle_run_exit() >>
+
+=cut
+
+sub handle_run_exit {
+ my $self = shift;
+ my $overhead = $self->get_run_time - $self->get_sys_time;
+
+ $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2;
+ $self->{NeedNL} = 3;
+
+ $self->_emit( "IPC::Run3 child: ",
+ join( " ", @{$self->get_run_cmd} ),
+ "\n");
+ $self->_emit( "IPC::Run3 run3() : ", _t( $self->get_run_time ), "\n",
+ "IPC::Run3 child : ", _t( $self->get_sys_time ), "\n",
+ "IPC::Run3 overhead: ", _t( $overhead ),
+ _pct( $overhead, $self->get_sys_time ),
+ "\n");
+}
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
--- /dev/null
+package IPC::Run3::ProfReporter;
+
+$VERSION = 0.048;
+
+=head1 NAME
+
+IPC::Run3::ProfReporter - base class for handling profiling data
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+See L<IPC::Run3::ProfPP|IPC::Run3::ProfPP> and for an example subclass.
+
+This class just notes and accumulates times; subclasses use methods like
+"handle_app_call", "handle_run_exit" and "handle_app_exit" to emit reports on
+it. The default methods for these handlers are noops.
+
+If run from the command line, a reporter will be created and run on
+each logfile given as a command line parameter or on run3.out if none
+are given.
+
+This allows reports to be run like:
+
+ perl -MIPC::Run3::ProfPP -e1
+ perl -MIPC::Run3::ProfPP -e1 foo.out bar.out
+
+Use "-" to read from STDIN (the log file format is meant to be moderately
+greppable):
+
+ grep "^cvs " run3.out perl -MIPC::Run3::ProfPP -e1 -
+
+Use --app to show only application level statistics (ie don't emit
+a report section for each command run).
+
+=cut
+
+use strict;
+
+my $loaded_by;
+
+sub import {
+ $loaded_by = shift;
+}
+
+END {
+ my @caller;
+ for ( my $i = 0;; ++$i ) {
+ my @c = caller $i;
+ last unless @c;
+ @caller = @c;
+ }
+
+ if ( $caller[0] eq "main"
+ && $caller[1] eq "-e"
+ ) {
+ require IPC::Run3::ProfLogReader;
+ require Getopt::Long;
+ my ( $app, $run );
+
+ Getopt::Long::GetOptions(
+ "app" => \$app,
+ "run" => \$run,
+ );
+
+ $app = 1, $run = 1 unless $app || $run;
+
+ for ( @ARGV ? @ARGV : "" ) {
+ my $r = IPC::Run3::ProfLogReader->new(
+ Source => $_,
+ Handler => $loaded_by->new(
+ Source => $_,
+ app_report => $app,
+ run_report => $run,
+ ),
+ );
+ $r->read_all;
+ }
+ }
+}
+
+=head1 METHODS
+
+=over
+
+=item C<< IPC::Run3::ProfReporter->new >>
+
+Returns a new profile reporting object.
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+ $self->{app_report} = 1, $self->{run_report} = 1
+ unless $self->{app_report} || $self->{run_report};
+
+ return $self;
+}
+
+=item C<< $reporter->handle_app_call( ... ) >>
+
+=item C<< $reporter->handle_app_exit( ... ) >>
+
+=item C<< $reporter->handle_run_exit( ... ) >>
+
+These methods are called by the handled events (see below).
+
+=cut
+
+sub handle_app_call {}
+sub handle_app_exit {}
+
+sub handle_run_exit {}
+
+=item C<< $reporter->app_call(\@cmd, $time) >>
+
+=item C<< $reporter->app_exit($time) >>
+
+=item C<< $reporter->run_exit(@times) >>
+
+ $self->app_call( $time );
+ my $time = $self->get_app_call_time;
+
+Sets the time (in floating point seconds) when the application, run3(),
+or system() was called or exited. If no time parameter is passed, uses
+IPC::Run3's time routine.
+
+Use get_...() to retrieve these values (and _accum values, too). This
+is a separate method to speed the execution time of the setters just a
+bit.
+
+=cut
+
+sub app_call {
+ my $self = shift;
+ ( $self->{app_cmd}, $self->{app_call_time} ) = @_;
+ $self->handle_app_call if $self->{app_report};
+}
+
+sub app_exit {
+ my $self = shift;
+ $self->{app_exit_time} = shift;
+ $self->handle_app_exit if $self->{app_report};
+}
+
+sub run_exit {
+ my $self = shift;
+ @{$self}{qw(
+ run_cmd run_call_time sys_call_time sys_exit_time run_exit_time
+ )} = @_;
+
+ ++$self->{run_count};
+ $self->{run_cumulative_time} += $self->get_run_time;
+ $self->{sys_cumulative_time} += $self->get_sys_time;
+ $self->handle_run_exit if $self->{run_report};
+}
+
+=item C<< $reporter->get_run_count() >>
+
+=item C<< $reporter->get_app_call_time() >>
+
+=item C<< $reporter->get_app_exit_time() >>
+
+=item C<< $reporter->get_app_cmd() >>
+
+=item C<< $reporter->get_app_time() >>
+
+=cut
+
+sub get_run_count { shift->{run_count} }
+sub get_app_call_time { shift->{app_call_time} }
+sub get_app_exit_time { shift->{app_exit_time} }
+sub get_app_cmd { shift->{app_cmd} }
+sub get_app_time {
+ my $self = shift;
+ $self->get_app_exit_time - $self->get_app_call_time;
+}
+
+=item C<< $reporter->get_app_cumulative_time() >>
+
+=cut
+
+sub get_app_cumulative_time {
+ my $self = shift;
+ $self->get_app_exit_time - $self->get_app_call_time;
+}
+
+=item C<< $reporter->get_run_call_time() >>
+
+=item C<< $reporter->get_run_exit_time() >>
+
+=item C<< $reporter->get_run_time() >>
+
+=cut
+
+sub get_run_call_time { shift->{run_call_time} }
+sub get_run_exit_time { shift->{run_exit_time} }
+sub get_run_time {
+ my $self = shift;
+ $self->get_run_exit_time - $self->get_run_call_time;
+}
+
+=item C<< $reporter->get_run_cumulative_time() >>
+
+=cut
+
+sub get_run_cumulative_time { shift->{run_cumulative_time} }
+
+=item C<< $reporter->get_sys_call_time() >>
+
+=item C<< $reporter->get_sys_exit_time() >>
+
+=item C<< $reporter->get_sys_time() >>
+
+=cut
+
+sub get_sys_call_time { shift->{sys_call_time} }
+sub get_sys_exit_time { shift->{sys_exit_time} }
+sub get_sys_time {
+ my $self = shift;
+ $self->get_sys_exit_time - $self->get_sys_call_time;
+}
+
+=item C<< $reporter->get_sys_cumulative_time() >>
+
+=cut
+
+sub get_sys_cumulative_time { shift->{sys_cumulative_time} }
+
+=item C<< $reporter->get_run_cmd() >>
+
+=cut
+
+sub get_run_cmd { shift->{run_cmd} }
+
+=back
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker <barries@slaysys.com>
+
+=cut
+
+1;
--- /dev/null
+package Menlo;
+our $VERSION = "1.9019";
+
+1;
+
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+Menlo - A CPAN client
+
+=head1 DESCRIPTION
+
+Menlo is a backend for I<cpanm 2.0>, developed with the goal to
+replace L<cpanm> internals with a set of modules that are more
+flexible, extensible and easier to use.
+
+=head1 COMPATIBILITY
+
+Menlo is developed within L<cpanminus> git repository at C<Menlo>
+subdirectory at L<https://github.com/miyagawa/cpanminus>
+
+Menlo::CLI::Compat started off as a copy of App::cpanminus::script,
+but will go under a big refactoring to extract all the bits out of
+it. Hopefully the end result will be just a shim and translation layer
+to interpret command line options.
+
+=head1 MOTIVATION
+
+cpanm has been a popular choice of CPAN package installer for many
+developers, because it is lightweight, fast, and requires no
+configuration in most environments.
+
+Meanwhile, the way cpanm has been implemented (one God class, and all
+modules are packaged in one script with fatpacker) makes it difficult
+to extend, or modify the behaviors at a runtime, unless you decide to
+fork the code or monkeypatch its hidden backend class.
+
+cpanm also has no scriptable API or hook points, which means if you
+want to write a tool that works with cpanm, you basically have to work
+around its behavior by writing a shell wrapper, or parsing the output
+of its standard out or a build log file.
+
+Menlo will keep the best aspects of cpanm, which is dependencies free,
+configuration free, lightweight and fast to install CPAN modules. At
+the same time, it's impelmented as a standard perl module, available
+on CPAN, and you can extend its behavior by either using its modular
+interfaces, or writing plugins to hook into its behaviors.
+
+=head1 FAQ
+
+=over 4
+
+=item Dependencies free? I see many prerequisites in Menlo.
+
+Menlo is a set of libraries and uses non-core CPAN modules as its
+dependencies. App-cpanminus distribution embeds Menlo and all of its
+runtime dependencies into a fatpacked binary, so that you can install
+App-cpanminus or Menlo without having any CPAN client to begin with.
+
+=item Is Menlo a new name for cpanm?
+
+Right now it's just a library name, but I'm comfortable calling this a
+new package name for cpanm 2's backend.
+
+=back
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+
+=head1 COPYRIGHT
+
+2010- Tatsuhiko Miyagawa
+
+=head1 LICENSE
+
+This software is licensed under the same terms as Perl.
+
+=head1 SEE ALSO
+
+L<cpanm>
+
+=cut
--- /dev/null
+package Menlo::Builder::Static;
+use strict;
+use warnings;
+
+use CPAN::Meta;
+use ExtUtils::Config 0.003;
+use ExtUtils::Helpers 0.020 qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
+use ExtUtils::Install qw/pm_to_blib install/;
+use ExtUtils::InstallPaths 0.002;
+use File::Basename qw/dirname/;
+use File::Find ();
+use File::Path qw/mkpath/;
+use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/;
+use Getopt::Long 2.36 qw/GetOptionsFromArray/;
+
+sub new {
+ my($class, %args) = @_;
+ bless {
+ meta => $args{meta},
+ }, $class;
+}
+
+sub meta {
+ my $self = shift;
+ $self->{meta};
+}
+
+sub manify {
+ my ($input_file, $output_file, $section, $opts) = @_;
+ return if -e $output_file && -M $input_file <= -M $output_file;
+ my $dirname = dirname($output_file);
+ mkpath($dirname, $opts->{verbose}) if not -d $dirname;
+ require Pod::Man;
+ Pod::Man->new(section => $section)->parse_from_file($input_file, $output_file);
+ print "Manifying $output_file\n" if $opts->{verbose} && $opts->{verbose} > 0;
+ return;
+}
+
+sub find {
+ my ($pattern, $dir) = @_;
+ my @ret;
+ File::Find::find(sub { push @ret, $File::Find::name if /$pattern/ && -f }, $dir) if -d $dir;
+ return @ret;
+}
+
+my %actions = (
+ build => sub {
+ my %opt = @_;
+ my %modules = map { $_ => catfile('blib', $_) } find(qr/\.p(?:m|od)$/, 'lib');
+ my %scripts = map { $_ => catfile('blib', $_) } find(qr//, 'script');
+ my %shared = map { $_ => catfile(qw/blib lib auto share dist/, $opt{meta}->name, abs2rel($_, 'share')) } find(qr//, 'share');
+ pm_to_blib({ %modules, %scripts, %shared }, catdir(qw/blib lib auto/));
+ make_executable($_) for values %scripts;
+ mkpath(catdir(qw/blib arch/), $opt{verbose});
+
+ if ($opt{install_paths}->install_destination('bindoc') && $opt{install_paths}->is_default_installable('bindoc')) {
+ manify($_, catfile('blib', 'bindoc', man1_pagename($_)), $opt{config}->get('man1ext'), \%opt) for keys %scripts;
+ }
+ if ($opt{install_paths}->install_destination('libdoc') && $opt{install_paths}->is_default_installable('libdoc')) {
+ manify($_, catfile('blib', 'libdoc', man3_pagename($_)), $opt{config}->get('man3ext'), \%opt) for keys %modules;
+ }
+ 1;
+ },
+ test => sub {
+ my %opt = @_;
+ die "Must run `./Build build` first\n" if not -d 'blib';
+ require TAP::Harness::Env;
+ my %test_args = (
+ (verbosity => $opt{verbose}) x!! exists $opt{verbose},
+ (jobs => $opt{jobs}) x!! exists $opt{jobs},
+ (color => 1) x !!-t STDOUT,
+ lib => [ map { rel2abs(catdir(qw/blib/, $_)) } qw/arch lib/ ],
+ );
+ my $tester = TAP::Harness::Env->create(\%test_args);
+ $tester->runtests(sort +find(qr/\.t$/, 't'))->has_errors and return;
+ 1;
+ },
+ install => sub {
+ my %opt = @_;
+ die "Must run `./Build build` first\n" if not -d 'blib';
+ install($opt{install_paths}->install_map, @opt{qw/verbose dry_run uninst/});
+ 1;
+ },
+);
+
+sub build {
+ my $self = shift;
+ my $action = @_ && $_[0] =~ /\A\w+\z/ ? shift @_ : 'build';
+ die "No such action '$action'\n" if not $actions{$action};
+ my %opt;
+ GetOptionsFromArray([@$_], \%opt, qw/install_base=s install_path=s% installdirs=s destdir=s prefix=s config=s% uninst:1 verbose:1 dry_run:1 pureperl-only:1 create_packlist=i jobs=i/) for ($self->{env}, $self->{configure_args}, \@_);
+ $_ = detildefy($_) for grep { defined } @opt{qw/install_base destdir prefix/}, values %{ $opt{install_path} };
+ @opt{ 'config', 'meta' } = (ExtUtils::Config->new($opt{config}), $self->meta);
+ $actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name));
+}
+
+sub configure {
+ my $self = shift;
+ $self->{env} = defined $ENV{PERL_MB_OPT} ? [split_like_shell($ENV{PERL_MB_OPT})] : [];
+ $self->{configure_args} = [@_];
+ $self->meta->save(@$_) for ['MYMETA.json'], [ 'MYMETA.yml' => { version => 1.4 } ];
+}
+
+1;
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2011 by Leon Timmermans, David Golden.
+
+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
--- /dev/null
+package Menlo::CLI::Compat;
+use strict;
+use Config;
+use Cwd ();
+use Menlo;
+use Menlo::Dependency;
+use Menlo::Util qw(WIN32);
+use File::Basename ();
+use File::Find ();
+use File::Path ();
+use File::Spec ();
+use File::Copy ();
+use File::Temp ();
+use File::Which qw(which);
+use Getopt::Long ();
+use Symbol ();
+use version ();
+
+use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux');
+use constant CAN_SYMLINK => eval { symlink("", ""); 1 };
+
+our $VERSION = '1.9022';
+
+if ($INC{"App/FatPacker/Trace.pm"}) {
+ require version::vpp;
+}
+
+sub qs($) {
+ Menlo::Util::shell_quote($_[0]);
+}
+
+sub determine_home {
+ my $class = shift;
+
+ my $homedir = $ENV{HOME}
+ || eval { require File::HomeDir; File::HomeDir->my_home }
+ || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
+
+ if (WIN32) {
+ require Win32; # no fatpack
+ $homedir = Win32::GetShortPathName($homedir);
+ }
+
+ return "$homedir/.cpanm";
+}
+
+sub new {
+ my $class = shift;
+
+ my $self = bless {
+ name => "Menlo",
+ home => $class->determine_home,
+ cmd => 'install',
+ seen => {},
+ notest => undef,
+ test_only => undef,
+ installdeps => undef,
+ force => undef,
+ sudo => undef,
+ make => undef,
+ verbose => undef,
+ quiet => undef,
+ interactive => undef,
+ log => undef,
+ mirrors => [],
+ mirror_only => undef,
+ mirror_index => undef,
+ cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/",
+ perl => $^X,
+ argv => [],
+ local_lib => undef,
+ self_contained => undef,
+ exclude_vendor => undef,
+ prompt_timeout => 0,
+ prompt => undef,
+ configure_timeout => 60,
+ build_timeout => 3600,
+ test_timeout => 1800,
+ try_lwp => 1,
+ try_wget => 1,
+ try_curl => 1,
+ uninstall_shadows => ($] < 5.012),
+ skip_installed => 1,
+ skip_satisfied => 0,
+ static_install => 1,
+ auto_cleanup => 7, # days
+ pod2man => 1,
+ installed_dists => 0,
+ install_types => ['requires'],
+ with_develop => 0,
+ with_configure => 0,
+ showdeps => 0,
+ scandeps => 0,
+ scandeps_tree => [],
+ format => 'tree',
+ save_dists => undef,
+ skip_configure => 0,
+ verify => 0,
+ report_perl_version => !$class->maybe_ci,
+ build_args => {},
+ features => {},
+ pure_perl => 0,
+ cpanfile_path => 'cpanfile',
+ @_,
+ }, $class;
+
+ $self;
+}
+
+sub env {
+ my($self, $key) = @_;
+ $ENV{"PERL_CPANM_" . $key};
+}
+
+sub maybe_ci {
+ my $class = shift;
+ grep $ENV{$_}, qw( TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING );
+}
+
+sub install_type_handlers {
+ my $self = shift;
+
+ my @handlers;
+ for my $type (qw( recommends suggests )) {
+ push @handlers, "with-$type" => sub {
+ my %uniq;
+ $self->{install_types} = [ grep !$uniq{$_}++, @{$self->{install_types}}, $type ];
+ };
+ push @handlers, "without-$type" => sub {
+ $self->{install_types} = [ grep $_ ne $type, @{$self->{install_types}} ];
+ };
+ }
+
+ @handlers;
+}
+
+sub build_args_handlers {
+ my $self = shift;
+
+ my @handlers;
+ for my $phase (qw( configure build test install )) {
+ push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
+ }
+
+ @handlers;
+}
+
+sub parse_options {
+ my $self = shift;
+
+ local @ARGV = @{$self->{argv}};
+ push @ARGV, grep length, split /\s+/, $self->env('OPT');
+ push @ARGV, @_;
+
+ Getopt::Long::Configure("bundling");
+ Getopt::Long::GetOptions(
+ 'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
+ 'n|notest!' => \$self->{notest},
+ 'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 },
+ 'S|sudo!' => \$self->{sudo},
+ 'v|verbose' => \$self->{verbose},
+ 'verify!' => \$self->{verify},
+ 'q|quiet!' => \$self->{quiet},
+ 'h|help' => sub { $self->{action} = 'show_help' },
+ 'V|version' => sub { $self->{action} = 'show_version' },
+ 'perl=s' => sub {
+ $self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n", 1);
+ $self->{perl} = $_[1];
+ },
+ '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;
+ $self->{pod2man} = undef;
+ },
+ 'self-contained!' => \$self->{self_contained},
+ 'exclude-vendor!' => \$self->{exclude_vendor},
+ 'mirror=s@' => $self->{mirrors},
+ 'mirror-only!' => \$self->{mirror_only},
+ 'mirror-index=s' => sub { $self->{mirror_index} = $self->maybe_abs($_[1]) },
+ 'M|from=s' => sub {
+ $self->{mirrors} = [$_[1]];
+ $self->{mirror_only} = 1;
+ },
+ 'cpanmetadb=s' => \$self->{cpanmetadb},
+ 'cascade-search!' => \$self->{cascade_search},
+ 'prompt!' => \$self->{prompt},
+ 'installdeps' => \$self->{installdeps},
+ 'skip-installed!' => \$self->{skip_installed},
+ 'skip-satisfied!' => \$self->{skip_satisfied},
+ '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 },
+ 'U|uninstall' => sub { $self->{cmd} = 'uninstall' },
+ 'self-upgrade' => sub { $self->{action} = 'self_upgrade' },
+ 'uninst-shadows!' => \$self->{uninstall_shadows},
+ 'lwp!' => \$self->{try_lwp},
+ 'wget!' => \$self->{try_wget},
+ 'curl!' => \$self->{try_curl},
+ 'auto-cleanup=s' => \$self->{auto_cleanup},
+ 'man-pages!' => \$self->{pod2man},
+ 'scandeps' => \$self->{scandeps},
+ 'showdeps' => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
+ 'format=s' => \$self->{format},
+ 'save-dists=s' => sub {
+ $self->{save_dists} = $self->maybe_abs($_[1]);
+ },
+ 'skip-configure!' => \$self->{skip_configure},
+ 'static-install!' => \$self->{static_install},
+ 'dev!' => \$self->{dev_release},
+ 'metacpan!' => \$self->{metacpan},
+ 'report-perl-version!' => \$self->{report_perl_version},
+ 'configure-timeout=i' => \$self->{configure_timeout},
+ 'build-timeout=i' => \$self->{build_timeout},
+ 'test-timeout=i' => \$self->{test_timeout},
+ 'with-develop' => \$self->{with_develop},
+ 'without-develop' => sub { $self->{with_develop} = 0 },
+ 'with-configure' => \$self->{with_configure},
+ 'without-configure' => sub { $self->{with_configure} = 0 },
+ 'with-feature=s' => sub { $self->{features}{$_[1]} = 1 },
+ 'without-feature=s' => sub { $self->{features}{$_[1]} = 0 },
+ 'with-all-features' => sub { $self->{features}{__all} = 1 },
+ 'pp|pureperl!' => \$self->{pure_perl},
+ "cpanfile=s" => \$self->{cpanfile_path},
+ $self->install_type_handlers,
+ $self->build_args_handlers,
+ );
+
+ if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm
+ push @ARGV, $self->load_argv_from_fh(\*STDIN);
+ $self->{load_from_stdin} = 1;
+ }
+
+ $self->{argv} = \@ARGV;
+}
+
+sub check_upgrade {
+ my $self = shift;
+ my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin};
+ if ($0 eq '-') {
+ # run from curl, that's fine
+ return;
+ } elsif ($0 !~ /^$install_base/) {
+ if ($0 =~ m!perlbrew/bin!) {
+ die <<DIE;
+It appears your cpanm executable was installed via `perlbrew install-cpanm`.
+cpanm --self-upgrade won't upgrade the version of cpanm you're running.
+
+Run the following command to get it upgraded.
+
+ perlbrew install-cpanm
+
+DIE
+ } else {
+ die <<DIE;
+You are running cpanm from the path where your current perl won't install executables to.
+Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
+
+ cpanm path : $0
+ Install path : $Config{installsitebin}
+
+It means you either installed cpanm globally with system perl, or use distro packages such
+as rpm or apt-get, and you have to use them again to upgrade cpanm.
+DIE
+ }
+ }
+}
+
+sub check_libs {
+ my $self = shift;
+ return if $self->{_checked}++;
+ $self->bootstrap_local_lib;
+}
+
+sub setup_verify {
+ my $self = shift;
+
+ my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
+ $self->{cpansign} = which('cpansign');
+
+ unless ($has_modules && $self->{cpansign}) {
+ warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
+ $self->{verify} = 0;
+ }
+}
+
+sub parse_module_args {
+ my($self, $module) = @_;
+
+ # Plack@1.2 -> Plack~"==1.2"
+ # BUT don't expand @ in git URLs
+ $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
+
+ # Plack~1.20, DBI~"> 1.0, <= 2.0"
+ if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
+ return split '~', $module, 2;
+ } else {
+ return $module, undef;
+ }
+}
+
+sub run {
+ my $self = shift;
+
+ my $code;
+ eval {
+ $code = ($self->_doit == 0);
+ }; if (my $e = $@) {
+ warn $e;
+ $code = 1;
+ }
+
+ $self->{status} = $code;
+}
+
+sub status {
+ $_[0]->{status};
+}
+
+sub _doit {
+ my $self = shift;
+
+ $self->setup_home;
+ $self->init_tools;
+ $self->setup_verify if $self->{verify};
+
+ if (my $action = $self->{action}) {
+ $self->$action() and return 1;
+ }
+
+ return $self->show_help(1)
+ unless @{$self->{argv}} or $self->{load_from_stdin};
+
+ $self->configure_mirrors;
+
+ my $cwd = Cwd::cwd;
+
+ 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;
+ }
+ ($module, my $version) = $self->parse_module_args($module);
+
+ $self->chdir($cwd);
+ if ($self->{cmd} eq 'uninstall') {
+ $self->uninstall_module($module)
+ or push @fail, $module;
+ } else {
+ $self->install_module($module, 0, $version)
+ or push @fail, $module;
+ }
+ }
+
+ if ($self->{base} && $self->{auto_cleanup}) {
+ $self->cleanup_workdirs;
+ }
+
+ if ($self->{installed_dists}) {
+ my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
+ $self->diag("$self->{installed_dists} $dists installed\n", 1);
+ }
+
+ if ($self->{scandeps}) {
+ $self->dump_scandeps();
+ }
+ # Workaround for older File::Temp's
+ # where creating a tempdir with an implicit $PWD
+ # causes tempdir non-cleanup if $PWD changes
+ # as paths are stored internally without being resolved
+ # absolutely.
+ # https://rt.cpan.org/Public/Bug/Display.html?id=44924
+ $self->chdir($cwd);
+
+ 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);
+
+ # native path because we use shell redirect
+ $self->{log} = File::Spec->catfile($self->{base}, "build.log");
+ my $final_log = "$self->{home}/build.log";
+
+ { open my $out, ">$self->{log}" or die "$self->{log}: $!" }
+
+ if (CAN_SYMLINK) {
+ my $build_link = "$self->{home}/latest-build";
+ unlink $build_link;
+ symlink $self->{base}, $build_link;
+
+ unlink $final_log;
+ symlink $self->{log}, $final_log;
+ } else {
+ my $log = $self->{log}; my $home = $self->{home};
+ $self->{at_exit} = sub {
+ my $self = shift;
+ my $temp_log = "$home/build.log." . time . ".$$";
+ File::Copy::copy($log, $temp_log)
+ && unlink($final_log);
+ rename($temp_log, $final_log);
+ }
+ }
+
+ $self->chat("cpanm ($self->{name}) $Menlo::VERSION on perl $] built for $Config{archname}\n" .
+ "Work directory is $self->{base}\n");
+}
+
+sub search_mirror_index_local {
+ my ($self, $local, $module, $version) = @_;
+ require CPAN::Common::Index::LocalPackage;
+ my $index = CPAN::Common::Index::LocalPackage->new({ source => $local });
+ $self->search_common($index, { package => $module }, $version);
+}
+
+sub search_mirror_index {
+ my ($self, $mirror, $module, $version) = @_;
+ require Menlo::Index::Mirror;
+ my $index = Menlo::Index::Mirror->new({
+ mirror => $mirror,
+ cache => $self->source_for($mirror),
+ fetcher => sub { $self->mirror(@_) },
+ });
+ $self->search_common($index, { package => $module }, $version);
+}
+
+sub search_common {
+ my($self, $index, $search_args, $want_version) = @_;
+
+ $index->refresh_index;
+
+ my $found = $index->search_packages($search_args);
+ $found = $self->cpan_module_common($found) if $found;
+
+ return $found unless $self->{cascade_search};
+
+ if ($found) {
+ if ($self->satisfy_version($found->{module}, $found->{module_version}, $want_version)) {
+ return $found;
+ } else {
+ $self->chat("Found $found->{module} $found->{module_version} which doesn't satisfy $want_version.\n");
+ }
+ }
+
+ return;
+}
+
+sub with_version_range {
+ my($self, $version) = @_;
+ defined($version) && $version =~ /(?:<|!=|==)/;
+}
+
+sub search_metacpan {
+ my($self, $module, $version, $dev_release) = @_;
+
+ require Menlo::Index::MetaCPAN;
+ $self->chat("Searching $module ($version) on metacpan ...\n");
+
+ my $index = Menlo::Index::MetaCPAN->new({ include_dev => $self->{dev_release} });
+ my $pkg = $self->search_common($index, { package => $module, version_range => $version }, $version);
+ return $pkg if $pkg;
+
+ $self->diag_fail("Finding $module ($version) on metacpan failed.");
+ return;
+}
+
+sub search_database {
+ my($self, $module, $version) = @_;
+
+ my $found;
+
+ if ($self->{dev_release} or $self->{metacpan}) {
+ $found = $self->search_metacpan($module, $version, $self->{dev_release}) and return $found;
+ $found = $self->search_cpanmetadb($module, $version, $self->{dev_release}) and return $found;
+ } else {
+ $found = $self->search_cpanmetadb($module, $version) and return $found;
+ $found = $self->search_metacpan($module, $version) and return $found;
+ }
+}
+
+sub search_cpanmetadb {
+ my($self, $module, $version, $dev_release) = @_;
+
+ require Menlo::Index::MetaDB;
+ $self->chat("Searching $module ($version) on cpanmetadb ...\n");
+
+ my $args = { package => $module };
+ if ($self->with_version_range($version)) {
+ $args->{version_range} = $version;
+ }
+
+ my $index = Menlo::Index::MetaDB->new({ uri => $self->{cpanmetadb} });
+ my $pkg = $self->search_common($index, $args, $version);
+ return $pkg if $pkg;
+
+ $self->diag_fail("Finding $module on cpanmetadb failed.");
+ return;
+}
+
+sub search_module {
+ my($self, $module, $version) = @_;
+
+ if ($self->{mirror_index}) {
+ $self->mask_output( chat => "Searching $module on mirror index $self->{mirror_index} ...\n" );
+ my $pkg = $self->search_mirror_index_local($self->{mirror_index}, $module, $version);
+ return $pkg if $pkg;
+
+ unless ($self->{cascade_search}) {
+ $self->mask_output( diag_fail => "Finding $module ($version) on mirror index $self->{mirror_index} failed." );
+ return;
+ }
+ }
+
+ unless ($self->{mirror_only}) {
+ my $found = $self->search_database($module, $version);
+ return $found if $found;
+ }
+
+ MIRROR: for my $mirror (@{ $self->{mirrors} }) {
+ $self->mask_output( chat => "Searching $module on mirror $mirror ...\n" );
+
+ my $pkg = $self->search_mirror_index($mirror, $module, $version);
+ return $pkg if $pkg;
+
+ $self->mask_output( diag_fail => "Finding $module ($version) 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 {
+ my $self = shift;
+
+ print "cpanm ($self->{name}) version $VERSION ($0)\n";
+ print "perl version $] ($^X)\n\n";
+
+ print " \%Config:\n";
+ for my $key (qw( archname installsitelib installsitebin installman1dir installman3dir
+ sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp )) {
+ print " $key=$Config{$key}\n" if $Config{$key};
+ }
+
+ print " \%ENV:\n";
+ for my $key (grep /^PERL/, sort keys %ENV) {
+ print " $key=$ENV{$key}\n";
+ }
+
+ print " \@INC:\n";
+ for my $inc (@INC) {
+ print " $inc\n" unless ref($inc) eq 'CODE';
+ }
+
+ return 1;
+}
+
+sub show_help {
+ my $self = shift;
+
+ if ($_[0]) {
+ print <<USAGE;
+Usage: cpanm [options] Module [...]
+
+Try `cpanm --help` or `man cpanm` for more options.
+USAGE
+ return;
+ }
+
+ print <<HELP;
+Usage: cpanm [options] Module [...]
+
+Options:
+ -v,--verbose Turns on chatty output
+ -q,--quiet Turns off the most output
+ --interactive Turns on interactive configure (required for Task:: modules)
+ -f,--force force install
+ -n,--notest Do not run unit tests
+ --test-only Run tests only, do not install
+ -S,--sudo sudo to run install commands
+ --installdeps Only install dependencies
+ --showdeps Only display direct dependencies
+ --reinstall Reinstall the distribution even if you already have the latest version installed
+ --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
+ --mirror-only Use the mirror's index file instead of the CPAN Meta DB
+ -M,--from Use only this mirror base URL and its index file
+ --prompt Prompt when configure/build/test fails
+ -l,--local-lib Specify the install base to install modules
+ -L,--local-lib-contained Specify the install base to install all non-core modules
+ --self-contained Install all non-core modules, even if they're already installed.
+ --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7
+
+Commands:
+ --self-upgrade upgrades itself
+ --info Displays distribution info on CPAN
+ --look Opens the distribution with your SHELL
+ -U,--uninstall Uninstalls the modules (EXPERIMENTAL)
+ -V,--version Displays software version
+
+Examples:
+
+ cpanm Test::More # install Test::More
+ cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
+ cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
+ cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
+ cpanm --interactive Task::Kensho # Configure interactively
+ cpanm . # install from local directory
+ cpanm --installdeps . # install all the deps for the current directory
+ cpanm -L extlib Plack # install Plack and all non-core deps into extlib
+ cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
+ cpanm -M https://cpan.metacpan.org App::perlbrew # use only this secure mirror and its index
+
+You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
+
+ export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
+
+Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
+
+HELP
+
+ return 1;
+}
+
+sub _writable {
+ my $dir = shift;
+ my @dir = File::Spec->splitdir($dir);
+ while (@dir) {
+ $dir = File::Spec->catdir(@dir);
+ if (-e $dir) {
+ return -w _;
+ }
+ pop @dir;
+ }
+
+ return;
+}
+
+sub maybe_abs {
+ my($self, $lib) = @_;
+ if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) {
+ return $lib;
+ } else {
+ return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib));
+ }
+}
+
+sub local_lib_target {
+ my($self, $root) = @_;
+ # local::lib 1.008025 changed the order of PERL_LOCAL_LIB_ROOT
+ (grep { $_ ne '' } split /\Q$Config{path_sep}/, $root)[0];
+}
+
+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});
+ }
+
+ # PERL_LOCAL_LIB_ROOT is defined. Run as local::lib mode without overwriting ENV
+ if ($ENV{PERL_LOCAL_LIB_ROOT} && $ENV{PERL_MM_OPT}) {
+ return $self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}), 1);
+ }
+
+ # 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})) {
+ return;
+ }
+
+ $self->setup_local_lib;
+
+ $self->diag(<<DIAG, 1);
+!
+! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
+! To turn off this warning, you have to do one of the following:
+! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
+! - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
+! - Install local::lib by running the following commands
+!
+! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
+!
+DIAG
+ sleep 2;
+}
+
+sub upgrade_toolchain {
+ my($self, $config_deps) = @_;
+
+ my %deps = map { $_->module => $_ } @$config_deps;
+
+ # M::B 0.38 and EUMM 6.58 for MYMETA
+ # EU::Install 1.46 for local::lib
+ my $reqs = CPAN::Meta::Requirements->from_string_hash({
+ 'Module::Build' => '0.38',
+ 'ExtUtils::MakeMaker' => '6.58',
+ 'ExtUtils::Install' => '1.46',
+ });
+
+ if ($deps{"ExtUtils::MakeMaker"}) {
+ $deps{"ExtUtils::MakeMaker"}->merge_with($reqs);
+ } elsif ($deps{"Module::Build"}) {
+ $deps{"Module::Build"}->merge_with($reqs);
+ $deps{"ExtUtils::Install"} ||= Menlo::Dependency->new("ExtUtils::Install", 0, 'configure');
+ $deps{"ExtUtils::Install"}->merge_with($reqs);
+ }
+
+ @$config_deps = values %deps;
+}
+
+sub _core_only_inc {
+ my($self, $base) = @_;
+ require local::lib;
+ (
+ local::lib->resolve_path(local::lib->install_base_arch_path($base)),
+ local::lib->resolve_path(local::lib->install_base_perl_path($base)),
+ (!$self->{exclude_vendor} ? grep {$_} @Config{qw(vendorarch vendorlibexp)} : ()),
+ @Config{qw(archlibexp privlibexp)},
+ );
+}
+
+sub _setup_local_lib_env {
+ my($self, $base) = @_;
+
+ $self->diag(<<WARN, 1) if $base =~ /\s/;
+WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory.
+WARN
+
+ local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
+ local::lib->setup_env_hash_for($base, 0);
+}
+
+sub setup_local_lib {
+ my($self, $base, $no_env) = @_;
+ $base = undef if $base eq '_';
+
+ require local::lib;
+ {
+ local $0 = 'cpanm'; # so curl/wget | perl works
+ $base ||= "~/perl5";
+ $base = local::lib->resolve_path($base);
+ if ($self->{self_contained}) {
+ my @inc = $self->_core_only_inc($base);
+ $self->{search_inc} = [ @inc ];
+ } else {
+ $self->{search_inc} = [
+ local::lib->install_base_arch_path($base),
+ local::lib->install_base_perl_path($base),
+ @INC,
+ ];
+ }
+ $self->_setup_local_lib_env($base) unless $no_env;
+ $self->{local_lib} = $base;
+ }
+}
+
+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->{prompt} || (!$isa_tty && eof STDIN)) {
+ return $def;
+ }
+
+ local $|=1;
+ local $\;
+ my $ans;
+ eval {
+ local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
+ print STDOUT "$mess $dispdef";
+ alarm $self->{prompt_timeout} if $self->{prompt_timeout};
+ $ans = <STDIN>;
+ alarm 0;
+ };
+ if ( defined $ans ) {
+ chomp $ans;
+ } else { # user hit ctrl-D or alarm timeout
+ print STDOUT "\n";
+ }
+
+ return (!defined $ans || $ans eq '') ? $def : $ans;
+}
+
+sub diag_ok {
+ my($self, $msg) = @_;
+ chomp $msg;
+ $msg ||= "OK";
+ if ($self->{in_progress}) {
+ $self->_diag("$msg\n");
+ $self->{in_progress} = 0;
+ }
+ $self->log("-> $msg\n");
+}
+
+sub diag_fail {
+ my($self, $msg, $always) = @_;
+ chomp $msg;
+ if ($self->{in_progress}) {
+ $self->_diag("FAIL\n");
+ $self->{in_progress} = 0;
+ }
+
+ if ($msg) {
+ $self->_diag("! $msg\n", $always, 1);
+ $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, $msg, $always, $error) = @_;
+ my $fh = $error ? *STDERR : *STDOUT;
+ print {$fh} $msg if $always or $self->{verbose} or !$self->{quiet};
+}
+
+sub diag {
+ my($self, $msg, $always) = @_;
+ $self->_diag($msg, $always);
+ $self->log($msg);
+}
+
+sub chat {
+ my $self = shift;
+ print STDERR @_ if $self->{verbose};
+ $self->log(@_);
+}
+
+sub mask_output {
+ my $self = shift;
+ my $method = shift;
+ $self->$method( $self->mask_uri_passwords(@_) );
+}
+
+sub log {
+ my $self = shift;
+ open my $out, ">>$self->{log}";
+ print $out @_;
+}
+
+sub run_command {
+ my($self, $cmd) = @_;
+
+ # TODO move to a more appropriate runner method
+ if (ref $cmd eq 'CODE') {
+ if ($self->{verbose}) {
+ return $cmd->();
+ } else {
+ require Capture::Tiny;
+ open my $logfh, ">>", $self->{log};
+ my $ret;
+ Capture::Tiny::capture(sub { $ret = $cmd->() }, stdout => $logfh, stderr => $logfh);
+ return $ret;
+ }
+ }
+
+ if (WIN32) {
+ $cmd = Menlo::Util::shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
+ unless ($self->{verbose}) {
+ $cmd .= " >> " . Menlo::Util::shell_quote($self->{log}) . " 2>&1";
+ }
+ !system $cmd;
+ } else {
+ my $pid = fork;
+ if ($pid) {
+ waitpid $pid, 0;
+ return !$?;
+ } else {
+ $self->run_exec($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 .= " >> " . Menlo::Util::shell_quote($self->{log}) . " 2>&1";
+ }
+ exec $cmd;
+ }
+}
+
+sub run_timeout {
+ my($self, $cmd, $timeout) = @_;
+
+ return $self->run_command($cmd) if ref($cmd) eq 'CODE' || 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_command($cmd);
+ }
+}
+
+sub append_args {
+ my($self, $cmd, $phase) = @_;
+
+ return $cmd if ref $cmd ne 'ARRAY';
+
+ if (my $args = $self->{build_args}{$phase}) {
+ $cmd = join ' ', Menlo::Util::shell_quote(@$cmd), $args;
+ }
+
+ $cmd;
+}
+
+sub _use_unsafe_inc {
+ my($self, $dist) = @_;
+
+ # if it's set in the env (i.e. user's shell), just use that
+ if (exists $ENV{PERL_USE_UNSAFE_INC}) {
+ return $ENV{PERL_USE_UNSAFE_INC};
+ }
+
+ # it's set in CPAN Meta, prefer what the author says
+ if (exists $dist->{meta}{x_use_unsafe_inc}) {
+ $self->chat("Distribution opts in x_use_unsafe_inc: $dist->{meta}{x_use_unsafe_inc}\n");
+ return $dist->{meta}{x_use_unsafe_inc};
+ }
+
+ # otherwise set to 1 as a default to allow for old modules
+ return 1;
+}
+
+sub configure {
+ my($self, $cmd, $dist, $depth) = @_;
+
+ # 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 $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT};
+ local $ENV{PERL_MB_OPT} = $ENV{PERL_MB_OPT};
+
+ # skip man page generation
+ unless ($self->{pod2man}) {
+ $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";
+ $ENV{PERL_MB_OPT} .= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir=";
+ }
+
+ # Lancaster Consensus
+ if ($self->{pure_perl}) {
+ $ENV{PERL_MM_OPT} .= " PUREPERL_ONLY=1";
+ $ENV{PERL_MB_OPT} .= " --pureperl-only";
+ }
+
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
+
+ $cmd = $self->append_args($cmd, 'configure') if $depth == 0;
+
+ local $self->{verbose} = $self->{verbose} || $self->{interactive};
+ $self->run_timeout($cmd, $self->{configure_timeout});
+}
+
+sub build {
+ my($self, $cmd, $distname, $dist, $depth) = @_;
+
+ local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
+
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
+
+ $cmd = $self->append_args($cmd, 'build') if $depth == 0;
+
+ 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, e)xamine build log, or l)ook ?", "s");
+ return if $ans eq 's';
+ return $self->build($cmd, $distname, $dist, $depth) if $ans eq 'r';
+ $self->show_build_log if $ans eq 'e';
+ $self->look if $ans eq 'l';
+ }
+}
+
+sub test {
+ my($self, $cmd, $distname, $dist, $depth) = @_;
+ return 1 if $self->{notest};
+
+ # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
+ local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
+
+ # https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
+ local $ENV{NONINTERACTIVE_TESTING} = !$self->{interactive};
+
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
+
+ $cmd = $self->append_args($cmd, 'test') if $depth == 0;
+
+ 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, e)xamine build log, or l)ook ?", "s");
+ return if $ans eq 's';
+ return $self->test($cmd, $distname, $dist, $depth) if $ans eq 'r';
+ return 1 if $ans eq 'f';
+ $self->show_build_log if $ans eq 'e';
+ $self->look if $ans eq 'l';
+ }
+ }
+}
+
+sub install {
+ my($self, $cmd, $uninst_opts, $dist, $depth) = @_;
+
+ if ($depth == 0 && $self->{test_only}) {
+ return 1;
+ }
+
+ return $self->run_command($cmd) if ref $cmd eq 'CODE';
+
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
+
+ if ($self->{sudo}) {
+ unshift @$cmd, "sudo";
+ }
+
+ if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
+ push @$cmd, @$uninst_opts;
+ }
+
+ $cmd = $self->append_args($cmd, 'install') if $depth == 0;
+
+ $self->run_command($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 show_build_log {
+ my $self = shift;
+
+ my @pagers = (
+ $ENV{PAGER},
+ (WIN32 ? () : ('less')),
+ 'more'
+ );
+ my $pager;
+ while (@pagers) {
+ $pager = shift @pagers;
+ next unless $pager;
+ $pager = which($pager);
+ next unless $pager;
+ last;
+ }
+
+ if ($pager) {
+ if (WIN32) {
+ system "@{[ qs $pager ]} < @{[ qs $self->{log}]}";
+ } else {
+ system $pager, $self->{log};
+ }
+ }
+ else {
+ $self->diag_fail("You don't seem to have a PAGER :/");
+ }
+}
+
+sub chdir {
+ my $self = shift;
+ Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
+}
+
+sub configure_mirrors {
+ my $self = shift;
+ unless (@{$self->{mirrors}}) {
+ $self->{mirrors} = [ 'http://www.cpan.org' ];
+ }
+ for (@{$self->{mirrors}}) {
+ s!^/!file:///!;
+ s!/$!!;
+ }
+}
+
+sub self_upgrade {
+ my $self = shift;
+ $self->check_upgrade;
+ $self->{argv} = [ 'Menlo' ];
+ return; # continue
+}
+
+sub install_module {
+ my($self, $module, $depth, $version, $dep) = @_;
+
+ $self->check_libs;
+
+ if ($self->{seen}{$module}++) {
+ # TODO: circular dependencies
+ $self->chat("Already tried $module. Skipping.\n");
+ return 1;
+ }
+
+ if ($self->{skip_satisfied}) {
+ my($ok, $local) = $self->check_module($module, $version || 0);
+ if ($ok) {
+ $self->diag("You have $module ($local)\n", 1);
+ return 1;
+ }
+ }
+
+ my $dist = $self->resolve_name($module, $version, $dep);
+ unless ($dist) {
+ my $what = $module . ($version ? " ($version)" : "");
+ $self->diag_fail("Couldn't find module or a distribution $what", 1);
+ return;
+ }
+
+ if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
+ $self->chat("Already tried $dist->{distvname}. Skipping.\n");
+ return 1;
+ }
+
+ if ($self->{cmd} eq 'info') {
+ print $self->format_dist($dist), "\n";
+ return 1;
+ }
+
+ $dist->{depth} = $depth; # ugly hack
+
+ if ($dist->{module}) {
+ unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) {
+ $self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n", 1);
+ return;
+ }
+
+ # If a version is requested, it has to be the exact same version, otherwise, check as if
+ # it is the minimum version you need.
+ my $cmp = $version ? "==" : "";
+ my $requirement = $dist->{module_version} ? "$cmp$dist->{module_version}" : 0;
+ my($ok, $local) = $self->check_module($dist->{module}, $requirement);
+ if ($self->{skip_installed} && $ok) {
+ $self->diag("$dist->{module} is up to date. ($local)\n", 1);
+ 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}", 1);
+ 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 uninstall_search_path {
+ my $self = shift;
+
+ $self->{local_lib}
+ ? (local::lib->install_base_arch_path($self->{local_lib}),
+ local::lib->install_base_perl_path($self->{local_lib}))
+ : @Config{qw(installsitearch installsitelib)};
+}
+
+sub uninstall_module {
+ my ($self, $module) = @_;
+
+ $self->check_libs;
+
+ my @inc = $self->uninstall_search_path;
+
+ my($metadata, $packlist) = $self->packlists_containing($module, \@inc);
+ unless ($packlist) {
+ $self->diag_fail(<<DIAG, 1);
+$module is not found in the following directories and can't be uninstalled.
+
+@{[ join(" \n", map " $_", @inc) ]}
+
+DIAG
+ return;
+ }
+
+ my @uninst_files = $self->uninstall_target($metadata, $packlist);
+
+ $self->ask_permission($module, \@uninst_files) or return;
+ $self->uninstall_files(@uninst_files, $packlist);
+
+ $self->diag("Successfully uninstalled $module\n", 1);
+
+ return 1;
+}
+
+sub packlists_containing {
+ my($self, $module, $inc) = @_;
+
+ require Module::Metadata;
+ my $metadata = Module::Metadata->new_from_module($module, inc => $inc)
+ or return;
+
+ my $packlist;
+ my $wanted = sub {
+ return unless $_ eq '.packlist' && -f $_;
+ for my $file ($self->unpack_packlist($File::Find::name)) {
+ $packlist ||= $File::Find::name if $file eq $metadata->filename;
+ }
+ };
+
+ {
+ require File::pushd;
+ my $pushd = File::pushd::pushd();
+ my @search = grep -d $_, map File::Spec->catdir($_, 'auto'), @$inc;
+ File::Find::find($wanted, @search);
+ }
+
+ return $metadata, $packlist;
+}
+
+sub uninstall_target {
+ my($self, $metadata, $packlist) = @_;
+
+ # If the module has a shadow install, or uses local::lib, then you can't just remove
+ # all files in .packlist since it might have shadows in there
+ if ($self->has_shadow_install($metadata) or $self->{local_lib}) {
+ grep $self->should_unlink($_), $self->unpack_packlist($packlist);
+ } else {
+ $self->unpack_packlist($packlist);
+ }
+}
+
+sub has_shadow_install {
+ my($self, $metadata) = @_;
+
+ # check if you have the module in site_perl *and* perl
+ my @shadow = grep defined, map Module::Metadata->new_from_module($metadata->name, inc => [$_]), @INC;
+ @shadow >= 2;
+}
+
+sub should_unlink {
+ my($self, $file) = @_;
+
+ # If local::lib is used, everything under the directory can be safely removed
+ # Otherwise, bin and man files might be shared with the shadows i.e. site_perl vs perl
+ # This is not 100% safe to keep the script there hoping to work with older version of .pm
+ # files in the shadow, but there's nothing you can do about it.
+ if ($self->{local_lib}) {
+ $file =~ /^\Q$self->{local_lib}\E/;
+ } else {
+ !(grep $file =~ /^\Q$_\E/, @Config{qw(installbin installscript installman1dir installman3dir)});
+ }
+}
+
+sub ask_permission {
+ my ($self, $module, $files) = @_;
+
+ $self->diag("$module contains the following files:\n\n");
+ for my $file (@$files) {
+ $self->diag(" $file\n");
+ }
+ $self->diag("\n");
+
+ return 'force uninstall' if $self->{force};
+ local $self->{prompt} = 1;
+ return $self->prompt_bool("Are you sure you want to uninstall $module?", 'y');
+}
+
+sub unpack_packlist {
+ my ($self, $packlist) = @_;
+ open my $fh, '<', $packlist or die "$packlist: $!";
+ map { chomp; $_ } <$fh>;
+}
+
+sub uninstall_files {
+ my ($self, @files) = @_;
+
+ $self->diag("\n");
+
+ for my $file (@files) {
+ $self->diag("Unlink: $file\n");
+ unlink $file or $self->diag_fail("$!: $file");
+ }
+
+ $self->diag("\n");
+
+ return 1;
+}
+
+sub format_dist {
+ my($self, $dist) = @_;
+
+ # TODO support --dist-format?
+ return "$dist->{cpanid}/$dist->{filename}";
+}
+
+sub trim {
+ local $_ = shift;
+ tr/\n/ /d;
+ s/^\s*|\s*$//g;
+ $_;
+}
+
+sub fetch_module {
+ my($self, $dist) = @_;
+
+ $self->chdir($self->{base});
+
+ for my $uri (@{$dist->{uris}}) {
+ $self->mask_output( 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->diag("ERROR: " . trim("$@") . "\n", 1) if $@ && $@ ne "SIGINT\n";
+ return $file;
+ };
+
+ my($try, $file);
+ while ($try++ < 3) {
+ $file = $fetch->();
+ last if $cancelled or $file;
+ $self->mask_output( diag_fail => "Download $uri failed. Retrying ... ");
+ }
+
+ if ($cancelled) {
+ $self->diag_fail("Download cancelled.");
+ return;
+ }
+
+ unless ($file) {
+ $self->mask_output( diag_fail => "Failed to download $uri");
+ next;
+ }
+
+ $self->diag_ok;
+ $dist->{local_path} = File::Spec->rel2abs($name);
+
+ my $dir = $self->unpack($file, $uri, $dist);
+ next unless $dir; # unpack failed
+
+ if (my $save = $self->{save_dists}) {
+ # Only distros retrieved from CPAN have a pathname set
+ my $path = $dist->{pathname} ? "$save/authors/id/$dist->{pathname}"
+ : "$save/vendor/$file";
+ $self->chat("Copying $name to $path\n");
+ File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777);
+ File::Copy::copy($file, $path) or warn $!;
+ }
+
+ return $dist, $dir;
+ }
+}
+
+sub unpack {
+ my($self, $file, $uri, $dist) = @_;
+
+ if ($self->{verify}) {
+ $self->verify_archive($file, $uri, $dist) or return;
+ }
+
+ $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 verify_checksums_signature {
+ my($self, $chk_file) = @_;
+
+ require Module::Signature; # no fatpack
+
+ $self->chat("Verifying the signature of CHECKSUMS\n");
+
+ my $rv = eval {
+ local $SIG{__WARN__} = sub {}; # suppress warnings
+ my $v = Module::Signature::_verify($chk_file);
+ $v == Module::Signature::SIGNATURE_OK();
+ };
+ if ($rv) {
+ $self->chat("Verified OK!\n");
+ } else {
+ $self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");
+ return;
+ }
+
+ return 1;
+}
+
+sub verify_archive {
+ my($self, $file, $uri, $dist) = @_;
+
+ unless ($dist->{cpanid}) {
+ $self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
+ return 1;
+ }
+
+ (my $mirror = $uri) =~ s!/authors/id.*$!!;
+
+ (my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!;
+ my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS";
+ $self->mask_output( diag_progress => "Fetching $chksum_uri" );
+ $self->mirror($chksum_uri, $chk_file);
+
+ unless (-e $chk_file) {
+ $self->diag_fail("Fetching $chksum_uri failed.\n");
+ return;
+ }
+
+ $self->diag_ok;
+ $self->verify_checksums_signature($chk_file) or return;
+ $self->verify_checksum($file, $chk_file);
+}
+
+sub verify_checksum {
+ my($self, $file, $chk_file) = @_;
+
+ $self->chat("Verifying the SHA1 for $file\n");
+
+ open my $fh, "<$chk_file" or die "$chk_file: $!";
+ my $data = join '', <$fh>;
+ $data =~ s/\015?\012/\n/g;
+
+ require Safe; # no fatpack
+ my $chksum = Safe->new->reval($data);
+
+ if (!ref $chksum or ref $chksum ne 'HASH') {
+ $self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");
+ return;
+ }
+
+ if (my $sha = $chksum->{$file}{sha256}) {
+ my $hex = $self->sha_for(256, $file);
+ if ($hex eq $sha) {
+ $self->chat("Checksum for $file: Verified!\n");
+ } else {
+ $self->diag_fail("Checksum mismatch for $file\n");
+ return;
+ }
+ } else {
+ $self->chat("Checksum for $file not found in CHECKSUMS.\n");
+ return;
+ }
+}
+
+sub sha_for {
+ my($self, $alg, $file) = @_;
+
+ require Digest::SHA; # no fatpack
+
+ open my $fh, "<", $file or die "$file: $!";
+ my $dg = Digest::SHA->new($alg);
+ my($data);
+ while (read($fh, $data, 4096)) {
+ $dg->add($data);
+ }
+
+ return $dg->hexdigest;
+}
+
+sub verify_signature {
+ my($self, $dist) = @_;
+
+ $self->diag_progress("Verifying the SIGNATURE file");
+ my $out = `@{[ qs $self->{cpansign} ]} -v --skip 2>&1`;
+ $self->log($out);
+
+ if ($out =~ /Signature verified OK/) {
+ $self->diag_ok("Verified OK");
+ return 1;
+ } else {
+ $self->diag_fail("SIGNATURE verification for $dist->{filename} failed\n");
+ return;
+ }
+}
+
+sub resolve_name {
+ my($self, $module, $version, $dep) = @_;
+
+ if ($dep && $dep->url) {
+ if ($dep->url =~ m!authors/id/(.*)!) {
+ return $self->cpan_dist($1, $dep->url);
+ } else {
+ return { uris => [ $dep->url ] };
+ }
+ }
+
+ if ($dep && $dep->dist) {
+ return $self->cpan_dist($dep->dist, undef, $dep->mirror);
+ }
+
+ # Git
+ if ($module =~ /(?:^git:|\.git(?:@.+)?$)/) {
+ return $self->git_uri($module);
+ }
+
+ # URL
+ if ($module =~ /^(ftp|https?|file):/) {
+ if ($module =~ m!authors/id/(.*)!) {
+ return $self->cpan_dist($1, $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
+ # P/PA/PAUSEID/foo
+ if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!) {
+ return $self->cpan_dist($1);
+ }
+
+ # Module name
+ return $self->search_module($module, $version);
+}
+
+sub cpan_module_common {
+ my($self, $match) = @_;
+
+ (my $distfile = $match->{uri}) =~ s!^cpan:///distfile/!!;
+
+ my $mirrors = $self->{mirrors};
+ if ($match->{download_uri}) {
+ (my $mirror = $match->{download_uri}) =~ s!/authors/id/.*$!!;
+ $mirrors = [$mirror];
+ }
+
+ local $self->{mirrors} = $mirrors;
+ return $self->cpan_module($match->{package}, $distfile, $match->{version});
+}
+
+sub cpan_module {
+ my($self, $module, $dist_file, $version) = @_;
+
+ my $dist = $self->cpan_dist($dist_file);
+ $dist->{module} = $module;
+ $dist->{module_version} = $version if $version && $version ne 'undef';
+
+ return $dist;
+}
+
+sub cpan_dist {
+ my($self, $dist, $url, $mirror) = @_;
+
+ # strip trailing slash
+ $mirror =~ s!/$!! if $mirror;
+
+ $dist =~ s!^([A-Z]{2})!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 = $mirror ? ($mirror) : @{$self->{mirrors}};
+ my @urls = map "$_/authors/id/$fn", @mirrors;
+
+ $url = \@urls,
+ }
+
+ return {
+ $d->properties,
+ source => 'cpan',
+ uris => $url,
+ };
+}
+
+sub git_uri {
+ my ($self, $uri) = @_;
+
+ # similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support
+ # git URL has to end with .git when you need to use pin @ commit/tag/branch
+
+ ($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2;
+
+ my $dir = File::Temp::tempdir(CLEANUP => 1);
+
+ $self->mask_output( diag_progress => "Cloning $uri" );
+ $self->run_command([ 'git', 'clone', $uri, $dir ]);
+
+ unless (-e "$dir/.git") {
+ $self->diag_fail("Failed cloning git repository $uri", 1);
+ return;
+ }
+
+ if ($commitish) {
+ require File::pushd;
+ my $dir = File::pushd::pushd($dir);
+
+ unless ($self->run_command([ 'git', 'checkout', $commitish ])) {
+ $self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");
+ return;
+ }
+ }
+
+ $self->diag_ok;
+
+ return {
+ source => 'local',
+ dir => $dir,
+ };
+}
+
+sub core_version_for {
+ my($self, $module) = @_;
+
+ require Module::CoreList; # no fatpack
+ unless (exists $Module::CoreList::version{$]+0}) {
+ die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " .
+ "You're strongly recommended to upgrade Module::CoreList from CPAN.\n",
+ $Module::CoreList::VERSION, $INC{"Module/CoreList.pm"});
+ }
+
+ unless (exists $Module::CoreList::version{$]+0}{$module}) {
+ return -1;
+ }
+
+ return $Module::CoreList::version{$]+0}{$module};
+}
+
+sub search_inc {
+ my $self = shift;
+ $self->{search_inc} ||= do {
+ # strip lib/ and fatlib/ from search path when booted from dev
+ if (defined $::Bin) {
+ [grep !/^\Q$::Bin\E\/..\/(?:fat)?lib$/, @INC]
+ } else {
+ [@INC]
+ }
+ };
+}
+
+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 (or actually wasn't core at) the version
+ # that is shipped with the current perl
+ if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) {
+ $version = $self->core_version_for($mod);
+ return 0, undef if $version && $version == -1;
+ }
+
+ $self->{local_versions}{$mod} = $version;
+
+ if ($self->is_deprecated($meta)){
+ return 0, $version;
+ } elsif ($self->satisfy_version($mod, $version, $want_ver)) {
+ return 1, ($version || 'undef');
+ } else {
+ return 0, $version;
+ }
+}
+
+sub satisfy_version {
+ my($self, $mod, $version, $want_ver) = @_;
+
+ $want_ver = '0' unless defined($want_ver) && length($want_ver);
+
+ require CPAN::Meta::Requirements;
+ my $requirements = CPAN::Meta::Requirements->new;
+ $requirements->add_string_requirement($mod, $want_ver);
+ $requirements->accepts_module($mod, $version);
+}
+
+sub unsatisfy_how {
+ my($self, $ver, $want_ver) = @_;
+
+ if ($want_ver =~ /^[v0-9\.\_]+$/) {
+ return "$ver < $want_ver";
+ } else {
+ return "$ver doesn't satisfy $want_ver";
+ }
+}
+
+sub is_deprecated {
+ my($self, $meta) = @_;
+
+ my $deprecated = eval {
+ require Module::CoreList; # no fatpack
+ Module::CoreList::is_deprecated($meta->{module});
+ };
+
+ return $deprecated && $self->loaded_from_perl_lib($meta);
+}
+
+sub loaded_from_perl_lib {
+ my($self, $meta) = @_;
+
+ require Config;
+ my @dirs = qw(archlibexp privlibexp);
+ if ($self->{self_contained} && ! $self->{exclude_vendor} && $Config{vendorarch}) {
+ unshift @dirs, qw(vendorarch vendorlibexp);
+ }
+ for my $dir (@dirs) {
+ 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 (" . $self->unsatisfy_how($local, $ver) . ")\n") }
+ else { $self->chat("No\n") }
+
+ return $mod unless $ok;
+ return;
+}
+
+sub check_perl_version {
+ my($self, $version) = @_;
+ require CPAN::Meta::Requirements;
+ my $req = CPAN::Meta::Requirements->from_string_hash({ perl => $version });
+ $req->accepts_module(perl => $]);
+}
+
+sub install_deps {
+ my($self, $dir, $depth, @deps) = @_;
+
+ my(@install, %seen, @fail);
+ for my $dep (@deps) {
+ next if $seen{$dep->module};
+ if ($dep->module eq 'perl') {
+ if ($dep->is_requirement && !$self->check_perl_version($dep->version)) {
+ $self->diag("Needs perl @{[$dep->version]}, you have $]\n");
+ push @fail, 'perl';
+ }
+ } elsif ($self->should_install($dep->module, $dep->version)) {
+ push @install, $dep;
+ $seen{$dep->module} = 1;
+ }
+ }
+
+ if (@install) {
+ $self->diag("==> Found dependencies: " . join(", ", map $_->module, @install) . "\n");
+ }
+
+ for my $dep (@install) {
+ $self->install_module($dep->module, $depth + 1, $dep->version, $dep);
+ }
+
+ $self->chdir($self->{base});
+ $self->chdir($dir) if $dir;
+
+ if ($self->{scandeps}) {
+ return 1; # Don't check if dependencies are installed, since with --scandeps they aren't
+ }
+ my @not_ok = $self->unsatisfied_deps(@deps);
+ if (@not_ok) {
+ return 0, \@not_ok;
+ } else {
+ return 1;
+ }
+}
+
+sub unsatisfied_deps {
+ my($self, @deps) = @_;
+
+ require CPAN::Meta::Check;
+ require CPAN::Meta::Requirements;
+
+ my $reqs = CPAN::Meta::Requirements->new;
+ for my $dep (grep $_->is_requirement, @deps) {
+ $reqs->add_string_requirement($dep->module => $dep->requires_version || '0');
+ }
+
+ my $ret = CPAN::Meta::Check::check_requirements($reqs, 'requires', $self->{search_inc});
+ grep defined, values %$ret;
+}
+
+sub install_deps_bailout {
+ my($self, $target, $dir, $depth, @deps) = @_;
+
+ my($ok, $fail) = $self->install_deps($dir, $depth, @deps);
+ if (!$ok) {
+ $self->diag_fail("Installing the dependencies failed: " . join(", ", @$fail), 1);
+ unless ($self->prompt_bool("Do you want to continue building $target anyway?", "n")) {
+ $self->diag_fail("Bailing out the installation for $target.", 1);
+ return;
+ }
+ }
+
+ return 1;
+}
+
+sub build_stuff {
+ my($self, $stuff, $dist, $depth) = @_;
+
+ if ($self->{verify} && -e 'SIGNATURE') {
+ $self->verify_signature($dist) or return;
+ }
+
+ require CPAN::Meta;
+
+ my($meta_file) = grep -f, qw(META.json META.yml);
+ if ($meta_file) {
+ $self->chat("Checking configure dependencies from $meta_file\n");
+ $dist->{cpanmeta} = eval { CPAN::Meta->load_file($meta_file) };
+ } elsif ($dist->{dist} && $dist->{version}) {
+ $self->chat("META.yml/json not found. Creating skeleton for it.\n");
+ $dist->{cpanmeta} = CPAN::Meta->new({ name => $dist->{dist}, version => $dist->{version} });
+ }
+
+ $dist->{meta} = $dist->{cpanmeta} ? $dist->{cpanmeta}->as_struct : {};
+
+ if ($self->opts_in_static_install($dist->{cpanmeta})) {
+ $dist->{static_install} = 1;
+ }
+
+ my @config_deps;
+
+ if ($dist->{cpanmeta}) {
+ push @config_deps, Menlo::Dependency->from_prereqs(
+ $dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
+ );
+ }
+
+ if (-e 'Build.PL' && !@config_deps) {
+ push @config_deps, Menlo::Dependency->from_versions(
+ { 'Module::Build' => '0.38' }, 'configure',
+ );
+ }
+
+ $self->merge_with_cpanfile($dist, \@config_deps);
+
+ $self->upgrade_toolchain(\@config_deps);
+
+ my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
+
+ unless ($self->skip_configure($dist, $depth)) {
+ $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
+ or return;
+ }
+
+ $self->diag_progress("Configuring $target");
+
+ my $configure_state = $self->configure_this($dist, $depth);
+ $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
+
+ if ($dist->{cpanmeta} && $dist->{source} eq 'cpan') {
+ $dist->{provides} = $dist->{cpanmeta}{provides} || $self->extract_packages($dist->{cpanmeta}, ".");
+ }
+
+ # install direct 'test' dependencies for --installdeps, even with --notest
+ # TODO: remove build dependencies for static install
+ my $deps_only = $self->deps_only($depth);
+ $dist->{want_phases} = $self->{notest} && !$self->deps_only($depth)
+ ? [qw( build runtime )] : [qw( build test runtime )];
+
+ push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0;
+ push @{$dist->{want_phases}}, 'configure' if $self->{with_configure} && $depth == 0;
+
+ my @deps = $self->find_prereqs($dist);
+ my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
+ $module_name =~ s/-/::/g;
+
+ if ($self->{showdeps}) {
+ for my $dep (@config_deps, @deps) {
+ print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n";
+ }
+ return 1;
+ }
+
+ my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
+
+ my $walkup;
+ if ($self->{scandeps}) {
+ $walkup = $self->scandeps_append_child($dist);
+ }
+
+ $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
+ or return;
+
+ if ($self->{scandeps}) {
+ unless ($configure_state->{configured_ok}) {
+ my $diag = <<DIAG;
+! Configuring $distname failed. See $self->{log} for details.
+! You might have to install the following modules first to get --scandeps working correctly.
+DIAG
+ if (@config_deps) {
+ my @tree = @{$self->{scandeps_tree}};
+ $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree;
+ }
+ $self->diag("!\n$diag!\n", 1);
+ }
+ $walkup->();
+ return 1;
+ }
+
+ if ($self->{installdeps} && $depth == 0) {
+ if ($configure_state->{configured_ok}) {
+ $self->diag("<== Installed dependencies for $stuff. Finishing.\n");
+ return 1;
+ } else {
+ $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1);
+ return;
+ }
+ }
+
+ my $installed;
+ if ($configure_state->{static_install}) {
+ $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
+ $self->build(sub { $configure_state->{static_install}->build }, $distname, $dist, $depth) &&
+ $self->test(sub { $configure_state->{static_install}->build("test") }, $distname, $dist, $depth) &&
+ $self->install(sub { $configure_state->{static_install}->build("install") }, [], $dist, $depth) &&
+ $installed++;
+ } elsif ($configure_state->{use_module_build} && -e 'Build' && -f _) {
+ $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
+ $self->build([ $self->{perl}, "./Build" ], $distname, $dist, $depth) &&
+ $self->test([ $self->{perl}, "./Build", "test" ], $distname, $dist, $depth) &&
+ $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $dist, $depth) &&
+ $installed++;
+ } elsif ($self->{make} && -e 'Makefile') {
+ $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
+ $self->build([ $self->{make} ], $distname, $dist, $depth) &&
+ $self->test([ $self->{make}, "test" ], $distname, $dist, $depth) &&
+ $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $dist, $depth) &&
+ $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.", 1);
+ return;
+ }
+
+ if ($installed && $self->{test_only}) {
+ $self->diag_ok;
+ $self->diag("Successfully tested $distname\n", 1);
+ } elsif ($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 $action = $local && !$reinstall
+ ? $self->is_downgrade($version, $local)
+ ? "downgraded"
+ : "upgraded"
+ : undef;
+
+ my $how = $reinstall ? "reinstalled $distname"
+ : $local ? "installed $distname ($action from $local)"
+ : "installed $distname" ;
+ my $msg = "Successfully $how";
+ $self->diag_ok;
+ $self->diag("$msg\n", 1);
+ $self->{installed_dists}++;
+ $self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps);
+ return 1;
+ } else {
+ my $what = $self->{test_only} ? "Testing" : "Installing";
+ $self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.", 1);
+ return;
+ }
+}
+
+sub is_downgrade {
+ my($self, $va, $vb) = @_;
+ eval { version::->new($va) < $vb };
+}
+
+sub opts_in_static_install {
+ my($self, $meta) = @_;
+
+ return if !$self->{static_install};
+
+ # --sudo requires running a separate shell to prevent persistent configuration
+ # uninstall-shadows (default on < 5.12) is not supported in BuildPL spec, yet.
+ return if $self->{sudo} or $self->{uninstall_shadows};
+
+ return $meta->{x_static_install} && $meta->{x_static_install} == 1;
+}
+
+sub skip_configure {
+ my($self, $dist, $depth) = @_;
+
+ return 1 if $self->{skip_configure};
+ return 1 if $dist->{static_install};
+ return 1 if $self->no_dynamic_config($dist->{meta}) && $self->deps_only($depth);
+
+ return;
+}
+
+sub no_dynamic_config {
+ my($self, $meta) = @_;
+ exists $meta->{dynamic_config} && $meta->{dynamic_config} == 0;
+}
+
+sub deps_only {
+ my($self, $depth) = @_;
+ ($self->{installdeps} && $depth == 0)
+ or $self->{showdeps}
+ or $self->{scandeps};
+}
+
+sub perl_requirements {
+ my($self, @requires) = @_;
+
+ my @perl;
+ for my $requires (grep defined, @requires) {
+ if (exists $requires->{perl}) {
+ push @perl, Menlo::Dependency->new(perl => $requires->{perl});
+ }
+ }
+
+ return @perl;
+}
+
+sub configure_this {
+ my($self, $dist, $depth) = @_;
+
+ my $deps_only = $self->deps_only($depth);
+ if (-e $self->{cpanfile_path} && $deps_only) {
+ require Module::CPANfile;
+ $dist->{cpanfile} = eval { Module::CPANfile->load($self->{cpanfile_path}) };
+ $self->diag_fail($@, 1) if $@;
+
+ $self->{cpanfile_global} ||= $dist->{cpanfile};
+
+ return {
+ configured => 1,
+ configured_ok => !!$dist->{cpanfile},
+ use_module_build => 0,
+ };
+ }
+
+ if ($self->{skip_configure}) {
+ my $eumm = -e 'Makefile';
+ my $mb = -e 'Build' && -f _;
+ return {
+ configured => 1,
+ configured_ok => $eumm || $mb,
+ use_module_build => $mb,
+ };
+ }
+
+ if ($deps_only && $self->no_dynamic_config($dist->{meta})) {
+ return {
+ configured => 1,
+ configured_ok => exists $dist->{meta}{prereqs},
+ use_module_build => 0,
+ };
+ }
+
+ my $state = {};
+
+ my $try_static = sub {
+ if ($dist->{static_install}) {
+ $self->chat("Distribution opts in x_static_install: $dist->{meta}{x_static_install}\n");
+ $self->static_install_configure($state, $dist, $depth);
+ }
+ };
+
+ my $try_eumm = sub {
+ if (-e 'Makefile.PL') {
+ $self->chat("Running Makefile.PL\n");
+
+ # NOTE: according to Devel::CheckLib, most XS modules exit
+ # with 0 even if header files are missing, to avoid receiving
+ # tons of FAIL reports in such cases. So exit code can't be
+ # trusted if it went well.
+ if ($self->configure([ $self->{perl}, "Makefile.PL" ], $dist, $depth)) {
+ $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}, "Build.PL" ], $dist, $depth)) {
+ $state->{configured_ok} = -e 'Build' && -f _;
+ }
+ $state->{use_module_build}++;
+ $state->{configured}++;
+ }
+ };
+
+ for my $try ($try_static, $try_mb, $try_eumm) {
+ $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, e)xamine build log, or l)ook ?", "s");
+ last if $ans eq 's';
+ return $self->configure_this($dist, $depth) if $ans eq 'r';
+ $self->show_build_log if $ans eq 'e';
+ $self->look if $ans eq 'l';
+ }
+ }
+
+ return $state;
+}
+
+sub static_install_configure {
+ my($self, $state, $dist, $depth) = @_;
+
+ my $args = $depth == 0 ? $self->{build_args}{configure} : [];
+
+ require Menlo::Builder::Static;
+ my $builder = Menlo::Builder::Static->new(meta => $dist->{cpanmeta});
+ $self->configure(sub { $builder->configure($args || []) }, $dist, $depth);
+
+ $state->{configured_ok} = 1;
+ $state->{static_install} = $builder;
+ $state->{configured}++;
+}
+
+sub find_module_name {
+ my($self, $state) = @_;
+
+ return unless $state->{configured_ok};
+
+ if ($state->{use_module_build} &&
+ -e "_build/build_params") {
+ my $params = do { open my $in, "_build/build_params"; eval(join "", <$in>) };
+ return eval { $params->[2]{module_name} } || undef;
+ } elsif (-e "Makefile") {
+ open my $mf, "Makefile";
+ while (<$mf>) {
+ if (/^\#\s+NAME\s+=>\s+(.*)/) {
+ return eval($1);
+ }
+ }
+ }
+
+ return;
+}
+
+sub list_files {
+ my $self = shift;
+
+ if (-e 'MANIFEST') {
+ require ExtUtils::Manifest;
+ my $manifest = eval { ExtUtils::Manifest::manifind() } || {};
+ return sort { lc $a cmp lc $b } keys %$manifest;
+ } else {
+ require File::Find;
+ my @files;
+ my $finder = sub {
+ my $name = $File::Find::name;
+ $name =~ s!\.[/\\]!!;
+ push @files, $name;
+ };
+ File::Find::find($finder, ".");
+ return sort { lc $a cmp lc $b } @files;
+ }
+}
+
+sub extract_packages {
+ my($self, $meta, $dir) = @_;
+
+ my $try = sub {
+ my $file = shift;
+ return 0 if $file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;
+ return 1 unless $meta->{no_index};
+ return 0 if grep { $file =~ m!^$_/! } @{$meta->{no_index}{directory} || []};
+ return 0 if grep { $file eq $_ } @{$meta->{no_index}{file} || []};
+ return 1;
+ };
+
+ require Parse::PMFile;
+
+ my @files = grep { /\.pm(?:\.PL)?$/ && $try->($_) } $self->list_files;
+
+ my $provides = { };
+
+ for my $file (@files) {
+ my $parser = Parse::PMFile->new($meta, { UNSAFE => 1, ALLOW_DEV_VERSION => 1 });
+ my $packages = $parser->parse($file);
+
+ while (my($package, $meta) = each %$packages) {
+ $provides->{$package} ||= {
+ file => $meta->{infile},
+ ($meta->{version} eq 'undef') ? () : (version => $meta->{version}),
+ };
+ }
+ }
+
+ return $provides;
+}
+
+sub save_meta {
+ my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;
+
+ return unless $dist->{distvname} && $dist->{source} eq 'cpan';
+
+ my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
+ ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};
+
+ my $provides = $dist->{provides};
+
+ File::Path::mkpath("blib/meta", 0, 0777);
+
+ my $local = {
+ name => $module_name,
+ target => $module,
+ version => exists $provides->{$module_name}
+ ? ($provides->{$module_name}{version} || $dist->{version}) : $dist->{version},
+ dist => $dist->{distvname},
+ pathname => $dist->{pathname},
+ provides => $provides,
+ };
+
+ require JSON::PP;
+ open my $fh, ">", "blib/meta/install.json" or die $!;
+ print $fh JSON::PP::encode_json($local);
+
+ File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json");
+
+ my @cmd = (
+ ($self->{sudo} ? 'sudo' : ()),
+ $^X,
+ '-MExtUtils::Install=install',
+ '-e',
+ qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
+ );
+ $self->run_command(\@cmd);
+}
+
+sub install_base {
+ my($self, $mm_opt) = @_;
+ $mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;
+ die "Your PERL_MM_OPT doesn't contain INSTALL_BASE";
+}
+
+sub configure_features {
+ my($self, $dist, @features) = @_;
+ map $_->identifier, grep { $self->effective_feature($dist, $_) } @features;
+}
+
+sub effective_feature {
+ my($self, $dist, $feature) = @_;
+
+ if ($dist->{depth} == 0) {
+ my $value = $self->{features}{$feature->identifier};
+ return $value if defined $value;
+ return 1 if $self->{features}{__all};
+ }
+
+ if ($self->{interactive}) {
+ require CPAN::Meta::Requirements;
+
+ $self->diag("[@{[ $feature->description ]}]\n", 1);
+
+ my $req = CPAN::Meta::Requirements->new;
+ for my $phase (@{$dist->{want_phases}}) {
+ for my $type (@{$self->{install_types}}) {
+ $req->add_requirements($feature->prereqs->requirements_for($phase, $type));
+ }
+ }
+
+ my $reqs = $req->as_string_hash;
+ my @missing;
+ for my $module (keys %$reqs) {
+ if ($self->should_install($module, $req->{$module})) {
+ push @missing, $module;
+ }
+ }
+
+ if (@missing) {
+ my $howmany = @missing;
+ $self->diag("==> Found missing dependencies: " . join(", ", @missing) . "\n", 1);
+ local $self->{prompt} = 1;
+ return $self->prompt_bool("Install the $howmany optional module(s)?", "y");
+ }
+ }
+
+ return;
+}
+
+sub find_prereqs {
+ my($self, $dist) = @_;
+
+ my @deps = $self->extract_meta_prereqs($dist);
+
+ if ($dist->{module} =~ /^Bundle::/i) {
+ push @deps, $self->bundle_deps($dist);
+ }
+
+ $self->merge_with_cpanfile($dist, \@deps);
+
+ return @deps;
+}
+
+sub merge_with_cpanfile {
+ my($self, $dist, $deps) = @_;
+
+ if ($self->{cpanfile_requirements} && !$dist->{cpanfile}) {
+ for my $dep (@$deps) {
+ $dep->merge_with($self->{cpanfile_requirements});
+ }
+ }
+
+ if ($self->{cpanfile_global}) {
+ for my $dep (@$deps) {
+ my $opts = $self->{cpanfile_global}->options_for_module($dep->module)
+ or next;
+
+ $dep->dist($opts->{dist}) if $opts->{dist};
+ $dep->mirror($opts->{mirror}) if $opts->{mirror};
+ $dep->url($opts->{url}) if $opts->{url};
+ }
+ }
+}
+
+sub extract_meta_prereqs {
+ my($self, $dist) = @_;
+
+ if ($dist->{cpanfile}) {
+ my @features = $self->configure_features($dist, $dist->{cpanfile}->features);
+ my $prereqs = $dist->{cpanfile}->prereqs_with(@features);
+ # TODO: creating requirements is useful even without cpanfile to detect conflicting prereqs
+ $self->{cpanfile_requirements} = $prereqs->merged_requirements($dist->{want_phases}, ['requires']);
+ return Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
+ }
+
+ require CPAN::Meta;
+
+ my @meta = qw(MYMETA.json MYMETA.yml);
+ if ($self->no_dynamic_config($dist->{meta})) {
+ push @meta, qw(META.json META.yml);
+ }
+
+ my @deps;
+ my($meta_file) = grep -f, @meta;
+ if ($meta_file) {
+ $self->chat("Checking dependencies from $meta_file ...\n");
+ my $mymeta = eval { CPAN::Meta->load_file($meta_file, { lazy_validation => 1 }) };
+ if ($mymeta) {
+ $dist->{meta}{name} = $mymeta->name;
+ $dist->{meta}{version} = $mymeta->version;
+ return $self->extract_prereqs($mymeta, $dist);
+ }
+ }
+
+ $self->diag_fail("No MYMETA file is found after configure. Your toolchain is too old?");
+ return;
+}
+
+sub bundle_deps {
+ my($self, $dist) = @_;
+
+ my $match;
+ if ($dist->{module}) {
+ $match = sub {
+ my $meta = Module::Metadata->new_from_file($_[0]);
+ $meta && ($meta->name eq $dist->{module});
+ };
+ } else {
+ $match = sub { 1 };
+ }
+
+ my @files;
+ File::Find::find({
+ wanted => sub {
+ push @files, File::Spec->rel2abs($_) if /\.pm$/i && $match->($_);
+ },
+ no_chdir => 1,
+ }, '.');
+
+ my @deps;
+
+ for my $file (@files) {
+ open my $pod, "<", $file or next;
+ my $in_contents;
+ while (<$pod>) {
+ if (/^=head\d\s+CONTENTS/) {
+ $in_contents = 1;
+ } elsif (/^=/) {
+ $in_contents = 0;
+ } elsif ($in_contents) {
+ /^(\S+)\s*(\S+)?/
+ and push @deps, Menlo::Dependency->new($1, $self->maybe_version($2));
+ }
+ }
+ }
+
+ return @deps;
+}
+
+sub maybe_version {
+ my($self, $string) = @_;
+ return $string && $string =~ /^\.?\d/ ? $string : undef;
+}
+
+sub extract_prereqs {
+ my($self, $meta, $dist) = @_;
+
+ my @features = $self->configure_features($dist, $meta->features);
+
+ my $prereqs = $meta->effective_prereqs(\@features)->clone;
+ $self->adjust_prereqs($dist, $prereqs);
+
+ return Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
+}
+
+sub adjust_prereqs {
+ my($self, $dist, $prereqs) = @_;
+
+ # Workaround for Module::Install 1.04 creating a bogus (higher) MakeMaker requirement that it needs in build_requires
+ # Assuming MakeMaker requirement is already satisfied in configure_requires, there's no need to have higher version of
+ # MakeMaker in build/test anyway. https://github.com/miyagawa/cpanminus/issues/463
+ if (-e "inc/Module/Install.pm") {
+ for my $phase (qw( build test runtime )) {
+ my $reqs = $prereqs->requirements_for($phase, 'requires');
+ if ($reqs->requirements_for_module('ExtUtils::MakeMaker')) {
+ $reqs->clear_requirement('ExtUtils::MakeMaker');
+ $reqs->add_minimum('ExtUtils::MakeMaker' => 0);
+ }
+ }
+ }
+
+ # Static installation is optional and we're adding runtime dependencies
+ if ($dist->{static_install}) {
+ my $reqs = $prereqs->requirements_for('test' => 'requires');
+ $reqs->add_minimum('TAP::Harness::Env' => 0);
+ }
+}
+
+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) {
+ if (@targets >= 64) {
+ $self->diag("Expiring " . scalar(@targets) . " work directories. This might take a while...\n");
+ } else {
+ $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 scandeps_append_child {
+ my($self, $dist) = @_;
+
+ my $new_node = [ $dist, [] ];
+
+ my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
+ push @{$curr_node->[1]}, $new_node;
+
+ $self->{scandeps_current} = $new_node;
+
+ return sub { $self->{scandeps_current} = $curr_node };
+}
+
+sub dump_scandeps {
+ my $self = shift;
+
+ if ($self->{format} eq 'tree') {
+ $self->walk_down(sub {
+ my($dist, $depth) = @_;
+ if ($depth == 0) {
+ print "$dist->{distvname}\n";
+ } else {
+ print " " x ($depth - 1);
+ print "\\_ $dist->{distvname}\n";
+ }
+ }, 1);
+ } elsif ($self->{format} =~ /^dists?$/) {
+ $self->walk_down(sub {
+ my($dist, $depth) = @_;
+ print $self->format_dist($dist), "\n";
+ }, 0);
+ } elsif ($self->{format} eq 'json') {
+ require JSON::PP;
+ print JSON::PP::encode_json($self->{scandeps_tree});
+ } elsif ($self->{format} eq 'yaml') {
+ require CPAN::Meta::YAML;
+ print CPAN::Meta::YAML::Dump($self->{scandeps_tree});
+ } else {
+ $self->diag("Unknown format: $self->{format}\n");
+ }
+}
+
+sub walk_down {
+ my($self, $cb, $pre) = @_;
+ $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
+}
+
+sub _do_walk_down {
+ my($self, $children, $cb, $depth, $pre) = @_;
+
+ # DFS - $pre determines when we call the callback
+ for my $node (@$children) {
+ $cb->($node->[0], $depth) if $pre;
+ $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
+ $cb->($node->[0], $depth) unless $pre;
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+ $self->{at_exit}->($self) if $self->{at_exit};
+}
+
+# Utils
+
+sub mirror {
+ my($self, $uri, $local) = @_;
+ if ($uri =~ /^file:/) {
+ $self->file_mirror($uri, $local);
+ } else {
+ $self->{http}->mirror($uri, $local);
+ }
+}
+
+sub untar { $_[0]->{_backends}{untar}->(@_) };
+sub unzip { $_[0]->{_backends}{unzip}->(@_) };
+
+sub uri_to_file {
+ my($self, $uri) = @_;
+
+ # file:///path/to/file -> /path/to/file
+ # file://C:/path -> C:/path
+ if ($uri =~ s!file:/+!!) {
+ $uri = "/$uri" unless $uri =~ m![a-zA-Z]:!;
+ }
+
+ return $uri;
+}
+
+sub file_get {
+ my($self, $uri) = @_;
+ my $file = $self->uri_to_file($uri);
+ open my $fh, "<$file" or return;
+ join '', <$fh>;
+}
+
+sub file_mirror {
+ my($self, $uri, $path) = @_;
+ my $file = $self->uri_to_file($uri);
+
+ my $source_mtime = (stat $file)[9];
+
+ # Don't mirror a file that's already there (like the index)
+ return 1 if -e $path && (stat $path)[9] >= $source_mtime;
+
+ File::Copy::copy($file, $path);
+
+ utime $source_mtime, $source_mtime, $path;
+}
+
+sub configure_http {
+ my $self = shift;
+
+ require HTTP::Tinyish;
+
+ my @try = qw(HTTPTiny);
+ unshift @try, 'Wget' if $self->{try_wget};
+ unshift @try, 'Curl' if $self->{try_curl};
+ unshift @try, 'LWP' if $self->{try_lwp};
+
+ my @protocol = ('http');
+ push @protocol, 'https'
+ if grep /^https:/, @{$self->{mirrors}};
+
+ my $backend;
+ for my $try (map "HTTP::Tinyish::$_", @try) {
+ if (my $meta = HTTP::Tinyish->configure_backend($try)) {
+ if ((grep $try->supports($_), @protocol) == @protocol) {
+ for my $tool (sort keys %$meta){
+ (my $desc = $meta->{$tool}) =~ s/^(.*?)\n.*/$1/s;
+ $self->chat("You have $tool: $desc\n");
+ }
+ $backend = $try;
+ last;
+ }
+ }
+ }
+
+ $backend->new(agent => "Menlo/$Menlo::VERSION", verify_SSL => 1);
+}
+
+sub init_tools {
+ my $self = shift;
+
+ return if $self->{initialized}++;
+
+ if ($self->{make} = which($Config{make})) {
+ $self->chat("You have make $self->{make}\n");
+ }
+
+ $self->{http} = $self->configure_http;
+
+ my $tar = which('tar');
+ my $tar_ver;
+ my $maybe_bad_tar = sub { WIN32 || BAD_TAR || (($tar_ver = `@{[ qs $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 = ($self->{verbose} ? 'v' : '')."xf";
+ my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
+
+ my($root, @others) = `@{[ qs $tar ]} ${ar}tf @{[ qs $tarfile ]}`
+ or return undef;
+
+ FILE: {
+ chomp $root;
+ $root =~ s!^\./!!;
+ $root =~ s{^(.+?)/.*$}{$1};
+
+ if (!length($root)) {
+ # archive had ./ as the first entry, so try again
+ $root = shift(@others);
+ redo FILE if $root;
+ }
+ }
+
+ $self->run_command([ $tar, $ar.$xf, $tarfile ]);
+ return $root if -d $root;
+
+ $self->diag_fail("Bad archive: $tarfile");
+ return undef;
+ }
+ } elsif ( $tar
+ and my $gzip = which('gzip')
+ and my $bzip2 = 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) = `@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $tar ]} tf -`
+ or return undef;
+
+ FILE: {
+ chomp $root;
+ $root =~ s!^\./!!;
+ $root =~ s{^(.+?)/.*$}{$1};
+
+ if (!length($root)) {
+ # archive had ./ as the first entry, so try again
+ $root = shift(@others);
+ redo FILE if $root;
+ }
+ }
+
+ system "@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $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, @others) = $t->list_files;
+ FILE: {
+ $root =~ s!^\./!!;
+ $root =~ s{^(.+?)/.*$}{$1};
+
+ if (!length($root)) {
+ # archive had ./ as the first entry, so try again
+ $root = shift(@others);
+ redo FILE if $root;
+ }
+ }
+ $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 = which('unzip')) {
+ $self->chat("You have $unzip\n");
+ $self->{_backends}{unzip} = sub {
+ my($self, $zipfile) = @_;
+
+ my @opt = $self->{verbose} ? () : ('-q');
+ my(undef, $root, @others) = `@{[ qs $unzip ]} -t @{[ qs $zipfile ]}`
+ or return undef;
+ FILE: {
+ chomp $root;
+ if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
+ $root = shift(@others);
+ redo FILE if $root;
+ }
+ }
+
+ $self->run_command([ $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();
+ for my $member ( @members ) {
+ my $af = $member->fileName();
+ next if ($af =~ m!^(/|\.\./)!);
+ $status = $member->extractToFileNamed( $af );
+ $self->diag_fail("Extracting of file 'af' from zipfile '$file' failed")
+ if $status != Archive::Zip::AZ_OK();
+ }
+
+ my ($root) = $zip->membersMatching( qr<^[^/]+/$> );
+ $root &&= $root->fileName;
+ return -d $root ? $root : undef;
+ };
+ }
+}
+
+sub mask_uri_passwords {
+ my($self, @strings) = @_;
+ s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for @strings;
+ return @strings;
+}
+
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+Menlo::CLI::Compat - cpanm compatible CPAN installer
+
+=head1 SYNOPSIS
+
+ use Menlo::CLI::Compat;
+
+ my $app = Menlo::CLI::Compat->new;
+ $app->parse_options(@ARGV);
+ $app->run;
+
+=head1 DESCRIPTION
+
+Menlo::CLI::Compat is a port of App::cpanminus to Menlo, and provides
+a compatibility layer for users and clients to depend on the specific
+cpanm behaviors.
+
+=head1 SEE ALSO
+
+L<Menlo>, L<Menlo::Legacy>
+
+=cut
+
--- /dev/null
+package Menlo::Dependency;
+use strict;
+use CPAN::Meta::Requirements;
+use Class::Tiny qw( module version type original_version dist mirror url );
+
+sub BUILDARGS {
+ my($class, $module, $version, $type) = @_;
+ return {
+ module => $module,
+ version => $version,
+ type => $type || 'requires',
+ };
+}
+
+sub from_prereqs {
+ my($class, $prereqs, $phases, $types) = @_;
+
+ my @deps;
+ for my $type (@$types) {
+ push @deps, $class->from_versions(
+ $prereqs->merged_requirements($phases, [$type])->as_string_hash,
+ $type,
+ );
+ }
+
+ return @deps;
+}
+
+sub from_versions {
+ my($class, $versions, $type) = @_;
+
+ my @deps;
+ while (my($module, $version) = each %$versions) {
+ push @deps, $class->new($module, $version, $type)
+ }
+
+ @deps;
+}
+
+sub merge_with {
+ my($self, $requirements) = @_;
+
+ # save the original requirement
+ $self->original_version($self->version);
+
+ # should it clone? not cloning means we upgrade root $requirements on our way
+ eval {
+ $requirements->add_string_requirement($self->module, $self->version);
+ };
+ if ($@ =~ /illegal requirements/) {
+ # Just give a warning then replace with the root requirements
+ # so that later CPAN::Meta::Check can give a valid error
+ warn sprintf("Can't merge requirements for %s: '%s' and '%s'",
+ $self->module, $self->version,
+ $requirements->requirements_for_module($self->module));
+ }
+
+ $self->version( $requirements->requirements_for_module($self->module) );
+}
+
+sub requires_version {
+ my $self = shift;
+
+ # original_version may be 0
+ if (defined $self->original_version) {
+ return $self->original_version;
+ }
+
+ $self->version;
+}
+
+sub is_requirement {
+ $_[0]->type eq 'requires';
+}
+
+1;
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package Menlo::Index::MetaCPAN;
+# ABSTRACT: Search index via MetaCPAN
+# VERSION
+
+use parent 'CPAN::Common::Index';
+
+use Class::Tiny qw/uri include_dev/;
+
+use Carp;
+use HTTP::Tinyish;
+use JSON::PP ();
+use Time::Local ();
+
+sub BUILD {
+ my $self = shift;
+ my $uri = $self->uri;
+ $uri = "https://fastapi.metacpan.org/v1/download_url/"
+ unless defined $uri;
+ # ensure URI ends in '/'
+ $uri =~ s{/?$}{/};
+ $self->uri($uri);
+ return;
+}
+
+sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+
+ my $range;
+ if ( $args->{version} ) {
+ $range = "== $args->{version}";
+ } elsif ( $args->{version_range} ) {
+ $range = $args->{version_range};
+ }
+ my %query = (
+ ($self->include_dev ? (dev => 1) : ()),
+ ($range ? (version => $range) : ()),
+ );
+ my $query = join "&", map { "$_=" . $self->_uri_escape($query{$_}) } sort keys %query;
+
+ my $uri = $self->uri . $args->{package} . ($query ? "?$query" : "");
+ my $res = HTTP::Tinyish->new->get($uri);
+ return unless $res->{success};
+
+ my $dist_meta = eval { JSON::PP::decode_json($res->{content}) };
+ if ($dist_meta && $dist_meta->{download_url}) {
+ (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/\w/\w\w/!!;
+
+ return {
+ package => $args->{package},
+ version => $dist_meta->{version},
+ uri => "cpan:///distfile/$distfile",
+ download_uri => $self->_download_uri("http://cpan.metacpan.org", $distfile),
+ };
+ }
+
+ return;
+}
+
+sub _parse_date {
+ my($self, $date) = @_;
+ my @date = $date =~ /^(\d{4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)$/;
+ Time::Local::timegm($date[5], $date[4], $date[3], $date[2], $date[1] - 1, $date[0] - 1900);
+}
+
+sub _uri_escape {
+ my($self, $string) = @_;
+ $string =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
+ $string;
+}
+
+sub _download_uri {
+ my($self, $base, $distfile) = @_;
+ join "/", $base, "authors/id", substr($distfile, 0, 1), substr($distfile, 0, 2), $distfile;
+}
+
+sub index_age { return time } # pretend always current
+
+sub search_authors { return } # not supported
+
+1;
+
+=for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::MetaCPAN;
+
+ $index = CPAN::Common::Index::MetaCPAN->new({ include_dev => 1 });
+ $index->search_packages({ package => "Moose", version => "1.1" });
+ $index->search_packages({ package => "Moose", version_range => ">= 1.1, < 2" });
+
+=head1 DESCRIPTION
+
+This module implements a CPAN::Common::Index that searches for packages against
+the MetaCPAN API.
+
+This backend supports searching modules with a version range (as
+specified in L<CPAN::Meta::Spec>) which is translated into MetaCPAN
+search query.
+
+There is also a support for I<dev> release search, by passing
+C<include_dev> parameter to the index object.
+
+The result may include an optional field C<download_uri> which
+suggests a specific mirror URL to download from, which can be
+C<backpan.org> if the archive was deleted, or C<cpan.metacpan.org> if
+the release date is within 1 day (because some mirrors might not have
+synced it yet).
+
+There is no support for searching packages with a regular expression, nor searching authors.
+
+=cut
+
+# vim: ts=4 sts=4 sw=4 et:
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package Menlo::Index::MetaDB;
+# ABSTRACT: Search index via CPAN MetaDB
+
+our $VERSION = "1.9019";
+
+use parent 'CPAN::Common::Index';
+
+use Class::Tiny qw/uri/;
+
+use Carp;
+use CPAN::Meta::YAML;
+use CPAN::Meta::Requirements;
+use HTTP::Tiny;
+
+sub BUILD {
+ my $self = shift;
+ my $uri = $self->uri;
+ $uri = "http://cpanmetadb.plackperl.org/v1.0/"
+ unless defined $uri;
+ # ensure URI ends in '/'
+ $uri =~ s{/?$}{/};
+ $self->uri($uri);
+ return;
+}
+
+sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+
+ return
+ unless exists $args->{package} && ref $args->{package} eq '';
+
+ my $mod = $args->{package};
+
+ if ($args->{version} || $args->{version_range}) {
+ my $res = HTTP::Tiny->new->get( $self->uri . "history/$mod" );
+ return unless $res->{success};
+
+ my $range = defined $args->{version} ? "== $args->{version}" : $args->{version_range};
+ my $reqs = CPAN::Meta::Requirements->from_string_hash({ $mod => $range });
+
+ my @found;
+ for my $line ( split /\r?\n/, $res->{content} ) {
+ if ($line =~ /^$mod\s+(\S+)\s+(\S+)$/) {
+ push @found, {
+ version => $1,
+ version_o => version::->parse($1),
+ distfile => $2,
+ };
+ }
+ }
+
+ return unless @found;
+ $found[-1]->{latest} = 1;
+
+ my $match;
+ for my $try (sort { $b->{version_o} <=> $a->{version_o} } @found) {
+ if ($reqs->accepts_module($mod => $try->{version_o})) {
+ $match = $try, last;
+ }
+ }
+
+ if ($match) {
+ my $file = $match->{distfile};
+ $file =~ s{^./../}{}; # strip leading
+ return {
+ package => $mod,
+ version => $match->{version},
+ uri => "cpan:///distfile/$file",
+ ($match->{latest} ? () :
+ (download_uri => "http://backpan.perl.org/authors/id/$match->{distfile}")),
+ };
+ }
+ } else {
+ my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
+ return unless $res->{success};
+
+ if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
+ my $meta = $yaml->[0];
+ if ( $meta && $meta->{distfile} ) {
+ my $file = $meta->{distfile};
+ $file =~ s{^./../}{}; # strip leading
+ return {
+ package => $mod,
+ version => $meta->{version},
+ uri => "cpan:///distfile/$file",
+ };
+ }
+ }
+ }
+
+ return;
+}
+
+sub index_age { return time }; # pretend always current
+
+sub search_authors { return }; # not supported
+
+1;
+
+=for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
+
+=head1 SYNOPSIS
+
+ use CPAN::Common::Index::MetaDB;
+
+ $index = CPAN::Common::Index::MetaDB->new;
+
+ $index->search_packages({ package => "Moose" });
+ $index->search_packages({ package => "Moose", version_range => ">= 2.0" });
+
+=head1 DESCRIPTION
+
+This module implements a CPAN::Common::Index that searches for packages against
+the same CPAN MetaDB API used by L<cpanminus>.
+
+There is no support for advanced package queries or searching authors. It just
+takes a package name and returns the corresponding version and distribution.
+
+=cut
+
+# vim: ts=4 sts=4 sw=4 et:
--- /dev/null
+package Menlo::Index::Mirror;
+use strict;
+use parent qw(CPAN::Common::Index::Mirror);
+use Class::Tiny qw(fetcher);
+
+use File::Basename ();
+use File::Spec ();
+use URI ();
+
+our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
+
+my %INDICES = (
+# mailrc => 'authors/01mailrc.txt.gz',
+ packages => 'modules/02packages.details.txt.gz',
+);
+
+sub refresh_index {
+ my $self = shift;
+ for my $file ( values %INDICES ) {
+ my $remote = URI->new_abs( $file, $self->mirror );
+ $remote =~ s/\.gz$//
+ unless $HAS_IO_UNCOMPRESS_GUNZIP;
+ my $local = File::Spec->catfile( $self->cache, File::Basename::basename($file) );
+ $self->fetcher->($remote, $local)
+ or Carp::croak( "Cannot fetch $remote to $local");
+ if ($HAS_IO_UNCOMPRESS_GUNZIP) {
+ ( my $uncompressed = $local ) =~ s/\.gz$//;
+ IO::Uncompress::Gunzip::gunzip( $local, $uncompressed )
+ or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
+ }
+ }
+}
+
+1;
--- /dev/null
+package Menlo::Legacy;
+
+use strict;
+our $VERSION = '1.9022';
+
+1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+Menlo::Legacy - Legacy internal and client support for Menlo
+
+=head1 DESCRIPTION
+
+Menlo::Legacy is a package to install L<Menlo::CLI::Compat> which is a
+compatibility library that implements the classic version of cpanminus
+internals and behavios. This is so that existing users of cpanm and
+API clients such as L<Carton>, L<Carmel> and L<App::cpm>) can rely on
+the stable features and specific behaviors of cpanm.
+
+This way Menlo can evolve and be refactored without the fear of
+breaking any downstream clients, including C<cpanm> itself.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2018- Tatsuhiko Miyagawa
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<Menlo::CLI::Compat>
+
+=cut
--- /dev/null
+package Menlo::Util;
+use strict;
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(WIN32);
+
+use constant WIN32 => $^O eq 'MSWin32';
+
+if (WIN32) {
+ require Win32::ShellQuote;
+ *shell_quote = \&Win32::ShellQuote::quote_native;
+} else {
+ require String::ShellQuote;
+ *shell_quote = \&String::ShellQuote::shell_quote_best_effort;
+}
+
+1;
+
--- /dev/null
+package Module::Build::Tiny;
+$Module::Build::Tiny::VERSION = '0.039';
+use strict;
+use warnings;
+use Exporter 5.57 'import';
+our @EXPORT = qw/Build Build_PL/;
+
+use CPAN::Meta;
+use ExtUtils::Config 0.003;
+use ExtUtils::Helpers 0.020 qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
+use ExtUtils::Install qw/pm_to_blib install/;
+use ExtUtils::InstallPaths 0.002;
+use File::Basename qw/basename dirname/;
+use File::Find ();
+use File::Path qw/mkpath rmtree/;
+use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/;
+use Getopt::Long 2.36 qw/GetOptionsFromArray/;
+use JSON::PP 2 qw/encode_json decode_json/;
+
+sub write_file {
+ my ($filename, $content) = @_;
+ open my $fh, '>', $filename or die "Could not open $filename: $!\n";
+ print $fh $content;
+}
+sub read_file {
+ my ($filename, $mode) = @_;
+ open my $fh, '<', $filename or die "Could not open $filename: $!\n";
+ return do { local $/; <$fh> };
+}
+
+sub get_meta {
+ my ($metafile) = grep { -e $_ } qw/META.json META.yml/ or die "No META information provided\n";
+ return CPAN::Meta->load_file($metafile);
+}
+
+sub manify {
+ my ($input_file, $output_file, $section, $opts) = @_;
+ return if -e $output_file && -M $input_file <= -M $output_file;
+ my $dirname = dirname($output_file);
+ mkpath($dirname, $opts->{verbose}) if not -d $dirname;
+ require Pod::Man;
+ Pod::Man->new(section => $section)->parse_from_file($input_file, $output_file);
+ print "Manifying $output_file\n" if $opts->{verbose} && $opts->{verbose} > 0;
+ return;
+}
+
+sub process_xs {
+ my ($source, $options) = @_;
+
+ die "Can't build xs files under --pureperl-only\n" if $options->{'pureperl-only'};
+ my (undef, @parts) = splitdir(dirname($source));
+ push @parts, my $file_base = basename($source, '.xs');
+ my $archdir = catdir(qw/blib arch auto/, @parts);
+ my $tempdir = 'temp';
+
+ my $c_file = catfile($tempdir, "$file_base.c");
+ require ExtUtils::ParseXS;
+ mkpath($tempdir, $options->{verbose}, oct '755');
+ ExtUtils::ParseXS::process_file(filename => $source, prototypes => 0, output => $c_file);
+
+ my $version = $options->{meta}->version;
+ require ExtUtils::CBuilder;
+ my $builder = ExtUtils::CBuilder->new(config => $options->{config}->values_set);
+ my $ob_file = $builder->compile(source => $c_file, defines => { VERSION => qq/"$version"/, XS_VERSION => qq/"$version"/ }, include_dirs => [ curdir, dirname($source) ]);
+
+ require DynaLoader;
+ my $mod2fname = defined &DynaLoader::mod2fname ? \&DynaLoader::mod2fname : sub { return $_[0][-1] };
+
+ mkpath($archdir, $options->{verbose}, oct '755') unless -d $archdir;
+ my $lib_file = catfile($archdir, $mod2fname->(\@parts) . '.' . $options->{config}->get('dlext'));
+ return $builder->link(objects => $ob_file, lib_file => $lib_file, module_name => join '::', @parts);
+}
+
+sub find {
+ my ($pattern, $dir) = @_;
+ my @ret;
+ File::Find::find(sub { push @ret, $File::Find::name if /$pattern/ && -f }, $dir) if -d $dir;
+ return @ret;
+}
+
+my %actions = (
+ build => sub {
+ my %opt = @_;
+ for my $pl_file (find(qr/\.PL$/, 'lib')) {
+ (my $pm = $pl_file) =~ s/\.PL$//;
+ system $^X, $pl_file, $pm and die "$pl_file returned $?\n";
+ }
+ my %modules = map { $_ => catfile('blib', $_) } find(qr/\.p(?:m|od)$/, 'lib');
+ my %scripts = map { $_ => catfile('blib', $_) } find(qr//, 'script');
+ my %shared = map { $_ => catfile(qw/blib lib auto share dist/, $opt{meta}->name, abs2rel($_, 'share')) } find(qr//, 'share');
+ pm_to_blib({ %modules, %scripts, %shared }, catdir(qw/blib lib auto/));
+ make_executable($_) for values %scripts;
+ mkpath(catdir(qw/blib arch/), $opt{verbose});
+ process_xs($_, \%opt) for find(qr/.xs$/, 'lib');
+
+ if ($opt{install_paths}->install_destination('bindoc') && $opt{install_paths}->is_default_installable('bindoc')) {
+ manify($_, catfile('blib', 'bindoc', man1_pagename($_)), $opt{config}->get('man1ext'), \%opt) for keys %scripts;
+ }
+ if ($opt{install_paths}->install_destination('libdoc') && $opt{install_paths}->is_default_installable('libdoc')) {
+ manify($_, catfile('blib', 'libdoc', man3_pagename($_)), $opt{config}->get('man3ext'), \%opt) for keys %modules;
+ }
+ },
+ test => sub {
+ my %opt = @_;
+ die "Must run `./Build build` first\n" if not -d 'blib';
+ require TAP::Harness::Env;
+ my %test_args = (
+ (verbosity => $opt{verbose}) x!! exists $opt{verbose},
+ (jobs => $opt{jobs}) x!! exists $opt{jobs},
+ (color => 1) x !!-t STDOUT,
+ lib => [ map { rel2abs(catdir(qw/blib/, $_)) } qw/arch lib/ ],
+ );
+ my $tester = TAP::Harness::Env->create(\%test_args);
+ $tester->runtests(sort +find(qr/\.t$/, 't'))->has_errors and exit 1;
+ },
+ install => sub {
+ my %opt = @_;
+ die "Must run `./Build build` first\n" if not -d 'blib';
+ install($opt{install_paths}->install_map, @opt{qw/verbose dry_run uninst/});
+ },
+ clean => sub {
+ my %opt = @_;
+ rmtree($_, $opt{verbose}) for qw/blib temp/;
+ },
+ realclean => sub {
+ my %opt = @_;
+ rmtree($_, $opt{verbose}) for qw/blib temp Build _build_params MYMETA.yml MYMETA.json/;
+ },
+);
+
+sub Build {
+ my $action = @ARGV && $ARGV[0] =~ /\A\w+\z/ ? shift @ARGV : 'build';
+ die "No such action '$action'\n" if not $actions{$action};
+ my($env, $bargv) = @{ decode_json(read_file('_build_params')) };
+ my %opt;
+ GetOptionsFromArray($_, \%opt, qw/install_base=s install_path=s% installdirs=s destdir=s prefix=s config=s% uninst:1 verbose:1 dry_run:1 pureperl-only:1 create_packlist=i jobs=i/) for ($env, $bargv, \@ARGV);
+ $_ = detildefy($_) for grep { defined } @opt{qw/install_base destdir prefix/}, values %{ $opt{install_path} };
+ @opt{ 'config', 'meta' } = (ExtUtils::Config->new($opt{config}), get_meta());
+ $actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name));
+}
+
+sub Build_PL {
+ my $meta = get_meta();
+ printf "Creating new 'Build' script for '%s' version '%s'\n", $meta->name, $meta->version;
+ my $dir = $meta->name eq 'Module-Build-Tiny' ? "use lib 'lib';" : '';
+ write_file('Build', "#!perl\n$dir\nuse Module::Build::Tiny;\nBuild();\n");
+ make_executable('Build');
+ my @env = defined $ENV{PERL_MB_OPT} ? split_like_shell($ENV{PERL_MB_OPT}) : ();
+ write_file('_build_params', encode_json([ \@env, \@ARGV ]));
+ $meta->save(@$_) for ['MYMETA.json'], [ 'MYMETA.yml' => { version => 1.4 } ];
+}
+
+1;
+
+#ABSTRACT: A tiny replacement for Module::Build
+
+
+# vi:et:sts=2:sw=2:ts=2
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Module::Build::Tiny - A tiny replacement for Module::Build
+
+=head1 VERSION
+
+version 0.039
+
+=head1 SYNOPSIS
+
+ use Module::Build::Tiny;
+ Build_PL();
+
+=head1 DESCRIPTION
+
+Many Perl distributions use a Build.PL file instead of a Makefile.PL file
+to drive distribution configuration, build, test and installation.
+Traditionally, Build.PL uses Module::Build as the underlying build system.
+This module provides a simple, lightweight, drop-in replacement.
+
+Whereas Module::Build has over 6,700 lines of code; this module has less
+than 120, yet supports the features needed by most distributions.
+
+=head2 Supported
+
+=over 4
+
+=item * Pure Perl distributions
+
+=item * Building XS or C
+
+=item * Recursive test files
+
+=item * MYMETA
+
+=item * Man page generation
+
+=item * Generated code from PL files
+
+=back
+
+=head2 Not Supported
+
+=over 4
+
+=item * Dynamic prerequisites
+
+=item * HTML documentation generation
+
+=item * Extending Module::Build::Tiny
+
+=item * Module sharedirs
+
+=back
+
+=head2 Directory structure
+
+Your .pm and .pod files must be in F<lib/>. Any executables must be in
+F<script/>. Test files must be in F<t/>. Dist sharedirs must be in F<share/>.
+
+=head1 USAGE
+
+These all work pretty much like their Module::Build equivalents.
+
+=head2 perl Build.PL
+
+=head2 Build [ build ]
+
+=head2 Build test
+
+=head2 Build install
+
+This supports the following options:
+
+=over
+
+=item * verbose
+
+=item * install_base
+
+=item * installdirs
+
+=item * prefix
+
+=item * install_path
+
+=item * destdir
+
+=item * uninst
+
+=item * config
+
+=item * pure-perl
+
+=item * create_packlist
+
+=back
+
+=head1 AUTHORING
+
+This module doesn't support authoring. To develop modules using Module::Build::Tiny, usage of L<Dist::Zilla::Plugin::ModuleBuildTiny> or L<App::ModuleBuildTiny> is recommended.
+
+=head1 CONFIG FILE AND ENVIRONMENT
+
+Options can be provided in the C<PERL_MB_OPT> environment variable the same way they can with Module::Build. This should be done during the configuration stage.
+
+=head2 Incompatibilities
+
+=over 4
+
+=item * Argument parsing
+
+Module::Build has an extremely permissive way of argument handling, Module::Build::Tiny only supports a (sane) subset of that. In particular, C<./Build destdir=/foo> does not work, you will need to pass it as C<./Build --destdir=/foo>.
+
+=item * .modulebuildrc
+
+Module::Build::Tiny does not support .modulebuildrc files. In particular, this means that versions of local::lib older than 1.006008 may break with C<ERROR: Can't create /usr/local/somepath>. If the output of C<perl -Mlocal::lib> contains C<MODULEBUILDRC> but not C<PERL_MB_OPT >, you will need to upgrade it to resolve this issue.
+
+=back
+
+=head1 SEE ALSO
+
+L<Module::Build>
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+Leon Timmermans <leont@cpan.org>
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2011 by Leon Timmermans, David Golden.
+
+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
--- /dev/null
+package Module::CPANfile;
+use strict;
+use warnings;
+use Cwd;
+use Carp ();
+use Module::CPANfile::Environment;
+use Module::CPANfile::Requirement;
+
+our $VERSION = '1.1004';
+
+BEGIN {
+ if (${^TAINT}) {
+ *untaint = sub {
+ my $str = shift;
+ ($str) = $str =~ /^(.+)$/s;
+ $str;
+ };
+ } else {
+ *untaint = sub { $_[0] };
+ }
+}
+
+sub new {
+ my($class, $file) = @_;
+ bless {}, $class;
+}
+
+sub load {
+ my($proto, $file) = @_;
+
+ my $self = ref $proto ? $proto : $proto->new;
+ $self->parse($file || _default_cpanfile());
+ $self;
+}
+
+sub save {
+ my($self, $path) = @_;
+
+ open my $out, ">", $path or die "$path: $!";
+ print {$out} $self->to_string;
+}
+
+sub parse {
+ my($self, $file) = @_;
+
+ my $code = do {
+ open my $fh, "<", $file or die "$file: $!";
+ join '', <$fh>;
+ };
+
+ $code = untaint $code;
+
+ my $env = Module::CPANfile::Environment->new($file);
+ $env->parse($code) or die $@;
+
+ $self->{_mirrors} = $env->mirrors;
+ $self->{_prereqs} = $env->prereqs;
+}
+
+sub from_prereqs {
+ my($proto, $prereqs) = @_;
+
+ my $self = $proto->new;
+ $self->{_prereqs} = Module::CPANfile::Prereqs->from_cpan_meta($prereqs);
+
+ $self;
+}
+
+sub mirrors {
+ my $self = shift;
+ $self->{_mirrors} || [];
+}
+
+sub features {
+ my $self = shift;
+ map $self->feature($_), $self->{_prereqs}->identifiers;
+}
+
+sub feature {
+ my($self, $identifier) = @_;
+ $self->{_prereqs}->feature($identifier);
+}
+
+sub prereq { shift->prereqs }
+
+sub prereqs {
+ my $self = shift;
+ $self->{_prereqs}->as_cpan_meta;
+}
+
+sub merged_requirements {
+ my $self = shift;
+ $self->{_prereqs}->merged_requirements;
+}
+
+sub effective_prereqs {
+ my($self, $features) = @_;
+ $self->prereqs_with(@{$features || []});
+}
+
+sub prereqs_with {
+ my($self, @feature_identifiers) = @_;
+
+ my @others = map { $self->feature($_)->prereqs } @feature_identifiers;
+ $self->prereqs->with_merged_prereqs(\@others);
+}
+
+sub prereq_specs {
+ my $self = shift;
+ $self->prereqs->as_string_hash;
+}
+
+sub prereq_for_module {
+ my($self, $module) = @_;
+ $self->{_prereqs}->find($module);
+}
+
+sub options_for_module {
+ my($self, $module) = @_;
+ my $prereq = $self->prereq_for_module($module) or return;
+ $prereq->requirement->options;
+}
+
+sub merge_meta {
+ my($self, $file, $version) = @_;
+
+ require CPAN::Meta;
+
+ $version ||= $file =~ /\.yml$/ ? '1.4' : '2';
+
+ my $prereq = $self->prereqs;
+
+ my $meta = CPAN::Meta->load_file($file);
+ my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;
+ my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash };
+
+ CPAN::Meta->new($struct)->save($file, { version => $version });
+}
+
+sub _d($) {
+ require Data::Dumper;
+ chomp(my $value = Data::Dumper->new([$_[0]])->Terse(1)->Dump);
+ $value;
+}
+
+sub _default_cpanfile {
+ my $file = Cwd::abs_path('cpanfile');
+ untaint $file;
+}
+
+sub to_string {
+ my($self, $include_empty) = @_;
+
+ my $mirrors = $self->mirrors;
+ my $prereqs = $self->prereq_specs;
+
+ my $code = '';
+ $code .= $self->_dump_mirrors($mirrors);
+ $code .= $self->_dump_prereqs($prereqs, $include_empty);
+
+ for my $feature ($self->features) {
+ $code .= "feature @{[ _d $feature->{identifier} ]}, @{[ _d $feature->{description} ]} => sub {\n";
+ $code .= $self->_dump_prereqs($feature->{prereqs}->as_string_hash, $include_empty, 4);
+ $code .= "};\n\n";
+ }
+
+ $code =~ s/\n+$/\n/s;
+ $code;
+}
+
+sub _dump_mirrors {
+ my($self, $mirrors) = @_;
+
+ my $code = "";
+
+ for my $url (@$mirrors) {
+ $code .= "mirror @{[ _d $url ]};\n";
+ }
+
+ $code =~ s/\n+$/\n/s;
+ $code;
+}
+
+sub _dump_prereqs {
+ my($self, $prereqs, $include_empty, $base_indent) = @_;
+
+ my $code = '';
+ for my $phase (qw(runtime configure build test develop)) {
+ my $indent = $phase eq 'runtime' ? '' : ' ';
+ $indent .= (' ' x ($base_indent || 0));
+
+ my($phase_code, $requirements);
+ $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime';
+
+ for my $type (qw(requires recommends suggests conflicts)) {
+ for my $mod (sort keys %{$prereqs->{$phase}{$type}}) {
+ my $ver = $prereqs->{$phase}{$type}{$mod};
+ $phase_code .= $ver eq '0'
+ ? "${indent}$type @{[ _d $mod ]}"
+ : "${indent}$type @{[ _d $mod ]}, @{[ _d $ver ]}";
+
+ my $options = $self->options_for_module($mod) || {};
+ if (%$options) {
+ my @opts;
+ for my $key (keys %$options) {
+ my $k = $key =~ /^[a-zA-Z0-9_]+$/ ? $key : _d $key;
+ push @opts, "$k => @{[ _d $options->{$k} ]}";
+ }
+
+ $phase_code .= ",\n" . join(",\n", map " $indent$_", @opts);
+ }
+
+ $phase_code .= ";\n";
+ $requirements++;
+ }
+ }
+
+ $phase_code .= "\n" unless $requirements;
+ $phase_code .= "};\n" unless $phase eq 'runtime';
+
+ $code .= $phase_code . "\n" if $requirements or $include_empty;
+ }
+
+ $code =~ s/\n+$/\n/s;
+ $code;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Module::CPANfile - Parse cpanfile
+
+=head1 SYNOPSIS
+
+ use Module::CPANfile;
+
+ my $file = Module::CPANfile->load("cpanfile");
+ my $prereqs = $file->prereqs; # CPAN::Meta::Prereqs object
+
+ my @features = $file->features; # CPAN::Meta::Feature objects
+ my $merged_prereqs = $file->prereqs_with(@identifiers); # CPAN::Meta::Prereqs
+
+ $file->merge_meta('MYMETA.json');
+
+=head1 DESCRIPTION
+
+Module::CPANfile is a tool to handle L<cpanfile> format to load application
+specific dependencies, not just for CPAN distributions.
+
+=head1 METHODS
+
+=over 4
+
+=item load
+
+ $file = Module::CPANfile->load;
+ $file = Module::CPANfile->load('cpanfile');
+
+Load and parse a cpanfile. By default it tries to load C<cpanfile> in
+the current directory, unless you pass the path to its argument.
+
+=item from_prereqs
+
+ $file = Module::CPANfile->from_prereqs({
+ runtime => { requires => { DBI => '1.000' } },
+ });
+
+Creates a new Module::CPANfile object from prereqs hash you can get
+via L<CPAN::Meta>'s C<prereqs>, or L<CPAN::Meta::Prereqs>'
+C<as_string_hash>.
+
+ # read MYMETA, then feed the prereqs to create Module::CPANfile
+ my $meta = CPAN::Meta->load_file('MYMETA.json');
+ my $file = Module::CPANfile->from_prereqs($meta->prereqs);
+
+ # load cpanfile, then recreate it with round-trip
+ my $file = Module::CPANfile->load('cpanfile');
+ $file = Module::CPANfile->from_prereqs($file->prereq_specs);
+ # or $file->prereqs->as_string_hash
+
+=item prereqs
+
+Returns L<CPAN::Meta::Prereqs> object out of the parsed cpanfile.
+
+=item prereq_specs
+
+Returns a hash reference that should be passed to C<< CPAN::Meta::Prereqs->new >>.
+
+=item features
+
+Returns a list of features available in the cpanfile as L<CPAN::Meta::Feature>.
+
+=item prereqs_with(@identifiers), effective_prereqs(\@identifiers)
+
+Returns L<CPAN::Meta::Prereqs> object, with merged prereqs for
+features identified with the C<@identifiers>.
+
+=item to_string($include_empty)
+
+ $file->to_string;
+ $file->to_string(1);
+
+Returns a canonical string (code) representation for cpanfile. Useful
+if you want to convert L<CPAN::Meta::Prereqs> to a new cpanfile.
+
+ # read MYMETA's prereqs and print cpanfile representation of it
+ my $meta = CPAN::Meta->load_file('MYMETA.json');
+ my $file = Module::CPANfile->from_prereqs($meta->prereqs);
+ print $file->to_string;
+
+By default, it omits the phase where there're no modules
+registered. If you pass the argument of a true value, it will print
+them as well.
+
+=item save
+
+ $file->save('cpanfile');
+
+Saves the currently loaded prereqs as a new C<cpanfile> by calling
+C<to_string>. Beware B<this method will overwrite the existing
+cpanfile without any warning or backup>. Taking a backup or giving
+warnings to users is a caller's responsibility.
+
+ # Read MYMETA.json and creates a new cpanfile
+ my $meta = CPAN::Meta->load_file('MYMETA.json');
+ my $file = Module::CPANfile->from_prereqs($meta->prereqs);
+ $file->save('cpanfile');
+
+=item merge_meta
+
+ $file->merge_meta('META.yml');
+ $file->merge_meta('MYMETA.json', '2.0');
+
+Merge the effective prereqs with Meta specification loaded from the
+given META file, using CPAN::Meta. You can specify the META spec
+version in the second argument, which defaults to 1.4 in case the
+given file is YAML, and 2 if it is JSON.
+
+=item options_for_module
+
+ my $options = $file->options_for_module($module);
+
+Returns the extra options specified for a given module as a hash
+reference. Returns C<undef> when the given module is not specified in
+the C<cpanfile>.
+
+For example,
+
+ # cpanfile
+ requires 'Plack', '1.000',
+ dist => "MIYAGAWA/Plack-1.000.tar.gz";
+
+ # ...
+ my $file = Module::CPANfile->load;
+ my $options = $file->options_for_module('Plack');
+ # => { dist => "MIYAGAWA/Plack-1.000.tar.gz" }
+
+=back
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<cpanfile>, L<CPAN::Meta>, L<CPAN::Meta::Spec>
+
+=cut
--- /dev/null
+package Module::CPANfile::Environment;
+use strict;
+use warnings;
+use Module::CPANfile::Prereqs;
+use Carp ();
+
+my @bindings = qw(
+ on requires recommends suggests conflicts
+ feature
+ osname
+ mirror
+ configure_requires build_requires test_requires author_requires
+);
+
+my $file_id = 1;
+
+sub new {
+ my($class, $file) = @_;
+ bless {
+ file => $file,
+ phase => 'runtime', # default phase
+ feature => undef,
+ features => {},
+ prereqs => Module::CPANfile::Prereqs->new,
+ mirrors => [],
+ }, $class;
+}
+
+sub bind {
+ my $self = shift;
+ my $pkg = caller;
+
+ for my $binding (@bindings) {
+ no strict 'refs';
+ *{"$pkg\::$binding"} = sub { $self->$binding(@_) };
+ }
+}
+
+sub parse {
+ my($self, $code) = @_;
+
+ my $err;
+ {
+ local $@;
+ $file_id++;
+ $self->_evaluate(<<EVAL);
+package Module::CPANfile::Sandbox$file_id;
+no warnings;
+BEGIN { \$_environment->bind }
+
+# line 1 "$self->{file}"
+$code;
+EVAL
+ $err = $@;
+ }
+
+ if ($err) { die "Parsing $self->{file} failed: $err" };
+
+ return 1;
+}
+
+sub _evaluate {
+ my $_environment = $_[0];
+ eval $_[1];
+}
+
+sub prereqs { $_[0]->{prereqs} }
+
+sub mirrors { $_[0]->{mirrors} }
+
+# DSL goes from here
+
+sub on {
+ my($self, $phase, $code) = @_;
+ local $self->{phase} = $phase;
+ $code->();
+}
+
+sub feature {
+ my($self, $identifier, $description, $code) = @_;
+
+ # shortcut: feature identifier => sub { ... }
+ if (@_ == 3 && ref($description) eq 'CODE') {
+ $code = $description;
+ $description = $identifier;
+ }
+
+ unless (ref $description eq '' && ref $code eq 'CODE') {
+ Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }");
+ }
+
+ local $self->{feature} = $identifier;
+ $self->prereqs->add_feature($identifier, $description);
+
+ $code->();
+}
+
+sub osname { die "TODO" }
+
+sub mirror {
+ my($self, $url) = @_;
+ push @{$self->{mirrors}}, $url;
+}
+
+sub requirement_for {
+ my($self, $module, @args) = @_;
+
+ my $requirement = 0;
+ $requirement = shift @args if @args % 2;
+
+ return Module::CPANfile::Requirement->new(
+ name => $module,
+ version => $requirement,
+ @args,
+ );
+}
+
+sub requires {
+ my $self = shift;
+ $self->add_prereq(requires => @_);
+}
+
+sub recommends {
+ my $self = shift;
+ $self->add_prereq(recommends => @_);
+}
+
+sub suggests {
+ my $self = shift;
+ $self->add_prereq(suggests => @_);
+}
+
+sub conflicts {
+ my $self = shift;
+ $self->add_prereq(conflicts => @_);
+}
+
+sub add_prereq {
+ my($self, $type, $module, @args) = @_;
+
+ $self->prereqs->add(
+ feature => $self->{feature},
+ phase => $self->{phase},
+ type => $type,
+ module => $module,
+ requirement => $self->requirement_for($module, @args),
+ );
+}
+
+# Module::Install compatible shortcuts
+
+sub configure_requires {
+ my($self, @args) = @_;
+ $self->on(configure => sub { $self->requires(@args) });
+}
+
+sub build_requires {
+ my($self, @args) = @_;
+ $self->on(build => sub { $self->requires(@args) });
+}
+
+sub test_requires {
+ my($self, @args) = @_;
+ $self->on(test => sub { $self->requires(@args) });
+}
+
+sub author_requires {
+ my($self, @args) = @_;
+ $self->on(develop => sub { $self->requires(@args) });
+}
+
+1;
+
--- /dev/null
+package Module::CPANfile::Prereq;
+use strict;
+
+sub new {
+ my($class, %options) = @_;
+ bless \%options, $class;
+}
+
+sub feature { $_[0]->{feature} }
+sub phase { $_[0]->{phase} }
+sub type { $_[0]->{type} }
+sub module { $_[0]->{module} }
+sub requirement { $_[0]->{requirement} }
+
+1;
--- /dev/null
+package Module::CPANfile::Prereqs;
+use strict;
+use Carp ();
+use CPAN::Meta::Feature;
+use Module::CPANfile::Prereq;
+
+sub from_cpan_meta {
+ my($class, $prereqs) = @_;
+
+ my $self = $class->new;
+
+ for my $phase (keys %$prereqs) {
+ for my $type (keys %{ $prereqs->{$phase} }) {
+ while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
+ $self->add(
+ phase => $phase,
+ type => $type,
+ module => $module,
+ requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement),
+ );
+ }
+ }
+ }
+
+ $self;
+}
+
+sub new {
+ my $class = shift;
+ bless {
+ prereqs => {},
+ features => {},
+ }, $class;
+}
+
+sub add_feature {
+ my($self, $identifier, $description) = @_;
+ $self->{features}{$identifier} = { description => $description };
+}
+
+sub add {
+ my($self, %args) = @_;
+
+ my $feature = $args{feature} || '';
+ push @{$self->{prereqs}{$feature}},
+ Module::CPANfile::Prereq->new(%args);
+}
+
+sub as_cpan_meta {
+ my $self = shift;
+ $self->{cpanmeta} ||= $self->build_cpan_meta;
+}
+
+sub build_cpan_meta {
+ my($self, $feature) = @_;
+ CPAN::Meta::Prereqs->new($self->specs($feature));
+}
+
+sub specs {
+ my($self, $feature) = @_;
+
+ $feature = ''
+ unless defined $feature;
+
+ my $prereqs = $self->{prereqs}{$feature} || [];
+ my $specs = {};
+
+ for my $prereq (@$prereqs) {
+ $specs->{$prereq->phase}{$prereq->type}{$prereq->module} =
+ $prereq->requirement->version;
+ }
+
+ return $specs;
+}
+
+sub merged_requirements {
+ my $self = shift;
+
+ my $reqs = CPAN::Meta::Requirements->new;
+ for my $prereq (@{$self->{prereqs}}) {
+ $reqs->add_string_requirement($prereq->module, $prereq->requirement->version);
+ }
+
+ $reqs;
+}
+
+sub find {
+ my($self, $module) = @_;
+
+ for my $feature ('', keys %{$self->{features}}) {
+ for my $prereq (@{$self->{prereqs}{$feature}}) {
+ return $prereq if $prereq->module eq $module;
+ }
+ }
+
+ return;
+}
+
+sub identifiers {
+ my $self = shift;
+ keys %{$self->{features}};
+}
+
+sub feature {
+ my($self, $identifier) = @_;
+
+ my $data = $self->{features}{$identifier}
+ or Carp::croak("Unknown feature '$identifier'");
+
+ my $prereqs = $self->build_cpan_meta($identifier);
+
+ CPAN::Meta::Feature->new($identifier, {
+ description => $data->{description},
+ prereqs => $prereqs->as_string_hash,
+ });
+}
+
+1;
--- /dev/null
+package Module::CPANfile::Requirement;
+use strict;
+
+sub new {
+ my ($class, %args) = @_;
+
+ $args{version} ||= 0;
+
+ bless +{
+ name => delete $args{name},
+ version => delete $args{version},
+ options => \%args,
+ }, $class;
+}
+
+sub name { $_[0]->{name} }
+sub version { $_[0]->{version} }
+
+sub options { $_[0]->{options} }
+
+sub has_options {
+ keys %{$_[0]->{options}} > 0;
+}
+
+1;
--- /dev/null
+package Parallel::Pipes;
+use 5.008001;
+use strict;
+use warnings;
+use IO::Handle;
+use IO::Select;
+
+use constant WIN32 => $^O eq 'MSWin32';
+
+our $VERSION = '0.005';
+
+{
+ package Parallel::Pipe::Impl;
+ use Storable ();
+ sub new {
+ my ($class, %option) = @_;
+ my $read_fh = delete $option{read_fh} or die;
+ my $write_fh = delete $option{write_fh} or die;
+ $write_fh->autoflush(1);
+ bless { %option, read_fh => $read_fh, write_fh => $write_fh, buf => '' }, $class;
+ }
+ sub read :method {
+ my $self = shift;
+ my $_size = $self->_read(4) or return;
+ my $size = unpack 'I', $_size;
+ my $freezed = $self->_read($size);
+ Storable::thaw($freezed);
+ }
+ sub write :method {
+ my ($self, $data) = @_;
+ my $freezed = Storable::freeze({data => $data});
+ my $size = pack 'I', length($freezed);
+ $self->_write("$size$freezed");
+ }
+ sub _read {
+ my ($self, $size) = @_;
+ my $fh = $self->{read_fh};
+ my $offset = length $self->{buf};
+ while ($offset < $size) {
+ my $len = sysread $fh, $self->{buf}, 65536, $offset;
+ if (!defined $len) {
+ die $!;
+ } elsif ($len == 0) {
+ last;
+ } else {
+ $offset += $len;
+ }
+ }
+ return substr $self->{buf}, 0, $size, '';
+ }
+ sub _write {
+ my ($self, $data) = @_;
+ my $fh = $self->{write_fh};
+ my $size = length $data;
+ my $offset = 0;
+ while ($size) {
+ my $len = syswrite $fh, $data, $size, $offset;
+ if (!defined $len) {
+ die $!;
+ } elsif ($len == 0) {
+ last;
+ } else {
+ $size -= $len;
+ $offset += $len;
+ }
+ }
+ $size;
+ }
+}
+{
+ package Parallel::Pipe::Here;
+ our @ISA = qw(Parallel::Pipe::Impl);
+ use Carp ();
+ sub new {
+ my ($class, %option) = @_;
+ $class->SUPER::new(%option, _written => 0);
+ }
+ sub is_written {
+ my $self = shift;
+ $self->{_written} == 1;
+ }
+ sub read :method {
+ my $self = shift;
+ if (!$self->is_written) {
+ Carp::croak("This pipe has not been written; you cannot read it");
+ }
+ $self->{_written}--;
+ return unless my $read = $self->SUPER::read;
+ $read->{data};
+ }
+ sub write :method {
+ my ($self, $task) = @_;
+ if ($self->is_written) {
+ Carp::croak("This pipe has already been written; you must read it first");
+ }
+ $self->{_written}++;
+ $self->SUPER::write($task);
+ }
+}
+{
+ package Parallel::Pipe::There;
+ our @ISA = qw(Parallel::Pipe::Impl);
+}
+{
+ package Parallel::Pipe::Impl::NoFork;
+ use Carp ();
+ sub new {
+ my ($class, %option) = @_;
+ bless {%option}, $class;
+ }
+ sub is_written {
+ my $self = shift;
+ exists $self->{_result};
+ }
+ sub read :method {
+ my $self = shift;
+ if (!$self->is_written) {
+ Carp::croak("This pipe has not been written; you cannot read it");
+ }
+ delete $self->{_result};
+ }
+ sub write :method {
+ my ($self, $task) = @_;
+ if ($self->is_written) {
+ Carp::croak("This pipe has already been written; you must read it first");
+ }
+ my $result = $self->{code}->($task);
+ $self->{_result} = $result;
+ }
+}
+
+sub new {
+ my ($class, $number, $code) = @_;
+ if (WIN32 and $number != 1) {
+ die "The number of pipes must be 1 under WIN32 environment.\n";
+ }
+ my $self = bless {
+ code => $code,
+ number => $number,
+ no_fork => $number == 1,
+ pipes => {},
+ }, $class;
+
+ if ($self->no_fork) {
+ $self->{pipes}{-1} = Parallel::Pipe::Impl::NoFork->new(code => $self->{code});
+ } else {
+ $self->_fork for 1 .. $number;
+ }
+ $self;
+}
+
+sub no_fork { shift->{no_fork} }
+
+sub _fork {
+ my $self = shift;
+ my $code = $self->{code};
+ pipe my $read_fh1, my $write_fh1;
+ pipe my $read_fh2, my $write_fh2;
+ my $pid = fork;
+ die "fork failed" unless defined $pid;
+ if ($pid == 0) {
+ srand;
+ close $_ for $read_fh1, $write_fh2, map { ($_->{read_fh}, $_->{write_fh}) } $self->pipes;
+ my $there = Parallel::Pipe::There->new(read_fh => $read_fh2, write_fh => $write_fh1);
+ while (my $read = $there->read) {
+ $there->write( $code->($read->{data}) );
+ }
+ exit;
+ }
+ close $_ for $write_fh1, $read_fh2;
+ $self->{pipes}{$pid} = Parallel::Pipe::Here->new(
+ pid => $pid, read_fh => $read_fh1, write_fh => $write_fh2,
+ );
+}
+
+sub pipes {
+ my $self = shift;
+ map { $self->{pipes}{$_} } sort { $a <=> $b } keys %{$self->{pipes}};
+}
+
+sub is_ready {
+ my $self = shift;
+ return $self->pipes if $self->no_fork;
+
+ my @pipes = @_ ? @_ : $self->pipes;
+ if (my @ready = grep { $_->{_written} == 0 } @pipes) {
+ return @ready;
+ }
+
+ my $select = IO::Select->new(map { $_->{read_fh} } @pipes);
+ my @ready = $select->can_read;
+
+ my @return;
+ for my $pipe (@pipes) {
+ if (grep { $pipe->{read_fh} == $_ } @ready) {
+ push @return, $pipe;
+ }
+ }
+ return @return;
+}
+
+sub is_written {
+ my $self = shift;
+ grep { $_->is_written } $self->pipes;
+}
+
+sub close :method {
+ my $self = shift;
+ return if $self->no_fork;
+
+ close $_ for map { ($_->{write_fh}, $_->{read_fh}) } $self->pipes;
+ while (%{$self->{pipes}}) {
+ my $pid = wait;
+ if (delete $self->{pipes}{$pid}) {
+ # OK
+ } else {
+ warn "wait() unexpectedly returns $pid\n";
+ }
+ }
+}
+
+1;
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+Parallel::Pipes - parallel processing using pipe(2) for communication and synchronization
+
+=head1 SYNOPSIS
+
+ use Parallel::Pipes;
+
+ my $pipes = Parallel::Pipes->new(5, sub {
+ # this is a worker code
+ my $task = shift;
+ my $result = do_work($task);
+ return $result;
+ });
+
+ my $queue = Your::TaskQueue->new;
+ # wrap Your::TaskQueue->get
+ my $get; $get = sub {
+ my $queue = shift;
+ if (my @task = $queue->get) {
+ return @task;
+ }
+ if (my @written = $pipes->is_written) {
+ my @ready = $pipes->is_ready(@written);
+ $queue->register($_->read) for @ready;
+ return $queue->$get;
+ } else {
+ return;
+ }
+ };
+
+ while (my @task = $queue->$get) {
+ my @ready = $pipes->is_ready;
+ $queue->register($_->read) for grep $_->is_written, @ready;
+ my $min = List::Util::min($#task, $#ready);
+ for my $i (0..$min) {
+ # write tasks to pipes which are ready
+ $ready[$i]->write($task[$i]);
+ }
+ }
+
+ $pipes->close;
+
+=head1 DESCRIPTION
+
+B<THIS IS EXPERIMENTAL>.
+
+Parallel processing is essential, but it is also difficult:
+
+=over 4
+
+=item How can we synchronize our workers?
+
+More precisely, how to detect our workers are ready or finished.
+
+=item How can we communicate with our workers?
+
+More precisely, how to collect results of tasks.
+
+=back
+
+Parallel::Pipes tries to solve these problems with C<pipe(2)> and C<select(2)>.
+
+L<App::cpm>, a fast CPAN module installer, uses Parallel::Pipes.
+Please look at L<App::cpm|https://github.com/skaji/cpm/blob/master/lib/App/cpm.pm>
+or L<eg directory|https://github.com/skaji/Parallel-Pipes/tree/master/eg> for real world usages.
+
+=begin html
+
+<a href="https://raw.githubusercontent.com/skaji/Parallel-Pipes/master/author/image.png"><img src="https://raw.githubusercontent.com/skaji/Parallel-Pipes/master/author/image.png" alt="image" class="img-responsive"></a>
+
+=end html
+
+=head1 METHOD
+
+=head2 new
+
+ my $pipes = Parallel::Pipes->new($number, $code);
+
+The constructor, which takes
+
+=over 4
+
+=item number
+
+The number of workers.
+
+=item code
+
+Worker's code.
+
+=back
+
+=head2 is_ready
+
+ my @ready = $pipes->is_ready;
+ my @ready = $pipes->is_ready(@pipes);
+
+Get pipes which are ready to write.
+
+=head2 is_written
+
+ my @written = $pipes->is_written;
+
+Get pipes which are written.
+
+=head2 close
+
+ $pipes->close;
+
+Close pipes (also shutdown workers).
+
+=head1 AUTHOR
+
+Shoichi Kaji <skaji@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2016 Shoichi Kaji <skaji@cpan.org>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package Parse::PMFile;
+
+sub __clean_eval { eval $_[0] } # needs to be here (RT#101273)
+
+use strict;
+use warnings;
+use Safe;
+use JSON::PP ();
+use Dumpvalue;
+use version ();
+use File::Spec ();
+
+our $VERSION = '0.42';
+our $VERBOSE = 0;
+our $ALLOW_DEV_VERSION = 0;
+our $FORK = 0;
+our $UNSAFE = $] < 5.010000 ? 1 : 0;
+
+sub new {
+ my ($class, $meta, $opts) = @_;
+ bless {%{ $opts || {} }, META_CONTENT => $meta}, $class;
+}
+
+# from PAUSE::pmfile::examine_fio
+sub parse {
+ my ($self, $pmfile) = @_;
+
+ $pmfile =~ s|\\|/|g;
+
+ my($filemtime) = (stat $pmfile)[9];
+ $self->{MTIME} = $filemtime;
+ $self->{PMFILE} = $pmfile;
+
+ unless ($self->_version_from_meta_ok) {
+ my $version;
+ unless (eval { $version = $self->_parse_version; 1 }) {
+ $self->_verbose(1, "error with version in $pmfile: $@");
+ return;
+ }
+
+ $self->{VERSION} = $version;
+ if ($self->{VERSION} =~ /^\{.*\}$/) {
+ # JSON error message
+ } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
+ return;
+ }
+ }
+
+ my($ppp) = $self->_packages_per_pmfile;
+ my @keys_ppp = $self->_filter_ppps(sort keys %$ppp);
+ $self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");
+
+ #
+ # Immediately after each package (pmfile) examined contact
+ # the database
+ #
+
+ my ($package, %errors);
+ my %checked_in;
+ DBPACK: foreach $package (@keys_ppp) {
+ # this part is taken from PAUSE::package::examine_pkg
+ # and PAUSE::package::_pkg_name_insane
+ if ($package !~ /^\w[\w\:\']*\w?\z/
+ || $package !~ /\w\z/
+ || $package =~ /:/ && $package !~ /::/
+ || $package =~ /\w:\w/
+ || $package =~ /:::/
+ ){
+ $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");
+ delete $ppp->{$package};
+ next;
+ }
+
+ if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) {
+ delete $ppp->{$package};
+ next;
+ }
+
+ # Check that package name matches case of file name
+ {
+ my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2;
+ if ($module) {
+ $module =~ s{\.pm\z}{};
+ $module =~ s{/}{::}g;
+
+ if (lc $module eq lc $package && $module ne $package) {
+ # warn "/// $self->{PMFILE} vs. $module vs. $package\n";
+ $errors{$package} = {
+ indexing_warning => "Capitalization of package ($package) does not match filename!",
+ infile => $self->{PMFILE},
+ };
+ }
+ }
+ }
+
+ my $pp = $ppp->{$package};
+ if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error
+ my $err = JSON::PP::decode_json($pp->{version});
+ if ($err->{x_normalize}) {
+ $errors{$package} = {
+ normalize => $err->{version},
+ infile => $pp->{infile},
+ };
+ $pp->{version} = "undef";
+ } elsif ($err->{openerr}) {
+ $pp->{version} = "undef";
+ $self->_verbose(1,
+ qq{Parse::PMFile was not able to
+ read the file. It issued the following error: C< $err->{r} >},
+ );
+ $errors{$package} = {
+ open => $err->{r},
+ infile => $pp->{infile},
+ };
+ } else {
+ $pp->{version} = "undef";
+ $self->_verbose(1,
+ qq{Parse::PMFile was not able to
+ parse the following line in that file: C< $err->{line} >
+
+ Note: the indexer is running in a Safe compartement and cannot
+ provide the full functionality of perl in the VERSION line. It
+ is trying hard, but sometime it fails. As a workaround, please
+ consider writing a META.yml that contains a 'provides'
+ attribute or contact the CPAN admins to investigate (yet
+ another) workaround against "Safe" limitations.)},
+
+ );
+ $errors{$package} = {
+ parse_version => $err->{line},
+ infile => $err->{file},
+ };
+ }
+ }
+
+ # Sanity checks
+
+ for (
+ $package,
+ $pp->{version},
+ ) {
+ if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here
+ delete $ppp->{$package};
+ next; # don't screw up 02packages
+ }
+ }
+ unless ($self->_version_ok($pp)) {
+ $errors{$package} = {
+ long_version => qq{Version string exceeds maximum allowed length of 16b: "$pp->{version}"},
+ infile => $pp->{infile},
+ };
+ next;
+ }
+ $checked_in{$package} = $ppp->{$package};
+ } # end foreach package
+
+ return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in;
+}
+
+sub _version_ok {
+ my ($self, $pp) = @_;
+ return if length($pp->{version} || 0) > 16;
+ return 1
+}
+
+sub _perm_check {
+ my ($self, $package) = @_;
+ my $userid = $self->{USERID};
+ my $module = $self->{PERMISSIONS}->module_permissions($package);
+ return 1 if !$module; # not listed yet
+ return 1 if defined $module->m && $module->m eq $userid;
+ return 1 if defined $module->f && $module->f eq $userid;
+ return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c};
+ return;
+}
+
+# from PAUSE::pmfile;
+sub _parse_version {
+ my $self = shift;
+
+ use strict;
+
+ my $pmfile = $self->{PMFILE};
+ my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000));
+
+ my $pmcp = $pmfile;
+ for ($pmcp) {
+ s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the
+ # solution to escape @s and \
+ }
+ my($v);
+ {
+
+ package main; # seems necessary
+
+ # XXX: do we need to fork as PAUSE does?
+ # or, is alarm() just fine?
+ my $pid;
+ if ($self->{FORK} || $FORK) {
+ $pid = fork();
+ die "Can't fork: $!" unless defined $pid;
+ }
+ if ($pid) {
+ waitpid($pid, 0);
+ if (open my $fh, '<', $tmpfile) {
+ $v = <$fh>;
+ }
+ } else {
+ # XXX Limit Resources too
+
+ my($comp) = Safe->new;
+ my $eval = qq{
+ local(\$^W) = 0;
+ Parse::PMFile::_parse_version_safely("$pmcp");
+ };
+ $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz
+ $comp->share("*Parse::PMFile::_parse_version_safely");
+ $comp->share("*version::new");
+ $comp->share("*version::numify");
+ $comp->share_from('main', ['*version::',
+ '*charstar::',
+ '*Exporter::',
+ '*DynaLoader::']);
+ $comp->share_from('version', ['&qv']);
+ $comp->permit(":base_math"); # atan2 (Acme-Pi)
+ # $comp->permit("require"); # no strict!
+ $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample
+
+ version->import('qv') if $self->{UNSAFE} || $UNSAFE;
+ {
+ no strict;
+ $v = ($self->{UNSAFE} || $UNSAFE) ? eval $eval : $comp->reval($eval);
+ }
+ if ($@){ # still in the child process, out of Safe::reval
+ my $err = $@;
+ # warn ">>>>>>>err[$err]<<<<<<<<";
+ if (ref $err) {
+ if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) {
+ local($^W) = 0;
+ my ($sigil, $vstr) = ($1, $3);
+ $self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/;
+ $v = ($self->{UNSAFE} || $UNSAFE) ? eval $vstr : $comp->reval($vstr);
+ $v = $$v if $sigil eq '*' && ref $v;
+ }
+ if ($@ or !$v) {
+ $self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]",
+ JSON::PP::encode_json($err),
+ $eval,
+ ));
+ $v = JSON::PP::encode_json($err);
+ }
+ } else {
+ $v = JSON::PP::encode_json({ openerr => $err });
+ }
+ }
+ if (defined $v) {
+ no warnings;
+ $v = $v->numify if ref($v) =~ /^version(::vpp)?$/;
+ } else {
+ $v = "";
+ }
+ if ($self->{FORK} || $FORK) {
+ open my $fh, '>:utf8', $tmpfile;
+ print $fh $v;
+ exit 0;
+ } else {
+ utf8::encode($v);
+ # undefine empty $v as if read from the tmpfile
+ $v = undef if defined $v && !length $v;
+ $comp->erase;
+ $self->_restore_overloaded_stuff;
+ }
+ }
+ }
+ unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile;
+
+ return $self->_normalize_version($v);
+}
+
+sub _restore_overloaded_stuff {
+ my ($self, $used_version_in_safe) = @_;
+ return if $self->{UNSAFE} || $UNSAFE;
+
+ no strict 'refs';
+ no warnings 'redefine';
+
+ # version XS in CPAN
+ my $restored;
+ if ($INC{'version/vxs.pm'}) {
+ *{'version::(""'} = \&version::vxs::stringify;
+ *{'version::(0+'} = \&version::vxs::numify;
+ *{'version::(cmp'} = \&version::vxs::VCMP;
+ *{'version::(<=>'} = \&version::vxs::VCMP;
+ *{'version::(bool'} = \&version::vxs::boolean;
+ $restored = 1;
+ }
+ # version PP in CPAN
+ if ($INC{'version/vpp.pm'}) {
+ {
+ package # hide from PAUSE
+ charstar;
+ overload->import;
+ }
+ if (!$used_version_in_safe) {
+ package # hide from PAUSE
+ version::vpp;
+ overload->import;
+ }
+ unless ($restored) {
+ *{'version::(""'} = \&version::vpp::stringify;
+ *{'version::(0+'} = \&version::vpp::numify;
+ *{'version::(cmp'} = \&version::vpp::vcmp;
+ *{'version::(<=>'} = \&version::vpp::vcmp;
+ *{'version::(bool'} = \&version::vpp::vbool;
+ }
+ *{'version::vpp::(""'} = \&version::vpp::stringify;
+ *{'version::vpp::(0+'} = \&version::vpp::numify;
+ *{'version::vpp::(cmp'} = \&version::vpp::vcmp;
+ *{'version::vpp::(<=>'} = \&version::vpp::vcmp;
+ *{'version::vpp::(bool'} = \&version::vpp::vbool;
+ *{'charstar::(""'} = \&charstar::thischar;
+ *{'charstar::(0+'} = \&charstar::thischar;
+ *{'charstar::(++'} = \&charstar::increment;
+ *{'charstar::(--'} = \&charstar::decrement;
+ *{'charstar::(+'} = \&charstar::plus;
+ *{'charstar::(-'} = \&charstar::minus;
+ *{'charstar::(*'} = \&charstar::multiply;
+ *{'charstar::(cmp'} = \&charstar::cmp;
+ *{'charstar::(<=>'} = \&charstar::spaceship;
+ *{'charstar::(bool'} = \&charstar::thischar;
+ *{'charstar::(='} = \&charstar::clone;
+ $restored = 1;
+ }
+ # version in core
+ if (!$restored) {
+ *{'version::(""'} = \&version::stringify;
+ *{'version::(0+'} = \&version::numify;
+ *{'version::(cmp'} = \&version::vcmp;
+ *{'version::(<=>'} = \&version::vcmp;
+ *{'version::(bool'} = \&version::boolean;
+ }
+}
+
+# from PAUSE::pmfile;
+sub _packages_per_pmfile {
+ my $self = shift;
+
+ my $ppp = {};
+ my $pmfile = $self->{PMFILE};
+ my $filemtime = $self->{MTIME};
+ my $version = $self->{VERSION};
+
+ open my $fh, "<", "$pmfile" or return $ppp;
+
+ local $/ = "\n";
+ my $inpod = 0;
+
+ PLINE: while (<$fh>) {
+ chomp;
+ my($pline) = $_;
+ $inpod = $pline =~ /^=(?!cut)/ ? 1 :
+ $pline =~ /^=cut/ ? 0 : $inpod;
+ next if $inpod;
+ next if substr($pline,0,4) eq "=cut";
+
+ $pline =~ s/\#.*//;
+ next if $pline =~ /^\s*$/;
+ if ($pline =~ /^__(?:END|DATA)__\b/
+ and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__
+ ){
+ last PLINE;
+ }
+
+ my $pkg;
+ my $strict_version;
+
+ if (
+ $pline =~ m{
+ # (.*) # takes too much time if $pline is long
+ #(?<![*\$\\@%&]) # no sigils
+ ^[\s\{;]*
+ \bpackage\s+
+ ([\w\:\']+)
+ \s*
+ (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
+ }x) {
+ $pkg = $1;
+ $strict_version = $2;
+ if ($pkg eq "DB"){
+ # XXX if pumpkin and perl make him comaintainer! I
+ # think I always made the pumpkins comaint on DB
+ # without further ado (?)
+ next PLINE;
+ }
+ }
+
+ if ($pkg) {
+ # Found something
+
+ # from package
+ $pkg =~ s/\'/::/g;
+ next PLINE unless $pkg =~ /^[A-Za-z]/;
+ next PLINE unless $pkg =~ /\w$/;
+ next PLINE if $pkg eq "main";
+ # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
+ # database for modid in mods, package in packages, package in perms
+ # alter table mods modify modid varchar(128) binary NOT NULL default '';
+ # alter table packages modify package varchar(128) binary NOT NULL default '';
+ next PLINE if length($pkg) > 128;
+ #restriction
+ $ppp->{$pkg}{parsed}++;
+ $ppp->{$pkg}{infile} = $pmfile;
+ if ($self->_simile($pmfile,$pkg)) {
+ $ppp->{$pkg}{simile} = $pmfile;
+ if ($self->_version_from_meta_ok) {
+ my $provides = $self->{META_CONTENT}{provides};
+ if (exists $provides->{$pkg}) {
+ if (defined $provides->{$pkg}{version}) {
+ my $v = $provides->{$pkg}{version};
+ if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!"
+ next PLINE;
+ }
+
+ unless (eval { $version = $self->_normalize_version($v); 1 }) {
+ $self->_verbose(1, "error with version in $pmfile: $@");
+ next;
+
+ }
+ $ppp->{$pkg}{version} = $version;
+ } else {
+ $ppp->{$pkg}{version} = "undef";
+ }
+ }
+ } else {
+ if (defined $strict_version){
+ $ppp->{$pkg}{version} = $strict_version ;
+ } else {
+ $ppp->{$pkg}{version} = defined $version ? $version : "";
+ }
+ no warnings;
+ if ($version eq 'undef') {
+ $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version};
+ } else {
+ $ppp->{$pkg}{version} =
+ $version
+ if $version
+ > $ppp->{$pkg}{version} ||
+ $version
+ gt $ppp->{$pkg}{version};
+ }
+ }
+ } else { # not simile
+ #### it comes later, it would be nonsense
+ #### to set to "undef". MM_Unix gives us
+ #### the best we can reasonably consider
+ $ppp->{$pkg}{version} =
+ $version
+ unless defined $ppp->{$pkg}{version} &&
+ length($ppp->{$pkg}{version});
+ }
+ $ppp->{$pkg}{filemtime} = $filemtime;
+ } else {
+ # $self->_verbose(2,"no pkg found");
+ }
+ }
+
+ close $fh;
+ $ppp;
+}
+
+# from PAUSE::pmfile;
+{
+ no strict;
+ sub _parse_version_safely {
+ my($parsefile) = @_;
+ my $result;
+ local *FH;
+ local $/ = "\n";
+ open(FH,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ while (<FH>) {
+ $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
+ next if $inpod || /^\s*#/;
+ last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer
+ chop;
+
+ if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) {
+ # XXX: should handle this better if version is bogus -- rjbs,
+ # 2014-03-16
+ return $ver if version::is_lax($ver);
+ }
+
+ # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
+ next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;
+ my $current_parsed_line = $_;
+ my $eval = qq{
+ package #
+ ExtUtils::MakeMaker::_version;
+
+ local $1$2;
+ \$$2=undef; do {
+ $_
+ }; \$$2
+ };
+ local $^W = 0;
+ local $SIG{__WARN__} = sub {};
+ $result = __clean_eval($eval);
+ # warn "current_parsed_line[$current_parsed_line]\$\@[$@]";
+ if ($@ or !defined $result){
+ die +{
+ eval => $eval,
+ line => $current_parsed_line,
+ file => $parsefile,
+ err => $@,
+ };
+ }
+ last;
+ } #;
+ close FH;
+
+ $result = "undef" unless defined $result;
+ if ((ref $result) =~ /^version(?:::vpp)?\b/) {
+ no warnings;
+ $result = $result->numify;
+ }
+ return $result;
+ }
+}
+
+# from PAUSE::pmfile;
+sub _filter_ppps {
+ my($self,@ppps) = @_;
+ my @res;
+
+ # very similar code is in PAUSE::dist::filter_pms
+ MANI: for my $ppp ( @ppps ) {
+ if ($self->{META_CONTENT}){
+ my $no_index = $self->{META_CONTENT}{no_index}
+ || $self->{META_CONTENT}{private}; # backward compat
+ if (ref($no_index) eq 'HASH') {
+ my %map = (
+ package => qr{\z},
+ namespace => qr{::},
+ );
+ for my $k (qw(package namespace)) {
+ next unless my $v = $no_index->{$k};
+ my $rest = $map{$k};
+ if (ref $v eq "ARRAY") {
+ for my $ve (@$v) {
+ $ve =~ s|::$||;
+ if ($ppp =~ /^$ve$rest/){
+ $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");
+ next MANI;
+ } else {
+ $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]");
+ }
+ }
+ } else {
+ $v =~ s|::$||;
+ if ($ppp =~ /^$v$rest/){
+ $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");
+ next MANI;
+ } else {
+ $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]");
+ }
+ }
+ }
+ } else {
+ $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT");
+ }
+ } else {
+ # $self->_verbose(1,"no META_CONTENT"); # too noisy
+ }
+ push @res, $ppp;
+ }
+ $self->_verbose(1,"Result of filter_ppps: res[@res]");
+ @res;
+}
+
+# from PAUSE::pmfile;
+sub _simile {
+ my($self,$file,$package) = @_;
+ # MakeMaker gives them the chance to have the file Simple.pm in
+ # this directory but have the package HTML::Simple in it.
+ # Afaik, they wouldn't be able to do so with deeper nested packages
+ $file =~ s|.*/||;
+ $file =~ s|\.pm(?:\.PL)?||;
+ my $ret = $package =~ m/\b\Q$file\E$/;
+ $ret ||= 0;
+ unless ($ret) {
+ # Apache::mod_perl_guide stuffs it into Version.pm
+ $ret = 1 if lc $file eq 'version';
+ }
+ $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");
+ $ret;
+}
+
+# from PAUSE::pmfile
+sub _normalize_version {
+ my($self,$v) = @_;
+ $v = "undef" unless defined $v;
+ my $dv = Dumpvalue->new;
+ my $sdv = $dv->stringify($v,1); # second argument prevents ticks
+ $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");
+
+ return $v if $v eq "undef";
+ return $v if $v =~ /^\{.*\}$/; # JSON object
+ $v =~ s/^\s+//;
+ $v =~ s/\s+\z//;
+ if ($v =~ /_/) {
+ # XXX should pass something like EDEVELOPERRELEASE up e.g.
+ # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one
+ # such modules and the mesage was not helpful that "nothing
+ # was found".
+ return $v ;
+ }
+ if (!version::is_lax($v)) {
+ return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v });
+ }
+ # may warn "Integer overflow"
+ my $vv = eval { no warnings; version->new($v)->numify };
+ if ($@) {
+ # warn "$v: $@";
+ return JSON::PP::encode_json({ x_normalize => $@, version => $v });
+ # return "undef";
+ }
+ if ($vv eq $v) {
+ # the boring 3.14
+ } else {
+ my $forced = $self->_force_numeric($v);
+ if ($forced eq $vv) {
+ } elsif ($forced =~ /^v(.+)/) {
+ # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz)
+ no warnings;
+ $vv = version->new($1)->numify;
+ } else {
+ # warn "Unequal forced[$forced] and vv[$vv]";
+ if ($forced == $vv) {
+ # the trailing zeroes would cause unnecessary havoc
+ $vv = $forced;
+ }
+ }
+ }
+ return $vv;
+}
+
+# from PAUSE::pmfile;
+sub _force_numeric {
+ my($self,$v) = @_;
+ $v = $self->_readable($v);
+
+ if (
+ $v =~
+ /^(\+?)(\d*)(\.(\d*))?/ &&
+ # "$2$4" ne ''
+ (
+ defined $2 && length $2
+ ||
+ defined $4 && length $4
+ )
+ ) {
+ my $two = defined $2 ? $2 : "";
+ my $three = defined $3 ? $3 : "";
+ $v = "$two$three";
+ }
+ # no else branch! We simply say, everything else is a string.
+ $v;
+}
+
+# from PAUSE::dist
+sub _version_from_meta_ok {
+ my($self) = @_;
+ return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK};
+ my $c = $self->{META_CONTENT};
+
+ # If there's no provides hash, we can't get our module versions from the
+ # provides hash! -- rjbs, 2012-03-31
+ return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides};
+
+ # Some versions of Module::Build geneated an empty provides hash. If we're
+ # *not* looking at a Module::Build-generated metafile, then it's okay.
+ my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/;
+ return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v;
+
+ # ??? I don't know why this is here.
+ return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0';
+
+ if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) {
+ # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron
+ # did not find the reason why this happened, but let's not go
+ # overboard, 0.26 seems a good threshold from the statistics: there
+ # are not many empty provides hashes from 0.26 up.
+ return($self->{VERSION_FROM_META_OK} = 0);
+ }
+
+ # We're not in the suspect range of M::B versions. It's good to go.
+ return($self->{VERSION_FROM_META_OK} = 1);
+}
+
+sub _verbose {
+ my($self,$level,@what) = @_;
+ warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE);
+}
+
+# all of the following methods are stripped from CPAN::Version
+# (as of version 5.5001, bundled in CPAN 2.03), and slightly
+# modified (ie. made private, as well as CPAN->debug(...) are
+# replaced with $self->_verbose(9, ...).)
+
+# CPAN::Version::vcmp courtesy Jost Krieger
+sub _vcmp {
+ my($self,$l,$r) = @_;
+ local($^W) = 0;
+ $self->_verbose(9, "l[$l] r[$r]");
+
+ return 0 if $l eq $r; # short circuit for quicker success
+
+ for ($l,$r) {
+ s/_//g;
+ }
+ $self->_verbose(9, "l[$l] r[$r]");
+ for ($l,$r) {
+ next unless tr/.// > 1 || /^v/;
+ s/^v?/v/;
+ 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
+ }
+ $self->_verbose(9, "l[$l] r[$r]");
+ if ($l=~/^v/ <=> $r=~/^v/) {
+ for ($l,$r) {
+ next if /^v/;
+ $_ = $self->_float2vv($_);
+ }
+ }
+ $self->_verbose(9, "l[$l] r[$r]");
+ my $lvstring = "v0";
+ my $rvstring = "v0";
+ if ($] >= 5.006
+ && $l =~ /^v/
+ && $r =~ /^v/) {
+ $lvstring = $self->_vstring($l);
+ $rvstring = $self->_vstring($r);
+ $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring);
+ }
+
+ return (
+ ($l ne "undef") <=> ($r ne "undef")
+ ||
+ $lvstring cmp $rvstring
+ ||
+ $l <=> $r
+ ||
+ $l cmp $r
+ );
+}
+
+sub _vgt {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) > 0;
+}
+
+sub _vlt {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) < 0;
+}
+
+sub _vge {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) >= 0;
+}
+
+sub _vle {
+ my($self,$l,$r) = @_;
+ $self->_vcmp($l,$r) <= 0;
+}
+
+sub _vstring {
+ my($self,$n) = @_;
+ $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";
+ pack "U*", split /\./, $n;
+}
+
+# vv => visible vstring
+sub _float2vv {
+ my($self,$n) = @_;
+ my($rev) = int($n);
+ $rev ||= 0;
+ my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
+ # architecture influence
+ $mantissa ||= 0;
+ $mantissa .= "0" while length($mantissa)%3;
+ my $ret = "v" . $rev;
+ while ($mantissa) {
+ $mantissa =~ s/(\d{1,3})// or
+ die "Panic: length>0 but not a digit? mantissa[$mantissa]";
+ $ret .= ".".int($1);
+ }
+ # warn "n[$n]ret[$ret]";
+ $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
+ $ret;
+}
+
+sub _readable {
+ my($self,$n) = @_;
+ $n =~ /^([\w\-\+\.]+)/;
+
+ return $1 if defined $1 && length($1)>0;
+ # if the first user reaches version v43, he will be treated as "+".
+ # We'll have to decide about a new rule here then, depending on what
+ # will be the prevailing versioning behavior then.
+
+ if ($] < 5.006) { # or whenever v-strings were introduced
+ # we get them wrong anyway, whatever we do, because 5.005 will
+ # have already interpreted 0.2.4 to be "0.24". So even if he
+ # indexer sends us something like "v0.2.4" we compare wrongly.
+
+ # And if they say v1.2, then the old perl takes it as "v12"
+
+ $self->_verbose(9, "Suspicious version string seen [$n]\n");
+ return $n;
+ }
+ my $better = sprintf "v%vd", $n;
+ $self->_verbose(9, "n[$n] better[$better]");
+ return $better;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Parse::PMFile - parses .pm file as PAUSE does
+
+=head1 SYNOPSIS
+
+ use Parse::PMFile;
+
+ my $parser = Parse::PMFile->new($metadata, {VERBOSE => 1});
+ my $packages_info = $parser->parse($pmfile);
+
+ # if you need info about invalid versions
+ my ($packages_info, $errors) = $parser->parse($pmfile);
+
+ # to check permissions
+ my $parser = Parse::PMFile->new($metadata, {
+ USERID => 'ISHIGAKI',
+ PERMISSIONS => PAUSE::Permissions->new,
+ });
+
+=head1 DESCRIPTION
+
+The most of the code of this module is taken from the PAUSE code as of April 2013 almost verbatim. Thus, the heart of this module should be quite stable. However, I made it not to use pipe ("-|") as well as I stripped database-related code. If you encounter any issue, that's most probably because of my modification.
+
+This module doesn't provide features to extract a distribution or parse meta files intentionally.
+
+=head1 METHODS
+
+=head2 new
+
+creates an object. You can also pass a hashref taken from META.yml etc, and an optional hashref. Options are:
+
+=over 4
+
+=item ALLOW_DEV_VERSION
+
+Parse::PMFile usually ignores a version with an underscore as PAUSE does (because it's for a developer release, and should not be indexed). Set this option to true if you happen to need to keep such a version for better analysis.
+
+=item VERBOSE
+
+Set this to true if you need to know some details.
+
+=item FORK
+
+As of version 0.17, Parse::PMFile stops forking while parsing a version for better performance. Parse::PMFile should return the same result no matter how this option is set, but if you do care, set this to true to fork as PAUSE does.
+
+=item USERID, PERMISSIONS
+
+As of version 0.21, Parse::PMFile checks permissions of a package if both USERID and PERMISSIONS (which should be an instance of L<PAUSE::Permissions>) are provided. Unauthorized packages are removed.
+
+=item UNSAFE
+
+Parse::PMFile usually parses a module version in a Safe compartment. However, this approach doesn't work smoothly under older perls (prior to 5.10) plus some combinations of recent versions of Safe.pm (2.24 and above) and version.pm (0.9905 and above) for various reasons. As of version 0.27, Parse::PMFile simply uses C<eval> to parse a version under older perls. If you want it to use always C<eval> (even under recent perls), set this to true.
+
+=back
+
+=head2 parse
+
+takes a path to a .pm file, and returns a hash reference that holds information for package(s) found in the file.
+
+=head1 SEE ALSO
+
+L<Parse::LocalDistribution>, L<PAUSE::Permissions>
+
+Most part of this module is derived from PAUSE and CPAN::Version.
+
+L<https://github.com/andk/pause>
+
+L<https://github.com/andk/cpanpm>
+
+=head1 AUTHOR
+
+Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
+
+Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> for most of the code.
+
+Copyright 2013 by Kenichi Ishigaki for some.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+use 5.008001;
+use strict;
+use warnings;
+
+package Path::Tiny;
+# ABSTRACT: File path utility
+
+our $VERSION = '0.114';
+
+# Dependencies
+use Config;
+use Exporter 5.57 (qw/import/);
+use File::Spec 0.86 (); # shipped with 5.8.1
+use Carp ();
+
+our @EXPORT = qw/path/;
+our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/;
+
+use constant {
+ PATH => 0,
+ CANON => 1,
+ VOL => 2,
+ DIR => 3,
+ FILE => 4,
+ TEMP => 5,
+ IS_WIN32 => ( $^O eq 'MSWin32' ),
+};
+
+use overload (
+ q{""} => sub { $_[0]->[PATH] },
+ bool => sub () { 1 },
+ fallback => 1,
+);
+
+# FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol
+sub FREEZE { return $_[0]->[PATH] }
+sub THAW { return path( $_[2] ) }
+{ no warnings 'once'; *TO_JSON = *FREEZE };
+
+my $HAS_UU; # has Unicode::UTF8; lazily populated
+
+sub _check_UU {
+ local $SIG{__DIE__}; # prevent outer handler from being called
+ !!eval {
+ require Unicode::UTF8;
+ Unicode::UTF8->VERSION(0.58);
+ 1;
+ };
+}
+
+my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
+
+sub _check_PU {
+ local $SIG{__DIE__}; # prevent outer handler from being called
+ !!eval {
+ # MUST preload Encode or $SIG{__DIE__} localization fails
+ # on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2.
+ require Encode;
+ require PerlIO::utf8_strict;
+ PerlIO::utf8_strict->VERSION(0.003);
+ 1;
+ };
+}
+
+my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
+
+# notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \
+my $SLASH = qr{[\\/]};
+my $NOTSLASH = qr{[^\\/]};
+my $DRV_VOL = qr{[a-z]:}i;
+my $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x;
+my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x;
+
+sub _win32_vol {
+ my ( $path, $drv ) = @_;
+ require Cwd;
+ my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd
+ # getdcwd on non-existent drive returns empty string
+ # so just use the original drive Z: -> Z:
+ $dcwd = "$drv" unless defined $dcwd && length $dcwd;
+ # normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z:
+ $dcwd =~ s{$SLASH?\z}{/};
+ # make the path absolute with dcwd
+ $path =~ s{^$DRV_VOL}{$dcwd};
+ return $path;
+}
+
+# This is a string test for before we have the object; see is_rootdir for well-formed
+# object test
+sub _is_root {
+ return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' );
+}
+
+BEGIN {
+ *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] };
+}
+
+# mode bits encoded for chmod in symbolic mode
+my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic
+{ my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ };
+
+sub _symbolic_chmod {
+ my ( $mode, $symbolic ) = @_;
+ for my $clause ( split /,\s*/, $symbolic ) {
+ if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) {
+ my ( $who, $action, $perms ) = ( $1, $2, $3 );
+ $who =~ s/a/ugo/g;
+ for my $w ( split //, $who ) {
+ my $p = 0;
+ $p |= $MODEBITS{"$w$_"} for split //, $perms;
+ if ( $action eq '=' ) {
+ $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p;
+ }
+ else {
+ $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p );
+ }
+ }
+ }
+ else {
+ Carp::croak("Invalid mode clause '$clause' for chmod()");
+ }
+ }
+ return $mode;
+}
+
+# flock doesn't work on NFS on BSD or on some filesystems like lustre.
+# Since program authors often can't control or detect that, we warn once
+# instead of being fatal if we can detect it and people who need it strict
+# can fatalize the 'flock' category
+
+#<<< No perltidy
+{ package flock; use warnings::register }
+#>>>
+
+my $WARNED_NO_FLOCK = 0;
+
+sub _throw {
+ my ( $self, $function, $file, $msg ) = @_;
+ if ( $function =~ /^flock/
+ && $! =~ /operation not supported|function not implemented/i
+ && !warnings::fatal_enabled('flock') )
+ {
+ if ( !$WARNED_NO_FLOCK ) {
+ warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
+ $WARNED_NO_FLOCK++;
+ }
+ }
+ else {
+ $msg = $! unless defined $msg;
+ Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ),
+ $msg );
+ }
+ return;
+}
+
+# cheapo option validation
+sub _get_args {
+ my ( $raw, @valid ) = @_;
+ if ( defined($raw) && ref($raw) ne 'HASH' ) {
+ my ( undef, undef, undef, $called_as ) = caller(1);
+ $called_as =~ s{^.*::}{};
+ Carp::croak("Options for $called_as must be a hash reference");
+ }
+ my $cooked = {};
+ for my $k (@valid) {
+ $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k};
+ }
+ if ( keys %$raw ) {
+ my ( undef, undef, undef, $called_as ) = caller(1);
+ $called_as =~ s{^.*::}{};
+ Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) );
+ }
+ return $cooked;
+}
+
+#--------------------------------------------------------------------------#
+# Constructors
+#--------------------------------------------------------------------------#
+
+#pod =construct path
+#pod
+#pod $path = path("foo/bar");
+#pod $path = path("/tmp", "file.txt"); # list
+#pod $path = path("."); # cwd
+#pod $path = path("~user/file.txt"); # tilde processing
+#pod
+#pod Constructs a C<Path::Tiny> object. It doesn't matter if you give a file or
+#pod directory path. It's still up to you to call directory-like methods only on
+#pod directories and file-like methods only on files. This function is exported
+#pod automatically by default.
+#pod
+#pod The first argument must be defined and have non-zero length or an exception
+#pod will be thrown. This prevents subtle, dangerous errors with code like
+#pod C<< path( maybe_undef() )->remove_tree >>.
+#pod
+#pod If the first component of the path is a tilde ('~') then the component will be
+#pod replaced with the output of C<glob('~')>. If the first component of the path
+#pod is a tilde followed by a user name then the component will be replaced with
+#pod output of C<glob('~username')>. Behaviour for non-existent users depends on
+#pod the output of C<glob> on the system.
+#pod
+#pod On Windows, if the path consists of a drive identifier without a path component
+#pod (C<C:> or C<D:>), it will be expanded to the absolute path of the current
+#pod directory on that volume using C<Cwd::getdcwd()>.
+#pod
+#pod If called with a single C<Path::Tiny> argument, the original is returned unless
+#pod the original is holding a temporary file or directory reference in which case a
+#pod stringified copy is made.
+#pod
+#pod $path = path("foo/bar");
+#pod $temp = Path::Tiny->tempfile;
+#pod
+#pod $p2 = path($path); # like $p2 = $path
+#pod $t2 = path($temp); # like $t2 = path( "$temp" )
+#pod
+#pod This optimizes copies without proliferating references unexpectedly if a copy is
+#pod made by code outside your control.
+#pod
+#pod Current API available since 0.017.
+#pod
+#pod =cut
+
+sub path {
+ my $path = shift;
+ Carp::croak("Path::Tiny paths require defined, positive-length parts")
+ unless 1 + @_ == grep { defined && length } $path, @_;
+
+ # non-temp Path::Tiny objects are effectively immutable and can be reused
+ if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) {
+ return $path;
+ }
+
+ # stringify objects
+ $path = "$path";
+
+ # expand relative volume paths on windows; put trailing slash on UNC root
+ if ( IS_WIN32() ) {
+ $path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH|\z)};
+ $path .= "/" if $path =~ m{^$UNC_VOL\z};
+ }
+
+ # concatenations stringifies objects, too
+ if (@_) {
+ $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ );
+ }
+
+ # canonicalize, but with unix slashes and put back trailing volume slash
+ my $cpath = $path = File::Spec->canonpath($path);
+ $path =~ tr[\\][/] if IS_WIN32();
+ $path = "/" if $path eq '/..'; # for old File::Spec
+ $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z};
+
+ # root paths must always have a trailing slash, but other paths must not
+ if ( _is_root($path) ) {
+ $path =~ s{/?\z}{/};
+ }
+ else {
+ $path =~ s{/\z}{};
+ }
+
+ # do any tilde expansions
+ if ( $path =~ m{^(~[^/]*).*} ) {
+ require File::Glob;
+ my ($homedir) = File::Glob::bsd_glob($1);
+ $homedir =~ tr[\\][/] if IS_WIN32();
+ $path =~ s{^(~[^/]*)}{$homedir};
+ }
+
+ bless [ $path, $cpath ], __PACKAGE__;
+}
+
+#pod =construct new
+#pod
+#pod $path = Path::Tiny->new("foo/bar");
+#pod
+#pod This is just like C<path>, but with method call overhead. (Why would you
+#pod do that?)
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub new { shift; path(@_) }
+
+#pod =construct cwd
+#pod
+#pod $path = Path::Tiny->cwd; # path( Cwd::getcwd )
+#pod $path = cwd; # optional export
+#pod
+#pod Gives you the absolute path to the current directory as a C<Path::Tiny> object.
+#pod This is slightly faster than C<< path(".")->absolute >>.
+#pod
+#pod C<cwd> may be exported on request and used as a function instead of as a
+#pod method.
+#pod
+#pod Current API available since 0.018.
+#pod
+#pod =cut
+
+sub cwd {
+ require Cwd;
+ return path( Cwd::getcwd() );
+}
+
+#pod =construct rootdir
+#pod
+#pod $path = Path::Tiny->rootdir; # /
+#pod $path = rootdir; # optional export
+#pod
+#pod Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too
+#pod picky for C<path("/")>.
+#pod
+#pod C<rootdir> may be exported on request and used as a function instead of as a
+#pod method.
+#pod
+#pod Current API available since 0.018.
+#pod
+#pod =cut
+
+sub rootdir { path( File::Spec->rootdir ) }
+
+#pod =construct tempfile, tempdir
+#pod
+#pod $temp = Path::Tiny->tempfile( @options );
+#pod $temp = Path::Tiny->tempdir( @options );
+#pod $temp = tempfile( @options ); # optional export
+#pod $temp = tempdir( @options ); # optional export
+#pod
+#pod C<tempfile> passes the options to C<< File::Temp->new >> and returns a C<Path::Tiny>
+#pod object with the file name. The C<TMPDIR> option is enabled by default.
+#pod
+#pod The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
+#pod destroyed, the C<File::Temp> object will be as well.
+#pod
+#pod C<File::Temp> annoyingly requires you to specify a custom template in slightly
+#pod different ways depending on which function or method you call, but
+#pod C<Path::Tiny> lets you ignore that and can take either a leading template or a
+#pod C<TEMPLATE> option and does the right thing.
+#pod
+#pod $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok
+#pod $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
+#pod
+#pod The tempfile path object will be normalized to have an absolute path, even if
+#pod created in a relative directory using C<DIR>. If you want it to have
+#pod the C<realpath> instead, pass a leading options hash like this:
+#pod
+#pod $real_temp = tempfile({realpath => 1}, @options);
+#pod
+#pod C<tempdir> is just like C<tempfile>, except it calls
+#pod C<< File::Temp->newdir >> instead.
+#pod
+#pod Both C<tempfile> and C<tempdir> may be exported on request and used as
+#pod functions instead of as methods.
+#pod
+#pod B<Note>: for tempfiles, the filehandles from File::Temp are closed and not
+#pod reused. This is not as secure as using File::Temp handles directly, but is
+#pod less prone to deadlocks or access problems on some platforms. Think of what
+#pod C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
+#pod up.
+#pod
+#pod B<Note 2>: if you don't want these cleaned up automatically when the object
+#pod is destroyed, File::Temp requires different options for directories and
+#pod files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
+#pod files.
+#pod
+#pod B<Note 3>: Don't lose the temporary object by chaining a method call instead
+#pod of storing it:
+#pod
+#pod my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
+#pod
+#pod B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
+#pod Keeping a reference to, or modifying the cached object may break the
+#pod behavior documented above and is not supported. Use at your own risk.
+#pod
+#pod Current API available since 0.097.
+#pod
+#pod =cut
+
+sub tempfile {
+ shift if @_ && $_[0] eq 'Path::Tiny'; # called as method
+ my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
+ $opts = _get_args( $opts, qw/realpath/ );
+
+ my ( $maybe_template, $args ) = _parse_file_temp_args(@_);
+ # File::Temp->new demands TEMPLATE
+ $args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template;
+
+ require File::Temp;
+ my $temp = File::Temp->new( TMPDIR => 1, %$args );
+ close $temp;
+ my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute;
+ $self->[TEMP] = $temp; # keep object alive while we are
+ return $self;
+}
+
+sub tempdir {
+ shift if @_ && $_[0] eq 'Path::Tiny'; # called as method
+ my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {};
+ $opts = _get_args( $opts, qw/realpath/ );
+
+ my ( $maybe_template, $args ) = _parse_file_temp_args(@_);
+
+ # File::Temp->newdir demands leading template
+ require File::Temp;
+ my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args );
+ my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute;
+ $self->[TEMP] = $temp; # keep object alive while we are
+ # Some ActiveState Perls for Windows break Cwd in ways that lead
+ # File::Temp to get confused about what path to remove; this
+ # monkey-patches the object with our own view of the absolute path
+ $temp->{REALNAME} = $self->[CANON] if IS_WIN32;
+ return $self;
+}
+
+# normalize the various ways File::Temp does templates
+sub _parse_file_temp_args {
+ my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' );
+ my %args = @_;
+ %args = map { uc($_), $args{$_} } keys %args;
+ my @template = (
+ exists $args{TEMPLATE} ? delete $args{TEMPLATE}
+ : $leading_template ? $leading_template
+ : ()
+ );
+ return ( \@template, \%args );
+}
+
+#--------------------------------------------------------------------------#
+# Private methods
+#--------------------------------------------------------------------------#
+
+sub _splitpath {
+ my ($self) = @_;
+ @{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] );
+}
+
+sub _resolve_symlinks {
+ my ($self) = @_;
+ my $new = $self;
+ my ( $count, %seen ) = 0;
+ while ( -l $new->[PATH] ) {
+ if ( $seen{ $new->[PATH] }++ ) {
+ $self->_throw( 'readlink', $self->[PATH], "symlink loop detected" );
+ }
+ if ( ++$count > 100 ) {
+ $self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" );
+ }
+ my $resolved = readlink $new->[PATH] or $new->_throw( 'readlink', $new->[PATH] );
+ $resolved = path($resolved);
+ $new = $resolved->is_absolute ? $resolved : $new->sibling($resolved);
+ }
+ return $new;
+}
+
+#--------------------------------------------------------------------------#
+# Public methods
+#--------------------------------------------------------------------------#
+
+#pod =method absolute
+#pod
+#pod $abs = path("foo/bar")->absolute;
+#pod $abs = path("foo/bar")->absolute("/tmp");
+#pod
+#pod Returns a new C<Path::Tiny> object with an absolute path (or itself if already
+#pod absolute). If no argument is given, the current directory is used as the
+#pod absolute base path. If an argument is given, it will be converted to an
+#pod absolute path (if it is not already) and used as the absolute base path.
+#pod
+#pod This will not resolve upward directories ("foo/../bar") unless C<canonpath>
+#pod in L<File::Spec> would normally do so on your platform. If you need them
+#pod resolved, you must call the more expensive C<realpath> method instead.
+#pod
+#pod On Windows, an absolute path without a volume component will have it added
+#pod based on the current drive.
+#pod
+#pod Current API available since 0.101.
+#pod
+#pod =cut
+
+sub absolute {
+ my ( $self, $base ) = @_;
+
+ # absolute paths handled differently by OS
+ if (IS_WIN32) {
+ return $self if length $self->volume;
+ # add missing volume
+ if ( $self->is_absolute ) {
+ require Cwd;
+ # use Win32::GetCwd not Cwd::getdcwd because we're sure
+ # to have the former but not necessarily the latter
+ my ($drv) = Win32::GetCwd() =~ /^($DRV_VOL | $UNC_VOL)/x;
+ return path( $drv . $self->[PATH] );
+ }
+ }
+ else {
+ return $self if $self->is_absolute;
+ }
+
+ # no base means use current directory as base
+ require Cwd;
+ return path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base;
+
+ # relative base should be made absolute; we check is_absolute rather
+ # than unconditionally make base absolute so that "/foo" doesn't become
+ # "C:/foo" on Windows.
+ $base = path($base);
+ return path( ( $base->is_absolute ? $base : $base->absolute ), $_[0]->[PATH] );
+}
+
+#pod =method append, append_raw, append_utf8
+#pod
+#pod path("foo.txt")->append(@data);
+#pod path("foo.txt")->append(\@data);
+#pod path("foo.txt")->append({binmode => ":raw"}, @data);
+#pod path("foo.txt")->append_raw(@data);
+#pod path("foo.txt")->append_utf8(@data);
+#pod
+#pod Appends data to a file. The file is locked with C<flock> prior to writing
+#pod and closed afterwards. An optional hash reference may be used to pass
+#pod options. Valid options are:
+#pod
+#pod =for :list
+#pod * C<binmode>: passed to C<binmode()> on the handle used for writing.
+#pod * C<truncate>: truncates the file after locking and before appending
+#pod
+#pod The C<truncate> option is a way to replace the contents of a file
+#pod B<in place>, unlike L</spew> which writes to a temporary file and then
+#pod replaces the original (if it exists).
+#pod
+#pod C<append_raw> is like C<append> with a C<binmode> of C<:unix> for fast,
+#pod unbuffered, raw write.
+#pod
+#pod C<append_utf8> is like C<append> with a C<binmode> of
+#pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+#pod 0.58+ is installed, a raw append will be done instead on the data encoded
+#pod with C<Unicode::UTF8>.
+#pod
+#pod Current API available since 0.060.
+#pod
+#pod =cut
+
+sub append {
+ my ( $self, @data ) = @_;
+ my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
+ $args = _get_args( $args, qw/binmode truncate/ );
+ my $binmode = $args->{binmode};
+ $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
+ my $mode = $args->{truncate} ? ">" : ">>";
+ my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode );
+ print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data;
+ close $fh or $self->_throw('close');
+}
+
+sub append_raw {
+ my ( $self, @data ) = @_;
+ my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
+ $args = _get_args( $args, qw/binmode truncate/ );
+ $args->{binmode} = ':unix';
+ append( $self, $args, @data );
+}
+
+sub append_utf8 {
+ my ( $self, @data ) = @_;
+ my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
+ $args = _get_args( $args, qw/binmode truncate/ );
+ if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
+ $args->{binmode} = ":unix";
+ append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data );
+ }
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ $args->{binmode} = ":unix:utf8_strict";
+ append( $self, $args, @data );
+ }
+ else {
+ $args->{binmode} = ":unix:encoding(UTF-8)";
+ append( $self, $args, @data );
+ }
+}
+
+#pod =method assert
+#pod
+#pod $path = path("foo.txt")->assert( sub { $_->exists } );
+#pod
+#pod Returns the invocant after asserting that a code reference argument returns
+#pod true. When the assertion code reference runs, it will have the invocant
+#pod object in the C<$_> variable. If it returns false, an exception will be
+#pod thrown. The assertion code reference may also throw its own exception.
+#pod
+#pod If no assertion is provided, the invocant is returned without error.
+#pod
+#pod Current API available since 0.062.
+#pod
+#pod =cut
+
+sub assert {
+ my ( $self, $assertion ) = @_;
+ return $self unless $assertion;
+ if ( ref $assertion eq 'CODE' ) {
+ local $_ = $self;
+ $assertion->()
+ or Path::Tiny::Error->throw( "assert", $self->[PATH], "failed assertion" );
+ }
+ else {
+ Carp::croak("argument to assert must be a code reference argument");
+ }
+ return $self;
+}
+
+#pod =method basename
+#pod
+#pod $name = path("foo/bar.txt")->basename; # bar.txt
+#pod $name = path("foo.txt")->basename('.txt'); # foo
+#pod $name = path("foo.txt")->basename(qr/.txt/); # foo
+#pod $name = path("foo.txt")->basename(@suffixes);
+#pod
+#pod Returns the file portion or last directory portion of a path.
+#pod
+#pod Given a list of suffixes as strings or regular expressions, any that match at
+#pod the end of the file portion or last directory portion will be removed before
+#pod the result is returned.
+#pod
+#pod Current API available since 0.054.
+#pod
+#pod =cut
+
+sub basename {
+ my ( $self, @suffixes ) = @_;
+ $self->_splitpath unless defined $self->[FILE];
+ my $file = $self->[FILE];
+ for my $s (@suffixes) {
+ my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/;
+ last if $file =~ s/$re//;
+ }
+ return $file;
+}
+
+#pod =method canonpath
+#pod
+#pod $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
+#pod
+#pod Returns a string with the canonical format of the path name for
+#pod the platform. In particular, this means directory separators
+#pod will be C<\> on Windows.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub canonpath { $_[0]->[CANON] }
+
+#pod =method cached_temp
+#pod
+#pod Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
+#pod C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
+#pod If there is no such object, this method throws.
+#pod
+#pod B<WARNING>: Keeping a reference to, or modifying the cached object may
+#pod break the behavior documented for temporary files and directories created
+#pod with C<Path::Tiny> and is not supported. Use at your own risk.
+#pod
+#pod Current API available since 0.101.
+#pod
+#pod =cut
+
+sub cached_temp {
+ my $self = shift;
+ $self->_throw( "cached_temp", $self, "has no cached File::Temp object" )
+ unless defined $self->[TEMP];
+ return $self->[TEMP];
+}
+
+#pod =method child
+#pod
+#pod $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
+#pod $file = path("/tmp")->child(@parts);
+#pod
+#pod Returns a new C<Path::Tiny> object relative to the original. Works
+#pod like C<catfile> or C<catdir> from File::Spec, but without caring about
+#pod file or directories.
+#pod
+#pod B<WARNING>: because the argument could contain C<..> or refer to symlinks,
+#pod there is no guarantee that the new path refers to an actual descendent of
+#pod the original. If this is important to you, transform parent and child with
+#pod L</realpath> and check them with L</subsumes>.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub child {
+ my ( $self, @parts ) = @_;
+ return path( $self->[PATH], @parts );
+}
+
+#pod =method children
+#pod
+#pod @paths = path("/tmp")->children;
+#pod @paths = path("/tmp")->children( qr/\.txt\z/ );
+#pod
+#pod Returns a list of C<Path::Tiny> objects for all files and directories
+#pod within a directory. Excludes "." and ".." automatically.
+#pod
+#pod If an optional C<qr//> argument is provided, it only returns objects for child
+#pod names that match the given regular expression. Only the base name is used
+#pod for matching:
+#pod
+#pod @paths = path("/tmp")->children( qr/^foo/ );
+#pod # matches children like the glob foo*
+#pod
+#pod Current API available since 0.028.
+#pod
+#pod =cut
+
+sub children {
+ my ( $self, $filter ) = @_;
+ my $dh;
+ opendir $dh, $self->[PATH] or $self->_throw('opendir');
+ my @children = readdir $dh;
+ closedir $dh or $self->_throw('closedir');
+
+ if ( not defined $filter ) {
+ @children = grep { $_ ne '.' && $_ ne '..' } @children;
+ }
+ elsif ( $filter && ref($filter) eq 'Regexp' ) {
+ @children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children;
+ }
+ else {
+ Carp::croak("Invalid argument '$filter' for children()");
+ }
+
+ return map { path( $self->[PATH], $_ ) } @children;
+}
+
+#pod =method chmod
+#pod
+#pod path("foo.txt")->chmod(0777);
+#pod path("foo.txt")->chmod("0755");
+#pod path("foo.txt")->chmod("go-w");
+#pod path("foo.txt")->chmod("a=r,u+wx");
+#pod
+#pod Sets file or directory permissions. The argument can be a numeric mode, a
+#pod octal string beginning with a "0" or a limited subset of the symbolic mode use
+#pod by F</bin/chmod>.
+#pod
+#pod The symbolic mode must be a comma-delimited list of mode clauses. Clauses must
+#pod match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
+#pod "perms" parameters for each clause. Unlike F</bin/chmod>, all three parameters
+#pod are required for each clause, multiple ops are not allowed and permissions
+#pod C<stugoX> are not supported. (See L<File::chmod> for more complex needs.)
+#pod
+#pod Current API available since 0.053.
+#pod
+#pod =cut
+
+sub chmod {
+ my ( $self, $new_mode ) = @_;
+
+ my $mode;
+ if ( $new_mode =~ /\d/ ) {
+ $mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode );
+ }
+ elsif ( $new_mode =~ /[=+-]/ ) {
+ $mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic
+ }
+ else {
+ Carp::croak("Invalid mode argument '$new_mode' for chmod()");
+ }
+
+ CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod");
+
+ return 1;
+}
+
+#pod =method copy
+#pod
+#pod path("/tmp/foo.txt")->copy("/tmp/bar.txt");
+#pod
+#pod Copies the current path to the given destination using L<File::Copy>'s
+#pod C<copy> function. Upon success, returns the C<Path::Tiny> object for the
+#pod newly copied file.
+#pod
+#pod Current API available since 0.070.
+#pod
+#pod =cut
+
+# XXX do recursively for directories?
+sub copy {
+ my ( $self, $dest ) = @_;
+ require File::Copy;
+ File::Copy::copy( $self->[PATH], $dest )
+ or Carp::croak("copy failed for $self to $dest: $!");
+
+ return -d $dest ? path( $dest, $self->basename ) : path($dest);
+}
+
+#pod =method digest
+#pod
+#pod $obj = path("/tmp/foo.txt")->digest; # SHA-256
+#pod $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
+#pod $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );
+#pod
+#pod Returns a hexadecimal digest for a file. An optional hash reference of options may
+#pod be given. The only option is C<chunk_size>. If C<chunk_size> is given, that many
+#pod bytes will be read at a time. If not provided, the entire file will be slurped
+#pod into memory to compute the digest.
+#pod
+#pod Any subsequent arguments are passed to the constructor for L<Digest> to select
+#pod an algorithm. If no arguments are given, the default is SHA-256.
+#pod
+#pod Current API available since 0.056.
+#pod
+#pod =cut
+
+sub digest {
+ my ( $self, @opts ) = @_;
+ my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {};
+ $args = _get_args( $args, qw/chunk_size/ );
+ unshift @opts, 'SHA-256' unless @opts;
+ require Digest;
+ my $digest = Digest->new(@opts);
+ if ( $args->{chunk_size} ) {
+ my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" );
+ my $buf;
+ $digest->add($buf) while read $fh, $buf, $args->{chunk_size};
+ }
+ else {
+ $digest->add( $self->slurp_raw );
+ }
+ return $digest->hexdigest;
+}
+
+#pod =method dirname (deprecated)
+#pod
+#pod $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
+#pod
+#pod Returns the directory portion you would get from calling
+#pod C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
+#pod parent directory portion. Because L<File::Spec> is inconsistent, the result
+#pod might or might not have a trailing slash. Because of this, this method is
+#pod B<deprecated>.
+#pod
+#pod A better, more consistently approach is likely C<< $path->parent->stringify >>,
+#pod which will not have a trailing slash except for a root directory.
+#pod
+#pod Deprecated in 0.056.
+#pod
+#pod =cut
+
+sub dirname {
+ my ($self) = @_;
+ $self->_splitpath unless defined $self->[DIR];
+ return length $self->[DIR] ? $self->[DIR] : ".";
+}
+
+#pod =method edit, edit_raw, edit_utf8
+#pod
+#pod path("foo.txt")->edit( \&callback, $options );
+#pod path("foo.txt")->edit_utf8( \&callback );
+#pod path("foo.txt")->edit_raw( \&callback );
+#pod
+#pod These are convenience methods that allow "editing" a file using a single
+#pod callback argument. They slurp the file using C<slurp>, place the contents
+#pod inside a localized C<$_> variable, call the callback function (without
+#pod arguments), and then write C<$_> (presumably mutated) back to the
+#pod file with C<spew>.
+#pod
+#pod An optional hash reference may be used to pass options. The only option is
+#pod C<binmode>, which is passed to C<slurp> and C<spew>.
+#pod
+#pod C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
+#pod C<spew_*> methods.
+#pod
+#pod Current API available since 0.077.
+#pod
+#pod =cut
+
+sub edit {
+ my $self = shift;
+ my $cb = shift;
+ my $args = _get_args( shift, qw/binmode/ );
+ Carp::croak("Callback for edit() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+
+ local $_ =
+ $self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () );
+ $cb->();
+ $self->spew( $args, $_ );
+
+ return;
+}
+
+# this is done long-hand to benefit from slurp_utf8 optimizations
+sub edit_utf8 {
+ my ( $self, $cb ) = @_;
+ Carp::croak("Callback for edit_utf8() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+
+ local $_ = $self->slurp_utf8;
+ $cb->();
+ $self->spew_utf8($_);
+
+ return;
+}
+
+sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit }
+
+#pod =method edit_lines, edit_lines_utf8, edit_lines_raw
+#pod
+#pod path("foo.txt")->edit_lines( \&callback, $options );
+#pod path("foo.txt")->edit_lines_utf8( \&callback );
+#pod path("foo.txt")->edit_lines_raw( \&callback );
+#pod
+#pod These are convenience methods that allow "editing" a file's lines using a
+#pod single callback argument. They iterate over the file: for each line, the
+#pod line is put into a localized C<$_> variable, the callback function is
+#pod executed (without arguments) and then C<$_> is written to a temporary file.
+#pod When iteration is finished, the temporary file is atomically renamed over
+#pod the original.
+#pod
+#pod An optional hash reference may be used to pass options. The only option is
+#pod C<binmode>, which is passed to the method that open handles for reading and
+#pod writing.
+#pod
+#pod C<edit_lines_utf8> and C<edit_lines_raw> act like their respective
+#pod C<slurp_*> and C<spew_*> methods.
+#pod
+#pod Current API available since 0.077.
+#pod
+#pod =cut
+
+sub edit_lines {
+ my $self = shift;
+ my $cb = shift;
+ my $args = _get_args( shift, qw/binmode/ );
+ Carp::croak("Callback for edit_lines() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+
+ my $binmode = $args->{binmode};
+ # get default binmode from caller's lexical scope (see "perldoc open")
+ $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
+
+ # writing need to follow the link and create the tempfile in the same
+ # dir for later atomic rename
+ my $resolved_path = $self->_resolve_symlinks;
+ my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) );
+
+ my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
+ my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode );
+
+ local $_;
+ while (<$in_fh>) {
+ $cb->();
+ $temp_fh->print($_);
+ }
+
+ close $temp_fh or $self->_throw( 'close', $temp );
+ close $in_fh or $self->_throw('close');
+
+ return $temp->move($resolved_path);
+}
+
+sub edit_lines_raw { $_[2] = { binmode => ":unix" }; goto &edit_lines }
+
+sub edit_lines_utf8 {
+ $_[2] = { binmode => ":raw:encoding(UTF-8)" };
+ goto &edit_lines;
+}
+
+#pod =method exists, is_file, is_dir
+#pod
+#pod if ( path("/tmp")->exists ) { ... } # -e
+#pod if ( path("/tmp")->is_dir ) { ... } # -d
+#pod if ( path("/tmp")->is_file ) { ... } # -e && ! -d
+#pod
+#pod Implements file test operations, this means the file or directory actually has
+#pod to exist on the filesystem. Until then, it's just a path.
+#pod
+#pod B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>.
+#pod C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
+#pod read just like files.
+#pod
+#pod Use C<-f> instead if you really mean to check for a plain file.
+#pod
+#pod Current API available since 0.053.
+#pod
+#pod =cut
+
+sub exists { -e $_[0]->[PATH] }
+
+sub is_file { -e $_[0]->[PATH] && !-d _ }
+
+sub is_dir { -d $_[0]->[PATH] }
+
+#pod =method filehandle
+#pod
+#pod $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
+#pod $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
+#pod $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode);
+#pod
+#pod Returns an open file handle. The C<$mode> argument must be a Perl-style
+#pod read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode>
+#pod is given, it is set during the C<open> call.
+#pod
+#pod An optional hash reference may be used to pass options.
+#pod
+#pod The C<locked> option governs file locking; if true, handles opened for writing,
+#pod appending or read-write are locked with C<LOCK_EX>; otherwise, they are
+#pod locked with C<LOCK_SH>. When using C<locked>, ">" or "+>" modes will delay
+#pod truncation until after the lock is acquired.
+#pod
+#pod The C<exclusive> option causes the open() call to fail if the file already
+#pod exists. This corresponds to the O_EXCL flag to sysopen / open(2).
+#pod C<exclusive> implies C<locked> and will set it for you if you forget it.
+#pod
+#pod See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar.
+#pod
+#pod Current API available since 0.066.
+#pod
+#pod =cut
+
+# Note: must put binmode on open line, not subsequent binmode() call, so things
+# like ":unix" actually stop perlio/crlf from being added
+
+sub filehandle {
+ my ( $self, @args ) = @_;
+ my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
+ $args = _get_args( $args, qw/locked exclusive/ );
+ $args->{locked} = 1 if $args->{exclusive};
+ my ( $opentype, $binmode ) = @args;
+
+ $opentype = "<" unless defined $opentype;
+ Carp::croak("Invalid file mode '$opentype'")
+ unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/;
+
+ $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $opentype, -1, 1 ) }
+ unless defined $binmode;
+ $binmode = "" unless defined $binmode;
+
+ my ( $fh, $lock, $trunc );
+ if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
+ require Fcntl;
+ # truncating file modes shouldn't truncate until lock acquired
+ if ( grep { $opentype eq $_ } qw( > +> ) ) {
+ # sysopen in write mode without truncation
+ my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR();
+ $flags |= Fcntl::O_CREAT();
+ $flags |= Fcntl::O_EXCL() if $args->{exclusive};
+ sysopen( $fh, $self->[PATH], $flags ) or $self->_throw("sysopen");
+
+ # fix up the binmode since sysopen() can't specify layers like
+ # open() and binmode() can't start with just :unix like open()
+ if ( $binmode =~ s/^:unix// ) {
+ # eliminate pseudo-layers
+ binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)");
+ # strip off real layers until only :unix is left
+ while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
+ binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)");
+ }
+ }
+
+ # apply any remaining binmode layers
+ if ( length $binmode ) {
+ binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)");
+ }
+
+ # ask for lock and truncation
+ $lock = Fcntl::LOCK_EX();
+ $trunc = 1;
+ }
+ elsif ( $^O eq 'aix' && $opentype eq "<" ) {
+ # AIX can only lock write handles, so upgrade to RW and LOCK_EX if
+ # the file is writable; otherwise give up on locking. N.B.
+ # checking -w before open to determine the open mode is an
+ # unavoidable race condition
+ if ( -w $self->[PATH] ) {
+ $opentype = "+<";
+ $lock = Fcntl::LOCK_EX();
+ }
+ }
+ else {
+ $lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX();
+ }
+ }
+
+ unless ($fh) {
+ my $mode = $opentype . $binmode;
+ open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)");
+ }
+
+ do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock;
+ do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc;
+
+ return $fh;
+}
+
+#pod =method is_absolute, is_relative
+#pod
+#pod if ( path("/tmp")->is_absolute ) { ... }
+#pod if ( path("/tmp")->is_relative ) { ... }
+#pod
+#pod Booleans for whether the path appears absolute or relative.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' }
+
+sub is_relative { substr( $_[0]->dirname, 0, 1 ) ne '/' }
+
+#pod =method is_rootdir
+#pod
+#pod while ( ! $path->is_rootdir ) {
+#pod $path = $path->parent;
+#pod ...
+#pod }
+#pod
+#pod Boolean for whether the path is the root directory of the volume. I.e. the
+#pod C<dirname> is C<q[/]> and the C<basename> is C<q[]>.
+#pod
+#pod This works even on C<MSWin32> with drives and UNC volumes:
+#pod
+#pod path("C:/")->is_rootdir; # true
+#pod path("//server/share/")->is_rootdir; #true
+#pod
+#pod Current API available since 0.038.
+#pod
+#pod =cut
+
+sub is_rootdir {
+ my ($self) = @_;
+ $self->_splitpath unless defined $self->[DIR];
+ return $self->[DIR] eq '/' && $self->[FILE] eq '';
+}
+
+#pod =method iterator
+#pod
+#pod $iter = path("/tmp")->iterator( \%options );
+#pod
+#pod Returns a code reference that walks a directory lazily. Each invocation
+#pod returns a C<Path::Tiny> object or undef when the iterator is exhausted.
+#pod
+#pod $iter = path("/tmp")->iterator;
+#pod while ( $path = $iter->() ) {
+#pod ...
+#pod }
+#pod
+#pod The current and parent directory entries ("." and "..") will not
+#pod be included.
+#pod
+#pod If the C<recurse> option is true, the iterator will walk the directory
+#pod recursively, breadth-first. If the C<follow_symlinks> option is also true,
+#pod directory links will be followed recursively. There is no protection against
+#pod loops when following links. If a directory is not readable, it will not be
+#pod followed.
+#pod
+#pod The default is the same as:
+#pod
+#pod $iter = path("/tmp")->iterator( {
+#pod recurse => 0,
+#pod follow_symlinks => 0,
+#pod } );
+#pod
+#pod For a more powerful, recursive iterator with built-in loop avoidance, see
+#pod L<Path::Iterator::Rule>.
+#pod
+#pod See also L</visit>.
+#pod
+#pod Current API available since 0.016.
+#pod
+#pod =cut
+
+sub iterator {
+ my $self = shift;
+ my $args = _get_args( shift, qw/recurse follow_symlinks/ );
+ my @dirs = $self;
+ my $current;
+ return sub {
+ my $next;
+ while (@dirs) {
+ if ( ref $dirs[0] eq 'Path::Tiny' ) {
+ if ( !-r $dirs[0] ) {
+ # Directory is missing or not readable, so skip it. There
+ # is still a race condition possible between the check and
+ # the opendir, but we can't easily differentiate between
+ # error cases that are OK to skip and those that we want
+ # to be exceptions, so we live with the race and let opendir
+ # be fatal.
+ shift @dirs and next;
+ }
+ $current = $dirs[0];
+ my $dh;
+ opendir( $dh, $current->[PATH] )
+ or $self->_throw( 'opendir', $current->[PATH] );
+ $dirs[0] = $dh;
+ if ( -l $current->[PATH] && !$args->{follow_symlinks} ) {
+ # Symlink attack! It was a real dir, but is now a symlink!
+ # N.B. we check *after* opendir so the attacker has to win
+ # two races: replace dir with symlink before opendir and
+ # replace symlink with dir before -l check above
+ shift @dirs and next;
+ }
+ }
+ while ( defined( $next = readdir $dirs[0] ) ) {
+ next if $next eq '.' || $next eq '..';
+ my $path = $current->child($next);
+ push @dirs, $path
+ if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path );
+ return $path;
+ }
+ shift @dirs;
+ }
+ return;
+ };
+}
+
+#pod =method lines, lines_raw, lines_utf8
+#pod
+#pod @contents = path("/tmp/foo.txt")->lines;
+#pod @contents = path("/tmp/foo.txt")->lines(\%options);
+#pod @contents = path("/tmp/foo.txt")->lines_raw;
+#pod @contents = path("/tmp/foo.txt")->lines_utf8;
+#pod
+#pod @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
+#pod
+#pod Returns a list of lines from a file. Optionally takes a hash-reference of
+#pod options. Valid options are C<binmode>, C<count> and C<chomp>.
+#pod
+#pod If C<binmode> is provided, it will be set on the handle prior to reading.
+#pod
+#pod If a positive C<count> is provided, that many lines will be returned from the
+#pod start of the file. If a negative C<count> is provided, the entire file will be
+#pod read, but only C<abs(count)> will be kept and returned. If C<abs(count)>
+#pod exceeds the number of lines in the file, all lines will be returned.
+#pod
+#pod If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
+#pod C<LF>) will be removed from the lines returned.
+#pod
+#pod Because the return is a list, C<lines> in scalar context will return the number
+#pod of lines (and throw away the data).
+#pod
+#pod $number_of_lines = path("/tmp/foo.txt")->lines;
+#pod
+#pod C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>. We use C<:raw>
+#pod instead of C<:unix> so PerlIO buffering can manage reading by line.
+#pod
+#pod C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
+#pod (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
+#pod UTF-8 slurp will be done and then the lines will be split. This is
+#pod actually faster than relying on C<:encoding(UTF-8)>, though a bit memory
+#pod intensive. If memory use is a concern, consider C<openr_utf8> and
+#pod iterating directly on the handle.
+#pod
+#pod Current API available since 0.065.
+#pod
+#pod =cut
+
+sub lines {
+ my $self = shift;
+ my $args = _get_args( shift, qw/binmode chomp count/ );
+ my $binmode = $args->{binmode};
+ $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
+ my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
+ my $chomp = $args->{chomp};
+ # XXX more efficient to read @lines then chomp(@lines) vs map?
+ if ( $args->{count} ) {
+ my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) );
+ while ( my $line = <$fh> ) {
+ $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp;
+ $result[ $counter++ ] = $line;
+ # for positive count, terminate after right number of lines
+ last if $counter == $args->{count};
+ # for negative count, eventually wrap around in the result array
+ $counter %= $mod;
+ }
+ # reorder results if full and wrapped somewhere in the middle
+ splice( @result, 0, 0, splice( @result, $counter ) )
+ if @result == $mod && $counter % $mod;
+ return @result;
+ }
+ elsif ($chomp) {
+ return map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic
+ }
+ else {
+ return wantarray ? <$fh> : ( my $count =()= <$fh> );
+ }
+}
+
+sub lines_raw {
+ my $self = shift;
+ my $args = _get_args( shift, qw/binmode chomp count/ );
+ if ( $args->{chomp} && !$args->{count} ) {
+ return split /\n/, slurp_raw($self); ## no critic
+ }
+ else {
+ $args->{binmode} = ":raw";
+ return lines( $self, $args );
+ }
+}
+
+my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/;
+
+sub lines_utf8 {
+ my $self = shift;
+ my $args = _get_args( shift, qw/binmode chomp count/ );
+ if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) )
+ && $args->{chomp}
+ && !$args->{count} )
+ {
+ my $slurp = slurp_utf8($self);
+ $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR
+ return split $CRLF, $slurp, -1; ## no critic
+ }
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ $args->{binmode} = ":unix:utf8_strict";
+ return lines( $self, $args );
+ }
+ else {
+ $args->{binmode} = ":raw:encoding(UTF-8)";
+ return lines( $self, $args );
+ }
+}
+
+#pod =method mkpath
+#pod
+#pod path("foo/bar/baz")->mkpath;
+#pod path("foo/bar/baz")->mkpath( \%options );
+#pod
+#pod Like calling C<make_path> from L<File::Path>. An optional hash reference
+#pod is passed through to C<make_path>. Errors will be trapped and an exception
+#pod thrown. Returns the list of directories created or an empty list if
+#pod the directories already exist, just like C<make_path>.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub mkpath {
+ my ( $self, $args ) = @_;
+ $args = {} unless ref $args eq 'HASH';
+ my $err;
+ $args->{error} = \$err unless defined $args->{error};
+ require File::Path;
+ my @dirs = File::Path::make_path( $self->[PATH], $args );
+ if ( $err && @$err ) {
+ my ( $file, $message ) = %{ $err->[0] };
+ Carp::croak("mkpath failed for $file: $message");
+ }
+ return @dirs;
+}
+
+#pod =method move
+#pod
+#pod path("foo.txt")->move("bar.txt");
+#pod
+#pod Move the current path to the given destination path using Perl's
+#pod built-in L<rename|perlfunc/rename> function. Returns the result
+#pod of the C<rename> function (except it throws an exception if it fails).
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub move {
+ my ( $self, $dst ) = @_;
+
+ return rename( $self->[PATH], $dst )
+ || $self->_throw( 'rename', $self->[PATH] . "' -> '$dst" );
+}
+
+#pod =method openr, openw, openrw, opena
+#pod
+#pod $fh = path("foo.txt")->openr($binmode); # read
+#pod $fh = path("foo.txt")->openr_raw;
+#pod $fh = path("foo.txt")->openr_utf8;
+#pod
+#pod $fh = path("foo.txt")->openw($binmode); # write
+#pod $fh = path("foo.txt")->openw_raw;
+#pod $fh = path("foo.txt")->openw_utf8;
+#pod
+#pod $fh = path("foo.txt")->opena($binmode); # append
+#pod $fh = path("foo.txt")->opena_raw;
+#pod $fh = path("foo.txt")->opena_utf8;
+#pod
+#pod $fh = path("foo.txt")->openrw($binmode); # read/write
+#pod $fh = path("foo.txt")->openrw_raw;
+#pod $fh = path("foo.txt")->openrw_utf8;
+#pod
+#pod Returns a file handle opened in the specified mode. The C<openr> style methods
+#pod take a single C<binmode> argument. All of the C<open*> methods have
+#pod C<open*_raw> and C<open*_utf8> equivalents that use C<:raw> and
+#pod C<:raw:encoding(UTF-8)>, respectively.
+#pod
+#pod An optional hash reference may be used to pass options. The only option is
+#pod C<locked>. If true, handles opened for writing, appending or read-write are
+#pod locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.
+#pod
+#pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
+#pod
+#pod See L</filehandle> for more on locking.
+#pod
+#pod Current API available since 0.011.
+#pod
+#pod =cut
+
+# map method names to corresponding open mode
+my %opens = (
+ opena => ">>",
+ openr => "<",
+ openw => ">",
+ openrw => "+<"
+);
+
+while ( my ( $k, $v ) = each %opens ) {
+ no strict 'refs';
+ # must check for lexical IO mode hint
+ *{$k} = sub {
+ my ( $self, @args ) = @_;
+ my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
+ $args = _get_args( $args, qw/locked/ );
+ my ($binmode) = @args;
+ $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) }
+ unless defined $binmode;
+ $self->filehandle( $args, $v, $binmode );
+ };
+ *{ $k . "_raw" } = sub {
+ my ( $self, @args ) = @_;
+ my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
+ $args = _get_args( $args, qw/locked/ );
+ $self->filehandle( $args, $v, ":raw" );
+ };
+ *{ $k . "_utf8" } = sub {
+ my ( $self, @args ) = @_;
+ my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {};
+ $args = _get_args( $args, qw/locked/ );
+ $self->filehandle( $args, $v, ":raw:encoding(UTF-8)" );
+ };
+}
+
+#pod =method parent
+#pod
+#pod $parent = path("foo/bar/baz")->parent; # foo/bar
+#pod $parent = path("foo/wibble.txt")->parent; # foo
+#pod
+#pod $parent = path("foo/bar/baz")->parent(2); # foo
+#pod
+#pod Returns a C<Path::Tiny> object corresponding to the parent directory of the
+#pod original directory or file. An optional positive integer argument is the number
+#pod of parent directories upwards to return. C<parent> by itself is equivalent to
+#pod C<parent(1)>.
+#pod
+#pod Current API available since 0.014.
+#pod
+#pod =cut
+
+# XXX this is ugly and coverage is incomplete. I think it's there for windows
+# so need to check coverage there and compare
+sub parent {
+ my ( $self, $level ) = @_;
+ $level = 1 unless defined $level && $level > 0;
+ $self->_splitpath unless defined $self->[FILE];
+ my $parent;
+ if ( length $self->[FILE] ) {
+ if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) {
+ $parent = path( $self->[PATH] . "/.." );
+ }
+ else {
+ $parent = path( _non_empty( $self->[VOL] . $self->[DIR] ) );
+ }
+ }
+ elsif ( length $self->[DIR] ) {
+ # because of symlinks, any internal updir requires us to
+ # just add more updirs at the end
+ if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) {
+ $parent = path( $self->[VOL] . $self->[DIR] . "/.." );
+ }
+ else {
+ ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/};
+ $parent = path( $self->[VOL] . $dir );
+ }
+ }
+ else {
+ $parent = path( _non_empty( $self->[VOL] ) );
+ }
+ return $level == 1 ? $parent : $parent->parent( $level - 1 );
+}
+
+sub _non_empty {
+ my ($string) = shift;
+ return ( ( defined($string) && length($string) ) ? $string : "." );
+}
+
+#pod =method realpath
+#pod
+#pod $real = path("/baz/foo/../bar")->realpath;
+#pod $real = path("foo/../bar")->realpath;
+#pod
+#pod Returns a new C<Path::Tiny> object with all symbolic links and upward directory
+#pod parts resolved using L<Cwd>'s C<realpath>. Compared to C<absolute>, this is
+#pod more expensive as it must actually consult the filesystem.
+#pod
+#pod If the parent path can't be resolved (e.g. if it includes directories that
+#pod don't exist), an exception will be thrown:
+#pod
+#pod $real = path("doesnt_exist/foo")->realpath; # dies
+#pod
+#pod However, if the parent path exists and only the last component (e.g. filename)
+#pod doesn't exist, the realpath will be the realpath of the parent plus the
+#pod non-existent last component:
+#pod
+#pod $real = path("./aasdlfasdlf")->realpath; # works
+#pod
+#pod The underlying L<Cwd> module usually worked this way on Unix, but died on
+#pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064,
+#pod it's safe to use anywhere.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+# Win32 and some Unixes need parent path resolved separately so realpath
+# doesn't throw an error resolving non-existent basename
+sub realpath {
+ my $self = shift;
+ $self = $self->_resolve_symlinks;
+ require Cwd;
+ $self->_splitpath if !defined $self->[FILE];
+ my $check_parent =
+ length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..';
+ my $realpath = eval {
+ # pure-perl Cwd can carp
+ local $SIG{__WARN__} = sub { };
+ Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] );
+ };
+ # parent realpath must exist; not all Cwd::realpath will error if it doesn't
+ $self->_throw("resolving realpath")
+ unless defined $realpath && length $realpath && -e $realpath;
+ return ( $check_parent ? path( $realpath, $self->[FILE] ) : path($realpath) );
+}
+
+#pod =method relative
+#pod
+#pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
+#pod
+#pod Returns a C<Path::Tiny> object with a path relative to a new base path
+#pod given as an argument. If no argument is given, the current directory will
+#pod be used as the new base path.
+#pod
+#pod If either path is already relative, it will be made absolute based on the
+#pod current directly before determining the new relative path.
+#pod
+#pod The algorithm is roughly as follows:
+#pod
+#pod =for :list
+#pod * If the original and new base path are on different volumes, an exception
+#pod will be thrown.
+#pod * If the original and new base are identical, the relative path is C<".">.
+#pod * If the new base subsumes the original, the relative path is the original
+#pod path with the new base chopped off the front
+#pod * If the new base does not subsume the original, a common prefix path is
+#pod determined (possibly the root directory) and the relative path will
+#pod consist of updirs (C<"..">) to reach the common prefix, followed by the
+#pod original path less the common prefix.
+#pod
+#pod Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
+#pod on a common prefix takes into account symlinks that could affect the updir
+#pod process. Given an original path "/A/B" and a new base "/A/C",
+#pod (where "A", "B" and "C" could each have multiple path components):
+#pod
+#pod =for :list
+#pod * Symlinks in "A" don't change the result unless the last component of A is
+#pod a symlink and the first component of "C" is an updir.
+#pod * Symlinks in "B" don't change the result and will exist in the result as
+#pod given.
+#pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into
+#pod account the possibility that not all path components might exist on the
+#pod filesystem.
+#pod
+#pod Current API available since 0.001. New algorithm (that accounts for
+#pod symlinks) available since 0.079.
+#pod
+#pod =cut
+
+sub relative {
+ my ( $self, $base ) = @_;
+ $base = path( defined $base && length $base ? $base : '.' );
+
+ # relative paths must be converted to absolute first
+ $self = $self->absolute if $self->is_relative;
+ $base = $base->absolute if $base->is_relative;
+
+ # normalize volumes if they exist
+ $self = $self->absolute if !length $self->volume && length $base->volume;
+ $base = $base->absolute if length $self->volume && !length $base->volume;
+
+ # can't make paths relative across volumes
+ if ( !_same( $self->volume, $base->volume ) ) {
+ Carp::croak("relative() can't cross volumes: '$self' vs '$base'");
+ }
+
+ # if same absolute path, relative is current directory
+ return path(".") if _same( $self->[PATH], $base->[PATH] );
+
+ # if base is a prefix of self, chop prefix off self
+ if ( $base->subsumes($self) ) {
+ $base = "" if $base->is_rootdir;
+ my $relative = "$self";
+ $relative =~ s{\A\Q$base/}{};
+ return path($relative);
+ }
+
+ # base is not a prefix, so must find a common prefix (even if root)
+ my ( @common, @self_parts, @base_parts );
+ @base_parts = split /\//, $base->_just_filepath;
+
+ # if self is rootdir, then common directory is root (shown as empty
+ # string for later joins); otherwise, must be computed from path parts.
+ if ( $self->is_rootdir ) {
+ @common = ("");
+ shift @base_parts;
+ }
+ else {
+ @self_parts = split /\//, $self->_just_filepath;
+
+ while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) {
+ push @common, shift @base_parts;
+ shift @self_parts;
+ }
+ }
+
+ # if there are any symlinks from common to base, we have a problem, as
+ # you can't guarantee that updir from base reaches the common prefix;
+ # we must resolve symlinks and try again; likewise, any updirs are
+ # a problem as it throws off calculation of updirs needed to get from
+ # self's path to the common prefix.
+ if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) {
+ return $self->relative($new_base);
+ }
+
+ # otherwise, symlinks in common or from common to A don't matter as
+ # those don't involve updirs
+ my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts );
+ return path(@new_path);
+}
+
+sub _just_filepath {
+ my $self = shift;
+ my $self_vol = $self->volume;
+ return "$self" if !length $self_vol;
+
+ ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{};
+
+ return $self_path;
+}
+
+sub _resolve_between {
+ my ( $self, $common, $base ) = @_;
+ my $path = $self->volume . join( "/", @$common );
+ my $changed = 0;
+ for my $p (@$base) {
+ $path .= "/$p";
+ if ( $p eq '..' ) {
+ $changed = 1;
+ if ( -e $path ) {
+ $path = path($path)->realpath->[PATH];
+ }
+ else {
+ $path =~ s{/[^/]+/..\z}{/};
+ }
+ }
+ if ( -l $path ) {
+ $changed = 1;
+ $path = path($path)->realpath->[PATH];
+ }
+ }
+ return $changed ? path($path) : undef;
+}
+
+#pod =method remove
+#pod
+#pod path("foo.txt")->remove;
+#pod
+#pod This is just like C<unlink>, except for its error handling: if the path does
+#pod not exist, it returns false; if deleting the file fails, it throws an
+#pod exception.
+#pod
+#pod Current API available since 0.012.
+#pod
+#pod =cut
+
+sub remove {
+ my $self = shift;
+
+ return 0 if !-e $self->[PATH] && !-l $self->[PATH];
+
+ return unlink( $self->[PATH] ) || $self->_throw('unlink');
+}
+
+#pod =method remove_tree
+#pod
+#pod # directory
+#pod path("foo/bar/baz")->remove_tree;
+#pod path("foo/bar/baz")->remove_tree( \%options );
+#pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
+#pod
+#pod Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
+#pod An optional hash reference is passed through to C<remove_tree>. Errors will be
+#pod trapped and an exception thrown. Returns the number of directories deleted,
+#pod just like C<remove_tree>.
+#pod
+#pod If you want to remove a directory only if it is empty, use the built-in
+#pod C<rmdir> function instead.
+#pod
+#pod rmdir path("foo/bar/baz/");
+#pod
+#pod Current API available since 0.013.
+#pod
+#pod =cut
+
+sub remove_tree {
+ my ( $self, $args ) = @_;
+ return 0 if !-e $self->[PATH] && !-l $self->[PATH];
+ $args = {} unless ref $args eq 'HASH';
+ my $err;
+ $args->{error} = \$err unless defined $args->{error};
+ $args->{safe} = 1 unless defined $args->{safe};
+ require File::Path;
+ my $count = File::Path::remove_tree( $self->[PATH], $args );
+
+ if ( $err && @$err ) {
+ my ( $file, $message ) = %{ $err->[0] };
+ Carp::croak("remove_tree failed for $file: $message");
+ }
+ return $count;
+}
+
+#pod =method sibling
+#pod
+#pod $foo = path("/tmp/foo.txt");
+#pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt
+#pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
+#pod
+#pod Returns a new C<Path::Tiny> object relative to the parent of the original.
+#pod This is slightly more efficient than C<< $path->parent->child(...) >>.
+#pod
+#pod Current API available since 0.058.
+#pod
+#pod =cut
+
+sub sibling {
+ my $self = shift;
+ return path( $self->parent->[PATH], @_ );
+}
+
+#pod =method slurp, slurp_raw, slurp_utf8
+#pod
+#pod $data = path("foo.txt")->slurp;
+#pod $data = path("foo.txt")->slurp( {binmode => ":raw"} );
+#pod $data = path("foo.txt")->slurp_raw;
+#pod $data = path("foo.txt")->slurp_utf8;
+#pod
+#pod Reads file contents into a scalar. Takes an optional hash reference which may
+#pod be used to pass options. The only available option is C<binmode>, which is
+#pod passed to C<binmode()> on the handle used for reading.
+#pod
+#pod C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
+#pod a fast, unbuffered, raw read.
+#pod
+#pod C<slurp_utf8> is like C<slurp> with a C<binmode> of
+#pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+#pod 0.58+ is installed, a raw slurp will be done instead and the result decoded
+#pod with C<Unicode::UTF8>. This is just as strict and is roughly an order of
+#pod magnitude faster than using C<:encoding(UTF-8)>.
+#pod
+#pod B<Note>: C<slurp> and friends lock the filehandle before slurping. If
+#pod you plan to slurp from a file created with L<File::Temp>, be sure to
+#pod close other handles or open without locking to avoid a deadlock:
+#pod
+#pod my $tempfile = File::Temp->new(EXLOCK => 0);
+#pod my $guts = path($tempfile)->slurp;
+#pod
+#pod Current API available since 0.004.
+#pod
+#pod =cut
+
+sub slurp {
+ my $self = shift;
+ my $args = _get_args( shift, qw/binmode/ );
+ my $binmode = $args->{binmode};
+ $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode;
+ my $fh = $self->filehandle( { locked => 1 }, "<", $binmode );
+ if ( ( defined($binmode) ? $binmode : "" ) eq ":unix"
+ and my $size = -s $fh )
+ {
+ my $buf;
+ read $fh, $buf, $size; # File::Slurp in a nutshell
+ return $buf;
+ }
+ else {
+ local $/;
+ return scalar <$fh>;
+ }
+}
+
+sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp }
+
+sub slurp_utf8 {
+ if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
+ return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) );
+ }
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ $_[1] = { binmode => ":unix:utf8_strict" };
+ goto &slurp;
+ }
+ else {
+ $_[1] = { binmode => ":raw:encoding(UTF-8)" };
+ goto &slurp;
+ }
+}
+
+#pod =method spew, spew_raw, spew_utf8
+#pod
+#pod path("foo.txt")->spew(@data);
+#pod path("foo.txt")->spew(\@data);
+#pod path("foo.txt")->spew({binmode => ":raw"}, @data);
+#pod path("foo.txt")->spew_raw(@data);
+#pod path("foo.txt")->spew_utf8(@data);
+#pod
+#pod Writes data to a file atomically. The file is written to a temporary file in
+#pod the same directory, then renamed over the original. An optional hash reference
+#pod may be used to pass options. The only option is C<binmode>, which is passed to
+#pod C<binmode()> on the handle used for writing.
+#pod
+#pod C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
+#pod unbuffered, raw write.
+#pod
+#pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
+#pod (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
+#pod spew will be done instead on the data encoded with C<Unicode::UTF8>.
+#pod
+#pod B<NOTE>: because the file is written to a temporary file and then renamed, the
+#pod new file will wind up with permissions based on your current umask. This is a
+#pod feature to protect you from a race condition that would otherwise give
+#pod different permissions than you might expect. If you really want to keep the
+#pod original mode flags, use L</append> with the C<truncate> option.
+#pod
+#pod Current API available since 0.011.
+#pod
+#pod =cut
+
+# XXX add "unsafe" option to disable flocking and atomic? Check benchmarks on append() first.
+sub spew {
+ my ( $self, @data ) = @_;
+ my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {};
+ $args = _get_args( $args, qw/binmode/ );
+ my $binmode = $args->{binmode};
+ # get default binmode from caller's lexical scope (see "perldoc open")
+ $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode;
+
+ # spewing need to follow the link
+ # and create the tempfile in the same dir
+ my $resolved_path = $self->_resolve_symlinks;
+
+ my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) );
+ my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode );
+ print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data;
+ close $fh or $self->_throw( 'close', $temp->[PATH] );
+
+ return $temp->move($resolved_path);
+}
+
+sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew }
+
+sub spew_utf8 {
+ if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) {
+ my $self = shift;
+ spew(
+ $self,
+ { binmode => ":unix" },
+ map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_
+ );
+ }
+ elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) {
+ splice @_, 1, 0, { binmode => ":unix:utf8_strict" };
+ goto &spew;
+ }
+ else {
+ splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" };
+ goto &spew;
+ }
+}
+
+#pod =method stat, lstat
+#pod
+#pod $stat = path("foo.txt")->stat;
+#pod $stat = path("/some/symlink")->lstat;
+#pod
+#pod Like calling C<stat> or C<lstat> from L<File::stat>.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+# XXX break out individual stat() components as subs?
+sub stat {
+ my $self = shift;
+ require File::stat;
+ return File::stat::stat( $self->[PATH] ) || $self->_throw('stat');
+}
+
+sub lstat {
+ my $self = shift;
+ require File::stat;
+ return File::stat::lstat( $self->[PATH] ) || $self->_throw('lstat');
+}
+
+#pod =method stringify
+#pod
+#pod $path = path("foo.txt");
+#pod say $path->stringify; # same as "$path"
+#pod
+#pod Returns a string representation of the path. Unlike C<canonpath>, this method
+#pod returns the path standardized with Unix-style C</> directory separators.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub stringify { $_[0]->[PATH] }
+
+#pod =method subsumes
+#pod
+#pod path("foo/bar")->subsumes("foo/bar/baz"); # true
+#pod path("/foo/bar")->subsumes("/foo/baz"); # false
+#pod
+#pod Returns true if the first path is a prefix of the second path at a directory
+#pod boundary.
+#pod
+#pod This B<does not> resolve parent directory entries (C<..>) or symlinks:
+#pod
+#pod path("foo/bar")->subsumes("foo/bar/../baz"); # true
+#pod
+#pod If such things are important to you, ensure that both paths are resolved to
+#pod the filesystem with C<realpath>:
+#pod
+#pod my $p1 = path("foo/bar")->realpath;
+#pod my $p2 = path("foo/bar/../baz")->realpath;
+#pod if ( $p1->subsumes($p2) ) { ... }
+#pod
+#pod Current API available since 0.048.
+#pod
+#pod =cut
+
+sub subsumes {
+ my $self = shift;
+ Carp::croak("subsumes() requires a defined, positive-length argument")
+ unless defined $_[0];
+ my $other = path(shift);
+
+ # normalize absolute vs relative
+ if ( $self->is_absolute && !$other->is_absolute ) {
+ $other = $other->absolute;
+ }
+ elsif ( $other->is_absolute && !$self->is_absolute ) {
+ $self = $self->absolute;
+ }
+
+ # normalize volume vs non-volume; do this after absolute path
+ # adjustments above since that might add volumes already
+ if ( length $self->volume && !length $other->volume ) {
+ $other = $other->absolute;
+ }
+ elsif ( length $other->volume && !length $self->volume ) {
+ $self = $self->absolute;
+ }
+
+ if ( $self->[PATH] eq '.' ) {
+ return !!1; # cwd subsumes everything relative
+ }
+ elsif ( $self->is_rootdir ) {
+ # a root directory ("/", "c:/") already ends with a separator
+ return $other->[PATH] =~ m{^\Q$self->[PATH]\E};
+ }
+ else {
+ # exact match or prefix breaking at a separator
+ return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/|\z)};
+ }
+}
+
+#pod =method touch
+#pod
+#pod path("foo.txt")->touch;
+#pod path("foo.txt")->touch($epoch_secs);
+#pod
+#pod Like the Unix C<touch> utility. Creates the file if it doesn't exist, or else
+#pod changes the modification and access times to the current time. If the first
+#pod argument is the epoch seconds then it will be used.
+#pod
+#pod Returns the path object so it can be easily chained with other methods:
+#pod
+#pod # won't die if foo.txt doesn't exist
+#pod $content = path("foo.txt")->touch->slurp;
+#pod
+#pod Current API available since 0.015.
+#pod
+#pod =cut
+
+sub touch {
+ my ( $self, $epoch ) = @_;
+ if ( !-e $self->[PATH] ) {
+ my $fh = $self->openw;
+ close $fh or $self->_throw('close');
+ }
+ if ( defined $epoch ) {
+ utime $epoch, $epoch, $self->[PATH]
+ or $self->_throw("utime ($epoch)");
+ }
+ else {
+ # literal undef prevents warnings :-(
+ utime undef, undef, $self->[PATH]
+ or $self->_throw("utime ()");
+ }
+ return $self;
+}
+
+#pod =method touchpath
+#pod
+#pod path("bar/baz/foo.txt")->touchpath;
+#pod
+#pod Combines C<mkpath> and C<touch>. Creates the parent directory if it doesn't exist,
+#pod before touching the file. Returns the path object like C<touch> does.
+#pod
+#pod Current API available since 0.022.
+#pod
+#pod =cut
+
+sub touchpath {
+ my ($self) = @_;
+ my $parent = $self->parent;
+ $parent->mkpath unless $parent->exists;
+ $self->touch;
+}
+
+#pod =method visit
+#pod
+#pod path("/tmp")->visit( \&callback, \%options );
+#pod
+#pod Executes a callback for each child of a directory. It returns a hash
+#pod reference with any state accumulated during iteration.
+#pod
+#pod The options are the same as for L</iterator> (which it uses internally):
+#pod C<recurse> and C<follow_symlinks>. Both default to false.
+#pod
+#pod The callback function will receive a C<Path::Tiny> object as the first argument
+#pod and a hash reference to accumulate state as the second argument. For example:
+#pod
+#pod # collect files sizes
+#pod my $sizes = path("/tmp")->visit(
+#pod sub {
+#pod my ($path, $state) = @_;
+#pod return if $path->is_dir;
+#pod $state->{$path} = -s $path;
+#pod },
+#pod { recurse => 1 }
+#pod );
+#pod
+#pod For convenience, the C<Path::Tiny> object will also be locally aliased as the
+#pod C<$_> global variable:
+#pod
+#pod # print paths matching /foo/
+#pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
+#pod
+#pod If the callback returns a B<reference> to a false scalar value, iteration will
+#pod terminate. This is not the same as "pruning" a directory search; this just
+#pod stops all iteration and returns the state hash reference.
+#pod
+#pod # find up to 10 files larger than 100K
+#pod my $files = path("/tmp")->visit(
+#pod sub {
+#pod my ($path, $state) = @_;
+#pod $state->{$path}++ if -s $path > 102400
+#pod return \0 if keys %$state == 10;
+#pod },
+#pod { recurse => 1 }
+#pod );
+#pod
+#pod If you want more flexible iteration, use a module like L<Path::Iterator::Rule>.
+#pod
+#pod Current API available since 0.062.
+#pod
+#pod =cut
+
+sub visit {
+ my $self = shift;
+ my $cb = shift;
+ my $args = _get_args( shift, qw/recurse follow_symlinks/ );
+ Carp::croak("Callback for visit() must be a code reference")
+ unless defined($cb) && ref($cb) eq 'CODE';
+ my $next = $self->iterator($args);
+ my $state = {};
+ while ( my $file = $next->() ) {
+ local $_ = $file;
+ my $r = $cb->( $file, $state );
+ last if ref($r) eq 'SCALAR' && !$$r;
+ }
+ return $state;
+}
+
+#pod =method volume
+#pod
+#pod $vol = path("/tmp/foo.txt")->volume; # ""
+#pod $vol = path("C:/tmp/foo.txt")->volume; # "C:"
+#pod
+#pod Returns the volume portion of the path. This is equivalent
+#pod to what L<File::Spec> would give from C<splitpath> and thus
+#pod usually is the empty string on Unix-like operating systems or the
+#pod drive letter for an absolute path on C<MSWin32>.
+#pod
+#pod Current API available since 0.001.
+#pod
+#pod =cut
+
+sub volume {
+ my ($self) = @_;
+ $self->_splitpath unless defined $self->[VOL];
+ return $self->[VOL];
+}
+
+package Path::Tiny::Error;
+
+our @CARP_NOT = qw/Path::Tiny/;
+
+use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 );
+
+sub throw {
+ my ( $class, $op, $file, $err ) = @_;
+ chomp( my $trace = Carp::shortmess );
+ my $msg = "Error $op on '$file': $err$trace\n";
+ die bless { op => $op, file => $file, err => $err, msg => $msg }, $class;
+}
+
+1;
+
+
+# vim: ts=4 sts=4 sw=4 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Path::Tiny - File path utility
+
+=head1 VERSION
+
+version 0.114
+
+=head1 SYNOPSIS
+
+ use Path::Tiny;
+
+ # creating Path::Tiny objects
+
+ $dir = path("/tmp");
+ $foo = path("foo.txt");
+
+ $subdir = $dir->child("foo");
+ $bar = $subdir->child("bar.txt");
+
+ # stringifies as cleaned up path
+
+ $file = path("./foo.txt");
+ print $file; # "foo.txt"
+
+ # reading files
+
+ $guts = $file->slurp;
+ $guts = $file->slurp_utf8;
+
+ @lines = $file->lines;
+ @lines = $file->lines_utf8;
+
+ ($head) = $file->lines( {count => 1} );
+ ($tail) = $file->lines( {count => -1} );
+
+ # writing files
+
+ $bar->spew( @data );
+ $bar->spew_utf8( @data );
+
+ # reading directories
+
+ for ( $dir->children ) { ... }
+
+ $iter = $dir->iterator;
+ while ( my $next = $iter->() ) { ... }
+
+=head1 DESCRIPTION
+
+This module provides a small, fast utility for working with file paths. It is
+friendlier to use than L<File::Spec> and provides easy access to functions from
+several other core file handling modules. It aims to be smaller and faster
+than many alternatives on CPAN, while helping people do many common things in
+consistent and less error-prone ways.
+
+Path::Tiny does not try to work for anything except Unix-like and Win32
+platforms. Even then, it might break if you try something particularly obscure
+or tortuous. (Quick! What does this mean:
+C<< ///../../..//./././a//b/.././c/././ >>? And how does it differ on Win32?)
+
+All paths are forced to have Unix-style forward slashes. Stringifying
+the object gives you back the path (after some clean up).
+
+File input/output methods C<flock> handles before reading or writing,
+as appropriate (if supported by the platform and/or filesystem).
+
+The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw
+mode. On Windows, that means they will not have CRLF translation from the
+C<:crlf> IO layer. Installing L<Unicode::UTF8> 0.58 or later will speed up
+C<*_utf8> situations in many cases and is highly recommended.
+Alternatively, installing L<PerlIO::utf8_strict> 0.003 or later will be
+used in place of the default C<:encoding(UTF-8)>.
+
+This module depends heavily on PerlIO layers for correct operation and thus
+requires Perl 5.008001 or later.
+
+=head1 CONSTRUCTORS
+
+=head2 path
+
+ $path = path("foo/bar");
+ $path = path("/tmp", "file.txt"); # list
+ $path = path("."); # cwd
+ $path = path("~user/file.txt"); # tilde processing
+
+Constructs a C<Path::Tiny> object. It doesn't matter if you give a file or
+directory path. It's still up to you to call directory-like methods only on
+directories and file-like methods only on files. This function is exported
+automatically by default.
+
+The first argument must be defined and have non-zero length or an exception
+will be thrown. This prevents subtle, dangerous errors with code like
+C<< path( maybe_undef() )->remove_tree >>.
+
+If the first component of the path is a tilde ('~') then the component will be
+replaced with the output of C<glob('~')>. If the first component of the path
+is a tilde followed by a user name then the component will be replaced with
+output of C<glob('~username')>. Behaviour for non-existent users depends on
+the output of C<glob> on the system.
+
+On Windows, if the path consists of a drive identifier without a path component
+(C<C:> or C<D:>), it will be expanded to the absolute path of the current
+directory on that volume using C<Cwd::getdcwd()>.
+
+If called with a single C<Path::Tiny> argument, the original is returned unless
+the original is holding a temporary file or directory reference in which case a
+stringified copy is made.
+
+ $path = path("foo/bar");
+ $temp = Path::Tiny->tempfile;
+
+ $p2 = path($path); # like $p2 = $path
+ $t2 = path($temp); # like $t2 = path( "$temp" )
+
+This optimizes copies without proliferating references unexpectedly if a copy is
+made by code outside your control.
+
+Current API available since 0.017.
+
+=head2 new
+
+ $path = Path::Tiny->new("foo/bar");
+
+This is just like C<path>, but with method call overhead. (Why would you
+do that?)
+
+Current API available since 0.001.
+
+=head2 cwd
+
+ $path = Path::Tiny->cwd; # path( Cwd::getcwd )
+ $path = cwd; # optional export
+
+Gives you the absolute path to the current directory as a C<Path::Tiny> object.
+This is slightly faster than C<< path(".")->absolute >>.
+
+C<cwd> may be exported on request and used as a function instead of as a
+method.
+
+Current API available since 0.018.
+
+=head2 rootdir
+
+ $path = Path::Tiny->rootdir; # /
+ $path = rootdir; # optional export
+
+Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too
+picky for C<path("/")>.
+
+C<rootdir> may be exported on request and used as a function instead of as a
+method.
+
+Current API available since 0.018.
+
+=head2 tempfile, tempdir
+
+ $temp = Path::Tiny->tempfile( @options );
+ $temp = Path::Tiny->tempdir( @options );
+ $temp = tempfile( @options ); # optional export
+ $temp = tempdir( @options ); # optional export
+
+C<tempfile> passes the options to C<< File::Temp->new >> and returns a C<Path::Tiny>
+object with the file name. The C<TMPDIR> option is enabled by default.
+
+The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is
+destroyed, the C<File::Temp> object will be as well.
+
+C<File::Temp> annoyingly requires you to specify a custom template in slightly
+different ways depending on which function or method you call, but
+C<Path::Tiny> lets you ignore that and can take either a leading template or a
+C<TEMPLATE> option and does the right thing.
+
+ $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok
+ $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok
+
+The tempfile path object will be normalized to have an absolute path, even if
+created in a relative directory using C<DIR>. If you want it to have
+the C<realpath> instead, pass a leading options hash like this:
+
+ $real_temp = tempfile({realpath => 1}, @options);
+
+C<tempdir> is just like C<tempfile>, except it calls
+C<< File::Temp->newdir >> instead.
+
+Both C<tempfile> and C<tempdir> may be exported on request and used as
+functions instead of as methods.
+
+B<Note>: for tempfiles, the filehandles from File::Temp are closed and not
+reused. This is not as secure as using File::Temp handles directly, but is
+less prone to deadlocks or access problems on some platforms. Think of what
+C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned
+up.
+
+B<Note 2>: if you don't want these cleaned up automatically when the object
+is destroyed, File::Temp requires different options for directories and
+files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for
+files.
+
+B<Note 3>: Don't lose the temporary object by chaining a method call instead
+of storing it:
+
+ my $lost = tempdir()->child("foo"); # tempdir cleaned up right away
+
+B<Note 4>: The cached object may be accessed with the L</cached_temp> method.
+Keeping a reference to, or modifying the cached object may break the
+behavior documented above and is not supported. Use at your own risk.
+
+Current API available since 0.097.
+
+=head1 METHODS
+
+=head2 absolute
+
+ $abs = path("foo/bar")->absolute;
+ $abs = path("foo/bar")->absolute("/tmp");
+
+Returns a new C<Path::Tiny> object with an absolute path (or itself if already
+absolute). If no argument is given, the current directory is used as the
+absolute base path. If an argument is given, it will be converted to an
+absolute path (if it is not already) and used as the absolute base path.
+
+This will not resolve upward directories ("foo/../bar") unless C<canonpath>
+in L<File::Spec> would normally do so on your platform. If you need them
+resolved, you must call the more expensive C<realpath> method instead.
+
+On Windows, an absolute path without a volume component will have it added
+based on the current drive.
+
+Current API available since 0.101.
+
+=head2 append, append_raw, append_utf8
+
+ path("foo.txt")->append(@data);
+ path("foo.txt")->append(\@data);
+ path("foo.txt")->append({binmode => ":raw"}, @data);
+ path("foo.txt")->append_raw(@data);
+ path("foo.txt")->append_utf8(@data);
+
+Appends data to a file. The file is locked with C<flock> prior to writing
+and closed afterwards. An optional hash reference may be used to pass
+options. Valid options are:
+
+=over 4
+
+=item *
+
+C<binmode>: passed to C<binmode()> on the handle used for writing.
+
+=item *
+
+C<truncate>: truncates the file after locking and before appending
+
+=back
+
+The C<truncate> option is a way to replace the contents of a file
+B<in place>, unlike L</spew> which writes to a temporary file and then
+replaces the original (if it exists).
+
+C<append_raw> is like C<append> with a C<binmode> of C<:unix> for fast,
+unbuffered, raw write.
+
+C<append_utf8> is like C<append> with a C<binmode> of
+C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+0.58+ is installed, a raw append will be done instead on the data encoded
+with C<Unicode::UTF8>.
+
+Current API available since 0.060.
+
+=head2 assert
+
+ $path = path("foo.txt")->assert( sub { $_->exists } );
+
+Returns the invocant after asserting that a code reference argument returns
+true. When the assertion code reference runs, it will have the invocant
+object in the C<$_> variable. If it returns false, an exception will be
+thrown. The assertion code reference may also throw its own exception.
+
+If no assertion is provided, the invocant is returned without error.
+
+Current API available since 0.062.
+
+=head2 basename
+
+ $name = path("foo/bar.txt")->basename; # bar.txt
+ $name = path("foo.txt")->basename('.txt'); # foo
+ $name = path("foo.txt")->basename(qr/.txt/); # foo
+ $name = path("foo.txt")->basename(@suffixes);
+
+Returns the file portion or last directory portion of a path.
+
+Given a list of suffixes as strings or regular expressions, any that match at
+the end of the file portion or last directory portion will be removed before
+the result is returned.
+
+Current API available since 0.054.
+
+=head2 canonpath
+
+ $canonical = path("foo/bar")->canonpath; # foo\bar on Windows
+
+Returns a string with the canonical format of the path name for
+the platform. In particular, this means directory separators
+will be C<\> on Windows.
+
+Current API available since 0.001.
+
+=head2 cached_temp
+
+Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the
+C<Path::Tiny> object was created with C</tempfile> or C</tempdir>.
+If there is no such object, this method throws.
+
+B<WARNING>: Keeping a reference to, or modifying the cached object may
+break the behavior documented for temporary files and directories created
+with C<Path::Tiny> and is not supported. Use at your own risk.
+
+Current API available since 0.101.
+
+=head2 child
+
+ $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt"
+ $file = path("/tmp")->child(@parts);
+
+Returns a new C<Path::Tiny> object relative to the original. Works
+like C<catfile> or C<catdir> from File::Spec, but without caring about
+file or directories.
+
+B<WARNING>: because the argument could contain C<..> or refer to symlinks,
+there is no guarantee that the new path refers to an actual descendent of
+the original. If this is important to you, transform parent and child with
+L</realpath> and check them with L</subsumes>.
+
+Current API available since 0.001.
+
+=head2 children
+
+ @paths = path("/tmp")->children;
+ @paths = path("/tmp")->children( qr/\.txt\z/ );
+
+Returns a list of C<Path::Tiny> objects for all files and directories
+within a directory. Excludes "." and ".." automatically.
+
+If an optional C<qr//> argument is provided, it only returns objects for child
+names that match the given regular expression. Only the base name is used
+for matching:
+
+ @paths = path("/tmp")->children( qr/^foo/ );
+ # matches children like the glob foo*
+
+Current API available since 0.028.
+
+=head2 chmod
+
+ path("foo.txt")->chmod(0777);
+ path("foo.txt")->chmod("0755");
+ path("foo.txt")->chmod("go-w");
+ path("foo.txt")->chmod("a=r,u+wx");
+
+Sets file or directory permissions. The argument can be a numeric mode, a
+octal string beginning with a "0" or a limited subset of the symbolic mode use
+by F</bin/chmod>.
+
+The symbolic mode must be a comma-delimited list of mode clauses. Clauses must
+match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and
+"perms" parameters for each clause. Unlike F</bin/chmod>, all three parameters
+are required for each clause, multiple ops are not allowed and permissions
+C<stugoX> are not supported. (See L<File::chmod> for more complex needs.)
+
+Current API available since 0.053.
+
+=head2 copy
+
+ path("/tmp/foo.txt")->copy("/tmp/bar.txt");
+
+Copies the current path to the given destination using L<File::Copy>'s
+C<copy> function. Upon success, returns the C<Path::Tiny> object for the
+newly copied file.
+
+Current API available since 0.070.
+
+=head2 digest
+
+ $obj = path("/tmp/foo.txt")->digest; # SHA-256
+ $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected
+ $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" );
+
+Returns a hexadecimal digest for a file. An optional hash reference of options may
+be given. The only option is C<chunk_size>. If C<chunk_size> is given, that many
+bytes will be read at a time. If not provided, the entire file will be slurped
+into memory to compute the digest.
+
+Any subsequent arguments are passed to the constructor for L<Digest> to select
+an algorithm. If no arguments are given, the default is SHA-256.
+
+Current API available since 0.056.
+
+=head2 dirname (deprecated)
+
+ $name = path("/tmp/foo.txt")->dirname; # "/tmp/"
+
+Returns the directory portion you would get from calling
+C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a
+parent directory portion. Because L<File::Spec> is inconsistent, the result
+might or might not have a trailing slash. Because of this, this method is
+B<deprecated>.
+
+A better, more consistently approach is likely C<< $path->parent->stringify >>,
+which will not have a trailing slash except for a root directory.
+
+Deprecated in 0.056.
+
+=head2 edit, edit_raw, edit_utf8
+
+ path("foo.txt")->edit( \&callback, $options );
+ path("foo.txt")->edit_utf8( \&callback );
+ path("foo.txt")->edit_raw( \&callback );
+
+These are convenience methods that allow "editing" a file using a single
+callback argument. They slurp the file using C<slurp>, place the contents
+inside a localized C<$_> variable, call the callback function (without
+arguments), and then write C<$_> (presumably mutated) back to the
+file with C<spew>.
+
+An optional hash reference may be used to pass options. The only option is
+C<binmode>, which is passed to C<slurp> and C<spew>.
+
+C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and
+C<spew_*> methods.
+
+Current API available since 0.077.
+
+=head2 edit_lines, edit_lines_utf8, edit_lines_raw
+
+ path("foo.txt")->edit_lines( \&callback, $options );
+ path("foo.txt")->edit_lines_utf8( \&callback );
+ path("foo.txt")->edit_lines_raw( \&callback );
+
+These are convenience methods that allow "editing" a file's lines using a
+single callback argument. They iterate over the file: for each line, the
+line is put into a localized C<$_> variable, the callback function is
+executed (without arguments) and then C<$_> is written to a temporary file.
+When iteration is finished, the temporary file is atomically renamed over
+the original.
+
+An optional hash reference may be used to pass options. The only option is
+C<binmode>, which is passed to the method that open handles for reading and
+writing.
+
+C<edit_lines_utf8> and C<edit_lines_raw> act like their respective
+C<slurp_*> and C<spew_*> methods.
+
+Current API available since 0.077.
+
+=head2 exists, is_file, is_dir
+
+ if ( path("/tmp")->exists ) { ... } # -e
+ if ( path("/tmp")->is_dir ) { ... } # -d
+ if ( path("/tmp")->is_file ) { ... } # -e && ! -d
+
+Implements file test operations, this means the file or directory actually has
+to exist on the filesystem. Until then, it's just a path.
+
+B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>.
+C<-f> means "plain file", excluding symlinks, devices, etc. that often can be
+read just like files.
+
+Use C<-f> instead if you really mean to check for a plain file.
+
+Current API available since 0.053.
+
+=head2 filehandle
+
+ $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode);
+ $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode);
+ $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode);
+
+Returns an open file handle. The C<$mode> argument must be a Perl-style
+read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode>
+is given, it is set during the C<open> call.
+
+An optional hash reference may be used to pass options.
+
+The C<locked> option governs file locking; if true, handles opened for writing,
+appending or read-write are locked with C<LOCK_EX>; otherwise, they are
+locked with C<LOCK_SH>. When using C<locked>, ">" or "+>" modes will delay
+truncation until after the lock is acquired.
+
+The C<exclusive> option causes the open() call to fail if the file already
+exists. This corresponds to the O_EXCL flag to sysopen / open(2).
+C<exclusive> implies C<locked> and will set it for you if you forget it.
+
+See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar.
+
+Current API available since 0.066.
+
+=head2 is_absolute, is_relative
+
+ if ( path("/tmp")->is_absolute ) { ... }
+ if ( path("/tmp")->is_relative ) { ... }
+
+Booleans for whether the path appears absolute or relative.
+
+Current API available since 0.001.
+
+=head2 is_rootdir
+
+ while ( ! $path->is_rootdir ) {
+ $path = $path->parent;
+ ...
+ }
+
+Boolean for whether the path is the root directory of the volume. I.e. the
+C<dirname> is C<q[/]> and the C<basename> is C<q[]>.
+
+This works even on C<MSWin32> with drives and UNC volumes:
+
+ path("C:/")->is_rootdir; # true
+ path("//server/share/")->is_rootdir; #true
+
+Current API available since 0.038.
+
+=head2 iterator
+
+ $iter = path("/tmp")->iterator( \%options );
+
+Returns a code reference that walks a directory lazily. Each invocation
+returns a C<Path::Tiny> object or undef when the iterator is exhausted.
+
+ $iter = path("/tmp")->iterator;
+ while ( $path = $iter->() ) {
+ ...
+ }
+
+The current and parent directory entries ("." and "..") will not
+be included.
+
+If the C<recurse> option is true, the iterator will walk the directory
+recursively, breadth-first. If the C<follow_symlinks> option is also true,
+directory links will be followed recursively. There is no protection against
+loops when following links. If a directory is not readable, it will not be
+followed.
+
+The default is the same as:
+
+ $iter = path("/tmp")->iterator( {
+ recurse => 0,
+ follow_symlinks => 0,
+ } );
+
+For a more powerful, recursive iterator with built-in loop avoidance, see
+L<Path::Iterator::Rule>.
+
+See also L</visit>.
+
+Current API available since 0.016.
+
+=head2 lines, lines_raw, lines_utf8
+
+ @contents = path("/tmp/foo.txt")->lines;
+ @contents = path("/tmp/foo.txt")->lines(\%options);
+ @contents = path("/tmp/foo.txt")->lines_raw;
+ @contents = path("/tmp/foo.txt")->lines_utf8;
+
+ @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } );
+
+Returns a list of lines from a file. Optionally takes a hash-reference of
+options. Valid options are C<binmode>, C<count> and C<chomp>.
+
+If C<binmode> is provided, it will be set on the handle prior to reading.
+
+If a positive C<count> is provided, that many lines will be returned from the
+start of the file. If a negative C<count> is provided, the entire file will be
+read, but only C<abs(count)> will be kept and returned. If C<abs(count)>
+exceeds the number of lines in the file, all lines will be returned.
+
+If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or
+C<LF>) will be removed from the lines returned.
+
+Because the return is a list, C<lines> in scalar context will return the number
+of lines (and throw away the data).
+
+ $number_of_lines = path("/tmp/foo.txt")->lines;
+
+C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>. We use C<:raw>
+instead of C<:unix> so PerlIO buffering can manage reading by line.
+
+C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)>
+(or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
+UTF-8 slurp will be done and then the lines will be split. This is
+actually faster than relying on C<:encoding(UTF-8)>, though a bit memory
+intensive. If memory use is a concern, consider C<openr_utf8> and
+iterating directly on the handle.
+
+Current API available since 0.065.
+
+=head2 mkpath
+
+ path("foo/bar/baz")->mkpath;
+ path("foo/bar/baz")->mkpath( \%options );
+
+Like calling C<make_path> from L<File::Path>. An optional hash reference
+is passed through to C<make_path>. Errors will be trapped and an exception
+thrown. Returns the list of directories created or an empty list if
+the directories already exist, just like C<make_path>.
+
+Current API available since 0.001.
+
+=head2 move
+
+ path("foo.txt")->move("bar.txt");
+
+Move the current path to the given destination path using Perl's
+built-in L<rename|perlfunc/rename> function. Returns the result
+of the C<rename> function (except it throws an exception if it fails).
+
+Current API available since 0.001.
+
+=head2 openr, openw, openrw, opena
+
+ $fh = path("foo.txt")->openr($binmode); # read
+ $fh = path("foo.txt")->openr_raw;
+ $fh = path("foo.txt")->openr_utf8;
+
+ $fh = path("foo.txt")->openw($binmode); # write
+ $fh = path("foo.txt")->openw_raw;
+ $fh = path("foo.txt")->openw_utf8;
+
+ $fh = path("foo.txt")->opena($binmode); # append
+ $fh = path("foo.txt")->opena_raw;
+ $fh = path("foo.txt")->opena_utf8;
+
+ $fh = path("foo.txt")->openrw($binmode); # read/write
+ $fh = path("foo.txt")->openrw_raw;
+ $fh = path("foo.txt")->openrw_utf8;
+
+Returns a file handle opened in the specified mode. The C<openr> style methods
+take a single C<binmode> argument. All of the C<open*> methods have
+C<open*_raw> and C<open*_utf8> equivalents that use C<:raw> and
+C<:raw:encoding(UTF-8)>, respectively.
+
+An optional hash reference may be used to pass options. The only option is
+C<locked>. If true, handles opened for writing, appending or read-write are
+locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>.
+
+ $fh = path("foo.txt")->openrw_utf8( { locked => 1 } );
+
+See L</filehandle> for more on locking.
+
+Current API available since 0.011.
+
+=head2 parent
+
+ $parent = path("foo/bar/baz")->parent; # foo/bar
+ $parent = path("foo/wibble.txt")->parent; # foo
+
+ $parent = path("foo/bar/baz")->parent(2); # foo
+
+Returns a C<Path::Tiny> object corresponding to the parent directory of the
+original directory or file. An optional positive integer argument is the number
+of parent directories upwards to return. C<parent> by itself is equivalent to
+C<parent(1)>.
+
+Current API available since 0.014.
+
+=head2 realpath
+
+ $real = path("/baz/foo/../bar")->realpath;
+ $real = path("foo/../bar")->realpath;
+
+Returns a new C<Path::Tiny> object with all symbolic links and upward directory
+parts resolved using L<Cwd>'s C<realpath>. Compared to C<absolute>, this is
+more expensive as it must actually consult the filesystem.
+
+If the parent path can't be resolved (e.g. if it includes directories that
+don't exist), an exception will be thrown:
+
+ $real = path("doesnt_exist/foo")->realpath; # dies
+
+However, if the parent path exists and only the last component (e.g. filename)
+doesn't exist, the realpath will be the realpath of the parent plus the
+non-existent last component:
+
+ $real = path("./aasdlfasdlf")->realpath; # works
+
+The underlying L<Cwd> module usually worked this way on Unix, but died on
+Windows (and some Unixes) if the full path didn't exist. As of version 0.064,
+it's safe to use anywhere.
+
+Current API available since 0.001.
+
+=head2 relative
+
+ $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar
+
+Returns a C<Path::Tiny> object with a path relative to a new base path
+given as an argument. If no argument is given, the current directory will
+be used as the new base path.
+
+If either path is already relative, it will be made absolute based on the
+current directly before determining the new relative path.
+
+The algorithm is roughly as follows:
+
+=over 4
+
+=item *
+
+If the original and new base path are on different volumes, an exception will be thrown.
+
+=item *
+
+If the original and new base are identical, the relative path is C<".">.
+
+=item *
+
+If the new base subsumes the original, the relative path is the original path with the new base chopped off the front
+
+=item *
+
+If the new base does not subsume the original, a common prefix path is determined (possibly the root directory) and the relative path will consist of updirs (C<"..">) to reach the common prefix, followed by the original path less the common prefix.
+
+=back
+
+Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based
+on a common prefix takes into account symlinks that could affect the updir
+process. Given an original path "/A/B" and a new base "/A/C",
+(where "A", "B" and "C" could each have multiple path components):
+
+=over 4
+
+=item *
+
+Symlinks in "A" don't change the result unless the last component of A is a symlink and the first component of "C" is an updir.
+
+=item *
+
+Symlinks in "B" don't change the result and will exist in the result as given.
+
+=item *
+
+Symlinks and updirs in "C" must be resolved to actual paths, taking into account the possibility that not all path components might exist on the filesystem.
+
+=back
+
+Current API available since 0.001. New algorithm (that accounts for
+symlinks) available since 0.079.
+
+=head2 remove
+
+ path("foo.txt")->remove;
+
+This is just like C<unlink>, except for its error handling: if the path does
+not exist, it returns false; if deleting the file fails, it throws an
+exception.
+
+Current API available since 0.012.
+
+=head2 remove_tree
+
+ # directory
+ path("foo/bar/baz")->remove_tree;
+ path("foo/bar/baz")->remove_tree( \%options );
+ path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove
+
+Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode.
+An optional hash reference is passed through to C<remove_tree>. Errors will be
+trapped and an exception thrown. Returns the number of directories deleted,
+just like C<remove_tree>.
+
+If you want to remove a directory only if it is empty, use the built-in
+C<rmdir> function instead.
+
+ rmdir path("foo/bar/baz/");
+
+Current API available since 0.013.
+
+=head2 sibling
+
+ $foo = path("/tmp/foo.txt");
+ $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt
+ $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt
+
+Returns a new C<Path::Tiny> object relative to the parent of the original.
+This is slightly more efficient than C<< $path->parent->child(...) >>.
+
+Current API available since 0.058.
+
+=head2 slurp, slurp_raw, slurp_utf8
+
+ $data = path("foo.txt")->slurp;
+ $data = path("foo.txt")->slurp( {binmode => ":raw"} );
+ $data = path("foo.txt")->slurp_raw;
+ $data = path("foo.txt")->slurp_utf8;
+
+Reads file contents into a scalar. Takes an optional hash reference which may
+be used to pass options. The only available option is C<binmode>, which is
+passed to C<binmode()> on the handle used for reading.
+
+C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for
+a fast, unbuffered, raw read.
+
+C<slurp_utf8> is like C<slurp> with a C<binmode> of
+C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8>
+0.58+ is installed, a raw slurp will be done instead and the result decoded
+with C<Unicode::UTF8>. This is just as strict and is roughly an order of
+magnitude faster than using C<:encoding(UTF-8)>.
+
+B<Note>: C<slurp> and friends lock the filehandle before slurping. If
+you plan to slurp from a file created with L<File::Temp>, be sure to
+close other handles or open without locking to avoid a deadlock:
+
+ my $tempfile = File::Temp->new(EXLOCK => 0);
+ my $guts = path($tempfile)->slurp;
+
+Current API available since 0.004.
+
+=head2 spew, spew_raw, spew_utf8
+
+ path("foo.txt")->spew(@data);
+ path("foo.txt")->spew(\@data);
+ path("foo.txt")->spew({binmode => ":raw"}, @data);
+ path("foo.txt")->spew_raw(@data);
+ path("foo.txt")->spew_utf8(@data);
+
+Writes data to a file atomically. The file is written to a temporary file in
+the same directory, then renamed over the original. An optional hash reference
+may be used to pass options. The only option is C<binmode>, which is passed to
+C<binmode()> on the handle used for writing.
+
+C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast,
+unbuffered, raw write.
+
+C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)>
+(or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw
+spew will be done instead on the data encoded with C<Unicode::UTF8>.
+
+B<NOTE>: because the file is written to a temporary file and then renamed, the
+new file will wind up with permissions based on your current umask. This is a
+feature to protect you from a race condition that would otherwise give
+different permissions than you might expect. If you really want to keep the
+original mode flags, use L</append> with the C<truncate> option.
+
+Current API available since 0.011.
+
+=head2 stat, lstat
+
+ $stat = path("foo.txt")->stat;
+ $stat = path("/some/symlink")->lstat;
+
+Like calling C<stat> or C<lstat> from L<File::stat>.
+
+Current API available since 0.001.
+
+=head2 stringify
+
+ $path = path("foo.txt");
+ say $path->stringify; # same as "$path"
+
+Returns a string representation of the path. Unlike C<canonpath>, this method
+returns the path standardized with Unix-style C</> directory separators.
+
+Current API available since 0.001.
+
+=head2 subsumes
+
+ path("foo/bar")->subsumes("foo/bar/baz"); # true
+ path("/foo/bar")->subsumes("/foo/baz"); # false
+
+Returns true if the first path is a prefix of the second path at a directory
+boundary.
+
+This B<does not> resolve parent directory entries (C<..>) or symlinks:
+
+ path("foo/bar")->subsumes("foo/bar/../baz"); # true
+
+If such things are important to you, ensure that both paths are resolved to
+the filesystem with C<realpath>:
+
+ my $p1 = path("foo/bar")->realpath;
+ my $p2 = path("foo/bar/../baz")->realpath;
+ if ( $p1->subsumes($p2) ) { ... }
+
+Current API available since 0.048.
+
+=head2 touch
+
+ path("foo.txt")->touch;
+ path("foo.txt")->touch($epoch_secs);
+
+Like the Unix C<touch> utility. Creates the file if it doesn't exist, or else
+changes the modification and access times to the current time. If the first
+argument is the epoch seconds then it will be used.
+
+Returns the path object so it can be easily chained with other methods:
+
+ # won't die if foo.txt doesn't exist
+ $content = path("foo.txt")->touch->slurp;
+
+Current API available since 0.015.
+
+=head2 touchpath
+
+ path("bar/baz/foo.txt")->touchpath;
+
+Combines C<mkpath> and C<touch>. Creates the parent directory if it doesn't exist,
+before touching the file. Returns the path object like C<touch> does.
+
+Current API available since 0.022.
+
+=head2 visit
+
+ path("/tmp")->visit( \&callback, \%options );
+
+Executes a callback for each child of a directory. It returns a hash
+reference with any state accumulated during iteration.
+
+The options are the same as for L</iterator> (which it uses internally):
+C<recurse> and C<follow_symlinks>. Both default to false.
+
+The callback function will receive a C<Path::Tiny> object as the first argument
+and a hash reference to accumulate state as the second argument. For example:
+
+ # collect files sizes
+ my $sizes = path("/tmp")->visit(
+ sub {
+ my ($path, $state) = @_;
+ return if $path->is_dir;
+ $state->{$path} = -s $path;
+ },
+ { recurse => 1 }
+ );
+
+For convenience, the C<Path::Tiny> object will also be locally aliased as the
+C<$_> global variable:
+
+ # print paths matching /foo/
+ path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} );
+
+If the callback returns a B<reference> to a false scalar value, iteration will
+terminate. This is not the same as "pruning" a directory search; this just
+stops all iteration and returns the state hash reference.
+
+ # find up to 10 files larger than 100K
+ my $files = path("/tmp")->visit(
+ sub {
+ my ($path, $state) = @_;
+ $state->{$path}++ if -s $path > 102400
+ return \0 if keys %$state == 10;
+ },
+ { recurse => 1 }
+ );
+
+If you want more flexible iteration, use a module like L<Path::Iterator::Rule>.
+
+Current API available since 0.062.
+
+=head2 volume
+
+ $vol = path("/tmp/foo.txt")->volume; # ""
+ $vol = path("C:/tmp/foo.txt")->volume; # "C:"
+
+Returns the volume portion of the path. This is equivalent
+to what L<File::Spec> would give from C<splitpath> and thus
+usually is the empty string on Unix-like operating systems or the
+drive letter for an absolute path on C<MSWin32>.
+
+Current API available since 0.001.
+
+=for Pod::Coverage openr_utf8 opena_utf8 openw_utf8 openrw_utf8
+openr_raw opena_raw openw_raw openrw_raw
+IS_WIN32 FREEZE THAW TO_JSON abs2rel
+
+=head1 EXCEPTION HANDLING
+
+Simple usage errors will generally croak. Failures of underlying Perl
+functions will be thrown as exceptions in the class
+C<Path::Tiny::Error>.
+
+A C<Path::Tiny::Error> object will be a hash reference with the following fields:
+
+=over 4
+
+=item *
+
+C<op> — a description of the operation, usually function call and any extra info
+
+=item *
+
+C<file> — the file or directory relating to the error
+
+=item *
+
+C<err> — hold C<$!> at the time the error was thrown
+
+=item *
+
+C<msg> — a string combining the above data and a Carp-like short stack trace
+
+=back
+
+Exception objects will stringify as the C<msg> field.
+
+=head1 ENVIRONMENT
+
+=head2 PERL_PATH_TINY_NO_FLOCK
+
+If the environment variable C<PERL_PATH_TINY_NO_FLOCK> is set to a true
+value then flock will NOT be used when accessing files (this is not
+recommended).
+
+=head1 CAVEATS
+
+=head2 Subclassing not supported
+
+For speed, this class is implemented as an array based object and uses many
+direct function calls internally. You must not subclass it and expect
+things to work properly.
+
+=head2 File locking
+
+If flock is not supported on a platform, it will not be used, even if
+locking is requested.
+
+In situations where a platform normally would support locking, but the
+flock fails due to a filesystem limitation, Path::Tiny has some heuristics
+to detect this and will warn once and continue in an unsafe mode. If you
+want this failure to be fatal, you can fatalize the 'flock' warnings
+category:
+
+ use warnings FATAL => 'flock';
+
+See additional caveats below.
+
+=head3 NFS and BSD
+
+On BSD, Perl's flock implementation may not work to lock files on an
+NFS filesystem. If detected, this situation will warn once, as described
+above.
+
+=head3 Lustre
+
+The Lustre filesystem does not support flock. If detected, this situation
+will warn once, as described above.
+
+=head3 AIX and locking
+
+AIX requires a write handle for locking. Therefore, calls that normally
+open a read handle and take a shared lock instead will open a read-write
+handle and take an exclusive lock. If the user does not have write
+permission, no lock will be used.
+
+=head2 utf8 vs UTF-8
+
+All the C<*_utf8> methods by default use C<:encoding(UTF-8)> -- either as
+C<:unix:encoding(UTF-8)> (unbuffered) or C<:raw:encoding(UTF-8)> (buffered) --
+which is strict against the Unicode spec and disallows illegal Unicode
+codepoints or UTF-8 sequences.
+
+Unfortunately, C<:encoding(UTF-8)> is very, very slow. If you install
+L<Unicode::UTF8> 0.58 or later, that module will be used by some C<*_utf8>
+methods to encode or decode data after a raw, binary input/output operation,
+which is much faster. Alternatively, if you install L<PerlIO::utf8_strict>,
+that will be used instead of C<:encoding(UTF-8)> and is also very fast.
+
+If you need the performance and can accept the security risk,
+C<< slurp({binmode => ":unix:utf8"}) >> will be faster than C<:unix:encoding(UTF-8)>
+(but not as fast as C<Unicode::UTF8>).
+
+Note that the C<*_utf8> methods read in B<raw> mode. There is no CRLF
+translation on Windows. If you must have CRLF translation, use the regular
+input/output methods with an appropriate binmode:
+
+ $path->spew_utf8($data); # raw
+ $path->spew({binmode => ":encoding(UTF-8)"}, $data; # LF -> CRLF
+
+=head2 Default IO layers and the open pragma
+
+If you have Perl 5.10 or later, file input/output methods (C<slurp>, C<spew>,
+etc.) and high-level handle opening methods ( C<filehandle>, C<openr>,
+C<openw>, etc. ) respect default encodings set by the C<-C> switch or lexical
+L<open> settings of the caller. For UTF-8, this is almost certainly slower
+than using the dedicated C<_utf8> methods if you have L<Unicode::UTF8>.
+
+=head1 TYPE CONSTRAINTS AND COERCION
+
+A standard L<MooseX::Types> library is available at
+L<MooseX::Types::Path::Tiny>. A L<Type::Tiny> equivalent is available as
+L<Types::Path::Tiny>.
+
+=head1 SEE ALSO
+
+These are other file/path utilities, which may offer a different feature
+set than C<Path::Tiny>.
+
+=over 4
+
+=item *
+
+L<File::chmod>
+
+=item *
+
+L<File::Fu>
+
+=item *
+
+L<IO::All>
+
+=item *
+
+L<Path::Class>
+
+=back
+
+These iterators may be slightly faster than the recursive iterator in
+C<Path::Tiny>:
+
+=over 4
+
+=item *
+
+L<Path::Iterator::Rule>
+
+=item *
+
+L<File::Next>
+
+=back
+
+There are probably comparable, non-Tiny tools. Let me know if you want me to
+add a module to the list.
+
+This module was featured in the L<2013 Perl Advent Calendar|http://www.perladvent.org/2013/2013-12-18.html>.
+
+=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/dagolden/Path-Tiny/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/dagolden/Path-Tiny>
+
+ git clone https://github.com/dagolden/Path-Tiny.git
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 CONTRIBUTORS
+
+=for stopwords Alex Efros Aristotle Pagaltzis Chris Williams Dan Book Dave Rolsky David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis Ian Sillitoe James Hunt John Karr Karen Etheridge Mark Ellis Martin H. Sluka Kjeldsen Michael G. Schwern Nigel Gregoire Philippe Bruhat (BooK) Regina Verbae Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim
+
+=over 4
+
+=item *
+
+Alex Efros <powerman@powerman.name>
+
+=item *
+
+Aristotle Pagaltzis <pagaltzis@gmx.de>
+
+=item *
+
+Chris Williams <bingos@cpan.org>
+
+=item *
+
+Dan Book <grinnz@grinnz.com>
+
+=item *
+
+Dave Rolsky <autarch@urth.org>
+
+=item *
+
+David Steinbrunner <dsteinbrunner@pobox.com>
+
+=item *
+
+Doug Bell <madcityzen@gmail.com>
+
+=item *
+
+Gabor Szabo <szabgab@cpan.org>
+
+=item *
+
+Gabriel Andrade <gabiruh@gmail.com>
+
+=item *
+
+George Hartzell <hartzell@cpan.org>
+
+=item *
+
+Geraud Continsouzas <geraud@scsi.nc>
+
+=item *
+
+Goro Fuji <gfuji@cpan.org>
+
+=item *
+
+Graham Knop <haarg@haarg.org>
+
+=item *
+
+Graham Ollis <plicease@cpan.org>
+
+=item *
+
+Ian Sillitoe <ian@sillit.com>
+
+=item *
+
+James Hunt <james@niftylogic.com>
+
+=item *
+
+John Karr <brainbuz@brainbuz.org>
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Mark Ellis <mark.ellis@cartridgesave.co.uk>
+
+=item *
+
+Martin H. Sluka <fany@cpan.org>
+
+=item *
+
+Martin Kjeldsen <mk@bluepipe.dk>
+
+=item *
+
+Michael G. Schwern <mschwern@cpan.org>
+
+=item *
+
+Nigel Gregoire <nigelgregoire@gmail.com>
+
+=item *
+
+Philippe Bruhat (BooK) <book@cpan.org>
+
+=item *
+
+Regina Verbae <regina-verbae@users.noreply.github.com>
+
+=item *
+
+Roy Ivy III <rivy@cpan.org>
+
+=item *
+
+Shlomi Fish <shlomif@shlomifish.org>
+
+=item *
+
+Smylers <Smylers@stripey.com>
+
+=item *
+
+Tatsuhiko Miyagawa <miyagawa@bulknews.net>
+
+=item *
+
+Toby Inkster <tobyink@cpan.org>
+
+=item *
+
+Yanick Champoux <yanick@babyl.dyndns.org>
+
+=item *
+
+김도형 - Keedi Kim <keedi@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2014 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+# $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
+#
+# Copyright (c) 1997 Roderick Schertler. All rights reserved. This
+# program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+=head1 NAME
+
+String::ShellQuote - quote strings for passing through the shell
+
+=head1 SYNOPSIS
+
+ $string = shell_quote @list;
+ $string = shell_quote_best_effort @list;
+ $string = shell_comment_quote $string;
+
+=head1 DESCRIPTION
+
+This module contains some functions which are useful for quoting strings
+which are going to pass through the shell or a shell-like object.
+
+=over
+
+=cut
+
+package String::ShellQuote;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+
+require Exporter;
+
+$VERSION = '1.04';
+@ISA = qw(Exporter);
+@EXPORT = qw(shell_quote shell_quote_best_effort shell_comment_quote);
+
+sub croak {
+ require Carp;
+ goto &Carp::croak;
+}
+
+sub _shell_quote_backend {
+ my @in = @_;
+ my @err = ();
+
+ if (0) {
+ require RS::Handy;
+ print RS::Handy::data_dump(\@in);
+ }
+
+ return \@err, '' unless @in;
+
+ my $ret = '';
+ my $saw_non_equal = 0;
+ foreach (@in) {
+ if (!defined $_ or $_ eq '') {
+ $_ = "''";
+ next;
+ }
+
+ if (s/\x00//g) {
+ push @err, "No way to quote string containing null (\\000) bytes";
+ }
+
+ my $escape = 0;
+
+ # = needs quoting when it's the first element (or part of a
+ # series of such elements), as in command position it's a
+ # program-local environment setting
+
+ if (/=/) {
+ if (!$saw_non_equal) {
+ $escape = 1;
+ }
+ }
+ else {
+ $saw_non_equal = 1;
+ }
+
+ if (m|[^\w!%+,\-./:=@^]|) {
+ $escape = 1;
+ }
+
+ if ($escape
+ || (!$saw_non_equal && /=/)) {
+
+ # ' -> '\''
+ s/'/'\\''/g;
+
+ # make multiple ' in a row look simpler
+ # '\'''\'''\'' -> '"'''"'
+ s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
+
+ $_ = "'$_'";
+ s/^''//;
+ s/''$//;
+ }
+ }
+ continue {
+ $ret .= "$_ ";
+ }
+
+ chop $ret;
+ return \@err, $ret;
+}
+
+=item B<shell_quote> [I<string>]...
+
+B<shell_quote> quotes strings so they can be passed through the shell.
+Each I<string> is quoted so that the shell will pass it along as a
+single argument and without further interpretation. If no I<string>s
+are given an empty string is returned.
+
+If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
+
+=cut
+
+sub shell_quote {
+ my ($rerr, $s) = _shell_quote_backend @_;
+
+ if (@$rerr) {
+ my %seen;
+ @$rerr = grep { !$seen{$_}++ } @$rerr;
+ my $s = join '', map { "shell_quote(): $_\n" } @$rerr;
+ chomp $s;
+ croak $s;
+ }
+ return $s;
+}
+
+=item B<shell_quote_best_effort> [I<string>]...
+
+This is like B<shell_quote>, excpet if the string can't be safely quoted
+it does the best it can and returns the result, instead of dying.
+
+=cut
+
+sub shell_quote_best_effort {
+ my ($rerr, $s) = _shell_quote_backend @_;
+
+ return $s;
+}
+
+=item B<shell_comment_quote> [I<string>]
+
+B<shell_comment_quote> quotes the I<string> so that it can safely be
+included in a shell-style comment (the current algorithm is that a sharp
+character is placed after any newlines in the string).
+
+This routine might be changed to accept multiple I<string> arguments
+in the future. I haven't done this yet because I'm not sure if the
+I<string>s should be joined with blanks ($") or nothing ($,). Cast
+your vote today! Be sure to justify your answer.
+
+=cut
+
+sub shell_comment_quote {
+ return '' unless @_;
+ unless (@_ == 1) {
+ croak "Too many arguments to shell_comment_quote "
+ . "(got " . @_ . " expected 1)";
+ }
+ local $_ = shift;
+ s/\n/\n#/g;
+ return $_;
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 EXAMPLES
+
+ $cmd = 'fuser 2>/dev/null ' . shell_quote @files;
+ @pids = split ' ', `$cmd`;
+
+ print CFG "# Configured by: ",
+ shell_comment_quote($ENV{LOGNAME}), "\n";
+
+=head1 BUGS
+
+Only Bourne shell quoting is supported. I'd like to add other shells
+(particularly cmd.exe), but I'm not familiar with them. It would be a
+big help if somebody supplied the details.
+
+=head1 AUTHOR
+
+Roderick Schertler <F<roderick@argon.org>>
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
--- /dev/null
+use strict;
+BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } }
+
+package Tie::Handle::Offset;
+# ABSTRACT: Tied handle that hides the beginning of a file
+
+our $VERSION = '0.004';
+
+use Tie::Handle;
+our @ISA = qw/Tie::Handle/;
+
+#--------------------------------------------------------------------------#
+# Glob slot accessor
+#--------------------------------------------------------------------------#
+
+sub offset {
+ my $self = shift;
+ if ( @_ ) {
+ return ${*$self}{offset} = shift;
+ }
+ else {
+ return ${*$self}{offset};
+ }
+}
+
+#--------------------------------------------------------------------------#
+# Tied handle methods
+#--------------------------------------------------------------------------#
+
+sub TIEHANDLE
+{
+ my $class = shift;
+ my $params;
+ $params = pop if ref $_[-1] eq 'HASH';
+
+ my $self = \do { no warnings 'once'; local *HANDLE};
+ bless $self,$class;
+
+ $self->OPEN(@_) if (@_);
+ if ( $params->{offset} ) {
+ seek( $self, $self->offset( $params->{offset} ), 0 );
+ }
+ return $self;
+}
+
+sub TELL {
+ my $cur = tell($_[0]) - $_[0]->offset;
+ # XXX shouldn't ever be less than zero, but just in case...
+ return $cur > 0 ? $cur : 0;
+}
+
+sub SEEK {
+ my ($self, $pos, $whence) = @_;
+ my $rc;
+ if ( $whence == 0 || $whence == 1 ) { # pos from start, cur
+ $rc = seek($self, $pos + $self->offset, $whence);
+ }
+ elsif ( _size($self) + $pos < $self->offset ) { # from end
+ $rc = '';
+ }
+ else {
+ $rc = seek($self,$pos,$whence);
+ }
+ return $rc;
+}
+
+sub OPEN
+{
+ $_[0]->offset(0);
+ $_[0]->CLOSE if defined($_[0]->FILENO);
+ @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
+}
+
+sub _size {
+ my ($self) = @_;
+ my $cur = tell($self);
+ seek($self,0,2); # end
+ my $size = tell($self);
+ seek($self,$cur,0); # reset
+ return $size;
+}
+
+#--------------------------------------------------------------------------#
+# Methods copied from Tie::StdHandle to avoid dependency on Perl 5.8.9/5.10.0
+#--------------------------------------------------------------------------#
+
+sub EOF { eof($_[0]) }
+sub FILENO { fileno($_[0]) }
+sub CLOSE { close($_[0]) }
+sub BINMODE { binmode($_[0]) }
+sub READ { read($_[0],$_[1],$_[2]) }
+sub READLINE { my $fh = $_[0]; <$fh> }
+sub GETC { getc($_[0]) }
+
+sub WRITE
+{
+ my $fh = $_[0];
+ print $fh substr($_[1],0,$_[2])
+}
+
+1;
+
+
+# vim: ts=2 sts=2 sw=2 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Tie::Handle::Offset - Tied handle that hides the beginning of a file
+
+=head1 VERSION
+
+version 0.004
+
+=head1 SYNOPSIS
+
+ use Tie::Handle::Offset;
+
+ tie *FH, 'Tie::Handle::Offset', "<", $filename, { offset => 20 };
+
+=head1 DESCRIPTION
+
+This modules provides a file handle that hides the beginning of a file.
+After opening, the file is positioned at the offset location. C<seek()> and
+C<tell()> calls are modified to preserve the offset.
+
+For example, C<tell($fh)> will return 0, though the actual file position
+is at the offset. Likewise, C<seek($fh,80,0)> will seek to 80 bytes from
+the offset instead of 80 bytes from the actual start of the file.
+
+=for Pod::Coverage method_names_here
+
+=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
+
+=head1 SUPPORT
+
+=head2 Bugs / Feature Requests
+
+Please report any bugs or feature requests through the issue tracker
+at L<https://github.com/dagolden/tie-handle-offset/issues>.
+You will be notified automatically of any progress on your issue.
+
+=head2 Source Code
+
+This is open source software. The code repository is available for
+public review and contribution under the terms of the license.
+
+L<https://github.com/dagolden/tie-handle-offset>
+
+ git clone https://github.com/dagolden/tie-handle-offset.git
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2012 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+use strict;
+BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } }
+
+package Tie::Handle::SkipHeader;
+# ABSTRACT: Tied handle that hides an RFC822-style header
+
+our $VERSION = '0.004';
+
+use Tie::Handle::Offset;
+our @ISA = qw/Tie::Handle::Offset/;
+
+sub TIEHANDLE
+{
+ my $class = shift;
+ pop if ref $_[-1] eq 'HASH'; # we don't take any arguments
+ return $class->SUPER::TIEHANDLE(@_);
+}
+
+# read to blank/whitespace line and set offset right after
+sub OPEN
+{
+ my $self = shift;
+ my $rc = $self->SUPER::OPEN(@_);
+ while ( my $line = <$self> ) {
+ last if $line =~ /\A\s*\Z/;
+ }
+ $self->offset( tell($self) );
+ return $rc;
+}
+
+1;
+
+
+# vim: ts=2 sts=2 sw=2 et:
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Tie::Handle::SkipHeader - Tied handle that hides an RFC822-style header
+
+=head1 VERSION
+
+version 0.004
+
+=head1 SYNOPSIS
+
+ use Tie::Handle::SkipHeader;
+
+ tie *FH, 'Tie::Handle::SkipHeader', "<", $filename;
+
+=head1 DESCRIPTION
+
+This subclass of L<Tie::Handle::Offset> automatically hides an email-style
+message header. After opening the file, it reads up to a blank or
+white-space-only line and sets the offset to the next byte.
+
+=for Pod::Coverage method_names_here
+
+=head1 AUTHOR
+
+David Golden <dagolden@cpan.org>
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2012 by David Golden.
+
+This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+=cut
--- /dev/null
+package Try::Tiny; # git description: v0.29-2-g3b23a06
+use 5.006;
+# ABSTRACT: Minimal try/catch with proper preservation of $@
+
+our $VERSION = '0.30';
+
+use strict;
+use warnings;
+
+use Exporter 5.57 'import';
+our @EXPORT = our @EXPORT_OK = qw(try catch finally);
+
+use Carp;
+$Carp::Internal{+__PACKAGE__}++;
+
+BEGIN {
+ my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname;
+ my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) };
+ unless ($su || $sn) {
+ $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname;
+ unless ($su) {
+ $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) };
+ }
+ }
+
+ *_subname = $su ? \&Sub::Util::set_subname
+ : $sn ? \&Sub::Name::subname
+ : sub { $_[1] };
+ *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0};
+}
+
+my %_finally_guards;
+
+# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
+# Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
+# context & not a scalar one
+
+sub try (&;@) {
+ my ( $try, @code_refs ) = @_;
+
+ # we need to save this here, the eval block will be in scalar context due
+ # to $failed
+ my $wantarray = wantarray;
+
+ # work around perl bug by explicitly initializing these, due to the likelyhood
+ # this will be used in global destruction (perl rt#119311)
+ my ( $catch, @finally ) = ();
+
+ # find labeled blocks in the argument list.
+ # catch and finally tag the blocks by blessing a scalar reference to them.
+ foreach my $code_ref (@code_refs) {
+
+ if ( ref($code_ref) eq 'Try::Tiny::Catch' ) {
+ croak 'A try() may not be followed by multiple catch() blocks'
+ if $catch;
+ $catch = ${$code_ref};
+ } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) {
+ push @finally, ${$code_ref};
+ } else {
+ croak(
+ 'try() encountered an unexpected argument ('
+ . ( defined $code_ref ? $code_ref : 'undef' )
+ . ') - perhaps a missing semi-colon before or'
+ );
+ }
+ }
+
+ # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
+ # not perfect, but we could provide a list of additional errors for
+ # $catch->();
+
+ # name the blocks if we have Sub::Name installed
+ _subname(caller().'::try {...} ' => $try)
+ if _HAS_SUBNAME;
+
+ # set up scope guards to invoke the finally blocks at the end.
+ # this should really be a function scope lexical variable instead of
+ # file scope + local but that causes issues with perls < 5.20 due to
+ # perl rt#119311
+ local $_finally_guards{guards} = [
+ map { Try::Tiny::ScopeGuard->_new($_) }
+ @finally
+ ];
+
+ # save the value of $@ so we can set $@ back to it in the beginning of the eval
+ # and restore $@ after the eval finishes
+ my $prev_error = $@;
+
+ my ( @ret, $error );
+
+ # failed will be true if the eval dies, because 1 will not be returned
+ # from the eval body
+ my $failed = not eval {
+ $@ = $prev_error;
+
+ # evaluate the try block in the correct context
+ if ( $wantarray ) {
+ @ret = $try->();
+ } elsif ( defined $wantarray ) {
+ $ret[0] = $try->();
+ } else {
+ $try->();
+ };
+
+ return 1; # properly set $failed to false
+ };
+
+ # preserve the current error and reset the original value of $@
+ $error = $@;
+ $@ = $prev_error;
+
+ # at this point $failed contains a true value if the eval died, even if some
+ # destructor overwrote $@ as the eval was unwinding.
+ if ( $failed ) {
+ # pass $error to the finally blocks
+ push @$_, $error for @{$_finally_guards{guards}};
+
+ # if we got an error, invoke the catch block.
+ if ( $catch ) {
+ # This works like given($error), but is backwards compatible and
+ # sets $_ in the dynamic scope for the body of C<$catch>
+ for ($error) {
+ return $catch->($error);
+ }
+
+ # in case when() was used without an explicit return, the C<for>
+ # loop will be aborted and there's no useful return value
+ }
+
+ return;
+ } else {
+ # no failure, $@ is back to what it was, everything is fine
+ return $wantarray ? @ret : $ret[0];
+ }
+}
+
+sub catch (&;@) {
+ my ( $block, @rest ) = @_;
+
+ croak 'Useless bare catch()' unless wantarray;
+
+ _subname(caller().'::catch {...} ' => $block)
+ if _HAS_SUBNAME;
+ return (
+ bless(\$block, 'Try::Tiny::Catch'),
+ @rest,
+ );
+}
+
+sub finally (&;@) {
+ my ( $block, @rest ) = @_;
+
+ croak 'Useless bare finally()' unless wantarray;
+
+ _subname(caller().'::finally {...} ' => $block)
+ if _HAS_SUBNAME;
+ return (
+ bless(\$block, 'Try::Tiny::Finally'),
+ @rest,
+ );
+}
+
+{
+ package # hide from PAUSE
+ Try::Tiny::ScopeGuard;
+
+ use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0;
+
+ sub _new {
+ shift;
+ bless [ @_ ];
+ }
+
+ sub DESTROY {
+ my ($code, @args) = @{ $_[0] };
+
+ local $@ if UNSTABLE_DOLLARAT;
+ eval {
+ $code->(@args);
+ 1;
+ } or do {
+ warn
+ "Execution of finally() block $code resulted in an exception, which "
+ . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
+ . 'Your program will continue as if this event never took place. '
+ . "Original exception text follows:\n\n"
+ . (defined $@ ? $@ : '$@ left undefined...')
+ . "\n"
+ ;
+ }
+ }
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Try::Tiny - Minimal try/catch with proper preservation of $@
+
+=head1 VERSION
+
+version 0.30
+
+=head1 SYNOPSIS
+
+You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional
+conditions, avoiding quirks in Perl and common mistakes:
+
+ # handle errors with a catch handler
+ try {
+ die "foo";
+ } catch {
+ warn "caught error: $_"; # not $@
+ };
+
+You can also use it like a standalone C<eval> to catch and ignore any error
+conditions. Obviously, this is an extreme measure not to be undertaken
+lightly:
+
+ # just silence errors
+ try {
+ die "foo";
+ };
+
+=head1 DESCRIPTION
+
+This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to
+minimize common mistakes with eval blocks, and NOTHING else.
+
+This is unlike L<TryCatch> which provides a nice syntax and avoids adding
+another call stack layer, and supports calling C<return> from the C<try> block to
+return from the parent subroutine. These extra features come at a cost of a few
+dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are
+occasionally problematic, and the additional catch filtering uses L<Moose>
+type constraints which may not be desirable either.
+
+The main focus of this module is to provide simple and reliable error handling
+for those having a hard time installing L<TryCatch>, but who still want to
+write correct C<eval> blocks without 5 lines of boilerplate each time.
+
+It's designed to work as correctly as possible in light of the various
+pathological edge cases (see L</BACKGROUND>) and to be compatible with any style
+of error values (simple strings, references, objects, overloaded objects, etc).
+
+If the C<try> block dies, it returns the value of the last statement executed in
+the C<catch> block, if there is one. Otherwise, it returns C<undef> in scalar
+context or the empty list in list context. The following examples all
+assign C<"bar"> to C<$x>:
+
+ my $x = try { die "foo" } catch { "bar" };
+ my $x = try { die "foo" } || "bar";
+ my $x = (try { die "foo" }) // "bar";
+
+ my $x = eval { die "foo" } || "bar";
+
+You can add C<finally> blocks, yielding the following:
+
+ my $x;
+ try { die 'foo' } finally { $x = 'bar' };
+ try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
+
+C<finally> blocks are always executed making them suitable for cleanup code
+which cannot be handled using local. You can add as many C<finally> blocks to a
+given C<try> block as you like.
+
+Note that adding a C<finally> block without a preceding C<catch> block
+suppresses any errors. This behaviour is consistent with using a standalone
+C<eval>, but it is not consistent with C<try>/C<finally> patterns found in
+other programming languages, such as Java, Python, Javascript or C#. If you
+learnt the C<try>/C<finally> pattern from one of these languages, watch out for
+this.
+
+=head1 EXPORTS
+
+All functions are exported by default using L<Exporter>.
+
+If you need to rename the C<try>, C<catch> or C<finally> keyword consider using
+L<Sub::Import> to get L<Sub::Exporter>'s flexibility.
+
+=over 4
+
+=item try (&;@)
+
+Takes one mandatory C<try> subroutine, an optional C<catch> subroutine and C<finally>
+subroutine.
+
+The mandatory subroutine is evaluated in the context of an C<eval> block.
+
+If no error occurred the value from the first block is returned, preserving
+list/scalar context.
+
+If there was an error and the second subroutine was given it will be invoked
+with the error in C<$_> (localized) and as that block's first and only
+argument.
+
+C<$@> does B<not> contain the error. Inside the C<catch> block it has the same
+value it had before the C<try> block was executed.
+
+Note that the error may be false, but if that happens the C<catch> block will
+still be invoked.
+
+Once all execution is finished then the C<finally> block, if given, will execute.
+
+=item catch (&;@)
+
+Intended to be used in the second argument position of C<try>.
+
+Returns a reference to the subroutine it was given but blessed as
+C<Try::Tiny::Catch> which allows try to decode correctly what to do
+with this code reference.
+
+ catch { ... }
+
+Inside the C<catch> block the caught error is stored in C<$_>, while previous
+value of C<$@> is still available for use. This value may or may not be
+meaningful depending on what happened before the C<try>, but it might be a good
+idea to preserve it in an error stack.
+
+For code that captures C<$@> when throwing new errors (i.e.
+L<Class::Throwable>), you'll need to do:
+
+ local $@ = $_;
+
+=item finally (&;@)
+
+ try { ... }
+ catch { ... }
+ finally { ... };
+
+Or
+
+ try { ... }
+ finally { ... };
+
+Or even
+
+ try { ... }
+ finally { ... }
+ catch { ... };
+
+Intended to be the second or third element of C<try>. C<finally> blocks are always
+executed in the event of a successful C<try> or if C<catch> is run. This allows
+you to locate cleanup code which cannot be done via C<local()> e.g. closing a file
+handle.
+
+When invoked, the C<finally> block is passed the error that was caught. If no
+error was caught, it is passed nothing. (Note that the C<finally> block does not
+localize C<$_> with the error, since unlike in a C<catch> block, there is no way
+to know if C<$_ == undef> implies that there were no errors.) In other words,
+the following code does just what you would expect:
+
+ try {
+ die_sometimes();
+ } catch {
+ # ...code run in case of error
+ } finally {
+ if (@_) {
+ print "The try block died with: @_\n";
+ } else {
+ print "The try block ran without error.\n";
+ }
+ };
+
+B<You must always do your own error handling in the C<finally> block>. C<Try::Tiny> will
+not do anything about handling possible errors coming from code located in these
+blocks.
+
+Furthermore B<exceptions in C<finally> blocks are not trappable and are unable
+to influence the execution of your program>. This is due to limitation of
+C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This
+may change in a future version of Try::Tiny.
+
+In the same way C<catch()> blesses the code reference this subroutine does the same
+except it bless them as C<Try::Tiny::Finally>.
+
+=back
+
+=head1 BACKGROUND
+
+There are a number of issues with C<eval>.
+
+=head2 Clobbering $@
+
+When you run an C<eval> block and it succeeds, C<$@> will be cleared, potentially
+clobbering an error that is currently being caught.
+
+This causes action at a distance, clearing previous errors your caller may have
+not yet handled.
+
+C<$@> must be properly localized before invoking C<eval> in order to avoid this
+issue.
+
+More specifically,
+L<before Perl version 5.14.0|perl5140delta/"Exception Handling">
+C<$@> was clobbered at the beginning of the C<eval>, which
+also made it impossible to capture the previous error before you die (for
+instance when making exception objects with error stacks).
+
+For this reason C<try> will actually set C<$@> to its previous value (the one
+available before entering the C<try> block) in the beginning of the C<eval>
+block.
+
+=head2 Localizing $@ silently masks errors
+
+Inside an C<eval> block, C<die> behaves sort of like:
+
+ sub die {
+ $@ = $_[0];
+ return_undef_from_eval();
+ }
+
+This means that if you were polite and localized C<$@> you can't die in that
+scope, or your error will be discarded (printing "Something's wrong" instead).
+
+The workaround is very ugly:
+
+ my $error = do {
+ local $@;
+ eval { ... };
+ $@;
+ };
+
+ ...
+ die $error;
+
+=head2 $@ might not be a true value
+
+This code is wrong:
+
+ if ( $@ ) {
+ ...
+ }
+
+because due to the previous caveats it may have been unset.
+
+C<$@> could also be an overloaded error object that evaluates to false, but
+that's asking for trouble anyway.
+
+The classic failure mode (fixed in L<Perl 5.14.0|perl5140delta/"Exception Handling">) is:
+
+ sub Object::DESTROY {
+ eval { ... }
+ }
+
+ eval {
+ my $obj = Object->new;
+
+ die "foo";
+ };
+
+ if ( $@ ) {
+
+ }
+
+In this case since C<Object::DESTROY> is not localizing C<$@> but still uses
+C<eval>, it will set C<$@> to C<"">.
+
+The destructor is called when the stack is unwound, after C<die> sets C<$@> to
+C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has
+been cleared by C<eval> in the destructor.
+
+The workaround for this is even uglier than the previous ones. Even though we
+can't save the value of C<$@> from code that doesn't localize, we can at least
+be sure the C<eval> was aborted due to an error:
+
+ my $failed = not eval {
+ ...
+
+ return 1;
+ };
+
+This is because an C<eval> that caught a C<die> will always return a false
+value.
+
+=head1 ALTERNATE SYNTAX
+
+Using Perl 5.10 you can use L<perlsyn/"Switch statements"> (but please don't,
+because that syntax has since been deprecated because there was too much
+unexpected magical behaviour).
+
+=for stopwords topicalizer
+
+The C<catch> block is invoked in a topicalizer context (like a C<given> block),
+but note that you can't return a useful value from C<catch> using the C<when>
+blocks without an explicit C<return>.
+
+This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to
+concisely match errors:
+
+ try {
+ require Foo;
+ } catch {
+ when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
+ default { die $_ }
+ };
+
+=head1 CAVEATS
+
+=over 4
+
+=item *
+
+C<@_> is not available within the C<try> block, so you need to copy your
+argument list. In case you want to work with argument values directly via C<@_>
+aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference:
+
+ sub foo {
+ my ( $self, @args ) = @_;
+ try { $self->bar(@args) }
+ }
+
+or
+
+ sub bar_in_place {
+ my $self = shift;
+ my $args = \@_;
+ try { $_ = $self->bar($_) for @$args }
+ }
+
+=item *
+
+C<return> returns from the C<try> block, not from the parent sub (note that
+this is also how C<eval> works, but not how L<TryCatch> works):
+
+ sub parent_sub {
+ try {
+ die;
+ }
+ catch {
+ return;
+ };
+
+ say "this text WILL be displayed, even though an exception is thrown";
+ }
+
+Instead, you should capture the return value:
+
+ sub parent_sub {
+ my $success = try {
+ die;
+ 1;
+ };
+ return unless $success;
+
+ say "This text WILL NEVER appear!";
+ }
+ # OR
+ sub parent_sub_with_catch {
+ my $success = try {
+ die;
+ 1;
+ }
+ catch {
+ # do something with $_
+ return undef; #see note
+ };
+ return unless $success;
+
+ say "This text WILL NEVER appear!";
+ }
+
+Note that if you have a C<catch> block, it must return C<undef> for this to work,
+since if a C<catch> block exists, its return value is returned in place of C<undef>
+when an exception is thrown.
+
+=item *
+
+C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp>
+will not report this when using full stack traces, though, because
+C<%Carp::Internal> is used. This lack of magic is considered a feature.
+
+=for stopwords unhygienically
+
+=item *
+
+The value of C<$_> in the C<catch> block is not guaranteed to be the value of
+the exception thrown (C<$@>) in the C<try> block. There is no safe way to
+ensure this, since C<eval> may be used unhygienically in destructors. The only
+guarantee is that the C<catch> will be called if an exception is thrown.
+
+=item *
+
+The return value of the C<catch> block is not ignored, so if testing the result
+of the expression for truth on success, be sure to return a false value from
+the C<catch> block:
+
+ my $obj = try {
+ MightFail->new;
+ } catch {
+ ...
+
+ return; # avoid returning a true value;
+ };
+
+ return unless $obj;
+
+=item *
+
+C<$SIG{__DIE__}> is still in effect.
+
+Though it can be argued that C<$SIG{__DIE__}> should be disabled inside of
+C<eval> blocks, since it isn't people have grown to rely on it. Therefore in
+the interests of compatibility, C<try> does not disable C<$SIG{__DIE__}> for
+the scope of the error throwing code.
+
+=item *
+
+Lexical C<$_> may override the one set by C<catch>.
+
+For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some
+confusing behavior:
+
+ given ($foo) {
+ when (...) {
+ try {
+ ...
+ } catch {
+ warn $_; # will print $foo, not the error
+ warn $_[0]; # instead, get the error like this
+ }
+ }
+ }
+
+Note that this behavior was changed once again in
+L<Perl5 version 18|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
+However, since the entirety of lexical C<$_> is now L<considered experimental
+|https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it
+is unclear whether the new version 18 behavior is final.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<TryCatch>
+
+Much more feature complete, more convenient semantics, but at the cost of
+implementation complexity.
+
+=item L<autodie>
+
+Automatic error throwing for builtin functions and more. Also designed to
+work well with C<given>/C<when>.
+
+=item L<Throwable>
+
+A lightweight role for rolling your own exception classes.
+
+=item L<Error>
+
+Exception object implementation with a C<try> statement. Does not localize
+C<$@>.
+
+=item L<Exception::Class::TryCatch>
+
+Provides a C<catch> statement, but properly calling C<eval> is your
+responsibility.
+
+The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the
+issues with C<$@>, but you still need to localize to prevent clobbering.
+
+=back
+
+=head1 LIGHTNING TALK
+
+I gave a lightning talk about this module, you can see the slides (Firefox
+only):
+
+L<http://web.archive.org/web/20100628040134/http://nothingmuch.woobling.org/talks/takahashi.xul>
+
+Or read the source:
+
+L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
+
+=head1 SUPPORT
+
+Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny>
+(or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>).
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
+
+=item *
+
+Jesse Luehrs <doy@tozt.net>
+
+=back
+
+=head1 CONTRIBUTORS
+
+=for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Lukas Mai Aristotle Pagaltzis Dagfinn Ilmari Mannsåker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jens Berthold Jonathan Yu Marc Mims Stosberg Pali
+
+=over 4
+
+=item *
+
+Karen Etheridge <ether@cpan.org>
+
+=item *
+
+Peter Rabbitson <ribasushi@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Mark Fowler <mark@twoshortplanks.com>
+
+=item *
+
+Graham Knop <haarg@haarg.org>
+
+=item *
+
+Lukas Mai <l.mai@web.de>
+
+=item *
+
+Aristotle Pagaltzis <pagaltzis@gmx.de>
+
+=item *
+
+Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+=item *
+
+Paul Howarth <paul@city-fan.org>
+
+=item *
+
+Rudolf Leermakers <rudolf@hatsuseno.org>
+
+=item *
+
+anaxagoras <walkeraj@gmail.com>
+
+=item *
+
+awalker <awalker@sourcefire.com>
+
+=item *
+
+chromatic <chromatic@wgz.org>
+
+=item *
+
+Alex <alex@koban.(none)>
+
+=item *
+
+cm-perl <cm-perl@users.noreply.github.com>
+
+=item *
+
+Andrew Yates <ayates@haddock.local>
+
+=item *
+
+David Lowe <davidl@lokku.com>
+
+=item *
+
+Glenn Fowler <cebjyre@cpan.org>
+
+=item *
+
+Hans Dieter Pearcey <hdp@weftsoar.net>
+
+=item *
+
+Jens Berthold <jens@jebecs.de>
+
+=item *
+
+Jonathan Yu <JAWNSY@cpan.org>
+
+=item *
+
+Marc Mims <marc@questright.com>
+
+=item *
+
+Mark Stosberg <mark@stosberg.com>
+
+=item *
+
+Pali <pali@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is Copyright (c) 2009 by יובל קוג'מן (Yuval Kogman).
+
+This is free software, licensed under:
+
+ The MIT (X11) License
+
+=cut
--- /dev/null
+package URI;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER);
+
+my %implements; # mapping from scheme to implementor class
+
+# Some "official" character classes
+
+our $reserved = q(;/?:@&=+$,[]);
+our $mark = q(-_.!~*'()); #'; emacs
+our $unreserved = "A-Za-z0-9\Q$mark\E";
+our $uric = quotemeta($reserved) . $unreserved . "%";
+
+our $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
+
+use Carp ();
+use URI::Escape ();
+
+use overload ('""' => sub { ${$_[0]} },
+ '==' => sub { _obj_eq(@_) },
+ '!=' => sub { !_obj_eq(@_) },
+ fallback => 1,
+ );
+
+# Check if two objects are the same object
+sub _obj_eq {
+ return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
+}
+
+sub new
+{
+ my($class, $uri, $scheme) = @_;
+
+ $uri = defined ($uri) ? "$uri" : ""; # stringify
+ # Get rid of potential wrapping
+ $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
+ $uri =~ s/^"(.*)"$/$1/;
+ $uri =~ s/^\s+//;
+ $uri =~ s/\s+$//;
+
+ my $impclass;
+ if ($uri =~ m/^($scheme_re):/so) {
+ $scheme = $1;
+ }
+ else {
+ if (($impclass = ref($scheme))) {
+ $scheme = $scheme->scheme;
+ }
+ elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
+ $scheme = $1;
+ }
+ }
+ $impclass ||= implementor($scheme) ||
+ do {
+ require URI::_foreign;
+ $impclass = 'URI::_foreign';
+ };
+
+ return $impclass->_init($uri, $scheme);
+}
+
+
+sub new_abs
+{
+ my($class, $uri, $base) = @_;
+ $uri = $class->new($uri, $base);
+ $uri->abs($base);
+}
+
+
+sub _init
+{
+ my $class = shift;
+ my($str, $scheme) = @_;
+ # find all funny characters and encode the bytes.
+ $str = $class->_uric_escape($str);
+ $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
+ $class->_no_scheme_ok;
+ my $self = bless \$str, $class;
+ $self;
+}
+
+
+sub _uric_escape
+{
+ my($class, $str) = @_;
+ $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
+ utf8::downgrade($str);
+ return $str;
+}
+
+my %require_attempted;
+
+sub implementor
+{
+ my($scheme, $impclass) = @_;
+ if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
+ require URI::_generic;
+ return "URI::_generic";
+ }
+
+ $scheme = lc($scheme);
+
+ if ($impclass) {
+ # Set the implementor class for a given scheme
+ my $old = $implements{$scheme};
+ $impclass->_init_implementor($scheme);
+ $implements{$scheme} = $impclass;
+ return $old;
+ }
+
+ my $ic = $implements{$scheme};
+ return $ic if $ic;
+
+ # scheme not yet known, look for internal or
+ # preloaded (with 'use') implementation
+ $ic = "URI::$scheme"; # default location
+
+ # turn scheme into a valid perl identifier by a simple transformation...
+ $ic =~ s/\+/_P/g;
+ $ic =~ s/\./_O/g;
+ $ic =~ s/\-/_/g;
+
+ no strict 'refs';
+ # check we actually have one for the scheme:
+ unless (@{"${ic}::ISA"}) {
+ if (not exists $require_attempted{$ic}) {
+ # Try to load it
+ my $_old_error = $@;
+ eval "require $ic";
+ die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+ $@ = $_old_error;
+ }
+ return undef unless @{"${ic}::ISA"};
+ }
+
+ $ic->_init_implementor($scheme);
+ $implements{$scheme} = $ic;
+ $ic;
+}
+
+
+sub _init_implementor
+{
+ my($class, $scheme) = @_;
+ # Remember that one implementor class may actually
+ # serve to implement several URI schemes.
+}
+
+
+sub clone
+{
+ my $self = shift;
+ my $other = $$self;
+ bless \$other, ref $self;
+}
+
+sub TO_JSON { ${$_[0]} }
+
+sub _no_scheme_ok { 0 }
+
+sub _scheme
+{
+ my $self = shift;
+
+ unless (@_) {
+ return undef unless $$self =~ /^($scheme_re):/o;
+ return $1;
+ }
+
+ my $old;
+ my $new = shift;
+ if (defined($new) && length($new)) {
+ Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ my $newself = URI->new("$new:$$self");
+ $$self = $$newself;
+ bless $self, ref($newself);
+ }
+ else {
+ if ($self->_no_scheme_ok) {
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ Carp::carp("Oops, opaque part now look like scheme")
+ if $^W && $$self =~ m/^$scheme_re:/o
+ }
+ else {
+ $old = $1 if $$self =~ m/^($scheme_re):/o;
+ }
+ }
+
+ return $old;
+}
+
+sub scheme
+{
+ my $scheme = shift->_scheme(@_);
+ return undef unless defined $scheme;
+ lc($scheme);
+}
+
+sub has_recognized_scheme {
+ my $self = shift;
+ return ref($self) !~ /^URI::_(?:foreign|generic)\z/;
+}
+
+sub opaque
+{
+ my $self = shift;
+
+ unless (@_) {
+ $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
+ return $1;
+ }
+
+ $$self =~ /^($scheme_re:)? # optional scheme
+ ([^\#]*) # opaque
+ (\#.*)? # optional fragment
+ $/sx or die;
+
+ my $old_scheme = $1;
+ my $old_opaque = $2;
+ my $old_frag = $3;
+
+ my $new_opaque = shift;
+ $new_opaque = "" unless defined $new_opaque;
+ $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($new_opaque);
+
+ $$self = defined($old_scheme) ? $old_scheme : "";
+ $$self .= $new_opaque;
+ $$self .= $old_frag if defined $old_frag;
+
+ $old_opaque;
+}
+
+sub path { goto &opaque } # alias
+
+
+sub fragment
+{
+ my $self = shift;
+ unless (@_) {
+ return undef unless $$self =~ /\#(.*)/s;
+ return $1;
+ }
+
+ my $old;
+ $old = $1 if $$self =~ s/\#(.*)//s;
+
+ my $new_frag = shift;
+ if (defined $new_frag) {
+ $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
+ utf8::downgrade($new_frag);
+ $$self .= "#$new_frag";
+ }
+ $old;
+}
+
+
+sub as_string
+{
+ my $self = shift;
+ $$self;
+}
+
+
+sub as_iri
+{
+ my $self = shift;
+ my $str = $$self;
+ if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
+ # All this crap because the more obvious:
+ #
+ # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
+ #
+ # doesn't work before Encode 2.39. Wait for a standard release
+ # to bundle that version.
+
+ require Encode;
+ my $enc = Encode::find_encoding("UTF-8");
+ my $u = "";
+ while (length $str) {
+ $u .= $enc->decode($str, Encode::FB_QUIET());
+ if (length $str) {
+ # escape next char
+ $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
+ }
+ }
+ $str = $u;
+ }
+ return $str;
+}
+
+
+sub canonical
+{
+ # Make sure scheme is lowercased, that we don't escape unreserved chars,
+ # and that we use upcase escape sequences.
+
+ my $self = shift;
+ my $scheme = $self->_scheme || "";
+ my $uc_scheme = $scheme =~ /[A-Z]/;
+ my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
+ return $self unless $uc_scheme || $esc;
+
+ my $other = $self->clone;
+ if ($uc_scheme) {
+ $other->_scheme(lc $scheme);
+ }
+ if ($esc) {
+ $$other =~ s{%([0-9a-fA-F]{2})}
+ { my $a = chr(hex($1));
+ $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
+ }ge;
+ }
+ return $other;
+}
+
+# Compare two URIs, subclasses will provide a more correct implementation
+sub eq {
+ my($self, $other) = @_;
+ $self = URI->new($self, $other) unless ref $self;
+ $other = URI->new($other, $self) unless ref $other;
+ ref($self) eq ref($other) && # same class
+ $self->canonical->as_string eq $other->canonical->as_string;
+}
+
+# generic-URI transformation methods
+sub abs { $_[0]; }
+sub rel { $_[0]; }
+
+sub secure { 0 }
+
+# help out Storable
+sub STORABLE_freeze {
+ my($self, $cloning) = @_;
+ return $$self;
+}
+
+sub STORABLE_thaw {
+ my($self, $cloning, $str) = @_;
+ $$self = $str;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI - Uniform Resource Identifiers (absolute and relative)
+
+=head1 SYNOPSIS
+
+ use URI;
+
+ $u1 = URI->new("http://www.perl.com");
+ $u2 = URI->new("foo", "http");
+ $u3 = $u2->abs($u1);
+ $u4 = $u3->clone;
+ $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical;
+
+ $str = $u->as_string;
+ $str = "$u";
+
+ $scheme = $u->scheme;
+ $opaque = $u->opaque;
+ $path = $u->path;
+ $frag = $u->fragment;
+
+ $u->scheme("ftp");
+ $u->host("ftp.perl.com");
+ $u->path("cpan/");
+
+=head1 DESCRIPTION
+
+This module implements the C<URI> class. Objects of this class
+represent "Uniform Resource Identifier references" as specified in RFC
+2396 (and updated by RFC 2732).
+
+A Uniform Resource Identifier is a compact string of characters that
+identifies an abstract or physical resource. A Uniform Resource
+Identifier can be further classified as either a Uniform Resource Locator
+(URL) or a Uniform Resource Name (URN). The distinction between URL
+and URN does not matter to the C<URI> class interface. A
+"URI-reference" is a URI that may have additional information attached
+in the form of a fragment identifier.
+
+An absolute URI reference consists of three parts: a I<scheme>, a
+I<scheme-specific part> and a I<fragment> identifier. A subset of URI
+references share a common syntax for hierarchical namespaces. For
+these, the scheme-specific part is further broken down into
+I<authority>, I<path> and I<query> components. These URIs can also
+take the form of relative URI references, where the scheme (and
+usually also the authority) component is missing, but implied by the
+context of the URI reference. The three forms of URI reference
+syntax are summarized as follows:
+
+ <scheme>:<scheme-specific-part>#<fragment>
+ <scheme>://<authority><path>?<query>#<fragment>
+ <path>?<query>#<fragment>
+
+The components into which a URI reference can be divided depend on the
+I<scheme>. The C<URI> class provides methods to get and set the
+individual components. The methods available for a specific
+C<URI> object depend on the scheme.
+
+=head1 CONSTRUCTORS
+
+The following methods construct new C<URI> objects:
+
+=over 4
+
+=item $uri = URI->new( $str )
+
+=item $uri = URI->new( $str, $scheme )
+
+Constructs a new URI object. The string
+representation of a URI is given as argument, together with an optional
+scheme specification. Common URI wrappers like "" and <>, as well as
+leading and trailing white space, are automatically removed from
+the $str argument before it is processed further.
+
+The constructor determines the scheme, maps this to an appropriate
+URI subclass, constructs a new object of that class and returns it.
+
+If the scheme isn't one of those that URI recognizes, you still get
+an URI object back that you can access the generic methods on. The
+C<< $uri->has_recognized_scheme >> method can be used to test for
+this.
+
+The $scheme argument is only used when $str is a
+relative URI. It can be either a simple string that
+denotes the scheme, a string containing an absolute URI reference, or
+an absolute C<URI> object. If no $scheme is specified for a relative
+URI $str, then $str is simply treated as a generic URI (no scheme-specific
+methods available).
+
+The set of characters available for building URI references is
+restricted (see L<URI::Escape>). Characters outside this set are
+automatically escaped by the URI constructor.
+
+=item $uri = URI->new_abs( $str, $base_uri )
+
+Constructs a new absolute URI object. The $str argument can
+denote a relative or absolute URI. If relative, then it is
+absolutized using $base_uri as base. The $base_uri must be an absolute
+URI.
+
+=item $uri = URI::file->new( $filename )
+
+=item $uri = URI::file->new( $filename, $os )
+
+Constructs a new I<file> URI from a file name. See L<URI::file>.
+
+=item $uri = URI::file->new_abs( $filename )
+
+=item $uri = URI::file->new_abs( $filename, $os )
+
+Constructs a new absolute I<file> URI from a file name. See
+L<URI::file>.
+
+=item $uri = URI::file->cwd
+
+Returns the current working directory as a I<file> URI. See
+L<URI::file>.
+
+=item $uri->clone
+
+Returns a copy of the $uri.
+
+=back
+
+=head1 COMMON METHODS
+
+The methods described in this section are available for all C<URI>
+objects.
+
+Methods that give access to components of a URI always return the
+old value of the component. The value returned is C<undef> if the
+component was not present. There is generally a difference between a
+component that is empty (represented as C<"">) and a component that is
+missing (represented as C<undef>). If an accessor method is given an
+argument, it updates the corresponding component in addition to
+returning the old value of the component. Passing an undefined
+argument removes the component (if possible). The description of
+each accessor method indicates whether the component is passed as
+an escaped (percent-encoded) or an unescaped string. A component that can be further
+divided into sub-parts are usually passed escaped, as unescaping might
+change its semantics.
+
+The common methods available for all URI are:
+
+=over 4
+
+=item $uri->scheme
+
+=item $uri->scheme( $new_scheme )
+
+Sets and returns the scheme part of the $uri. If the $uri is
+relative, then $uri->scheme returns C<undef>. If called with an
+argument, it updates the scheme of $uri, possibly changing the
+class of $uri, and returns the old scheme value. The method croaks
+if the new scheme name is illegal; a scheme name must begin with a
+letter and must consist of only US-ASCII letters, numbers, and a few
+special marks: ".", "+", "-". This restriction effectively means
+that the scheme must be passed unescaped. Passing an undefined
+argument to the scheme method makes the URI relative (if possible).
+
+Letter case does not matter for scheme names. The string
+returned by $uri->scheme is always lowercase. If you want the scheme
+just as it was written in the URI in its original case,
+you can use the $uri->_scheme method instead.
+
+=item $uri->has_recognized_scheme
+
+Returns TRUE if the URI scheme is one that URI recognizes.
+
+It will also be TRUE for relative URLs where a recognized
+scheme was provided to the constructor, even if C<< $uri->scheme >>
+returns C<undef> for these.
+
+=item $uri->opaque
+
+=item $uri->opaque( $new_opaque )
+
+Sets and returns the scheme-specific part of the $uri
+(everything between the scheme and the fragment)
+as an escaped string.
+
+=item $uri->path
+
+=item $uri->path( $new_path )
+
+Sets and returns the same value as $uri->opaque unless the URI
+supports the generic syntax for hierarchical namespaces.
+In that case the generic method is overridden to set and return
+the part of the URI between the I<host name> and the I<fragment>.
+
+=item $uri->fragment
+
+=item $uri->fragment( $new_frag )
+
+Returns the fragment identifier of a URI reference
+as an escaped string.
+
+=item $uri->as_string
+
+Returns a URI object to a plain ASCII string. URI objects are
+also converted to plain strings automatically by overloading. This
+means that $uri objects can be used as plain strings in most Perl
+constructs.
+
+=item $uri->as_iri
+
+Returns a Unicode string representing the URI. Escaped UTF-8 sequences
+representing non-ASCII characters are turned into their corresponding Unicode
+code point.
+
+=item $uri->canonical
+
+Returns a normalized version of the URI. The rules
+for normalization are scheme-dependent. They usually involve
+lowercasing the scheme and Internet host name components,
+removing the explicit port specification if it matches the default port,
+uppercasing all escape sequences, and unescaping octets that can be
+better represented as plain characters.
+
+For efficiency reasons, if the $uri is already in normalized form,
+then a reference to it is returned instead of a copy.
+
+=item $uri->eq( $other_uri )
+
+=item URI::eq( $first_uri, $other_uri )
+
+Tests whether two URI references are equal. URI references
+that normalize to the same string are considered equal. The method
+can also be used as a plain function which can also test two string
+arguments.
+
+If you need to test whether two C<URI> object references denote the
+same object, use the '==' operator.
+
+=item $uri->abs( $base_uri )
+
+Returns an absolute URI reference. If $uri is already
+absolute, then a reference to it is simply returned. If the $uri
+is relative, then a new absolute URI is constructed by combining the
+$uri and the $base_uri, and returned.
+
+=item $uri->rel( $base_uri )
+
+Returns a relative URI reference if it is possible to
+make one that denotes the same resource relative to $base_uri.
+If not, then $uri is simply returned.
+
+=item $uri->secure
+
+Returns a TRUE value if the URI is considered to point to a resource on
+a secure channel, such as an SSL or TLS encrypted one.
+
+=back
+
+=head1 GENERIC METHODS
+
+The following methods are available to schemes that use the
+common/generic syntax for hierarchical namespaces. The descriptions of
+schemes below indicate which these are. Unrecognized schemes are
+assumed to support the generic syntax, and therefore the following
+methods:
+
+=over 4
+
+=item $uri->authority
+
+=item $uri->authority( $new_authority )
+
+Sets and returns the escaped authority component
+of the $uri.
+
+=item $uri->path
+
+=item $uri->path( $new_path )
+
+Sets and returns the escaped path component of
+the $uri (the part between the host name and the query or fragment).
+The path can never be undefined, but it can be the empty string.
+
+=item $uri->path_query
+
+=item $uri->path_query( $new_path_query )
+
+Sets and returns the escaped path and query
+components as a single entity. The path and the query are
+separated by a "?" character, but the query can itself contain "?".
+
+=item $uri->path_segments
+
+=item $uri->path_segments( $segment, ... )
+
+Sets and returns the path. In a scalar context, it returns
+the same value as $uri->path. In a list context, it returns the
+unescaped path segments that make up the path. Path segments that
+have parameters are returned as an anonymous array. The first element
+is the unescaped path segment proper; subsequent elements are escaped
+parameter strings. Such an anonymous array uses overloading so it can
+be treated as a string too, but this string does not include the
+parameters.
+
+Note that absolute paths have the empty string as their first
+I<path_segment>, i.e. the I<path> C</foo/bar> have 3
+I<path_segments>; "", "foo" and "bar".
+
+=item $uri->query
+
+=item $uri->query( $new_query )
+
+Sets and returns the escaped query component of
+the $uri.
+
+=item $uri->query_form
+
+=item $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
+
+=item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim )
+
+=item $uri->query_form( \@key_value_pairs )
+
+=item $uri->query_form( \@key_value_pairs, $delim )
+
+=item $uri->query_form( \%hash )
+
+=item $uri->query_form( \%hash, $delim )
+
+Sets and returns query components that use the
+I<application/x-www-form-urlencoded> format. Key/value pairs are
+separated by "&", and the key is separated from the value by a "="
+character.
+
+The form can be set either by passing separate key/value pairs, or via
+an array or hash reference. Passing an empty array or an empty hash
+removes the query component, whereas passing no arguments at all leaves
+the component unchanged. The order of keys is undefined if a hash
+reference is passed. The old value is always returned as a list of
+separate key/value pairs. Assigning this list to a hash is unwise as
+the keys returned might repeat.
+
+The values passed when setting the form can be plain strings or
+references to arrays of strings. Passing an array of values has the
+same effect as passing the key repeatedly with one value at a time.
+All the following statements have the same effect:
+
+ $uri->query_form(foo => 1, foo => 2);
+ $uri->query_form(foo => [1, 2]);
+ $uri->query_form([ foo => 1, foo => 2 ]);
+ $uri->query_form([ foo => [1, 2] ]);
+ $uri->query_form({ foo => [1, 2] });
+
+The $delim parameter can be passed as ";" to force the key/value pairs
+to be delimited by ";" instead of "&" in the query string. This
+practice is often recommended for URLs embedded in HTML or XML
+documents as this avoids the trouble of escaping the "&" character.
+You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to
+";" for the same global effect.
+
+The C<URI::QueryParam> module can be loaded to add further methods to
+manipulate the form of a URI. See L<URI::QueryParam> for details.
+
+=item $uri->query_keywords
+
+=item $uri->query_keywords( $keywords, ... )
+
+=item $uri->query_keywords( \@keywords )
+
+Sets and returns query components that use the
+keywords separated by "+" format.
+
+The keywords can be set either by passing separate keywords directly
+or by passing a reference to an array of keywords. Passing an empty
+array removes the query component, whereas passing no arguments at
+all leaves the component unchanged. The old value is always returned
+as a list of separate words.
+
+=back
+
+=head1 SERVER METHODS
+
+For schemes where the I<authority> component denotes an Internet host,
+the following methods are available in addition to the generic
+methods.
+
+=over 4
+
+=item $uri->userinfo
+
+=item $uri->userinfo( $new_userinfo )
+
+Sets and returns the escaped userinfo part of the
+authority component.
+
+For some schemes this is a user name and a password separated by
+a colon. This practice is not recommended. Embedding passwords in
+clear text (such as URI) has proven to be a security risk in almost
+every case where it has been used.
+
+=item $uri->host
+
+=item $uri->host( $new_host )
+
+Sets and returns the unescaped hostname.
+
+If the $new_host string ends with a colon and a number, then this
+number also sets the port.
+
+For IPv6 addresses the brackets around the raw address is removed in the return
+value from $uri->host. When setting the host attribute to an IPv6 address you
+can use a raw address or one enclosed in brackets. The address needs to be
+enclosed in brackets if you want to pass in a new port value as well.
+
+=item $uri->ihost
+
+Returns the host in Unicode form. Any IDNA A-labels are turned into U-labels.
+
+=item $uri->port
+
+=item $uri->port( $new_port )
+
+Sets and returns the port. The port is a simple integer
+that should be greater than 0.
+
+If a port is not specified explicitly in the URI, then the URI scheme's default port
+is returned. If you don't want the default port
+substituted, then you can use the $uri->_port method instead.
+
+=item $uri->host_port
+
+=item $uri->host_port( $new_host_port )
+
+Sets and returns the host and port as a single
+unit. The returned value includes a port, even if it matches the
+default port. The host part and the port part are separated by a
+colon: ":".
+
+For IPv6 addresses the bracketing is preserved; thus
+URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with
+$uri->host which will remove the brackets.
+
+=item $uri->default_port
+
+Returns the default port of the URI scheme to which $uri
+belongs. For I<http> this is the number 80, for I<ftp> this
+is the number 21, etc. The default port for a scheme can not be
+changed.
+
+=back
+
+=head1 SCHEME-SPECIFIC SUPPORT
+
+Scheme-specific support is provided for the following URI schemes. For C<URI>
+objects that do not belong to one of these, you can only use the common and
+generic methods.
+
+=over 4
+
+=item B<data>:
+
+The I<data> URI scheme is specified in RFC 2397. It allows inclusion
+of small data items as "immediate" data, as if it had been included
+externally.
+
+C<URI> objects belonging to the data scheme support the common methods
+and two new methods to access their scheme-specific components:
+$uri->media_type and $uri->data. See L<URI::data> for details.
+
+=item B<file>:
+
+An old specification of the I<file> URI scheme is found in RFC 1738.
+A new RFC 2396 based specification in not available yet, but file URI
+references are in common use.
+
+C<URI> objects belonging to the file scheme support the common and
+generic methods. In addition, they provide two methods for mapping file URIs
+back to local file names; $uri->file and $uri->dir. See L<URI::file>
+for details.
+
+=item B<ftp>:
+
+An old specification of the I<ftp> URI scheme is found in RFC 1738. A
+new RFC 2396 based specification in not available yet, but ftp URI
+references are in common use.
+
+C<URI> objects belonging to the ftp scheme support the common,
+generic and server methods. In addition, they provide two methods for
+accessing the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<gopher>:
+
+The I<gopher> URI scheme is specified in
+<draft-murali-url-gopher-1996-12-04> and will hopefully be available
+as a RFC 2396 based specification.
+
+C<URI> objects belonging to the gopher scheme support the common,
+generic and server methods. In addition, they support some methods for
+accessing gopher-specific path components: $uri->gopher_type,
+$uri->selector, $uri->search, $uri->string.
+
+=item B<http>:
+
+The I<http> URI scheme is specified in RFC 2616.
+The scheme is used to reference resources hosted by HTTP servers.
+
+C<URI> objects belonging to the http scheme support the common,
+generic and server methods.
+
+=item B<https>:
+
+The I<https> URI scheme is a Netscape invention which is commonly
+implemented. The scheme is used to reference HTTP servers through SSL
+connections. Its syntax is the same as http, but the default
+port is different.
+
+=item B<ldap>:
+
+The I<ldap> URI scheme is specified in RFC 2255. LDAP is the
+Lightweight Directory Access Protocol. An ldap URI describes an LDAP
+search operation to perform to retrieve information from an LDAP
+directory.
+
+C<URI> objects belonging to the ldap scheme support the common,
+generic and server methods as well as ldap-specific methods: $uri->dn,
+$uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See
+L<URI::ldap> for details.
+
+=item B<ldapi>:
+
+Like the I<ldap> URI scheme, but uses a UNIX domain socket. The
+server methods are not supported, and the local socket path is
+available as $uri->un_path. The I<ldapi> scheme is used by the
+OpenLDAP package. There is no real specification for it, but it is
+mentioned in various OpenLDAP manual pages.
+
+=item B<ldaps>:
+
+Like the I<ldap> URI scheme, but uses an SSL connection. This
+scheme is deprecated, as the preferred way is to use the I<start_tls>
+mechanism.
+
+=item B<mailto>:
+
+The I<mailto> URI scheme is specified in RFC 2368. The scheme was
+originally used to designate the Internet mailing address of an
+individual or service. It has (in RFC 2368) been extended to allow
+setting of other mail header fields and the message body.
+
+C<URI> objects belonging to the mailto scheme support the common
+methods and the generic query methods. In addition, they support the
+following mailto-specific methods: $uri->to, $uri->headers.
+
+Note that the "foo@example.com" part of a mailto is I<not> the
+C<userinfo> and C<host> but instead the C<path>. This allows a
+mailto URI to contain multiple comma separated email addresses.
+
+=item B<mms>:
+
+The I<mms> URL specification can be found at L<http://sdp.ppona.com/>.
+C<URI> objects belonging to the mms scheme support the common,
+generic, and server methods, with the exception of userinfo and
+query-related sub-components.
+
+=item B<news>:
+
+The I<news>, I<nntp> and I<snews> URI schemes are specified in
+<draft-gilman-news-url-01> and will hopefully be available as an RFC
+2396 based specification soon.
+
+C<URI> objects belonging to the news scheme support the common,
+generic and server methods. In addition, they provide some methods to
+access the path: $uri->group and $uri->message.
+
+=item B<nntp>:
+
+See I<news> scheme.
+
+=item B<pop>:
+
+The I<pop> URI scheme is specified in RFC 2384. The scheme is used to
+reference a POP3 mailbox.
+
+C<URI> objects belonging to the pop scheme support the common, generic
+and server methods. In addition, they provide two methods to access the
+userinfo components: $uri->user and $uri->auth
+
+=item B<rlogin>:
+
+An old specification of the I<rlogin> URI scheme is found in RFC
+1738. C<URI> objects belonging to the rlogin scheme support the
+common, generic and server methods.
+
+=item B<rtsp>:
+
+The I<rtsp> URL specification can be found in section 3.2 of RFC 2326.
+C<URI> objects belonging to the rtsp scheme support the common,
+generic, and server methods, with the exception of userinfo and
+query-related sub-components.
+
+=item B<rtspu>:
+
+The I<rtspu> URI scheme is used to talk to RTSP servers over UDP
+instead of TCP. The syntax is the same as rtsp.
+
+=item B<rsync>:
+
+Information about rsync is available from L<http://rsync.samba.org/>.
+C<URI> objects belonging to the rsync scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<sip>:
+
+The I<sip> URI specification is described in sections 19.1 and 25
+of RFC 3261. C<URI> objects belonging to the sip scheme support the
+common, generic, and server methods with the exception of path related
+sub-components. In addition, they provide two methods to get and set
+I<sip> parameters: $uri->params_form and $uri->params.
+
+=item B<sips>:
+
+See I<sip> scheme. Its syntax is the same as sip, but the default
+port is different.
+
+=item B<snews>:
+
+See I<news> scheme. Its syntax is the same as news, but the default
+port is different.
+
+=item B<telnet>:
+
+An old specification of the I<telnet> URI scheme is found in RFC
+1738. C<URI> objects belonging to the telnet scheme support the
+common, generic and server methods.
+
+=item B<tn3270>:
+
+These URIs are used like I<telnet> URIs but for connections to IBM
+mainframes. C<URI> objects belonging to the tn3270 scheme support the
+common, generic and server methods.
+
+=item B<ssh>:
+
+Information about ssh is available at L<http://www.openssh.com/>.
+C<URI> objects belonging to the ssh scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<sftp>:
+
+C<URI> objects belonging to the sftp scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components: $uri->user and $uri->password.
+
+=item B<urn>:
+
+The syntax of Uniform Resource Names is specified in RFC 2141. C<URI>
+objects belonging to the urn scheme provide the common methods, and also the
+methods $uri->nid and $uri->nss, which return the Namespace Identifier
+and the Namespace-Specific String respectively.
+
+The Namespace Identifier basically works like the Scheme identifier of
+URIs, and further divides the URN namespace. Namespace Identifier
+assignments are maintained at
+L<http://www.iana.org/assignments/urn-namespaces>.
+
+Letter case is not significant for the Namespace Identifier. It is
+always returned in lower case by the $uri->nid method. The $uri->_nid
+method can be used if you want it in its original case.
+
+=item B<urn>:B<isbn>:
+
+The C<urn:isbn:> namespace contains International Standard Book
+Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging
+to this namespace has the following extra methods (if the
+Business::ISBN module is available): $uri->isbn,
+$uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code,
+which is still supported by issues a deprecation warning), $uri->isbn_as_ean.
+
+=item B<urn>:B<oid>:
+
+The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is
+described in RFC 3061. An object identifier consists of sequences of digits
+separated by dots. A C<URI> object belonging to this namespace has an
+additional method called $uri->oid that can be used to get/set the oid
+value. In a list context, oid numbers are returned as separate elements.
+
+=back
+
+=head1 CONFIGURATION VARIABLES
+
+The following configuration variables influence how the class and its
+methods behave:
+
+=over 4
+
+=item $URI::ABS_ALLOW_RELATIVE_SCHEME
+
+Some older parsers used to allow the scheme name to be present in the
+relative URL if it was the same as the base URL scheme. RFC 2396 says
+that this should be avoided, but you can enable this old behaviour by
+setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value.
+The difference is demonstrated by the following examples:
+
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:foo"
+
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:/host/a/foo"
+
+
+=item $URI::ABS_REMOTE_LEADING_DOTS
+
+You can also have the abs() method ignore excess ".."
+segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS
+to a TRUE value. The difference is demonstrated by the following
+examples:
+
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/../../foo"
+
+ local $URI::ABS_REMOTE_LEADING_DOTS = 1;
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/foo"
+
+=item $URI::DEFAULT_QUERY_FORM_DELIMITER
+
+This value can be set to ";" to have the query form C<key=value> pairs
+delimited by ";" instead of "&" which is the default.
+
+=back
+
+=head1 BUGS
+
+There are some things that are not quite right:
+
+=over
+
+=item *
+
+Using regexp variables like $1 directly as arguments to the URI accessor methods
+does not work too well with current perl implementations. I would argue
+that this is actually a bug in perl. The workaround is to quote
+them. Example:
+
+ /(...)/ || die;
+ $u->query("$1");
+
+
+=item *
+
+The escaping (percent encoding) of chars in the 128 .. 255 range passed to the
+URI constructor or when setting URI parts using the accessor methods depend on
+the state of the internal UTF8 flag (see utf8::is_utf8) of the string passed.
+If the UTF8 flag is set the UTF-8 encoded version of the character is percent
+encoded. If the UTF8 flag isn't set the Latin-1 version (byte) of the
+character is percent encoded. This basically exposes the internal encoding of
+Perl strings.
+
+=back
+
+=head1 PARSING URIs WITH REGEXP
+
+As an alternative to this module, the following (official) regular
+expression can be used to decode a URI:
+
+ my($scheme, $authority, $path, $query, $fragment) =
+ $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
+
+The C<URI::Split> module provides the function uri_split() as a
+readable alternative.
+
+=head1 SEE ALSO
+
+L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>,
+L<URI::Split>, L<URI::Heuristic>
+
+RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax",
+Berners-Lee, Fielding, Masinter, August 1998.
+
+L<http://www.iana.org/assignments/uri-schemes>
+
+L<http://www.iana.org/assignments/urn-namespaces>
+
+L<http://www.w3.org/Addressing/>
+
+=head1 COPYRIGHT
+
+Copyright 1995-2009 Gisle Aas.
+
+Copyright 1995 Martijn Koster.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 AUTHORS / ACKNOWLEDGMENTS
+
+This module is based on the C<URI::URL> module, which in turn was
+(distantly) based on the C<wwwurl.pl> code in the libwww-perl for
+perl4 developed by Roy Fielding, as part of the Arcadia project at the
+University of California, Irvine, with contributions from Brooks
+Cutter.
+
+C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and
+Martijn Koster with input from other people on the libwww-perl mailing
+list.
+
+C<URI> and related subclasses was developed by Gisle Aas.
+
+=cut
--- /dev/null
+package URI::Escape;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+URI::Escape - Percent-encode and percent-decode unsafe characters
+
+=head1 SYNOPSIS
+
+ use URI::Escape;
+ $safe = uri_escape("10% is enough\n");
+ $verysafe = uri_escape("foo", "\0-\377");
+ $str = uri_unescape($safe);
+
+=head1 DESCRIPTION
+
+This module provides functions to percent-encode and percent-decode URI strings as
+defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping".
+This is the terminology used by this module, which predates the formalization of the
+terms by the RFC by several years.
+
+A URI consists of a restricted set of characters. The restricted set
+of characters consists of digits, letters, and a few graphic symbols
+chosen from those common to most of the character encodings and input
+facilities available to Internet users. They are made up of the
+"unreserved" and "reserved" character sets as defined in RFC 3986.
+
+ unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
+ reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@"
+ "!" / "$" / "&" / "'" / "(" / ")"
+ / "*" / "+" / "," / ";" / "="
+
+In addition, any byte (octet) can be represented in a URI by an escape
+sequence: a triplet consisting of the character "%" followed by two
+hexadecimal digits. A byte can also be represented directly by a
+character, using the US-ASCII character for that octet.
+
+Some of the characters are I<reserved> for use as delimiters or as
+part of certain URI components. These must be escaped if they are to
+be treated as ordinary data. Read RFC 3986 for further details.
+
+The functions provided (and exported by default) from this module are:
+
+=over 4
+
+=item uri_escape( $string )
+
+=item uri_escape( $string, $unsafe )
+
+Replaces each unsafe character in the $string with the corresponding
+escape sequence and returns the result. The $string argument should
+be a string of bytes. The uri_escape() function will croak if given a
+characters with code above 255. Use uri_escape_utf8() if you know you
+have such chars or/and want chars in the 128 .. 255 range treated as
+UTF-8.
+
+The uri_escape() function takes an optional second argument that
+overrides the set of characters that are to be escaped. The set is
+specified as a string that can be used in a regular expression
+character class (between [ ]). E.g.:
+
+ "\x00-\x1f\x7f-\xff" # all control and hi-bit characters
+ "a-z" # all lower case characters
+ "^A-Za-z" # everything not a letter
+
+The default set of characters to be escaped is all those which are
+I<not> part of the C<unreserved> character class shown above as well
+as the reserved characters. I.e. the default is:
+
+ "^A-Za-z0-9\-\._~"
+
+=item uri_escape_utf8( $string )
+
+=item uri_escape_utf8( $string, $unsafe )
+
+Works like uri_escape(), but will encode chars as UTF-8 before
+escaping them. This makes this function able to deal with characters
+with code above 255 in $string. Note that chars in the 128 .. 255
+range will be escaped differently by this function compared to what
+uri_escape() would. For chars in the 0 .. 127 range there is no
+difference.
+
+Equivalent to:
+
+ utf8::encode($string);
+ my $uri = uri_escape($string);
+
+Note: JavaScript has a function called escape() that produces the
+sequence "%uXXXX" for chars in the 256 .. 65535 range. This function
+has really nothing to do with URI escaping but some folks got confused
+since it "does the right thing" in the 0 .. 255 range. Because of
+this you sometimes see "URIs" with these kind of escapes. The
+JavaScript encodeURIComponent() function is similar to uri_escape_utf8().
+
+=item uri_unescape($string,...)
+
+Returns a string with each %XX sequence replaced with the actual byte
+(octet).
+
+This does the same as:
+
+ $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+
+but does not modify the string in-place as this RE would. Using the
+uri_unescape() function instead of the RE might make the code look
+cleaner and is a few characters less to type.
+
+In a simple benchmark test I did,
+calling the function (instead of the inline RE above) if a few chars
+were unescaped was something like 40% slower, and something like 700% slower if none were. If
+you are going to unescape a lot of times it might be a good idea to
+inline the RE.
+
+If the uri_unescape() function is passed multiple strings, then each
+one is returned unescaped.
+
+=back
+
+The module can also export the C<%escapes> hash, which contains the
+mapping from all 256 bytes to the corresponding escape codes. Lookup
+in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))>
+each time.
+
+=head1 SEE ALSO
+
+L<URI>
+
+
+=head1 COPYRIGHT
+
+Copyright 1995-2004 Gisle Aas.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+use Exporter 5.57 'import';
+our %escapes;
+our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8);
+our @EXPORT_OK = qw(%escapes);
+our $VERSION = "3.31";
+
+use Carp ();
+
+# Build a char->hex map
+for (0..255) {
+ $escapes{chr($_)} = sprintf("%%%02X", $_);
+}
+
+my %subst; # compiled patterns
+
+my %Unsafe = (
+ RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/,
+ RFC3986 => qr/[^A-Za-z0-9\-\._~]/,
+);
+
+sub uri_escape {
+ my($text, $patn) = @_;
+ return undef unless defined $text;
+ if (defined $patn){
+ unless (exists $subst{$patn}) {
+ # Because we can't compile the regex we fake it with a cached sub
+ (my $tmp = $patn) =~ s,/,\\/,g;
+ eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }";
+ Carp::croak("uri_escape: $@") if $@;
+ }
+ &{$subst{$patn}}($text);
+ } else {
+ $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge;
+ }
+ $text;
+}
+
+sub _fail_hi {
+ my $chr = shift;
+ Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr));
+}
+
+sub uri_escape_utf8 {
+ my $text = shift;
+ return undef unless defined $text;
+ utf8::encode($text);
+ return uri_escape($text, @_);
+}
+
+sub uri_unescape {
+ # Note from RFC1630: "Sequences which start with a percent sign
+ # but are not followed by two hexadecimal characters are reserved
+ # for future extension"
+ my $str = shift;
+ if (@_ && wantarray) {
+ # not executed for the common case of a single argument
+ my @str = ($str, @_); # need to copy
+ for (@str) {
+ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ }
+ return @str;
+ }
+ $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str;
+ $str;
+}
+
+# XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format.
+sub escape_char {
+ # Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1).
+ # The following forces a fetch to occur beforehand.
+ my $dummy = substr($_[0], 0, 0);
+
+ if (utf8::is_utf8($_[0])) {
+ my $s = shift;
+ utf8::encode($s);
+ unshift(@_, $s);
+ }
+
+ return join '', @URI::Escape::escapes{split //, $_[0]};
+}
+
+1;
--- /dev/null
+package URI::Heuristic;
+
+=head1 NAME
+
+URI::Heuristic - Expand URI using heuristics
+
+=head1 SYNOPSIS
+
+ use URI::Heuristic qw(uf_uristr);
+ $u = uf_uristr("perl"); # http://www.perl.com
+ $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol
+ $u = uf_uristr("aas"); # http://www.aas.no
+ $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi
+ $u = uf_uristr("/etc/passwd"); # file:/etc/passwd
+
+=head1 DESCRIPTION
+
+This module provides functions that expand strings into real absolute
+URIs using some built-in heuristics. Strings that already represent
+absolute URIs (i.e. that start with a C<scheme:> part) are never modified
+and are returned unchanged. The main use of these functions is to
+allow abbreviated URIs similar to what many web browsers allow for URIs
+typed in by the user.
+
+The following functions are provided:
+
+=over 4
+
+=item uf_uristr($str)
+
+Tries to make the argument string
+into a proper absolute URI string. The "uf_" prefix stands for "User
+Friendly". Under MacOS, it assumes that any string with a common URL
+scheme (http, ftp, etc.) is a URL rather than a local path. So don't name
+your volumes after common URL schemes and expect uf_uristr() to construct
+valid file: URL's on those volumes for you, because it won't.
+
+=item uf_uri($str)
+
+Works the same way as uf_uristr() but
+returns a C<URI> object.
+
+=back
+
+=head1 ENVIRONMENT
+
+If the hostname portion of a URI does not contain any dots, then
+certain qualified guesses are made. These guesses are governed by
+the following environment variables:
+
+=over 10
+
+=item COUNTRY
+
+The two-letter country code (ISO 3166) for your location. If
+the domain name of your host ends with two letters, then it is taken
+to be the default country. See also L<Locale::Country>.
+
+=item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG
+
+If COUNTRY is not set, these standard environment variables are
+examined and country (not language) information possibly found in them
+is used as the default country.
+
+=item URL_GUESS_PATTERN
+
+Contains a space-separated list of URL patterns to try. The string
+"ACME" is for some reason used as a placeholder for the host name in
+the URL provided. Example:
+
+ URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com"
+ export URL_GUESS_PATTERN
+
+Specifying URL_GUESS_PATTERN disables any guessing rules based on
+country. An empty URL_GUESS_PATTERN disables any guessing that
+involves host name lookups.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 1997-1998, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use warnings;
+
+use Exporter 5.57 'import';
+our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr);
+our $VERSION = "4.20";
+
+our ($MY_COUNTRY, $DEBUG);
+
+sub MY_COUNTRY() {
+ for ($MY_COUNTRY) {
+ return $_ if defined;
+
+ # First try the environment.
+ $_ = $ENV{COUNTRY};
+ return $_ if defined;
+
+ # Try the country part of LC_ALL and LANG from environment
+ my @srcs = ($ENV{LC_ALL}, $ENV{LANG});
+ # ...and HTTP_ACCEPT_LANGUAGE before those if present
+ if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) {
+ # TODO: q-value processing/ordering
+ for $httplang (split(/\s*,\s*/, $httplang)) {
+ if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) {
+ unshift(@srcs, "${1}_${2}");
+ last;
+ }
+ }
+ }
+ for (@srcs) {
+ next unless defined;
+ return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/;
+ }
+
+ # Last bit of domain name. This may access the network.
+ require Net::Domain;
+ my $fqdn = Net::Domain::hostfqdn();
+ $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/;
+ return $_ if defined;
+
+ # Give up. Defined but false.
+ return ($_ = 0);
+ }
+}
+
+our %LOCAL_GUESSING =
+(
+ 'us' => [qw(www.ACME.gov www.ACME.mil)],
+ 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)],
+ 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)],
+ 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)],
+ # send corrections and new entries to <gisle@aas.no>
+);
+# Backwards compatibility; uk != United Kingdom in ISO 3166
+$LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb};
+
+
+sub uf_uristr ($)
+{
+ local($_) = @_;
+ print STDERR "uf_uristr: resolving $_\n" if $DEBUG;
+ return unless defined;
+
+ s/^\s+//;
+ s/\s+$//;
+
+ if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) {
+ $_ = "http://$_";
+
+ } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) {
+ $_ = lc($1) . "://$_";
+
+ } elsif ($^O ne "MacOS" &&
+ (m,^/, || # absolute file name
+ m,^\.\.?/, || # relative file name
+ m,^[a-zA-Z]:[/\\],) # dosish file name
+ )
+ {
+ $_ = "file:$_";
+
+ } elsif ($^O eq "MacOS" && m/:/) {
+ # potential MacOS file name
+ unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) {
+ require URI::file;
+ my $a = URI::file->new($_)->as_string;
+ $_ = ($a =~ m/^file:/) ? $a : "file:$a";
+ }
+ } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) {
+ $_ = "mailto:$_";
+
+ } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified
+ if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) {
+ my $host = $1;
+
+ my $scheme = "http";
+ if (/^:(\d+)\b/) {
+ # Some more or less well known ports
+ if ($1 =~ /^[56789]?443$/) {
+ $scheme = "https";
+ } elsif ($1 eq "21") {
+ $scheme = "ftp";
+ }
+ }
+
+ if ($host !~ /\./ && $host ne "localhost") {
+ my @guess;
+ if (exists $ENV{URL_GUESS_PATTERN}) {
+ @guess = map { s/\bACME\b/$host/; $_ }
+ split(' ', $ENV{URL_GUESS_PATTERN});
+ } else {
+ if (MY_COUNTRY()) {
+ my $special = $LOCAL_GUESSING{MY_COUNTRY()};
+ if ($special) {
+ my @special = @$special;
+ push(@guess, map { s/\bACME\b/$host/; $_ }
+ @special);
+ } else {
+ push(@guess, "www.$host." . MY_COUNTRY());
+ }
+ }
+ push(@guess, map "www.$host.$_",
+ "com", "org", "net", "edu", "int");
+ }
+
+
+ my $guess;
+ for $guess (@guess) {
+ print STDERR "uf_uristr: gethostbyname('$guess.')..."
+ if $DEBUG;
+ if (gethostbyname("$guess.")) {
+ print STDERR "yes\n" if $DEBUG;
+ $host = $guess;
+ last;
+ }
+ print STDERR "no\n" if $DEBUG;
+ }
+ }
+ $_ = "$scheme://$host$_";
+
+ } else {
+ # pure junk, just return it unchanged...
+
+ }
+ }
+ print STDERR "uf_uristr: ==> $_\n" if $DEBUG;
+
+ $_;
+}
+
+sub uf_uri ($)
+{
+ require URI;
+ URI->new(uf_uristr($_[0]));
+}
+
+# legacy
+*uf_urlstr = \*uf_uristr;
+
+sub uf_url ($)
+{
+ require URI::URL;
+ URI::URL->new(uf_uristr($_[0]));
+}
+
+1;
--- /dev/null
+package URI::IRI;
+
+# Experimental
+
+use strict;
+use warnings;
+use URI ();
+
+use overload '""' => sub { shift->as_string };
+
+our $VERSION = '1.76';
+
+sub new {
+ my($class, $uri, $scheme) = @_;
+ utf8::upgrade($uri);
+ return bless {
+ uri => URI->new($uri, $scheme),
+ }, $class;
+}
+
+sub clone {
+ my $self = shift;
+ return bless {
+ uri => $self->{uri}->clone,
+ }, ref($self);
+}
+
+sub as_string {
+ my $self = shift;
+ return $self->{uri}->as_iri;
+}
+
+our $AUTOLOAD;
+sub AUTOLOAD
+{
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+ # We create the function here so that it will not need to be
+ # autoloaded the next time.
+ no strict 'refs';
+ *$method = sub { shift->{uri}->$method(@_) };
+ goto &$method;
+}
+
+sub DESTROY {} # avoid AUTOLOADing it
+
+1;
--- /dev/null
+package URI::QueryParam;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+sub URI::_query::query_param {
+ my $self = shift;
+ my @old = $self->query_form;
+
+ if (@_ == 0) {
+ # get keys
+ my (%seen, $i);
+ return grep !($i++ % 2 || $seen{$_}++), @old;
+ }
+
+ my $key = shift;
+ my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old;
+
+ if (@_) {
+ my @new = @old;
+ my @new_i = @i;
+ my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
+
+ while (@new_i > @vals) {
+ splice @new, pop @new_i, 2;
+ }
+ if (@vals > @new_i) {
+ my $i = @new_i ? $new_i[-1] + 2 : @new;
+ my @splice = splice @vals, @new_i, @vals - @new_i;
+
+ splice @new, $i, 0, map { $key => $_ } @splice;
+ }
+ if (@vals) {
+ #print "SET $new_i[0]\n";
+ @new[ map $_ + 1, @new_i ] = @vals;
+ }
+
+ $self->query_form(\@new);
+ }
+
+ return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef;
+}
+
+sub URI::_query::query_param_append {
+ my $self = shift;
+ my $key = shift;
+ my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_;
+ $self->query_form($self->query_form, $key => \@vals); # XXX
+ return;
+}
+
+sub URI::_query::query_param_delete {
+ my $self = shift;
+ my $key = shift;
+ my @old = $self->query_form;
+ my @vals;
+
+ for (my $i = @old - 2; $i >= 0; $i -= 2) {
+ next if $old[$i] ne $key;
+ push(@vals, (splice(@old, $i, 2))[1]);
+ }
+ $self->query_form(\@old) if @vals;
+ return wantarray ? reverse @vals : $vals[-1];
+}
+
+sub URI::_query::query_form_hash {
+ my $self = shift;
+ my @old = $self->query_form;
+ if (@_) {
+ $self->query_form(@_ == 1 ? %{shift(@_)} : @_);
+ }
+ my %hash;
+ while (my($k, $v) = splice(@old, 0, 2)) {
+ if (exists $hash{$k}) {
+ for ($hash{$k}) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push(@$_, $v);
+ }
+ }
+ else {
+ $hash{$k} = $v;
+ }
+ }
+ return \%hash;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::QueryParam - Additional query methods for URIs
+
+=head1 SYNOPSIS
+
+ use URI;
+ use URI::QueryParam;
+
+ $u = URI->new("", "http");
+ $u->query_param(foo => 1, 2, 3);
+ print $u->query; # prints foo=1&foo=2&foo=3
+
+ for my $key ($u->query_param) {
+ print "$key: ", join(", ", $u->query_param($key)), "\n";
+ }
+
+=head1 DESCRIPTION
+
+Loading the C<URI::QueryParam> module adds some extra methods to
+URIs that support query methods. These methods provide an alternative
+interface to the $u->query_form data.
+
+The query_param_* methods have deliberately been made identical to the
+interface of the corresponding C<CGI.pm> methods.
+
+The following additional methods are made available:
+
+=over
+
+=item @keys = $u->query_param
+
+=item @values = $u->query_param( $key )
+
+=item $first_value = $u->query_param( $key )
+
+=item $u->query_param( $key, $value,... )
+
+If $u->query_param is called with no arguments, it returns all the
+distinct parameter keys of the URI. In a scalar context it returns the
+number of distinct keys.
+
+When a $key argument is given, the method returns the parameter values with the
+given key. In a scalar context, only the first parameter value is
+returned.
+
+If additional arguments are given, they are used to update successive
+parameters with the given key. If any of the values provided are
+array references, then the array is dereferenced to get the actual
+values.
+
+Please note that you can supply multiple values to this method, but you cannot
+supply multiple keys.
+
+Do this:
+
+ $uri->query_param( widget_id => 1, 5, 9 );
+
+Do NOT do this:
+
+ $uri->query_param( widget_id => 1, frobnicator_id => 99 );
+
+=item $u->query_param_append($key, $value,...)
+
+Adds new parameters with the given
+key without touching any old parameters with the same key. It
+can be explained as a more efficient version of:
+
+ $u->query_param($key,
+ $u->query_param($key),
+ $value,...);
+
+One difference is that this expression would return the old values
+of $key, whereas the query_param_append() method does not.
+
+=item @values = $u->query_param_delete($key)
+
+=item $first_value = $u->query_param_delete($key)
+
+Deletes all key/value pairs with the given key.
+The old values are returned. In a scalar context, only the first value
+is returned.
+
+Using the query_param_delete() method is slightly more efficient than
+the equivalent:
+
+ $u->query_param($key, []);
+
+=item $hashref = $u->query_form_hash
+
+=item $u->query_form_hash( \%new_form )
+
+Returns a reference to a hash that represents the
+query form's key/value pairs. If a key occurs multiple times, then the hash
+value becomes an array reference.
+
+Note that sequence information is lost. This means that:
+
+ $u->query_form_hash($u->query_form_hash);
+
+is not necessarily a no-op, as it may reorder the key/value pairs.
+The values returned by the query_param() method should stay the same
+though.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<CGI>
+
+=head1 COPYRIGHT
+
+Copyright 2002 Gisle Aas.
+
+=cut
--- /dev/null
+package URI::Split;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use Exporter 5.57 'import';
+our @EXPORT_OK = qw(uri_split uri_join);
+
+use URI::Escape ();
+
+sub uri_split {
+ return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
+}
+
+sub uri_join {
+ my($scheme, $auth, $path, $query, $frag) = @_;
+ my $uri = defined($scheme) ? "$scheme:" : "";
+ $path = "" unless defined $path;
+ if (defined $auth) {
+ $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+ $uri .= "//$auth";
+ $path = "/$path" if length($path) && $path !~ m,^/,;
+ }
+ elsif ($path =~ m,^//,) {
+ $uri .= "//"; # XXX force empty auth
+ }
+ unless (length $uri) {
+ $path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,;
+ }
+ $path =~ s,([?\#]), URI::Escape::escape_char($1),eg;
+ $uri .= $path;
+ if (defined $query) {
+ $query =~ s,(\#), URI::Escape::escape_char($1),eg;
+ $uri .= "?$query";
+ }
+ $uri .= "#$frag" if defined $frag;
+ $uri;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::Split - Parse and compose URI strings
+
+=head1 SYNOPSIS
+
+ use URI::Split qw(uri_split uri_join);
+ ($scheme, $auth, $path, $query, $frag) = uri_split($uri);
+ $uri = uri_join($scheme, $auth, $path, $query, $frag);
+
+=head1 DESCRIPTION
+
+Provides functions to parse and compose URI
+strings. The following functions are provided:
+
+=over
+
+=item ($scheme, $auth, $path, $query, $frag) = uri_split($uri)
+
+Breaks up a URI string into its component
+parts. An C<undef> value is returned for those parts that are not
+present. The $path part is always present (but can be the empty
+string) and is thus never returned as C<undef>.
+
+No sensible value is returned if this function is called in a scalar
+context.
+
+=item $uri = uri_join($scheme, $auth, $path, $query, $frag)
+
+Puts together a URI string from its parts.
+Missing parts are signaled by passing C<undef> for the corresponding
+argument.
+
+Minimal escaping is applied to parts that contain reserved chars
+that would confuse a parser. For instance, any occurrence of '?' or '#'
+in $path is always escaped, as it would otherwise be parsed back
+as a query or fragment.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>, L<URI::Escape>
+
+=head1 COPYRIGHT
+
+Copyright 2003, Gisle Aas
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package URI::URL;
+
+use strict;
+use warnings;
+
+use parent 'URI::WithBase';
+
+our $VERSION = "5.04";
+
+# Provide as much as possible of the old URI::URL interface for backwards
+# compatibility...
+
+use Exporter 5.57 'import';
+our @EXPORT = qw(url);
+
+# Easy to use constructor
+sub url ($;$) { URI::URL->new(@_); }
+
+use URI::Escape qw(uri_unescape);
+
+sub new
+{
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->[0] = $self->[0]->canonical;
+ $self;
+}
+
+sub newlocal
+{
+ my $class = shift;
+ require URI::file;
+ bless [URI::file->new_abs(shift)], $class;
+}
+
+{package URI::_foreign;
+ sub _init # hope it is not defined
+ {
+ my $class = shift;
+ die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT;
+ $class->SUPER::_init(@_);
+ }
+}
+
+sub strict
+{
+ my $old = $URI::URL::STRICT;
+ $URI::URL::STRICT = shift if @_;
+ $old;
+}
+
+sub print_on
+{
+ my $self = shift;
+ require Data::Dumper;
+ print STDERR Data::Dumper::Dumper($self);
+}
+
+sub _try
+{
+ my $self = shift;
+ my $method = shift;
+ scalar(eval { $self->$method(@_) });
+}
+
+sub crack
+{
+ # should be overridden by subclasses
+ my $self = shift;
+ (scalar($self->scheme),
+ $self->_try("user"),
+ $self->_try("password"),
+ $self->_try("host"),
+ $self->_try("port"),
+ $self->_try("path"),
+ $self->_try("params"),
+ $self->_try("query"),
+ scalar($self->fragment),
+ )
+}
+
+sub full_path
+{
+ my $self = shift;
+ my $path = $self->path_query;
+ $path = "/" unless length $path;
+ $path;
+}
+
+sub netloc
+{
+ shift->authority(@_);
+}
+
+sub epath
+{
+ my $path = shift->SUPER::path(@_);
+ $path =~ s/;.*//;
+ $path;
+}
+
+sub eparams
+{
+ my $self = shift;
+ my @p = $self->path_segments;
+ return undef unless ref($p[-1]);
+ @p = @{$p[-1]};
+ shift @p;
+ join(";", @p);
+}
+
+sub params { shift->eparams(@_); }
+
+sub path {
+ my $self = shift;
+ my $old = $self->epath(@_);
+ return unless defined wantarray;
+ return '/' if !defined($old) || !length($old);
+ Carp::croak("Path components contain '/' (you must call epath)")
+ if $old =~ /%2[fF]/ and !@_;
+ $old = "/$old" if $old !~ m|^/| && defined $self->netloc;
+ return uri_unescape($old);
+}
+
+sub path_components {
+ shift->path_segments(@_);
+}
+
+sub query {
+ my $self = shift;
+ my $old = $self->equery(@_);
+ if (defined(wantarray) && defined($old)) {
+ if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+'
+ my $mess;
+ for ($old) {
+ $mess = "Query contains both '+' and '%2B'"
+ if /\+/ && /%2[bB]/;
+ $mess = "Form query contains escaped '=' or '&'"
+ if /=/ && /%(?:3[dD]|26)/;
+ }
+ if ($mess) {
+ Carp::croak("$mess (you must call equery)");
+ }
+ }
+ # Now it should be safe to unescape the string without losing
+ # information
+ return uri_unescape($old);
+ }
+ undef;
+
+}
+
+sub abs
+{
+ my $self = shift;
+ my $base = shift;
+ my $allow_scheme = shift;
+ $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME
+ unless defined $allow_scheme;
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme;
+ local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS;
+ $self->SUPER::abs($base);
+}
+
+sub frag { shift->fragment(@_); }
+sub keywords { shift->query_keywords(@_); }
+
+# file:
+sub local_path { shift->file; }
+sub unix_path { shift->file("unix"); }
+sub dos_path { shift->file("dos"); }
+sub mac_path { shift->file("mac"); }
+sub vms_path { shift->file("vms"); }
+
+# mailto:
+sub address { shift->to(@_); }
+sub encoded822addr { shift->to(@_); }
+sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work
+
+# news:
+sub groupart { shift->_group(@_); }
+sub article { shift->message(@_); }
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::URL - Uniform Resource Locators
+
+=head1 SYNOPSIS
+
+ $u1 = URI::URL->new($str, $base);
+ $u2 = $u1->abs;
+
+=head1 DESCRIPTION
+
+This module is provided for backwards compatibility with modules that
+depend on the interface provided by the C<URI::URL> class that used to
+be distributed with the libwww-perl library.
+
+The following differences exist compared to the C<URI> class interface:
+
+=over 3
+
+=item *
+
+The URI::URL module exports the url() function as an alternate
+constructor interface.
+
+=item *
+
+The constructor takes an optional $base argument. The C<URI::URL>
+class is a subclass of C<URI::WithBase>.
+
+=item *
+
+The URI::URL->newlocal class method is the same as URI::file->new_abs.
+
+=item *
+
+URI::URL::strict(1)
+
+=item *
+
+$url->print_on method
+
+=item *
+
+$url->crack method
+
+=item *
+
+$url->full_path: same as ($uri->abs_path || "/")
+
+=item *
+
+$url->netloc: same as $uri->authority
+
+=item *
+
+$url->epath, $url->equery: same as $uri->path, $uri->query
+
+=item *
+
+$url->path and $url->query pass unescaped strings.
+
+=item *
+
+$url->path_components: same as $uri->path_segments (if you don't
+consider path segment parameters)
+
+=item *
+
+$url->params and $url->eparams methods
+
+=item *
+
+$url->base method. See L<URI::WithBase>.
+
+=item *
+
+$url->abs and $url->rel have an optional $base argument. See
+L<URI::WithBase>.
+
+=item *
+
+$url->frag: same as $uri->fragment
+
+=item *
+
+$url->keywords: same as $uri->query_keywords
+
+=item *
+
+$url->localpath and friends map to $uri->file.
+
+=item *
+
+$url->address and $url->encoded822addr: same as $uri->to for mailto URI
+
+=item *
+
+$url->groupart method for news URI
+
+=item *
+
+$url->article: same as $uri->message
+
+=back
+
+
+
+=head1 SEE ALSO
+
+L<URI>, L<URI::WithBase>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2000 Gisle Aas.
+
+=cut
--- /dev/null
+package URI::WithBase;
+
+use strict;
+use warnings;
+
+use URI;
+use Scalar::Util 'blessed';
+
+our $VERSION = "2.20";
+
+use overload '""' => "as_string", fallback => 1;
+
+sub as_string; # help overload find it
+
+sub new
+{
+ my($class, $uri, $base) = @_;
+ my $ibase = $base;
+ if ($base && blessed($base) && $base->isa(__PACKAGE__)) {
+ $base = $base->abs;
+ $ibase = $base->[0];
+ }
+ bless [URI->new($uri, $ibase), $base], $class;
+}
+
+sub new_abs
+{
+ my $class = shift;
+ my $self = $class->new(@_);
+ $self->abs;
+}
+
+sub _init
+{
+ my $class = shift;
+ my($str, $scheme) = @_;
+ bless [URI->new($str, $scheme), undef], $class;
+}
+
+sub eq
+{
+ my($self, $other) = @_;
+ $other = $other->[0] if blessed($other) and $other->isa(__PACKAGE__);
+ $self->[0]->eq($other);
+}
+
+our $AUTOLOAD;
+sub AUTOLOAD
+{
+ my $self = shift;
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+ return if $method eq "DESTROY";
+ $self->[0]->$method(@_);
+}
+
+sub can { # override UNIVERSAL::can
+ my $self = shift;
+ $self->SUPER::can(@_) || (
+ ref($self)
+ ? $self->[0]->can(@_)
+ : undef
+ )
+}
+
+sub base {
+ my $self = shift;
+ my $base = $self->[1];
+
+ if (@_) { # set
+ my $new_base = shift;
+ # ensure absoluteness
+ $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__);
+ $self->[1] = $new_base;
+ }
+ return unless defined wantarray;
+
+ # The base attribute supports 'lazy' conversion from URL strings
+ # to URL objects. Strings may be stored but when a string is
+ # fetched it will automatically be converted to a URL object.
+ # The main benefit is to make it much cheaper to say:
+ # URI::WithBase->new($random_url_string, 'http:')
+ if (defined($base) && !ref($base)) {
+ $base = ref($self)->new($base);
+ $self->[1] = $base unless @_;
+ }
+ $base;
+}
+
+sub clone
+{
+ my $self = shift;
+ my $base = $self->[1];
+ $base = $base->clone if ref($base);
+ bless [$self->[0]->clone, $base], ref($self);
+}
+
+sub abs
+{
+ my $self = shift;
+ my $base = shift || $self->base || return $self->clone;
+ $base = $base->as_string if ref($base);
+ bless [$self->[0]->abs($base, @_), $base], ref($self);
+}
+
+sub rel
+{
+ my $self = shift;
+ my $base = shift || $self->base || return $self->clone;
+ $base = $base->as_string if ref($base);
+ bless [$self->[0]->rel($base, @_), $base], ref($self);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::WithBase - URIs which remember their base
+
+=head1 SYNOPSIS
+
+ $u1 = URI::WithBase->new($str, $base);
+ $u2 = $u1->abs;
+
+ $base = $u1->base;
+ $u1->base( $new_base )
+
+=head1 DESCRIPTION
+
+This module provides the C<URI::WithBase> class. Objects of this class
+are like C<URI> objects, but can keep their base too. The base
+represents the context where this URI was found and can be used to
+absolutize or relativize the URI. All the methods described in L<URI>
+are supported for C<URI::WithBase> objects.
+
+The methods provided in addition to or modified from those of C<URI> are:
+
+=over 4
+
+=item $uri = URI::WithBase->new($str, [$base])
+
+The constructor takes an optional base URI as the second argument.
+If provided, this argument initializes the base attribute.
+
+=item $uri->base( [$new_base] )
+
+Can be used to get or set the value of the base attribute.
+The return value, which is the old value, is a URI object or C<undef>.
+
+=item $uri->abs( [$base_uri] )
+
+The $base_uri argument is now made optional as the object carries its
+base with it. A new object is returned even if $uri is already
+absolute (while plain URI objects simply return themselves in
+that case).
+
+=item $uri->rel( [$base_uri] )
+
+The $base_uri argument is now made optional as the object carries its
+base with it. A new object is always returned.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<URI>
+
+=head1 COPYRIGHT
+
+Copyright 1998-2002 Gisle Aas.
+
+=cut
--- /dev/null
+package URI::_foreign;
+
+use strict;
+use warnings;
+
+use parent 'URI::_generic';
+
+our $VERSION = '1.76';
+
+1;
--- /dev/null
+package URI::_generic;
+
+use strict;
+use warnings;
+
+use parent qw(URI URI::_query);
+
+use URI::Escape qw(uri_unescape);
+use Carp ();
+
+our $VERSION = '1.76';
+
+my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g;
+my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
+
+sub _no_scheme_ok { 1 }
+
+sub authority
+{
+ my $self = shift;
+ $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
+
+ if (@_) {
+ my $auth = shift;
+ $$self = $1;
+ my $rest = $3;
+ if (defined $auth) {
+ $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($auth);
+ $$self .= "//$auth";
+ }
+ _check_path($rest, $$self);
+ $$self .= $rest;
+ }
+ $2;
+}
+
+sub path
+{
+ my $self = shift;
+ $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
+
+ if (@_) {
+ $$self = $1;
+ my $rest = $3;
+ my $new_path = shift;
+ $new_path = "" unless defined $new_path;
+ $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($new_path);
+ _check_path($new_path, $$self);
+ $$self .= $new_path . $rest;
+ }
+ $2;
+}
+
+sub path_query
+{
+ my $self = shift;
+ $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
+
+ if (@_) {
+ $$self = $1;
+ my $rest = $3;
+ my $new_path = shift;
+ $new_path = "" unless defined $new_path;
+ $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($new_path);
+ _check_path($new_path, $$self);
+ $$self .= $new_path . $rest;
+ }
+ $2;
+}
+
+sub _check_path
+{
+ my($path, $pre) = @_;
+ my $prefix;
+ if ($pre =~ m,/,) { # authority present
+ $prefix = "/" if length($path) && $path !~ m,^[/?\#],;
+ }
+ else {
+ if ($path =~ m,^//,) {
+ Carp::carp("Path starting with double slash is confusing")
+ if $^W;
+ }
+ elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
+ Carp::carp("Path might look like scheme, './' prepended")
+ if $^W;
+ $prefix = "./";
+ }
+ }
+ substr($_[0], 0, 0) = $prefix if defined $prefix;
+}
+
+sub path_segments
+{
+ my $self = shift;
+ my $path = $self->path;
+ if (@_) {
+ my @arg = @_; # make a copy
+ for (@arg) {
+ if (ref($_)) {
+ my @seg = @$_;
+ $seg[0] =~ s/%/%25/g;
+ for (@seg) { s/;/%3B/g; }
+ $_ = join(";", @seg);
+ }
+ else {
+ s/%/%25/g; s/;/%3B/g;
+ }
+ s,/,%2F,g;
+ }
+ $self->path(join("/", @arg));
+ }
+ return $path unless wantarray;
+ map {/;/ ? $self->_split_segment($_)
+ : uri_unescape($_) }
+ split('/', $path, -1);
+}
+
+
+sub _split_segment
+{
+ my $self = shift;
+ require URI::_segment;
+ URI::_segment->new(@_);
+}
+
+
+sub abs
+{
+ my $self = shift;
+ my $base = shift || Carp::croak("Missing base argument");
+
+ if (my $scheme = $self->scheme) {
+ return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
+ $base = URI->new($base) unless ref $base;
+ return $self unless $scheme eq $base->scheme;
+ }
+
+ $base = URI->new($base) unless ref $base;
+ my $abs = $self->clone;
+ $abs->scheme($base->scheme);
+ return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
+ $abs->authority($base->authority);
+
+ my $path = $self->path;
+ return $abs if $path =~ m,^/,;
+
+ if (!length($path)) {
+ my $abs = $base->clone;
+ my $query = $self->query;
+ $abs->query($query) if defined $query;
+ my $fragment = $self->fragment;
+ $abs->fragment($fragment) if defined $fragment;
+ return $abs;
+ }
+
+ my $p = $base->path;
+ $p =~ s,[^/]+$,,;
+ $p .= $path;
+ my @p = split('/', $p, -1);
+ shift(@p) if @p && !length($p[0]);
+ my $i = 1;
+ while ($i < @p) {
+ #print "$i ", join("/", @p), " ($p[$i])\n";
+ if ($p[$i-1] eq ".") {
+ splice(@p, $i-1, 1);
+ $i-- if $i > 1;
+ }
+ elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
+ splice(@p, $i-1, 2);
+ if ($i > 1) {
+ $i--;
+ push(@p, "") if $i == @p;
+ }
+ }
+ else {
+ $i++;
+ }
+ }
+ $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/."
+ if ($URI::ABS_REMOTE_LEADING_DOTS) {
+ shift @p while @p && $p[0] =~ /^\.\.?$/;
+ }
+ $abs->path("/" . join("/", @p));
+ $abs;
+}
+
+# The opposite of $url->abs. Return a URI which is as relative as possible
+sub rel {
+ my $self = shift;
+ my $base = shift || Carp::croak("Missing base argument");
+ my $rel = $self->clone;
+ $base = URI->new($base) unless ref $base;
+
+ #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
+ my $scheme = $rel->scheme;
+ my $auth = $rel->canonical->authority;
+ my $path = $rel->path;
+
+ if (!defined($scheme) && !defined($auth)) {
+ # it is already relative
+ return $rel;
+ }
+
+ #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
+ my $bscheme = $base->scheme;
+ my $bauth = $base->canonical->authority;
+ my $bpath = $base->path;
+
+ for ($bscheme, $bauth, $auth) {
+ $_ = '' unless defined
+ }
+
+ unless ($scheme eq $bscheme && $auth eq $bauth) {
+ # different location, can't make it relative
+ return $rel;
+ }
+
+ for ($path, $bpath) { $_ = "/$_" unless m,^/,; }
+
+ # Make it relative by eliminating scheme and authority
+ $rel->scheme(undef);
+ $rel->authority(undef);
+
+ # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
+ # First we calculate common initial path components length ($li).
+ my $li = 1;
+ while (1) {
+ my $i = index($path, '/', $li);
+ last if $i < 0 ||
+ $i != index($bpath, '/', $li) ||
+ substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
+ $li=$i+1;
+ }
+ # then we nuke it from both paths
+ substr($path, 0,$li) = '';
+ substr($bpath,0,$li) = '';
+
+ if ($path eq $bpath &&
+ defined($rel->fragment) &&
+ !defined($rel->query)) {
+ $rel->path("");
+ }
+ else {
+ # Add one "../" for each path component left in the base path
+ $path = ('../' x $bpath =~ tr|/|/|) . $path;
+ $path = "./" if $path eq "";
+ $rel->path($path);
+ }
+
+ $rel;
+}
+
+1;
--- /dev/null
+package URI::_idna;
+
+# This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep)
+# based on Python-2.6.4/Lib/encodings/idna.py
+
+use strict;
+use warnings;
+
+use URI::_punycode qw(encode_punycode decode_punycode);
+use Carp qw(croak);
+
+our $VERSION = '1.76';
+
+BEGIN {
+ *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = "$]" < 5.008_003
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+}
+
+my $ASCII = qr/^[\x00-\x7F]*\z/;
+
+sub encode {
+ my $idomain = shift;
+ my @labels = split(/\./, $idomain, -1);
+ my @last_empty;
+ push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq "";
+ for (@labels) {
+ $_ = ToASCII($_);
+ }
+
+ return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS;
+ return join(".", @labels, @last_empty);
+}
+
+sub decode {
+ my $domain = shift;
+ return join(".", map ToUnicode($_), split(/\./, $domain, -1))
+}
+
+sub nameprep { # XXX real implementation missing
+ my $label = shift;
+ $label = lc($label);
+ return $label;
+}
+
+sub check_size {
+ my $label = shift;
+ croak "Label empty" if $label eq "";
+ croak "Label too long" if length($label) > 63;
+ return $label;
+}
+
+sub ToASCII {
+ my $label = shift;
+ return check_size($label) if $label =~ $ASCII;
+
+ # Step 2: nameprep
+ $label = nameprep($label);
+ # Step 3: UseSTD3ASCIIRules is false
+ # Step 4: try ASCII again
+ return check_size($label) if $label =~ $ASCII;
+
+ # Step 5: Check ACE prefix
+ if ($label =~ /^xn--/) {
+ croak "Label starts with ACE prefix";
+ }
+
+ # Step 6: Encode with PUNYCODE
+ $label = encode_punycode($label);
+
+ # Step 7: Prepend ACE prefix
+ $label = "xn--$label";
+
+ # Step 8: Check size
+ return check_size($label);
+}
+
+sub ToUnicode {
+ my $label = shift;
+ $label = nameprep($label) unless $label =~ $ASCII;
+ return $label unless $label =~ /^xn--/;
+ my $result = decode_punycode(substr($label, 4));
+ my $label2 = ToASCII($result);
+ if (lc($label) ne $label2) {
+ croak "IDNA does not round-trip: '\L$label\E' vs '$label2'";
+ }
+ return $result;
+}
+
+1;
--- /dev/null
+# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package URI::_ldap;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use URI::Escape qw(uri_unescape);
+
+sub _ldap_elem {
+ my $self = shift;
+ my $elem = shift;
+ my $query = $self->query;
+ my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4);
+ my $old = $bits[$elem];
+
+ if (@_) {
+ my $new = shift;
+ $new =~ s/\?/%3F/g;
+ $bits[$elem] = $new;
+ $query = join("?",@bits);
+ $query =~ s/\?+$//;
+ $query = undef unless length($query);
+ $self->query($query);
+ }
+
+ $old;
+}
+
+sub dn {
+ my $old = shift->path(@_);
+ $old =~ s:^/::;
+ uri_unescape($old);
+}
+
+sub attributes {
+ my $self = shift;
+ my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
+ return $old unless wantarray;
+ map { uri_unescape($_) } split(/,/,$old);
+}
+
+sub _scope {
+ my $self = shift;
+ my $old = _ldap_elem($self,1, @_);
+ return undef unless defined wantarray && defined $old;
+ uri_unescape($old);
+}
+
+sub scope {
+ my $old = &_scope;
+ $old = "base" unless length $old;
+ $old;
+}
+
+sub _filter {
+ my $self = shift;
+ my $old = _ldap_elem($self,2, @_);
+ return undef unless defined wantarray && defined $old;
+ uri_unescape($old); # || "(objectClass=*)";
+}
+
+sub filter {
+ my $old = &_filter;
+ $old = "(objectClass=*)" unless length $old;
+ $old;
+}
+
+sub extensions {
+ my $self = shift;
+ my @ext;
+ while (@_) {
+ my $key = shift;
+ my $value = shift;
+ push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
+ }
+ @ext = join(",", @ext) if @ext;
+ my $old = _ldap_elem($self,3, @ext);
+ return $old unless wantarray;
+ map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
+}
+
+sub canonical
+{
+ my $self = shift;
+ my $other = $self->_nonldap_canonical;
+
+ # The stuff below is not as efficient as one might hope...
+
+ $other = $other->clone if $other == $self;
+
+ $other->dn(_normalize_dn($other->dn));
+
+ # Should really know about mixed case "postalAddress", etc...
+ $other->attributes(map lc, $other->attributes);
+
+ # Lowercase scope, remove default
+ my $old_scope = $other->scope;
+ my $new_scope = lc($old_scope);
+ $new_scope = "" if $new_scope eq "base";
+ $other->scope($new_scope) if $new_scope ne $old_scope;
+
+ # Remove filter if default
+ my $old_filter = $other->filter;
+ $other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
+ lc($old_filter) eq "objectclass=*";
+
+ # Lowercase extensions types and deal with known extension values
+ my @ext = $other->extensions;
+ for (my $i = 0; $i < @ext; $i += 2) {
+ my $etype = $ext[$i] = lc($ext[$i]);
+ if ($etype =~ /^!?bindname$/) {
+ $ext[$i+1] = _normalize_dn($ext[$i+1]);
+ }
+ }
+ $other->extensions(@ext) if @ext;
+
+ $other;
+}
+
+sub _normalize_dn # RFC 2253
+{
+ my $dn = shift;
+
+ return $dn;
+ # The code below will fail if the "+" or "," is embedding in a quoted
+ # string or simply escaped...
+
+ my @dn = split(/([+,])/, $dn);
+ for (@dn) {
+ s/^([a-zA-Z]+=)/lc($1)/e;
+ }
+ join("", @dn);
+}
+
+1;
--- /dev/null
+package URI::_login;
+
+use strict;
+use warnings;
+
+use parent qw(URI::_server URI::_userpass);
+
+our $VERSION = '1.76';
+
+# Generic terminal logins. This is used as a base class for 'telnet',
+# 'tn3270', and 'rlogin' URL schemes.
+
+1;
--- /dev/null
+package URI::_punycode;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use Exporter 'import';
+our @EXPORT = qw(encode_punycode decode_punycode);
+
+use integer;
+
+our $DEBUG = 0;
+
+use constant BASE => 36;
+use constant TMIN => 1;
+use constant TMAX => 26;
+use constant SKEW => 38;
+use constant DAMP => 700;
+use constant INITIAL_BIAS => 72;
+use constant INITIAL_N => 128;
+
+my $Delimiter = chr 0x2D;
+my $BasicRE = qr/[\x00-\x7f]/;
+
+sub _croak { require Carp; Carp::croak(@_); }
+
+sub digit_value {
+ my $code = shift;
+ return ord($code) - ord("A") if $code =~ /[A-Z]/;
+ return ord($code) - ord("a") if $code =~ /[a-z]/;
+ return ord($code) - ord("0") + 26 if $code =~ /[0-9]/;
+ return;
+}
+
+sub code_point {
+ my $digit = shift;
+ return $digit + ord('a') if 0 <= $digit && $digit <= 25;
+ return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36;
+ die 'NOT COME HERE';
+}
+
+sub adapt {
+ my($delta, $numpoints, $firsttime) = @_;
+ $delta = $firsttime ? $delta / DAMP : $delta / 2;
+ $delta += $delta / $numpoints;
+ my $k = 0;
+ while ($delta > ((BASE - TMIN) * TMAX) / 2) {
+ $delta /= BASE - TMIN;
+ $k += BASE;
+ }
+ return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW));
+}
+
+sub decode_punycode {
+ my $code = shift;
+
+ my $n = INITIAL_N;
+ my $i = 0;
+ my $bias = INITIAL_BIAS;
+ my @output;
+
+ if ($code =~ s/(.*)$Delimiter//o) {
+ push @output, map ord, split //, $1;
+ return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o;
+ }
+
+ while ($code) {
+ my $oldi = $i;
+ my $w = 1;
+ LOOP:
+ for (my $k = BASE; 1; $k += BASE) {
+ my $cp = substr($code, 0, 1, '');
+ my $digit = digit_value($cp);
+ defined $digit or return _croak("invalid punycode input");
+ $i += $digit * $w;
+ my $t = ($k <= $bias) ? TMIN
+ : ($k >= $bias + TMAX) ? TMAX : $k - $bias;
+ last LOOP if $digit < $t;
+ $w *= (BASE - $t);
+ }
+ $bias = adapt($i - $oldi, @output + 1, $oldi == 0);
+ warn "bias becomes $bias" if $DEBUG;
+ $n += $i / (@output + 1);
+ $i = $i % (@output + 1);
+ splice(@output, $i, 0, $n);
+ warn join " ", map sprintf('%04x', $_), @output if $DEBUG;
+ $i++;
+ }
+ return join '', map chr, @output;
+}
+
+sub encode_punycode {
+ my $input = shift;
+ my @input = split //, $input;
+
+ my $n = INITIAL_N;
+ my $delta = 0;
+ my $bias = INITIAL_BIAS;
+
+ my @output;
+ my @basic = grep /$BasicRE/, @input;
+ my $h = my $b = @basic;
+ push @output, @basic;
+ push @output, $Delimiter if $b && $h < @input;
+ warn "basic codepoints: (@output)" if $DEBUG;
+
+ while ($h < @input) {
+ my $m = min(grep { $_ >= $n } map ord, @input);
+ warn sprintf "next code point to insert is %04x", $m if $DEBUG;
+ $delta += ($m - $n) * ($h + 1);
+ $n = $m;
+ for my $i (@input) {
+ my $c = ord($i);
+ $delta++ if $c < $n;
+ if ($c == $n) {
+ my $q = $delta;
+ LOOP:
+ for (my $k = BASE; 1; $k += BASE) {
+ my $t = ($k <= $bias) ? TMIN :
+ ($k >= $bias + TMAX) ? TMAX : $k - $bias;
+ last LOOP if $q < $t;
+ my $cp = code_point($t + (($q - $t) % (BASE - $t)));
+ push @output, chr($cp);
+ $q = ($q - $t) / (BASE - $t);
+ }
+ push @output, chr(code_point($q));
+ $bias = adapt($delta, $h + 1, $h == $b);
+ warn "bias becomes $bias" if $DEBUG;
+ $delta = 0;
+ $h++;
+ }
+ }
+ $delta++;
+ $n++;
+ }
+ return join '', @output;
+}
+
+sub min {
+ my $min = shift;
+ for (@_) { $min = $_ if $_ <= $min }
+ return $min;
+}
+
+1;
+__END__
+
+=encoding utf8
+
+=head1 NAME
+
+URI::_punycode - encodes Unicode string in Punycode
+
+=head1 SYNOPSIS
+
+ use strict;
+ use warnings;
+ use utf8;
+
+ use URI::_punycode qw(encode_punycode decode_punycode);
+
+ # encode a unicode string
+ my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
+ $punycode = encode_punycode('bücher'); # bcher-kva
+ $punycode = encode_punycode('他们为什么不说中文'); # ihqwcrb4cv8a8dqg056pqjye
+
+ # decode a punycode string back into a unicode string
+ my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
+ $unicode = decode_punycode('bcher-kva'); # bücher
+ $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
+
+=head1 DESCRIPTION
+
+L<URI::_punycode> is a module to encode / decode Unicode strings into
+L<Punycode|https://tools.ietf.org/html/rfc3492>, an efficient
+encoding of Unicode for use with L<IDNA|https://tools.ietf.org/html/rfc5890>.
+
+=head1 FUNCTIONS
+
+All functions throw exceptions on failure. You can C<catch> them with
+L<Syntax::Keyword::Try> or L<Try::Tiny>. The following functions are exported
+by default.
+
+=head2 encode_punycode
+
+ my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
+ $punycode = encode_punycode('bücher'); # bcher-kva
+ $punycode = encode_punycode('他们为什么不说中文') # ihqwcrb4cv8a8dqg056pqjye
+
+Takes a Unicode string (UTF8-flagged variable) and returns a Punycode
+encoding for it.
+
+=head2 decode_punycode
+
+ my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
+ $unicode = decode_punycode('bcher-kva'); # bücher
+ $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
+
+Takes a Punycode encoding and returns original Unicode string.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa <F<miyagawa@bulknews.net>> is the author of
+L<IDNA::Punycode> which was the basis for this module.
+
+=head1 SEE ALSO
+
+L<IDNA::Punycode>, L<RFC 3492|https://tools.ietf.org/html/rfc3492>,
+L<RFC 5891|https://tools.ietf.org/html/rfc5891>
+
+=head1 COPYRIGHT AND LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package URI::_query;
+
+use strict;
+use warnings;
+
+use URI ();
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub query
+{
+ my $self = shift;
+ $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die;
+
+ if (@_) {
+ my $q = shift;
+ $$self = $1;
+ if (defined $q) {
+ $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($q);
+ $$self .= "?$q";
+ }
+ $$self .= $3;
+ }
+ $2;
+}
+
+# Handle ...?foo=bar&bar=foo type of query
+sub query_form {
+ my $self = shift;
+ my $old = $self->query;
+ if (@_) {
+ # Try to set query string
+ my $delim;
+ my $r = $_[0];
+ if (ref($r) eq "ARRAY") {
+ $delim = $_[1];
+ @_ = @$r;
+ }
+ elsif (ref($r) eq "HASH") {
+ $delim = $_[1];
+ @_ = map { $_ => $r->{$_} } sort keys %$r;
+ }
+ $delim = pop if @_ % 2;
+
+ my @query;
+ while (my($key,$vals) = splice(@_, 0, 2)) {
+ $key = '' unless defined $key;
+ $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
+ $key =~ s/ /+/g;
+ $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
+ for my $val (@$vals) {
+ $val = '' unless defined $val;
+ $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
+ $val =~ s/ /+/g;
+ push(@query, "$key=$val");
+ }
+ }
+ if (@query) {
+ unless ($delim) {
+ $delim = $1 if $old && $old =~ /([&;])/;
+ $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&";
+ }
+ $self->query(join($delim, @query));
+ }
+ else {
+ $self->query(undef);
+ }
+ }
+ return if !defined($old) || !length($old) || !defined(wantarray);
+ return unless $old =~ /=/; # not a form
+ map { s/\+/ /g; uri_unescape($_) }
+ map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
+}
+
+# Handle ...?dog+bones type of query
+sub query_keywords
+{
+ my $self = shift;
+ my $old = $self->query;
+ if (@_) {
+ # Try to set query string
+ my @copy = @_;
+ @copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY";
+ for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
+ $self->query(@copy ? join('+', @copy) : undef);
+ }
+ return if !defined($old) || !defined(wantarray);
+ return if $old =~ /=/; # not keywords, but a form
+ map { uri_unescape($_) } split(/\+/, $old, -1);
+}
+
+# Some URI::URL compatibility stuff
+sub equery { goto &query }
+
+1;
--- /dev/null
+package URI::_segment;
+
+# Represents a generic path_segment so that it can be treated as
+# a string too.
+
+use strict;
+use warnings;
+
+use URI::Escape qw(uri_unescape);
+
+use overload '""' => sub { $_[0]->[0] },
+ fallback => 1;
+
+our $VERSION = '1.76';
+
+sub new
+{
+ my $class = shift;
+ my @segment = split(';', shift, -1);
+ $segment[0] = uri_unescape($segment[0]);
+ bless \@segment, $class;
+}
+
+1;
--- /dev/null
+package URI::_server;
+
+use strict;
+use warnings;
+
+use parent 'URI::_generic';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub _uric_escape {
+ my($class, $str) = @_;
+ if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+ my($scheme, $host, $rest) = ($1, $2, $3);
+ my $ui = $host =~ s/(.*@)// ? $1 : "";
+ my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+ if (_host_escape($host)) {
+ $str = "$scheme//$ui$host$port$rest";
+ }
+ }
+ return $class->SUPER::_uric_escape($str);
+}
+
+sub _host_escape {
+ return unless $_[0] =~ /[^$URI::uric]/;
+ eval {
+ require URI::_idna;
+ $_[0] = URI::_idna::encode($_[0]);
+ };
+ return 0 if $@;
+ return 1;
+}
+
+sub as_iri {
+ my $self = shift;
+ my $str = $self->SUPER::as_iri;
+ if ($str =~ /\bxn--/) {
+ if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+ my($scheme, $host, $rest) = ($1, $2, $3);
+ my $ui = $host =~ s/(.*@)// ? $1 : "";
+ my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+ require URI::_idna;
+ $host = URI::_idna::decode($host);
+ $str = "$scheme//$ui$host$port$rest";
+ }
+ }
+ return $str;
+}
+
+sub userinfo
+{
+ my $self = shift;
+ my $old = $self->authority;
+
+ if (@_) {
+ my $new = $old;
+ $new = "" unless defined $new;
+ $new =~ s/.*@//; # remove old stuff
+ my $ui = shift;
+ if (defined $ui) {
+ $ui =~ s/@/%40/g; # protect @
+ $new = "$ui\@$new";
+ }
+ $self->authority($new);
+ }
+ return undef if !defined($old) || $old !~ /(.*)@/;
+ return $1;
+}
+
+sub host
+{
+ my $self = shift;
+ my $old = $self->authority;
+ if (@_) {
+ my $tmp = $old;
+ $tmp = "" unless defined $tmp;
+ my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
+ my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
+ my $new = shift;
+ $new = "" unless defined $new;
+ if (length $new) {
+ $new =~ s/[@]/%40/g; # protect @
+ if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
+ $new =~ s/(:\d*)\z// || die "Assert";
+ $port = $1;
+ }
+ $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
+ _host_escape($new);
+ }
+ $self->authority("$ui$new$port");
+ }
+ return undef unless defined $old;
+ $old =~ s/.*@//;
+ $old =~ s/:\d+$//; # remove the port
+ $old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2)
+ return uri_unescape($old);
+}
+
+sub ihost
+{
+ my $self = shift;
+ my $old = $self->host(@_);
+ if ($old =~ /(^|\.)xn--/) {
+ require URI::_idna;
+ $old = URI::_idna::decode($old);
+ }
+ return $old;
+}
+
+sub _port
+{
+ my $self = shift;
+ my $old = $self->authority;
+ if (@_) {
+ my $new = $old;
+ $new =~ s/:\d*$//;
+ my $port = shift;
+ $new .= ":$port" if defined $port;
+ $self->authority($new);
+ }
+ return $1 if defined($old) && $old =~ /:(\d*)$/;
+ return;
+}
+
+sub port
+{
+ my $self = shift;
+ my $port = $self->_port(@_);
+ $port = $self->default_port if !defined($port) || $port eq "";
+ $port;
+}
+
+sub host_port
+{
+ my $self = shift;
+ my $old = $self->authority;
+ $self->host(shift) if @_;
+ return undef unless defined $old;
+ $old =~ s/.*@//; # zap userinfo
+ $old =~ s/:$//; # empty port should be treated the same a no port
+ $old .= ":" . $self->port unless $old =~ /:\d+$/;
+ $old;
+}
+
+
+sub default_port { undef }
+
+sub canonical
+{
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+ my $host = $other->host || "";
+ my $port = $other->_port;
+ my $uc_host = $host =~ /[A-Z]/;
+ my $def_port = defined($port) && ($port eq "" ||
+ $port == $self->default_port);
+ if ($uc_host || $def_port) {
+ $other = $other->clone if $other == $self;
+ $other->host(lc $host) if $uc_host;
+ $other->port(undef) if $def_port;
+ }
+ $other;
+}
+
+1;
--- /dev/null
+package URI::_userpass;
+
+use strict;
+use warnings;
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub user
+{
+ my $self = shift;
+ my $info = $self->userinfo;
+ if (@_) {
+ my $new = shift;
+ my $pass = defined($info) ? $info : "";
+ $pass =~ s/^[^:]*//;
+
+ if (!defined($new) && !length($pass)) {
+ $self->userinfo(undef);
+ } else {
+ $new = "" unless defined($new);
+ $new =~ s/%/%25/g;
+ $new =~ s/:/%3A/g;
+ $self->userinfo("$new$pass");
+ }
+ }
+ return undef unless defined $info;
+ $info =~ s/:.*//;
+ uri_unescape($info);
+}
+
+sub password
+{
+ my $self = shift;
+ my $info = $self->userinfo;
+ if (@_) {
+ my $new = shift;
+ my $user = defined($info) ? $info : "";
+ $user =~ s/:.*//;
+
+ if (!defined($new) && !length($user)) {
+ $self->userinfo(undef);
+ } else {
+ $new = "" unless defined($new);
+ $new =~ s/%/%25/g;
+ $self->userinfo("$user:$new");
+ }
+ }
+ return undef unless defined $info;
+ return undef unless $info =~ s/^[^:]*://;
+ uri_unescape($info);
+}
+
+1;
--- /dev/null
+package URI::data; # RFC 2397
+
+use strict;
+use warnings;
+
+use parent 'URI';
+
+our $VERSION = '1.76';
+
+use MIME::Base64 qw(encode_base64 decode_base64);
+use URI::Escape qw(uri_unescape);
+
+sub media_type
+{
+ my $self = shift;
+ my $opaque = $self->opaque;
+ $opaque =~ /^([^,]*),?/ or die;
+ my $old = $1;
+ my $base64;
+ $base64 = $1 if $old =~ s/(;base64)$//i;
+ if (@_) {
+ my $new = shift;
+ $new = "" unless defined $new;
+ $new =~ s/%/%25/g;
+ $new =~ s/,/%2C/g;
+ $base64 = "" unless defined $base64;
+ $opaque =~ s/^[^,]*,?/$new$base64,/;
+ $self->opaque($opaque);
+ }
+ return uri_unescape($old) if $old; # media_type can't really be "0"
+ "text/plain;charset=US-ASCII"; # default type
+}
+
+sub data
+{
+ my $self = shift;
+ my($enc, $data) = split(",", $self->opaque, 2);
+ unless (defined $data) {
+ $data = "";
+ $enc = "" unless defined $enc;
+ }
+ my $base64 = ($enc =~ /;base64$/i);
+ if (@_) {
+ $enc =~ s/;base64$//i if $base64;
+ my $new = shift;
+ $new = "" unless defined $new;
+ my $uric_count = _uric_count($new);
+ my $urienc_len = $uric_count + (length($new) - $uric_count) * 3;
+ my $base64_len = int((length($new)+2) / 3) * 4;
+ $base64_len += 7; # because of ";base64" marker
+ if ($base64_len < $urienc_len || $_[0]) {
+ $enc .= ";base64";
+ $new = encode_base64($new, "");
+ } else {
+ $new =~ s/%/%25/g;
+ }
+ $self->opaque("$enc,$new");
+ }
+ return unless defined wantarray;
+ $data = uri_unescape($data);
+ return $base64 ? decode_base64($data) : $data;
+}
+
+# I could not find a better way to interpolate the tr/// chars from
+# a variable.
+my $ENC = $URI::uric;
+$ENC =~ s/%//;
+
+eval <<EOT; die $@ if $@;
+sub _uric_count
+{
+ \$_[0] =~ tr/$ENC//;
+}
+EOT
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::data - URI that contains immediate data
+
+=head1 SYNOPSIS
+
+ use URI;
+
+ $u = URI->new("data:");
+ $u->media_type("image/gif");
+ $u->data(scalar(`cat camel.gif`));
+ print "$u\n";
+ open(XV, "|xv -") and print XV $u->data;
+
+=head1 DESCRIPTION
+
+The C<URI::data> class supports C<URI> objects belonging to the I<data>
+URI scheme. The I<data> URI scheme is specified in RFC 2397. It
+allows inclusion of small data items as "immediate" data, as if it had
+been included externally. Examples:
+
+ data:,Perl%20is%20good
+
+ data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI
+ AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG
+ Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p
+ KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI
+ JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs=
+
+
+
+C<URI> objects belonging to the data scheme support the common methods
+(described in L<URI>) and the following two scheme-specific methods:
+
+=over 4
+
+=item $uri->media_type( [$new_media_type] )
+
+Can be used to get or set the media type specified in the
+URI. If no media type is specified, then the default
+C<"text/plain;charset=US-ASCII"> is returned.
+
+=item $uri->data( [$new_data] )
+
+Can be used to get or set the data contained in the URI.
+The data is passed unescaped (in binary form). The decision about
+whether to base64 encode the data in the URI is taken automatically,
+based on the encoding that produces the shorter URI string.
+
+=back
+
+=head1 SEE ALSO
+
+L<URI>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1998 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package URI::file;
+
+use strict;
+use warnings;
+
+use parent 'URI::_generic';
+our $VERSION = "4.21";
+
+use URI::Escape qw(uri_unescape);
+
+our $DEFAULT_AUTHORITY = "";
+
+# Map from $^O values to implementation classes. The Unix
+# class is the default.
+our %OS_CLASS = (
+ os2 => "OS2",
+ mac => "Mac",
+ MacOS => "Mac",
+ MSWin32 => "Win32",
+ win32 => "Win32",
+ msdos => "FAT",
+ dos => "FAT",
+ qnx => "QNX",
+);
+
+sub os_class
+{
+ my($OS) = shift || $^O;
+
+ my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix");
+ no strict 'refs';
+ unless (%{"$class\::"}) {
+ eval "require $class";
+ die $@ if $@;
+ }
+ $class;
+}
+
+sub host { uri_unescape(shift->authority(@_)) }
+
+sub new
+{
+ my($class, $path, $os) = @_;
+ os_class($os)->new($path);
+}
+
+sub new_abs
+{
+ my $class = shift;
+ my $file = $class->new(@_);
+ return $file->abs($class->cwd) unless $$file =~ /^file:/;
+ $file;
+}
+
+sub cwd
+{
+ my $class = shift;
+ require Cwd;
+ my $cwd = Cwd::cwd();
+ $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS';
+ $cwd = $class->new($cwd);
+ $cwd .= "/" unless substr($cwd, -1, 1) eq "/";
+ $cwd;
+}
+
+sub canonical {
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+
+ my $scheme = $other->scheme;
+ my $auth = $other->authority;
+ return $other if !defined($scheme) && !defined($auth); # relative
+
+ if (!defined($auth) ||
+ $auth eq "" ||
+ lc($auth) eq "localhost" ||
+ (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY))
+ )
+ {
+ # avoid cloning if $auth already match
+ if ((defined($auth) || defined($DEFAULT_AUTHORITY)) &&
+ (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY)
+ )
+ {
+ $other = $other->clone if $self == $other;
+ $other->authority($DEFAULT_AUTHORITY);
+ }
+ }
+
+ $other;
+}
+
+sub file
+{
+ my($self, $os) = @_;
+ os_class($os)->file($self);
+}
+
+sub dir
+{
+ my($self, $os) = @_;
+ os_class($os)->dir($self);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::file - URI that maps to local file names
+
+=head1 SYNOPSIS
+
+ use URI::file;
+
+ $u1 = URI->new("file:/foo/bar");
+ $u2 = URI->new("foo/bar", "file");
+
+ $u3 = URI::file->new($path);
+ $u4 = URI::file->new("c:\\windows\\", "win32");
+
+ $u1->file;
+ $u1->file("mac");
+
+=head1 DESCRIPTION
+
+The C<URI::file> class supports C<URI> objects belonging to the I<file>
+URI scheme. This scheme allows us to map the conventional file names
+found on various computer systems to the URI name space. An old
+specification of the I<file> URI scheme is found in RFC 1738. Some
+older background information is also in RFC 1630. There are no newer
+specifications as far as I know.
+
+If you simply want to construct I<file> URI objects from URI strings,
+use the normal C<URI> constructor. If you want to construct I<file>
+URI objects from the actual file names used by various systems, then
+use one of the following C<URI::file> constructors:
+
+=over 4
+
+=item $u = URI::file->new( $filename, [$os] )
+
+Maps a file name to the I<file:> URI name space, creates a URI object
+and returns it. The $filename is interpreted as belonging to the
+indicated operating system ($os), which defaults to the value of the
+$^O variable. The $filename can be either absolute or relative, and
+the corresponding type of URI object for $os is returned.
+
+=item $u = URI::file->new_abs( $filename, [$os] )
+
+Same as URI::file->new, but makes sure that the URI returned
+represents an absolute file name. If the $filename argument is
+relative, then the name is resolved relative to the current directory,
+i.e. this constructor is really the same as:
+
+ URI::file->new($filename)->abs(URI::file->cwd);
+
+=item $u = URI::file->cwd
+
+Returns a I<file> URI that represents the current working directory.
+See L<Cwd>.
+
+=back
+
+The following methods are supported for I<file> URI (in addition to
+the common and generic methods described in L<URI>):
+
+=over 4
+
+=item $u->file( [$os] )
+
+Returns a file name. It maps from the URI name space
+to the file name space of the indicated operating system.
+
+It might return C<undef> if the name can not be represented in the
+indicated file system.
+
+=item $u->dir( [$os] )
+
+Some systems use a different form for names of directories than for plain
+files. Use this method if you know you want to use the name for
+a directory.
+
+=back
+
+The C<URI::file> module can be used to map generic file names to names
+suitable for the current system. As such, it can work as a nice
+replacement for the C<File::Spec> module. For instance, the following
+code translates the UNIX-style file name F<Foo/Bar.pm> to a name
+suitable for the local system:
+
+ $file = URI::file->new("Foo/Bar.pm", "unix")->file;
+ die "Can't map filename Foo/Bar.pm for $^O" unless defined $file;
+ open(FILE, $file) || die "Can't open '$file': $!";
+ # do something with FILE
+
+=head1 MAPPING NOTES
+
+Most computer systems today have hierarchically organized file systems.
+Mapping the names used in these systems to the generic URI syntax
+allows us to work with relative file URIs that behave as they should
+when resolved using the generic algorithm for URIs (specified in RFC
+2396). Mapping a file name to the generic URI syntax involves mapping
+the path separator character to "/" and encoding any reserved
+characters that appear in the path segments of the file name. If
+path segments consisting of the strings "." or ".." have a
+different meaning than what is specified for generic URIs, then these
+must be encoded as well.
+
+If the file system has device, volume or drive specifications as
+the root of the name space, then it makes sense to map them to the
+authority field of the generic URI syntax. This makes sure that
+relative URIs can not be resolved "above" them, i.e. generally how
+relative file names work in those systems.
+
+Another common use of the authority field is to encode the host on which
+this file name is valid. The host name "localhost" is special and
+generally has the same meaning as a missing or empty authority
+field. This use is in conflict with using it as a device
+specification, but can often be resolved for device specifications
+having characters not legal in plain host names.
+
+File name to URI mapping in normally not one-to-one. There are
+usually many URIs that map to any given file name. For instance, an
+authority of "localhost" maps the same as a URI with a missing or empty
+authority.
+
+Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator,
+but not in the same way as a generic URI. ":foo" was a relative name. "foo:bar"
+was an absolute name. Also, path segments could contain the "/" character as well
+as the literal "." or "..". So the mapping looks like this:
+
+ Mac classic URI
+ ---------- -------------------
+ :foo:bar <==> foo/bar
+ : <==> ./
+ ::foo:bar <==> ../foo/bar
+ ::: <==> ../../
+ foo:bar <==> file:/foo/bar
+ foo:bar: <==> file:/foo/bar/
+ .. <==> %2E%2E
+ <undef> <== /
+ foo/ <== file:/foo%2F
+ ./foo.txt <== file:/.%2Ffoo.txt
+
+Note that if you want a relative URL, you *must* begin the path with a :. Any
+path that begins with [^:] is treated as absolute.
+
+Example 2: The UNIX file system is easy to map, as it uses the same path
+separator as URIs, has a single root, and segments of "." and ".."
+have the same meaning. URIs that have the character "\0" or "/" as
+part of any path segment can not be turned into valid UNIX file names.
+
+ UNIX URI
+ ---------- ------------------
+ foo/bar <==> foo/bar
+ /foo/bar <==> file:/foo/bar
+ /foo/bar <== file://localhost/foo/bar
+ file: ==> ./file:
+ <undef> <== file:/fo%00/bar
+ / <==> file:/
+
+=cut
+
+
+RFC 1630
+
+ [...]
+
+ There is clearly a danger of confusion that a link made to a local
+ file should be followed by someone on a different system, with
+ unexpected and possibly harmful results. Therefore, the convention
+ is that even a "file" URL is provided with a host part. This allows
+ a client on another system to know that it cannot access the file
+ system, or perhaps to use some other local mechanism to access the
+ file.
+
+ The special value "localhost" is used in the host field to indicate
+ that the filename should really be used on whatever host one is.
+ This for example allows links to be made to files which are
+ distributed on many machines, or to "your unix local password file"
+ subject of course to consistency across the users of the data.
+
+ A void host field is equivalent to "localhost".
+
+=head1 CONFIGURATION VARIABLES
+
+The following configuration variables influence how the class and its
+methods behave:
+
+=over
+
+=item %URI::file::OS_CLASS
+
+This hash maps OS identifiers to implementation classes. You might
+want to add or modify this if you want to plug in your own file
+handler class. Normally the keys should match the $^O values in use.
+
+If there is no mapping then the "Unix" implementation is used.
+
+=item $URI::file::DEFAULT_AUTHORITY
+
+This determine what "authority" string to include in absolute file
+URIs. It defaults to "". If you prefer verbose URIs you might set it
+to be "localhost".
+
+Setting this value to C<undef> force behaviour compatible to URI v1.31
+and earlier. In this mode host names in UNC paths and drive letters
+are mapped to the authority component on Windows, while we produce
+authority-less URIs on Unix.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<URI>, L<File::Spec>, L<perlport>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1998,2004 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package URI::file::Base;
+
+use strict;
+use warnings;
+
+use URI::Escape qw();
+
+our $VERSION = '1.76';
+
+sub new
+{
+ my $class = shift;
+ my $path = shift;
+ $path = "" unless defined $path;
+
+ my($auth, $escaped_auth, $escaped_path);
+
+ ($auth, $escaped_auth) = $class->_file_extract_authority($path);
+ ($path, $escaped_path) = $class->_file_extract_path($path);
+
+ if (defined $auth) {
+ $auth =~ s,%,%25,g unless $escaped_auth;
+ $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+ $auth = "//$auth";
+ if (defined $path) {
+ $path = "/$path" unless substr($path, 0, 1) eq "/";
+ } else {
+ $path = "";
+ }
+ } else {
+ return undef unless defined $path;
+ $auth = "";
+ }
+
+ $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path;
+ $path =~ s/\#/%23/g;
+
+ my $uri = $auth . $path;
+ $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
+
+ URI->new($uri, "file");
+}
+
+sub _file_extract_authority
+{
+ my($class, $path) = @_;
+ return undef unless $class->_file_is_absolute($path);
+ return $URI::file::DEFAULT_AUTHORITY;
+}
+
+sub _file_extract_path
+{
+ return undef;
+}
+
+sub _file_is_absolute
+{
+ return 0;
+}
+
+sub _file_is_localhost
+{
+ shift; # class
+ my $host = lc(shift);
+ return 1 if $host eq "localhost";
+ eval {
+ require Net::Domain;
+ lc(Net::Domain::hostfqdn() || '') eq $host ||
+ lc(Net::Domain::hostname() || '') eq $host;
+ };
+}
+
+sub file
+{
+ undef;
+}
+
+sub dir
+{
+ my $self = shift;
+ $self->file(@_);
+}
+
+1;
--- /dev/null
+package URI::file::FAT;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Win32';
+
+our $VERSION = '1.76';
+
+sub fix_path
+{
+ shift; # class
+ for (@_) {
+ # turn it into 8.3 names
+ my @p = map uc, split(/\./, $_, -1);
+ return if @p > 2; # more than 1 dot is not allowed
+ @p = ("") unless @p; # split bug? (returns nothing when splitting "")
+ $_ = substr($p[0], 0, 8);
+ if (@p > 1) {
+ my $ext = substr($p[1], 0, 3);
+ $_ .= ".$ext" if length $ext;
+ }
+ }
+ 1; # ok
+}
+
+1;
--- /dev/null
+package URI::file::Mac;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Base';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub _file_extract_path
+{
+ my $class = shift;
+ my $path = shift;
+
+ my @pre;
+ if ($path =~ s/^(:+)//) {
+ if (length($1) == 1) {
+ @pre = (".") unless length($path);
+ } else {
+ @pre = ("..") x (length($1) - 1);
+ }
+ } else { #absolute
+ $pre[0] = "";
+ }
+
+ my $isdir = ($path =~ s/:$//);
+ $path =~ s,([%/;]), URI::Escape::escape_char($1),eg;
+
+ my @path = split(/:/, $path, -1);
+ for (@path) {
+ if ($_ eq "." || $_ eq "..") {
+ $_ = "%2E" x length($_);
+ }
+ $_ = ".." unless length($_);
+ }
+ push (@path,"") if $isdir;
+ (join("/", @pre, @path), 1);
+}
+
+
+sub file
+{
+ my $class = shift;
+ my $uri = shift;
+ my @path;
+
+ my $auth = $uri->authority;
+ if (defined $auth) {
+ if (lc($auth) ne "localhost" && $auth ne "") {
+ my $u_auth = uri_unescape($auth);
+ if (!$class->_file_is_localhost($u_auth)) {
+ # some other host (use it as volume name)
+ @path = ("", $auth);
+ # XXX or just return to make it illegal;
+ }
+ }
+ }
+ my @ps = split("/", $uri->path, -1);
+ shift @ps if @path;
+ push(@path, @ps);
+
+ my $pre = "";
+ if (!@path) {
+ return; # empty path; XXX return ":" instead?
+ } elsif ($path[0] eq "") {
+ # absolute
+ shift(@path);
+ if (@path == 1) {
+ return if $path[0] eq ""; # not root directory
+ push(@path, ""); # volume only, effectively append ":"
+ }
+ @ps = @path;
+ @path = ();
+ my $part;
+ for (@ps) { #fix up "." and "..", including interior, in relatives
+ next if $_ eq ".";
+ $part = $_ eq ".." ? "" : $_;
+ push(@path,$part);
+ }
+ if ($ps[-1] eq "..") { #if this happens, we need another :
+ push(@path,"");
+ }
+
+ } else {
+ $pre = ":";
+ @ps = @path;
+ @path = ();
+ my $part;
+ for (@ps) { #fix up "." and "..", including interior, in relatives
+ next if $_ eq ".";
+ $part = $_ eq ".." ? "" : $_;
+ push(@path,$part);
+ }
+ if ($ps[-1] eq "..") { #if this happens, we need another :
+ push(@path,"");
+ }
+
+ }
+ return unless $pre || @path;
+ for (@path) {
+ s/;.*//; # get rid of parameters
+ #return unless length; # XXX
+ $_ = uri_unescape($_);
+ return if /\0/;
+ return if /:/; # Should we?
+ }
+ $pre . join(":", @path);
+}
+
+sub dir
+{
+ my $class = shift;
+ my $path = $class->file(@_);
+ return unless defined $path;
+ $path .= ":" unless $path =~ /:$/;
+ $path;
+}
+
+1;
--- /dev/null
+package URI::file::OS2;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Win32';
+
+our $VERSION = '1.76';
+
+# The Win32 version translates k:/foo to file://k:/foo (?!)
+# We add an empty host
+
+sub _file_extract_authority
+{
+ my $class = shift;
+ return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC
+ return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too?
+
+ if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives
+ return "";
+ }
+ return;
+}
+
+sub file {
+ my $p = &URI::file::Win32::file;
+ return unless defined $p;
+ $p =~ s,\\,/,g;
+ $p;
+}
+
+1;
--- /dev/null
+package URI::file::QNX;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Unix';
+
+our $VERSION = '1.76';
+
+sub _file_extract_path
+{
+ my($class, $path) = @_;
+ # tidy path
+ $path =~ s,(.)//+,$1/,g; # ^// is correct
+ $path =~ s,(/\.)+/,/,g;
+ $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+ $path;
+}
+
+1;
--- /dev/null
+package URI::file::Unix;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Base';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub _file_extract_path
+{
+ my($class, $path) = @_;
+
+ # tidy path
+ $path =~ s,//+,/,g;
+ $path =~ s,(/\.)+/,/,g;
+ $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+
+ return $path;
+}
+
+sub _file_is_absolute {
+ my($class, $path) = @_;
+ return $path =~ m,^/,;
+}
+
+sub file
+{
+ my $class = shift;
+ my $uri = shift;
+ my @path;
+
+ my $auth = $uri->authority;
+ if (defined($auth)) {
+ if (lc($auth) ne "localhost" && $auth ne "") {
+ $auth = uri_unescape($auth);
+ unless ($class->_file_is_localhost($auth)) {
+ push(@path, "", "", $auth);
+ }
+ }
+ }
+
+ my @ps = $uri->path_segments;
+ shift @ps if @path;
+ push(@path, @ps);
+
+ for (@path) {
+ # Unix file/directory names are not allowed to contain '\0' or '/'
+ return undef if /\0/;
+ return undef if /\//; # should we really?
+ }
+
+ return join("/", @path);
+}
+
+1;
--- /dev/null
+package URI::file::Win32;
+
+use strict;
+use warnings;
+
+use parent 'URI::file::Base';
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub _file_extract_authority
+{
+ my $class = shift;
+
+ return $class->SUPER::_file_extract_authority($_[0])
+ if defined $URI::file::DEFAULT_AUTHORITY;
+
+ return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC
+ return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too?
+
+ if ($_[0] =~ s,^([a-zA-Z]:),,) {
+ my $auth = $1;
+ $auth .= "relative" if $_[0] !~ m,^[\\/],;
+ return $auth;
+ }
+ return undef;
+}
+
+sub _file_extract_path
+{
+ my($class, $path) = @_;
+ $path =~ s,\\,/,g;
+ #$path =~ s,//+,/,g;
+ $path =~ s,(/\.)+/,/,g;
+
+ if (defined $URI::file::DEFAULT_AUTHORITY) {
+ $path =~ s,^([a-zA-Z]:),/$1,;
+ }
+
+ return $path;
+}
+
+sub _file_is_absolute {
+ my($class, $path) = @_;
+ return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
+}
+
+sub file
+{
+ my $class = shift;
+ my $uri = shift;
+ my $auth = $uri->authority;
+ my $rel; # is filename relative to drive specified in authority
+ if (defined $auth) {
+ $auth = uri_unescape($auth);
+ if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
+ $auth = uc($1) . ":";
+ $rel++ if $2;
+ } elsif (lc($auth) eq "localhost") {
+ $auth = "";
+ } elsif (length $auth) {
+ $auth = "\\\\" . $auth; # UNC
+ }
+ } else {
+ $auth = "";
+ }
+
+ my @path = $uri->path_segments;
+ for (@path) {
+ return undef if /\0/;
+ return undef if /\//;
+ #return undef if /\\/; # URLs with "\" is not uncommon
+ }
+ return undef unless $class->fix_path(@path);
+
+ my $path = join("\\", @path);
+ $path =~ s/^\\// if $rel;
+ $path = $auth . $path;
+ $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
+
+ return $path;
+}
+
+sub fix_path { 1; }
+
+1;
--- /dev/null
+package URI::ftp;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent qw(URI::_server URI::_userpass);
+
+sub default_port { 21 }
+
+sub path { shift->path_query(@_) } # XXX
+
+sub _user { shift->SUPER::user(@_); }
+sub _password { shift->SUPER::password(@_); }
+
+sub user
+{
+ my $self = shift;
+ my $user = $self->_user(@_);
+ $user = "anonymous" unless defined $user;
+ $user;
+}
+
+sub password
+{
+ my $self = shift;
+ my $pass = $self->_password(@_);
+ unless (defined $pass) {
+ my $user = $self->user;
+ if ($user eq 'anonymous' || $user eq 'ftp') {
+ # anonymous ftp login password
+ # If there is no ftp anonymous password specified
+ # then we'll just use 'anonymous@'
+ # We don't try to send the read e-mail address because:
+ # - We want to remain anonymous
+ # - We want to stop SPAM
+ # - We don't want to let ftp sites to discriminate by the user,
+ # host, country or ftp client being used.
+ $pass = 'anonymous@';
+ }
+ }
+ $pass;
+}
+
+1;
--- /dev/null
+package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_server';
+
+use URI::Escape qw(uri_unescape);
+
+# A Gopher URL follows the common internet scheme syntax as defined in
+# section 4.3 of [RFC-URL-SYNTAX]:
+#
+# gopher://<host>[:<port>]/<gopher-path>
+#
+# where
+#
+# <gopher-path> := <gopher-type><selector> |
+# <gopher-type><selector>%09<search> |
+# <gopher-type><selector>%09<search>%09<gopher+_string>
+#
+# <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7'
+# '8' | '9' | '+' | 'I' | 'g' | 'T'
+#
+# <selector> := *pchar Refer to RFC 1808 [4]
+# <search> := *pchar
+# <gopher+_string> := *uchar Refer to RFC 1738 [3]
+#
+# If the optional port is omitted, the port defaults to 70.
+
+sub default_port { 70 }
+
+sub _gopher_type
+{
+ my $self = shift;
+ my $path = $self->path_query;
+ $path =~ s,^/,,;
+ my $gtype = $1 if $path =~ s/^(.)//s;
+ if (@_) {
+ my $new_type = shift;
+ if (defined($new_type)) {
+ Carp::croak("Bad gopher type '$new_type'")
+ unless length($new_type) == 1;
+ substr($path, 0, 0) = $new_type;
+ $self->path_query($path);
+ } else {
+ Carp::croak("Can't delete gopher type when selector is present")
+ if length($path);
+ $self->path_query(undef);
+ }
+ }
+ return $gtype;
+}
+
+sub gopher_type
+{
+ my $self = shift;
+ my $gtype = $self->_gopher_type(@_);
+ $gtype = "1" unless defined $gtype;
+ $gtype;
+}
+
+sub gtype { goto &gopher_type } # URI::URL compatibility
+
+sub selector { shift->_gfield(0, @_) }
+sub search { shift->_gfield(1, @_) }
+sub string { shift->_gfield(2, @_) }
+
+sub _gfield
+{
+ my $self = shift;
+ my $fno = shift;
+ my $path = $self->path_query;
+
+ # not according to spec., but many popular browsers accept
+ # gopher URLs with a '?' before the search string.
+ $path =~ s/\?/\t/;
+ $path = uri_unescape($path);
+ $path =~ s,^/,,;
+ my $gtype = $1 if $path =~ s,^(.),,s;
+ my @path = split(/\t/, $path, 3);
+ if (@_) {
+ # modify
+ my $new = shift;
+ $path[$fno] = $new;
+ pop(@path) while @path && !defined($path[-1]);
+ for (@path) { $_="" unless defined }
+ $path = $gtype;
+ $path = "1" unless defined $path;
+ $path .= join("\t", @path);
+ $self->path_query($path);
+ }
+ $path[$fno];
+}
+
+1;
--- /dev/null
+package URI::http;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_server';
+
+sub default_port { 80 }
+
+sub canonical
+{
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+
+ my $slash_path = defined($other->authority) &&
+ !length($other->path) && !defined($other->query);
+
+ if ($slash_path) {
+ $other = $other->clone if $other == $self;
+ $other->path("/");
+ }
+ $other;
+}
+
+1;
--- /dev/null
+package URI::https;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::http';
+
+sub default_port { 443 }
+
+sub secure { 1 }
+
+1;
--- /dev/null
+# Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package URI::ldap;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent qw(URI::_ldap URI::_server);
+
+sub default_port { 389 }
+
+sub _nonldap_canonical {
+ my $self = shift;
+ $self->URI::_server::canonical(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+URI::ldap - LDAP Uniform Resource Locators
+
+=head1 SYNOPSIS
+
+ use URI;
+
+ $uri = URI->new("ldap:$uri_string");
+ $dn = $uri->dn;
+ $filter = $uri->filter;
+ @attr = $uri->attributes;
+ $scope = $uri->scope;
+ %extn = $uri->extensions;
+
+ $uri = URI->new("ldap:"); # start empty
+ $uri->host("ldap.itd.umich.edu");
+ $uri->dn("o=University of Michigan,c=US");
+ $uri->attributes(qw(postalAddress));
+ $uri->scope('sub');
+ $uri->filter('(cn=Babs Jensen)');
+ print $uri->as_string,"\n";
+
+=head1 DESCRIPTION
+
+C<URI::ldap> provides an interface to parse an LDAP URI into its
+constituent parts and also to build a URI as described in
+RFC 2255.
+
+=head1 METHODS
+
+C<URI::ldap> supports all the generic and server methods defined by
+L<URI>, plus the following.
+
+Each of the following methods can be used to set or get the value in
+the URI. The values are passed in unescaped form. None of these
+return undefined values, but elements without a default can be empty.
+If arguments are given, then a new value is set for the given part
+of the URI.
+
+=over 4
+
+=item $uri->dn( [$new_dn] )
+
+Sets or gets the I<Distinguished Name> part of the URI. The DN
+identifies the base object of the LDAP search.
+
+=item $uri->attributes( [@new_attrs] )
+
+Sets or gets the list of attribute names which are
+returned by the search.
+
+=item $uri->scope( [$new_scope] )
+
+Sets or gets the scope to be used by the search. The value can be one of
+C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the
+return value defaults to C<"base">.
+
+=item $uri->_scope( [$new_scope] )
+
+Same as scope(), but does not default to anything.
+
+=item $uri->filter( [$new_filter] )
+
+Sets or gets the filter to be used by the search. If none is given in
+the URI then the return value defaults to C<"(objectClass=*)">.
+
+=item $uri->_filter( [$new_filter] )
+
+Same as filter(), but does not default to anything.
+
+=item $uri->extensions( [$etype => $evalue,...] )
+
+Sets or gets the extensions used for the search. The list passed should
+be in the form etype1 => evalue1, etype2 => evalue2,... This is also
+the form of list that is returned.
+
+=back
+
+=head1 SEE ALSO
+
+L<http://tools.ietf.org/html/rfc2255>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
+
+Slightly modified by Gisle Aas to fit into the URI distribution.
+
+=head1 COPYRIGHT
+
+Copyright (c) 1998 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
--- /dev/null
+package URI::ldapi;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent qw(URI::_ldap URI::_generic);
+
+require URI::Escape;
+
+sub un_path {
+ my $self = shift;
+ my $old = URI::Escape::uri_unescape($self->authority);
+ if (@_) {
+ my $p = shift;
+ $p =~ s/:/%3A/g;
+ $p =~ s/\@/%40/g;
+ $self->authority($p);
+ }
+ return $old;
+}
+
+sub _nonldap_canonical {
+ my $self = shift;
+ $self->URI::_generic::canonical(@_);
+}
+
+1;
--- /dev/null
+package URI::ldaps;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::ldap';
+
+sub default_port { 636 }
+
+sub secure { 1 }
+
+1;
--- /dev/null
+package URI::mailto; # RFC 2368
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent qw(URI URI::_query);
+
+sub to
+{
+ my $self = shift;
+ my @old = $self->headers;
+ if (@_) {
+ my @new = @old;
+ # get rid of any other to: fields
+ for (my $i = 0; $i < @new; $i += 2) {
+ if (lc($new[$i] || '') eq "to") {
+ splice(@new, $i, 2);
+ redo;
+ }
+ }
+
+ my $to = shift;
+ $to = "" unless defined $to;
+ unshift(@new, "to" => $to);
+ $self->headers(@new);
+ }
+ return unless defined wantarray;
+
+ my @to;
+ while (@old) {
+ my $h = shift @old;
+ my $v = shift @old;
+ push(@to, $v) if lc($h) eq "to";
+ }
+ join(",", @to);
+}
+
+
+sub headers
+{
+ my $self = shift;
+
+ # The trick is to just treat everything as the query string...
+ my $opaque = "to=" . $self->opaque;
+ $opaque =~ s/\?/&/;
+
+ if (@_) {
+ my @new = @_;
+
+ # strip out any "to" fields
+ my @to;
+ for (my $i=0; $i < @new; $i += 2) {
+ if (lc($new[$i] || '') eq "to") {
+ push(@to, (splice(@new, $i, 2))[1]); # remove header
+ redo;
+ }
+ }
+
+ my $new = join(",",@to);
+ $new =~ s/%/%25/g;
+ $new =~ s/\?/%3F/g;
+ $self->opaque($new);
+ $self->query_form(@new) if @new;
+ }
+ return unless defined wantarray;
+
+ # I am lazy today...
+ URI->new("mailto:?$opaque")->query_form;
+}
+
+1;
--- /dev/null
+package URI::mms;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::http';
+
+sub default_port { 1755 }
+
+1;
--- /dev/null
+package URI::news; # draft-gilman-news-url-01
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_server';
+
+use URI::Escape qw(uri_unescape);
+use Carp ();
+
+sub default_port { 119 }
+
+# newsURL = scheme ":" [ news-server ] [ refbygroup | message ]
+# scheme = "news" | "snews" | "nntp"
+# news-server = "//" server "/"
+# refbygroup = group [ "/" messageno [ "-" messageno ] ]
+# message = local-part "@" domain
+
+sub _group
+{
+ my $self = shift;
+ my $old = $self->path;
+ if (@_) {
+ my($group,$from,$to) = @_;
+ if ($group =~ /\@/) {
+ $group =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it
+ }
+ $group =~ s,%,%25,g;
+ $group =~ s,/,%2F,g;
+ my $path = $group;
+ if (defined $from) {
+ $path .= "/$from";
+ $path .= "-$to" if defined $to;
+ }
+ $self->path($path);
+ }
+
+ $old =~ s,^/,,;
+ if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) {
+ my $extra = $1;
+ return (uri_unescape($old), split(/-/, $extra));
+ }
+ uri_unescape($old);
+}
+
+
+sub group
+{
+ my $self = shift;
+ if (@_) {
+ Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/;
+ }
+ my @old = $self->_group(@_);
+ return if $old[0] =~ /\@/;
+ wantarray ? @old : $old[0];
+}
+
+sub message
+{
+ my $self = shift;
+ if (@_) {
+ Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/;
+ }
+ my $old = $self->_group(@_);
+ return undef unless $old =~ /\@/;
+ return $old;
+}
+
+1;
--- /dev/null
+package URI::nntp; # draft-gilman-news-url-01
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::news';
+
+1;
--- /dev/null
+package URI::pop; # RFC 2384
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_server';
+
+use URI::Escape qw(uri_unescape);
+
+sub default_port { 110 }
+
+#pop://<user>;auth=<auth>@<host>:<port>
+
+sub user
+{
+ my $self = shift;
+ my $old = $self->userinfo;
+
+ if (@_) {
+ my $new_info = $old;
+ $new_info = "" unless defined $new_info;
+ $new_info =~ s/^[^;]*//;
+
+ my $new = shift;
+ if (!defined($new) && !length($new_info)) {
+ $self->userinfo(undef);
+ } else {
+ $new = "" unless defined $new;
+ $new =~ s/%/%25/g;
+ $new =~ s/;/%3B/g;
+ $self->userinfo("$new$new_info");
+ }
+ }
+
+ return undef unless defined $old;
+ $old =~ s/;.*//;
+ return uri_unescape($old);
+}
+
+sub auth
+{
+ my $self = shift;
+ my $old = $self->userinfo;
+
+ if (@_) {
+ my $new = $old;
+ $new = "" unless defined $new;
+ $new =~ s/(^[^;]*)//;
+ my $user = $1;
+ $new =~ s/;auth=[^;]*//i;
+
+
+ my $auth = shift;
+ if (defined $auth) {
+ $auth =~ s/%/%25/g;
+ $auth =~ s/;/%3B/g;
+ $new = ";AUTH=$auth$new";
+ }
+ $self->userinfo("$user$new");
+
+ }
+
+ return undef unless defined $old;
+ $old =~ s/^[^;]*//;
+ return uri_unescape($1) if $old =~ /;auth=(.*)/i;
+ return;
+}
+
+1;
--- /dev/null
+package URI::rlogin;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_login';
+
+sub default_port { 513 }
+
+1;
--- /dev/null
+package URI::rsync; # http://rsync.samba.org/
+
+# rsync://[USER@]HOST[:PORT]/SRC
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent qw(URI::_server URI::_userpass);
+
+sub default_port { 873 }
+
+1;
--- /dev/null
+package URI::rtsp;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::http';
+
+sub default_port { 554 }
+
+1;
--- /dev/null
+package URI::rtspu;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::rtsp';
+
+sub default_port { 554 }
+
+1;
--- /dev/null
+package URI::sftp;
+
+use strict;
+use warnings;
+
+use parent 'URI::ssh';
+
+our $VERSION = '1.76';
+
+1;
--- /dev/null
+#
+# Written by Ryan Kereliuk <ryker@ryker.org>. This file may be
+# distributed under the same terms as Perl itself.
+#
+# The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>.
+#
+
+package URI::sip;
+
+use strict;
+use warnings;
+
+use parent qw(URI::_server URI::_userpass);
+
+use URI::Escape qw(uri_unescape);
+
+our $VERSION = '1.76';
+
+sub default_port { 5060 }
+
+sub authority
+{
+ my $self = shift;
+ $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
+ my $old = $2;
+
+ if (@_) {
+ my $auth = shift;
+ $$self = defined($1) ? $1 : "";
+ my $rest = $3;
+ if (defined $auth) {
+ $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+ $$self .= "$auth";
+ }
+ $$self .= $rest;
+ }
+ $old;
+}
+
+sub params_form
+{
+ my $self = shift;
+ $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
+ my $paramstr = $3;
+
+ if (@_) {
+ my @args = @_;
+ $$self = $1 . $2;
+ my $rest = $4;
+ my @new;
+ for (my $i=0; $i < @args; $i += 2) {
+ push(@new, "$args[$i]=$args[$i+1]");
+ }
+ $paramstr = join(";", @new);
+ $$self .= ";" . $paramstr . $rest;
+ }
+ $paramstr =~ s/^;//o;
+ return split(/[;=]/, $paramstr);
+}
+
+sub params
+{
+ my $self = shift;
+ $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
+ my $paramstr = $3;
+
+ if (@_) {
+ my $new = shift;
+ $$self = $1 . $2;
+ my $rest = $4;
+ $$self .= $paramstr . $rest;
+ }
+ $paramstr =~ s/^;//o;
+ return $paramstr;
+}
+
+# Inherited methods that make no sense for a SIP URI.
+sub path {}
+sub path_query {}
+sub path_segments {}
+sub abs { shift }
+sub rel { shift }
+sub query_keywords {}
+
+1;
--- /dev/null
+package URI::sips;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::sip';
+
+sub default_port { 5061 }
+
+sub secure { 1 }
+
+1;
--- /dev/null
+package URI::snews; # draft-gilman-news-url-01
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::news';
+
+sub default_port { 563 }
+
+sub secure { 1 }
+
+1;
--- /dev/null
+package URI::ssh;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_login';
+
+# ssh://[USER@]HOST[:PORT]/SRC
+
+sub default_port { 22 }
+
+sub secure { 1 }
+
+1;
--- /dev/null
+package URI::telnet;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_login';
+
+sub default_port { 23 }
+
+1;
--- /dev/null
+package URI::tn3270;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::_login';
+
+sub default_port { 23 }
+
+1;
--- /dev/null
+package URI::urn; # RFC 2141
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI';
+
+use Carp qw(carp);
+
+my %implementor;
+my %require_attempted;
+
+sub _init {
+ my $class = shift;
+ my $self = $class->SUPER::_init(@_);
+ my $nid = $self->nid;
+
+ my $impclass = $implementor{$nid};
+ return $impclass->_urn_init($self, $nid) if $impclass;
+
+ $impclass = "URI::urn";
+ if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) {
+ my $id = $nid;
+ # make it a legal perl identifier
+ $id =~ s/-/_/g;
+ $id = "_$id" if $id =~ /^\d/;
+
+ $impclass = "URI::urn::$id";
+ no strict 'refs';
+ unless (@{"${impclass}::ISA"}) {
+ if (not exists $require_attempted{$impclass}) {
+ # Try to load it
+ my $_old_error = $@;
+ eval "require $impclass";
+ die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+ $@ = $_old_error;
+ }
+ $impclass = "URI::urn" unless @{"${impclass}::ISA"};
+ }
+ }
+ else {
+ carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W;
+ }
+ $implementor{$nid} = $impclass;
+
+ return $impclass->_urn_init($self, $nid);
+}
+
+sub _urn_init {
+ my($class, $self, $nid) = @_;
+ bless $self, $class;
+}
+
+sub _nid {
+ my $self = shift;
+ my $opaque = $self->opaque;
+ if (@_) {
+ my $v = $opaque;
+ my $new = shift;
+ $v =~ s/[^:]*/$new/;
+ $self->opaque($v);
+ # XXX possible rebless
+ }
+ $opaque =~ s/:.*//s;
+ return $opaque;
+}
+
+sub nid { # namespace identifier
+ my $self = shift;
+ my $nid = $self->_nid(@_);
+ $nid = lc($nid) if defined($nid);
+ return $nid;
+}
+
+sub nss { # namespace specific string
+ my $self = shift;
+ my $opaque = $self->opaque;
+ if (@_) {
+ my $v = $opaque;
+ my $new = shift;
+ if (defined $new) {
+ $v =~ s/(:|\z).*/:$new/;
+ }
+ else {
+ $v =~ s/:.*//s;
+ }
+ $self->opaque($v);
+ }
+ return undef unless $opaque =~ s/^[^:]*://;
+ return $opaque;
+}
+
+sub canonical {
+ my $self = shift;
+ my $nid = $self->_nid;
+ my $new = $self->SUPER::canonical;
+ return $new if $nid !~ /[A-Z]/ || $nid =~ /%/;
+ $new = $new->clone if $new == $self;
+ $new->nid(lc($nid));
+ return $new;
+}
+
+1;
--- /dev/null
+package URI::urn::isbn; # RFC 3187
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::urn';
+
+use Carp qw(carp);
+
+BEGIN {
+ require Business::ISBN;
+
+ local $^W = 0; # don't warn about dev versions, perl5.004 style
+ warn "Using Business::ISBN version " . Business::ISBN->VERSION .
+ " which is deprecated.\nUpgrade to Business::ISBN version 2\n"
+ if Business::ISBN->VERSION < 2;
+ }
+
+sub _isbn {
+ my $nss = shift;
+ $nss = $nss->nss if ref($nss);
+ my $isbn = Business::ISBN->new($nss);
+ $isbn = undef if $isbn && !$isbn->is_valid;
+ return $isbn;
+}
+
+sub _nss_isbn {
+ my $self = shift;
+ my $nss = $self->nss(@_);
+ my $isbn = _isbn($nss);
+ $isbn = $isbn->as_string if $isbn;
+ return($nss, $isbn);
+}
+
+sub isbn {
+ my $self = shift;
+ my $isbn;
+ (undef, $isbn) = $self->_nss_isbn(@_);
+ return $isbn;
+}
+
+sub isbn_publisher_code {
+ my $isbn = shift->_isbn || return undef;
+ return $isbn->publisher_code;
+}
+
+BEGIN {
+my $group_method = do {
+ local $^W = 0; # don't warn about dev versions, perl5.004 style
+ Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code';
+ };
+
+sub isbn_group_code {
+ my $isbn = shift->_isbn || return undef;
+ return $isbn->$group_method;
+}
+}
+
+sub isbn_country_code {
+ my $name = (caller(0))[3]; $name =~ s/.*:://;
+ carp "$name is DEPRECATED. Use isbn_group_code instead";
+
+ no strict 'refs';
+ &isbn_group_code;
+}
+
+BEGIN {
+my $isbn13_method = do {
+ local $^W = 0; # don't warn about dev versions, perl5.004 style
+ Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean';
+ };
+
+sub isbn13 {
+ my $isbn = shift->_isbn || return undef;
+
+ # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string
+ # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects
+ # and it uses the hyphens, so call as_string with an empty anon array
+ # or, adjust the test and features to say that it comes out with hyphens.
+ my $thingy = $isbn->$isbn13_method;
+ return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy;
+}
+}
+
+sub isbn_as_ean {
+ my $name = (caller(0))[3]; $name =~ s/.*:://;
+ carp "$name is DEPRECATED. Use isbn13 instead";
+
+ no strict 'refs';
+ &isbn13;
+}
+
+sub canonical {
+ my $self = shift;
+ my($nss, $isbn) = $self->_nss_isbn;
+ my $new = $self->SUPER::canonical;
+ return $new unless $nss && $isbn && $nss ne $isbn;
+ $new = $new->clone if $new == $self;
+ $new->nss($isbn);
+ return $new;
+}
+
+1;
--- /dev/null
+package URI::urn::oid; # RFC 2061
+
+use strict;
+use warnings;
+
+our $VERSION = '1.76';
+
+use parent 'URI::urn';
+
+sub oid {
+ my $self = shift;
+ my $old = $self->nss;
+ if (@_) {
+ $self->nss(join(".", @_));
+ }
+ return split(/\./, $old) if wantarray;
+ return $old;
+}
+
+1;
--- /dev/null
+package Win32::ShellQuote;
+use strict;
+use warnings FATAL => 'all';
+use base 'Exporter';
+use Carp;
+
+our $VERSION = '0.003001';
+$VERSION = eval $VERSION;
+
+our @EXPORT_OK = qw(
+ quote_native
+ quote_cmd
+ quote_system_list
+ quote_system_string
+ quote_system
+ quote_system_cmd
+ quote_literal
+ cmd_escape
+ unquote_native
+ cmd_unescape
+);
+our %EXPORT_TAGS = (all => [@EXPORT_OK]);
+
+sub quote_native {
+ return join q{ }, quote_system_list(@_);
+}
+
+sub quote_cmd {
+ return cmd_escape(quote_native(@_));
+}
+
+sub quote_system_list {
+ # have to force quoting, or perl might try to use cmd anyway
+ return map { quote_literal($_, 1) } @_;
+}
+
+sub quote_system_string {
+ my $args = quote_native(@_);
+
+ if (_has_shell_metachars($args)) {
+ $args = cmd_escape($args);
+ }
+ return $args;
+}
+
+sub quote_system {
+ if (@_ > 1) {
+ return quote_system_list(@_);
+ }
+ else {
+ return quote_system_string(@_);
+ }
+}
+
+sub quote_system_cmd {
+ # force cmd, even when running through system
+ my $args = quote_native(@_);
+
+ if (! _has_shell_metachars($args)) {
+ # IT BURNS LOOK AWAY
+ return '%PATH:~0,0%' . cmd_escape($args);
+ }
+ return cmd_escape($args);
+}
+
+
+sub cmd_escape {
+ my $string = shift;
+ if ($string =~ /[\r\n\0]/) {
+ croak "can't quote newlines to pass through cmd.exe";
+ }
+ $string =~ s/([()%!^"<>&|])/^$1/g;
+ return $string;
+}
+
+sub quote_literal {
+ my ($text, $force) = @_;
+
+ # basic argument quoting. uses backslashes and quotes to escape
+ # everything.
+ if (!$force && $text ne '' && $text !~ /[ \t\n\x0b"]/) {
+ # no quoting needed
+ }
+ else {
+ $text =~ s{(\\*)(?="|\z)}{$1$1}g;
+ $text =~ s{"}{\\"}g;
+ $text = qq{"$text"};
+ }
+
+ return $text;
+}
+
+# derived from rules in code in win32.c
+sub _has_shell_metachars {
+ my $string = shift;
+
+ return 1
+ if $string =~ /%/;
+ $string =~ s/(['"]).*?(\1|\z)//sg;
+ return $string =~ /[<>|]/;
+}
+
+sub unquote_native {
+ local ($_) = @_;
+ my @argv;
+
+ my $length = length
+ or return @argv;
+
+ m/\G\s*/gc;
+
+ ARGS: until ( pos == $length ) {
+ my $quote_mode;
+ my $arg = '';
+ CHARS: until ( pos == $length ) {
+ if ( m/\G((?:\\\\)+)(?=\\?(")?)/gc ) {
+ if (defined $2) {
+ $arg .= '\\' x (length($1) / 2);
+ }
+ else {
+ $arg .= $1;
+ }
+ }
+ elsif ( m/\G\\"/gc ) {
+ $arg .= '"';
+ }
+ elsif ( m/\G"/gc ) {
+ if ( $quote_mode && m/\G"/gc ) {
+ $arg .= '"';
+ }
+ $quote_mode = !$quote_mode;
+ }
+ elsif ( !$quote_mode && m/\G\s+/gc ) {
+ last;
+ }
+ elsif ( m/\G(.)/sgc ) {
+ $arg .= $1;
+ }
+ }
+ push @argv, $arg;
+ }
+
+ return @argv;
+}
+
+sub cmd_unescape {
+ my ($string) = @_;
+
+ no warnings 'uninitialized';
+ $string =~ s/\^(.?)|([^^"]+)|("[^"]*(?:"|\z))/$1$2$3/gs;
+
+ return $string;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Win32::ShellQuote - Quote argument lists for Win32
+
+=head1 SYNOPSIS
+
+ use Win32::ShellQuote qw(:all);
+
+ system quote_system('program.exe', '--switch', 'argument with spaces or other special characters');
+
+=head1 DESCRIPTION
+
+Quotes argument lists to be used in Win32 in several different
+situations.
+
+Windows passes its arguments as a single string instead of an array
+as other platforms do. In almost all cases, the standard Win32
+L<CommandLineToArgvW|http://msdn.microsoft.com/en-us/library/ms647232.aspx>
+function is used to parse this string. F<cmd.exe> has different
+rules for handling quoting, so extra work has to be done if it is
+involved. It isn't possible to consistantly create a single string
+that will be handled the same by F<cmd.exe> and the stardard parsing
+rules.
+
+Perl will try to detect if you need the shell by detecting shell
+metacharacters. The routine that checks that uses different quoting
+rules from both F<cmd.exe> and the native Win32 parsing. Extra
+work must therefore be done to protect against this autodetection.
+
+=head1 SUBROUTINES
+
+=head2 quote_native
+
+Quotes as a string to pass directly to a program using native methods
+like L<Win32::Spawn()|Win32>. This is the safest option to use if
+possible.
+
+=head2 quote_cmd
+
+Quotes as a string to be run through F<cmd.exe>, such as in a batch file.
+
+=head2 quote_system_list
+
+Quotes as a list to be passed to L<system|perlfunc/system> or
+L<exec|perlfunc/exec>. This is equally as safe as L</quote_native>,
+but you must ensure you have more than one item being quoted for
+the list to be usable with system.
+
+=head2 quote_system_string
+
+Like L</quote_system_list>, but returns a single string. Some
+argument lists cannot be properly quoted using this function.
+
+=head2 quote_system
+
+Switches between L</quote_system_list> and L</quote_system_string>
+based on the number of items quoted.
+
+=head2 quote_system_cmd
+
+Quotes as a single string that will always be run with F<cmd.exe>.
+
+=head2 quote_literal
+
+Quotes a single parameter in native form.
+
+=head2 cmd_escape
+
+Escapes a string to be passed untouched by F<cmd.exe>.
+
+=head1 CAVEATS
+
+=over
+
+=item *
+
+Newlines (\n or \r) and null (\0) can't be properly quoted when
+running through F<cmd.exe>.
+
+=item *
+
+This module re-implements some under-specified part of the perl
+internals to accurately perform its work.
+
+=back
+
+=head1 AUTHOR
+
+haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
+
+=head1 CONTRIBUTORS
+
+=over 8
+
+=item * Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2012 the L</AUTHOR> and L</CONTRIBUTORS>
+as listed above.
+
+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
--- /dev/null
+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 -mlocal::lib -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='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan
+
+Please note that it is necessary to use C<local::lib> twice for this to work.
+First so that C<lib::core::only> doesn't prevent C<local::lib> from loading
+(it's not currently in core) and then again after C<lib::core::only> so that
+the local paths are not removed.
+
+=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<App::FatPacker|App::FatPacker> 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</CAVEATS>).
+
+This module was extracted from L<local::lib|local::lib>'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<not> propagate properly across perl invocations like local::lib's
+stuff does. It can't. It's only a module import, so it B<only affects the
+specific perl VM instance in which you load and import() it>.
+
+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<lib|lib> 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<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways
+to achieve the old --self-contained feature's results, look at
+L<App::FatPacker|App::FatPacker>'s tree function, and at
+L<App::cpanminus|cpanm>'s --local-lib-contained feature.
+
+=head1 AUTHOR
+
+Matt S. Trout <mst@shadowcat.co.uk>
+
+=head1 LICENSE
+
+This library is free software under the same terms as perl itself.
+
+=head1 COPYRIGHT
+
+(c) 2010 the lib::core::only L</AUTHOR> as specified above.
+
+=cut
+
+1;
--- /dev/null
+package local::lib;
+use 5.006;
+BEGIN {
+ if ($ENV{RELEASE_TESTING}) {
+ require strict;
+ strict->import;
+ require warnings;
+ warnings->import;
+ }
+}
+use Config ();
+
+our $VERSION = '2.000024';
+$VERSION = eval $VERSION;
+
+BEGIN {
+ *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')
+ ? sub(){1} : sub(){0};
+ # punt on these systems
+ *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})
+ ? sub(){1} : sub(){0};
+}
+my $_archname = $Config::Config{archname};
+my $_version = $Config::Config{version};
+my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list};
+my $_path_sep = $Config::Config{path_sep};
+
+our $_DIR_JOIN = _WIN32 ? '\\' : '/';
+our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]}
+ : qr{/};
+our $_ROOT = _WIN32 ? do {
+ my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};
+ qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT};
+} : qr{^/};
+our $_PERL;
+
+sub _perl {
+ if (!$_PERL) {
+ # untaint and validate
+ ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/;
+ $_PERL = 'perl'
+ if $exe !~ /perl/;
+ if (_is_abs($_PERL)) {
+ }
+ elsif (-x $Config::Config{perlpath}) {
+ $_PERL = $Config::Config{perlpath};
+ }
+ elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) {
+ $_PERL = _rel2abs($_PERL);
+ }
+ else {
+ ($_PERL) =
+ map { /(.*)/ }
+ grep { -x $_ }
+ map { ($_, _WIN32 ? ("$_.exe") : ()) }
+ map { join($_DIR_JOIN, $_, $_PERL) }
+ split /\Q$_path_sep\E/, $ENV{PATH};
+ }
+ }
+ $_PERL;
+}
+
+sub _cwd {
+ if (my $cwd
+ = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd
+ : defined &Cwd::cwd ? \&Cwd::cwd
+ : undef
+ ) {
+ no warnings 'redefine';
+ *_cwd = $cwd;
+ goto &$cwd;
+ }
+ my $drive = shift;
+ return Win32::Cwd()
+ if _WIN32 && defined &Win32::Cwd && !$drive;
+ local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
+ my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }"
+ : 'getcwd';
+ my $perl = _perl;
+ my $cwd = `"$perl" -MCwd -le "print $cmd"`;
+ chomp $cwd;
+ if (!length $cwd && $drive) {
+ $cwd = $drive;
+ }
+ $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;
+ $cwd;
+}
+
+sub _catdir {
+ if (_USE_FSPEC) {
+ require File::Spec;
+ File::Spec->catdir(@_);
+ }
+ else {
+ my $dir = join($_DIR_JOIN, @_);
+ $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;
+ $dir;
+ }
+}
+
+sub _is_abs {
+ if (_USE_FSPEC) {
+ require File::Spec;
+ File::Spec->file_name_is_absolute($_[0]);
+ }
+ else {
+ $_[0] =~ $_ROOT;
+ }
+}
+
+sub _rel2abs {
+ my ($dir, $base) = @_;
+ return $dir
+ if _is_abs($dir);
+
+ $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1")
+ : $base ? _rel2abs($base)
+ : _cwd;
+ return _catdir($base, $dir);
+}
+
+our $_DEVNULL;
+sub _devnull {
+ return $_DEVNULL ||=
+ _USE_FSPEC ? (require File::Spec, File::Spec->devnull)
+ : _WIN32 ? 'nul'
+ : $^O eq 'os2' ? '/dev/nul'
+ : '/dev/null';
+}
+
+sub import {
+ my ($class, @args) = @_;
+ if ($0 eq '-') {
+ push @args, @ARGV;
+ require Cwd;
+ }
+
+ my @steps;
+ my %opts;
+ my %attr;
+ my $shelltype;
+
+ while (@args) {
+ my $arg = shift @args;
+ # check for lethal dash first to stop processing before causing problems
+ # the fancy dash is U+2212 or \xE2\x88\x92
+ if ($arg =~ /\xE2\x88\x92/) {
+ 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 ($arg eq '--self-contained') {
+ die <<'DEATH';
+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).
+DEATH
+ }
+ elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) {
+ my $path = defined $1 ? $1 : shift @args;
+ push @steps, ['deactivate', $path];
+ }
+ elsif ( $arg eq '--deactivate-all' ) {
+ push @steps, ['deactivate_all'];
+ }
+ elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) {
+ $shelltype = defined $1 ? $1 : shift @args;
+ }
+ elsif ( $arg eq '--no-create' ) {
+ $opts{no_create} = 1;
+ }
+ elsif ( $arg eq '--quiet' ) {
+ $attr{quiet} = 1;
+ }
+ elsif ( $arg =~ /^--/ ) {
+ die "Unknown import argument: $arg";
+ }
+ else {
+ push @steps, ['activate', $arg, \%opts];
+ }
+ }
+ if (!@steps) {
+ push @steps, ['activate', undef, \%opts];
+ }
+
+ my $self = $class->new(%attr);
+
+ for (@steps) {
+ my ($method, @args) = @$_;
+ $self = $self->$method(@args);
+ }
+
+ if ($0 eq '-') {
+ print $self->environment_vars_string($shelltype);
+ exit 0;
+ }
+ else {
+ $self->setup_local_lib;
+ }
+}
+
+sub new {
+ my $class = shift;
+ bless {@_}, $class;
+}
+
+sub clone {
+ my $self = shift;
+ bless {%$self, @_}, ref $self;
+}
+
+sub inc { $_[0]->{inc} ||= \@INC }
+sub libs { $_[0]->{libs} ||= [ \'PERL5LIB' ] }
+sub bins { $_[0]->{bins} ||= [ \'PATH' ] }
+sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] }
+sub extra { $_[0]->{extra} ||= {} }
+sub quiet { $_[0]->{quiet} }
+
+sub _as_list {
+ my $list = shift;
+ grep length, map {
+ !(ref $_ && ref $_ eq 'SCALAR') ? $_ : (
+ defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_})
+ : ()
+ )
+ } ref $list ? @$list : $list;
+}
+sub _remove_from {
+ my ($list, @remove) = @_;
+ return @$list
+ if !@remove;
+ my %remove = map { $_ => 1 } @remove;
+ grep !$remove{$_}, _as_list($list);
+}
+
+my @_lib_subdirs = (
+ [$_version, $_archname],
+ [$_version],
+ [$_archname],
+ (map [$_], @_inc_version_list),
+ [],
+);
+
+sub install_base_bin_path {
+ my ($class, $path) = @_;
+ return _catdir($path, 'bin');
+}
+sub install_base_perl_path {
+ my ($class, $path) = @_;
+ return _catdir($path, 'lib', 'perl5');
+}
+sub install_base_arch_path {
+ my ($class, $path) = @_;
+ _catdir($class->install_base_perl_path($path), $_archname);
+}
+
+sub lib_paths_for {
+ my ($class, $path) = @_;
+ my $base = $class->install_base_perl_path($path);
+ return map { _catdir($base, @$_) } @_lib_subdirs;
+}
+
+sub _mm_escape_path {
+ my $path = shift;
+ $path =~ s/\\/\\\\/g;
+ if ($path =~ s/ /\\ /g) {
+ $path = qq{"$path"};
+ }
+ return $path;
+}
+
+sub _mb_escape_path {
+ my $path = shift;
+ $path =~ s/\\/\\\\/g;
+ return qq{"$path"};
+}
+
+sub installer_options_for {
+ my ($class, $path) = @_;
+ return (
+ PERL_MM_OPT =>
+ defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef,
+ PERL_MB_OPT =>
+ defined $path ? "--install_base "._mb_escape_path($path) : undef,
+ );
+}
+
+sub active_paths {
+ my ($self) = @_;
+ $self = ref $self ? $self : $self->new;
+
+ return grep {
+ # screen out entries that aren't actually reflected in @INC
+ my $active_ll = $self->install_base_perl_path($_);
+ grep { $_ eq $active_ll } @{$self->inc};
+ } _as_list($self->roots);
+}
+
+
+sub deactivate {
+ my ($self, $path) = @_;
+ $self = $self->new unless ref $self;
+ $path = $self->resolve_path($path);
+ $path = $self->normalize_path($path);
+
+ my @active_lls = $self->active_paths;
+
+ if (!grep { $_ eq $path } @active_lls) {
+ warn "Tried to deactivate inactive local::lib '$path'\n";
+ return $self;
+ }
+
+ my %args = (
+ bins => [ _remove_from($self->bins,
+ $self->install_base_bin_path($path)) ],
+ libs => [ _remove_from($self->libs,
+ $self->install_base_perl_path($path)) ],
+ inc => [ _remove_from($self->inc,
+ $self->lib_paths_for($path)) ],
+ roots => [ _remove_from($self->roots, $path) ],
+ );
+
+ $args{extra} = { $self->installer_options_for($args{roots}[0]) };
+
+ $self->clone(%args);
+}
+
+sub deactivate_all {
+ my ($self) = @_;
+ $self = $self->new unless ref $self;
+
+ my @active_lls = $self->active_paths;
+
+ my %args;
+ if (@active_lls) {
+ %args = (
+ bins => [ _remove_from($self->bins,
+ map $self->install_base_bin_path($_), @active_lls) ],
+ libs => [ _remove_from($self->libs,
+ map $self->install_base_perl_path($_), @active_lls) ],
+ inc => [ _remove_from($self->inc,
+ map $self->lib_paths_for($_), @active_lls) ],
+ roots => [ _remove_from($self->roots, @active_lls) ],
+ );
+ }
+
+ $args{extra} = { $self->installer_options_for(undef) };
+
+ $self->clone(%args);
+}
+
+sub activate {
+ my ($self, $path, $opts) = @_;
+ $opts ||= {};
+ $self = $self->new unless ref $self;
+ $path = $self->resolve_path($path);
+ $self->ensure_dir_structure_for($path, { quiet => $self->quiet })
+ unless $opts->{no_create};
+
+ $path = $self->normalize_path($path);
+
+ my @active_lls = $self->active_paths;
+
+ if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) {
+ $self = $self->deactivate($path);
+ }
+
+ my %args;
+ if ($opts->{always} || !@active_lls || $active_lls[0] ne $path) {
+ %args = (
+ bins => [ $self->install_base_bin_path($path), @{$self->bins} ],
+ libs => [ $self->install_base_perl_path($path), @{$self->libs} ],
+ inc => [ $self->lib_paths_for($path), @{$self->inc} ],
+ roots => [ $path, @{$self->roots} ],
+ );
+ }
+
+ $args{extra} = { $self->installer_options_for($path) };
+
+ $self->clone(%args);
+}
+
+sub normalize_path {
+ my ($self, $path) = @_;
+ $path = ( Win32::GetShortPathName($path) || $path )
+ if $^O eq 'MSWin32';
+ return $path;
+}
+
+sub build_environment_vars_for {
+ my $self = $_[0]->new->activate($_[1], { always => 1 });
+ $self->build_environment_vars;
+}
+sub build_activate_environment_vars_for {
+ my $self = $_[0]->new->activate($_[1], { always => 1 });
+ $self->build_environment_vars;
+}
+sub build_deactivate_environment_vars_for {
+ my $self = $_[0]->new->deactivate($_[1]);
+ $self->build_environment_vars;
+}
+sub build_deact_all_environment_vars_for {
+ my $self = $_[0]->new->deactivate_all;
+ $self->build_environment_vars;
+}
+sub build_environment_vars {
+ my $self = shift;
+ (
+ PATH => join($_path_sep, _as_list($self->bins)),
+ PERL5LIB => join($_path_sep, _as_list($self->libs)),
+ PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)),
+ %{$self->extra},
+ );
+}
+
+sub setup_local_lib_for {
+ my $self = $_[0]->new->activate($_[1]);
+ $self->setup_local_lib;
+}
+
+sub setup_local_lib {
+ my $self = shift;
+
+ # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid
+ # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to
+ # check in the other direction)
+ require Carp::Heavy if $INC{'Carp.pm'};
+
+ $self->setup_env_hash;
+ @INC = @{$self->inc};
+}
+
+sub setup_env_hash_for {
+ my $self = $_[0]->new->activate($_[1]);
+ $self->setup_env_hash;
+}
+sub setup_env_hash {
+ my $self = shift;
+ my %env = $self->build_environment_vars;
+ for my $key (keys %env) {
+ if (defined $env{$key}) {
+ $ENV{$key} = $env{$key};
+ }
+ else {
+ delete $ENV{$key};
+ }
+ }
+}
+
+sub print_environment_vars_for {
+ print $_[0]->environment_vars_string_for(@_[1..$#_]);
+}
+
+sub environment_vars_string_for {
+ my $self = $_[0]->new->activate($_[1], { always => 1});
+ $self->environment_vars_string;
+}
+sub environment_vars_string {
+ my ($self, $shelltype) = @_;
+
+ $shelltype ||= $self->guess_shelltype;
+
+ my $extra = $self->extra;
+ my @envs = (
+ PATH => $self->bins,
+ PERL5LIB => $self->libs,
+ PERL_LOCAL_LIB_ROOT => $self->roots,
+ map { $_ => $extra->{$_} } sort keys %$extra,
+ );
+ $self->_build_env_string($shelltype, \@envs);
+}
+
+sub _build_env_string {
+ my ($self, $shelltype, $envs) = @_;
+ my @envs = @$envs;
+
+ my $build_method = "build_${shelltype}_env_declaration";
+
+ my $out = '';
+ while (@envs) {
+ my ($name, $value) = (shift(@envs), shift(@envs));
+ if (
+ ref $value
+ && @$value == 1
+ && ref $value->[0]
+ && ref $value->[0] eq 'SCALAR'
+ && ${$value->[0]} eq $name) {
+ next;
+ }
+ $out .= $self->$build_method($name, $value);
+ }
+ my $wrap_method = "wrap_${shelltype}_output";
+ if ($self->can($wrap_method)) {
+ return $self->$wrap_method($out);
+ }
+ return $out;
+}
+
+sub build_bourne_env_declaration {
+ my ($class, $name, $args) = @_;
+ my $value = $class->_interpolate($args, '${%s:-}', qr/["\\\$!`]/, '\\%s');
+
+ if (!defined $value) {
+ return qq{unset $name;\n};
+ }
+
+ $value =~ s/(^|\G|$_path_sep)\$\{$name:-\}$_path_sep/$1\${$name}\${$name:+$_path_sep}/g;
+ $value =~ s/$_path_sep\$\{$name:-\}$/\${$name:+$_path_sep\${$name}}/;
+
+ qq{${name}="$value"; export ${name};\n}
+}
+
+sub build_csh_env_declaration {
+ my ($class, $name, $args) = @_;
+ my ($value, @vars) = $class->_interpolate($args, '${%s}', qr/["\$]/, '"\\%s"');
+ if (!defined $value) {
+ return qq{unsetenv $name;\n};
+ }
+
+ my $out = '';
+ for my $var (@vars) {
+ $out .= qq{if ! \$?$name setenv $name '';\n};
+ }
+
+ my $value_without = $value;
+ if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) {
+ $out .= qq{if "\${$name}" != '' setenv $name "$value";\n};
+ $out .= qq{if "\${$name}" == '' };
+ }
+ $out .= qq{setenv $name "$value_without";\n};
+ return $out;
+}
+
+sub build_cmd_env_declaration {
+ my ($class, $name, $args) = @_;
+ my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s');
+ if (!$value) {
+ return qq{\@set $name=\n};
+ }
+
+ my $out = '';
+ my $value_without = $value;
+ if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) {
+ $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};
+ $out .= qq{\@if "%$name%"=="" };
+ }
+ $out .= qq{\@set "$name=$value_without"\n};
+ return $out;
+}
+
+sub build_powershell_env_declaration {
+ my ($class, $name, $args) = @_;
+ my $value = $class->_interpolate($args, '$env:%s', qr/["\$]/, '`%s');
+
+ if (!$value) {
+ return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n};
+ }
+
+ my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};
+ $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;
+ $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;
+
+ qq{\$env:$name = \$("$value");\n};
+}
+sub wrap_powershell_output {
+ my ($class, $out) = @_;
+ return $out || " \n";
+}
+
+sub build_fish_env_declaration {
+ my ($class, $name, $args) = @_;
+ my $value = $class->_interpolate($args, '$%s', qr/[\\"'$ ]/, '\\%s');
+ if (!defined $value) {
+ return qq{set -e $name;\n};
+ }
+
+ # fish has special handling for PATH, CDPATH, and MANPATH. They are always
+ # treated as arrays, and joined with ; when storing the environment. Other
+ # env vars can be arrays, but will be joined without a separator. We only
+ # really care about PATH, but might as well make this routine more general.
+ if ($name =~ /^(?:CD|MAN)?PATH$/) {
+ $value =~ s/$_path_sep/ /g;
+ my $silent = $name =~ /^(?:CD)?PATH$/ ? " ^"._devnull : '';
+ return qq{set -x $name $value$silent;\n};
+ }
+
+ my $out = '';
+ my $value_without = $value;
+ if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
+ $out .= qq{set -q $name; and set -x $name $value;\n};
+ $out .= qq{set -q $name; or };
+ }
+ $out .= qq{set -x $name $value_without;\n};
+ $out;
+}
+
+sub _interpolate {
+ my ($class, $args, $var_pat, $escape, $escape_pat) = @_;
+ return
+ unless defined $args;
+ my @args = ref $args ? @$args : $args;
+ return
+ unless @args;
+ my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args;
+ my $string = join $_path_sep, map {
+ ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do {
+ s/($escape)/sprintf($escape_pat, $1)/ge; $_;
+ };
+ } @args;
+ return wantarray ? ($string, \@vars) : $string;
+}
+
+sub pipeline;
+
+sub pipeline {
+ my @methods = @_;
+ my $last = pop(@methods);
+ if (@methods) {
+ \sub {
+ my ($obj, @args) = @_;
+ $obj->${pipeline @methods}(
+ $obj->$last(@args)
+ );
+ };
+ } else {
+ \sub {
+ shift->$last(@_);
+ };
+ }
+}
+
+sub resolve_path {
+ my ($class, $path) = @_;
+
+ $path = $class->${pipeline qw(
+ resolve_relative_path
+ resolve_home_path
+ resolve_empty_path
+ )}($path);
+
+ $path;
+}
+
+sub resolve_empty_path {
+ my ($class, $path) = @_;
+ if (defined $path) {
+ $path;
+ } else {
+ '~/perl5';
+ }
+}
+
+sub resolve_home_path {
+ my ($class, $path) = @_;
+ $path =~ /^~([^\/]*)/ or return $path;
+ my $user = $1;
+ my $homedir = do {
+ if (! length($user) && defined $ENV{HOME}) {
+ $ENV{HOME};
+ }
+ else {
+ require File::Glob;
+ File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE());
+ }
+ };
+ unless (defined $homedir) {
+ require Carp; require Carp::Heavy;
+ Carp::croak(
+ "Couldn't resolve homedir for "
+ .(defined $user ? $user : 'current user')
+ );
+ }
+ $path =~ s/^~[^\/]*/$homedir/;
+ $path;
+}
+
+sub resolve_relative_path {
+ my ($class, $path) = @_;
+ _rel2abs($path);
+}
+
+sub ensure_dir_structure_for {
+ my ($class, $path, $opts) = @_;
+ $opts ||= {};
+ my @dirs;
+ foreach my $dir (
+ $class->lib_paths_for($path),
+ $class->install_base_bin_path($path),
+ ) {
+ my $d = $dir;
+ while (!-d $d) {
+ push @dirs, $d;
+ require File::Basename;
+ $d = File::Basename::dirname($d);
+ }
+ }
+
+ warn "Attempting to create directory ${path}\n"
+ if !$opts->{quiet} && @dirs;
+
+ my %seen;
+ foreach my $dir (reverse @dirs) {
+ next
+ if $seen{$dir}++;
+
+ mkdir $dir
+ or -d $dir
+ or die "Unable to create $dir: $!"
+ }
+ return;
+}
+
+sub guess_shelltype {
+ my $shellbin
+ = defined $ENV{SHELL} && length $ENV{SHELL}
+ ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1]
+ : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} )
+ ? 'bash'
+ : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} )
+ ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1]
+ : ( $^O eq 'MSWin32' && !$ENV{PROMPT} )
+ ? 'powershell.exe'
+ : 'sh';
+
+ for ($shellbin) {
+ return
+ /csh$/ ? 'csh'
+ : /fish$/ ? 'fish'
+ : /command(?:\.com)?$/i ? 'cmd'
+ : /cmd(?:\.exe)?$/i ? 'cmd'
+ : /4nt(?:\.exe)?$/i ? 'cmd'
+ : /powershell(?:\.exe)?$/i ? 'powershell'
+ : 'bourne';
+ }
+}
+
+1;
+__END__
+
+=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
+ PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT;
+ PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT;
+ PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB;
+ PATH="/home/username/perl5/bin:$PATH"; export PATH;
+ PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT;
+
+From a F<.bash_profile> or F<.bashrc> file -
+
+ eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"
+
+=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.
+
+Even 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</Differences when using this module under Win32>.
+
+=over 4
+
+=item 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.
+
+=item 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
+
+=item 3.
+
+Run this: (local::lib assumes you have make installed on your system)
+
+ make test && make install
+
+=item 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
+ echo 'eval `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<source ~/.cshrc>.
+
+=back
+
+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 ...
+
+If you use F<.bashrc> to activate a local::lib automatically, the local::lib
+will be re-enabled in any sub-shells used, overriding adjustments you may have
+made in the parent shell. To avoid this, you can initialize the local::lib in
+F<.bash_profile> rather than F<.bashrc>, or protect the local::lib invocation
+with a C<$SHLVL> check:
+
+ [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"
+
+If you are working with several C<local::lib> environments, you may want to
+remove some of them from the current environment without disturbing the others.
+You can deactivate one environment like this (using bourne sh):
+
+ eval $(perl -Mlocal::lib=--deactivate,~/path)
+
+which will generate and run the commands needed to remove C<~/path> from your
+various search paths. Whichever environment was B<activated most recently> will
+remain the target for module installations. That is, if you activate
+C<~/path_A> and then you activate C<~/path_B>, new modules you install will go
+in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed
+into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be
+installed in C<~/pathB> because pathB was activated later.
+
+You can also ask C<local::lib> to clean itself completely out of the current
+shell's environment with the C<--deactivate-all> option.
+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<CMD.exe>, 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
+ 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%\tmp.bat
+ ### instead of $(perl -Mlocal::lib=./)
+
+If you want the environment entries to persist, you'll need to add them to the
+Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>.
+
+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.
+
+=head3 PowerShell
+
+local::lib also supports PowerShell, and can be used with the
+C<Invoke-Expression> cmdlet.
+
+ Invoke-Expression "$(perl -Mlocal::lib)"
+
+=head1 RATIONALE
+
+The version of a Perl package on your machine is not always the version you
+need. Obviously, the best thing to do would be to update to the version you
+need. However, you might be in a situation where you're prevented from doing
+this. Perhaps you don't have system administrator privileges; or perhaps you
+are using a package management system such as Debian, and nobody has yet gotten
+around to packaging up the version you need.
+
+local::lib solves this problem by allowing you to create your own directory of
+Perl packages downloaded from CPAN (in a multi-user system, this would typically
+be within your own home directory). The existing system Perl installation is
+not affected; you simply invoke Perl with special options so that Perl uses the
+packages in your own local package directory rather than the system packages.
+local::lib arranges things so that your locally installed version of the Perl
+packages takes precedence over the system installation.
+
+If you are using a package management system (such as Debian), you don't need to
+worry about Debian and CPAN stepping on each other's toes. Your local version
+of the packages will be written to an entirely separate directory from those
+installed by Debian.
+
+=head1 DESCRIPTION
+
+This module provides a quick, convenient way of bootstrapping a user-local Perl
+module library located within the user's home directory. It also constructs and
+prints out for the user the list of environment variables using the syntax
+appropriate for the user's current shell (as specified by the C<SHELL>
+environment variable), suitable for directly adding to one's shell
+configuration file.
+
+More generally, local::lib allows for the bootstrapping and usage of a
+directory containing Perl modules outside of Perl's C<@INC>. This makes it
+easier to ship an application with an app-specific copy of a Perl module, or
+collection of modules. Useful in cases like when an upstream maintainer hasn't
+applied a patch to a module of theirs that you need for your application.
+
+On import, local::lib sets the following environment variables to appropriate
+values:
+
+=over 4
+
+=item PERL_MB_OPT
+
+=item PERL_MM_OPT
+
+=item PERL5LIB
+
+=item PATH
+
+=item PERL_LOCAL_LIB_ROOT
+
+=back
+
+When possible, these will be appended to instead of overwritten entirely.
+
+These values are then available for reference by any code after import.
+
+=head1 CREATING A SELF-CONTAINED SET OF MODULES
+
+See L<lib::core::only> 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 IMPORT OPTIONS
+
+Options are values that can be passed to the C<local::lib> import besides the
+directory to use. They are specified as C<use local::lib '--option'[, path];>
+or C<perl -Mlocal::lib=--option[,path]>.
+
+=head2 --deactivate
+
+Remove the chosen path (or the default path) from the module search paths if it
+was added by C<local::lib>, instead of adding it.
+
+=head2 --deactivate-all
+
+Remove all directories that were added to search paths by C<local::lib> from the
+search paths.
+
+=head2 --shelltype
+
+Specify the shell type to use for output. By default, the shell will be
+detected based on the environment. Should be one of: C<bourne>, C<csh>,
+C<cmd>, or C<powershell>.
+
+=head2 --no-create
+
+Prevents C<local::lib> from creating directories when activating dirs. This is
+likely to cause issues on Win32 systems.
+
+=head1 CLASS METHODS
+
+=head2 ensure_dir_structure_for
+
+=over 4
+
+=item Arguments: $path
+
+=item Return value: None
+
+=back
+
+Attempts to create a local::lib directory, including subdirectories 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
+
+=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</build_environment_vars_for>.
+
+=head2 active_paths
+
+=over 4
+
+=item Arguments: None
+
+=item Return value: @paths
+
+=back
+
+Returns a list of active C<local::lib> paths, according to the
+C<PERL_LOCAL_LIB_ROOT> environment variable and verified against
+what is really in C<@INC>.
+
+=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<lib> and C<perl5> to the given
+path.
+
+=head2 lib_paths_for
+
+=over 4
+
+=item Arguments: $path
+
+=item Return value: @lib_paths
+
+=back
+
+Returns the list of paths perl will search for libraries, given a base path.
+This includes the base path itself, the architecture specific subdirectory, and
+perl version specific subdirectories. These paths may not all exist.
+
+=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. Appends the directory C<bin> to the given path.
+
+=head2 installer_options_for
+
+=over 4
+
+=item Arguments: $path
+
+=item Return value: %installer_env_vars
+
+=back
+
+Returns a hash of environment variables that should be set to cause
+installation into the given path.
+
+=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<File::HomeDir>
+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</resolve_empty_path>, L</resolve_home_path>,
+L</resolve_relative_path>. Passes the given path argument to
+L</resolve_empty_path> which then returns a result that is passed to
+L</resolve_home_path>, which then has its result passed to
+L</resolve_relative_path>. The result of this final call is returned from
+L</resolve_path>.
+
+=head1 OBJECT INTERFACE
+
+=head2 new
+
+=over 4
+
+=item Arguments: %attributes
+
+=item Return value: $local_lib
+
+=back
+
+Constructs a new C<local::lib> object, representing the current state of
+C<@INC> and the relevant environment variables.
+
+=head1 ATTRIBUTES
+
+=head2 roots
+
+An arrayref representing active C<local::lib> directories.
+
+=head2 inc
+
+An arrayref representing C<@INC>.
+
+=head2 libs
+
+An arrayref representing the PERL5LIB environment variable.
+
+=head2 bins
+
+An arrayref representing the PATH environment variable.
+
+=head2 extra
+
+A hashref of extra environment variables (e.g. C<PERL_MM_OPT> and
+C<PERL_MB_OPT>)
+
+=head2 no_create
+
+If set, C<local::lib> will not try to create directories when activating them.
+
+=head1 OBJECT METHODS
+
+=head2 clone
+
+=over 4
+
+=item Arguments: %attributes
+
+=item Return value: $local_lib
+
+=back
+
+Constructs a new C<local::lib> object based on the existing one, overriding the
+specified attributes.
+
+=head2 activate
+
+=over 4
+
+=item Arguments: $path
+
+=item Return value: $new_local_lib
+
+=back
+
+Constructs a new instance with the specified path active.
+
+=head2 deactivate
+
+=over 4
+
+=item Arguments: $path
+
+=item Return value: $new_local_lib
+
+=back
+
+Constructs a new instance with the specified path deactivated.
+
+=head2 deactivate_all
+
+=over 4
+
+=item Arguments: None
+
+=item Return value: $new_local_lib
+
+=back
+
+Constructs a new instance with all C<local::lib> directories deactivated.
+
+=head2 environment_vars_string
+
+=over 4
+
+=item Arguments: [ $shelltype ]
+
+=item Return value: $shell_env_string
+
+=back
+
+Returns a string to set up the C<local::lib>, meant to be run by a shell.
+
+=head2 build_environment_vars
+
+=over 4
+
+=item Arguments: None
+
+=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
+
+=over 4
+
+=item Arguments: None
+
+=item Return value: None
+
+=back
+
+Constructs the C<%ENV> keys for the given path, by calling
+L</build_environment_vars>.
+
+=head2 setup_local_lib
+
+Constructs the C<%ENV> hash using L</setup_env_hash>, and set up C<@INC>.
+
+=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
+
+=over 4
+
+=item * Directory names with spaces in them are not well supported by the perl
+toolchain and the programs it uses. Pure-perl distributions should support
+spaces, but problems are more likely with dists that require compilation. A
+workaround you can do is moving your local::lib to a directory with spaces
+B<after> you installed all modules inside your local::lib bootstrap. But be
+aware that you can't update or install CPAN modules after the move.
+
+=item * Rather basic shell detection. Right now anything with csh in its name is
+assumed to be a C shell or something compatible, and everything else is assumed
+to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is
+not set, a Bourne-compatible shell is assumed.
+
+=item * Kills any existing PERL_MM_OPT or PERL_MB_OPT.
+
+=item * Should probably auto-fixup CPAN config if not already done.
+
+=item * On VMS and MacOS Classic (pre-OS X), local::lib loads L<File::Spec>.
+This means any L<File::Spec> version installed in the local::lib will be
+ignored by scripts using local::lib. A workaround for this is using
+C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly.
+
+=item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option.
+C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and
+sane behavior. If something attempts to use the C<PREFIX> option when running
+a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two
+options conflict. This can be worked around by temporarily unsetting the
+C<PERL_MM_OPT> environment variable.
+
+=item * Conflicts with L<Module::Build>'s C<--prefix> option. Similar to the
+previous limitation, but any C<--prefix> option specified will be ignored.
+This can be worked around by temporarily unsetting the C<PERL_MB_OPT>
+environment variable.
+
+=back
+
+Patches very much welcome for any of the above.
+
+=over 4
+
+=item * 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.
+
+=back
+
+=head1 TROUBLESHOOTING
+
+If you've configured local::lib to install CPAN modules somewhere in to your
+home directory, and at some point later you try to install a module with C<cpan
+-i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
+permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
+/usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an
+error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then
+you've somehow lost your updated ExtUtils::MakeMaker module.
+
+To remedy this situation, rerun the bootstrapping procedure documented above.
+
+Then, run C<rm -r ~/.cpan/build/Foo-Bar*>
+
+Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item SHELL
+
+=item COMSPEC
+
+local::lib looks at the user's C<SHELL> environment variable when printing out
+commands to add to the shell configuration file.
+
+On Win32 systems, C<COMSPEC> is also examined.
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html>
+
+=back
+
+=head1 SUPPORT
+
+IRC:
+
+ Join #toolchain on irc.perl.org.
+
+=head1 AUTHOR
+
+Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
+
+auto_install fixes kindly sponsored by http://www.takkle.com/
+
+=head1 CONTRIBUTORS
+
+Patches to correctly output commands for csh style shells, as well as some
+documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>.
+
+Doc patches for a custom local::lib directory, more cleanups in the english
+documentation and a L<german documentation|POD2::DE::local::lib> contributed by
+Torsten Raudssus <torsten@raudssus.de>.
+
+Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring
+things will install properly, submitted a fix for the bug causing problems with
+writing Makefiles during bootstrapping, contributed an example program, and
+submitted yet another fix to ensure that local::lib can install and bootstrap
+properly. Many, many thanks!
+
+pattern of Freenode IRC contributed the beginnings of the Troubleshooting
+section. Many thanks!
+
+Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>.
+
+Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
+by a patch from Marco Emilio Poleggi.
+
+Mark Stosberg <mark@summersault.com> provided the code for the now deleted
+'--self-contained' option.
+
+Documentation patches to make win32 usage clearer by
+David Mertens <dcmertens.perl@gmail.com> (run4flat).
+
+Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc
+patches contributed by Breno G. de Oliveira <garu@cpan.org>.
+
+Improvements to stacking multiple local::lib dirs and removing them from the
+environment later on contributed by Andrew Rodland <arodland@cpan.org>.
+
+Patch for Carp version mismatch contributed by Hakim Cassimally
+<osfameron@cpan.org>.
+
+Rewrite of internals and numerous bug fixes and added features contributed by
+Graham Knop <haarg@haarg.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as
+listed above.
+
+=head1 LICENSE
+
+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
--- /dev/null
+# This is a basic workflow to help you get started with Actions
+
+name: Release Tests
+
+# Controls when the action will run. Triggers the workflow on push or pull request
+# events but only for the master branch
+on:
+ push:
+ branches: [ master, devel ]
+ pull_request:
+ branches: [ master, devel ]
+
+# A workflow run is made up of one or more jobs that can run sequentially or in parallel
+jobs:
+ ubuntu:
+ name: Release Tests on Ubuntu 20.04
+ runs-on: ubuntu-20.04
+ steps:
+ - name: Checkout the repository
+ uses: actions/checkout@v2
+ - name: Cache CPAN packages
+ uses: actions/cache@v2
+ with:
+ path: |
+ ~/.perl-cpm/cache
+ ~/.perl-cpm/builds
+ **/local/
+ key: ${{ runner.os }}-ubuntu-20.04
+ restore-keys: |
+ ${{ runner.os }}-ubuntu-20.04
+ - name: apt-get install
+ run: |
+ sudo apt-get install --ignore-hold --allow-downgrades -y \
+ build-essential curl libssl-dev zlib1g-dev openssl \
+ libexpat-dev cmake git libcairo-dev libgd-dev \
+ default-libmysqlclient-dev unzip wget libgd3=2.2.5-5.2ubuntu2
+ - name: cpm install
+ run: |
+ perl -I$GITHUB_WORKSPACE/.github/cpm/lib/perl5 $GITHUB_WORKSPACE/.github/cpm/bin/cpm install \
+ && tar -C $GITHUB_WORKSPACE \
+ --exclude 'local/cache/*' \
+ --exclude 'local/man/*' \
+ --exclude '*.pod' \
+ -zcvf local-lib.tar.gz local
+ - name: Save dependencies
+ uses: actions/upload-artifact@v2
+ with:
+ name: ubuntu-20.04-local-lib.tar.gz
+ path: local-lib.tar.gz
+ - name: Run Makefile.PL
+ run: 'perl Makefile.PL'
+ - name: Run checksetup
+ run: 'perl checksetup.pl --no-database --default-localconfig --no-templates'
+ - name: Run tests
+ run: 'prove -Ilocal/lib/perl5 t'
/js/yui3.js
/lib/*
/local/*
-/logs
+/logs/*
/template/en/custom
/docs/en/rst/extensions/*
/docs/en/rst/api/extensions/*
functions = :builtins
exclude_functions = print say sleep binmode
-[ValuesAndExpressions::ProhibitInterpolationOfLiterals]
+[-ValuesAndExpressions::ProhibitInterpolationOfLiterals]
severity = 2
[Freenode::EmptyReturn]
use 5.10.1;
use strict;
use warnings;
+use Sys::Hostname;
sub import {
my ($class, %lc) = @_;
+ $lc{urlbase} //= sprintf 'http://%s:%d', hostname(), 8000;
$ENV{LOCALCONFIG_ENV} = 'BMO';
$ENV{"BMO_$_"} = $lc{$_} for keys %lc;
}
# Log real IP addresses for auditing
Bugzilla->audit(sprintf(
'%s <%s> created bug %s',
- Bugzilla->user->login, remote_ip(), $args->{object}->id
+ Bugzilla->user->login, remote_ip() // '[undef]', $args->{object}->id
));
}
}
$VAR1 = [
{
- 'Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames' => 0,
- 'Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace' => 0,
- 'Perl::Critic::Policy::Variables::ProhibitUnusedVariables' => 1,
- 'Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProtectPrivateSubs' => 43,
+ 'Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer' => 10,
+ 'Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity' => 2,
+ 'Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration' => 1,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms' => 11,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses' => 40,
'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan' => 0,
- 'Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline' => 0,
- 'Perl::Critic::Policy::Variables::ProhibitReusedNames' => 7,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit' => 1,
- 'Perl::Critic::Policy::Subroutines::ProhibitNestedSubs' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions' => 0,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins' => 1264,
+ 'Perl::Critic::Policy::Variables::RequireNegativeIndices' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings' => 11,
+ 'Perl::Critic::Policy::Freenode::ModPerl' => 0,
+ 'Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars' => 6,
+ 'Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish' => 1,
+ 'Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils' => 14,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitMatchVars' => 0,
+ 'Perl::Critic::Policy::Modules::RequireEndWithOne' => 13,
+ 'Perl::Critic::Policy::Subroutines::ProhibitManyArgs' => 7,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions' => 20,
+ 'Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations' => 6,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::Freenode::DeprecatedFeatures' => 0,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists' => 22,
+ 'Perl::Critic::Policy::Subroutines::ProhibitNestedSubs' => 1,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitHardTabs' => 0,
'Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator' => 0,
- 'Perl::Critic::Policy::Freenode::Each' => 0,
- 'Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements' => 0,
- 'Perl::Critic::Policy::Freenode::OpenArgs' => 2,
- 'Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings' => 0,
- 'Perl::Critic::Policy::Miscellanea::ProhibitTies' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros' => 24,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion' => 0,
+ 'Perl::Critic::Policy::Modules::ProhibitAutomaticExportation' => 19,
+ 'Perl::Critic::Policy::InputOutput::RequireBriefOpen' => 19,
+ 'Perl::Critic::Policy::Freenode::OpenArgs' => 0,
+ 'Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName' => 15,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture' => 9,
+ 'Perl::Critic::Policy::Freenode::DollarAB' => 10,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators' => 67,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters' => 48,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep' => 100,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading' => 2,
+ 'Perl::Critic::Policy::Freenode::ConditionalDeclarations' => 0,
+ 'Perl::Critic::Policy::Freenode::LexicalForeachIterator' => 0,
+ 'Perl::Critic::Policy::Freenode::WarningsSwitch' => 0,
+ 'Perl::Critic::Policy::NamingConventions::Capitalization' => 129,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars' => 15,
'Perl::Critic::Policy::Modules::ProhibitEvilModules' => 0,
- 'Perl::Critic::Policy::Subroutines::ProhibitManyArgs' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators' => 0,
- 'Perl::Critic::Policy::Freenode::POSIXImports' => 0,
- 'Perl::Critic::Policy::Freenode::DollarAB' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator' => 29,
- 'Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect' => 0,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation' => 16,
- 'Perl::Critic::Policy::Freenode::ModPerl' => 0,
- 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings' => 0,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitFormats' => 0,
+ 'Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames' => 10,
+ 'Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop' => 3,
+ 'Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline' => 10,
+ 'Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines' => 56,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters' => 0,
+ 'Perl::Critic::Policy::Freenode::EmptyReturn' => 53,
+ 'Perl::Critic::Policy::Freenode::ConditionalImplicitReturn' => 5,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator' => 16,
+ 'Perl::Critic::Policy::Modules::RequireExplicitPackage' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators' => 0,
+ 'Perl::Critic::Policy::Freenode::Each' => 17,
+ 'Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock' => 5,
+ 'Perl::Critic::Policy::Variables::RequireInitializationForLocalVars' => 8,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict' => 0,
+ 'Perl::Critic::Policy::Freenode::StrictWarnings' => 0,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls' => 51,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval' => 10,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedOpen' => 4,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitDeepNests' => 6,
+ 'Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements' => 1,
+ 'Perl::Critic::Policy::Freenode::BarewordFilehandles' => 10,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters' => 268,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters' => 2,
+ 'Perl::Critic::Policy::Freenode::Threads' => 0,
+ 'Perl::Critic::Policy::Modules::ProhibitMultiplePackages' => 7,
'Perl::Critic::Policy::Freenode::IndirectObjectNotation' => 0,
- 'Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode' => 0,
- 'Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes' => 5,
- 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions' => 1,
- 'Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval' => 3,
- 'Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators' => 0,
- 'Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars' => 7,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa' => 0,
+ 'Perl::Critic::Policy::Freenode::LoopOnHash' => 0,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitTies' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitReturnSort' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap' => 21,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks' => 1,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep' => 112,
+ 'Perl::Critic::Policy::Objects::ProhibitIndirectSyntax' => 334,
'Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion' => 0,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless' => 0,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings' => 0,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitPunctuationVars' => 41,
+ 'Perl::Critic::Policy::Subroutines::RequireArgUnpacking' => 521,
+ 'Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles' => 13,
+ 'Perl::Critic::Policy::Documentation::RequirePodAtEnd' => 17,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock' => 0,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedClose' => 23,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect' => 0,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict' => 2,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops' => 9,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators' => 34,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest' => 29,
+ 'Perl::Critic::Policy::Freenode::WhileDiamondDefaultAssignment' => 6,
'Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic' => 0,
- 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict' => 1,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval' => 1,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa' => 0,
- 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists' => 0,
- 'Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames' => 0,
- 'Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals' => 255,
- 'Perl::Critic::Policy::Freenode::Wantarray' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators' => 0,
- 'Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint' => 14,
- 'Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms' => 0,
- 'Perl::Critic::Policy::Modules::RequireExplicitPackage' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitReusedNames' => 30,
+ 'Perl::Critic::Policy::Freenode::Prototypes' => 5,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls' => 1,
+ 'Perl::Critic::Policy::Variables::ProtectPrivateVars' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap' => 4,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions' => 1,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames' => 0,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA' => 7,
+ 'Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen' => 0,
+ 'Perl::Critic::Policy::Variables::RequireLexicalLoopIterators' => 6,
+ 'Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes' => 8,
+ 'Perl::Critic::Policy::Freenode::OverloadOptions' => 1,
+ 'Perl::Critic::Policy::CodeLayout::RequireTrailingCommas' => 28,
+ 'Perl::Critic::Policy::Documentation::PodSpelling' => 81,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings' => 9,
+ 'Perl::Critic::Policy::Freenode::Wantarray' => 17,
+ 'Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators' => 1,
+ 'Perl::Critic::Policy::Freenode::ArrayAssignAref' => 0,
+ 'Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval' => 45,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit' => 28,
+ 'Perl::Critic::Policy::Modules::RequireBarewordIncludes' => 2,
+ 'Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitUnusedVariables' => 6,
+ 'Perl::Critic::Policy::Freenode::POSIXImports' => 0,
+ 'Perl::Critic::Policy::Freenode::DiscouragedModules' => 7,
+ 'Perl::Critic::Policy::Freenode::PreferredAlternatives' => 30,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic' => 14,
+ 'Perl::Critic::Policy::Freenode::MultidimensionalArrayEmulation' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep' => 1,
+ 'Perl::Critic::Policy::Freenode::AmpersandSubCalls' => 0,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation' => 10,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches' => 36
+ },
+ {
+ 'Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode' => 0,
'Perl::Critic::Policy::CodeLayout::ProhibitHardTabs' => 0,
+ 'Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName' => 15,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros' => 24,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion' => 0,
+ 'Perl::Critic::Policy::Modules::ProhibitAutomaticExportation' => 19,
+ 'Perl::Critic::Policy::Freenode::OpenArgs' => 0,
+ 'Perl::Critic::Policy::InputOutput::RequireBriefOpen' => 19,
+ 'Perl::Critic::Policy::Subroutines::ProhibitNestedSubs' => 1,
+ 'Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations' => 6,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists' => 22,
+ 'Perl::Critic::Policy::Freenode::DeprecatedFeatures' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::Freenode::ModPerl' => 0,
+ 'Perl::Critic::Policy::Variables::RequireNegativeIndices' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings' => 11,
+ 'Perl::Critic::Policy::Variables::ProhibitMatchVars' => 0,
'Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr' => 0,
- 'Perl::Critic::Policy::Freenode::OverloadOptions' => 0,
+ 'Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish' => 1,
+ 'Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils' => 14,
+ 'Perl::Critic::Policy::Subroutines::ProhibitManyArgs' => 7,
+ 'Perl::Critic::Policy::Modules::RequireEndWithOne' => 13,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions' => 20,
+ 'Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars' => 6,
'Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros' => 0,
- 'Perl::Critic::Policy::CodeLayout::RequireTrailingCommas' => 2,
- 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect' => 0,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters' => 3,
- 'Perl::Critic::Policy::NamingConventions::Capitalization' => 0,
- 'Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish' => 0,
- 'Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration' => 1,
+ 'Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity' => 2,
+ 'Perl::Critic::Policy::Subroutines::ProtectPrivateSubs' => 43,
+ 'Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer' => 10,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins' => 1264,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms' => 11,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses' => 40,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator' => 16,
+ 'Perl::Critic::Policy::Freenode::Each' => 17,
+ 'Perl::Critic::Policy::Modules::RequireExplicitPackage' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators' => 0,
+ 'Perl::Critic::Policy::Freenode::ConditionalImplicitReturn' => 5,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls' => 51,
+ 'Perl::Critic::Policy::Freenode::StrictWarnings' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock' => 5,
+ 'Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect' => 2,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict' => 0,
+ 'Perl::Critic::Policy::Variables::RequireInitializationForLocalVars' => 8,
+ 'Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop' => 3,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters' => 0,
+ 'Perl::Critic::Policy::Freenode::EmptyReturn' => 53,
+ 'Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage' => 0,
+ 'Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline' => 10,
+ 'Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines' => 56,
+ 'Perl::Critic::Policy::Freenode::LexicalForeachIterator' => 0,
+ 'Perl::Critic::Policy::Freenode::WarningsSwitch' => 0,
+ 'Perl::Critic::Policy::Freenode::ConditionalDeclarations' => 0,
+ 'Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames' => 10,
'Perl::Critic::Policy::Miscellanea::ProhibitFormats' => 0,
- 'Perl::Critic::Policy::Variables::RequireInitializationForLocalVars' => 0,
- 'Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins' => 77,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep' => 4,
+ 'Perl::Critic::Policy::Modules::ProhibitEvilModules' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars' => 15,
+ 'Perl::Critic::Policy::NamingConventions::Capitalization' => 129,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters' => 48,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators' => 67,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture' => 9,
+ 'Perl::Critic::Policy::Freenode::DollarAB' => 10,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep' => 100,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading' => 2,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops' => 9,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict' => 2,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators' => 34,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedClose' => 23,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock' => 0,
+ 'Perl::Critic::Policy::Documentation::RequirePodAtEnd' => 17,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect' => 0,
+ 'Perl::Critic::Policy::Freenode::WhileDiamondDefaultAssignment' => 6,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest' => 29,
+ 'Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion' => 0,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings' => 0,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep' => 112,
+ 'Perl::Critic::Policy::Objects::ProhibitIndirectSyntax' => 334,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitPunctuationVars' => 41,
+ 'Perl::Critic::Policy::Subroutines::RequireArgUnpacking' => 521,
+ 'Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles' => 13,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace' => 0,
+ 'Perl::Critic::Policy::Freenode::LoopOnHash' => 0,
+ 'Perl::Critic::Policy::Freenode::IndirectObjectNotation' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa' => 0,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks' => 1,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator' => 0,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitTies' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap' => 21,
+ 'Perl::Critic::Policy::Subroutines::ProhibitReturnSort' => 2,
+ 'Perl::Critic::Policy::Freenode::BarewordFilehandles' => 10,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements' => 1,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedOpen' => 4,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval' => 10,
+ 'Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitDeepNests' => 6,
+ 'Perl::Critic::Policy::Modules::ProhibitMultiplePackages' => 7,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters' => 268,
+ 'Perl::Critic::Policy::Freenode::Threads' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters' => 2,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic' => 14,
+ 'Perl::Critic::Policy::Freenode::MultidimensionalArrayEmulation' => 0,
+ 'Perl::Critic::Policy::Freenode::DiscouragedModules' => 7,
+ 'Perl::Critic::Policy::Freenode::PreferredAlternatives' => 30,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches' => 36,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep' => 1,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation' => 10,
'Perl::Critic::Policy::Freenode::AmpersandSubCalls' => 0,
- 'Perl::Critic::Policy::Modules::RequireEndWithOne' => 0,
- 'Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen' => 2,
- 'Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion' => 0,
- 'Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls' => 4,
- 'Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars' => 0,
- 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks' => 0,
'Perl::Critic::Policy::Freenode::ArrayAssignAref' => 0,
- 'Perl::Critic::Policy::Freenode::ConditionalDeclarations' => 0,
- 'Perl::Critic::Policy::Objects::ProhibitIndirectSyntax' => 22,
+ 'Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval' => 45,
+ 'Perl::Critic::Policy::Freenode::Wantarray' => 17,
+ 'Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators' => 1,
+ 'Perl::Critic::Policy::Variables::ProhibitUnusedVariables' => 6,
'Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction' => 0,
- 'Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels' => 0,
- 'Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA' => 0,
- 'Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity' => 7,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters' => 1,
- 'Perl::Critic::Policy::Freenode::WarningsSwitch' => 19,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest' => 0,
- 'Perl::Critic::Policy::Variables::ProhibitPunctuationVars' => 14,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches' => 1,
- 'Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless' => 0,
+ 'Perl::Critic::Policy::Freenode::POSIXImports' => 0,
+ 'Perl::Critic::Policy::Modules::RequireBarewordIncludes' => 2,
+ 'Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit' => 28,
+ 'Perl::Critic::Policy::Variables::RequireLexicalLoopIterators' => 6,
+ 'Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes' => 8,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames' => 0,
+ 'Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen' => 0,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA' => 7,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings' => 9,
+ 'Perl::Critic::Policy::CodeLayout::RequireTrailingCommas' => 28,
+ 'Perl::Critic::Policy::Freenode::OverloadOptions' => 1,
+ 'Perl::Critic::Policy::Documentation::PodSpelling' => 81,
+ 'Perl::Critic::Policy::Variables::ProhibitReusedNames' => 30,
+ 'Perl::Critic::Policy::Freenode::Prototypes' => 5,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap' => 4,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions' => 1,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls' => 1,
+ 'Perl::Critic::Policy::Variables::ProtectPrivateVars' => 0
+ },
+ {
+ 'Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks' => 1,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitTies' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitReturnSort' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap' => 21,
+ 'Perl::Critic::Policy::Freenode::LoopOnHash' => 0,
+ 'Perl::Critic::Policy::Freenode::IndirectObjectNotation' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa' => 0,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic' => 0,
+ 'Perl::Critic::Policy::Modules::ProhibitMultiplePackages' => 7,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters' => 268,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters' => 2,
+ 'Perl::Critic::Policy::Freenode::Threads' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements' => 1,
+ 'Perl::Critic::Policy::Freenode::BarewordFilehandles' => 10,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval' => 10,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedOpen' => 4,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitDeepNests' => 6,
+ 'Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline' => 0,
+ 'Perl::Critic::Policy::Freenode::WhileDiamondDefaultAssignment' => 6,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest' => 29,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict' => 2,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops' => 9,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators' => 34,
+ 'Perl::Critic::Policy::Documentation::RequirePodAtEnd' => 17,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedClose' => 23,
'Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock' => 0,
- 'Perl::Critic::Policy::InputOutput::RequireCheckedOpen' => 0,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters' => 1,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators' => 0,
- 'Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration' => 1,
- 'Perl::Critic::Policy::Freenode::DiscouragedModules' => 5,
- 'Perl::Critic::Policy::Subroutines::ProtectPrivateSubs' => 1,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitPunctuationVars' => 41,
+ 'Perl::Critic::Policy::Subroutines::RequireArgUnpacking' => 521,
+ 'Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles' => 13,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace' => 0,
+ 'Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines' => 0,
'Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator' => 0,
- 'Perl::Critic::Policy::Modules::ProhibitMultiplePackages' => 0,
- 'Perl::Critic::Policy::Variables::ProhibitMatchVars' => 0,
- 'Perl::Critic::Policy::Variables::RequireLexicalLoopIterators' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap' => 0,
- 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines' => 55,
- 'Perl::Critic::Policy::Modules::RequireBarewordIncludes' => 0,
- 'Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles' => 2,
- 'Perl::Critic::Policy::InputOutput::RequireCheckedClose' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitDeepNests' => 0,
- 'Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops' => 2,
- 'Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop' => 0,
- 'Perl::Critic::Policy::Freenode::WhileDiamondDefaultAssignment' => 0,
- 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture' => 0,
- 'Perl::Critic::Policy::Modules::ProhibitAutomaticExportation' => 0,
- 'Perl::Critic::Policy::Subroutines::RequireArgUnpacking' => 0,
- 'Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline' => 0,
- 'Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines' => 0,
- 'Perl::Critic::Policy::Documentation::RequirePodAtEnd' => 4,
- 'Perl::Critic::Policy::Freenode::StrictWarnings' => 0,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless' => 0,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings' => 0,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep' => 112,
+ 'Perl::Critic::Policy::Objects::ProhibitIndirectSyntax' => 334,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings' => 9,
+ 'Perl::Critic::Policy::Freenode::OverloadOptions' => 1,
+ 'Perl::Critic::Policy::CodeLayout::RequireTrailingCommas' => 28,
+ 'Perl::Critic::Policy::Documentation::PodSpelling' => 81,
+ 'Perl::Critic::Policy::Variables::RequireLexicalLoopIterators' => 6,
+ 'Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes' => 8,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames' => 0,
+ 'Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen' => 0,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA' => 7,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap' => 4,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions' => 1,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls' => 1,
'Perl::Critic::Policy::Variables::ProtectPrivateVars' => 0,
- 'Perl::Critic::Policy::Freenode::DeprecatedFeatures' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep' => 6,
+ 'Perl::Critic::Policy::Variables::ProhibitReusedNames' => 30,
'Perl::Critic::Policy::Freenode::Prototypes' => 5,
- 'Perl::Critic::Policy::Freenode::ConditionalImplicitReturn' => 0,
- 'Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock' => 0,
- 'Perl::Critic::Policy::Freenode::EmptyReturn' => 0,
- 'Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading' => 0,
- 'Perl::Critic::Policy::Freenode::Threads' => 0,
- 'Perl::Critic::Policy::Freenode::BarewordFilehandles' => 2,
- 'Perl::Critic::Policy::Subroutines::ProhibitReturnSort' => 0,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic' => 0,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches' => 36,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep' => 1,
+ 'Perl::Critic::Policy::Freenode::AmpersandSubCalls' => 0,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation' => 10,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic' => 14,
+ 'Perl::Critic::Policy::Freenode::MultidimensionalArrayEmulation' => 0,
+ 'Perl::Critic::Policy::Freenode::DiscouragedModules' => 7,
+ 'Perl::Critic::Policy::Freenode::PreferredAlternatives' => 30,
+ 'Perl::Critic::Policy::Variables::ProhibitUnusedVariables' => 6,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction' => 0,
+ 'Perl::Critic::Policy::Freenode::POSIXImports' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit' => 28,
+ 'Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements' => 0,
+ 'Perl::Critic::Policy::Modules::RequireBarewordIncludes' => 2,
+ 'Perl::Critic::Policy::Freenode::ArrayAssignAref' => 0,
+ 'Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval' => 45,
+ 'Perl::Critic::Policy::Freenode::Wantarray' => 17,
+ 'Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators' => 1,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils' => 14,
+ 'Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish' => 1,
+ 'Perl::Critic::Policy::Variables::ProhibitMatchVars' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitManyArgs' => 7,
+ 'Perl::Critic::Policy::Modules::RequireEndWithOne' => 13,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions' => 20,
+ 'Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars' => 6,
+ 'Perl::Critic::Policy::Variables::RequireNegativeIndices' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings' => 11,
+ 'Perl::Critic::Policy::Freenode::ModPerl' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan' => 0,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins' => 1264,
+ 'Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms' => 11,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses' => 40,
+ 'Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration' => 1,
+ 'Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity' => 2,
+ 'Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride' => 0,
+ 'Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer' => 10,
+ 'Perl::Critic::Policy::Subroutines::ProtectPrivateSubs' => 43,
+ 'Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName' => 15,
+ 'Perl::Critic::Policy::Modules::ProhibitAutomaticExportation' => 19,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros' => 24,
+ 'Perl::Critic::Policy::InputOutput::RequireBriefOpen' => 19,
+ 'Perl::Critic::Policy::Freenode::OpenArgs' => 0,
+ 'Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames' => 0,
+ 'Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode' => 0,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitHardTabs' => 0,
+ 'Perl::Critic::Policy::Subroutines::ProhibitNestedSubs' => 1,
+ 'Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations' => 6,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator' => 0,
+ 'Perl::Critic::Policy::Freenode::DeprecatedFeatures' => 0,
+ 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists' => 22,
+ 'Perl::Critic::Policy::Modules::ProhibitEvilModules' => 0,
+ 'Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames' => 10,
+ 'Perl::Critic::Policy::Miscellanea::ProhibitFormats' => 0,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars' => 15,
+ 'Perl::Critic::Policy::NamingConventions::Capitalization' => 129,
+ 'Perl::Critic::Policy::Freenode::LexicalForeachIterator' => 0,
+ 'Perl::Critic::Policy::Freenode::WarningsSwitch' => 0,
+ 'Perl::Critic::Policy::Freenode::ConditionalDeclarations' => 0,
+ 'Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep' => 100,
+ 'Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading' => 2,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators' => 67,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters' => 48,
+ 'Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture' => 9,
+ 'Perl::Critic::Policy::Freenode::DollarAB' => 10,
+ 'Perl::Critic::Policy::Freenode::StrictWarnings' => 0,
+ 'Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls' => 51,
+ 'Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect' => 2,
+ 'Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock' => 5,
+ 'Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict' => 0,
+ 'Perl::Critic::Policy::Variables::RequireInitializationForLocalVars' => 8,
+ 'Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator' => 16,
+ 'Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators' => 0,
+ 'Perl::Critic::Policy::Modules::RequireExplicitPackage' => 0,
+ 'Perl::Critic::Policy::Freenode::Each' => 17,
+ 'Perl::Critic::Policy::Freenode::ConditionalImplicitReturn' => 5,
'Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters' => 0,
- 'Perl::Critic::Policy::Variables::RequireNegativeIndices' => 0,
- 'Perl::Critic::Policy::InputOutput::RequireBriefOpen' => 4,
+ 'Perl::Critic::Policy::Freenode::EmptyReturn' => 53,
+ 'Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage' => 0,
+ 'Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline' => 10,
+ 'Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines' => 56,
+ 'Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop' => 3
}
];
+++ /dev/null
-# This Source Code Form is subject to the terms of the Mozilla Public
-# License, v. 2.0. If a copy of the MPL was not distributed with this
-# file, You can obtain one at http://mozilla.org/MPL/2.0/.
-#
-# This Source Code Form is "Incompatible With Secondary Licenses", as
-# defined by the Mozilla Public License, v. 2.0.
-
-
-#################
-#Bugzilla Test 1#
-###Compilation###
-
-use 5.10.1;
-use strict;
-use warnings;
-
-use lib qw(. lib local/lib/perl5 t);
-use Config;
-use Support::Files;
-use Test::More;
-
-BEGIN {
- if ($ENV{CI}) {
- plan skip_all => 'Not running compile tests in CI.';
- exit;
- }
- plan tests => @Support::Files::testitems + @Support::Files::test_files;
-
- use_ok('Bugzilla::Constants');
- use_ok('Bugzilla::Install::Requirements');
- use_ok('Bugzilla');
-}
-Bugzilla->usage_mode(USAGE_MODE_TEST);
-
-sub compile_file {
- my ($file) = @_;
-
- # Don't allow CPAN.pm to modify the global @INC, which the version
- # shipped with Perl 5.8.8 does. (It gets loaded by
- # Bugzilla::Install::CPAN.)
- local @INC = @INC;
-
- if ($file =~ /extensions/) {
- skip "$file: extensions not tested", 1;
- return;
- }
-
- if ($file =~ s/\.pm$//) {
- $file =~ s{/}{::}g;
- use_ok($file);
- return;
- }
-
- open(my $fh, $file);
- my $bang = <$fh>;
- close $fh;
-
- my $T = "";
- if ($bang =~ m/#!\S*perl\s+-.*T/) {
- $T = "T";
- }
-
- my $libs = '-It ';
- if ($ENV{PERL5LIB}) {
- $libs .= join " ", map {"-I\"$_\""} split /$Config{path_sep}/, $ENV{PERL5LIB};
- }
- my $perl = qq{"$^X"};
- my $output = `$perl $libs -c$T -MSupport::Systemexec $file 2>&1`;
- chomp($output);
- my $return_val = $?;
- $output =~ s/^\Q$file\E syntax OK$//ms;
- diag($output) if $output;
- ok(!$return_val, $file) or diag('--ERROR');
-}
-
-my @testitems = (@Support::Files::testitems, @Support::Files::test_files);
-my $file_features = map_files_to_features();
-
-# Test the scripts by compiling them
-foreach my $file (@testitems) {
-
- # These were already compiled, above.
- next
- if ($file eq 'Bugzilla.pm'
- or $file eq 'Bugzilla/Constants.pm'
- or $file eq 'Bugzilla/Install/Requirements.pm');
-SKIP: {
- if ($file eq 'mod_perl.pl') {
- skip 'mod_perl.pl cannot be compiled from the command line', 1;
- }
- my $feature = $file_features->{$file};
- if ($feature and !Bugzilla->feature($feature)) {
- skip "$file: $feature not enabled", 1;
- }
-
- # Check that we have a DBI module to support the DB, if this
- # is a database module (but not Schema)
- if ($file =~ m{Bugzilla/DB/([^/]+)\.pm$} and $file ne "Bugzilla/DB/Schema.pm") {
- my $module = lc($1);
- Bugzilla->feature($module) or skip "$file: Driver for $module not installed", 1;
- }
-
- compile_file($file);
- }
-}
$used =~ s#/#::#g;
$used =~ s#\.pm$##;
$used =~ s#\$module#[^:]+#;
- $used =~ s#\${[^}]+}#[^:]+#;
+ $used =~ s#\$\{[^}]+}#[^:]+#;
$used =~ s#[" ]##g;
push(@use, grep(/^\Q$used\E$/, keys %mods));
}
use warnings;
use 5.10.1;
use lib qw( . lib local/lib/perl5 );
-use Test::More tests => 1;
+use Test::More skip_all => 'the Crypt::OpenPGP module is broken';
use Crypt::OpenPGP;
my $ok = eval { require Test::Perl::Critic::Progressive };
plan skip_all => 'T::P::C::Progressive required for this test' unless $ok;
+plan skip_all => 'Disabled until we can make this only check our code and not local-lib';
Test::Perl::Critic::Progressive::progressive_critic_ok();
use warnings;
use lib qw( . lib local/lib/perl5 );
-use Bugzilla::Test::MockDB;
use Bugzilla::Test::MockLocalconfig urlbase => 'http://bmo.test/';
+use Bugzilla::Test::MockDB;
use Bugzilla::Test::MockParams (password_complexity => 'no_constraints');
use Mojo::DOM;
use Bugzilla;
$ENV{BUGZILLA_ALLOW_INSECURE_HTTP} = 1;
}
+use CGI::Compile;
use Bugzilla::Test::MockDB;
use Bugzilla::Test::MockParams (password_complexity => 'no_constraints');
use Bugzilla::Test::Util qw(create_user create_oauth_client);
use Test2::V0;
use Test::Mojo;
+skip_all("these don't work without more scaffolding");
+
my $oauth_login = 'oauth@mozilla.bugs';
my $oauth_password = 'password123456789!';
my $referer = Bugzilla->localconfig->urlbase;
[%# Use the current script name. If an empty name is returned,
# then we are accessing the home page. %]
-<li id="mini_signup_container[% qs_suffix %]">
- <a id="signup_link[% qs_suffix %]" href="#"
+<li id="mini_signup_container[% qs_suffix FILTER html %]">
+ <a id="signup_link[% qs_suffix FILTER html %]" href="#"
class='show_mini_signup_form' data-qs-suffix="[% qs_suffix FILTER html %]">Sign Up</a>
<div id="mini_signup[% qs_suffix FILTER html %]" class="mini-popup mini_signup bz_default_hidden">
required
>
<input type="hidden" name="csrf_token"
- value="[% c.csrf_token %]">
+ value="[% c.csrf_token FILTER html %]">
<input type="submit" value="Sign up"
class="check_mini_signup_fields"
- id="signup_[% qs_suffix %]">
+ id="signup_[% qs_suffix FILTER html %]">
<a href="#" id="hide_mini_signup[% qs_suffix FILTER html %]" aria-label="Close"
class="close-button hide_mini_signup_form" data-qs-suffix="[% qs_suffix FILTER html %]">
<span class="icon" aria-hidden="true"></span>
[% PROCESS global/variables.none.tmpl %]
From: [% Param('mailfrom') %]
-To: [% email %]
+To: [% email FILTER none %]
Subject: [% terms.Bugzilla %]: complete account signup
X-Bugzilla-Type: admin
[%+ terms.Bugzilla %] has received a request to create a user account
-using your email address ([% email %]).
+using your email address ([% email FILTER none %]).
To continue creating an account using this email address, visit the
following link by [% expiration_ts FILTER time("%B %e, %Y at %H:%M %Z") %]:
-[%+ verify_url %]
+[%+ verify_url FILTER none %]
[% IF Param('createemailregexp') == '.*' && Param('emailsuffix') == '' %]
PRIVACY NOTICE: [% terms.Bugzilla %] is an open [% terms.bug %] tracking system. Activity on most
%]
[% IF signup_token %]
- <form class="signup" method="post" action="[% c.url_for('signup_email_finish') %]">
+ <form class="signup" method="post" action="[% c.url_for('signup_email_finish') FILTER html %]">
<p class="notes">
This account will not be created if this form is not completed by
<u>[% expires FILTER time("%B %e, %Y at %H:%M %Z") %]</u>.
</div>
</form>
[% ELSE %]
- <form class="fresh-signup" method="post" action="[% c.url_for('signup_email') %]">
+ <form class="fresh-signup" method="post" action="[% c.url_for('signup_email') FILTER html %]">
<p class="notes">
It seems we can't verify your email address because the signup token is expired.
Fill in the email below and we'll try this again.
</p>
- <input type="hidden" name="csrf_token" value="[% c.csrf_token %]">
+ <input type="hidden" name="csrf_token" value="[% c.csrf_token FILTER html %]">
<input type="text" placeholder="Email Address" id="email">
<button type="submit" id="confirm" name="submit" value="create">Sign up</button>
</form>
projects / thirdparty / bugzilla.git / commitdiff
