view release on metacpan or  search on metacpan

lib/CPAN/Shell.pm  view on Meta::CPAN

    $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;
        }