diff --git a/.github/cpm/bin/cpm b/.github/cpm/bin/cpm deleted file mode 100755 index f13f468b58..0000000000 --- a/.github/cpm/bin/cpm +++ /dev/null @@ -1,122 +0,0 @@ -#!/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 Eskaji@cpan.orgE - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/.github/cpm/lib/perl5/App/cpm.pm b/.github/cpm/lib/perl5/App/cpm.pm deleted file mode 100644 index bb4bcc204d..0000000000 --- a/.github/cpm/lib/perl5/App/cpm.pm +++ /dev/null @@ -1,110 +0,0 @@ -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 -demo - -cpm is a fast CPAN module installer, which uses L 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. - -For tutorial, check out L. - -=head1 MOTIVATION - -Why do we need a new CPAN client? - -I used L 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 reported that -the parallel feature of cpm yielded a new type of failure for CPAN module installation. -That is, -if B implicitly requires B in configure/build phase, -and B is about to be installed, -then it may happen that the installation of B 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, -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 Eskaji@cpan.orgE - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 SEE ALSO - -L - -L - -L - -L - -L - -=cut diff --git a/.github/cpm/lib/perl5/App/cpm/CLI.pm b/.github/cpm/lib/perl5/App/cpm/CLI.pm deleted file mode 100644 index 565063d0ff..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/CLI.pm +++ /dev/null @@ -1,596 +0,0 @@ -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 = ) { - 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; diff --git a/.github/cpm/lib/perl5/App/cpm/CircularDependency.pm b/.github/cpm/lib/perl5/App/cpm/CircularDependency.pm deleted file mode 100644 index 6682f9f111..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/CircularDependency.pm +++ /dev/null @@ -1,102 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/DistNotation.pm b/.github/cpm/lib/perl5/App/cpm/DistNotation.pm deleted file mode 100644 index 1182f907c6..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/DistNotation.pm +++ /dev/null @@ -1,55 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Distribution.pm b/.github/cpm/lib/perl5/App/cpm/Distribution.pm deleted file mode 100644 index 24347cd2d0..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Distribution.pm +++ /dev/null @@ -1,165 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/HTTP.pm b/.github/cpm/lib/perl5/App/cpm/HTTP.pm deleted file mode 100644 index ae37036f55..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/HTTP.pm +++ /dev/null @@ -1,38 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Installer/Unpacker.pm b/.github/cpm/lib/perl5/App/cpm/Installer/Unpacker.pm deleted file mode 100644 index 6b452eaf27..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Installer/Unpacker.pm +++ /dev/null @@ -1,218 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Job.pm b/.github/cpm/lib/perl5/App/cpm/Job.pm deleted file mode 100644 index 4e045bb405..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Job.pm +++ /dev/null @@ -1,84 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Logger.pm b/.github/cpm/lib/perl5/App/cpm/Logger.pm deleted file mode 100644 index c2c55a7349..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Logger.pm +++ /dev/null @@ -1,63 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Logger/File.pm b/.github/cpm/lib/perl5/App/cpm/Logger/File.pm deleted file mode 100644 index 0b6ae2b0f4..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Logger/File.pm +++ /dev/null @@ -1,67 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Master.pm b/.github/cpm/lib/perl5/App/cpm/Master.pm deleted file mode 100644 index 0c277ba840..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Master.pm +++ /dev/null @@ -1,501 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Requirement.pm b/.github/cpm/lib/perl5/App/cpm/Requirement.pm deleted file mode 100644 index 0ab3a676eb..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Requirement.pm +++ /dev/null @@ -1,71 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver.pm b/.github/cpm/lib/perl5/App/cpm/Resolver.pm deleted file mode 100644 index 4b03ad7de3..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver.pm +++ /dev/null @@ -1,5 +0,0 @@ -package App::cpm::Resolver; -use strict; -use warnings; - -1; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver/02Packages.pm b/.github/cpm/lib/perl5/App/cpm/Resolver/02Packages.pm deleted file mode 100644 index 8e3ac9d20e..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver/02Packages.pm +++ /dev/null @@ -1,126 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver/CPANfile.pm b/.github/cpm/lib/perl5/App/cpm/Resolver/CPANfile.pm deleted file mode 100644 index a517a85577..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver/CPANfile.pm +++ /dev/null @@ -1,83 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver/Cascade.pm b/.github/cpm/lib/perl5/App/cpm/Resolver/Cascade.pm deleted file mode 100644 index 7cc68d0804..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver/Cascade.pm +++ /dev/null @@ -1,37 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver/MetaCPAN.pm b/.github/cpm/lib/perl5/App/cpm/Resolver/MetaCPAN.pm deleted file mode 100644 index cd2770f610..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver/MetaCPAN.pm +++ /dev/null @@ -1,57 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver/MetaDB.pm b/.github/cpm/lib/perl5/App/cpm/Resolver/MetaDB.pm deleted file mode 100644 index c0a51ba183..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver/MetaDB.pm +++ /dev/null @@ -1,115 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Resolver/Snapshot.pm b/.github/cpm/lib/perl5/App/cpm/Resolver/Snapshot.pm deleted file mode 100644 index 9f6a7e2213..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Resolver/Snapshot.pm +++ /dev/null @@ -1,55 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Tutorial.pm b/.github/cpm/lib/perl5/App/cpm/Tutorial.pm deleted file mode 100644 index a958454244..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Tutorial.pm +++ /dev/null @@ -1,152 +0,0 @@ -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, L, and L), -which is fast! - -=head2 How to install cpm - -From CPAN: - - $ cpanm -nq App::cpm - -Or, download a I 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 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. 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 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, -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 -(minicpan, CPAN mirror) such as L, L, L. - -Such darkpans store distribution tarballs in - - DARKPAN/authors/id/A/AU/AUTHOR/Module-0.01.tar.gz - -and create the I 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 diff --git a/.github/cpm/lib/perl5/App/cpm/Util.pm b/.github/cpm/lib/perl5/App/cpm/Util.pm deleted file mode 100644 index fae016e624..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Util.pm +++ /dev/null @@ -1,44 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Worker.pm b/.github/cpm/lib/perl5/App/cpm/Worker.pm deleted file mode 100644 index 65ae039f8e..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Worker.pm +++ /dev/null @@ -1,66 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Worker/Installer.pm b/.github/cpm/lib/perl5/App/cpm/Worker/Installer.pm deleted file mode 100644 index bff5e20fcf..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Worker/Installer.pm +++ /dev/null @@ -1,524 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Worker/Installer/Menlo.pm b/.github/cpm/lib/perl5/App/cpm/Worker/Installer/Menlo.pm deleted file mode 100644 index 95880a324b..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Worker/Installer/Menlo.pm +++ /dev/null @@ -1,83 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Worker/Installer/Prebuilt.pm b/.github/cpm/lib/perl5/App/cpm/Worker/Installer/Prebuilt.pm deleted file mode 100644 index 6ecba2c278..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Worker/Installer/Prebuilt.pm +++ /dev/null @@ -1,19 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/Worker/Resolver.pm b/.github/cpm/lib/perl5/App/cpm/Worker/Resolver.pm deleted file mode 100644 index e8ca53fae8..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/Worker/Resolver.pm +++ /dev/null @@ -1,31 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/App/cpm/version.pm b/.github/cpm/lib/perl5/App/cpm/version.pm deleted file mode 100644 index 1ff04ebac5..0000000000 --- a/.github/cpm/lib/perl5/App/cpm/version.pm +++ /dev/null @@ -1,41 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/CPAN/Common/Index.pm b/.github/cpm/lib/perl5/CPAN/Common/Index.pm deleted file mode 100644 index 4e046f4dbe..0000000000 --- a/.github/cpm/lib/perl5/CPAN/Common/Index.pm +++ /dev/null @@ -1,373 +0,0 @@ -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 field should be a valid URI. It may be a L 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 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 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 field should be a valid URI. It may be a L 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 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. -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 - - git clone https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index.git - -=head1 AUTHOR - -David Golden - -=head1 CONTRIBUTORS - -=for stopwords David Golden Helmut Wollmersdorfer Kenichi Ishigaki Shoichi Kaji Tatsuhiko Miyagawa - -=over 4 - -=item * - -David Golden - -=item * - -Helmut Wollmersdorfer - -=item * - -Kenichi Ishigaki - -=item * - -Shoichi Kaji - -=item * - -Tatsuhiko Miyagawa - -=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 diff --git a/.github/cpm/lib/perl5/CPAN/Common/Index/LocalPackage.pm b/.github/cpm/lib/perl5/CPAN/Common/Index/LocalPackage.pm deleted file mode 100644 index b082095950..0000000000 --- a/.github/cpm/lib/perl5/CPAN/Common/Index/LocalPackage.pm +++ /dev/null @@ -1,145 +0,0 @@ -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 - -=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 diff --git a/.github/cpm/lib/perl5/CPAN/Common/Index/MetaDB.pm b/.github/cpm/lib/perl5/CPAN/Common/Index/MetaDB.pm deleted file mode 100644 index f662f7b52d..0000000000 --- a/.github/cpm/lib/perl5/CPAN/Common/Index/MetaDB.pm +++ /dev/null @@ -1,123 +0,0 @@ -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. -#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. - -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. - -=for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD - -=head1 AUTHOR - -David Golden - -=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 diff --git a/.github/cpm/lib/perl5/CPAN/Common/Index/Mirror.pm b/.github/cpm/lib/perl5/CPAN/Common/Index/Mirror.pm deleted file mode 100644 index 637ea048ac..0000000000 --- a/.github/cpm/lib/perl5/CPAN/Common/Index/Mirror.pm +++ /dev/null @@ -1,334 +0,0 @@ -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. -#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. 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. - -=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 - -=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 diff --git a/.github/cpm/lib/perl5/CPAN/Common/Index/Mux/Ordered.pm b/.github/cpm/lib/perl5/CPAN/Common/Index/Mux/Ordered.pm deleted file mode 100644 index d6a0a080e8..0000000000 --- a/.github/cpm/lib/perl5/CPAN/Common/Index/Mux/Ordered.pm +++ /dev/null @@ -1,204 +0,0 @@ -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 - -=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 diff --git a/.github/cpm/lib/perl5/CPAN/DistnameInfo.pm b/.github/cpm/lib/perl5/CPAN/DistnameInfo.pm deleted file mode 100644 index 5e05ca9960..0000000000 --- a/.github/cpm/lib/perl5/CPAN/DistnameInfo.pm +++ /dev/null @@ -1,205 +0,0 @@ - -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(?=-) - )(? 6 and $1 & 1) or ($2 and $2 >= 50)) or $3; - } - elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) { - $dev = 1; - } - } - else { - $version = undef; - } - - ($dist, $version, $dev); -} - -sub new { - my $class = shift; - my $distfile = shift; - - $distfile =~ s,//+,/,g; - - my %info = ( pathname => $distfile ); - - ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, - and $info{cpanid} = $6; - - if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ? - $info{distvname} = $1; - $info{extension} = $2; - } - - @info{qw(dist version beta)} = distname_info($info{distvname}); - $info{maturity} = delete $info{beta} ? 'developer' : 'released'; - - return bless \%info, $class; -} - -sub dist { shift->{dist} } -sub version { shift->{version} } -sub maturity { shift->{maturity} } -sub filename { shift->{filename} } -sub cpanid { shift->{cpanid} } -sub distvname { shift->{distvname} } -sub extension { shift->{extension} } -sub pathname { shift->{pathname} } - -sub properties { %{ $_[0] } } - -1; - -__END__ - -=head1 NAME - -CPAN::DistnameInfo - Extract distribution name and version from a distribution filename - -=head1 SYNOPSIS - - my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz"; - - my $d = CPAN::DistnameInfo->new($pathname); - - my $dist = $d->dist; # "CPAN-DistnameInfo" - my $version = $d->version; # "0.02" - my $maturity = $d->maturity; # "released" - my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" - my $cpanid = $d->cpanid; # "GBARR" - my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" - my $extension = $d->extension; # "tar.gz" - my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..." - - my %prop = $d->properties; - -=head1 DESCRIPTION - -Many online services that are centered around CPAN attempt to -associate multiple uploads by extracting a distribution name from -the filename of the upload. For most distributions this is easy as -they have used ExtUtils::MakeMaker or Module::Build to create the -distribution, which results in a uniform name. But sadly not all -uploads are created in this way. - -C uses heuristics that have been learnt by -L to extract the distribution name and -version from filenames and also report if the version is to be -treated as a developer release - -The constructor takes a single pathname, returning an object with the following methods - -=over - -=item cpanid - -If the path given looked like a CPAN authors directory path, then this will be the -the CPAN id of the author. - -=item dist - -The name of the distribution - -=item distvname - -The file name with any suffix and leading directory names removed - -=item filename - -If the path given looked like a CPAN authors directory path, then this will be the -path to the file relative to the detected CPAN author directory. Otherwise it is the path -that was passed in. - -=item maturity - -The maturity of the distribution. This will be either C or C - -=item extension - -The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz') - -=item pathname - -The pathname that was passed to the constructor when creating the object. - -=item properties - -This will return a list of key-value pairs, suitable for assigning to a hash, -for the known properties. - -=item version - -The extracted version - -=back - -=head1 AUTHOR - -Graham Barr - -=head1 COPYRIGHT - -Copyright (c) 2003 Graham Barr. All rights reserved. This program is -free software; you can redistribute it and/or modify it under the same -terms as Perl itself. - -=cut - diff --git a/.github/cpm/lib/perl5/CPAN/Meta/Check.pm b/.github/cpm/lib/perl5/CPAN/Meta/Check.pm deleted file mode 100644 index b9a3c91603..0000000000 --- a/.github/cpm/lib/perl5/CPAN/Meta/Check.pm +++ /dev/null @@ -1,132 +0,0 @@ -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 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 or L 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 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. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L or L object. - -=head1 SEE ALSO - -=over 4 - -=item * L - -=item * L - -=for comment # vi:noet:sts=2:sw=2:ts=2 - -=back - -=head1 AUTHOR - -Leon Timmermans - -=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 diff --git a/.github/cpm/lib/perl5/Capture/Tiny.pm b/.github/cpm/lib/perl5/Capture/Tiny.pm deleted file mode 100644 index 2a5af95d40..0000000000 --- a/.github/cpm/lib/perl5/Capture/Tiny.pm +++ /dev/null @@ -1,901 +0,0 @@ -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 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 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 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 function works just like C except only -STDOUT is captured. STDERR is not captured. - -=head2 capture_stderr - - ($stderr, @result) = capture_stderr \&code; - $stderr = capture_stderr \&code; - -The C function works just like C except only -STDERR is captured. STDOUT is not captured. - -=head2 capture_merged - - ($merged, @result) = capture_merged \&code; - $merged = capture_merged \&code; - -The C function works just like C 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 function works just like C, except that output is captured -as well as passed on to the original STDOUT and STDERR. - -When called in void context, C 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 function works just like C 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 function works just like C 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 function works just like C 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 requires fork, except on -Windows where C is used instead. Not tested on any -particularly esoteric platforms yet. See the -L -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 the call to C or C. 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 or C, then Capture::Tiny will override the output filehandle for -the duration of the C or C call and then, for C, 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 or C, then -Capture::Tiny will attempt to override the tie for the duration of the -C or C 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, 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 C or C 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. 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 environment variable. Setting it to zero will -disable timeouts. B, 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, which provides -similar functionality without the ability to tee output and with more -complicated code and API. L does not handle layers -or most of the unusual cases described in the L 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 - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=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. -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 - - git clone https://github.com/dagolden/Capture-Tiny.git - -=head1 AUTHOR - -David Golden - -=head1 CONTRIBUTORS - -=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson - -=over 4 - -=item * - -Dagfinn Ilmari Mannsåker - -=item * - -David E. Wheeler - -=item * - -fecundf - -=item * - -Graham Knop - -=item * - -Peter Rabbitson - -=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 diff --git a/.github/cpm/lib/perl5/Carton.pm b/.github/cpm/lib/perl5/Carton.pm deleted file mode 100644 index bb3e693e8d..0000000000 --- a/.github/cpm/lib/perl5/Carton.pm +++ /dev/null @@ -1,209 +0,0 @@ -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 command or to include the I directory -in your Perl library search path (using C, C<-I>, or -L). - -=head1 DESCRIPTION - -carton is a command line tool to track the Perl module dependencies -for your Perl application. Dependencies are declared using L -format, and the managed dependencies are tracked in a -I 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 syntax, see L documentation. - -=head1 TUTORIAL - -=head2 Initializing the environment - -carton will use the I 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 - 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 directory, and the -dependencies tree and version information are analyzed and saved into -I in your directory. - -Make sure you add I and I 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, C and C options in C. - - # 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 and -I<.carton>) and run the following command: - - > carton install --deployment - -This will look at the I and install the exact same -versions of the dependencies into I, 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 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 (which has a -L) -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 and -C<.perl-version> to lock perl versions in development. - -You can also specify the minimum perl required in C: - - 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 - -Code repository, Wiki and Issue Tracker - -=item L - -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 - -L - -L - -L - -L - -L - -L - -=cut diff --git a/.github/cpm/lib/perl5/Carton/Builder.pm b/.github/cpm/lib/perl5/Carton/Builder.pm deleted file mode 100644 index d3aa010a8c..0000000000 --- a/.github/cpm/lib/perl5/Carton/Builder.pm +++ /dev/null @@ -1,124 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/CLI.pm b/.github/cpm/lib/perl5/Carton/CLI.pm deleted file mode 100644 index ed9c71eb31..0000000000 --- a/.github/cpm/lib/perl5/Carton/CLI.pm +++ /dev/null @@ -1,405 +0,0 @@ -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(< - -where is one of: - @{[ join ", ", $self->commands ]} - -Run carton -h 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; diff --git a/.github/cpm/lib/perl5/Carton/CPANfile.pm b/.github/cpm/lib/perl5/Carton/CPANfile.pm deleted file mode 100644 index a60d6908cc..0000000000 --- a/.github/cpm/lib/perl5/Carton/CPANfile.pm +++ /dev/null @@ -1,44 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Dependency.pm b/.github/cpm/lib/perl5/Carton/Dependency.pm deleted file mode 100644 index d3e11acf09..0000000000 --- a/.github/cpm/lib/perl5/Carton/Dependency.pm +++ /dev/null @@ -1,21 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Dist.pm b/.github/cpm/lib/perl5/Carton/Dist.pm deleted file mode 100644 index 9310e7072a..0000000000 --- a/.github/cpm/lib/perl5/Carton/Dist.pm +++ /dev/null @@ -1,37 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Dist/Core.pm b/.github/cpm/lib/perl5/Carton/Dist/Core.pm deleted file mode 100644 index 760ce66fe0..0000000000 --- a/.github/cpm/lib/perl5/Carton/Dist/Core.pm +++ /dev/null @@ -1,23 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Environment.pm b/.github/cpm/lib/perl5/Carton/Environment.pm deleted file mode 100644 index 6a58944f8f..0000000000 --- a/.github/cpm/lib/perl5/Carton/Environment.pm +++ /dev/null @@ -1,100 +0,0 @@ -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; - diff --git a/.github/cpm/lib/perl5/Carton/Error.pm b/.github/cpm/lib/perl5/Carton/Error.pm deleted file mode 100644 index b469eac7f7..0000000000 --- a/.github/cpm/lib/perl5/Carton/Error.pm +++ /dev/null @@ -1,42 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Index.pm b/.github/cpm/lib/perl5/Carton/Index.pm deleted file mode 100644 index 43ab608c50..0000000000 --- a/.github/cpm/lib/perl5/Carton/Index.pm +++ /dev/null @@ -1,68 +0,0 @@ -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 <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; diff --git a/.github/cpm/lib/perl5/Carton/Mirror.pm b/.github/cpm/lib/perl5/Carton/Mirror.pm deleted file mode 100644 index 60bc937c7d..0000000000 --- a/.github/cpm/lib/perl5/Carton/Mirror.pm +++ /dev/null @@ -1,23 +0,0 @@ -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; - diff --git a/.github/cpm/lib/perl5/Carton/Package.pm b/.github/cpm/lib/perl5/Carton/Package.pm deleted file mode 100644 index 01eaa1f8d3..0000000000 --- a/.github/cpm/lib/perl5/Carton/Package.pm +++ /dev/null @@ -1,17 +0,0 @@ -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; - - diff --git a/.github/cpm/lib/perl5/Carton/Packer.pm b/.github/cpm/lib/perl5/Carton/Packer.pm deleted file mode 100644 index 056213612f..0000000000 --- a/.github/cpm/lib/perl5/Carton/Packer.pm +++ /dev/null @@ -1,109 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Snapshot.pm b/.github/cpm/lib/perl5/Carton/Snapshot.pm deleted file mode 100644 index 9e57f18f4a..0000000000 --- a/.github/cpm/lib/perl5/Carton/Snapshot.pm +++ /dev/null @@ -1,191 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Snapshot/Emitter.pm b/.github/cpm/lib/perl5/Carton/Snapshot/Emitter.pm deleted file mode 100644 index c8e9fa868b..0000000000 --- a/.github/cpm/lib/perl5/Carton/Snapshot/Emitter.pm +++ /dev/null @@ -1,32 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Snapshot/Parser.pm b/.github/cpm/lib/perl5/Carton/Snapshot/Parser.pm deleted file mode 100644 index ae34a508e1..0000000000 --- a/.github/cpm/lib/perl5/Carton/Snapshot/Parser.pm +++ /dev/null @@ -1,125 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Tree.pm b/.github/cpm/lib/perl5/Carton/Tree.pm deleted file mode 100644 index 6ce22a1aa2..0000000000 --- a/.github/cpm/lib/perl5/Carton/Tree.pm +++ /dev/null @@ -1,69 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Carton/Util.pm b/.github/cpm/lib/perl5/Carton/Util.pm deleted file mode 100644 index c1962494a9..0000000000 --- a/.github/cpm/lib/perl5/Carton/Util.pm +++ /dev/null @@ -1,31 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Class/Tiny.pm b/.github/cpm/lib/perl5/Class/Tiny.pm deleted file mode 100644 index 2df92d0c13..0000000000 --- a/.github/cpm/lib/perl5/Class/Tiny.pm +++ /dev/null @@ -1,627 +0,0 @@ -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: - - package Person; - - use Class::Tiny qw( name ); - - 1; - -In F: - - package Employee; - use parent 'Person'; - - use Class::Tiny qw( ssn ), { - timestamp => sub { time } # attribute with default - }; - - 1; - -In F: - - 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 constructor - -=item * - -C takes a hash reference or list of key/value pairs - -=item * - -C supports providing C to customize constructor options - -=item * - -C calls C for each class from parent to child - -=item * - -superclass provides a C method - -=item * - -C calls C for each class from child to parent - -=back - -Multiple-inheritance is possible, with superclass order determined via -L. - -It uses no non-core modules for any recent Perl. On Perls older than v5.10 it -requires L. On Perls older than v5.14, it requires -L. - -=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 already inherit from some class, then -Class::Tiny::Object will be added to your C<@ISA> to provide C and -C. - -If your class B 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, L -or L 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 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 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 will be ignored. - -=head2 BUILD - -If your class or any superclass defines a C 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 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 method. If your class or any superclass -defines a C 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 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 class -method. Any attributes without a default will be C. - - my $def = Class::Tiny->get_all_attribute_defaults_for("Employee"); - # returns { - # name => undef, - # ssn => undef - # timestamp => $coderef - # } - -The C method uses two class methods, C and -C 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. - -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 or roll-their-own OO framework each time. - -L and L 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, 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 and L 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 non-core dependencies for -Perls in the L. 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 -and C 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. -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 - - git clone https://github.com/dagolden/Class-Tiny.git - -=head1 AUTHOR - -David Golden - -=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 - -=item * - -David Golden - -=item * - -Gelu Lupas - -=item * - -Karen Etheridge - -=item * - -Olivier Mengué - -=item * - -Toby Inkster - -=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 diff --git a/.github/cpm/lib/perl5/Command/Runner.pm b/.github/cpm/lib/perl5/Command/Runner.pm deleted file mode 100644 index 5a113d3e38..0000000000 --- a/.github/cpm/lib/perl5/Command/Runner.pm +++ /dev/null @@ -1,392 +0,0 @@ -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-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, where I need to execute external commands and Perl code refs with: - -=over 4 - -=item timeout - -=item quoting - -=item flexible logging - -=back - -While L has excellent APIs for such use, I still needed to tweak them in L. - -So I ended up creating a seperate module, Command::Runner. - -=head1 AUTHOR - -Shoichi Kaji - -=head1 COPYRIGHT AND LICENSE - -Copyright 2017 Shoichi Kaji - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/.github/cpm/lib/perl5/Command/Runner/Format.pm b/.github/cpm/lib/perl5/Command/Runner/Format.pm deleted file mode 100644 index 921d7c2855..0000000000 --- a/.github/cpm/lib/perl5/Command/Runner/Format.pm +++ /dev/null @@ -1,38 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Command/Runner/LineBuffer.pm b/.github/cpm/lib/perl5/Command/Runner/LineBuffer.pm deleted file mode 100644 index 93a278859a..0000000000 --- a/.github/cpm/lib/perl5/Command/Runner/LineBuffer.pm +++ /dev/null @@ -1,51 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/Command/Runner/Quote.pm b/.github/cpm/lib/perl5/Command/Runner/Quote.pm deleted file mode 100644 index 4fa148519b..0000000000 --- a/.github/cpm/lib/perl5/Command/Runner/Quote.pm +++ /dev/null @@ -1,27 +0,0 @@ -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; diff --git a/.github/cpm/lib/perl5/ExtUtils/Config.pm b/.github/cpm/lib/perl5/ExtUtils/Config.pm deleted file mode 100644 index 64134c5a4b..0000000000 --- a/.github/cpm/lib/perl5/ExtUtils/Config.pm +++ /dev/null @@ -1,114 +0,0 @@ -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 - -=item * - -Leon Timmermans - -=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 diff --git a/.github/cpm/lib/perl5/ExtUtils/Helpers.pm b/.github/cpm/lib/perl5/ExtUtils/Helpers.pm deleted file mode 100644 index 42c6cbfb92..0000000000 --- a/.github/cpm/lib/perl5/ExtUtils/Helpers.pm +++ /dev/null @@ -1,131 +0,0 @@ -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 work on Windows. - -=head1 AUTHORS - -=over 4 - -=item * - -Ken Williams - -=item * - -Leon Timmermans - -=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 diff --git a/.github/cpm/lib/perl5/ExtUtils/Helpers/Unix.pm b/.github/cpm/lib/perl5/ExtUtils/Helpers/Unix.pm deleted file mode 100644 index 24f5d01549..0000000000 --- a/.github/cpm/lib/perl5/ExtUtils/Helpers/Unix.pm +++ /dev/null @@ -1,86 +0,0 @@ -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 - -=item * - -Leon Timmermans - -=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 diff --git a/.github/cpm/lib/perl5/ExtUtils/Helpers/VMS.pm b/.github/cpm/lib/perl5/ExtUtils/Helpers/VMS.pm deleted file mode 100644 index cd0e210065..0000000000 --- a/.github/cpm/lib/perl5/ExtUtils/Helpers/VMS.pm +++ /dev/null @@ -1,117 +0,0 @@ -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 - -=item * - -Leon Timmermans - -=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 diff --git a/.github/cpm/lib/perl5/ExtUtils/Helpers/Windows.pm b/.github/cpm/lib/perl5/ExtUtils/Helpers/Windows.pm deleted file mode 100644 index 8b232e400a..0000000000 --- a/.github/cpm/lib/perl5/ExtUtils/Helpers/Windows.pm +++ /dev/null @@ -1,70 +0,0 @@ -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 - -=item * - -Leon Timmermans - -=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 diff --git a/.github/cpm/lib/perl5/ExtUtils/InstallPaths.pm b/.github/cpm/lib/perl5/ExtUtils/InstallPaths.pm deleted file mode 100644 index d5bc16c2b8..0000000000 --- a/.github/cpm/lib/perl5/ExtUtils/InstallPaths.pm +++ /dev/null @@ -1,625 +0,0 @@ -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, and they may be individually overridden by using the C attribute. An C attribute lets you specify an alternative installation root like F and C does something similar in a rather different (and more complicated) way. C lets you specify a temporary installation directory like F 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, 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