File Coverage

script/cpan-outdated
Criterion Covered Total %
statement 47 111 42.3
branch 4 46 8.7
condition 4 24 16.6
subroutine 13 21 61.9
pod n/a
total 68 202 33.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2 2     2   851 use strict;
  2         3  
  2         56  
3 2     2   9 use warnings;
  2         2  
  2         60  
4 2     2   1161 use ExtUtils::Installed;
  2         235326  
  2         71  
5 2     2   1539 use Getopt::Long;
  2         18963  
  2         11  
6 2     2   353 use Config;
  2         3  
  2         80  
7 2     2   9 use version;
  2         4  
  2         13  
8 2     2   1677 use IO::Zlib;
  2         128904  
  2         14  
9 2     2   1088 use CPAN::DistnameInfo;
  2         1335  
  2         49  
10 2     2   1142 use Module::Metadata;
  2         9259  
  2         90  
11 2     2   1119 use URI;
  2         7481  
  2         547  
12              
13             our $VERSION = "0.32";
14              
15             my $mirror = 'http://www.cpan.org/';
16             my $local_lib;
17             my $self_contained = 0;
18             my $index_file;
19             my $help;
20             Getopt::Long::Configure("bundling");
21             Getopt::Long::GetOptions(
22             'h|help' => \$help,
23             'verbose' => \my $verbose,
24             'm|mirror=s' => \$mirror,
25             'index=s' => \$index_file,
26             'p|print-package' => \my $print_package,
27             'I=s' => sub { die "this option was deprecated" },
28             'l|local-lib=s' => \$local_lib,
29             'L|local-lib-contained=s' =>
30             sub { $local_lib = $_[1]; $self_contained = 1; },
31             'compare-changes' => sub {
32             die "--compare-changes option was deprecated.\n"
33             . "You can use 'cpan-listchanges `cpan-outdated -p`' instead.\n"
34             . "cpanm cpan-listchanges # install from CPAN\n"
35             },
36             'exclude-core' => \my $exclude_core,
37             ) or $help++;
38             if ($help) {
39             require Pod::Usage;
40             Pod::Usage::pod2usage();
41             }
42              
43             $mirror =~ s:/$::;
44             my $index_url = "${mirror}/modules/02packages.details.txt.gz";
45             $index_url = URI->new($index_url);
46             if ($index_url->isa('URI::file')) {
47             die '--index is incompatible with a file:// mirror' if defined $index_file;
48             $index_file = $index_url->file
49             }
50              
51             my $core_modules;
52             if ($exclude_core) {
53             require Module::CoreList;
54 2     2   15 no warnings 'once';
  2         2  
  2         2848  
55             $core_modules = $Module::CoreList::version{$]};
56             }
57              
58             unless ($ENV{HARNESS_ACTIVE}) {
59             &main;
60             exit;
61             }
62              
63             sub modules_to_check {
64 0     0   0 my @inc = @_;
65 0         0 my @modules =
66             ExtUtils::Installed->new(skip_cwd => 1, inc_override => \@inc)->modules;
67             # As core modules may not have been listed by EUI because they lack
68             # .packlist, we add them from Module::CoreList
69 0 0 0     0 if (!$exclude_core || ($local_lib && !$self_contained)) {
      0        
70 0         0 require Module::CoreList;
71             # This adds duplicates, but they are removed by the caller
72 0         0 push @modules, keys %{ $Module::CoreList::version{$]} };
  0         0  
73             }
74 0         0 (@modules)
75             }
76              
77             sub installed_version_for {
78 0     0   0 my($pkg, $inc) = @_;
79              
80 0     0   0 local $SIG{__WARN__} = sub {};
81 0         0 my $meta = Module::Metadata->new_from_module($pkg, inc => $inc);
82 0 0       0 $meta ? $meta->version($pkg) : undef;
83             }
84              
85             sub main {
86 0     0   0 my @inc = make_inc($local_lib, $self_contained);
87              
88 0 0 0     0 if ( !defined($index_file)
      0        
      0        
89             || ! -e $index_file || -z $index_file
90             || !$index_url->isa('URI::file')) {
91              
92 0         0 $index_file = get_index($index_url, $index_file)
93             }
94              
95 0         0 my %installed = map { $_ => 1 } modules_to_check(@inc);
  0         0  
96              
97 0 0       0 my $fh = zopen($index_file) or die "cannot open $index_file";
98             # skip header part
99 0         0 while (my $line = <$fh>) {
100 0 0       0 last if $line eq "\n";
101             }
102             # body part
103 0         0 my %seen;
104             my %dist_latest_version;
105 0         0 LINES: while (my $line = <$fh>) {
106 0         0 my ($pkg, $version, $dist) = split /\s+/, $line;
107 0 0       0 next unless $installed{$pkg};
108 0 0       0 next if $version eq 'undef';
109              
110             # The note below about the latest version heuristics applies here too
111 0 0       0 next if $seen{$dist};
112              
113             # $Mail::SpamAssassin::Conf::VERSION is 'bogus'
114             # https://rt.cpan.org/Public/Bug/Display.html?id=73465
115 0 0       0 next unless $version =~ /[0-9]/;
116              
117             # if excluding core modules
118 0 0 0     0 next if $exclude_core && exists $core_modules->{$pkg};
119              
120 0 0       0 next if $dist =~ m{/perl-[0-9._]+\.tar\.(gz|bz2)$};
121              
122 0 0       0 my $inst_version = installed_version_for($pkg, \@inc)
123             or next;
124              
125 0 0       0 if (compare_version($inst_version, $version)) {
126 0         0 $seen{$dist}++;
127 0 0       0 if ($verbose) {
    0          
128 0         0 printf "%-30s %-7s %-7s %s\n", $pkg, $inst_version, $version, $dist;
129             } elsif ($print_package) {
130 0         0 print "$pkg\n";
131             } else {
132 0         0 print "$dist\n";
133             }
134             }
135             }
136             }
137              
138              
139             # return true if $inst_version is less than $version
140             sub compare_version {
141 7     7   20 my ($inst_version, $version) = @_;
142 7 100       22 return 0 if $inst_version eq $version;
143              
144 5   66     7 my $inst_version_obj = eval { version->new($inst_version) } || version->new(permissive_filter($inst_version));
145 5   66     11 my $version_obj = eval { version->new($version) } || version->new(permissive_filter($version));
146              
147 5 100       39 return $inst_version_obj < $version_obj ? 1 : 0;
148             }
149              
150             # for broken packages.
151             sub permissive_filter {
152 12     12   38 local $_ = $_[0];
153 12         24 s/^[Vv](\d)/$1/; # Bioinf V2.0
154 12         25 s/^(\d+)_(\d+)$/$1.$2/; # VMS-IndexedFile 0_02
155 12         16 s/-[a-zA-Z]+$//; # Math-Polygon-Tree 0.035-withoutworldwriteables
156 12         25 s/([a-j])/ord($1)-ord('a')/gie; # DBD-Solid 0.20a
  7         18  
157 12         16 s/[_h-z-]/./gi; # makepp 1.50.2vs.070506
158 12         17 s/\.{2,}/./g;
159 12         73 $_;
160             }
161              
162              
163             # Return the $fname (a generated File::Temp object if not provided)
164             sub get_index {
165 0     0     my ($url, $fname) = @_;
166 0           require HTTP::Tiny;
167 0           my $ua = HTTP::Tiny->new;
168 0           my $response;
169 0 0         if (defined $fname) {
170             # If the file is not empty, use it as a local cached copy
171 0 0         if (-s $fname) {
172 0           $response = $ua->mirror($url, $fname);
173             } else {
174             # If the file is empty we do not trust its timestamp
175             # so set a custom If-Modified-Since (Perl 5.0 release)
176 0           $response = $ua->mirror($url, $fname,
177             {
178             headers => {
179             'if-modified-since' => 'Wed, 19 Oct 1994 17:18:57 GMT',
180             },
181             });
182             }
183             } else {
184 0           require File::Temp;
185 0           $fname = File::Temp->new(UNLINK => 1, SUFFIX => '.gz');
186 0           binmode $fname;
187             $response = $ua->request(
188             'GET' => $url,
189             {
190 0     0     data_callback => sub { print {$fname} $_[0] },
  0            
191             }
192 0           );
193 0           close $fname;
194             }
195 0 0         if ($response->{status} == 599) {
    0          
196 0           die "Cannot get_index $url to $fname: $response->{content}";
197             # 304 = "Not Modified" is still a success since we are mirroring
198             } elsif (! $response->{success}) {
199 0           die "Cannot get_index $url to $fname: $response->{status} $response->{reason}";
200             }
201             #print "$fname $response->{status} $response->{reason}\n";
202             # Return the filename (which might be a File::Temp object)
203             $fname
204 0           }
205              
206             sub zopen {
207             # Explicitely stringify the filename as it may be a File::Temp object
208 0     0     IO::Zlib->new("$_[0]", "rb");
209             }
210              
211             sub make_inc {
212 0     0     my ($base, $self_contained) = @_;
213              
214 0 0         if ($base) {
215 0           require local::lib;
216 0           my @modified_inc = (
217             local::lib->install_base_perl_path($base),
218             local::lib->install_base_arch_path($base),
219             );
220 0 0         if ($self_contained) {
221 0           push @modified_inc, @Config{qw(privlibexp archlibexp)};
222             } else {
223 0           push @modified_inc, @INC;
224             }
225 0           return @modified_inc;
226             } else {
227 0           return @INC;
228             }
229             }
230              
231             __END__