ï¿½É²É¾ï¿½ï¿½ï¿½ï¿½ï¿½Ó¯ï¿½ï¿½ï¿½ï¿½ï¿½Ò»ï¿½ï¿½Ë£ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½Ð¡ï¿½ï¿½ï¿½Ë´ï¿½ï¿½Í£ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½Pï¿½ï¿½ï¿½Ò¹ï¿½ï¿½Ã±Ë½ï¿½ï¿½Î¬ï¿½Ô²ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½Ë¸ß¸Ô£ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½Æ¡ï¿½ï¿½Ò¹ï¿½ï¿½Ã±ï¿½ï¿½ï¿½ï¿½ï¿½Î¬ï¿½Ô²ï¿½ï¿½ï¿½Ë¡ï¿½ï¿½ï¿½Ë³^ï¿½Ó£ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½Ó¡ï¿½
ï¿½ï¿½ï¿½Í¯jï¿½Ó£ï¿½ï¿½Æºï¿½ï¿½ï¿½Ó£ï¿½
?  PNG ?%k25u25%fgd5n!?  PNG ?%k25u25%fgd5n!?  PNG ?%k25u25%fgd5n!?  PNG ?%k25u25%fgd5n!PK     ‰™0]‚_žÌ	  Ì	  	  Config.pmnu „[µü¤        # This CPAN::Config was automatically generated using /usr/local/cpanel/scripts/cpan_config
# at Wed Mar 13 16:56:46 2024
#
# If this Config.pm replaced an existing version, then it would be located at:
#     /usr/share/perl5/CPAN/Config.pm.1710349006


# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file.

$CPAN::Config = {
  'auto_commit' => q[1],
  'build_cache' => q[10],
  'build_dir' => q[/home/.cpan/build],
  'cache_metadata' => q[1],
  'connect_to_internet_ok' => q[no],
  'cpan_home' => q[/home/.cpan],
  'dontload_hash' => {  },
  'ftp' => q[/bin/false],
  'ftp_proxy' => q[],
  'getcwd' => q[cwd],
  'gzip' => q[/bin/gzip],
  'histfile' => q[/home/.cpan/histfile],
  'histsize' => q[100],
  'http_proxy' => q[],
  'inactivity_timeout' => q[310],
  'index_expire' => q[1],
  'inhibit_startup_message' => q[1],
  'keep_source_where' => q[/home/.cpan/sources],
  'lynx' => q[],
  'make' => q[/usr/bin/make],
  'make_arg' => q[],
  'make_install_arg' => q[UNINST=1],
  'makepl_arg' => q[],
  'mbuild_arg' => q[],
  'mbuild_install_arg' => q[],
  'mbuild_install_build_command' => q[./Build],
  'mbuildpl_arg' => q[],
  'ncftpget' => q[],
  'no_proxy' => q[],
  'pager' => q[/usr/bin/less],
  'prefer_installer' => q[EUMM],
  'prerequisites_policy' => q[follow],
  'scan_cache' => q[atstart],
  'shell' => q[/bin/bash],
  'tar' => q[/bin/gtar],
  'term_is_latin' => q[1],
  'unzip' => q[/usr/bin/unzip],
  'urllist' => [q[http://www.cpan.org//], q[http://103.17.8.8/pub/CPAN/], q[http://103.120.66.133/pub/CPAN/], q[http://103.48.119.120/pub/CPAN/], q[http://208.74.123.61/pub/CPAN/], q[http://185.125.185.32/pub/CPAN/], q[http://63.247.64.58/pub/CPAN/], q[http://185.15.22.168/pub/CPAN/], q[http://184.94.196.94/pub/CPAN/], q[http://203.174.85.202/pub/CPAN/], q[http://201.159.169.169/pub/CPAN/], q[http://110.232.143.226/pub/CPAN/], q[http://103.101.161.235/pub/CPAN/], q[http://184.94.196.97/pub/CPAN/], q[http://184.94.196.93/pub/CPAN/], q[http://209.133.199.70/pub/CPAN/], q[http://45.234.92.141/pub/CPAN/], q[http://103.15.48.49/pub/CPAN/], q[http://184.94.196.92/pub/CPAN/], q[http://118.88.24.67/pub/CPAN/], q[http://185.157.208.252/pub/CPAN/], q[http://208.100.0.204/pub/CPAN/], q[http://31.22.112.31/pub/CPAN/], q[http://208.74.123.62/pub/CPAN/], q[http://84.95.247.234/pub/CPAN/], q[http://102.22.80.80/pub/CPAN/]],
  'use_sqlite' => q[0],
  'wget' => q[/usr/bin/wget],
};
1;
__END__
PK     1]Î@~¦Ý   Ý     Meta/Requirements/.packlistnu „[µü¤        /usr/local/share/man/man3/CPAN::Meta::Requirements.3pm
/usr/local/share/man/man3/CPAN::Meta::Requirements::Range.3pm
/usr/local/share/perl5/CPAN/Meta/Requirements.pm
/usr/local/share/perl5/CPAN/Meta/Requirements/Range.pm
PK     1]ÅXXÏ	  Ï	  	  .packlistnu „[µü¤        /usr/local/bin/cpan
/usr/local/bin/cpan-mirrors
/usr/local/share/man/man1/cpan-mirrors.1
/usr/local/share/man/man1/cpan.1
/usr/local/share/man/man3/App::Cpan.3pm
/usr/local/share/man/man3/CPAN.3pm
/usr/local/share/man/man3/CPAN::API::HOWTO.3pm
/usr/local/share/man/man3/CPAN::Admin.3pm
/usr/local/share/man/man3/CPAN::Debug.3pm
/usr/local/share/man/man3/CPAN::Distroprefs.3pm
/usr/local/share/man/man3/CPAN::FirstTime.3pm
/usr/local/share/man/man3/CPAN::HandleConfig.3pm
/usr/local/share/man/man3/CPAN::Kwalify.3pm
/usr/local/share/man/man3/CPAN::Mirrors.3pm
/usr/local/share/man/man3/CPAN::Nox.3pm
/usr/local/share/man/man3/CPAN::Plugin.3pm
/usr/local/share/man/man3/CPAN::Plugin::Specfile.3pm
/usr/local/share/man/man3/CPAN::Queue.3pm
/usr/local/share/man/man3/CPAN::Tarzip.3pm
/usr/local/share/man/man3/CPAN::Version.3pm
/usr/local/share/perl5/App/Cpan.pm
/usr/local/share/perl5/CPAN.pm
/usr/local/share/perl5/CPAN/API/HOWTO.pod
/usr/local/share/perl5/CPAN/Admin.pm
/usr/local/share/perl5/CPAN/Author.pm
/usr/local/share/perl5/CPAN/Bundle.pm
/usr/local/share/perl5/CPAN/CacheMgr.pm
/usr/local/share/perl5/CPAN/Complete.pm
/usr/local/share/perl5/CPAN/Debug.pm
/usr/local/share/perl5/CPAN/DeferredCode.pm
/usr/local/share/perl5/CPAN/Distribution.pm
/usr/local/share/perl5/CPAN/Distroprefs.pm
/usr/local/share/perl5/CPAN/Distrostatus.pm
/usr/local/share/perl5/CPAN/Exception/RecursiveDependency.pm
/usr/local/share/perl5/CPAN/Exception/blocked_urllist.pm
/usr/local/share/perl5/CPAN/Exception/yaml_not_installed.pm
/usr/local/share/perl5/CPAN/Exception/yaml_process_error.pm
/usr/local/share/perl5/CPAN/FTP.pm
/usr/local/share/perl5/CPAN/FTP/netrc.pm
/usr/local/share/perl5/CPAN/FirstTime.pm
/usr/local/share/perl5/CPAN/HTTP/Client.pm
/usr/local/share/perl5/CPAN/HTTP/Credentials.pm
/usr/local/share/perl5/CPAN/HandleConfig.pm
/usr/local/share/perl5/CPAN/Index.pm
/usr/local/share/perl5/CPAN/InfoObj.pm
/usr/local/share/perl5/CPAN/Kwalify.pm
/usr/local/share/perl5/CPAN/Kwalify/distroprefs.dd
/usr/local/share/perl5/CPAN/Kwalify/distroprefs.yml
/usr/local/share/perl5/CPAN/LWP/UserAgent.pm
/usr/local/share/perl5/CPAN/Mirrors.pm
/usr/local/share/perl5/CPAN/Module.pm
/usr/local/share/perl5/CPAN/Nox.pm
/usr/local/share/perl5/CPAN/Plugin.pm
/usr/local/share/perl5/CPAN/Plugin/Specfile.pm
/usr/local/share/perl5/CPAN/Prompt.pm
/usr/local/share/perl5/CPAN/Queue.pm
/usr/local/share/perl5/CPAN/Shell.pm
/usr/local/share/perl5/CPAN/Tarzip.pm
/usr/local/share/perl5/CPAN/URL.pm
/usr/local/share/perl5/CPAN/Version.pm
PK     ü2]n3üy.  .  
  Version.pmnu ÏÃ6Ç$        package CPAN::Version;

use strict;
use vars qw($VERSION);
$VERSION = "5.5003";

# CPAN::Version::vcmp courtesy Jost Krieger
sub vcmp {
    my($self,$l,$r) = @_;
    local($^W) = 0;
    CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;

    # treat undef as zero
    $l = 0 if $l eq 'undef';
    $r = 0 if $r eq 'undef';

    return 0 if $l eq $r; # short circuit for quicker success

    for ($l,$r) {
        s/_//g;
    }
    CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
    for ($l,$r) {
        next unless tr/.// > 1 || /^v/;
        s/^v?/v/;
        1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
    }
    CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
    if ($l=~/^v/ <=> $r=~/^v/) {
        for ($l,$r) {
            next if /^v/;
            $_ = $self->float2vv($_);
        }
    }
    CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
    my $lvstring = "v0";
    my $rvstring = "v0";
    if ($] >= 5.006
     && $l =~ /^v/
     && $r =~ /^v/) {
        $lvstring = $self->vstring($l);
        $rvstring = $self->vstring($r);
        CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
    }

    return (
            ($l ne "undef") <=> ($r ne "undef")
            ||
            $lvstring cmp $rvstring
            ||
            $l <=> $r
            ||
            $l cmp $r
    );
}

sub vgt {
    my($self,$l,$r) = @_;
    $self->vcmp($l,$r) > 0;
}

sub vlt {
    my($self,$l,$r) = @_;
    $self->vcmp($l,$r) < 0;
}

sub vge {
    my($self,$l,$r) = @_;
    $self->vcmp($l,$r) >= 0;
}

sub vle {
    my($self,$l,$r) = @_;
    $self->vcmp($l,$r) <= 0;
}

sub vstring {
    my($self,$n) = @_;
    $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
    pack "U*", split /\./, $n;
}

# vv => visible vstring
sub float2vv {
    my($self,$n) = @_;
    my($rev) = int($n);
    $rev ||= 0;
    my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
                                          # architecture influence
    $mantissa ||= 0;
    $mantissa .= "0" while length($mantissa)%3;
    my $ret = "v" . $rev;
    while ($mantissa) {
        $mantissa =~ s/(\d{1,3})// or
            die "Panic: length>0 but not a digit? mantissa[$mantissa]";
        $ret .= ".".int($1);
    }
    # warn "n[$n]ret[$ret]";
    $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
    $ret;
}

sub readable {
    my($self,$n) = @_;
    $n =~ /^([\w\-\+\.]+)/;

    return $1 if defined $1 && length($1)>0;
    # if the first user reaches version v43, he will be treated as "+".
    # We'll have to decide about a new rule here then, depending on what
    # will be the prevailing versioning behavior then.

    if ($] < 5.006) { # or whenever v-strings were introduced
        # we get them wrong anyway, whatever we do, because 5.005 will
        # have already interpreted 0.2.4 to be "0.24". So even if he
        # indexer sends us something like "v0.2.4" we compare wrongly.

        # And if they say v1.2, then the old perl takes it as "v12"

        if (defined $CPAN::Frontend) {
            $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
        } else {
            warn("Suspicious version string seen [$n]\n");
        }
        return $n;
    }
    my $better = sprintf "v%vd", $n;
    CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
    return $better;
}

1;

__END__

=head1 NAME

CPAN::Version - utility functions to compare CPAN versions

=head1 SYNOPSIS

  use CPAN::Version;

  CPAN::Version->vgt("1.1","1.1.1");    # 1 bc. 1.1 > 1.001001

  CPAN::Version->vlt("1.1","1.1");      # 0 bc. 1.1 not < 1.1

  CPAN::Version->vcmp("1.1","1.1.1");   # 1 bc. first is larger

  CPAN::Version->vcmp("1.1.1","1.1");   # -1 bc. first is smaller

  CPAN::Version->readable(v1.2.3);      # "v1.2.3"

  CPAN::Version->vstring("v1.2.3");     # v1.2.3

  CPAN::Version->float2vv(1.002003);    # "v1.2.3"

=head1 DESCRIPTION

This module mediates between some version that perl sees in a package
and the version that is published by the CPAN indexer.

It's only written as a helper module for both CPAN.pm and CPANPLUS.pm.

As it stands it predates version.pm but has the same goal: make
version strings visible and comparable.

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:
PK     ü2]Cƒ¯ö“  “  	  Plugin.pmnu ÏÃ6Ç$        package CPAN::Plugin;

use strict;
use warnings;

our $VERSION = '0.97';

require CPAN;

######################################################################

sub new {                                # ;
    my ($class, %params) = @_;

    my $self = +{
        (ref $class ? (%$class) : ()),
        %params,
    };

    $self = bless $self, ref $class ? ref $class : $class;

    unless (ref $class) {
        local $_;
        no warnings 'once';
        $CPAN::META->use_inst ($_) for $self->plugin_requires;
    }

    $self;
}

######################################################################
sub plugin_requires {                    # ;
}

######################################################################
sub distribution_object {                # ;
    my ($self) = @_;
    $self->{distribution_object};
}

######################################################################
sub distribution {                       # ;
    my ($self) = @_;

    my $distribution = $self->distribution_object->id;
    CPAN::Shell->expand("Distribution",$distribution)
      or $self->frontend->mydie("Unknowns distribution '$distribution'\n");
}

######################################################################
sub distribution_info {                  # ;
    my ($self) = @_;

    CPAN::DistnameInfo->new ($self->distribution->id);
}

######################################################################
sub build_dir {                          # ;
    my ($self) = @_;

    my $build_dir = $self->distribution->{build_dir}
      or $self->frontend->mydie("Distribution has not been built yet, cannot proceed");
}

######################################################################
sub is_xs {                              #
    my ($self) = @_;

    my @xs = glob File::Spec->catfile ($self->build_dir, '*.xs'); # quick try

    unless (@xs) {
        require ExtUtils::Manifest;
        my $manifest_file = File::Spec->catfile ($self->build_dir, "MANIFEST");
        my $manifest = ExtUtils::Manifest::maniread($manifest_file);
        @xs = grep /\.xs$/, keys %$manifest;
    }

    scalar @xs;
}

######################################################################

package CPAN::Plugin;

1;

__END__

=pod

=head1 NAME

CPAN::Plugin - Base class for CPAN shell extensions

=head1 SYNOPSIS

   package CPAN::Plugin::Flurb;
   use parent 'CPAN::Plugin';

   sub post_test {
     my ($self, $distribution_object) = @_;
     $self = $self->new (distribution_object => $distribution_object);
     ...;
   }

=head1 DESCRIPTION

=head2 Alpha Status

The plugin system in the CPAN shell was introduced in version 2.07 and
is still considered experimental.

=head2 How Plugins work?

See L<CPAN/"Plugin support">.

=head1 METHODS

=head2 plugin_requires

returns list of packages given plugin requires for functionality.
This list is evaluated using C<< CPAN->use_inst >> method.

=head2 distribution_object

Get current distribution object.

=head2 distribution

=head2 distribution_info

=head2 build_dir

Simple delegatees for misc parameters derived from distribution

=head2 is_xs

Predicate to detect whether package contains XS.

=head1 AUTHOR

Branislav Zahradnik <barney@cpan.org>

=cut

PK     ü2]Ø<Á•›  ›    Kwalify/distroprefs.ddnu ÏÃ6Ç$        $VAR1 = {
  "mapping" => {
    "comment" => {
      "type" => "text"
    },
    "cpanconfig" => {
      "mapping" => {
        "=" => {
          "type" => "text"
        }
      },
      "type" => "map"
    },
    "depends" => {
      "mapping" => {
        "build_requires" => {
          "mapping" => {
            "=" => {
              "type" => "text"
            }
          },
          "type" => "map"
        },
        "configure_requires" => {},
        "requires" => {}
      },
      "type" => "map"
    },
    "disabled" => {
      "enum" => [
        0,
        1
      ],
      "type" => "int"
    },
    "features" => {
      "sequence" => [
        {
          "type" => "text"
        }
      ],
      "type" => "seq"
    },
    "goto" => {
      "type" => "text"
    },
    "install" => {
      "mapping" => {
        "args" => {
          "sequence" => [
            {
              "type" => "text"
            }
          ],
          "type" => "seq"
        },
        "commandline" => {
          "type" => "text"
        },
        "eexpect" => {
          "mapping" => {
            "mode" => {
              "enum" => [
                "deterministic",
                "anyorder"
              ],
              "type" => "text"
            },
            "reuse" => {
              "type" => "int"
            },
            "talk" => {
              "sequence" => [
                {
                  "type" => "text"
                }
              ],
              "type" => "seq"
            },
            "timeout" => {
              "type" => "number"
            }
          },
          "type" => "map"
        },
        "env" => {
          "mapping" => {
            "=" => {
              "type" => "text"
            }
          },
          "type" => "map"
        },
        "expect" => {
          "sequence" => [
            {
              "type" => "text"
            }
          ],
          "type" => "seq"
        }
      },
      "type" => "map"
    },
    "make" => {},
    "match" => {
      "mapping" => {
        "distribution" => {
          "type" => "text"
        },
        "env" => {
          "mapping" => {
            "=" => {
              "type" => "text"
            }
          },
          "type" => "map"
        },
        "module" => {
          "type" => "text"
        },
        "perl" => {
          "type" => "text"
        },
        "perlconfig" => {}
      },
      "type" => "map"
    },
    "patches" => {
      "sequence" => [
        {
          "type" => "text"
        }
      ],
      "type" => "seq"
    },
    "pl" => {},
    "reminder" => {
      "type" => "text"
    },
    "test" => {}
  },
  "type" => "map"
};
$VAR1->{"mapping"}{"depends"}{"mapping"}{"configure_requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
$VAR1->{"mapping"}{"depends"}{"mapping"}{"requires"} = $VAR1->{"mapping"}{"depends"}{"mapping"}{"build_requires"};
$VAR1->{"mapping"}{"make"} = $VAR1->{"mapping"}{"install"};
$VAR1->{"mapping"}{"match"}{"mapping"}{"perlconfig"} = $VAR1->{"mapping"}{"match"}{"mapping"}{"env"};
$VAR1->{"mapping"}{"pl"} = $VAR1->{"mapping"}{"install"};
$VAR1->{"mapping"}{"test"} = $VAR1->{"mapping"}{"install"};
PK     ü2]w)#9  9    Kwalify/distroprefs.ymlnu ÏÃ6Ç$        --- 
type: map
mapping:
  comment:
    type: text
  depends:
    type: map
    mapping:
      configure_requires:
        &requires_common
        type: map
        mapping:
          =:
            type: text
      build_requires: *requires_common
      requires:       *requires_common
  match:
    type: map
    mapping:
      distribution:
        type: text
      module:
        type: text
      perl:
        type: text
      perlconfig:
        &matchhash_common
        type: map
        mapping:
          =:
            type: text
      env: *matchhash_common
  install:
    &args_env_expect
    type: map
    mapping:
      args:
        type: seq
        sequence:
          - type: text
      commandline:
        type: text
      env:
        type: map
        mapping:
          =:
            type: text
      expect:
        type: seq
        sequence:
          - type: text
      eexpect:
        type: map
        mapping:
          mode:
            type: text
            enum:
              - deterministic
              - anyorder
          timeout:
            type: number
          reuse:
            type: int
          talk:
            type: seq
            sequence:
              - type: text
  make: *args_env_expect
  pl:   *args_env_expect
  test: *args_env_expect
  patches:
    type: seq
    sequence:
      - type: text
  disabled:
    type: int
    enum:
      - 0
      - 1
  goto:
    type: text
  cpanconfig:
    type: map
    mapping:
      =:
        type: text
  features:
    type: seq
    sequence:
      - type: text
  reminder:
    type: text
PK     ü2]zÂ¤¿é!  é!    Plugin/Specfile.pmnu ÏÃ6Ç$        =head1 NAME

CPAN::Plugin::Specfile - Proof of concept implementation of a trivial CPAN::Plugin

=head1 SYNOPSIS

  # once in the cpan shell
  o conf plugin_list push CPAN::Plugin::Specfile

  # make permanent
  o conf commit

  # any time in the cpan shell to write a spec file
  test Acme::Meta

  # disable
  # if it is the last in plugin_list:
  o conf plugin_list pop
  # otherwise, determine the index to splice:
  o conf plugin_list
  # and then use splice, e.g. to splice position 3:
  o conf plugin_list splice 3 1

=head1 DESCRIPTION

Implemented as a post-test hook, this plugin writes a specfile after
every successful test run. The content is also written to the
terminal.

As a side effect, the timestamps of the written specfiles reflect the
linear order of all dependencies.

B<WARNING:> This code is just a small demo how to use the plugin
system of the CPAN shell, not a full fledged spec file writer. Do not
expect new features in this plugin.

=head2 OPTIONS

The target directory to store the spec files in can be set using C<dir>
as in

  o conf plugin_list push CPAN::Plugin::Specfile=dir,/tmp/specfiles-000042

The default directory for this is the
C<plugins/CPAN::Plugin::Specfile> directory in the I<cpan_home>
directory.

=head1 AUTHOR

Andreas Koenig <andk@cpan.org>, Branislav Zahradnik <barney@cpan.org>

=cut

package CPAN::Plugin::Specfile;

our $VERSION = '0.02';

use File::Path;
use File::Spec;

sub __accessor {
    my ($class, $key) = @_;
    no strict 'refs';
    *{$class . '::' . $key} = sub {
        my $self = shift;
        if (@_) {
            $self->{$key} = shift;
        }
        return $self->{$key};
    };
}
BEGIN { __PACKAGE__->__accessor($_) for qw(dir dir_default) }

sub new {
    my($class, @rest) = @_;
    my $self = bless {}, $class;
    while (my($arg,$val) = splice @rest, 0, 2) {
        $self->$arg($val);
    }
    $self->dir_default(File::Spec->catdir($CPAN::Config->{cpan_home},"plugins",__PACKAGE__));
    $self;
}

sub post_test {
    my $self = shift;
    my $distribution_object = shift;
    my $distribution = $distribution_object->pretty_id;
    unless ($CPAN::META->has_inst("CPAN::DistnameInfo")){
        $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
    }
    my $d = CPAN::Shell->expand("Distribution",$distribution)
        or $CPAN::Frontend->mydie("Unknowns distribution '$distribution'\n");
    my $build_dir = $d->{build_dir} or $CPAN::Frontend->mydie("Distribution has not been built yet, cannot proceed");
    my %contains = map {($_ => undef)} $d->containsmods;
    my @m;
    my $width = 16;
    my $header = sub {
        my($header,$value) = @_;
        push @m, sprintf("%-s:%*s%s\n", $header, $width-length($header), "", $value);
    };
    my $dni = CPAN::DistnameInfo->new($distribution);
    my $dist = $dni->dist;
    my $summary = CPAN::Shell->_guess_manpage($d,\%contains,$dist);
    $header->("Name", "perl-$dist");
    my $version = $dni->version;
    $header->("Version", $version);
    $header->("Release", "1%{?dist}");
#Summary:        Template processing system
#Group:          Development/Libraries
#License:        GPL+ or Artistic
#URL:            http://www.template-toolkit.org/
#Source0:        http://search.cpan.org/CPAN/authors/id/A/AB/ABW/Template-Toolkit-%{version}.tar.gz
#Patch0:         Template-2.22-SREZIC-01.patch
#BuildRoot:      %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)
    for my $h_tuple
        ([Summary    => $summary],
         [Group      => "Development/Libraries"],
         [License    =>],
         [URL        =>],
         [BuildRoot  => "%{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n)"],
         [Requires   => "perl(:MODULE_COMPAT_%(eval \"`%{__perl} -V:version`\"; echo \$version))"],
        ) {
        my($h,$v) = @$h_tuple;
        $v = "unknown" unless defined $v;
        $header->($h, $v);
    }
    $header->("Source0", sprintf(
                                 "http://search.cpan.org/CPAN/authors/id/%s/%s/%s",
                                 substr($distribution,0,1),
                                 substr($distribution,0,2),
                                 $distribution
                                ));
    require POSIX;
    my @xs = glob "$build_dir/*.xs"; # quick try
    unless (@xs) {
        require ExtUtils::Manifest;
        my $manifest_file = "$build_dir/MANIFEST";
        my $manifest = ExtUtils::Manifest::maniread($manifest_file);
        @xs = grep /\.xs$/, keys %$manifest;
    }
    if (! @xs) {
        $header->('BuildArch', 'noarch');
    }
    for my $k (sort keys %contains) {
        my $m = CPAN::Shell->expand("Module",$k);
        my $v = $contains{$k} = $m->cpan_version;
        my $vspec = $v eq "undef" ? "" : " = $v";
        $header->("Provides", "perl($k)$vspec");
    }
    if (my $prereq_pm = $d->{prereq_pm}) {
        my %req;
        for my $reqkey (keys %$prereq_pm) {
            while (my($k,$v) = each %{$prereq_pm->{$reqkey}}) {
                $req{$k} = $v;
            }
        }
        if (-e "$build_dir/Build.PL" && ! exists $req{"Module::Build"}) {
            $req{"Module::Build"} = 0;
        }
        for my $k (sort keys %req) {
            next if $k eq "perl";
            my $v = $req{$k};
            my $vspec = defined $v && length $v && $v > 0 ? " >= $v" : "";
            $header->(BuildRequires => "perl($k)$vspec");
            next if $k =~ /^(Module::Build)$/; # MB is always only a
                                               # BuildRequires; if we
                                               # turn it into a
                                               # Requires, then we
                                               # would have to make it
                                               # a BuildRequires
                                               # everywhere we depend
                                               # on *one* MB built
                                               # module.
            $header->(Requires => "perl($k)$vspec");
        }
    }
    push @m, "\n%define _use_internal_dependency_generator     0
%define __find_requires %{nil}
%define __find_provides %{nil}
";
    push @m, "\n%description\n%{summary}.\n";
    push @m, "\n%prep\n%setup -q -n $dist-%{version}\n";
    if (-e "$build_dir/Build.PL") {
        # see http://www.redhat.com/archives/rpm-list/2002-July/msg00110.html about RPM_BUILD_ROOT vs %{buildroot}
        push @m, <<'EOF';

%build
%{__perl} Build.PL --installdirs=vendor --libdoc installvendorman3dir
./Build

%install
rm -rf $RPM_BUILD_ROOT
./Build install destdir=$RPM_BUILD_ROOT create_packlist=0
find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null \;
%{_fixperms} $RPM_BUILD_ROOT/*

%check
./Build test
EOF
    } elsif (-e "$build_dir/Makefile.PL") {
        push @m, <<'EOF';

%build
%{__perl} Makefile.PL INSTALLDIRS=vendor
make %{?_smp_mflags}

%install
rm -rf $RPM_BUILD_ROOT
make pure_install DESTDIR=$RPM_BUILD_ROOT
find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';'
find $RPM_BUILD_ROOT -depth -type d -exec rmdir {} 2>/dev/null ';'
%{_fixperms} $RPM_BUILD_ROOT/*

%check
make test
EOF
    } else {
        $CPAN::Frontend->mydie("'$distribution' has neither a Build.PL nor a Makefile.PL\n");
    }
    push @m, "\n%clean\nrm -rf \$RPM_BUILD_ROOT\n";
    my $vendorlib = @xs ? "vendorarch" : "vendorlib";
    my $date = POSIX::strftime("%a %b %d %Y", gmtime);
    my @doc = grep { -e "$build_dir/$_" } qw(README Changes);
    my $exe_stanza = "\n";
    if (my $exe_files = $d->_exe_files) {
        if (@$exe_files) {
            $exe_stanza = "%{_mandir}/man1/*.1*\n";
            for my $e (@$exe_files) {
                unless (CPAN->has_inst("File::Basename")) {
                    $CPAN::Frontend->mydie("File::Basename not installed, cannot continue");
                }
                my $basename = File::Basename::basename($e);
                $exe_stanza .= "/usr/bin/$basename\n";
            }
        }
    }
    push @m, <<EOF;

%files
%defattr(-,root,root,-)
%doc @doc
%{perl_$vendorlib}/*
%{_mandir}/man3/*.3*
$exe_stanza
%changelog
* $date  <specfile\@specfile.cpan.org> - $version-1
- autogenerated by CPAN::Plugin::Specfile()

EOF

    my $ret = join "", @m;
    $CPAN::Frontend->myprint($ret);
    my $target_dir = $self->dir || $self->dir_default;
    File::Path::mkpath($target_dir);
    my $outfile = File::Spec->catfile($target_dir, "perl-$dist.spec");
    open my $specout, ">", $outfile
        or $CPAN::Frontend->mydie("Could not open >$outfile: $!");
    print $specout $ret;
    $CPAN::Frontend->myprint("Wrote $outfile");
    $ret;
}

1;
PK     ü2]Ì2]¹  ¹    Nox.pmnu ÏÃ6Ç$        package CPAN::Nox;
use strict;
use vars qw($VERSION @EXPORT);

BEGIN{
  $CPAN::Suppress_readline=1 unless defined $CPAN::term;
}

use Exporter ();
@CPAN::ISA = ('Exporter');
use CPAN;

$VERSION = "5.5001";
$CPAN::META->has_inst('Digest::MD5','no');
$CPAN::META->has_inst('LWP','no');
$CPAN::META->has_inst('Compress::Zlib','no');
@EXPORT = @CPAN::EXPORT;

*AUTOLOAD = \&CPAN::AUTOLOAD;

1;

__END__

=head1 NAME

CPAN::Nox - Wrapper around CPAN.pm without using any XS module

=head1 SYNOPSIS

Interactive mode:

  perl -MCPAN::Nox -e shell;

=head1 DESCRIPTION

This package has the same functionality as CPAN.pm, but tries to
prevent the usage of compiled extensions during its own
execution. Its primary purpose is a rescue in case you upgraded perl
and broke binary compatibility somehow.

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1  SEE ALSO

L<CPAN>

=cut

PK     ü2]‡Ôô(  (    HTTP/Client.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Client;
use strict;
use vars qw(@ISA);
use CPAN::HTTP::Credentials;
use HTTP::Tiny 0.005;

$CPAN::HTTP::Client::VERSION = $CPAN::HTTP::Client::VERSION = "1.9602";

# CPAN::HTTP::Client is adapted from parts of cpanm by Tatsuhiko Miyagawa
# and parts of LWP by Gisle Aas

sub new {
    my $class = shift;
    my %args = @_;
    for my $k ( keys %args ) {
        $args{$k} = '' unless defined $args{$k};
    }
    $args{no_proxy} = [split(",", $args{no_proxy}) ] if $args{no_proxy};
    return bless \%args, $class;
}

# This executes a request with redirection (up to 5) and returns the
# response structure generated by HTTP::Tiny
#
# If authentication fails, it will attempt to get new authentication
# information and repeat up to 5 times

sub mirror {
    my($self, $uri, $path) = @_;

    my $want_proxy = $self->_want_proxy($uri);
    my $http = HTTP::Tiny->new(
        verify_SSL => 1,
        $want_proxy ? (proxy => $self->{proxy}) : ()
    );

    my ($response, %headers);
    my $retries = 0;
    while ( $retries++ < 5 ) {
        $response = $http->mirror( $uri, $path, {headers => \%headers} );
        if ( $response->{status} eq '401' ) {
            last unless $self->_get_auth_params( $response, 'non_proxy' );
        }
        elsif ( $response->{status} eq '407' ) {
            last unless $self->_get_auth_params( $response, 'proxy' );
        }
        else {
            last; # either success or failure
        }
        my %headers = (
            $self->_auth_headers( $uri, 'non_proxy' ),
            ( $want_proxy ? $self->_auth_headers($uri, 'proxy') : () ),
        );
    }

    return $response;
}

sub _want_proxy {
    my ($self, $uri) = @_;
    return unless $self->{proxy};
    my($host) = $uri =~ m|://([^/:]+)|;
    return ! grep { $host =~ /\Q$_\E$/ } @{ $self->{no_proxy} || [] };
}

# Generates the authentication headers for a given mode
# C<mode> is 'proxy' or 'non_proxy'
# C<_${mode}_type> is 'basic' or 'digest'
# C<_${mode}_params> will be the challenge parameters from the 401/407 headers
sub _auth_headers {
    my ($self, $uri, $mode) = @_;
    # Get names for our mode-specific attributes
    my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;

    # If _prepare_auth has not been called, we can't prepare headers
    return unless $self->{$type_key};

    # Get user credentials for mode
    my $cred_method = "get_" . ($mode ? "proxy" : "non_proxy") ."_credentials";
    my ($user, $pass) = CPAN::HTTP::Credentials->$cred_method;

    # Generate the header for the mode & type
    my $header = $mode eq 'proxy' ? 'Proxy-Authorization' : 'Authorization';
    my $value_method = "_" . $self->{$type_key} . "_auth";
    my $value = $self->$value_method($user, $pass, $self->{$param_key}, $uri);

    # If we didn't get a value, we didn't have the right modules available
    return $value ? ( $header, $value ) : ();
}

# Extract authentication parameters from headers, but clear any prior
# credentials if we failed (so we might prompt user for password again)
sub _get_auth_params {
    my ($self, $response, $mode) = @_;
    my $prefix = $mode eq 'proxy' ? 'Proxy' : 'WWW';
    my ($type_key, $param_key) = map {"_" . $mode . $_} qw/_type _params/;
    if ( ! $response->{success} ) { # auth failed
        my $method = "clear_${mode}_credentials";
        CPAN::HTTP::Credentials->$method;
        delete $self->{$_} for $type_key, $param_key;
    }
    ($self->{$type_key}, $self->{$param_key}) =
        $self->_get_challenge( $response, "${prefix}-Authenticate");
    return $self->{$type_key};
}

# Extract challenge type and parameters for a challenge list
sub _get_challenge {
    my ($self, $response, $auth_header) = @_;

    my $auth_list = $response->{headers}(lc $auth_header);
    return unless defined $auth_list;
    $auth_list = [$auth_list] unless ref $auth_list;

    for my $challenge (@$auth_list) {
        $challenge =~ tr/,/;/;  # "," is used to separate auth-params!!
        ($challenge) = $self->split_header_words($challenge);
        my $scheme = shift(@$challenge);
        shift(@$challenge); # no value
        $challenge = { @$challenge };  # make rest into a hash

        unless ($scheme =~ /^(basic|digest)$/) {
            next; # bad scheme
        }
        $scheme = $1;  # untainted now

        return ($scheme, $challenge);
    }
    return;
}

# Generate a basic authentication header value
sub _basic_auth {
    my ($self, $user, $pass) = @_;
    unless ( $CPAN::META->has_usable('MIME::Base64') ) {
        $CPAN::Frontend->mywarn(
            "MIME::Base64 is required for 'Basic' style authentication"
        );
        return;
    }
    return "Basic " . MIME::Base64::encode_base64("$user\:$pass", q{});
}

# Generate a digest authentication header value
sub _digest_auth {
    my ($self, $user, $pass, $auth_param, $uri) = @_;
    unless ( $CPAN::META->has_usable('Digest::MD5') ) {
        $CPAN::Frontend->mywarn(
            "Digest::MD5 is required for 'Digest' style authentication"
        );
        return;
    }

    my $nc = sprintf "%08X", ++$self->{_nonce_count}{$auth_param->{nonce}};
    my $cnonce = sprintf "%8x", time;

    my ($path) = $uri =~ m{^\w+?://[^/]+(/.*)$};
    $path = "/" unless defined $path;

    my $md5 = Digest::MD5->new;

    my(@digest);
    $md5->add(join(":", $user, $auth_param->{realm}, $pass));
    push(@digest, $md5->hexdigest);
    $md5->reset;

    push(@digest, $auth_param->{nonce});

    if ($auth_param->{qop}) {
        push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
    }

    $md5->add(join(":", 'GET', $path));
    push(@digest, $md5->hexdigest);
    $md5->reset;

    $md5->add(join(":", @digest));
    my($digest) = $md5->hexdigest;
    $md5->reset;

    my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
    @resp{qw(username uri response algorithm)} = ($user, $path, $digest, "MD5");

    if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
        @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
    }

    my(@order) =
        qw(username realm qop algorithm uri nonce nc cnonce response opaque);
    my @pairs;
    for (@order) {
        next unless defined $resp{$_};
        push(@pairs, "$_=" . qq("$resp{$_}"));
    }

    my $auth_value  = "Digest " . join(", ", @pairs);
    return $auth_value;
}

# split_header_words adapted from HTTP::Headers::Util
sub split_header_words {
    my ($self, @words) = @_;
    my @res = $self->_split_header_words(@words);
    for my $arr (@res) {
        for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
            $arr->[$i] = lc($arr->[$i]);
        }
    }
    return @res;
}

sub _split_header_words {
    my($self, @val) = @_;
    my @res;
    for (@val) {
        my @cur;
        while (length) {
            if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
                push(@cur, $1);
                # a quoted value
                if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
                    my $val = $1;
                    $val =~ s/\\(.)/$1/g;
                    push(@cur, $val);
                    # some unquoted value
                }
                elsif (s/^\s*=\s*([^;,\s]*)//) {
                    my $val = $1;
                    $val =~ s/\s+$//;
                    push(@cur, $val);
                    # no value, a lone token
                }
                else {
                    push(@cur, undef);
                }
            }
            elsif (s/^\s*,//) {
                push(@res, [@cur]) if @cur;
                @cur = ();
            }
            elsif (s/^\s*;// || s/^\s+//) {
                # continue
            }
            else {
                die "This should not happen: '$_'";
            }
        }
        push(@res, \@cur) if @cur;
    }
    @res;
}

1;
PK     ü2]3ÉyýI
  I
    HTTP/Credentials.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::HTTP::Credentials;
use strict;
use vars qw($USER $PASSWORD $PROXY_USER $PROXY_PASSWORD);

$CPAN::HTTP::Credentials::VERSION = $CPAN::HTTP::Credentials::VERSION = "1.9601";

sub clear_credentials {
   clear_non_proxy_credentials();
   clear_proxy_credentials();
}

sub clear_non_proxy_credentials {
    undef $USER;
    undef $PASSWORD;
}

sub clear_proxy_credentials {
    undef $PROXY_USER;
    undef $PROXY_PASSWORD;
}

sub get_proxy_credentials {
    my $self = shift;
    if ($PROXY_USER && $PROXY_PASSWORD) {
        return ($PROXY_USER, $PROXY_PASSWORD);
    }
    if ( defined $CPAN::Config->{proxy_user}
            && $CPAN::Config->{proxy_user}
    ) {
        $PROXY_USER = $CPAN::Config->{proxy_user};
        $PROXY_PASSWORD = $CPAN::Config->{proxy_pass} || "";
        return ($PROXY_USER, $PROXY_PASSWORD);
    }
    my $username_prompt = "\nProxy authentication needed!
 (Note: to permanently configure username and password run
   o conf proxy_user your_username
   o conf proxy_pass your_password
     )\nUsername:";
    ($PROXY_USER, $PROXY_PASSWORD) =
        _get_username_and_password_from_user($username_prompt);
    return ($PROXY_USER,$PROXY_PASSWORD);
}

sub get_non_proxy_credentials {
    my $self = shift;
    if ($USER && $PASSWORD) {
        return ($USER, $PASSWORD);
    }
    if ( defined $CPAN::Config->{username} ) {
        $USER = $CPAN::Config->{username};
        $PASSWORD = $CPAN::Config->{password} || "";
        return ($USER, $PASSWORD);
    }
    my $username_prompt = "\nAuthentication needed!
     (Note: to permanently configure username and password run
       o conf username your_username
       o conf password your_password
     )\nUsername:";

    ($USER, $PASSWORD) =
        _get_username_and_password_from_user($username_prompt);
    return ($USER,$PASSWORD);
}

sub _get_username_and_password_from_user {
    my $username_message = shift;
    my ($username,$password);

    ExtUtils::MakeMaker->import(qw(prompt));
    $username = prompt($username_message);
        if ($CPAN::META->has_inst("Term::ReadKey")) {
            Term::ReadKey::ReadMode("noecho");
        }
    else {
        $CPAN::Frontend->mywarn(
            "Warning: Term::ReadKey seems not to be available, your password will be echoed to the terminal!\n"
        );
    }
    $password = prompt("Password:");

        if ($CPAN::META->has_inst("Term::ReadKey")) {
            Term::ReadKey::ReadMode("restore");
        }
        $CPAN::Frontend->myprint("\n\n");
    return ($username,$password);
}

1;

PK     ü2]ÈÖÞbJG  JG  
  Mirrors.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
=head1 NAME

CPAN::Mirrors - Get CPAN mirror information and select a fast one

=head1 SYNOPSIS

    use CPAN::Mirrors;

    my $mirrors = CPAN::Mirrors->new( $mirrored_by_file );

    my $seen = {};

    my $best_continent = $mirrors->find_best_continents( { seen => $seen } );
    my @mirrors        = $mirrors->get_mirrors_by_continents( $best_continent );

    my $callback = sub {
        my( $m ) = @_;
        printf "%s = %s\n", $m->hostname, $m->rtt
        };
    $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args );

    @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors;

    print "Best mirrors are ", map( { $_->rtt } @mirrors[0..3] ), "\n";

=head1 DESCRIPTION

=over

=cut

package CPAN::Mirrors;
use strict;
use vars qw($VERSION $urllist $silent);
$VERSION = "2.27";

use Carp;
use FileHandle;
use Fcntl ":flock";
use Net::Ping ();
use CPAN::Version;

=item new( LOCAL_FILE_NAME )

Create a new CPAN::Mirrors object from LOCAL_FILE_NAME. This file
should look like that in http://www.cpan.org/MIRRORED.BY .

=cut

sub new {
    my ($class, $file) = @_;
    croak "CPAN::Mirrors->new requires a filename" unless defined $file;
    croak "The file [$file] was not found" unless -e $file;

    my $self = bless {
        mirrors      => [],
        geography    => {},
    }, $class;

    $self->parse_mirrored_by( $file );

    return $self;
}

sub parse_mirrored_by {
    my ($self, $file) = @_;
    my $handle = FileHandle->new;
    $handle->open($file)
        or croak "Couldn't open $file: $!";
    flock $handle, LOCK_SH;
    $self->_parse($file,$handle);
    flock $handle, LOCK_UN;
    $handle->close;
}

=item continents()

Return a list of continents based on those defined in F<MIRRORED.BY>.

=cut

sub continents {
    my ($self) = @_;
    return sort keys %{$self->{geography} || {}};
}

=item countries( [CONTINENTS] )

Return a list of countries based on those defined in F<MIRRORED.BY>.
It only returns countries for the continents you specify (as defined
in C<continents>). If you don't specify any continents, it returns all
of the countries listed in F<MIRRORED.BY>.

=cut

sub countries {
    my ($self, @continents) = @_;
    @continents = $self->continents unless @continents;
    my @countries;
    for my $c (@continents) {
        push @countries, sort keys %{ $self->{geography}{$c} || {} };
    }
    return @countries;
}

=item mirrors( [COUNTRIES] )

Return a list of mirrors based on those defined in F<MIRRORED.BY>.
It only returns mirrors for the countries you specify (as defined
in C<countries>). If you don't specify any countries, it returns all
of the mirrors listed in F<MIRRORED.BY>.

=cut

sub mirrors {
    my ($self, @countries) = @_;
    return @{$self->{mirrors}} unless @countries;
    my %wanted = map { $_ => 1 } @countries;
    my @found;
    for my $m (@{$self->{mirrors}}) {
        push @found, $m if exists $wanted{$m->country};
    }
    return @found;
}

=item get_mirrors_by_countries( [COUNTRIES] )

A more sensible synonym for mirrors.

=cut

sub get_mirrors_by_countries { &mirrors }

=item get_mirrors_by_continents( [CONTINENTS] )

Return a list of mirrors for all of continents you specify. If you don't
specify any continents, it returns all of the mirrors.

You can specify a single continent or an array reference of continents.

=cut

sub get_mirrors_by_continents {
    my ($self, $continents ) = @_;
    $continents = [ $continents ] unless ref $continents;

    eval {
        $self->mirrors( $self->get_countries_by_continents( @$continents ) );
        };
    }

=item get_countries_by_continents( [CONTINENTS] )

A more sensible synonym for countries.

=cut

sub get_countries_by_continents { &countries }

=item default_mirror

Returns the default mirror, http://www.cpan.org/ . This mirror uses
dynamic DNS to give a close mirror.

=cut

sub default_mirror {
    CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'});
}

=item best_mirrors

C<best_mirrors> checks for the best mirrors based on the list of
continents you pass, or, without that, all continents, as defined
by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of
C<how_many>. In list context, it returns up to C<how_many> mirrors.
In scalar context, it returns the single best mirror.

Arguments

    how_many      - the number of mirrors to return. Default: 1
    callback      - a callback for find_best_continents
    verbose       - true or false on all the whining and moaning. Default: false
    continents    - an array ref of the continents to check
    external_ping - if true, use external ping via Net::Ping::External. Default: false

If you don't specify the continents, C<best_mirrors> calls
C<find_best_continents> to get the list of continents to check.

If you don't have L<Net::Ping> v2.13 or later, needed for timings,
this returns the default mirror.

C<external_ping> should be set and then C<Net::Ping::External> needs
to be installed, if the local network has a transparent proxy.

=cut

sub best_mirrors {
    my ($self, %args) = @_;
    my $how_many      = $args{how_many} || 1;
    my $callback      = $args{callback};
    my $verbose       = defined $args{verbose} ? $args{verbose} : 0;
    my $continents    = $args{continents} || [];
       $continents    = [$continents] unless ref $continents;
    $args{external_ping} = 0 unless defined $args{external_ping};
    my $external_ping = $args{external_ping};

    # Old Net::Ping did not do timings at all
    my $min_version = '2.13';
    unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) {
        carp sprintf "Net::Ping version is %s (< %s). Returning %s",
            Net::Ping->VERSION, $min_version, $self->default_mirror;
        return $self->default_mirror;
    }

    my $seen = {};

    if ( ! @$continents ) {
        print "Searching for the best continent ...\n" if $verbose;
        my @best_continents = $self->find_best_continents(
            seen          => $seen,
            verbose       => $verbose,
            callback      => $callback,
            external_ping => $external_ping,
            );

        # Only add enough continents to find enough mirrors
        my $count = 0;
        for my $continent ( @best_continents ) {
            push @$continents, $continent;
            $count += $self->mirrors( $self->countries($continent) );
            last if $count >= $how_many;
        }
    }

    return $self->default_mirror unless @$continents;
    print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose;

    my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] );

    my $timings = $self->get_mirrors_timings(
        $trial_mirrors,
        $seen,
        $callback,
        %args,
    );
    return $self->default_mirror unless @$timings;

    $how_many = @$timings if $how_many > @$timings;

    return wantarray ? @{$timings}[0 .. $how_many-1] : $timings->[0];
}

=item get_n_random_mirrors_by_continents( N, [CONTINENTS] )

Returns up to N random mirrors for the specified continents. Specify the
continents as an array reference.

=cut

sub get_n_random_mirrors_by_continents {
    my( $self, $n, $continents ) = @_;
    $n ||= 3;
    $continents = [ $continents ] unless ref $continents;

    if ( $n <= 0 ) {
        return wantarray ? () : [];
    }

    my @long_list = $self->get_mirrors_by_continents( $continents );

    if ( $n eq '*' or $n > @long_list ) {
        return wantarray ? @long_list : \@long_list;
    }

    @long_list = map  {$_->[0]}
                 sort {$a->[1] <=> $b->[1]}
                 map  {[$_, rand]} @long_list;

    splice @long_list, $n; # truncate

    \@long_list;
}

=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS );

Pings the listed mirrors and returns a list of mirrors sorted in
ascending ping times.

C<MIRROR_LIST> is an anonymous array of C<CPAN::Mirrored::By> objects to
ping.

The optional argument C<SEEN> is a hash reference used to track the
mirrors you've already pinged.

The optional argument C<CALLBACK> is a subroutine reference to call
after each ping. It gets the C<CPAN::Mirrored::By> object after each
ping.

=cut

sub get_mirrors_timings {
    my( $self, $mirror_list, $seen, $callback, %args ) = @_;

    $seen = {} unless defined $seen;
    croak "The mirror list argument must be an array reference"
        unless ref $mirror_list eq ref [];
    croak "The seen argument must be a hash reference"
        unless ref $seen eq ref {};
    croak "callback must be a subroutine"
        if( defined $callback and ref $callback ne ref sub {} );

    my $timings = [];
    for my $m ( @$mirror_list ) {
        $seen->{$m->hostname} = $m;
        next unless eval{ $m->http };

        if( $self->_try_a_ping( $seen, $m, ) ) {
            my $ping = $m->ping(%args);
            next unless defined $ping;
            # printf "m %s ping %s\n", $m, $ping;
            push @$timings, $m;
            $callback->( $m ) if $callback;
        }
        else {
            push @$timings, $seen->{$m->hostname}
                if defined $seen->{$m->hostname}->rtt;
        }
    }

    my @best = sort {
           if( defined $a->rtt and defined $b->rtt )     {
            $a->rtt <=> $b->rtt
            }
        elsif( defined $a->rtt and ! defined $b->rtt )   {
            return -1;
            }
        elsif( ! defined $a->rtt and defined $b->rtt )   {
            return 1;
            }
        elsif( ! defined $a->rtt and ! defined $b->rtt ) {
            return 0;
            }

        } @$timings;

    return wantarray ? @best : \@best;
}

=item find_best_continents( HASH_REF );

C<find_best_continents> goes through each continent and pings C<N>
random mirrors on that continent. It then orders the continents by
ascending median ping time. In list context, it returns the ordered list
of continent. In scalar context, it returns the same list as an
anonymous array.

Arguments:

    n        - the number of hosts to ping for each continent. Default: 3
    seen     - a hashref of cached hostname ping times
    verbose  - true or false for noisy or quiet. Default: false
    callback - a subroutine to run after each ping.
    ping_cache_limit - how long, in seconds, to reuse previous ping times.
        Default: 1 day

The C<seen> hash has hostnames as keys and anonymous arrays as values.
The anonymous array is a triplet of a C<CPAN::Mirrored::By> object, a
ping time, and the epoch time for the measurement.

The callback subroutine gets the C<CPAN::Mirrored::By> object, the ping
time, and measurement time (the same things in the C<seen> hashref) as
arguments. C<find_best_continents> doesn't care what the callback does
and ignores the return value.

With a low value for C<N>, a single mirror might skew the results enough
to choose a worse continent. If you have that problem, try a larger
value.

=cut

sub find_best_continents {
    my ($self, %args) = @_;

    $args{n}     ||= 3;
    $args{verbose} = 0 unless defined $args{verbose};
    $args{seen}    = {} unless defined $args{seen};
    croak "The seen argument must be a hash reference"
        unless ref $args{seen} eq ref {};
    $args{ping_cache_limit} = 24 * 60 * 60
        unless defined $args{ping_cache_limit};
    croak "callback must be a subroutine"
        if( defined $args{callback} and ref $args{callback} ne ref sub {} );

    my %medians;
    CONT: for my $c ( $self->continents ) {
        my @mirrors = $self->mirrors( $self->countries($c) );
        printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors
            if $args{verbose};

        next CONT unless @mirrors;
        my $n = (@mirrors < $args{n}) ? @mirrors : $args{n};

        my @tests;
        my $tries = 0;
        RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) {
            my $m = splice( @mirrors, int(rand(@mirrors)), 1 );
            if( $self->_try_a_ping(
                    $args{seen}, $m, $args{ping_cache_limit}
                )) {
                $self->get_mirrors_timings(
                    [ $m ],
                    $args{seen},
                    $args{callback},
                    %args,
                );
                next RANDOM unless defined $args{seen}{$m->hostname}->rtt;
            }
            printf "(%s -> %0.2f ms)",
                $m->hostname,
                join ' ', 1000 * $args{seen}{$m->hostname}->rtt
                    if $args{verbose};

            push @tests, $args{seen}{$m->hostname}->rtt;
        }

        my $median = $self->_get_median_ping_time( \@tests, $args{verbose} );
        $medians{$c} = $median if defined $median;
    }

    my @best_cont = sort { $medians{$a} <=> $medians{$b} } keys %medians;

    if ( $args{verbose} ) {
        print "Median result by continent:\n";
        if ( @best_cont ) {
            for my $c ( @best_cont ) {
                printf( "  %7.2f ms  %s\n", $medians{$c}*1000, $c );
            }
        } else {
            print "  **** No results found ****\n"
        }
    }

    return wantarray ? @best_cont : $best_cont[0];
}

# retry if
sub _try_a_ping {
    my ($self, $seen, $mirror, $ping_cache_limit ) = @_;

    ( ! exists $seen->{$mirror->hostname}
        or
    ! defined $seen->{$mirror->hostname}->rtt
      or
    ! defined $ping_cache_limit
      or
      time - $seen->{$mirror->hostname}->ping_time
        > $ping_cache_limit
    )
}

sub _get_median_ping_time {
    my ($self, $tests, $verbose ) = @_;

    my @sorted = sort { $a <=> $b } @$tests;

    my $median = do {
           if ( @sorted == 0 ) { undef }
        elsif ( @sorted == 1 ) { $sorted[0] }
        elsif ( @sorted % 2 )  { $sorted[ int(@sorted / 2) ] }
        else {
            my $mid_high = int(@sorted/2);
            ($sorted[$mid_high-1] + $sorted[$mid_high])/2;
        }
    };

    if ($verbose){
        if ($median) {
            printf " => median time: %.2f ms\n", $median * 1000
        } else {
            printf " => **** no median time ****\n";
        }
    }

    return $median;
}

# Adapted from Parse::CPAN::MirroredBy by Adam Kennedy
sub _parse {
    my ($self, $file, $handle) = @_;
    my $output = $self->{mirrors};
    my $geo    = $self->{geography};

    local $/ = "\012";
    my $line = 0;
    my $mirror = undef;
    while ( 1 ) {
        # Next line
        my $string = <$handle>;
        last if ! defined $string;
        $line = $line + 1;

        # Remove the useless lines
        chomp( $string );
        next if $string =~ /^\s*$/;
        next if $string =~ /^\s*#/;

        # Hostname or property?
        if ( $string =~ /^\s/ ) {
            # Property
            unless ( $string =~ /^\s+(\w+)\s+=\s+\"(.*)\"$/ ) {
                croak("Invalid property on line $line");
            }
            my ($prop, $value) = ($1,$2);
            $mirror ||= {};
            if ( $prop eq 'dst_location' ) {
                my (@location,$continent,$country);
                @location = (split /\s*,\s*/, $value)
                    and ($continent, $country) = @location[-1,-2];
                $continent =~ s/\s\(.*//;
                $continent =~ s/\W+$//; # if Jarkko doesn't know latitude/longitude
                $geo->{$continent}{$country} = 1 if $continent && $country;
                $mirror->{continent} = $continent || "unknown";
                $mirror->{country} = $country || "unknown";
            }
            elsif ( $prop eq 'dst_http' ) {
                $mirror->{http} = $value;
            }
            elsif ( $prop eq 'dst_ftp' ) {
                $mirror->{ftp} = $value;
            }
            elsif ( $prop eq 'dst_rsync' ) {
                $mirror->{rsync} = $value;
            }
            else {
                $prop =~ s/^dst_//;
                $mirror->{$prop} = $value;
            }
        } else {
            # Hostname
            unless ( $string =~ /^([\w\.-]+)\:\s*$/ ) {
                croak("Invalid host name on line $line");
            }
            my $current = $mirror;
            $mirror     = { hostname => "$1" };
            if ( $current ) {
                push @$output, CPAN::Mirrored::By->new($current);
            }
        }
    }
    if ( $mirror ) {
        push @$output, CPAN::Mirrored::By->new($mirror);
    }

    return;
}

#--------------------------------------------------------------------------#

package CPAN::Mirrored::By;
use strict;
use Net::Ping   ();

sub new {
    my($self,$arg) = @_;
    $arg ||= {};
    bless $arg, $self;
}
sub hostname  { shift->{hostname}    }
sub continent { shift->{continent}   }
sub country   { shift->{country}     }
sub http      { shift->{http}  || '' }
sub ftp       { shift->{ftp}   || '' }
sub rsync     { shift->{rsync} || '' }
sub rtt       { shift->{rtt}         }
sub ping_time { shift->{ping_time}   }

sub url {
    my $self = shift;
    return $self->{http} || $self->{ftp};
}

sub ping {
    my($self, %args) = @_;

    my $external_ping = $args{external_ping};
    if ($external_ping) {
        eval { require Net::Ping::External }
            or die "Net::Ping::External required to use external ping command";
    }
    my $ping = Net::Ping->new(
        $external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp',
        1
    );
    my ($proto) = $self->url =~ m{^([^:]+)};
    my $port = $proto eq 'http' ? 80 : 21;
    return unless $port;

    if ( $ping->can('port_number') ) {
        $ping->port_number($port);
    }
    else {
        $ping->{'port_num'} = $port;
    }

    $ping->hires(1) if $ping->can('hires');
    my ($alive,$rtt) = eval { $ping->ping($self->hostname); };
    my $verbose = $args{verbose};
    if ($verbose && !$alive) {
        printf "(host %s not alive)", $self->hostname;
    }

    $self->{rtt} = $alive ? $rtt : undef;
    $self->{ping_time} = time;

    $self->rtt;
}


1;

=back

=head1 AUTHOR

Andreas Koenig C<< <andk@cpan.org> >>, David Golden C<< <dagolden@cpan.org> >>,
brian d foy C<< <bdfoy@cpan.org> >>

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut
PK     ü2]×!+“Ô Ô   Shell.pmnu ÏÃ6Ç$        package CPAN::Shell;
use strict;

# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:

use vars qw(
            $ADVANCED_QUERY
            $AUTOLOAD
            $COLOR_REGISTERED
            $Help
            $autoload_recursion
            $reload
            @ISA
            @relo
            $VERSION
           );
@relo =     (
             "CPAN.pm",
             "CPAN/Author.pm",
             "CPAN/CacheMgr.pm",
             "CPAN/Complete.pm",
             "CPAN/Debug.pm",
             "CPAN/DeferredCode.pm",
             "CPAN/Distribution.pm",
             "CPAN/Distroprefs.pm",
             "CPAN/Distrostatus.pm",
             "CPAN/Exception/RecursiveDependency.pm",
             "CPAN/Exception/yaml_not_installed.pm",
             "CPAN/FirstTime.pm",
             "CPAN/FTP.pm",
             "CPAN/FTP/netrc.pm",
             "CPAN/HandleConfig.pm",
             "CPAN/Index.pm",
             "CPAN/InfoObj.pm",
             "CPAN/Kwalify.pm",
             "CPAN/LWP/UserAgent.pm",
             "CPAN/Module.pm",
             "CPAN/Prompt.pm",
             "CPAN/Queue.pm",
             "CPAN/Reporter/Config.pm",
             "CPAN/Reporter/History.pm",
             "CPAN/Reporter/PrereqCheck.pm",
             "CPAN/Reporter.pm",
             "CPAN/Shell.pm",
             "CPAN/SQLite.pm",
             "CPAN/Tarzip.pm",
             "CPAN/Version.pm",
            );
$VERSION = "5.5009";
# record the initial timestamp for reload.
$reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo };
@CPAN::Shell::ISA = qw(CPAN::Debug);
use Cwd qw(chdir);
use Carp ();
$COLOR_REGISTERED ||= 0;
$Help = {
         '?' => \"help",
         '!' => "eval the rest of the line as perl",
         a => "whois author",
         autobundle => "write inventory into a bundle file",
         b => "info about bundle",
         bye => \"quit",
         clean => "clean up a distribution's build directory",
         # cvs_import
         d => "info about a distribution",
         # dump
         exit => \"quit",
         failed => "list all failed actions within current session",
         fforce => "redo a command from scratch",
         force => "redo a command",
         get => "download a distribution",
         h => \"help",
         help => "overview over commands; 'help ...' explains specific commands",
         hosts => "statistics about recently used hosts",
         i => "info about authors/bundles/distributions/modules",
         install => "install a distribution",
         install_tested => "install all distributions tested OK",
         is_tested => "list all distributions tested OK",
         look => "open a subshell in a distribution's directory",
         ls => "list distributions matching a fileglob",
         m => "info about a module",
         make => "make/build a distribution",
         mkmyconfig => "write current config into a CPAN/MyConfig.pm file",
         notest => "run a (usually install) command but leave out the test phase",
         o => "'o conf ...' for config stuff; 'o debug ...' for debugging",
         perldoc => "try to get a manpage for a module",
         q => \"quit",
         quit => "leave the cpan shell",
         r => "review upgradable modules",
         readme => "display the README of a distro with a pager",
         recent => "show recent uploads to the CPAN",
         # recompile
         reload => "'reload cpan' or 'reload index'",
         report => "test a distribution and send a test report to cpantesters",
         reports => "info about reported tests from cpantesters",
         # scripts
         # smoke
         test => "test a distribution",
         u => "display uninstalled modules",
         upgrade => "combine 'r' command with immediate installation",
        };
{
    $autoload_recursion   ||= 0;

    #-> sub CPAN::Shell::AUTOLOAD ;
    sub AUTOLOAD { ## no critic
        $autoload_recursion++;
        my($l) = $AUTOLOAD;
        my $class = shift(@_);
        # warn "autoload[$l] class[$class]";
        $l =~ s/.*:://;
        if ($CPAN::Signal) {
            warn "Refusing to autoload '$l' while signal pending";
            $autoload_recursion--;
            return;
        }
        if ($autoload_recursion > 1) {
            my $fullcommand = join " ", map { "'$_'" } $l, @_;
            warn "Refusing to autoload $fullcommand in recursion\n";
            $autoload_recursion--;
            return;
        }
        if ($l =~ /^w/) {
            # XXX needs to be reconsidered
            if ($CPAN::META->has_inst('CPAN::WAIT')) {
                CPAN::WAIT->$l(@_);
            } else {
                $CPAN::Frontend->mywarn(qq{
Commands starting with "w" require CPAN::WAIT to be installed.
Please consider installing CPAN::WAIT to use the fulltext index.
For this you just need to type
    install CPAN::WAIT
});
            }
        } else {
            $CPAN::Frontend->mywarn(qq{Unknown shell command '$l'. }.
                                    qq{Type ? for help.
});
        }
        $autoload_recursion--;
    }
}


#-> sub CPAN::Shell::h ;
sub h {
    my($class,$about) = @_;
    if (defined $about) {
        my $help;
        if (exists $Help->{$about}) {
            if (ref $Help->{$about}) { # aliases
                $about = ${$Help->{$about}};
            }
            $help = $Help->{$about};
        } else {
            $help = "No help available";
        }
        $CPAN::Frontend->myprint("$about\: $help\n");
    } else {
        my $filler = " " x (80 - 28 - length($CPAN::VERSION));
        $CPAN::Frontend->myprint(qq{
Display Information $filler (ver $CPAN::VERSION)
 command  argument          description
 a,b,d,m  WORD or /REGEXP/  about authors, bundles, distributions, modules
 i        WORD or /REGEXP/  about any of the above
 ls       AUTHOR or GLOB    about files in the author's directory
    (with WORD being a module, bundle or author name or a distribution
    name of the form AUTHOR/DISTRIBUTION)

Download, Test, Make, Install...
 get      download                     clean    make clean
 make     make (implies get)           look     open subshell in dist directory
 test     make test (implies make)     readme   display these README files
 install  make install (implies test)  perldoc  display POD documentation

Upgrade installed modules
 r        WORDs or /REGEXP/ or NONE    report updates for some/matching/all
 upgrade  WORDs or /REGEXP/ or NONE    upgrade some/matching/all modules

Pragmas
 force  CMD    try hard to do command  fforce CMD    try harder
 notest CMD    skip testing

Other
 h,?           display this menu       ! perl-code   eval a perl command
 o conf [opt]  set and query options   q             quit the cpan shell
 reload cpan   load CPAN.pm again      reload index  load newer indices
 autobundle    Snapshot                recent        latest CPAN uploads});
}
}

*help = \&h;

#-> sub CPAN::Shell::a ;
sub a {
  my($self,@arg) = @_;
  # authors are always UPPERCASE
  for (@arg) {
    $_ = uc $_ unless /=/;
  }
  $CPAN::Frontend->myprint($self->format_result('Author',@arg));
}

#-> sub CPAN::Shell::globls ;
sub globls {
    my($self,$s,$pragmas) = @_;
    # ls is really very different, but we had it once as an ordinary
    # command in the Shell (up to rev. 321) and we could not handle
    # force well then
    my(@accept,@preexpand);
    if ($s =~ /[\*\?\/]/) {
        if ($CPAN::META->has_inst("Text::Glob")) {
            if (my($au,$pathglob) = $s =~ m|(.*?)/(.*)|) {
                my $rau = Text::Glob::glob_to_regex(uc $au);
                CPAN::Shell->debug("au[$au]pathglob[$pathglob]rau[$rau]")
                      if $CPAN::DEBUG;
                push @preexpand, map { $_->id . "/" . $pathglob }
                    CPAN::Shell->expand_by_method('CPAN::Author',['id'],"/$rau/");
            } else {
                my $rau = Text::Glob::glob_to_regex(uc $s);
                push @preexpand, map { $_->id }
                    CPAN::Shell->expand_by_method('CPAN::Author',
                                                  ['id'],
                                                  "/$rau/");
            }
        } else {
            $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
        }
    } else {
        push @preexpand, uc $s;
    }
    for (@preexpand) {
        unless (/^[A-Z0-9\-]+(\/|$)/i) {
            $CPAN::Frontend->mywarn("ls command rejects argument $_: not an author\n");
            next;
        }
        push @accept, $_;
    }
    my $silent = @accept>1;
    my $last_alpha = "";
    my @results;
    for my $a (@accept) {
        my($author,$pathglob);
        if ($a =~ m|(.*?)/(.*)|) {
            my $a2 = $1;
            $pathglob = $2;
            $author = CPAN::Shell->expand_by_method('CPAN::Author',
                                                    ['id'],
                                                    $a2)
                or $CPAN::Frontend->mydie("No author found for $a2\n");
        } else {
            $author = CPAN::Shell->expand_by_method('CPAN::Author',
                                                    ['id'],
                                                    $a)
                or $CPAN::Frontend->mydie("No author found for $a\n");
        }
        if ($silent) {
            my $alpha = substr $author->id, 0, 1;
            my $ad;
            if ($alpha eq $last_alpha) {
                $ad = "";
            } else {
                $ad = "[$alpha]";
                $last_alpha = $alpha;
            }
            $CPAN::Frontend->myprint($ad);
        }
        for my $pragma (@$pragmas) {
            if ($author->can($pragma)) {
                $author->$pragma();
            }
        }
        CPAN->debug("author[$author]pathglob[$pathglob]silent[$silent]") if $CPAN::DEBUG;
        push @results, $author->ls($pathglob,$silent); # silent if
                                                       # more than one
                                                       # author
        for my $pragma (@$pragmas) {
            my $unpragma = "un$pragma";
            if ($author->can($unpragma)) {
                $author->$unpragma();
            }
        }
    }
    @results;
}

#-> sub CPAN::Shell::local_bundles ;
sub local_bundles {
    my($self,@which) = @_;
    my($incdir,$bdir,$dh);
    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
        my @bbase = "Bundle";
        while (my $bbase = shift @bbase) {
            $bdir = File::Spec->catdir($incdir,split /::/, $bbase);
            CPAN->debug("bdir[$bdir]\@bbase[@bbase]") if $CPAN::DEBUG;
            if ($dh = DirHandle->new($bdir)) { # may fail
                my($entry);
                for $entry ($dh->read) {
                    next if $entry =~ /^\./;
                    next unless $entry =~ /^\w+(\.pm)?(?!\n)\Z/;
                    if (-d File::Spec->catdir($bdir,$entry)) {
                        push @bbase, "$bbase\::$entry";
                    } else {
                        next unless $entry =~ s/\.pm(?!\n)\Z//;
                        $CPAN::META->instance('CPAN::Bundle',"$bbase\::$entry");
                    }
                }
            }
        }
    }
}

#-> sub CPAN::Shell::b ;
sub b {
    my($self,@which) = @_;
    CPAN->debug("which[@which]") if $CPAN::DEBUG;
    $self->local_bundles;
    $CPAN::Frontend->myprint($self->format_result('Bundle',@which));
}

#-> sub CPAN::Shell::d ;
sub d { $CPAN::Frontend->myprint(shift->format_result('Distribution',@_));}

#-> sub CPAN::Shell::m ;
sub m { # emacs confused here }; sub mimimimimi { # emacs in sync here
    my $self = shift;
    my @m = @_;
    for (@m) {
        if (m|(?:\w+/)*\w+\.pm$|) { # same regexp in expandany
            s/.pm$//;
            s|/|::|g;
        }
    }
    $CPAN::Frontend->myprint($self->format_result('Module',@m));
}

#-> sub CPAN::Shell::i ;
sub i {
    my($self) = shift;
    my(@args) = @_;
    @args = '/./' unless @args;
    my(@result);
    for my $type (qw/Bundle Distribution Module/) {
        push @result, $self->expand($type,@args);
    }
    # Authors are always uppercase.
    push @result, $self->expand("Author", map { uc $_ } @args);

    my $result = @result == 1 ?
        $result[0]->as_string :
            @result == 0 ?
                "No objects found of any type for argument @args\n" :
                    join("",
                         (map {$_->as_glimpse} @result),
                         scalar @result, " items found\n",
                        );
    $CPAN::Frontend->myprint($result);
}

#-> sub CPAN::Shell::o ;

# CPAN::Shell::o and CPAN::HandleConfig::edit are closely related. 'o
# conf' calls through to CPAN::HandleConfig::edit. 'o conf' should
# probably have been called 'set' and 'o debug' maybe 'set debug' or
# 'debug'; 'o conf ARGS' calls ->edit in CPAN/HandleConfig.pm
sub o {
    my($self,$o_type,@o_what) = @_;
    $o_type ||= "";
    CPAN->debug("o_type[$o_type] o_what[".join(" | ",@o_what)."]\n");
    if ($o_type eq 'conf') {
        my($cfilter);
        ($cfilter) = $o_what[0] =~ m|^/(.*)/$| if @o_what;
        if (!@o_what or $cfilter) { # print all things, "o conf"
            $cfilter ||= "";
            my $qrfilter = eval 'qr/$cfilter/';
            if ($@) {
                $CPAN::Frontend->mydie("Cannot parse commandline: $@");
            }
            my($k,$v);
            my $configpm = CPAN::HandleConfig->require_myconfig_or_config;
            $CPAN::Frontend->myprint("\$CPAN::Config options from $configpm\:\n");
            for $k (sort keys %CPAN::HandleConfig::can) {
                next unless $k =~ /$qrfilter/;
                $v = $CPAN::HandleConfig::can{$k};
                $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
            }
            $CPAN::Frontend->myprint("\n");
            for $k (sort keys %CPAN::HandleConfig::keys) {
                next unless $k =~ /$qrfilter/;
                CPAN::HandleConfig->prettyprint($k);
            }
            $CPAN::Frontend->myprint("\n");
        } else {
            if (CPAN::HandleConfig->edit(@o_what)) {
            } else {
                $CPAN::Frontend->myprint(qq{Type 'o conf' to view all configuration }.
                                         qq{items\n\n});
            }
        }
    } elsif ($o_type eq 'debug') {
        my(%valid);
        @o_what = () if defined $o_what[0] && $o_what[0] =~ /help/i;
        if (@o_what) {
            while (@o_what) {
                my($what) = shift @o_what;
                if ($what =~ s/^-// && exists $CPAN::DEBUG{$what}) {
                    $CPAN::DEBUG &= $CPAN::DEBUG ^ $CPAN::DEBUG{$what};
                    next;
                }
                if ( exists $CPAN::DEBUG{$what} ) {
                    $CPAN::DEBUG |= $CPAN::DEBUG{$what};
                } elsif ($what =~ /^\d/) {
                    $CPAN::DEBUG = $what;
                } elsif (lc $what eq 'all') {
                    my($max) = 0;
                    for (values %CPAN::DEBUG) {
                        $max += $_;
                    }
                    $CPAN::DEBUG = $max;
                } else {
                    my($known) = 0;
                    for (keys %CPAN::DEBUG) {
                        next unless lc($_) eq lc($what);
                        $CPAN::DEBUG |= $CPAN::DEBUG{$_};
                        $known = 1;
                    }
                    $CPAN::Frontend->myprint("unknown argument [$what]\n")
                        unless $known;
                }
            }
        } else {
            my $raw = "Valid options for debug are ".
                join(", ",sort(keys %CPAN::DEBUG), 'all').
                     qq{ or a number. Completion works on the options. }.
                     qq{Case is ignored.};
            require Text::Wrap;
            $CPAN::Frontend->myprint(Text::Wrap::fill("","",$raw));
            $CPAN::Frontend->myprint("\n\n");
        }
        if ($CPAN::DEBUG) {
            $CPAN::Frontend->myprint("Options set for debugging ($CPAN::DEBUG):\n");
            my($k,$v);
            for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
                $v = $CPAN::DEBUG{$k};
                $CPAN::Frontend->myprint(sprintf "    %-14s(%s)\n", $k, $v)
                    if $v & $CPAN::DEBUG;
            }
        } else {
            $CPAN::Frontend->myprint("Debugging turned off completely.\n");
        }
    } else {
        $CPAN::Frontend->myprint(qq{
Known options:
  conf    set or get configuration variables
  debug   set or get debugging options
});
    }
}

# CPAN::Shell::paintdots_onreload
sub paintdots_onreload {
    my($ref) = shift;
    sub {
        if ( $_[0] =~ /[Ss]ubroutine ([\w:]+) redefined/ ) {
            my($subr) = $1;
            ++$$ref;
            local($|) = 1;
            # $CPAN::Frontend->myprint(".($subr)");
            $CPAN::Frontend->myprint(".");
            if ($subr =~ /\bshell\b/i) {
                # warn "debug[$_[0]]";

                # It would be nice if we could detect that a
                # subroutine has actually changed, but for now we
                # practically always set the GOTOSHELL global

                $CPAN::GOTOSHELL=1;
            }
            return;
        }
        warn @_;
    };
}

#-> sub CPAN::Shell::hosts ;
sub hosts {
    my($self) = @_;
    my $fullstats = CPAN::FTP->_ftp_statistics();
    my $history = $fullstats->{history} || [];
    my %S; # statistics
    while (my $last = pop @$history) {
        my $attempts = $last->{attempts} or next;
        my $start;
        if (@$attempts) {
            $start = $attempts->[-1]{start};
            if ($#$attempts > 0) {
                for my $i (0..$#$attempts-1) {
                    my $url = $attempts->[$i]{url} or next;
                    $S{no}{$url}++;
                }
            }
        } else {
            $start = $last->{start};
        }
        next unless $last->{thesiteurl}; # C-C? bad filenames?
        $S{start} = $start;
        $S{end} ||= $last->{end};
        my $dltime = $last->{end} - $start;
        my $dlsize = $last->{filesize} || 0;
        my $url = ref $last->{thesiteurl} ? $last->{thesiteurl}->text : $last->{thesiteurl};
        my $s = $S{ok}{$url} ||= {};
        $s->{n}++;
        $s->{dlsize} ||= 0;
        $s->{dlsize} += $dlsize/1024;
        $s->{dltime} ||= 0;
        $s->{dltime} += $dltime;
    }
    my $res;
    for my $url (sort keys %{$S{ok}}) {
        next if $S{ok}{$url}{dltime} == 0; # div by zero
        push @{$res->{ok}}, [@{$S{ok}{$url}}{qw(n dlsize dltime)},
                             $S{ok}{$url}{dlsize}/$S{ok}{$url}{dltime},
                             $url,
                            ];
    }
    for my $url (sort keys %{$S{no}}) {
        push @{$res->{no}}, [$S{no}{$url},
                             $url,
                            ];
    }
    my $R = ""; # report
    if ($S{start} && $S{end}) {
        $R .= sprintf "Log starts: %s\n", $S{start} ? scalar(localtime $S{start}) : "unknown";
        $R .= sprintf "Log ends  : %s\n", $S{end}   ? scalar(localtime $S{end})   : "unknown";
    }
    if ($res->{ok} && @{$res->{ok}}) {
        $R .= sprintf "\nSuccessful downloads:
   N       kB  secs      kB/s url\n";
        my $i = 20;
        for (sort { $b->[3] <=> $a->[3] } @{$res->{ok}}) {
            $R .= sprintf "%4d %8d %5d %9.1f %s\n", @$_;
            last if --$i<=0;
        }
    }
    if ($res->{no} && @{$res->{no}}) {
        $R .= sprintf "\nUnsuccessful downloads:\n";
        my $i = 20;
        for (sort { $b->[0] <=> $a->[0] } @{$res->{no}}) {
            $R .= sprintf "%4d %s\n", @$_;
            last if --$i<=0;
        }
    }
    $CPAN::Frontend->myprint($R);
}

# here is where 'reload cpan' is done
#-> sub CPAN::Shell::reload ;
sub reload {
    my($self,$command,@arg) = @_;
    $command ||= "";
    $self->debug("self[$self]command[$command]arg[@arg]") if $CPAN::DEBUG;
    if ($command =~ /^cpan$/i) {
        my $redef = 0;
        chdir "$CPAN::iCwd" if $CPAN::iCwd; # may fail
        my $failed;
      MFILE: for my $f (@relo) {
            next unless exists $INC{$f};
            my $p = $f;
            $p =~ s/\.pm$//;
            $p =~ s|/|::|g;
            $CPAN::Frontend->myprint("($p");
            local($SIG{__WARN__}) = paintdots_onreload(\$redef);
            $self->_reload_this($f) or $failed++;
            my $v = eval "$p\::->VERSION";
            $CPAN::Frontend->myprint("v$v)");
        }
        $CPAN::Frontend->myprint("\n$redef subroutines redefined\n");
        if ($failed) {
            my $errors = $failed == 1 ? "error" : "errors";
            $CPAN::Frontend->mywarn("\n$failed $errors during reload. You better quit ".
                                    "this session.\n");
        }
    } elsif ($command =~ /^index$/i) {
      CPAN::Index->force_reload;
    } else {
      $CPAN::Frontend->myprint(qq{cpan     re-evals the CPAN modules
index    re-reads the index files\n});
    }
}

# reload means only load again what we have loaded before
#-> sub CPAN::Shell::_reload_this ;
sub _reload_this {
    my($self,$f,$args) = @_;
    CPAN->debug("f[$f]") if $CPAN::DEBUG;
    return 1 unless $INC{$f}; # we never loaded this, so we do not
                              # reload but say OK
    my $pwd = CPAN::anycwd();
    CPAN->debug("pwd[$pwd]") if $CPAN::DEBUG;
    my($file);
    for my $inc (@INC) {
        $file = File::Spec->catfile($inc,split /\//, $f);
        last if -f $file;
        $file = "";
    }
    CPAN->debug("file[$file]") if $CPAN::DEBUG;
    my @inc = @INC;
    unless ($file && -f $file) {
        # this thingy is not in the INC path, maybe CPAN/MyConfig.pm?
        $file = $INC{$f};
        unless (CPAN->has_inst("File::Basename")) {
            @inc = File::Basename::dirname($file);
        } else {
            # do we ever need this?
            @inc = substr($file,0,-length($f)-1); # bring in back to me!
        }
    }
    CPAN->debug("file[$file]inc[@inc]") if $CPAN::DEBUG;
    unless (-f $file) {
        $CPAN::Frontend->mywarn("Found no file to reload for '$f'\n");
        return;
    }
    my $mtime = (stat $file)[9];
    $reload->{$f} ||= -1;
    my $must_reload = $mtime != $reload->{$f};
    $args ||= {};
    $must_reload ||= $args->{reloforce}; # o conf defaults needs this
    if ($must_reload) {
        my $fh = FileHandle->new($file) or
            $CPAN::Frontend->mydie("Could not open $file: $!");
        my $content;
        {
            local($/);
            local $^W = 1;
            $content = <$fh>;
        }
        CPAN->debug(sprintf("reload file[%s] content[%s...]",$file,substr($content,0,128)))
            if $CPAN::DEBUG;
        my $includefile;
        if ($includefile = $INC{$f} and -e $includefile) {
            $f = $includefile;
        }
        delete $INC{$f};
        local @INC = @inc;
        eval "require '$f'";
        if ($@) {
            warn $@;
            return;
        }
        $reload->{$f} = $mtime;
    } else {
        $CPAN::Frontend->myprint("__unchanged__");
    }
    return 1;
}

#-> sub CPAN::Shell::mkmyconfig ;
sub mkmyconfig {
    my($self) = @_;
    if ( my $configpm = $INC{'CPAN/MyConfig.pm'} ) {
        $CPAN::Frontend->myprint(
            "CPAN::MyConfig already exists as $configpm.\n" .
            "Running configuration again...\n"
        );
        require CPAN::FirstTime;
        CPAN::FirstTime::init($configpm);
    }
    else {
        # force some missing values to be filled in with defaults
        delete $CPAN::Config->{$_}
            for qw/build_dir cpan_home keep_source_where histfile/;
        CPAN::HandleConfig->load( make_myconfig => 1 );
    }
}

#-> sub CPAN::Shell::_binary_extensions ;
sub _binary_extensions {
    my($self) = shift @_;
    my(@result,$module,%seen,%need,$headerdone);
    for $module ($self->expand('Module','/./')) {
        my $file  = $module->cpan_file;
        next if $file eq "N/A";
        next if $file =~ /^Contact Author/;
        my $dist = $CPAN::META->instance('CPAN::Distribution',$file);
        next if $dist->isa_perl;
        next unless $module->xs_file;
        local($|) = 1;
        $CPAN::Frontend->myprint(".");
        push @result, $module;
    }
#    print join " | ", @result;
    $CPAN::Frontend->myprint("\n");
    return @result;
}

#-> sub CPAN::Shell::recompile ;
sub recompile {
    my($self) = shift @_;
    my($module,@module,$cpan_file,%dist);
    @module = $self->_binary_extensions();
    for $module (@module) { # we force now and compile later, so we
                            # don't do it twice
        $cpan_file = $module->cpan_file;
        my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
        $pack->force;
        $dist{$cpan_file}++;
    }
    for $cpan_file (sort keys %dist) {
        $CPAN::Frontend->myprint("  CPAN: Recompiling $cpan_file\n\n");
        my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
        $pack->install;
        $CPAN::Signal = 0; # it's tempting to reset Signal, so we can
                           # stop a package from recompiling,
                           # e.g. IO-1.12 when we have perl5.003_10
    }
}

#-> sub CPAN::Shell::scripts ;
sub scripts {
    my($self, $arg) = @_;
    $CPAN::Frontend->mywarn(">>>> experimental command, currently unsupported <<<<\n\n");

    for my $req (qw( HTML::LinkExtor Sort::Versions List::Util )) {
        unless ($CPAN::META->has_inst($req)) {
            $CPAN::Frontend->mywarn("  $req not available\n");
        }
    }
    my $p = HTML::LinkExtor->new();
    my $indexfile = "/home/ftp/pub/PAUSE/scripts/new/index.html";
    unless (-f $indexfile) {
        $CPAN::Frontend->mydie("found no indexfile[$indexfile]\n");
    }
    $p->parse_file($indexfile);
    my @hrefs;
    my $qrarg;
    if ($arg =~ s|^/(.+)/$|$1|) {
        $qrarg = eval 'qr/$arg/'; # hide construct from 5.004
    }
    for my $l ($p->links) {
        my $tag = shift @$l;
        next unless $tag eq "a";
        my %att = @$l;
        my $href = $att{href};
        next unless $href =~ s|^\.\./authors/id/./../||;
        if ($arg) {
            if ($qrarg) {
                if ($href =~ $qrarg) {
                    push @hrefs, $href;
                }
            } else {
                if ($href =~ /\Q$arg\E/) {
                    push @hrefs, $href;
                }
            }
        } else {
            push @hrefs, $href;
        }
    }
    # now filter for the latest version if there is more than one of a name
    my %stems;
    for (sort @hrefs) {
        my $href = $_;
        s/-v?\d.*//;
        my $stem = $_;
        $stems{$stem} ||= [];
        push @{$stems{$stem}}, $href;
    }
    for (sort keys %stems) {
        my $highest;
        if (@{$stems{$_}} > 1) {
            $highest = List::Util::reduce {
                Sort::Versions::versioncmp($a,$b) > 0 ? $a : $b
              } @{$stems{$_}};
        } else {
            $highest = $stems{$_}[0];
        }
        $CPAN::Frontend->myprint("$highest\n");
    }
}

sub _guess_manpage {
    my($self,$d,$contains,$dist) = @_;
    $dist =~ s/-/::/g;
    my $module;
    if (exists $contains->{$dist}) {
        $module = $dist;
    } elsif (1 == keys %$contains) {
        ($module) = keys %$contains;
    }
    my $manpage;
    if ($module) {
        my $m = $self->expand("Module",$module);
        $m->as_string; # called for side-effects, shame
        $manpage = $m->{MANPAGE};
    } else {
        $manpage = "unknown";
    }
    return $manpage;
}

#-> sub CPAN::Shell::_specfile ;
sub _specfile {
    die "CPAN::Shell::_specfile() has been moved to CPAN::Plugin::Specfile::post_test()";
}

#-> sub CPAN::Shell::report ;
sub report {
    my($self,@args) = @_;
    unless ($CPAN::META->has_inst("CPAN::Reporter")) {
        $CPAN::Frontend->mydie("CPAN::Reporter not installed; cannot continue");
    }
    local $CPAN::Config->{test_report} = 1;
    $self->force("test",@args); # force is there so that the test be
                                # re-run (as documented)
}

# compare with is_tested
#-> sub CPAN::Shell::install_tested
sub install_tested {
    my($self,@some) = @_;
    $CPAN::Frontend->mywarn("install_tested() must not be called with arguments.\n"),
        return if @some;
    CPAN::Index->reload;

    for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
        my $yaml = "$b.yml";
        unless (-f $yaml) {
            $CPAN::Frontend->mywarn("No YAML file for $b available, skipping\n");
            next;
        }
        my $yaml_content = CPAN->_yaml_loadfile($yaml);
        my $id = $yaml_content->[0]{distribution}{ID};
        unless ($id) {
            $CPAN::Frontend->mywarn("No ID found in '$yaml', skipping\n");
            next;
        }
        my $do = CPAN::Shell->expandany($id);
        unless ($do) {
            $CPAN::Frontend->mywarn("Could not expand ID '$id', skipping\n");
            next;
        }
        unless ($do->{build_dir}) {
            $CPAN::Frontend->mywarn("Distro '$id' has no build_dir, skipping\n");
            next;
        }
        unless ($do->{build_dir} eq $b) {
            $CPAN::Frontend->mywarn("Distro '$id' has build_dir '$do->{build_dir}' but expected '$b', skipping\n");
            next;
        }
        push @some, $do;
    }

    $CPAN::Frontend->mywarn("No tested distributions found.\n"),
        return unless @some;

    @some = grep { $_->{make_test} && ! $_->{make_test}->failed } @some;
    $CPAN::Frontend->mywarn("No distributions tested with this build of perl found.\n"),
        return unless @some;

    # @some = grep { not $_->uptodate } @some;
    # $CPAN::Frontend->mywarn("No non-uptodate distributions tested with this build of perl found.\n"),
    #     return unless @some;

    CPAN->debug("some[@some]");
    for my $d (@some) {
        my $id = $d->can("pretty_id") ? $d->pretty_id : $d->id;
        $CPAN::Frontend->myprint("install_tested: Running for $id\n");
        $CPAN::Frontend->mysleep(1);
        $self->install($d);
    }
}

#-> sub CPAN::Shell::upgrade ;
sub upgrade {
    my($self,@args) = @_;
    $self->install($self->r(@args));
}

#-> sub CPAN::Shell::_u_r_common ;
sub _u_r_common {
    my($self) = shift @_;
    my($what) = shift @_;
    CPAN->debug("self[$self] what[$what] args[@_]") if $CPAN::DEBUG;
    Carp::croak "Usage: \$obj->_u_r_common(a|r|u)" unless
          $what && $what =~ /^[aru]$/;
    my(@args) = @_;
    @args = '/./' unless @args;
    my(@result,$module,%seen,%need,$headerdone,
       $version_undefs,$version_zeroes,
       @version_undefs,@version_zeroes);
    $version_undefs = $version_zeroes = 0;
    my $sprintf = "%s%-25s%s %9s %9s  %s\n";
    my @expand = $self->expand('Module',@args);
    if ($CPAN::DEBUG) { # Looks like noise to me, was very useful for debugging
             # for metadata cache
        my $expand = scalar @expand;
        $CPAN::Frontend->myprint(sprintf "%d matches in the database, time[%d]\n", $expand, time);
    }
    my @sexpand;
    if ($] < 5.008) {
        # hard to believe that the more complex sorting can lead to
        # stack curruptions on older perl
        @sexpand = sort {$a->id cmp $b->id} @expand;
    } else {
        @sexpand = map {
            $_->[1]
        } sort {
            $b->[0] <=> $a->[0]
            ||
            $a->[1]{ID} cmp $b->[1]{ID},
        } map {
            [$_->_is_representative_module,
             $_
            ]
        } @expand;
    }
    if ($CPAN::DEBUG) {
        $CPAN::Frontend->myprint(sprintf "sorted at time[%d]\n", time);
        sleep 1;
    }
  MODULE: for $module (@sexpand) {
        my $file  = $module->cpan_file;
        next MODULE unless defined $file; # ??
        $file =~ s!^./../!!;
        my($latest) = $module->cpan_version;
        my($inst_file) = $module->inst_file;
        CPAN->debug("file[$file]latest[$latest]") if $CPAN::DEBUG;
        my($have);
        return if $CPAN::Signal;
        my($next_MODULE);
        eval { # version.pm involved!
            if ($inst_file) {
                if ($what eq "a") {
                    $have = $module->inst_version;
                } elsif ($what eq "r") {
                    $have = $module->inst_version;
                    local($^W) = 0;
                    if ($have eq "undef") {
                        $version_undefs++;
                        push @version_undefs, $module->as_glimpse;
                    } elsif (CPAN::Version->vcmp($have,0)==0) {
                        $version_zeroes++;
                        push @version_zeroes, $module->as_glimpse;
                    }
                    ++$next_MODULE unless CPAN::Version->vgt($latest, $have);
                    # to be pedantic we should probably say:
                    #    && !($have eq "undef" && $latest ne "undef" && $latest gt "");
                    # to catch the case where CPAN has a version 0 and we have a version undef
                } elsif ($what eq "u") {
                    ++$next_MODULE;
                }
            } else {
                if ($what eq "a") {
                    ++$next_MODULE;
                } elsif ($what eq "r") {
                    ++$next_MODULE;
                } elsif ($what eq "u") {
                    $have = "-";
                }
            }
        };
        next MODULE if $next_MODULE;
        if ($@) {
            $CPAN::Frontend->mywarn
                (sprintf("Error while comparing cpan/installed versions of '%s':
INST_FILE: %s
INST_VERSION: %s %s
CPAN_VERSION: %s %s
",
                         $module->id,
                         $inst_file || "",
                         (defined $have ? $have : "[UNDEFINED]"),
                         (ref $have ? ref $have : ""),
                         $latest,
                         (ref $latest ? ref $latest : ""),
                        ));
            next MODULE;
        }
        return if $CPAN::Signal; # this is sometimes lengthy
        $seen{$file} ||= 0;
        if ($what eq "a") {
            push @result, sprintf "%s %s\n", $module->id, $have;
        } elsif ($what eq "r") {
            push @result, $module->id;
            next MODULE if $seen{$file}++;
        } elsif ($what eq "u") {
            push @result, $module->id;
            next MODULE if $seen{$file}++;
            next MODULE if $file =~ /^Contact/;
        }
        unless ($headerdone++) {
            $CPAN::Frontend->myprint("\n");
            $CPAN::Frontend->myprint(sprintf(
                                             $sprintf,
                                             "",
                                             "Package namespace",
                                             "",
                                             "installed",
                                             "latest",
                                             "in CPAN file"
                                            ));
        }
        my $color_on = "";
        my $color_off = "";
        if (
            $COLOR_REGISTERED
            &&
            $CPAN::META->has_inst("Term::ANSIColor")
            &&
            $module->description
           ) {
            $color_on = Term::ANSIColor::color("green");
            $color_off = Term::ANSIColor::color("reset");
        }
        $CPAN::Frontend->myprint(sprintf $sprintf,
                                 $color_on,
                                 $module->id,
                                 $color_off,
                                 $have,
                                 $latest,
                                 $file);
        $need{$module->id}++;
    }
    unless (%need) {
        if (!@expand || $what eq "u") {
            $CPAN::Frontend->myprint("No modules found for @args\n");
        } elsif ($what eq "r") {
            $CPAN::Frontend->myprint("All modules are up to date for @args\n");
        }
    }
    if ($what eq "r") {
        if ($version_zeroes) {
            my $s_has = $version_zeroes > 1 ? "s have" : " has";
            $CPAN::Frontend->myprint(qq{$version_zeroes installed module$s_has }.
                                     qq{a version number of 0\n});
            if ($CPAN::Config->{show_zero_versions}) {
                local $" = "\t";
                $CPAN::Frontend->myprint(qq{  they are\n\t@version_zeroes\n});
                $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 0' }.
                                         qq{to hide them)\n});
            } else {
                $CPAN::Frontend->myprint(qq{(use 'o conf show_zero_versions 1' }.
                                         qq{to show them)\n});
            }
        }
        if ($version_undefs) {
            my $s_has = $version_undefs > 1 ? "s have" : " has";
            $CPAN::Frontend->myprint(qq{$version_undefs installed module$s_has no }.
                                     qq{parsable version number\n});
            if ($CPAN::Config->{show_unparsable_versions}) {
                local $" = "\t";
                $CPAN::Frontend->myprint(qq{  they are\n\t@version_undefs\n});
                $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 0' }.
                                         qq{to hide them)\n});
            } else {
                $CPAN::Frontend->myprint(qq{(use 'o conf show_unparsable_versions 1' }.
                                         qq{to show them)\n});
            }
        }
    }
    @result;
}

#-> sub CPAN::Shell::r ;
sub r {
    shift->_u_r_common("r",@_);
}

#-> sub CPAN::Shell::u ;
sub u {
    shift->_u_r_common("u",@_);
}

#-> sub CPAN::Shell::failed ;
sub failed {
    my($self,$only_id,$silent) = @_;
    my @failed = $self->find_failed($only_id);
    my $scope;
    if ($only_id) {
        $scope = "this command";
    } elsif ($CPAN::Index::HAVE_REANIMATED) {
        $scope = "this or a previous session";
        # it might be nice to have a section for previous session and
        # a second for this
    } else {
        $scope = "this session";
    }
    if (@failed) {
        my $print;
        my $debug = 0;
        if ($debug) {
            $print = join "",
                map { sprintf "%5d %-45s: %s %s\n", @$_ }
                    sort { $a->[0] <=> $b->[0] } @failed;
        } else {
            $print = join "",
                map { sprintf " %-45s: %s %s\n", @$_[1..3] }
                    sort {
                        $a->[0] <=> $b->[0]
                            ||
                                $a->[4] <=> $b->[4]
                       } @failed;
        }
        $CPAN::Frontend->myprint("Failed during $scope:\n$print");
    } elsif (!$only_id || !$silent) {
        $CPAN::Frontend->myprint("Nothing failed in $scope\n");
    }
}

sub find_failed {
    my($self,$only_id) = @_;
    my @failed;
  DIST: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) {
        my $failed = "";
      NAY: for my $nosayer ( # order matters!
                            "unwrapped",
                            "writemakefile",
                            "signature_verify",
                            "make",
                            "make_test",
                            "install",
                            "make_clean",
                           ) {
            next unless exists $d->{$nosayer};
            next unless defined $d->{$nosayer};
            next unless (
                         UNIVERSAL::can($d->{$nosayer},"failed") ?
                         $d->{$nosayer}->failed :
                         $d->{$nosayer} =~ /^NO/
                        );
            next NAY if $only_id && $only_id != (
                                                 UNIVERSAL::can($d->{$nosayer},"commandid")
                                                 ?
                                                 $d->{$nosayer}->commandid
                                                 :
                                                 $CPAN::CurrentCommandId
                                                );
            $failed = $nosayer;
            last;
        }
        next DIST unless $failed;
        my $id = $d->id;
        $id =~ s|^./../||;
        ### XXX need to flag optional modules as '(optional)' if they are
        # from recommends/suggests -- i.e. *show* failure, but make it clear
        # it was failure of optional module -- xdg, 2012-04-01
        $id = "(optional) $id" if ! $d->{mandatory};
        #$print .= sprintf(
        #                  "  %-45s: %s %s\n",
        push @failed,
            (
             UNIVERSAL::can($d->{$failed},"failed") ?
             [
              $d->{$failed}->commandid,
              $id,
              $failed,
              $d->{$failed}->text,
              $d->{$failed}{TIME}||0,
              !! $d->{mandatory},
             ] :
             [
              1,
              $id,
              $failed,
              $d->{$failed},
              0,
              !! $d->{mandatory},
             ]
            );
    }
    return @failed;
}

sub mandatory_dist_failed {
    my ($self) = @_;
    return grep { $_->[5] } $self->find_failed($CPAN::CurrentCommandID);
}

# XXX intentionally undocumented because completely bogus, unportable,
# useless, etc.

#-> sub CPAN::Shell::status ;
sub status {
    my($self) = @_;
    require Devel::Size;
    my $ps = FileHandle->new;
    open $ps, "/proc/$$/status";
    my $vm = 0;
    while (<$ps>) {
        next unless /VmSize:\s+(\d+)/;
        $vm = $1;
        last;
    }
    $CPAN::Frontend->mywarn(sprintf(
                                    "%-27s %6d\n%-27s %6d\n",
                                    "vm",
                                    $vm,
                                    "CPAN::META",
                                    Devel::Size::total_size($CPAN::META)/1024,
                                   ));
    for my $k (sort keys %$CPAN::META) {
        next unless substr($k,0,4) eq "read";
        warn sprintf " %-26s %6d\n", $k, Devel::Size::total_size($CPAN::META->{$k})/1024;
        for my $k2 (sort keys %{$CPAN::META->{$k}}) {
            warn sprintf "  %-25s %6d (keys: %6d)\n",
                $k2,
                    Devel::Size::total_size($CPAN::META->{$k}{$k2})/1024,
                          scalar keys %{$CPAN::META->{$k}{$k2}};
        }
    }
}

# compare with install_tested
#-> sub CPAN::Shell::is_tested
sub is_tested {
    my($self) = @_;
    CPAN::Index->reload;
    for my $b (reverse $CPAN::META->_list_sorted_descending_is_tested) {
        my $time;
        if ($CPAN::META->{is_tested}{$b}) {
            $time = scalar(localtime $CPAN::META->{is_tested}{$b});
        } else {
            $time = scalar localtime;
            $time =~ s/\S/?/g;
        }
        $CPAN::Frontend->myprint(sprintf "%s %s\n", $time, $b);
    }
}

#-> sub CPAN::Shell::autobundle ;
sub autobundle {
    my($self) = shift;
    CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
    my(@bundle) = $self->_u_r_common("a",@_);
    my($todir) = File::Spec->catdir($CPAN::Config->{'cpan_home'},"Bundle");
    File::Path::mkpath($todir);
    unless (-d $todir) {
        $CPAN::Frontend->myprint("Couldn't mkdir $todir for some reason\n");
        return;
    }
    my($y,$m,$d) =  (localtime)[5,4,3];
    $y+=1900;
    $m++;
    my($c) = 0;
    my($me) = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, $c;
    my($to) = File::Spec->catfile($todir,"$me.pm");
    while (-f $to) {
        $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
        $to = File::Spec->catfile($todir,"$me.pm");
    }
    my($fh) = FileHandle->new(">$to") or Carp::croak "Can't open >$to: $!";
    $fh->print(
               "package Bundle::$me;\n\n",
               "\$","VERSION = '0.01';\n\n", # hide from perl-reversion
               "1;\n\n",
               "__END__\n\n",
               "=head1 NAME\n\n",
               "Bundle::$me - Snapshot of installation on ",
               $Config::Config{'myhostname'},
               " on ",
               scalar(localtime),
               "\n\n=head1 SYNOPSIS\n\n",
               "perl -MCPAN -e 'install Bundle::$me'\n\n",
               "=head1 CONTENTS\n\n",
               join("\n", @bundle),
               "\n\n=head1 CONFIGURATION\n\n",
               Config->myconfig,
               "\n\n=head1 AUTHOR\n\n",
               "This Bundle has been generated automatically ",
               "by the autobundle routine in CPAN.pm.\n",
              );
    $fh->close;
    $CPAN::Frontend->myprint("\nWrote bundle file
    $to\n\n");
    return $to;
}

#-> sub CPAN::Shell::expandany ;
sub expandany {
    my($self,$s) = @_;
    CPAN->debug("s[$s]") if $CPAN::DEBUG;
    my $module_as_path = "";
    if ($s =~ m|(?:\w+/)*\w+\.pm$|) { # same regexp in sub m
        $module_as_path = $s;
        $module_as_path =~ s/.pm$//;
        $module_as_path =~ s|/|::|g;
    }
    if ($module_as_path) {
        if ($module_as_path =~ m|^Bundle::|) {
            $self->local_bundles;
            return $self->expand('Bundle',$module_as_path);
        } else {
            return $self->expand('Module',$module_as_path)
                if $CPAN::META->exists('CPAN::Module',$module_as_path);
        }
    } elsif ($s =~ m|/| or substr($s,-1,1) eq ".") { # looks like a file or a directory
        $s = CPAN::Distribution->normalize($s);
        return $CPAN::META->instance('CPAN::Distribution',$s);
        # Distributions spring into existence, not expand
    } elsif ($s =~ m|^Bundle::|) {
        $self->local_bundles; # scanning so late for bundles seems
                              # both attractive and crumpy: always
                              # current state but easy to forget
                              # somewhere
        return $self->expand('Bundle',$s);
    } else {
        return $self->expand('Module',$s)
            if $CPAN::META->exists('CPAN::Module',$s);
    }
    return;
}

#-> sub CPAN::Shell::expand ;
sub expand {
    my $self = shift;
    my($type,@args) = @_;
    CPAN->debug("type[$type]args[@args]") if $CPAN::DEBUG;
    my $class = "CPAN::$type";
    my $methods = ['id'];
    for my $meth (qw(name)) {
        next unless $class->can($meth);
        push @$methods, $meth;
    }
    $self->expand_by_method($class,$methods,@args);
}

#-> sub CPAN::Shell::expand_by_method ;
sub expand_by_method {
    my $self = shift;
    my($class,$methods,@args) = @_;
    my($arg,@m);
    for $arg (@args) {
        my($regex,$command);
        if ($arg =~ m|^/(.*)/$|) {
            $regex = $1;
# FIXME:  there seem to be some ='s in the author data, which trigger
#         a failure here.  This needs to be contemplated.
#            } elsif ($arg =~ m/=/) {
#                $command = 1;
        }
        my $obj;
        CPAN->debug(sprintf "class[%s]regex[%s]command[%s]",
                    $class,
                    defined $regex ? $regex : "UNDEFINED",
                    defined $command ? $command : "UNDEFINED",
                   ) if $CPAN::DEBUG;
        if (defined $regex) {
            if (CPAN::_sqlite_running()) {
                CPAN::Index->reload;
                $CPAN::SQLite->search($class, $regex);
            }
            for $obj (
                      $CPAN::META->all_objects($class)
                     ) {
                unless ($obj && UNIVERSAL::can($obj,"id") && $obj->id) {
                    # BUG, we got an empty object somewhere
                    require Data::Dumper;
                    CPAN->debug(sprintf(
                                        "Bug in CPAN: Empty id on obj[%s][%s]",
                                        $obj,
                                        Data::Dumper::Dumper($obj)
                                       )) if $CPAN::DEBUG;
                    next;
                }
                for my $method (@$methods) {
                    my $match = eval {$obj->$method() =~ /$regex/i};
                    if ($@) {
                        my($err) = $@ =~ /^(.+) at .+? line \d+\.$/;
                        $err ||= $@; # if we were too restrictive above
                        $CPAN::Frontend->mydie("$err\n");
                    } elsif ($match) {
                        push @m, $obj;
                        last;
                    }
                }
            }
        } elsif ($command) {
            die "equal sign in command disabled (immature interface), ".
                "you can set
 ! \$CPAN::Shell::ADVANCED_QUERY=1
to enable it. But please note, this is HIGHLY EXPERIMENTAL code
that may go away anytime.\n"
                    unless $ADVANCED_QUERY;
            my($method,$criterion) = $arg =~ /(.+?)=(.+)/;
            my($matchcrit) = $criterion =~ m/^~(.+)/;
            for my $self (
                          sort
                          {$a->id cmp $b->id}
                          $CPAN::META->all_objects($class)
                         ) {
                my $lhs = $self->$method() or next; # () for 5.00503
                if ($matchcrit) {
                    push @m, $self if $lhs =~ m/$matchcrit/;
                } else {
                    push @m, $self if $lhs eq $criterion;
                }
            }
        } else {
            my($xarg) = $arg;
            if ( $class eq 'CPAN::Bundle' ) {
                $xarg =~ s/^(Bundle::)?(.*)/Bundle::$2/;
            } elsif ($class eq "CPAN::Distribution") {
                $xarg = CPAN::Distribution->normalize($arg);
            } else {
                $xarg =~ s/:+/::/g;
            }
            if ($CPAN::META->exists($class,$xarg)) {
                $obj = $CPAN::META->instance($class,$xarg);
            } elsif ($CPAN::META->exists($class,$arg)) {
                $obj = $CPAN::META->instance($class,$arg);
            } else {
                next;
            }
            push @m, $obj;
        }
    }
    @m = sort {$a->id cmp $b->id} @m;
    if ( $CPAN::DEBUG ) {
        my $wantarray = wantarray;
        my $join_m = join ",", map {$_->id} @m;
        # $self->debug("wantarray[$wantarray]join_m[$join_m]");
        my $count = scalar @m;
        $self->debug("class[$class]wantarray[$wantarray]count m[$count]");
    }
    return wantarray ? @m : $m[0];
}

#-> sub CPAN::Shell::format_result ;
sub format_result {
    my($self) = shift;
    my($type,@args) = @_;
    @args = '/./' unless @args;
    my(@result) = $self->expand($type,@args);
    my $result = @result == 1 ?
        $result[0]->as_string :
            @result == 0 ?
                "No objects of type $type found for argument @args\n" :
                    join("",
                         (map {$_->as_glimpse} @result),
                         scalar @result, " items found\n",
                        );
    $result;
}

#-> sub CPAN::Shell::report_fh ;
{
    my $installation_report_fh;
    my $previously_noticed = 0;

    sub report_fh {
        return $installation_report_fh if $installation_report_fh;
        if ($CPAN::META->has_usable("File::Temp")) {
            $installation_report_fh
                = File::Temp->new(
                                  dir      => File::Spec->tmpdir,
                                  template => 'cpan_install_XXXX',
                                  suffix   => '.txt',
                                  unlink   => 0,
                                 );
        }
        unless ( $installation_report_fh ) {
            warn("Couldn't open installation report file; " .
                 "no report file will be generated."
                ) unless $previously_noticed++;
        }
    }
}


# The only reason for this method is currently to have a reliable
# debugging utility that reveals which output is going through which
# channel. No, I don't like the colors ;-)

# to turn colordebugging on, write
# cpan> o conf colorize_output 1

#-> sub CPAN::Shell::colorize_output ;
{
    my $print_ornamented_have_warned = 0;
    sub colorize_output {
        my $colorize_output = $CPAN::Config->{colorize_output};
        if ($colorize_output && $^O eq 'MSWin32' && !$CPAN::META->has_inst("Win32::Console::ANSI")) {
            unless ($print_ornamented_have_warned++) {
                # no myprint/mywarn within myprint/mywarn!
                warn "Colorize_output is set to true but Win32::Console::ANSI is not
installed. To activate colorized output, please install Win32::Console::ANSI.\n\n";
            }
            $colorize_output = 0;
        }
        if ($colorize_output && !$CPAN::META->has_inst("Term::ANSIColor")) {
            unless ($print_ornamented_have_warned++) {
                # no myprint/mywarn within myprint/mywarn!
                warn "Colorize_output is set to true but Term::ANSIColor is not
installed. To activate colorized output, please install Term::ANSIColor.\n\n";
            }
            $colorize_output = 0;
        }
        return $colorize_output;
    }
}


#-> sub CPAN::Shell::print_ornamented ;
sub print_ornamented {
    my($self,$what,$ornament) = @_;
    return unless defined $what;

    local $| = 1; # Flush immediately
    if ( $CPAN::Be_Silent ) {
        # WARNING: variable Be_Silent is poisoned and must be eliminated.
        print {report_fh()} $what;
        return;
    }
    my $swhat = "$what"; # stringify if it is an object
    if ($CPAN::Config->{term_is_latin}) {
        # note: deprecated, need to switch to $LANG and $LC_*
        # courtesy jhi:
        $swhat
            =~ s{([\xC0-\xDF])([\x80-\xBF])}{chr(ord($1)<<6&0xC0|ord($2)&0x3F)}eg; #};
    }
    if ($self->colorize_output) {
        if ( $CPAN::DEBUG && $swhat =~ /^Debug\(/ ) {
            # if you want to have this configurable, please file a bug report
            $ornament = $CPAN::Config->{colorize_debug} || "black on_cyan";
        }
        my $color_on = eval { Term::ANSIColor::color($ornament) } || "";
        if ($@) {
            print "Term::ANSIColor rejects color[$ornament]: $@\n
Please choose a different color (Hint: try 'o conf init /color/')\n";
        }
        # GGOLDBACH/Test-GreaterVersion-0.008 broke without this
        # $trailer construct. We want the newline be the last thing if
        # there is a newline at the end ensuring that the next line is
        # empty for other players
        my $trailer = "";
        $trailer = $1 if $swhat =~ s/([\r\n]+)\z//;
        print $color_on,
            $swhat,
                Term::ANSIColor::color("reset"),
                      $trailer;
    } else {
        print $swhat;
    }
}

#-> sub CPAN::Shell::myprint ;

# where is myprint/mywarn/Frontend/etc. documented? Where to use what?
# I think, we send everything to STDOUT and use print for normal/good
# news and warn for news that need more attention. Yes, this is our
# working contract for now.
sub myprint {
    my($self,$what) = @_;
    $self->print_ornamented($what,
                            $CPAN::Config->{colorize_print}||'bold blue on_white',
                           );
}

my %already_printed;
#-> sub CPAN::Shell::mywarnonce ;
sub myprintonce {
    my($self,$what) = @_;
    $self->myprint($what) unless $already_printed{$what}++;
}

sub optprint {
    my($self,$category,$what) = @_;
    my $vname = $category . "_verbosity";
    CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
    if (!$CPAN::Config->{$vname}
        || $CPAN::Config->{$vname} =~ /^v/
       ) {
        $CPAN::Frontend->myprint($what);
    }
}

#-> sub CPAN::Shell::myexit ;
sub myexit {
    my($self,$what) = @_;
    $self->myprint($what);
    exit;
}

#-> sub CPAN::Shell::mywarn ;
sub mywarn {
    my($self,$what) = @_;
    $self->print_ornamented($what, $CPAN::Config->{colorize_warn}||'bold red on_white');
}

my %already_warned;
#-> sub CPAN::Shell::mywarnonce ;
sub mywarnonce {
    my($self,$what) = @_;
    $self->mywarn($what) unless $already_warned{$what}++;
}

# only to be used for shell commands
#-> sub CPAN::Shell::mydie ;
sub mydie {
    my($self,$what) = @_;
    $self->mywarn($what);

    # If it is the shell, we want the following die to be silent,
    # but if it is not the shell, we would need a 'die $what'. We need
    # to take care that only shell commands use mydie. Is this
    # possible?

    die "\n";
}

# sub CPAN::Shell::colorable_makemaker_prompt ;
sub colorable_makemaker_prompt {
    my($foo,$bar,$ornament) = @_;
    $ornament ||= "colorize_print";
    if (CPAN::Shell->colorize_output) {
        my $ornament = $CPAN::Config->{$ornament}||'bold blue on_white';
        my $color_on = eval { Term::ANSIColor::color($ornament); } || "";
        print $color_on;
    }
    my $ans = ExtUtils::MakeMaker::prompt($foo,$bar);
    if (CPAN::Shell->colorize_output) {
        print Term::ANSIColor::color('reset');
    }
    return $ans;
}

# use this only for unrecoverable errors!
#-> sub CPAN::Shell::unrecoverable_error ;
sub unrecoverable_error {
    my($self,$what) = @_;
    my @lines = split /\n/, $what;
    my $longest = 0;
    for my $l (@lines) {
        $longest = length $l if length $l > $longest;
    }
    $longest = 62 if $longest > 62;
    for my $l (@lines) {
        if ($l =~ /^\s*$/) {
            $l = "\n";
            next;
        }
        $l = "==> $l";
        if (length $l < 66) {
            $l = pack "A66 A*", $l, "<==";
        }
        $l .= "\n";
    }
    unshift @lines, "\n";
    $self->mydie(join "", @lines);
}

#-> sub CPAN::Shell::mysleep ;
sub mysleep {
    return if $ENV{AUTOMATED_TESTING} || ! -t STDOUT;
    my($self, $sleep) = @_;
    if (CPAN->has_inst("Time::HiRes")) {
        Time::HiRes::sleep($sleep);
    } else {
        sleep($sleep < 1 ? 1 : int($sleep + 0.5));
    }
}

#-> sub CPAN::Shell::setup_output ;
sub setup_output {
    return if -t STDOUT;
    my $odef = select STDERR;
    $| = 1;
    select STDOUT;
    $| = 1;
    select $odef;
}

#-> sub CPAN::Shell::rematein ;
# RE-adme||MA-ke||TE-st||IN-stall : nearly everything runs through here
sub rematein {
    my $self = shift;
    # this variable was global and disturbed programmers, so localize:
    local $CPAN::Distrostatus::something_has_failed_at;
    my($meth,@some) = @_;
    my @pragma;
    while($meth =~ /^(ff?orce|notest)$/) {
        push @pragma, $meth;
        $meth = shift @some or
            $CPAN::Frontend->mydie("Pragma $pragma[-1] used without method: ".
                                   "cannot continue");
    }
    setup_output();
    CPAN->debug("pragma[@pragma]meth[$meth]some[@some]") if $CPAN::DEBUG;

    # Here is the place to set "test_count" on all involved parties to
    # 0. We then can pass this counter on to the involved
    # distributions and those can refuse to test if test_count > X. In
    # the first stab at it we could use a 1 for "X".

    # But when do I reset the distributions to start with 0 again?
    # Jost suggested to have a random or cycling interaction ID that
    # we pass through. But the ID is something that is just left lying
    # around in addition to the counter, so I'd prefer to set the
    # counter to 0 now, and repeat at the end of the loop. But what
    # about dependencies? They appear later and are not reset, they
    # enter the queue but not its copy. How do they get a sensible
    # test_count?

    # With configure_requires, "get" is vulnerable in recursion.

    my $needs_recursion_protection = "get|make|test|install";

    # construct the queue
    my($s,@s,@qcopy);
  STHING: foreach $s (@some) {
        my $obj;
        if (ref $s) {
            CPAN->debug("s is an object[$s]") if $CPAN::DEBUG;
            $obj = $s;
        } elsif ($s =~ m|[\$\@\%]|) { # looks like a perl variable
        } elsif ($s =~ m|^/|) { # looks like a regexp
            if (substr($s,-1,1) eq ".") {
                $obj = CPAN::Shell->expandany($s);
            } else {
                my @obj;
            CLASS: for my $class (qw(Distribution Bundle Module)) {
                    if (@obj = $self->expand($class,$s)) {
                        last CLASS;
                    }
                }
                if (@obj) {
                    if (1==@obj) {
                        $obj = $obj[0];
                    } else {
                        $CPAN::Frontend->mywarn("Sorry, $meth with a regular expression is ".
                                                "only supported when unambiguous.\nRejecting argument '$s'\n");
                        $CPAN::Frontend->mysleep(2);
                        next STHING;
                    }
                }
            }
        } elsif ($meth eq "ls") {
            $self->globls($s,\@pragma);
            next STHING;
        } else {
            CPAN->debug("calling expandany [$s]") if $CPAN::DEBUG;
            $obj = CPAN::Shell->expandany($s);
        }
        if (0) {
        } elsif (ref $obj) {
            if ($meth =~ /^($needs_recursion_protection)$/) {
                # it would be silly to check for recursion for look or dump
                # (we are in CPAN::Shell::rematein)
                CPAN->debug("Testing against recursion") if $CPAN::DEBUG;
                eval {  $obj->color_cmd_tmps(0,1); };
                if ($@) {
                    if (ref $@
                        and $@->isa("CPAN::Exception::RecursiveDependency")) {
                        $CPAN::Frontend->mywarn($@);
                    } else {
                        if (0) {
                            require Carp;
                            Carp::confess(sprintf "DEBUG: \$\@[%s]ref[%s]", $@, ref $@);
                        }
                        die;
                    }
                }
            }
            CPAN::Queue->queue_item(qmod => $obj->id, reqtype => "c", optional => '');
            push @qcopy, $obj;
        } elsif ($CPAN::META->exists('CPAN::Author',uc($s))) {
            $obj = $CPAN::META->instance('CPAN::Author',uc($s));
            if ($meth =~ /^(dump|ls|reports)$/) {
                $obj->$meth();
            } else {
                $CPAN::Frontend->mywarn(
                                        join "",
                                        "Don't be silly, you can't $meth ",
                                        $obj->fullname,
                                        " ;-)\n"
                                       );
                $CPAN::Frontend->mysleep(2);
            }
        } elsif ($s =~ m|[\$\@\%]| && $meth eq "dump") {
            CPAN::InfoObj->dump($s);
        } else {
            $CPAN::Frontend
                ->mywarn(qq{Warning: Cannot $meth $s, }.
                         qq{don't know what it is.
Try the command

    i /$s/

to find objects with matching identifiers.
});
            $CPAN::Frontend->mysleep(2);
        }
    }

    # queuerunner (please be warned: when I started to change the
    # queue to hold objects instead of names, I made one or two
    # mistakes and never found which. I reverted back instead)
  QITEM: while (my $q = CPAN::Queue->first) {
        my $obj;
        my $s = $q->as_string;
        my $reqtype = $q->reqtype || "";
        my $optional = $q->optional || "";
        $obj = CPAN::Shell->expandany($s);
        unless ($obj) {
            # don't know how this can happen, maybe we should panic,
            # but maybe we get a solution from the first user who hits
            # this unfortunate exception?
            $CPAN::Frontend->mywarn("Warning: Could not expand string '$s' ".
                                    "to an object. Skipping.\n");
            $CPAN::Frontend->mysleep(5);
            CPAN::Queue->delete_first($s);
            next QITEM;
        }
        $obj->{reqtype} ||= "";
        my $type = ref $obj;
        if ( $type eq 'CPAN::Distribution' || $type eq 'CPAN::Bundle' ) {
            $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
        }
        elsif ( $type eq 'CPAN::Module' ) {
            $obj->{mandatory} ||= ! $optional; # once mandatory, always mandatory
            if (my $d = $obj->distribution) {
                $d->{mandatory} ||= ! $optional; # once mandatory, always mandatory
            } elsif ($optional) {
                # the queue object does not know who was recommending/suggesting us:(
                # So we only vaguely write "optional".
                $CPAN::Frontend->mywarn("Warning: optional module '$s' ".
                                        "not known. Skipping.\n");
                CPAN::Queue->delete_first($s);
                next QITEM;
            }
        }
        {
            # force debugging because CPAN::SQLite somehow delivers us
            # an empty object;

            # local $CPAN::DEBUG = 1024; # Shell; probably fixed now

            CPAN->debug("s[$s]obj-reqtype[$obj->{reqtype}]".
                        "q-reqtype[$reqtype]") if $CPAN::DEBUG;
        }
        if ($obj->{reqtype}) {
            if ($obj->{reqtype} eq "b" && $reqtype =~ /^[rc]$/) {
                $obj->{reqtype} = $reqtype;
                if (
                    exists $obj->{install}
                    &&
                    (
                     UNIVERSAL::can($obj->{install},"failed") ?
                     $obj->{install}->failed :
                     $obj->{install} =~ /^NO/
                    )
                   ) {
                    delete $obj->{install};
                    $CPAN::Frontend->mywarn
                        ("Promoting $obj->{ID} from 'build_requires' to 'requires'");
                }
            }
        } else {
            $obj->{reqtype} = $reqtype;
        }

        for my $pragma (@pragma) {
            if ($pragma
                &&
                $obj->can($pragma)) {
                $obj->$pragma($meth);
            }
        }
        if (UNIVERSAL::can($obj, 'called_for')) {
            $obj->called_for($s) unless $obj->called_for;
        }
        CPAN->debug(qq{pragma[@pragma]meth[$meth]}.
                    qq{ID[$obj->{ID}]}) if $CPAN::DEBUG;

        push @qcopy, $obj;
        if ($meth =~ /^(report)$/) { # they came here with a pragma?
            $self->$meth($obj);
        } elsif (! UNIVERSAL::can($obj,$meth)) {
            # Must never happen
            my $serialized = "";
            if (0) {
            } elsif ($CPAN::META->has_inst("YAML::Syck")) {
                $serialized = YAML::Syck::Dump($obj);
            } elsif ($CPAN::META->has_inst("YAML")) {
                $serialized = YAML::Dump($obj);
            } elsif ($CPAN::META->has_inst("Data::Dumper")) {
                $serialized = Data::Dumper::Dumper($obj);
            } else {
                require overload;
                $serialized = overload::StrVal($obj);
            }
            CPAN->debug("Going to panic. meth[$meth]s[$s]") if $CPAN::DEBUG;
            $CPAN::Frontend->mydie("Panic: obj[$serialized] cannot meth[$meth]");
        } else {
            my $upgraded_meth = $meth;
            if ( $meth eq "make" and $obj->{reqtype} eq "b" ) {
                # rt 86915
                $upgraded_meth = "test";
            }
            if ($obj->$upgraded_meth()) {
                CPAN::Queue->delete($s);
                CPAN->debug("Succeeded and deleted from queue. pragma[@pragma]meth[$meth][s][$s]") if $CPAN::DEBUG;
            } else {
                CPAN->debug("Failed. pragma[@pragma]meth[$meth]s[$s]") if $CPAN::DEBUG;
            }
        }

        $obj->undelay;
        for my $pragma (@pragma) {
            my $unpragma = "un$pragma";
            if ($obj->can($unpragma)) {
                $obj->$unpragma();
            }
        }
        # if any failures occurred and the current object is mandatory, we
        # still don't know if *it* failed or if it was another (optional)
        # module, so we have to check that explicitly (and expensively)
        if (    $CPAN::Config->{halt_on_failure}
            && $obj->{mandatory}
            && CPAN::Distrostatus::something_has_just_failed()
            && $self->mandatory_dist_failed()
        ) {
            $CPAN::Frontend->mywarn("Stopping: '$meth' failed for '$s'.\n");
            CPAN::Queue->nullify_queue;
            last QITEM;
        }
        CPAN::Queue->delete_first($s);
    }
    if ($meth =~ /^($needs_recursion_protection)$/) {
        for my $obj (@qcopy) {
            $obj->color_cmd_tmps(0,0);
        }
    }
}

#-> sub CPAN::Shell::recent ;
sub recent {
  my($self) = @_;
  if ($CPAN::META->has_inst("XML::LibXML")) {
      my $url = $CPAN::Defaultrecent;
      $CPAN::Frontend->myprint("Fetching '$url'\n");
      unless ($CPAN::META->has_usable("LWP")) {
          $CPAN::Frontend->mydie("LWP not installed; cannot continue");
      }
      CPAN::LWP::UserAgent->config;
      my $Ua;
      eval { $Ua = CPAN::LWP::UserAgent->new; };
      if ($@) {
          $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
      }
      my $resp = $Ua->get($url);
      unless ($resp->is_success) {
          $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
      }
      $CPAN::Frontend->myprint("DONE\n\n");
      my $xml = XML::LibXML->new->parse_string($resp->content);
      if (0) {
          my $s = $xml->serialize(2);
          $s =~ s/\n\s*\n/\n/g;
          $CPAN::Frontend->myprint($s);
          return;
      }
      my @distros;
      if ($url =~ /winnipeg/) {
          my $pubdate = $xml->findvalue("/rss/channel/pubDate");
          $CPAN::Frontend->myprint("    pubDate: $pubdate\n\n");
          for my $eitem ($xml->findnodes("/rss/channel/item")) {
              my $distro = $eitem->findvalue("enclosure/\@url");
              $distro =~ s|.*?/authors/id/./../||;
              my $size   = $eitem->findvalue("enclosure/\@length");
              my $desc   = $eitem->findvalue("description");
              $desc =~ s/.+? - //;
              $CPAN::Frontend->myprint("$distro [$size b]\n    $desc\n");
              push @distros, $distro;
          }
      } elsif ($url =~ /search.*uploads.rdf/) {
          # xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
          # xmlns="http://purl.org/rss/1.0/"
          # xmlns:taxo="http://purl.org/rss/1.0/modules/taxonomy/"
          # xmlns:dc="http://purl.org/dc/elements/1.1/"
          # xmlns:syn="http://purl.org/rss/1.0/modules/syndication/"
          # xmlns:admin="http://webns.net/mvcb/"


          my $dc_date = $xml->findvalue("//*[local-name(.) = 'RDF']/*[local-name(.) = 'channel']/*[local-name(.) = 'date']");
          $CPAN::Frontend->myprint("    dc:date: $dc_date\n\n");
          my $finish_eitem = 0;
          local $SIG{INT} = sub { $finish_eitem = 1 };
        EITEM: for my $eitem ($xml->findnodes("//*[local-name(.) = 'RDF']/*[local-name(.) = 'item']")) {
              my $distro = $eitem->findvalue("\@rdf:about");
              $distro =~ s|.*~||; # remove up to the tilde before the name
              $distro =~ s|/$||; # remove trailing slash
              $distro =~ s|([^/]+)|\U$1\E|; # upcase the name
              my $author = uc $1 or die "distro[$distro] without author, cannot continue";
              my $desc   = $eitem->findvalue("*[local-name(.) = 'description']");
              my $i = 0;
            SUBDIRTEST: while () {
                  last SUBDIRTEST if ++$i >= 6; # half a dozen must do!
                  if (my @ret = $self->globls("$distro*")) {
                      @ret = grep {$_->[2] !~ /meta/} @ret;
                      @ret = grep {length $_->[2]} @ret;
                      if (@ret) {
                          $distro = "$author/$ret[0][2]";
                          last SUBDIRTEST;
                      }
                  }
                  $distro =~ s|/|/*/|; # allow it to reside in a subdirectory
              }

              next EITEM if $distro =~ m|\*|; # did not find the thing
              $CPAN::Frontend->myprint("____$desc\n");
              push @distros, $distro;
              last EITEM if $finish_eitem;
          }
      }
      return \@distros;
  } else {
      # deprecated old version
      $CPAN::Frontend->mydie("no XML::LibXML installed, cannot continue\n");
  }
}

#-> sub CPAN::Shell::smoke ;
sub smoke {
    my($self) = @_;
    my $distros = $self->recent;
  DISTRO: for my $distro (@$distros) {
        next if $distro =~ m|/Bundle-|; # XXX crude heuristic to skip bundles
        $CPAN::Frontend->myprint(sprintf "Downloading and testing '$distro'\n");
        {
            my $skip = 0;
            local $SIG{INT} = sub { $skip = 1 };
            for (0..9) {
                $CPAN::Frontend->myprint(sprintf "\r%2d (Hit ^C to skip)", 10-$_);
                sleep 1;
                if ($skip) {
                    $CPAN::Frontend->myprint(" skipped\n");
                    next DISTRO;
                }
            }
        }
        $CPAN::Frontend->myprint("\r  \n"); # leave the dirty line with a newline
        $self->test($distro);
    }
}

{
    # set up the dispatching methods
    no strict "refs";
    for my $command (qw(
                        clean
                        cvs_import
                        dump
                        force
                        fforce
                        get
                        install
                        look
                        ls
                        make
                        notest
                        perldoc
                        readme
                        reports
                        test
                       )) {
        *$command = sub { shift->rematein($command, @_); };
    }
}

1;
PK     ü2]naX67  7  	  Prompt.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Prompt;
use overload '""' => "as_string";
use vars qw($prompt);
use vars qw(
            $VERSION
);
$VERSION = "5.5";


$prompt = "cpan> ";
$CPAN::CurrentCommandId ||= 0;
sub new {
    bless {}, shift;
}
sub as_string {
    my $word = "cpan";
    unless ($CPAN::META->{LOCK}) {
        $word = "nolock_cpan";
    }
    if ($CPAN::Config->{commandnumber_in_prompt}) {
        sprintf "$word\[%d]> ", $CPAN::CurrentCommandId;
    } else {
        "$word> ";
    }
}

1;
PK     ü2]§:‡  ‡    Complete.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Complete;
use strict;
@CPAN::Complete::ISA = qw(CPAN::Debug);
# Q: where is the "How do I add a new command" HOWTO?
# A: git log -p -1 355c44e9caaec857e4b12f51afb96498833c3e36 where andk added the report command
@CPAN::Complete::COMMANDS = sort qw(
                                    ? ! a b d h i m o q r u
                                    autobundle
                                    bye
                                    clean
                                    cvs_import
                                    dump
                                    exit
                                    failed
                                    force
                                    fforce
                                    hosts
                                    install
                                    install_tested
                                    is_tested
                                    look
                                    ls
                                    make
                                    mkmyconfig
                                    notest
                                    perldoc
                                    quit
                                    readme
                                    recent
                                    recompile
                                    reload
                                    report
                                    reports
                                    scripts
                                    smoke
                                    test
                                    upgrade
);

use vars qw(
            $VERSION
);
$VERSION = "5.5001";

package CPAN::Complete;
use strict;

sub gnu_cpl {
    my($text, $line, $start, $end) = @_;
    my(@perlret) = cpl($text, $line, $start);
    # find longest common match. Can anybody show me how to peruse
    # T::R::Gnu to have this done automatically? Seems expensive.
    return () unless @perlret;
    my($newtext) = $text;
    for (my $i = length($text)+1;;$i++) {
        last unless length($perlret[0]) && length($perlret[0]) >= $i;
        my $try = substr($perlret[0],0,$i);
        my @tries = grep {substr($_,0,$i) eq $try} @perlret;
        # warn "try[$try]tries[@tries]";
        if (@tries == @perlret) {
            $newtext = $try;
        } else {
            last;
        }
    }
    ($newtext,@perlret);
}

#-> sub CPAN::Complete::cpl ;
sub cpl {
    my($word,$line,$pos) = @_;
    $word ||= "";
    $line ||= "";
    $pos ||= 0;
    CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    $line =~ s/^\s*//;
    if ($line =~ s/^((?:notest|f?force)\s*)//) {
        $pos -= length($1);
    }
    my @return;
    if ($pos == 0 || $line =~ /^(?:h(?:elp)?|\?)\s/) {
        @return = grep /^\Q$word\E/, @CPAN::Complete::COMMANDS;
    } elsif ( $line !~ /^[\!abcdghimorutl]/ ) {
        @return = ();
    } elsif ($line =~ /^a\s/) {
        @return = cplx('CPAN::Author',uc($word));
    } elsif ($line =~ /^ls\s/) {
        my($author,$rest) = $word =~ m|([^/]+)/?(.*)|;
        @return = $rest ? () : map {"$_/"} cplx('CPAN::Author',uc($author||""));
        if (0 && 1==@return) { # XXX too slow and even wrong when there is a * already
            @return = grep /^\Q$word\E/, map {"$author/$_->[2]"} CPAN::Shell->expand("Author",$author)->ls("$rest*","2");
        }
    } elsif ($line =~ /^b\s/) {
        CPAN::Shell->local_bundles;
        @return = cplx('CPAN::Bundle',$word);
    } elsif ($line =~ /^d\s/) {
        @return = cplx('CPAN::Distribution',$word);
    } elsif ($line =~ m/^(
                          [mru]|make|clean|dump|get|test|install|readme|look|cvs_import|perldoc|recent
                         )\s/x ) {
        if ($word =~ /^Bundle::/) {
            CPAN::Shell->local_bundles;
        }
        @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
    } elsif ($line =~ /^i\s/) {
        @return = cpl_any($word);
    } elsif ($line =~ /^reload\s/) {
        @return = cpl_reload($word,$line,$pos);
    } elsif ($line =~ /^o\s/) {
        @return = cpl_option($word,$line,$pos);
    } elsif ($line =~ m/^\S+\s/ ) {
        # fallback for future commands and what we have forgotten above
        @return = (cplx('CPAN::Module',$word),cplx('CPAN::Bundle',$word));
    } else {
        @return = ();
    }
    return @return;
}

#-> sub CPAN::Complete::cplx ;
sub cplx {
    my($class, $word) = @_;
    if (CPAN::_sqlite_running()) {
        $CPAN::SQLite->search($class, "^\Q$word\E");
    }
    my $method = "id";
    $method = "pretty_id" if $class eq "CPAN::Distribution";
    sort grep /^\Q$word\E/, map { $_->$method() } $CPAN::META->all_objects($class);
}

#-> sub CPAN::Complete::cpl_any ;
sub cpl_any {
    my($word) = shift;
    return (
            cplx('CPAN::Author',$word),
            cplx('CPAN::Bundle',$word),
            cplx('CPAN::Distribution',$word),
            cplx('CPAN::Module',$word),
           );
}

#-> sub CPAN::Complete::cpl_reload ;
sub cpl_reload {
    my($word,$line,$pos) = @_;
    $word ||= "";
    my(@words) = split " ", $line;
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@ok) = qw(cpan index);
    return @ok if @words == 1;
    return grep /^\Q$word\E/, @ok if @words == 2 && $word;
}

#-> sub CPAN::Complete::cpl_option ;
sub cpl_option {
    my($word,$line,$pos) = @_;
    $word ||= "";
    my(@words) = split " ", $line;
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@ok) = qw(conf debug);
    return @ok if @words == 1;
    return grep /^\Q$word\E/, @ok if @words == 2 && length($word);
    if (0) {
    } elsif ($words[1] eq 'index') {
        return ();
    } elsif ($words[1] eq 'conf') {
        return CPAN::HandleConfig::cpl(@_);
    } elsif ($words[1] eq 'debug') {
        return sort grep /^\Q$word\E/i,
            sort keys %CPAN::DEBUG, 'all';
    }
}

1;
PK     ü2]Æ®Þ’w^  w^    HandleConfig.pmnu ÏÃ6Ç$        package CPAN::HandleConfig;
use strict;
use vars qw(%can %keys $loading $VERSION);
use File::Path ();
use File::Spec ();
use File::Basename ();
use Carp ();

=head1 NAME

CPAN::HandleConfig - internal configuration handling for CPAN.pm

=cut 

$VERSION = "5.5012"; # see also CPAN::Config::VERSION at end of file

%can = (
        commit   => "Commit changes to disk",
        defaults => "Reload defaults from disk",
        help     => "Short help about 'o conf' usage",
        init     => "Interactive setting of all options",
);

# Q: where is the "How do I add a new config option" HOWTO?
# A1: svn diff -r 757:758 # where dagolden added test_report [git e997b71de88f1019a1472fc13cb97b1b7f96610f]
# A2: svn diff -r 985:986 # where andk added yaml_module [git 312b6d9b12b1bdec0b6e282d853482145475021f]
# A3: 1. add new config option to %keys below
#     2. add a Pod description in CPAN::FirstTime in the DESCRIPTION
#        section; it should include a prompt line; see others for
#        examples
#     3. add a "matcher" section in CPAN::FirstTime::init that includes
#        a prompt function; see others for examples
#     4. add config option to documentation section in CPAN.pm

%keys = map { $_ => undef }
    (
     "allow_installing_module_downgrades",
     "allow_installing_outdated_dists",
     "applypatch",
     "auto_commit",
     "build_cache",
     "build_dir",
     "build_dir_reuse",
     "build_requires_install_policy",
     "bzip2",
     "cache_metadata",
     "check_sigs",
     "cleanup_after_install",
     "colorize_debug",
     "colorize_output",
     "colorize_print",
     "colorize_warn",
     "commandnumber_in_prompt",
     "commands_quote",
     "connect_to_internet_ok",
     "cpan_home",
     "curl",
     "dontload_hash", # deprecated after 1.83_68 (rev. 581)
     "dontload_list",
     "ftp",
     "ftp_passive",
     "ftp_proxy",
     "ftpstats_size",
     "ftpstats_period",
     "getcwd",
     "gpg",
     "gzip",
     "halt_on_failure",
     "histfile",
     "histsize",
     "http_proxy",
     "inactivity_timeout",
     "index_expire",
     "inhibit_startup_message",
     "keep_source_where",
     "load_module_verbosity",
     "lynx",
     "make",
     "make_arg",
     "make_install_arg",
     "make_install_make_command",
     "makepl_arg",
     "mbuild_arg",
     "mbuild_install_arg",
     "mbuild_install_build_command",
     "mbuildpl_arg",
     "ncftp",
     "ncftpget",
     "no_proxy",
     "pager",
     "password",
     "patch",
     "patches_dir",
     "perl5lib_verbosity",
     "plugin_list",
     "prefer_external_tar",
     "prefer_installer",
     "prefs_dir",
     "prerequisites_policy",
     "proxy_pass",
     "proxy_user",
     "pushy_https",
     "randomize_urllist",
     "recommends_policy",
     "scan_cache",
     "shell",
     "show_unparsable_versions",
     "show_upload_date",
     "show_zero_versions",
     "suggests_policy",
     "tar",
     "tar_verbosity",
     "term_is_latin",
     "term_ornaments",
     "test_report",
     "trust_test_report_history",
     "unzip",
     "urllist",
     "urllist_ping_verbose",
     "urllist_ping_external",
     "use_prompt_default",
     "use_sqlite",
     "username",
     "version_timeout",
     "wait_list",
     "wget",
     "yaml_load_code",
     "yaml_module",
    );

my %prefssupport = map { $_ => 1 }
    (
     "allow_installing_module_downgrades",
     "allow_installing_outdated_dists",
     "build_requires_install_policy",
     "check_sigs",
     "make",
     "make_install_make_command",
     "prefer_installer",
     "test_report",
    );

# returns true on successful action
sub edit {
    my($self,@args) = @_;
    return unless @args;
    CPAN->debug("self[$self]args[".join(" | ",@args)."]");
    my($o,$str,$func,$args,$key_exists);
    $o = shift @args;
    if($can{$o}) {
        my $success = $self->$o(args => \@args); # o conf init => sub init => sub load
        unless ($success) {
            die "Panic: could not configure CPAN.pm for args [@args]. Giving up.";
        }
    } else {
        CPAN->debug("o[$o]") if $CPAN::DEBUG;
        unless (exists $keys{$o}) {
            $CPAN::Frontend->mywarn("Warning: unknown configuration variable '$o'\n");
        }
        my $changed;


        # one day I used randomize_urllist for a boolean, so we must
        # list them explicitly --ak
        if (0) {
        } elsif ($o =~ /^(wait_list|urllist|dontload_list|plugin_list)$/) {

            #
            # ARRAYS
            #

            $func = shift @args;
            $func ||= "";
            CPAN->debug("func[$func]args[@args]") if $CPAN::DEBUG;
            # Let's avoid eval, it's easier to comprehend without.
            if ($func eq "push") {
                push @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
            } elsif ($func eq "pop") {
                pop @{$CPAN::Config->{$o}};
                $changed = 1;
            } elsif ($func eq "shift") {
                shift @{$CPAN::Config->{$o}};
                $changed = 1;
            } elsif ($func eq "unshift") {
                unshift @{$CPAN::Config->{$o}}, @args;
                $changed = 1;
            } elsif ($func eq "splice") {
                my $offset = shift @args || 0;
                my $length = shift @args || 0;
                splice @{$CPAN::Config->{$o}}, $offset, $length, @args; # may warn
                $changed = 1;
            } elsif ($func) {
                $CPAN::Config->{$o} = [$func, @args];
                $changed = 1;
            } else {
                $self->prettyprint($o);
            }
            if ($changed) {
                if ($o eq "urllist") {
                    # reset the cached values
                    undef $CPAN::FTP::Thesite;
                    undef $CPAN::FTP::Themethod;
                    $CPAN::Index::LAST_TIME = 0;
                } elsif ($o eq "dontload_list") {
                    # empty it, it will be built up again
                    $CPAN::META->{dontload_hash} = {};
                }
            }
        } elsif ($o =~ /_hash$/) {

            #
            # HASHES
            #

            if (@args==1 && $args[0] eq "") {
                @args = ();
            } elsif (@args % 2) {
                push @args, "";
            }
            $CPAN::Config->{$o} = { @args };
            $changed = 1;
        } else {

            #
            # SCALARS
            #

            if (defined $args[0]) {
                $CPAN::CONFIG_DIRTY = 1;
                $CPAN::Config->{$o} = $args[0];
                $changed = 1;
            }
            $self->prettyprint($o)
                if exists $keys{$o} or defined $CPAN::Config->{$o};
        }
        if ($changed) {
            if ($CPAN::Config->{auto_commit}) {
                $self->commit;
            } else {
                $CPAN::CONFIG_DIRTY = 1;
                $CPAN::Frontend->myprint("Please use 'o conf commit' to ".
                                         "make the config permanent!\n\n");
            }
        }
    }
}

sub prettyprint {
    my($self,$k) = @_;
    my $v = $CPAN::Config->{$k};
    if (ref $v) {
        my(@report);
        if (ref $v eq "ARRAY") {
            @report = map {"\t$_ \[$v->[$_]]\n"} 0..$#$v;
        } else {
            @report = map
                {
                    sprintf "\t%-18s => %s\n",
                               "[$_]",
                                        defined $v->{$_} ? "[$v->{$_}]" : "undef"
                } sort keys %$v;
        }
        $CPAN::Frontend->myprint(
                                 join(
                                      "",
                                      sprintf(
                                              "    %-18s\n",
                                              $k
                                             ),
                                      @report
                                     )
                                );
    } elsif (defined $v) {
        $CPAN::Frontend->myprint(sprintf "    %-18s [%s]\n", $k, $v);
    } else {
        $CPAN::Frontend->myprint(sprintf "    %-18s undef\n", $k);
    }
}

# generally, this should be called without arguments so that the currently
# loaded config file is where changes are committed.
sub commit {
    my($self,@args) = @_;
    CPAN->debug("args[@args]") if $CPAN::DEBUG;
    if ($CPAN::RUN_DEGRADED) {
        $CPAN::Frontend->mydie(
            "'o conf commit' disabled in ".
            "degraded mode. Maybe try\n".
            " !undef \$CPAN::RUN_DEGRADED\n"
        );
    }
    my ($configpm, $must_reload);

    # XXX does anything do this? can it be simplified? -- dagolden, 2011-01-19
    if (@args) {
      if ($args[0] eq "args") {
        # we have not signed that contract
      } else {
        $configpm = $args[0];
      }
    }

    # use provided name or the current config or create a new MyConfig
    $configpm ||= require_myconfig_or_config() || make_new_config();

    # commit to MyConfig if we can't write to Config
    if ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm} ) {
        my $myconfig = _new_config_name();
        $CPAN::Frontend->mywarn(
            "Your $configpm file\n".
            "is not writable. I will attempt to write your configuration to\n" .
            "$myconfig instead.\n\n"
        );
        $configpm = make_new_config();
        $must_reload++; # so it gets loaded as $INC{'CPAN/MyConfig.pm'}
    }

    # XXX why not just "-w $configpm"? -- dagolden, 2011-01-19
    my($mode);
    if (-f $configpm) {
        $mode = (stat $configpm)[2];
        if ($mode && ! -w _) {
            _die_cant_write_config($configpm);
        }
    }

    $self->_write_config_file($configpm);
    require_myconfig_or_config() if $must_reload;

    #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
    #chmod $mode, $configpm;
###why was that so?    $self->defaults;
    $CPAN::Frontend->myprint("commit: wrote '$configpm'\n");
    $CPAN::CONFIG_DIRTY = 0;
    1;
}

sub _write_config_file {
    my ($self, $configpm) = @_;
    my $msg;
    $msg = <<EOF if $configpm =~ m{CPAN/Config\.pm};

# This is CPAN.pm's systemwide configuration file. This file provides
# defaults for users, and the values can be changed in a per-user
# configuration file.

EOF
    $msg ||= "\n";
    my($fh) = FileHandle->new;
    rename $configpm, "$configpm~" if -f $configpm;
    open $fh, ">$configpm" or
        $CPAN::Frontend->mydie("Couldn't open >$configpm: $!");
    $fh->print(qq[$msg\$CPAN::Config = \{\n]);
    foreach (sort keys %$CPAN::Config) {
        unless (exists $keys{$_}) {
            # do not drop them: forward compatibility!
            $CPAN::Frontend->mywarn("Unknown config variable '$_'\n");
            next;
        }
        $fh->print(
            "  '$_' => ",
            $self->neatvalue($CPAN::Config->{$_}),
            ",\n"
        );
    }
    $fh->print("};\n1;\n__END__\n");
    close $fh;

    return;
}


# stolen from MakeMaker; not taking the original because it is buggy;
# bugreport will have to say: keys of hashes remain unquoted and can
# produce syntax errors
sub neatvalue {
    my($self, $v) = @_;
    return "undef" unless defined $v;
    my($t) = ref $v;
    unless ($t) {
        $v =~ s/\\/\\\\/g;
        return "q[$v]";
    }
    if ($t eq 'ARRAY') {
        my(@m, @neat);
        push @m, "[";
        foreach my $elem (@$v) {
            push @neat, "q[$elem]";
        }
        push @m, join ", ", @neat;
        push @m, "]";
        return join "", @m;
    }
    return "$v" unless $t eq 'HASH';
    my @m;
    foreach my $key (sort keys %$v) {
        my $val = $v->{$key};
        push(@m,"q[$key]=>".$self->neatvalue($val)) ;
    }
    return "{ ".join(', ',@m)." }";
}

sub defaults {
    my($self) = @_;
    if ($CPAN::RUN_DEGRADED) {
                             $CPAN::Frontend->mydie(
                                                    "'o conf defaults' disabled in ".
                                                    "degraded mode. Maybe try\n".
                                                    " !undef \$CPAN::RUN_DEGRADED\n"
                                                   );
    }
    my $done;
    for my $config (qw(CPAN/MyConfig.pm CPAN/Config.pm)) {
        if ($INC{$config}) {
            CPAN->debug("INC{'$config'}[$INC{$config}]") if $CPAN::DEBUG;
            CPAN::Shell->_reload_this($config,{reloforce => 1});
            $CPAN::Frontend->myprint("'$INC{$config}' reread\n");
            last;
        }
    }
    $CPAN::CONFIG_DIRTY = 0;
    1;
}

=head2 C<< CLASS->safe_quote ITEM >>

Quotes an item to become safe against spaces
in shell interpolation. An item is enclosed
in double quotes if:

  - the item contains spaces in the middle
  - the item does not start with a quote

This happens to avoid shell interpolation
problems when whitespace is present in
directory names.

This method uses C<commands_quote> to determine
the correct quote. If C<commands_quote> is
a space, no quoting will take place.


if it starts and ends with the same quote character: leave it as it is

if it contains no whitespace: leave it as it is

if it contains whitespace, then

if it contains quotes: better leave it as it is

else: quote it with the correct quote type for the box we're on

=cut

{
    # Instead of patching the guess, set commands_quote
    # to the right value
    my ($quotes,$use_quote)
        = $^O eq 'MSWin32'
            ? ('"', '"')
                : (q{"'}, "'")
                    ;

    sub safe_quote {
        my ($self, $command) = @_;
        # Set up quote/default quote
        my $quote = $CPAN::Config->{commands_quote} || $quotes;

        if ($quote ne ' '
            and defined($command )
            and $command =~ /\s/
            and $command !~ /[$quote]/) {
            return qq<$use_quote$command$use_quote>
        }
        return $command;
    }
}

sub init {
    my($self,@args) = @_;
    CPAN->debug("self[$self]args[".join(",",@args)."]");
    $self->load(do_init => 1, @args);
    1;
}

# Loads CPAN::MyConfig or fall-back to CPAN::Config. Will not reload a file
# if already loaded. Returns the path to the file %INC or else the empty string
#
# Note -- if CPAN::Config were loaded and CPAN::MyConfig subsequently
# created, calling this again will leave *both* in %INC

sub require_myconfig_or_config () {
    if (   $INC{"CPAN/MyConfig.pm"} || _try_loading("CPAN::MyConfig", cpan_home())) {
        return $INC{"CPAN/MyConfig.pm"};
    }
    elsif ( $INC{"CPAN/Config.pm"} || _try_loading("CPAN::Config") ) {
        return $INC{"CPAN/Config.pm"};
    }
    else {
        return q{};
    }
}

# Load a module, but ignore "can't locate..." errors
# Optionally take a list of directories to add to @INC for the load
sub _try_loading {
    my ($module, @dirs) = @_;
    (my $file = $module) =~ s{::}{/}g;
    $file .= ".pm";

    local @INC = @INC;
    for my $dir ( @dirs ) {
        if ( -f File::Spec->catfile($dir, $file) ) {
            unshift @INC, $dir;
            last;
        }
    }

    eval { require $file };
    my $err_myconfig = $@;
    if ($err_myconfig and $err_myconfig !~ m#locate \Q$file\E#) {
        die "Error while requiring ${module}:\n$err_myconfig";
    }
    return $INC{$file};
}

# prioritized list of possible places for finding "CPAN/MyConfig.pm"
sub cpan_home_dir_candidates {
    my @dirs;
    my $old_v = $CPAN::Config->{load_module_verbosity};
    $CPAN::Config->{load_module_verbosity} = q[none];
    if ($CPAN::META->has_usable('File::HomeDir')) {
        if ($^O ne 'darwin') {
            push @dirs, File::HomeDir->my_data;
            # my_data is ~/Library/Application Support on darwin,
            # which causes issues in the toolchain.
        }
        push @dirs, File::HomeDir->my_home;
    }
    # Windows might not have HOME, so check it first
    push @dirs, $ENV{HOME} if $ENV{HOME};
    # Windows might have these instead
    push( @dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') )
      if $ENV{HOMEDRIVE} && $ENV{HOMEPATH};
    push @dirs, $ENV{USERPROFILE} if $ENV{USERPROFILE};

    $CPAN::Config->{load_module_verbosity} = $old_v;
    my $dotcpan = $^O eq 'VMS' ? '_cpan' : '.cpan';
    @dirs = map { File::Spec->catdir($_, $dotcpan) } grep { defined } @dirs;
    return wantarray ? @dirs : $dirs[0];
}

sub load {
    my($self, %args) = @_;
    $CPAN::Be_Silent+=0; # protect against 'used only once'
    $CPAN::Be_Silent++ if $args{be_silent}; # do not use; planned to be removed in 2011
    my $do_init = delete $args{do_init} || 0;
    my $make_myconfig = delete $args{make_myconfig};
    $loading = 0 unless defined $loading;

    my $configpm = require_myconfig_or_config;
    my @miss = $self->missing_config_data;
    CPAN->debug("do_init[$do_init]loading[$loading]miss[@miss]") if $CPAN::DEBUG;
    return unless $do_init || @miss;
    if (@miss==1 and $miss[0] eq "pushy_https" && !$do_init) {
        $CPAN::Frontend->myprint(<<'END');

Starting with version 2.29 of the cpan shell, a new download mechanism
is the default which exclusively uses cpan.org as the host to download
from. The configuration variable pushy_https can be used to (de)select
the new mechanism. Please read more about it and make your choice
between the old and the new mechanism by running

    o conf init pushy_https

Once you have done that and stored the config variable this dialog
will disappear.
END

        return;
    }

    # I'm not how we'd ever wind up in a recursive loop, but I'm leaving
    # this here for safety's sake -- dagolden, 2011-01-19
    return if $loading;
    local $loading = ($loading||0) + 1;

    # Warn if we have a config file, but things were found missing
    if ($configpm && @miss && !$do_init) {
        if ($make_myconfig || ( ! -w $configpm && $configpm =~ m{CPAN/Config\.pm})) {
            $configpm = make_new_config();
            $CPAN::Frontend->myprint(<<END);
The system CPAN configuration file has provided some default values,
but you need to complete the configuration dialog for CPAN.pm.
Configuration will be written to
 <<$configpm>>
END
        }
        else {
            $CPAN::Frontend->myprint(<<END);
Sorry, we have to rerun the configuration dialog for CPAN.pm due to
some missing parameters. Configuration will be written to
 <<$configpm>>

END
        }
    }

    require CPAN::FirstTime;
    return CPAN::FirstTime::init($configpm || make_new_config(), %args);
}

# Creates a new, empty config file at the preferred location
# Any existing will be renamed with a ".bak" suffix if possible
# If the file cannot be created, an exception is thrown
sub make_new_config {
    my $configpm = _new_config_name();
    my $configpmdir = File::Basename::dirname( $configpm );
    File::Path::mkpath($configpmdir) unless -d $configpmdir;

    if ( -w $configpmdir ) {
        #_#_# following code dumped core on me with 5.003_11, a.k.
        if( -f $configpm ) {
            my $configpm_bak = "$configpm.bak";
            unlink $configpm_bak if -f $configpm_bak;
            if( rename $configpm, $configpm_bak ) {
                $CPAN::Frontend->mywarn(<<END);
Old configuration file $configpm
    moved to $configpm_bak
END
            }
        }
        my $fh = FileHandle->new;
        if ($fh->open(">$configpm")) {
            $fh->print("1;\n");
            return $configpm;
        }
    }
    _die_cant_write_config($configpm);
}

sub _die_cant_write_config {
    my ($configpm) = @_;
    $CPAN::Frontend->mydie(<<"END");
WARNING: CPAN.pm is unable to write a configuration file.  You
must be able to create and write to '$configpm'.

Aborting configuration.
END

}

# From candidate directories, we would like (in descending preference order):
#   * the one that contains a MyConfig file
#   * one that exists (even without MyConfig)
#   * the first one on the list
sub cpan_home {
    my @dirs = cpan_home_dir_candidates();
    for my $d (@dirs) {
        return $d if -f "$d/CPAN/MyConfig.pm";
    }
    for my $d (@dirs) {
        return $d if -d $d;
    }
    return $dirs[0];
}

sub _new_config_name {
    return File::Spec->catfile(cpan_home(), 'CPAN', 'MyConfig.pm');
}

# returns mandatory but missing entries in the Config
sub missing_config_data {
    my(@miss);
    for (
         "auto_commit",
         "build_cache",
         "build_dir",
         "cache_metadata",
         "cpan_home",
         "ftp_proxy",
         #"gzip",
         "http_proxy",
         "index_expire",
         #"inhibit_startup_message",
         "keep_source_where",
         #"make",
         "make_arg",
         "make_install_arg",
         "makepl_arg",
         "mbuild_arg",
         "mbuild_install_arg",
         ($^O eq "MSWin32" ? "" : "mbuild_install_build_command"),
         "mbuildpl_arg",
         "no_proxy",
         #"pager",
         "prerequisites_policy",
         "pushy_https",
         "scan_cache",
         #"tar",
         #"unzip",
         "urllist",
        ) {
        next unless exists $keys{$_};
        push @miss, $_ unless defined $CPAN::Config->{$_};
    }
    return @miss;
}

sub help {
    $CPAN::Frontend->myprint(q[
Known options:
  commit    commit session changes to disk
  defaults  reload default config values from disk
  help      this help
  init      enter a dialog to set all or a set of parameters

Edit key values as in the following (the "o" is a literal letter o):
  o conf build_cache 15
  o conf build_dir "/foo/bar"
  o conf urllist shift
  o conf urllist unshift ftp://ftp.foo.bar/
  o conf inhibit_startup_message 1

]);
    1; #don't reprint CPAN::Config
}

sub cpl {
    my($word,$line,$pos) = @_;
    $word ||= "";
    CPAN->debug("word[$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
    my(@words) = split " ", substr($line,0,$pos+1);
    if (
        defined($words[2])
        and
        $words[2] =~ /list$/
        and
        (
        @words == 3
        ||
        @words == 4 && length($word)
        )
       ) {
        return grep /^\Q$word\E/, qw(splice shift unshift pop push);
    } elsif (defined($words[2])
             and
             $words[2] eq "init"
             and
            (
             @words == 3
             ||
             @words >= 4 && length($word)
            )) {
        return sort grep /^\Q$word\E/, keys %keys;
    } elsif (@words >= 4) {
        return ();
    }
    my %seen;
    my(@o_conf) =  sort grep { !$seen{$_}++ }
        keys %can,
            keys %$CPAN::Config,
                keys %keys;
    return grep /^\Q$word\E/, @o_conf;
}

sub prefs_lookup {
    my($self,$distro,$what) = @_;

    if ($prefssupport{$what}) {
        return $CPAN::Config->{$what} unless
            $distro
                and $distro->prefs
                    and $distro->prefs->{cpanconfig}
                        and defined $distro->prefs->{cpanconfig}{$what};
        return $distro->prefs->{cpanconfig}{$what};
    } else {
        $CPAN::Frontend->mywarn("Warning: $what not yet officially ".
                                "supported for distroprefs, doing a normal lookup\n");
        return $CPAN::Config->{$what};
    }
}


{
    package
        CPAN::Config; ####::###### #hide from indexer
    # note: J. Nick Koston wrote me that they are using
    # CPAN::Config->commit although undocumented. I suggested
    # CPAN::Shell->o("conf","commit") even when ugly it is at least
    # documented

    # that's why I added the CPAN::Config class with autoload and
    # deprecated warning

    use strict;
    use vars qw($AUTOLOAD $VERSION);
    $VERSION = "5.5012";

    # formerly CPAN::HandleConfig was known as CPAN::Config
    sub AUTOLOAD { ## no critic
        my $class = shift; # e.g. in dh-make-perl: CPAN::Config
        my($l) = $AUTOLOAD;
        $CPAN::Frontend->mywarn("Dispatching deprecated method '$l' to CPAN::HandleConfig\n");
        $l =~ s/.*:://;
        CPAN::HandleConfig->$l(@_);
    }
}

1;

__END__

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:
# vim: ts=4 sts=4 sw=4:
PK     ü2]‘Úoð  ð    CacheMgr.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::CacheMgr;
use strict;
use CPAN::InfoObj;
@CPAN::CacheMgr::ISA = qw(CPAN::InfoObj CPAN);
use Cwd qw(chdir);
use File::Find;

use vars qw(
            $VERSION
);
$VERSION = "5.5002";

package CPAN::CacheMgr;
use strict;

#-> sub CPAN::CacheMgr::as_string ;
sub as_string {
    eval { require Data::Dumper };
    if ($@) {
        return shift->SUPER::as_string;
    } else {
        return Data::Dumper::Dumper(shift);
    }
}

#-> sub CPAN::CacheMgr::cachesize ;
sub cachesize {
    shift->{DU};
}

#-> sub CPAN::CacheMgr::tidyup ;
sub tidyup {
  my($self) = @_;
  return unless $CPAN::META->{LOCK};
  return unless -d $self->{ID};
  my @toremove = grep { $self->{SIZE}{$_}==0 } @{$self->{FIFO}};
  for my $current (0..$#toremove) {
    my $toremove = $toremove[$current];
    $CPAN::Frontend->myprint(sprintf(
                                     "DEL(%d/%d): %s \n",
                                     $current+1,
                                     scalar @toremove,
                                     $toremove,
                                    )
                            );
    return if $CPAN::Signal;
    $self->_clean_cache($toremove);
    return if $CPAN::Signal;
  }
  $self->{FIFO} = [];
}

#-> sub CPAN::CacheMgr::dir ;
sub dir {
    shift->{ID};
}

#-> sub CPAN::CacheMgr::entries ;
sub entries {
    my($self,$dir) = @_;
    return unless defined $dir;
    $self->debug("reading dir[$dir]") if $CPAN::DEBUG;
    $dir ||= $self->{ID};
    my($cwd) = CPAN::anycwd();
    chdir $dir or Carp::croak("Can't chdir to $dir: $!");
    my $dh = DirHandle->new(File::Spec->curdir)
        or Carp::croak("Couldn't opendir $dir: $!");
    my(@entries);
    for ($dh->read) {
        next if $_ eq "." || $_ eq "..";
        if (-f $_) {
            push @entries, File::Spec->catfile($dir,$_);
        } elsif (-d _) {
            push @entries, File::Spec->catdir($dir,$_);
        } else {
            $CPAN::Frontend->mywarn("Warning: weird direntry in $dir: $_\n");
        }
    }
    chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
    sort { -M $a <=> -M $b} @entries;
}

#-> sub CPAN::CacheMgr::disk_usage ;
sub disk_usage {
    my($self,$dir,$fast) = @_;
    return if exists $self->{SIZE}{$dir};
    return if $CPAN::Signal;
    my($Du) = 0;
    if (-e $dir) {
        if (-d $dir) {
            unless (-x $dir) {
                unless (chmod 0755, $dir) {
                    $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
                                            "permission to change the permission; cannot ".
                                            "estimate disk usage of '$dir'\n");
                    $CPAN::Frontend->mysleep(5);
                    return;
                }
            }
        } elsif (-f $dir) {
            # nothing to say, no matter what the permissions
        }
    } else {
        $CPAN::Frontend->mywarn("File or directory '$dir' has gone, ignoring\n");
        return;
    }
    if ($fast) {
        $Du = 0; # placeholder
    } else {
        find(
             sub {
           $File::Find::prune++ if $CPAN::Signal;
           return if -l $_;
           if ($^O eq 'MacOS') {
             require Mac::Files;
             my $cat  = Mac::Files::FSpGetCatInfo($_);
             $Du += $cat->ioFlLgLen() + $cat->ioFlRLgLen() if $cat;
           } else {
             if (-d _) {
               unless (-x _) {
                 unless (chmod 0755, $_) {
                   $CPAN::Frontend->mywarn("I have neither the -x permission nor ".
                                           "the permission to change the permission; ".
                                           "can only partially estimate disk usage ".
                                           "of '$_'\n");
                   $CPAN::Frontend->mysleep(5);
                   return;
                 }
               }
             } else {
               $Du += (-s _);
             }
           }
         },
         $dir
            );
    }
    return if $CPAN::Signal;
    $self->{SIZE}{$dir} = $Du/1024/1024;
    unshift @{$self->{FIFO}}, $dir;
    $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
    $self->{DU} += $Du/1024/1024;
    $self->{DU};
}

#-> sub CPAN::CacheMgr::_clean_cache ;
sub _clean_cache {
    my($self,$dir) = @_;
    return unless -e $dir;
    unless (File::Spec->canonpath(File::Basename::dirname($dir))
            eq File::Spec->canonpath($CPAN::Config->{build_dir})) {
        $CPAN::Frontend->mywarn("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
                                "will not remove\n");
        $CPAN::Frontend->mysleep(5);
        return;
    }
    $self->debug("have to rmtree $dir, will free $self->{SIZE}{$dir}")
        if $CPAN::DEBUG;
    File::Path::rmtree($dir);
    my $id_deleted = 0;
    if ($dir !~ /\.yml$/ && -f "$dir.yml") {
        my $yaml_module = CPAN::_yaml_module();
        if ($CPAN::META->has_inst($yaml_module)) {
            my($peek_yaml) = eval { CPAN->_yaml_loadfile("$dir.yml"); };
            if ($@) {
                $CPAN::Frontend->mywarn("(parse error on '$dir.yml' removing anyway)");
                unlink "$dir.yml" or
                    $CPAN::Frontend->mywarn("(Could not unlink '$dir.yml': $!)");
                return;
            } elsif (my $id = $peek_yaml->[0]{distribution}{ID}) {
                $CPAN::META->delete("CPAN::Distribution", $id);

                # XXX we should restore the state NOW, otherwise this
                # distro does not exist until we read an index. BUG ALERT(?)

                # $CPAN::Frontend->mywarn (" +++\n");
                $id_deleted++;
            }
        }
        unlink "$dir.yml"; # may fail
        unless ($id_deleted) {
            CPAN->debug("no distro found associated with '$dir'");
        }
    }
    $self->{DU} -= $self->{SIZE}{$dir};
    delete $self->{SIZE}{$dir};
}

#-> sub CPAN::CacheMgr::new ;
sub new {
    my($class,$phase) = @_;
    $phase ||= "atstart";
    my $time = time;
    my($debug,$t2);
    $debug = "";
    my $self = {
        ID => $CPAN::Config->{build_dir},
        MAX => $CPAN::Config->{'build_cache'},
        SCAN => $CPAN::Config->{'scan_cache'} || 'atstart',
        DU => 0
    };
    $CPAN::Frontend->mydie("Unknown scan_cache argument: $self->{SCAN}")
        unless $self->{SCAN} =~ /never|atstart|atexit/;
    File::Path::mkpath($self->{ID});
    my $dh = DirHandle->new($self->{ID});
    bless $self, $class;
    $self->scan_cache($phase);
    $t2 = time;
    $debug .= "timing of CacheMgr->new: ".($t2 - $time);
    $time = $t2;
    CPAN->debug($debug) if $CPAN::DEBUG;
    $self;
}

#-> sub CPAN::CacheMgr::scan_cache ;
sub scan_cache {
    my ($self, $phase) = @_;
    $phase = '' unless defined $phase;
    return unless $phase eq $self->{SCAN};
    return unless $CPAN::META->{LOCK};
    $CPAN::Frontend->myprint(
                             sprintf("Scanning cache %s for sizes\n",
                             $self->{ID}));
    my $e;
    my @entries = $self->entries($self->{ID});
    my $i = 0;
    my $painted = 0;
    for $e (@entries) {
        my $symbol = ".";
        if ($self->{DU} > $self->{MAX}) {
            $symbol = "-";
            $self->disk_usage($e,1);
        } else {
            $self->disk_usage($e);
        }
        $i++;
        while (($painted/76) < ($i/@entries)) {
            $CPAN::Frontend->myprint($symbol);
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
    $self->tidyup;
}

1;
PK     ü2]M :Ö.  Ö.    Distroprefs.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:

use 5.006;
use strict;
package CPAN::Distroprefs;

use vars qw($VERSION);
$VERSION = '6.0001';

package CPAN::Distroprefs::Result;

use File::Spec;

sub new { bless $_[1] || {} => $_[0] }

sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }

sub __cloner {
    my ($class, $name, $newclass) = @_;
    $newclass = 'CPAN::Distroprefs::Result::' . $newclass;
    no strict 'refs';
    *{$class . '::' . $name} = sub {
        $newclass->new({
            %{ $_[0] },
            %{ $_[1] },
        });
    };
}
BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
BEGIN { __PACKAGE__->__cloner(as_fatal   => 'Fatal') }
BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }

sub __accessor {
    my ($class, $key) = @_;
    no strict 'refs';
    *{$class . '::' . $key} = sub { $_[0]->{$key} };
}
BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }

sub is_warning { 0 }
sub is_fatal   { 0 }
sub is_success { 0 }

package CPAN::Distroprefs::Result::Error;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }

sub as_string {
    my ($self) = @_;
    if ($self->msg) {
        return sprintf $self->fmt_reason, $self->file, $self->msg;
    } else {
        return sprintf $self->fmt_unknown, $self->file;
    }
}

package CPAN::Distroprefs::Result::Warning;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
sub is_warning { 1 }
sub fmt_reason  { "Error reading distroprefs file %s, skipping: %s" }
sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }

package CPAN::Distroprefs::Result::Fatal;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
sub is_fatal { 1 }
sub fmt_reason  { "Error reading distroprefs file %s: %s" }
sub fmt_unknown { "Unknown error reading distroprefs file %s." }

package CPAN::Distroprefs::Result::Success;
use vars qw(@ISA);
BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
sub is_success { 1 }

package CPAN::Distroprefs::Iterator;

sub new { bless $_[1] => $_[0] }

sub next { $_[0]->() }

package CPAN::Distroprefs;

use Carp ();
use DirHandle;

sub _load_method {
    my ($self, $loader, $result) = @_;
    return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
    return '_load_' . $result->ext;
}

sub _load_yaml {
    my ($self, $loader, $result) = @_;
    my $data = eval {
        $loader eq 'CPAN'
        ? $loader->_yaml_loadfile($result->abs)
        : [ $loader->can('LoadFile')->($result->abs) ]
    };
    if (my $err = $@) {
        die $result->as_warning({
            msg  => $err,
        });
    } elsif (!$data) {
        die $result->as_warning;
    } else {
        return @$data;
    }
}

sub _load_dd {
    my ($self, $loader, $result) = @_;
    my @data;
    {
        package CPAN::Eval;
        # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
        # not sure why we wouldn't just skip the file as we do for all other
        # errors. -- hdp
        my $abs = $result->abs;
        open FH, "<$abs" or die $result->as_fatal(msg => "$!");
        local $/;
        my $eval = <FH>;
        close FH;
        no strict;
        eval $eval;
        if (my $err = $@) {
            die $result->as_warning({ msg => $err });
        }
        my $i = 1;
        while (${"VAR$i"}) {
            push @data, ${"VAR$i"};
            $i++;
        }
    }
    return @data;
}

sub _load_st {
    my ($self, $loader, $result) = @_;
    # eval because Storable is never forward compatible
    my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
    if (my $err = $@) {
        die $result->as_warning({ msg => $err });
    }
    return @data;
}

sub _build_file_list {
    if (@_ > 3) {
        die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
    }
    my ($dir, $dir1, $ext_re) = @_;
    my @list;
    my $dh;
    unless (opendir($dh, $dir)) {
        $CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
        return @list;
    }
    while (my $fn = readdir $dh) {
        next if $fn eq '.' || $fn eq '..';
        if (-d "$dir/$fn") {
            next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
            push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
        } else {
            if ($fn =~ $ext_re) {
                push @list, "$dir1$fn";
            }
        }
    }
    return @list;
}

sub find {
    my ($self, $dir, $ext_map) = @_;

    return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;

    my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
    my $ext_re = qr/\.($possible_ext)$/;

    my @files = _build_file_list($dir, '', $ext_re);
    @files = sort @files if @files;

    # label the block so that we can use redo in the middle
    return CPAN::Distroprefs::Iterator->new(sub { LOOP: {

        my $fn = shift @files;
        return unless defined $fn;
        my ($ext) = $fn =~ $ext_re;

        my $loader = $ext_map->{$ext};

        my $result = CPAN::Distroprefs::Result->new({
            file => $fn, ext => $ext, dir => $dir
        });
        # copied from CPAN.pm; is this ever actually possible?
        redo unless -f $result->abs;

        my $load_method = $self->_load_method($loader, $result);
        my @prefs = eval { $self->$load_method($loader, $result) };
        if (my $err = $@) {
            if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
                return $err;
            }
            # rethrow any exceptions that we did not generate
            die $err;
        } elsif (!@prefs) {
            # the loader should have handled this, but just in case:
            return $result->as_warning;
        }
        return $result->as_success({
            prefs => [
                map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
            ],
        });
    } });
}

package CPAN::Distroprefs::Pref;

use Carp ();

sub new { bless $_[1] => $_[0] }

sub data { shift->{data} }

sub has_any_match { $_[0]->data->{match} ? 1 : 0 }

sub has_match {
    my $match = $_[0]->data->{match} || return 0;
    exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
}

sub has_valid_subkeys {
    grep { exists $_[0]->data->{match}{$_} }
        map { $_, "not_$_" }
        $_[0]->match_attributes
}

sub _pattern {
    my $re = shift;
    my $p = eval sprintf 'qr{%s}', $re;
    if ($@) {
        $@ =~ s/\n$//;
        die "Error in Distroprefs pattern qr{$re}\n$@";
    }
    return $p;
}

sub _match_scalar {
    my ($match, $data) = @_;
    my $qr = _pattern($match);
    return $data =~ /$qr/;
}

sub _match_hash {
    my ($match, $data) = @_;
    for my $mkey (keys %$match) {
	(my $dkey = $mkey) =~ s/^not_//;
        my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
	if (_match_scalar($match->{$mkey}, $val)) {
	    return 0 if $mkey =~ /^not_/;
	}
	else {
	    return 0 if $mkey !~ /^not_/;
	}
    }
    return 1;
}

sub _match {
    my ($self, $key, $data, $matcher) = @_;
    my $m = $self->data->{match};
    if (exists $m->{$key}) {
	return 0 unless $matcher->($m->{$key}, $data);
    }
    if (exists $m->{"not_$key"}) {
	return 0 if $matcher->($m->{"not_$key"}, $data);
    }
    return 1;
}

sub _scalar_match {
    my ($self, $key, $data) = @_;
    return $self->_match($key, $data, \&_match_scalar);
}

sub _hash_match {
    my ($self, $key, $data) = @_;
    return $self->_match($key, $data, \&_match_hash);
}

# do not take the order of C<keys %$match> because "module" is by far the
# slowest
sub match_attributes { qw(env distribution perl perlconfig module) }

sub match_module {
    my ($self, $modules) = @_;
    return $self->_match("module", $modules, sub {
	my($match, $data) = @_;
	my $qr = _pattern($match);
	for my $module (@$data) {
	    return 1 if $module =~ /$qr/;
	}
	return 0;
    });
}

sub match_distribution { shift->_scalar_match(distribution => @_) }
sub match_perl         { shift->_scalar_match(perl         => @_) }

sub match_perlconfig   { shift->_hash_match(perlconfig => @_) }
sub match_env          { shift->_hash_match(env        => @_) }

sub matches {
    my ($self, $arg) = @_;

    my $default_match = 0;
    for my $key (grep { $self->has_match($_) } $self->match_attributes) {
        unless (exists $arg->{$key}) {
            Carp::croak "Can't match pref: missing argument key $key";
        }
        $default_match = 1;
        my $val = $arg->{$key};
        # make it possible to avoid computing things until we have to
        if (ref($val) eq 'CODE') { $val = $val->() }
        my $meth = "match_$key";
        return 0 unless $self->$meth($val);
    }

    return $default_match;
}

1;

__END__

=head1 NAME

CPAN::Distroprefs -- read and match distroprefs

=head1 SYNOPSIS

    use CPAN::Distroprefs;

    my %info = (... distribution/environment info ...);

    my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);

    while (my $result = $finder->next) {

        die $result->as_string if $result->is_fatal;

        warn($result->as_string), next if $result->is_warning;

        for my $pref (@{ $result->prefs }) {
            if ($pref->matches(\%info)) {
                return $pref;
            }
        }
    }


=head1 DESCRIPTION

This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.

=head1 INTERFACE

    my $finder = CPAN::Distroprefs->find($dir, \%ext_map);

    while (my $result = $finder->next) { ... }

Build an iterator which finds distroprefs files in the tree below the
given directory. Within the tree directories matching C<m/^[._]/> are
pruned.

C<%ext_map> is a hashref whose keys are file extensions and whose values are
modules used to load matching files:

    {
        'yml' => 'YAML::Syck',
        'dd'  => 'Data::Dumper',
        ...
    }

Each time C<< $finder->next >> is called, the iterator returns one of two
possible values:

=over

=item * a CPAN::Distroprefs::Result object

=item * C<undef>, indicating that no prefs files remain to be found

=back

=head1 RESULTS

L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
indicate success or failure when reading a prefs file.

=head2 Common

All results share some common attributes:

=head3 type

C<success>, C<warning>, or C<fatal>

=head3 file

the file from which these prefs were read, or to which this error refers (relative filename)

=head3 ext

the file's extension, which determines how to load it

=head3 dir

the directory the file was read from

=head3 abs

the absolute path to the file

=head2 Errors

Error results (warning and fatal) contain:

=head3 msg

the error message (usually either C<$!> or a YAML error)

=head2 Successes

Success results contain:

=head3 prefs

an arrayref of CPAN::Distroprefs::Pref objects

=head1 PREFS

CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C<success> results from C<find()>.

=head3 data

the pref information as a hashref, suitable for e.g. passing to Kwalify

=head3 match_attributes

returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)

currently: C<env perl perlconfig distribution module>

=head3 has_any_match

true if this pref has a 'match' attribute at all

=head3 has_valid_subkeys

true if this pref has a 'match' attribute and at least one valid match attribute

=head3 matches

  if ($pref->matches(\%arg)) { ... }

true if this pref matches the passed-in hashref, which must have a value for
each of the C<match_attributes> (above)

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
PK     ü2]¶†ä½   ½     DeferredCode.pmnu ÏÃ6Ç$        package CPAN::DeferredCode;

use strict;
use vars qw/$VERSION/;

use overload fallback => 1, map { ($_ => 'run') } qw/
    bool "" 0+
/;

$VERSION = "5.50";

sub run {
    $_[0]->();
}

1;
PK     ü2]7ªSº  º  	  Author.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Author;
use strict;

use CPAN::InfoObj;
@CPAN::Author::ISA = qw(CPAN::InfoObj);
use vars qw(
            $VERSION
);
$VERSION = "5.5002";

package CPAN::Author;
use strict;

#-> sub CPAN::Author::force
sub force {
    my $self = shift;
    $self->{force}++;
}

#-> sub CPAN::Author::force
sub unforce {
    my $self = shift;
    delete $self->{force};
}

#-> sub CPAN::Author::id
sub id {
    my $self = shift;
    my $id = $self->{ID};
    $CPAN::Frontend->mydie("Illegal author id[$id]") unless $id =~ /^[A-Z]/;
    $id;
}

#-> sub CPAN::Author::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    push @m, sprintf(qq{%-15s %s ("%s" <%s>)\n},
                     $class,
                     $self->{ID},
                     $self->fullname,
                     $self->email);
    join "", @m;
}

#-> sub CPAN::Author::fullname ;
sub fullname {
    shift->ro->{FULLNAME};
}
*name = \&fullname;

#-> sub CPAN::Author::email ;
sub email    { shift->ro->{EMAIL}; }

#-> sub CPAN::Author::ls ;
sub ls {
    my $self = shift;
    my $glob = shift || "";
    my $silent = shift || 0;
    my $id = $self->id;

    # adapted from CPAN::Distribution::verifyCHECKSUM ;
    my(@csf); # chksumfile
    @csf = $self->id =~ /(.)(.)(.*)/;
    $csf[1] = join "", @csf[0,1];
    $csf[2] = join "", @csf[1,2]; # ("A","AN","ANDK")
    my(@dl);
    @dl = $self->dir_listing([$csf[0],"CHECKSUMS"], 0, 1);
    unless (grep {$_->[2] eq $csf[1]} @dl) {
        $CPAN::Frontend->myprint("Directory $csf[1]/ does not exist\n") unless $silent ;
        return;
    }
    @dl = $self->dir_listing([@csf[0,1],"CHECKSUMS"], 0, 1);
    unless (grep {$_->[2] eq $csf[2]} @dl) {
        $CPAN::Frontend->myprint("Directory $id/ does not exist\n") unless $silent;
        return;
    }
    @dl = $self->dir_listing([@csf,"CHECKSUMS"], 1, 1);
    if ($glob) {
        if ($CPAN::META->has_inst("Text::Glob")) {
            $glob =~ s|/$|/*|;
            my $rglob = Text::Glob::glob_to_regex($glob);
            CPAN->debug("glob[$glob]rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
            my @tmpdl = grep { $_->[2] =~ /$rglob/ } @dl;
            if (1==@tmpdl && $tmpdl[0][0]==0) {
                $rglob = Text::Glob::glob_to_regex("$glob/*");
                @dl = grep { $_->[2] =~ /$rglob/ } @dl;
            } else {
                @dl = @tmpdl;
            }
            CPAN->debug("rglob[$rglob]dl[@dl]") if $CPAN::DEBUG;
        } else {
            $CPAN::Frontend->mydie("Text::Glob not installed, cannot proceed");
        }
    }
    unless ($silent >= 2) {
        $CPAN::Frontend->myprint
            (
             join "",
             map {
                 sprintf
                     (
                      "%8d %10s %s/%s%s\n",
                      $_->[0],
                      $_->[1],
                      $id,
                      $_->[2],
                      0==$_->[0]?"/":"",
                     )
                 } sort { $a->[2] cmp $b->[2] } @dl
            );
    }
    @dl;
}

# returns an array of arrays, the latter contain (size,mtime,filename)
#-> sub CPAN::Author::dir_listing ;
sub dir_listing {
    my $self = shift;
    my $chksumfile = shift;
    my $recursive = shift;
    my $may_ftp = shift;

    my $lc_want =
        File::Spec->catfile($CPAN::Config->{keep_source_where},
                            "authors", "id", @$chksumfile);

    my $fh;

    CPAN->debug("chksumfile[@$chksumfile]recursive[$recursive]may_ftp[$may_ftp]") if $CPAN::DEBUG;
    # Purge and refetch old (pre-PGP) CHECKSUMS; they are a security
    # hazard.  (Without GPG installed they are not that much better,
    # though.)
    $fh = FileHandle->new;
    if (open($fh, $lc_want)) {
        my $line = <$fh>; close $fh;
        unlink($lc_want) unless $line =~ /PGP/;
    }

    local($") = "/";
    # connect "force" argument with "index_expire".
    my $force = $self->{force};
    if (my @stat = stat $lc_want) {
        $force ||= $stat[9] + $CPAN::Config->{index_expire}*86400 <= time;
    }
    my $lc_file;
    if ($may_ftp) {
        $lc_file = eval {
            CPAN::FTP->localize
                    (
                     "authors/id/@$chksumfile",
                     $lc_want,
                     $force,
                    );
        };
        unless ($lc_file) {
            $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
            $chksumfile->[-1] .= ".gz";
            $lc_file = eval {
                CPAN::FTP->localize
                        ("authors/id/@$chksumfile",
                         "$lc_want.gz",
                         1,
                        );
            };
            if ($lc_file) {
                $lc_file =~ s{\.gz(?!\n)\Z}{}; #};
                eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
            } else {
                return;
            }
        }
    } else {
        $lc_file = $lc_want;
        # we *could* second-guess and if the user has a file: URL,
        # then we could look there. But on the other hand, if they do
        # have a file: URL, why did they choose to set
        # $CPAN::Config->{show_upload_date} to false?
    }

    # adapted from CPAN::Distribution::CHECKSUM_check_file ;
    $fh = FileHandle->new;
    my($cksum);
    if (open $fh, $lc_file) {
        local($/);
        my $eval = <$fh>;
        $eval =~ s/\015?\012/\n/g;
        close $fh;
        my($compmt) = Safe->new();
        $cksum = $compmt->reval($eval);
        if ($@) {
            rename $lc_file, "$lc_file.bad";
            Carp::confess($@) if $@;
        }
    } elsif ($may_ftp) {
        Carp::carp ("Could not open '$lc_file' for reading.");
    } else {
        # Maybe should warn: "You may want to set show_upload_date to a true value"
        return;
    }
    my(@result,$f);
    for $f (sort keys %$cksum) {
        if (exists $cksum->{$f}{isdir}) {
            if ($recursive) {
                my(@dir) = @$chksumfile;
                pop @dir;
                push @dir, $f, "CHECKSUMS";
                push @result, [ 0, "-", $f ];
                push @result, map {
                    [$_->[0], $_->[1], "$f/$_->[2]"]
                } $self->dir_listing(\@dir,1,$may_ftp);
            } else {
                push @result, [ 0, "-", $f ];
            }
        } else {
            push @result, [
                           ($cksum->{$f}{"size"}||0),
                           $cksum->{$f}{"mtime"}||"---",
                           $f
                          ];
        }
    }
    @result;
}

#-> sub CPAN::Author::reports
sub reports {
    $CPAN::Frontend->mywarn("reports on authors not implemented.
Please file a bugreport if you need this.\n");
}

1;
PK     ü2]½Y3Á A   A  	  Tarzip.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Tarzip;
use strict;
use vars qw($VERSION @ISA $BUGHUNTING);
use CPAN::Debug;
use File::Basename qw(basename);
$VERSION = "5.5013";
# module is internal to CPAN.pm

@ISA = qw(CPAN::Debug); ## no critic
$BUGHUNTING ||= 0; # released code must have turned off

# it's ok if file doesn't exist, it just matters if it is .gz or .bz2
sub new {
    my($class,$file) = @_;
    $CPAN::Frontend->mydie("CPAN::Tarzip->new called without arg") unless defined $file;
    my $me = { FILE => $file };
    if ($file =~ /\.(bz2|gz|zip|tbz|tgz)$/i) {
        $me->{ISCOMPRESSED} = 1;
    } else {
        $me->{ISCOMPRESSED} = 0;
    }
    if (0) {
    } elsif ($file =~ /\.(?:bz2|tbz)$/i) {
        unless ($me->{UNGZIPPRG} = $CPAN::Config->{bzip2}) {
            my $bzip2 = _my_which("bzip2");
            if ($bzip2) {
                $me->{UNGZIPPRG} = $bzip2;
            } else {
                $CPAN::Frontend->mydie(qq{
CPAN.pm needs the external program bzip2 in order to handle '$file'.
Please install it now and run 'o conf init bzip2' from the
CPAN shell prompt to register it as external program.
});
            }
        }
    } else {
        $me->{UNGZIPPRG} = _my_which("gzip");
    }
    $me->{TARPRG} = _my_which("tar") || _my_which("gtar");
    bless $me, $class;
}

sub _zlib_ok () {
    $CPAN::META->has_inst("Compress::Zlib") or return;
    Compress::Zlib->can('gzopen');
}

sub _my_which {
    my($what) = @_;
    if ($CPAN::Config->{$what}) {
        return $CPAN::Config->{$what};
    }
    if ($CPAN::META->has_inst("File::Which")) {
        return File::Which::which($what);
    }
    my @cand = MM->maybe_command($what);
    return $cand[0] if @cand;
    require File::Spec;
    my $component;
  PATH_COMPONENT: foreach $component (File::Spec->path()) {
        next unless defined($component) && $component;
        my($abs) = File::Spec->catfile($component,$what);
        if (MM->maybe_command($abs)) {
            return $abs;
        }
    }
    return;
}

sub gzip {
    my($self,$read) = @_;
    my $write = $self->{FILE};
    if (_zlib_ok) {
        my($buffer,$fhw);
        $fhw = FileHandle->new($read)
            or $CPAN::Frontend->mydie("Could not open $read: $!");
        my $cwd = `pwd`;
        my $gz = Compress::Zlib::gzopen($write, "wb")
            or $CPAN::Frontend->mydie("Cannot gzopen $write: $! (pwd is $cwd)\n");
        binmode($fhw);
        $gz->gzwrite($buffer)
            while read($fhw,$buffer,4096) > 0 ;
        $gz->gzclose() ;
        $fhw->close;
        return 1;
    } else {
        my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
        system(qq{$command -c "$read" > "$write"})==0;
    }
}


sub gunzip {
    my($self,$write) = @_;
    my $read = $self->{FILE};
    if (_zlib_ok) {
        my($buffer,$fhw);
        $fhw = FileHandle->new(">$write")
            or $CPAN::Frontend->mydie("Could not open >$write: $!");
        my $gz = Compress::Zlib::gzopen($read, "rb")
            or $CPAN::Frontend->mydie("Cannot gzopen $read: $!\n");
        binmode($fhw);
        $fhw->print($buffer)
            while $gz->gzread($buffer) > 0 ;
        $CPAN::Frontend->mydie("Error reading from $read: $!\n")
            if $gz->gzerror != Compress::Zlib::Z_STREAM_END();
        $gz->gzclose() ;
        $fhw->close;
        return 1;
    } else {
        my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
        system(qq{$command -d -c "$read" > "$write"})==0;
    }
}


sub gtest {
    my($self) = @_;
    return $self->{GTEST} if exists $self->{GTEST};
    defined $self->{FILE} or $CPAN::Frontend->mydie("gtest called but no FILE specified");
    my $read = $self->{FILE};
    my $success;
    if ($read=~/\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
        my($buffer,$len);
        $len = 0;
        my $gz = Compress::Bzip2::bzopen($read, "rb")
            or $CPAN::Frontend->mydie(sprintf("Cannot bzopen %s: %s\n",
                                              $read,
                                              $Compress::Bzip2::bzerrno));
        while ($gz->bzread($buffer) > 0 ) {
            $len += length($buffer);
            $buffer = "";
        }
        my $err = $gz->bzerror;
        $success = ! $err || $err == Compress::Bzip2::BZ_STREAM_END();
        if ($len == -s $read) {
            $success = 0;
            CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
        }
        $gz->gzclose();
        CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
    } elsif ( $read=~/\.(?:gz|tgz)$/ && _zlib_ok ) {
        # After I had reread the documentation in zlib.h, I discovered that
        # uncompressed files do not lead to an gzerror (anymore?).
        my($buffer,$len);
        $len = 0;
        my $gz = Compress::Zlib::gzopen($read, "rb")
            or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n",
                                              $read,
                                              $Compress::Zlib::gzerrno));
        while ($gz->gzread($buffer) > 0 ) {
            $len += length($buffer);
            $buffer = "";
        }
        my $err = $gz->gzerror;
        $success = ! $err || $err == Compress::Zlib::Z_STREAM_END();
        if ($len == -s $read) {
            $success = 0;
            CPAN->debug("hit an uncompressed file") if $CPAN::DEBUG;
        }
        $gz->gzclose();
        CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG;
    } elsif (!$self->{ISCOMPRESSED}) {
        $success = 0;
    } else {
        my $command = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
        $success = 0==system(qq{$command -qdt "$read"});
    }
    return $self->{GTEST} = $success;
}


sub TIEHANDLE {
    my($class,$file) = @_;
    my $ret;
    $class->debug("file[$file]");
    my $self = $class->new($file);
    if (0) {
    } elsif (!$self->gtest) {
        my $fh = FileHandle->new($file)
            or $CPAN::Frontend->mydie("Could not open file[$file]: $!");
        binmode $fh;
        $self->{FH} = $fh;
        $class->debug("via uncompressed FH");
    } elsif ($file =~ /\.(?:bz2|tbz)$/ && $CPAN::META->has_inst("Compress::Bzip2")) {
        my $gz = Compress::Bzip2::bzopen($file,"rb") or
            $CPAN::Frontend->mydie("Could not bzopen $file");
        $self->{GZ} = $gz;
        $class->debug("via Compress::Bzip2");
    } elsif ($file =~/\.(?:gz|tgz)$/ && _zlib_ok) {
        my $gz = Compress::Zlib::gzopen($file,"rb") or
            $CPAN::Frontend->mydie("Could not gzopen $file");
        $self->{GZ} = $gz;
        $class->debug("via Compress::Zlib");
    } else {
        my $gzip = CPAN::HandleConfig->safe_quote($self->{UNGZIPPRG});
        my $pipe = "$gzip -d -c $file |";
        my $fh = FileHandle->new($pipe) or $CPAN::Frontend->mydie("Could not pipe[$pipe]: $!");
        binmode $fh;
        $self->{FH} = $fh;
        $class->debug("via external $gzip");
    }
    $self;
}


sub READLINE {
    my($self) = @_;
    if (exists $self->{GZ}) {
        my $gz = $self->{GZ};
        my($line,$bytesread);
        $bytesread = $gz->gzreadline($line);
        return undef if $bytesread <= 0;
        return $line;
    } else {
        my $fh = $self->{FH};
        return scalar <$fh>;
    }
}


sub READ {
    my($self,$ref,$length,$offset) = @_;
    $CPAN::Frontend->mydie("read with offset not implemented") if defined $offset;
    if (exists $self->{GZ}) {
        my $gz = $self->{GZ};
        my $byteread = $gz->gzread($$ref,$length);# 30eaf79e8b446ef52464b5422da328a8
        return $byteread;
    } else {
        my $fh = $self->{FH};
        return read($fh,$$ref,$length);
    }
}


sub DESTROY {
    my($self) = @_;
    if (exists $self->{GZ}) {
        my $gz = $self->{GZ};
        $gz->gzclose() if defined $gz; # hard to say if it is allowed
                                       # to be undef ever. AK, 2000-09
    } else {
        my $fh = $self->{FH};
        $fh->close if defined $fh;
    }
    undef $self;
}

sub untar {
    my($self) = @_;
    my $file = $self->{FILE};
    my($prefer) = 0;

    my $exttar = $self->{TARPRG} || "";
    $exttar = "" if $exttar =~ /^\s+$/; # user refuses to use it
    my $extgzip = $self->{UNGZIPPRG} || "";
    $extgzip = "" if $extgzip =~ /^\s+$/; # user refuses to use it

    if (0) { # makes changing order easier
    } elsif ($BUGHUNTING) {
        $prefer=2;
    } elsif ($CPAN::Config->{prefer_external_tar}) {
        $prefer = 1;
    } elsif (
             $CPAN::META->has_usable("Archive::Tar")
             &&
             _zlib_ok ) {
        my $prefer_external_tar = $CPAN::Config->{prefer_external_tar};
        unless (defined $prefer_external_tar) {
            if ($^O =~ /(MSWin32|solaris)/) {
                $prefer_external_tar = 0;
            } else {
                $prefer_external_tar = 1;
            }
        }
        $prefer = $prefer_external_tar ? 1 : 2;
    } elsif ($exttar && $extgzip) {
        # no modules and not bz2
        $prefer = 1;
        # but solaris binary tar is a problem
        if ($^O eq 'solaris' && qx($exttar --version 2>/dev/null) !~ /gnu/i) {
            $CPAN::Frontend->mywarn(<< 'END_WARN');

WARNING: Many CPAN distributions were archived with GNU tar and some of
them may be incompatible with Solaris tar.  We respectfully suggest you
configure CPAN to use a GNU tar instead ("o conf init tar") or install
a recent Archive::Tar instead;

END_WARN
        }
    } else {
        my $foundtar = $exttar ? "'$exttar'" : "nothing";
        my $foundzip = $extgzip ? "'$extgzip'" : $foundtar ? "nothing" : "also nothing";
        my $foundAT;
        if ($CPAN::META->has_usable("Archive::Tar")) {
            $foundAT = sprintf "'%s'", "Archive::Tar::"->VERSION;
        } else {
            $foundAT = "nothing";
        }
        my $foundCZ;
        if (_zlib_ok) {
            $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION;
        } elsif ($foundAT) {
            $foundCZ = "nothing";
        } else {
            $foundCZ = "also nothing";
        }
        $CPAN::Frontend->mydie(qq{

CPAN.pm needs either the external programs tar and gzip -or- both
modules Archive::Tar and Compress::Zlib installed.

For tar I found $foundtar, for gzip $foundzip.

For Archive::Tar I found $foundAT, for Compress::Zlib $foundCZ;

Can't continue cutting file '$file'.
});
    }
    my $tar_verb = "v";
    if (defined $CPAN::Config->{tar_verbosity}) {
        $tar_verb = $CPAN::Config->{tar_verbosity} eq "none" ? "" :
            $CPAN::Config->{tar_verbosity};
    }
    if ($prefer==1) { # 1 => external gzip+tar
        my($system);
        my $is_compressed = $self->gtest();
        my $tarcommand = CPAN::HandleConfig->safe_quote($exttar);
        if ($is_compressed) {
            my $command = CPAN::HandleConfig->safe_quote($extgzip);
            $system = qq{$command -d -c }.
                qq{< "$file" | $tarcommand x${tar_verb}f -};
        } else {
            $system = qq{$tarcommand x${tar_verb}f "$file"};
        }
        if (system($system) != 0) {
            # people find the most curious tar binaries that cannot handle
            # pipes
            if ($is_compressed) {
                (my $ungzf = $file) =~ s/\.gz(?!\n)\Z//;
                $ungzf = basename $ungzf;
                my $ct = CPAN::Tarzip->new($file);
                if ($ct->gunzip($ungzf)) {
                    $CPAN::Frontend->myprint(qq{Uncompressed $file successfully\n});
                } else {
                    $CPAN::Frontend->mydie(qq{Couldn\'t uncompress $file\n});
                }
                $file = $ungzf;
            }
            $system = qq{$tarcommand x${tar_verb}f "$file"};
            $CPAN::Frontend->myprint(qq{Using Tar:$system:\n});
            my $ret = system($system);
            if ($ret==0) {
                $CPAN::Frontend->myprint(qq{Untarred $file successfully\n});
            } else {
                if ($? == -1) {
                    $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: '%s'\n},
                                           $file, $!);
                } elsif ($? & 127) {
                    $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child died with signal %d, %s coredump\n},
                                           $file, ($? & 127),  ($? & 128) ? 'with' : 'without');
                } else {
                    $CPAN::Frontend->mydie(sprintf qq{Couldn\'t untar %s: child exited with value %d\n},
                                           $file, $? >> 8);
                }
            }
            return 1;
        } else {
            return 1;
        }
    } elsif ($prefer==2) { # 2 => modules
        unless ($CPAN::META->has_usable("Archive::Tar")) {
            $CPAN::Frontend->mydie("Archive::Tar not installed, please install it to continue");
        }
        # Make sure AT does not use uid/gid/permissions in the archive
        # This leaves it to the user's umask instead
        local $Archive::Tar::CHMOD = 1;
        local $Archive::Tar::SAME_PERMISSIONS = 0;
        # Make sure AT leaves current user as owner
        local $Archive::Tar::CHOWN = 0;
        my $tar = Archive::Tar->new($file,1);
        my $af; # archive file
        my @af;
        if ($BUGHUNTING) {
            # RCS 1.337 had this code, it turned out unacceptable slow but
            # it revealed a bug in Archive::Tar. Code is only here to hunt
            # the bug again. It should never be enabled in published code.
            # GDGraph3d-0.53 was an interesting case according to Larry
            # Virden.
            warn(">>>Bughunting code enabled<<< " x 20);
            for $af ($tar->list_files) {
                if ($af =~ m!^(/|\.\./)!) {
                    $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                           "illegal member [$af]");
                }
                $CPAN::Frontend->myprint("$af\n");
                $tar->extract($af); # slow but effective for finding the bug
                return if $CPAN::Signal;
            }
        } else {
            for $af ($tar->list_files) {
                if ($af =~ m!^(/|\.\./)!) {
                    $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                           "illegal member [$af]");
                }
                if ($tar_verb eq "v" || $tar_verb eq "vv") {
                    $CPAN::Frontend->myprint("$af\n");
                }
                push @af, $af;
                return if $CPAN::Signal;
            }
            $tar->extract(@af) or
                $CPAN::Frontend->mydie("Could not untar with Archive::Tar.");
        }

        Mac::BuildTools::convert_files([$tar->list_files], 1)
            if ($^O eq 'MacOS');

        return 1;
    }
}

sub unzip {
    my($self) = @_;
    my $file = $self->{FILE};
    if ($CPAN::META->has_inst("Archive::Zip")) {
        # blueprint of the code from Archive::Zip::Tree::extractTree();
        my $zip = Archive::Zip->new();
        my $status;
        $status = $zip->read($file);
        $CPAN::Frontend->mydie("Read of file[$file] failed\n")
            if $status != Archive::Zip::AZ_OK();
        $CPAN::META->debug("Successfully read file[$file]") if $CPAN::DEBUG;
        my @members = $zip->members();
        for my $member ( @members ) {
            my $af = $member->fileName();
            if ($af =~ m!^(/|\.\./)!) {
                $CPAN::Frontend->mydie("ALERT: Archive contains ".
                                       "illegal member [$af]");
            }
            $status = $member->extractToFileNamed( $af );
            $CPAN::META->debug("af[$af]status[$status]") if $CPAN::DEBUG;
            $CPAN::Frontend->mydie("Extracting of file[$af] from zipfile[$file] failed\n") if
                $status != Archive::Zip::AZ_OK();
            return if $CPAN::Signal;
        }
        return 1;
    } elsif ( my $unzip = $CPAN::Config->{unzip}  ) {
        my @system = ($unzip, $file);
        return system(@system) == 0;
    }
    else {
            $CPAN::Frontend->mydie(<<"END");

Can't unzip '$file':

You have not configured an 'unzip' program and do not have Archive::Zip
installed.  Please either install Archive::Zip or else configure 'unzip'
by running the command 'o conf init unzip' from the CPAN shell prompt.

END
    }
}

1;

__END__

=head1 NAME

CPAN::Tarzip - internal handling of tar archives for CPAN.pm

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
PK     ü2]iÛ¨DÌ  Ì    Distrostatus.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Distrostatus;
use overload '""' => "as_string",
    fallback => 1;
use vars qw($something_has_failed_at);
use vars qw(
            $VERSION
);
$VERSION = "5.5";


sub new {
    my($class,$arg) = @_;
    my $failed = substr($arg,0,2) eq "NO";
    if ($failed) {
        $something_has_failed_at = $CPAN::CurrentCommandId;
    }
    bless {
           TEXT => $arg,
           FAILED => $failed,
           COMMANDID => $CPAN::CurrentCommandId,
           TIME => time,
          }, $class;
}
sub something_has_just_failed () {
    defined $something_has_failed_at &&
        $something_has_failed_at == $CPAN::CurrentCommandId;
}
sub commandid { shift->{COMMANDID} }
sub failed { shift->{FAILED} }
sub text {
    my($self,$set) = @_;
    if (defined $set) {
        $self->{TEXT} = $set;
    }
    $self->{TEXT};
}
sub as_string {
    my($self) = @_;
    $self->text;
}


1;
PK     ü2]*ƒ^˜  ˜    Exception/blocked_urllist.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::blocked_urllist;
use strict;
use overload '""' => "as_string";

use vars qw(
            $VERSION
);
$VERSION = "1.001";


sub new {
    my($class) = @_;
    bless {}, $class;
}

sub as_string {
    my($self) = shift;
    if ($CPAN::Config->{connect_to_internet_ok}) {
        return qq{

You have not configured a urllist for CPAN mirrors. Configure it with

    o conf init urllist

};
    } else {
        return qq{

You have not configured a urllist and do not allow connections to the
internet to get a list of mirrors.  If you wish to get a list of CPAN
mirrors to pick from, use this command

    o conf init connect_to_internet_ok urllist

If you do not wish to get a list of mirrors and would prefer to set
your urllist manually, use just this command instead

    o conf init urllist

};
    }
}

1;
PK     ü2]ž¹º1.  .     Exception/RecursiveDependency.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::RecursiveDependency;
use strict;
use overload '""' => "as_string";

use vars qw(
            $VERSION
);
$VERSION = "5.5001";

{
    package CPAN::Exception::RecursiveDependency::na;
    use overload '""' => "as_string";
    sub new { bless {}, shift };
    sub as_string { "N/A" };
}

my $NA = CPAN::Exception::RecursiveDependency::na->new;

# a module sees its distribution (no version)
# a distribution sees its prereqs (which are module names) (usually with versions)
# a bundle sees its module names and/or its distributions (no version)

sub new {
    my($class) = shift;
    my($deps_arg) = shift;
    my (@deps,%seen,$loop_starts_with);
  DCHAIN: for my $dep (@$deps_arg) {
        push @deps, {name => $dep, display_as => $dep};
        if ($seen{$dep}++) {
            $loop_starts_with = $dep;
            last DCHAIN;
        }
    }
    my $in_loop = 0;
    my %mark;
 DWALK: for my $i (0..$#deps) {
        my $x = $deps[$i]{name};
        $in_loop ||= $loop_starts_with && $x eq $loop_starts_with;
        my $xo = CPAN::Shell->expandany($x) or next;
        if ($xo->isa("CPAN::Module")) {
            my $have = $xo->inst_version || $NA;
            my($want,$d,$want_type);
            if ($i>0 and $d = $deps[$i-1]{name}) {
                my $do = CPAN::Shell->expandany($d);
                $want = $do->{prereq_pm}{requires}{$x};
                if (defined $want) {
                    $want_type = "requires: ";
                } else {
                    $want = $do->{prereq_pm}{build_requires}{$x};
                    if (defined $want) {
                        $want_type = "build_requires: ";
                    } else {
                        $want_type = "unknown status";
                        $want = "???";
                    }
                }
            } else {
                $want = $xo->cpan_version;
                $want_type = "want: ";
            }
            $deps[$i]{have} = $have;
            $deps[$i]{want_type} = $want_type;
            $deps[$i]{want} = $want;
            $deps[$i]{display_as} = "$x (have: $have; $want_type$want)";
            if ((! ref $have || !$have->isa('CPAN::Exception::RecursiveDependency::na'))
                && CPAN::Version->vge($have, $want)) {
                # https://rt.cpan.org/Ticket/Display.html?id=115340
                undef $loop_starts_with;
                last DWALK;
            }
        } elsif ($xo->isa("CPAN::Distribution")) {
            my $pretty = $deps[$i]{display_as} = $xo->pretty_id;
            my $mark_as;
            if ($in_loop) {
                $mark_as = CPAN::Distrostatus->new("NO cannot resolve circular dependency");
            } else {
                $mark_as = CPAN::Distrostatus->new("NO one dependency ($loop_starts_with) is a circular dependency");
            }
            $mark{$pretty} = { xo => $xo, mark_as => $mark_as };
        }
    }
    if ($loop_starts_with) {
        while (my($k,$v) = each %mark) {
            my $xo = $v->{xo};
            $xo->{make} = $v->{mark_as};
            $xo->store_persistent_state; # otherwise I will not reach
                                         # all involved parties for
                                         # the next session
        }
    }
    bless { deps => \@deps, loop_starts_with => $loop_starts_with }, $class;
}

sub is_resolvable {
    ! defined shift->{loop_starts_with};
}

sub as_string {
    my($self) = shift;
    my $deps = $self->{deps};
    my $loop_starts_with = $self->{loop_starts_with};
    unless ($loop_starts_with) {
        return "--not a recursive/circular dependency--";
    }
    my $ret = "\nRecursive dependency detected:\n    ";
    $ret .= join("\n => ", map {$_->{display_as}} @$deps);
    $ret .= ".\nCannot resolve.\n";
    $ret;
}

1;
PK     ü2]T–òê  ê    Exception/yaml_not_installed.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::yaml_not_installed;
use strict;
use overload '""' => "as_string";

use vars qw(
            $VERSION
);
$VERSION = "5.5";


sub new {
    my($class,$module,$file,$during) = @_;
    bless { module => $module, file => $file, during => $during }, $class;
}

sub as_string {
    my($self) = shift;
    "'$self->{module}' not installed, cannot $self->{during} '$self->{file}'\n";
}

1;
PK     ü2]´Ü‘H§  §    Exception/yaml_process_error.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Exception::yaml_process_error;
use strict;
use overload '""' => "as_string";

use vars qw(
            $VERSION
);
$VERSION = "5.5";


sub new {
    my($class,$module,$file,$during,$error) = @_;
    # my $at = Carp::longmess(""); # XXX find something more beautiful
    bless { module => $module,
            file => $file,
            during => $during,
            error => $error,
            # at => $at,
          }, $class;
}

sub as_string {
    my($self) = shift;
    if ($self->{during}) {
        if ($self->{file}) {
            if ($self->{module}) {
                if ($self->{error}) {
                    return "Alert: While trying to '$self->{during}' YAML file\n".
                        " '$self->{file}'\n".
                            "with '$self->{module}' the following error was encountered:\n".
                                "  $self->{error}\n";
                } else {
                    return "Alert: While trying to '$self->{during}' YAML file\n".
                        " '$self->{file}'\n".
                            "with '$self->{module}' some unknown error was encountered\n";
                }
            } else {
                return "Alert: While trying to '$self->{during}' YAML file\n".
                    " '$self->{file}'\n".
                        "some unknown error was encountered\n";
            }
        } else {
            return "Alert: While trying to '$self->{during}' some YAML file\n".
                    "some unknown error was encountered\n";
        }
    } else {
        return "Alert: unknown error encountered\n";
    }
}

1;
PK     ü2]×šÄ9L  L    URL.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::URL;
use overload '""' => "as_string", fallback => 1;
# accessors: TEXT(the url string), FROM(DEF=>defaultlist,USER=>urllist),
# planned are things like age or quality

use vars qw(
            $VERSION
);
$VERSION = "5.5";

sub new {
    my($class,%args) = @_;
    bless {
           %args
          }, $class;
}
sub as_string {
    my($self) = @_;
    $self->text;
}
sub text {
    my($self,$set) = @_;
    if (defined $set) {
        $self->{TEXT} = $set;
    }
    $self->{TEXT};
}

1;
PK     ü2]>+ò  ò    LWP/UserAgent.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::LWP::UserAgent;
use strict;
use vars qw(@ISA $USER $PASSWD $SETUPDONE);
use CPAN::HTTP::Credentials;
# we delay requiring LWP::UserAgent and setting up inheritance until we need it

$CPAN::LWP::UserAgent::VERSION = $CPAN::LWP::UserAgent::VERSION = "1.9601";


sub config {
    return if $SETUPDONE;
    if ($CPAN::META->has_usable('LWP::UserAgent')) {
        require LWP::UserAgent;
        @ISA = qw(Exporter LWP::UserAgent); ## no critic
        $SETUPDONE++;
    } else {
        $CPAN::Frontend->mywarn("  LWP::UserAgent not available\n");
    }
}

sub get_basic_credentials {
    my($self, $realm, $uri, $proxy) = @_;
    if ( $proxy ) {
        return CPAN::HTTP::Credentials->get_proxy_credentials();
    } else {
        return CPAN::HTTP::Credentials->get_non_proxy_credentials();
    }
}

sub no_proxy {
    my ( $self, $no_proxy ) = @_;
    return $self->SUPER::no_proxy( split(',',$no_proxy) );
}

# mirror(): Its purpose is to deal with proxy authentication. When we
# call SUPER::mirror, we really call the mirror method in
# LWP::UserAgent. LWP::UserAgent will then call
# $self->get_basic_credentials or some equivalent and this will be
# $self->dispatched to our own get_basic_credentials method.

# Our own get_basic_credentials sets $USER and $PASSWD, two globals.

# 407 stands for HTTP_PROXY_AUTHENTICATION_REQUIRED. Which means
# although we have gone through our get_basic_credentials, the proxy
# server refuses to connect. This could be a case where the username or
# password has changed in the meantime, so I'm trying once again without
# $USER and $PASSWD to give the get_basic_credentials routine another
# chance to set $USER and $PASSWD.

sub mirror {
    my($self,$url,$aslocal) = @_;
    my $result = $self->SUPER::mirror($url,$aslocal);
    if ($result->code == 407) {
        CPAN::HTTP::Credentials->clear_credentials;
        $result = $self->SUPER::mirror($url,$aslocal);
    }
    $result;
}

1;
PK     ü2]¬«õri  ri    Meta/YAML.pmnu „[µü¤        use 5.008001; # sane UTF-8 support
use strict;
use warnings;
package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
# XXX-INGY is 5.8.1 too old/broken for utf8?
# XXX-XDG Lancaster consensus was that it was sufficient until
# proven otherwise
$CPAN::Meta::YAML::VERSION = '0.018';
; # original $VERSION removed by Doppelgaenger

#####################################################################
# The CPAN::Meta::YAML API.
#
# These are the currently documented API functions/methods and
# exports:

use Exporter;
our @ISA       = qw{ Exporter  };
our @EXPORT    = qw{ Load Dump };
our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };

###
# Functional/Export API:

sub Dump {
    return CPAN::Meta::YAML->new(@_)->_dump_string;
}

# XXX-INGY Returning last document seems a bad behavior.
# XXX-XDG I think first would seem more natural, but I don't know
# that it's worth changing now
sub Load {
    my $self = CPAN::Meta::YAML->_load_string(@_);
    if ( wantarray ) {
        return @$self;
    } else {
        # To match YAML.pm, return the last document
        return $self->[-1];
    }
}

# XXX-INGY Do we really need freeze and thaw?
# XXX-XDG I don't think so.  I'd support deprecating them.
BEGIN {
    *freeze = \&Dump;
    *thaw   = \&Load;
}

sub DumpFile {
    my $file = shift;
    return CPAN::Meta::YAML->new(@_)->_dump_file($file);
}

sub LoadFile {
    my $file = shift;
    my $self = CPAN::Meta::YAML->_load_file($file);
    if ( wantarray ) {
        return @$self;
    } else {
        # Return only the last document to match YAML.pm,
        return $self->[-1];
    }
}


###
# Object Oriented API:

# Create an empty CPAN::Meta::YAML object
# XXX-INGY Why do we use ARRAY object?
# NOTE: I get it now, but I think it's confusing and not needed.
# Will change it on a branch later, for review.
#
# XXX-XDG I don't support changing it yet.  It's a very well-documented
# "API" of CPAN::Meta::YAML.  I'd support deprecating it, but Adam suggested
# we not change it until YAML.pm's own OO API is established so that
# users only have one API change to digest, not two
sub new {
    my $class = shift;
    bless [ @_ ], $class;
}

# XXX-INGY It probably doesn't matter, and it's probably too late to
# change, but 'read/write' are the wrong names. Read and Write
# are actions that take data from storage to memory
# characters/strings. These take the data to/from storage to native
# Perl objects, which the terms dump and load are meant. As long as
# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
# to add new {read,write}_* methods to this API.

sub read_string {
    my $self = shift;
    $self->_load_string(@_);
}

sub write_string {
    my $self = shift;
    $self->_dump_string(@_);
}

sub read {
    my $self = shift;
    $self->_load_file(@_);
}

sub write {
    my $self = shift;
    $self->_dump_file(@_);
}


#####################################################################
# Constants

# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
    0    x01  x02  x03  x04  x05  x06  a
    b    t    n    v    f    r    x0E  x0F
    x10  x11  x12  x13  x14  x15  x16  x17
    x18  x19  x1A  e    x1C  x1D  x1E  x1F
);

# Printable characters for escapes
my %UNESCAPES = (
    0 => "\x00", z => "\x00", N    => "\x85",
    a => "\x07", b => "\x08", t    => "\x09",
    n => "\x0a", v => "\x0b", f    => "\x0c",
    r => "\x0d", e => "\x1b", '\\' => '\\',
);

# XXX-INGY
# I(ngy) need to decide if these values should be quoted in
# CPAN::Meta::YAML or not. Probably yes.

# These 3 values have special meaning when unquoted and using the
# default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
    null true false
};

# The commented out form is simpler, but overloaded the Perl regex
# engine due to recursion and backtracking problems on strings
# larger than 32,000ish characters. Keep it for reference purposes.
# qr/\"((?:\\.|[^\"])*)\"/
my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
# unquoted re gets trailing space that needs to be stripped
my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
my $re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;


#####################################################################
# CPAN::Meta::YAML Implementation.
#
# These are the private methods that do all the work. They may change
# at any time.


###
# Loader functions:

# Create an object from a file
sub _load_file {
    my $class = ref $_[0] ? ref shift : shift;

    # Check the file
    my $file = shift or $class->_error( 'You did not specify a file name' );
    $class->_error( "File '$file' does not exist" )
        unless -e $file;
    $class->_error( "'$file' is a directory, not a file" )
        unless -f _;
    $class->_error( "Insufficient permissions to read '$file'" )
        unless -r _;

    # Open unbuffered with strict UTF-8 decoding and no translation layers
    open( my $fh, "<:unix:encoding(UTF-8)", $file );
    unless ( $fh ) {
        $class->_error("Failed to open file '$file': $!");
    }

    # flock if available (or warn if not possible for OS-specific reasons)
    if ( _can_flock() ) {
        flock( $fh, Fcntl::LOCK_SH() )
            or warn "Couldn't lock '$file' for reading: $!";
    }

    # slurp the contents
    my $contents = eval {
        use warnings FATAL => 'utf8';
        local $/;
        <$fh>
    };
    if ( my $err = $@ ) {
        $class->_error("Error reading from file '$file': $err");
    }

    # close the file (release the lock)
    unless ( close $fh ) {
        $class->_error("Failed to close file '$file': $!");
    }

    $class->_load_string( $contents );
}

# Create an object from a string
sub _load_string {
    my $class  = ref $_[0] ? ref shift : shift;
    my $self   = bless [], $class;
    my $string = $_[0];
    eval {
        unless ( defined $string ) {
            die \"Did not provide a string to load";
        }

        # Check if Perl has it marked as characters, but it's internally
        # inconsistent.  E.g. maybe latin1 got read on a :utf8 layer
        if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
            die \<<'...';
Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
...
        }

        # Ensure Unicode character semantics, even for 0x80-0xff
        utf8::upgrade($string);

        # Check for and strip any leading UTF-8 BOM
        $string =~ s/^\x{FEFF}//;

        # Check for some special cases
        return $self unless length $string;

        # Split the file into lines
        my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
                split /(?:\015{1,2}\012|\015|\012)/, $string;

        # Strip the initial YAML header
        @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;

        # A nibbling parser
        my $in_document = 0;
        while ( @lines ) {
            # Do we have a document header?
            if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
                # Handle scalar documents
                shift @lines;
                if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
                    push @$self,
                        $self->_load_scalar( "$1", [ undef ], \@lines );
                    next;
                }
                $in_document = 1;
            }

            if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
                # A naked document
                push @$self, undef;
                while ( @lines and $lines[0] !~ /^---/ ) {
                    shift @lines;
                }
                $in_document = 0;

            # XXX The final '-+$' is to look for -- which ends up being an
            # error later.
            } elsif ( ! $in_document && @$self ) {
                # only the first document can be explicit
                die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
            } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
                # An array at the root
                my $document = [ ];
                push @$self, $document;
                $self->_load_array( $document, [ 0 ], \@lines );

            } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
                # A hash at the root
                my $document = { };
                push @$self, $document;
                $self->_load_hash( $document, [ length($1) ], \@lines );

            } else {
                # Shouldn't get here.  @lines have whitespace-only lines
                # stripped, and previous match is a line with any
                # non-whitespace.  So this clause should only be reachable via
                # a perlbug where \s is not symmetric with \S

                # uncoverable statement
                die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
            }
        }
    };
    my $err = $@;
    if ( ref $err eq 'SCALAR' ) {
        $self->_error(${$err});
    } elsif ( $err ) {
        $self->_error($err);
    }

    return $self;
}

sub _unquote_single {
    my ($self, $string) = @_;
    return '' unless length $string;
    $string =~ s/\'\'/\'/g;
    return $string;
}

sub _unquote_double {
    my ($self, $string) = @_;
    return '' unless length $string;
    $string =~ s/\\"/"/g;
    $string =~
        s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
         {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
    return $string;
}

# Load a YAML scalar string to the actual Perl scalar
sub _load_scalar {
    my ($self, $string, $indent, $lines) = @_;

    # Trim trailing whitespace
    $string =~ s/\s*\z//;

    # Explitic null/undef
    return undef if $string eq '~';

    # Single quote
    if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
        return $self->_unquote_single($1);
    }

    # Double quote.
    if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
        return $self->_unquote_double($1);
    }

    # Special cases
    if ( $string =~ /^[\'\"!&]/ ) {
        die \"CPAN::Meta::YAML does not support a feature in line '$string'";
    }
    return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
    return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;

    # Regular unquoted string
    if ( $string !~ /^[>|]/ ) {
        die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
            if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
                $string =~ /:(?:\s|$)/;
        $string =~ s/\s+#.*\z//;
        return $string;
    }

    # Error
    die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;

    # Check the indent depth
    $lines->[0]   =~ /^(\s*)/;
    $indent->[-1] = length("$1");
    if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
        die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
    }

    # Pull the lines
    my @multiline = ();
    while ( @$lines ) {
        $lines->[0] =~ /^(\s*)/;
        last unless length($1) >= $indent->[-1];
        push @multiline, substr(shift(@$lines), length($1));
    }

    my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
    my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
    return join( $j, @multiline ) . $t;
}

# Load an array
sub _load_array {
    my ($self, $array, $indent, $lines) = @_;

    while ( @$lines ) {
        # Check for a new document
        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
            while ( @$lines and $lines->[0] !~ /^---/ ) {
                shift @$lines;
            }
            return 1;
        }

        # Check the indent level
        $lines->[0] =~ /^(\s*)/;
        if ( length($1) < $indent->[-1] ) {
            return 1;
        } elsif ( length($1) > $indent->[-1] ) {
            die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
        }

        if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
            # Inline nested hash
            my $indent2 = length("$1");
            $lines->[0] =~ s/-/ /;
            push @$array, { };
            $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );

        } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
            shift @$lines;
            unless ( @$lines ) {
                push @$array, undef;
                return 1;
            }
            if ( $lines->[0] =~ /^(\s*)\-/ ) {
                my $indent2 = length("$1");
                if ( $indent->[-1] == $indent2 ) {
                    # Null array entry
                    push @$array, undef;
                } else {
                    # Naked indenter
                    push @$array, [ ];
                    $self->_load_array(
                        $array->[-1], [ @$indent, $indent2 ], $lines
                    );
                }

            } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
                push @$array, { };
                $self->_load_hash(
                    $array->[-1], [ @$indent, length("$1") ], $lines
                );

            } else {
                die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
            }

        } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
            # Array entry with a value
            shift @$lines;
            push @$array, $self->_load_scalar(
                "$2", [ @$indent, undef ], $lines
            );

        } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
            # This is probably a structure like the following...
            # ---
            # foo:
            # - list
            # bar: value
            #
            # ... so lets return and let the hash parser handle it
            return 1;

        } else {
            die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
        }
    }

    return 1;
}

# Load a hash
sub _load_hash {
    my ($self, $hash, $indent, $lines) = @_;

    while ( @$lines ) {
        # Check for a new document
        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
            while ( @$lines and $lines->[0] !~ /^---/ ) {
                shift @$lines;
            }
            return 1;
        }

        # Check the indent level
        $lines->[0] =~ /^(\s*)/;
        if ( length($1) < $indent->[-1] ) {
            return 1;
        } elsif ( length($1) > $indent->[-1] ) {
            die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
        }

        # Find the key
        my $key;

        # Quoted keys
        if ( $lines->[0] =~
            s/^\s*$re_capture_single_quoted$re_key_value_separator//
        ) {
            $key = $self->_unquote_single($1);
        }
        elsif ( $lines->[0] =~
            s/^\s*$re_capture_double_quoted$re_key_value_separator//
        ) {
            $key = $self->_unquote_double($1);
        }
        elsif ( $lines->[0] =~
            s/^\s*$re_capture_unquoted_key$re_key_value_separator//
        ) {
            $key = $1;
            $key =~ s/\s+$//;
        }
        elsif ( $lines->[0] =~ /^\s*\?/ ) {
            die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
        }
        else {
            die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
        }

        if ( exists $hash->{$key} ) {
            warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
        }

        # Do we have a value?
        if ( length $lines->[0] ) {
            # Yes
            $hash->{$key} = $self->_load_scalar(
                shift(@$lines), [ @$indent, undef ], $lines
            );
        } else {
            # An indent
            shift @$lines;
            unless ( @$lines ) {
                $hash->{$key} = undef;
                return 1;
            }
            if ( $lines->[0] =~ /^(\s*)-/ ) {
                $hash->{$key} = [];
                $self->_load_array(
                    $hash->{$key}, [ @$indent, length($1) ], $lines
                );
            } elsif ( $lines->[0] =~ /^(\s*)./ ) {
                my $indent2 = length("$1");
                if ( $indent->[-1] >= $indent2 ) {
                    # Null hash entry
                    $hash->{$key} = undef;
                } else {
                    $hash->{$key} = {};
                    $self->_load_hash(
                        $hash->{$key}, [ @$indent, length($1) ], $lines
                    );
                }
            }
        }
    }

    return 1;
}


###
# Dumper functions:

# Save an object to a file
sub _dump_file {
    my $self = shift;

    require Fcntl;

    # Check the file
    my $file = shift or $self->_error( 'You did not specify a file name' );

    my $fh;
    # flock if available (or warn if not possible for OS-specific reasons)
    if ( _can_flock() ) {
        # Open without truncation (truncate comes after lock)
        my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
        sysopen( $fh, $file, $flags );
        unless ( $fh ) {
            $self->_error("Failed to open file '$file' for writing: $!");
        }

        # Use no translation and strict UTF-8
        binmode( $fh, ":raw:encoding(UTF-8)");

        flock( $fh, Fcntl::LOCK_EX() )
            or warn "Couldn't lock '$file' for reading: $!";

        # truncate and spew contents
        truncate $fh, 0;
        seek $fh, 0, 0;
    }
    else {
        open $fh, ">:unix:encoding(UTF-8)", $file;
    }

    # serialize and spew to the handle
    print {$fh} $self->_dump_string;

    # close the file (release the lock)
    unless ( close $fh ) {
        $self->_error("Failed to close file '$file': $!");
    }

    return 1;
}

# Save an object to a string
sub _dump_string {
    my $self = shift;
    return '' unless ref $self && @$self;

    # Iterate over the documents
    my $indent = 0;
    my @lines  = ();

    eval {
        foreach my $cursor ( @$self ) {
            push @lines, '---';

            # An empty document
            if ( ! defined $cursor ) {
                # Do nothing

            # A scalar document
            } elsif ( ! ref $cursor ) {
                $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );

            # A list at the root
            } elsif ( ref $cursor eq 'ARRAY' ) {
                unless ( @$cursor ) {
                    $lines[-1] .= ' []';
                    next;
                }
                push @lines, $self->_dump_array( $cursor, $indent, {} );

            # A hash at the root
            } elsif ( ref $cursor eq 'HASH' ) {
                unless ( %$cursor ) {
                    $lines[-1] .= ' {}';
                    next;
                }
                push @lines, $self->_dump_hash( $cursor, $indent, {} );

            } else {
                die \("Cannot serialize " . ref($cursor));
            }
        }
    };
    if ( ref $@ eq 'SCALAR' ) {
        $self->_error(${$@});
    } elsif ( $@ ) {
        $self->_error($@);
    }

    join '', map { "$_\n" } @lines;
}

sub _has_internal_string_value {
    my $value = shift;
    my $b_obj = B::svref_2object(\$value);  # for round trip problem
    return $b_obj->FLAGS & B::SVf_POK();
}

sub _dump_scalar {
    my $string = $_[1];
    my $is_key = $_[2];
    # Check this before checking length or it winds up looking like a string!
    my $has_string_flag = _has_internal_string_value($string);
    return '~'  unless defined $string;
    return "''" unless length  $string;
    if (Scalar::Util::looks_like_number($string)) {
        # keys and values that have been used as strings get quoted
        if ( $is_key || $has_string_flag ) {
            return qq['$string'];
        }
        else {
            return $string;
        }
    }
    if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
        $string =~ s/\\/\\\\/g;
        $string =~ s/"/\\"/g;
        $string =~ s/\n/\\n/g;
        $string =~ s/[\x85]/\\N/g;
        $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
        $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
        return qq|"$string"|;
    }
    if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
        $QUOTE{$string}
    ) {
        return "'$string'";
    }
    return $string;
}

sub _dump_array {
    my ($self, $array, $indent, $seen) = @_;
    if ( $seen->{refaddr($array)}++ ) {
        die \"CPAN::Meta::YAML does not support circular references";
    }
    my @lines  = ();
    foreach my $el ( @$array ) {
        my $line = ('  ' x $indent) . '-';
        my $type = ref $el;
        if ( ! $type ) {
            $line .= ' ' . $self->_dump_scalar( $el );
            push @lines, $line;

        } elsif ( $type eq 'ARRAY' ) {
            if ( @$el ) {
                push @lines, $line;
                push @lines, $self->_dump_array( $el, $indent + 1, $seen );
            } else {
                $line .= ' []';
                push @lines, $line;
            }

        } elsif ( $type eq 'HASH' ) {
            if ( keys %$el ) {
                push @lines, $line;
                push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
            } else {
                $line .= ' {}';
                push @lines, $line;
            }

        } else {
            die \"CPAN::Meta::YAML does not support $type references";
        }
    }

    @lines;
}

sub _dump_hash {
    my ($self, $hash, $indent, $seen) = @_;
    if ( $seen->{refaddr($hash)}++ ) {
        die \"CPAN::Meta::YAML does not support circular references";
    }
    my @lines  = ();
    foreach my $name ( sort keys %$hash ) {
        my $el   = $hash->{$name};
        my $line = ('  ' x $indent) . $self->_dump_scalar($name, 1) . ":";
        my $type = ref $el;
        if ( ! $type ) {
            $line .= ' ' . $self->_dump_scalar( $el );
            push @lines, $line;

        } elsif ( $type eq 'ARRAY' ) {
            if ( @$el ) {
                push @lines, $line;
                push @lines, $self->_dump_array( $el, $indent + 1, $seen );
            } else {
                $line .= ' []';
                push @lines, $line;
            }

        } elsif ( $type eq 'HASH' ) {
            if ( keys %$el ) {
                push @lines, $line;
                push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
            } else {
                $line .= ' {}';
                push @lines, $line;
            }

        } else {
            die \"CPAN::Meta::YAML does not support $type references";
        }
    }

    @lines;
}


#####################################################################
# DEPRECATED API methods:

# Error storage (DEPRECATED as of 1.57)
our $errstr    = '';

# Set error
sub _error {
    require Carp;
    $errstr = $_[1];
    $errstr =~ s/ at \S+ line \d+.*//;
    Carp::croak( $errstr );
}

# Retrieve error
my $errstr_warned;
sub errstr {
    require Carp;
    Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
        unless $errstr_warned++;
    $errstr;
}


#####################################################################
# Helper functions. Possibly not needed.


# Use to detect nv or iv
use B;

# XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
# Some platforms can't flock :-(
# XXX-XDG I think it is.  When reading and writing files, we ought
# to be locking whenever possible.  People (foolishly) use YAML
# files for things like session storage, which has race issues.
my $HAS_FLOCK;
sub _can_flock {
    if ( defined $HAS_FLOCK ) {
        return $HAS_FLOCK;
    }
    else {
        require Config;
        my $c = \%Config::Config;
        $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
        require Fcntl if $HAS_FLOCK;
        return $HAS_FLOCK;
    }
}


# XXX-INGY Is this core in 5.8.1? Can we remove this?
# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it

use Scalar::Util ();
BEGIN {
    local $@;
    if ( eval { Scalar::Util->VERSION(1.18); } ) {
        *refaddr = *Scalar::Util::refaddr;
    }
    else {
        eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
    my $pkg = ref($_[0]) or return undef;
    if ( !! UNIVERSAL::can($_[0], 'can') ) {
        bless $_[0], 'Scalar::Util::Fake';
    } else {
        $pkg = undef;
    }
    "$_[0]" =~ /0x(\w+)/;
    my $i = do { no warnings 'portable'; hex $1 };
    bless $_[0], $pkg if defined $pkg;
    $i;
}
END_PERL
    }
}

delete $CPAN::Meta::YAML::{refaddr};

1;

# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
# but leaving grey area stuff up here.
#
# I would like to change Read/Write to Load/Dump below without
# changing the actual API names.
#
# It might be better to put Load/Dump API in the SYNOPSIS instead of the
# dubious OO API.
#
# null and bool explanations may be outdated.

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files

=head1 VERSION

version 0.018

=head1 SYNOPSIS

    use CPAN::Meta::YAML;

    # reading a META file
    open $fh, "<:utf8", "META.yml";
    $yaml_text = do { local $/; <$fh> };
    $yaml = CPAN::Meta::YAML->read_string($yaml_text)
      or die CPAN::Meta::YAML->errstr;

    # finding the metadata
    $meta = $yaml->[0];

    # writing a META file
    $yaml_text = $yaml->write_string
      or die CPAN::Meta::YAML->errstr;
    open $fh, ">:utf8", "META.yml";
    print $fh $yaml_text;

=head1 DESCRIPTION

This module implements a subset of the YAML specification for use in reading
and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>.  It should
not be used for any other general YAML parsing or generation task.

NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded.  Users are
responsible for proper encoding and decoding.  In particular, the C<read> and
C<write> methods do B<not> support UTF-8 and should not be used.

=head1 SUPPORT

This module is currently derived from L<YAML::Tiny> by Adam Kennedy.  If
there are bugs in how it parses a particular META.yml file, please file
a bug report in the YAML::Tiny bugtracker:
L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>

=head1 SEE ALSO

L<YAML::Tiny>, L<YAML>, L<YAML::XS>

=head1 AUTHORS

=over 4

=item *

Adam Kennedy <adamk@cpan.org>

=item *

David Golden <dagolden@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Adam Kennedy.

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

__END__


# ABSTRACT: Read and write a subset of YAML for CPAN Meta files


PK     ü2]®9QìT4  T4    Meta/Prereqs.pmnu „[µü¤        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Prereqs;

our $VERSION = '2.150010';

#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
#pod distribution or one of its optional features.  Each set of prereqs is
#pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>.
#pod
#pod =cut

use Carp qw(confess);
use Scalar::Util qw(blessed);
use CPAN::Meta::Requirements 2.121;

#pod =method new
#pod
#pod   my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );
#pod
#pod This method returns a new set of Prereqs.  The input should look like the
#pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
#pod something more or less like this:
#pod
#pod   my $prereq = CPAN::Meta::Prereqs->new({
#pod     runtime => {
#pod       requires => {
#pod         'Some::Module' => '1.234',
#pod         ...,
#pod       },
#pod       ...,
#pod     },
#pod     ...,
#pod   });
#pod
#pod You can also construct an empty set of prereqs with:
#pod
#pod   my $prereqs = CPAN::Meta::Prereqs->new;
#pod
#pod This empty set of prereqs is useful for accumulating new prereqs before finally
#pod dumping the whole set into a structure or string.
#pod
#pod =cut

# note we also accept anything matching /\Ax_/i
sub __legal_phases { qw(configure build test runtime develop)   }
sub __legal_types  { qw(requires recommends suggests conflicts) }

# expect a prereq spec from META.json -- rjbs, 2010-04-11
sub new {
  my ($class, $prereq_spec) = @_;
  $prereq_spec ||= {};

  my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
  my %is_legal_type  = map {; $_ => 1 } $class->__legal_types;

  my %guts;
  PHASE: for my $phase (keys %$prereq_spec) {
    next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};

    my $phase_spec = $prereq_spec->{ $phase };
    next PHASE unless keys %$phase_spec;

    TYPE: for my $type (keys %$phase_spec) {
      next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};

      my $spec = $phase_spec->{ $type };

      next TYPE unless keys %$spec;

      $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
        $spec
      );
    }
  }

  return bless \%guts => $class;
}

#pod =method requirements_for
#pod
#pod   my $requirements = $prereqs->requirements_for( $phase, $type );
#pod
#pod This method returns a L<CPAN::Meta::Requirements> object for the given
#pod phase/type combination.  If no prerequisites are registered for that
#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may
#pod be added to as needed.
#pod
#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
#pod be raised.
#pod
#pod =cut

sub requirements_for {
  my ($self, $phase, $type) = @_;

  confess "requirements_for called without phase" unless defined $phase;
  confess "requirements_for called without type"  unless defined $type;

  unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
    confess "requested requirements for unknown phase: $phase";
  }

  unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
    confess "requested requirements for unknown type: $type";
  }

  my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);

  $req->finalize if $self->is_finalized;

  return $req;
}

#pod =method phases
#pod
#pod   my @phases = $prereqs->phases;
#pod
#pod This method returns the list of all phases currently populated in the prereqs
#pod object, suitable for iterating.
#pod
#pod =cut

sub phases {
  my ($self) = @_;

  my %is_legal_phase = map {; $_ => 1 } $self->__legal_phases;
  grep { /\Ax_/i or $is_legal_phase{$_} } keys %{ $self->{prereqs} };
}

#pod =method types_in
#pod
#pod   my @runtime_types = $prereqs->types_in('runtime');
#pod
#pod This method returns the list of all types currently populated in the prereqs
#pod object for the provided phase, suitable for iterating.
#pod
#pod =cut

sub types_in {
  my ($self, $phase) = @_;

  return unless $phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases;

  my %is_legal_type  = map {; $_ => 1 } $self->__legal_types;
  grep { /\Ax_/i or $is_legal_type{$_} } keys %{ $self->{prereqs}{$phase} };
}

#pod =method with_merged_prereqs
#pod
#pod   my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );
#pod
#pod   my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );
#pod
#pod This method returns a new CPAN::Meta::Prereqs objects in which all the
#pod other prerequisites given are merged into the current set.  This is primarily
#pod provided for combining a distribution's core prereqs with the prereqs of one of
#pod its optional features.
#pod
#pod The new prereqs object has no ties to the originals, and altering it further
#pod will not alter them.
#pod
#pod =cut

sub with_merged_prereqs {
  my ($self, $other) = @_;

  my @other = blessed($other) ? $other : @$other;

  my @prereq_objs = ($self, @other);

  my %new_arg;

  for my $phase (__uniq(map { $_->phases } @prereq_objs)) {
    for my $type (__uniq(map { $_->types_in($phase) } @prereq_objs)) {

      my $req = CPAN::Meta::Requirements->new;

      for my $prereq (@prereq_objs) {
        my $this_req = $prereq->requirements_for($phase, $type);
        next unless $this_req->required_modules;

        $req->add_requirements($this_req);
      }

      next unless $req->required_modules;

      $new_arg{ $phase }{ $type } = $req->as_string_hash;
    }
  }

  return (ref $self)->new(\%new_arg);
}

#pod =method merged_requirements
#pod
#pod     my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
#pod     my $new_reqs = $prereqs->merged_requirements( \@phases );
#pod     my $new_reqs = $prereqs->merged_requirements();
#pod
#pod This method joins together all requirements across a number of phases
#pod and types into a new L<CPAN::Meta::Requirements> object.  If arguments
#pod are omitted, it defaults to "runtime", "build" and "test" for phases
#pod and "requires" and "recommends" for types.
#pod
#pod =cut

sub merged_requirements {
  my ($self, $phases, $types) = @_;
  $phases = [qw/runtime build test/] unless defined $phases;
  $types = [qw/requires recommends/] unless defined $types;

  confess "merged_requirements phases argument must be an arrayref"
    unless ref $phases eq 'ARRAY';
  confess "merged_requirements types argument must be an arrayref"
    unless ref $types eq 'ARRAY';

  my $req = CPAN::Meta::Requirements->new;

  for my $phase ( @$phases ) {
    unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
        confess "requested requirements for unknown phase: $phase";
    }
    for my $type ( @$types ) {
      unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
          confess "requested requirements for unknown type: $type";
      }
      $req->add_requirements( $self->requirements_for($phase, $type) );
    }
  }

  $req->finalize if $self->is_finalized;

  return $req;
}


#pod =method as_string_hash
#pod
#pod This method returns a hashref containing structures suitable for dumping into a
#pod distmeta data structure.  It is made up of hashes and strings, only; there will
#pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.
#pod
#pod =cut

sub as_string_hash {
  my ($self) = @_;

  my %hash;

  for my $phase ($self->phases) {
    for my $type ($self->types_in($phase)) {
      my $req = $self->requirements_for($phase, $type);
      next unless $req->required_modules;

      $hash{ $phase }{ $type } = $req->as_string_hash;
    }
  }

  return \%hash;
}

#pod =method is_finalized
#pod
#pod This method returns true if the set of prereqs has been marked "finalized," and
#pod cannot be altered.
#pod
#pod =cut

sub is_finalized { $_[0]{finalized} }

#pod =method finalize
#pod
#pod Calling C<finalize> on a Prereqs object will close it for further modification.
#pod Attempting to make any changes that would actually alter the prereqs will
#pod result in an exception being thrown.
#pod
#pod =cut

sub finalize {
  my ($self) = @_;

  $self->{finalized} = 1;

  for my $phase (keys %{ $self->{prereqs} }) {
    $_->finalize for values %{ $self->{prereqs}{$phase} };
  }
}

#pod =method clone
#pod
#pod   my $cloned_prereqs = $prereqs->clone;
#pod
#pod This method returns a Prereqs object that is identical to the original object,
#pod but can be altered without affecting the original object.  Finalization does
#pod not survive cloning, meaning that you may clone a finalized set of prereqs and
#pod then modify the clone.
#pod
#pod =cut

sub clone {
  my ($self) = @_;

  my $clone = (ref $self)->new( $self->as_string_hash );
}

sub __uniq {
  my (%s, $u);
  grep { defined($_) ? !$s{$_}++ : !$u++ } @_;
}

1;

# ABSTRACT: a set of distribution prerequisites by phase and type

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type

=head1 VERSION

version 2.150010

=head1 DESCRIPTION

A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN
distribution or one of its optional features.  Each set of prereqs is
organized by phase and type, as described in L<CPAN::Meta::Prereqs>.

=head1 METHODS

=head2 new

  my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec );

This method returns a new set of Prereqs.  The input should look like the
contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning
something more or less like this:

  my $prereq = CPAN::Meta::Prereqs->new({
    runtime => {
      requires => {
        'Some::Module' => '1.234',
        ...,
      },
      ...,
    },
    ...,
  });

You can also construct an empty set of prereqs with:

  my $prereqs = CPAN::Meta::Prereqs->new;

This empty set of prereqs is useful for accumulating new prereqs before finally
dumping the whole set into a structure or string.

=head2 requirements_for

  my $requirements = $prereqs->requirements_for( $phase, $type );

This method returns a L<CPAN::Meta::Requirements> object for the given
phase/type combination.  If no prerequisites are registered for that
combination, a new CPAN::Meta::Requirements object will be returned, and it may
be added to as needed.

If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will
be raised.

=head2 phases

  my @phases = $prereqs->phases;

This method returns the list of all phases currently populated in the prereqs
object, suitable for iterating.

=head2 types_in

  my @runtime_types = $prereqs->types_in('runtime');

This method returns the list of all types currently populated in the prereqs
object for the provided phase, suitable for iterating.

=head2 with_merged_prereqs

  my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs );

  my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs );

This method returns a new CPAN::Meta::Prereqs objects in which all the
other prerequisites given are merged into the current set.  This is primarily
provided for combining a distribution's core prereqs with the prereqs of one of
its optional features.

The new prereqs object has no ties to the originals, and altering it further
will not alter them.

=head2 merged_requirements

    my $new_reqs = $prereqs->merged_requirements( \@phases, \@types );
    my $new_reqs = $prereqs->merged_requirements( \@phases );
    my $new_reqs = $prereqs->merged_requirements();

This method joins together all requirements across a number of phases
and types into a new L<CPAN::Meta::Requirements> object.  If arguments
are omitted, it defaults to "runtime", "build" and "test" for phases
and "requires" and "recommends" for types.

=head2 as_string_hash

This method returns a hashref containing structures suitable for dumping into a
distmeta data structure.  It is made up of hashes and strings, only; there will
be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it.

=head2 is_finalized

This method returns true if the set of prereqs has been marked "finalized," and
cannot be altered.

=head2 finalize

Calling C<finalize> on a Prereqs object will close it for further modification.
Attempting to make any changes that would actually alter the prereqs will
result in an exception being thrown.

=head2 clone

  my $cloned_prereqs = $prereqs->clone;

This method returns a Prereqs object that is identical to the original object,
but can be altered without affecting the original object.  Finalization does
not survive cloning, meaning that you may clone a finalized set of prereqs and
then modify the clone.

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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

__END__


# vim: ts=2 sts=2 sw=2 et :
PK     ü2]èåÞAú  ú    Meta/History.pmnu „[µü¤        # vi:tw=72
use 5.006;
use strict;
use warnings;
package CPAN::Meta::History;

our $VERSION = '2.150010';

1;

# ABSTRACT: history of CPAN Meta Spec changes

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::History - history of CPAN Meta Spec changes

=head1 VERSION

version 2.150010

=head1 DESCRIPTION

The CPAN Meta Spec has gone through several iterations.  It was
originally written in HTML and later revised into POD (though published
in HTML generated from the POD).  Fields were added, removed or changed,
sometimes by design and sometimes to reflect real-world usage after the
fact.

This document reconstructs the history of the CPAN Meta Spec based on
change logs, repository commit messages and the published HTML files.
In some cases, particularly prior to version 1.2, the exact version
when certain fields were introduced or changed is inconsistent between
sources.  When in doubt, the published HTML files for versions 1.0 to
1.4 as they existed when version 2 was developed are used as the
definitive source.

Starting with version 2, the specification document is part of the
CPAN-Meta distribution and will be published on CPAN as
L<CPAN::Meta::Spec>.

Going forward, specification version numbers will be integers and
decimal portions will correspond to a release date for the CPAN::Meta
library.

=head1 HISTORY

=head2 Version 2

April 2010

=over

=item *

Revised spec examples as perl data structures rather than YAML

=item *

Switched to JSON serialization from YAML

=item *

Specified allowed version number formats

=item *

Replaced 'requires', 'build_requires', 'configure_requires',
'recommends' and 'conflicts' with new 'prereqs' data structure divided
by I<phase> (configure, build, test, runtime, etc.) and I<relationship>
(requires, recommends, suggests, conflicts)

=item *

Added support for 'develop' phase for requirements for maintaining
a list of authoring tools

=item *

Changed 'license' to a list and revised the set of valid licenses

=item *

Made 'dynamic_config' mandatory to reduce confusion

=item *

Changed 'resources' subkey 'repository' to a hash that clarifies
repository type, url for browsing and url for checkout

=item *

Changed 'resources' subkey 'bugtracker' to a hash for either web
or mailto resource

=item *

Changed specification of 'optional_features':

=over

=item *

Added formal specification and usage guide instead of just example

=item *

Changed to use new prereqs data structure instead of individual keys

=back

=item *

Clarified intended use of 'author' as generalized contact list

=item *

Added 'release_status' field to indicate stable, testing or unstable
status to provide hints to indexers

=item *

Added 'description' field for a longer description of the distribution

=item *

Formalized use of "x_" or "X_" for all custom keys not listed in the
official spec

=back

=head2 Version 1.4

June 2008

=over

=item *

Noted explicit support for 'perl' in prerequisites

=item *

Added 'configure_requires' prerequisite type

=item *

Changed 'optional_features'

=over

=item *

Example corrected to show map of maps instead of list of maps
(though descriptive text said 'map' even in v1.3)

=item *

Removed 'requires_packages', 'requires_os' and 'excluded_os'
as valid subkeys

=back

=back

=head2 Version 1.3

November 2006

=over

=item *

Added 'no_index' subkey 'directory' and removed 'dir' to match actual
usage in the wild

=item *

Added a 'repository' subkey to 'resources'

=back

=head2 Version 1.2

August 2005

=over

=item *

Re-wrote and restructured spec in POD syntax

=item *

Changed 'name' to be mandatory

=item *

Changed 'generated_by' to be mandatory

=item *

Changed 'license' to be mandatory

=item *

Added version range specifications for prerequisites

=item *

Added required 'abstract' field

=item *

Added required 'author' field

=item *

Added required 'meta-spec' field to define 'version' (and 'url') of the
CPAN Meta Spec used for metadata

=item *

Added 'provides' field

=item *

Added 'no_index' field and deprecated 'private' field.  'no_index'
subkeys include 'file', 'dir', 'package' and 'namespace'

=item *

Added 'keywords' field

=item *

Added 'resources' field with subkeys 'homepage', 'license', and
'bugtracker'

=item *

Added 'optional_features' field as an alternate under 'recommends'.
Includes 'description', 'requires', 'build_requires', 'conflicts',
'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys

=item *

Removed 'license_uri' field

=back

=head2 Version 1.1

May 2003

=over

=item *

Changed 'version' to be mandatory

=item *

Added 'private' field

=item *

Added 'license_uri' field

=back

=head2 Version 1.0

March 2003

=over

=item *

Original release (in HTML format only)

=item *

Included 'name', 'version', 'license', 'distribution_type', 'requires',
'recommends', 'build_requires', 'conflicts', 'dynamic_config',
'generated_by'

=back

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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
PK     ü2]ýsomFU  FU    Meta/Requirements.pmnu ÏÃ6Ç$        use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements;
# ABSTRACT: a set of version requirements for a CPAN dist

our $VERSION = '2.143';

use CPAN::Meta::Requirements::Range;

#pod =head1 SYNOPSIS
#pod
#pod   use CPAN::Meta::Requirements;
#pod
#pod   my $build_requires = CPAN::Meta::Requirements->new;
#pod
#pod   $build_requires->add_minimum('Library::Foo' => 1.208);
#pod
#pod   $build_requires->add_minimum('Library::Foo' => 2.602);
#pod
#pod   $build_requires->add_minimum('Module::Bar'  => 'v1.2.3');
#pod
#pod   $METAyml->{build_requires} = $build_requires->as_string_hash;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>.
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut

use Carp ();

#pod =method new
#pod
#pod   my $req = CPAN::Meta::Requirements->new;
#pod
#pod This returns a new CPAN::Meta::Requirements object.  It takes an optional
#pod hash reference argument.  Currently, only one key is supported:
#pod
#pod =for :list
#pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into
#pod   a version object, this code reference will be called with the invalid
#pod   version string as first argument, and the module name as second
#pod   argument.  It must return a valid version object.
#pod
#pod All other keys are ignored.
#pod
#pod =cut

my @valid_options = qw( bad_version_hook );

sub new {
  my ($class, $options) = @_;
  $options ||= {};
  Carp::croak "Argument to $class\->new() must be a hash reference"
    unless ref $options eq 'HASH';
  my %self = map {; $_ => $options->{$_}} @valid_options;

  return bless \%self => $class;
}

#pod =method add_minimum
#pod
#pod   $req->add_minimum( $module => $version );
#pod
#pod This adds a new minimum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive.  C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_maximum
#pod
#pod   $req->add_maximum( $module => $version );
#pod
#pod This adds a new maximum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive.  No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the requirements object.
#pod
#pod =method add_exclusion
#pod
#pod   $req->add_exclusion( $module => $version );
#pod
#pod This adds a new excluded version.  For example, you might use these three
#pod method calls:
#pod
#pod   $req->add_minimum( $module => '1.00' );
#pod   $req->add_maximum( $module => '1.82' );
#pod
#pod   $req->add_exclusion( $module => '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =method exact_version
#pod
#pod   $req->exact_version( $module => $version );
#pod
#pod This sets the version required for the given module to I<exactly> the given
#pod version.  No other version would be considered acceptable.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

BEGIN {
  for my $type (qw(maximum exclusion exact_version)) {
    my $method = "with_$type";
    my $to_add = $type eq 'exact_version' ? $type : "add_$type";

    my $code = sub {
      my ($self, $name, $version) = @_;

      $self->__modify_entry_for($name, $method, $version);

      return $self;
    };

    no strict 'refs';
    *$to_add = $code;
  }
}

# add_minimum is optimized compared to generated subs above because
# it is called frequently and with "0" or equivalent input
sub add_minimum {
  my ($self, $name, $version) = @_;

  # stringify $version so that version->new("0.00")->stringify ne "0"
  # which preserves the user's choice of "0.00" as the requirement
  if (not defined $version or "$version" eq '0') {
    return $self if $self->__entry_for($name);
    Carp::croak("can't add new requirements to finalized requirements")
      if $self->is_finalized;

    $self->{requirements}{ $name } =
      CPAN::Meta::Requirements::Range->with_minimum('0', $name);
  }
  else {
    $self->__modify_entry_for($name, 'with_minimum', $version);
  }
  return $self;
}

#pod =method version_range_for_module
#pod
#pod   $req->version_range_for_module( $another_req_object );
#pod
#pod =cut

sub version_range_for_module {
  my ($self, $module) = @_;
  return $self->{requirements}{$module};
}

#pod =method add_requirements
#pod
#pod   $req->add_requirements( $another_req_object );
#pod
#pod This method adds all the requirements in the given CPAN::Meta::Requirements
#pod object to the requirements object on which it was called.  If there are any
#pod conflicts, an exception is thrown.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

sub add_requirements {
  my ($self, $req) = @_;

  for my $module ($req->required_modules) {
    my $new_range = $req->version_range_for_module($module);
    $self->__modify_entry_for($module, 'with_range', $new_range);
  }

  return $self;
}

#pod =method accepts_module
#pod
#pod   my $bool = $req->accepts_module($module => $version);
#pod
#pod Given an module and version, this method returns true if the version
#pod specification for the module accepts the provided version.  In other words,
#pod given:
#pod
#pod   Module => '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod For modules that do not appear in the requirements, this method will return
#pod true.
#pod
#pod =cut

sub accepts_module {
  my ($self, $module, $version) = @_;

  return 1 unless my $range = $self->__entry_for($module);
  return $range->accepts($version);
}

#pod =method clear_requirement
#pod
#pod   $req->clear_requirement( $module );
#pod
#pod This removes the requirement for a given module from the object.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

sub clear_requirement {
  my ($self, $module) = @_;

  return $self unless $self->__entry_for($module);

  Carp::croak("can't clear requirements on finalized requirements")
    if $self->is_finalized;

  delete $self->{requirements}{ $module };

  return $self;
}

#pod =method requirements_for_module
#pod
#pod   $req->requirements_for_module( $module );
#pod
#pod This returns a string containing the version requirements for a given module in
#pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no
#pod requirements. This should only be used for informational purposes such as error
#pod messages and should not be interpreted or used for comparison (see
#pod L</accepts_module> instead).
#pod
#pod =cut

sub requirements_for_module {
  my ($self, $module) = @_;
  my $entry = $self->__entry_for($module);
  return unless $entry;
  return $entry->as_string;
}

#pod =method structured_requirements_for_module
#pod
#pod   $req->structured_requirements_for_module( $module );
#pod
#pod This returns a data structure containing the version requirements for a given
#pod module or undef if the given module has no requirements.  This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod Added in version 2.134.
#pod
#pod =cut

sub structured_requirements_for_module {
  my ($self, $module) = @_;
  my $entry = $self->__entry_for($module);
  return unless $entry;
  return $entry->as_struct;
}

#pod =method required_modules
#pod
#pod This method returns a list of all the modules for which requirements have been
#pod specified.
#pod
#pod =cut

sub required_modules { keys %{ $_[0]{requirements} } }

#pod =method clone
#pod
#pod   $req->clone;
#pod
#pod This method returns a clone of the invocant.  The clone and the original object
#pod can then be changed independent of one another.
#pod
#pod =cut

sub clone {
  my ($self) = @_;
  my $new = (ref $self)->new;

  return $new->add_requirements($self);
}

sub __entry_for     { $_[0]{requirements}{ $_[1] } }

sub __modify_entry_for {
  my ($self, $name, $method, $version) = @_;

  my $fin = $self->is_finalized;
  my $old = $self->__entry_for($name);

  Carp::croak("can't add new requirements to finalized requirements")
    if $fin and not $old;

  my $new = ($old || 'CPAN::Meta::Requirements::Range')
          ->$method($version, $name, $self->{bad_version_hook});

  Carp::croak("can't modify finalized requirements")
    if $fin and $old->as_string ne $new->as_string;

  $self->{requirements}{ $name } = $new;
}

#pod =method is_simple
#pod
#pod This method returns true if and only if all requirements are inclusive minimums
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut

sub is_simple {
  my ($self) = @_;
  for my $module ($self->required_modules) {
    # XXX: This is a complete hack, but also entirely correct.
    return if not $self->__entry_for($module)->is_simple;
  }

  return 1;
}

#pod =method is_finalized
#pod
#pod This method returns true if the requirements have been finalized by having the
#pod C<finalize> method called on them.
#pod
#pod =cut

sub is_finalized { $_[0]{finalized} }

#pod =method finalize
#pod
#pod This method marks the requirements finalized.  Subsequent attempts to change
#pod the requirements will be fatal, I<if> they would result in a change.  If they
#pod would not alter the requirements, they have no effect.
#pod
#pod If a finalized set of requirements is cloned, the cloned requirements are not
#pod also finalized.
#pod
#pod =cut

sub finalize { $_[0]{finalized} = 1 }

#pod =method as_string_hash
#pod
#pod This returns a reference to a hash describing the requirements using the
#pod strings in the L<CPAN::Meta::Spec> specification.
#pod
#pod For example after the following program:
#pod
#pod   my $req = CPAN::Meta::Requirements->new;
#pod
#pod   $req->add_minimum('CPAN::Meta::Requirements' => 0.102);
#pod
#pod   $req->add_minimum('Library::Foo' => 1.208);
#pod
#pod   $req->add_maximum('Library::Foo' => 2.602);
#pod
#pod   $req->add_minimum('Module::Bar'  => 'v1.2.3');
#pod
#pod   $req->add_exclusion('Module::Bar'  => 'v1.2.8');
#pod
#pod   $req->exact_version('Xyzzy'  => '6.01');
#pod
#pod   my $hashref = $req->as_string_hash;
#pod
#pod C<$hashref> would contain:
#pod
#pod   {
#pod     'CPAN::Meta::Requirements' => '0.102',
#pod     'Library::Foo' => '>= 1.208, <= 2.206',
#pod     'Module::Bar'  => '>= v1.2.3, != v1.2.8',
#pod     'Xyzzy'        => '== 6.01',
#pod   }
#pod
#pod =cut

sub as_string_hash {
  my ($self) = @_;

  my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
             $self->required_modules;

  return \%hash;
}

#pod =method add_string_requirement
#pod
#pod   $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
#pod   $req->add_string_requirement('Library::Foo' => v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement
#pod for the given module.  A version can be a Perl "v-string".  It understands
#pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
#pod example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>).  Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut

sub add_string_requirement {
  my ($self, $module, $req) = @_;

  $self->__modify_entry_for($module, 'with_string_requirement', $req);
}

#pod =method from_string_hash
#pod
#pod   my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
#pod   my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );
#pod
#pod This is an alternate constructor for a CPAN::Meta::Requirements
#pod object. It takes a hash of module names and version requirement
#pod strings and returns a new CPAN::Meta::Requirements object. As with
#pod add_string_requirement, a version can be a Perl "v-string". Optionally,
#pod you can supply a hash-reference of options, exactly as with the L</new>
#pod method.
#pod
#pod =cut

sub from_string_hash {
  my ($class, $hash, $options) = @_;

  my $self = $class->new($options);

  for my $module (keys %$hash) {
    my $req = $hash->{$module};
    $self->add_string_requirement($module, $req);
  }

  return $self;
}

1;
# vim: ts=2 sts=2 sw=2 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Requirements - a set of version requirements for a CPAN dist

=head1 VERSION

version 2.143

=head1 SYNOPSIS

  use CPAN::Meta::Requirements;

  my $build_requires = CPAN::Meta::Requirements->new;

  $build_requires->add_minimum('Library::Foo' => 1.208);

  $build_requires->add_minimum('Library::Foo' => 2.602);

  $build_requires->add_minimum('Module::Bar'  => 'v1.2.3');

  $METAyml->{build_requires} = $build_requires->as_string_hash;

=head1 DESCRIPTION

A CPAN::Meta::Requirements object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>.
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.

Logically impossible constraints will be identified immediately by thrown
exceptions.

=head1 METHODS

=head2 new

  my $req = CPAN::Meta::Requirements->new;

This returns a new CPAN::Meta::Requirements object.  It takes an optional
hash reference argument.  Currently, only one key is supported:

=over 4

=item *

C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument.  It must return a valid version object.

=back

All other keys are ignored.

=head2 add_minimum

  $req->add_minimum( $module => $version );

This adds a new minimum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Minimum requirements are inclusive.  C<$version> is required, along with any
greater version number.

This method returns the requirements object.

=head2 add_maximum

  $req->add_maximum( $module => $version );

This adds a new maximum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Maximum requirements are inclusive.  No version strictly greater than the given
version is allowed.

This method returns the requirements object.

=head2 add_exclusion

  $req->add_exclusion( $module => $version );

This adds a new excluded version.  For example, you might use these three
method calls:

  $req->add_minimum( $module => '1.00' );
  $req->add_maximum( $module => '1.82' );

  $req->add_exclusion( $module => '1.75' );

Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.

This method returns the requirements object.

=head2 exact_version

  $req->exact_version( $module => $version );

This sets the version required for the given module to I<exactly> the given
version.  No other version would be considered acceptable.

This method returns the requirements object.

=head2 version_range_for_module

  $req->version_range_for_module( $another_req_object );

=head2 add_requirements

  $req->add_requirements( $another_req_object );

This method adds all the requirements in the given CPAN::Meta::Requirements
object to the requirements object on which it was called.  If there are any
conflicts, an exception is thrown.

This method returns the requirements object.

=head2 accepts_module

  my $bool = $req->accepts_module($module => $version);

Given an module and version, this method returns true if the version
specification for the module accepts the provided version.  In other words,
given:

  Module => '>= 1.00, < 2.00'

We will accept 1.00 and 1.75 but not 0.50 or 2.00.

For modules that do not appear in the requirements, this method will return
true.

=head2 clear_requirement

  $req->clear_requirement( $module );

This removes the requirement for a given module from the object.

This method returns the requirements object.

=head2 requirements_for_module

  $req->requirements_for_module( $module );

This returns a string containing the version requirements for a given module in
the format described in L<CPAN::Meta::Spec> or undef if the given module has no
requirements. This should only be used for informational purposes such as error
messages and should not be interpreted or used for comparison (see
L</accepts_module> instead).

=head2 structured_requirements_for_module

  $req->structured_requirements_for_module( $module );

This returns a data structure containing the version requirements for a given
module or undef if the given module has no requirements.  This should
not be used for version checks (see L</accepts_module> instead).

Added in version 2.134.

=head2 required_modules

This method returns a list of all the modules for which requirements have been
specified.

=head2 clone

  $req->clone;

This method returns a clone of the invocant.  The clone and the original object
can then be changed independent of one another.

=head2 is_simple

This method returns true if and only if all requirements are inclusive minimums
-- that is, if their string expression is just the version number.

=head2 is_finalized

This method returns true if the requirements have been finalized by having the
C<finalize> method called on them.

=head2 finalize

This method marks the requirements finalized.  Subsequent attempts to change
the requirements will be fatal, I<if> they would result in a change.  If they
would not alter the requirements, they have no effect.

If a finalized set of requirements is cloned, the cloned requirements are not
also finalized.

=head2 as_string_hash

This returns a reference to a hash describing the requirements using the
strings in the L<CPAN::Meta::Spec> specification.

For example after the following program:

  my $req = CPAN::Meta::Requirements->new;

  $req->add_minimum('CPAN::Meta::Requirements' => 0.102);

  $req->add_minimum('Library::Foo' => 1.208);

  $req->add_maximum('Library::Foo' => 2.602);

  $req->add_minimum('Module::Bar'  => 'v1.2.3');

  $req->add_exclusion('Module::Bar'  => 'v1.2.8');

  $req->exact_version('Xyzzy'  => '6.01');

  my $hashref = $req->as_string_hash;

C<$hashref> would contain:

  {
    'CPAN::Meta::Requirements' => '0.102',
    'Library::Foo' => '>= 1.208, <= 2.206',
    'Module::Bar'  => '>= v1.2.3, != v1.2.8',
    'Xyzzy'        => '== 6.01',
  }

=head2 add_string_requirement

  $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206');
  $req->add_string_requirement('Library::Foo' => v1.208);

This method parses the passed in string and adds the appropriate requirement
for the given module.  A version can be a Perl "v-string".  It understands
version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For
example:

=over 4

=item 1.3

=item >= 1.3

=item <= 1.3

=item == 1.3

=item != 1.3

=item > 1.3

=item < 1.3

=item >= 1.3, != 1.5, <= 2.0

A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>).  Extra whitespace is allowed.

=back

=head2 from_string_hash

  my $req = CPAN::Meta::Requirements->from_string_hash( \%hash );
  my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts );

This is an alternate constructor for a CPAN::Meta::Requirements
object. It takes a hash of module names and version requirement
strings and returns a new CPAN::Meta::Requirements object. As with
add_string_requirement, a version can be a Perl "v-string". Optionally,
you can supply a hash-reference of options, exactly as with the L</new>
method.

=for :stopwords cpan testmatrix url bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements>

  git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 CONTRIBUTORS

=for stopwords Ed J Graham Knop Karen Etheridge Leon Timmermans Paul Howarth Ricardo Signes robario Tatsuhiko Miyagawa

=over 4

=item *

Ed J <mohawk2@users.noreply.github.com>

=item *

Graham Knop <haarg@haarg.org>

=item *

Karen Etheridge <ether@cpan.org>

=item *

Leon Timmermans <fawaka@gmail.com>

=item *

Paul Howarth <paul@city-fan.org>

=item *

Ricardo Signes <rjbs@semiotic.systems>

=item *

robario <webmaster@robario.com>

=item *

Tatsuhiko Miyagawa <miyagawa@bulknews.net>

=item *

Tatsuhiko Miyagawa <miyagawa@gmail.com>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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
PK     ü2]XŠá‰a  a    Meta/Feature.pmnu „[µü¤        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Feature;

our $VERSION = '2.150010';

use CPAN::Meta::Prereqs;

#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
#pod distribution and specified in the distribution's F<META.json> (or F<META.yml>)
#pod file.
#pod
#pod For the most part, this class will only be used when operating on the result of
#pod the C<feature> or C<features> methods on a L<CPAN::Meta> object.
#pod
#pod =method new
#pod
#pod   my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );
#pod
#pod This returns a new Feature object.  The C<%spec> argument to the constructor
#pod should be the same as the value of the C<optional_feature> entry in the
#pod distmeta.  It must contain entries for C<description> and C<prereqs>.
#pod
#pod =cut

sub new {
  my ($class, $identifier, $spec) = @_;

  my %guts = (
    identifier  => $identifier,
    description => $spec->{description},
    prereqs     => CPAN::Meta::Prereqs->new($spec->{prereqs}),
  );

  bless \%guts => $class;
}

#pod =method identifier
#pod
#pod This method returns the feature's identifier.
#pod
#pod =cut

sub identifier  { $_[0]{identifier}  }

#pod =method description
#pod
#pod This method returns the feature's long description.
#pod
#pod =cut

sub description { $_[0]{description} }

#pod =method prereqs
#pod
#pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
#pod object.
#pod
#pod =cut

sub prereqs     { $_[0]{prereqs} }

1;

# ABSTRACT: an optional feature provided by a CPAN distribution

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Feature - an optional feature provided by a CPAN distribution

=head1 VERSION

version 2.150010

=head1 DESCRIPTION

A CPAN::Meta::Feature object describes an optional feature offered by a CPAN
distribution and specified in the distribution's F<META.json> (or F<META.yml>)
file.

For the most part, this class will only be used when operating on the result of
the C<feature> or C<features> methods on a L<CPAN::Meta> object.

=head1 METHODS

=head2 new

  my $feature = CPAN::Meta::Feature->new( $identifier => \%spec );

This returns a new Feature object.  The C<%spec> argument to the constructor
should be the same as the value of the C<optional_feature> entry in the
distmeta.  It must contain entries for C<description> and C<prereqs>.

=head2 identifier

This method returns the feature's identifier.

=head2 description

This method returns the feature's long description.

=head2 prereqs

This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs>
object.

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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

__END__


# vim: ts=2 sts=2 sw=2 et :
PK     ü2]Ã]sÌHH  HH    Meta/History/Meta_1_3.podnu „[µü¤        =for :stopwords MailingList PODs RWS subcontext

=head1 NAME

CPAN::Meta::History::Meta_1_3 - Version 1.3 metadata specification for META.yml

=head1 PREFACE

This is a historical copy of the version 1.3 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.

Modifications from the original:

=over

=item *

Various spelling corrections

=item *

Include list of valid licenses from L<Module::Build> 0.2805 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.

=item *

Fixed some dead links to point to active resources.

=back

=head1 SYNOPSIS

 --- #YAML:1.0
 name: Module-Build
 abstract: Build and install Perl modules
 version: 0.20
 author:
   - Ken Williams <kwilliams@cpan.org>
 license: perl
 distribution_type: module
 requires:
   Config: 0
   Cwd: 0
   Data::Dumper: 0
   ExtUtils::Install: 0
   File::Basename: 0
   File::Compare: 0
   File::Copy: 0
   File::Find: 0
   File::Path: 0
   File::Spec: 0
   IO::File: 0
   perl: 5.005_03
 recommends:
   Archive::Tar: 1.00
   ExtUtils::Install: 0.3
   ExtUtils::ParseXS: 2.02
   Pod::Text: 0
   YAML: 0.35
 build_requires:
   Test: 0
 urls:
   license: http://dev.perl.org/licenses/
 meta-spec:
   version: 1.3
   url: http://module-build.sourceforge.net/META-spec-v1.3.html
 generated_by: Module::Build version 0.20

=head1 DESCRIPTION

This document describes version 1.3 of the F<META.yml> specification.

The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN.  It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.

The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.

I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>

=head1 FORMAT

F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).

See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:

=over 4

=item *

L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>

=item *

L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>

=item *

L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>

=back

=head1 TERMINOLOGY

=over 4

=item distribution

This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
together for other developers to use.  Examples of distributions are
C<Class-Container>, C<libwww-perl>, or C<DBI>.

=item module

This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby).  Examples of modules are C<Class::Container>,
C<LWP::Simple>, or C<DBD::File>.

=back

=head1 HEADER

The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.

=head1 FIELDS

The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.

=head2 meta-spec

Example:

 meta-spec:
   version: 1.3
   url: http://module-build.sourceforge.net/META-spec-v1.3.html

(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.

=head2 name

Example:

  name: Module-Build

(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-".  Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/dist/libwww-perl/>).

=head2 version

Example:

  version: 0.20

(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.

=head2 abstract

Example:

  abstract: Build and install Perl modules.

(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.

=head2 author

Example:

  author:
    - Ken Williams <kwilliams@cpan.org>

(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.

=head2 license

Example:

  license: perl

(Spec 1.0) [required] {string} The license under which this distribution may be
used and redistributed.

Must be one of the following licenses:

=over 4

=item apache

The distribution is licensed under the Apache Software License version 1.1
(L<http://opensource.org/licenses/Apache-1.1>).

=item artistic

The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).

=item bsd

The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).

=item gpl

The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).

=item lgpl

The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).

=item mit

The distribution is licensed under the MIT License
(L<http://opensource.org/licenses/MIT>).

=item mozilla

The distribution is licensed under the Mozilla Public License.
(L<http://opensource.org/licenses/MPL-1.0> or
L<http://opensource.org/licenses/MPL-1.1>)

=item open_source

The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.

=item perl

The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.

=item restrictive

The distribution may not be redistributed without special permission from the
author and/or copyright holder.

=item unrestricted

The distribution is licensed under a license that is not approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.

=back

=head2 distribution_type

Example:

  distribution_type: module

(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution.  Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.

Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them.  Tools like Module::Build and MakeMaker will likely stop
generating this field.

=head2 requires

Example:

  requires:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation.  The keys are the module
names, and the values are version specifications as described in
L</"VERSION SPECIFICATIONS">.

=head2 recommends

Example:

  recommends:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
this distribution recommends for enhanced operation.  The keys are the
module names, and the values are version specifications as described
in L</"VERSION SPECIFICATIONS">.


I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed decision
about which recommended modules to install.>

Example:

  optional_features:
  - foo:
      description: Provides the ability to blah.
      requires:
        Data::Dumper: 0
        File::Find: 1.03
  - bar:
      description: This feature is not available on this platform.
      excludes_os: MSWin32

I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, L</conflicts>, C<requires_packages>,
C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>

=head2 build_requires

Example:

  build_requires:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution.  The keys
are the module names, and the values are version specifications as
described in L</"VERSION SPECIFICATIONS">.  These dependencies are not
required after the module is installed.

=head2 conflicts

Example:

  conflicts:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
cannot be installed while this distribution is installed.  This is a
pretty uncommon situation.  The keys for C<conflicts> are the module
names, and the values are version specifications as described in
L</"VERSION SPECIFICATIONS">.


=head2 dynamic_config

Example:

  dynamic_config: 0

(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file.  The main reason to set this to a true value is that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.

Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it.  It can potentially bring lots of
security, packaging, and convenience improvements.

If this field is omitted, it defaults to 1 (true).

=head2 private

I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>.  See below.

=head2 provides

Example:

  provides:
    Foo::Bar:
      file: lib/Foo/Bar.pm
      version: 0.27_02
    Foo::Bar::Blah:
      file: lib/Foo/Bar/Blah.pm
    Foo::Bar::Baz:
      file: lib/Foo/Bar/Baz.pm
      version: 0.3

(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution.  This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.

When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions.  This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.

=head2 no_index

Example:

  no_index:
    file:
    - My/Module.pm
    directory:
    - My/Private
    package:
    - My::Module::Stuff
    namespace:
    - My::Module::Stuff

(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools.  This is useful when no C<provides> field is
present.

For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
through.

=head3 file

(Spec 1.1) [optional] Exclude any listed file(s).

=head3 directory

(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).

[Note: previous editions of the spec had C<dir> instead of
C<directory>, but I think MakeMaker and various users started using
C<directory>, so in deference we switched to that.]

=head3 package

(Spec 1.1) [optional] Exclude the listed package(s).

=head3 namespace

(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.

=head2 keywords

Example:

  keywords:
    - make
    - build
    - install

(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.

=head2 resources

Example:

  resources:
    license: http://dev.perl.org/licenses/
    homepage: http://sourceforge.net/projects/module-build
    bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
    repository: http://sourceforge.net/cvs/?group_id=45731
    MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general

(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution.  All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification.  If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.

The current set of official keys is:

=over 2

=item homepage

The official home of this project on the web.

=item license

An URL for an official statement of this distribution's license.

=item bugtracker

An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.

=back


=head2 generated_by

Example:

  generated_by: Module::Build version 0.20

(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file.  It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.

[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]

=head1 VERSION SPECIFICATIONS

Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite.  This section details the version specification formats
that are currently supported.

The simplest format for a version specification is just the version
number itself, e.g. C<2.4>.  This means that B<at least> version 2.4
must be present.  To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.

You may also use the operators E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
(equal), and != (not equal).  For example, the specification C<E<lt>
2.0> means that any version of the prerequisite less than 2.0 is
suitable.

For more complicated situations, version specifications may be AND-ed
together using commas.  The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than>
2.0, and B<not equal to> 1.5.

=head1 SEE ALSO

L<CPAN|http://www.cpan.org/>

L<CPAN.pm|CPAN>

L<CPANPLUS>

L<Data::Dumper>

L<ExtUtils::MakeMaker>

L<Module::Build>

L<Module::Install>

L<XML|http://www.w3.org/XML/>

L<YAML|http://www.yaml.org/>

=head1 HISTORY

=over 4

=item March 14, 2003 (Pi day)

=over 2

=item *

Created version 1.0 of this document.

=back

=item May 8, 2003

=over 2

=item *

Added the L</dynamic_config> field, which was missing from the initial
version.

=back

=item November 13, 2003

=over 2

=item *

Added more YAML rationale articles.

=item *

Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.

=item *

Added and deprecated the L</private> field.

=item *

Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.

=item *

Bumped version.

=back

=item November 16, 2003

=over 2

=item *

Added C<generation>, C<authored_by> fields.

=item *

Add alternative proposal to the L</recommends> field.

=item *

Add proposal for a C<requires_build_tools> field.

=back

=item December 9, 2003

=over 2

=item *

Added link to latest version of this specification on CPAN.

=item *

Added section L</"VERSION SPECIFICATIONS">.

=item *

Chang name from Module::Build::META-spec to CPAN::META::Specification.

=item *

Add proposal for C<auto_regenerate> field.

=back

=item December 15, 2003

=over 2

=item *

Add C<index> field as a compliment to L</no_index>

=item *

Add L</keywords> field as a means to aid searching distributions.

=item *

Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.

=back

=item July 26, 2005

=over 2

=item *

Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.

=item *

Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.

=item *

Added the "==" operator to the list of supported version-checking
operators.

=item *

Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.

=item *

Clarified L</dynamic_config> a bit.

=back

=item August 23, 2005

=over 2

=item *

Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.

=back

=back
PK     ü2]ÄÀ·œB  œB    Meta/History/Meta_1_2.podnu „[µü¤        =for :stopwords MailingList RWS subcontext

=head1 NAME

CPAN::Meta::History::Meta_1_2 - Version 1.2 metadata specification for META.yml

=head1 PREFACE

This is a historical copy of the version 1.2 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.

Modifications from the original:

=over

=item *

Various spelling corrections

=item *

Include list of valid licenses from L<Module::Build> 0.2611 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.

=item *

Fixed some dead links to point to active resources.

=back

=head1 SYNOPSIS

 --- #YAML:1.0
 name: Module-Build
 abstract: Build and install Perl modules
 version: 0.20
 author:
   - Ken Williams <kwilliams@cpan.org>
 license: perl
 distribution_type: module
 requires:
   Config: 0
   Cwd: 0
   Data::Dumper: 0
   ExtUtils::Install: 0
   File::Basename: 0
   File::Compare: 0
   File::Copy: 0
   File::Find: 0
   File::Path: 0
   File::Spec: 0
   IO::File: 0
   perl: 5.005_03
 recommends:
   Archive::Tar: 1.00
   ExtUtils::Install: 0.3
   ExtUtils::ParseXS: 2.02
   Pod::Text: 0
   YAML: 0.35
 build_requires:
   Test: 0
 urls:
   license: http://dev.perl.org/licenses/
 meta-spec:
   version: 1.2
   url: http://module-build.sourceforge.net/META-spec-v1.2.html
 generated_by: Module::Build version 0.20

=head1 DESCRIPTION

This document describes version 1.2 of the F<META.yml> specification.

The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN.  It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.

The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.

I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>

=head1 FORMAT

F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).

See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:

=over 4

=item *

L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>

=item *

L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>

=item *

L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>

=back

=head1 TERMINOLOGY

=over 4

=item distribution

This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
for other developers to use.

=item module

This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby).

=back

=head1 VERSION SPECIFICATIONS

Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.).  This section details the
version specifications that are currently supported.

If a single version is listed, then that version is considered to be
the minimum version supported.

If 0 is given as the version number, then any version is supported.

Additionally, for more complicated requirements, the specification
supports a list of versions, each of which may be optionally preceded
by a relational operator.

Supported operators include E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), == (equal), and !=
(not equal).

If a list is given then it is evaluated from left to right so that any
specifications in the list that conflict with a previous specification
are overridden by the later.

Examples:

 >= 1.2, != 1.5, < 2.0

Any version from version 1.2 onward, except version 1.5, that also
precedes version 2.0.

=head1 HEADER

The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.

=head1 FIELDS

The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.

=head2 meta-spec

Example:

 meta-spec:
   version: 1.2
   url: http://module-build.sourceforge.net/META-spec-v1.2.html

(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.

=head2 name

Example:

  name: Module-Build

(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-".  Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/author/GAAS/libwww-perl/>).

=head2 version

Example:

  version: 0.20

(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.

=head2 abstract

Example:

  abstract: Build and install Perl modules.

(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.

=head2 author

Example:

  author:
    - Ken Williams <kwilliams@cpan.org>

(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.

=head2 license

Example:

  license: perl

(Spec 1.0) [required] {string} The license under which this distribution may be
used and redistributed.

Must be one of the following licenses:

=over 4

=item perl

The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.

=item gpl

The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).

=item lgpl

The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).

=item artistic

The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).

=item bsd

The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).

=item open_source

The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.

=item unrestricted

The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.

=item restrictive

The distribution may not be redistributed without special permission from the
author and/or copyright holder.

=back

=head2 distribution_type

Example:

  distribution_type: module

(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution.  Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.

Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them.  Tools like Module::Build and MakeMaker will likely stop
generating this field.

=head2 requires

Example:

  requires:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution requires for proper operation.  The keys are the module
names, and the values are version specifications as described in
L<Module::Build> for the "requires" parameter.

=head2 recommends

Example:

  recommends:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules this
distribution recommends for enhanced operation.

I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed
decision about which recommended modules to install.>

Example:

  optional_features:
  - foo:
      description: Provides the ability to blah.
      requires:
        Data::Dumper: 0
        File::Find: 1.03
  - bar:
      description: This feature is not available on this platform.
      excludes_os: MSWin32

I<(Spec 1.1) [optional] {map} A YAML sequence of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, L</conflicts>, C<requires_packages>,
C<requires_os>, and C<excludes_os> which have the same meaning in
this subcontext as described elsewhere in this document.>

=head2 build_requires

Example:

  build_requires:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules
required for building and/or testing of this distribution.  These
dependencies are not required after the module is installed.

=head2 conflicts

Example:

  conflicts:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl modules that
cannot be installed while this distribution is installed.  This is a
pretty uncommon situation.

=head2 dynamic_config

Example:

  dynamic_config: 0

(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file.  The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.

Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it.  It can potentially bring lots of
security, packaging, and convenience improvements.

If this field is omitted, it defaults to 1 (true).

=head2 private

I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>.  See below.

=head2 provides

Example:

  provides:
    Foo::Bar:
      file: lib/Foo/Bar.pm
      version: 0.27_02
    Foo::Bar::Blah:
      file: lib/Foo/Bar/Blah.pm
    Foo::Bar::Baz:
      file: lib/Foo/Bar/Baz.pm
      version: 0.3

(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution.  This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.

When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions.  This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.

=head2 no_index

Example:

  no_index:
    file:
    - My/Module.pm
    dir:
    - My/Private
    package:
    - My::Module::Stuff
    namespace:
    - My::Module::Stuff

(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools.  This is useful when no C<provides> field is
present.

I<(Note: I'm not actually sure who looks at this field, or exactly
what they do with it.  This spec could be off in some way from actual
usage.)>

=head3 file

(Spec 1.1) [optional] Exclude any listed file(s).

=head3 dir

(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).

=head3 package

(Spec 1.1) [optional] Exclude the listed package(s).

=head3 namespace

(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.

=head2 keywords

Example:

  keywords:
    - make
    - build
    - install

(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.

=head2 resources

Example:

  resources:
    license: http://dev.perl.org/licenses/
    homepage: http://sourceforge.net/projects/module-build
    bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
    MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general

(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution.  All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification.  If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.

The current set of official keys is:

=over 2

=item homepage

The official home of this project on the web.

=item license

An URL for an official statement of this distribution's license.

=item bugtracker

An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.

=back


=head2 generated_by

Example:

  generated_by: Module::Build version 0.20

(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file.  It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.

[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]

=head1 SEE ALSO

L<CPAN|http://www.cpan.org/>

L<CPAN.pm|CPAN>

L<CPANPLUS>

L<Data::Dumper>

L<ExtUtils::MakeMaker>

L<Module::Build>

L<Module::Install>

L<XML|http://www.w3.org/XML/>

L<YAML|http://www.yaml.org/>

=head1 HISTORY

=over 4

=item March 14, 2003 (Pi day)

=over 2

=item *

Created version 1.0 of this document.

=back

=item May 8, 2003

=over 2

=item *

Added the L</dynamic_config> field, which was missing from the initial
version.

=back

=item November 13, 2003

=over 2

=item *

Added more YAML rationale articles.

=item *

Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.

=item *

Added and deprecated the L</private> field.

=item *

Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.

=item *

Bumped version.

=back

=item November 16, 2003

=over 2

=item *

Added C<generation>, C<authored_by> fields.

=item *

Add alternative proposal to the L</recommends> field.

=item *

Add proposal for a C<requires_build_tools> field.

=back

=item December 9, 2003

=over 2

=item *

Added link to latest version of this specification on CPAN.

=item *

Added section L</"VERSION SPECIFICATIONS">.

=item *

Chang name from Module::Build::META-spec to CPAN::META::Specification.

=item *

Add proposal for C<auto_regenerate> field.

=back

=item December 15, 2003

=over 2

=item *

Add C<index> field as a compliment to L</no_index>

=item *

Add L</keywords> field as a means to aid searching distributions.

=item *

Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.

=back

=item July 26, 2005

=over 2

=item *

Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.

=item *

Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.

=item *

Added the "==" operator to the list of supported version-checking
operators.

=item *

Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.

=item *

Clarified L</dynamic_config> a bit.

=back

=item August 23, 2005

=over 2

=item *

Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.

=back

=back
PK     ü2]w#j¸dJ  dJ    Meta/History/Meta_1_4.podnu „[µü¤        =for :stopwords MailingList PODs RWS subcontext

=head1 NAME

CPAN::Meta::History::Meta_1_4 - Version 1.4 metadata specification for META.yml

=head1 PREFACE

This is a historical copy of the version 1.4 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.

Modifications from the original:

=over

=item *

Various spelling corrections

=item *

Include list of valid licenses from L<Module::Build> 0.2807 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.

=item *

Fixed some dead links to point to active resources.

=back

=head1 SYNOPSIS

 --- #YAML:1.0
 name: Module-Build
 abstract: Build and install Perl modules
 version: 0.20
 author:
   - Ken Williams <kwilliams@cpan.org>
 license: perl
 distribution_type: module
 requires:
   Config: 0
   Cwd: 0
   Data::Dumper: 0
   ExtUtils::Install: 0
   File::Basename: 0
   File::Compare: 0
   File::Copy: 0
   File::Find: 0
   File::Path: 0
   File::Spec: 0
   IO::File: 0
   perl: 5.005_03
 recommends:
   Archive::Tar: 1.00
   ExtUtils::Install: 0.3
   ExtUtils::ParseXS: 2.02
   Pod::Text: 0
   YAML: 0.35
 build_requires:
   Test: 0
 resources:
   license: http://dev.perl.org/licenses/
 meta-spec:
   version: 1.4
   url: http://module-build.sourceforge.net/META-spec-v1.3.html
 generated_by: Module::Build version 0.20

=head1 DESCRIPTION

This document describes version 1.4 of the F<META.yml> specification.

The F<META.yml> file describes important properties of contributed
Perl distributions such as the ones found on CPAN.  It is typically
created by tools like Module::Build, Module::Install, and
ExtUtils::MakeMaker.

The fields in the F<META.yml> file are meant to be helpful for people
maintaining module collections (like CPAN), for people writing
installation tools (like CPAN.pm or CPANPLUS), or just for people who
want to know some stuff about a distribution before downloading it and
starting to install it.

I<Note: The latest stable version of this specification can always be
found at L<http://module-build.sourceforge.net/META-spec-current.html>,
and the latest development version (which may include things that
won't make it into the stable version) can always be found at
L<http://module-build.sourceforge.net/META-spec-blead.html>.>

=head1 FORMAT

F<META.yml> files are written in the YAML format (see
L<http://www.yaml.org/>).

See the following links to learn why we chose YAML instead of, say,
XML or Data::Dumper:

=over 4

=item *

L<Module::Build design plans|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg407.html>

=item *

L<Not keen on YAML|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1353.html>

=item *

L<META Concerns|http://www.nntp.perl.org/group/perl.module-authors/2003/11/msg1385.html>

=back

=head1 TERMINOLOGY

=over 4

=item distribution

This is the primary object described by the F<META.yml>
specification. In the context of this document it usually refers to a
collection of modules, scripts, and/or documents that are distributed
together for other developers to use.  Examples of distributions are
C<Class-Container>, C<libwww-perl>, or C<DBI>.

=item module

This refers to a reusable library of code typically contained in a
single file. Currently, we primarily talk of perl modules, but this
specification should be open enough to apply to other languages as
well (ex. python, ruby).  Examples of modules are C<Class::Container>,
C<LWP::Simple>, or C<DBD::File>.

=back

=head1 HEADER

The first line of a F<META.yml> file should be a valid YAML document
header like C<"--- #YAML:1.0">.

=head1 FIELDS

The rest of the F<META.yml> file is one big YAML mapping whose keys
are described here.

=head2 meta-spec

Example:

 meta-spec:
   version: 1.4
   url: http://module-build.sourceforge.net/META-spec-v1.3.html

(Spec 1.1) [required] {URL} This field indicates the location of the
version of the META.yml specification used.

=head2 name

Example:

  name: Module-Build

(Spec 1.0) [required] {string} The name of the distribution which is often
created by taking the "main module" in the distribution and changing
"::" to "-".  Sometimes it's completely different, however, as in the
case of the libwww-perl distribution (see
L<http://search.cpan.org/dist/libwww-perl/>).

=head2 version

Example:

  version: 0.20

(Spec 1.0) [required] {version} The version of the distribution to which the
F<META.yml> file refers.

=head2 abstract

Example:

  abstract: Build and install Perl modules.

(Spec 1.1) [required] {string} A short description of the purpose of the
distribution.

=head2 author

Example:

  author:
    - Ken Williams <kwilliams@cpan.org>

(Spec 1.1) [required] {list of strings} A YAML sequence indicating the author(s) of the
distribution. The preferred form is author-name <email-address>.

=head2 license

Example:

  license: perl

(Spec 1.0) [required] {string} The license under which this
distribution may be used and redistributed.

Must be one of the following licenses:

=over 4

=item apache

The distribution is licensed under the Apache Software License version 1.1
(L<http://opensource.org/licenses/Apache-1.1>).

=item artistic

The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).

=item bsd

The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).

=item gpl

The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).

=item lgpl

The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).

=item mit

The distribution is licensed under the MIT License
(L<http://opensource.org/licenses/MIT>).

=item mozilla

The distribution is licensed under the Mozilla Public License.
(L<http://opensource.org/licenses/MPL-1.0> or
L<http://opensource.org/licenses/MPL-1.1>)

=item open_source

The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.

=item perl

The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL or
the Artistic license.

=item restrictive

The distribution may not be redistributed without special permission from the
author and/or copyright holder.

=item unrestricted

The distribution is licensed under a license that is not approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.

=back

=head2 distribution_type

Example:

  distribution_type: module

(Spec 1.0) [optional] {string} What kind of stuff is contained in this
distribution.  Most things on CPAN are C<module>s (which can also mean
a collection of modules), but some things are C<script>s.

Unfortunately this field is basically meaningless, since many
distributions are hybrids of several kinds of things, or some new
thing, or subjectively different in focus depending on who's using
them.  Tools like Module::Build and MakeMaker will likely stop
generating this field.

=head2 requires

Example:

  requires:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites this distribution requires for proper operation.  The
keys are the names of the prerequisites (module names or 'perl'), and
the values are version specifications as described in L<VERSION
SPECIFICATIONS>.

=head2 recommends

Example:

  recommends:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites this distribution recommends for enhanced operation.
The keys are the names of the prerequisites (module names or 'perl'),
and the values are version specifications as described in L<VERSION
SPECIFICATIONS>.


I<ALTERNATIVE: It may be desirable to present to the user which
features depend on which modules so they can make an informed decision
about which recommended modules to install.>

Example:

  optional_features:
    foo:
      description: Provides the ability to blah.
      requires:
        Data::Dumper: 0
        File::Find: 1.03

I<(Spec 1.1) [optional] {map} A YAML mapping of names for optional features
which are made available when its requirements are met. For each
feature a description is provided along with any of L</requires>,
L</build_requires>, and L</conflicts>, which have the same meaning in
this subcontext as described elsewhere in this document.>

=head2 build_requires

Example:

  build_requires:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating the Perl
prerequisites required for building and/or testing of this
distribution.  The keys are the names of the prerequisites (module
names or 'perl'), and the values are version specifications as
described in L</"VERSION SPECIFICATIONS">.  These dependencies are not
required after the distribution is installed.

=head2 configure_requires

Example:

  configure_requires:
    Module::Build: 0.2809
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.4) [optional] {map} A YAML mapping indicating the Perl prerequisites
required before configuring this distribution.  The keys are the
names of the prerequisites (module names or 'perl'), and the values are version
specifications as described in L</"VERSION SPECIFICATIONS">.  These
dependencies are not required after the distribution is installed.

=head2 conflicts

Example:

  conflicts:
    Data::Dumper: 0
    File::Find: 1.03

(Spec 1.0) [optional] {map} A YAML mapping indicating any items that
cannot be installed while this distribution is installed.  This is a
pretty uncommon situation.  The keys for C<conflicts> are the item
names (module names or 'perl'), and the values are version
specifications as described in L</"VERSION SPECIFICATIONS">.


=head2 dynamic_config

Example:

  dynamic_config: 0

(Spec 1.0) [optional] {boolean} A boolean flag indicating whether a F<Build.PL>
or F<Makefile.PL> (or similar) must be executed when building this
distribution, or whether it can be built, tested and installed solely
from consulting its
metadata file.  The main reason to set this to a true value is that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.

Currently Module::Build doesn't actually do anything with this flag
- it's probably going to be up to higher-level tools like CPAN
to do something useful with it.  It can potentially bring lots of
security, packaging, and convenience improvements.

If this field is omitted, it defaults to 1 (true).

=head2 private

I<(Deprecated)> (Spec 1.0) [optional] {map} This field has been renamed to
L</no_index>.  See below.

=head2 provides

Example:

  provides:
    Foo::Bar:
      file: lib/Foo/Bar.pm
      version: 0.27_02
    Foo::Bar::Blah:
      file: lib/Foo/Bar/Blah.pm
    Foo::Bar::Baz:
      file: lib/Foo/Bar/Baz.pm
      version: 0.3

(Spec 1.1) [optional] {map} A YAML mapping that describes all packages
provided by this distribution.  This information can be (and, in some
cases, is) used by distribution and automation mechanisms like PAUSE,
CPAN, and search.cpan.org to build indexes saying in which
distribution various packages can be found.

When using tools like L<Module::Build> that can generate the
C<provides> mapping for your distribution automatically, make sure you
examine what it generates to make sure it makes sense - indexers will
usually trust the C<provides> field if it's present, rather than
scanning through the distribution files themselves to figure out
packages and versions.  This is a good thing, because it means you can
use the C<provides> field to tell the indexers precisely what you want
indexed about your distribution, rather than relying on them to
essentially guess what you want indexed.

=head2 no_index

Example:

  no_index:
    file:
    - My/Module.pm
    directory:
    - My/Private
    package:
    - My::Module::Stuff
    namespace:
    - My::Module::Stuff

(Spec 1.1) [optional] {map} A YAML mapping that describes any files,
directories, packages, and namespaces that are private
(i.e. implementation artifacts) that are not of interest to searching
and indexing tools.  This is useful when no C<provides> field is
present.

For example, L<http://search.cpan.org/> excludes items listed in C<no_index>
when searching for POD, meaning files in these directories will not
converted to HTML and made public - which is useful if you have
example or test PODs that you don't want the search engine to go
through.

=head3 file

(Spec 1.1) [optional] Exclude any listed file(s).

=head3 directory

(Spec 1.1) [optional] Exclude anything below the listed
directory(ies).

[Note: previous editions of the spec had C<dir> instead of
C<directory>, but I think MakeMaker and various users started using
C<directory>, so in deference we switched to that.]

=head3 package

(Spec 1.1) [optional] Exclude the listed package(s).

=head3 namespace

(Spec 1.1) [optional] Excludes anything below the listed namespace(s),
but I<not> the listed namespace(s) its self.

=head2 keywords

Example:

  keywords:
    - make
    - build
    - install

(Spec 1.1) [optional] {list} A sequence of keywords/phrases that describe
this distribution.

=head2 resources

Example:

  resources:
    license: http://dev.perl.org/licenses/
    homepage: http://sourceforge.net/projects/module-build
    bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Module-Build
    repository: http://sourceforge.net/cvs/?group_id=45731
    MailingList: http://lists.sourceforge.net/lists/listinfo/module-build-general

(Spec 1.1) [optional] {map} A mapping of any URL resources related to
this distribution.  All-lower-case keys, such as C<homepage>,
C<license>, and C<bugtracker>, are reserved by this specification, as
they have "official" meanings defined here in this specification.  If
you'd like to add your own "special" entries (like the "MailingList"
entry above), use at least one upper-case letter.

The current set of official keys is:

=over 2

=item homepage

The official home of this project on the web.

=item license

An URL for an official statement of this distribution's license.

=item bugtracker

An URL for a bug tracker (e.g. Bugzilla or RT queue) for this project.

=back


=head2 generated_by

Example:

  generated_by: Module::Build version 0.20

(Spec 1.0) [required] {string} Indicates the tool that was used to create this
F<META.yml> file.  It's good form to include both the name of the tool
and its version, but this field is essentially opaque, at least for
the moment. If F<META.yml> was generated by hand, it is suggested that
the author be specified here.

[Note: My F<meta_stats.pl> script which I use to gather statistics
regarding F<META.yml> usage prefers the form listed above, i.e. it
splits on /\s+version\s+/ taking the first field as the name of the
tool that generated the file and the second field as version of that
tool. RWS]

=head1 VERSION SPECIFICATIONS

Some fields require a version specification (ex. L</requires>,
L</recommends>, L</build_requires>, etc.) to indicate the particular
versionZ<>(s) of some other module that may be required as a
prerequisite.  This section details the version specification formats
that are currently supported.

The simplest format for a version specification is just the version
number itself, e.g. C<2.4>.  This means that B<at least> version 2.4
must be present.  To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.

You may also use the operators E<lt> (less than), E<lt>= (less than or
equal), E<gt> (greater than), E<gt>= (greater than or equal), ==
(equal), and != (not equal).  For example, the specification C<E<lt>
2.0> means that any version of the prerequisite less than 2.0 is
suitable.

For more complicated situations, version specifications may be AND-ed
together using commas.  The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than>
2.0, and B<not equal to> 1.5.

=head1 SEE ALSO

L<CPAN|http://www.cpan.org/>

L<CPAN.pm|CPAN>

L<CPANPLUS>

L<Data::Dumper>

L<ExtUtils::MakeMaker>

L<Module::Build>

L<Module::Install>

L<XML|http://www.w3.org/XML/>

L<YAML|http://www.yaml.org/>

=head1 HISTORY

=over 4

=item March 14, 2003 (Pi day)

=over 2

=item *

Created version 1.0 of this document.

=back

=item May 8, 2003

=over 2

=item *

Added the L</dynamic_config> field, which was missing from the initial
version.

=back

=item November 13, 2003

=over 2

=item *

Added more YAML rationale articles.

=item *

Fixed existing link to YAML discussion thread to point to new
L<http://nntp.x.perl.org/group/> site.

=item *

Added and deprecated the L</private> field.

=item *

Added L</abstract>, C<configure>, C<requires_packages>,
C<requires_os>, C<excludes_os>, and L</no_index> fields.

=item *

Bumped version.

=back

=item November 16, 2003

=over 2

=item *

Added C<generation>, C<authored_by> fields.

=item *

Add alternative proposal to the L</recommends> field.

=item *

Add proposal for a C<requires_build_tools> field.

=back

=item December 9, 2003

=over 2

=item *

Added link to latest version of this specification on CPAN.

=item *

Added section L</"VERSION SPECIFICATIONS">.

=item *

Chang name from Module::Build::META-spec to CPAN::META::Specification.

=item *

Add proposal for C<auto_regenerate> field.

=back

=item December 15, 2003

=over 2

=item *

Add C<index> field as a compliment to L</no_index>

=item *

Add L</keywords> field as a means to aid searching distributions.

=item *

Add L</TERMINOLOGY> section to explain certain terms that may be
ambiguous.

=back

=item July 26, 2005

=over 2

=item *

Removed a bunch of items (generation, requires_build_tools,
requires_packages, configure, requires_os, excludes_os,
auto_regenerate) that have never actually been supported, but were
more like records of brainstorming.

=item *

Changed C<authored_by> to L</author>, since that's always been what
it's actually called in actual F<META.yml> files.

=item *

Added the "==" operator to the list of supported version-checking
operators.

=item *

Noted that the L</distribution_type> field is basically meaningless,
and shouldn't really be used.

=item *

Clarified L</dynamic_config> a bit.

=back

=item August 23, 2005

=over 2

=item *

Removed the name C<CPAN::META::Specification>, since that implies a
module that doesn't actually exist.

=back

=item June 12, 2007

=over 2

=item *

Added L</configure_requires>.

=back

=back
PK     ü2]w"ì‰"  ‰"    Meta/History/Meta_1_1.podnu „[µü¤        =for :stopwords Ingy READMEs WTF licensure

=head1 NAME

CPAN::Meta::History::Meta_1_1 - Version 1.1 metadata specification for META.yml

=head1 PREFACE

This is a historical copy of the version 1.1 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.

Modifications from the original:

=over

=item *

Conversion from the original HTML to POD format

=item *

Include list of valid licenses from L<Module::Build> 0.18 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.

=item *

Fixed some dead links to point to active resources.

=back

=head1 DESCRIPTION

This document describes version 1.1 of the F<META.yml> specification.

The F<META.yml> file describes important properties of contributed Perl
distributions such as the ones found on L<CPAN|http://www.cpan.org>.  It is
typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.

The fields in the F<META.yml> file are meant to be helpful to people
maintaining module collections (like CPAN), for people writing
installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
know some stuff about a distribution before downloading it and starting to
install it.

=head1 Format

F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format.  The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.

The first line of a F<META.yml> file should be a valid
L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">

=head1 Fields

The rest of the META.yml file is one big YAML
L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.

=over 4

=item name

Example: C<Module-Build>

The name of the distribution.  Often created by taking the "main
module" in the distribution and changing "::" to "-".  Sometimes it's
completely different, however, as in the case of the
L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.

=item version

Example: C<0.16>

The version of the distribution to which the META.yml file refers.
This is a mandatory field.

The version is essentially an arbitrary string, but I<must> be
only ASCII characters, and I<strongly should> be of the format
integer-dot-digit-digit, i.e. C<25.57>, optionally followed by
underscore-digit-digit, i.e. C<25.57_04>.

The standard tools that deal with module distribution (PAUSE, CPAN,
etc.) form an identifier for each distribution by joining the 'name'
and 'version' attributes with a dash (C<->) character.  Tools
who are prepared to deal with distributions that have no version
numbers generally omit the dash as well.

=item license

Example: C<perl>

a descriptive term for the licenses ... not authoritative, but must
be consistent with licensure statements in the READMEs, documentation, etc.

The license under which this distribution may be used and
redistributed.

Must be one of the following licenses:

=over 4

=item perl

The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.

=item gpl

The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).

=item lgpl

The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).

=item artistic

The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).

=item bsd

The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).

=item open_source

The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.

=item unrestricted

The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.

=item restrictive

The distribution may not be redistributed without special permission from the
author and/or copyright holder.

=back

=item license_uri

This should contain a URI where the exact terms of the license may be found.

(change "unrestricted" to "redistributable"?)

=item distribution_type

Example: C<module>

What kind of stuff is contained in this distribution.  Most things on
CPAN are C<module>s (which can also mean a collection of
modules), but some things are C<script>s.

This field is basically meaningless, and tools (like Module::Build or
MakeMaker) will likely stop generating it in the future.

=item private

WTF is going on here?

index_ignore: any application that indexes the contents of
distributions (PAUSE, search.cpan.org) ought to ignore the items
(packages, files, directories, namespace hierarchies).

=item requires

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation.  The keys are the module names, and the values are version
specifications as described in the
L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.

I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
change.  Advance notice will be given here.  The simple specifications
like C<"1.2"> will not change in format.>

=item recommends

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.

=item build_requires

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution.  These dependencies are not required after the
module is installed.

=item conflicts

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed.  This is a pretty uncommon situation.

- possibly separate out test-time prereqs, complications include: can
tests be meaningfully preserved for later running?  are test-time
prereqs in addition to build-time, or exclusive?

- make official location for installed *distributions*, which can
contain tests, etc.

=item dynamic_config

Example: C<0>

A boolean flag indicating whether a F<Build.PL> or
F<Makefile.PL> (or similar) must be executed, or whether this
module can be built, tested and installed solely from consulting its
metadata file.  The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.

Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
L<CPAN.pm|CPAN> to do something useful with it.  It can potentially
bring lots of security, packaging, and convenience improvements.

=item generated_by

Example: C<Module::Build version 0.16>

Indicates the tool that was used to create this F<META.yml> file.  It's
good form to include both the name of the tool and its version, but
this field is essentially opaque, at least for the moment.

=back

=head2 Ingy's suggestions

=over 4

=item short_description

add as field, containing abstract, maximum 80 characters, suggested minimum 40 characters

=item description

long version of abstract, should add?

=item maturity

alpha, beta, gamma, mature, stable

=item author_id, owner_id

=item categorization, keyword, chapter_id

=item URL for further information

could default to search.cpan.org on PAUSE

=item namespaces

can be specified for single elements by prepending
dotted-form, i.e. "com.example.my_application.my_property".  Default
namespace for META.yml is probably "org.cpan.meta_author" or
something.  Precedent for this is Apple's Carbon namespaces, I think.

=back

=head1 History

=over 4

=item *

B<March 14, 2003> (Pi day) - created version 1.0 of this document.

=item *

B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
initial version.

=back
PK     ü2]ÆPs,‰  ‰    Meta/History/Meta_1_0.podnu „[µü¤        =for :stopwords DOAP RDF

=head1 NAME

CPAN::Meta::History::Meta_1_0 - Version 1.0 metadata specification for META.yml

=head1 PREFACE

This is a historical copy of the version 1.0 specification for F<META.yml>
files, copyright by Ken Williams and licensed under the same terms as Perl
itself.

Modifications from the original:

=over

=item *

Conversion from the original HTML to POD format

=item *

Include list of valid licenses from L<Module::Build> 0.17 rather than
linking to the module, with minor updates to text and links to reflect
versions at the time of publication.

=item *

Fixed some dead links to point to active resources.

=back

=head1 DESCRIPTION

This document describes version 1.0 of the F<META.yml> specification.

The META.yml file describes important properties of contributed Perl
distributions such as the ones found on L<CPAN|http://www.cpan.org>.  It is
typically created by tools like L<Module::Build> and L<ExtUtils::MakeMaker>.

The fields in the F<META.yml> file are meant to be helpful to people
maintaining module collections (like CPAN), for people writing
installation tools (like L<CPAN> or L<CPANPLUS>), or just people who want to
know some stuff about a distribution before downloading it and starting to
install it.

=head1 Format

F<META.yml> files are written in the L<YAML|http://www.yaml.org/> format.  The
reasons we chose YAML instead of, say, XML or Data::Dumper are discussed in
L<this thread|http://www.nntp.perl.org/group/perl.makemaker/2002/04/msg406.html>
on the MakeMaker mailing list.

The first line of a F<META.yml> file should be a valid
L<YAML document header|http://yaml.org/spec/history/2002-10-31.html#syntax-document>
like C<"--- #YAML:1.0">

=head1 Fields

The rest of the META.yml file is one big YAML
L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>,
whose keys are described here.

=over 4

=item name

Example: C<Module-Build>

The name of the distribution.  Often created by taking the "main
module" in the distribution and changing "::" to "-".  Sometimes it's
completely different, however, as in the case of the
L<libwww-perl|http://search.cpan.org/author/GAAS/libwww-perl/> distribution.

=item version

Example: C<0.16>

The version of the distribution to which the META.yml file refers.

=item license

Example: C<perl>

The license under which this distribution may be used and
redistributed.

Must be one of the following licenses:

=over 4

=item perl

The distribution may be copied and redistributed under the same terms as perl
itself (this is by far the most common licensing option for modules on CPAN).
This is a dual license, in which the user may choose between either the GPL
version 1 or the Artistic version 1 license.

=item gpl

The distribution is distributed under the terms of the GNU General Public
License version 2 (L<http://opensource.org/licenses/GPL-2.0>).

=item lgpl

The distribution is distributed under the terms of the GNU Lesser General
Public License version 2 (L<http://opensource.org/licenses/LGPL-2.1>).

=item artistic

The distribution is licensed under the Artistic License version 1, as specified
by the Artistic file in the standard perl distribution
(L<http://opensource.org/licenses/Artistic-Perl-1.0>).

=item bsd

The distribution is licensed under the BSD 3-Clause License
(L<http://opensource.org/licenses/BSD-3-Clause>).

=item open_source

The distribution is licensed under some other Open Source Initiative-approved
license listed at L<http://www.opensource.org/licenses/>.

=item unrestricted

The distribution is licensed under a license that is B<not> approved by
L<www.opensource.org|http://www.opensource.org/> but that allows distribution
without restrictions.

=item restrictive

The distribution may not be redistributed without special permission from the
author and/or copyright holder.

=back

=item distribution_type

Example: C<module>

What kind of stuff is contained in this distribution.  Most things on
CPAN are C<module>s (which can also mean a collection of
modules), but some things are C<script>s.

=item requires

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution requires for proper
operation.  The keys are the module names, and the values are version
specifications as described in the
L<documentation for Module::Build's "requires" parameter|Module::Build::API/requires>.

I<Note: the exact nature of the fancy specifications like
C<< ">= 1.2, != 1.5, < 2.0" >> is subject to
change.  Advance notice will be given here.  The simple specifications
like C<"1.2"> will not change in format.>

=item recommends

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules this distribution recommends for enhanced
operation.

=item build_requires

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules required for building and/or testing of
this distribution.  These dependencies are not required after the
module is installed.

=item conflicts

Example:

  Data::Dumper: 0
  File::Find: 1.03

A YAML L<mapping|http://yaml.org/spec/history/2002-10-31.html#syntax-mapping>
indicating the Perl modules that cannot be installed while this
distribution is installed.  This is a pretty uncommon situation.

=item dynamic_config

Example: C<0>

A boolean flag indicating whether a F<Build.PL> or
F<Makefile.PL> (or similar) must be executed, or whether this
module can be built, tested and installed solely from consulting its
metadata file.  The main reason to set this to a true value if that
your module performs some dynamic configuration (asking questions,
sensing the environment, etc.) as part of its build/install process.

Currently L<Module::Build> doesn't actually do anything with
this flag - it's probably going to be up to higher-level tools like
L<CPAN.pm|CPAN> to do something useful with it.  It can potentially
bring lots of security, packaging, and convenience improvements.

=item generated_by

Example: C<Module::Build version 0.16>

Indicates the tool that was used to create this F<META.yml> file.  It's
good form to include both the name of the tool and its version, but
this field is essentially opaque, at least for the moment.

=back

=head1 Related Projects

=over 4

=item DOAP

An RDF vocabulary to describe software projects. L<http://usefulinc.com/doap>.

=back

=head1 History

=over 4

=item *

B<March 14, 2003> (Pi day) - created version 1.0 of this document.

=item *

B<May 8, 2003> - added the "dynamic_config" field, which was missing from the
initial version.

=back
PK     ü2]~“ ˆi#  i#    Meta/Merge.pmnu „[µü¤        use strict;
use warnings;

package CPAN::Meta::Merge;

our $VERSION = '2.150010';

use Carp qw/croak/;
use Scalar::Util qw/blessed/;
use CPAN::Meta::Converter 2.141170;

sub _is_identical {
  my ($left, $right) = @_;
  return
    (not defined $left and not defined $right)
    # if either of these are references, we compare the serialized value
    || (defined $left and defined $right and $left eq $right);
}

sub _identical {
  my ($left, $right, $path) = @_;
  croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
    unless _is_identical($left, $right);
  return $left;
}

sub _merge {
  my ($current, $next, $mergers, $path) = @_;
  for my $key (keys %{$next}) {
    if (not exists $current->{$key}) {
      $current->{$key} = $next->{$key};
    }
    elsif (my $merger = $mergers->{$key}) {
      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
    }
    elsif ($merger = $mergers->{':default'}) {
      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
    }
    else {
      croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
    }
  }
  return $current;
}

sub _uniq {
  my %seen = ();
  return grep { not $seen{$_}++ } @_;
}

sub _set_addition {
  my ($left, $right) = @_;
  return [ +_uniq(@{$left}, @{$right}) ];
}

sub _uniq_map {
  my ($left, $right, $path) = @_;
  for my $key (keys %{$right}) {
    if (not exists $left->{$key}) {
      $left->{$key} = $right->{$key};
    }
    # identical strings or references are merged identically
    elsif (_is_identical($left->{$key}, $right->{$key})) {
      1; # do nothing - keep left
    }
    elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
      $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
    }
    else {
      croak 'Duplication of element ' . join '.', @{$path}, $key;
    }
  }
  return $left;
}

sub _improvise {
  my ($left, $right, $path) = @_;
  my ($name) = reverse @{$path};
  if ($name =~ /^x_/) {
    if (ref($left) eq 'ARRAY') {
      return _set_addition($left, $right, $path);
    }
    elsif (ref($left) eq 'HASH') {
      return _uniq_map($left, $right, $path);
    }
    else {
      return _identical($left, $right, $path);
    }
  }
  croak sprintf "Can't merge '%s'", join '.', @{$path};
}

sub _optional_features {
  my ($left, $right, $path) = @_;

  for my $key (keys %{$right}) {
    if (not exists $left->{$key}) {
      $left->{$key} = $right->{$key};
    }
    else {
      for my $subkey (keys %{ $right->{$key} }) {
        next if $subkey eq 'prereqs';
        if (not exists $left->{$key}{$subkey}) {
          $left->{$key}{$subkey} = $right->{$key}{$subkey};
        }
        else {
          Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
            if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
        }
      }

      require CPAN::Meta::Prereqs;
      $left->{$key}{prereqs} =
        CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
          ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
          ->as_string_hash;
    }
  }
  return $left;
}


my %default = (
  abstract       => \&_identical,
  author         => \&_set_addition,
  dynamic_config => sub {
    my ($left, $right) = @_;
    return $left || $right;
  },
  generated_by => sub {
    my ($left, $right) = @_;
    return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
  },
  license     => \&_set_addition,
  'meta-spec' => {
    version => \&_identical,
    url     => \&_identical
  },
  name              => \&_identical,
  release_status    => \&_identical,
  version           => \&_identical,
  description       => \&_identical,
  keywords          => \&_set_addition,
  no_index          => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
  optional_features => \&_optional_features,
  prereqs           => sub {
    require CPAN::Meta::Prereqs;
    my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
    return $left->with_merged_prereqs($right)->as_string_hash;
  },
  provides  => \&_uniq_map,
  resources => {
    license    => \&_set_addition,
    homepage   => \&_identical,
    bugtracker => \&_uniq_map,
    repository => \&_uniq_map,
    ':default' => \&_improvise,
  },
  ':default' => \&_improvise,
);

sub new {
  my ($class, %arguments) = @_;
  croak 'default version required' if not exists $arguments{default_version};
  my %mapping = %default;
  my %extra = %{ $arguments{extra_mappings} || {} };
  for my $key (keys %extra) {
    if (ref($mapping{$key}) eq 'HASH') {
      $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
    }
    else {
      $mapping{$key} = $extra{$key};
    }
  }
  return bless {
    default_version => $arguments{default_version},
    mapping => _coerce_mapping(\%mapping, []),
  }, $class;
}

my %coderef_for = (
  set_addition => \&_set_addition,
  uniq_map     => \&_uniq_map,
  identical    => \&_identical,
  improvise    => \&_improvise,
  improvize    => \&_improvise, # [sic] for backwards compatibility
);

sub _coerce_mapping {
  my ($orig, $map_path) = @_;
  my %ret;
  for my $key (keys %{$orig}) {
    my $value = $orig->{$key};
    if (ref($orig->{$key}) eq 'CODE') {
      $ret{$key} = $value;
    }
    elsif (ref($value) eq 'HASH') {
      my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
      $ret{$key} = sub {
        my ($left, $right, $path) = @_;
        return _merge($left, $right, $mapping, [ @{$path} ]);
      };
    }
    elsif ($coderef_for{$value}) {
      $ret{$key} = $coderef_for{$value};
    }
    else {
      croak "Don't know what to do with " . join '.', @{$map_path}, $key;
    }
  }
  return \%ret;
}

sub merge {
  my ($self, @items) = @_;
  my $current = {};
  for my $next (@items) {
    if ( blessed($next) && $next->isa('CPAN::Meta') ) {
      $next = $next->as_struct;
    }
    elsif ( ref($next) eq 'HASH' ) {
      my $cmc = CPAN::Meta::Converter->new(
        $next, default_version => $self->{default_version}
      );
      $next = $cmc->upgrade_fragment;
    }
    else {
      croak "Don't know how to merge '$next'";
    }
    $current = _merge($current, $next, $self->{mapping}, []);
  }
  return $current;
}

1;

# ABSTRACT: Merging CPAN Meta fragments


# vim: ts=2 sts=2 sw=2 et :

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Merge - Merging CPAN Meta fragments

=head1 VERSION

version 2.150010

=head1 SYNOPSIS

 my $merger = CPAN::Meta::Merge->new(default_version => "2");
 my $meta = $merger->merge($base, @additional);

=head1 DESCRIPTION

=head1 METHODS

=head2 new

This creates a CPAN::Meta::Merge object. It takes one mandatory named
argument, C<version>, declaring the version of the meta-spec that must be
used for the merge. It can optionally take an C<extra_mappings> argument
that allows one to add additional merging functions for specific elements.

The C<extra_mappings> arguments takes a hash ref with the same type of
structure as described in L<CPAN::Meta::Spec>, except with its values as
one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
to a merging function.

  my $merger = CPAN::Meta::Merge->new(
      default_version => '2',
      extra_mappings => {
          'optional_features' => \&custom_merge_function,
          'x_custom' => 'set_addition',
          'x_meta_meta' => {
              name => 'identical',
              tags => 'set_addition',
          }
      }
  );

=head2 merge(@fragments)

Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
(possibly incomplete) hashrefs of metadata.

=head1 MERGE STRATEGIES

C<merge> uses various strategies to combine different elements of the CPAN::Meta objects.  The following strategies can be used with the extra_mappings argument of C<new>:

=over

=item identical

The elements must be identical

=item set_addition

The union of two array refs

  [ a, b ] U [ a, c]  = [ a, b, c ]

=item uniq_map

Key value pairs from the right hash are merged to the left hash.  Key
collisions are only allowed if their values are the same.  This merge
function will recurse into nested hash refs following the same merge
rules.

=item improvise

This merge strategy will try to pick the appropriate predefined strategy
based on what element type.  Array refs will try to use the
C<set_addition> strategy,  Hash refs will try to use the C<uniq_map>
strategy, and everything else will try the C<identical> strategy.

=back

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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
PK     ü2]ñ‚qNÃ  NÃ    Meta/Converter.pmnu „[µü¤        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;

our $VERSION = '2.150010';

#pod =head1 SYNOPSIS
#pod
#pod   my $struct = decode_json_file('META.json');
#pod
#pod   my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod   my $new_struct = $cmc->convert( version => "2" );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module converts CPAN Meta structures from one form to another.  The
#pod primary use is to convert older structures to the most modern version of
#pod the specification, but other transformations may be implemented in the
#pod future as needed.  (E.g. stripping all custom fields or stripping all
#pod optional fields.)
#pod
#pod =cut

use CPAN::Meta::Validator;
use CPAN::Meta::Requirements;
use Parse::CPAN::Meta 1.4400 ();

# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available.  This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.

BEGIN {
  eval "use version ()"; ## no critic
  if ( my $err = $@ ) {
    eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
  }
}

# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };

# We limit cloning to a maximum depth to bail out on circular data
# structures.  While actual cycle detection might be technically better,
# we expect circularity in META data structures to be rare and generally
# the result of user error.  Therefore, a depth counter is lower overhead.
our $DCLONE_MAXDEPTH = 1024;
our $_CLONE_DEPTH;

sub _dclone {
  my ( $ref  ) = @_;
  return $ref unless my $reftype = ref $ref;

  local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
  die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;

  return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
  return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;

  if ( 'SCALAR' eq $reftype ) {
    my $new = _dclone(${$ref});
    return \$new;
  }

  # We can't know if TO_JSON gives us cloned data, so refs must recurse
  if ( eval { $ref->can('TO_JSON') } ) {
    my $data = $ref->TO_JSON;
    return ref $data ? _dclone( $data ) : $data;
  }

  # Just stringify everything else
  return "$ref";
}

my %known_specs = (
    '2'   => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
    '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
    '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
    '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
    '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
    '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);

my @spec_list = sort { $a <=> $b } keys %known_specs;
my ($LOWEST, $HIGHEST) = @spec_list[0,-1];

#--------------------------------------------------------------------------#
# converters
#
# called as $converter->($element, $field_name, $full_meta, $to_version)
#
# defined return value used for field
# undef return value means field is skipped
#--------------------------------------------------------------------------#

sub _keep { $_[0] }

sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }

sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }

sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }

sub _generated_by {
  my $gen = shift;
  my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");

  return $sig unless defined $gen and length $gen;
  return $gen if $gen =~ /\Q$sig/;
  return "$gen, $sig";
}

sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }

sub _prefix_custom {
  my $key = shift;
  $key =~ s/^(?!x_)   # Unless it already starts with x_
             (?:x-?)? # Remove leading x- or x (if present)
           /x_/ix;    # and prepend x_
  return $key;
}

sub _ucfirst_custom {
  my $key = shift;
  $key = ucfirst $key unless $key =~ /[A-Z]/;
  return $key;
}

sub _no_prefix_ucfirst_custom {
  my $key = shift;
  $key =~ s/^x_//;
  return _ucfirst_custom($key);
}

sub _change_meta_spec {
  my ($element, undef, undef, $version) = @_;
  return {
    version => $version,
    url => $known_specs{$version},
  };
}

my @open_source = (
  'perl',
  'gpl',
  'apache',
  'artistic',
  'artistic_2',
  'lgpl',
  'bsd',
  'gpl',
  'mit',
  'mozilla',
  'open_source',
);

my %is_open_source = map {; $_ => 1 } @open_source;

my @valid_licenses_1 = (
  @open_source,
  'unrestricted',
  'restrictive',
  'unknown',
);

my %license_map_1 = (
  ( map { $_ => $_ } @valid_licenses_1 ),
  artistic2 => 'artistic_2',
);

sub _license_1 {
  my ($element) = @_;
  return 'unknown' unless defined $element;
  if ( $license_map_1{lc $element} ) {
    return $license_map_1{lc $element};
  }
  else {
    return 'unknown';
  }
}

my @valid_licenses_2 = qw(
  agpl_3
  apache_1_1
  apache_2_0
  artistic_1
  artistic_2
  bsd
  freebsd
  gfdl_1_2
  gfdl_1_3
  gpl_1
  gpl_2
  gpl_3
  lgpl_2_1
  lgpl_3_0
  mit
  mozilla_1_0
  mozilla_1_1
  openssl
  perl_5
  qpl_1_0
  ssleay
  sun
  zlib
  open_source
  restricted
  unrestricted
  unknown
);

# The "old" values were defined by Module::Build, and were often vague.  I have
# made the decisions below based on reading Module::Build::API and how clearly
# it specifies the version of the license.
my %license_map_2 = (
  (map { $_ => $_ } @valid_licenses_2),
  apache      => 'apache_2_0',  # clearly stated as 2.0
  artistic    => 'artistic_1',  # clearly stated as 1
  artistic2   => 'artistic_2',  # clearly stated as 2
  gpl         => 'open_source', # we don't know which GPL; punt
  lgpl        => 'open_source', # we don't know which LGPL; punt
  mozilla     => 'open_source', # we don't know which MPL; punt
  perl        => 'perl_5',      # clearly Perl 5
  restrictive => 'restricted',
);

sub _license_2 {
  my ($element) = @_;
  return [ 'unknown' ] unless defined $element;
  $element = [ $element ] unless ref $element eq 'ARRAY';
  my @new_list;
  for my $lic ( @$element ) {
    next unless defined $lic;
    if ( my $new = $license_map_2{lc $lic} ) {
      push @new_list, $new;
    }
  }
  return @new_list ? \@new_list : [ 'unknown' ];
}

my %license_downgrade_map = qw(
  agpl_3            open_source
  apache_1_1        apache
  apache_2_0        apache
  artistic_1        artistic
  artistic_2        artistic_2
  bsd               bsd
  freebsd           open_source
  gfdl_1_2          open_source
  gfdl_1_3          open_source
  gpl_1             gpl
  gpl_2             gpl
  gpl_3             gpl
  lgpl_2_1          lgpl
  lgpl_3_0          lgpl
  mit               mit
  mozilla_1_0       mozilla
  mozilla_1_1       mozilla
  openssl           open_source
  perl_5            perl
  qpl_1_0           open_source
  ssleay            open_source
  sun               open_source
  zlib              open_source
  open_source       open_source
  restricted        restrictive
  unrestricted      unrestricted
  unknown           unknown
);

sub _downgrade_license {
  my ($element) = @_;
  if ( ! defined $element ) {
    return "unknown";
  }
  elsif( ref $element eq 'ARRAY' ) {
    if ( @$element > 1) {
      if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
        return 'unknown';
      }
      else {
        return 'open_source';
      }
    }
    elsif ( @$element == 1 ) {
      return $license_downgrade_map{lc $element->[0]} || "unknown";
    }
  }
  elsif ( ! ref $element ) {
    return $license_downgrade_map{lc $element} || "unknown";
  }
  return "unknown";
}

my $no_index_spec_1_2 = {
  'file' => \&_listify,
  'dir' => \&_listify,
  'package' => \&_listify,
  'namespace' => \&_listify,
};

my $no_index_spec_1_3 = {
  'file' => \&_listify,
  'directory' => \&_listify,
  'package' => \&_listify,
  'namespace' => \&_listify,
};

my $no_index_spec_2 = {
  'file' => \&_listify,
  'directory' => \&_listify,
  'package' => \&_listify,
  'namespace' => \&_listify,
  ':custom'  => \&_prefix_custom,
};

sub _no_index_1_2 {
  my (undef, undef, $meta) = @_;
  my $no_index = $meta->{no_index} || $meta->{private};
  return unless $no_index;

  # cleanup wrong format
  if ( ! ref $no_index ) {
    my $item = $no_index;
    $no_index = { dir => [ $item ], file => [ $item ] };
  }
  elsif ( ref $no_index eq 'ARRAY' ) {
    my $list = $no_index;
    $no_index = { dir => [ @$list ], file => [ @$list ] };
  }

  # common mistake: files -> file
  if ( exists $no_index->{files} ) {
    $no_index->{file} = delete $no_index->{files};
  }
  # common mistake: modules -> module
  if ( exists $no_index->{modules} ) {
    $no_index->{module} = delete $no_index->{modules};
  }
  return _convert($no_index, $no_index_spec_1_2);
}

sub _no_index_directory {
  my ($element, $key, $meta, $version) = @_;
  return unless $element;

  # clean up wrong format
  if ( ! ref $element ) {
    my $item = $element;
    $element = { directory => [ $item ], file => [ $item ] };
  }
  elsif ( ref $element eq 'ARRAY' ) {
    my $list = $element;
    $element = { directory => [ @$list ], file => [ @$list ] };
  }

  if ( exists $element->{dir} ) {
    $element->{directory} = delete $element->{dir};
  }
  # common mistake: files -> file
  if ( exists $element->{files} ) {
    $element->{file} = delete $element->{files};
  }
  # common mistake: modules -> module
  if ( exists $element->{modules} ) {
    $element->{module} = delete $element->{modules};
  }
  my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
  return _convert($element, $spec);
}

sub _is_module_name {
  my $mod = shift;
  return unless defined $mod && length $mod;
  return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
}

sub _clean_version {
  my ($element) = @_;
  return 0 if ! defined $element;

  $element =~ s{^\s*}{};
  $element =~ s{\s*$}{};
  $element =~ s{^\.}{0.};

  return 0 if ! length $element;
  return 0 if ( $element eq 'undef' || $element eq '<undef>' );

  my $v = eval { version->new($element) };
  # XXX check defined $v and not just $v because version objects leak memory
  # in boolean context -- dagolden, 2012-02-03
  if ( defined $v ) {
    return _is_qv($v) ? $v->normal : $element;
  }
  else {
    return 0;
  }
}

sub _bad_version_hook {
  my ($v) = @_;
  $v =~ s{^\s*}{};
  $v =~ s{\s*$}{};
  $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
  my $vobj = eval { version->new($v) };
  return defined($vobj) ? $vobj : version->new(0); # or give up
}

sub _version_map {
  my ($element) = @_;
  return unless defined $element;
  if ( ref $element eq 'HASH' ) {
    # XXX turn this into CPAN::Meta::Requirements with bad version hook
    # and then turn it back into a hash
    my $new_map = CPAN::Meta::Requirements->new(
      { bad_version_hook => \&_bad_version_hook } # punt
    );
    while ( my ($k,$v) = each %$element ) {
      next unless _is_module_name($k);
      if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>'  ) {
        $v = 0;
      }
      # some weird, old META have bad yml with module => module
      # so check if value is like a module name and not like a version
      if ( _is_module_name($v) && ! version::is_lax($v) ) {
        $new_map->add_minimum($k => 0);
        $new_map->add_minimum($v => 0);
      }
      $new_map->add_string_requirement($k => $v);
    }
    return $new_map->as_string_hash;
  }
  elsif ( ref $element eq 'ARRAY' ) {
    my $hashref = { map { $_ => 0 } @$element };
    return _version_map($hashref); # clean up any weird stuff
  }
  elsif ( ref $element eq '' && length $element ) {
    return { $element => 0 }
  }
  return;
}

sub _prereqs_from_1 {
  my (undef, undef, $meta) = @_;
  my $prereqs = {};
  for my $phase ( qw/build configure/ ) {
    my $key = "${phase}_requires";
    $prereqs->{$phase}{requires} = _version_map($meta->{$key})
      if $meta->{$key};
  }
  for my $rel ( qw/requires recommends conflicts/ ) {
    $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
      if $meta->{$rel};
  }
  return $prereqs;
}

my $prereqs_spec = {
  configure => \&_prereqs_rel,
  build     => \&_prereqs_rel,
  test      => \&_prereqs_rel,
  runtime   => \&_prereqs_rel,
  develop   => \&_prereqs_rel,
  ':custom'  => \&_prefix_custom,
};

my $relation_spec = {
  requires   => \&_version_map,
  recommends => \&_version_map,
  suggests   => \&_version_map,
  conflicts  => \&_version_map,
  ':custom'  => \&_prefix_custom,
};

sub _cleanup_prereqs {
  my ($prereqs, $key, $meta, $to_version) = @_;
  return unless $prereqs && ref $prereqs eq 'HASH';
  return _convert( $prereqs, $prereqs_spec, $to_version );
}

sub _prereqs_rel {
  my ($relation, $key, $meta, $to_version) = @_;
  return unless $relation && ref $relation eq 'HASH';
  return _convert( $relation, $relation_spec, $to_version );
}


BEGIN {
  my @old_prereqs = qw(
    requires
    configure_requires
    recommends
    conflicts
  );

  for ( @old_prereqs ) {
    my $sub = "_get_$_";
    my ($phase,$type) = split qr/_/, $_;
    if ( ! defined $type ) {
      $type = $phase;
      $phase = 'runtime';
    }
    no strict 'refs';
    *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
  }
}

sub _get_build_requires {
  my ($data, $key, $meta) = @_;

  my $test_h  = _extract_prereqs($_[2]->{prereqs}, qw(test  requires)) || {};
  my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};

  my $test_req  = CPAN::Meta::Requirements->from_string_hash($test_h);
  my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);

  $test_req->add_requirements($build_req)->as_string_hash;
}

sub _extract_prereqs {
  my ($prereqs, $phase, $type) = @_;
  return unless ref $prereqs eq 'HASH';
  return scalar _version_map($prereqs->{$phase}{$type});
}

sub _downgrade_optional_features {
  my (undef, undef, $meta) = @_;
  return unless exists $meta->{optional_features};
  my $origin = $meta->{optional_features};
  my $features = {};
  for my $name ( keys %$origin ) {
    $features->{$name} = {
      description => $origin->{$name}{description},
      requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
      configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
      build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
      recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
      conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
    };
    for my $k (keys %{$features->{$name}} ) {
      delete $features->{$name}{$k} unless defined $features->{$name}{$k};
    }
  }
  return $features;
}

sub _upgrade_optional_features {
  my (undef, undef, $meta) = @_;
  return unless exists $meta->{optional_features};
  my $origin = $meta->{optional_features};
  my $features = {};
  for my $name ( keys %$origin ) {
    $features->{$name} = {
      description => $origin->{$name}{description},
      prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
    };
    delete $features->{$name}{prereqs}{configure};
  }
  return $features;
}

my $optional_features_2_spec = {
  description => \&_keep,
  prereqs => \&_cleanup_prereqs,
  ':custom'  => \&_prefix_custom,
};

sub _feature_2 {
  my ($element, $key, $meta, $to_version) = @_;
  return unless $element && ref $element eq 'HASH';
  _convert( $element, $optional_features_2_spec, $to_version );
}

sub _cleanup_optional_features_2 {
  my ($element, $key, $meta, $to_version) = @_;
  return unless $element && ref $element eq 'HASH';
  my $new_data = {};
  for my $k ( keys %$element ) {
    $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
  }
  return unless keys %$new_data;
  return $new_data;
}

sub _optional_features_1_4 {
  my ($element) = @_;
  return unless $element;
  $element = _optional_features_as_map($element);
  for my $name ( keys %$element ) {
    for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
      delete $element->{$name}{$drop};
    }
  }
  return $element;
}

sub _optional_features_as_map {
  my ($element) = @_;
  return unless $element;
  if ( ref $element eq 'ARRAY' ) {
    my %map;
    for my $feature ( @$element ) {
      my (@parts) = %$feature;
      $map{$parts[0]} = $parts[1];
    }
    $element = \%map;
  }
  return $element;
}

sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }

sub _url_or_drop {
  my ($element) = @_;
  return $element if _is_urlish($element);
  return;
}

sub _url_list {
  my ($element) = @_;
  return unless $element;
  $element = _listify( $element );
  $element = [ grep { _is_urlish($_) } @$element ];
  return unless @$element;
  return $element;
}

sub _author_list {
  my ($element) = @_;
  return [ 'unknown' ] unless $element;
  $element = _listify( $element );
  $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
  return [ 'unknown' ] unless @$element;
  return $element;
}

my $resource2_upgrade = {
  license    => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
  homepage   => \&_url_or_drop,
  bugtracker => sub {
    my ($item) = @_;
    return unless $item;
    if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
    elsif( _is_urlish($item) ) { return { web => $item } }
    else { return }
  },
  repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
  ':custom'  => \&_prefix_custom,
};

sub _upgrade_resources_2 {
  my (undef, undef, $meta, $version) = @_;
  return unless exists $meta->{resources};
  return _convert($meta->{resources}, $resource2_upgrade);
}

my $bugtracker2_spec = {
  web => \&_url_or_drop,
  mailto => \&_keep,
  ':custom'  => \&_prefix_custom,
};

sub _repo_type {
  my ($element, $key, $meta, $to_version) = @_;
  return $element if defined $element;
  return unless exists $meta->{url};
  my $repo_url = $meta->{url};
  for my $type ( qw/git svn/ ) {
    return $type if $repo_url =~ m{\A$type};
  }
  return;
}

my $repository2_spec = {
  web => \&_url_or_drop,
  url => \&_url_or_drop,
  type => \&_repo_type,
  ':custom'  => \&_prefix_custom,
};

my $resources2_cleanup = {
  license    => \&_url_list,
  homepage   => \&_url_or_drop,
  bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
  repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
  ':custom'  => \&_prefix_custom,
};

sub _cleanup_resources_2 {
  my ($resources, $key, $meta, $to_version) = @_;
  return unless $resources && ref $resources eq 'HASH';
  return _convert($resources, $resources2_cleanup, $to_version);
}

my $resource1_spec = {
  license    => \&_url_or_drop,
  homepage   => \&_url_or_drop,
  bugtracker => \&_url_or_drop,
  repository => \&_url_or_drop,
  ':custom'  => \&_keep,
};

sub _resources_1_3 {
  my (undef, undef, $meta, $version) = @_;
  return unless exists $meta->{resources};
  return _convert($meta->{resources}, $resource1_spec);
}

*_resources_1_4 = *_resources_1_3;

sub _resources_1_2 {
  my (undef, undef, $meta) = @_;
  my $resources = $meta->{resources} || {};
  if ( $meta->{license_url} && ! $resources->{license} ) {
    $resources->{license} = $meta->{license_url}
      if _is_urlish($meta->{license_url});
  }
  return unless keys %$resources;
  return _convert($resources, $resource1_spec);
}

my $resource_downgrade_spec = {
  license    => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
  homepage   => \&_url_or_drop,
  bugtracker => sub { return $_[0]->{web} },
  repository => sub { return $_[0]->{url} || $_[0]->{web} },
  ':custom'  => \&_no_prefix_ucfirst_custom,
};

sub _downgrade_resources {
  my (undef, undef, $meta, $version) = @_;
  return unless exists $meta->{resources};
  return _convert($meta->{resources}, $resource_downgrade_spec);
}

sub _release_status {
  my ($element, undef, $meta) = @_;
  return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
  return _release_status_from_version(undef, undef, $meta);
}

sub _release_status_from_version {
  my (undef, undef, $meta) = @_;
  my $version = $meta->{version} || '';
  return ( $version =~ /_/ ) ? 'testing' : 'stable';
}

my $provides_spec = {
  file => \&_keep,
  version => \&_keep,
};

my $provides_spec_2 = {
  file => \&_keep,
  version => \&_keep,
  ':custom'  => \&_prefix_custom,
};

sub _provides {
  my ($element, $key, $meta, $to_version) = @_;
  return unless defined $element && ref $element eq 'HASH';
  my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
  my $new_data = {};
  for my $k ( keys %$element ) {
    $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
    $new_data->{$k}{version} = _clean_version($element->{$k}{version})
      if exists $element->{$k}{version};
  }
  return $new_data;
}

sub _convert {
  my ($data, $spec, $to_version, $is_fragment) = @_;

  my $new_data = {};
  for my $key ( keys %$spec ) {
    next if $key eq ':custom' || $key eq ':drop';
    next unless my $fcn = $spec->{$key};
    if ( $is_fragment && $key eq 'generated_by' ) {
      $fcn = \&_keep;
    }
    die "spec for '$key' is not a coderef"
      unless ref $fcn && ref $fcn eq 'CODE';
    my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
    $new_data->{$key} = $new_value if defined $new_value;
  }

  my $drop_list   = $spec->{':drop'};
  my $customizer  = $spec->{':custom'} || \&_keep;

  for my $key ( keys %$data ) {
    next if $drop_list && grep { $key eq $_ } @$drop_list;
    next if exists $spec->{$key}; # we handled it
    $new_data->{ $customizer->($key) } = $data->{$key};
  }

  return $new_data;
}

#--------------------------------------------------------------------------#
# define converters for each conversion
#--------------------------------------------------------------------------#

# each converts from prior version
# special ":custom" field is used for keys not recognized in spec
my %up_convert = (
  '2-from-1.4' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_2,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'dynamic_config'      => \&_keep_or_one,
    # ADDED MANDATORY
    'release_status'      => \&_release_status,
    # PRIOR OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_upgrade_optional_features,
    'provides'            => \&_provides,
    'resources'           => \&_upgrade_resources_2,
    # ADDED OPTIONAL
    'description'         => \&_keep,
    'prereqs'             => \&_prereqs_from_1,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
        build_requires
        configure_requires
        conflicts
        distribution_type
        license_url
        private
        recommends
        requires
    ) ],

    # other random keys need x_ prefixing
    ':custom'              => \&_prefix_custom,
  },
  '1.4-from-1.3' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_1_4,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_4,
    # ADDED OPTIONAL
    'configure_requires'  => \&_keep,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
      license_url
      private
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
  '1.3-from-1.2' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
      license_url
      private
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
  '1.2-from-1.1' => {
    # PRIOR MANDATORY
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'license'             => \&_license_1,
    'name'                => \&_keep,
    'generated_by'        => \&_generated_by,
    # ADDED MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'meta-spec'           => \&_change_meta_spec,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_1_2,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'resources'           => \&_resources_1_2,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
      license_url
      private
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
  '1.1-from-1.0' => {
    # CHANGED TO MANDATORY
    'version'             => \&_keep,
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'license_url'         => \&_url_or_drop,
    'private'             => \&_keep,

    # other random keys are OK if already valid
    ':custom'              => \&_keep
  },
);

my %down_convert = (
  '1.4-from-2' => {
    # MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_downgrade_license,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # OPTIONAL
    'build_requires'      => \&_get_build_requires,
    'configure_requires'  => \&_get_configure_requires,
    'conflicts'           => \&_get_conflicts,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_downgrade_optional_features,
    'provides'            => \&_provides,
    'recommends'          => \&_get_recommends,
    'requires'            => \&_get_requires,
    'resources'           => \&_downgrade_resources,

    # drop these unsupported fields (after conversion)
    ':drop' => [ qw(
      description
      prereqs
      release_status
    )],

    # custom keys will be left unchanged
    ':custom'              => \&_keep
  },
  '1.3-from-1.4' => {
    # MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # drop these unsupported fields, but only after we convert
    ':drop' => [ qw(
      configure_requires
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
  '1.2-from-1.3' => {
    # MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_1_2,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
  '1.1-from-1.2' => {
    # MANDATORY
    'version'             => \&_keep,
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    # OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'private'             => \&_keep,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,

    # drop unsupported fields
    ':drop' => [ qw(
      abstract
      author
      provides
      no_index
      keywords
      resources
    )],

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
  '1.0-from-1.1' => {
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,

    # other random keys are OK if already valid
    ':custom'              => \&_keep,
  },
);

my %cleanup = (
  '2' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_2,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'dynamic_config'      => \&_keep_or_one,
    # ADDED MANDATORY
    'release_status'      => \&_release_status,
    # PRIOR OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_cleanup_optional_features_2,
    'provides'            => \&_provides,
    'resources'           => \&_cleanup_resources_2,
    # ADDED OPTIONAL
    'description'         => \&_keep,
    'prereqs'             => \&_cleanup_prereqs,

    # drop these deprecated fields, but only after we convert
    ':drop' => [ qw(
        build_requires
        configure_requires
        conflicts
        distribution_type
        license_url
        private
        recommends
        requires
    ) ],

    # other random keys need x_ prefixing
    ':custom'              => \&_prefix_custom,
  },
  '1.4' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_1_4,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_4,
    # ADDED OPTIONAL
    'configure_requires'  => \&_keep,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.3' => {
    # PRIOR MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'meta-spec'           => \&_change_meta_spec,
    'name'                => \&_keep,
    'version'             => \&_keep,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_directory,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    'resources'           => \&_resources_1_3,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.2' => {
    # PRIOR MANDATORY
    'version'             => \&_keep,
    # CHANGED TO MANDATORY
    'license'             => \&_license_1,
    'name'                => \&_keep,
    'generated_by'        => \&_generated_by,
    # ADDED MANDATORY
    'abstract'            => \&_keep_or_unknown,
    'author'              => \&_author_list,
    'meta-spec'           => \&_change_meta_spec,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'keywords'            => \&_keep,
    'no_index'            => \&_no_index_1_2,
    'optional_features'   => \&_optional_features_as_map,
    'provides'            => \&_provides,
    'resources'           => \&_resources_1_2,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.1' => {
    # CHANGED TO MANDATORY
    'version'             => \&_keep,
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    # PRIOR OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,
    # ADDED OPTIONAL
    'license_url'         => \&_url_or_drop,
    'private'             => \&_keep,

    # other random keys are OK if already valid
    ':custom'             => \&_keep
  },
  '1.0' => {
    # IMPLIED MANDATORY
    'name'                => \&_keep,
    'meta-spec'           => \&_change_meta_spec,
    'version'             => \&_keep,
    # IMPLIED OPTIONAL
    'build_requires'      => \&_version_map,
    'conflicts'           => \&_version_map,
    'distribution_type'   => \&_keep,
    'dynamic_config'      => \&_keep_or_one,
    'generated_by'        => \&_generated_by,
    'license'             => \&_license_1,
    'recommends'          => \&_version_map,
    'requires'            => \&_version_map,

    # other random keys are OK if already valid
    ':custom'             => \&_keep,
  },
);

# for a given field in a spec version, what fields will it feed
# into in the *latest* spec (i.e. v2); meta-spec omitted because
# we always expect a meta-spec to be generated
my %fragments_generate = (
  '2' => {
    'abstract'            =>   'abstract',
    'author'              =>   'author',
    'generated_by'        =>   'generated_by',
    'license'             =>   'license',
    'name'                =>   'name',
    'version'             =>   'version',
    'dynamic_config'      =>   'dynamic_config',
    'release_status'      =>   'release_status',
    'keywords'            =>   'keywords',
    'no_index'            =>   'no_index',
    'optional_features'   =>   'optional_features',
    'provides'            =>   'provides',
    'resources'           =>   'resources',
    'description'         =>   'description',
    'prereqs'             =>   'prereqs',
  },
  '1.4' => {
    'abstract'            => 'abstract',
    'author'              => 'author',
    'generated_by'        => 'generated_by',
    'license'             => 'license',
    'name'                => 'name',
    'version'             => 'version',
    'build_requires'      => 'prereqs',
    'conflicts'           => 'prereqs',
    'distribution_type'   => 'distribution_type',
    'dynamic_config'      => 'dynamic_config',
    'keywords'            => 'keywords',
    'no_index'            => 'no_index',
    'optional_features'   => 'optional_features',
    'provides'            => 'provides',
    'recommends'          => 'prereqs',
    'requires'            => 'prereqs',
    'resources'           => 'resources',
    'configure_requires'  => 'prereqs',
  },
);
# this is not quite true but will work well enough
# as 1.4 is a superset of earlier ones
$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;

#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#

#pod =method new
#pod
#pod   my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod The constructor should be passed a valid metadata structure but invalid
#pod structures are accepted.  If no meta-spec version is provided, version 1.0 will
#pod be assumed.
#pod
#pod Optionally, you can provide a C<default_version> argument after C<$struct>:
#pod
#pod   my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
#pod
#pod This is only needed when converting a metadata fragment that does not include a
#pod C<meta-spec> field.
#pod
#pod =cut

sub new {
  my ($class,$data,%args) = @_;

  # create an attributes hash
  my $self = {
    'data'    => $data,
    'spec'    => _extract_spec_version($data, $args{default_version}),
  };

  # create the object
  return bless $self, $class;
}

sub _extract_spec_version {
    my ($data, $default) = @_;
    my $spec = $data->{'meta-spec'};

    # is meta-spec there and valid?
    return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?

    # does the version key look like a valid version?
    my $v = $spec->{version};
    if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
        return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
        return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
    }

    # otherwise, use heuristics: look for 1.x vs 2.0 fields
    return "2" if exists $data->{prereqs};
    return "1.4" if exists $data->{configure_requires};
    return( $default || "1.2" ); # when meta-spec was first defined
}

#pod =method convert
#pod
#pod   my $new_struct = $cmc->convert( version => "2" );
#pod
#pod Returns a new hash reference with the metadata converted to a different form.
#pod C<convert> will die if any conversion/standardization still results in an
#pod invalid structure.
#pod
#pod Valid parameters include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
#pod Defaults to the latest version of the CPAN Meta Spec.
#pod
#pod =back
#pod
#pod Conversion proceeds through each version in turn.  For example, a version 1.2
#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
#pod conversion process attempts to clean-up simple errors and standardize data.
#pod For example, if C<author> is given as a scalar, it will converted to an array
#pod reference containing the item. (Converting a structure to its own version will
#pod also clean-up and standardize.)
#pod
#pod When data are cleaned and standardized, missing or invalid fields will be
#pod replaced with sensible defaults when possible.  This may be lossy or imprecise.
#pod For example, some badly structured META.yml files on CPAN have prerequisite
#pod modules listed as both keys and values:
#pod
#pod   requires => { 'Foo::Bar' => 'Bam::Baz' }
#pod
#pod These would be split and each converted to a prerequisite with a minimum
#pod version of zero.
#pod
#pod When some mandatory fields are missing or invalid, the conversion will attempt
#pod to provide a sensible default or will fill them with a value of 'unknown'.  For
#pod example a missing or unrecognized C<license> field will result in a C<license>
#pod field of 'unknown'.  Fields that may get an 'unknown' include:
#pod
#pod =for :list
#pod * abstract
#pod * author
#pod * license
#pod
#pod =cut

sub convert {
  my ($self, %args) = @_;
  my $args = { %args };

  my $new_version = $args->{version} || $HIGHEST;
  my $is_fragment = $args->{is_fragment};

  my ($old_version) = $self->{spec};
  my $converted = _dclone($self->{data});

  if ( $old_version == $new_version ) {
    $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
    unless ( $args->{is_fragment} ) {
      my $cmv = CPAN::Meta::Validator->new( $converted );
      unless ( $cmv->is_valid ) {
        my $errs = join("\n", $cmv->errors);
        die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
      }
    }
    return $converted;
  }
  elsif ( $old_version > $new_version )  {
    my @vers = sort { $b <=> $a } keys %known_specs;
    for my $i ( 0 .. $#vers-1 ) {
      next if $vers[$i] > $old_version;
      last if $vers[$i+1] < $new_version;
      my $spec_string = "$vers[$i+1]-from-$vers[$i]";
      $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
      unless ( $args->{is_fragment} ) {
        my $cmv = CPAN::Meta::Validator->new( $converted );
        unless ( $cmv->is_valid ) {
          my $errs = join("\n", $cmv->errors);
          die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
        }
      }
    }
    return $converted;
  }
  else {
    my @vers = sort { $a <=> $b } keys %known_specs;
    for my $i ( 0 .. $#vers-1 ) {
      next if $vers[$i] < $old_version;
      last if $vers[$i+1] > $new_version;
      my $spec_string = "$vers[$i+1]-from-$vers[$i]";
      $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
      unless ( $args->{is_fragment} ) {
        my $cmv = CPAN::Meta::Validator->new( $converted );
        unless ( $cmv->is_valid ) {
          my $errs = join("\n", $cmv->errors);
          die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
        }
      }
    }
    return $converted;
  }
}

#pod =method upgrade_fragment
#pod
#pod   my $new_struct = $cmc->upgrade_fragment;
#pod
#pod Returns a new hash reference with the metadata converted to the latest version
#pod of the CPAN Meta Spec.  No validation is done on the result -- you must
#pod validate after merging fragments into a complete metadata document.
#pod
#pod Available since version 2.141170.
#pod
#pod =cut

sub upgrade_fragment {
  my ($self) = @_;
  my ($old_version) = $self->{spec};
  my %expected =
    map {; $_ => 1 }
    grep { defined }
    map { $fragments_generate{$old_version}{$_} }
    keys %{ $self->{data} };
  my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
  for my $key ( keys %$converted ) {
    next if $key =~ /^x_/i || $key eq 'meta-spec';
    delete $converted->{$key} unless $expected{$key};
  }
  return $converted;
}

1;

# ABSTRACT: Convert CPAN distribution metadata structures

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Converter - Convert CPAN distribution metadata structures

=head1 VERSION

version 2.150010

=head1 SYNOPSIS

  my $struct = decode_json_file('META.json');

  my $cmc = CPAN::Meta::Converter->new( $struct );

  my $new_struct = $cmc->convert( version => "2" );

=head1 DESCRIPTION

This module converts CPAN Meta structures from one form to another.  The
primary use is to convert older structures to the most modern version of
the specification, but other transformations may be implemented in the
future as needed.  (E.g. stripping all custom fields or stripping all
optional fields.)

=head1 METHODS

=head2 new

  my $cmc = CPAN::Meta::Converter->new( $struct );

The constructor should be passed a valid metadata structure but invalid
structures are accepted.  If no meta-spec version is provided, version 1.0 will
be assumed.

Optionally, you can provide a C<default_version> argument after C<$struct>:

  my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );

This is only needed when converting a metadata fragment that does not include a
C<meta-spec> field.

=head2 convert

  my $new_struct = $cmc->convert( version => "2" );

Returns a new hash reference with the metadata converted to a different form.
C<convert> will die if any conversion/standardization still results in an
invalid structure.

Valid parameters include:

=over

=item *

C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
Defaults to the latest version of the CPAN Meta Spec.

=back

Conversion proceeds through each version in turn.  For example, a version 1.2
structure might be converted to 1.3 then 1.4 then finally to version 2. The
conversion process attempts to clean-up simple errors and standardize data.
For example, if C<author> is given as a scalar, it will converted to an array
reference containing the item. (Converting a structure to its own version will
also clean-up and standardize.)

When data are cleaned and standardized, missing or invalid fields will be
replaced with sensible defaults when possible.  This may be lossy or imprecise.
For example, some badly structured META.yml files on CPAN have prerequisite
modules listed as both keys and values:

  requires => { 'Foo::Bar' => 'Bam::Baz' }

These would be split and each converted to a prerequisite with a minimum
version of zero.

When some mandatory fields are missing or invalid, the conversion will attempt
to provide a sensible default or will fill them with a value of 'unknown'.  For
example a missing or unrecognized C<license> field will result in a C<license>
field of 'unknown'.  Fields that may get an 'unknown' include:

=over 4

=item *

abstract

=item *

author

=item *

license

=back

=head2 upgrade_fragment

  my $new_struct = $cmc->upgrade_fragment;

Returns a new hash reference with the metadata converted to the latest version
of the CPAN Meta Spec.  No validation is done on the result -- you must
validate after merging fragments into a complete metadata document.

Available since version 2.141170.

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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

__END__


# vim: ts=2 sts=2 sw=2 et :
PK     ü2]V–}™  ™    Meta/Spec.pmnu „[µü¤        # XXX RULES FOR PATCHING THIS FILE XXX
# Patches that fix typos or formatting are acceptable.  Patches
# that change semantics are not acceptable without prior approval
# by David Golden or Ricardo Signes.

use 5.006;
use strict;
use warnings;
package CPAN::Meta::Spec;

our $VERSION = '2.150010';

1;

# ABSTRACT: specification for CPAN distribution metadata


# vi:tw=72

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Spec - specification for CPAN distribution metadata

=head1 VERSION

version 2.150010

=head1 SYNOPSIS

  my $distmeta = {
    name => 'Module-Build',
    abstract => 'Build and install Perl modules',
    description =>  "Module::Build is a system for "
      . "building, testing, and installing Perl modules. "
      . "It is meant to ... blah blah blah ...",
    version  => '0.36',
    release_status => 'stable',
    author   => [
      'Ken Williams <kwilliams@cpan.org>',
      'Module-Build List <module-build@perl.org>', # additional contact
    ],
    license  => [ 'perl_5' ],
    prereqs => {
      runtime => {
        requires => {
          'perl'   => '5.006',
          'ExtUtils::Install' => '0',
          'File::Basename' => '0',
          'File::Compare'  => '0',
          'IO::File'   => '0',
        },
        recommends => {
          'Archive::Tar' => '1.00',
          'ExtUtils::Install' => '0.3',
          'ExtUtils::ParseXS' => '2.02',
        },
      },
      build => {
        requires => {
          'Test::More' => '0',
        },
      }
    },
    resources => {
      license => ['http://dev.perl.org/licenses/'],
    },
    optional_features => {
      domination => {
        description => 'Take over the world',
        prereqs     => {
          develop => { requires => { 'Genius::Evil'     => '1.234' } },
          runtime => { requires => { 'Machine::Weather' => '2.0'   } },
        },
      },
    },
    dynamic_config => 1,
    keywords => [ qw/ toolchain cpan dual-life / ],
    'meta-spec' => {
      version => '2',
      url     => 'https://metacpan.org/pod/CPAN::Meta::Spec',
    },
    generated_by => 'Module::Build version 0.36',
  };

=head1 DESCRIPTION

This document describes version 2 of the CPAN distribution metadata
specification, also known as the "CPAN Meta Spec".

Revisions of this specification for typo corrections and prose
clarifications may be issued as CPAN::Meta::Spec 2.I<x>.  These
revisions will never change semantics or add or remove specified
behavior.

Distribution metadata describe important properties of Perl
distributions. Distribution building tools like Module::Build,
Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a
metadata file in accordance with this specification and include it with
the distribution for use by automated tools that index, examine, package
or install Perl distributions.

=head1 TERMINOLOGY

=over 4

=item distribution

This is the primary object described by the metadata. In the context of
this document it usually refers to a collection of modules, scripts,
and/or documents that are distributed together for other developers to
use.  Examples of distributions are C<Class-Container>, C<libwww-perl>,
or C<DBI>.

=item module

This refers to a reusable library of code contained in a single file.
Modules usually contain one or more packages and are often referred
to by the name of a primary package that can be mapped to the file
name. For example, one might refer to C<File::Spec> instead of
F<File/Spec.pm>

=item package

This refers to a namespace declared with the Perl C<package> statement.
In Perl, packages often have a version number property given by the
C<$VERSION> variable in the namespace.

=item consumer

This refers to code that reads a metadata file, deserializes it into a
data structure in memory, or interprets a data structure of metadata
elements.

=item producer

This refers to code that constructs a metadata data structure,
serializes into a bytestream and/or writes it to disk.

=item must, should, may, etc.

These terms are interpreted as described in IETF RFC 2119.

=back

=head1 DATA TYPES

Fields in the L</STRUCTURE> section describe data elements, each of
which has an associated data type as described herein.  There are four
primitive types: Boolean, String, List and Map.  Other types are
subtypes of primitives and define compound data structures or define
constraints on the values of a data element.

=head2 Boolean

A I<Boolean> is used to provide a true or false value.  It B<must> be
represented as a defined value that is either "1" or "0" or stringifies
to those values.

=head2 String

A I<String> is data element containing a non-zero length sequence of
Unicode characters, such as an ordinary Perl scalar that is not a
reference.

=head2 List

A I<List> is an ordered collection of zero or more data elements.
Elements of a List may be of mixed types.

Producers B<must> represent List elements using a data structure which
unambiguously indicates that multiple values are possible, such as a
reference to a Perl array (an "arrayref").

Consumers expecting a List B<must> consider a String as equivalent to a
List of length 1.

=head2 Map

A I<Map> is an unordered collection of zero or more data elements
("values"), indexed by associated String elements ("keys").  The Map's
value elements may be of mixed types.

=head2 License String

A I<License String> is a subtype of String with a restricted set of
values.  Valid values are described in detail in the description of
the L</license> field.

=head2 URL

I<URL> is a subtype of String containing a Uniform Resource Locator or
Identifier.  [ This type is called URL and not URI for historical reasons. ]

=head2 Version

A I<Version> is a subtype of String containing a value that describes
the version number of packages or distributions.  Restrictions on format
are described in detail in the L</Version Formats> section.

=head2 Version Range

The I<Version Range> type is a subtype of String.  It describes a range
of Versions that may be present or installed to fulfill prerequisites.
It is specified in detail in the L</Version Ranges> section.

=head1 STRUCTURE

The metadata structure is a data element of type Map.  This section
describes valid keys within the Map.

Any keys not described in this specification document (whether top-level
or within compound data structures described herein) are considered
I<custom keys> and B<must> begin with an "x" or "X" and be followed by an
underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>.  If a
custom key refers to a compound data structure, subkeys within it do not
need an "x_" or "X_" prefix.

Consumers of metadata may ignore any or all custom keys.  All other keys
not described herein are invalid and should be ignored by consumers.
Producers must not generate or output invalid keys.

For each key, an example is provided followed by a description.  The
description begins with the version of spec in which the key was added
or in which the definition was modified, whether the key is I<required>
or I<optional> and the data type of the corresponding data element.
These items are in parentheses, brackets and braces, respectively.

If a data type is a Map or Map subtype, valid subkeys will be described
as well.

Some fields are marked I<Deprecated>.  These are shown for historical
context and must not be produced in or consumed from any metadata structure
of version 2 or higher.

=head2 REQUIRED FIELDS

=head3 abstract

Example:

  abstract => 'Build and install Perl modules'

(Spec 1.2) [required] {String}

This is a short description of the purpose of the distribution.

=head3 author

Example:

  author => [ 'Ken Williams <kwilliams@cpan.org>' ]

(Spec 1.2) [required] {List of one or more Strings}

This List indicates the person(s) to contact concerning the
distribution. The preferred form of the contact string is:

  contact-name <email-address>

This field provides a general contact list independent of other
structured fields provided within the L</resources> field, such as
C<bugtracker>.  The addressee(s) can be contacted for any purpose
including but not limited to (security) problems with the distribution,
questions about the distribution or bugs in the distribution.

A distribution's original author is usually the contact listed within
this field.  Co-maintainers, successor maintainers or mailing lists
devoted to the distribution may also be listed in addition to or instead
of the original author.

=head3 dynamic_config

Example:

  dynamic_config => 1

(Spec 2) [required] {Boolean}

A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or
similar) must be executed to determine prerequisites.

This field should be set to a true value if the distribution performs
some dynamic configuration (asking questions, sensing the environment,
etc.) as part of its configuration.  This field should be set to a false
value to indicate that prerequisites included in metadata may be
considered final and valid for static analysis.

Note: when this field is true, post-configuration prerequisites are not
guaranteed to bear any relation whatsoever to those stated in the metadata,
and relying on them doing so is an error. See also
L</Prerequisites for dynamically configured distributions> in the implementors'
notes.

This field explicitly B<does not> indicate whether installation may be
safely performed without using a Makefile or Build file, as there may be
special files to install or custom installation targets (e.g. for
dual-life modules that exist on CPAN as well as in the Perl core).  This
field only defines whether or not prerequisites are exactly as given in the
metadata.

=head3 generated_by

Example:

  generated_by => 'Module::Build version 0.36'

(Spec 1.0) [required] {String}

This field indicates the tool that was used to create this metadata.
There are no defined semantics for this field, but it is traditional to
use a string in the form "Generating::Package version 1.23" or the
author's name, if the file was generated by hand.

=head3 license

Example:

  license => [ 'perl_5' ]

  license => [ 'apache_2_0', 'mozilla_1_0' ]

(Spec 2) [required] {List of one or more License Strings}

One or more licenses that apply to some or all of the files in the
distribution.  If multiple licenses are listed, the distribution
documentation should be consulted to clarify the interpretation of
multiple licenses.

The following list of license strings are valid:

 string          description
 -------------   -----------------------------------------------
 agpl_3          GNU Affero General Public License, Version 3
 apache_1_1      Apache Software License, Version 1.1
 apache_2_0      Apache License, Version 2.0
 artistic_1      Artistic License, (Version 1)
 artistic_2      Artistic License, Version 2.0
 bsd             BSD License (three-clause)
 freebsd         FreeBSD License (two-clause)
 gfdl_1_2        GNU Free Documentation License, Version 1.2
 gfdl_1_3        GNU Free Documentation License, Version 1.3
 gpl_1           GNU General Public License, Version 1
 gpl_2           GNU General Public License, Version 2
 gpl_3           GNU General Public License, Version 3
 lgpl_2_1        GNU Lesser General Public License, Version 2.1
 lgpl_3_0        GNU Lesser General Public License, Version 3.0
 mit             MIT (aka X11) License
 mozilla_1_0     Mozilla Public License, Version 1.0
 mozilla_1_1     Mozilla Public License, Version 1.1
 openssl         OpenSSL License
 perl_5          The Perl 5 License (Artistic 1 & GPL 1 or later)
 qpl_1_0         Q Public License, Version 1.0
 ssleay          Original SSLeay License
 sun             Sun Internet Standards Source License (SISSL)
 zlib            zlib License

The following license strings are also valid and indicate other
licensing not described above:

 string          description
 -------------   -----------------------------------------------
 open_source     Other Open Source Initiative (OSI) approved license
 restricted      Requires special permission from copyright holder
 unrestricted    Not an OSI approved license, but not restricted
 unknown         License not provided in metadata

All other strings are invalid in the license field.

=head3 meta-spec

Example:

  'meta-spec' => {
    version => '2',
    url     => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
  }

(Spec 1.2) [required] {Map}

This field indicates the version of the CPAN Meta Spec that should be
used to interpret the metadata.  Consumers must check this key as soon
as possible and abort further metadata processing if the meta-spec
version is not supported by the consumer.

The following keys are valid, but only C<version> is required.

=over

=item version

This subkey gives the integer I<Version> of the CPAN Meta Spec against
which the document was generated.

=item url

This is a I<URL> of the metadata specification document corresponding to
the given version.  This is strictly for human-consumption and should
not impact the interpretation of the document.

For the version 2 spec, either of these are recommended:

=over 4

=item *

C<https://metacpan.org/pod/CPAN::Meta::Spec>

=item *

C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>

=back

=back

=head3 name

Example:

  name => 'Module-Build'

(Spec 1.0) [required] {String}

This field is the name of the distribution.  This is often created by
taking the "main package" in the distribution and changing C<::> to
C<->, but the name may be completely unrelated to the packages within
the distribution.  For example, L<LWP::UserAgent> is distributed as part
of the distribution name "libwww-perl".

=head3 release_status

Example:

  release_status => 'stable'

(Spec 2) [required] {String}

This field provides the  release status of this distribution.  If the
C<version> field contains an underscore character, then
C<release_status> B<must not> be "stable."

The C<release_status> field B<must> have one of the following values:

=over

=item stable

This indicates an ordinary, "final" release that should be indexed by PAUSE
or other indexers.

=item testing

This indicates a "beta" release that is substantially complete, but has an
elevated risk of bugs and requires additional testing.  The distribution
should not be installed over a stable release without an explicit request
or other confirmation from a user.  This release status may also be used
for "release candidate" versions of a distribution.

=item unstable

This indicates an "alpha" release that is under active development, but has
been released for early feedback or testing and may be missing features or
may have serious bugs.  The distribution should not be installed over a
stable release without an explicit request or other confirmation from a
user.

=back

Consumers B<may> use this field to determine how to index the
distribution for CPAN or other repositories in addition to or in
replacement of heuristics based on version number or file name.

=head3 version

Example:

  version => '0.36'

(Spec 1.0) [required] {Version}

This field gives the version of the distribution to which the metadata
structure refers.

=head2 OPTIONAL FIELDS

=head3 description

Example:

    description =>  "Module::Build is a system for "
      . "building, testing, and installing Perl modules. "
      . "It is meant to ... blah blah blah ...",

(Spec 2) [optional] {String}

A longer, more complete description of the purpose or intended use of
the distribution than the one provided by the C<abstract> key.

=head3 keywords

Example:

  keywords => [ qw/ toolchain cpan dual-life / ]

(Spec 1.1) [optional] {List of zero or more Strings}

A List of keywords that describe this distribution.  Keywords
B<must not> include whitespace.

=head3 no_index

Example:

  no_index => {
    file      => [ 'My/Module.pm' ],
    directory => [ 'My/Private' ],
    package   => [ 'My::Module::Secret' ],
    namespace => [ 'My::Module::Sample' ],
  }

(Spec 1.2) [optional] {Map}

This Map describes any files, directories, packages, and namespaces that
are private to the packaging or implementation of the distribution and
should be ignored by indexing or search tools. Note that this is a list of
exclusions, and the spec does not define what to I<include> - see
L</Indexing distributions a la PAUSE> in the implementors notes for more
information.

Valid subkeys are as follows:

=over

=item file

A I<List> of relative paths to files.  Paths B<must be> specified with
unix conventions.

=item directory

A I<List> of relative paths to directories.  Paths B<must be> specified
with unix conventions.

[ Note: previous editions of the spec had C<dir> instead of C<directory> ]

=item package

A I<List> of package names.

=item namespace

A I<List> of package namespaces, where anything below the namespace
must be ignored, but I<not> the namespace itself.

In the example above for C<no_index>, C<My::Module::Sample::Foo> would
be ignored, but C<My::Module::Sample> would not.

=back

=head3 optional_features

Example:

  optional_features => {
    sqlite => {
      description => 'Provides SQLite support',
      prereqs => {
        runtime => {
          requires => {
            'DBD::SQLite' => '1.25'
          }
        }
      }
    }
  }

(Spec 2) [optional] {Map}

This Map describes optional features with incremental prerequisites.
Each key of the C<optional_features> Map is a String used to identify
the feature and each value is a Map with additional information about
the feature.  Valid subkeys include:

=over

=item description

This is a String describing the feature.  Every optional feature
should provide a description

=item prereqs

This entry is required and has the same structure as that of the
C<L</prereqs>> key.  It provides a list of package requirements
that must be satisfied for the feature to be supported or enabled.

There is one crucial restriction:  the prereqs of an optional feature
B<must not> include C<configure> phase prereqs.

=back

Consumers B<must not> include optional features as prerequisites without
explicit instruction from users (whether via interactive prompting,
a function parameter or a configuration value, etc. ).

If an optional feature is used by a consumer to add additional
prerequisites, the consumer should merge the optional feature
prerequisites into those given by the C<prereqs> key using the same
semantics.  See L</Merging and Resolving Prerequisites> for details on
merging prerequisites.

I<Suggestion for disuse:> Because there is currently no way for a
distribution to specify a dependency on an optional feature of another
dependency, the use of C<optional_feature> is discouraged.  Instead,
create a separate, installable distribution that ensures the desired
feature is available.  For example, if C<Foo::Bar> has a C<Baz> feature,
release a separate C<Foo-Bar-Baz> distribution that satisfies
requirements for the feature.

=head3 prereqs

Example:

  prereqs => {
    runtime => {
      requires => {
        'perl'          => '5.006',
        'File::Spec'    => '0.86',
        'JSON'          => '2.16',
      },
      recommends => {
        'JSON::XS'      => '2.26',
      },
      suggests => {
        'Archive::Tar'  => '0',
      },
    },
    build => {
      requires => {
        'Alien::SDL'    => '1.00',
      },
    },
    test => {
      recommends => {
        'Test::Deep'    => '0.10',
      },
    }
  }

(Spec 2) [optional] {Map}

This is a Map that describes all the prerequisites of the distribution.
The keys are phases of activity, such as C<configure>, C<build>, C<test>
or C<runtime>.  Values are Maps in which the keys name the type of
prerequisite relationship such as C<requires>, C<recommends>, or
C<suggests> and the value provides a set of prerequisite relations.  The
set of relations B<must> be specified as a Map of package names to
version ranges.

The full definition for this field is given in the L</Prereq Spec>
section.

=head3 provides

Example:

  provides => {
    'Foo::Bar' => {
      file    => 'lib/Foo/Bar.pm',
      version => '0.27_02',
    },
    'Foo::Bar::Blah' => {
      file    => 'lib/Foo/Bar/Blah.pm',
    },
    'Foo::Bar::Baz' => {
      file    => 'lib/Foo/Bar/Baz.pm',
      version => '0.3',
    },
  }

(Spec 1.2) [optional] {Map}

This describes all packages provided by this distribution.  This
information is used by distribution and automation mechanisms like
PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in
which distribution various packages can be found.

The keys of C<provides> are package names that can be found within
the distribution.  If a package name key is provided, it must
have a Map with the following valid subkeys:

=over

=item file

This field is required.  It must contain a Unix-style relative file path
from the root of the distribution directory to a file that contains or
generates the package.  It may be given as C<META.yml> or C<META.json>
to claim a package for indexing without needing a C<*.pm>.

=item version

If it exists, this field must contains a I<Version> String for the
package.  If the package does not have a C<$VERSION>, this field must
be omitted.

=back

=head3 resources

Example:

  resources => {
    license     => [ 'http://dev.perl.org/licenses/' ],
    homepage    => 'http://sourceforge.net/projects/module-build',
    bugtracker  => {
      web    => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta',
      mailto => 'meta-bugs@example.com',
    },
    repository  => {
      url  => 'git://github.com/dagolden/cpan-meta.git',
      web  => 'http://github.com/dagolden/cpan-meta',
      type => 'git',
    },
    x_twitter   => 'http://twitter.com/cpan_linked/',
  }

(Spec 2) [optional] {Map}

This field describes resources related to this distribution.

Valid subkeys include:

=over

=item homepage

The official home of this project on the web.

=item license

A List of I<URL>'s that relate to this distribution's license.  As with the
top-level C<license> field, distribution documentation should be consulted
to clarify the interpretation of multiple licenses provided here.

=item bugtracker

This entry describes the bug tracking system for this distribution.  It
is a Map with the following valid keys:

  web    - a URL pointing to a web front-end for the bug tracker
  mailto - an email address to which bugs can be sent

=item repository

This entry describes the source control repository for this distribution.  It
is a Map with the following valid keys:

  url  - a URL pointing to the repository itself
  web  - a URL pointing to a web front-end for the repository
  type - a lowercase string indicating the VCS used

Because a url like C<http://myrepo.example.com/> is ambiguous as to
type, producers should provide a C<type> whenever a C<url> key is given.
The C<type> field should be the name of the most common program used
to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
C<bzr> or C<hg>.

=back

=head2 DEPRECATED FIELDS

=head3 build_requires

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 configure_requires

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 conflicts

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 distribution_type

I<(Deprecated in Spec 2)> [optional] {String}

This field indicated 'module' or 'script' but was considered
meaningless, since many distributions are hybrids of several kinds of
things.

=head3 license_uri

I<(Deprecated in Spec 1.2)> [optional] {URL}

Replaced by C<license> in C<resources>

=head3 private

I<(Deprecated in Spec 1.2)> [optional] {Map}

This field has been renamed to L</"no_index">.

=head3 recommends

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head3 requires

I<(Deprecated in Spec 2)> [optional] {String}

Replaced by C<prereqs>

=head1 VERSION NUMBERS

=head2 Version Formats

This section defines the Version type, used by several fields in the
CPAN Meta Spec.

Version numbers must be treated as strings, not numbers.  For
example, C<1.200> B<must not> be serialized as C<1.2>.  Version
comparison should be delegated to the Perl L<version> module, version
0.80 or newer.

Unless otherwise specified, version numbers B<must> appear in one of two
formats:

=over

=item Decimal versions

Decimal versions are regular "decimal numbers", with some limitations.
They B<must> be non-negative and B<must> begin and end with a digit.  A
single underscore B<may> be included, but B<must> be between two digits.
They B<must not> use exponential notation ("1.23e-2").

   version => '1.234'       # OK
   version => '1.23_04'     # OK

   version => '1.23_04_05'  # Illegal
   version => '1.'          # Illegal
   version => '.1'          # Illegal

=item Dotted-integer versions

Dotted-integer (also known as dotted-decimal) versions consist of
positive integers separated by full stop characters (i.e. "dots",
"periods" or "decimal points").  This are equivalent in format to Perl
"v-strings", with some additional restrictions on form.  They must be
given in "normal" form, which has a leading "v" character and at least
three integer components.  To retain a one-to-one mapping with decimal
versions, all components after the first B<should> be restricted to the
range 0 to 999.  The final component B<may> be separated by an
underscore character instead of a period.

   version => 'v1.2.3'      # OK
   version => 'v1.2_3'      # OK
   version => 'v1.2.3.4'    # OK
   version => 'v1.2.3_4'    # OK
   version => 'v2009.10.31' # OK

   version => 'v1.2'          # Illegal
   version => '1.2.3'         # Illegal
   version => 'v1.2_3_4'      # Illegal
   version => 'v1.2009.10.31' # Not recommended

=back

=head2 Version Ranges

Some fields (prereq, optional_features) indicate the particular
version(s) of some other module that may be required as a prerequisite.
This section details the Version Range type used to provide this
information.

The simplest format for a Version Range is just the version
number itself, e.g. C<2.4>.  This means that B<at least> version 2.4
must be present.  To indicate that B<any> version of a prerequisite is
okay, even if the prerequisite doesn't define a version at all, use
the version C<0>.

Alternatively, a version range B<may> use the operators E<lt> (less than),
E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
or equal), == (equal), and != (not equal).  For example, the
specification C<E<lt> 2.0> means that any version of the prerequisite
less than 2.0 is suitable.

For more complicated situations, version specifications B<may> be AND-ed
together using commas.  The specification C<E<gt>= 1.2, != 1.5, E<lt>
2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
and B<not equal to> 1.5.

=head1 PREREQUISITES

=head2 Prereq Spec

The C<prereqs> key in the top-level metadata and within
C<optional_features> define the relationship between a distribution and
other packages.  The prereq spec structure is a hierarchical data
structure which divides prerequisites into I<Phases> of activity in the
installation process and I<Relationships> that indicate how
prerequisites should be resolved.

For example, to specify that C<Data::Dumper> is C<required> during the
C<test> phase, this entry would appear in the distribution metadata:

  prereqs => {
    test => {
      requires => {
        'Data::Dumper' => '2.00'
      }
    }
  }

=head3 Phases

Requirements for regular use must be listed in the C<runtime> phase.
Other requirements should be listed in the earliest stage in which they
are required and consumers must accumulate and satisfy requirements
across phases before executing the activity. For example, C<build>
requirements must also be available during the C<test> phase.

  before action       requirements that must be met
  ----------------    --------------------------------
  perl Build.PL       configure
  perl Makefile.PL

  make                configure, runtime, build
  Build

  make test           configure, runtime, build, test
  Build test

Consumers that install the distribution must ensure that
I<runtime> requirements are also installed and may install
dependencies from other phases.

  after action        requirements that must be met
  ----------------    --------------------------------
  make install        runtime
  Build install

=over

=item configure

The configure phase occurs before any dynamic configuration has been
attempted.  Libraries required by the configure phase B<must> be
available for use before the distribution building tool has been
executed.

=item build

The build phase is when the distribution's source code is compiled (if
necessary) and otherwise made ready for installation.

=item test

The test phase is when the distribution's automated test suite is run.
Any library that is needed only for testing and not for subsequent use
should be listed here.

=item runtime

The runtime phase refers not only to when the distribution's contents
are installed, but also to its continued use.  Any library that is a
prerequisite for regular use of this distribution should be indicated
here.

=item develop

The develop phase's prereqs are libraries needed to work on the
distribution's source code as its author does.  These tools might be
needed to build a release tarball, to run author-only tests, or to
perform other tasks related to developing new versions of the
distribution.

=back

=head3 Relationships

=over

=item requires

These dependencies B<must> be installed for proper completion of the
phase.

=item recommends

Recommended dependencies are I<strongly> encouraged and should be
satisfied except in resource constrained environments.

=item suggests

These dependencies are optional, but are suggested for enhanced operation
of the described distribution.

=item conflicts

These libraries cannot be installed when the phase is in operation.
This is a very rare situation, and the C<conflicts> relationship should
be used with great caution, or not at all.

=back

=head2 Merging and Resolving Prerequisites

Whenever metadata consumers merge prerequisites, either from different
phases or from C<optional_features>, they should merged in a way which
preserves the intended semantics of the prerequisite structure.  Generally,
this means concatenating the version specifications using commas, as
described in the L<Version Ranges> section.

Another subtle error that can occur in resolving prerequisites comes from
the way that modules in prerequisites are indexed to distribution files on
CPAN.  When a module is deleted from a distribution, prerequisites calling
for that module could indicate an older distribution should be installed,
potentially overwriting files from a newer distribution.

For example, as of Oct 31, 2009, the CPAN index file contained these
module-distribution mappings:

  Class::MOP                   0.94  D/DR/DROLSKY/Class-MOP-0.94.tar.gz
  Class::MOP::Class            0.94  D/DR/DROLSKY/Class-MOP-0.94.tar.gz
  Class::MOP::Class::Immutable 0.04  S/ST/STEVAN/Class-MOP-0.36.tar.gz

Consider the case where "Class::MOP" 0.94 is installed.  If a
distribution specified "Class::MOP::Class::Immutable" as a prerequisite,
it could result in Class-MOP-0.36.tar.gz being installed, overwriting
any files from Class-MOP-0.94.tar.gz.

Consumers of metadata B<should> test whether prerequisites would result
in installed module files being "downgraded" to an older version and
B<may> warn users or ignore the prerequisite that would cause such a
result.

=head1 SERIALIZATION

Distribution metadata should be serialized (as a hashref) as
JSON-encoded data and packaged with distributions as the file
F<META.json>.

In the past, the distribution metadata structure had been packed with
distributions as F<META.yml>, a file in the YAML Tiny format (for which,
see L<YAML::Tiny>).  Tools that consume distribution metadata from disk
should be capable of loading F<META.yml>, but should prefer F<META.json>
if both are found.

=head1 NOTES FOR IMPLEMENTORS

=head2 Extracting Version Numbers from Perl Modules

To get the version number from a Perl module, consumers should use the
C<< MM->parse_version($file) >> method provided by
L<ExtUtils::MakeMaker> or L<Module::Metadata>.  For example, for the
module given by C<$mod>, the version may be retrieved in one of the
following ways:

  # via ExtUtils::MakeMaker
  my $file = MM->_installed_file_for_module($mod);
  my $version = MM->parse_version($file)

The private C<_installed_file_for_module> method may be replaced with
other methods for locating a module in C<@INC>.

  # via Module::Metadata
  my $info = Module::Metadata->new_from_module($mod);
  my $version = $info->version;

If only a filename is available, the following approach may be used:

  # via Module::Build
  my $info = Module::Metadata->new_from_file($file);
  my $version = $info->version;

=head2 Comparing Version Numbers

The L<version> module provides the most reliable way to compare version
numbers in all the various ways they might be provided or might exist
within modules.  Given two strings containing version numbers, C<$v1> and
C<$v2>, they should be converted to C<version> objects before using
ordinary comparison operators.  For example:

  use version;
  if ( version->new($v1) <=> version->new($v2) ) {
    print "Versions are not equal\n";
  }

If the only comparison needed is whether an installed module is of a
sufficiently high version, a direct test may be done using the string
form of C<eval> and the C<use> function.  For example, for module C<$mod>
and version prerequisite C<$prereq>:

  if ( eval "use $mod $prereq (); 1" ) {
    print "Module $mod version is OK.\n";
  }

If the values of C<$mod> and C<$prereq> have not been scrubbed, however,
this presents security implications.

=head2 Prerequisites for dynamically configured distributions

When C<dynamic_config> is true, it is an error to presume that the
prerequisites given in distribution metadata will have any relationship
whatsoever to the actual prerequisites of the distribution.

In practice, however, one can generally expect such prerequisites to be
one of two things:

=over 4

=item *

The minimum prerequisites for the distribution, to which dynamic configuration will only add items

=item *

Whatever the distribution configured with on the releaser's machine at release time

=back

The second case often turns out to have identical results to the first case,
albeit only by accident.

As such, consumers may use this data for informational analysis, but
presenting it to the user as canonical or relying on it as such is
invariably the height of folly.

=head2 Indexing distributions a la PAUSE

While no_index tells you what must be ignored when indexing, this spec holds
no opinion on how you should get your initial candidate list of things to
possibly index. For "normal" distributions you might consider simply indexing
the contents of lib/, but there are many fascinating oddities on CPAN and
many dists from the days when it was normal to put the main .pm file in the
root of the distribution archive - so PAUSE currently indexes all .pm and .PL
files that are not either (a) specifically excluded by no_index (b) in
C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
C<perl5>.

Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
C<t> as well as anything marked as no_index.

Also remember: If the META file contains a provides field, you shouldn't be
indexing anything in the first place - just use that.

=head1 SEE ALSO

=over 4

=item *

CPAN, L<http://www.cpan.org/>

=item *

JSON, L<http://json.org/>

=item *

YAML, L<http://www.yaml.org/>

=item *

L<CPAN>

=item *

L<CPANPLUS>

=item *

L<ExtUtils::MakeMaker>

=item *

L<Module::Build>

=item *

L<Module::Install>

=item *

L<CPAN::Meta::History::Meta_1_4>

=back

=head1 HISTORY

Ken Williams wrote the original CPAN Meta Spec (also known as the
"META.yml spec") in 2003 and maintained it through several revisions
with input from various members of the community.  In 2005, Randy
Sims redrafted it from HTML to POD for the version 1.2 release.  Ken
continued to maintain the spec through version 1.4.

In late 2009, David Golden organized the version 2 proposal review
process.  David and Ricardo Signes drafted the final version 2 spec
in April 2010 based on the version 1.4 spec and patches contributed
during the proposal process.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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
PK     ü2]ÓTòˆ„  ˆ„    Meta/Validator.pmnu „[µü¤        use 5.006;
use strict;
use warnings;
package CPAN::Meta::Validator;

our $VERSION = '2.150010';

#pod =head1 SYNOPSIS
#pod
#pod   my $struct = decode_json_file('META.json');
#pod
#pod   my $cmv = CPAN::Meta::Validator->new( $struct );
#pod
#pod   unless ( $cmv->is_valid ) {
#pod     my $msg = "Invalid META structure.  Errors found:\n";
#pod     $msg .= join( "\n", $cmv->errors );
#pod     die $msg;
#pod   }
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module validates a CPAN Meta structure against the version of the
#pod the specification claimed in the C<meta-spec> field of the structure.
#pod
#pod =cut

#--------------------------------------------------------------------------#
# This code copied and adapted from Test::CPAN::Meta
# by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
# L<http://www.missbarbell.co.uk>
#--------------------------------------------------------------------------#

#--------------------------------------------------------------------------#
# Specification Definitions
#--------------------------------------------------------------------------#

my %known_specs = (
    '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
    '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
    '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
    '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
    '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;

my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };

my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version   } } };

my $no_index_2 = {
    'map'       => { file       => { list => { value => \&string } },
                     directory  => { list => { value => \&string } },
                     'package'  => { list => { value => \&string } },
                     namespace  => { list => { value => \&string } },
                    ':key'      => { name => \&custom_2, value => \&anything },
    }
};

my $no_index_1_3 = {
    'map'       => { file       => { list => { value => \&string } },
                     directory  => { list => { value => \&string } },
                     'package'  => { list => { value => \&string } },
                     namespace  => { list => { value => \&string } },
                     ':key'     => { name => \&string, value => \&anything },
    }
};

my $no_index_1_2 = {
    'map'       => { file       => { list => { value => \&string } },
                     dir        => { list => { value => \&string } },
                     'package'  => { list => { value => \&string } },
                     namespace  => { list => { value => \&string } },
                     ':key'     => { name => \&string, value => \&anything },
    }
};

my $no_index_1_1 = {
    'map'       => { ':key'     => { name => \&string, list => { value => \&string } },
    }
};

my $prereq_map = {
  map => {
    ':key' => {
      name => \&phase,
      'map' => {
        ':key'  => {
          name => \&relation,
          %$module_map1,
        },
      },
    }
  },
};

my %definitions = (
  '2' => {
    # REQUIRED
    'abstract'            => { mandatory => 1, value => \&string  },
    'author'              => { mandatory => 1, list => { value => \&string } },
    'dynamic_config'      => { mandatory => 1, value => \&boolean },
    'generated_by'        => { mandatory => 1, value => \&string  },
    'license'             => { mandatory => 1, list => { value => \&license } },
    'meta-spec' => {
      mandatory => 1,
      'map' => {
        version => { mandatory => 1, value => \&version},
        url     => { value => \&url },
        ':key' => { name => \&custom_2, value => \&anything },
      }
    },
    'name'                => { mandatory => 1, value => \&string  },
    'release_status'      => { mandatory => 1, value => \&release_status },
    'version'             => { mandatory => 1, value => \&version },

    # OPTIONAL
    'description' => { value => \&string },
    'keywords'    => { list => { value => \&string } },
    'no_index'    => $no_index_2,
    'optional_features'   => {
      'map'       => {
        ':key'  => {
          name => \&string,
          'map'   => {
            description        => { value => \&string },
            prereqs => $prereq_map,
            ':key' => { name => \&custom_2, value => \&anything },
          }
        }
      }
    },
    'prereqs' => $prereq_map,
    'provides'    => {
      'map'       => {
        ':key' => {
          name  => \&module,
          'map' => {
            file    => { mandatory => 1, value => \&file },
            version => { value => \&version },
            ':key' => { name => \&custom_2, value => \&anything },
          }
        }
      }
    },
    'resources'   => {
      'map'       => {
        license    => { list => { value => \&url } },
        homepage   => { value => \&url },
        bugtracker => {
          'map' => {
            web => { value => \&url },
            mailto => { value => \&string},
            ':key' => { name => \&custom_2, value => \&anything },
          }
        },
        repository => {
          'map' => {
            web => { value => \&url },
            url => { value => \&url },
            type => { value => \&string },
            ':key' => { name => \&custom_2, value => \&anything },
          }
        },
        ':key'     => { value => \&string, name => \&custom_2 },
      }
    },

    # CUSTOM -- additional user defined key/value pairs
    # note we can only validate the key name, as the structure is user defined
    ':key'        => { name => \&custom_2, value => \&anything },
  },

'1.4' => {
  'meta-spec'           => {
    mandatory => 1,
    'map' => {
      version => { mandatory => 1, value => \&version},
      url     => { mandatory => 1, value => \&urlspec },
      ':key'  => { name => \&string, value => \&anything },
    },
  },

  'name'                => { mandatory => 1, value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'abstract'            => { mandatory => 1, value => \&string  },
  'author'              => { mandatory => 1, list  => { value => \&string } },
  'license'             => { mandatory => 1, value => \&license },
  'generated_by'        => { mandatory => 1, value => \&string  },

  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'configure_requires'  => $module_map1,
  'conflicts'           => $module_map2,

  'optional_features'   => {
    'map'       => {
        ':key'  => { name => \&string,
            'map'   => { description        => { value => \&string },
                         requires           => $module_map1,
                         recommends         => $module_map1,
                         build_requires     => $module_map1,
                         conflicts          => $module_map2,
                         ':key'  => { name => \&string, value => \&anything },
            }
        }
     }
  },

  'provides'    => {
    'map'       => {
      ':key' => { name  => \&module,
        'map' => {
          file    => { mandatory => 1, value => \&file },
          version => { value => \&version },
          ':key'  => { name => \&string, value => \&anything },
        }
      }
    }
  },

  'no_index'    => $no_index_1_3,
  'private'     => $no_index_1_3,

  'keywords'    => { list => { value => \&string } },

  'resources'   => {
    'map'       => { license    => { value => \&url },
                     homepage   => { value => \&url },
                     bugtracker => { value => \&url },
                     repository => { value => \&url },
                     ':key'     => { value => \&string, name => \&custom_1 },
    }
  },

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

'1.3' => {
  'meta-spec'           => {
    mandatory => 1,
    'map' => {
      version => { mandatory => 1, value => \&version},
      url     => { mandatory => 1, value => \&urlspec },
      ':key'  => { name => \&string, value => \&anything },
    },
  },

  'name'                => { mandatory => 1, value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'abstract'            => { mandatory => 1, value => \&string  },
  'author'              => { mandatory => 1, list  => { value => \&string } },
  'license'             => { mandatory => 1, value => \&license },
  'generated_by'        => { mandatory => 1, value => \&string  },

  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  'optional_features'   => {
    'map'       => {
        ':key'  => { name => \&string,
            'map'   => { description        => { value => \&string },
                         requires           => $module_map1,
                         recommends         => $module_map1,
                         build_requires     => $module_map1,
                         conflicts          => $module_map2,
                         ':key'  => { name => \&string, value => \&anything },
            }
        }
     }
  },

  'provides'    => {
    'map'       => {
      ':key' => { name  => \&module,
        'map' => {
          file    => { mandatory => 1, value => \&file },
          version => { value => \&version },
          ':key'  => { name => \&string, value => \&anything },
        }
      }
    }
  },


  'no_index'    => $no_index_1_3,
  'private'     => $no_index_1_3,

  'keywords'    => { list => { value => \&string } },

  'resources'   => {
    'map'       => { license    => { value => \&url },
                     homepage   => { value => \&url },
                     bugtracker => { value => \&url },
                     repository => { value => \&url },
                     ':key'     => { value => \&string, name => \&custom_1 },
    }
  },

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

# v1.2 is misleading, it seems to assume that a number of fields where created
# within v1.1, when they were created within v1.2. This may have been an
# original mistake, and that a v1.1 was retro fitted into the timeline, when
# v1.2 was originally slated as v1.1. But I could be wrong ;)
'1.2' => {
  'meta-spec'           => {
    mandatory => 1,
    'map' => {
      version => { mandatory => 1, value => \&version},
      url     => { mandatory => 1, value => \&urlspec },
      ':key'  => { name => \&string, value => \&anything },
    },
  },


  'name'                => { mandatory => 1, value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'license'             => { mandatory => 1, value => \&license },
  'generated_by'        => { mandatory => 1, value => \&string  },
  'author'              => { mandatory => 1, list => { value => \&string } },
  'abstract'            => { mandatory => 1, value => \&string  },

  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'keywords'            => { list => { value => \&string } },

  'private'             => $no_index_1_2,
  '$no_index'           => $no_index_1_2,

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  'optional_features'   => {
    'map'       => {
        ':key'  => { name => \&string,
            'map'   => { description        => { value => \&string },
                         requires           => $module_map1,
                         recommends         => $module_map1,
                         build_requires     => $module_map1,
                         conflicts          => $module_map2,
                         ':key'  => { name => \&string, value => \&anything },
            }
        }
     }
  },

  'provides'    => {
    'map'       => {
      ':key' => { name  => \&module,
        'map' => {
          file    => { mandatory => 1, value => \&file },
          version => { value => \&version },
          ':key'  => { name => \&string, value => \&anything },
        }
      }
    }
  },

  'resources'   => {
    'map'       => { license    => { value => \&url },
                     homepage   => { value => \&url },
                     bugtracker => { value => \&url },
                     repository => { value => \&url },
                     ':key'     => { value => \&string, name => \&custom_1 },
    }
  },

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

# note that the 1.1 spec only specifies 'version' as mandatory
'1.1' => {
  'name'                => { value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'license'             => { value => \&license },
  'generated_by'        => { value => \&string  },

  'license_uri'         => { value => \&url },
  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'private'             => $no_index_1_1,

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},

# note that the 1.0 spec doesn't specify optional or mandatory fields
# but we will treat version as mandatory since otherwise META 1.0 is
# completely arbitrary and pointless
'1.0' => {
  'name'                => { value => \&string  },
  'version'             => { mandatory => 1, value => \&version },
  'license'             => { value => \&license },
  'generated_by'        => { value => \&string  },

  'license_uri'         => { value => \&url },
  'distribution_type'   => { value => \&string  },
  'dynamic_config'      => { value => \&boolean },

  'requires'            => $module_map1,
  'recommends'          => $module_map1,
  'build_requires'      => $module_map1,
  'conflicts'           => $module_map2,

  # additional user defined key/value pairs
  # note we can only validate the key name, as the structure is user defined
  ':key'        => { name => \&string, value => \&anything },
},
);

#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#

#pod =method new
#pod
#pod   my $cmv = CPAN::Meta::Validator->new( $struct )
#pod
#pod The constructor must be passed a metadata structure.
#pod
#pod =cut

sub new {
  my ($class,$data) = @_;

  # create an attributes hash
  my $self = {
    'data'    => $data,
    'spec'    => eval { $data->{'meta-spec'}{'version'} } || "1.0",
    'errors'  => undef,
  };

  # create the object
  return bless $self, $class;
}

#pod =method is_valid
#pod
#pod   if ( $cmv->is_valid ) {
#pod     ...
#pod   }
#pod
#pod Returns a boolean value indicating whether the metadata provided
#pod is valid.
#pod
#pod =cut

sub is_valid {
    my $self = shift;
    my $data = $self->{data};
    my $spec_version = $self->{spec};
    $self->check_map($definitions{$spec_version},$data);
    return ! $self->errors;
}

#pod =method errors
#pod
#pod   warn( join "\n", $cmv->errors );
#pod
#pod Returns a list of errors seen during validation.
#pod
#pod =cut

sub errors {
    my $self = shift;
    return ()   unless(defined $self->{errors});
    return @{$self->{errors}};
}

#pod =begin :internals
#pod
#pod =head2 Check Methods
#pod
#pod =over
#pod
#pod =item *
#pod
#pod check_map($spec,$data)
#pod
#pod Checks whether a map (or hash) part of the data structure conforms to the
#pod appropriate specification definition.
#pod
#pod =item *
#pod
#pod check_list($spec,$data)
#pod
#pod Checks whether a list (or array) part of the data structure conforms to
#pod the appropriate specification definition.
#pod
#pod =item *
#pod
#pod =back
#pod
#pod =cut

my $spec_error = "Missing validation action in specification. "
  . "Must be one of 'map', 'list', or 'value'";

sub check_map {
    my ($self,$spec,$data) = @_;

    if(ref($spec) ne 'HASH') {
        $self->_error( "Unknown META specification, cannot validate." );
        return;
    }

    if(ref($data) ne 'HASH') {
        $self->_error( "Expected a map structure from string or file." );
        return;
    }

    for my $key (keys %$spec) {
        next    unless($spec->{$key}->{mandatory});
        next    if(defined $data->{$key});
        push @{$self->{stack}}, $key;
        $self->_error( "Missing mandatory field, '$key'" );
        pop @{$self->{stack}};
    }

    for my $key (keys %$data) {
        push @{$self->{stack}}, $key;
        if($spec->{$key}) {
            if($spec->{$key}{value}) {
                $spec->{$key}{value}->($self,$key,$data->{$key});
            } elsif($spec->{$key}{'map'}) {
                $self->check_map($spec->{$key}{'map'},$data->{$key});
            } elsif($spec->{$key}{'list'}) {
                $self->check_list($spec->{$key}{'list'},$data->{$key});
            } else {
                $self->_error( "$spec_error for '$key'" );
            }

        } elsif ($spec->{':key'}) {
            $spec->{':key'}{name}->($self,$key,$key);
            if($spec->{':key'}{value}) {
                $spec->{':key'}{value}->($self,$key,$data->{$key});
            } elsif($spec->{':key'}{'map'}) {
                $self->check_map($spec->{':key'}{'map'},$data->{$key});
            } elsif($spec->{':key'}{'list'}) {
                $self->check_list($spec->{':key'}{'list'},$data->{$key});
            } else {
                $self->_error( "$spec_error for ':key'" );
            }


        } else {
            $self->_error( "Unknown key, '$key', found in map structure" );
        }
        pop @{$self->{stack}};
    }
}

sub check_list {
    my ($self,$spec,$data) = @_;

    if(ref($data) ne 'ARRAY') {
        $self->_error( "Expected a list structure" );
        return;
    }

    if(defined $spec->{mandatory}) {
        if(!defined $data->[0]) {
            $self->_error( "Missing entries from mandatory list" );
        }
    }

    for my $value (@$data) {
        push @{$self->{stack}}, $value || "<undef>";
        if(defined $spec->{value}) {
            $spec->{value}->($self,'list',$value);
        } elsif(defined $spec->{'map'}) {
            $self->check_map($spec->{'map'},$value);
        } elsif(defined $spec->{'list'}) {
            $self->check_list($spec->{'list'},$value);
        } elsif ($spec->{':key'}) {
            $self->check_map($spec,$value);
        } else {
          $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
        }
        pop @{$self->{stack}};
    }
}

#pod =head2 Validator Methods
#pod
#pod =over
#pod
#pod =item *
#pod
#pod header($self,$key,$value)
#pod
#pod Validates that the header is valid.
#pod
#pod Note: No longer used as we now read the data structure, not the file.
#pod
#pod =item *
#pod
#pod url($self,$key,$value)
#pod
#pod Validates that a given value is in an acceptable URL format
#pod
#pod =item *
#pod
#pod urlspec($self,$key,$value)
#pod
#pod Validates that the URL to a META specification is a known one.
#pod
#pod =item *
#pod
#pod string_or_undef($self,$key,$value)
#pod
#pod Validates that the value is either a string or an undef value. Bit of a
#pod catchall function for parts of the data structure that are completely user
#pod defined.
#pod
#pod =item *
#pod
#pod string($self,$key,$value)
#pod
#pod Validates that a string exists for the given key.
#pod
#pod =item *
#pod
#pod file($self,$key,$value)
#pod
#pod Validate that a file is passed for the given key. This may be made more
#pod thorough in the future. For now it acts like \&string.
#pod
#pod =item *
#pod
#pod exversion($self,$key,$value)
#pod
#pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.
#pod
#pod =item *
#pod
#pod version($self,$key,$value)
#pod
#pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
#pod are both valid. A leading 'v' like 'v1.2.3' is also valid.
#pod
#pod =item *
#pod
#pod boolean($self,$key,$value)
#pod
#pod Validates for a boolean value: a defined value that is either "1" or "0" or
#pod stringifies to those values.
#pod
#pod =item *
#pod
#pod license($self,$key,$value)
#pod
#pod Validates that a value is given for the license. Returns 1 if an known license
#pod type, or 2 if a value is given but the license type is not a recommended one.
#pod
#pod =item *
#pod
#pod custom_1($self,$key,$value)
#pod
#pod Validates that the given key is in CamelCase, to indicate a user defined
#pod keyword and only has characters in the class [-_a-zA-Z].  In version 1.X
#pod of the spec, this was only explicitly stated for 'resources'.
#pod
#pod =item *
#pod
#pod custom_2($self,$key,$value)
#pod
#pod Validates that the given key begins with 'x_' or 'X_', to indicate a user
#pod defined keyword and only has characters in the class [-_a-zA-Z]
#pod
#pod =item *
#pod
#pod identifier($self,$key,$value)
#pod
#pod Validates that key is in an acceptable format for the META specification,
#pod for an identifier, i.e. any that matches the regular expression
#pod qr/[a-z][a-z_]/i.
#pod
#pod =item *
#pod
#pod module($self,$key,$value)
#pod
#pod Validates that a given key is in an acceptable module name format, e.g.
#pod 'Test::CPAN::Meta::Version'.
#pod
#pod =back
#pod
#pod =end :internals
#pod
#pod =cut

sub header {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value && $value =~ /^--- #YAML:1.0/);
    }
    $self->_error( "file does not have a valid YAML header." );
    return 0;
}

sub release_status {
  my ($self,$key,$value) = @_;
  if(defined $value) {
    my $version = $self->{data}{version} || '';
    if ( $version =~ /_/ ) {
      return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
      $self->_error( "'$value' for '$key' is invalid for version '$version'" );
    }
    else {
      return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
      $self->_error( "'$value' for '$key' is invalid" );
    }
  }
  else {
    $self->_error( "'$key' is not defined" );
  }
  return 0;
}

# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
sub _uri_split {
     return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
}

sub url {
    my ($self,$key,$value) = @_;
    if(defined $value) {
      my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
      unless ( defined $scheme && length $scheme ) {
        $self->_error( "'$value' for '$key' does not have a URL scheme" );
        return 0;
      }
      unless ( defined $auth && length $auth ) {
        $self->_error( "'$value' for '$key' does not have a URL authority" );
        return 0;
      }
      return 1;
    }
    $value ||= '';
    $self->_error( "'$value' for '$key' is not a valid URL." );
    return 0;
}

sub urlspec {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value && $known_specs{$self->{spec}} eq $value);
        if($value && $known_urls{$value}) {
            $self->_error( 'META specification URL does not match version' );
            return 0;
        }
    }
    $self->_error( 'Unknown META specification' );
    return 0;
}

sub anything { return 1 }

sub string {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value || $value =~ /^0$/);
    }
    $self->_error( "value is an undefined string" );
    return 0;
}

sub string_or_undef {
    my ($self,$key,$value) = @_;
    return 1    unless(defined $value);
    return 1    if($value || $value =~ /^0$/);
    $self->_error( "No string defined for '$key'" );
    return 0;
}

sub file {
    my ($self,$key,$value) = @_;
    return 1    if(defined $value);
    $self->_error( "No file defined for '$key'" );
    return 0;
}

sub exversion {
    my ($self,$key,$value) = @_;
    if(defined $value && ($value || $value =~ /0/)) {
        my $pass = 1;
        for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
        return $pass;
    }
    $value = '<undef>'  unless(defined $value);
    $self->_error( "'$value' for '$key' is not a valid version." );
    return 0;
}

sub version {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 0    unless($value || $value =~ /0/);
        return 1    if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
    } else {
        $value = '<undef>';
    }
    $self->_error( "'$value' for '$key' is not a valid version." );
    return 0;
}

sub boolean {
    my ($self,$key,$value) = @_;
    if(defined $value) {
        return 1    if($value =~ /^(0|1)$/);
    } else {
        $value = '<undef>';
    }
    $self->_error( "'$value' for '$key' is not a boolean value." );
    return 0;
}

my %v1_licenses = (
    'perl'         => 'http://dev.perl.org/licenses/',
    'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
    'apache'       => 'http://apache.org/licenses/LICENSE-2.0',
    'artistic'     => 'http://opensource.org/licenses/artistic-license.php',
    'artistic_2'   => 'http://opensource.org/licenses/artistic-license-2.0.php',
    'lgpl'         => 'http://www.opensource.org/licenses/lgpl-license.php',
    'bsd'          => 'http://www.opensource.org/licenses/bsd-license.php',
    'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
    'mit'          => 'http://opensource.org/licenses/mit-license.php',
    'mozilla'      => 'http://opensource.org/licenses/mozilla1.1.php',
    'open_source'  => undef,
    'unrestricted' => undef,
    'restrictive'  => undef,
    'unknown'      => undef,
);

my %v2_licenses = map { $_ => 1 } qw(
  agpl_3
  apache_1_1
  apache_2_0
  artistic_1
  artistic_2
  bsd
  freebsd
  gfdl_1_2
  gfdl_1_3
  gpl_1
  gpl_2
  gpl_3
  lgpl_2_1
  lgpl_3_0
  mit
  mozilla_1_0
  mozilla_1_1
  openssl
  perl_5
  qpl_1_0
  ssleay
  sun
  zlib
  open_source
  restricted
  unrestricted
  unknown
);

sub license {
    my ($self,$key,$value) = @_;
    my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
    if(defined $value) {
        return 1    if($value && exists $licenses->{$value});
    } else {
        $value = '<undef>';
    }
    $self->_error( "License '$value' is invalid" );
    return 0;
}

sub custom_1 {
    my ($self,$key) = @_;
    if(defined $key) {
        # a valid user defined key should be alphabetic
        # and contain at least one capital case letter.
        return 1    if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
    } else {
        $key = '<undef>';
    }
    $self->_error( "Custom resource '$key' must be in CamelCase." );
    return 0;
}

sub custom_2 {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1    if($key && $key =~ /^x_/i);  # user defined
    } else {
        $key = '<undef>';
    }
    $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
    return 0;
}

sub identifier {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1    if($key && $key =~ /^([a-z][_a-z]+)$/i);    # spec 2.0 defined
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal identifier." );
    return 0;
}

sub module {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1    if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal module name." );
    return 0;
}

my @valid_phases = qw/ configure build test runtime develop /;
sub phase {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1 if( length $key && grep { $key eq $_ } @valid_phases );
        return 1 if $key =~ /x_/i;
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal phase." );
    return 0;
}

my @valid_relations = qw/ requires recommends suggests conflicts /;
sub relation {
    my ($self,$key) = @_;
    if(defined $key) {
        return 1 if( length $key && grep { $key eq $_ } @valid_relations );
        return 1 if $key =~ /x_/i;
    } else {
        $key = '<undef>';
    }
    $self->_error( "Key '$key' is not a legal prereq relationship." );
    return 0;
}

sub _error {
    my $self = shift;
    my $mess = shift;

    $mess .= ' ('.join(' -> ',@{$self->{stack}}).')'  if($self->{stack});
    $mess .= " [Validation: $self->{spec}]";

    push @{$self->{errors}}, $mess;
}

1;

# ABSTRACT: validate CPAN distribution metadata structures

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Validator - validate CPAN distribution metadata structures

=head1 VERSION

version 2.150010

=head1 SYNOPSIS

  my $struct = decode_json_file('META.json');

  my $cmv = CPAN::Meta::Validator->new( $struct );

  unless ( $cmv->is_valid ) {
    my $msg = "Invalid META structure.  Errors found:\n";
    $msg .= join( "\n", $cmv->errors );
    die $msg;
  }

=head1 DESCRIPTION

This module validates a CPAN Meta structure against the version of the
the specification claimed in the C<meta-spec> field of the structure.

=head1 METHODS

=head2 new

  my $cmv = CPAN::Meta::Validator->new( $struct )

The constructor must be passed a metadata structure.

=head2 is_valid

  if ( $cmv->is_valid ) {
    ...
  }

Returns a boolean value indicating whether the metadata provided
is valid.

=head2 errors

  warn( join "\n", $cmv->errors );

Returns a list of errors seen during validation.

=begin :internals

=head2 Check Methods

=over

=item *

check_map($spec,$data)

Checks whether a map (or hash) part of the data structure conforms to the
appropriate specification definition.

=item *

check_list($spec,$data)

Checks whether a list (or array) part of the data structure conforms to
the appropriate specification definition.

=item *

=back

=head2 Validator Methods

=over

=item *

header($self,$key,$value)

Validates that the header is valid.

Note: No longer used as we now read the data structure, not the file.

=item *

url($self,$key,$value)

Validates that a given value is in an acceptable URL format

=item *

urlspec($self,$key,$value)

Validates that the URL to a META specification is a known one.

=item *

string_or_undef($self,$key,$value)

Validates that the value is either a string or an undef value. Bit of a
catchall function for parts of the data structure that are completely user
defined.

=item *

string($self,$key,$value)

Validates that a string exists for the given key.

=item *

file($self,$key,$value)

Validate that a file is passed for the given key. This may be made more
thorough in the future. For now it acts like \&string.

=item *

exversion($self,$key,$value)

Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'.

=item *

version($self,$key,$value)

Validates a single version string. Versions of the type '5.8.8' and '0.00_00'
are both valid. A leading 'v' like 'v1.2.3' is also valid.

=item *

boolean($self,$key,$value)

Validates for a boolean value: a defined value that is either "1" or "0" or
stringifies to those values.

=item *

license($self,$key,$value)

Validates that a value is given for the license. Returns 1 if an known license
type, or 2 if a value is given but the license type is not a recommended one.

=item *

custom_1($self,$key,$value)

Validates that the given key is in CamelCase, to indicate a user defined
keyword and only has characters in the class [-_a-zA-Z].  In version 1.X
of the spec, this was only explicitly stated for 'resources'.

=item *

custom_2($self,$key,$value)

Validates that the given key begins with 'x_' or 'X_', to indicate a user
defined keyword and only has characters in the class [-_a-zA-Z]

=item *

identifier($self,$key,$value)

Validates that key is in an acceptable format for the META specification,
for an identifier, i.e. any that matches the regular expression
qr/[a-z][a-z_]/i.

=item *

module($self,$key,$value)

Validates that a given key is in an acceptable module name format, e.g.
'Test::CPAN::Meta::Version'.

=back

=end :internals

=for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file
identifier license module phase relation release_status string string_or_undef
url urlspec version header check_map

=head1 BUGS

Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>

When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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

__END__


# vim: ts=2 sts=2 sw=2 et :
PK     ü2]¾$Šd  d  
  Kwalify.pmnu ÏÃ6Ç$        =head1 NAME

CPAN::Kwalify - Interface between CPAN.pm and Kwalify.pm

=head1 SYNOPSIS

  use CPAN::Kwalify;
  validate($schema_name, $data, $file, $doc);

=head1 DESCRIPTION

=over

=item _validate($schema_name, $data, $file, $doc)

$schema_name is the name of a supported schema. Currently only
C<distroprefs> is supported. $data is the data to be validated. $file
is the absolute path to the file the data are coming from. $doc is the
index of the document within $doc that is to be validated. The last
two arguments are only there for better error reporting.

Relies on being called from within CPAN.pm.

Dies if something fails. Does not return anything useful.

=item yaml($schema_name)

Returns the YAML text of that schema. Dies if something fails.

=back

=head1 AUTHOR

Andreas Koenig C<< <andk@cpan.org> >>

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>


=cut


use strict;

package CPAN::Kwalify;
use vars qw($VERSION $VAR1);
$VERSION = "5.50";

use File::Spec ();

my %vcache = ();

my $schema_loaded = {};

sub _validate {
    my($schema_name,$data,$abs,$y) = @_;
    my $yaml_module = CPAN->_yaml_module;
    if (
        $CPAN::META->has_inst($yaml_module)
        &&
        $CPAN::META->has_inst("Kwalify")
       ) {
        my $load = UNIVERSAL::can($yaml_module,"Load");
        unless ($schema_loaded->{$schema_name}) {
            eval {
                my $schema_yaml = yaml($schema_name);
                $schema_loaded->{$schema_name} = $load->($schema_yaml);
            };
            if ($@) {
                # we know that YAML.pm 0.62 cannot parse the schema,
                # so we try a fallback
                my $content = do {
                    my $path = __FILE__;
                    $path =~ s/\.pm$//;
                    $path = File::Spec->catfile($path, "$schema_name.dd");
                    local *FH;
                    open FH, $path or die "Could not open '$path': $!";
                    local $/;
                    <FH>;
                };
                $VAR1 = undef;
                eval $content;
                if (my $err = $@) {
                    die "parsing of '$schema_name.dd' failed: $err";
                }
                $schema_loaded->{$schema_name} = $VAR1;
            }
        }
    }
    if (my $schema = $schema_loaded->{$schema_name}) {
        my $mtime = (stat $abs)[9];
        for my $k (keys %{$vcache{$abs}}) {
            delete $vcache{$abs}{$k} unless $k eq $mtime;
        }
        return if $vcache{$abs}{$mtime}{$y}++;
        eval { Kwalify::validate($schema, $data) };
        if (my $err = $@) {
            my $info = {}; yaml($schema_name, info => $info);
            die "validation of distropref '$abs'[$y] against schema '$info->{path}' failed: $err";
        }
    }
}

sub _clear_cache {
    %vcache = ();
}

sub yaml {
    my($schema_name, %opt) = @_;
    my $content = do {
        my $path = __FILE__;
        $path =~ s/\.pm$//;
        $path = File::Spec->catfile($path, "$schema_name.yml");
        if ($opt{info}) {
            $opt{info}{path} = $path;
        }
        local *FH;
        open FH, $path or die "Could not open '$path': $!";
        local $/;
        <FH>;
    };
    return $content;
}

1;

# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# End:

PK     ü2]’Fq¼÷)  ÷)    Meta.pmnu „[µü¤        use 5.008001;
use strict;
use warnings;
package Parse::CPAN::Meta;
# ABSTRACT: Parse META.yml and META.json CPAN metadata files

our $VERSION = '2.150010';

use Exporter;
use Carp 'croak';

our @ISA = qw/Exporter/;
our @EXPORT_OK = qw/Load LoadFile/;

sub load_file {
  my ($class, $filename) = @_;

  my $meta = _slurp($filename);

  if ($filename =~ /\.ya?ml$/) {
    return $class->load_yaml_string($meta);
  }
  elsif ($filename =~ /\.json$/) {
    return $class->load_json_string($meta);
  }
  else {
    $class->load_string($meta); # try to detect yaml/json
  }
}

sub load_string {
  my ($class, $string) = @_;
  if ( $string =~ /^---/ ) { # looks like YAML
    return $class->load_yaml_string($string);
  }
  elsif ( $string =~ /^\s*\{/ ) { # looks like JSON
    return $class->load_json_string($string);
  }
  else { # maybe doc-marker-free YAML
    return $class->load_yaml_string($string);
  }
}

sub load_yaml_string {
  my ($class, $string) = @_;
  my $backend = $class->yaml_backend();
  my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
  croak $@ if $@;
  return $data || {}; # in case document was valid but empty
}

sub load_json_string {
  my ($class, $string) = @_;
  require Encode;
  # load_json_string takes characters, decode_json expects bytes
  my $encoded = Encode::encode('UTF-8', $string, Encode::PERLQQ());
  my $data = eval { $class->json_decoder()->can('decode_json')->($encoded) };
  croak $@ if $@;
  return $data || {};
}

sub yaml_backend {
  if ($ENV{PERL_CORE} or not defined $ENV{PERL_YAML_BACKEND} ) {
    _can_load( 'CPAN::Meta::YAML', 0.011 )
      or croak "CPAN::Meta::YAML 0.011 is not available\n";
    return "CPAN::Meta::YAML";
  }
  else {
    my $backend = $ENV{PERL_YAML_BACKEND};
    _can_load( $backend )
      or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
    $backend->can("Load")
      or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
    return $backend;
  }
}

sub json_decoder {
  if ($ENV{PERL_CORE}) {
    _can_load( 'JSON::PP' => 2.27300 )
      or croak "JSON::PP 2.27300 is not available\n";
    return 'JSON::PP';
  }
  if (my $decoder = $ENV{CPAN_META_JSON_DECODER}) {
    _can_load( $decoder )
      or croak "Could not load CPAN_META_JSON_DECODER '$decoder'\n";
    $decoder->can('decode_json')
      or croak "No decode_json sub provided by CPAN_META_JSON_DECODER '$decoder'\n";
    return $decoder;
  }
  return $_[0]->json_backend;
}

sub json_backend {
  if ($ENV{PERL_CORE}) {
    _can_load( 'JSON::PP' => 2.27300 )
      or croak "JSON::PP 2.27300 is not available\n";
    return 'JSON::PP';
  }
  if (my $backend = $ENV{CPAN_META_JSON_BACKEND}) {
    _can_load( $backend )
      or croak "Could not load CPAN_META_JSON_BACKEND '$backend'\n";
    $backend->can('new')
      or croak "No constructor provided by CPAN_META_JSON_BACKEND '$backend'\n";
    return $backend;
  }
  if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
    _can_load( 'JSON::PP' => 2.27300 )
      or croak "JSON::PP 2.27300 is not available\n";
    return 'JSON::PP';
  }
  else {
    _can_load( 'JSON' => 2.5 )
      or croak  "JSON 2.5 is required for " .
                "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
    return "JSON";
  }
}

sub _slurp {
  require Encode;
  open my $fh, "<:raw", "$_[0]" ## no critic
    or die "can't open $_[0] for reading: $!";
  my $content = do { local $/; <$fh> };
  $content = Encode::decode('UTF-8', $content, Encode::PERLQQ());
  return $content;
}

sub _can_load {
  my ($module, $version) = @_;
  (my $file = $module) =~ s{::}{/}g;
  $file .= ".pm";
  return 1 if $INC{$file};
  return 0 if exists $INC{$file}; # prior load failed
  eval { require $file; 1 }
    or return 0;
  if ( defined $version ) {
    eval { $module->VERSION($version); 1 }
      or return 0;
  }
  return 1;
}

# Kept for backwards compatibility only
# Create an object from a file
sub LoadFile ($) { ## no critic
  return Load(_slurp(shift));
}

# Parse a document from a string.
sub Load ($) { ## no critic
  require CPAN::Meta::YAML;
  my $object = eval { CPAN::Meta::YAML::Load(shift) };
  croak $@ if $@;
  return $object;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files

=head1 VERSION

version 2.150010

=head1 SYNOPSIS

    #############################################
    # In your file

    ---
    name: My-Distribution
    version: 1.23
    resources:
      homepage: "http://example.com/dist/My-Distribution"


    #############################################
    # In your program

    use Parse::CPAN::Meta;

    my $distmeta = Parse::CPAN::Meta->load_file('META.yml');

    # Reading properties
    my $name     = $distmeta->{name};
    my $version  = $distmeta->{version};
    my $homepage = $distmeta->{resources}{homepage};

=head1 DESCRIPTION

B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
L<JSON::PP> and/or L<CPAN::Meta::YAML>.

B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
and C<load_yaml_string>.  These will read and deserialize CPAN metafiles, and
are described below in detail.

B<Parse::CPAN::Meta> provides a legacy API of only two functions,
based on the YAML functions of the same name. Wherever possible,
identical calling semantics are used.  These may only be used with YAML sources.

All error reporting is done with exceptions (die'ing).

Note that META files are expected to be in UTF-8 encoding, only.  When
converted string data, it must first be decoded from UTF-8.

=begin Pod::Coverage


=end Pod::Coverage

=head1 METHODS

=head2 load_file

  my $metadata_structure = Parse::CPAN::Meta->load_file('META.json');

  my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml');

This method will read the named file and deserialize it to a data structure,
determining whether it should be JSON or YAML based on the filename.
The file will be read using the ":utf8" IO layer.

=head2 load_yaml_string

  my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string);

This method deserializes the given string of YAML and returns the first
document in it.  (CPAN metadata files should always have only one document.)
If the source was UTF-8 encoded, the string must be decoded before calling
C<load_yaml_string>.

=head2 load_json_string

  my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string);

This method deserializes the given string of JSON and the result.
If the source was UTF-8 encoded, the string must be decoded before calling
C<load_json_string>.

=head2 load_string

  my $metadata_structure = Parse::CPAN::Meta->load_string($some_string);

If you don't know whether a string contains YAML or JSON data, this method
will use some heuristics and guess.  If it can't tell, it assumes YAML.

=head2 yaml_backend

  my $backend = Parse::CPAN::Meta->yaml_backend;

Returns the module name of the YAML serializer. See L</ENVIRONMENT>
for details.

=head2 json_backend

  my $backend = Parse::CPAN::Meta->json_backend;

Returns the module name of the JSON serializer.  If C<CPAN_META_JSON_BACKEND>
is set, this will be whatever that's set to.  If not, this will either
be L<JSON::PP> or L<JSON>.  If C<PERL_JSON_BACKEND> is set,
this will return L<JSON> as further delegation is handled by
the L<JSON> module.  See L</ENVIRONMENT> for details.

=head2 json_decoder

  my $decoder = Parse::CPAN::Meta->json_decoder;

Returns the module name of the JSON decoder.  Unlike L</json_backend>, this
is not necessarily a full L<JSON>-style module, but only something that will
provide a C<decode_json> subroutine.  If C<CPAN_META_JSON_DECODER> is set,
this will be whatever that's set to.  If not, this will be whatever has
been selected as L</json_backend>.  See L</ENVIRONMENT> for more notes.

=head1 FUNCTIONS

For maintenance clarity, no functions are exported by default.  These functions
are available for backwards compatibility only and are best avoided in favor of
C<load_file>.

=head2 Load

  my @yaml = Parse::CPAN::Meta::Load( $string );

Parses a string containing a valid YAML stream into a list of Perl data
structures.

=head2 LoadFile

  my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' );

Reads the YAML stream from a file instead of a string.

=head1 ENVIRONMENT

=head2 CPAN_META_JSON_DECODER

By default, L<JSON::PP> will be used for deserializing JSON data.  If the
C<CPAN_META_JSON_DECODER> environment variable exists, this is expected to
be the name of a loadable module that provides a C<decode_json> subroutine,
which will then be used for deserialization.  Relying only on the existence
of said subroutine allows for maximum compatibility, since this API is
provided by all of L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS>,
L<JSON::MaybeXS>, L<JSON::Tiny>, and L<Mojo::JSON>.

=head2 CPAN_META_JSON_BACKEND

By default, L<JSON::PP> will be used for deserializing JSON data.  If the
C<CPAN_META_JSON_BACKEND> environment variable exists, this is expected to
be the name of a loadable module that provides the L<JSON> API, since
downstream code expects to be able to call C<new> on this class.  As such,
while L<JSON::PP>, L<JSON::XS>, L<Cpanel::JSON::XS> and L<JSON::MaybeXS> will
work for this, to use L<Mojo::JSON> or L<JSON::Tiny> for decoding requires
setting L</CPAN_META_JSON_DECODER>.

=head2 PERL_JSON_BACKEND

If the C<CPAN_META_JSON_BACKEND> environment variable does not exist, and if
C<PERL_JSON_BACKEND> environment variable exists, is true and is not
"JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
used to interpret C<PERL_JSON_BACKEND>.  If L<JSON> is not installed or is too
old, an exception will be thrown.  Note that at the time of writing, the only
useful values are 1, which will tell L<JSON> to guess, or L<JSON::XS> - if
you want to use a newer JSON module, see L</CPAN_META_JSON_BACKEND>.

=head2 PERL_YAML_BACKEND

By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted
as a module to use for deserialization.  The given module must be installed,
must load correctly and must implement the C<Load()> function or an exception
will be thrown.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=item *

Adam Kennedy <adamk@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.

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
PK     ü2]Ð§§·ý  ý  
  InfoObj.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::InfoObj;
use strict;

use CPAN::Debug;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);

use Cwd qw(chdir);

use vars qw(
            $VERSION
);
$VERSION = "5.5";

sub ro {
    my $self = shift;
    exists $self->{RO} and return $self->{RO};
}

#-> sub CPAN::InfoObj::cpan_userid
sub cpan_userid {
    my $self = shift;
    my $ro = $self->ro;
    if ($ro) {
        return $ro->{CPAN_USERID} || "N/A";
    } else {
        $self->debug("ID[$self->{ID}]");
        # N/A for bundles found locally
        return "N/A";
    }
}

sub id { shift->{ID}; }

#-> sub CPAN::InfoObj::new ;
sub new {
    my $this = bless {}, shift;
    %$this = @_;
    $this
}

# The set method may only be used by code that reads index data or
# otherwise "objective" data from the outside world. All session
# related material may do anything else with instance variables but
# must not touch the hash under the RO attribute. The reason is that
# the RO hash gets written to Metadata file and is thus persistent.

#-> sub CPAN::InfoObj::safe_chdir ;
sub safe_chdir {
  my($self,$todir) = @_;
  # we die if we cannot chdir and we are debuggable
  Carp::confess("safe_chdir called without todir argument")
        unless defined $todir and length $todir;
  if (chdir $todir) {
    $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
        if $CPAN::DEBUG;
  } else {
    if (-e $todir) {
        unless (-x $todir) {
            unless (chmod 0755, $todir) {
                my $cwd = CPAN::anycwd();
                $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
                                        "permission to change the permission; cannot ".
                                        "chdir to '$todir'\n");
                $CPAN::Frontend->mysleep(5);
                $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
                                       qq{to todir[$todir]: $!});
            }
        }
    } else {
        $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
    }
    if (chdir $todir) {
      $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
          if $CPAN::DEBUG;
    } else {
      my $cwd = CPAN::anycwd();
      $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
                             qq{to todir[$todir] (a chmod has been issued): $!});
    }
  }
}

#-> sub CPAN::InfoObj::set ;
sub set {
    my($self,%att) = @_;
    my $class = ref $self;

    # This must be ||=, not ||, because only if we write an empty
    # reference, only then the set method will write into the readonly
    # area. But for Distributions that spring into existence, maybe
    # because of a typo, we do not like it that they are written into
    # the readonly area and made permanent (at least for a while) and
    # that is why we do not "allow" other places to call ->set.
    unless ($self->id) {
        CPAN->debug("Bug? Empty ID, rejecting");
        return;
    }
    my $ro = $self->{RO} =
        $CPAN::META->{readonly}{$class}{$self->id} ||= {};

    while (my($k,$v) = each %att) {
        $ro->{$k} = $v;
    }
}

#-> sub CPAN::InfoObj::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
    push @m, sprintf "%-15s %s\n", $class, $id;
    join "", @m;
}

#-> sub CPAN::InfoObj::as_string ;
sub as_string {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    push @m, $class, " id = $self->{ID}\n";
    my $ro;
    unless ($ro = $self->ro) {
        if (substr($self->{ID},-1,1) eq ".") { # directory
            $ro = +{};
        } else {
            $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
            $CPAN::Frontend->mysleep(5);
            return;
        }
    }
    for (sort keys %$ro) {
        # next if m/^(ID|RO)$/;
        my $extra = "";
        if ($_ eq "CPAN_USERID") {
            $extra .= " (";
            $extra .= $self->fullname;
            my $email; # old perls!
            if ($email = $CPAN::META->instance("CPAN::Author",
                                               $self->cpan_userid
                                              )->email) {
                $extra .= " <$email>";
            } else {
                $extra .= " <no email>";
            }
            $extra .= ")";
        } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
            push @m, sprintf "    %-12s %s\n", $_, $self->fullname;
            next;
        }
        next unless defined $ro->{$_};
        push @m, sprintf "    %-12s %s%s\n", $_, $ro->{$_}, $extra;
    }
  KEY: for (sort keys %$self) {
        next if m/^(ID|RO)$/;
        unless (defined $self->{$_}) {
            delete $self->{$_};
            next KEY;
        }
        if (ref($self->{$_}) eq "ARRAY") {
            push @m, sprintf "    %-12s %s\n", $_, "@{$self->{$_}}";
        } elsif (ref($self->{$_}) eq "HASH") {
            my $value;
            if (/^CONTAINSMODS$/) {
                $value = join(" ",sort keys %{$self->{$_}});
            } elsif (/^prereq_pm$/) {
                my @value;
                my $v = $self->{$_};
                for my $x (sort keys %$v) {
                    my @svalue;
                    for my $y (sort keys %{$v->{$x}}) {
                        push @svalue, "$y=>$v->{$x}{$y}";
                    }
                    push @value, "$x\:" . join ",", @svalue if @svalue;
                }
                $value = join ";", @value;
            } else {
                $value = $self->{$_};
            }
            push @m, sprintf(
                             "    %-12s %s\n",
                             $_,
                             $value,
                            );
        } else {
            push @m, sprintf "    %-12s %s\n", $_, $self->{$_};
        }
    }
    join "", @m, "\n";
}

#-> sub CPAN::InfoObj::fullname ;
sub fullname {
    my($self) = @_;
    $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
}

#-> sub CPAN::InfoObj::dump ;
sub dump {
    my($self, $what) = @_;
    unless ($CPAN::META->has_inst("Data::Dumper")) {
        $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
    }
    local $Data::Dumper::Sortkeys;
    $Data::Dumper::Sortkeys = 1;
    my $out = Data::Dumper::Dumper($what ? eval $what : $self);
    if (length $out > 100000) {
        my $fh_pager = FileHandle->new;
        local($SIG{PIPE}) = "IGNORE";
        my $pager = $CPAN::Config->{'pager'} || "cat";
        $fh_pager->open("|$pager")
            or die "Could not open pager $pager\: $!";
        $fh_pager->print($out);
        close $fh_pager;
    } else {
        $CPAN::Frontend->myprint($out);
    }
}

1;
PK     ü2]¨ÖH      FTP/netrc.pmnu ÏÃ6Ç$        package CPAN::FTP::netrc;
use strict;

$CPAN::FTP::netrc::VERSION = $CPAN::FTP::netrc::VERSION = "1.01";

# package CPAN::FTP::netrc;
sub new {
    my($class) = @_;
    my $file = File::Spec->catfile($ENV{HOME},".netrc");

    my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
       $atime,$mtime,$ctime,$blksize,$blocks)
        = stat($file);
    $mode ||= 0;
    my $protected = 0;

    my($fh,@machines,$hasdefault);
    $hasdefault = 0;
    $fh = FileHandle->new or die "Could not create a filehandle";

    if($fh->open($file)) {
        $protected = ($mode & 077) == 0;
        local($/) = "";
      NETRC: while (<$fh>) {
            my(@tokens) = split " ", $_;
          TOKEN: while (@tokens) {
                my($t) = shift @tokens;
                if ($t eq "default") {
                    $hasdefault++;
                    last NETRC;
                }
                last TOKEN if $t eq "macdef";
                if ($t eq "machine") {
                    push @machines, shift @tokens;
                }
            }
        }
    } else {
        $file = $hasdefault = $protected = "";
    }

    bless {
        'mach' => [@machines],
        'netrc' => $file,
        'hasdefault' => $hasdefault,
        'protected' => $protected,
    }, $class;
}

# CPAN::FTP::netrc::hasdefault;
sub hasdefault { shift->{'hasdefault'} }
sub netrc      { shift->{'netrc'}      }
sub protected  { shift->{'protected'}  }
sub contains {
    my($self,$mach) = @_;
    for ( @{$self->{'mach'}} ) {
        return 1 if $_ eq $mach;
    }
    return 0;
}

1;
PK     ü2]4Aöë '   '  	  Bundle.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Bundle;
use strict;
use CPAN::Module;
@CPAN::Bundle::ISA = qw(CPAN::Module);

use vars qw(
            $VERSION
);
$VERSION = "5.5005";

sub look {
    my $self = shift;
    $CPAN::Frontend->myprint($self->as_string);
}

#-> CPAN::Bundle::undelay
sub undelay {
    my $self = shift;
    delete $self->{later};
    for my $c ( $self->contains ) {
        my $obj = CPAN::Shell->expandany($c) or next;
        if ($obj->id eq $self->id){
            my $id = $obj->id;
            $CPAN::Frontend->mywarn("$id seems to contain itself, skipping\n");
            next;
        }
        $obj->undelay;
    }
}

# mark as dirty/clean
#-> sub CPAN::Bundle::color_cmd_tmps ;
sub color_cmd_tmps {
    my($self) = shift;
    my($depth) = shift || 0;
    my($color) = shift || 0;
    my($ancestors) = shift || [];
    # a module needs to recurse to its cpan_file, a distribution needs
    # to recurse into its prereq_pms, a bundle needs to recurse into its modules

    return if exists $self->{incommandcolor}
        && $color==1
        && $self->{incommandcolor}==$color;
    if ($depth>=$CPAN::MAX_RECURSION) {
        my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
        if ($e->is_resolvable) {
            return $self->{incommandcolor}=2;
        } else {
            die $e;
        }
    }
    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;

    for my $c ( $self->contains ) {
        my $obj = CPAN::Shell->expandany($c) or next;
        CPAN->debug("c[$c]obj[$obj]") if $CPAN::DEBUG;
        $obj->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
    }
    # never reached code?
    #if ($color==0) {
      #delete $self->{badtestcnt};
    #}
    $self->{incommandcolor} = $color;
}

#-> sub CPAN::Bundle::as_string ;
sub as_string {
    my($self) = @_;
    $self->contains;
    # following line must be "=", not "||=" because we have a moving target
    $self->{INST_VERSION} = $self->inst_version;
    return $self->SUPER::as_string;
}

#-> sub CPAN::Bundle::contains ;
sub contains {
    my($self) = @_;
    my($inst_file) = $self->inst_file || "";
    my($id) = $self->id;
    $self->debug("inst_file[$inst_file]id[$id]") if $CPAN::DEBUG;
    if ($inst_file && CPAN::Version->vlt($self->inst_version,$self->cpan_version)) {
        undef $inst_file;
    }
    unless ($inst_file) {
        # Try to get at it in the cpan directory
        $self->debug("no inst_file") if $CPAN::DEBUG;
        my $cpan_file;
        $CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless
              $cpan_file = $self->cpan_file;
        if ($cpan_file eq "N/A") {
            $CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n");
            return;
        }
        my $dist = $CPAN::META->instance('CPAN::Distribution',
                                         $self->cpan_file);
        $self->debug("before get id[$dist->{ID}]") if $CPAN::DEBUG;
        $dist->get;
        $self->debug("after get id[$dist->{ID}]") if $CPAN::DEBUG;
        my($todir) = $CPAN::Config->{'cpan_home'};
        my(@me,$from,$to,$me);
        @me = split /::/, $self->id;
        $me[-1] .= ".pm";
        $me = File::Spec->catfile(@me);
        my $build_dir;
        unless ($build_dir = $dist->{build_dir}) {
            $CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n");
            return;
        }
        $from = $self->find_bundle_file($build_dir,join('/',@me));
        $to = File::Spec->catfile($todir,$me);
        File::Path::mkpath(File::Basename::dirname($to));
        File::Copy::copy($from, $to)
              or Carp::confess("Couldn't copy $from to $to: $!");
        $inst_file = $to;
    }
    my @result;
    my $fh = FileHandle->new;
    local $/ = "\n";
    open($fh,$inst_file) or die "Could not open '$inst_file': $!";
    my $in_cont = 0;
    $self->debug("inst_file[$inst_file]") if $CPAN::DEBUG;
    while (<$fh>) {
        $in_cont = m/^=(?!head1\s+(?i-xsm:CONTENTS))/ ? 0 :
            m/^=head1\s+(?i-xsm:CONTENTS)/ ? 1 : $in_cont;
        next unless $in_cont;
        next if /^=/;
        s/\#.*//;
        next if /^\s+$/;
        chomp;
        push @result, (split " ", $_, 2)[0];
    }
    close $fh;
    delete $self->{STATUS};
    $self->{CONTAINS} = \@result;
    $self->debug("CONTAINS[@result]") if $CPAN::DEBUG;
    unless (@result) {
        $CPAN::Frontend->mywarn(qq{
The bundle file "$inst_file" may be a broken
bundlefile. It seems not to contain any bundle definition.
Please check the file and if it is bogus, please delete it.
Sorry for the inconvenience.
});
    }
    @result;
}

#-> sub CPAN::Bundle::find_bundle_file
# $where is in local format, $what is in unix format
sub find_bundle_file {
    my($self,$where,$what) = @_;
    $self->debug("where[$where]what[$what]") if $CPAN::DEBUG;
### The following two lines let CPAN.pm become Bundle/CPAN.pm :-(
###    my $bu = File::Spec->catfile($where,$what);
###    return $bu if -f $bu;
    my $manifest = File::Spec->catfile($where,"MANIFEST");
    unless (-f $manifest) {
        require ExtUtils::Manifest;
        my $cwd = CPAN::anycwd();
        $self->safe_chdir($where);
        ExtUtils::Manifest::mkmanifest();
        $self->safe_chdir($cwd);
    }
    my $fh = FileHandle->new($manifest)
        or Carp::croak("Couldn't open $manifest: $!");
    local($/) = "\n";
    my $bundle_filename = $what;
    $bundle_filename =~ s|Bundle.*/||;
    my $bundle_unixpath;
    while (<$fh>) {
        next if /^\s*\#/;
        my($file) = /(\S+)/;
        if ($file =~ m|\Q$what\E$|) {
            $bundle_unixpath = $file;
            # return File::Spec->catfile($where,$bundle_unixpath); # bad
            last;
        }
        # retry if she managed to have no Bundle directory
        $bundle_unixpath = $file if $file =~ m|\Q$bundle_filename\E$|;
    }
    return File::Spec->catfile($where, split /\//, $bundle_unixpath)
        if $bundle_unixpath;
    Carp::croak("Couldn't find a Bundle file in $where");
}

# needs to work quite differently from Module::inst_file because of
# cpan_home/Bundle/ directory and the possibility that we have
# shadowing effect. As it makes no sense to take the first in @INC for
# Bundles, we parse them all for $VERSION and take the newest.

#-> sub CPAN::Bundle::inst_file ;
sub inst_file {
    my($self) = @_;
    my($inst_file);
    my(@me);
    @me = split /::/, $self->id;
    $me[-1] .= ".pm";
    my($incdir,$bestv);
    foreach $incdir ($CPAN::Config->{'cpan_home'},@INC) {
        my $parsefile = File::Spec->catfile($incdir, @me);
        CPAN->debug("parsefile[$parsefile]") if $CPAN::DEBUG;
        next unless -f $parsefile;
        my $have = eval { MM->parse_version($parsefile); };
        if ($@) {
            $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
        }
        if (!$bestv || CPAN::Version->vgt($have,$bestv)) {
            $self->{INST_FILE} = $parsefile;
            $self->{INST_VERSION} = $bestv = $have;
        }
    }
    $self->{INST_FILE};
}

#-> sub CPAN::Bundle::inst_version ;
sub inst_version {
    my($self) = @_;
    $self->inst_file; # finds INST_VERSION as side effect
    $self->{INST_VERSION};
}

#-> sub CPAN::Bundle::rematein ;
sub rematein {
    my($self,$meth) = @_;
    $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
    my($id) = $self->id;
    Carp::croak( "Can't $meth $id, don't have an associated bundle file. :-(\n" )
        unless $self->inst_file || $self->cpan_file;
    my($s,%fail);
    for $s ($self->contains) {
        my($type) = $s =~ m|/| ? 'CPAN::Distribution' :
            $s =~ m|^Bundle::| ? 'CPAN::Bundle' : 'CPAN::Module';
        if ($type eq 'CPAN::Distribution') {
            $CPAN::Frontend->mywarn(qq{
The Bundle }.$self->id.qq{ contains
explicitly a file '$s'.
Going to $meth that.
});
            $CPAN::Frontend->mysleep(5);
        }
        # possibly noisy action:
        $self->debug("type[$type] s[$s]") if $CPAN::DEBUG;
        my $obj = $CPAN::META->instance($type,$s);
        $obj->{reqtype} = $self->{reqtype};
        $obj->{viabundle} ||= { id => $id, reqtype => $self->{reqtype}, optional => !$self->{mandatory}};
        # $obj->$meth();
        # XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01
        # A: Sure, what could demand otherwise? --andk, 2013-11-25
        CPAN::Queue->queue_item(qmod => $obj->id, reqtype => $self->{reqtype}, optional => !$self->{mandatory});
    }
}

# If a bundle contains another that contains an xs_file we have here,
# we just don't bother I suppose
#-> sub CPAN::Bundle::xs_file
sub xs_file {
    return 0;
}

#-> sub CPAN::Bundle::force ;
sub fforce   { shift->rematein('fforce',@_); }
#-> sub CPAN::Bundle::force ;
sub force   { shift->rematein('force',@_); }
#-> sub CPAN::Bundle::notest ;
sub notest  { shift->rematein('notest',@_); }
#-> sub CPAN::Bundle::get ;
sub get     { shift->rematein('get',@_); }
#-> sub CPAN::Bundle::make ;
sub make    { shift->rematein('make',@_); }
#-> sub CPAN::Bundle::test ;
sub test    {
    my $self = shift;
    # $self->{badtestcnt} ||= 0;
    $self->rematein('test',@_);
}
#-> sub CPAN::Bundle::install ;
sub install {
  my $self = shift;
  $self->rematein('install',@_);
}
#-> sub CPAN::Bundle::clean ;
sub clean   { shift->rematein('clean',@_); }

#-> sub CPAN::Bundle::uptodate ;
sub uptodate {
    my($self) = @_;
    return 0 unless $self->SUPER::uptodate; # we must have the current Bundle def
    my $c;
    foreach $c ($self->contains) {
        my $obj = CPAN::Shell->expandany($c);
        return 0 unless $obj->uptodate;
    }
    return 1;
}

#-> sub CPAN::Bundle::readme ;
sub readme  {
    my($self) = @_;
    my($file) = $self->cpan_file or $CPAN::Frontend->myprint(qq{
No File found for bundle } . $self->id . qq{\n}), return;
    $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
    $CPAN::META->instance('CPAN::Distribution',$file)->readme;
}

1;
PK     ü2]íù7=$ $   FirstTime.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::FirstTime;
use strict;

use ExtUtils::MakeMaker ();
use FileHandle ();
use File::Basename ();
use File::Path ();
use File::Spec ();
use CPAN::Mirrors ();
use CPAN::Version ();
use vars qw($VERSION $auto_config);
$VERSION = "5.5317";

=head1 NAME

CPAN::FirstTime - Utility for CPAN::Config file Initialization

=head1 SYNOPSIS

CPAN::FirstTime::init()

=head1 DESCRIPTION

The init routine asks a few questions and writes a CPAN/Config.pm or
CPAN/MyConfig.pm file (depending on what it is currently using).

In the following all questions and explanations regarding config
variables are collected.

=cut

# down until the next =back the manpage must be parsed by the program
# because the text is used in the init dialogues.

my @podpara = split /\n\n/, <<'=back';

=over 2

=item allow_installing_module_downgrades

The CPAN shell can watch the C<blib/> directories that are built up
before running C<make test> to determine whether the current
distribution will end up with modules being overwritten with decreasing module version numbers. It
can then let the build of this distro fail when it discovers a
downgrade.

Do you want to allow installing distros with decreasing module
versions compared to what you have installed (yes, no, ask/yes,
ask/no)?

=item allow_installing_outdated_dists

The CPAN shell can watch the C<blib/> directories that are built up
before running C<make test> to determine whether the current
distribution contains modules that are indexed with a distro with a
higher distro-version number than the current one. It can
then let the build of this distro fail when it would not represent the
most up-to-date version of the distro.

Note: choosing anything but 'yes' for this option will need
CPAN::DistnameInfo being installed for taking effect.

Do you want to allow installing distros that are not indexed as the
highest distro-version for all contained modules (yes, no, ask/yes,
ask/no)?

=item auto_commit

Normally CPAN.pm keeps config variables in memory and changes need to
be saved in a separate 'o conf commit' command to make them permanent
between sessions. If you set the 'auto_commit' option to true, changes
to a config variable are always automatically committed to disk.

Always commit changes to config variables to disk?

=item build_cache

CPAN.pm can limit the size of the disk area for keeping the build
directories with all the intermediate files.

Cache size for build directory (in MB)?

=item build_dir

Directory where the build process takes place?

=item build_dir_reuse

Until version 1.88 CPAN.pm never trusted the contents of the build_dir
directory between sessions. Since 1.88_58 CPAN.pm has a YAML-based
mechanism that makes it possible to share the contents of the
build_dir/ directory between different sessions with the same version
of perl. People who prefer to test things several days before
installing will like this feature because it saves a lot of time.

If you say yes to the following question, CPAN will try to store
enough information about the build process so that it can pick up in
future sessions at the same state of affairs as it left a previous
session.

Store and re-use state information about distributions between
CPAN.pm sessions?

=item build_requires_install_policy

When a module declares another one as a 'build_requires' prerequisite
this means that the other module is only needed for building or
testing the module but need not be installed permanently. In this case
you may wish to install that other module nonetheless or just keep it
in the 'build_dir' directory to have it available only temporarily.
Installing saves time on future installations but makes the perl
installation bigger.

You can choose if you want to always install (yes), never install (no)
or be always asked. In the latter case you can set the default answer
for the question to yes (ask/yes) or no (ask/no).

Policy on installing 'build_requires' modules (yes, no, ask/yes,
ask/no)?

=item cache_metadata

To considerably speed up the initial CPAN shell startup, it is
possible to use Storable to create a cache of metadata. If Storable is
not available, the normal index mechanism will be used.

Note: this mechanism is not used when use_sqlite is on and SQLite is
running.

Cache metadata (yes/no)?

=item check_sigs

CPAN packages can be digitally signed by authors and thus verified
with the security provided by strong cryptography. The exact mechanism
is defined in the Module::Signature module. While this is generally
considered a good thing, it is not always convenient to the end user
to install modules that are signed incorrectly or where the key of the
author is not available or where some prerequisite for
Module::Signature has a bug and so on.

With the check_sigs parameter you can turn signature checking on and
off. The default is off for now because the whole tool chain for the
functionality is not yet considered mature by some. The author of
CPAN.pm would recommend setting it to true most of the time and
turning it off only if it turns out to be annoying.

Note that if you do not have Module::Signature installed, no signature
checks will be performed at all.

Always try to check and verify signatures if a SIGNATURE file is in
the package and Module::Signature is installed (yes/no)?

=item cleanup_after_install

Users who install modules and do not intend to look back, can free
occupied disk space quickly by letting CPAN.pm cleanup each build
directory immediately after a successful install.

Remove build directory after a successful install? (yes/no)?

=item colorize_output

When you have Term::ANSIColor installed, you can turn on colorized
output to have some visual differences between normal CPAN.pm output,
warnings, debugging output, and the output of the modules being
installed. Set your favorite colors after some experimenting with the
Term::ANSIColor module.

Please note that on Windows platforms colorized output also requires
the Win32::Console::ANSI module.

Do you want to turn on colored output?

=item colorize_print

Color for normal output?

=item colorize_warn

Color for warnings?

=item colorize_debug

Color for debugging messages?

=item commandnumber_in_prompt

The prompt of the cpan shell can contain the current command number
for easier tracking of the session or be a plain string.

Do you want the command number in the prompt (yes/no)?

=item connect_to_internet_ok

If you have never defined your own C<urllist> in your configuration
then C<CPAN.pm> will be hesitant to use the built in default sites for
downloading. It will ask you once per session if a connection to the
internet is OK and only if you say yes, it will try to connect. But to
avoid this question, you can choose your favorite download sites once
and get away with it. Or, if you have no favorite download sites
answer yes to the following question.

If no urllist has been chosen yet, would you prefer CPAN.pm to connect
to the built-in default sites without asking? (yes/no)?

=item ftp_passive

Shall we always set the FTP_PASSIVE environment variable when dealing
with ftp download (yes/no)?

=item ftpstats_period

Statistics about downloads are truncated by size and period
simultaneously.

How many days shall we keep statistics about downloads?

=item ftpstats_size

Statistics about downloads are truncated by size and period
simultaneously. Setting this to zero or negative disables download
statistics.

How many items shall we keep in the statistics about downloads?

=item getcwd

CPAN.pm changes the current working directory often and needs to
determine its own current working directory. Per default it uses
Cwd::cwd but if this doesn't work on your system for some reason,
alternatives can be configured according to the following table:

    cwd         Cwd::cwd
    getcwd      Cwd::getcwd
    fastcwd     Cwd::fastcwd
    getdcwd     Cwd::getdcwd
    backtickcwd external command cwd

Preferred method for determining the current working directory?

=item halt_on_failure

Normally, CPAN.pm continues processing the full list of targets and
dependencies, even if one of them fails.  However, you can specify
that CPAN should halt after the first failure.  (Note that optional
recommended or suggested modules that fail will not cause a halt.)

Do you want to halt on failure (yes/no)?

=item histfile

If you have one of the readline packages (Term::ReadLine::Perl,
Term::ReadLine::Gnu, possibly others) installed, the interactive CPAN
shell will have history support. The next two questions deal with the
filename of the history file and with its size. If you do not want to
set this variable, please hit SPACE ENTER to the following question.

File to save your history?

=item histsize

Number of lines to save?

=item inactivity_timeout

Sometimes you may wish to leave the processes run by CPAN alone
without caring about them. Because the Makefile.PL or the Build.PL
sometimes contains question you're expected to answer, you can set a
timer that will kill a 'perl Makefile.PL' process after the specified
time in seconds.

If you set this value to 0, these processes will wait forever. This is
the default and recommended setting.

Timeout for inactivity during {Makefile,Build}.PL?

=item index_expire

The CPAN indexes are usually rebuilt once or twice per hour, but the
typical CPAN mirror mirrors only once or twice per day. Depending on
the quality of your mirror and your desire to be on the bleeding edge,
you may want to set the following value to more or less than one day
(which is the default). It determines after how many days CPAN.pm
downloads new indexes.

Let the index expire after how many days?

=item inhibit_startup_message

When the CPAN shell is started it normally displays a greeting message
that contains the running version and the status of readline support.

Do you want to turn this message off?

=item keep_source_where

Unless you are accessing the CPAN on your filesystem via a file: URL,
CPAN.pm needs to keep the source files it downloads somewhere. Please
supply a directory where the downloaded files are to be kept.

Download target directory?

=item load_module_verbosity

When CPAN.pm loads a module it needs for some optional feature, it
usually reports about module name and version. Choose 'v' to get this
message, 'none' to suppress it.

Verbosity level for loading modules (none or v)?

=item makepl_arg

Every Makefile.PL is run by perl in a separate process. Likewise we
run 'make' and 'make install' in separate processes. If you have
any parameters (e.g. PREFIX, UNINST or the like) you want to
pass to the calls, please specify them here.

If you don't understand this question, just press ENTER.

Typical frequently used settings:

    PREFIX=~/perl    # non-root users (please see manual for more hints)

Parameters for the 'perl Makefile.PL' command?

=item make_arg

Parameters for the 'make' command? Typical frequently used setting:

    -j3              # dual processor system (on GNU make)

Your choice:

=item make_install_arg

Parameters for the 'make install' command?
Typical frequently used setting:

    UNINST=1         # to always uninstall potentially conflicting files
                     # (but do NOT use with local::lib or INSTALL_BASE)

Your choice:

=item make_install_make_command

Do you want to use a different make command for 'make install'?
Cautious people will probably prefer:

    su root -c make
 or
    sudo make
 or
    /path1/to/sudo -u admin_account /path2/to/make

or some such. Your choice:

=item mbuildpl_arg

A Build.PL is run by perl in a separate process. Likewise we run
'./Build' and './Build install' in separate processes. If you have any
parameters you want to pass to the calls, please specify them here.

Typical frequently used settings:

    --install_base /home/xxx             # different installation directory

Parameters for the 'perl Build.PL' command?

=item mbuild_arg

Parameters for the './Build' command? Setting might be:

    --extra_linker_flags -L/usr/foo/lib  # non-standard library location

Your choice:

=item mbuild_install_arg

Parameters for the './Build install' command? Typical frequently used
setting:

    --uninst 1       # uninstall conflicting files
                     # (but do NOT use with local::lib or INSTALL_BASE)

Your choice:

=item mbuild_install_build_command

Do you want to use a different command for './Build install'? Sudo
users will probably prefer:

    su root -c ./Build
 or
    sudo ./Build
 or
    /path1/to/sudo -u admin_account ./Build

or some such. Your choice:

=item pager

What is your favorite pager program?

=item prefer_installer

When you have Module::Build installed and a module comes with both a
Makefile.PL and a Build.PL, which shall have precedence?

The main two standard installer modules are the old and well
established ExtUtils::MakeMaker (for short: EUMM) which uses the
Makefile.PL. And the next generation installer Module::Build (MB)
which works with the Build.PL (and often comes with a Makefile.PL
too). If a module comes only with one of the two we will use that one
but if both are supplied then a decision must be made between EUMM and
MB. See also http://rt.cpan.org/Ticket/Display.html?id=29235 for a
discussion about the right default.

Or, as a third option you can choose RAND which will make a random
decision (something regular CPAN testers will enjoy).

In case you can choose between running a Makefile.PL or a Build.PL,
which installer would you prefer (EUMM or MB or RAND)?

=item prefs_dir

CPAN.pm can store customized build environments based on regular
expressions for distribution names. These are YAML files where the
default options for CPAN.pm and the environment can be overridden and
dialog sequences can be stored that can later be executed by an
Expect.pm object. The CPAN.pm distribution comes with some prefab YAML
files that cover sample distributions that can be used as blueprints
to store your own prefs. Please check out the distroprefs/ directory of
the CPAN.pm distribution to get a quick start into the prefs system.

Directory where to store default options/environment/dialogs for
building modules that need some customization?

=item prerequisites_policy

The CPAN module can detect when a module which you are trying to build
depends on prerequisites. If this happens, it can build the
prerequisites for you automatically ('follow'), ask you for
confirmation ('ask'), or just ignore them ('ignore').  Choosing
'follow' also sets PERL_AUTOINSTALL and PERL_EXTUTILS_AUTOINSTALL for
"--defaultdeps" if not already set.

Please set your policy to one of the three values.

Policy on building prerequisites (follow, ask or ignore)?

=item pushy_https

Boolean. Defaults to true. If this option is true, the cpan shell will
use https://cpan.org/ to download stuff from the CPAN. It will fall
back to http://cpan.org/ if it can't handle https for some reason
(missing modules, missing programs). Whenever it falls back to the
http protocol, it will issue a warning.

If this option is true, the option C<urllist> will be ignored.
Consequently, if you want to work with local mirrors via your own
configured list of URLs, you will have to choose no below.

Do you want to turn the pushy_https behaviour on?

=item randomize_urllist

CPAN.pm can introduce some randomness when using hosts for download
that are configured in the urllist parameter. Enter a numeric value
between 0 and 1 to indicate how often you want to let CPAN.pm try a
random host from the urllist. A value of one specifies to always use a
random host as the first try. A value of zero means no randomness at
all. Anything in between specifies how often, on average, a random
host should be tried first.

Randomize parameter

=item recommends_policy

(Experimental feature!) Some CPAN modules recommend additional, optional dependencies.  These should
generally be installed except in resource constrained environments.  When this
policy is true, recommended modules will be included with required modules.

Include recommended modules?

=item scan_cache

By default, each time the CPAN module is started, cache scanning is
performed to keep the cache size in sync ('atstart'). Alternatively,
scanning and cleanup can happen when CPAN exits ('atexit'). To prevent
any cache cleanup, answer 'never'.

Perform cache scanning ('atstart', 'atexit' or 'never')?

=item shell

What is your favorite shell?

=item show_unparsable_versions

During the 'r' command CPAN.pm finds modules without version number.
When the command finishes, it prints a report about this. If you
want this report to be very verbose, say yes to the following
variable.

Show all individual modules that have no $VERSION?

=item show_upload_date

The 'd' and the 'm' command normally only show you information they
have in their in-memory database and thus will never connect to the
internet. If you set the 'show_upload_date' variable to true, 'm' and
'd' will additionally show you the upload date of the module or
distribution. Per default this feature is off because it may require a
net connection to get at the upload date.

Always try to show upload date with 'd' and 'm' command (yes/no)?

=item show_zero_versions

During the 'r' command CPAN.pm finds modules with a version number of
zero. When the command finishes, it prints a report about this. If you
want this report to be very verbose, say yes to the following
variable.

Show all individual modules that have a $VERSION of zero?

=item suggests_policy

(Experimental feature!) Some CPAN modules suggest additional, optional dependencies.  These 'suggest'
dependencies provide enhanced operation.  When this policy is true, suggested
modules will be included with required modules.

Include suggested modules?

=item tar_verbosity

When CPAN.pm uses the tar command, which switch for the verbosity
shall be used? Choose 'none' for quiet operation, 'v' for file
name listing, 'vv' for full listing.

Tar command verbosity level (none or v or vv)?

=item term_is_latin

The next option deals with the charset (a.k.a. character set) your
terminal supports. In general, CPAN is English speaking territory, so
the charset does not matter much but some CPAN have names that are
outside the ASCII range. If your terminal supports UTF-8, you should
say no to the next question. If it expects ISO-8859-1 (also known as
LATIN1) then you should say yes. If it supports neither, your answer
does not matter because you will not be able to read the names of some
authors anyway. If you answer no, names will be output in UTF-8.

Your terminal expects ISO-8859-1 (yes/no)?

=item term_ornaments

When using Term::ReadLine, you can turn ornaments on so that your
input stands out against the output from CPAN.pm.

Do you want to turn ornaments on?

=item test_report

The goal of the CPAN Testers project (http://testers.cpan.org/) is to
test as many CPAN packages as possible on as many platforms as
possible.  This provides valuable feedback to module authors and
potential users to identify bugs or platform compatibility issues and
improves the overall quality and value of CPAN.

One way you can contribute is to send test results for each module
that you install.  If you install the CPAN::Reporter module, you have
the option to automatically generate and deliver test reports to CPAN
Testers whenever you run tests on a CPAN package.

See the CPAN::Reporter documentation for additional details and
configuration settings.  If your firewall blocks outgoing traffic,
you may need to configure CPAN::Reporter before sending reports.

Generate test reports if CPAN::Reporter is installed (yes/no)?

=item perl5lib_verbosity

When CPAN.pm extends @INC via PERL5LIB, it prints a list of
directories added (or a summary of how many directories are
added).  Choose 'v' to get this message, 'none' to suppress it.

Verbosity level for PERL5LIB changes (none or v)?

=item prefer_external_tar

Per default all untar operations are done with the perl module
Archive::Tar; by setting this variable to true the external tar
command is used if available; on Unix this is usually preferred
because they have a reliable and fast gnutar implementation.

Use the external tar program instead of Archive::Tar?

=item trust_test_report_history

When a distribution has already been tested by CPAN::Reporter on
this machine, CPAN can skip the test phase and just rely on the
test report history instead.

Note that this will not apply to distributions that failed tests
because of missing dependencies.  Also, tests can be run
regardless of the history using "force".

Do you want to rely on the test report history (yes/no)?

=item urllist_ping_external

When automatic selection of the nearest cpan mirrors is performed,
turn on the use of the external ping via Net::Ping::External. This is
recommended in the case the local network has a transparent proxy.

Do you want to use the external ping command when autoselecting
mirrors?

=item urllist_ping_verbose

When automatic selection of the nearest cpan mirrors is performed,
this option can be used to turn on verbosity during the selection
process.

Do you want to see verbosity turned on when autoselecting mirrors?

=item use_prompt_default

When this is true, CPAN will set PERL_MM_USE_DEFAULT to a true
value.  This causes ExtUtils::MakeMaker (and compatible) prompts
to use default values instead of stopping to prompt you to answer
questions. It also sets NONINTERACTIVE_TESTING to a true value to
signal more generally that distributions should not try to
interact with you.

Do you want to use prompt defaults (yes/no)?

=item use_sqlite

CPAN::SQLite is a layer between the index files that are downloaded
from the CPAN and CPAN.pm that speeds up metadata queries and reduces
memory consumption of CPAN.pm considerably.

Use CPAN::SQLite if available? (yes/no)?

=item version_timeout

This timeout prevents CPAN from hanging when trying to parse a
pathologically coded $VERSION from a module.

The default is 15 seconds.  If you set this value to 0, no timeout
will occur, but this is not recommended.

Timeout for parsing module versions?

=item yaml_load_code

Both YAML.pm and YAML::Syck are capable of deserialising code. As this
requires a string eval, which might be a security risk, you can use
this option to enable or disable the deserialisation of code via
CPAN::DeferredCode. (Note: This does not work under perl 5.6)

Do you want to enable code deserialisation (yes/no)?

=item yaml_module

At the time of this writing (2009-03) there are three YAML
implementations working: YAML, YAML::Syck, and YAML::XS. The latter
two are faster but need a C compiler installed on your system. There
may be more alternative YAML conforming modules. When I tried two
other players, YAML::Tiny and YAML::Perl, they seemed not powerful
enough to work with CPAN.pm. This may have changed in the meantime.

Which YAML implementation would you prefer?

=back

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

use vars qw( %prompts );

{

    my @prompts = (

auto_config => qq{
CPAN.pm requires configuration, but most of it can be done automatically.
If you answer 'no' below, you will enter an interactive dialog for each
configuration option instead.

Would you like to configure as much as possible automatically?},

auto_pick => qq{
Would you like me to automatically choose some CPAN mirror
sites for you? (This means connecting to the Internet)},

config_intro => qq{

The following questions are intended to help you with the
configuration. The CPAN module needs a directory of its own to cache
important index files and maybe keep a temporary mirror of CPAN files.
This may be a site-wide or a personal directory.

},

# cpan_home => qq{ },

cpan_home_where => qq{

First of all, I'd like to create this directory. Where?

},

external_progs => qq{

The CPAN module will need a few external programs to work properly.
Please correct me, if I guess the wrong path for a program. Don't
panic if you do not have some of them, just press ENTER for those. To
disable the use of a program, you can type a space followed by ENTER.

},

proxy_intro => qq{

If you're accessing the net via proxies, you can specify them in the
CPAN configuration or via environment variables. The variable in
the \$CPAN::Config takes precedence.

},

proxy_user => qq{

If your proxy is an authenticating proxy, you can store your username
permanently. If you do not want that, just press ENTER. You will then
be asked for your username in every future session.

},

proxy_pass => qq{

Your password for the authenticating proxy can also be stored
permanently on disk. If this violates your security policy, just press
ENTER. You will then be asked for the password in every future
session.

},

urls_intro => qq{
Now you need to choose your CPAN mirror sites.  You can let me
pick mirrors for you, you can select them from a list or you
can enter them by hand.
},

urls_picker_intro => qq{First, pick a nearby continent and country by typing in the number(s)
in front of the item(s) you want to select. You can pick several of
each, separated by spaces. Then, you will be presented with a list of
URLs of CPAN mirrors in the countries you selected, along with
previously selected URLs. Select some of those URLs, or just keep the
old list. Finally, you will be prompted for any extra URLs -- file:,
ftp:, or http: -- that host a CPAN mirror.

You should select more than one (just in case the first isn't available).

},

password_warn => qq{

Warning: Term::ReadKey seems not to be available, your password will
be echoed to the terminal!

},

install_help => qq{
Warning: You do not have write permission for Perl library directories.

To install modules, you need to configure a local Perl library directory or
escalate your privileges.  CPAN can help you by bootstrapping the local::lib
module or by configuring itself to use 'sudo' (if available).  You may also
resolve this problem manually if you need to customize your setup.

What approach do you want?  (Choose 'local::lib', 'sudo' or 'manual')
},

local_lib_installed => qq{
local::lib is installed. You must now add the following environment variables
to your shell configuration files (or registry, if you are on Windows) and
then restart your command line shell and CPAN before installing modules:

},

              );

    die "Coding error in \@prompts declaration.  Odd number of elements, above"
        if (@prompts % 2);

    %prompts = @prompts;

    if (scalar(keys %prompts) != scalar(@prompts)/2) {
        my %already;
        for my $item (0..$#prompts) {
            next if $item % 2;
            die "$prompts[$item] is duplicated\n" if $already{$prompts[$item]}++;
        }
    }

    shift @podpara;
    while (@podpara) {
        warn "Alert: cannot parse my own manpage for init dialog" unless $podpara[0] =~ s/^=item\s+//;
        my $name = shift @podpara;
        my @para;
        while (@podpara && $podpara[0] !~ /^=item/) {
            push @para, shift @podpara;
        }
        $prompts{$name} = pop @para;
        if (@para) {
            $prompts{$name . "_intro"} = join "", map { "$_\n\n" } @para;
        }
    }

}

sub init {
    my($configpm, %args) = @_;
    use Config;
    # extra args after 'o conf init'
    my $matcher = $args{args} && @{$args{args}} ? $args{args}[0] : '';
    if ($matcher =~ /^\/(.*)\/$/) {
        # case /regex/ => take the first, ignore the rest
        $matcher = $1;
        shift @{$args{args}};
        if (@{$args{args}}) {
            local $" = " ";
            $CPAN::Frontend->mywarn("Ignoring excessive arguments '@{$args{args}}'");
            $CPAN::Frontend->mysleep(2);
        }
    } elsif (0 == length $matcher) {
    } elsif (0 && $matcher eq "~") { # extremely buggy, but a nice idea
        my @unconfigured = sort grep { not exists $CPAN::Config->{$_}
                                      or not defined $CPAN::Config->{$_}
                                          or not length $CPAN::Config->{$_}
                                  } keys %$CPAN::Config;
        $matcher = "\\b(".join("|", @unconfigured).")\\b";
        $CPAN::Frontend->mywarn("matcher[$matcher]");
    } else {
        # case WORD... => all arguments must be valid
        for my $arg (@{$args{args}}) {
            unless (exists $CPAN::HandleConfig::keys{$arg}) {
                $CPAN::Frontend->mywarn("'$arg' is not a valid configuration variable\n");
                return;
            }
        }
        $matcher = "\\b(".join("|",@{$args{args}}).")\\b";
    }
    CPAN->debug("matcher[$matcher]") if $CPAN::DEBUG;

    unless ($CPAN::VERSION) {
        require CPAN::Nox;
    }
    require CPAN::HandleConfig;
    CPAN::HandleConfig::require_myconfig_or_config();
    $CPAN::Config ||= {};
    local($/) = "\n";
    local($\) = "";
    local($|) = 1;

    my($ans,$default); # why so half global?

    #
    #= Files, directories
    #

    local *_real_prompt;
    if ( $args{autoconfig} ) {
        $auto_config = 1;
    } elsif ($matcher) {
        $auto_config = 0;
    } else {
        my $_conf = prompt($prompts{auto_config}, "yes");
        $auto_config = ($_conf and $_conf =~ /^y/i) ? 1 : 0;
    }
    CPAN->debug("auto_config[$auto_config]") if $CPAN::DEBUG;
    if ( $auto_config ) {
            local $^W = 0;
            # prototype should match that of &MakeMaker::prompt
            my $current_second = time;
            my $current_second_count = 0;
            my $i_am_mad = 0;
            # silent prompting -- just quietly use default
            *_real_prompt = sub { return $_[1] };
    }

    #
    # bootstrap local::lib or sudo
    #
    unless ( $matcher
        || _can_write_to_libdirs() || _using_installbase() || _using_sudo()
    ) {
        local $auto_config = 0; # We *must* ask, even under autoconfig
        local *_real_prompt;    # We *must* show prompt
        my_prompt_loop(install_help => 'local::lib', $matcher,
                   'local::lib|sudo|manual');
    }
    $CPAN::Config->{install_help} ||= ''; # Temporary to suppress warnings

    if (!$matcher or q{
                       build_dir
                       build_dir_reuse
                       cpan_home
                       keep_source_where
                       prefs_dir
                      } =~ /$matcher/) {
        $CPAN::Frontend->myprint($prompts{config_intro}) unless $auto_config;

        init_cpan_home($matcher);

        my_dflt_prompt("keep_source_where",
                       File::Spec->catdir($CPAN::Config->{cpan_home},"sources"),
                       $matcher,
                      );
        my_dflt_prompt("build_dir",
                       File::Spec->catdir($CPAN::Config->{cpan_home},"build"),
                       $matcher
                      );
        my_yn_prompt(build_dir_reuse => 0, $matcher);
        my_dflt_prompt("prefs_dir",
                       File::Spec->catdir($CPAN::Config->{cpan_home},"prefs"),
                       $matcher
                      );
    }

    #
    #= Config: auto_commit
    #

    my_yn_prompt(auto_commit => 0, $matcher);

    #
    #= Cache size, Index expire
    #
    my_dflt_prompt(build_cache => 100, $matcher);

    my_dflt_prompt(index_expire => 1, $matcher);
    my_prompt_loop(scan_cache => 'atstart', $matcher, 'atstart|atexit|never');
    my_yn_prompt(cleanup_after_install => 0, $matcher);

    #
    #= cache_metadata
    #

    my_yn_prompt(cache_metadata => 1, $matcher);
    my_yn_prompt(use_sqlite => 0, $matcher);

    #
    #= Do we follow PREREQ_PM?
    #

    my_prompt_loop(prerequisites_policy => 'follow', $matcher,
                   'follow|ask|ignore');
    my_prompt_loop(build_requires_install_policy => 'yes', $matcher,
                   'yes|no|ask/yes|ask/no');
    my_yn_prompt(recommends_policy => 1, $matcher);
    my_yn_prompt(suggests_policy => 0, $matcher);

    #
    #= Module::Signature
    #
    my_yn_prompt(check_sigs => 0, $matcher);

    #
    #= CPAN::Reporter
    #
    if (!$matcher or 'test_report' =~ /$matcher/) {
        my_yn_prompt(test_report => 0, $matcher);
        if (
            $matcher &&
            $CPAN::Config->{test_report} &&
            $CPAN::META->has_inst("CPAN::Reporter") &&
            CPAN::Reporter->can('configure')
           ) {
            my $_conf = prompt("Would you like me configure CPAN::Reporter now?", "yes");
            if ($_conf =~ /^y/i) {
              $CPAN::Frontend->myprint("\nProceeding to configure CPAN::Reporter.\n");
              CPAN::Reporter::configure();
              $CPAN::Frontend->myprint("\nReturning to CPAN configuration.\n");
            }
        }
    }

    my_yn_prompt(trust_test_report_history => 0, $matcher);

    #
    #= YAML vs. YAML::Syck
    #
    if (!$matcher or "yaml_module" =~ /$matcher/) {
        my_dflt_prompt(yaml_module => "YAML", $matcher);
        my $old_v = $CPAN::Config->{load_module_verbosity};
        $CPAN::Config->{load_module_verbosity} = q[none];
        if (!$auto_config && !$CPAN::META->has_inst($CPAN::Config->{yaml_module})) {
            $CPAN::Frontend->mywarn
                ("Warning (maybe harmless): '$CPAN::Config->{yaml_module}' not installed.\n");
            $CPAN::Frontend->mysleep(3);
        }
        $CPAN::Config->{load_module_verbosity} = $old_v;
    }

    #
    #= YAML code deserialisation
    #
    my_yn_prompt(yaml_load_code => 0, $matcher);

    #
    #= External programs
    #
    my(@path) = split /$Config{'path_sep'}/, $ENV{'PATH'};
    $CPAN::Frontend->myprint($prompts{external_progs})
        if !$matcher && !$auto_config;
    _init_external_progs($matcher, {
        path => \@path,
        progs => [ qw/make bzip2 gzip tar unzip gpg patch applypatch/ ],
        shortcut => 0
      });
    _init_external_progs($matcher, {
        path => \@path,
        progs => [ qw/wget curl lynx ncftpget ncftp ftp/ ],
        shortcut => 1
      });

    {
        my $path = $CPAN::Config->{'pager'} ||
            $ENV{PAGER} || find_exe("less",\@path) ||
                find_exe("more",\@path) || ($^O eq 'MacOS' ? $ENV{EDITOR} : 0 )
                    || "more";
        my_dflt_prompt(pager => $path, $matcher);
    }

    {
        my $path = $CPAN::Config->{'shell'};
        if ($path && File::Spec->file_name_is_absolute($path)) {
            $CPAN::Frontend->mywarn("Warning: configured $path does not exist\n")
                unless -e $path;
            $path = "";
        }
        $path ||= $ENV{SHELL};
        $path ||= $ENV{COMSPEC} if $^O eq "MSWin32";
        if ($^O eq 'MacOS') {
            $CPAN::Config->{'shell'} = 'not_here';
        } else {
            $path ||= 'sh', $path =~ s,\\,/,g if $^O eq 'os2'; # Cosmetic only
            my_dflt_prompt(shell => $path, $matcher);
        }
    }

    {
        my $tar = $CPAN::Config->{tar};
        my $prefer_external_tar = $CPAN::Config->{prefer_external_tar}; # XXX not yet supported
        unless (defined $prefer_external_tar) {
            if ($^O =~ /(MSWin32|solaris)/) {
                # both have a record of broken tars
                $prefer_external_tar = 0;
            } elsif ($tar) {
                $prefer_external_tar = 1;
            } else {
                $prefer_external_tar = 0;
            }
        }
        my_yn_prompt(prefer_external_tar => $prefer_external_tar, $matcher);
    }

    #
    # verbosity
    #

    my_prompt_loop(tar_verbosity => 'none', $matcher,
                   'none|v|vv');
    my_prompt_loop(load_module_verbosity => 'none', $matcher,
                   'none|v');
    my_prompt_loop(perl5lib_verbosity => 'none', $matcher,
                   'none|v');
    my_yn_prompt(inhibit_startup_message => 0, $matcher);

    #
    #= Installer, arguments to make etc.
    #

    my_prompt_loop(prefer_installer => 'MB', $matcher, 'MB|EUMM|RAND');

    if (!$matcher or 'makepl_arg make_arg' =~ /$matcher/) {
        my_dflt_prompt(makepl_arg => "", $matcher);
        my_dflt_prompt(make_arg => "", $matcher);
        if ( $CPAN::Config->{makepl_arg} =~ /LIBS=|INC=/ ) {
            $CPAN::Frontend->mywarn(
                "Warning: Using LIBS or INC in makepl_arg will likely break distributions\n" .
                "that specify their own LIBS or INC options in Makefile.PL.\n"
            );
        }

    }

    require CPAN::HandleConfig;
    if (exists $CPAN::HandleConfig::keys{make_install_make_command}) {
        # as long as Windows needs $self->_build_command, we cannot
        # support sudo on windows :-)
        my $default = $CPAN::Config->{make} || "";
        if ( $default && $CPAN::Config->{install_help} eq 'sudo' ) {
            if ( find_exe('sudo') ) {
                $default = "sudo $default";
                delete $CPAN::Config->{make_install_make_command}
                    unless $CPAN::Config->{make_install_make_command} =~ /sudo/;
            }
            else {
                $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n");
            }
        }
        my_dflt_prompt(make_install_make_command => $default, $matcher);
    }

    my_dflt_prompt(make_install_arg => $CPAN::Config->{make_arg} || "",
                   $matcher);

    my_dflt_prompt(mbuildpl_arg => "", $matcher);
    my_dflt_prompt(mbuild_arg => "", $matcher);

    if (exists $CPAN::HandleConfig::keys{mbuild_install_build_command}
        and $^O ne "MSWin32") {
        # as long as Windows needs $self->_build_command, we cannot
        # support sudo on windows :-)
        my $default = $^O eq 'VMS' ? '@Build.com' : "./Build";
        if ( $CPAN::Config->{install_help} eq 'sudo' ) {
            if ( find_exe('sudo') ) {
                $default = "sudo $default";
                delete $CPAN::Config->{mbuild_install_build_command}
                    unless $CPAN::Config->{mbuild_install_build_command} =~ /sudo/;
            }
            else {
                $CPAN::Frontend->mywarnonce("Could not find 'sudo' in PATH\n");
            }
        }
        my_dflt_prompt(mbuild_install_build_command => $default, $matcher);
    }

    my_dflt_prompt(mbuild_install_arg => "", $matcher);

    for my $o (qw(
        allow_installing_outdated_dists
        allow_installing_module_downgrades
        )) {
        my_prompt_loop($o => 'ask/no', $matcher,
                       'yes|no|ask/yes|ask/no');
    }

    #
    #== use_prompt_default
    #
    my_yn_prompt(use_prompt_default => 0, $matcher);

    #
    #= Alarm period
    #

    my_dflt_prompt(inactivity_timeout => 0, $matcher);
    my_dflt_prompt(version_timeout => 15, $matcher);

    #
    #== halt_on_failure
    #
    my_yn_prompt(halt_on_failure => 0, $matcher);

    #
    #= Proxies
    #

    my @proxy_vars = qw/ftp_proxy http_proxy no_proxy/;
    my @proxy_user_vars = qw/proxy_user proxy_pass/;
    if (!$matcher or "@proxy_vars @proxy_user_vars" =~ /$matcher/) {
        $CPAN::Frontend->myprint($prompts{proxy_intro}) unless $auto_config;

        for (@proxy_vars) {
            $prompts{$_} = "Your $_?";
            my_dflt_prompt($_ => $ENV{$_}||"", $matcher);
        }

        if ($CPAN::Config->{ftp_proxy} ||
            $CPAN::Config->{http_proxy}) {

            $default = $CPAN::Config->{proxy_user} || $CPAN::LWP::UserAgent::USER || "";

            $CPAN::Frontend->myprint($prompts{proxy_user}) unless $auto_config;

            if ($CPAN::Config->{proxy_user} = prompt("Your proxy user id?",$default)) {
                $CPAN::Frontend->myprint($prompts{proxy_pass}) unless $auto_config;

                if ($CPAN::META->has_inst("Term::ReadKey")) {
                    Term::ReadKey::ReadMode("noecho");
                } else {
                    $CPAN::Frontend->myprint($prompts{password_warn}) unless $auto_config;
                }
                $CPAN::Config->{proxy_pass} = prompt_no_strip("Your proxy password?");
                if ($CPAN::META->has_inst("Term::ReadKey")) {
                    Term::ReadKey::ReadMode("restore");
                }
                $CPAN::Frontend->myprint("\n\n") unless $auto_config;
            }
        }
    }

    #
    #= how plugins work
    #

    # XXX MISSING: my_array_prompt to be used with plugins. We did something like this near
    #     git log -p fd68f8f5e33f4cecea4fdb7abc5ee19c12f138f0..test-notest-test-dependency
    # Need to do similar steps for plugin_list. As long as we do not support it here, people
    # must use the cpan shell prompt to write something like
    #     o conf plugin_list push CPAN::Plugin::Specfile=dir,/tmp/foo-20141013,...
    #     o conf commit

    #
    #= how FTP works
    #

    my_yn_prompt(ftp_passive => 1, $matcher);

    #
    #= how cwd works
    #

    my_prompt_loop(getcwd => 'cwd', $matcher,
                   'cwd|getcwd|fastcwd|getdcwd|backtickcwd');

    #
    #= the CPAN shell itself (prompt, color)
    #

    my_yn_prompt(commandnumber_in_prompt => 1, $matcher);
    my_yn_prompt(term_ornaments => 1, $matcher);
    if ("colorize_output colorize_print colorize_warn colorize_debug" =~ $matcher) {
        my_yn_prompt(colorize_output => 0, $matcher);
        if ($CPAN::Config->{colorize_output}) {
            if ($CPAN::META->has_inst("Term::ANSIColor")) {
                my $T="gYw";
                $CPAN::Frontend->myprint( "                                      on_  on_y ".
                    "        on_ma           on_\n") unless $auto_config;
                $CPAN::Frontend->myprint( "                   on_black on_red  green ellow ".
                    "on_blue genta on_cyan white\n") unless $auto_config;

                for my $FG ("", "bold",
                            map {$_,"bold $_"} "black","red","green",
                            "yellow","blue",
                            "magenta",
                            "cyan","white") {
                    $CPAN::Frontend->myprint(sprintf( "%12s ", $FG)) unless $auto_config;
                    for my $BG ("",map {"on_$_"} qw(black red green yellow
                                                    blue magenta cyan white)) {
                            $CPAN::Frontend->myprint( $FG||$BG ?
                            Term::ANSIColor::colored("  $T  ","$FG $BG") : "  $T  ") unless $auto_config;
                    }
                    $CPAN::Frontend->myprint( "\n" ) unless $auto_config;
                }
                $CPAN::Frontend->myprint( "\n" ) unless $auto_config;
            }
            for my $tuple (
                           ["colorize_print", "bold blue on_white"],
                           ["colorize_warn", "bold red on_white"],
                           ["colorize_debug", "black on_cyan"],
                          ) {
                my_dflt_prompt($tuple->[0] => $tuple->[1], $matcher);
                if ($CPAN::META->has_inst("Term::ANSIColor")) {
                    eval { Term::ANSIColor::color($CPAN::Config->{$tuple->[0]})};
                    if ($@) {
                        $CPAN::Config->{$tuple->[0]} = $tuple->[1];
                        $CPAN::Frontend->mywarn($@."setting to default '$tuple->[1]'\n");
                    }
                }
            }
        }
    }

    #
    #== term_is_latin
    #

    my_yn_prompt(term_is_latin => 1, $matcher);

    #
    #== save history in file 'histfile'
    #

    if (!$matcher or 'histfile histsize' =~ /$matcher/) {
        $CPAN::Frontend->myprint($prompts{histfile_intro}) unless $auto_config;
        defined($default = $CPAN::Config->{histfile}) or
            $default = File::Spec->catfile($CPAN::Config->{cpan_home},"histfile");
        my_dflt_prompt(histfile => $default, $matcher);

        if ($CPAN::Config->{histfile}) {
            defined($default = $CPAN::Config->{histsize}) or $default = 100;
            my_dflt_prompt(histsize => $default, $matcher);
        }
    }

    #
    #== do an ls on the m or the d command
    #
    my_yn_prompt(show_upload_date => 0, $matcher);

    #
    #== verbosity at the end of the r command
    #
    if (!$matcher
        or 'show_unparsable_versions' =~ /$matcher/
        or 'show_zero_versions' =~ /$matcher/
       ) {
        my_yn_prompt(show_unparsable_versions => 0, $matcher);
        my_yn_prompt(show_zero_versions => 0, $matcher);
    }

    #
    #= MIRRORED.BY and conf_sites()
    #

    # Let's assume they want to use the internet and make them turn it
    # off if they really don't.
    my_yn_prompt("connect_to_internet_ok" => 1, $matcher);
    my_yn_prompt("pushy_https" => 1, $matcher);

    # Allow matching but don't show during manual config
    if ($matcher) {
        if ("urllist_ping_external" =~ $matcher) {
            my_yn_prompt(urllist_ping_external => 0, $matcher);
        }
        if ("urllist_ping_verbose" =~ $matcher) {
            my_yn_prompt(urllist_ping_verbose => 0, $matcher);
        }
        if ("randomize_urllist" =~ $matcher) {
            my_dflt_prompt(randomize_urllist => 0, $matcher);
        }
        if ("ftpstats_size" =~ $matcher) {
            my_dflt_prompt(ftpstats_size => 99, $matcher);
        }
        if ("ftpstats_period" =~ $matcher) {
            my_dflt_prompt(ftpstats_period => 14, $matcher);
        }
    }

    $CPAN::Config->{urllist} ||= [];

    if ($auto_config) {
        if(@{ $CPAN::Config->{urllist} }) {
            $CPAN::Frontend->myprint(
                "Your 'urllist' is already configured. Type 'o conf init urllist' to change it.\n"
            );
        }
        else {
            # Hint: as of 2021-11: to get http, use http://www.cpan.org/
            $CPAN::Config->{urllist} = [ 'https://cpan.org/' ];
            $CPAN::Frontend->myprint(
                "We initialized your 'urllist' to @{$CPAN::Config->{urllist}}. Type 'o conf init urllist' to change it.\n"
            );
        }
    }
    elsif (!$matcher || "urllist" =~ $matcher) {
        _do_pick_mirrors();
    }

    if ($auto_config) {
        $CPAN::Frontend->myprint(
            "\nAutoconfiguration complete.\n"
        );
        $auto_config = 0; # reset
    }

    # bootstrap local::lib now if requested
    if ( $CPAN::Config->{install_help} eq 'local::lib' ) {
        if ( ! @{ $CPAN::Config->{urllist} } ) {
            $CPAN::Frontend->myprint(
                "\nALERT: Skipping local::lib bootstrap because 'urllist' is not configured.\n"
            );
        }
        elsif (! $CPAN::Config->{make} ) {
            $CPAN::Frontend->mywarn(
                "\nALERT: Skipping local::lib bootstrap because 'make' is not configured.\n"
            );
            _beg_for_make(); # repetitive, but we don't want users to miss it
        }
        else {
            $CPAN::Frontend->myprint("\nAttempting to bootstrap local::lib...\n");
            $CPAN::Frontend->myprint("\nWriting $configpm for bootstrap...\n");
            delete $CPAN::Config->{install_help}; # temporary only
            CPAN::HandleConfig->commit;
            my($dist, $locallib);
            $locallib = CPAN::Shell->expand('Module', 'local::lib');
            if ( $locallib and $dist = $locallib->distribution ) {
                # this is a hack to force bootstrapping
                $dist->{prefs}{pl}{commandline} = "$^X Makefile.PL --bootstrap";
                # Set @INC for this process so we find things as they bootstrap
                require lib;
                lib->import(_local_lib_inc_path());
                eval { $dist->install };
            }
            if ( ! $dist || (my $err = $@) ) {
                $err ||= 'Could not locate local::lib in the CPAN index';
                $CPAN::Frontend->mywarn("Error bootstrapping local::lib: $@\n");
                $CPAN::Frontend->myprint("From the CPAN Shell, you might try 'look local::lib' and \n"
                    . "run 'perl Makefile --bootstrap' and see if that is successful.  Then\n"
                    . "restart your CPAN client\n"
                );
            }
            else {
                _local_lib_config();
            }
        }
    }

    # install_help is temporary for configuration and not saved
    delete $CPAN::Config->{install_help};

    $CPAN::Frontend->myprint("\n");
    if ($matcher && !$CPAN::Config->{auto_commit}) {
        $CPAN::Frontend->myprint("Please remember to call 'o conf commit' to ".
                                 "make the config permanent!\n");
    } else {
        CPAN::HandleConfig->commit;
    }

    if (! $matcher) {
        $CPAN::Frontend->myprint(
            "\nYou can re-run configuration any time with 'o conf init' in the CPAN shell\n"
        );
    }

}

sub _local_lib_config {
    # Set environment stuff for this process
    require local::lib;

    # Tell user about environment vars to set
    $CPAN::Frontend->myprint($prompts{local_lib_installed});
    local $ENV{SHELL} = $CPAN::Config->{shell} || $ENV{SHELL};
    my $shellvars = local::lib->environment_vars_string_for(_local_lib_path());
    $CPAN::Frontend->myprint($shellvars);

    # Set %ENV after getting string above
    my %env = local::lib->build_environment_vars_for(_local_lib_path(), 1);
    while ( my ($k, $v) = each %env ) {
        $ENV{$k} = $v;
    }

    # Offer to mangle the shell config
    my $munged_rc;
    if ( my $rc = _find_shell_config() ) {
        local $auto_config = 0; # We *must* ask, even under autoconfig
        local *_real_prompt;    # We *must* show prompt
        my $_conf = prompt(
            "\nWould you like me to append that to $rc now?", "yes"
        );
        if ($_conf =~ /^y/i) {
            open my $fh, ">>", $rc;
            print {$fh} "\n$shellvars";
            close $fh;
            $munged_rc++;
        }
    }

    # Warn at exit time
    if ($munged_rc) {
        push @{$CPAN::META->_exit_messages}, << "HERE";

*** Remember to restart your shell before running cpan again ***
HERE
    }
    else {
        push @{$CPAN::META->_exit_messages}, << "HERE";

*** Remember to add these environment variables to your shell config
    and restart your shell before running cpan again ***

$shellvars
HERE
    }
}

{
    my %shell_rc_map = (
        map { $_ => ".${_}rc" } qw/ bash tcsh csh /,
        map { $_ => ".profile" } qw/dash ash sh/,
        zsh  => ".zshenv",
    );

    sub _find_shell_config {
        my $shell = File::Basename::basename($CPAN::Config->{shell});
        if ( my $rc = $shell_rc_map{$shell} ) {
            my $path = File::Spec->catfile($ENV{HOME}, $rc);
            return $path if -w $path;
        }
    }
}


sub _local_lib_inc_path {
    return File::Spec->catdir(_local_lib_path(), qw/lib perl5/);
}

sub _local_lib_path {
    return File::Spec->catdir(_local_lib_home(), 'perl5');
}

# Adapted from resolve_home_path() in local::lib -- this is where
# local::lib thinks the user's home is
{
    my $local_lib_home;
    sub _local_lib_home {
        $local_lib_home ||= File::Spec->rel2abs( do {
            if ($CPAN::META->has_usable("File::HomeDir") && File::HomeDir->VERSION >= 0.65) {
                File::HomeDir->my_home;
            } elsif (defined $ENV{HOME}) {
                $ENV{HOME};
            } else {
                (getpwuid $<)[7] || "~";
            }
        });
    }
}

sub _do_pick_mirrors {
    local *_real_prompt;
    *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
    $CPAN::Frontend->myprint($prompts{urls_intro});
    # Only prompt for auto-pick if Net::Ping is new enough to do timings
    my $_conf = 'n';
    if ( $CPAN::META->has_usable("Net::Ping") && CPAN::Version->vgt(Net::Ping->VERSION, '2.13')) {
        $_conf = prompt($prompts{auto_pick}, "yes");
    } else {
        prompt("Autoselection disabled due to Net::Ping missing or insufficient. Please press ENTER");
    }
    my @old_list = @{ $CPAN::Config->{urllist} };
    if ( $_conf =~ /^y/i ) {
        conf_sites( auto_pick => 1 ) or bring_your_own();
    }
    else {
        _print_urllist('Current') if @old_list;
        my $msg = scalar @old_list
            ? "\nWould you like to edit the urllist or pick new mirrors from a list?"
            : "\nWould you like to pick from the CPAN mirror list?" ;
        my $_conf = prompt($msg, "yes");
        if ( $_conf =~ /^y/i ) {
            conf_sites();
        }
        bring_your_own();
    }
    _print_urllist('New');
}

sub _init_external_progs {
    my($matcher,$args) = @_;
    my $PATH = $args->{path};
    my @external_progs = @{ $args->{progs} };
    my $shortcut = $args->{shortcut};
    my $showed_make_warning;

    if (!$matcher or "@external_progs" =~ /$matcher/) {
        my $old_warn = $^W;
        local $^W if $^O eq 'MacOS';
        local $^W = $old_warn;
        my $progname;
        for $progname (@external_progs) {
            next if $matcher && $progname !~ /$matcher/;
            if ($^O eq 'MacOS') {
                $CPAN::Config->{$progname} = 'not_here';
                next;
            }

            my $progcall = $progname;
            unless ($matcher) {
                # we really don't need ncftp if we have ncftpget, but
                # if they chose this dialog via matcher, they shall have it
                next if $progname eq "ncftp" && $CPAN::Config->{ncftpget} gt " ";
            }
            my $path = $CPAN::Config->{$progname}
                || $Config::Config{$progname}
                    || "";
            if (File::Spec->file_name_is_absolute($path)) {
                # testing existence is not good enough, some have these exe
                # extensions

                # warn "Warning: configured $path does not exist\n" unless -e $path;
                # $path = "";
            } elsif ($path =~ /^\s+$/) {
                # preserve disabled programs
            } else {
                $path = '';
            }
            unless ($path) {
                # e.g. make -> nmake
                $progcall = $Config::Config{$progname} if $Config::Config{$progname};
            }

            $path ||= find_exe($progcall,$PATH);
            unless ($path) { # not -e $path, because find_exe already checked that
                local $"=";";
                $CPAN::Frontend->mywarn("Warning: $progcall not found in PATH[@$PATH]\n") unless $auto_config;
                _beg_for_make(), $showed_make_warning++ if $progname eq "make";
            }
            $prompts{$progname} = "Where is your $progname program?";
            $path = my_dflt_prompt($progname,$path,$matcher,1); # 1 => no strip spaces
            my $disabling = $path =~ m/^\s*$/;

            # don't let them disable or misconfigure make without warning
            if ( $progname eq "make" && ( $disabling || ! _check_found($path) ) ) {
              if ( $disabling && $showed_make_warning ) {
                next;
              }
              else {
                _beg_for_make() unless $showed_make_warning++;
                undef $CPAN::Config->{$progname};
                $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable make (NOT RECOMMENDED)\n");
                redo;
              }
            }
            elsif ( $disabling ) {
              next;
            }
            elsif ( _check_found( $CPAN::Config->{$progname} ) ) {
              last if $shortcut && !$matcher;
            }
            else {
              undef $CPAN::Config->{$progname};
              $CPAN::Frontend->mywarn("Press SPACE and ENTER to disable $progname\n");
              redo;
            }
        }
    }
}

sub _check_found {
  my ($prog) = @_;
  if ( ! -f $prog ) {
    $CPAN::Frontend->mywarn("Warning: '$prog' does not exist\n")
      unless $auto_config;
    return;
  }
  elsif ( ! -x $prog ) {
    $CPAN::Frontend->mywarn("Warning: '$prog' is not executable\n")
      unless $auto_config;
    return;
  }
  return 1;
}

sub _beg_for_make {
  $CPAN::Frontend->mywarn(<<"HERE");

ALERT: 'make' is an essential tool for building perl Modules.
Please make sure you have 'make' (or some equivalent) working.

HERE
  if ($^O eq "MSWin32") {
    $CPAN::Frontend->mywarn(<<"HERE");
Windows users may want to follow this procedure when back in the CPAN shell:

    look YVES/scripts/alien_nmake.pl
    perl alien_nmake.pl

This will install nmake on your system which can be used as a 'make'
substitute.

HERE
  }

  $CPAN::Frontend->mywarn(<<"HERE");
You can then retry the 'make' configuration step with

    o conf init make

HERE
}

sub init_cpan_home {
    my($matcher) = @_;
    if (!$matcher or 'cpan_home' =~ /$matcher/) {
        my $cpan_home =
            $CPAN::Config->{cpan_home} || CPAN::HandleConfig::cpan_home();
        if (-d $cpan_home) {
            $CPAN::Frontend->myprint(
                "\nI see you already have a directory\n" .
                "\n$cpan_home\n" .
                "Shall we use it as the general CPAN build and cache directory?\n\n"
            ) unless $auto_config;
        } else {
            # no cpan-home, must prompt and get one
            $CPAN::Frontend->myprint($prompts{cpan_home_where}) unless $auto_config;
        }

        my $default = $cpan_home;
        my $loop = 0;
        my($last_ans,$ans);
        $CPAN::Frontend->myprint(" <cpan_home>\n") unless $auto_config;
    PROMPT: while ($ans = prompt("CPAN build and cache directory?",$default)) {
            if (File::Spec->file_name_is_absolute($ans)) {
                my @cpan_home = split /[\/\\]/, $ans;
            DIR: for my $dir (@cpan_home) {
                    if ($dir =~ /^~/ and (!$last_ans or $ans ne $last_ans)) {
                        $CPAN::Frontend
                            ->mywarn("Warning: a tilde in the path will be ".
                                     "taken as a literal tilde. Please ".
                                     "confirm again if you want to keep it\n");
                        $last_ans = $default = $ans;
                        next PROMPT;
                    }
                }
            } else {
                require Cwd;
                my $cwd = Cwd::cwd();
                my $absans = File::Spec->catdir($cwd,$ans);
                $CPAN::Frontend->mywarn("The path '$ans' is not an ".
                                        "absolute path. Please specify ".
                                        "an absolute path\n");
                $default = $absans;
                next PROMPT;
            }
            eval { File::Path::mkpath($ans); }; # dies if it can't
            if ($@) {
                $CPAN::Frontend->mywarn("Couldn't create directory $ans.\n".
                                        "Please retry.\n");
                next PROMPT;
            }
            if (-d $ans && -w _) {
                last PROMPT;
            } else {
                $CPAN::Frontend->mywarn("Couldn't find directory $ans\n".
                                        "or directory is not writable. Please retry.\n");
                if (++$loop > 5) {
                    $CPAN::Frontend->mydie("Giving up");
                }
            }
        }
        $CPAN::Config->{cpan_home} = $ans;
    }
}

sub my_dflt_prompt {
    my ($item, $dflt, $m, $no_strip) = @_;
    my $default = $CPAN::Config->{$item} || $dflt;

    if (!$auto_config && (!$m || $item =~ /$m/)) {
        if (my $intro = $prompts{$item . "_intro"}) {
            $CPAN::Frontend->myprint($intro);
        }
        $CPAN::Frontend->myprint(" <$item>\n");
        $CPAN::Config->{$item} =
          $no_strip ? prompt_no_strip($prompts{$item}, $default)
                    : prompt(         $prompts{$item}, $default);
    } else {
        $CPAN::Config->{$item} = $default;
    }
    return $CPAN::Config->{$item};
}

sub my_yn_prompt {
    my ($item, $dflt, $m) = @_;
    my $default;
    defined($default = $CPAN::Config->{$item}) or $default = $dflt;

    if (!$auto_config && (!$m || $item =~ /$m/)) {
        if (my $intro = $prompts{$item . "_intro"}) {
            $CPAN::Frontend->myprint($intro);
        }
        $CPAN::Frontend->myprint(" <$item>\n");
        my $ans = prompt($prompts{$item}, $default ? 'yes' : 'no');
        $CPAN::Config->{$item} = ($ans =~ /^[y1]/i ? 1 : 0);
    } else {
        $CPAN::Config->{$item} = $default;
    }
}

sub my_prompt_loop {
    my ($item, $dflt, $m, $ok) = @_;
    my $default = $CPAN::Config->{$item} || $dflt;
    my $ans;

    if (!$auto_config && (!$m || $item =~ /$m/)) {
        my $intro = $prompts{$item . "_intro"};
        $CPAN::Frontend->myprint($intro) if defined $intro;
        $CPAN::Frontend->myprint(" <$item>\n");
        do { $ans = prompt($prompts{$item}, $default);
        } until $ans =~ /$ok/;
        $CPAN::Config->{$item} = $ans;
    } else {
        $CPAN::Config->{$item} = $default;
    }
}


# Here's the logic about the MIRRORED.BY file.  There are a number of scenarios:
# (1) We have a cached MIRRORED.BY file
#   (1a) We're auto-picking
#       - Refresh it automatically if it's old
#   (1b) Otherwise, ask if using cached is ok.  If old, default to no.
#       - If cached is not ok, get it from the Internet. If it succeeds we use
#         the new file.  Otherwise, we use the old file.
# (2) We don't have a copy at all
#   (2a) If we are allowed to connect, we try to get a new copy.  If it succeeds,
#        we use it, otherwise, we warn about failure
#   (2b) If we aren't allowed to connect,

sub conf_sites {
    my %args = @_;
    # auto pick implies using the internet
    $CPAN::Config->{connect_to_internet_ok} = 1 if $args{auto_pick};

    my $m = 'MIRRORED.BY';
    my $mby = File::Spec->catfile($CPAN::Config->{keep_source_where},$m);
    File::Path::mkpath(File::Basename::dirname($mby));
    # Why are we using MIRRORED.BY from the current directory?
    # Is this for testing? -- dagolden, 2009-11-05
    if (-f $mby && -f $m && -M $m < -M $mby) {
        require File::Copy;
        File::Copy::copy($m,$mby) or die "Could not update $mby: $!";
    }
    local $^T = time;
    # if we have a cached copy is not older than 60 days, we either
    # use it or refresh it or fall back to it if the refresh failed.
    if ($mby && -f $mby && -s _ > 0 ) {
      my $very_old = (-M $mby > 60);
      my $mtime = localtime((stat _)[9]);
      # if auto_pick, refresh anything old automatically
      if ( $args{auto_pick} ) {
        if ( $very_old ) {
          $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n});
          eval { CPAN::FTP->localize($m,$mby,3,1) }
            or $CPAN::Frontend->myprint(qq{Refresh failed.  Using the old cached copy instead.\n});
          $CPAN::Frontend->myprint("\n");
        }
      }
      else {
        my $prompt = qq{Found a cached mirror list as of $mtime

If you'd like to just use the cached copy, answer 'yes', below.
If you'd like an updated copy of the mirror list, answer 'no' and
I'll get a fresh one from the Internet.

Shall I use the cached mirror list?};
        my $ans = prompt($prompt, $very_old ? "no" : "yes");
        if ($ans =~ /^n/i) {
          $CPAN::Frontend->myprint(qq{Trying to refresh your mirror list\n});
          # you asked for it from the Internet
          $CPAN::Config->{connect_to_internet_ok} = 1;
          eval { CPAN::FTP->localize($m,$mby,3,1) }
            or $CPAN::Frontend->myprint(qq{Refresh failed.  Using the old cached copy instead.\n});
          $CPAN::Frontend->myprint("\n");
        }
      }
    }
    # else there is no cached copy and we must fetch or fail
    else {
      # If they haven't agree to connect to the internet, ask again
      if ( ! $CPAN::Config->{connect_to_internet_ok} ) {
        my $prompt = q{You are missing a copy of the CPAN mirror list.

May I connect to the Internet to get it?};
        my $ans = prompt($prompt, "yes");
        if ($ans =~ /^y/i) {
          $CPAN::Config->{connect_to_internet_ok} = 1;
        }
      }

      # Now get it from the Internet or complain
      if ( $CPAN::Config->{connect_to_internet_ok} ) {
        $CPAN::Frontend->myprint(qq{Trying to fetch a mirror list from the Internet\n});
        eval { CPAN::FTP->localize($m,$mby,3,1) }
          or $CPAN::Frontend->mywarn(<<'HERE');
We failed to get a copy of the mirror list from the Internet.
You will need to provide CPAN mirror URLs yourself.
HERE
        $CPAN::Frontend->myprint("\n");
      }
      else {
        $CPAN::Frontend->mywarn(<<'HERE');
You will need to provide CPAN mirror URLs yourself or set
'o conf connect_to_internet_ok 1' and try again.
HERE
      }
    }

    # if we finally have a good local MIRRORED.BY, get on with picking
    if (-f $mby && -s _ > 0){
        $CPAN::Config->{urllist} =
          $args{auto_pick} ? auto_mirrored_by($mby) : choose_mirrored_by($mby);
        return 1;
    }

    return;
}

sub find_exe {
    my($exe,$path) = @_;
    $path ||= [split /$Config{'path_sep'}/, $ENV{'PATH'}];
    my($dir);
    #warn "in find_exe exe[$exe] path[@$path]";
    for $dir (@$path) {
        my $abs = File::Spec->catfile($dir,$exe);
        if (($abs = MM->maybe_command($abs))) {
            return $abs;
        }
    }
}

sub picklist {
    my($items,$prompt,$default,$require_nonempty,$empty_warning)=@_;
    CPAN->debug("picklist('$items','$prompt','$default','$require_nonempty',".
                "'$empty_warning')") if $CPAN::DEBUG;
    $default ||= '';

    my $pos = 0;

    my @nums;
  SELECTION: while (1) {

        # display, at most, 15 items at a time
        my $limit = $#{ $items } - $pos;
        $limit = 15 if $limit > 15;

        # show the next $limit items, get the new position
        $pos = display_some($items, $limit, $pos, $default);
        $pos = 0 if $pos >= @$items;

        my $num = prompt($prompt,$default);

        @nums = split (' ', $num);
        {
            my %seen;
            @nums = grep { !$seen{$_}++ } @nums;
        }
        my $i = scalar @$items;
        unrangify(\@nums);
        if (0 == @nums) {
            # cannot allow nothing because nothing means paging!
            # return;
        } elsif (grep (/\D/ || $_ < 1 || $_ > $i, @nums)) {
            $CPAN::Frontend->mywarn("invalid items entered, try again\n");
            if ("@nums" =~ /\D/) {
                $CPAN::Frontend->mywarn("(we are expecting only numbers between 1 and $i)\n");
            }
            next SELECTION;
        }
        if ($require_nonempty && !@nums) {
            $CPAN::Frontend->mywarn("$empty_warning\n");
        }

        # a blank line continues...
        unless (@nums){
            $CPAN::Frontend->mysleep(0.1); # prevent hot spinning process on the next bug
            next SELECTION;
        }
        last;
    }
    for (@nums) { $_-- }
    @{$items}[@nums];
}

sub unrangify ($) {
    my($nums) = $_[0];
    my @nums2 = ();
    while (@{$nums||[]}) {
        my $n = shift @$nums;
        if ($n =~ /^(\d+)-(\d+)$/) {
            my @range = $1 .. $2;
            # warn "range[@range]";
            push @nums2, @range;
        } else {
            push @nums2, $n;
        }
    }
    push @$nums, @nums2;
}

sub display_some {
    my ($items, $limit, $pos, $default) = @_;
    $pos ||= 0;

    my @displayable = @$items[$pos .. ($pos + $limit)];
    for my $item (@displayable) {
        $CPAN::Frontend->myprint(sprintf "(%d) %s\n", ++$pos, $item);
    }
    my $hit_what = $default ? "SPACE ENTER" : "ENTER";
    $CPAN::Frontend->myprint(sprintf("%d more items, hit %s to show them\n",
                                     (@$items - $pos),
                                     $hit_what,
                                    ))
        if $pos < @$items;
    return $pos;
}

sub auto_mirrored_by {
    my $local = shift or return;
    local $|=1;
    $CPAN::Frontend->myprint("Looking for CPAN mirrors near you (please be patient)\n");
    my $mirrors = CPAN::Mirrors->new($local);

    my $cnt = 0;
    my $callback_was_active = 0;
    my @best = $mirrors->best_mirrors(
      how_many => 3,
      callback => sub {
          $callback_was_active++;
          $CPAN::Frontend->myprint(".");
          if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); }
      },
      $CPAN::Config->{urllist_ping_external} ? (external_ping => 1) : (),
      $CPAN::Config->{urllist_ping_verbose} ? (verbose => 1) : (),
    );

    my $urllist = [
        map { $_->http }
        grep { $_ && ref $_ && $_->can('http') }
        @best
    ];
    push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}};
    $CPAN::Frontend->myprint(" done!\n\n") if $callback_was_active;

    return $urllist
}

sub choose_mirrored_by {
    my $local = shift or return;
    my ($default);
    my $mirrors = CPAN::Mirrors->new($local);
    my @previous_urls = @{$CPAN::Config->{urllist}};

    $CPAN::Frontend->myprint($prompts{urls_picker_intro});

    my (@cont, $cont, %cont, @countries, @urls, %seen);
    my $no_previous_warn =
        "Sorry! since you don't have any existing picks, you must make a\n" .
            "geographic selection.";
    my $offer_cont = [sort $mirrors->continents];
    if (@previous_urls) {
        push @$offer_cont, "(edit previous picks)";
        $default = @$offer_cont;
    } else {
        # cannot allow nothing because nothing means paging!
        # push @$offer_cont, "(none of the above)";
    }
    @cont = picklist($offer_cont,
                     "Select your continent (or several nearby continents)",
                     $default,
                     ! @previous_urls,
                     $no_previous_warn);
    # cannot allow nothing because nothing means paging!
    # return unless @cont;

    foreach $cont (@cont) {
        my @c = sort $mirrors->countries($cont);
        @cont{@c} = map ($cont, 0..$#c);
        @c = map ("$_ ($cont)", @c) if @cont > 1;
        push (@countries, @c);
    }
    if (@previous_urls && @countries) {
        push @countries, "(edit previous picks)";
        $default = @countries;
    }

    if (@countries) {
        @countries = picklist (\@countries,
                               "Select your country (or several nearby countries)",
                               $default,
                               ! @previous_urls,
                               $no_previous_warn);
        %seen = map (($_ => 1), @previous_urls);
        # hmmm, should take list of defaults from CPAN::Config->{'urllist'}...
        foreach my $country (@countries) {
            next if $country =~ /edit previous picks/;
            (my $bare_country = $country) =~ s/ \(.*\)//;
            my @u;
            for my $m ( $mirrors->mirrors($bare_country) ) {
              push @u, $m->ftp if $m->ftp;
              push @u, $m->http if $m->http;
            }
            @u = grep (! $seen{$_}, @u);
            @u = map ("$_ ($bare_country)", @u)
                if @countries > 1;
            push (@urls, sort @u);
        }
    }
    push (@urls, map ("$_ (previous pick)", @previous_urls));
    my $prompt = "Select as many URLs as you like (by number),
put them on one line, separated by blanks, hyphenated ranges allowed
 e.g. '1 4 5' or '7 1-4 8'";
    if (@previous_urls) {
        $default = join (' ', ((scalar @urls) - (scalar @previous_urls) + 1) ..
                         (scalar @urls));
        $prompt .= "\n(or just hit ENTER to keep your previous picks)";
    }

    @urls = picklist (\@urls, $prompt, $default);
    foreach (@urls) { s/ \(.*\)//; }
    return [ @urls ];
}

sub bring_your_own {
    my $urllist = [ @{$CPAN::Config->{urllist}} ];
    my %seen = map (($_ => 1), @$urllist);
    my($ans,@urls);
    my $eacnt = 0; # empty answers
    $CPAN::Frontend->myprint(<<'HERE');
Now you can enter your own CPAN URLs by hand. A local CPAN mirror can be
listed using a 'file:' URL like 'file:///path/to/cpan/'

HERE
    do {
        my $prompt = "Enter another URL or ENTER to quit:";
        unless (%seen) {
            $prompt = qq{CPAN.pm needs at least one URL where it can fetch CPAN files from.

Please enter your CPAN site:};
        }
        $ans = prompt ($prompt, "");

        if ($ans) {
            $ans =~ s|/?\z|/|; # has to end with one slash
            # XXX This manipulation is odd.  Shouldn't we check that $ans is
            # a directory before converting to file:///?  And we need /// below,
            # too, don't we?  -- dagolden, 2009-11-05
            $ans = "file:$ans" unless $ans =~ /:/; # without a scheme is a file:
            if ($ans =~ /^\w+:\/./) {
                push @urls, $ans unless $seen{$ans}++;
            } else {
                $CPAN::Frontend->
                    myprint(sprintf(qq{"%s" doesn\'t look like an URL at first sight.
I\'ll ignore it for now.
You can add it to your %s
later if you\'re sure it\'s right.\n},
                                   $ans,
                                   $INC{'CPAN/MyConfig.pm'}
                                   || $INC{'CPAN/Config.pm'}
                                   || "configuration file",
                                  ));
            }
        } else {
            if (++$eacnt >= 5) {
                $CPAN::Frontend->
                    mywarn("Giving up.\n");
                $CPAN::Frontend->mysleep(5);
                return;
            }
        }
    } while $ans || !%seen;

    @$urllist = CPAN::_uniq(@$urllist, @urls);
    $CPAN::Config->{urllist} = $urllist;
}

sub _print_urllist {
    my ($which) = @_;
    $CPAN::Frontend->myprint("$which urllist\n");
    for ( @{$CPAN::Config->{urllist} || []} ) {
      $CPAN::Frontend->myprint("  $_\n")
    };
}

sub _can_write_to_libdirs {
    return -w $Config{installprivlib}
        && -w $Config{installarchlib}
        && -w $Config{installsitelib}
        && -w $Config{installsitearch}
}

sub _using_installbase {
    return 1 if $ENV{PERL_MM_OPT} && $ENV{PERL_MM_OPT} =~ /install_base/i;
    return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /install_base/i }
        qw(makepl_arg make_install_arg mbuildpl_arg mbuild_install_arg);
    return;
}

sub _using_sudo {
    return 1 if grep { ($CPAN::Config->{$_}||q{}) =~ /sudo/ }
        qw(make_install_make_command mbuild_install_build_command);
    return;
}

sub _strip_spaces {
    $_[0] =~ s/^\s+//;  # no leading spaces
    $_[0] =~ s/\s+\z//; # no trailing spaces
}

sub prompt ($;$) {
    unless (defined &_real_prompt) {
        *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
    }
    my $ans = _real_prompt(@_);

    _strip_spaces($ans);
    $CPAN::Frontend->myprint("\n") unless $auto_config;

    return $ans;
}


sub prompt_no_strip ($;$) {
    unless (defined &_real_prompt) {
        *_real_prompt = \&CPAN::Shell::colorable_makemaker_prompt;
    }
    return _real_prompt(@_);
}


1;
PK     ü2]¬ÑñCvW  vW  	  Module.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Module;
use strict;
@CPAN::Module::ISA = qw(CPAN::InfoObj);

use vars qw(
            $VERSION
);
$VERSION = "5.5003";

BEGIN {
    # alarm() is not implemented in perl 5.6.x and earlier under Windows
    *ALARM_IMPLEMENTED = sub () { $] >= 5.007 || $^O !~ /MSWin/ };
}

# Accessors
#-> sub CPAN::Module::userid
sub userid {
    my $self = shift;
    my $ro = $self->ro;
    return unless $ro;
    return $ro->{userid} || $ro->{CPAN_USERID};
}
#-> sub CPAN::Module::description
sub description {
    my $self = shift;
    my $ro = $self->ro or return "";
    $ro->{description}
}

#-> sub CPAN::Module::distribution
sub distribution {
    my($self) = @_;
    CPAN::Shell->expand("Distribution",$self->cpan_file);
}

#-> sub CPAN::Module::_is_representative_module
sub _is_representative_module {
    my($self) = @_;
    return $self->{_is_representative_module} if defined $self->{_is_representative_module};
    my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
    $pm =~ s|.+/||;
    $pm =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i; # see base_id
    $pm =~ s|-\d+\.\d+.+$||;
    $pm =~ s|-[\d\.]+$||;
    $pm =~ s/-/::/g;
    $self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
    # warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
    $self->{_is_representative_module};
}

#-> sub CPAN::Module::undelay
sub undelay {
    my $self = shift;
    delete $self->{later};
    if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
        $dist->undelay;
    }
}

# mark as dirty/clean
#-> sub CPAN::Module::color_cmd_tmps ;
sub color_cmd_tmps {
    my($self) = shift;
    my($depth) = shift || 0;
    my($color) = shift || 0;
    my($ancestors) = shift || [];
    # a module needs to recurse to its cpan_file

    return if exists $self->{incommandcolor}
        && $color==1
        && $self->{incommandcolor}==$color;
    return if $color==0 && !$self->{incommandcolor};
    if ($color>=1) {
        if ( $self->uptodate ) {
            $self->{incommandcolor} = $color;
            return;
        } elsif (my $have_version = $self->available_version) {
            # maybe what we have is good enough
            if (@$ancestors) {
                my $who_asked_for_me = $ancestors->[-1];
                my $obj = CPAN::Shell->expandany($who_asked_for_me);
                if (0) {
                } elsif ($obj->isa("CPAN::Bundle")) {
                    # bundles cannot specify a minimum version
                    return;
                } elsif ($obj->isa("CPAN::Distribution")) {
                    if (my $prereq_pm = $obj->prereq_pm) {
                        for my $k (keys %$prereq_pm) {
                            if (my $want_version = $prereq_pm->{$k}{$self->id}) {
                                if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
                                    $self->{incommandcolor} = $color;
                                    return;
                                }
                            }
                        }
                    }
                }
            }
        }
    } else {
        $self->{incommandcolor} = $color; # set me before recursion,
                                          # so we can break it
    }
    if ($depth>=$CPAN::MAX_RECURSION) {
        my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
        if ($e->is_resolvable) {
            return $self->{incommandcolor}=2;
        } else {
            die $e;
        }
    }
    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;

    if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
        $dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
    }
    # unreached code?
    # if ($color==0) {
    #    delete $self->{badtestcnt};
    # }
    $self->{incommandcolor} = $color;
}

#-> sub CPAN::Module::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    my $color_on = "";
    my $color_off = "";
    if (
        $CPAN::Shell::COLOR_REGISTERED
        &&
        $CPAN::META->has_inst("Term::ANSIColor")
        &&
        $self->description
       ) {
        $color_on = Term::ANSIColor::color("green");
        $color_off = Term::ANSIColor::color("reset");
    }
    my $uptodateness = " ";
    unless ($class eq "Bundle") {
        my $u = $self->uptodate;
        $uptodateness = $u ? "=" : "<" if defined $u;
    };
    my $id = do {
        my $d = $self->distribution;
        $d ? $d -> pretty_id : $self->cpan_userid;
    };
    push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
                     $class,
                     $uptodateness,
                     $color_on,
                     $self->id,
                     $color_off,
                     $id,
                    );
    join "", @m;
}

#-> sub CPAN::Module::dslip_status
sub dslip_status {
    my($self) = @_;
    my($stat);
    # development status
    @{$stat->{D}}{qw,i c a b R M S,}     = qw,idea
                                              pre-alpha alpha beta released
                                              mature standard,;
    # support level
    @{$stat->{S}}{qw,m d u n a,}         = qw,mailing-list
                                              developer comp.lang.perl.*
                                              none abandoned,;
    # language
    @{$stat->{L}}{qw,p c + o h,}         = qw,perl C C++ other hybrid,;
    # interface
    @{$stat->{I}}{qw,f r O p h n,}       = qw,functions
                                              references+ties
                                              object-oriented pragma
                                              hybrid none,;
    # public licence
    @{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
                                              GPL LGPL
                                              BSD Artistic Artistic_2
                                              open-source
                                              distribution_allowed
                                              restricted_distribution
                                              no_licence,;
    for my $x (qw(d s l i p)) {
        $stat->{$x}{' '} = 'unknown';
        $stat->{$x}{'?'} = 'unknown';
    }
    my $ro = $self->ro;
    return +{} unless $ro && $ro->{statd};
    return {
            D  => $ro->{statd},
            S  => $ro->{stats},
            L  => $ro->{statl},
            I  => $ro->{stati},
            P  => $ro->{statp},
            DV => $stat->{D}{$ro->{statd}},
            SV => $stat->{S}{$ro->{stats}},
            LV => $stat->{L}{$ro->{statl}},
            IV => $stat->{I}{$ro->{stati}},
            PV => $stat->{P}{$ro->{statp}},
           };
}

#-> sub CPAN::Module::as_string ;
sub as_string {
    my($self) = @_;
    my(@m);
    CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    local($^W) = 0;
    push @m, $class, " id = $self->{ID}\n";
    my $sprintf = "    %-12s %s\n";
    push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
        if $self->description;
    my $sprintf2 = "    %-12s %s (%s)\n";
    my($userid);
    $userid = $self->userid;
    if ( $userid ) {
        my $author;
        if ($author = CPAN::Shell->expand('Author',$userid)) {
            my $email = "";
            my $m; # old perls
            if ($m = $author->email) {
                $email = " <$m>";
            }
            push @m, sprintf(
                             $sprintf2,
                             'CPAN_USERID',
                             $userid,
                             $author->fullname . $email
                            );
        }
    }
    push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
        if $self->cpan_version;
    if (my $cpan_file = $self->cpan_file) {
        push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
        if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
            my $upload_date = $dist->upload_date;
            if ($upload_date) {
                push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
            }
        }
    }
    my $sprintf3 = "    %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
    my $dslip = $self->dslip_status;
    push @m, sprintf(
                     $sprintf3,
                     'DSLIP_STATUS',
                     @{$dslip}{qw(D S L I P DV SV LV IV PV)},
                    ) if $dslip->{D};
    my $local_file = $self->inst_file;
    unless ($self->{MANPAGE}) {
        my $manpage;
        if ($local_file) {
            $manpage = $self->manpage_headline($local_file);
        } else {
            # If we have already untarred it, we should look there
            my $dist = $CPAN::META->instance('CPAN::Distribution',
                                             $self->cpan_file);
            # warn "dist[$dist]";
            # mff=manifest file; mfh=manifest handle
            my($mff,$mfh);
            if (
                $dist->{build_dir}
                and
                (-f  ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
                and
                $mfh = FileHandle->new($mff)
               ) {
                CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
                my $lfre = $self->id; # local file RE
                $lfre =~ s/::/./g;
                $lfre .= "\\.pm\$";
                my($lfl); # local file file
                local $/ = "\n";
                my(@mflines) = <$mfh>;
                for (@mflines) {
                    s/^\s+//;
                    s/\s.*//s;
                }
                while (length($lfre)>5 and !$lfl) {
                    ($lfl) = grep /$lfre/, @mflines;
                    CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
                    $lfre =~ s/.+?\.//;
                }
                $lfl =~ s/\s.*//; # remove comments
                $lfl =~ s/\s+//g; # chomp would maybe be too system-specific
                my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
                # warn "lfl_abs[$lfl_abs]";
                if (-f $lfl_abs) {
                    $manpage = $self->manpage_headline($lfl_abs);
                }
            }
        }
        $self->{MANPAGE} = $manpage if $manpage;
    }
    my($item);
    for $item (qw/MANPAGE/) {
        push @m, sprintf($sprintf, $item, $self->{$item})
            if exists $self->{$item};
    }
    for $item (qw/CONTAINS/) {
        push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
            if exists $self->{$item} && @{$self->{$item}};
    }
    push @m, sprintf($sprintf, 'INST_FILE',
                     $local_file || "(not installed)");
    push @m, sprintf($sprintf, 'INST_VERSION',
                     $self->inst_version) if $local_file;
    if (%{$CPAN::META->{is_tested}||{}}) { # XXX needs to be methodified somehow
        my $available_file = $self->available_file;
        if ($available_file && $available_file ne $local_file) {
            push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
            push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
        }
    }
    join "", @m, "\n";
}

#-> sub CPAN::Module::manpage_headline
sub manpage_headline {
    my($self,$local_file) = @_;
    my(@local_file) = $local_file;
    $local_file =~ s/\.pm(?!\n)\Z/.pod/;
    push @local_file, $local_file;
    my(@result,$locf);
    for $locf (@local_file) {
        next unless -f $locf;
        my $fh = FileHandle->new($locf)
            or $Carp::Frontend->mydie("Couldn't open $locf: $!");
        my $inpod = 0;
        local $/ = "\n";
        while (<$fh>) {
            $inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
                m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
            next unless $inpod;
            next if /^=/;
            next if /^\s+$/;
            chomp;
            push @result, $_;
        }
        close $fh;
        last if @result;
    }
    for (@result) {
        s/^\s+//;
        s/\s+$//;
    }
    join " ", @result;
}

#-> sub CPAN::Module::cpan_file ;
# Note: also inherited by CPAN::Bundle
sub cpan_file {
    my $self = shift;
    # CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
    unless ($self->ro) {
        CPAN::Index->reload;
    }
    my $ro = $self->ro;
    if ($ro && defined $ro->{CPAN_FILE}) {
        return $ro->{CPAN_FILE};
    } else {
        my $userid = $self->userid;
        if ( $userid ) {
            if ($CPAN::META->exists("CPAN::Author",$userid)) {
                my $author = $CPAN::META->instance("CPAN::Author",
                                                   $userid);
                my $fullname = $author->fullname;
                my $email = $author->email;
                unless (defined $fullname && defined $email) {
                    return sprintf("Contact Author %s",
                                   $userid,
                                  );
                }
                return "Contact Author $fullname <$email>";
            } else {
                return "Contact Author $userid (Email address not available)";
            }
        } else {
            return "N/A";
        }
    }
}

#-> sub CPAN::Module::cpan_version ;
sub cpan_version {
    my $self = shift;

    my $ro = $self->ro;
    unless ($ro) {
        # Can happen with modules that are not on CPAN
        $ro = {};
    }
    $ro->{CPAN_VERSION} = 'undef'
        unless defined $ro->{CPAN_VERSION};
    $ro->{CPAN_VERSION};
}

#-> sub CPAN::Module::force ;
sub force {
    my($self) = @_;
    $self->{force_update} = 1;
}

#-> sub CPAN::Module::fforce ;
sub fforce {
    my($self) = @_;
    $self->{force_update} = 2;
}

#-> sub CPAN::Module::notest ;
sub notest {
    my($self) = @_;
    # $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
    $self->{notest}++;
}

#-> sub CPAN::Module::rematein ;
sub rematein {
    my($self,$meth) = @_;
    $CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
                                     $meth,
                                     $self->id));
    my $cpan_file = $self->cpan_file;
    if ($cpan_file eq "N/A" || $cpan_file =~ /^Contact Author/) {
        $CPAN::Frontend->mywarn(sprintf qq{
  The module %s isn\'t available on CPAN.

  Either the module has not yet been uploaded to CPAN, or it is
  temporary unavailable. Please contact the author to find out
  more about the status. Try 'i %s'.
},
                                $self->id,
                                $self->id,
                               );
        return;
    }
    my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
    $pack->called_for($self->id);
    if (exists $self->{force_update}) {
        if ($self->{force_update} == 2) {
            $pack->fforce($meth);
        } else {
            $pack->force($meth);
        }
    }
    $pack->notest($meth) if exists $self->{notest} && $self->{notest};

    $pack->{reqtype} ||= "";
    CPAN->debug("dist-reqtype[$pack->{reqtype}]".
                "self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
        if ($pack->{reqtype}) {
            if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
                $pack->{reqtype} = $self->{reqtype};
                if (
                    exists $pack->{install}
                    &&
                    (
                     UNIVERSAL::can($pack->{install},"failed") ?
                     $pack->{install}->failed :
                     $pack->{install} =~ /^NO/
                    )
                   ) {
                    delete $pack->{install};
                    $CPAN::Frontend->mywarn
                        ("Promoting $pack->{ID} from 'build_requires' to 'requires'");
                }
            }
        } else {
            $pack->{reqtype} = $self->{reqtype};
        }

    my $success = eval {
        $pack->$meth();
    };
    my $err = $@;
    $pack->unforce if $pack->can("unforce") && exists $self->{force_update};
    $pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
    delete $self->{force_update};
    delete $self->{notest};
    if ($err) {
        die $err;
    }
    return $success;
}

#-> sub CPAN::Module::perldoc ;
sub perldoc { shift->rematein('perldoc') }
#-> sub CPAN::Module::readme ;
sub readme  { shift->rematein('readme') }
#-> sub CPAN::Module::look ;
sub look    { shift->rematein('look') }
#-> sub CPAN::Module::cvs_import ;
sub cvs_import { shift->rematein('cvs_import') }
#-> sub CPAN::Module::get ;
sub get     { shift->rematein('get',@_) }
#-> sub CPAN::Module::make ;
sub make    { shift->rematein('make') }
#-> sub CPAN::Module::test ;
sub test   {
    my $self = shift;
    # $self->{badtestcnt} ||= 0;
    $self->rematein('test',@_);
}

#-> sub CPAN::Module::deprecated_in_core ;
sub deprecated_in_core {
    my ($self) = @_;
    return unless $CPAN::META->has_inst('Module::CoreList') && Module::CoreList->can('is_deprecated');
    return Module::CoreList::is_deprecated($self->{ID});
}

#-> sub CPAN::Module::inst_deprecated;
# Indicates whether the *installed* version of the module is a deprecated *and*
# installed as part of the Perl core library path
sub inst_deprecated {
    my ($self) = @_;
    my $inst_file = $self->inst_file or return;
    return $self->deprecated_in_core && $self->_in_priv_or_arch($inst_file);
}

#-> sub CPAN::Module::uptodate ;
sub uptodate {
    my ($self) = @_;
    local ($_);
    my $inst = $self->inst_version or return 0;
    my $cpan = $self->cpan_version;
    return 0 if CPAN::Version->vgt($cpan,$inst) || $self->inst_deprecated;
    CPAN->debug
        (join
         ("",
          "returning uptodate. ",
          "cpan[$cpan]inst[$inst]",
         )) if $CPAN::DEBUG;
    return 1;
}

# returns true if installed in privlib or archlib
sub _in_priv_or_arch {
    my($self,$inst_file) = @_;
    foreach my $pair (
        [qw(sitearchexp archlibexp)],
        [qw(sitelibexp privlibexp)]
    ) {
        my ($site, $priv) = @Config::Config{@$pair};
        if ($^O eq 'VMS') {
            for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) };
        }
        s!/*$!!g foreach $site, $priv;
        next if $site eq $priv;

        if ($priv eq substr($inst_file,0,length($priv))) {
            return 1;
        }
    }
    return 0;
}

#-> sub CPAN::Module::install ;
sub install {
    my($self) = @_;
    my($doit) = 0;
    if ($self->uptodate
        &&
        not exists $self->{force_update}
       ) {
        $CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
                                         $self->id,
                                         $self->inst_version,
                                        ));
    } else {
        $doit = 1;
    }
    my $ro = $self->ro;
    if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
        $CPAN::Frontend->mywarn(qq{
\n\n\n     ***WARNING***
     The module $self->{ID} has no active maintainer (CPAN support level flag 'abandoned').\n\n\n
});
        $CPAN::Frontend->mysleep(5);
    }
    return $doit ? $self->rematein('install') : 1;
}
#-> sub CPAN::Module::clean ;
sub clean  { shift->rematein('clean') }

#-> sub CPAN::Module::inst_file ;
sub inst_file {
    my($self) = @_;
    $self->_file_in_path([@INC]);
}

#-> sub CPAN::Module::available_file ;
sub available_file {
    my($self) = @_;
    my $sep = $Config::Config{path_sep};
    my $perllib = $ENV{PERL5LIB};
    $perllib = $ENV{PERLLIB} unless defined $perllib;
    my @perllib = split(/$sep/,$perllib) if defined $perllib;
    my @cpan_perl5inc;
    if ($CPAN::Perl5lib_tempfile) {
        my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
        @cpan_perl5inc = @{$yaml->[0]{inc} || []};
    }
    $self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
}

#-> sub CPAN::Module::file_in_path ;
sub _file_in_path {
    my($self,$path) = @_;
    my($dir,@packpath);
    @packpath = split /::/, $self->{ID};
    $packpath[-1] .= ".pm";
    if (@packpath == 1 && $packpath[0] eq "readline.pm") {
        unshift @packpath, "Term", "ReadLine"; # historical reasons
    }
    foreach $dir (@$path) {
        my $pmfile = File::Spec->catfile($dir,@packpath);
        if (-f $pmfile) {
            return $pmfile;
        }
    }
    return;
}

#-> sub CPAN::Module::xs_file ;
sub xs_file {
    my($self) = @_;
    my($dir,@packpath);
    @packpath = split /::/, $self->{ID};
    push @packpath, $packpath[-1];
    $packpath[-1] .= "." . $Config::Config{'dlext'};
    foreach $dir (@INC) {
        my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
        if (-f $xsfile) {
            return $xsfile;
        }
    }
    return;
}

#-> sub CPAN::Module::inst_version ;
sub inst_version {
    my($self) = @_;
    my $parsefile = $self->inst_file or return;
    my $have = $self->parse_version($parsefile);
    $have;
}

#-> sub CPAN::Module::inst_version ;
sub available_version {
    my($self) = @_;
    my $parsefile = $self->available_file or return;
    my $have = $self->parse_version($parsefile);
    $have;
}

#-> sub CPAN::Module::parse_version ;
sub parse_version {
    my($self,$parsefile) = @_;
    if (ALARM_IMPLEMENTED) {
        my $timeout = (exists($CPAN::Config{'version_timeout'}))
                            ? $CPAN::Config{'version_timeout'}
                            : 15;
        alarm($timeout);
    }
    my $have = eval {
        local $SIG{ALRM} = sub { die "alarm\n" };
        MM->parse_version($parsefile);
    };
    if ($@) {
        $CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
    }
    alarm(0) if ALARM_IMPLEMENTED;
    my $leastsanity = eval { defined $have && length $have; };
    $have = "undef" unless $leastsanity;
    $have =~ s/^ //; # since the %vd hack these two lines here are needed
    $have =~ s/ $//; # trailing whitespace happens all the time

    $have = CPAN::Version->readable($have);

    $have =~ s/\s*//g; # stringify to float around floating point issues
    $have; # no stringify needed, \s* above matches always
}

#-> sub CPAN::Module::reports
sub reports {
    my($self) = @_;
    $self->distribution->reports;
}

1;
PK     ü2]”ƒBo  o    Admin.pmnu ÏÃ6Ç$        package CPAN::Admin;
use base CPAN;
use CPAN; # old base.pm did not load CPAN on previous line
use strict;
use vars qw(@EXPORT $VERSION);
use constant PAUSE_IP => "pause.perl.org";

@EXPORT = qw(shell);
$VERSION = "5.501";
push @CPAN::Complete::COMMANDS, qw(register modsearch);
$CPAN::Shell::COLOR_REGISTERED = 1;

sub shell {
    CPAN::shell($_[0]||"admin's cpan> ",$_[1]);
}

sub CPAN::Shell::register {
    my($self,$mod,@rest) = @_;
    unless ($mod) {
        print "register called without argument\n";
        return;
    }
    if ($CPAN::META->has_inst("URI::Escape")) {
        require URI::Escape;
    } else {
        print "register requires URI::Escape installed, otherwise it cannot work\n";
        return;
    }
    print "Got request for mod[$mod]\n";
    if (@rest) {
        my $modline = join " ", $mod, @rest;
        print "Sending to PAUSE [$modline]\n";
        my $emodline = URI::Escape::uri_escape($modline, '^\w ');
        $emodline =~ s/ /+/g;
        my $url =
            sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
                    "%s;SUBMIT_pause99_add_mod_hint=hint",
                    PAUSE_IP,
                    $emodline,
                   );
        print "url[$url]\n\n";
        print ">>>>Trying to open a netscape window<<<<\n";
        sleep 1;
        system("netscape","-remote","openURL($url)");
        return;
    }
    my $m = CPAN::Shell->expand("Module",$mod);
    unless (ref $m) {
        print "Could not determine the object for $mod\n";
        return;
    }
    my $id = $m->id;
    print "Found module id[$id] in database\n";

    if (exists $m->{RO} && $m->{RO}{chapterid}) {
        print "$id is already registered\n";
        return;
    }

    my(@namespace) = split /::/, $id;
    my $rootns = $namespace[0];

    # Tk, XML and Apache need special treatment
    if ($rootns=~/^(Bundle)\b/) {
        print "Bundles are not yet ready for registering\n";
        return;
    }

    # make a good suggestion for the chapter
    my(@simile) = CPAN::Shell->expand("Module","/^$rootns(:|\$)/");
    print "Found within this namespace ", join(", ", map { $_->id } @simile), "\n";
    my(%seench);
    for my $ch (map { exists $_->{RO} ? $_->{RO}{chapterid} : ""} @simile) {
        next unless $ch;
        $seench{$ch}=undef;
    }
    my(@seench) = sort grep {length($_)} keys %seench;
    my $reco_ch = "";
    if (@seench>1) {
        print "Found rootnamespace[$rootns] in the chapters [", join(", ", @seench), "]\n";
        $reco_ch = $seench[0];
        print "Picking $reco_ch\n";
    } elsif (@seench==1) {
        print "Found rootnamespace[$rootns] in the chapter[$seench[0]]\n";
        $reco_ch = $seench[0];
    } else {
        print "The new rootnamespace[$rootns] needs to be introduced. Oh well.\n";
    }

    # Look closer at the dist
    my $d = CPAN::Shell->expand("Distribution", $m->cpan_file);
    printf "Module comes with dist[%s]\n", $d->id;
    for my $contm ($d->containsmods) {
        if ($CPAN::META->exists("CPAN::Module",$contm)) {
            my $contm_obj = CPAN::Shell->expand("Module",$contm) or next;
            my $is_reg = exists $contm_obj->{RO} && $contm_obj->{RO}{description};
            printf(" in same dist: %s%s\n",
                   $contm,
                   $is_reg ? " already in modulelist" : "",
                  );
        }
    }

    # get it so that m is better and we can inspect for XS
    CPAN::Shell->get($id);
    CPAN::Shell->m($id);
    CPAN::Shell->d($d->id);

    my $has_xs = 0;
    {
        my($mani,@mani);
        local $/ = "\n";
        open $mani, "$d->{build_dir}/MANIFEST" and @mani = <$mani>;
        my @xs = grep /\.xs\b/, @mani;
        if (@xs) {
            print "Found XS files: @xs";
            $has_xs=1;
        }
    }
    my $emodid = URI::Escape::uri_escape($id, '\W');
    my $ech = $reco_ch;
    $ech =~ s/ /+/g;
    my $description = $m->{MANPAGE} || "";
    $description =~ s/[A-Z]<//; # POD markup (and maybe more)
    $description =~ s/^\s+//; # leading spaces
    $description =~ s/>//; # POD
    $description =~ s/^\Q$id\E//; # usually this line starts with the modid
    $description =~ s/^[ \-]+//; # leading spaces and dashes
    substr($description,44) = "" if length($description)>44;
    $description = ucfirst($description);
    my $edescription = URI::Escape::uri_escape($description, '^\w ');
    $edescription =~ s/ /+/g;
    my $url =
        sprintf("https://%s/pause/authenquery?pause99_add_mod_modid=".
                "%s;pause99_add_mod_chapterid=%s;pause99_add_mod_statd=%s;".
                "pause99_add_mod_stats=%s;pause99_add_mod_statl=%s;".
                "pause99_add_mod_stati=%s;pause99_add_mod_description=%s;".
                "pause99_add_mod_userid=%s;SUBMIT_pause99_add_mod_preview=preview",
                PAUSE_IP,
                $emodid,
                $ech,
                "R",
                "d",
                $has_xs ? "c" : "p",
                "O",
                $edescription,
                $m->{RO}{CPAN_USERID},
               );
    print "$url\n\n";
    print ">>>>Trying to open a netscape window<<<<\n";
    system("netscape","-remote","openURL($url)");
}

sub CPAN::Shell::modsearch {
    my($self,@line) = @_;
    unless (@line) {
        print "modsearch called without argument\n";
        return;
    }
    my $request = join " ", @line;
    print "Got request[$request]\n";
    my $erequest = URI::Escape::uri_escape($request, '^\w ');
    $erequest =~ s/ /+/g;
    my $url =
        sprintf("http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=%s".
                "&errors=0&case=on&maxfiles=100&maxlines=30",
                $erequest,
               );
    print "$url\n\n";
    print ">>>>Trying to open a netscape window<<<<\n";
    system("netscape","-remote","openURL('$url')");
}

1;

__END__

=head1 NAME

 CPAN::Admin - A CPAN Shell for CPAN admins

=head1 SYNOPSIS

 perl -MCPAN::Admin -e shell

=head1 STATUS

Note: this module is currently not maintained. If you need it and fix
it for your needs, please submit patches.

=head1 DESCRIPTION

CPAN::Admin is a subclass of CPAN that adds the commands C<register>
and C<modsearch> to the CPAN shell.

C<register> calls C<get> on the named module, assembles a couple of
informations (description, language), and calls Netscape with the
-remote argument so that a form is filled with all the assembled
informations and the registration can be performed with a single
click. If the command line has more than one argument, register does
not run a C<get>, instead it interprets the rest of the line as DSLI
status, description, and userid and sends them to netscape such that
the form is again mostly filled and can be edited or confirmed with a
single click. CPAN::Admin never performs the submission click for you,
it is only intended to fill in the form on PAUSE and leave the
confirmation to you.

C<modsearch> simply passes the arguments to the search engine for the
modules@perl.org mailing list at L<http://www.xray.mpe.mpg.de> where all
registration requests are stored. It does so in the same way as
register, namely with the C<netscape -remote> command.

An experimental feature has also been added, namely to color already
registered modules in listings. If you have L<Term::ANSIColor> installed,
the u, r, and m commands will show already registered modules in
green.

=head1 PREREQUISITES

L<URI::Escape>, a browser available in the path, the browser must
understand the -remote switch (as far as I know, this is only
available on UNIX); coloring of registered modules is only available
if L<Term::ANSIColor> is installed.

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
PK     ü2]hz.Î·Â  ·Â    FTP.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::FTP;
use strict;

use Errno ();
use Fcntl qw(:flock);
use File::Basename qw(dirname);
use File::Path qw(mkpath);
use CPAN::FTP::netrc;
use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod);

@CPAN::FTP::ISA = qw(CPAN::Debug);

use vars qw(
            $VERSION
);
$VERSION = "5.5016";

sub _plus_append_open {
    my($fh, $file) = @_;
    my $parent_dir = dirname $file;
    mkpath $parent_dir;
    my($cnt);
    until (open $fh, "+>>$file") {
        next if exists &Errno::EAGAIN && $! == &Errno::EAGAIN; # don't increment on EAGAIN
        $CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000;
        sleep 0.0001;
        mkpath $parent_dir;
    }
}

#-> sub CPAN::FTP::ftp_statistics
# if they want to rewrite, they need to pass in a filehandle
sub _ftp_statistics {
    my($self,$fh) = @_;
    my $ftpstats_size = $CPAN::Config->{ftpstats_size};
    return if defined $ftpstats_size && $ftpstats_size <= 0;
    my $locktype = $fh ? LOCK_EX : LOCK_SH;
    # XXX On Windows flock() implements mandatory locking, so we can
    # XXX only use shared locking to still allow _yaml_loadfile() to
    # XXX read from the file using a different filehandle.
    $locktype = LOCK_SH if $^O eq "MSWin32";

    $fh ||= FileHandle->new;
    my $file = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
    _plus_append_open($fh,$file);
    my $sleep = 1;
    my $waitstart;
    while (!CPAN::_flock($fh, $locktype|LOCK_NB)) {
        $waitstart ||= localtime();
        if ($sleep>3) {
            my $now = localtime();
            $CPAN::Frontend->mywarn("$now: waiting for read lock on '$file' (since $waitstart)\n");
        }
        sleep($sleep); # this sleep must not be overridden;
                       # Frontend->mysleep with AUTOMATED_TESTING has
                       # provoked complete lock contention on my NFS
        if ($sleep <= 6) {
            $sleep+=0.5;
        } else {
            # retry to get a fresh handle. If it is NFS and the handle is stale, we will never get an flock
            _plus_append_open($fh, $file);
        }
    }
    my $stats = eval { CPAN->_yaml_loadfile($file, {loadblessed => 1}); };
    if ($@) {
        if (ref $@) {
            if (ref $@ eq "CPAN::Exception::yaml_not_installed") {
                chomp $@;
                $CPAN::Frontend->myprintonce("Warning (usually harmless): $@\n");
                return;
            } elsif (ref $@ eq "CPAN::Exception::yaml_process_error") {
                my $time = time;
                my $to = "$file.$time";
                $CPAN::Frontend->mywarn("Error reading '$file': $@
  Trying to stash it away as '$to' to prevent further interruptions.
  You may want to remove that file later.\n");
                # may fail because somebody else has moved it away in the meantime:
                rename $file, $to or $CPAN::Frontend->mywarn("Could not rename '$file' to '$to': $!\n");
                return;
            }
        } else {
            $CPAN::Frontend->mydie($@);
        }
    }
    CPAN::_flock($fh, LOCK_UN);
    return $stats->[0];
}

#-> sub CPAN::FTP::_mytime
sub _mytime () {
    if (CPAN->has_inst("Time::HiRes")) {
        return Time::HiRes::time();
    } else {
        return time;
    }
}

#-> sub CPAN::FTP::_new_stats
sub _new_stats {
    my($self,$file) = @_;
    my $ret = {
               file => $file,
               attempts => [],
               start => _mytime,
              };
    $ret;
}

#-> sub CPAN::FTP::_add_to_statistics
sub _add_to_statistics {
    my($self,$stats) = @_;
    my $yaml_module = CPAN::_yaml_module();
    $self->debug("yaml_module[$yaml_module]") if $CPAN::DEBUG;
    if ($CPAN::META->has_inst($yaml_module)) {
        $stats->{thesiteurl} = $ThesiteURL;
        $stats->{end} = CPAN::FTP::_mytime();
        my $fh = FileHandle->new;
        my $time = time;
        my $sdebug = 0;
        my @debug;
        @debug = $time if $sdebug;
        my $fullstats = $self->_ftp_statistics($fh);
        close $fh if $fh && defined(fileno($fh));
        $fullstats->{history} ||= [];
        push @debug, scalar @{$fullstats->{history}} if $sdebug;
        push @debug, time if $sdebug;
        push @{$fullstats->{history}}, $stats;
        # YAML.pm 0.62 is unacceptably slow with 999;
        # YAML::Syck 0.82 has no noticable performance problem with 999;
        my $ftpstats_size = $CPAN::Config->{ftpstats_size};
        $ftpstats_size = 99 unless defined $ftpstats_size;
        my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14;
        while (
               @{$fullstats->{history} || []}
               &&
               (
                @{$fullstats->{history}} > $ftpstats_size
                || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period
               )
              ) {
            shift @{$fullstats->{history}}
        }
        push @debug, scalar @{$fullstats->{history}} if $sdebug;
        push @debug, time if $sdebug;
        push @debug, scalar localtime($fullstats->{history}[0]{start}) if $sdebug;
        # need no eval because if this fails, it is serious
        my $sfile = File::Spec->catfile($CPAN::Config->{cpan_home},"FTPstats.yml");
        CPAN->_yaml_dumpfile("$sfile.$$",$fullstats);
        if ( $sdebug ) {
            local $CPAN::DEBUG = 512; # FTP
            push @debug, time;
            CPAN->debug(sprintf("DEBUG history: before_read[%d]before[%d]at[%d]".
                                "after[%d]at[%d]oldest[%s]dumped backat[%d]",
                                @debug,
                               ));
        }
        # Win32 cannot rename a file to an existing filename
        unlink($sfile) if ($^O eq 'MSWin32' or $^O eq 'os2');
	_copy_stat($sfile, "$sfile.$$") if -e $sfile;
        rename "$sfile.$$", $sfile
            or $CPAN::Frontend->mywarn("Could not rename '$sfile.$$' to '$sfile': $!\nGiving up\n");
    }
}

# Copy some stat information (owner, group, mode and) from one file to
# another.
# This is a utility function which might be moved to a utility repository.
#-> sub CPAN::FTP::_copy_stat
sub _copy_stat {
    my($src, $dest) = @_;
    my @stat = stat($src);
    if (!@stat) {
	$CPAN::Frontend->mywarn("Can't stat '$src': $!\n");
	return;
    }

    eval {
	chmod $stat[2], $dest
	    or $CPAN::Frontend->mywarn("Can't chmod '$dest' to " . sprintf("0%o", $stat[2]) . ": $!\n");
    };
    warn $@ if $@;
    eval {
	chown $stat[4], $stat[5], $dest
	    or do {
		my $save_err = $!; # otherwise it's lost in the get... calls
		$CPAN::Frontend->mywarn("Can't chown '$dest' to " .
					(getpwuid($stat[4]))[0] . "/" .
					(getgrgid($stat[5]))[0] . ": $save_err\n"
				       );
	    };
    };
    warn $@ if $@;
}

# if file is CHECKSUMS, suggest the place where we got the file to be
# checked from, maybe only for young files?
#-> sub CPAN::FTP::_recommend_url_for
sub _recommend_url_for {
    my($self, $file, $urllist) = @_;
    if ($file =~ s|/CHECKSUMS(.gz)?$||) {
        my $fullstats = $self->_ftp_statistics();
        my $history = $fullstats->{history} || [];
        while (my $last = pop @$history) {
            last if $last->{end} - time > 3600; # only young results are interesting
            next unless $last->{file}; # dirname of nothing dies!
            next unless $file eq dirname($last->{file});
            return $last->{thesiteurl};
        }
    }
    if ($CPAN::Config->{randomize_urllist}
        &&
        rand(1) < $CPAN::Config->{randomize_urllist}
       ) {
        $urllist->[int rand scalar @$urllist];
    } else {
        return ();
    }
}

#-> sub CPAN::FTP::_get_urllist
sub _get_urllist {
    my($self, $with_defaults) = @_;
    $with_defaults ||= 0;
    CPAN->debug("with_defaults[$with_defaults]") if $CPAN::DEBUG;

    $CPAN::Config->{urllist} ||= [];
    unless (ref $CPAN::Config->{urllist} eq 'ARRAY') {
        $CPAN::Frontend->mywarn("Malformed urllist; ignoring.  Configuration file corrupt?\n");
        $CPAN::Config->{urllist} = [];
    }
    my @urllist = grep { defined $_ and length $_ } @{$CPAN::Config->{urllist}};
    push @urllist, @CPAN::Defaultsites if $with_defaults;
    for my $u (@urllist) {
        CPAN->debug("u[$u]") if $CPAN::DEBUG;
        if (UNIVERSAL::can($u,"text")) {
            $u->{TEXT} .= "/" unless substr($u->{TEXT},-1) eq "/";
        } else {
            $u .= "/" unless substr($u,-1) eq "/";
            $u = CPAN::URL->new(TEXT => $u, FROM => "USER");
        }
    }
    \@urllist;
}

#-> sub CPAN::FTP::ftp_get ;
sub ftp_get {
    my($class,$host,$dir,$file,$target) = @_;
    $class->debug(
                  qq[Going to fetch file [$file] from dir [$dir]
        on host [$host] as local [$target]\n]
                 ) if $CPAN::DEBUG;
    my $ftp = Net::FTP->new($host);
    unless ($ftp) {
        $CPAN::Frontend->mywarn("  Could not connect to host '$host' with Net::FTP\n");
        return;
    }
    return 0 unless defined $ftp;
    $ftp->debug(1) if $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG;
    $class->debug(qq[Going to login("anonymous","$Config::Config{cf_email}")]);
    unless ( $ftp->login("anonymous",$Config::Config{'cf_email'}) ) {
        my $msg = $ftp->message;
        $CPAN::Frontend->mywarn("  Couldn't login on $host: $msg\n");
        return;
    }
    unless ( $ftp->cwd($dir) ) {
        my $msg = $ftp->message;
        $CPAN::Frontend->mywarn("  Couldn't cwd $dir: $msg\n");
        return;
    }
    $ftp->binary;
    $class->debug(qq[Going to ->get("$file","$target")\n]) if $CPAN::DEBUG;
    unless ( $ftp->get($file,$target) ) {
        my $msg = $ftp->message;
        $CPAN::Frontend->mywarn("  Couldn't fetch $file from $host: $msg\n");
        return;
    }
    $ftp->quit; # it's ok if this fails
    return 1;
}

# If more accuracy is wanted/needed, Chris Leach sent me this patch...

 # > *** /install/perl/live/lib/CPAN.pm- Wed Sep 24 13:08:48 1997
 # > --- /tmp/cp Wed Sep 24 13:26:40 1997
 # > ***************
 # > *** 1562,1567 ****
 # > --- 1562,1580 ----
 # >       return 1 if substr($url,0,4) eq "file";
 # >       return 1 unless $url =~ m|://([^/]+)|;
 # >       my $host = $1;
 # > +     my $proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
 # > +     if ($proxy) {
 # > +         $proxy =~ m|://([^/:]+)|;
 # > +         $proxy = $1;
 # > +         my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'};
 # > +         if ($noproxy) {
 # > +             if ($host !~ /$noproxy$/) {
 # > +                 $host = $proxy;
 # > +             }
 # > +         } else {
 # > +             $host = $proxy;
 # > +         }
 # > +     }
 # >       require Net::Ping;
 # >       return 1 unless $Net::Ping::VERSION >= 2;
 # >       my $p;


#-> sub CPAN::FTP::localize ;
sub localize {
    my($self,$file,$aslocal,$force,$with_defaults) = @_;
    $force ||= 0;
    Carp::croak( "Usage: ->localize(cpan_file,as_local_file[,\$force])" )
        unless defined $aslocal;
    if ($CPAN::DEBUG){
        require Carp;
        my $longmess = Carp::longmess();
        $self->debug("file[$file] aslocal[$aslocal] force[$force] carplongmess[$longmess]");
    }
    for ($CPAN::Config->{connect_to_internet_ok}) {
        $connect_to_internet_ok = $_ if not defined $connect_to_internet_ok and defined $_;
    }
    my $ph = $CPAN::Config->{pushy_https};
    if (!defined $ph || $ph) {
        return $self->localize_2021($file,$aslocal,$force,$with_defaults);
    } else {
        return $self->localize_1995ff($file,$aslocal,$force,$with_defaults);
    }
}

sub have_promising_aslocal {
    my($self, $aslocal, $force) = @_;
    if (-f $aslocal && -r _ && !($force & 1)) {
        my $size;
        if ($size = -s $aslocal) {
            $self->debug("aslocal[$aslocal]size[$size]") if $CPAN::DEBUG;
            return 1;
        } else {
            # empty file from a previous unsuccessful attempt to download it
            unlink $aslocal or
                $CPAN::Frontend->mydie("Found a zero-length '$aslocal' that I ".
                                       "could not remove.");
        }
    }
    return;
}

#-> sub CPAN::FTP::localize ;
sub localize_2021 {
    my($self,$file,$aslocal,$force,$with_defaults) = @_;
    return $aslocal if $self->have_promising_aslocal($aslocal, $force);
    my($aslocal_dir) = dirname($aslocal);
    my $ret;
    $self->mymkpath($aslocal_dir);
    my $aslocal_tempfile = $aslocal . ".tmp" . $$;
    my $base;
    if (
           ($CPAN::META->has_usable('HTTP::Tiny')
            && $CPAN::META->has_usable('Net::SSLeay')
            && $CPAN::META->has_usable('IO::Socket::SSL')
           )
        || $CPAN::Config->{curl}
        || $CPAN::Config->{wget}
       ) {
        for my $prx (qw(https_proxy no_proxy)) {
            $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
        }
        $base = "https://cpan.org/";
    } else {
        my @missing_modules = grep { ! $CPAN::META->has_usable($_) } qw(HTTP::Tiny Net::SSLeay IO::Socket::SSL);
        my $miss = join ", ", map { "'$_'" } @missing_modules;
        my $modules = @missing_modules == 1 ? "module" : "modules";
        $CPAN::Frontend->mywarn("Missing or unusable $modules $miss, and found neither curl nor wget installed.\n");
        if ($CPAN::META->has_usable('HTTP::Tiny')) {
            $CPAN::Frontend->mywarn("Need to fall back to http.\n")
        }
        for my $prx (qw(http_proxy no_proxy)) {
            $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
        }
        $base = "http://www.cpan.org/";
    }
    $ret = $self->hostdl_2021($base,$file,$aslocal_tempfile);
    if ($ret) { # c&p from below
        CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
        if ($ret eq $aslocal_tempfile) {
            # if we got it exactly as we asked for, only then we
            # want to rename
            rename $aslocal_tempfile, $aslocal
                or $CPAN::Frontend->mydie("Error while trying to rename ".
                                          "'$ret' to '$aslocal': $!");
            $ret = $aslocal;
        }
    } else {
        unlink $aslocal_tempfile;
        return;
    }
    return $ret;
}

sub hostdl_2021 {
    my($self, $base, $file, $aslocal) = @_; # the $aslocal is $aslocal_tempfile in the caller (old convention)
    my $proxy_vars = $self->_proxy_vars($base);
    my($proto) = $base =~ /^(https?)/;
    my $url = "$base$file";
    # hostdl_2021 may be called with either http or https urls
    if (
        $CPAN::META->has_usable('HTTP::Tiny')
        &&
        (
         $proto eq "http"
         ||
         (    $CPAN::META->has_usable('Net::SSLeay')
              && $CPAN::META->has_usable('IO::Socket::SSL')   )
        )
       ){
        # mostly c&p from below
        require CPAN::HTTP::Client;
        my $chc = CPAN::HTTP::Client->new(
            proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy},
            no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy},
        );
        for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) {
            $CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n");
            my $res = eval { $chc->mirror($try, $aslocal) };
            if ( $res && $res->{success} ) {
                my $now = time;
                utime $now, $now, $aslocal; # download time is more
                                            # important than upload
                                            # time
                return $aslocal;
            }
            elsif ( $res && $res->{status} ne '599') {
                $CPAN::Frontend->myprint(sprintf(
                        "HTTP::Tiny failed with code[%s] message[%s]\n",
                        $res->{status},
                        $res->{reason},
                    )
                );
            }
            elsif ( $res && $res->{status} eq '599') {
                $CPAN::Frontend->myprint(sprintf(
                        "HTTP::Tiny failed with an internal error: %s\n",
                        $res->{content},
                    )
                );
            }
            else {
                my $err = $@ || 'Unknown error';
                $CPAN::Frontend->myprint(sprintf(
                        "Error downloading with HTTP::Tiny: %s\n", $err
                    )
                );
            }
        }
    } elsif ($CPAN::Config->{curl} || $CPAN::Config->{wget}){
        # c&p from further down
        my($src_switch, $stdout_redir);
        my($devnull) = $CPAN::Config->{devnull} || "";
      DLPRG: for my $dlprg (qw(curl wget)) {
            my $dlprg_configured = $CPAN::Config->{$dlprg};
            next unless defined $dlprg_configured && length $dlprg_configured;
            my $funkyftp = CPAN::HandleConfig->safe_quote($dlprg_configured);
            if ($dlprg eq "wget") {
                $src_switch = " -O \"$aslocal\"";
                $stdout_redir = "";
            } elsif ($dlprg eq 'curl') {
                $src_switch   = ' -L -f -s -S --netrc-optional';
                $stdout_redir = " > \"$aslocal\"";
                if ($proxy_vars->{http_proxy}) {
                    $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
                }
            }
            $CPAN::Frontend->myprint(
                                     qq[
Trying with
    $funkyftp$src_switch
to get
    $url
]);
            my($system) =
                "$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
            $self->debug("system[$system]") if $CPAN::DEBUG;
            my($wstatus) = system($system);
            if ($wstatus == 0) {
                return $aslocal;
            } else {
                my $estatus = $wstatus >> 8;
                my $size = -f $aslocal ?
                    ", left\n$aslocal with size ".-s _ :
                    "\nWarning: expected file [$aslocal] doesn't exist";
                $CPAN::Frontend->myprint(qq{
    Function system("$system")
    returned status $estatus (wstat $wstatus)$size
    });
            }
        } # DLPRG
    } # curl, wget
    return;
}

#-> sub CPAN::FTP::localize ;
sub localize_1995ff {
    my($self,$file,$aslocal,$force,$with_defaults) = @_;
    if ($^O eq 'MacOS') {
        # Comment by AK on 2000-09-03: Uniq short filenames would be
        # available in CHECKSUMS file
        my($name, $path) = File::Basename::fileparse($aslocal, '');
        if (length($name) > 31) {
            $name =~ s/(
                        \.(
                           readme(\.(gz|Z))? |
                           (tar\.)?(gz|Z) |
                           tgz |
                           zip |
                           pm\.(gz|Z)
                          )
                       )$//x;
            my $suf = $1;
            my $size = 31 - length($suf);
            while (length($name) > $size) {
                chop $name;
            }
            $name .= $suf;
            $aslocal = File::Spec->catfile($path, $name);
        }
    }

    return $aslocal if $self->have_promising_aslocal($aslocal, $force);
    my($maybe_restore) = 0;
    if (-f $aslocal) {
        rename $aslocal, "$aslocal.bak$$";
        $maybe_restore++;
    }

    my($aslocal_dir) = dirname($aslocal);
    # Inheritance is not easier to manage than a few if/else branches
    if ($CPAN::META->has_usable('LWP::UserAgent')) {
        unless ($Ua) {
            CPAN::LWP::UserAgent->config;
            eval {$Ua = CPAN::LWP::UserAgent->new;}; # Why is has_usable still not fit enough?
            if ($@) {
                $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n")
                    if $CPAN::DEBUG;
            } else {
                my($var);
                $Ua->proxy('ftp',  $var)
                    if $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy};
                $Ua->proxy('http', $var)
                    if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
                $Ua->no_proxy($var)
                    if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
            }
        }
    }
    for my $prx (qw(ftp_proxy http_proxy no_proxy)) {
        $ENV{$prx} = $CPAN::Config->{$prx} if $CPAN::Config->{$prx};
    }

    # Try the list of urls for each single object. We keep a record
    # where we did get a file from
    my(@reordered,$last);
    my $ccurllist = $self->_get_urllist($with_defaults);
    $last = $#$ccurllist;
    if ($force & 2) { # local cpans probably out of date, don't reorder
        @reordered = (0..$last);
    } else {
        @reordered =
            sort {
                (substr($ccurllist->[$b],0,4) eq "file")
                    <=>
                (substr($ccurllist->[$a],0,4) eq "file")
                    or
                defined($ThesiteURL)
                    and
                ($ccurllist->[$b] eq $ThesiteURL)
                    <=>
                ($ccurllist->[$a] eq $ThesiteURL)
            } 0..$last;
    }
    my(@levels);
    $Themethod ||= "";
    $self->debug("Themethod[$Themethod]reordered[@reordered]") if $CPAN::DEBUG;
    my @all_levels = (
                      ["dleasy",   "file"],
                      ["dleasy"],
                      ["dlhard"],
                      ["dlhardest"],
                      ["dleasy",   "http","defaultsites"],
                      ["dlhard",   "http","defaultsites"],
                      ["dleasy",   "ftp", "defaultsites"],
                      ["dlhard",   "ftp", "defaultsites"],
                      ["dlhardest","",    "defaultsites"],
                     );
    if ($Themethod) {
        @levels = grep {$_->[0] eq $Themethod} @all_levels;
        push @levels, grep {$_->[0] ne $Themethod} @all_levels;
    } else {
        @levels = @all_levels;
    }
    @levels = qw/dleasy/ if $^O eq 'MacOS';
    my($levelno);
    local $ENV{FTP_PASSIVE} =
        exists $CPAN::Config->{ftp_passive} ?
        $CPAN::Config->{ftp_passive} : 1;
    my $ret;
    my $stats = $self->_new_stats($file);
  LEVEL: for $levelno (0..$#levels) {
        my $level_tuple = $levels[$levelno];
        my($level,$scheme,$sitetag) = @$level_tuple;
        $self->mymkpath($aslocal_dir) unless $scheme && "file" eq $scheme;
        my $defaultsites = $sitetag && $sitetag eq "defaultsites" && !@$ccurllist;
        my @urllist;
        if ($defaultsites) {
            unless (defined $connect_to_internet_ok) {
                $CPAN::Frontend->myprint(sprintf qq{
I would like to connect to one of the following sites to get '%s':

%s
},
                                         $file,
                                         join("",map { " ".$_->text."\n" } @CPAN::Defaultsites),
                                        );
                my $answer = CPAN::Shell::colorable_makemaker_prompt("Is it OK to try to connect to the Internet?", "yes");
                if ($answer =~ /^y/i) {
                    $connect_to_internet_ok = 1;
                } else {
                    $connect_to_internet_ok = 0;
                }
            }
            if ($connect_to_internet_ok) {
                @urllist = @CPAN::Defaultsites;
            } else {
                my $sleep = 2;
                # the tricky thing about dying here is that everybody
                # believes that calls to exists() or all_objects() are
                # safe.
                require CPAN::Exception::blocked_urllist;
                die CPAN::Exception::blocked_urllist->new;
            }
        } else { # ! $defaultsites
            my @host_seq = $level =~ /dleasy/ ?
                @reordered : 0..$last;  # reordered has file and $Thesiteurl first
            @urllist = map { $ccurllist->[$_] } @host_seq;
        }
        $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
        my $aslocal_tempfile = $aslocal . ".tmp" . $$;
        if (my $recommend = $self->_recommend_url_for($file,\@urllist)) {
            @urllist = grep { $_ ne $recommend } @urllist;
            unshift @urllist, $recommend;
        }
        $self->debug("synth. urllist[@urllist]") if $CPAN::DEBUG;
        $ret = $self->hostdlxxx($level,$scheme,\@urllist,$file,$aslocal_tempfile,$stats);
        if ($ret) {
            CPAN->debug("ret[$ret]aslocal[$aslocal]") if $CPAN::DEBUG;
            if ($ret eq $aslocal_tempfile) {
                # if we got it exactly as we asked for, only then we
                # want to rename
                rename $aslocal_tempfile, $aslocal
                    or $CPAN::Frontend->mydie("Error while trying to rename ".
                                              "'$ret' to '$aslocal': $!");
                $ret = $aslocal;
            }
            elsif (-f $ret && $scheme eq 'file' ) {
                # it's a local file, so there's nothing left to do, we
                # let them read from where it is
            }
            $Themethod = $level;
            my $now = time;
            # utime $now, $now, $aslocal; # too bad, if we do that, we
                                          # might alter a local mirror
            $self->debug("level[$level]") if $CPAN::DEBUG;
            last LEVEL;
        } else {
            unlink $aslocal_tempfile;
            last if $CPAN::Signal; # need to cleanup
        }
    }
    if ($ret) {
        $stats->{filesize} = -s $ret;
    }
    $self->debug("before _add_to_statistics") if $CPAN::DEBUG;
    $self->_add_to_statistics($stats);
    $self->debug("after _add_to_statistics") if $CPAN::DEBUG;
    if ($ret) {
        unlink "$aslocal.bak$$";
        return $ret;
    }
    unless ($CPAN::Signal) {
        my(@mess);
        local $" = " ";
        if (@{$CPAN::Config->{urllist}}) {
            push @mess,
                qq{Please check, if the URLs I found in your configuration file \(}.
                    join(", ", @{$CPAN::Config->{urllist}}).
                        qq{\) are valid.};
        } else {
            push @mess, qq{Your urllist is empty!};
        }
        push @mess, qq{The urllist can be edited.},
            qq{E.g. with 'o conf urllist push ftp://myurl/'};
        $CPAN::Frontend->mywarn(Text::Wrap::wrap("","","@mess"). "\n\n");
        $CPAN::Frontend->mydie("Could not fetch $file\n");
    }
    if ($maybe_restore) {
        rename "$aslocal.bak$$", $aslocal;
        $CPAN::Frontend->myprint("Trying to get away with old file:\n" .
                                 $self->ls($aslocal) . "\n");
        return $aslocal;
    }
    return;
}

sub mymkpath {
    my($self, $aslocal_dir) = @_;
    mkpath($aslocal_dir);
    $CPAN::Frontend->mywarn(qq{Warning: You are not allowed to write into }.
                            qq{directory "$aslocal_dir".
    I\'ll continue, but if you encounter problems, they may be due
    to insufficient permissions.\n}) unless -w $aslocal_dir;
}

sub hostdlxxx {
    my $self = shift;
    my $level = shift;
    my $scheme = shift;
    my $h = shift;
    $h = [ grep /^\Q$scheme\E:/, @$h ] if $scheme;
    my $method = "host$level";
    $self->$method($h, @_);
}

sub _set_attempt {
    my($self,$stats,$method,$url) = @_;
    push @{$stats->{attempts}}, {
                                 method => $method,
                                 start => _mytime,
                                 url => $url,
                                };
}

# package CPAN::FTP;
sub hostdleasy { #called from hostdlxxx
    my($self,$host_seq,$file,$aslocal,$stats) = @_;
    my($ro_url);
  HOSTEASY: for $ro_url (@$host_seq) {
        $self->_set_attempt($stats,"dleasy",$ro_url);
        my $url = "$ro_url$file";
        $self->debug("localizing perlish[$url]") if $CPAN::DEBUG;
        if ($url =~ /^file:/) {
            my $l;
            if ($CPAN::META->has_inst('URI::URL')) {
                my $u =  URI::URL->new($url);
                $l = $u->file;
            } else { # works only on Unix, is poorly constructed, but
                # hopefully better than nothing.
                # RFC 1738 says fileurl BNF is
                # fileurl = "file://" [ host | "localhost" ] "/" fpath
                # Thanks to "Mark D. Baushke" <mdb@cisco.com> for
                # the code
                ($l = $url) =~ s|^file://[^/]*/|/|; # discard the host part
                $l =~ s|^file:||;                   # assume they
                                                    # meant
                                                    # file://localhost
                $l =~ s|^/||s
                    if ! -f $l && $l =~ m|^/\w:|;   # e.g. /P:
            }
            $self->debug("local file[$l]") if $CPAN::DEBUG;
            if ( -f $l && -r _) {
                $ThesiteURL = $ro_url;
                return $l;
            }
            # If request is for a compressed file and we can find the
            # uncompressed file also, return the path of the uncompressed file
            # otherwise, decompress it and return the resulting path
            if ($l =~ /(.+)\.gz$/) {
                my $ungz = $1;
                if ( -f $ungz && -r _) {
                    $ThesiteURL = $ro_url;
                    return $ungz;
                }
                elsif (-f $l && -r _) {
                    eval { CPAN::Tarzip->new($l)->gunzip($aslocal) };
                    if ( -f $aslocal && -s _) {
                        $ThesiteURL = $ro_url;
                        return $aslocal;
                    }
                    elsif (! -s $aslocal) {
                        unlink $aslocal;
                    }
                    elsif (-f $l) {
                        $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
                            if $@;
                        return;
                    }
                }
            }
            # Otherwise, return the local file path if it exists
            elsif ( -f $l && -r _) {
                $ThesiteURL = $ro_url;
                return $l;
            }
            # If we can't find it, but there is a compressed version
            # of it, then decompress it
            elsif (-f "$l.gz") {
                $self->debug("found compressed $l.gz") if $CPAN::DEBUG;
                eval { CPAN::Tarzip->new("$l.gz")->gunzip($aslocal) };
                if ( -f $aslocal) {
                    $ThesiteURL = $ro_url;
                    return $aslocal;
                }
                else {
                    $CPAN::Frontend->mywarn("Error decompressing '$l': $@\n")
                        if $@;
                    return;
                }
            }
            $CPAN::Frontend->mywarn("Could not find '$l'\n");
        }
        $self->debug("it was not a file URL") if $CPAN::DEBUG;
        if ($CPAN::META->has_usable('LWP')) {
            $CPAN::Frontend->myprint("Fetching with LWP:\n$url\n");
            unless ($Ua) {
                CPAN::LWP::UserAgent->config;
                eval { $Ua = CPAN::LWP::UserAgent->new; };
                if ($@) {
                    $CPAN::Frontend->mywarn("CPAN::LWP::UserAgent->new dies with $@\n");
                }
            }
            my $res = $Ua->mirror($url, $aslocal);
            if ($res->is_success) {
                $ThesiteURL = $ro_url;
                my $now = time;
                utime $now, $now, $aslocal; # download time is more
                                            # important than upload
                                            # time
                return $aslocal;
            } elsif ($url !~ /\.gz(?!\n)\Z/) {
                my $gzurl = "$url.gz";
                $CPAN::Frontend->myprint("Fetching with LWP:\n$gzurl\n");
                $res = $Ua->mirror($gzurl, "$aslocal.gz");
                if ($res->is_success) {
                    if (eval {CPAN::Tarzip->new("$aslocal.gz")->gunzip($aslocal)}) {
                        $ThesiteURL = $ro_url;
                        return $aslocal;
                    }
                }
            } else {
                $CPAN::Frontend->myprint(sprintf(
                                                 "LWP failed with code[%s] message[%s]\n",
                                                 $res->code,
                                                 $res->message,
                                                ));
                # Alan Burlison informed me that in firewall environments
                # Net::FTP can still succeed where LWP fails. So we do not
                # skip Net::FTP anymore when LWP is available.
            }
        } elsif ($url =~ /^http:/i && $CPAN::META->has_usable('HTTP::Tiny')) {
            require CPAN::HTTP::Client;
            my $chc = CPAN::HTTP::Client->new(
                proxy => $CPAN::Config->{http_proxy} || $ENV{http_proxy},
                no_proxy => $CPAN::Config->{no_proxy} || $ENV{no_proxy},
            );
            for my $try ( $url, ( $url !~ /\.gz(?!\n)\Z/ ? "$url.gz" : () ) ) {
                $CPAN::Frontend->myprint("Fetching with HTTP::Tiny:\n$try\n");
                my $res = eval { $chc->mirror($try, $aslocal) };
                if ( $res && $res->{success} ) {
                    $ThesiteURL = $ro_url;
                    my $now = time;
                    utime $now, $now, $aslocal; # download time is more
                                                # important than upload
                                                # time
                    return $aslocal;
                }
                elsif ( $res && $res->{status} ne '599') {
                    $CPAN::Frontend->myprint(sprintf(
                            "HTTP::Tiny failed with code[%s] message[%s]\n",
                            $res->{status},
                            $res->{reason},
                        )
                    );
                }
                elsif ( $res && $res->{status} eq '599') {
                    $CPAN::Frontend->myprint(sprintf(
                            "HTTP::Tiny failed with an internal error: %s\n",
                            $res->{content},
                        )
                    );
                }
                else {
                    my $err = $@ || 'Unknown error';
                    $CPAN::Frontend->myprint(sprintf(
                            "Error downloading with HTTP::Tiny: %s\n", $err
                        )
                    );
                }
            }
        }
        return if $CPAN::Signal;
        if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
            # that's the nice and easy way thanks to Graham
            $self->debug("recognized ftp") if $CPAN::DEBUG;
            my($host,$dir,$getfile) = ($1,$2,$3);
            if ($CPAN::META->has_usable('Net::FTP')) {
                $dir =~ s|/+|/|g;
                $CPAN::Frontend->myprint("Fetching with Net::FTP:\n$url\n");
                $self->debug("getfile[$getfile]dir[$dir]host[$host]" .
                             "aslocal[$aslocal]") if $CPAN::DEBUG;
                if (CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal)) {
                    $ThesiteURL = $ro_url;
                    return $aslocal;
                }
                if ($aslocal !~ /\.gz(?!\n)\Z/) {
                    my $gz = "$aslocal.gz";
                    $CPAN::Frontend->myprint("Fetching with Net::FTP\n$url.gz\n");
                    if (CPAN::FTP->ftp_get($host,
                                           $dir,
                                           "$getfile.gz",
                                           $gz) &&
                        eval{CPAN::Tarzip->new($gz)->gunzip($aslocal)}
                    ) {
                        $ThesiteURL = $ro_url;
                        return $aslocal;
                    }
                }
                # next HOSTEASY;
            } else {
                CPAN->debug("Net::FTP does not count as usable atm") if $CPAN::DEBUG;
            }
        }
        if (
            UNIVERSAL::can($ro_url,"text")
            and
            $ro_url->{FROM} eq "USER"
           ) {
            ##address #17973: default URLs should not try to override
            ##user-defined URLs just because LWP is not available
            my $ret = $self->hostdlhard([$ro_url],$file,$aslocal,$stats);
            return $ret if $ret;
        }
        return if $CPAN::Signal;
    }
}

# package CPAN::FTP;
sub hostdlhard {
    my($self,$host_seq,$file,$aslocal,$stats) = @_;

    # Came back if Net::FTP couldn't establish connection (or
    # failed otherwise) Maybe they are behind a firewall, but they
    # gave us a socksified (or other) ftp program...

    my($ro_url);
    my($devnull) = $CPAN::Config->{devnull} || "";
    # < /dev/null ";
    my($aslocal_dir) = dirname($aslocal);
    mkpath($aslocal_dir);
    my $some_dl_success = 0;
    my $any_attempt = 0;
 HOSTHARD: for $ro_url (@$host_seq) {
        $self->_set_attempt($stats,"dlhard",$ro_url);
        my $url = "$ro_url$file";
        my($proto,$host,$dir,$getfile);

        # Courtesy Mark Conty mark_conty@cargill.com change from
        # if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
        # to
        if ($url =~ m|^([^:]+)://(.*?)/(.*)/(.*)|) {
            # proto not yet used
            ($proto,$host,$dir,$getfile) = ($1,$2,$3,$4);
        } else {
            next HOSTHARD; # who said, we could ftp anything except ftp?
        }
        next HOSTHARD if $proto eq "file"; # file URLs would have had
                                           # success above. Likely a bogus URL

        # making at least one attempt against a host
        $any_attempt++;

        $self->debug("localizing funkyftpwise[$url]") if $CPAN::DEBUG;

        # Try the most capable first and leave ncftp* for last as it only
        # does FTP.
        my $proxy_vars = $self->_proxy_vars($ro_url);
      DLPRG: for my $f (qw(curl wget lynx ncftpget ncftp)) {
            my $funkyftp = CPAN::HandleConfig->safe_quote($CPAN::Config->{$f});
            next DLPRG unless defined $funkyftp;
            next DLPRG if $funkyftp =~ /^\s*$/;

            my($src_switch) = "";
            my($chdir) = "";
            my($stdout_redir) = " > \"$aslocal\"";
            if ($f eq "lynx") {
                $src_switch = " -source";
            } elsif ($f eq "ncftp") {
                next DLPRG unless $url =~ m{\Aftp://};
                $src_switch = " -c";
            } elsif ($f eq "wget") {
                $src_switch = " -O \"$aslocal\"";
                $stdout_redir = "";
            } elsif ($f eq 'curl') {
                $src_switch = ' -L -f -s -S --netrc-optional';
                if ($proxy_vars->{http_proxy}) {
                    $src_switch .= qq{ -U "$proxy_vars->{proxy_user}:$proxy_vars->{proxy_pass}" -x "$proxy_vars->{http_proxy}"};
                }
            } elsif ($f eq "ncftpget") {
                next DLPRG unless $url =~ m{\Aftp://};
                $chdir = "cd $aslocal_dir && ";
                $stdout_redir = "";
            }
            $CPAN::Frontend->myprint(
                                     qq[
Trying with
    $funkyftp$src_switch
to get
    $url
]);
            my($system) =
                "$chdir$funkyftp$src_switch \"$url\" $devnull$stdout_redir";
            $self->debug("system[$system]") if $CPAN::DEBUG;
            my($wstatus) = system($system);
            if ($f eq "lynx") {
                # lynx returns 0 when it fails somewhere
                if (-s $aslocal) {
                    my $content = do { local *FH;
                                       open FH, $aslocal or die;
                                       local $/;
                                       <FH> };
                    if ($content =~ /^<.*(<title>[45]|Error [45])/si) {
                        $CPAN::Frontend->mywarn(qq{
No success, the file that lynx has downloaded looks like an error message:
$content
});
                        $CPAN::Frontend->mysleep(1);
                        next DLPRG;
                    }
                    $some_dl_success++;
                } else {
                    $CPAN::Frontend->myprint(qq{
No success, the file that lynx has downloaded is an empty file.
});
                    next DLPRG;
                }
            }
            if ($wstatus == 0) {
                if (-s $aslocal) {
                    # Looks good
                    $some_dl_success++;
                }
                $ThesiteURL = $ro_url;
                return $aslocal;
            } else {
                my $estatus = $wstatus >> 8;
                my $size = -f $aslocal ?
                    ", left\n$aslocal with size ".-s _ :
                    "\nWarning: expected file [$aslocal] doesn't exist";
                $CPAN::Frontend->myprint(qq{
    Function system("$system")
    returned status $estatus (wstat $wstatus)$size
    });
            }
            return if $CPAN::Signal;
        } # download/transfer programs (DLPRG)
    } # host
    return unless $any_attempt;
    if ($some_dl_success) {
        $CPAN::Frontend->mywarn("Warning: doesn't seem we had substantial success downloading '$aslocal'. Don't know how to proceed.\n");
    } else {
        $CPAN::Frontend->mywarn("Warning: no success downloading '$aslocal'. Giving up on it.\n");
    }
    return;
}

#-> CPAN::FTP::_proxy_vars
sub _proxy_vars {
    my($self,$url) = @_;
    my $ret = +{};
    my $http_proxy = $CPAN::Config->{'http_proxy'} || $ENV{'http_proxy'};
    if ($http_proxy) {
        my($host) = $url =~ m|://([^/:]+)|;
        my $want_proxy = 1;
        my $noproxy = $CPAN::Config->{'no_proxy'} || $ENV{'no_proxy'} || "";
        my @noproxy = split /\s*,\s*/, $noproxy;
        if ($host) {
          DOMAIN: for my $domain (@noproxy) {
                if ($host =~ /\Q$domain\E$/) { # cf. LWP::UserAgent
                    $want_proxy = 0;
                    last DOMAIN;
                }
            }
        } else {
            $CPAN::Frontend->mywarn("  Could not determine host from http_proxy '$http_proxy'\n");
        }
        if ($want_proxy) {
            my($user, $pass) =
                CPAN::HTTP::Credentials->get_proxy_credentials();
            $ret = {
                    proxy_user => $user,
                    proxy_pass => $pass,
                    http_proxy => $http_proxy
                  };
        }
    }
    return $ret;
}

# package CPAN::FTP;
sub hostdlhardest {
    my($self,$host_seq,$file,$aslocal,$stats) = @_;

    return unless @$host_seq;
    my($ro_url);
    my($aslocal_dir) = dirname($aslocal);
    mkpath($aslocal_dir);
    my $ftpbin = $CPAN::Config->{ftp};
    unless ($ftpbin && length $ftpbin && MM->maybe_command($ftpbin)) {
        $CPAN::Frontend->myprint("No external ftp command available\n\n");
        return;
    }
    $CPAN::Frontend->mywarn(qq{
As a last resort we now switch to the external ftp command '$ftpbin'
to get '$aslocal'.

Doing so often leads to problems that are hard to diagnose.

If you're the victim of such problems, please consider unsetting the
ftp config variable with

    o conf ftp ""
    o conf commit

});
    $CPAN::Frontend->mysleep(2);
  HOSTHARDEST: for $ro_url (@$host_seq) {
        $self->_set_attempt($stats,"dlhardest",$ro_url);
        my $url = "$ro_url$file";
        $self->debug("localizing ftpwise[$url]") if $CPAN::DEBUG;
        unless ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
            next;
        }
        my($host,$dir,$getfile) = ($1,$2,$3);
        my $timestamp = 0;
        my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
            $ctime,$blksize,$blocks) = stat($aslocal);
        $timestamp = $mtime ||= 0;
        my($netrc) = CPAN::FTP::netrc->new;
        my($netrcfile) = $netrc->netrc;
        my($verbose) = $CPAN::DEBUG{'FTP'} & $CPAN::DEBUG ? " -v" : "";
        my $targetfile = File::Basename::basename($aslocal);
        my(@dialog);
        push(
             @dialog,
             "lcd $aslocal_dir",
             "cd /",
             map("cd $_", split /\//, $dir), # RFC 1738
             "bin",
             "passive",
             "get $getfile $targetfile",
             "quit"
        );
        if (! $netrcfile) {
            CPAN->debug("No ~/.netrc file found") if $CPAN::DEBUG;
        } elsif ($netrc->hasdefault || $netrc->contains($host)) {
            CPAN->debug(sprintf("hasdef[%d]cont($host)[%d]",
                                $netrc->hasdefault,
                                $netrc->contains($host))) if $CPAN::DEBUG;
            if ($netrc->protected) {
                my $dialog = join "", map { "    $_\n" } @dialog;
                my $netrc_explain;
                if ($netrc->contains($host)) {
                    $netrc_explain = "Relying that your .netrc entry for '$host' ".
                        "manages the login";
                } else {
                    $netrc_explain = "Relying that your default .netrc entry ".
                        "manages the login";
                }
                $CPAN::Frontend->myprint(qq{
  Trying with external ftp to get
    '$url'
  $netrc_explain
  Sending the dialog
$dialog
}
                );
                $self->talk_ftp("$ftpbin$verbose $host",
                                @dialog);
                ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                    $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
                $mtime ||= 0;
                if ($mtime > $timestamp) {
                    $CPAN::Frontend->myprint("GOT $aslocal\n");
                    $ThesiteURL = $ro_url;
                    return $aslocal;
                } else {
                    $CPAN::Frontend->myprint("Hmm... Still failed!\n");
                }
                    return if $CPAN::Signal;
            } else {
                $CPAN::Frontend->mywarn(qq{Your $netrcfile is not }.
                                        qq{correctly protected.\n});
            }
        } else {
            $CPAN::Frontend->mywarn("Your ~/.netrc neither contains $host
  nor does it have a default entry\n");
        }

        # OK, they don't have a valid ~/.netrc. Use 'ftp -n'
        # then and login manually to host, using e-mail as
        # password.
        $CPAN::Frontend->myprint(qq{Issuing "$ftpbin$verbose -n"\n});
        unshift(
                @dialog,
                "open $host",
                "user anonymous $Config::Config{'cf_email'}"
        );
        my $dialog = join "", map { "    $_\n" } @dialog;
        $CPAN::Frontend->myprint(qq{
  Trying with external ftp to get
    $url
  Sending the dialog
$dialog
}
        );
        $self->talk_ftp("$ftpbin$verbose -n", @dialog);
        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
            $atime,$mtime,$ctime,$blksize,$blocks) = stat($aslocal);
        $mtime ||= 0;
        if ($mtime > $timestamp) {
            $CPAN::Frontend->myprint("GOT $aslocal\n");
            $ThesiteURL = $ro_url;
            return $aslocal;
        } else {
            $CPAN::Frontend->myprint("Bad luck... Still failed!\n");
        }
        return if $CPAN::Signal;
        $CPAN::Frontend->mywarn("Can't access URL $url.\n\n");
        $CPAN::Frontend->mysleep(2);
    } # host
}

# package CPAN::FTP;
sub talk_ftp {
    my($self,$command,@dialog) = @_;
    my $fh = FileHandle->new;
    $fh->open("|$command") or die "Couldn't open ftp: $!";
    foreach (@dialog) { $fh->print("$_\n") }
    $fh->close; # Wait for process to complete
    my $wstatus = $?;
    my $estatus = $wstatus >> 8;
    $CPAN::Frontend->myprint(qq{
Subprocess "|$command"
  returned status $estatus (wstat $wstatus)
}) if $wstatus;
}

# find2perl needs modularization, too, all the following is stolen
# from there
# CPAN::FTP::ls
sub ls {
    my($self,$name) = @_;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
     $atime,$mtime,$ctime,$blksize,$blocks) = lstat($name);

    my($perms,%user,%group);
    my $pname = $name;

    if ($blocks) {
        $blocks = int(($blocks + 1) / 2);
    }
    else {
        $blocks = int(($sizemm + 1023) / 1024);
    }

    if    (-f _) { $perms = '-'; }
    elsif (-d _) { $perms = 'd'; }
    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
    elsif (-p _) { $perms = 'p'; }
    elsif (-S _) { $perms = 's'; }
    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }

    my(@rwx) = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
    my(@moname) = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my $tmpmode = $mode;
    my $tmp = $rwx[$tmpmode & 7];
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    $tmpmode >>= 3;
    $tmp = $rwx[$tmpmode & 7] . $tmp;
    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
    $perms .= $tmp;

    my $user = $user{$uid} || $uid;   # too lazy to implement lookup
    my $group = $group{$gid} || $gid;

    my($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
    my($timeyear);
    my($moname) = $moname[$mon];
    if (-M _ > 365.25 / 2) {
        $timeyear = $year + 1900;
    }
    else {
        $timeyear = sprintf("%02d:%02d", $hour, $min);
    }

    sprintf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
             $ino,
                  $blocks,
                       $perms,
                             $nlink,
                                 $user,
                                      $group,
                                           $sizemm,
                                               $moname,
                                                  $mday,
                                                      $timeyear,
                                                          $pname;
}

1;
PK     ü2]ÏUÜV  ÜV    Index.pmnu ÏÃ6Ç$        package CPAN::Index;
use strict;
use vars qw($LAST_TIME $DATE_OF_02 $DATE_OF_03 $HAVE_REANIMATED $VERSION);
$VERSION = "2.29";
@CPAN::Index::ISA = qw(CPAN::Debug);
$LAST_TIME ||= 0;
$DATE_OF_03 ||= 0;
# use constant PROTOCOL => "2.0"; # commented out to avoid warning on upgrade from 1.57
sub PROTOCOL { 2.0 }

#-> sub CPAN::Index::force_reload ;
sub force_reload {
    my($class) = @_;
    $CPAN::Index::LAST_TIME = 0;
    $class->reload(1);
}

my @indexbundle =
    (
     {
      reader => "rd_authindex",
      dir => "authors",
      remotefile => '01mailrc.txt.gz',
      shortlocalfile => '01mailrc.gz',
     },
     {
      reader => "rd_modpacks",
      dir => "modules",
      remotefile => '02packages.details.txt.gz',
      shortlocalfile => '02packag.gz',
     },
     {
      reader => "rd_modlist",
      dir => "modules",
      remotefile => '03modlist.data.gz',
      shortlocalfile => '03mlist.gz',
     },
    );

#-> sub CPAN::Index::reload ;
sub reload {
    my($self,$force) = @_;
    my $time = time;

    # XXX check if a newer one is available. (We currently read it
    # from time to time)
    for ($CPAN::Config->{index_expire}) {
        $_ = 0.001 unless $_ && $_ > 0.001;
    }
    unless (1 || $CPAN::Have_warned->{readmetadatacache}++) {
        # debug here when CPAN doesn't seem to read the Metadata
        require Carp;
        Carp::cluck("META-PROTOCOL[$CPAN::META->{PROTOCOL}]");
    }
    unless ($CPAN::META->{PROTOCOL}) {
        $self->read_metadata_cache;
        $CPAN::META->{PROTOCOL} ||= "1.0";
    }
    if ( $CPAN::META->{PROTOCOL} < PROTOCOL  ) {
        # warn "Setting last_time to 0";
        $LAST_TIME = 0; # No warning necessary
    }
    if ($LAST_TIME + $CPAN::Config->{index_expire}*86400 > $time
        and ! $force) {
        # called too often
        # CPAN->debug("LAST_TIME[$LAST_TIME]index_expire[$CPAN::Config->{index_expire}]time[$time]");
    } elsif (0) {
        # IFF we are developing, it helps to wipe out the memory
        # between reloads, otherwise it is not what a user expects.
        undef $CPAN::META; # Neue Gruendlichkeit since v1.52(r1.274)
        $CPAN::META = CPAN->new;
    } else {
        my($debug,$t2);
        local $LAST_TIME = $time;
        local $CPAN::META->{PROTOCOL} = PROTOCOL;

        my $needshort = $^O eq "dos";

    INX: for my $indexbundle (@indexbundle) {
            my $reader = $indexbundle->{reader};
            my $localfile = $needshort ? $indexbundle->{shortlocalfile} : $indexbundle->{remotefile};
            my $localpath = File::Spec->catfile($indexbundle->{dir}, $localfile);
            my $remote = join "/", $indexbundle->{dir}, $indexbundle->{remotefile};
            my $localized = $self->reload_x($remote, $localpath, $force);
            $self->$reader($localized); # may die but we let the shell catch it
            if ($CPAN::DEBUG){
                $t2 = time;
                $debug = "timing reading 01[".($t2 - $time)."]";
                $time = $t2;
            }
            return if $CPAN::Signal; # this is sometimes lengthy
        }
        $self->write_metadata_cache;
        if ($CPAN::DEBUG){
            $t2 = time;
            $debug .= "03[".($t2 - $time)."]";
            $time = $t2;
        }
        CPAN->debug($debug) if $CPAN::DEBUG;
    }
    if ($CPAN::Config->{build_dir_reuse}) {
        $self->reanimate_build_dir;
    }
    if (CPAN::_sqlite_running()) {
        $CPAN::SQLite->reload(time => $time, force => $force)
            if not $LAST_TIME;
    }
    $LAST_TIME = $time;
    $CPAN::META->{PROTOCOL} = PROTOCOL;
}

#-> sub CPAN::Index::reanimate_build_dir ;
sub reanimate_build_dir {
    my($self) = @_;
    unless ($CPAN::META->has_inst($CPAN::Config->{yaml_module}||"YAML")) {
        return;
    }
    return if $HAVE_REANIMATED++;
    my $d = $CPAN::Config->{build_dir};
    my $dh = DirHandle->new;
    opendir $dh, $d or return; # does not exist
    my $dirent;
    my $i = 0;
    my $painted = 0;
    my $restored = 0;
    my $start = CPAN::FTP::_mytime();
    my @candidates = map { $_->[0] }
        sort { $b->[1] <=> $a->[1] }
            map { [ $_, -M File::Spec->catfile($d,$_) ] }
                grep {/(.+)\.yml$/ && -d File::Spec->catfile($d,$1)} readdir $dh;
    if ( @candidates ) {
        $CPAN::Frontend->myprint
            (sprintf("Reading %d yaml file%s from %s/\n",
                    scalar @candidates,
                    @candidates==1 ? "" : "s",
                    $CPAN::Config->{build_dir}
                    ));
      DISTRO: for $i (0..$#candidates) {
            my $dirent = $candidates[$i];
            my $y = eval {CPAN->_yaml_loadfile(File::Spec->catfile($d,$dirent), {loadblessed => 1})};
            if ($@) {
                warn "Error while parsing file '$dirent'; error: '$@'";
                next DISTRO;
            }
            my $c = $y->[0];
            if ($c && $c->{perl} && $c->{distribution} && CPAN->_perl_fingerprint($c->{perl})) {
                my $key = $c->{distribution}{ID};
                for my $k (keys %{$c->{distribution}}) {
                    if ($c->{distribution}{$k}
                        && ref $c->{distribution}{$k}
                        && UNIVERSAL::isa($c->{distribution}{$k},"CPAN::Distrostatus")) {
                        $c->{distribution}{$k}{COMMANDID} = $i - @candidates;
                    }
                }

                #we tried to restore only if element already
                #exists; but then we do not work with metadata
                #turned off.
                my $do
                    = $CPAN::META->{readwrite}{'CPAN::Distribution'}{$key}
                        = $c->{distribution};
                for my $skipper (qw(
                                    badtestcnt
                                    configure_requires_later
                                    configure_requires_later_for
                                    force_update
                                    later
                                    later_for
                                    notest
                                    should_report
                                    sponsored_mods
                                    prefs
                                    negative_prefs_cache
                                  )) {
                    delete $do->{$skipper};
                }
                if ($do->can("tested_ok_but_not_installed")) {
                    if ($do->tested_ok_but_not_installed) {
                        $CPAN::META->is_tested($do->{build_dir},$do->{make_test}{TIME});
                    } else {
                        next DISTRO;
                    }
                }
                $restored++;
            }
            $i++;
            while (($painted/76) < ($i/@candidates)) {
                $CPAN::Frontend->myprint(".");
                $painted++;
            }
        }
    }
    else {
        $CPAN::Frontend->myprint("Build_dir empty, nothing to restore\n");
    }
    my $took = CPAN::FTP::_mytime() - $start;
    $CPAN::Frontend->myprint(sprintf(
                                     "DONE\nRestored the state of %s (in %.4f secs)\n",
                                     $restored || "none",
                                     $took,
                                    ));
}


#-> sub CPAN::Index::reload_x ;
sub reload_x {
    my($cl,$wanted,$localname,$force) = @_;
    $force |= 2; # means we're dealing with an index here
    CPAN::HandleConfig->load; # we should guarantee loading wherever
                              # we rely on Config XXX
    $localname ||= $wanted;
    my $abs_wanted = File::Spec->catfile($CPAN::Config->{'keep_source_where'},
                                         $localname);
    if (
        -f $abs_wanted &&
        -M $abs_wanted < $CPAN::Config->{'index_expire'} &&
        !($force & 1)
       ) {
        my $s = $CPAN::Config->{'index_expire'} == 1 ? "" : "s";
        $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} }.
                   qq{day$s. I\'ll use that.});
        return $abs_wanted;
    } else {
        $force |= 1; # means we're quite serious about it.
    }
    return CPAN::FTP->localize($wanted,$abs_wanted,$force);
}

#-> sub CPAN::Index::rd_authindex ;
sub rd_authindex {
    my($cl, $index_target) = @_;
    return unless defined $index_target;
    return if CPAN::_sqlite_running();
    my @lines;
    $CPAN::Frontend->myprint("Reading '$index_target'\n");
    local(*FH);
    tie *FH, 'CPAN::Tarzip', $index_target;
    local($/) = "\n";
    local($_);
    push @lines, split /\012/ while <FH>;
    my $i = 0;
    my $painted = 0;
    foreach (@lines) {
        my($userid,$fullname,$email) =
            m/alias\s+(\S+)\s+\"([^\"\<]*)\s+\<(.*)\>\"/;
        $fullname ||= $email;
        if ($userid && $fullname && $email) {
            my $userobj = $CPAN::META->instance('CPAN::Author',$userid);
            $userobj->set('FULLNAME' => $fullname, 'EMAIL' => $email);
        } else {
            CPAN->debug(sprintf "line[%s]", $_) if $CPAN::DEBUG;
        }
        $i++;
        while (($painted/76) < ($i/@lines)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
}

sub userid {
  my($self,$dist) = @_;
  $dist = $self->{'id'} unless defined $dist;
  my($ret) = $dist =~ m|(?:\w/\w\w/)?([^/]+)/|;
  $ret;
}

#-> sub CPAN::Index::rd_modpacks ;
sub rd_modpacks {
    my($self, $index_target) = @_;
    return unless defined $index_target;
    return if CPAN::_sqlite_running();
    $CPAN::Frontend->myprint("Reading '$index_target'\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    local $_;
    CPAN->debug(sprintf "start[%d]", time) if $CPAN::DEBUG;
    my $slurp = "";
    my $chunk;
    while (my $bytes = $fh->READ(\$chunk,8192)) {
        $slurp.=$chunk;
    }
    my @lines = split /\012/, $slurp;
    CPAN->debug(sprintf "end[%d]", time) if $CPAN::DEBUG;
    undef $fh;
    # read header
    my($line_count,$last_updated);
    while (@lines) {
        my $shift = shift(@lines);
        last if $shift =~ /^\s*$/;
        $shift =~ /^Line-Count:\s+(\d+)/ and $line_count = $1;
        $shift =~ /^Last-Updated:\s+(.+)/ and $last_updated = $1;
    }
    CPAN->debug("line_count[$line_count]last_updated[$last_updated]") if $CPAN::DEBUG;
    my $errors = 0;
    if (not defined $line_count) {

        $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Line-Count header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
        $errors++;
        $CPAN::Frontend->mysleep(5);
    } elsif ($line_count != scalar @lines) {

        $CPAN::Frontend->mywarn(sprintf qq{Warning: Your %s
contains a Line-Count header of %d but I see %d lines there. Please
check the validity of the index file by comparing it to more than one
CPAN mirror. I'll continue but problems seem likely to happen.\a\n},
$index_target, $line_count, scalar(@lines));

    }
    if (not defined $last_updated) {

        $CPAN::Frontend->mywarn(qq{Warning: Your $index_target does not contain a Last-Updated header.
Please check the validity of the index file by comparing it to more
than one CPAN mirror. I'll continue but problems seem likely to
happen.\a
});
        $errors++;
        $CPAN::Frontend->mysleep(5);
    } else {

        $CPAN::Frontend
            ->myprint(sprintf qq{  Database was generated on %s\n},
                      $last_updated);
        $DATE_OF_02 = $last_updated;

        my $age = time;
        if ($CPAN::META->has_inst('HTTP::Date')) {
            require HTTP::Date;
            $age -= HTTP::Date::str2time($last_updated);
        } else {
            $CPAN::Frontend->mywarn("  HTTP::Date not available\n");
            require Time::Local;
            my(@d) = $last_updated =~ / (\d+) (\w+) (\d+) (\d+):(\d+):(\d+) /;
            $d[1] = index("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec", $d[1])/4;
            $age -= $d[1]>=0 ? Time::Local::timegm(@d[5,4,3,0,1,2]) : 0;
        }
        $age /= 3600*24;
        if ($age > 30) {

            $CPAN::Frontend
                ->mywarn(sprintf
                         qq{Warning: This index file is %d days old.
  Please check the host you chose as your CPAN mirror for staleness.
  I'll continue but problems seem likely to happen.\a\n},
                         $age);

        } elsif ($age < -1) {

            $CPAN::Frontend
                ->mywarn(sprintf
                         qq{Warning: Your system date is %d days behind this index file!
  System time:          %s
  Timestamp index file: %s
  Please fix your system time, problems with the make command expected.\n},
                         -$age,
                         scalar gmtime,
                         $DATE_OF_02,
                        );

        }
    }


    # A necessity since we have metadata_cache: delete what isn't
    # there anymore
    my $secondtime = $CPAN::META->exists("CPAN::Module","CPAN");
    CPAN->debug("secondtime[$secondtime]") if $CPAN::DEBUG;
    my(%exists);
    my $i = 0;
    my $painted = 0;
 LINE: foreach (@lines) {
        # before 1.56 we split into 3 and discarded the rest. From
        # 1.57 we assign remaining text to $comment thus allowing to
        # influence isa_perl
        my($mod,$version,$dist,$comment) = split " ", $_, 4;
        unless ($mod && defined $version && $dist) {
            require Dumpvalue;
            my $dv = Dumpvalue->new(tick => '"');
            $CPAN::Frontend->mywarn(sprintf "Could not split line[%s]\n", $dv->stringify($_));
            if ($errors++ >= 5){
                $CPAN::Frontend->mydie("Giving up parsing your $index_target, too many errors");
            }
            next LINE;
        }
        my($bundle,$id,$userid);

        if ($mod eq 'CPAN' &&
            ! (
            CPAN::Queue->exists('Bundle::CPAN') ||
            CPAN::Queue->exists('CPAN')
            )
        ) {
            local($^W)= 0;
            if ($version > $CPAN::VERSION) {
                $CPAN::Frontend->mywarn(qq{
  New CPAN.pm version (v$version) available.
  [Currently running version is v$CPAN::VERSION]
  You might want to try
    install CPAN
    reload cpan
  to both upgrade CPAN.pm and run the new version without leaving
  the current session.

}); #});
                $CPAN::Frontend->mysleep(2);
                $CPAN::Frontend->myprint(qq{\n});
            }
            last if $CPAN::Signal;
        } elsif ($mod =~ /^Bundle::(.*)/) {
            $bundle = $1;
        }

        if ($bundle) {
            $id =  $CPAN::META->instance('CPAN::Bundle',$mod);
            # Let's make it a module too, because bundles have so much
            # in common with modules.

            # Changed in 1.57_63: seems like memory bloat now without
            # any value, so commented out

            # $CPAN::META->instance('CPAN::Module',$mod);

        } else {

            # instantiate a module object
            $id = $CPAN::META->instance('CPAN::Module',$mod);

        }

        # Although CPAN prohibits same name with different version the
        # indexer may have changed the version for the same distro
        # since the last time ("Force Reindexing" feature)
        if ($id->cpan_file ne $dist
            ||
            $id->cpan_version ne $version
           ) {
            $userid = $id->userid || $self->userid($dist);
            $id->set(
                     'CPAN_USERID' => $userid,
                     'CPAN_VERSION' => $version,
                     'CPAN_FILE' => $dist,
                    );
        }

        # instantiate a distribution object
        if ($CPAN::META->exists('CPAN::Distribution',$dist)) {
        # we do not need CONTAINSMODS unless we do something with
        # this dist, so we better produce it on demand.

        ## my $obj = $CPAN::META->instance(
        ##                                 'CPAN::Distribution' => $dist
        ##                                );
        ## $obj->{CONTAINSMODS}{$mod} = undef; # experimental
        } else {
            $CPAN::META->instance(
                                  'CPAN::Distribution' => $dist
                                 )->set(
                                        'CPAN_USERID' => $userid,
                                        'CPAN_COMMENT' => $comment,
                                       );
        }
        if ($secondtime) {
            for my $name ($mod,$dist) {
                # $self->debug("exists name[$name]") if $CPAN::DEBUG;
                $exists{$name} = undef;
            }
        }
        $i++;
        while (($painted/76) < ($i/@lines)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
    if ($secondtime) {
        for my $class (qw(CPAN::Module CPAN::Bundle CPAN::Distribution)) {
            for my $o ($CPAN::META->all_objects($class)) {
                next if exists $exists{$o->{ID}};
                $CPAN::META->delete($class,$o->{ID});
                # CPAN->debug("deleting ID[$o->{ID}] in class[$class]")
                #     if $CPAN::DEBUG;
            }
        }
    }
}

#-> sub CPAN::Index::rd_modlist ;
sub rd_modlist {
    my($cl,$index_target) = @_;
    return unless defined $index_target;
    return if CPAN::_sqlite_running();
    $CPAN::Frontend->myprint("Reading '$index_target'\n");
    my $fh = CPAN::Tarzip->TIEHANDLE($index_target);
    local $_;
    my $slurp = "";
    my $chunk;
    while (my $bytes = $fh->READ(\$chunk,8192)) {
        $slurp.=$chunk;
    }
    my @eval2 = split /\012/, $slurp;

    while (@eval2) {
        my $shift = shift(@eval2);
        if ($shift =~ /^Date:\s+(.*)/) {
            if ($DATE_OF_03 eq $1) {
                $CPAN::Frontend->myprint("Unchanged.\n");
                return;
            }
            ($DATE_OF_03) = $1;
        }
        last if $shift =~ /^\s*$/;
    }
    push @eval2, q{CPAN::Modulelist->data;};
    local($^W) = 0;
    my($compmt) = Safe->new("CPAN::Safe1");
    my($eval2) = join("\n", @eval2);
    CPAN->debug(sprintf "length of eval2[%d]", length $eval2) if $CPAN::DEBUG;
    my $ret = $compmt->reval($eval2);
    Carp::confess($@) if $@;
    return if $CPAN::Signal;
    my $i = 0;
    my $until = keys(%$ret);
    my $painted = 0;
    CPAN->debug(sprintf "until[%d]", $until) if $CPAN::DEBUG;
    for (sort keys %$ret) {
        my $obj = $CPAN::META->instance("CPAN::Module",$_);
        delete $ret->{$_}{modid}; # not needed here, maybe elsewhere
        $obj->set(%{$ret->{$_}});
        $i++;
        while (($painted/76) < ($i/$until)) {
            $CPAN::Frontend->myprint(".");
            $painted++;
        }
        return if $CPAN::Signal;
    }
    $CPAN::Frontend->myprint("DONE\n");
}

#-> sub CPAN::Index::write_metadata_cache ;
sub write_metadata_cache {
    my($self) = @_;
    return unless $CPAN::Config->{'cache_metadata'};
    return if CPAN::_sqlite_running();
    return unless $CPAN::META->has_usable("Storable");
    my $cache;
    foreach my $k (qw(CPAN::Bundle CPAN::Author CPAN::Module
                      CPAN::Distribution)) {
        $cache->{$k} = $CPAN::META->{readonly}{$k}; # unsafe meta access, ok
    }
    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
    $cache->{last_time} = $LAST_TIME;
    $cache->{DATE_OF_02} = $DATE_OF_02;
    $cache->{PROTOCOL} = PROTOCOL;
    $CPAN::Frontend->myprint("Writing $metadata_file\n");
    eval { Storable::nstore($cache, $metadata_file) };
    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
}

#-> sub CPAN::Index::read_metadata_cache ;
sub read_metadata_cache {
    my($self) = @_;
    return unless $CPAN::Config->{'cache_metadata'};
    return if CPAN::_sqlite_running();
    return unless $CPAN::META->has_usable("Storable");
    my $metadata_file = File::Spec->catfile($CPAN::Config->{cpan_home},"Metadata");
    return unless -r $metadata_file and -f $metadata_file;
    $CPAN::Frontend->myprint("Reading '$metadata_file'\n");
    my $cache;
    eval { $cache = Storable::retrieve($metadata_file) };
    $CPAN::Frontend->mywarn($@) if $@; # ?? missing "\n" after $@ in mywarn ??
    if (!$cache || !UNIVERSAL::isa($cache, 'HASH')) {
        $LAST_TIME = 0;
        return;
    }
    if (exists $cache->{PROTOCOL}) {
        if (PROTOCOL > $cache->{PROTOCOL}) {
            $CPAN::Frontend->mywarn(sprintf("Ignoring Metadata cache written ".
                                            "with protocol v%s, requiring v%s\n",
                                            $cache->{PROTOCOL},
                                            PROTOCOL)
                                   );
            return;
        }
    } else {
        $CPAN::Frontend->mywarn("Ignoring Metadata cache written ".
                                "with protocol v1.0\n");
        return;
    }
    my $clcnt = 0;
    my $idcnt = 0;
    while(my($class,$v) = each %$cache) {
        next unless $class =~ /^CPAN::/;
        $CPAN::META->{readonly}{$class} = $v; # unsafe meta access, ok
        while (my($id,$ro) = each %$v) {
            $CPAN::META->{readwrite}{$class}{$id} ||=
                $class->new(ID=>$id, RO=>$ro);
            $idcnt++;
        }
        $clcnt++;
    }
    unless ($clcnt) { # sanity check
        $CPAN::Frontend->myprint("Warning: Found no data in $metadata_file\n");
        return;
    }
    if ($idcnt < 1000) {
        $CPAN::Frontend->myprint("Warning: Found only $idcnt objects ".
                                 "in $metadata_file\n");
        return;
    }
    $CPAN::META->{PROTOCOL} ||=
        $cache->{PROTOCOL}; # reading does not up or downgrade, but it
                            # does initialize to some protocol
    $LAST_TIME = $cache->{last_time};
    $DATE_OF_02 = $cache->{DATE_OF_02};
    $CPAN::Frontend->myprint("  Database was generated on $DATE_OF_02\n")
        if defined $DATE_OF_02; # An old cache may not contain DATE_OF_02
    return;
}

1;
PK     ü2]B¢È3Ô  Ô    Queue.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
use strict;
package CPAN::Queue::Item;

# CPAN::Queue::Item::new ;
sub new {
    my($class,@attr) = @_;
    my $self = bless { @attr }, $class;
    return $self;
}

sub as_string {
    my($self) = @_;
    $self->{qmod};
}

# r => requires, b => build_requires, c => commandline
sub reqtype {
    my($self) = @_;
    $self->{reqtype};
}

sub optional {
    my($self) = @_;
    $self->{optional};
}

package CPAN::Queue;

# One use of the queue is to determine if we should or shouldn't
# announce the availability of a new CPAN module

# Now we try to use it for dependency tracking. For that to happen
# we need to draw a dependency tree and do the leaves first. This can
# easily be reached by running CPAN.pm recursively, but we don't want
# to waste memory and run into deep recursion. So what we can do is
# this:

# CPAN::Queue is the package where the queue is maintained. Dependencies
# often have high priority and must be brought to the head of the queue,
# possibly by jumping the queue if they are already there. My first code
# attempt tried to be extremely correct. Whenever a module needed
# immediate treatment, I either unshifted it to the front of the queue,
# or, if it was already in the queue, I spliced and let it bypass the
# others. This became a too correct model that made it impossible to put
# an item more than once into the queue. Why would you need that? Well,
# you need temporary duplicates as the manager of the queue is a loop
# that
#
#  (1) looks at the first item in the queue without shifting it off
#
#  (2) cares for the item
#
#  (3) removes the item from the queue, *even if its agenda failed and
#      even if the item isn't the first in the queue anymore* (that way
#      protecting against never ending queues)
#
# So if an item has prerequisites, the installation fails now, but we
# want to retry later. That's easy if we have it twice in the queue.
#
# I also expect insane dependency situations where an item gets more
# than two lives in the queue. Simplest example is triggered by 'install
# Foo Foo Foo'. People make this kind of mistakes and I don't want to
# get in the way. I wanted the queue manager to be a dumb servant, not
# one that knows everything.
#
# Who would I tell in this model that the user wants to be asked before
# processing? I can't attach that information to the module object,
# because not modules are installed but distributions. So I'd have to
# tell the distribution object that it should ask the user before
# processing. Where would the question be triggered then? Most probably
# in CPAN::Distribution::rematein.

use vars qw{ @All $VERSION };
$VERSION = "5.5003";

# CPAN::Queue::queue_item ;
sub queue_item {
    my($class,@attr) = @_;
    my $item = "$class\::Item"->new(@attr);
    $class->qpush($item);
    return 1;
}

# CPAN::Queue::qpush ;
sub qpush {
    my($class,$obj) = @_;
    push @All, $obj;
    CPAN->debug(sprintf("in new All[%s]",
                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
                       )) if $CPAN::DEBUG;
}

# CPAN::Queue::first ;
sub first {
    my $obj = $All[0];
    $obj;
}

# CPAN::Queue::delete_first ;
sub delete_first {
    my($class,$what) = @_;
    my $i;
    for my $i (0..$#All) {
        if (  $All[$i]->{qmod} eq $what ) {
            splice @All, $i, 1;
            last;
        }
    }
    CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
                        $what,
                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
                       )) if $CPAN::DEBUG;
}

# CPAN::Queue::jumpqueue ;
sub jumpqueue {
    my $class = shift;
    my @what = @_;
    CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
                       )) if $CPAN::DEBUG;
    unless (defined $what[0]{reqtype}) {
        # apparently it was not the Shell that sent us this enquiry,
        # treat it as commandline
        $what[0]{reqtype} = "c";
    }
    my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
  WHAT: for my $what_tuple (@what) {
        my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
        if ($reqtype eq "r"
            &&
            $inherit_reqtype eq "b"
           ) {
            $reqtype = "b";
        }
        my $jumped = 0;
        for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
            if ($All[$i]{qmod} eq $qmod) {
                $jumped++;
            }
        }
        # high jumped values are normal for popular modules when
        # dealing with large bundles: XML::Simple,
        # namespace::autoclean, UNIVERSAL::require
        CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
        my $obj = "$class\::Item"->new(
                                       qmod => $qmod,
                                       reqtype => $reqtype,
                                       optional => !! $optional,
                                      );
        unshift @All, $obj;
    }
    CPAN->debug(sprintf("after jumpqueue All[%s]",
                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
                       )) if $CPAN::DEBUG;
}

# CPAN::Queue::exists ;
sub exists {
    my($self,$what) = @_;
    my @all = map { $_->{qmod} } @All;
    my $exists = grep { $_->{qmod} eq $what } @All;
    # warn "in exists what[$what] all[@all] exists[$exists]";
    $exists;
}

# CPAN::Queue::delete ;
sub delete {
    my($self,$mod) = @_;
    @All = grep { $_->{qmod} ne $mod } @All;
    CPAN->debug(sprintf("after delete mod[%s] All[%s]",
                        $mod,
                        join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
                       )) if $CPAN::DEBUG;
}

# CPAN::Queue::nullify_queue ;
sub nullify_queue {
    @All = ();
}

# CPAN::Queue::size ;
sub size {
    return scalar @All;
}

sub reqtype_of {
    my($self,$mod) = @_;
    my $best = "";
    for my $item (grep { $_->{qmod} eq $mod } @All) {
        my $c = $item->{reqtype};
        if ($c eq "c") {
            $best = $c;
            last;
        } elsif ($c eq "r") {
            $best = $c;
        } elsif ($c eq "b") {
            if ($best eq "") {
                $best = $c;
            }
        } else {
            die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
        }
    }
    return $best;
}

sub iterator {
    my $i = 0;
    return sub {
        until ($All[$i] || $i > $#All) {
            $i++;
        }
        return if $i > $#All;
        return $All[$i++]
    };
}

1;

__END__

=head1 NAME

CPAN::Queue - internal queue support for CPAN.pm

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
PK     ü2]}lë¸+  +    API/HOWTO.podnu ÏÃ6Ç$        =head1 NAME

CPAN::API::HOWTO - a recipe book for programming with CPAN.pm

=head1 RECIPES

All of these recipes assume that you have put "use CPAN" at the top of
your program.

=head2 What distribution contains a particular module?

    my $distribution = CPAN::Shell->expand(
        "Module", "Data::UUID"
    )->distribution()->pretty_id();

This returns a string of the form "AUTHORID/TARBALL".  If you want the
full path and filename to this distribution on a CPAN mirror, then it is
C<.../authors/id/A/AU/AUTHORID/TARBALL>.

=head2 What modules does a particular distribution contain?

    CPAN::Index->reload();
    my @modules = CPAN::Shell->expand(
        "Distribution", "JHI/Graph-0.83.tar.gz"
    )->containsmods();

You may also refer to a distribution in the form A/AU/AUTHORID/TARBALL.

=head1 SEE ALSO

the main CPAN.pm documentation

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=head1 AUTHOR

David Cantrell

=cut
PK     ü2]§«LÛË ÛË   Distribution.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::Distribution;
use strict;
use Cwd qw(chdir);
use CPAN::Distroprefs;
use CPAN::InfoObj;
use File::Path ();
use POSIX ":sys_wait_h"; 
@CPAN::Distribution::ISA = qw(CPAN::InfoObj);
use vars qw($VERSION);
$VERSION = "2.34";

my $run_allow_installing_within_test = 1; # boolean; either in test or in install, there is no third option

# no prepare, because prepare is not a command on the shell command line
# TODO: clear instance cache on reload
my %instance;
for my $method (qw(get make test install)) {
    no strict 'refs';
    for my $prefix (qw(pre post)) {
        my $hookname = sprintf "%s_%s", $prefix, $method;
        *$hookname = sub {
            my($self) = @_;
            for my $plugin (@{$CPAN::Config->{plugin_list}}) {
                my($plugin_proper,$args) = split /=/, $plugin, 2;
                $args = "" unless defined $args;
                if ($CPAN::META->has_inst($plugin_proper)){
                    my @args = split /,/, $args;
                    $instance{$plugin} ||= $plugin_proper->new(@args);
                    if ($instance{$plugin}->can($hookname)) {
                        $instance{$plugin}->$hookname($self);
                    }
                } else {
                    $CPAN::Frontend->mydie("Plugin '$plugin_proper' not found for hook '$hookname'");
                }
            }
        };
    }
}

# Accessors
sub cpan_comment {
    my $self = shift;
    my $ro = $self->ro or return;
    $ro->{CPAN_COMMENT}
}

#-> CPAN::Distribution::undelay
sub undelay {
    my $self = shift;
    for my $delayer (
                     "configure_requires_later",
                     "configure_requires_later_for",
                     "later",
                     "later_for",
                    ) {
        delete $self->{$delayer};
    }
}

#-> CPAN::Distribution::is_dot_dist
sub is_dot_dist {
    my($self) = @_;
    return substr($self->id,-1,1) eq ".";
}

# add the A/AN/ stuff
#-> CPAN::Distribution::normalize
sub normalize {
    my($self,$s) = @_;
    $s = $self->id unless defined $s;
    if (substr($s,-1,1) eq ".") {
        # using a global because we are sometimes called as static method
        if (!$CPAN::META->{LOCK}
            && !$CPAN::Have_warned->{"$s is unlocked"}++
           ) {
            $CPAN::Frontend->mywarn("You are visiting the local directory
  '$s'
  without lock, take care that concurrent processes do not do likewise.\n");
            $CPAN::Frontend->mysleep(1);
        }
        if ($s eq ".") {
            $s = "$CPAN::iCwd/.";
        } elsif (File::Spec->file_name_is_absolute($s)) {
        } elsif (File::Spec->can("rel2abs")) {
            $s = File::Spec->rel2abs($s);
        } else {
            $CPAN::Frontend->mydie("Your File::Spec is too old, please upgrade File::Spec");
        }
        CPAN->debug("s[$s]") if $CPAN::DEBUG;
        unless ($CPAN::META->exists("CPAN::Distribution", $s)) {
            for ($CPAN::META->instance("CPAN::Distribution", $s)) {
                $_->{build_dir} = $s;
                $_->{archived} = "local_directory";
                $_->{unwrapped} = CPAN::Distrostatus->new("YES -- local_directory");
            }
        }
    } elsif (
        $s =~ tr|/|| == 1
        or
        $s !~ m|[A-Z]/[A-Z-0-9]{2}/[A-Z-0-9]{2,}/|
       ) {
        return $s if $s =~ m:^N/A|^Contact Author: ;
        $s =~ s|^(.)(.)([^/]*/)(.+)$|$1/$1$2/$1$2$3$4|;
        CPAN->debug("s[$s]") if $CPAN::DEBUG;
    }
    $s;
}

#-> sub CPAN::Distribution::author ;
sub author {
    my($self) = @_;
    my($authorid);
    if (substr($self->id,-1,1) eq ".") {
        $authorid = "LOCAL";
    } else {
        ($authorid) = $self->pretty_id =~ /^([\w\-]+)/;
    }
    CPAN::Shell->expand("Author",$authorid);
}

# tries to get the yaml from CPAN instead of the distro itself:
# EXPERIMENTAL, UNDOCUMENTED AND UNTESTED, for Tels
sub fast_yaml {
    my($self) = @_;
    my $meta = $self->pretty_id;
    $meta =~ s/\.(tar.gz|tgz|zip|tar.bz2)/.meta/;
    my(@ls) = CPAN::Shell->globls($meta);
    my $norm = $self->normalize($meta);

    my($local_file);
    my($local_wanted) =
        File::Spec->catfile(
                            $CPAN::Config->{keep_source_where},
                            "authors",
                            "id",
                            split(/\//,$norm)
                           );
    $self->debug("Doing localize") if $CPAN::DEBUG;
    unless ($local_file =
            CPAN::FTP->localize("authors/id/$norm",
                                $local_wanted)) {
        $CPAN::Frontend->mydie("Giving up on downloading yaml file '$local_wanted'\n");
    }
    my $yaml = CPAN->_yaml_loadfile($local_file)->[0];
}

#-> sub CPAN::Distribution::cpan_userid
sub cpan_userid {
    my $self = shift;
    if ($self->{ID} =~ m{[A-Z]/[A-Z\-]{2}/([A-Z\-]+)/}) {
        return $1;
    }
    return $self->SUPER::cpan_userid;
}

#-> sub CPAN::Distribution::pretty_id
sub pretty_id {
    my $self = shift;
    my $id = $self->id;
    return $id unless $id =~ m|^./../|;
    substr($id,5);
}

#-> sub CPAN::Distribution::base_id
sub base_id {
    my $self = shift;
    my $id = $self->pretty_id();
    my $base_id = File::Basename::basename($id);
    $base_id =~ s{\.(?:tar\.(bz2|gz|Z)|t(?:gz|bz)|zip)$}{}i;
    return $base_id;
}

#-> sub CPAN::Distribution::tested_ok_but_not_installed
sub tested_ok_but_not_installed {
    my $self = shift;
    return (
           $self->{make_test}
        && $self->{build_dir}
        && (UNIVERSAL::can($self->{make_test},"failed") ?
             ! $self->{make_test}->failed :
             $self->{make_test} =~ /^YES/
            )
        && (
            !$self->{install}
            ||
            $self->{install}->failed
           )
    );
}


# mark as dirty/clean for the sake of recursion detection. $color=1
# means "in use", $color=0 means "not in use anymore". $color=2 means
# we have determined prereqs now and thus insist on passing this
# through (at least) once again.

#-> sub CPAN::Distribution::color_cmd_tmps ;
sub color_cmd_tmps {
    my($self) = shift;
    my($depth) = shift || 0;
    my($color) = shift || 0;
    my($ancestors) = shift || [];
    # a distribution needs to recurse into its prereq_pms
    $self->debug("color_cmd_tmps[$depth,$color,@$ancestors]") if $CPAN::DEBUG;

    return if exists $self->{incommandcolor}
        && $color==1
        && $self->{incommandcolor}==$color;
    $CPAN::MAX_RECURSION||=0; # silence 'once' warnings
    if ($depth>=$CPAN::MAX_RECURSION) {
        my $e = CPAN::Exception::RecursiveDependency->new($ancestors);
        if ($e->is_resolvable) {
            return $self->{incommandcolor}=2;
        } else {
            die $e;
        }
    }
    # warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
    my $prereq_pm = $self->prereq_pm;
    if (defined $prereq_pm) {
        # XXX also optional_req & optional_breq? -- xdg, 2012-04-01
        # A: no, optional deps may recurse -- ak, 2014-05-07
      PREREQ: for my $pre (sort(
                keys %{$prereq_pm->{requires}||{}},
                keys %{$prereq_pm->{build_requires}||{}},
            )) {
            next PREREQ if $pre eq "perl";
            my $premo;
            unless ($premo = CPAN::Shell->expand("Module",$pre)) {
                $CPAN::Frontend->mywarn("prerequisite module[$pre] not known\n");
                $CPAN::Frontend->mysleep(0.2);
                next PREREQ;
            }
            $premo->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
        }
    }
    if ($color==0) {
        delete $self->{sponsored_mods};

        # as we are at the end of a command, we'll give up this
        # reminder of a broken test. Other commands may test this guy
        # again. Maybe 'badtestcnt' should be renamed to
        # 'make_test_failed_within_command'?
        delete $self->{badtestcnt};
    }
    $self->{incommandcolor} = $color;
}

#-> sub CPAN::Distribution::as_string ;
sub as_string {
    my $self = shift;
    $self->containsmods;
    $self->upload_date;
    $self->SUPER::as_string(@_);
}

#-> sub CPAN::Distribution::containsmods ;
sub containsmods {
    my $self = shift;
    return sort keys %{$self->{CONTAINSMODS}} if exists $self->{CONTAINSMODS};
    my $dist_id = $self->{ID};
    for my $mod ($CPAN::META->all_objects("CPAN::Module")) {
        my $mod_file = $mod->cpan_file or next;
        my $mod_id = $mod->{ID} or next;
        # warn "mod_file[$mod_file] dist_id[$dist_id] mod_id[$mod_id]";
        # sleep 1;
        if ($CPAN::Signal) {
            delete $self->{CONTAINSMODS};
            return;
        }
        $self->{CONTAINSMODS}{$mod_id} = undef if $mod_file eq $dist_id;
    }
    sort keys %{$self->{CONTAINSMODS}||={}};
}

#-> sub CPAN::Distribution::upload_date ;
sub upload_date {
    my $self = shift;
    return $self->{UPLOAD_DATE} if exists $self->{UPLOAD_DATE};
    my(@local_wanted) = split(/\//,$self->id);
    my $filename = pop @local_wanted;
    push @local_wanted, "CHECKSUMS";
    my $author = CPAN::Shell->expand("Author",$self->cpan_userid);
    return unless $author;
    my @dl = $author->dir_listing(\@local_wanted,0,$CPAN::Config->{show_upload_date});
    return unless @dl;
    my($dirent) = grep { $_->[2] eq $filename } @dl;
    # warn sprintf "dirent[%s]id[%s]", $dirent, $self->id;
    return unless $dirent->[1];
    return $self->{UPLOAD_DATE} = $dirent->[1];
}

#-> sub CPAN::Distribution::uptodate ;
sub uptodate {
    my($self) = @_;
    my $c;
    foreach $c ($self->containsmods) {
        my $obj = CPAN::Shell->expandany($c);
        unless ($obj->uptodate) {
            my $id = $self->pretty_id;
            $self->debug("$id not uptodate due to $c") if $CPAN::DEBUG;
            return 0;
        }
    }
    return 1;
}

#-> sub CPAN::Distribution::called_for ;
sub called_for {
    my($self,$id) = @_;
    $self->{CALLED_FOR} = $id if defined $id;
    return $self->{CALLED_FOR};
}

#-> sub CPAN::Distribution::shortcut_get ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success
sub shortcut_get {
    my ($self) = @_;

    if (exists $self->{cleanup_after_install_done}) {
        if ($self->{force_update}) {
            delete $self->{cleanup_after_install_done};
        } else {
            my $id = $self->{CALLED_FOR} || $self->pretty_id;
            return $self->success(
                "Has already been *installed and cleaned up in the staging area* within this session, will not work on it again; if you really want to start over, try something like `force get $id`"
            );
        }
    }

    if (my $why = $self->check_disabled) {
        $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
        # XXX why is this goodbye() instead of just print/warn?
        # Alternatively, should other print/warns here be goodbye()?
        # -- xdg, 2012-04-05
        return $self->goodbye("[disabled] -- NA $why");
    }

    $self->debug("checking already unwrapped[$self->{ID}]") if $CPAN::DEBUG;
    if (exists $self->{build_dir} && -d $self->{build_dir}) {
        # this deserves print, not warn:
        return $self->success("Has already been unwrapped into directory ".
            "$self->{build_dir}"
        );
    }

    # XXX I'm not sure this should be here because it's not really
    # a test for whether get should continue or return; this is
    # a side effect -- xdg, 2012-04-05
    $self->debug("checking missing build_dir[$self->{ID}]") if $CPAN::DEBUG;
    if (exists $self->{build_dir} && ! -d $self->{build_dir}){
        # we have lost it.
        $self->fforce(""); # no method to reset all phases but not set force (dodge)
        return undef; # no shortcut
    }

    # although we talk about 'force' we shall not test on
    # force directly. New model of force tries to refrain from
    # direct checking of force.
    $self->debug("checking unwrapping error[$self->{ID}]") if $CPAN::DEBUG;
    if ( exists $self->{unwrapped} and (
            UNIVERSAL::can($self->{unwrapped},"failed") ?
            $self->{unwrapped}->failed :
            $self->{unwrapped} =~ /^NO/ )
    ) {
        return $self->goodbye("Unwrapping had some problem, won't try again without force");
    }

    return undef; # no shortcut
}

#-> sub CPAN::Distribution::get ;
sub get {
    my($self) = @_;

    $self->pre_get();

    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
    if (my $goto = $self->prefs->{goto}) {
        $self->post_get();
        return $self->goto($goto);
    }

    if ( defined( my $sc = $self->shortcut_get) ) {
        $self->post_get();
        return $sc;
    }

    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
                           ? $ENV{PERL5LIB}
                           : ($ENV{PERLLIB} || "");
    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
    # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # get
    $CPAN::META->set_perl5lib;
    local $ENV{MAKEFLAGS}; # protect us from outer make calls

    my $sub_wd = CPAN::anycwd(); # for cleaning up as good as possible

    my($local_file);
    # XXX I don't think this check needs to be here, as it
    # is already checked in shortcut_get() -- xdg, 2012-04-05
    unless ($self->{build_dir} && -d $self->{build_dir}) {
        $self->get_file_onto_local_disk;
        if ($CPAN::Signal){
            $self->post_get();
            return;
        }
        $self->check_integrity;
        if ($CPAN::Signal){
            $self->post_get();
            return;
        }
        (my $packagedir,$local_file) = $self->run_preps_on_packagedir;
        # XXX why is this check here? -- xdg, 2012-04-08
        if (exists $self->{writemakefile} && ref $self->{writemakefile}
           && $self->{writemakefile}->can("failed") &&
           $self->{writemakefile}->failed) {
           #
            $self->post_get();
            return;
        }
        $packagedir ||= $self->{build_dir};
        $self->{build_dir} = $packagedir;
    }

    # XXX should this move up to after run_preps_on_packagedir?
    # Otherwise, failing writemakefile can return without
    # a $CPAN::Signal check -- xdg, 2012-04-05
    if ($CPAN::Signal) {
        $self->safe_chdir($sub_wd);
        $self->post_get();
        return;
    }
    unless ($self->patch){
        $self->post_get();
        return;
    }
    $self->store_persistent_state;

    $self->post_get();

    return 1; # success
}

#-> CPAN::Distribution::get_file_onto_local_disk
sub get_file_onto_local_disk {
    my($self) = @_;

    return if $self->is_dot_dist;
    my($local_file);
    my($local_wanted) =
        File::Spec->catfile(
                            $CPAN::Config->{keep_source_where},
                            "authors",
                            "id",
                            split(/\//,$self->id)
                           );

    $self->debug("Doing localize") if $CPAN::DEBUG;
    unless ($local_file =
            CPAN::FTP->localize("authors/id/$self->{ID}",
                                $local_wanted)) {
        my $note = "";
        if ($CPAN::Index::DATE_OF_02) {
            $note = "Note: Current database in memory was generated ".
                "on $CPAN::Index::DATE_OF_02\n";
        }
        $CPAN::Frontend->mydie("Giving up on '$local_wanted'\n$note");
    }

    $self->debug("local_wanted[$local_wanted]local_file[$local_file]") if $CPAN::DEBUG;
    $self->{localfile} = $local_file;
}


#-> CPAN::Distribution::check_integrity
sub check_integrity {
    my($self) = @_;

    return if $self->is_dot_dist;
    if ($CPAN::META->has_inst("Digest::SHA")) {
        $self->debug("Digest::SHA is installed, verifying");
        $self->verifyCHECKSUM;
    } else {
        $self->debug("Digest::SHA is NOT installed");
    }
}

#-> CPAN::Distribution::run_preps_on_packagedir
sub run_preps_on_packagedir {
    my($self) = @_;
    return if $self->is_dot_dist;

    $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new(); # unsafe meta access, ok
    my $builddir = $CPAN::META->{cachemgr}->dir; # unsafe meta access, ok
    $self->safe_chdir($builddir);
    $self->debug("Removing tmp-$$") if $CPAN::DEBUG;
    File::Path::rmtree("tmp-$$");
    unless (mkdir "tmp-$$", 0755) {
        $CPAN::Frontend->unrecoverable_error(<<EOF);
Couldn't mkdir '$builddir/tmp-$$': $!

Cannot continue: Please find the reason why I cannot make the
directory
$builddir/tmp-$$
and fix the problem, then retry.

EOF
    }
    if ($CPAN::Signal) {
        return;
    }
    $self->safe_chdir("tmp-$$");

    #
    # Unpack the goods
    #
    my $local_file = $self->{localfile};
    my $ct = eval{CPAN::Tarzip->new($local_file)};
    unless ($ct) {
        $self->{unwrapped} = CPAN::Distrostatus->new("NO");
        delete $self->{build_dir};
        return;
    }
    if ($local_file =~ /(\.tar\.(bz2|gz|Z)|\.tgz)(?!\n)\Z/i) {
        $self->{was_uncompressed}++ unless eval{$ct->gtest()};
        $self->untar_me($ct);
    } elsif ( $local_file =~ /\.zip(?!\n)\Z/i ) {
        $self->unzip_me($ct);
    } else {
        $self->{was_uncompressed}++ unless $ct->gtest();
        $local_file = $self->handle_singlefile($local_file);
    }

    # we are still in the tmp directory!
    # Let's check if the package has its own directory.
    my $dh = DirHandle->new(File::Spec->curdir)
        or Carp::croak("Couldn't opendir .: $!");
    my @readdir = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh->read; ### MAC??
    if (grep { $_ eq "pax_global_header" } @readdir) {
        $CPAN::Frontend->mywarn("Your (un)tar seems to have extracted a file named 'pax_global_header'
from the tarball '$local_file'.
This is almost certainly an error. Please upgrade your tar.
I'll ignore this file for now.
See also http://rt.cpan.org/Ticket/Display.html?id=38932\n");
        $CPAN::Frontend->mysleep(5);
        @readdir = grep { $_ ne "pax_global_header" } @readdir;
    }
    $dh->close;
    my $tdir_base;
    my $from_dir;
    my @dirents;
    if (@readdir == 1 && -d $readdir[0]) {
        $tdir_base = $readdir[0];
        $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]);
        my($mode) = (stat $from_dir)[2];
        chmod $mode | 00755, $from_dir; # JONATHAN/Math-Calculus-TaylorSeries-0.1.tar.gz has 0644
        my $dh2;
        unless ($dh2 = DirHandle->new($from_dir)) {
            my $why = sprintf
                (
                 "Couldn't opendir '%s', mode '%o': %s",
                 $from_dir,
                 $mode,
                 $!,
                );
            $CPAN::Frontend->mywarn("$why\n");
            $self->{writemakefile} = CPAN::Distrostatus->new("NO -- $why");
            return;
        }
        @dirents = grep $_ !~ /^\.\.?(?!\n)\Z/s, $dh2->read; ### MAC??
    } else {
        my $userid = $self->cpan_userid;
        CPAN->debug("userid[$userid]");
        if (!$userid or $userid eq "N/A") {
            $userid = "anon";
        }
        $tdir_base = $userid;
        $from_dir = File::Spec->curdir;
        @dirents = @readdir;
    }
    my $packagedir;
    my $eexist = ($CPAN::META->has_usable("Errno") && defined &Errno::EEXIST)
        ? &Errno::EEXIST : undef;
    for(my $suffix = 0; ; $suffix++) {
        $packagedir = File::Spec->catdir($builddir, "$tdir_base-$suffix");
        my $parent = $builddir;
        mkdir($packagedir, 0777) and last;
        if((defined($eexist) && $! != $eexist) || $suffix == 999) {
            $CPAN::Frontend->mydie("Cannot create directory $packagedir: $!\n");
        }
    }
    my $f;
    for $f (@dirents) { # is already without "." and ".."
        my $from = File::Spec->catfile($from_dir,$f);
        my($mode) = (stat $from)[2];
        chmod $mode | 00755, $from if -d $from; # OTTO/Pod-Trial-LinkImg-0.005.tgz
        my $to = File::Spec->catfile($packagedir,$f);
        unless (File::Copy::move($from,$to)) {
            my $err = $!;
            $from = File::Spec->rel2abs($from);
            $CPAN::Frontend->mydie(
                "Couldn't move $from to $to: $err; #82295? ".
                "CPAN::VERSION=$CPAN::VERSION; ".
                "File::Copy::VERSION=$File::Copy::VERSION; ".
                "$from " . (-e $from ? "exists; " : "does not exist; ").
                "$to " . (-e $to ? "exists; " : "does not exist; ").
                "cwd=" . CPAN::anycwd() . ";"
            );
        }
    }
    $self->{build_dir} = $packagedir;
    $self->safe_chdir($builddir);
    File::Path::rmtree("tmp-$$");

    $self->safe_chdir($packagedir);
    $self->_signature_business();
    $self->safe_chdir($builddir);

    return($packagedir,$local_file);
}

#-> sub CPAN::Distribution::pick_meta_file ;
sub pick_meta_file {
    my($self, $filter) = @_;
    $filter = '.' unless defined $filter;

    my $build_dir;
    unless ($build_dir = $self->{build_dir}) {
        # maybe permission on build_dir was missing
        $CPAN::Frontend->mywarn("Warning: cannot determine META.yml without a build_dir.\n");
        return;
    }

    my $has_cm = $CPAN::META->has_usable("CPAN::Meta");
    my $has_pcm = $CPAN::META->has_usable("Parse::CPAN::Meta");

    my @choices;
    push @choices, 'MYMETA.json' if $has_cm;
    push @choices, 'MYMETA.yml' if $has_cm || $has_pcm;
    push @choices, 'META.json' if $has_cm;
    push @choices, 'META.yml' if $has_cm || $has_pcm;

    for my $file ( grep { /$filter/ } @choices ) {
        my $path = File::Spec->catfile( $build_dir, $file );
        return $path if -f $path
    }

    return;
}

#-> sub CPAN::Distribution::parse_meta_yml ;
sub parse_meta_yml {
    my($self, $yaml) = @_;
    $self->debug(sprintf("parse_meta_yml[%s]",$yaml||'undef')) if $CPAN::DEBUG;
    my $build_dir = $self->{build_dir} or die "PANIC: cannot parse yaml without a build_dir";
    $yaml ||= File::Spec->catfile($build_dir,"META.yml");
    $self->debug("meta[$yaml]") if $CPAN::DEBUG;
    return unless -f $yaml;
    my $early_yaml;
    eval {
        $CPAN::META->has_inst("Parse::CPAN::Meta") or die;
        die "Parse::CPAN::Meta yaml too old" unless $Parse::CPAN::Meta::VERSION >= "1.40";
        # P::C::M returns last document in scalar context
        $early_yaml = Parse::CPAN::Meta::LoadFile($yaml);
    };
    unless ($early_yaml) {
        eval { $early_yaml = CPAN->_yaml_loadfile($yaml)->[0]; };
    }
    $self->debug(sprintf("yaml[%s]", $early_yaml || 'UNDEF')) if $CPAN::DEBUG;
    $self->debug($early_yaml) if $CPAN::DEBUG && $early_yaml;
    if (!ref $early_yaml or ref $early_yaml ne "HASH"){
        # fix rt.cpan.org #95271
        $CPAN::Frontend->mywarn("The content of '$yaml' is not a HASH reference. Cannot use it.\n");
        return {};
    }
    return $early_yaml || undef;
}

#-> sub CPAN::Distribution::satisfy_requires ;
# return values: 1 means requirements are satisfied;
# and 0 means not satisfied (and maybe queued)
sub satisfy_requires {
    my ($self) = @_;
    $self->debug("Entering satisfy_requires") if $CPAN::DEBUG;
    if (my @prereq = $self->unsat_prereq("later")) {
        if ($CPAN::DEBUG){
            require Data::Dumper;
            my $prereq = Data::Dumper->new(\@prereq)->Terse(1)->Indent(0)->Dump;
            $self->debug("unsatisfied[$prereq]");
        }
        if ($prereq[0][0] eq "perl") {
            my $need = "requires perl '$prereq[0][1]'";
            my $id = $self->pretty_id;
            $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
            $self->{make} = CPAN::Distrostatus->new("NO $need");
            $self->store_persistent_state;
            die "[prereq] -- NOT OK\n";
        } else {
            my $follow = eval { $self->follow_prereqs("later",@prereq); };
            if (0) {
            } elsif ($follow) {
                return; # we need deps
            } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
                $CPAN::Frontend->mywarn($@);
                die "[depend] -- NOT OK\n";
            }
        }
    }
    return 1;
}

#-> sub CPAN::Distribution::satisfy_configure_requires ;
# return values: 1 means configure_require is satisfied;
# and 0 means not satisfied (and maybe queued)
sub satisfy_configure_requires {
    my($self) = @_;
    $self->debug("Entering satisfy_configure_requires") if $CPAN::DEBUG;
    my $enable_configure_requires = 1;
    if (!$enable_configure_requires) {
        return 1;
        # if we return 1 here, everything is as before we introduced
        # configure_requires that means, things with
        # configure_requires simply fail, all others succeed
    }
    my @prereq = $self->unsat_prereq("configure_requires_later");
    $self->debug(sprintf "configure_requires[%s]", join(",",map {join "/",@$_} @prereq)) if $CPAN::DEBUG;
    return 1 unless @prereq;
    $self->debug(\@prereq) if $CPAN::DEBUG;
    if ($self->{configure_requires_later}) {
        for my $k (sort keys %{$self->{configure_requires_later_for}||{}}) {
            if ($self->{configure_requires_later_for}{$k}>1) {
                my $type = "";
                for my $p (@prereq) {
                    if ($p->[0] eq $k) {
                        $type = $p->[1];
                    }
                }
                $type = " $type" if $type;
                $CPAN::Frontend->mywarn("Warning: unmanageable(?) prerequisite $k$type");
                sleep 1;
            }
        }
    }
    if ($prereq[0][0] eq "perl") {
        my $need = "requires perl '$prereq[0][1]'";
        my $id = $self->pretty_id;
        $CPAN::Frontend->mywarn("$id $need; you have only $]; giving up\n");
        $self->{make} = CPAN::Distrostatus->new("NO $need");
        $self->store_persistent_state;
        return $self->goodbye("[prereq] -- NOT OK");
    } else {
        my $follow = eval {
            $self->follow_prereqs("configure_requires_later", @prereq);
        };
        if (0) {
        } elsif ($follow) {
            return; # we need deps
        } elsif ($@ && ref $@ && $@->isa("CPAN::Exception::RecursiveDependency")) {
            $CPAN::Frontend->mywarn($@);
            return $self->goodbye("[depend] -- NOT OK");
        }
        else {
          return $self->goodbye("[configure_requires] -- NOT OK");
        }
    }
    die "never reached";
}

#-> sub CPAN::Distribution::choose_MM_or_MB ;
sub choose_MM_or_MB {
    my($self) = @_;
    $self->satisfy_configure_requires() or return;
    my $local_file = $self->{localfile};
    my($mpl) = File::Spec->catfile($self->{build_dir},"Makefile.PL");
    my($mpl_exists) = -f $mpl;
    unless ($mpl_exists) {
        # NFS has been reported to have racing problems after the
        # renaming of a directory in some environments.
        # This trick helps.
        $CPAN::Frontend->mysleep(1);
        my $mpldh = DirHandle->new($self->{build_dir})
            or Carp::croak("Couldn't opendir $self->{build_dir}: $!");
        $mpl_exists = grep /^Makefile\.PL$/, $mpldh->read;
        $mpldh->close;
    }
    my $prefer_installer = "eumm"; # eumm|mb
    if (-f File::Spec->catfile($self->{build_dir},"Build.PL")) {
        if ($mpl_exists) { # they *can* choose
            if ($CPAN::META->has_inst("Module::Build")) {
                $prefer_installer = CPAN::HandleConfig->prefs_lookup(
                  $self, q{prefer_installer}
                );
                # M::B <= 0.35 left a DATA handle open that
                # causes problems upgrading M::B on Windows
                close *Module::Build::Version::DATA
                  if fileno *Module::Build::Version::DATA;
            }
        } else {
            $prefer_installer = "mb";
        }
    }
    if (lc($prefer_installer) eq "rand") {
        $prefer_installer = rand()<.5 ? "eumm" : "mb";
    }
    if (lc($prefer_installer) eq "mb") {
        $self->{modulebuild} = 1;
    } elsif ($self->{archived} eq "patch") {
        # not an edge case, nothing to install for sure
        my $why = "A patch file cannot be installed";
        $CPAN::Frontend->mywarn("Refusing to handle this file: $why\n");
        $self->{writemakefile} = CPAN::Distrostatus->new("NO $why");
    } elsif (! $mpl_exists) {
        $self->_edge_cases($mpl,$local_file);
    }
    if ($self->{build_dir}
        &&
        $CPAN::Config->{build_dir_reuse}
       ) {
        $self->store_persistent_state;
    }
    return $self;
}

# see also reanimate_build_dir
#-> CPAN::Distribution::store_persistent_state
sub store_persistent_state {
    my($self) = @_;
    my $dir = $self->{build_dir};
    unless (defined $dir && length $dir) {
        my $id = $self->id;
        $CPAN::Frontend->mywarnonce("build_dir of $id is not known, ".
                                    "will not store persistent state\n");
        return;
    }
    # self-build-dir
    my $sbd = Cwd::realpath(
        File::Spec->catdir($dir,                       File::Spec->updir ())
                           );
    # config-build-dir
    my $cbd = Cwd::realpath(
        # the catdir is a workaround for bug https://rt.cpan.org/Ticket/Display.html?id=101283
        File::Spec->catdir($CPAN::Config->{build_dir}, File::Spec->curdir())
    );
    unless ($sbd eq $cbd) {
        $CPAN::Frontend->mywarnonce("Directory '$dir' not below $CPAN::Config->{build_dir}, ".
                                    "will not store persistent state\n");
        return;
    }
    my $file = sprintf "%s.yml", $dir;
    my $yaml_module = CPAN::_yaml_module();
    if ($CPAN::META->has_inst($yaml_module)) {
        CPAN->_yaml_dumpfile(
                             $file,
                             {
                              time => time,
                              perl => CPAN::_perl_fingerprint(),
                              distribution => $self,
                             }
                            );
    } else {
        $CPAN::Frontend->myprintonce("'$yaml_module' not installed, ".
                                    "will not store persistent state\n");
    }
}

#-> CPAN::Distribution::try_download
sub try_download {
    my($self,$patch) = @_;
    my $norm = $self->normalize($patch);
    my($local_wanted) =
        File::Spec->catfile(
                            $CPAN::Config->{keep_source_where},
                            "authors",
                            "id",
                            split(/\//,$norm),
                           );
    $self->debug("Doing localize") if $CPAN::DEBUG;
    return CPAN::FTP->localize("authors/id/$norm",
                               $local_wanted);
}

{
    my $stdpatchargs = "";
    #-> CPAN::Distribution::patch
    sub patch {
        my($self) = @_;
        $self->debug("checking patches id[$self->{ID}]") if $CPAN::DEBUG;
        my $patches = $self->prefs->{patches};
        $patches ||= "";
        $self->debug("patches[$patches]") if $CPAN::DEBUG;
        if ($patches) {
            return unless @$patches;
            $self->safe_chdir($self->{build_dir});
            CPAN->debug("patches[$patches]") if $CPAN::DEBUG;
            my $patchbin = $CPAN::Config->{patch};
            unless ($patchbin && length $patchbin) {
                $CPAN::Frontend->mydie("No external patch command configured\n\n".
                                       "Please run 'o conf init /patch/'\n\n");
            }
            unless (MM->maybe_command($patchbin)) {
                $CPAN::Frontend->mydie("No external patch command available\n\n".
                                       "Please run 'o conf init /patch/'\n\n");
            }
            $patchbin = CPAN::HandleConfig->safe_quote($patchbin);
            local $ENV{PATCH_GET} = 0; # formerly known as -g0
            unless ($stdpatchargs) {
                my $system = "$patchbin --version |";
                local *FH;
                open FH, $system or die "Could not fork '$system': $!";
                local $/ = "\n";
                my $pversion;
              PARSEVERSION: while (<FH>) {
                    if (/^patch\s+([\d\.]+)/) {
                        $pversion = $1;
                        last PARSEVERSION;
                    }
                }
                if ($pversion) {
                    $stdpatchargs = "-N --fuzz=3";
                } else {
                    $stdpatchargs = "-N";
                }
            }
            my $countedpatches = @$patches == 1 ? "1 patch" : (scalar @$patches . " patches");
            $CPAN::Frontend->myprint("Applying $countedpatches:\n");
            my $patches_dir = $CPAN::Config->{patches_dir};
            for my $patch (@$patches) {
                if ($patches_dir && !File::Spec->file_name_is_absolute($patch)) {
                    my $f = File::Spec->catfile($patches_dir, $patch);
                    $patch = $f if -f $f;
                }
                unless (-f $patch) {
                    CPAN->debug("not on disk: patch[$patch]") if $CPAN::DEBUG;
                    if (my $trydl = $self->try_download($patch)) {
                        $patch = $trydl;
                    } else {
                        my $fail = "Could not find patch '$patch'";
                        $CPAN::Frontend->mywarn("$fail; cannot continue\n");
                        $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
                        delete $self->{build_dir};
                        return;
                    }
                }
                $CPAN::Frontend->myprint("  $patch\n");
                my $readfh = CPAN::Tarzip->TIEHANDLE($patch);

                my $pcommand;
                my($ppp,$pfiles) = $self->_patch_p_parameter($readfh);
                if ($ppp eq "applypatch") {
                    $pcommand = "$CPAN::Config->{applypatch} -verbose";
                } else {
                    my $thispatchargs = join " ", $stdpatchargs, $ppp;
                    $pcommand = "$patchbin $thispatchargs";
                    require Config; # usually loaded from CPAN.pm
                    if ($Config::Config{osname} eq "solaris") {
                        # native solaris patch cannot patch readonly files
                        for my $file (@{$pfiles||[]}) {
                            my @stat = stat $file or next;
                            chmod $stat[2] | 0600, $file; # may fail
                        }
                    }
                }

                $readfh = CPAN::Tarzip->TIEHANDLE($patch); # open again
                my $writefh = FileHandle->new;
                $CPAN::Frontend->myprint("  $pcommand\n");
                unless (open $writefh, "|$pcommand") {
                    my $fail = "Could not fork '$pcommand'";
                    $CPAN::Frontend->mywarn("$fail; cannot continue\n");
                    $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
                    delete $self->{build_dir};
                    return;
                }
                binmode($writefh);
                while (my $x = $readfh->READLINE) {
                    print $writefh $x;
                }
                unless (close $writefh) {
                    my $fail = "Could not apply patch '$patch'";
                    $CPAN::Frontend->mywarn("$fail; cannot continue\n");
                    $self->{unwrapped} = CPAN::Distrostatus->new("NO -- $fail");
                    delete $self->{build_dir};
                    return;
                }
            }
            $self->{patched}++;
        }
        return 1;
    }
}

# may return
# - "applypatch"
# - ("-p0"|"-p1", $files)
sub _patch_p_parameter {
    my($self,$fh) = @_;
    my $cnt_files   = 0;
    my $cnt_p0files = 0;
    my @files;
    local($_);
    while ($_ = $fh->READLINE) {
        if (
            $CPAN::Config->{applypatch}
            &&
            /\#\#\#\# ApplyPatch data follows \#\#\#\#/
           ) {
            return "applypatch"
        }
        next unless /^[\*\+]{3}\s(\S+)/;
        my $file = $1;
        push @files, $file;
        $cnt_files++;
        $cnt_p0files++ if -f $file;
        CPAN->debug("file[$file]cnt_files[$cnt_files]cnt_p0files[$cnt_p0files]")
            if $CPAN::DEBUG;
    }
    return "-p1" unless $cnt_files;
    my $opt_p = $cnt_files==$cnt_p0files ? "-p0" : "-p1";
    return ($opt_p, \@files);
}

#-> sub CPAN::Distribution::_edge_cases
# with "configure" or "Makefile" or single file scripts
sub _edge_cases {
    my($self,$mpl,$local_file) = @_;
    $self->debug(sprintf("makefilepl[%s]anycwd[%s]",
                         $mpl,
                         CPAN::anycwd(),
                        )) if $CPAN::DEBUG;
    my $build_dir = $self->{build_dir};
    my($configure) = File::Spec->catfile($build_dir,"Configure");
    if (-f $configure) {
        # do we have anything to do?
        $self->{configure} = $configure;
    } elsif (-f File::Spec->catfile($build_dir,"Makefile")) {
        $CPAN::Frontend->mywarn(qq{
Package comes with a Makefile and without a Makefile.PL.
We\'ll try to build it with that Makefile then.
});
        $self->{writemakefile} = CPAN::Distrostatus->new("YES");
        $CPAN::Frontend->mysleep(2);
    } else {
        my $cf = $self->called_for || "unknown";
        if ($cf =~ m|/|) {
            $cf =~ s|.*/||;
            $cf =~ s|\W.*||;
        }
        $cf =~ s|[/\\:]||g;     # risk of filesystem damage
        $cf = "unknown" unless length($cf);
        if (my $crud = $self->_contains_crud($build_dir)) {
            my $why = qq{Package contains $crud; not recognized as a perl package, giving up};
            $CPAN::Frontend->mywarn("$why\n");
            $self->{writemakefile} = CPAN::Distrostatus->new(qq{NO -- $why});
            return;
        }
        $CPAN::Frontend->mywarn(qq{Package seems to come without Makefile.PL.
  (The test -f "$mpl" returned false.)
  Writing one on our own (setting NAME to $cf)\a\n});
        $self->{had_no_makefile_pl}++;
        $CPAN::Frontend->mysleep(3);

        # Writing our own Makefile.PL

        my $exefile_stanza = "";
        if ($self->{archived} eq "maybe_pl") {
            $exefile_stanza = $self->_exefile_stanza($build_dir,$local_file);
        }

        my $fh = FileHandle->new;
        $fh->open(">$mpl")
            or Carp::croak("Could not open >$mpl: $!");
        $fh->print(
                   qq{# This Makefile.PL has been autogenerated by the module CPAN.pm
# because there was no Makefile.PL supplied.
# Autogenerated on: }.scalar localtime().qq{

use ExtUtils::MakeMaker;
WriteMakefile(
              NAME => q[$cf],$exefile_stanza
             );
});
        $fh->close;
    }
}

#-> CPAN;:Distribution::_contains_crud
sub _contains_crud {
    my($self,$dir) = @_;
    my(@dirs, $dh, @files);
    opendir $dh, $dir or return;
    my $dirent;
    for $dirent (readdir $dh) {
        next if $dirent =~ /^\.\.?$/;
        my $path = File::Spec->catdir($dir,$dirent);
        if (-d $path) {
            push @dirs, $dirent;
        } elsif (-f $path) {
            push @files, $dirent;
        }
    }
    if (@dirs && @files) {
        return "both files[@files] and directories[@dirs]";
    } elsif (@files > 2) {
        return "several files[@files] but no Makefile.PL or Build.PL";
    }
    return;
}

#-> CPAN;:Distribution::_exefile_stanza
sub _exefile_stanza {
    my($self,$build_dir,$local_file) = @_;

            my $fh = FileHandle->new;
            my $script_file = File::Spec->catfile($build_dir,$local_file);
            $fh->open($script_file)
                or Carp::croak("Could not open script '$script_file': $!");
            local $/ = "\n";
            # parse name and prereq
            my($state) = "poddir";
            my($name, $prereq) = ("", "");
            while (<$fh>) {
                if ($state eq "poddir" && /^=head\d\s+(\S+)/) {
                    if ($1 eq 'NAME') {
                        $state = "name";
                    } elsif ($1 eq 'PREREQUISITES') {
                        $state = "prereq";
                    }
                } elsif ($state =~ m{^(name|prereq)$}) {
                    if (/^=/) {
                        $state = "poddir";
                    } elsif (/^\s*$/) {
                        # nop
                    } elsif ($state eq "name") {
                        if ($name eq "") {
                            ($name) = /^(\S+)/;
                            $state = "poddir";
                        }
                    } elsif ($state eq "prereq") {
                        $prereq .= $_;
                    }
                } elsif (/^=cut\b/) {
                    last;
                }
            }
            $fh->close;

            for ($name) {
                s{.*<}{};       # strip X<...>
                s{>.*}{};
            }
            chomp $prereq;
            $prereq = join " ", split /\s+/, $prereq;
            my($PREREQ_PM) = join("\n", map {
                s{.*<}{};       # strip X<...>
                s{>.*}{};
                if (/[\s\'\"]/) { # prose?
                } else {
                    s/[^\w:]$//; # period?
                    " "x28 . "'$_' => 0,";
                }
            } split /\s*,\s*/, $prereq);

            if ($name) {
                my $to_file = File::Spec->catfile($build_dir, $name);
                rename $script_file, $to_file
                    or die "Can't rename $script_file to $to_file: $!";
            }

    return "
              EXE_FILES => ['$name'],
              PREREQ_PM => {
$PREREQ_PM
                           },
";
}

#-> CPAN::Distribution::_signature_business
sub _signature_business {
    my($self) = @_;
    my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
                                                      q{check_sigs});
    if ($check_sigs) {
        if ($CPAN::META->has_inst("Module::Signature")) {
            if (-f "SIGNATURE") {
                $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
                my $rv = Module::Signature::verify();
                if ($rv != Module::Signature::SIGNATURE_OK() and
                    $rv != Module::Signature::SIGNATURE_MISSING()) {
                    $CPAN::Frontend->mywarn(
                                            qq{\nSignature invalid for }.
                                            qq{distribution file. }.
                                            qq{Please investigate.\n\n}
                                           );

                    my $wrap =
                        sprintf(qq{I'd recommend removing %s. Some error occurred   }.
                                qq{while checking its signature, so it could        }.
                                qq{be invalid. Maybe you have configured            }.
                                qq{your 'urllist' with a bad URL. Please check this }.
                                qq{array with 'o conf urllist' and retry. Or        }.
                                qq{examine the distribution in a subshell. Try
  look %s
and run
  cpansign -v
},
                                $self->{localfile},
                                $self->pretty_id,
                               );
                    $self->{signature_verify} = CPAN::Distrostatus->new("NO");
                    $CPAN::Frontend->mywarn(Text::Wrap::wrap("","",$wrap));
                    $CPAN::Frontend->mysleep(5) if $CPAN::Frontend->can("mysleep");
                } else {
                    $self->{signature_verify} = CPAN::Distrostatus->new("YES");
                    $self->debug("Module::Signature has verified") if $CPAN::DEBUG;
                }
            } else {
                $CPAN::Frontend->mywarn(qq{Package came without SIGNATURE\n\n});
            }
        } else {
            $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
        }
    }
}

#-> CPAN::Distribution::untar_me ;
sub untar_me {
    my($self,$ct) = @_;
    $self->{archived} = "tar";
    my $result = eval { $ct->untar() };
    if ($result) {
        $self->{unwrapped} = CPAN::Distrostatus->new("YES");
    } else {
        # unfortunately we have no $@ here, Tarzip is using mydie which dies with "\n"
        $self->{unwrapped} = CPAN::Distrostatus->new("NO -- untar failed");
    }
}

# CPAN::Distribution::unzip_me ;
sub unzip_me {
    my($self,$ct) = @_;
    $self->{archived} = "zip";
    if (eval { $ct->unzip() }) {
        $self->{unwrapped} = CPAN::Distrostatus->new("YES");
    } else {
        $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed during unzip");
    }
    return;
}

sub handle_singlefile {
    my($self,$local_file) = @_;

    if ( $local_file =~ /\.pm(\.(gz|Z))?(?!\n)\Z/ ) {
        $self->{archived} = "pm";
    } elsif ( $local_file =~ /\.patch(\.(gz|bz2))?(?!\n)\Z/ ) {
        $self->{archived} = "patch";
    } else {
        $self->{archived} = "maybe_pl";
    }

    my $to = File::Basename::basename($local_file);
    if ($to =~ s/\.(gz|Z)(?!\n)\Z//) {
        if (eval{CPAN::Tarzip->new($local_file)->gunzip($to)}) {
            $self->{unwrapped} = CPAN::Distrostatus->new("YES");
        } else {
            $self->{unwrapped} = CPAN::Distrostatus->new("NO -- uncompressing failed");
        }
    } else {
        if (File::Copy::cp($local_file,".")) {
            $self->{unwrapped} = CPAN::Distrostatus->new("YES");
        } else {
            $self->{unwrapped} = CPAN::Distrostatus->new("NO -- copying failed");
        }
    }
    return $to;
}

#-> sub CPAN::Distribution::new ;
sub new {
    my($class,%att) = @_;

    # $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();

    my $this = { %att };
    return bless $this, $class;
}

#-> sub CPAN::Distribution::look ;
sub look {
    my($self) = @_;

    if ($^O eq 'MacOS') {
      $self->Mac::BuildTools::look;
      return;
    }

    if (  $CPAN::Config->{'shell'} ) {
        $CPAN::Frontend->myprint(qq{
Trying to open a subshell in the build directory...
});
    } else {
        $CPAN::Frontend->myprint(qq{
Your configuration does not define a value for subshells.
Please define it with "o conf shell <your shell>"
});
        return;
    }
    my $dist = $self->id;
    my $dir;
    unless ($dir = $self->dir) {
        $self->get;
    }
    unless ($dir ||= $self->dir) {
        $CPAN::Frontend->mywarn(qq{
Could not determine which directory to use for looking at $dist.
});
        return;
    }
    my $pwd  = CPAN::anycwd();
    $self->safe_chdir($dir);
    $CPAN::Frontend->myprint(qq{Working directory is $dir\n});
    {
        local $ENV{CPAN_SHELL_LEVEL} = $ENV{CPAN_SHELL_LEVEL}||0;
        $ENV{CPAN_SHELL_LEVEL} += 1;
        my $shell = CPAN::HandleConfig->safe_quote($CPAN::Config->{'shell'});

        local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
            ? $ENV{PERL5LIB}
                : ($ENV{PERLLIB} || "");

        local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
        # local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # look
        $CPAN::META->set_perl5lib;
        local $ENV{MAKEFLAGS}; # protect us from outer make calls

        unless (system($shell) == 0) {
            my $code = $? >> 8;
            $CPAN::Frontend->mywarn("Subprocess shell exit code $code\n");
        }
    }
    $self->safe_chdir($pwd);
}

# CPAN::Distribution::cvs_import ;
sub cvs_import {
    my($self) = @_;
    $self->get;
    my $dir = $self->dir;

    my $package = $self->called_for;
    my $module = $CPAN::META->instance('CPAN::Module', $package);
    my $version = $module->cpan_version;

    my $userid = $self->cpan_userid;

    my $cvs_dir = (split /\//, $dir)[-1];
    $cvs_dir =~ s/-\d+[^-]+(?!\n)\Z//;
    my $cvs_root =
      $CPAN::Config->{cvsroot} || $ENV{CVSROOT};
    my $cvs_site_perl =
      $CPAN::Config->{cvs_site_perl} || $ENV{CVS_SITE_PERL};
    if ($cvs_site_perl) {
        $cvs_dir = "$cvs_site_perl/$cvs_dir";
    }
    my $cvs_log = qq{"imported $package $version sources"};
    $version =~ s/\./_/g;
    # XXX cvs: undocumented and unclear how it was meant to work
    my @cmd = ('cvs', '-d', $cvs_root, 'import', '-m', $cvs_log,
               "$cvs_dir", $userid, "v$version");

    my $pwd  = CPAN::anycwd();
    chdir($dir) or $CPAN::Frontend->mydie(qq{Could not chdir to "$dir": $!});

    $CPAN::Frontend->myprint(qq{Working directory is $dir\n});

    $CPAN::Frontend->myprint(qq{@cmd\n});
    system(@cmd) == 0 or
    # XXX cvs
        $CPAN::Frontend->mydie("cvs import failed");
    chdir($pwd) or $CPAN::Frontend->mydie(qq{Could not chdir to "$pwd": $!});
}

#-> sub CPAN::Distribution::readme ;
sub readme {
    my($self) = @_;
    my($dist) = $self->id;
    my($sans,$suffix) = $dist =~ /(.+)\.(tgz|tar[\._-]gz|tar\.Z|zip)$/;
    $self->debug("sans[$sans] suffix[$suffix]\n") if $CPAN::DEBUG;
    my($local_file);
    my($local_wanted) =
        File::Spec->catfile(
                            $CPAN::Config->{keep_source_where},
                            "authors",
                            "id",
                            split(/\//,"$sans.readme"),
                           );
    my $readme = "authors/id/$sans.readme";
    $self->debug("Doing localize for '$readme'") if $CPAN::DEBUG;
    $local_file = CPAN::FTP->localize($readme,
                                      $local_wanted)
        or $CPAN::Frontend->mydie(qq{No $sans.readme found});

    if ($^O eq 'MacOS') {
        Mac::BuildTools::launch_file($local_file);
        return;
    }

    my $fh_pager = FileHandle->new;
    local($SIG{PIPE}) = "IGNORE";
    my $pager = $CPAN::Config->{'pager'} || "cat";
    $fh_pager->open("|$pager")
        or die "Could not open pager $pager\: $!";
    my $fh_readme = FileHandle->new;
    $fh_readme->open($local_file)
        or $CPAN::Frontend->mydie(qq{Could not open "$local_file": $!});
    $CPAN::Frontend->myprint(qq{
Displaying file
  $local_file
with pager "$pager"
});
    $fh_pager->print(<$fh_readme>);
    $fh_pager->close;
}

#-> sub CPAN::Distribution::verifyCHECKSUM ;
sub verifyCHECKSUM {
    my($self) = @_;
  EXCUSE: {
        my @e;
        $self->{CHECKSUM_STATUS} ||= "";
        $self->{CHECKSUM_STATUS} eq "OK" and push @e, "Checksum was ok";
        $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    my($lc_want,$lc_file,@local,$basename);
    @local = split(/\//,$self->id);
    pop @local;
    push @local, "CHECKSUMS";
    $lc_want =
        File::Spec->catfile($CPAN::Config->{keep_source_where},
                            "authors", "id", @local);
    local($") = "/";
    if (my $size = -s $lc_want) {
        $self->debug("lc_want[$lc_want]size[$size]") if $CPAN::DEBUG;
        my @stat = stat $lc_want;
        my $epoch_starting_support_of_cpan_path = 1637471530;
        if ($stat[9] >= $epoch_starting_support_of_cpan_path) {
            if ($self->CHECKSUM_check_file($lc_want, 1)) {
                return $self->{CHECKSUM_STATUS} = "OK";
            }
        } else {
            unlink $lc_want;
        }
    }
    $lc_file = CPAN::FTP->localize("authors/id/@local",
                                   $lc_want,1);
    unless ($lc_file) {
        $CPAN::Frontend->myprint("Trying $lc_want.gz\n");
        $local[-1] .= ".gz";
        $lc_file = CPAN::FTP->localize("authors/id/@local",
                                       "$lc_want.gz",1);
        if ($lc_file) {
            $lc_file =~ s/\.gz(?!\n)\Z//;
            eval{CPAN::Tarzip->new("$lc_file.gz")->gunzip($lc_file)};
        } else {
            return;
        }
    }
    if ($self->CHECKSUM_check_file($lc_file)) {
        return $self->{CHECKSUM_STATUS} = "OK";
    }
}

#-> sub CPAN::Distribution::SIG_check_file ;
sub SIG_check_file {
    my($self,$chk_file) = @_;
    my $rv = eval { Module::Signature::_verify($chk_file) };

    if ($rv eq Module::Signature::CANNOT_VERIFY()) {
        $CPAN::Frontend->myprint(qq{\nSignature for }.
                                 qq{file $chk_file could not be verified for an unknown reason. }.
                                 $self->as_string.
                                 qq{Module::Signature verification returned value $rv\n\n}
                                );

        my $wrap = qq{The manual says for this case: Cannot verify the
OpenPGP signature, maybe due to the lack of a network connection to
the key server, or if neither gnupg nor Crypt::OpenPGP exists on the
system. You probably want to analyse the situation and if you cannot
fix it you will have to decide whether you want to stop this session
or you want to turn off signature verification. The latter would be
done with the command 'o conf init check_sigs'};

        $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
    } if ($rv == Module::Signature::SIGNATURE_OK()) {
        $CPAN::Frontend->myprint("Signature for $chk_file ok\n");
        return $self->{SIG_STATUS} = "OK";
    } else {
        $CPAN::Frontend->mywarn(qq{\nSignature invalid for }.
                                 qq{file $chk_file. }.
                                 qq{Please investigate.\n\n}.
                                 $self->as_string.
                                 qq{Module::Signature verification returned value $rv\n\n}
                                );

        my $wrap = qq{I\'d recommend removing $chk_file. Its signature
is invalid. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};

        $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));
    }
}

#-> sub CPAN::Distribution::CHECKSUM_check_file ;

# sloppy is 1 when we have an old checksums file that maybe is good
# enough

sub CHECKSUM_check_file {
    my($self,$chk_file,$sloppy) = @_;
    my($cksum,$file,$basename);

    $sloppy ||= 0;
    $self->debug("chk_file[$chk_file]sloppy[$sloppy]") if $CPAN::DEBUG;
    my $check_sigs = CPAN::HandleConfig->prefs_lookup($self,
                                                      q{check_sigs});
    if ($check_sigs) {
        if ($CPAN::META->has_inst("Module::Signature")) {
            $self->debug("Module::Signature is installed, verifying") if $CPAN::DEBUG;
            $self->SIG_check_file($chk_file);
        } else {
            $self->debug("Module::Signature is NOT installed") if $CPAN::DEBUG;
        }
    }

    $file = $self->{localfile};
    $basename = File::Basename::basename($file);
    my($signed_data);
    my $fh = FileHandle->new;
    if ($check_sigs) {
        my $tempdir;
        if ($CPAN::META->has_usable("File::Temp")) {
            $tempdir = File::Temp::tempdir("CHECKSUMS-XXXX", CLEANUP => 1, DIR => "/tmp" );
        } else {
            $tempdir = File::Spec->catdir(File::Spec->tmpdir, "CHECKSUMS-$$");
            File::Path::mkpath($tempdir);
        }
        my $tempfile = File::Spec->catfile($tempdir, "CHECKSUMS.$$");
        unlink $tempfile; # ignore missing file
        my $devnull = File::Spec->devnull;
        my $gpg = $CPAN::Config->{gpg} or
            $CPAN::Frontend->mydie("Your configuration suggests that you do not have 'gpg' installed. This is needed to verify checksums with the config variable 'check_sigs' on. Please configure it with 'o conf init gpg'");
        my $system = qq{"$gpg" --verify --batch --no-tty --output "$tempfile" "$chk_file" 2> "$devnull"};
        0 == system $system or $CPAN::Frontend->mydie("gpg run was failing, cannot continue: $system");
        open $fh, $tempfile or $CPAN::Frontend->mydie("Could not open $tempfile: $!");
        local $/;
        $signed_data = <$fh>;
        close $fh;
        File::Path::rmtree($tempdir);
    } else {
        my $fh = FileHandle->new;
        if (open $fh, $chk_file) {
            local($/);
            $signed_data = <$fh>;
        } else {
            $CPAN::Frontend->mydie("Could not open $chk_file for reading");
        }
        close $fh;
    }
    $signed_data =~ s/\015?\012/\n/g;
    my($compmt) = Safe->new();
    $cksum = $compmt->reval($signed_data);
    if ($@) {
        rename $chk_file, "$chk_file.bad";
        Carp::confess($@) if $@;
    }

    if (! ref $cksum or ref $cksum ne "HASH") {
        $CPAN::Frontend->mywarn(qq{
Warning: checksum file '$chk_file' broken.

When trying to read that file I expected to get a hash reference
for further processing, but got garbage instead.
});
        my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
        $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
        $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file broken";
        return;
    } elsif (exists $cksum->{$basename} && ! exists $cksum->{$basename}{cpan_path}) {
        $CPAN::Frontend->mywarn(qq{
Warning: checksum file '$chk_file' not conforming.

The cksum does not contain the key 'cpan_path' for '$basename'.
});
        my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
        $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
        $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS file without cpan_path";
        return;
    } elsif (exists $cksum->{$basename} && substr($self->{ID},0,length($cksum->{$basename}{cpan_path}))
             ne $cksum->{$basename}{cpan_path}) {
        $CPAN::Frontend->mywarn(qq{
Warning: checksum file not matching path '$self->{ID}'.

The cksum contain the key 'cpan_path=$cksum->{$basename}{cpan_path}'
which does not match the ID of the distribution '$self->{ID}'.
Something's suspicious might be going on here. Please investigate.

});
        my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed nonetheless?", "no");
        $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
        $self->{CHECKSUM_STATUS} = "NIL -- CHECKSUMS non-matching cpan_path vs. ID";
        return;
    } elsif (exists $cksum->{$basename}{sha256}) {
        $self->debug("Found checksum for $basename:" .
                     "$cksum->{$basename}{sha256}\n") if $CPAN::DEBUG;

        open($fh, $file);
        binmode $fh;
        my $eq = $self->eq_CHECKSUM($fh,$cksum->{$basename}{sha256});
        $fh->close;
        $fh = CPAN::Tarzip->TIEHANDLE($file);

        unless ($eq) {
            my $dg = Digest::SHA->new(256);
            my($data,$ref);
            $ref = \$data;
            while ($fh->READ($ref, 4096) > 0) {
                $dg->add($data);
            }
            my $hexdigest = $dg->hexdigest;
            $eq += $hexdigest eq $cksum->{$basename}{'sha256-ungz'};
        }

        if ($eq) {
            $CPAN::Frontend->myprint("Checksum for $file ok\n");
            return $self->{CHECKSUM_STATUS} = "OK";
        } else {
            $CPAN::Frontend->myprint(qq{\nChecksum mismatch for }.
                                     qq{distribution file. }.
                                     qq{Please investigate.\n\n}.
                                     $self->as_string,
                                     $CPAN::META->instance(
                                                           'CPAN::Author',
                                                           $self->cpan_userid
                                                          )->as_string);

            my $wrap = qq{I\'d recommend removing $file. Its
checksum is incorrect. Maybe you have configured your 'urllist' with
a bad URL. Please check this array with 'o conf urllist', and
retry.};

            $CPAN::Frontend->mydie(Text::Wrap::wrap("","",$wrap));

            # former versions just returned here but this seems a
            # serious threat that deserves a die

            # $CPAN::Frontend->myprint("\n\n");
            # sleep 3;
            # return;
        }
        # close $fh if fileno($fh);
    } else {
        return if $sloppy;
        unless ($self->{CHECKSUM_STATUS}) {
            $CPAN::Frontend->mywarn(qq{
Warning: No checksum for $basename in $chk_file.

The cause for this may be that the file is very new and the checksum
has not yet been calculated, but it may also be that something is
going awry right now.
});
            my $answer = CPAN::Shell::colorable_makemaker_prompt("Proceed?", "yes");
            $answer =~ /^\s*y/i or $CPAN::Frontend->mydie("Aborted.\n");
        }
        $self->{CHECKSUM_STATUS} = "NIL -- distro not in CHECKSUMS file";
        return;
    }
}

#-> sub CPAN::Distribution::eq_CHECKSUM ;
sub eq_CHECKSUM {
    my($self,$fh,$expect) = @_;
    if ($CPAN::META->has_inst("Digest::SHA")) {
        my $dg = Digest::SHA->new(256);
        my($data);
        while (read($fh, $data, 4096)) {
            $dg->add($data);
        }
        my $hexdigest = $dg->hexdigest;
        # warn "fh[$fh] hex[$hexdigest] aexp[$expectMD5]";
        return $hexdigest eq $expect;
    }
    return 1;
}

#-> sub CPAN::Distribution::force ;

# Both CPAN::Modules and CPAN::Distributions know if "force" is in
# effect by autoinspection, not by inspecting a global variable. One
# of the reason why this was chosen to work that way was the treatment
# of dependencies. They should not automatically inherit the force
# status. But this has the downside that ^C and die() will return to
# the prompt but will not be able to reset the force_update
# attributes. We try to correct for it currently in the read_metadata
# routine, and immediately before we check for a Signal. I hope this
# works out in one of v1.57_53ff

# "Force get forgets previous error conditions"

#-> sub CPAN::Distribution::fforce ;
sub fforce {
  my($self, $method) = @_;
  $self->force($method,1);
}

#-> sub CPAN::Distribution::force ;
sub force {
  my($self, $method,$fforce) = @_;
  my %phase_map = (
                   get => [
                           "unwrapped",
                           "build_dir",
                           "archived",
                           "localfile",
                           "CHECKSUM_STATUS",
                           "signature_verify",
                           "prefs",
                           "prefs_file",
                           "prefs_file_doc",
                           "cleanup_after_install_done",
                          ],
                   make => [
                            "writemakefile",
                            "make",
                            "modulebuild",
                            "prereq_pm",
                            "cleanup_after_install_done",
                           ],
                   test => [
                            "badtestcnt",
                            "make_test",
                            "cleanup_after_install_done",
                          ],
                   install => [
                               "install",
                               "cleanup_after_install_done",
                              ],
                   unknown => [
                               "reqtype",
                               "yaml_content",
                               "cleanup_after_install_done",
                              ],
                  );
  my $methodmatch = 0;
  my $ldebug = 0;
 PHASE: for my $phase (qw(unknown get make test install)) { # order matters
      $methodmatch = 1 if $fforce || ($method && $phase eq $method);
      next unless $methodmatch;
    ATTRIBUTE: for my $att (@{$phase_map{$phase}}) {
          if ($phase eq "get") {
              if (substr($self->id,-1,1) eq "."
                  && $att =~ /(unwrapped|build_dir|archived)/ ) {
                  # cannot be undone for local distros
                  next ATTRIBUTE;
              }
              if ($att eq "build_dir"
                  && $self->{build_dir}
                  && $CPAN::META->{is_tested}
                 ) {
                  delete $CPAN::META->{is_tested}{$self->{build_dir}};
              }
          } elsif ($phase eq "test") {
              if ($att eq "make_test"
                  && $self->{make_test}
                  && $self->{make_test}{COMMANDID}
                  && $self->{make_test}{COMMANDID} == $CPAN::CurrentCommandId
                 ) {
                  # endless loop too likely
                  next ATTRIBUTE;
              }
          }
          delete $self->{$att};
          if ($ldebug || $CPAN::DEBUG) {
              # local $CPAN::DEBUG = 16; # Distribution
              CPAN->debug(sprintf "id[%s]phase[%s]att[%s]", $self->id, $phase, $att);
          }
      }
  }
  if ($method && $method =~ /make|test|install/) {
    $self->{force_update} = 1; # name should probably have been force_install
  }
}

#-> sub CPAN::Distribution::notest ;
sub notest {
  my($self, $method) = @_;
  # $CPAN::Frontend->mywarn("XDEBUG: set notest for $self $method");
  $self->{"notest"}++; # name should probably have been force_install
}

#-> sub CPAN::Distribution::unnotest ;
sub unnotest {
  my($self) = @_;
  # warn "XDEBUG: deleting notest";
  delete $self->{notest};
}

#-> sub CPAN::Distribution::unforce ;
sub unforce {
  my($self) = @_;
  delete $self->{force_update};
}

#-> sub CPAN::Distribution::isa_perl ;
sub isa_perl {
  my($self) = @_;
  my $file = File::Basename::basename($self->id);
  if ($file =~ m{ ^ perl
                  (
                   -(5\.\d+\.\d+)
                   |
                   (5)[._-](00[0-5](?:_[0-4][0-9])?)
                  )
                  \.tar[._-](?:gz|bz2)
                  (?!\n)\Z
                }xs) {
    my $perl_version;
    if ($2) {
        $perl_version = $2;
    } else {
        $perl_version = "$3.$4";
    }
    return $perl_version;
  } elsif ($self->cpan_comment
           &&
           $self->cpan_comment =~ /isa_perl\(.+?\)/) {
    return $1;
  }
}


#-> sub CPAN::Distribution::perl ;
sub perl {
    my ($self) = @_;
    if (! $self) {
        use Carp qw(carp);
        carp __PACKAGE__ . "::perl was called without parameters.";
    }
    return CPAN::HandleConfig->safe_quote($CPAN::Perl);
}

#-> sub CPAN::Distribution::shortcut_prepare ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success

sub shortcut_prepare {
    my ($self) = @_;

    $self->debug("checking archive type[$self->{ID}]") if $CPAN::DEBUG;
    if (!$self->{archived} || $self->{archived} eq "NO") {
        return $self->goodbye("Is neither a tar nor a zip archive.");
    }

    $self->debug("checking unwrapping[$self->{ID}]") if $CPAN::DEBUG;
    if (!$self->{unwrapped}
        || (
            UNIVERSAL::can($self->{unwrapped},"failed") ?
            $self->{unwrapped}->failed :
            $self->{unwrapped} =~ /^NO/
            )) {
        return $self->goodbye("Had problems unarchiving. Please build manually");
    }

    $self->debug("checking signature[$self->{ID}]") if $CPAN::DEBUG;
    if ( ! $self->{force_update}
        && exists $self->{signature_verify}
        && (
                UNIVERSAL::can($self->{signature_verify},"failed") ?
                $self->{signature_verify}->failed :
                $self->{signature_verify} =~ /^NO/
            )
    ) {
        return $self->goodbye("Did not pass the signature test.");
    }

    $self->debug("checking writemakefile[$self->{ID}]") if $CPAN::DEBUG;
    if ($self->{writemakefile}) {
        if (
                UNIVERSAL::can($self->{writemakefile},"failed") ?
                $self->{writemakefile}->failed :
                $self->{writemakefile} =~ /^NO/
            ) {
            # XXX maybe a retry would be in order?
            my $err = UNIVERSAL::can($self->{writemakefile},"text") ?
                $self->{writemakefile}->text :
                    $self->{writemakefile};
            $err =~ s/^NO\s*(--\s+)?//;
            $err ||= "Had some problem writing Makefile";
            $err .= ", not re-running";
            return $self->goodbye($err);
        } else {
            return $self->success("Has already been prepared");
        }
    }

    $self->debug("checking configure_requires_later[$self->{ID}]") if $CPAN::DEBUG;
    if( my $later = $self->{configure_requires_later} ) { # see also undelay
        return $self->goodbye($later);
    }

    return undef; # no shortcut
}

sub prepare {
    my ($self) = @_;

    $self->get
        or return;

    if ( defined( my $sc = $self->shortcut_prepare) ) {
        return $sc;
    }

    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
                           ? $ENV{PERL5LIB}
                           : ($ENV{PERLLIB} || "");
    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
    local $ENV{PERL_USE_UNSAFE_INC} =
        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare
    $CPAN::META->set_perl5lib;
    local $ENV{MAKEFLAGS}; # protect us from outer make calls

    if ($CPAN::Signal) {
        delete $self->{force_update};
        return;
    }

    my $builddir = $self->dir or
        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");

    unless (chdir $builddir) {
        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
        return;
    }

    if ($CPAN::Signal) {
        delete $self->{force_update};
        return;
    }

    $self->debug("Changed directory to $builddir") if $CPAN::DEBUG;

    local $ENV{PERL_AUTOINSTALL} = $ENV{PERL_AUTOINSTALL} || '';
    local $ENV{PERL_EXTUTILS_AUTOINSTALL} = $ENV{PERL_EXTUTILS_AUTOINSTALL} || '';
    $self->choose_MM_or_MB
        or return;

    my $configurator = $self->{configure} ? "Configure"
                     : $self->{modulebuild} ? "Build.PL"
                     : "Makefile.PL";

    $CPAN::Frontend->myprint("Configuring ".$self->id." with $configurator\n");

    if ($CPAN::Config->{prerequisites_policy} eq "follow") {
        $ENV{PERL_AUTOINSTALL}          ||= "--defaultdeps";
        $ENV{PERL_EXTUTILS_AUTOINSTALL} ||= "--defaultdeps";
    }

    my $system;
    my $pl_commandline;
    if ($self->prefs->{pl}) {
        $pl_commandline = $self->prefs->{pl}{commandline};
    }
    local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
    local $ENV{PERL5_CPAN_IS_EXECUTING} = $ENV{PERL5_CPAN_IS_EXECUTING} || '';
    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
    if ($pl_commandline) {
        $system = $pl_commandline;
        $ENV{PERL} = $^X;
    } elsif ($self->{'configure'}) {
        $system = $self->{'configure'};
    } elsif ($self->{modulebuild}) {
        my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
        my $mbuildpl_arg = $self->_make_phase_arg("pl");
        $system = sprintf("%s Build.PL%s",
                          $perl,
                          $mbuildpl_arg ? " $mbuildpl_arg" : "",
                         );
    } else {
        my($perl) = $self->perl or die "Couldn\'t find executable perl\n";
        my $switch = "";
# This needs a handler that can be turned on or off:
#        $switch = "-MExtUtils::MakeMaker ".
#            "-Mops=:default,:filesys_read,:filesys_open,require,chdir"
#            if $] > 5.00310;
        my $makepl_arg = $self->_make_phase_arg("pl");
        $ENV{PERL5_CPAN_IS_EXECUTING} = File::Spec->catfile($self->{build_dir},
                                                            "Makefile.PL");
        $system = sprintf("%s%s Makefile.PL%s",
                          $perl,
                          $switch ? " $switch" : "",
                          $makepl_arg ? " $makepl_arg" : "",
                         );
    }
    my $pl_env;
    if ($self->prefs->{pl}) {
        $pl_env = $self->prefs->{pl}{env};
    }
    local @ENV{keys %$pl_env} = values %$pl_env if $pl_env;
    if (exists $self->{writemakefile}) {
    } else {
        local($SIG{ALRM}) = sub { die "inactivity_timeout reached\n" };
        my($ret,$pid,$output);
        $@ = "";
        my $go_via_alarm;
        if ($CPAN::Config->{inactivity_timeout}) {
            require Config;
            if ($Config::Config{d_alarm}
                &&
                $Config::Config{d_alarm} eq "define"
               ) {
                $go_via_alarm++
            } else {
                $CPAN::Frontend->mywarn("Warning: you have configured the config ".
                                        "variable 'inactivity_timeout' to ".
                                        "'$CPAN::Config->{inactivity_timeout}'. But ".
                                        "on this machine the system call 'alarm' ".
                                        "isn't available. This means that we cannot ".
                                        "provide the feature of intercepting long ".
                                        "waiting code and will turn this feature off.\n"
                                       );
                $CPAN::Config->{inactivity_timeout} = 0;
            }
        }
        if ($go_via_alarm) {
            if ( $self->_should_report('pl') ) {
                ($output, $ret) = CPAN::Reporter::record_command(
                    $system,
                    $CPAN::Config->{inactivity_timeout},
                );
                CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
            }
            else {
                eval {
                    alarm $CPAN::Config->{inactivity_timeout};
                    local $SIG{CHLD}; # = sub { wait };
                    if (defined($pid = fork)) {
                        if ($pid) { #parent
                            # wait;
                            waitpid $pid, 0;
                        } else {    #child
                            # note, this exec isn't necessary if
                            # inactivity_timeout is 0. On the Mac I'd
                            # suggest, we set it always to 0.
                            exec $system;
                        }
                    } else {
                        $CPAN::Frontend->myprint("Cannot fork: $!");
                        return;
                    }
                };
                alarm 0;
                if ($@) {
                    kill 9, $pid;
                    waitpid $pid, 0;
                    my $err = "$@";
                    $CPAN::Frontend->myprint($err);
                    $self->{writemakefile} = CPAN::Distrostatus->new("NO $err");
                    $@ = "";
                    $self->store_persistent_state;
                    return $self->goodbye("$system -- TIMED OUT");
                }
            }
        } else {
            if (my $expect_model = $self->_prefs_with_expect("pl")) {
                # XXX probably want to check _should_report here and warn
                # about not being able to use CPAN::Reporter with expect
                $ret = $self->_run_via_expect($system,'writemakefile',$expect_model);
                if (! defined $ret
                    && $self->{writemakefile}
                    && $self->{writemakefile}->failed) {
                    # timeout
                    return;
                }
            }
            elsif ( $self->_should_report('pl') ) {
                ($output, $ret) = eval { CPAN::Reporter::record_command($system) };
                if (! defined $output or $@) {
                    my $err = $@ || "Unknown error";
                    $CPAN::Frontend->mywarn("Error while running PL phase: $err\n");
                    $self->{writemakefile} = CPAN::Distrostatus
                        ->new("NO '$system' returned status $ret and no output");
                    return $self->goodbye("$system -- NOT OK");
                }
                CPAN::Reporter::grade_PL( $self, $system, $output, $ret );
            }
            else {
                $ret = system($system);
            }
            if ($ret != 0) {
                $self->{writemakefile} = CPAN::Distrostatus
                    ->new("NO '$system' returned status $ret");
                $CPAN::Frontend->mywarn("Warning: No success on command[$system]\n");
                $self->store_persistent_state;
                return $self->goodbye("$system -- NOT OK");
            }
        }
        if (-f "Makefile" || -f "Build" || ($^O eq 'VMS' && (-f 'descrip.mms' || -f 'Build.com'))) {
            $self->{writemakefile} = CPAN::Distrostatus->new("YES");
            delete $self->{make_clean}; # if cleaned before, enable next
            $self->store_persistent_state;
            return $self->success("$system -- OK");
        } else {
            my $makefile = $self->{modulebuild} ? "Build" : "Makefile";
            my $why = "No '$makefile' created";
            $CPAN::Frontend->mywarn($why);
            $self->{writemakefile} = CPAN::Distrostatus
                ->new(qq{NO -- $why\n});
            $self->store_persistent_state;
            return $self->goodbye("$system -- NOT OK");
        }
    }
    $self->store_persistent_state;
    return 1; # success
}

#-> sub CPAN::Distribution::shortcut_make ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success
sub shortcut_make {
    my ($self) = @_;

    $self->debug("checking make/build results[$self->{ID}]") if $CPAN::DEBUG;
    if (defined $self->{make}) {
        if (UNIVERSAL::can($self->{make},"failed") ?
            $self->{make}->failed :
            $self->{make} =~ /^NO/
        ) {
            if ($self->{force_update}) {
                # Trying an already failed 'make' (unless somebody else blocks)
                return undef; # no shortcut
            } else {
                # introduced for turning recursion detection into a distrostatus
                my $error = length $self->{make}>3
                    ? substr($self->{make},3) : "Unknown error";
                $self->store_persistent_state;
                return $self->goodbye("Could not make: $error\n");
            }
        } else {
            return $self->success("Has already been made")
        }
    }
    return undef; # no shortcut
}

#-> sub CPAN::Distribution::make ;
sub make {
    my($self) = @_;

    $self->pre_make();

    if (exists $self->{cleanup_after_install_done}) {
        $self->post_make();
        return $self->get;
    }

    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
    if (my $goto = $self->prefs->{goto}) {
        $self->post_make();
        return $self->goto($goto);
    }
    # Emergency brake if they said install Pippi and get newest perl

    # XXX Would this make more sense in shortcut_prepare, since
    # that doesn't make sense on a perl dist either?  Broader
    # question: what is the purpose of suggesting force install
    # on a perl distribution?  That seems unlikely to result in
    # such a dependency being satisfied, even if the perl is
    # successfully installed.  This situation is tantamount to
    # a prereq on a version of perl greater than the current one
    # so I think we should just abort. -- xdg, 2012-04-06
    if ($self->isa_perl) {
        if (
            $self->called_for ne $self->id &&
            ! $self->{force_update}
        ) {
            # if we die here, we break bundles
            $CPAN::Frontend
                ->mywarn(sprintf(
                            qq{The most recent version "%s" of the module "%s"
is part of the perl-%s distribution. To install that, you need to run
  force install %s   --or--
  install %s
},
                             $CPAN::META->instance(
                                                   'CPAN::Module',
                                                   $self->called_for
                                                  )->cpan_version,
                             $self->called_for,
                             $self->isa_perl,
                             $self->called_for,
                             $self->pretty_id,
                            ));
            $self->{make} = CPAN::Distrostatus->new("NO isa perl");
            $CPAN::Frontend->mysleep(1);
            $self->post_make();
            return;
        }
    }

    unless ($self->prepare){
        $self->post_make();
        return;
    }

    if ( defined( my $sc = $self->shortcut_make) ) {
        $self->post_make();
        return $sc;
    }

    if ($CPAN::Signal) {
        delete $self->{force_update};
        $self->post_make();
        return;
    }

    my $builddir = $self->dir or
        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");

    unless (chdir $builddir) {
        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
        $self->post_make();
        return;
    }

    my $make = $self->{modulebuild} ? "Build" : "make";
    $CPAN::Frontend->myprint(sprintf "Running %s for %s\n", $make, $self->id);
    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
                           ? $ENV{PERL5LIB}
                           : ($ENV{PERLLIB} || "");
    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
    local $ENV{PERL_USE_UNSAFE_INC} =
        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make
    $CPAN::META->set_perl5lib;
    local $ENV{MAKEFLAGS}; # protect us from outer make calls

    if ($CPAN::Signal) {
        delete $self->{force_update};
        $self->post_make();
        return;
    }

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make($self);
        $self->post_make();
        return;
    }

    my %env;
    while (my($k,$v) = each %ENV) {
        next if defined $v;
        $env{$k} = '';
    }
    local @ENV{keys %env} = values %env;
    my $satisfied = eval { $self->satisfy_requires };
    if ($@) {
        return $self->goodbye($@);
    }
    unless ($satisfied){
        $self->post_make();
        return;
    }
    if ($CPAN::Signal) {
        delete $self->{force_update};
        $self->post_make();
        return;
    }

    # need to chdir again, because $self->satisfy_requires might change the directory
    unless (chdir $builddir) {
        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
        $self->post_make();
        return;
    }

    my $system;
    my $make_commandline;
    if ($self->prefs->{make}) {
        $make_commandline = $self->prefs->{make}{commandline};
    }
    local $ENV{PERL} = defined $ENV{PERL}? $ENV{PERL} : $^X;
    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};
    if ($make_commandline) {
        $system = $make_commandline;
        $ENV{PERL} = CPAN::find_perl();
    } else {
        if ($self->{modulebuild}) {
            unless (-f "Build" || ($^O eq 'VMS' && -f 'Build.com')) {
                my $cwd = CPAN::anycwd();
                $CPAN::Frontend->mywarn("Alert: no Build file available for 'make $self->{id}'".
                                        " in cwd[$cwd]. Danger, Will Robinson!\n");
                $CPAN::Frontend->mysleep(5);
            }
            $system = join " ", $self->_build_command(), $CPAN::Config->{mbuild_arg};
        } else {
            $system = join " ", $self->_make_command(),  $CPAN::Config->{make_arg};
        }
        $system =~ s/\s+$//;
        my $make_arg = $self->_make_phase_arg("make");
        $system = sprintf("%s%s",
                          $system,
                          $make_arg ? " $make_arg" : "",
                         );
    }
    my $make_env;
    if ($self->prefs->{make}) {
        $make_env = $self->prefs->{make}{env};
    }
    local @ENV{keys %$make_env} = values %$make_env if $make_env;
    my $expect_model = $self->_prefs_with_expect("make");
    my $want_expect = 0;
    if ( $expect_model && @{$expect_model->{talk}} ) {
        my $can_expect = $CPAN::META->has_inst("Expect");
        if ($can_expect) {
            $want_expect = 1;
        } else {
            $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
                                    "system()\n");
        }
    }
    my ($system_ok, $system_err);
    if ($want_expect) {
        # XXX probably want to check _should_report here and
        # warn about not being able to use CPAN::Reporter with expect
        $system_ok = $self->_run_via_expect($system,'make',$expect_model) == 0;
    }
    elsif ( $self->_should_report('make') ) {
        my ($output, $ret) = CPAN::Reporter::record_command($system);
        CPAN::Reporter::grade_make( $self, $system, $output, $ret );
        $system_ok = ! $ret;
    }
    else {
        my $rc = system($system);
        $system_ok = $rc == 0;
        $system_err = $! if $rc == -1;
    }
    $self->introduce_myself;
    if ( $system_ok ) {
        $CPAN::Frontend->myprint("  $system -- OK\n");
        $self->{make} = CPAN::Distrostatus->new("YES");
    } else {
        $self->{writemakefile} ||= CPAN::Distrostatus->new("YES");
        $self->{make} = CPAN::Distrostatus->new("NO");
        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
        $CPAN::Frontend->mywarn("  $system_err\n") if defined $system_err;
    }
    $self->store_persistent_state;

    $self->post_make();

    return !! $system_ok;
}

# CPAN::Distribution::goodbye ;
sub goodbye {
    my($self,$goodbye) = @_;
    my $id = $self->pretty_id;
    $CPAN::Frontend->mywarn("  $id\n  $goodbye\n");
    return 0; # must be explicit false, not undef
}

sub success {
    my($self,$why) = @_;
    my $id = $self->pretty_id;
    $CPAN::Frontend->myprint("  $id\n  $why\n");
    return 1;
}

# CPAN::Distribution::_run_via_expect ;
sub _run_via_expect {
    my($self,$system,$phase,$expect_model) = @_;
    CPAN->debug("system[$system]expect_model[$expect_model]") if $CPAN::DEBUG;
    if ($CPAN::META->has_inst("Expect")) {
        my $expo = Expect->new;  # expo Expect object;
        $expo->spawn($system);
        $expect_model->{mode} ||= "deterministic";
        if ($expect_model->{mode} eq "deterministic") {
            return $self->_run_via_expect_deterministic($expo,$phase,$expect_model);
        } elsif ($expect_model->{mode} eq "anyorder") {
            return $self->_run_via_expect_anyorder($expo,$phase,$expect_model);
        } else {
            die "Panic: Illegal expect mode: $expect_model->{mode}";
        }
    } else {
        $CPAN::Frontend->mywarn("Expect not installed, falling back to system()\n");
        return system($system);
    }
}

sub _run_via_expect_anyorder {
    my($self,$expo,$phase,$expect_model) = @_;
    my $timeout = $expect_model->{timeout} || 5;
    my $reuse = $expect_model->{reuse};
    my @expectacopy = @{$expect_model->{talk}}; # we trash it!
    my $but = "";
    my $timeout_start = time;
  EXPECT: while () {
        my($eof,$ran_into_timeout);
        # XXX not up to the full power of expect. one could certainly
        # wrap all of the talk pairs into a single expect call and on
        # success tweak it and step ahead to the next question. The
        # current implementation unnecessarily limits itself to a
        # single match.
        my @match = $expo->expect(1,
                                  [ eof => sub {
                                        $eof++;
                                    } ],
                                  [ timeout => sub {
                                        $ran_into_timeout++;
                                    } ],
                                  -re => eval"qr{.}",
                                 );
        if ($match[2]) {
            $but .= $match[2];
        }
        $but .= $expo->clear_accum;
        if ($eof) {
            $expo->soft_close;
            return $expo->exitstatus();
        } elsif ($ran_into_timeout) {
            # warn "DEBUG: they are asking a question, but[$but]";
            for (my $i = 0; $i <= $#expectacopy; $i+=2) {
                my($next,$send) = @expectacopy[$i,$i+1];
                my $regex = eval "qr{$next}";
                # warn "DEBUG: will compare with regex[$regex].";
                if ($but =~ /$regex/) {
                    # warn "DEBUG: will send send[$send]";
                    $expo->send($send);
                    # never allow reusing an QA pair unless they told us
                    splice @expectacopy, $i, 2 unless $reuse;
                    $but =~ s/(?s:^.*?)$regex//;
                    $timeout_start = time;
                    next EXPECT;
                }
            }
            my $have_waited = time - $timeout_start;
            if ($have_waited < $timeout) {
                # warn "DEBUG: have_waited[$have_waited]timeout[$timeout]";
                next EXPECT;
            }
            my $why = "could not answer a question during the dialog";
            $CPAN::Frontend->mywarn("Failing: $why\n");
            $self->{$phase} =
                CPAN::Distrostatus->new("NO $why");
            return 0;
        }
    }
}

sub _run_via_expect_deterministic {
    my($self,$expo,$phase,$expect_model) = @_;
    my $ran_into_timeout;
    my $ran_into_eof;
    my $timeout = $expect_model->{timeout} || 15; # currently unsettable
    my $expecta = $expect_model->{talk};
  EXPECT: for (my $i = 0; $i <= $#$expecta; $i+=2) {
        my($re,$send) = @$expecta[$i,$i+1];
        CPAN->debug("timeout[$timeout]re[$re]") if $CPAN::DEBUG;
        my $regex = eval "qr{$re}";
        $expo->expect($timeout,
                      [ eof => sub {
                            my $but = $expo->clear_accum;
                            $CPAN::Frontend->mywarn("EOF (maybe harmless)
expected[$regex]\nbut[$but]\n\n");
                            $ran_into_eof++;
                        } ],
                      [ timeout => sub {
                            my $but = $expo->clear_accum;
                            $CPAN::Frontend->mywarn("TIMEOUT
expected[$regex]\nbut[$but]\n\n");
                            $ran_into_timeout++;
                        } ],
                      -re => $regex);
        if ($ran_into_timeout) {
            # note that the caller expects 0 for success
            $self->{$phase} =
                CPAN::Distrostatus->new("NO timeout during expect dialog");
            return 0;
        } elsif ($ran_into_eof) {
            last EXPECT;
        }
        $expo->send($send);
    }
    $expo->soft_close;
    return $expo->exitstatus();
}

#-> CPAN::Distribution::_validate_distropref
sub _validate_distropref {
    my($self,@args) = @_;
    if (
        $CPAN::META->has_inst("CPAN::Kwalify")
        &&
        $CPAN::META->has_inst("Kwalify")
       ) {
        eval {CPAN::Kwalify::_validate("distroprefs",@args);};
        if ($@) {
            $CPAN::Frontend->mywarn($@);
        }
    } else {
        CPAN->debug("not validating '@args'") if $CPAN::DEBUG;
    }
}

#-> CPAN::Distribution::_find_prefs
sub _find_prefs {
    my($self) = @_;
    my $distroid = $self->pretty_id;
    #CPAN->debug("distroid[$distroid]") if $CPAN::DEBUG;
    my $prefs_dir = $CPAN::Config->{prefs_dir};
    return if $prefs_dir =~ /^\s*$/;
    eval { File::Path::mkpath($prefs_dir); };
    if ($@) {
        $CPAN::Frontend->mydie("Cannot create directory $prefs_dir");
    }
    # shortcut if there are no distroprefs files
    {
      my $dh = DirHandle->new($prefs_dir) or $CPAN::Frontend->mydie("Couldn't open '$prefs_dir': $!");
      my @files = map { /\.(yml|dd|st)\z/i } $dh->read;
      return unless @files;
    }
    my $yaml_module = CPAN::_yaml_module();
    my $ext_map = {};
    my @extensions;
    if ($CPAN::META->has_inst($yaml_module)) {
        $ext_map->{yml} = 'CPAN';
    } else {
        my @fallbacks;
        if ($CPAN::META->has_inst("Data::Dumper")) {
            push @fallbacks, $ext_map->{dd} = 'Data::Dumper';
        }
        if ($CPAN::META->has_inst("Storable")) {
            push @fallbacks, $ext_map->{st} = 'Storable';
        }
        if (@fallbacks) {
            local $" = " and ";
            unless ($self->{have_complained_about_missing_yaml}++) {
                $CPAN::Frontend->mywarnonce("'$yaml_module' not installed, falling back ".
                                            "to @fallbacks to read prefs '$prefs_dir'\n");
            }
        } else {
            unless ($self->{have_complained_about_missing_yaml}++) {
                $CPAN::Frontend->mywarnonce("'$yaml_module' not installed, cannot ".
                                            "read prefs '$prefs_dir'\n");
            }
        }
    }
    my $finder = CPAN::Distroprefs->find($prefs_dir, $ext_map);
    DIRENT: while (my $result = $finder->next) {
        if ($result->is_warning) {
            $CPAN::Frontend->mywarn($result->as_string);
            $CPAN::Frontend->mysleep(1);
            next DIRENT;
        } elsif ($result->is_fatal) {
            $CPAN::Frontend->mydie($result->as_string);
        }

        my @prefs = @{ $result->prefs };

      ELEMENT: for my $y (0..$#prefs) {
            my $pref = $prefs[$y];
            $self->_validate_distropref($pref->data, $result->abs, $y);

            # I don't know why we silently skip when there's no match, but
            # complain if there's an empty match hashref, and there's no
            # comment explaining why -- hdp, 2008-03-18
            unless ($pref->has_any_match) {
                next ELEMENT;
            }

            unless ($pref->has_valid_subkeys) {
                $CPAN::Frontend->mydie(sprintf
                    "Nonconforming .%s file '%s': " .
                    "missing match/* subattribute. " .
                    "Please remove, cannot continue.",
                    $result->ext, $result->abs,
                );
            }

            my $arg = {
                env          => \%ENV,
                distribution => $distroid,
                perl         => \&CPAN::find_perl,
                perlconfig   => \%Config::Config,
                module       => sub { [ $self->containsmods ] },
            };

            if ($pref->matches($arg)) {
                return {
                    prefs => $pref->data,
                    prefs_file => $result->abs,
                    prefs_file_doc => $y,
                };
            }

        }
    }
    return;
}

# CPAN::Distribution::prefs
sub prefs {
    my($self) = @_;
    if (exists $self->{negative_prefs_cache}
        &&
        $self->{negative_prefs_cache} != $CPAN::CurrentCommandId
       ) {
        delete $self->{negative_prefs_cache};
        delete $self->{prefs};
    }
    if (exists $self->{prefs}) {
        return $self->{prefs}; # XXX comment out during debugging
    }
    if ($CPAN::Config->{prefs_dir}) {
        CPAN->debug("prefs_dir[$CPAN::Config->{prefs_dir}]") if $CPAN::DEBUG;
        my $prefs = $self->_find_prefs();
        $prefs ||= ""; # avoid warning next line
        CPAN->debug("prefs[$prefs]") if $CPAN::DEBUG;
        if ($prefs) {
            for my $x (qw(prefs prefs_file prefs_file_doc)) {
                $self->{$x} = $prefs->{$x};
            }
            my $bs = sprintf(
                             "%s[%s]",
                             File::Basename::basename($self->{prefs_file}),
                             $self->{prefs_file_doc},
                            );
            my $filler1 = "_" x 22;
            my $filler2 = int(66 - length($bs))/2;
            $filler2 = 0 if $filler2 < 0;
            $filler2 = " " x $filler2;
            $CPAN::Frontend->myprint("
$filler1 D i s t r o P r e f s $filler1
$filler2 $bs $filler2
");
            $CPAN::Frontend->mysleep(1);
            return $self->{prefs};
        }
    }
    $self->{negative_prefs_cache} = $CPAN::CurrentCommandId;
    return $self->{prefs} = +{};
}

# CPAN::Distribution::_make_phase_arg
sub _make_phase_arg {
    my($self, $phase) = @_;
    my $_make_phase_arg;
    my $prefs = $self->prefs;
    if (
        $prefs
        && exists $prefs->{$phase}
        && exists $prefs->{$phase}{args}
        && $prefs->{$phase}{args}
       ) {
        $_make_phase_arg = join(" ",
                           map {CPAN::HandleConfig
                                 ->safe_quote($_)} @{$prefs->{$phase}{args}},
                          );
    }

# cpan[2]> o conf make[TAB]
# make                       make_install_make_command
# make_arg                   makepl_arg
# make_install_arg
# cpan[2]> o conf mbuild[TAB]
# mbuild_arg                    mbuild_install_build_command
# mbuild_install_arg            mbuildpl_arg

    my $mantra; # must switch make/mbuild here
    if ($self->{modulebuild}) {
        $mantra = "mbuild";
    } else {
        $mantra = "make";
    }
    my %map = (
               pl => "pl_arg",
               make => "_arg",
               test => "_test_arg", # does not really exist but maybe
                                    # will some day and now protects
                                    # us from unini warnings
               install => "_install_arg",
              );
    my $phase_underscore_meshup = $map{$phase};
    my $what = sprintf "%s%s", $mantra, $phase_underscore_meshup;

    $_make_phase_arg ||= $CPAN::Config->{$what};
    return $_make_phase_arg;
}

# CPAN::Distribution::_make_command
sub _make_command {
    my ($self) = @_;
    if ($self) {
        return
            CPAN::HandleConfig
                ->safe_quote(
                             CPAN::HandleConfig->prefs_lookup($self,
                                                              q{make})
                             || $Config::Config{make}
                             || 'make'
                            );
    } else {
        # Old style call, without object. Deprecated
        Carp::confess("CPAN::_make_command() used as function. Don't Do That.");
        return
          safe_quote(undef,
                     CPAN::HandleConfig->prefs_lookup($self,q{make})
                     || $CPAN::Config->{make}
                     || $Config::Config{make}
                     || 'make');
    }
}

sub _make_install_make_command {
    my ($self) = @_;
    my $mimc =
        CPAN::HandleConfig->prefs_lookup($self, q{make_install_make_command});
    return $self->_make_command() unless $mimc;

    # Quote the "make install" make command on Windows, where it is commonly
    # found in, e.g., C:\Program Files\... and therefore needs quoting. We can't
    # do this in general because the command maybe "sudo make..." (i.e. a
    # program with arguments), but that is unlikely to be the case on Windows.
    $mimc = CPAN::HandleConfig->safe_quote($mimc) if $^O eq 'MSWin32';

    return $mimc;
}

#-> sub CPAN::Distribution::is_locally_optional
sub is_locally_optional {
    my($self, $prereq_pm, $prereq) = @_;
    $prereq_pm ||= $self->{prereq_pm};
    my($nmo,$opt);
    for my $rt (qw(requires build_requires)) {
        if (exists $prereq_pm->{$rt}{$prereq}) {
            # rt 121914
            $nmo ||= $CPAN::META->instance("CPAN::Module",$prereq);
            my $av = $nmo->available_version;
            return 0 if !$av || CPAN::Version->vlt($av,$prereq_pm->{$rt}{$prereq});
        }
        if (exists $prereq_pm->{"opt_$rt"}{$prereq}) {
            $opt = 1;
        }
    }
    return $opt||0;
}

#-> sub CPAN::Distribution::follow_prereqs ;
sub follow_prereqs {
    my($self) = shift;
    my($slot) = shift;
    my(@prereq_tuples) = grep {$_->[0] ne "perl"} @_;
    return unless @prereq_tuples;
    my(@good_prereq_tuples);
    for my $p (@prereq_tuples) {
        # e.g. $p = ['Devel::PartialDump', 'r', 1]
        # promote if possible
        if ($p->[1] =~ /^(r|c)$/) {
            push @good_prereq_tuples, $p;
        } elsif ($p->[1] =~ /^(b)$/) {
            my $reqtype = CPAN::Queue->reqtype_of($p->[0]);
            if ($reqtype =~ /^(r|c)$/) {
                push @good_prereq_tuples, [$p->[0], $reqtype, $p->[2]];
            } else {
                push @good_prereq_tuples, $p;
            }
        } else {
            die "Panic: in follow_prereqs: reqtype[$p->[1]] seen, should never happen";
        }
    }
    my $pretty_id = $self->pretty_id;
    my %map = (
               b => "build_requires",
               r => "requires",
               c => "commandline",
              );
    my($filler1,$filler2,$filler3,$filler4);
    my $unsat = "Unsatisfied dependencies detected during";
    my $w = length($unsat) > length($pretty_id) ? length($unsat) : length($pretty_id);
    {
        my $r = int(($w - length($unsat))/2);
        my $l = $w - length($unsat) - $r;
        $filler1 = "-"x4 . " "x$l;
        $filler2 = " "x$r . "-"x4 . "\n";
    }
    {
        my $r = int(($w - length($pretty_id))/2);
        my $l = $w - length($pretty_id) - $r;
        $filler3 = "-"x4 . " "x$l;
        $filler4 = " "x$r . "-"x4 . "\n";
    }
    $CPAN::Frontend->
        myprint("$filler1 $unsat $filler2".
                "$filler3 $pretty_id $filler4".
                join("", map {sprintf "    %s \[%s%s]\n", $_->[0], $map{$_->[1]}, $self->is_locally_optional(undef,$_->[0]) ? ",optional" : ""} @good_prereq_tuples),
               );
    my $follow = 0;
    if ($CPAN::Config->{prerequisites_policy} eq "follow") {
        $follow = 1;
    } elsif ($CPAN::Config->{prerequisites_policy} eq "ask") {
        my $answer = CPAN::Shell::colorable_makemaker_prompt(
"Shall I follow them and prepend them to the queue
of modules we are processing right now?", "yes");
        $follow = $answer =~ /^\s*y/i;
    } else {
        my @prereq = map { $_->[0] } @good_prereq_tuples;
        local($") = ", ";
        $CPAN::Frontend->
            myprint("  Ignoring dependencies on modules @prereq\n");
    }
    if ($follow) {
        my $id = $self->id;
        my(@to_queue_mand,@to_queue_opt);
        for my $gp (@good_prereq_tuples) {
            my($prereq,$reqtype,$optional) = @$gp;
            my $qthing = +{qmod=>$prereq,reqtype=>$reqtype,optional=>$optional};
            if ($optional &&
                $self->is_locally_optional(undef,$prereq)
               ){
                # Since we do not depend on this one, we do not need
                # this in a mandatory arrangement:
                push @to_queue_opt, $qthing;
            } else {
                my $any = CPAN::Shell->expandany($prereq);
                $self->{$slot . "_for"}{$any->id}++;
                if ($any) {
                    unless ($optional) {
                        # No recursion check in an optional area of the tree
                        $any->color_cmd_tmps(0,2);
                    }
                } else {
                    $CPAN::Frontend->mywarn("Warning (maybe a bug): Cannot expand prereq '$prereq'\n");
                    $CPAN::Frontend->mysleep(2);
                }
                # order everything that is not locally_optional just
                # like mandatory items: this keeps leaves before
                # branches
                unshift @to_queue_mand, $qthing;
            }
        }
        if (@to_queue_mand) {
            unshift @to_queue_mand, {qmod => $id, reqtype => $self->{reqtype}, optional=> !$self->{mandatory}};
            CPAN::Queue->jumpqueue(@to_queue_opt,@to_queue_mand);
            $self->{$slot} = "Delayed until after prerequisites";
            return 1; # signal we need dependencies
        } elsif (@to_queue_opt) {
            CPAN::Queue->jumpqueue(@to_queue_opt);
        }
    }
    return;
}

sub _feature_depends {
    my($self) = @_;
    my $meta_yml = $self->parse_meta_yml();
    my $optf = $meta_yml->{optional_features} or return;
    if (!ref $optf or ref $optf ne "HASH"){
        $CPAN::Frontend->mywarn("The content of optional_features is not a HASH reference. Cannot use it.\n");
        $optf = {};
    }
    my $wantf = $self->prefs->{features} or return;
    if (!ref $wantf or ref $wantf ne "ARRAY"){
        $CPAN::Frontend->mywarn("The content of 'features' is not an ARRAY reference. Cannot use it.\n");
        $wantf = [];
    }
    my $dep = +{};
    for my $wf (@$wantf) {
        if (my $f = $optf->{$wf}) {
            $CPAN::Frontend->myprint("Found the demanded feature '$wf' that ".
                                     "is accompanied by this description:\n".
                                     $f->{description}.
                                     "\n\n"
                                    );
            # configure_requires currently not in the spec, unlikely to be useful anyway
            for my $reqtype (qw(configure_requires build_requires requires)) {
                my $reqhash = $f->{$reqtype} or next;
                while (my($k,$v) = each %$reqhash) {
                    $dep->{$reqtype}{$k} = $v;
                }
            }
        } else {
            $CPAN::Frontend->mywarn("The demanded feature '$wf' was not ".
                                    "found in the META.yml file".
                                    "\n\n"
                                   );
        }
    }
    $dep;
}

sub prereqs_for_slot {
    my($self,$slot) = @_;
    my($prereq_pm);
    unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
        my $whynot = "not available";
        if (defined $CPAN::Meta::Requirements::VERSION) {
            $whynot = "version $CPAN::Meta::Requirements::VERSION not sufficient";
        }
        $CPAN::Frontend->mywarn("CPAN::Meta::Requirements $whynot\n");
        my $before = "";
        if ($self->{CALLED_FOR}){
            if ($self->{CALLED_FOR} =~
                /^(
                     CPAN::Meta::Requirements
                 |CPAN::DistnameInfo
                 |version
                 |parent
                 |ExtUtils::MakeMaker
                 |Test::Harness
                 )$/x) {
                $CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ".
                    "as soon as possible; it is needed for a reliable operation of ".
                    "the cpan shell; setting requirements to nil for '$1' for now ".
                    "to prevent deadlock during bootstrapping\n");
                return;
            }
            $before = " before $self->{CALLED_FOR}";
        }
        $CPAN::Frontend->mydie("Please install CPAN::Meta::Requirements manually$before");
    }
    my $merged = CPAN::Meta::Requirements->new;
    my $prefs_depends = $self->prefs->{depends}||{};
    my $feature_depends = $self->_feature_depends();
    if ($slot eq "configure_requires_later") {
        for my $hash (  $self->configure_requires,
                        $prefs_depends->{configure_requires},
                        $feature_depends->{configure_requires},
        ) {
            $merged->add_requirements(
                CPAN::Meta::Requirements->from_string_hash($hash)
            );
        }
        if (-f "Build.PL"
            && ! -f File::Spec->catfile($self->{build_dir},"Makefile.PL")
            && ! @{[ $merged->required_modules ]}
            && ! $CPAN::META->has_inst("Module::Build")
           ) {
            $CPAN::Frontend->mywarn(
              "  Warning: CPAN.pm discovered Module::Build as undeclared prerequisite.\n".
              "  Adding it now as such.\n"
            );
            $CPAN::Frontend->mysleep(5);
            $merged->add_minimum( "Module::Build" => 0 );
            delete $self->{writemakefile};
        }
        $prereq_pm = {}; # configure_requires defined as "b"
    } elsif ($slot eq "later") {
        my $prereq_pm_0 = $self->prereq_pm || {};
        for my $reqtype (qw(requires build_requires opt_requires opt_build_requires)) {
            $prereq_pm->{$reqtype} = {%{$prereq_pm_0->{$reqtype}||{}}}; # copy to not pollute it
            for my $dep ($prefs_depends,$feature_depends) {
                for my $k (keys %{$dep->{$reqtype}||{}}) {
                    $prereq_pm->{$reqtype}{$k} = $dep->{$reqtype}{$k};
                }
            }
        }
        # XXX what about optional_req|breq? -- xdg, 2012-04-01
        for my $hash (
            $prereq_pm->{requires},
            $prereq_pm->{build_requires},
            $prereq_pm->{opt_requires},
            $prereq_pm->{opt_build_requires},

        ) {
            $merged->add_requirements(
                CPAN::Meta::Requirements->from_string_hash($hash)
            );
        }
    } else {
        die "Panic: illegal slot '$slot'";
    }
    return ($merged->as_string_hash, $prereq_pm);
}

#-> sub CPAN::Distribution::unsat_prereq ;
# return ([Foo,"r"],[Bar,"b"]) for normal modules
# return ([perl=>5.008]) if we need a newer perl than we are running under
# (sorry for the inconsistency, it was an accident)
sub unsat_prereq {
    my($self,$slot) = @_;
    my($merged_hash,$prereq_pm) = $self->prereqs_for_slot($slot);
    my(@need);
    unless ($CPAN::META->has_usable("CPAN::Meta::Requirements")) {
        $CPAN::Frontend->mywarn("CPAN::Meta::Requirements not available, please install as soon as possible, trying to continue with severly limited capabilities\n");
        return;
    }
    my $merged = CPAN::Meta::Requirements->from_string_hash($merged_hash);
    my @merged = sort $merged->required_modules;
    CPAN->debug("all merged_prereqs[@merged]") if $CPAN::DEBUG;
  NEED: for my $need_module ( @merged ) {
        my $need_version = $merged->requirements_for_module($need_module);
        my($available_version,$inst_file,$available_file,$nmo);
        if ($need_module eq "perl") {
            $available_version = $];
            $available_file = CPAN::find_perl();
        } else {
            if (CPAN::_sqlite_running()) {
                CPAN::Index->reload;
                $CPAN::SQLite->search("CPAN::Module",$need_module);
            }
            $nmo = $CPAN::META->instance("CPAN::Module",$need_module);
            $inst_file = $nmo->inst_file || '';
            $available_file = $nmo->available_file || '';
            $available_version = $nmo->available_version;
            if ($nmo->uptodate) {
                my $accepts = eval {
                    $merged->accepts_module($need_module, $available_version);
                };
                unless ($accepts) {
                    my $rq = $merged->requirements_for_module( $need_module );
                    $CPAN::Frontend->mywarn(
                        "Warning: Version '$available_version' of ".
                        "'$need_module' is up to date but does not ".
                        "fulfill requirements ($rq). I will continue, ".
                        "but chances to succeed are low.\n");
                }
                next NEED;
            }

            # if they have not specified a version, we accept any
            # installed one; in that case inst_file is always
            # sufficient and available_file is sufficient on
            # both build_requires and configure_requires
            my $sufficient = $inst_file ||
                ( exists $prereq_pm->{requires}{$need_module} ? 0 : $available_file );
            if ( $sufficient
                and ( # a few quick short circuits
                     not defined $need_version
                     or $need_version eq '0'    # "==" would trigger warning when not numeric
                     or $need_version eq "undef"
                    )) {
                unless ($nmo->inst_deprecated) {
                    next NEED;
                }
            }
        }

        # We only want to install prereqs if either they're not installed
        # or if the installed version is too old. We cannot omit this
        # check, because if 'force' is in effect, nobody else will check.
        # But we don't want to accept a deprecated module installed as part
        # of the Perl core, so we continue if the available file is the installed
        # one and is deprecated

        if ( $available_file ) {
            my $fulfills_all_version_rqs = $self->_fulfills_all_version_rqs
                (
                 $need_module,
                 $available_file,
                 $available_version,
                 $need_version,
                );
            if ( $inst_file
                       && $available_file eq $inst_file
                       && $nmo->inst_deprecated
                     ) {
                # continue installing as a prereq. we really want that
                # because the deprecated module may spit out warnings
                # and third party did not know until today. Only one
                # exception is OK, because CPANPLUS is special after
                # all:
                if ( $fulfills_all_version_rqs and
                     $nmo->id =~ /^CPANPLUS(?:::Dist::Build)$/
                   ) {
                    # here we have an available version that is good
                    # enough although deprecated (preventing circular
                    # loop CPANPLUS => CPANPLUS::Dist::Build RT#83042)
                    next NEED;
                }
            } elsif (
                $self->{reqtype} # e.g. maybe we came via goto?
                && $self->{reqtype} =~ /^(r|c)$/
                && (   exists $prereq_pm->{requires}{$need_module}
                    || exists $prereq_pm->{opt_requires}{$need_module} )
                && $nmo
                && !$inst_file
            ) {
                # continue installing as a prereq; this may be a
                # distro we already used when it was a build_requires
                # so we did not install it. But suddenly somebody
                # wants it as a requires
                my $need_distro = $nmo->distribution;
                if ($need_distro->{install} && $need_distro->{install}->failed && $need_distro->{install}->text =~ /is only/) {
                    my $id = $need_distro->pretty_id;
                    $CPAN::Frontend->myprint("Promoting $id from build_requires to requires due $need_module\n");
                    delete $need_distro->{install}; # promote to another installation attempt
                    $need_distro->{reqtype} = "r";
                    $need_distro->install;
                    next NEED;
                }
            }
            else {
                next NEED if $fulfills_all_version_rqs;
            }
        }

        if ($need_module eq "perl") {
            return ["perl", $need_version];
        }
        $self->{sponsored_mods}{$need_module} ||= 0;
        CPAN->debug("need_module[$need_module]s/s/n[$self->{sponsored_mods}{$need_module}]") if $CPAN::DEBUG;
        if (my $sponsoring = $self->{sponsored_mods}{$need_module}++) {
            # We have already sponsored it and for some reason it's still
            # not available. So we do ... what??

            # if we push it again, we have a potential infinite loop

            # The following "next" was a very problematic construct.
            # It helped a lot but broke some day and had to be
            # replaced.

            # We must be able to deal with modules that come again and
            # again as a prereq and have themselves prereqs and the
            # queue becomes long but finally we would find the correct
            # order. The RecursiveDependency check should trigger a
            # die when it's becoming too weird. Unfortunately removing
            # this next breaks many other things.

            # The bug that brought this up is described in Todo under
            # "5.8.9 cannot install Compress::Zlib"

            # next; # this is the next that had to go away

            # The following "next NEED" are fine and the error message
            # explains well what is going on. For example when the DBI
            # fails and consequently DBD::SQLite fails and now we are
            # processing CPAN::SQLite. Then we must have a "next" for
            # DBD::SQLite. How can we get it and how can we identify
            # all other cases we must identify?

            my $do = $nmo->distribution;
            next NEED unless $do; # not on CPAN
            if (CPAN::Version->vcmp($need_version, $nmo->ro->{CPAN_VERSION}) > 0){
                $CPAN::Frontend->mywarn("Warning: Prerequisite ".
                                        "'$need_module => $need_version' ".
                                        "for '$self->{ID}' seems ".
                                        "not available according to the indices\n"
                                       );
                next NEED;
            }
          NOSAYER: for my $nosayer (
                                    "unwrapped",
                                    "writemakefile",
                                    "signature_verify",
                                    "make",
                                    "make_test",
                                    "install",
                                    "make_clean",
                                   ) {
                if ($do->{$nosayer}) {
                    my $selfid = $self->pretty_id;
                    my $did = $do->pretty_id;
                    if (UNIVERSAL::can($do->{$nosayer},"failed") ?
                        $do->{$nosayer}->failed :
                        $do->{$nosayer} =~ /^NO/) {
                        if ($nosayer eq "make_test"
                            &&
                            $do->{make_test}{COMMANDID} != $CPAN::CurrentCommandId
                           ) {
                            next NOSAYER;
                        }
                        ### XXX  don't complain about missing optional deps -- xdg, 2012-04-01
                        if ($self->is_locally_optional($prereq_pm, $need_module)) {
                            # don't complain about failing optional prereqs
                        }
                        else {
                            $CPAN::Frontend->mywarn("Warning: Prerequisite ".
                                                    "'$need_module => $need_version' ".
                                                    "for '$selfid' failed when ".
                                                    "processing '$did' with ".
                                                    "'$nosayer => $do->{$nosayer}'. Continuing, ".
                                                    "but chances to succeed are limited.\n"
                                                );
                            $CPAN::Frontend->mysleep($sponsoring/10);
                        }
                        next NEED;
                    } else { # the other guy succeeded
                        if ($nosayer =~ /^(install|make_test)$/) {
                            # we had this with
                            # DMAKI/DateTime-Calendar-Chinese-0.05.tar.gz
                            # in 2007-03 for 'make install'
                            # and 2008-04: #30464 (for 'make test')
                            # $CPAN::Frontend->mywarn("Warning: Prerequisite ".
                            #                         "'$need_module => $need_version' ".
                            #                         "for '$selfid' already built ".
                            #                         "but the result looks suspicious. ".
                            #                         "Skipping another build attempt, ".
                            #                         "to prevent looping endlessly.\n"
                            #                        );
                            next NEED;
                        }
                    }
                }
            }
        }
        my $needed_as;
        if (0) {
        } elsif (exists $prereq_pm->{requires}{$need_module}
            || exists $prereq_pm->{opt_requires}{$need_module}
        ) {
            $needed_as = "r";
        } elsif ($slot eq "configure_requires_later") {
            # in ae872487d5 we said: C< we have not yet run the
            # {Build,Makefile}.PL, we must presume "r" >; but the
            # meta.yml standard says C< These dependencies are not
            # required after the distribution is installed. >; so now
            # we change it back to "b" and care for the proper
            # promotion later.
            $needed_as = "b";
        } else {
            $needed_as = "b";
        }
        # here need to flag as optional for recommends/suggests
        # -- xdg, 2012-04-01
        $self->debug(sprintf "%s manadory?[%s]",
                     $self->pretty_id,
                     $self->{mandatory})
            if $CPAN::DEBUG;
        my $optional = !$self->{mandatory}
            || $self->is_locally_optional($prereq_pm, $need_module);
        push @need, [$need_module,$needed_as,$optional];
    }
    my @unfolded = map { "[".join(",",@$_)."]" } @need;
    CPAN->debug("returning from unsat_prereq[@unfolded]") if $CPAN::DEBUG;
    @need;
}

sub _fulfills_all_version_rqs {
    my($self,$need_module,$available_file,$available_version,$need_version) = @_;
    my(@all_requirements) = split /\s*,\s*/, $need_version;
    local($^W) = 0;
    my $ok = 0;
  RQ: for my $rq (@all_requirements) {
        if ($rq =~ s|>=\s*||) {
        } elsif ($rq =~ s|>\s*||) {
            # 2005-12: one user
            if (CPAN::Version->vgt($available_version,$rq)) {
                $ok++;
            }
            next RQ;
        } elsif ($rq =~ s|!=\s*||) {
            # 2005-12: no user
            if (CPAN::Version->vcmp($available_version,$rq)) {
                $ok++;
                next RQ;
            } else {
                $ok=0;
                last RQ;
            }
        } elsif ($rq =~ m|<=?\s*|) {
            # 2005-12: no user
            $CPAN::Frontend->mywarn("Downgrading not supported (rq[$rq])\n");
            $ok++;
            next RQ;
        } elsif ($rq =~ s|==\s*||) {
            # 2009-07: ELLIOTJS/Perl-Critic-1.099_002.tar.gz
            if (CPAN::Version->vcmp($available_version,$rq)) {
                $ok=0;
                last RQ;
            } else {
                $ok++;
                next RQ;
            }
        }
        if (! CPAN::Version->vgt($rq, $available_version)) {
            $ok++;
        }
        CPAN->debug(sprintf("need_module[%s]available_file[%s]".
                            "available_version[%s]rq[%s]ok[%d]",
                            $need_module,
                            $available_file,
                            $available_version,
                            CPAN::Version->readable($rq),
                            $ok,
                           )) if $CPAN::DEBUG;
    }
    my $ret = $ok == @all_requirements;
    CPAN->debug(sprintf("need_module[%s]ok[%s]all_requirements[%d]",$need_module, $ok, scalar @all_requirements)) if $CPAN::DEBUG;
    return $ret;
}

#-> sub CPAN::Distribution::read_meta
# read any sort of meta files, return CPAN::Meta object if no errors
sub read_meta {
    my($self) = @_;
    my $meta_file = $self->pick_meta_file
        or return;

    return unless $CPAN::META->has_usable("CPAN::Meta");
    my $meta = eval { CPAN::Meta->load_file($meta_file)}
        or return;

    # Very old EU::MM could have wrong META
    if ($meta_file eq 'META.yml'
        && $meta->generated_by =~ /ExtUtils::MakeMaker version ([\d\._]+)/
    ) {
        my $eummv = do { local $^W = 0; $1+0; };
        return if $eummv < 6.2501;
    }

    return $meta;
}

#-> sub CPAN::Distribution::read_yaml ;
# XXX This should be DEPRECATED -- dagolden, 2011-02-05
sub read_yaml {
    my($self) = @_;
    my $meta_file = $self->pick_meta_file('\.yml$');
    $self->debug("meta_file[$meta_file]") if $CPAN::DEBUG;
    return unless $meta_file;
    my $yaml;
    eval { $yaml = $self->parse_meta_yml($meta_file) };
    if ($@ or ! $yaml) {
        return undef; # if we die, then we cannot read YAML's own META.yml
    }
    # not "authoritative"
    if (defined $yaml && (! ref $yaml || ref $yaml ne "HASH")) {
        $CPAN::Frontend->mywarn("META.yml does not seem to be conforming, cannot use it.\n");
        $yaml = undef;
    }
    $self->debug(sprintf "yaml[%s]", $yaml || "UNDEF")
        if $CPAN::DEBUG;
    $self->debug($yaml) if $CPAN::DEBUG && $yaml;
    # MYMETA.yml is static and authoritative by definition
    if ( $meta_file =~ /MYMETA\.yml/ ) {
      return $yaml;
    }
    # META.yml is authoritative only if dynamic_config is defined and false
    if ( defined $yaml->{dynamic_config} && ! $yaml->{dynamic_config} ) {
      return $yaml;
    }
    # otherwise, we can't use what we found
    return undef;
}

#-> sub CPAN::Distribution::configure_requires ;
sub configure_requires {
    my($self) = @_;
    return unless my $meta_file = $self->pick_meta_file('^META');
    if (my $meta_obj = $self->read_meta) {
        my $prereqs = $meta_obj->effective_prereqs;
        my $cr = $prereqs->requirements_for(qw/configure requires/);
        return $cr ? $cr->as_string_hash : undef;
    }
    else {
        my $yaml = eval { $self->parse_meta_yml($meta_file) };
        return $yaml->{configure_requires};
    }
}

#-> sub CPAN::Distribution::prereq_pm ;
sub prereq_pm {
    my($self) = @_;
    return unless $self->{writemakefile}  # no need to have succeeded
                                          # but we must have run it
        || $self->{modulebuild};
    unless ($self->{build_dir}) {
        return;
    }
    # no Makefile/Build means configuration aborted, so don't look for prereqs
    my $makefile  = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'descrip.mms' : 'Makefile');
    my $buildfile = File::Spec->catfile($self->{build_dir}, $^O eq 'VMS' ? 'Build.com' : 'Build');
    return unless   -f $makefile || -f $buildfile;
    CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
                $self->{writemakefile}||"",
                $self->{modulebuild}||"",
               ) if $CPAN::DEBUG;
    my($req,$breq, $opt_req, $opt_breq);
    my $meta_obj = $self->read_meta;
    # META/MYMETA is only authoritative if dynamic_config is false
    if ($meta_obj && ! $meta_obj->dynamic_config) {
        my $prereqs = $meta_obj->effective_prereqs;
        my $requires = $prereqs->requirements_for(qw/runtime requires/);
        my $build_requires = $prereqs->requirements_for(qw/build requires/);
        my $test_requires = $prereqs->requirements_for(qw/test requires/);
        # XXX we don't yet distinguish build vs test, so merge them for now
        $build_requires->add_requirements($test_requires);
        $req = $requires->as_string_hash;
        $breq = $build_requires->as_string_hash;

        # XXX assemble optional_req && optional_breq from recommends/suggests
        # depending on corresponding policies -- xdg, 2012-04-01
        CPAN->use_inst("CPAN::Meta::Requirements");
        my $opt_runtime = CPAN::Meta::Requirements->new;
        my $opt_build   = CPAN::Meta::Requirements->new;
        if ( $CPAN::Config->{recommends_policy} ) {
            $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime recommends/));
            $opt_build->add_requirements(   $prereqs->requirements_for(qw/build recommends/));
            $opt_build->add_requirements(   $prereqs->requirements_for(qw/test  recommends/));

        }
        if ( $CPAN::Config->{suggests_policy} ) {
            $opt_runtime->add_requirements( $prereqs->requirements_for(qw/runtime suggests/));
            $opt_build->add_requirements(   $prereqs->requirements_for(qw/build suggests/));
            $opt_build->add_requirements(   $prereqs->requirements_for(qw/test  suggests/));
        }
        $opt_req = $opt_runtime->as_string_hash;
        $opt_breq = $opt_build->as_string_hash;
    }
    elsif (my $yaml = $self->read_yaml) { # often dynamic_config prevents a result here
        $req =  $yaml->{requires} || {};
        $breq =  $yaml->{build_requires} || {};
        if ( $CPAN::Config->{recommends_policy} ) {
            $opt_req = $yaml->{recommends} || {};
        }
        undef $req unless ref $req eq "HASH" && %$req;
        if ($req) {
            if ($yaml->{generated_by} &&
                $yaml->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) {
                my $eummv = do { local $^W = 0; $1+0; };
                if ($eummv < 6.2501) {
                    # thanks to Slaven for digging that out: MM before
                    # that could be wrong because it could reflect a
                    # previous release
                    undef $req;
                }
            }
            my $areq;
            my $do_replace;
            foreach my $k (sort keys %{$req||{}}) {
                my $v = $req->{$k};
                next unless defined $v;
                if ($v =~ /\d/) {
                    $areq->{$k} = $v;
                } elsif ($k =~ /[A-Za-z]/ &&
                         $v =~ /[A-Za-z]/ &&
                         $CPAN::META->exists("CPAN::Module",$v)
                        ) {
                    $CPAN::Frontend->mywarn("Suspicious key-value pair in META.yml's ".
                                            "requires hash: $k => $v; I'll take both ".
                                            "key and value as a module name\n");
                    $CPAN::Frontend->mysleep(1);
                    $areq->{$k} = 0;
                    $areq->{$v} = 0;
                    $do_replace++;
                }
            }
            $req = $areq if $do_replace;
        }
    }
    else {
        $CPAN::Frontend->mywarnonce("Could not read metadata file. Falling back to other ".
                                    "methods to determine prerequisites\n");
    }

    unless ($req || $breq) {
        my $build_dir;
        unless ( $build_dir = $self->{build_dir} ) {
            return;
        }
        my $makefile = File::Spec->catfile($build_dir,"Makefile");
        my $fh;
        if (-f $makefile
            and
            $fh = FileHandle->new("<$makefile\0")) {
            CPAN->debug("Getting prereq from Makefile") if $CPAN::DEBUG;
            local($/) = "\n";
            while (<$fh>) {
                last if /MakeMaker post_initialize section/;
                my($p) = m{^[\#]
                           \s+PREREQ_PM\s+=>\s+(.+)
                       }x;
                next unless $p;
                # warn "Found prereq expr[$p]";

                #  Regexp modified by A.Speer to remember actual version of file
                #  PREREQ_PM hash key wants, then add to
                while ( $p =~ m/(?:\s)([\w\:]+)=>(q\[.*?\]|undef),?/g ) {
                    my($m,$n) = ($1,$2);
                    # When a prereq is mentioned twice: let the bigger
                    # win; usual culprit is that they declared
                    # build_requires separately from requires; see
                    # rt.cpan.org #47774
                    my($prevn);
                    if ( defined $req->{$m} ) {
                        $prevn = $req->{$m};
                    }
                    if ($n =~ /^q\[(.*?)\]$/) {
                        $n = $1;
                    }
                    if (!$prevn || CPAN::Version->vlt($prevn, $n)){
                        $req->{$m} = $n;
                    }
                }
                last;
            }
        }
    }
    unless ($req || $breq) {
        my $build_dir = $self->{build_dir} or die "Panic: no build_dir?";
        my $buildfile = File::Spec->catfile($build_dir,"Build");
        if (-f $buildfile) {
            CPAN->debug("Found '$buildfile'") if $CPAN::DEBUG;
            my $build_prereqs = File::Spec->catfile($build_dir,"_build","prereqs");
            if (-f $build_prereqs) {
                CPAN->debug("Getting prerequisites from '$build_prereqs'") if $CPAN::DEBUG;
                my $content = do { local *FH;
                                   open FH, $build_prereqs
                                       or $CPAN::Frontend->mydie("Could not open ".
                                                                 "'$build_prereqs': $!");
                                   local $/;
                                   <FH>;
                               };
                my $bphash = eval $content;
                if ($@) {
                } else {
                    $req  = $bphash->{requires} || +{};
                    $breq = $bphash->{build_requires} || +{};
                }
            }
        }
    }
    # XXX needs to be adapted for optional_req & optional_breq -- xdg, 2012-04-01
    if ($req || $breq || $opt_req || $opt_breq ) {
        return $self->{prereq_pm} = {
           requires => $req,
           build_requires => $breq,
           opt_requires => $opt_req,
           opt_build_requires => $opt_breq,
       };
    }
}

#-> sub CPAN::Distribution::shortcut_test ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success
sub shortcut_test {
    my ($self) = @_;

    $self->debug("checking badtestcnt[$self->{ID}]") if $CPAN::DEBUG;
    $self->{badtestcnt} ||= 0;
    if ($self->{badtestcnt} > 0) {
        require Data::Dumper;
        CPAN->debug(sprintf "NOREPEAT[%s]", Data::Dumper::Dumper($self)) if $CPAN::DEBUG;
        return $self->goodbye("Won't repeat unsuccessful test during this command");
    }

    for my $slot ( qw/later configure_requires_later/ ) {
        $self->debug("checking $slot slot[$self->{ID}]") if $CPAN::DEBUG;
        return $self->success($self->{$slot})
        if $self->{$slot};
    }

    $self->debug("checking if tests passed[$self->{ID}]") if $CPAN::DEBUG;
    if ( $self->{make_test} ) {
        if (
            UNIVERSAL::can($self->{make_test},"failed") ?
            $self->{make_test}->failed :
            $self->{make_test} =~ /^NO/
        ) {
            if (
                UNIVERSAL::can($self->{make_test},"commandid")
                &&
                $self->{make_test}->commandid == $CPAN::CurrentCommandId
            ) {
                return $self->goodbye("Has already been tested within this command");
            }
        } else {
            # if global "is_tested" has been cleared, we need to mark this to
            # be added to PERL5LIB if not already installed
            if ($self->tested_ok_but_not_installed) {
                $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
            }
            return $self->success("Has already been tested successfully");
        }
    }

    if ($self->{notest}) {
        $self->{make_test} = CPAN::Distrostatus->new("YES");
        return $self->success("Skipping test because of notest pragma");
    }

    return undef; # no shortcut
}

#-> sub CPAN::Distribution::_exe_files ;
sub _exe_files {
    my($self) = @_;
    return unless $self->{writemakefile}  # no need to have succeeded
                                          # but we must have run it
        || $self->{modulebuild};
    unless ($self->{build_dir}) {
        return;
    }
    CPAN->debug(sprintf "writemakefile[%s]modulebuild[%s]",
                $self->{writemakefile}||"",
                $self->{modulebuild}||"",
               ) if $CPAN::DEBUG;
    my $build_dir;
    unless ( $build_dir = $self->{build_dir} ) {
        return;
    }
    my $makefile = File::Spec->catfile($build_dir,"Makefile");
    my $fh;
    my @exe_files;
    if (-f $makefile
        and
        $fh = FileHandle->new("<$makefile\0")) {
        CPAN->debug("Getting exefiles from Makefile") if $CPAN::DEBUG;
        local($/) = "\n";
        while (<$fh>) {
            last if /MakeMaker post_initialize section/;
            my($p) = m{^[\#]
                       \s+EXE_FILES\s+=>\s+\[(.+)\]
                  }x;
            next unless $p;
            # warn "Found exefiles expr[$p]";
            my @p = split /,\s*/, $p;
            for my $p2 (@p) {
                if ($p2 =~ /^q\[(.+)\]/) {
                    push @exe_files, $1;
                }
            }
        }
    }
    return \@exe_files if @exe_files;
    my $buildparams = File::Spec->catfile($build_dir,"_build","build_params");
    if (-f $buildparams) {
        CPAN->debug("Found '$buildparams'") if $CPAN::DEBUG;
        my $x = do $buildparams;
        for my $sf ($x->[2]{script_files}) {
            if (my $reftype = ref $sf) {
                if ($reftype eq "ARRAY") {
                    push @exe_files, @$sf;
                }
                elsif ($reftype eq "HASH") {
                    push @exe_files, keys %$sf;
                }
                else {
                    $CPAN::Frontend->mywarn("Invalid reftype $reftype for Build.PL 'script_files'\n");
                }
            }
            elsif (defined $sf) {
                push @exe_files, $sf;
            }
        }
    }
    return \@exe_files;
}

#-> sub CPAN::Distribution::test ;
sub test {
    my($self) = @_;

    $self->pre_test();

    if (exists $self->{cleanup_after_install_done}) {
        $self->post_test();
        return $self->make;
    }

    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
    if (my $goto = $self->prefs->{goto}) {
        $self->post_test();
        return $self->goto($goto);
    }

    unless ($self->make){
        $self->post_test();
        return;
    }

    if ( defined( my $sc = $self->shortcut_test ) ) {
        $self->post_test();
        return $sc;
    }

    if ($CPAN::Signal) {
        delete $self->{force_update};
        $self->post_test();
        return;
    }
    # warn "XDEBUG: checking for notest: $self->{notest} $self";
    my $make = $self->{modulebuild} ? "Build" : "make";

    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
                           ? $ENV{PERL5LIB}
                           : ($ENV{PERLLIB} || "");

    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
    local $ENV{PERL_USE_UNSAFE_INC} =
        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test
    $CPAN::META->set_perl5lib;
    local $ENV{MAKEFLAGS}; # protect us from outer make calls
    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};

    if ($run_allow_installing_within_test) {
        my($allow_installing, $why) = $self->_allow_installing;
        if (! $allow_installing) {
            $CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n");
            $self->introduce_myself;
            $self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why");
            $CPAN::Frontend->mywarn("  [testing] -- NOT OK\n");
            delete $self->{force_update};
            $self->post_test();
            return;
        }
    }
    $CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id);

    my $builddir = $self->dir or
        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");

    unless (chdir $builddir) {
        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
        $self->post_test();
        return;
    }

    $self->debug("Changed directory to $self->{build_dir}")
        if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make_test($self);
        $self->post_test();
        return;
    }

    if ($self->{modulebuild}) {
        my $thm = CPAN::Shell->expand("Module","Test::Harness");
        my $v = $thm->inst_version;
        if (CPAN::Version->vlt($v,2.62)) {
            # XXX Eric Wilhelm reported this as a bug: klapperl:
            # Test::Harness 3.0 self-tests, so that should be 'unless
            # installing Test::Harness'
            unless ($self->id eq $thm->distribution->id) {
                $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only
  '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n});
                $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old");
                $self->post_test();
                return;
            }
        }
    }

    if ( ! $self->{force_update}  ) {
        # bypass actual tests if "trust_test_report_history" and have a report
        my $have_tested_fcn;
        if (   $CPAN::Config->{trust_test_report_history}
            && $CPAN::META->has_inst("CPAN::Reporter::History")
            && ( $have_tested_fcn = CPAN::Reporter::History->can("have_tested" ))) {
            if ( my @reports = $have_tested_fcn->( dist => $self->base_id ) ) {
                # Do nothing if grade was DISCARD
                if ( $reports[-1]->{grade} =~ /^(?:PASS|UNKNOWN)$/ ) {
                    $self->{make_test} = CPAN::Distrostatus->new("YES");
                    # if global "is_tested" has been cleared, we need to mark this to
                    # be added to PERL5LIB if not already installed
                    if ($self->tested_ok_but_not_installed) {
                        $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
                    }
                    $CPAN::Frontend->myprint("Found prior test report -- OK\n");
                    $self->post_test();
                    return;
                }
                elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) {
                    $self->{make_test} = CPAN::Distrostatus->new("NO");
                    $self->{badtestcnt}++;
                    $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n");
                    $self->post_test();
                    return;
                }
            }
        }
    }

    my $system;
    my $prefs_test = $self->prefs->{test};
    if (my $commandline
        = exists $prefs_test->{commandline} ? $prefs_test->{commandline} : "") {
        $system = $commandline;
        $ENV{PERL} = CPAN::find_perl();
    } elsif ($self->{modulebuild}) {
        $system = sprintf "%s test", $self->_build_command();
        unless (-e "Build" || ($^O eq 'VMS' && -e "Build.com")) {
            my $id = $self->pretty_id;
            $CPAN::Frontend->mywarn("Alert: no 'Build' file found while trying to test '$id'");
        }
    } else {
        $system = join " ", $self->_make_command(), "test";
    }
    my $make_test_arg = $self->_make_phase_arg("test");
    $system = sprintf("%s%s",
                      $system,
                      $make_test_arg ? " $make_test_arg" : "",
                     );
    my($tests_ok);
    my $test_env;
    if ($self->prefs->{test}) {
        $test_env = $self->prefs->{test}{env};
    }
    local @ENV{keys %$test_env} = values %$test_env if $test_env;
    my $expect_model = $self->_prefs_with_expect("test");
    my $want_expect = 0;
    if ( $expect_model && @{$expect_model->{talk}} ) {
        my $can_expect = $CPAN::META->has_inst("Expect");
        if ($can_expect) {
            $want_expect = 1;
        } else {
            $CPAN::Frontend->mywarn("Expect not installed, falling back to ".
                                    "testing without\n");
        }
    }

 FORK: {
        my $pid = fork;
        if (! defined $pid) { # contention
            warn "Contention '$!', sleeping 2";
            sleep 2;
            redo FORK;
        } elsif ($pid) { # parent
            if ($^O eq "MSWin32") {
                wait;
            } else {
            SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) {
                    if ($CPAN::Signal) {
                        kill 9, -$pid;
                    }
                    sleep 1;
                }
            }
            $tests_ok = !$?;
        } else { # child
            POSIX::setsid() unless $^O eq "MSWin32";
            my $c_ok;
            $|=1;
            if ($want_expect) {
                if ($self->_should_report('test')) {
                    $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ".
                        "not supported when distroprefs specify ".
                        "an interactive test\n");
                }
                $c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0;
            } elsif ( $self->_should_report('test') ) {
                $c_ok = CPAN::Reporter::test($self, $system);
            } else {
                $c_ok = system($system) == 0;
            }
            exit !$c_ok;
        }
    } # FORK

    $self->introduce_myself;
    my $but = $self->_make_test_illuminate_prereqs();
    if ( $tests_ok ) {
        if ($but) {
            $CPAN::Frontend->mywarn("Tests succeeded but $but\n");
            $self->{make_test} = CPAN::Distrostatus->new("NO $but");
            $self->store_persistent_state;
            $self->post_test();
            return $self->goodbye("[dependencies] -- NA");
        }
        $CPAN::Frontend->myprint("  $system -- OK\n");
        $self->{make_test} = CPAN::Distrostatus->new("YES");
        $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME});
        # probably impossible to need the next line because badtestcnt
        # has a lifespan of one command
        delete $self->{badtestcnt};
    } else {
        if ($but) {
            $but .= "; additionally test harness failed";
            $CPAN::Frontend->mywarn("$but\n");
            $self->{make_test} = CPAN::Distrostatus->new("NO $but");
        } elsif ( $self->{force_update} ) {
            $self->{make_test} = CPAN::Distrostatus->new(
                "NO but failure ignored because 'force' in effect"
            );
        } elsif ($CPAN::Signal) {
            $self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted");
        } else {
            $self->{make_test} = CPAN::Distrostatus->new("NO");
        }
        $self->{badtestcnt}++;
        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
        CPAN::Shell->optprint
              ("hint",
               sprintf
               ("//hint// to see the cpan-testers results for installing this module, try:
  reports %s\n",
                $self->pretty_id));
    }
    $self->store_persistent_state;

    $self->post_test();

    return $self->{force_update} ? 1 : !! $tests_ok;
}

sub _make_test_illuminate_prereqs {
    my($self) = @_;
    my @prereq;

    # local $CPAN::DEBUG = 16; # Distribution
    for my $m (sort keys %{$self->{sponsored_mods}}) {
        next unless $self->{sponsored_mods}{$m} > 0;
        my $m_obj = CPAN::Shell->expand("Module",$m) or next;
        # XXX we need available_version which reflects
        # $ENV{PERL5LIB} so that already tested but not yet
        # installed modules are counted.
        my $available_version = $m_obj->available_version;
        my $available_file = $m_obj->available_file;
        if ($available_version &&
            !CPAN::Version->vlt($available_version,$self->{prereq_pm}{$m})
           ) {
            CPAN->debug("m[$m] good enough available_version[$available_version]")
                if $CPAN::DEBUG;
        } elsif ($available_file
                 && (
                     !$self->{prereq_pm}{$m}
                     ||
                     $self->{prereq_pm}{$m} == 0
                    )
                ) {
            # lex Class::Accessor::Chained::Fast which has no $VERSION
            CPAN->debug("m[$m] have available_file[$available_file]")
                if $CPAN::DEBUG;
        } else {
            push @prereq, $m
                unless $self->is_locally_optional(undef, $m);
        }
    }
    my $but;
    if (@prereq) {
        my $cnt = @prereq;
        my $which = join ",", @prereq;
        $but = $cnt == 1 ? "one dependency not OK ($which)" :
            "$cnt dependencies missing ($which)";
    }
    $but;
}

sub _prefs_with_expect {
    my($self,$where) = @_;
    return unless my $prefs = $self->prefs;
    return unless my $where_prefs = $prefs->{$where};
    if ($where_prefs->{expect}) {
        return {
                mode => "deterministic",
                timeout => 15,
                talk => $where_prefs->{expect},
               };
    } elsif ($where_prefs->{"eexpect"}) {
        return $where_prefs->{"eexpect"};
    }
    return;
}

#-> sub CPAN::Distribution::clean ;
sub clean {
    my($self) = @_;
    my $make = $self->{modulebuild} ? "Build" : "make";
    $CPAN::Frontend->myprint(sprintf "Running %s clean for %s\n", $make, $self->pretty_id);
    unless (exists $self->{archived}) {
        $CPAN::Frontend->mywarn("Distribution seems to have never been unzipped".
                                "/untarred, nothing done\n");
        return 1;
    }
    unless (exists $self->{build_dir}) {
        $CPAN::Frontend->mywarn("Distribution has no own directory, nothing to do.\n");
        return 1;
    }
    if (exists $self->{writemakefile}
        and $self->{writemakefile}->failed
       ) {
        $CPAN::Frontend->mywarn("No Makefile, don't know how to 'make clean'\n");
        return 1;
    }
  EXCUSE: {
        my @e;
        exists $self->{make_clean} and $self->{make_clean} eq "YES" and
            push @e, "make clean already called once";
        $CPAN::Frontend->myprint(join "", map {"  $_\n"} @e) and return if @e;
    }
    chdir "$self->{build_dir}" or
        Carp::confess("Couldn't chdir to $self->{build_dir}: $!");
    $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG;

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make_clean($self);
        return;
    }

    my $system;
    if ($self->{modulebuild}) {
        unless (-f "Build") {
            my $cwd = CPAN::anycwd();
            $CPAN::Frontend->mywarn("Alert: no Build file available for 'clean $self->{id}".
                                    " in cwd[$cwd]. Danger, Will Robinson!");
            $CPAN::Frontend->mysleep(5);
        }
        $system = sprintf "%s clean", $self->_build_command();
    } else {
        $system  = join " ", $self->_make_command(), "clean";
    }
    my $system_ok = system($system) == 0;
    $self->introduce_myself;
    if ( $system_ok ) {
      $CPAN::Frontend->myprint("  $system -- OK\n");

      # $self->force;

      # Jost Krieger pointed out that this "force" was wrong because
      # it has the effect that the next "install" on this distribution
      # will untar everything again. Instead we should bring the
      # object's state back to where it is after untarring.

      for my $k (qw(
                    force_update
                    install
                    writemakefile
                    make
                    make_test
                   )) {
          delete $self->{$k};
      }
      $self->{make_clean} = CPAN::Distrostatus->new("YES");

    } else {
      # Hmmm, what to do if make clean failed?

      $self->{make_clean} = CPAN::Distrostatus->new("NO");
      $CPAN::Frontend->mywarn(qq{  $system -- NOT OK\n});

      # 2006-02-27: seems silly to me to force a make now
      # $self->force("make"); # so that this directory won't be used again

    }
    $self->store_persistent_state;
}

#-> sub CPAN::Distribution::check_disabled ;
sub check_disabled {
    my ($self) = @_;
    $self->debug("checking disabled id[$self->{ID}]") if $CPAN::DEBUG;
    if ($self->prefs->{disabled} && ! $self->{force_update}) {
        return sprintf(
                            "Disabled via prefs file '%s' doc %d",
                            $self->{prefs_file},
                            $self->{prefs_file_doc},
                            );
    }
    return;
}

#-> sub CPAN::Distribution::goto ;
sub goto {
    my($self,$goto) = @_;
    $goto = $self->normalize($goto);
    my $why = sprintf(
                      "Goto '$goto' via prefs file '%s' doc %d",
                      $self->{prefs_file},
                      $self->{prefs_file_doc},
                     );
    $self->{unwrapped} = CPAN::Distrostatus->new("NO $why");
    # 2007-07-16 akoenig : Better than NA would be if we could inherit
    # the status of the $goto distro but given the exceptional nature
    # of 'goto' I feel reluctant to implement it
    my $goodbye_message = "[goto] -- NA $why";
    $self->goodbye($goodbye_message);

    # inject into the queue

    CPAN::Queue->delete($self->id);
    CPAN::Queue->jumpqueue({qmod => $goto, reqtype => $self->{reqtype}});

    # and run where we left off

    my($method) = (caller(1))[3];
    my $goto_do = CPAN->instance("CPAN::Distribution",$goto);
    $goto_do->called_for($self->called_for) unless $goto_do->called_for;
    $goto_do->{mandatory} ||= $self->{mandatory};
    $goto_do->{reqtype}   ||= $self->{reqtype};
    $goto_do->{coming_from} = $self->pretty_id;
    $goto_do->$method();
    CPAN::Queue->delete_first($goto);
    # XXX delete_first returns undef; is that what this should return
    # up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04
}

#-> sub CPAN::Distribution::shortcut_install ;
# return values: undef means don't shortcut; 0 means shortcut as fail;
# and 1 means shortcut as success
sub shortcut_install {
    my ($self) = @_;

    $self->debug("checking previous install results[$self->{ID}]") if $CPAN::DEBUG;
    if (exists $self->{install}) {
        my $text = UNIVERSAL::can($self->{install},"text") ?
            $self->{install}->text :
                $self->{install};
        if ($text =~ /^YES/) {
            $CPAN::META->is_installed($self->{build_dir});
            return $self->success("Already done");
        } elsif ($text =~ /is only/) {
            # e.g. 'is only build_requires': may be overruled later
            return $self->goodbye($text);
        } else {
            # comment in Todo on 2006-02-11; maybe retry?
            return $self->goodbye("Already tried without success");
        }
    }

    for my $slot ( qw/later configure_requires_later/ ) {
        return $self->success($self->{$slot})
        if $self->{$slot};
    }

    return undef;
}

#-> sub CPAN::Distribution::is_being_sponsored ;

# returns true if we find a distro object in the queue that has
# sponsored this one
sub is_being_sponsored {
    my($self) = @_;
    my $iterator = CPAN::Queue->iterator;
 QITEM: while (my $q = $iterator->()) {
        my $s = $q->as_string;
        my $obj = CPAN::Shell->expandany($s) or next QITEM;
        my $type = ref $obj;
        if ( $type eq 'CPAN::Distribution' ){
            for my $module (sort keys %{$obj->{sponsored_mods} || {}}) {
                return 1 if grep { $_ eq $module } $self->containsmods;
            }
        }
    }
    return 0;
}

#-> sub CPAN::Distribution::install ;
sub install {
    my($self) = @_;

    $self->pre_install();

    if (exists $self->{cleanup_after_install_done}) {
        return $self->test;
    }

    $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG;
    if (my $goto = $self->prefs->{goto}) {
        $self->goto($goto);
        $self->post_install();
        return;
    }

    unless ($self->test) {
        $self->post_install();
        return;
    }

    if ( defined( my $sc = $self->shortcut_install ) ) {
        $self->post_install();
        return $sc;
    }

    if ($CPAN::Signal) {
        delete $self->{force_update};
        $self->post_install();
        return;
    }

    my $builddir = $self->dir or
        $CPAN::Frontend->mydie("PANIC: Cannot determine build directory\n");

    unless (chdir $builddir) {
        $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!");
        $self->post_install();
        return;
    }

    $self->debug("Changed directory to $self->{build_dir}")
        if $CPAN::DEBUG;

    my $make = $self->{modulebuild} ? "Build" : "make";
    $CPAN::Frontend->myprint(sprintf "Running %s install for %s\n", $make, $self->pretty_id);

    if ($^O eq 'MacOS') {
        Mac::BuildTools::make_install($self);
        $self->post_install();
        return;
    }

    my $system;
    if (my $commandline = $self->prefs->{install}{commandline}) {
        $system = $commandline;
        $ENV{PERL} = CPAN::find_perl();
    } elsif ($self->{modulebuild}) {
        my($mbuild_install_build_command) =
            exists $CPAN::HandleConfig::keys{mbuild_install_build_command} &&
                $CPAN::Config->{mbuild_install_build_command} ?
                    $CPAN::Config->{mbuild_install_build_command} :
                        $self->_build_command();
        my $install_directive = $^O eq 'VMS' ? '"install"' : 'install';
        $system = sprintf("%s %s %s",
                          $mbuild_install_build_command,
                          $install_directive,
                          $CPAN::Config->{mbuild_install_arg},
                         );
    } else {
        my($make_install_make_command) = $self->_make_install_make_command();
        $system = sprintf("%s install %s",
                          $make_install_make_command,
                          $CPAN::Config->{make_install_arg},
                         );
    }

    my($stderr) = $^O eq "MSWin32" || $^O eq 'VMS' ? "" : " 2>&1 ";
    my $brip = CPAN::HandleConfig->prefs_lookup($self,
                                                q{build_requires_install_policy});
    $brip ||="ask/yes";
    my $id = $self->id;
    my $reqtype = $self->{reqtype} ||= "c"; # in doubt it was a command
    my $want_install = "yes";
    if ($reqtype eq "b") {
        if ($brip eq "no") {
            $want_install = "no";
        } elsif ($brip =~ m|^ask/(.+)|) {
            my $default = $1;
            $default = "yes" unless $default =~ /^(y|n)/i;
            $want_install =
                CPAN::Shell::colorable_makemaker_prompt
                      ("$id is just needed temporarily during building or testing. ".
                       "Do you want to install it permanently?",
                       $default);
        }
    }
    unless ($want_install =~ /^y/i) {
        my $is_only = "is only 'build_requires'";
        $self->{install} = CPAN::Distrostatus->new("NO -- $is_only");
        delete $self->{force_update};
        $self->goodbye("Not installing because $is_only");
        $self->post_install();
        return;
    }
    local $ENV{PERL5LIB} = defined($ENV{PERL5LIB})
                           ? $ENV{PERL5LIB}
                           : ($ENV{PERLLIB} || "");

    local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : "";
    local $ENV{PERL_USE_UNSAFE_INC} =
        exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC}
        ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install
    $CPAN::META->set_perl5lib;
    local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default};
    local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default};

    my $install_env;
    if ($self->prefs->{install}) {
        $install_env = $self->prefs->{install}{env};
    }
    local @ENV{keys %$install_env} = values %$install_env if $install_env;

    if (! $run_allow_installing_within_test) {
        my($allow_installing, $why) = $self->_allow_installing;
        if (! $allow_installing) {
            $CPAN::Frontend->mywarn("Installation stopped: $why\n");
            $self->introduce_myself;
            $self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why");
            $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
            delete $self->{force_update};
            $self->post_install();
            return;
        }
    }
    my($pipe) = FileHandle->new("$system $stderr |");
    unless ($pipe) {
        $CPAN::Frontend->mywarn("Can't execute $system: $!");
        $self->introduce_myself;
        $self->{install} = CPAN::Distrostatus->new("NO");
        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
        delete $self->{force_update};
        $self->post_install();
        return;
    }
    my($makeout) = "";
    while (<$pipe>) {
        print $_; # intentionally NOT use Frontend->myprint because it
                  # looks irritating when we markup in color what we
                  # just pass through from an external program
        $makeout .= $_;
    }
    $pipe->close;
    my $close_ok = $? == 0;
    $self->introduce_myself;
    if ( $close_ok ) {
        $CPAN::Frontend->myprint("  $system -- OK\n");
        $CPAN::META->is_installed($self->{build_dir});
        $self->{install} = CPAN::Distrostatus->new("YES");
        if ($CPAN::Config->{'cleanup_after_install'}
            && ! $self->is_dot_dist
            && ! $self->is_being_sponsored) {
            my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir );
            chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n");
            File::Path::rmtree($self->{build_dir});
            my $yml = "$self->{build_dir}.yml";
            if (-e $yml) {
                unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n");
            }
            $self->{cleanup_after_install_done}=1;
        }
    } else {
        $self->{install} = CPAN::Distrostatus->new("NO");
        $CPAN::Frontend->mywarn("  $system -- NOT OK\n");
        my $mimc =
            CPAN::HandleConfig->prefs_lookup($self,
                                             q{make_install_make_command});
        if (
            $makeout =~ /permission/s
            && $> > 0
            && (
                ! $mimc
                || $mimc eq (CPAN::HandleConfig->prefs_lookup($self,
                                                              q{make}))
               )
           ) {
            $CPAN::Frontend->myprint(
                                     qq{----\n}.
                                     qq{  You may have to su }.
                                     qq{to root to install the package\n}.
                                     qq{  (Or you may want to run something like\n}.
                                     qq{    o conf make_install_make_command 'sudo make'\n}.
                                     qq{  to raise your permissions.}
                                    );
        }
    }
    delete $self->{force_update};
    unless ($CPAN::Config->{'cleanup_after_install'}) {
        $self->store_persistent_state;
    }

    $self->post_install();

    return !! $close_ok;
}

sub blib_pm_walk {
    my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch");
    return sub {
    LOOP: {
            if (@queue) {
                my $file = shift @queue;
                if (-d $file) {
                    my $dh;
                    opendir $dh, $file or next;
                    my @newfiles = map {
                        my @ret;
                        my $maybedir = File::Spec->catdir($file, $_);
                        if (-d $maybedir) {
                            unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) {
                                # prune the blib/arch/auto directory, no pm files there
                                @ret = $maybedir;
                            }
                        } elsif (/\.pm$/) {
                            my $mustbefile = File::Spec->catfile($file, $_);
                            if (-f $mustbefile) {
                                @ret = $mustbefile;
                            }
                        }
                        @ret;
                    } grep {
                        $_ ne "."
                            && $_ ne ".."
                        } readdir $dh;
                    push @queue, @newfiles;
                    redo LOOP;
                } else {
                    return $file;
                }
            } else {
                return;
            }
        }
    };
}

sub _allow_installing {
    my($self) = @_;
    my $id = my $pretty_id = $self->pretty_id;
    if ($self->{CALLED_FOR}) {
        $id .= " (called for $self->{CALLED_FOR})";
    }
    my $allow_down   = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades});
    $allow_down      ||= "ask/yes";
    my $allow_outdd  = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists});
    $allow_outdd     ||= "ask/yes";
    return 1 if
           $allow_down  eq "yes"
        && $allow_outdd eq "yes";
    if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) {
        return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods;
        if ($allow_outdd ne "yes") {
            $CPAN::Frontend->mywarn("The current configuration of allow_installing_outdated_dists is '$allow_outdd', but for this option we would need 'CPAN::DistnameInfo' installed. Please install 'CPAN::DistnameInfo' as soon as possible. As long as we are not equipped with 'CPAN::DistnameInfo' this option does not take effect\n");
            $allow_outdd = "yes";
        }
    }
    return 1 if
           $allow_down  eq "yes"
        && $allow_outdd eq "yes";
    my($dist_version, $dist_dist);
    if ($allow_outdd ne "yes"){
        my $dni = CPAN::DistnameInfo->new($pretty_id);
        $dist_version = $dni->version;
        $dist_dist    = $dni->dist;
    }
    my $iterator = blib_pm_walk();
    my(@down,@outdd);
    while (my $file = $iterator->()) {
        my $version = CPAN::Module->parse_version($file);
        my($volume, $directories, $pmfile) = File::Spec->splitpath( $file );
        my @dirs = File::Spec->splitdir( $directories );
        my(@blib_plus1) = splice @dirs, 0, 2;
        my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile);
        unless ($allow_down eq "yes") {
            if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) {
                my $inst_version = CPAN::Module->parse_version($inst_file);
                my $cmp = CPAN::Version->vcmp($version, $inst_version);
                if ($cmp) {
                    if ($cmp < 0) {
                        push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version };
                    }
                }
                if (@down) {
                    my $why = "allow_installing_module_downgrades: $id contains downgrading module(s) (e.g. '$down[0]{pmpath}' would downgrade installed '$down[0]{inst_version}' to '$down[0]{version}')";
                    if (my($default) = $allow_down =~ m|^ask/(.+)|) {
                        $default = "yes" unless $default =~ /^(y|n)/i;
                        my $answer = CPAN::Shell::colorable_makemaker_prompt
                                ("$why. Do you want to allow installing it?",
                                 $default, "colorize_warn");
                        $allow_down = $answer =~ /^\s*y/i ? "yes" : "no";
                    }
                    if ($allow_down eq "no") {
                        return (0, $why);
                    }
                }
            }
        }
        unless ($allow_outdd eq "yes") {
            my @pmpath = (@dirs, $pmfile);
            $pmpath[-1] =~ s/\.pm$//;
            my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath);
            if ($mo) {
                my $cpan_version = $mo->cpan_version;
                my $is_lower = CPAN::Version->vlt($version, $cpan_version);
                my $other_dist;
                if (my $mo_dist = $mo->distribution) {
                    $other_dist = $mo_dist->pretty_id;
                    my $dni = CPAN::DistnameInfo->new($other_dist);
                    if ($dni->dist eq $dist_dist){
                        if (CPAN::Version->vgt($dni->version, $dist_version)) {
                            push @outdd, {
                                pmpath       => $pmpath,
                                cpan_path    => $dni->pathname,
                                dist_version => $dni->version,
                                dist_dist    => $dni->dist,
                            };
                        }
                    }
                }
            }
            if (@outdd && $allow_outdd ne "yes") {
                my $why = "allow_installing_outdated_dists: $id contains module(s) that are indexed on the CPAN with a different distro: (e.g. '$outdd[0]{pmpath}' is indexed with '$outdd[0]{cpan_path}')";
                if ($outdd[0]{dist_dist} eq $dist_dist) {
                    $why .= ", and this has a higher distribution-version, i.e. version '$outdd[0]{dist_version}' is higher than '$dist_version')";
                }
                if (my($default) = $allow_outdd =~ m|^ask/(.+)|) {
                    $default = "yes" unless $default =~ /^(y|n)/i;
                    my $answer = CPAN::Shell::colorable_makemaker_prompt
                        ("$why. Do you want to allow installing it?",
                         $default, "colorize_warn");
                    $allow_outdd = $answer =~ /^\s*y/i ? "yes" : "no";
                }
                if ($allow_outdd eq "no") {
                    return (0, $why);
                }
            }
        }
    }
    return 1;
}

sub _file_in_path { # similar to CPAN::Module::_file_in_path
    my($self,$pmpath,$incpath) = @_;
    my($dir,@packpath);
    foreach $dir (@$incpath) {
        my $pmfile = File::Spec->catfile($dir,$pmpath);
        if (-f $pmfile) {
            return $pmfile;
        }
    }
    return;
}
sub introduce_myself {
    my($self) = @_;
    $CPAN::Frontend->myprint(sprintf("  %s\n",$self->pretty_id));
}

#-> sub CPAN::Distribution::dir ;
sub dir {
    shift->{build_dir};
}

#-> sub CPAN::Distribution::perldoc ;
sub perldoc {
    my($self) = @_;

    my($dist) = $self->id;
    my $package = $self->called_for;

    if ($CPAN::META->has_inst("Pod::Perldocs")) {
        my($perl) = $self->perl
            or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
        my @args = ($perl, q{-MPod::Perldocs}, q{-e},
                    q{Pod::Perldocs->run()}, $package);
        my($wstatus);
        unless ( ($wstatus = system(@args)) == 0 ) {
            my $estatus = $wstatus >> 8;
            $CPAN::Frontend->myprint(qq{
    Function system("@args")
    returned status $estatus (wstat $wstatus)
    });
        }
    }
    else {
        $self->_display_url( $CPAN::Defaultdocs . $package );
    }
}

#-> sub CPAN::Distribution::_check_binary ;
sub _check_binary {
    my ($dist,$shell,$binary) = @_;
    my ($pid,$out);

    $CPAN::Frontend->myprint(qq{ + _check_binary($binary)\n})
      if $CPAN::DEBUG;

    if ($CPAN::META->has_inst("File::Which")) {
        return File::Which::which($binary);
    } else {
        local *README;
        $pid = open README, "which $binary|"
            or $CPAN::Frontend->mywarn(qq{Could not fork 'which $binary': $!\n});
        return unless $pid;
        while (<README>) {
            $out .= $_;
        }
        close README
            or $CPAN::Frontend->mywarn("Could not run 'which $binary': $!\n")
                and return;
    }

    $CPAN::Frontend->myprint(qq{   + $out \n})
      if $CPAN::DEBUG && $out;

    return $out;
}

#-> sub CPAN::Distribution::_display_url ;
sub _display_url {
    my($self,$url) = @_;
    my($res,$saved_file,$pid,$out);

    $CPAN::Frontend->myprint(qq{ + _display_url($url)\n})
      if $CPAN::DEBUG;

    # should we define it in the config instead?
    my $html_converter = "html2text.pl";

    my $web_browser = $CPAN::Config->{'lynx'} || undef;
    my $web_browser_out = $web_browser
        ? CPAN::Distribution->_check_binary($self,$web_browser)
        : undef;

    if ($web_browser_out) {
        # web browser found, run the action
        my $browser = CPAN::HandleConfig->safe_quote($CPAN::Config->{'lynx'});
        $CPAN::Frontend->myprint(qq{system[$browser $url]})
            if $CPAN::DEBUG;
        $CPAN::Frontend->myprint(qq{
Displaying URL
  $url
with browser $browser
});
        $CPAN::Frontend->mysleep(1);
        system("$browser $url");
        if ($saved_file) { 1 while unlink($saved_file) }
    } else {
        # web browser not found, let's try text only
        my $html_converter_out =
            CPAN::Distribution->_check_binary($self,$html_converter);
        $html_converter_out = CPAN::HandleConfig->safe_quote($html_converter_out);

        if ($html_converter_out ) {
            # html2text found, run it
            $saved_file = CPAN::Distribution->_getsave_url( $self, $url );
            $CPAN::Frontend->mydie(qq{ERROR: problems while getting $url\n})
                unless defined($saved_file);

            local *README;
            $pid = open README, "$html_converter $saved_file |"
                or $CPAN::Frontend->mydie(qq{
Could not fork '$html_converter $saved_file': $!});
            my($fh,$filename);
            if ($CPAN::META->has_usable("File::Temp")) {
                $fh = File::Temp->new(
                                      dir      => File::Spec->tmpdir,
                                      template => 'cpan_htmlconvert_XXXX',
                                      suffix => '.txt',
                                      unlink => 0,
                                     );
                $filename = $fh->filename;
            } else {
                $filename = "cpan_htmlconvert_$$.txt";
                $fh = FileHandle->new();
                open $fh, ">$filename" or die;
            }
            while (<README>) {
                $fh->print($_);
            }
            close README or
                $CPAN::Frontend->mydie(qq{Could not run '$html_converter $saved_file': $!});
            my $tmpin = $fh->filename;
            $CPAN::Frontend->myprint(sprintf(qq{
Run '%s %s' and
saved output to %s\n},
                                             $html_converter,
                                             $saved_file,
                                             $tmpin,
                                            )) if $CPAN::DEBUG;
            close $fh;
            local *FH;
            open FH, $tmpin
                or $CPAN::Frontend->mydie(qq{Could not open "$tmpin": $!});
            my $fh_pager = FileHandle->new;
            local($SIG{PIPE}) = "IGNORE";
            my $pager = $CPAN::Config->{'pager'} || "cat";
            $fh_pager->open("|$pager")
                or $CPAN::Frontend->mydie(qq{
Could not open pager '$pager': $!});
            $CPAN::Frontend->myprint(qq{
Displaying URL
  $url
with pager "$pager"
});
            $CPAN::Frontend->mysleep(1);
            $fh_pager->print(<FH>);
            $fh_pager->close;
        } else {
            # coldn't find the web browser or html converter
            $CPAN::Frontend->myprint(qq{
You need to install lynx or $html_converter to use this feature.});
        }
    }
}

#-> sub CPAN::Distribution::_getsave_url ;
sub _getsave_url {
    my($dist, $shell, $url) = @_;

    $CPAN::Frontend->myprint(qq{ + _getsave_url($url)\n})
      if $CPAN::DEBUG;

    my($fh,$filename);
    if ($CPAN::META->has_usable("File::Temp")) {
        $fh = File::Temp->new(
                              dir      => File::Spec->tmpdir,
                              template => "cpan_getsave_url_XXXX",
                              suffix => ".html",
                              unlink => 0,
                             );
        $filename = $fh->filename;
    } else {
        $fh = FileHandle->new;
        $filename = "cpan_getsave_url_$$.html";
    }
    my $tmpin = $filename;
    if ($CPAN::META->has_usable('LWP')) {
        $CPAN::Frontend->myprint("Fetching with LWP:
  $url
");
        my $Ua;
        CPAN::LWP::UserAgent->config;
        eval { $Ua = CPAN::LWP::UserAgent->new; };
        if ($@) {
            $CPAN::Frontend->mywarn("ERROR: CPAN::LWP::UserAgent->new dies with $@\n");
            return;
        } else {
            my($var);
            $Ua->proxy('http', $var)
                if $var = $CPAN::Config->{http_proxy} || $ENV{http_proxy};
            $Ua->no_proxy($var)
                if $var = $CPAN::Config->{no_proxy} || $ENV{no_proxy};
        }

        my $req = HTTP::Request->new(GET => $url);
        $req->header('Accept' => 'text/html');
        my $res = $Ua->request($req);
        if ($res->is_success) {
            $CPAN::Frontend->myprint(" + request successful.\n")
                if $CPAN::DEBUG;
            print $fh $res->content;
            close $fh;
            $CPAN::Frontend->myprint(qq{ + saved content to $tmpin \n})
                if $CPAN::DEBUG;
            return $tmpin;
        } else {
            $CPAN::Frontend->myprint(sprintf(
                                             "LWP failed with code[%s], message[%s]\n",
                                             $res->code,
                                             $res->message,
                                            ));
            return;
        }
    } else {
        $CPAN::Frontend->mywarn("  LWP not available\n");
        return;
    }
}

#-> sub CPAN::Distribution::_build_command
sub _build_command {
    my($self) = @_;
    if ($^O eq "MSWin32") { # special code needed at least up to
                            # Module::Build 0.2611 and 0.2706; a fix
                            # in M:B has been promised 2006-01-30
        my($perl) = $self->perl or $CPAN::Frontend->mydie("Couldn't find executable perl\n");
        return "$perl ./Build";
    }
    elsif ($^O eq 'VMS') {
        return "$^X Build.com";
    }
    return "./Build";
}

#-> sub CPAN::Distribution::_should_report
sub _should_report {
    my($self, $phase) = @_;
    die "_should_report() requires a 'phase' argument"
        if ! defined $phase;

    return unless $CPAN::META->has_usable("CPAN::Reporter");

    # configured
    my $test_report = CPAN::HandleConfig->prefs_lookup($self,
                                                       q{test_report});
    return unless $test_report;

    # don't repeat if we cached a result
    return $self->{should_report}
        if exists $self->{should_report};

    # don't report if we generated a Makefile.PL
    if ( $self->{had_no_makefile_pl} ) {
        $CPAN::Frontend->mywarn(
            "Will not send CPAN Testers report with generated Makefile.PL.\n"
        );
        return $self->{should_report} = 0;
    }

    # available
    if ( ! $CPAN::META->has_inst("CPAN::Reporter")) {
        $CPAN::Frontend->mywarnonce(
            "CPAN::Reporter not installed.  No reports will be sent.\n"
        );
        return $self->{should_report} = 0;
    }

    # capable
    my $crv = CPAN::Reporter->VERSION;
    if ( CPAN::Version->vlt( $crv, 0.99 ) ) {
        # don't cache $self->{should_report} -- need to check each phase
        if ( $phase eq 'test' ) {
            return 1;
        }
        else {
            $CPAN::Frontend->mywarn(
                "Reporting on the '$phase' phase requires CPAN::Reporter 0.99, but \n" .
                "you only have version $crv\.  Only 'test' phase reports will be sent.\n"
            );
            return;
        }
    }

    # appropriate
    if ($self->is_dot_dist) {
        $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
                                "for local directories\n");
        return $self->{should_report} = 0;
    }
    if ($self->prefs->{patches}
        &&
        @{$self->prefs->{patches}}
        &&
        $self->{patched}
       ) {
        $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is disabled ".
                                "when the source has been patched\n");
        return $self->{should_report} = 0;
    }

    # proceed and cache success
    return $self->{should_report} = 1;
}

#-> sub CPAN::Distribution::reports
sub reports {
    my($self) = @_;
    my $pathname = $self->id;
    $CPAN::Frontend->myprint("Distribution: $pathname\n");

    unless ($CPAN::META->has_inst("CPAN::DistnameInfo")) {
        $CPAN::Frontend->mydie("CPAN::DistnameInfo not installed; cannot continue");
    }
    unless ($CPAN::META->has_usable("LWP")) {
        $CPAN::Frontend->mydie("LWP not installed; cannot continue");
    }
    unless ($CPAN::META->has_usable("File::Temp")) {
        $CPAN::Frontend->mydie("File::Temp not installed; cannot continue");
    }

    my $format;
    if ($CPAN::META->has_inst("YAML::XS") || $CPAN::META->has_inst("YAML::Syck")){
        $format = 'yaml';
    }
    elsif (!$format && $CPAN::META->has_inst("JSON::PP") ) {
        $format = 'json';
    }
    else {
        $CPAN::Frontend->mydie("JSON::PP not installed, cannot continue");
    }

    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 $url = sprintf "http://www.cpantesters.org/show/%s.%s", $dist, $format;

    CPAN::LWP::UserAgent->config;
    my $Ua;
    eval { $Ua = CPAN::LWP::UserAgent->new; };
    if ($@) {
        $CPAN::Frontend->mydie("CPAN::LWP::UserAgent->new dies with $@\n");
    }
    $CPAN::Frontend->myprint("Fetching '$url'...");
    my $resp = $Ua->get($url);
    unless ($resp->is_success) {
        $CPAN::Frontend->mydie(sprintf "Could not download '%s': %s\n", $url, $resp->code);
    }
    $CPAN::Frontend->myprint("DONE\n\n");
    my $unserialized;
    if ( $format eq 'yaml' ) {
        my $yaml = $resp->content;
        # what a long way round!
        my $fh = File::Temp->new(
                                 dir      => File::Spec->tmpdir,
                                 template => 'cpan_reports_XXXX',
                                 suffix => '.yaml',
                                 unlink => 0,
                                );
        my $tfilename = $fh->filename;
        print $fh $yaml;
        close $fh or $CPAN::Frontend->mydie("Could not close '$tfilename': $!");
        $unserialized = CPAN->_yaml_loadfile($tfilename)->[0];
        unlink $tfilename or $CPAN::Frontend->mydie("Could not unlink '$tfilename': $!");
    } else {
        require JSON::PP;
        $unserialized = JSON::PP->new->utf8->decode($resp->content);
    }
    my %other_versions;
    my $this_version_seen;
    for my $rep (@$unserialized) {
        my $rversion = $rep->{version};
        if ($rversion eq $version) {
            unless ($this_version_seen++) {
                $CPAN::Frontend->myprint ("$rep->{version}:\n");
            }
            my $arch = $rep->{archname} || $rep->{platform}        || '????';
            my $grade = $rep->{action}  || $rep->{status}          || '????';
            my $ostext = $rep->{ostext} || ucfirst($rep->{osname}) || '????';
            $CPAN::Frontend->myprint
                (sprintf("%1s%1s%-4s %s on %s %s (%s)\n",
                         $arch eq $Config::Config{archname}?"*":"",
                         $grade eq "PASS"?"+":$grade eq"FAIL"?"-":"",
                         $grade,
                         $rep->{perl},
                         $ostext,
                         $rep->{osvers},
                         $arch,
                        ));
        } else {
            $other_versions{$rep->{version}}++;
        }
    }
    unless ($this_version_seen) {
        $CPAN::Frontend->myprint("No reports found for version '$version'
Reports for other versions:\n");
        for my $v (sort keys %other_versions) {
            $CPAN::Frontend->myprint(" $v\: $other_versions{$v}\n");
        }
    }
    $url = substr($url,0,-4) . 'html';
    $CPAN::Frontend->myprint("See $url for details\n");
}

1;
PK     ü2]zþªÇ6  6    Debug.pmnu ÏÃ6Ç$        # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN::Debug;
use strict;
use vars qw($VERSION);

$VERSION = "5.5001";
# module is internal to CPAN.pm

%CPAN::DEBUG = qw[
                  CPAN              1
                  Index             2
                  InfoObj           4
                  Author            8
                  Distribution     16
                  Bundle           32
                  Module           64
                  CacheMgr        128
                  Complete        256
                  FTP             512
                  Shell          1024
                  Eval           2048
                  HandleConfig   4096
                  Tarzip         8192
                  Version       16384
                  Queue         32768
                  FirstTime     65536
];

$CPAN::DEBUG ||= 0;

#-> sub CPAN::Debug::debug ;
sub debug {
    my($self,$arg) = @_;

    my @caller;
    my $i = 0;
    while () {
        my(@c) = (caller($i))[0 .. ($i ? 3 : 2)];
        last unless defined $c[0];
        push @caller, \@c;
        for (0,3) {
            last if $_ > $#c;
            $c[$_] =~ s/.*:://;
        }
        for (1) {
            $c[$_] =~ s|.*/||;
        }
        last if ++$i>=3;
    }
    pop @caller;
    if ($CPAN::DEBUG{$caller[0][0]} & $CPAN::DEBUG) {
        if ($arg and ref $arg) {
            eval { require Data::Dumper };
            if ($@) {
                $CPAN::Frontend->myprint("Debug(\n" . $arg->as_string . ")\n");
            } else {
                $CPAN::Frontend->myprint("Debug(\n" . Data::Dumper::Dumper($arg) . ")\n");
            }
        } else {
            my $outer = "";
            local $" = ",";
            if (@caller>1) {
                $outer = ",[@{$caller[1]}]";
            }
            $CPAN::Frontend->myprint("Debug(@{$caller[0]}$outer): $arg\n");
        }
    }
}

1;

__END__

=head1 NAME

CPAN::Debug - internal debugging for CPAN.pm

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
PK     ›"2]< $l:M  :M    Meta/Requirements/Range.pmnu ÏÃ6Ç$        use v5.10;
use strict;
use warnings;
package CPAN::Meta::Requirements::Range;
# ABSTRACT: a set of version requirements for a CPAN dist

our $VERSION = '2.143';

use Carp ();

#pod =head1 SYNOPSIS
#pod
#pod   use CPAN::Meta::Requirements::Range;
#pod
#pod   my $range = CPAN::Meta::Requirements::Range->with_minimum(1);
#pod
#pod   $range = $range->with_maximum('v2.2');
#pod
#pod   my $stringified = $range->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod A CPAN::Meta::Requirements::Range object models a set of version constraints like
#pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
#pod and as defined by L<CPAN::Meta::Spec>;
#pod It can be built up by adding more and more constraints, and it will reduce them
#pod to the simplest representation.
#pod
#pod Logically impossible constraints will be identified immediately by thrown
#pod exceptions.
#pod
#pod =cut

use Carp ();

package
  CPAN::Meta::Requirements::Range::_Base;

# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available.  This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.

BEGIN {
  eval "use version ()"; ## no critic
  if ( my $err = $@ ) {
    eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
  }
}

# from version::vpp
sub _find_magic_vstring {
  my $value = shift;
  my $tvalue = '';
  require B;
  my $sv = B::svref_2object(\$value);
  my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
  while ( $magic ) {
    if ( $magic->TYPE eq 'V' ) {
      $tvalue = $magic->PTR;
      $tvalue =~ s/^v?(.+)$/v$1/;
      last;
    }
    else {
      $magic = $magic->MOREMAGIC;
    }
  }
  return $tvalue;
}

# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };

# construct once, reuse many times
my $V0 = version->new(0);

# safe if given an unblessed reference
sub _isa_version {
  UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version')
}

sub _version_object {
  my ($self, $version, $module, $bad_version_hook) = @_;

  my ($vobj, $err);

  if (not defined $version or (!ref($version) && $version eq '0')) {
    return $V0;
  }
  elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) {
    $vobj = $version;
  }
  else {
    # hack around version::vpp not handling <3 character vstring literals
    if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) {
      my $magic = _find_magic_vstring( $version );
      $version = $magic if length $magic;
    }
    # pad to 3 characters if before 5.8.1 and appears to be a v-string
    if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) {
      $version .= "\0" x (3 - length($version));
    }
    eval {
      local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" };
      # avoid specific segfault on some older version.pm versions
      die "Invalid version: $version" if $version eq 'version';
      $vobj = version->new($version);
    };
    if ( my $err = $@ ) {
      $vobj = eval { $bad_version_hook->($version, $module) }
        if ref $bad_version_hook eq 'CODE';
      unless (eval { $vobj->isa("version") }) {
        $err =~ s{ at .* line \d+.*$}{};
        die "Can't convert '$version': $err";
      }
    }
  }

  # ensure no leading '.'
  if ( $vobj =~ m{\A\.} ) {
    $vobj = version->new("0$vobj");
  }

  # ensure normal v-string form
  if ( _is_qv($vobj) ) {
    $vobj = version->new($vobj->normal);
  }

  return $vobj;
}

#pod =method with_string_requirement
#pod
#pod   $req->with_string_requirement('>= 1.208, <= 2.206');
#pod   $req->with_string_requirement(v1.208);
#pod
#pod This method parses the passed in string and adds the appropriate requirement.
#pod A version can be a Perl "v-string".  It understands version ranges as described
#pod in the L<CPAN::Meta::Spec/Version Ranges>. For example:
#pod
#pod =over 4
#pod
#pod =item 1.3
#pod
#pod =item >= 1.3
#pod
#pod =item <= 1.3
#pod
#pod =item == 1.3
#pod
#pod =item != 1.3
#pod
#pod =item > 1.3
#pod
#pod =item < 1.3
#pod
#pod =item >= 1.3, != 1.5, <= 2.0
#pod
#pod A version number without an operator is equivalent to specifying a minimum
#pod (C<E<gt>=>).  Extra whitespace is allowed.
#pod
#pod =back
#pod
#pod =cut

my %methods_for_op = (
  '==' => [ qw(with_exact_version) ],
  '!=' => [ qw(with_exclusion) ],
  '>=' => [ qw(with_minimum)   ],
  '<=' => [ qw(with_maximum)   ],
  '>'  => [ qw(with_minimum with_exclusion) ],
  '<'  => [ qw(with_maximum with_exclusion) ],
);

sub with_string_requirement {
  my ($self, $req, $module, $bad_version_hook) = @_;
  $module //= 'module';

  unless ( defined $req && length $req ) {
    $req = 0;
    Carp::carp("Undefined requirement for $module treated as '0'");
  }

  my $magic = _find_magic_vstring( $req );
  if (length $magic) {
    return $self->with_minimum($magic, $module, $bad_version_hook);
  }

  my @parts = split qr{\s*,\s*}, $req;

  for my $part (@parts) {
    my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};

    if (! defined $op) {
      $self = $self->with_minimum($part, $module, $bad_version_hook);
    } else {
      Carp::croak("illegal requirement string: $req")
        unless my $methods = $methods_for_op{ $op };

      $self = $self->$_($ver, $module, $bad_version_hook) for @$methods;
    }
  }

  return $self;
}

#pod =method with_range
#pod
#pod  $range->with_range($other_range)
#pod
#pod This creates a new range object that is a merge two others.
#pod
#pod =cut

sub with_range {
  my ($self, $other, $module, $bad_version_hook) = @_;
  for my $modifier($other->_as_modifiers) {
    my ($method, $arg) = @$modifier;
    $self = $self->$method($arg, $module, $bad_version_hook);
  }
  return $self;
}

package CPAN::Meta::Requirements::Range;

our @ISA = 'CPAN::Meta::Requirements::Range::_Base';

sub _clone {
  return (bless { } => $_[0]) unless ref $_[0];

  my ($s) = @_;
  my %guts = (
    (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
    (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),

    (exists $s->{exclusions}
      ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
      : ()),
  );

  bless \%guts => ref($s);
}

#pod =method with_exact_version
#pod
#pod   $range->with_exact_version( $version );
#pod
#pod This sets the version required to I<exactly> the given
#pod version.  No other version would be considered acceptable.
#pod
#pod This method returns the version range object.
#pod
#pod =cut

sub with_exact_version {
  my ($self, $version, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $version = $self->_version_object($version, $module, $bad_version_hook);

  unless ($self->accepts($version)) {
    $self->_reject_requirements(
      $module,
      "exact specification $version outside of range " . $self->as_string
    );
  }

  return CPAN::Meta::Requirements::Range::_Exact->_new($version);
}

sub _simplify {
  my ($self, $module) = @_;

  if (defined $self->{minimum} and defined $self->{maximum}) {
    if ($self->{minimum} == $self->{maximum}) {
      if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) {
        $self->_reject_requirements(
          $module,
          "minimum and maximum are both $self->{minimum}, which is excluded",
        );
      }

      return CPAN::Meta::Requirements::Range::_Exact->_new($self->{minimum});
    }

    if ($self->{minimum} > $self->{maximum}) {
      $self->_reject_requirements(
        $module,
        "minimum $self->{minimum} exceeds maximum $self->{maximum}",
      );
    }
  }

  # eliminate irrelevant exclusions
  if ($self->{exclusions}) {
    my %seen;
    @{ $self->{exclusions} } = grep {
      (! defined $self->{minimum} or $_ >= $self->{minimum})
      and
      (! defined $self->{maximum} or $_ <= $self->{maximum})
      and
      ! $seen{$_}++
    } @{ $self->{exclusions} };
  }

  return $self;
}

#pod =method with_minimum
#pod
#pod   $range->with_minimum( $version );
#pod
#pod This adds a new minimum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Minimum requirements are inclusive.  C<$version> is required, along with any
#pod greater version number.
#pod
#pod This method returns the version range object.
#pod
#pod =cut

sub with_minimum {
  my ($self, $minimum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $minimum = $self->_version_object( $minimum, $module, $bad_version_hook );

  if (defined (my $old_min = $self->{minimum})) {
    $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
  } else {
    $self->{minimum} = $minimum;
  }

  return $self->_simplify($module);
}

#pod =method with_maximum
#pod
#pod   $range->with_maximum( $version );
#pod
#pod This adds a new maximum version requirement.  If the new requirement is
#pod redundant to the existing specification, this has no effect.
#pod
#pod Maximum requirements are inclusive.  No version strictly greater than the given
#pod version is allowed.
#pod
#pod This method returns the version range object.
#pod
#pod =cut

sub with_maximum {
  my ($self, $maximum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $maximum = $self->_version_object( $maximum, $module, $bad_version_hook );

  if (defined (my $old_max = $self->{maximum})) {
    $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
  } else {
    $self->{maximum} = $maximum;
  }

  return $self->_simplify($module);
}

#pod =method with_exclusion
#pod
#pod   $range->with_exclusion( $version );
#pod
#pod This adds a new excluded version.  For example, you might use these three
#pod method calls:
#pod
#pod   $range->with_minimum( '1.00' );
#pod   $range->with_maximum( '1.82' );
#pod
#pod   $range->with_exclusion( '1.75' );
#pod
#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for
#pod 1.75.
#pod
#pod This method returns the requirements object.
#pod
#pod =cut

sub with_exclusion {
  my ($self, $exclusion, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $self = $self->_clone;
  $exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );

  push @{ $self->{exclusions} ||= [] }, $exclusion;

  return $self->_simplify($module);
}

sub _as_modifiers {
  my ($self) = @_;
  my @mods;
  push @mods, [ with_minimum => $self->{minimum} ] if exists $self->{minimum};
  push @mods, [ with_maximum => $self->{maximum} ] if exists $self->{maximum};
  push @mods, map {; [ with_exclusion => $_ ] } @{$self->{exclusions} || []};
  return @mods;
}

#pod =method as_struct
#pod
#pod   $range->as_struct( $module );
#pod
#pod This returns a data structure containing the version requirements. This should
#pod not be used for version checks (see L</accepts_module> instead).
#pod
#pod =cut

sub as_struct {
  my ($self) = @_;

  return 0 if ! keys %$self;

  my @exclusions = @{ $self->{exclusions} || [] };

  my @parts;

  for my $tuple (
    [ qw( >= > minimum ) ],
    [ qw( <= < maximum ) ],
  ) {
    my ($op, $e_op, $k) = @$tuple;
    if (exists $self->{$k}) {
      my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
      if (@new_exclusions == @exclusions) {
        push @parts, [ $op, "$self->{ $k }" ];
      } else {
        push @parts, [ $e_op, "$self->{ $k }" ];
        @exclusions = @new_exclusions;
      }
    }
  }

  push @parts, map {; [ "!=", "$_" ] } @exclusions;

  return \@parts;
}

#pod =method as_string
#pod
#pod   $range->as_string;
#pod
#pod This returns a string containing the version requirements in the format
#pod described in L<CPAN::Meta::Spec>. This should only be used for informational
#pod purposes such as error messages and should not be interpreted or used for
#pod comparison (see L</accepts> instead).
#pod
#pod =cut

sub as_string {
  my ($self) = @_;

  my @parts = @{ $self->as_struct };

  return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>=';

  return join q{, }, map {; join q{ }, @$_ } @parts;
}

sub _reject_requirements {
  my ($self, $module, $error) = @_;
  Carp::croak("illegal requirements for $module: $error")
}

#pod =method accepts
#pod
#pod   my $bool = $range->accepts($version);
#pod
#pod Given a version, this method returns true if the version specification
#pod accepts the provided version.  In other words, given:
#pod
#pod   '>= 1.00, < 2.00'
#pod
#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00.
#pod
#pod =cut

sub accepts {
  my ($self, $version) = @_;

  return if defined $self->{minimum} and $version < $self->{minimum};
  return if defined $self->{maximum} and $version > $self->{maximum};
  return if defined $self->{exclusions}
        and grep { $version == $_ } @{ $self->{exclusions} };

  return 1;
}

#pod =method is_simple
#pod
#pod This method returns true if and only if the range is an inclusive minimum
#pod -- that is, if their string expression is just the version number.
#pod
#pod =cut

sub is_simple {
  my ($self) = @_;
  # XXX: This is a complete hack, but also entirely correct.
  return if $self->as_string =~ /\s/;

  return 1;
}

package
  CPAN::Meta::Requirements::Range::_Exact;

our @ISA = 'CPAN::Meta::Requirements::Range::_Base';

our $VERSION = '2.141';

BEGIN {
  eval "use version ()"; ## no critic
  if ( my $err = $@ ) {
    eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
  }
}

sub _new      { bless { version => $_[1] } => $_[0] }

sub accepts { return $_[0]{version} == $_[1] }

sub _reject_requirements {
  my ($self, $module, $error) = @_;
  Carp::croak("illegal requirements for $module: $error")
}

sub _clone {
  (ref $_[0])->_new( version->new( $_[0]{version} ) )
}

sub with_exact_version {
  my ($self, $version, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $version = $self->_version_object($version, $module, $bad_version_hook);

  return $self->_clone if $self->accepts($version);

  $self->_reject_requirements(
    $module,
    "can't be exactly $version when exact requirement is already $self->{version}",
  );
}

sub with_minimum {
  my ($self, $minimum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $minimum = $self->_version_object( $minimum, $module, $bad_version_hook );

  return $self->_clone if $self->{version} >= $minimum;
  $self->_reject_requirements(
    $module,
    "minimum $minimum exceeds exact specification $self->{version}",
  );
}

sub with_maximum {
  my ($self, $maximum, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $maximum = $self->_version_object( $maximum, $module, $bad_version_hook );

  return $self->_clone if $self->{version} <= $maximum;
  $self->_reject_requirements(
    $module,
    "maximum $maximum below exact specification $self->{version}",
  );
}

sub with_exclusion {
  my ($self, $exclusion, $module, $bad_version_hook) = @_;
  $module //= 'module';
  $exclusion = $self->_version_object( $exclusion, $module, $bad_version_hook );

  return $self->_clone unless $exclusion == $self->{version};
  $self->_reject_requirements(
    $module,
    "tried to exclude $exclusion, which is already exactly specified",
  );
}

sub as_string { return "== $_[0]{version}" }

sub as_struct { return [ [ '==', "$_[0]{version}" ] ] }

sub _as_modifiers { return [ with_exact_version => $_[0]{version} ] }


1;

# vim: ts=2 sts=2 sw=2 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

CPAN::Meta::Requirements::Range - a set of version requirements for a CPAN dist

=head1 VERSION

version 2.143

=head1 SYNOPSIS

  use CPAN::Meta::Requirements::Range;

  my $range = CPAN::Meta::Requirements::Range->with_minimum(1);

  $range = $range->with_maximum('v2.2');

  my $stringified = $range->as_string;

=head1 DESCRIPTION

A CPAN::Meta::Requirements::Range object models a set of version constraints like
those specified in the F<META.yml> or F<META.json> files in CPAN distributions,
and as defined by L<CPAN::Meta::Spec>;
It can be built up by adding more and more constraints, and it will reduce them
to the simplest representation.

Logically impossible constraints will be identified immediately by thrown
exceptions.

=head1 METHODS

=head2 with_string_requirement

  $req->with_string_requirement('>= 1.208, <= 2.206');
  $req->with_string_requirement(v1.208);

This method parses the passed in string and adds the appropriate requirement.
A version can be a Perl "v-string".  It understands version ranges as described
in the L<CPAN::Meta::Spec/Version Ranges>. For example:

=over 4

=item 1.3

=item >= 1.3

=item <= 1.3

=item == 1.3

=item != 1.3

=item > 1.3

=item < 1.3

=item >= 1.3, != 1.5, <= 2.0

A version number without an operator is equivalent to specifying a minimum
(C<E<gt>=>).  Extra whitespace is allowed.

=back

=head2 with_range

 $range->with_range($other_range)

This creates a new range object that is a merge two others.

=head2 with_exact_version

  $range->with_exact_version( $version );

This sets the version required to I<exactly> the given
version.  No other version would be considered acceptable.

This method returns the version range object.

=head2 with_minimum

  $range->with_minimum( $version );

This adds a new minimum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Minimum requirements are inclusive.  C<$version> is required, along with any
greater version number.

This method returns the version range object.

=head2 with_maximum

  $range->with_maximum( $version );

This adds a new maximum version requirement.  If the new requirement is
redundant to the existing specification, this has no effect.

Maximum requirements are inclusive.  No version strictly greater than the given
version is allowed.

This method returns the version range object.

=head2 with_exclusion

  $range->with_exclusion( $version );

This adds a new excluded version.  For example, you might use these three
method calls:

  $range->with_minimum( '1.00' );
  $range->with_maximum( '1.82' );

  $range->with_exclusion( '1.75' );

Any version between 1.00 and 1.82 inclusive would be acceptable, except for
1.75.

This method returns the requirements object.

=head2 as_struct

  $range->as_struct( $module );

This returns a data structure containing the version requirements. This should
not be used for version checks (see L</accepts_module> instead).

=head2 as_string

  $range->as_string;

This returns a string containing the version requirements in the format
described in L<CPAN::Meta::Spec>. This should only be used for informational
purposes such as error messages and should not be interpreted or used for
comparison (see L</accepts> instead).

=head2 accepts

  my $bool = $range->accepts($version);

Given a version, this method returns true if the version specification
accepts the provided version.  In other words, given:

  '>= 1.00, < 2.00'

We will accept 1.00 and 1.75 but not 0.50 or 2.00.

=head2 is_simple

This method returns true if and only if the range is an inclusive minimum
-- that is, if their string expression is just the version number.

=head1 AUTHORS

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Ricardo Signes <rjbs@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by David Golden and Ricardo Signes.

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
PK       ‰™0]‚_žÌ	  Ì	  	                Config.pmnu „[µü¤        PK       1]Î@~¦Ý   Ý               
  Meta/Requirements/.packlistnu „[µü¤        PK       1]ÅXXÏ	  Ï	  	            -  .packlistnu „[µü¤        PK       ü2]n3üy.  .  
            5  Version.pmnu ÏÃ6Ç$        PK       ü2]Cƒ¯ö“  “  	            &  Plugin.pmnu ÏÃ6Ç$        PK       ü2]Ø<Á•›  ›              i3  Kwalify/distroprefs.ddnu ÏÃ6Ç$        PK       ü2]w)#9  9              J@  Kwalify/distroprefs.ymlnu ÏÃ6Ç$        PK       ü2]zÂ¤¿é!  é!              ÊF  Plugin/Specfile.pmnu ÏÃ6Ç$        PK       ü2]Ì2]¹  ¹              õh  Nox.pmnu ÏÃ6Ç$        PK       ü2]‡Ôô(  (              äl  HTTP/Client.pmnu ÏÃ6Ç$        PK       ü2]3ÉyýI
  I
              JŒ  HTTP/Credentials.pmnu ÏÃ6Ç$        PK       ü2]ÈÖÞbJG  JG  
            Ö–  Mirrors.pmnu ÏÃ6Ç$        PK       ü2]×!+“Ô Ô             ZÞ  Shell.pmnu ÏÃ6Ç$        PK       ü2]naX67  7  	            fþ Prompt.pmnu ÏÃ6Ç$        PK       ü2]§:‡  ‡              Ö  Complete.pmnu ÏÃ6Ç$        PK       ü2]Æ®Þ’w^  w^              ˜ HandleConfig.pmnu ÏÃ6Ç$        PK       ü2]‘Úoð  ð              Nw CacheMgr.pmnu ÏÃ6Ç$        PK       ü2]M :Ö.  Ö.              y• Distroprefs.pmnu ÏÃ6Ç$        PK       ü2]¶†ä½   ½               Ä DeferredCode.pmnu ÏÃ6Ç$        PK       ü2]7ªSº  º  	            ‰Å Author.pmnu ÏÃ6Ç$        PK       ü2]½Y3Á A   A  	            |à Tarzip.pmnu ÏÃ6Ç$        PK       ü2]iÛ¨DÌ  Ì              µ! Distrostatus.pmnu ÏÃ6Ç$        PK       ü2]*ƒ^˜  ˜              À% Exception/blocked_urllist.pmnu ÏÃ6Ç$        PK       ü2]ž¹º1.  .               ¤) Exception/RecursiveDependency.pmnu ÏÃ6Ç$        PK       ü2]T–òê  ê              "9 Exception/yaml_not_installed.pmnu ÏÃ6Ç$        PK       ü2]´Ü‘H§  §              [; Exception/yaml_process_error.pmnu ÏÃ6Ç$        PK       ü2]×šÄ9L  L              QB URL.pmnu ÏÃ6Ç$        PK       ü2]>+ò  ò              ÓD LWP/UserAgent.pmnu ÏÃ6Ç$        PK       ü2]¬«õri  ri              M Meta/YAML.pmnu „[µü¤        PK       ü2]®9QìT4  T4              ³¶ Meta/Prereqs.pmnu „[µü¤        PK       ü2]èåÞAú  ú              Fë Meta/History.pmnu „[µü¤        PK       ü2]ýsomFU  FU                Meta/Requirements.pmnu ÏÃ6Ç$        PK       ü2]XŠá‰a  a              	V Meta/Feature.pmnu „[µü¤        PK       ü2]Ã]sÌHH  HH              ©c Meta/History/Meta_1_3.podnu „[µü¤        PK       ü2]ÄÀ·œB  œB              :¬ Meta/History/Meta_1_2.podnu „[µü¤        PK       ü2]w#j¸dJ  dJ              ï Meta/History/Meta_1_4.podnu „[µü¤        PK       ü2]w"ì‰"  ‰"              Ì9 Meta/History/Meta_1_1.podnu „[µü¤        PK       ü2]ÆPs,‰  ‰              ž\ Meta/History/Meta_1_0.podnu „[µü¤        PK       ü2]~“ ˆi#  i#              pw Meta/Merge.pmnu „[µü¤        PK       ü2]ñ‚qNÃ  NÃ              › Meta/Converter.pmnu „[µü¤        PK       ü2]V–}™  ™              ¥^ Meta/Spec.pmnu „[µü¤        PK       ü2]ÓTòˆ„  ˆ„              zï Meta/Validator.pmnu „[µü¤        PK       ü2]¾$Šd  d  
            Ct Kwalify.pmnu ÏÃ6Ç$        PK       ü2]’Fq¼÷)  ÷)              á Meta.pmnu „[µü¤        PK       ü2]Ð§§·ý  ý  
            ¬ InfoObj.pmnu ÏÃ6Ç$        PK       ü2]¨ÖH                FÇ FTP/netrc.pmnu ÏÃ6Ç$        PK       ü2]4Aöë '   '  	            œÍ Bundle.pmnu ÏÃ6Ç$        PK       ü2]íù7=$ $             uõ FirstTime.pmnu ÏÃ6Ç$        PK       ü2]¬ÑñCvW  vW  	            Æ	 Module.pmnu ÏÃ6Ç$        PK       ü2]”ƒBo  o              uq	 Admin.pmnu ÏÃ6Ç$        PK       ü2]hz.Î·Â  ·Â              	 FTP.pmnu ÏÃ6Ç$        PK       ü2]ÏUÜV  ÜV              	S
 Index.pmnu ÏÃ6Ç$        PK       ü2]B¢È3Ô  Ô              ª
 Queue.pmnu ÏÃ6Ç$        PK       ü2]}lë¸+  +              )Æ
 API/HOWTO.podnu ÏÃ6Ç$        PK       ü2]§«LÛË ÛË             ‘Ê
 Distribution.pmnu ÏÃ6Ç$        PK       ü2]zþªÇ6  6              «– Debug.pmnu ÏÃ6Ç$        PK       ›"2]< $l:M  :M              Ÿ Meta/Requirements/Range.pmnu ÏÃ6Ç$        PK    9 9 š  ì   