[perl5.git] / lib / CPAN / Module.pm

# -*- 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.5";

# 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) {
        die(CPAN::Exception::RecursiveDependency->new($ancestors));
    }
    # 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::uptodate ;
sub uptodate {
    my ($self) = @_;
    local ($_);
    my $inst = $self->inst_version or return undef;
    my $cpan = $self->cpan_version;
    local ($^W) = 0;
    CPAN::Version->vgt($cpan,$inst) and return 0;
    my $inst_file = $self->inst_file;
    # trying to support deprecated.pm by Nicholas 2009-02
    my $in_priv_or_arch = "";
    my $isa_perl = "";
    if ($] >= 5.011) { # probably harmful when distros say INSTALLDIRS=perl?
        if (0 == CPAN::Version->vcmp($cpan,$inst)) {
            if ($in_priv_or_arch = $self->_in_priv_or_arch($inst_file)) {
                if (my $distribution = $self->distribution) {
                    unless ($isa_perl = $distribution->isa_perl) {
                        return 0;
                    }
                }
            }
        }
    }
    CPAN->debug
        (join
         ("",
          "returning uptodate. ",
          "inst_file[$inst_file]",
          "cpan[$cpan]inst[$inst]",
          "in_priv_or_arch[$in_priv_or_arch]",
          "isa_perl[$isa_perl]",
         )) if $CPAN::DEBUG;
    return 1;
}

# returns true if installed in privlib or archlib
sub _in_priv_or_arch {
    my($self,$inst_file) = @_;
    for my $confdirname (qw(archlibexp privlibexp)) {
        my $confdir = $Config::Config{$confdirname};
        if ($confdir eq substr($inst_file,0,length($confdir))) {
            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.\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) = @_;
    alarm(10);
    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);
    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;
Commit	Line	Data
f9916dde A	1	# -- Mode: cperl; coding: utf-8; cperl-indent-level: 4 --
	2	# vim: ts=4 sts=4 sw=4:
	3	package CPAN::Module;
	4	use strict;
	5	@CPAN::Module::ISA = qw(CPAN::InfoObj);
	6
	7	use vars qw(
	8	$VERSION
	9	);
	10	$VERSION = "5.5";
	11
	12	# Accessors
	13	#-> sub CPAN::Module::userid
	14	sub userid {
	15	my $self = shift;
	16	my $ro = $self->ro;
	17	return unless $ro;
	18	return $ro->{userid} \|\| $ro->{CPAN_USERID};
	19	}
	20	#-> sub CPAN::Module::description
	21	sub description {
	22	my $self = shift;
	23	my $ro = $self->ro or return "";
	24	$ro->{description}
	25	}
	26
	27	#-> sub CPAN::Module::distribution
	28	sub distribution {
	29	my($self) = @_;
	30	CPAN::Shell->expand("Distribution",$self->cpan_file);
	31	}
	32
	33	#-> sub CPAN::Module::_is_representative_module
	34	sub _is_representative_module {
	35	my($self) = @_;
	36	return $self->{_is_representative_module} if defined $self->{_is_representative_module};
	37	my $pm = $self->cpan_file or return $self->{_is_representative_module} = 0;
	38	$pm =~ s\|.+/\|\|;
	39	$pm =~ s{\.(?:tar\.(bz2\|gz\|Z)\|t(?:gz\|bz)\|zip)$}{}i; # see base_id
	40	$pm =~ s\|-\d+\.\d+.+$\|\|;
	41	$pm =~ s\|-[\d\.]+$\|\|;
	42	$pm =~ s/-/::/g;
	43	$self->{_is_representative_module} = $pm eq $self->{ID} ? 1 : 0;
	44	# warn "DEBUG: $pm eq $self->{ID} => $self->{_is_representative_module}";
	45	$self->{_is_representative_module};
	46	}
	47
	48	#-> sub CPAN::Module::undelay
	49	sub undelay {
	50	my $self = shift;
	51	delete $self->{later};
	52	if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
	53	$dist->undelay;
	54	}
	55	}
	56
	57	# mark as dirty/clean
	58	#-> sub CPAN::Module::color_cmd_tmps ;
	59	sub color_cmd_tmps {
	60	my($self) = shift;
	61	my($depth) = shift \|\| 0;
	62	my($color) = shift \|\| 0;
	63	my($ancestors) = shift \|\| [];
	64	# a module needs to recurse to its cpan_file
65
66	return if exists $self->{incommandcolor}
67	&& $color==1
68	&& $self->{incommandcolor}==$color;
69	return if $color==0 && !$self->{incommandcolor};
70	if ($color>=1) {
71	if ( $self->uptodate ) {
72	$self->{incommandcolor} = $color;
73	return;
74	} elsif (my $have_version = $self->available_version) {
75	# maybe what we have is good enough
76	if (@$ancestors) {
77	my $who_asked_for_me = $ancestors->[-1];
78	my $obj = CPAN::Shell->expandany($who_asked_for_me);
79	if (0) {
80	} elsif ($obj->isa("CPAN::Bundle")) {
81	# bundles cannot specify a minimum version
82	return;
83	} elsif ($obj->isa("CPAN::Distribution")) {
84	if (my $prereq_pm = $obj->prereq_pm) {
85	for my $k (keys %$prereq_pm) {
86	if (my $want_version = $prereq_pm->{$k}{$self->id}) {
87	if (CPAN::Version->vcmp($have_version,$want_version) >= 0) {
88	$self->{incommandcolor} = $color;
89	return;
90	}
91	}
92	}
93	}
94	}
95	}
96	}
97	} else {
98	$self->{incommandcolor} = $color; # set me before recursion,
99	# so we can break it
100	}
101	if ($depth>=$CPAN::MAX_RECURSION) {
102	die(CPAN::Exception::RecursiveDependency->new($ancestors));
103	}
104	# warn "color_cmd_tmps $depth $color " . $self->id; # sleep 1;
105
106	if ( my $dist = CPAN::Shell->expand("Distribution", $self->cpan_file) ) {
107	$dist->color_cmd_tmps($depth+1,$color,[@$ancestors, $self->id]);
108	}
109	# unreached code?
110	# if ($color==0) {
111	# delete $self->{badtestcnt};
112	# }
113	$self->{incommandcolor} = $color;
114	}
115
116	#-> sub CPAN::Module::as_glimpse ;
117	sub as_glimpse {
118	my($self) = @_;
119	my(@m);
120	my $class = ref($self);
121	$class =~ s/^CPAN:://;
122	my $color_on = "";
123	my $color_off = "";
124	if (
125	$CPAN::Shell::COLOR_REGISTERED
126	&&
127	$CPAN::META->has_inst("Term::ANSIColor")
128	&&
129	$self->description
130	) {
131	$color_on = Term::ANSIColor::color("green");
132	$color_off = Term::ANSIColor::color("reset");
133	}
134	my $uptodateness = " ";
135	unless ($class eq "Bundle") {
136	my $u = $self->uptodate;
137	$uptodateness = $u ? "=" : "<" if defined $u;
138	};
139	my $id = do {
140	my $d = $self->distribution;
141	$d ? $d -> pretty_id : $self->cpan_userid;
142	};
143	push @m, sprintf("%-7s %1s %s%-22s%s (%s)\n",
144	$class,
145	$uptodateness,
146	$color_on,
147	$self->id,
148	$color_off,
149	$id,
150	);
151	join "", @m;
152	}
153
154	#-> sub CPAN::Module::dslip_status
155	sub dslip_status {
156	my($self) = @_;
157	my($stat);
158	# development status
159	@{$stat->{D}}{qw,i c a b R M S,} = qw,idea
160	pre-alpha alpha beta released
161	mature standard,;
162	# support level
163	@{$stat->{S}}{qw,m d u n a,} = qw,mailing-list
164	developer comp.lang.perl.*
165	none abandoned,;
166	# language
167	@{$stat->{L}}{qw,p c + o h,} = qw,perl C C++ other hybrid,;
168	# interface
169	@{$stat->{I}}{qw,f r O p h n,} = qw,functions
170	references+ties
171	object-oriented pragma
172	hybrid none,;
173	# public licence
174	@{$stat->{P}}{qw,p g l b a 2 o d r n,} = qw,Standard-Perl
175	GPL LGPL
176	BSD Artistic Artistic_2
177	open-source
178	distribution_allowed
179	restricted_distribution
180	no_licence,;
181	for my $x (qw(d s l i p)) {
182	$stat->{$x}{' '} = 'unknown';
183	$stat->{$x}{'?'} = 'unknown';
184	}
185	my $ro = $self->ro;
186	return +{} unless $ro && $ro->{statd};
187	return {
188	D => $ro->{statd},
189	S => $ro->{stats},
190	L => $ro->{statl},
191	I => $ro->{stati},
192	P => $ro->{statp},
193	DV => $stat->{D}{$ro->{statd}},
194	SV => $stat->{S}{$ro->{stats}},
195	LV => $stat->{L}{$ro->{statl}},
196	IV => $stat->{I}{$ro->{stati}},
197	PV => $stat->{P}{$ro->{statp}},
198	};
199	}
200
201	#-> sub CPAN::Module::as_string ;
202	sub as_string {
203	my($self) = @_;
204	my(@m);
205	CPAN->debug("$self entering as_string") if $CPAN::DEBUG;
206	my $class = ref($self);
207	$class =~ s/^CPAN:://;
208	local($^W) = 0;
209	push @m, $class, " id = $self->{ID}\n";
210	my $sprintf = " %-12s %s\n";
211	push @m, sprintf($sprintf, 'DESCRIPTION', $self->description)
212	if $self->description;
213	my $sprintf2 = " %-12s %s (%s)\n";
214	my($userid);
215	$userid = $self->userid;
216	if ( $userid ) {
217	my $author;
218	if ($author = CPAN::Shell->expand('Author',$userid)) {
219	my $email = "";
220	my $m; # old perls
221	if ($m = $author->email) {
222	$email = " <$m>";
223	}
224	push @m, sprintf(
225	$sprintf2,
226	'CPAN_USERID',
227	$userid,
228	$author->fullname . $email
229	);
230	}
231	}
232	push @m, sprintf($sprintf, 'CPAN_VERSION', $self->cpan_version)
233	if $self->cpan_version;
234	if (my $cpan_file = $self->cpan_file) {
235	push @m, sprintf($sprintf, 'CPAN_FILE', $cpan_file);
236	if (my $dist = CPAN::Shell->expand("Distribution",$cpan_file)) {
237	my $upload_date = $dist->upload_date;
238	if ($upload_date) {
239	push @m, sprintf($sprintf, 'UPLOAD_DATE', $upload_date);
240	}
241	}
242	}
243	my $sprintf3 = " %-12s %1s%1s%1s%1s%1s (%s,%s,%s,%s,%s)\n";
244	my $dslip = $self->dslip_status;
245	push @m, sprintf(
246	$sprintf3,
247	'DSLIP_STATUS',
248	@{$dslip}{qw(D S L I P DV SV LV IV PV)},
249	) if $dslip->{D};
250	my $local_file = $self->inst_file;
251	unless ($self->{MANPAGE}) {
252	my $manpage;
253	if ($local_file) {
254	$manpage = $self->manpage_headline($local_file);
255	} else {
256	# If we have already untarred it, we should look there
257	my $dist = $CPAN::META->instance('CPAN::Distribution',
258	$self->cpan_file);
259	# warn "dist[$dist]";
260	# mff=manifest file; mfh=manifest handle
261	my($mff,$mfh);
262	if (
263	$dist->{build_dir}
264	and
265	(-f ($mff = File::Spec->catfile($dist->{build_dir}, "MANIFEST")))
266	and
267	$mfh = FileHandle->new($mff)
268	) {
269	CPAN->debug("mff[$mff]") if $CPAN::DEBUG;
270	my $lfre = $self->id; # local file RE
271	$lfre =~ s/::/./g;
272	$lfre .= "\\.pm\$";
273	my($lfl); # local file file
274	local $/ = "\n";
275	my(@mflines) = <$mfh>;
276	for (@mflines) {
277	s/^\s+//;
278	s/\s.*//s;
279	}
280	while (length($lfre)>5 and !$lfl) {
281	($lfl) = grep /$lfre/, @mflines;
282	CPAN->debug("lfl[$lfl]lfre[$lfre]") if $CPAN::DEBUG;
283	$lfre =~ s/.+?\.//;
284	}
285	$lfl =~ s/\s.*//; # remove comments
286	$lfl =~ s/\s+//g; # chomp would maybe be too system-specific
287	my $lfl_abs = File::Spec->catfile($dist->{build_dir},$lfl);
288	# warn "lfl_abs[$lfl_abs]";
289	if (-f $lfl_abs) {
290	$manpage = $self->manpage_headline($lfl_abs);
291	}
292	}
293	}
294	$self->{MANPAGE} = $manpage if $manpage;
295	}
296	my($item);
297	for $item (qw/MANPAGE/) {
298	push @m, sprintf($sprintf, $item, $self->{$item})
299	if exists $self->{$item};
300	}
301	for $item (qw/CONTAINS/) {
302	push @m, sprintf($sprintf, $item, join(" ",@{$self->{$item}}))
303	if exists $self->{$item} && @{$self->{$item}};
304	}
305	push @m, sprintf($sprintf, 'INST_FILE',
306	$local_file \|\| "(not installed)");
307	push @m, sprintf($sprintf, 'INST_VERSION',
308	$self->inst_version) if $local_file;
309	if (%{$CPAN::META->{is_tested}\|\|{}}) { # XXX needs to be methodified somehow
310	my $available_file = $self->available_file;
311	if ($available_file && $available_file ne $local_file) {
312	push @m, sprintf($sprintf, 'AVAILABLE_FILE', $available_file);
313	push @m, sprintf($sprintf, 'AVAILABLE_VERSION', $self->available_version);
314	}
315	}
316	join "", @m, "\n";
317	}
318
319	#-> sub CPAN::Module::manpage_headline
320	sub manpage_headline {
321	my($self,$local_file) = @_;
322	my(@local_file) = $local_file;
323	$local_file =~ s/\.pm(?!\n)\Z/.pod/;
324	push @local_file, $local_file;
325	my(@result,$locf);
326	for $locf (@local_file) {
327	next unless -f $locf;
328	my $fh = FileHandle->new($locf)
329	or $Carp::Frontend->mydie("Couldn't open $locf: $!");
330	my $inpod = 0;
331	local $/ = "\n";
332	while (<$fh>) {
333	$inpod = m/^=(?!head1\s+NAME\s*$)/ ? 0 :
334	m/^=head1\s+NAME\s*$/ ? 1 : $inpod;
335	next unless $inpod;
336	next if /^=/;
337	next if /^\s+$/;
338	chomp;
339	push @result, $_;
340	}
341	close $fh;
342	last if @result;
343	}
344	for (@result) {
345	s/^\s+//;
346	s/\s+$//;
347	}
348	join " ", @result;
349	}
350
351	#-> sub CPAN::Module::cpan_file ;
352	# Note: also inherited by CPAN::Bundle
353	sub cpan_file {
354	my $self = shift;
355	# CPAN->debug(sprintf "id[%s]", $self->id) if $CPAN::DEBUG;
356	unless ($self->ro) {
357	CPAN::Index->reload;
358	}
359	my $ro = $self->ro;
360	if ($ro && defined $ro->{CPAN_FILE}) {
361	return $ro->{CPAN_FILE};
362	} else {
363	my $userid = $self->userid;
364	if ( $userid ) {
365	if ($CPAN::META->exists("CPAN::Author",$userid)) {
366	my $author = $CPAN::META->instance("CPAN::Author",
367	$userid);
368	my $fullname = $author->fullname;
369	my $email = $author->email;
370	unless (defined $fullname && defined $email) {
371	return sprintf("Contact Author %s",
372	$userid,
373	);
374	}
375	return "Contact Author $fullname <$email>";
376	} else {
377	return "Contact Author $userid (Email address not available)";
378	}
379	} else {
380	return "N/A";
381	}
382	}
383	}
384
385	#-> sub CPAN::Module::cpan_version ;
386	sub cpan_version {
387	my $self = shift;
388
389	my $ro = $self->ro;
390	unless ($ro) {
391	# Can happen with modules that are not on CPAN
392	$ro = {};
393	}
394	$ro->{CPAN_VERSION} = 'undef'
395	unless defined $ro->{CPAN_VERSION};
396	$ro->{CPAN_VERSION};
397	}
398
399	#-> sub CPAN::Module::force ;
400	sub force {
401	my($self) = @_;
402	$self->{force_update} = 1;
403	}
404
405	#-> sub CPAN::Module::fforce ;
406	sub fforce {
407	my($self) = @_;
408	$self->{force_update} = 2;
409	}
410
411	#-> sub CPAN::Module::notest ;
412	sub notest {
413	my($self) = @_;
414	# $CPAN::Frontend->mywarn("XDEBUG: set notest for Module");
415	$self->{notest}++;
416	}
417
418	#-> sub CPAN::Module::rematein ;
419	sub rematein {
420	my($self,$meth) = @_;
421	$CPAN::Frontend->myprint(sprintf("Running %s for module '%s'\n",
422	$meth,
423	$self->id));
424	my $cpan_file = $self->cpan_file;
425	if ($cpan_file eq "N/A" \|\| $cpan_file =~ /^Contact Author/) {
426	$CPAN::Frontend->mywarn(sprintf qq{
427	The module %s isn\'t available on CPAN.
428
429	Either the module has not yet been uploaded to CPAN, or it is
430	temporary unavailable. Please contact the author to find out
431	more about the status. Try 'i %s'.
432	},
433	$self->id,
434	$self->id,
435	);
436	return;
437	}
438	my $pack = $CPAN::META->instance('CPAN::Distribution',$cpan_file);
439	$pack->called_for($self->id);
440	if (exists $self->{force_update}) {
441	if ($self->{force_update} == 2) {
442	$pack->fforce($meth);
443	} else {
444	$pack->force($meth);
445	}
446	}
447	$pack->notest($meth) if exists $self->{notest} && $self->{notest};
448
449	$pack->{reqtype} \|\|= "";
450	CPAN->debug("dist-reqtype[$pack->{reqtype}]".
451	"self-reqtype[$self->{reqtype}]") if $CPAN::DEBUG;
452	if ($pack->{reqtype}) {
453	if ($pack->{reqtype} eq "b" && $self->{reqtype} =~ /^[rc]$/) {
454	$pack->{reqtype} = $self->{reqtype};
455	if (
456	exists $pack->{install}
457	&&
458	(
459	UNIVERSAL::can($pack->{install},"failed") ?
460	$pack->{install}->failed :
461	$pack->{install} =~ /^NO/
462	)
463	) {
464	delete $pack->{install};
465	$CPAN::Frontend->mywarn
466	("Promoting $pack->{ID} from 'build_requires' to 'requires'");
467	}
468	}
469	} else {
470	$pack->{reqtype} = $self->{reqtype};
471	}
472
473	my $success = eval {
474	$pack->$meth();
475	};
476	my $err = $@;
477	$pack->unforce if $pack->can("unforce") && exists $self->{force_update};
478	$pack->unnotest if $pack->can("unnotest") && exists $self->{notest};
479	delete $self->{force_update};
480	delete $self->{notest};
481	if ($err) {
482	die $err;
483	}
484	return $success;
485	}
486
487	#-> sub CPAN::Module::perldoc ;
488	sub perldoc { shift->rematein('perldoc') }
489	#-> sub CPAN::Module::readme ;
490	sub readme { shift->rematein('readme') }
491	#-> sub CPAN::Module::look ;
492	sub look { shift->rematein('look') }
493	#-> sub CPAN::Module::cvs_import ;
494	sub cvs_import { shift->rematein('cvs_import') }
495	#-> sub CPAN::Module::get ;
496	sub get { shift->rematein('get',@_) }
497	#-> sub CPAN::Module::make ;
498	sub make { shift->rematein('make') }
499	#-> sub CPAN::Module::test ;
500	sub test {
501	my $self = shift;
502	# $self->{badtestcnt} \|\|= 0;
503	$self->rematein('test',@_);
504	}
505
506	#-> sub CPAN::Module::uptodate ;
507	sub uptodate {
508	my ($self) = @_;
509	local ($_);
510	my $inst = $self->inst_version or return undef;
511	my $cpan = $self->cpan_version;
512	local ($^W) = 0;
513	CPAN::Version->vgt($cpan,$inst) and return 0;
2f2071b1 A	514	my $inst_file = $self->inst_file;
	515	# trying to support deprecated.pm by Nicholas 2009-02
	516	my $in_priv_or_arch = "";
	517	my $isa_perl = "";
	518	if ($] >= 5.011) { # probably harmful when distros say INSTALLDIRS=perl?
	519	if (0 == CPAN::Version->vcmp($cpan,$inst)) {
	520	if ($in_priv_or_arch = $self->_in_priv_or_arch($inst_file)) {
	521	if (my $distribution = $self->distribution) {
	522	unless ($isa_perl = $distribution->isa_perl) {
	523	return 0;
	524	}
	525	}
	526	}
	527	}
	528	}
	529	CPAN->debug
	530	(join
	531	("",
	532	"returning uptodate. ",
	533	"inst_file[$inst_file]",
	534	"cpan[$cpan]inst[$inst]",
	535	"in_priv_or_arch[$in_priv_or_arch]",
	536	"isa_perl[$isa_perl]",
	537	)) if $CPAN::DEBUG;
f9916dde A	538	return 1;
	539	}
	540
2f2071b1 A	541	# returns true if installed in privlib or archlib
	542	sub _in_priv_or_arch {
	543	my($self,$inst_file) = @_;
	544	for my $confdirname (qw(archlibexp privlibexp)) {
	545	my $confdir = $Config::Config{$confdirname};
	546	if ($confdir eq substr($inst_file,0,length($confdir))) {
	547	return 1;
	548	}
	549	}
	550	return 0;
	551	}
	552
f9916dde A	553	#-> sub CPAN::Module::install ;
	554	sub install {
	555	my($self) = @_;
	556	my($doit) = 0;
	557	if ($self->uptodate
	558	&&
	559	not exists $self->{force_update}
	560	) {
	561	$CPAN::Frontend->myprint(sprintf("%s is up to date (%s).\n",
	562	$self->id,
	563	$self->inst_version,
	564	));
	565	} else {
	566	$doit = 1;
	567	}
	568	my $ro = $self->ro;
	569	if ($ro && $ro->{stats} && $ro->{stats} eq "a") {
	570	$CPAN::Frontend->mywarn(qq{
	571	\n\n\n *WARNING*
	572	The module $self->{ID} has no active maintainer.\n\n\n
	573	});
	574	$CPAN::Frontend->mysleep(5);
	575	}
	576	return $doit ? $self->rematein('install') : 1;
	577	}
	578	#-> sub CPAN::Module::clean ;
	579	sub clean { shift->rematein('clean') }
	580
	581	#-> sub CPAN::Module::inst_file ;
	582	sub inst_file {
	583	my($self) = @_;
	584	$self->_file_in_path([@INC]);
	585	}
	586
	587	#-> sub CPAN::Module::available_file ;
	588	sub available_file {
	589	my($self) = @_;
	590	my $sep = $Config::Config{path_sep};
	591	my $perllib = $ENV{PERL5LIB};
	592	$perllib = $ENV{PERLLIB} unless defined $perllib;
	593	my @perllib = split(/$sep/,$perllib) if defined $perllib;
	594	my @cpan_perl5inc;
	595	if ($CPAN::Perl5lib_tempfile) {
	596	my $yaml = CPAN->_yaml_loadfile($CPAN::Perl5lib_tempfile);
	597	@cpan_perl5inc = @{$yaml->[0]{inc} \|\| []};
	598	}
	599	$self->_file_in_path([@cpan_perl5inc,@perllib,@INC]);
	600	}
	601
	602	#-> sub CPAN::Module::file_in_path ;
	603	sub _file_in_path {
	604	my($self,$path) = @_;
	605	my($dir,@packpath);
	606	@packpath = split /::/, $self->{ID};
	607	$packpath[-1] .= ".pm";
	608	if (@packpath == 1 && $packpath[0] eq "readline.pm") {
	609	unshift @packpath, "Term", "ReadLine"; # historical reasons
	610	}
	611	foreach $dir (@$path) {
	612	my $pmfile = File::Spec->catfile($dir,@packpath);
	613	if (-f $pmfile) {
	614	return $pmfile;
	615	}
	616	}
617	return;
618	}
619
620	#-> sub CPAN::Module::xs_file ;
621	sub xs_file {
622	my($self) = @_;
623	my($dir,@packpath);
624	@packpath = split /::/, $self->{ID};
625	push @packpath, $packpath[-1];
626	$packpath[-1] .= "." . $Config::Config{'dlext'};
627	foreach $dir (@INC) {
628	my $xsfile = File::Spec->catfile($dir,'auto',@packpath);
629	if (-f $xsfile) {
630	return $xsfile;
631	}
632	}
633	return;
634	}
635
636	#-> sub CPAN::Module::inst_version ;
637	sub inst_version {
638	my($self) = @_;
639	my $parsefile = $self->inst_file or return;
640	my $have = $self->parse_version($parsefile);
641	$have;
642	}
643
644	#-> sub CPAN::Module::inst_version ;
645	sub available_version {
646	my($self) = @_;
647	my $parsefile = $self->available_file or return;
648	my $have = $self->parse_version($parsefile);
649	$have;
650	}
651
652	#-> sub CPAN::Module::parse_version ;
653	sub parse_version {
654	my($self,$parsefile) = @_;
94fe740e A	655	alarm(10);
	656	my $have = eval {
	657	local $SIG{ALRM} = sub { die "alarm\n" };
	658	MM->parse_version($parsefile);
	659	};
f9916dde A	660	if ($@) {
	661	$CPAN::Frontend->mywarn("Error while parsing version number in file '$parsefile'\n");
	662	}
94fe740e	663	alarm(0);
f9916dde A	664	my $leastsanity = eval { defined $have && length $have; };
	665	$have = "undef" unless $leastsanity;
	666	$have =~ s/^ //; # since the %vd hack these two lines here are needed
	667	$have =~ s/ $//; # trailing whitespace happens all the time
	668
	669	$have = CPAN::Version->readable($have);
	670
	671	$have =~ s/\s*//g; # stringify to float around floating point issues
	672	$have; # no stringify needed, \s* above matches always
	673	}
	674
	675	#-> sub CPAN::Module::reports
	676	sub reports {
	677	my($self) = @_;
	678	$self->distribution->reports;
	679	}
	680
	681	1;