maintenance/module_usage.pl

   1 #!/usr/bin/perl -w
   2 #
   3 # Counts up all the used and inherited modules in a directory of modules to
   4 # help indicate which the most important modules are, graphs it also
   5 #
   6 # Written by Sendu Bala, using much code directly from
   7 # http://www.perlmonks.org/?displaytype=displaycode;node_id=87329
   8 # and also
   9 # http://search.cpan.org/src/NEILB/pmusage-1.2/pmusage
  10
  11 use strict;
  12 use warnings;
  13
  14 use IO::File;
  15 use File::Find;
  16 use Getopt::Std;
  17 use GraphViz;
  18
  19 sub usage
  20 {
  21         print <<EOF;
  22 $0 -- Shows which modules are used the most in a directory of modules
  23
  24 usage: $0 [-f outfile] [-l listfile] [-h] [-v] [dir]
  25 -f outfile   specify output file (default=module_usage)
  26 -h           get this help message
  27 -i fmt       set image format to fmt (default=jpeg)
  28              also available: canon,text,ps,hpgl,pcl,mif,pic,gd,gd2,gif,jpeg,
  29              png,wbmp,vrml,vtx,mp,fig,svg,plain *nb* only jpeg is tested as
  30                          working correctly
  31 -l listfile  get filenames/options from listfile
  32 -v           list filenames to STDERR
  33
  34 If directory names are given, all the *.p[lm] files in the directory will
  35 be processed. The default is to do all the Perl files in the current directory.
  36
  37
  38 The graphical output is a *simplification with information loss*, since BioPerl
  39 is too complex to graph 'raw'. The simplification proceeds as follows:
  40 # It is determined which modules each BioPerl package (aka class, module)
  41   'uses' (what modules does it load via 'use', 'require' or inherit from
  42   via 'use base', excluding external (non-BioPerl) modules).
  43 # Packages with identical usage (ignoring the type of usage) are grouped
  44   together.
  45 # The graph shows all the groups with more than one member as nodes, with edges
  46   from them pointing to the individual packages that they use.
  47 # The set of those individual packages pointed to by groups also have edges
  48   showing their use-relationship to other members of the set (only).
  49 # Members of that set are also shaded in red. The saturation of the shade
  50   indicates how many packages use that package (so dark red packages are used a
  51   lot).
  52 # Edges are coloured green to show inheritance-type usage, or blue to show
  53   'use'/'require'-type usage. It is possible that some members of a group
  54   inherit from a particular package, whilst other members only 'use' it. In that
  55   case, the colour is based on which is most common for the group.
  56 # Groups with members all from the same subdirectory, and individual packages
  57   pointed to by groups, are 'clustered' if they are from the same subdirectory
  58 EOF
  59         exit shift;
  60 }
  61
  62 # process cmdline options
  63 my $opts = 'f:l:hvi:';
  64 my %opts;
  65 getopts($opts, \%opts) || usage(1);
  66 usage(0) if defined($opts{h});
  67 while (defined($opts{l})) {
  68         my $lFile = IO::File->new($opts{l}) or die "can't open -l file $opts{l} : $!\n";
  69         my @largs = <$lFile>;
  70         chomp(@largs);
  71         splice(@ARGV, 0, 0, @largs);
  72         delete($opts{l});
  73         getopts($opts, \%opts) || usage(1);
  74         $lFile->close();
  75 }
  76
  77 my $outfile = defined($opts{f}) ? $opts{f} : "module_usage";
  78 my $format = defined($opts{i}) ? $opts{i} : 'jpeg';
  79
  80 # now filenames are in @ARGV
  81 push(@ARGV, '.') if !@ARGV;
  82
  83 my @files;
  84 my %sections;
  85
  86 sub findPerlFiles {
  87         -f $_ && /^.*\.p[ml]\z/si && push(@files, $File::Find::name);
  88 }
  89
  90 # process directories
  91 foreach my $top (@ARGV) {
  92         File::Find::find({wanted => \&findPerlFiles}, $top);
  93 }
  94
  95 my %usage;
  96 my %users;
  97 my %inheritance;
  98 my %packages;
  99
 100 sub store_package_usage {
 101     my ($package, $used) = @_;
 102     my %used = %{$used};
 103
 104     STDERR->print("package $package used (".join(' ', keys %used).")\n") if $opts{v};
 105
 106     $packages{$package} = \%used;
 107
 108     foreach my $module (keys %used) {
 109         $usage{$module}++;
 110         push (@{$users{$module}}, $package);
 111     }
 112 }
 113
 114 foreach my $file (@files) {
 115         $file =~ s#^./##;
 116         STDERR->print("processing $file\n") if $opts{v};
 117         my $f = IO::File->new($file) or warn "can't open $file: $!\n", next;
 118
 119         my ($package, %used);
 120
 121         my $pod = 0;
 122         while (<$f>) {
 123                 if (/^=cut/) {
 124                         $pod=0;
 125                         next;
 126                 }
 127                 if (/^=[a-zA-Z]+/) {
 128                         $pod=1;
 129                         next;
 130                 }
 131                 next if $pod;
 132
 133                 if (/^\s*package\s+([[:word:]:]+)\s*;/) {
 134             if ($package) {
 135                 store_package_usage($package, \%used);
 136                 %used = ();
 137             }
 138
 139                         $package = $1;
 140                         next;
 141                 }
 142                 if (/use base\s*(.*)/) {
 143                         my $tmp = $1;
 144                         while (!/;/)    # accumulate ISA value for multiple lines
 145                         {
 146                                 $_ = <$f>;
 147                                 $tmp .= $_;
 148                         }
 149                         my @use_base = eval $tmp;
 150                         if ($@) { warn "Unparseable 'use base' line for $package: $tmp"; next }
 151
 152             foreach my $module (@use_base) {
 153                 $used{$module} = 1;
 154                                 $inheritance{$package}->{$module} = 1;
 155             }
 156                 }
 157                 elsif (/^\s*use\s+([^\s;()]+)/ || /^\s*require\s+([^\s;()'"]+)/) {
 158             $used{$1} = 1;
 159                 }
 160         }
 161         $f->close();
 162
 163     if ($package) {
 164         store_package_usage($package, \%used);
 165     }
 166 }
 167
 168 # simplify so we can view a graph of usage: we group all packages that have
 169 # identical usage. NB: this doesn't look at external modules at all
 170 my %groups;
 171 while (my ($package, $used_hash) = each %packages) {
 172     my @used_packages;
 173     foreach my $used_module (sort keys %{$used_hash}) {
 174         next unless defined $packages{$used_module};
 175         push(@used_packages, $used_module);
 176     }
 177     @used_packages || next;
 178
 179     push(@{$groups{join('|', @used_packages)}}, $package);
 180 }
 181
 182 # we're going to shade boxes based on usage later, figure out an appropriate
 183 # shade range by ranking
 184 my %counts;
 185 while (my ($group, $pack_list) = each %groups) {
 186     my @children = @{$pack_list};
 187
 188     @children > 1 || next;
 189
 190     my @parents = split(/\|/, $group);
 191     foreach my $parent (@parents) {
 192         my $count = $usage{$parent};
 193         $counts{$parent} = $count;
 194     }
 195 }
 196 my %ranks;
 197 my $rank = 0;
 198 my $prev_count;
 199 foreach my $parent (sort { $counts{$a} <=> $counts{$b} } keys %counts) {
 200     my $this_count = $counts{$parent};
 201     $ranks{$parent} = $prev_count && $prev_count != $this_count ? ++$rank : $rank;
 202     $prev_count = $this_count;
 203 }
 204
 205 sub class_to_subdir {
 206     my $class = shift;
 207     $class =~ s/::[^:]+$//;
 208     return $class;
 209 }
 210
 211 my $g = GraphViz->new(concentrate => 1,
 212                       node => {shape => 'box'},
 213                       $format eq 'ps' ? (pagewidth => 46.81, pageheight => 33.11) : ()); # A0 for ps output
 214 my $inherited_edge_colour = 'green';
 215 my $used_edge_colour = 'blue';
 216 my $cluster_colour = 'black'; #*** darkgray, 0,0,0.31 don't work, why?!
 217 my $child_id = 0;
 218 my $group_definitions = '';
 219 my %parents;
 220 while (my ($group, $pack_list) = each %groups) {
 221     my @children = @{$pack_list};
 222
 223     # ignore single child groups (required or graph gets too wide to jpeg)
 224     @children > 1 || next;
 225
 226     # we'll cluster if all children belong to the same subdirectory
 227     my %subdirs;
 228     foreach my $child (@children) {
 229         $subdirs{class_to_subdir($child)} = 1;
 230     }
 231     my $subdir;
 232     if (keys %subdirs == 1) {
 233         ($subdir) = keys %subdirs;
 234         undef $subdir if $subdir eq 'Bio';
 235     }
 236
 237     my $this_child = 'group'.++$child_id;
 238     $g->add_node($this_child,
 239                  style => 'dashed',
 240                  label => "$this_child:\n".join("\n", @children),
 241                  $subdir ? (cluster => {name => $subdir, style => 'dotted', color => $cluster_colour}) : ());
 242
 243     my @parents = split(/\|/, $group);
 244
 245     $group_definitions .= "  $this_child consists of ".scalar(@children)." packages: ".join(', ', @children)."\n  $this_child members use ".scalar(@parents)." other packages: ".join(', ', @parents)."\n\n";
 246
 247     foreach my $parent (@parents) {
 248         # we'll shade the parent box based on how many packages use it
 249         my $this_rank = $ranks{$parent};
 250         my $shade = (1 / $rank) * $this_rank;
 251
 252                 # we'll colour the edge based on if we inherited this parent or just
 253                 # used it, going by the most common for the group
 254                 my ($inherited, $used) = (0, 0);
 255                 foreach my $child (@children) {
 256                         if (defined $inheritance{$child}->{$parent}) {
 257                                 $inherited++;
 258                         }
 259                         else {
 260                                 $used++;
 261                         }
 262                 }
 263                 my $edge_colour = $inherited > $used ? $inherited_edge_colour : $used_edge_colour;
 264
 265         # we'll cluster if this isn't a base Bio::x class
 266         my $subdir = class_to_subdir($parent);
 267         undef $subdir if $subdir eq 'Bio';
 268
 269         $g->add_node($parent,
 270                      style => 'filled',
 271                      fillcolor => "0,$shade,1",
 272                      $subdir ? (cluster => {name => $subdir, style => 'dotted', color => $cluster_colour}) : ());
 273         $parents{$parent} = 1;
 274         $g->add_edge($this_child => $parent, color => $edge_colour);
 275     }
 276 }
 277
 278 # show links between parents
 279 foreach my $parent (keys %parents) {
 280     my %used = %{$packages{$parent}};
 281
 282     foreach my $used (keys %used) {
 283         next unless defined $parents{$used};
 284         $g->add_edge($parent => $used, color => defined $inheritance{$parent}->{$used} ? $inherited_edge_colour : $used_edge_colour);
 285     }
 286 }
 287
 288 # write out graph
 289 my $output = IO::File->new($outfile.".$format", 'w') or die "can't open $outfile.$format: $!\n";
 290 $output->print(eval "\$g->as_$format()");
 291 $output->close();
 292
 293
 294 my $package_count = keys %packages;
 295 my $total_used = keys %usage;
 296
 297 my $results_str = "Packages investigated: $package_count\nTotal modules used: $total_used\n\n";
 298
 299
 300 # descriptive text output
 301 # list by popularity
 302 my @internal;
 303 my @external;
 304 foreach my $module (sort { $usage{$b} <=> $usage{$a} || $a cmp $b } keys %usage) {
 305     my $count = $usage{$module};
 306
 307     if (defined $packages{$module}) {
 308         push(@internal, "  $module => used $count times");
 309     }
 310     else {
 311         my $by = '';
 312         if ($count <= 5) {
 313             $by = " by ".join(", ", @{$users{$module}});
 314         }
 315         push(@external, "  $module => used $count times$by");
 316     }
 317 }
 318
 319 $results_str .= "External module usage:\n".join("\n", @external);
 320 $results_str .= "\n\nPackage usage:\n".join("\n", @internal);
 321
 322 # list the packages that aren't used by any other package
 323 $results_str .= "\n\nPackages not used by any other:\n";
 324 foreach my $package (sort keys %packages) {
 325     next if $usage{$package};
 326     $results_str .= "  $package\n";
 327 }
 328
 329 # define the groups referenced in the graph
 330 $results_str .= "\nGroup definitions:\n$group_definitions";
 331
 332 # write out descriptive text file
 333 $output = IO::File->new($outfile.'.txt', 'w') or die "can't open $outfile.txt: $!\n";
 334 $output->print($results_str);
 335 $output->close();
 336
 337 exit;