File Coverage

script/cpan-outdated

Criterion	Covered	Total	%
statement	47	106	44.3
branch	4	44	9.0
condition	4	18	22.2
subroutine	13	21	61.9
pod			n/a
total	68	189	35.9

#!/usr/bin/perl
use strict;
use warnings;
use ExtUtils::Installed;
use Getopt::Long;
use Config;
use version;
use IO::Zlib;
use CPAN::DistnameInfo;
use Module::Metadata;
use URI;

our $VERSION = "0.30";

my $mirror = 'http://www.cpan.org/';
my $local_lib;
my $self_contained = 0;
my $index_file;
my $help;
Getopt::Long::Configure("bundling");
Getopt::Long::GetOptions(
    'h|help'          => \$help,
    'verbose'         => \my $verbose,
    'm|mirror=s'      => \$mirror,
    'index=s'         => \$index_file,
    'p|print-package' => \my $print_package,
    'I=s'             => sub { die "this option was deprecated" },
    'l|local-lib=s'   => \$local_lib,
    'L|local-lib-contained=s' =>
      sub { $local_lib = $_[1]; $self_contained = 1; },
    'compare-changes' => sub {
        die "--compare-changes option was deprecated.\n"
          . "You can use 'cpan-listchanges `cpan-outdated -p`' instead.\n"
          . "cpanm cpan-listchanges # install from CPAN\n"
    },
    'exclude-core' => \my $exclude_core,
) or $help++;
if ($help) {
    require Pod::Usage;
    Pod::Usage::pod2usage();
}

$mirror =~ s:/$::;
my $index_url = "${mirror}/modules/02packages.details.txt.gz";
$index_url = URI->new($index_url);
if ($index_url->isa('URI::file')) {
    die '--index is incompatible with a file:// mirror' if defined $index_file;
    $index_file = $index_url->file
}

my $core_modules;
if ($exclude_core) {
    require Module::CoreList;
    no warnings 'once';
    $core_modules = $Module::CoreList::version{$]};
}

unless ($ENV{HARNESS_ACTIVE}) {
    &main;
    exit;
}

sub modules_to_check {
    my @inc = @_;
    # TODO: if you want to filter the target modules, you can change them here.
    ExtUtils::Installed->new(skip_cwd => 1, inc_override => \@inc)->modules;
}

sub installed_version_for {
    my($pkg, $inc) = @_;

    local $SIG{__WARN__} = sub {};
    my $meta = Module::Metadata->new_from_module($pkg, inc => $inc);
    $meta ? $meta->version($pkg) : undef;
}

sub main {
    my @inc = make_inc($local_lib, $self_contained);

    if (   !defined($index_file)
        || ! -e $index_file || -z $index_file
        || !$index_url->isa('URI::file')) {

        $index_file = get_index($index_url, $index_file)
    }

    my %installed = map { $_ => 1 } modules_to_check(@inc);

    my $fh = zopen($index_file) or die "cannot open $index_file";
    # skip header part
    while (my $line = <$fh>) {
        last if $line eq "\n";
    }
    # body part
    my %seen;
    my %dist_latest_version;
    LINES: while (my $line = <$fh>) {
        my ($pkg, $version, $dist) = split /\s+/, $line;
        next unless $installed{$pkg};
        next if $version eq 'undef';

        # The note below about the latest version heuristics applies here too
        next if $seen{$dist};

        # $Mail::SpamAssassin::Conf::VERSION is 'bogus'
        # https://rt.cpan.org/Public/Bug/Display.html?id=73465
        next unless $version =~ /[0-9]/;

        # if excluding core modules
        next if $exclude_core && exists $core_modules->{$pkg};

        next if $dist =~ m{/perl-[0-9._]+\.tar\.(gz|bz2)$};

        my $inst_version = installed_version_for($pkg, \@inc)
            or next;

        if (compare_version($inst_version, $version)) {
            $seen{$dist}++;
            if ($verbose) {
                printf "%-30s %-7s %-7s %s\n", $pkg, $inst_version, $version, $dist;
            } elsif ($print_package) {
                print "$pkg\n";
            } else {
                print "$dist\n";
            }
        }
    }
}


# return true if $inst_version is less than $version
sub compare_version {
    my ($inst_version, $version) = @_;
    return 0 if $inst_version eq $version;

    my $inst_version_obj = eval { version->new($inst_version) } || version->new(permissive_filter($inst_version));
    my $version_obj      = eval { version->new($version) } || version->new(permissive_filter($version));

    return $inst_version_obj < $version_obj ? 1 : 0;
}

# for broken packages.
sub permissive_filter {
    local $_ = $_[0];
    s/^[Vv](\d)/$1/;                   # Bioinf V2.0
    s/^(\d+)_(\d+)$/$1.$2/;            # VMS-IndexedFile 0_02
    s/-[a-zA-Z]+$//;                   # Math-Polygon-Tree 0.035-withoutworldwriteables
    s/([a-j])/ord($1)-ord('a')/gie;    # DBD-Solid 0.20a
    s/[_h-z-]/./gi;                    # makepp 1.50.2vs.070506
    s/\.{2,}/./g;
    $_;
}


# Return the $fname (a generated File::Temp object if not provided)
sub get_index {
    my ($url, $fname) = @_;
    require HTTP::Tiny;
    my $ua = HTTP::Tiny->new;
    my $response;
    if (defined $fname) {
        # If the file is not empty, use it as a local cached copy
        if (-s $fname) {
            $response = $ua->mirror($url, $fname);
        } else {
            # If the file is empty we do not trust its timestamp
            # so set a custom If-Modified-Since (Perl 5.0 release)
            $response = $ua->mirror($url, $fname,
                {
                    headers => {
                        'if-modified-since' => 'Wed, 19 Oct 1994 17:18:57 GMT',
                    },
                });
        }
    } else {
        require File::Temp;
        $fname = File::Temp->new(UNLINK => 1, SUFFIX => '.gz');
        binmode $fname;
        $response = $ua->request(
            'GET' => $url,
            {
                data_callback => sub { print {$fname} $_[0] },
            }
        );
        close $fname;
    }
    if ($response->{status} == 599) {
        die "Cannot get_index $url to $fname: $response->{content}";
    # 304 = "Not Modified" is still a success since we are mirroring
    } elsif (! $response->{success}) {
        die "Cannot get_index $url to $fname: $response->{status} $response->{reason}";
    }
    #print "$fname $response->{status} $response->{reason}\n";
    # Return the filename (which might be a File::Temp object)
    $fname
}

sub zopen {
    # Explicitely stringify the filename as it may be a File::Temp object
    IO::Zlib->new("$_[0]", "rb");
}

sub make_inc {
    my ($base, $self_contained) = @_;

    if ($base) {
        require local::lib;
        my @modified_inc = (
            local::lib->install_base_perl_path($base),
            local::lib->install_base_arch_path($base),
        );
        if ($self_contained) {
            push @modified_inc, @Config{qw(privlibexp archlibexp)};
        } else {
            push @modified_inc, @INC;
        }
        return @modified_inc;
    } else {
        return @INC;
    }
}

__END__