whatinstalled.pl

#!/usr/bin/env perl
use 5.010;
use strict;
use warnings;
use Config;
use CPAN::DistnameInfo;
use File::Basename;
use File::Spec;
use File::Spec::Unix;
use File::Fetch;
use File::Find;
use IO::Zlib;
use List::AllUtils qw/uniq/;
use version;
use Module::Load::Conditional qw[check_install];

use constant ON_WIN32       => $^O eq 'MSWin32';
use constant ON_VMS         => $^O eq 'VMS';

my $mirror = 'http://cpan.hexten.net/';

my %installed;
my %cpan;
my %map_module;
my %map_distname;

foreach my $module ( _all_installed() ) {
  my $href = check_install( module => $module );
  next unless $href;
  $installed{ $module } = defined $href->{version} ? $href->{version} : 'undef';
}

my $loc = fetch_indexes('.',$mirror) or die;
populate_cpan( $loc );
foreach my $module ( sort keys %installed ) {
  # Eliminate core modules
  if ( supplied_with_core( $module ) and !$cpan{ $module } ) { 
    delete $installed{ $module };
    next;
  }
}

# Get to a unique list of dists
say for map { $map_distname{$_}{path} } 
        uniq sort map { $map_module{$_} // () } 
        keys %installed;

exit 0;

sub supplied_with_core {
  my $name = shift;
  my $ver = shift || $];
  require Module::CoreList;
  return $Module::CoreList::version{ 0+$ver }->{ $name };
}

sub _vcmp {
  my ($x, $y) = @_;
  $x //= 0;
  $y //= 0;
  s/_//g foreach $x, $y;
  return version->parse($x) <=> version->parse($y);
}

sub populate_cpan {
  my $pfile = shift;
  my $fh = IO::Zlib->new( $pfile, "rb" ) or die "$!\n";

  while (<$fh>) {
    last if /^\s*$/;
  }
  while (<$fh>) {
    chomp;
    my ($module,$version,$package_path) = split ' ', $_;
    my $info = CPAN::DistnameInfo->new($package_path);
    my $name = $info->dist;
    warn "No name found for $package_path\n", next unless defined $name;
    warn "Bad version for $package_path\n", next 
      unless defined eval { version->parse($info->version) };
    $cpan{ $module } = $version;
    $map_module{ $module } = $name;
    # create map of most recent dist of a given name
    if ( ! exists $map_distname{$name} ) {
      $map_distname{$name} = {v => $info->version, path => $package_path};
    }
    elsif ( _vcmp($info->version, $map_distname{$name}{v}) > 0) {
      $map_distname{$name} = {v => $info->version, path => $package_path};
    }
  }
  return 1;
}

sub fetch_indexes {
  my ($location,$mirror) = @_;
  my $packages = 'modules/02packages.details.txt.gz';
  my $url = join '', $mirror, $packages;
  my $base = basename($packages);
  return $base if -f $base;
  my $ff = File::Fetch->new( uri => $url );
  my $stat = $ff->fetch( to => $location );
  return unless $stat;
  warn "Downloaded '$url' to '$stat'\n";
  return $stat;
}

sub _all_installed {
    ### File::Find uses follow_skip => 1 by default, which doesn't die
    ### on duplicates, unless they are directories or symlinks.
    ### Ticket #29796 shows this code dying on Alien::WxWidgets,
    ### which uses symlinks.
    ### File::Find doc says to use follow_skip => 2 to ignore duplicates
    ### so this will stop it from dying.
    my %find_args = ( follow_skip => 2 );

    ### File::Find uses lstat, which quietly becomes stat on win32
    ### it then uses -l _ which is not allowed by the statbuffer because
    ### you did a stat, not an lstat (duh!). so don't tell win32 to
    ### follow symlinks, as that will break badly
    $find_args{'follow_fast'} = 1 unless ON_WIN32;

    ### never use the @INC hooks to find installed versions of
    ### modules -- they're just there in case they're not on the
    ### perl install, but the user shouldn't trust them for *other*
    ### modules!
    ### XXX CPANPLUS::inc is now obsolete, remove the calls
    #local @INC = CPANPLUS::inc->original_inc;

    my %seen; my @rv;
    for my $dir (@INC ) {
        next if $dir eq '.';

        ### not a directory after all 
        ### may be coderef or some such
        next unless -d $dir;

        ### make sure to clean up the directories just in case,
        ### as we're making assumptions about the length
        ### This solves rt.cpan issue #19738
        
        ### John M. notes: On VMS cannonpath can not currently handle 
        ### the $dir values that are in UNIX format.
        $dir = File::Spec->canonpath( $dir ) unless ON_VMS;
        
        ### have to use F::S::Unix on VMS, or things will break
        my $file_spec = ON_VMS ? 'File::Spec::Unix' : 'File::Spec';

        ### XXX in some cases File::Find can actually die!
        ### so be safe and wrap it in an eval.
        eval { File::Find::find(
            {   %find_args,
                wanted      => sub {

                    return unless /\.pm$/i;
                    my $mod = $File::Find::name;

                    ### make sure it's in Unix format, as it
                    ### may be in VMS format on VMS;
                    $mod = VMS::Filespec::unixify( $mod ) if ON_VMS;                    
                    
                    $mod = substr($mod, length($dir) + 1, -3);
                    $mod = join '::', $file_spec->splitdir($mod);

                    $mod =~ s/^$Config{archname}:://;

                    return if $seen{$mod}++;

                    push @rv, $mod;
                },
            }, $dir
        ) };

    }

    return @rv;
}