cpan-outdated

#!/usr/bin/perl
use strict;
use warnings;
use Getopt::Long;
use Pod::Usage;
use ExtUtils::MakeMaker;
use File::Temp;
use File::Spec;
use Config;
use version;
use LWP::Simple ();
use IO::Zlib;
use constant WIN32 => $^O eq 'MSWin32';

our $VERSION = "0.11";

my $mirror = 'http://www.cpan.org/';
my $quote = WIN32 ? q/"/ : q/'/;
my $local_lib;
my $self_contained = 0;
Getopt::Long::Configure("bundling");
Getopt::Long::GetOptions(
    'h|help'          => \my $help,
    'verbose'         => \my $verbose,
    'p|pkg=s'         => \my $just_this_pkg,
    'f|filter-pkg=s'  => \my $filter_pkg,
    'compare-changes' => \my $compare_changes,
    'm|mirror=s'      => \$mirror,
    '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; },
) or pod2usage();
pod2usage() if $help;

$mirror =~ s:/$::;
my $index_url = "${mirror}/modules/02packages.details.txt.gz";

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

sub main {
    init_tools();

    if ($local_lib) {
        setup_local_lib($local_lib, $self_contained);
    }

    my $tmpfile = File::Temp->new(UNLINK => 1, SUFFIX => '.gz');
    getstore($index_url, $tmpfile->filename) or die "Cannot getstore file";

    my $fh = zopen($tmpfile) or die "cannot open $tmpfile";
    # skip header part
    while (my $line = <$fh>) {
        last if $line eq "\n";
    }
    # body part
    my %seen;
    while (my $line = <$fh>) {
        my ($pkg, $version, $dist) = split /\s+/, $line;
        next if $just_this_pkg && $just_this_pkg ne $pkg;
        next if $filter_pkg && $pkg !~ m/$filter_pkg/;
        next if $version eq 'undef';
        next if $dist =~ m{/perl-[0-9._]+\.tar\.gz$};
        (my $file = $pkg) =~ s!::!/!g;
        $file = "${file}.pm";
        SCAN_INC: for my $dir (@INC) {
            my $path = "$dir/$file";
            next unless -f $path;
            my $inst_version = parse_version($path);
               $inst_version  =~ s/\s+//; # workaround for Attribute::Params::Validate
            next if $inst_version eq 'undef';
            if (compare_version($inst_version, $version)) {
                next if $seen{$dist}++;
                if ($verbose) {
                    printf "%-30s %-7s %-7s %s\n", $pkg, $inst_version, $version, $dist;
                } else {
                    print "$dist\n";
                }
                if ($compare_changes) {
                    print_diff_changes($pkg, $inst_version, $version);
                }
            }
            last SCAN_INC;
        }
    }
}

sub print_diff_changes {
    my ( $pkg, $inst_version, $cpan_version ) = @_;
    $pkg =~ s/::/-/g;

    my $ua = LWP::UserAgent->new;

    my $change_file_name;
    my $old_changes;
    for my $tmp_change_file_name ( qw/Changes CHANGES Changelog ChangeLog CHANGELOG/ ) {
        my $res = $ua->get(qq{http://cpansearch.perl.org/dist/$pkg-$inst_version/$tmp_change_file_name});
        unless ( $res->is_success && $res->request->uri =~ m/$tmp_change_file_name$/ ) {
            next;
        }
        $old_changes = $res->content;
        if ( $old_changes ) {
            $change_file_name = $tmp_change_file_name;
            last;
        }
    }
    if ( !$old_changes || !$change_file_name ) {
        print "Cannot find old changes.\n\n";
        return;
    }

    my $res = $ua->get(qq{http://cpansearch.perl.org/dist/$pkg-$cpan_version/$change_file_name});
    unless ( $res->is_success && $res->request->uri =~ m/$change_file_name$/ && $res->content) {
        print "Cannot find new changes.\n\n";
        return;
    }
    my $new_changes = $res->content;

    print_diff($old_changes, $new_changes);
    print "\n";
}
sub print_diff {
    my ($old_changes, $new_changes) = @_;

    my $diff = Algorithm::Diff->new( [split /\n/, $old_changes], [split /\n/, $new_changes] );

    # copy from Algorithm::Diff SYNOPSYS
    $diff->Base( 1 );   # Return line numbers, not indices
    while(  $diff->Next()  ) {
        next   if  $diff->Same();
        my $sep = '';
        if(  ! $diff->Items(2)  ) {
            printf "%d,%dd%d\n",
                $diff->Get(qw( Min1 Max1 Max2 ));
        } elsif(  ! $diff->Items(1)  ) {
            printf "%da%d,%d\n",
                $diff->Get(qw( Max1 Min2 Max2 ));
        } else {
            $sep = "---\n";
            printf "%d,%dc%d,%d\n",
                $diff->Get(qw( Min1 Max1 Min2 Max2 ));
        }
        print "< $_\n"   for  $diff->Items(1);
        print $sep;
        print "> $_\n"   for  $diff->Items(2);
    }
}

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

sub parse_version {
    my $path = shift;
    local $SIG{__WARN__} = sub {
        # This is workaround for EU::MM's issue.
        # following one-liner makes too long warnings.
        #   perl -e 'use ExtUtils::MM; MM->parse_version("/usr/local/app/perl-5.10.1/lib/site_perl/5.10.1/Authen/Simple/Apache.pm")'
        return if @_ && $_[0] =~ /^Could not eval/;
        CORE::warn(@_);
    };
    MM->parse_version($path);
}

# taken from cpanminus
sub which {
    my($name) = @_;
    my $exe_ext = $Config{_exe};
    foreach my $dir(File::Spec->path){
        my $fullpath = File::Spec->catfile($dir, $name);
        if (-x $fullpath || -x ($fullpath .= $exe_ext)){
            if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) {
                $fullpath = "$quote$fullpath$quote"
            }
            return $fullpath;
        }
    }
    return;
}

sub getstore {
    my ($url, $fname) = @_;
    return LWP::Simple::getstore($url => $fname) == 200;
}

sub zopen {
    IO::Zlib->new($_[0], "rb");
}

sub init_tools {
    if ( $compare_changes ) {
        if ( !eval { require LWP::UserAgent } ) {
            die "Cannot find LWP::UserAgent.\n";
        }
        if ( !eval { require Algorithm::Diff } ) {
            die "Cannot find Algorithm::Diff.\n";
        }
    }
}

sub setup_local_lib {
    my ($base, $self_contained) = @_;
    $base ||= '~/perl5/';

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

    local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
    local::lib->import($base);
}

__END__

=head1 NAMES

cpan-outdated - detect outdated CPAN modules in your environment

=head1 SYNOPSIS

    # print list of outdated modules
    % cpan-outdated

    # verbose
    % cpan-outdated --verbose

    # output changes diff
    % cpan-outdated --compare-changes

    # alternate mirrors
    % cpan-outdated --mirror file:///home/user/minicpan/

    # additional module path(same as cpanminus)
    % cpan-outdated -l extlib/
    % cpan-outdated -L extlib/

    # install with cpan
    % cpan-outdated | xargs cpan -i

    # install with cpanm
    % cpan-outdated | xargs cpanm

=head1 DESCRIPTION

This module print list of outdated CPAN modules in your machine.

It's same feature of 'CPAN::Shell->r', but cpan-outdated is so fast and less memory.

This script can integrate with cpanm command.

=head1 DEPENDENCIES

perl 5.8 or later (Actually I believe it works with pre 5.8 too but haven't tested).

=over 4

=item LWP to get a index file over HTTP.

=item IO::Zlib to decode gziped index file.

=item version.pm

=back

=head1 AUTHOR

Tokuhiro Matsuno

=head1 LICENSE

Copyright (C) 2009 Tokuhiro Matsuno.

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

=head1 SEE ALSO

L<CPAN>

=cut