http://www.perlmonks.org?node_id=278901

   1: # (Please move this node if it belongs in Snippets or something)
   2: #
   3: # This little program will print a prettified inheritance
   4: # tree for the given perl module.  Its usage is:
   5: # perl-inheritance [<options>] <module-name>
   6: # e.g.: perl-inheritance Class::DBI
   7: #
   8: # Available options are:
   9: # -I<path> : include <path> in @INC
  10: # -a : attempt to use all modules instead of just the root one
  11: # -i : ignore modules that can't be found
  12: #
  13: # Some example output:
  14: # perl-inheritance Class::DBI
  15: # Class::DBI (v0.93)
  16: # +---Class::DBI::__::Base (v-1, set by base.pm)
  17: #     +---Class::Data::Inheritable (v0.02)
  18: #     +---Class::Accessor (v0.18)
  19: #     +---Ima::DBI (v0.29)
  20: #         +---Class::WhiteHole (v0.04)
  21: #         +---DBI (v1.37)
  22: #         |   +---Exporter (v5.567)
  23: #         |   +---DynaLoader (v1.04)
  24: #         +---Class::Data::Inheritable (loaded by Class::DBI::__::Base)
  25: #
  26: # perl-inheritance Net::FTP
  27: # Net::FTP (v2.71)
  28: # +---Exporter (v5.567)
  29: # +---Net::Cmd (v2.24)
  30: # |   +---Exporter (loaded by Net::FTP)
  31: # +---IO::Socket::INET (v1.26)
  32: #     +---IO::Socket (v1.27)
  33: #         +---IO::Handle (v1.21)
  34: #             +---Exporter (loaded by Net::FTP)
  35: 
  36: #!/usr/local/bin/perl -w
  37: use warnings;
  38: use strict;
  39: no strict 'refs';
  40: 
  41: my @ignore_list      = ();
  42: my $ignore_not_found = 0;
  43: my %already_loaded   = ();
  44: my $load_all         = 0;
  45: 
  46: ARG: while (@ARGV) {
  47:   SWITCH: {
  48:     ($ARGV[0] =~ /\-I(.+)/o) && do {
  49:       eval "use lib '$1';";
  50:       shift @ARGV;
  51:      last SWITCH;
  52:     };
  53:     ($ARGV[0] =~ /\-i$/o) && do {
  54:       $ignore_not_found = 1;
  55:       shift @ARGV;
  56:      last SWITCH;
  57:     };
  58:     ($ARGV[0] =~ /\-a$/o) && do {
  59:       $load_all = 1;
  60:       shift @ARGV;
  61:      last SWITCH;
  62:     };
  63:     ($ARGV[0] =~ /\-i=(.+)/o) && do {
  64:       @ignore_list = split " ", $1;
  65:       shift @ARGV;
  66:      last SWITCH;
  67:     };
  68:    last ARG;
  69:   } ## end SWITCH:
  70: } ## end while (@ARGV)
  71: 
  72: if (!@ARGV) {
  73:   print STDERR "Usage: $0 <perl modules>\n";
  74:   exit 1;
  75: }
  76: 
  77: foreach (@ARGV) {
  78:   %already_loaded = ();
  79:   ScanModule(undef, $_, 0);
  80: }
  81: 
  82: sub ScanModule {
  83:   my $parent  = shift;
  84:   my $module  = shift;
  85:   my $depth   = shift;
  86:   my @total   = @_;
  87:   my $ignored = 0;
  88:   my $loaded  = 0;
  89: 
  90:   $loaded = 1 if (exists $already_loaded{$module});
  91: 
  92:   eval "use $module" if (!defined $parent || $load_all);
  93:   if ($@ =~ /Can't locate .+ in \@INC/o) {
  94:     if ($ignore_not_found
  95:       || index("@ignore_list ", "$module ") != -1) {
  96:       $ignored = 1;
  97:       } else {
  98:       die "Error using $module: $@\n";
  99:     }
 100:   } elsif ($@) {
 101:     die "Error using $module: $@\n";
 102:   }
 103: 
 104:   if ($depth > 1) {
 105:     for (my $iter = 0; $iter < @total - 2; $iter += 2) {
 106:       if ($total[$iter] < $total[$iter + 1]) {
 107:         print "|   ";
 108:       } else {
 109:         print "    ";
 110:       }
 111:     } ## end for (my $iter = 0; $iter...
 112:   } ## end if ($depth > 1)
 113: 
 114:   if ($depth > 0) {
 115:     print "+---";
 116:   }
 117: 
 118:   print $module;
 119:   print " (ignored)" if ($ignored);
 120:   if ($loaded) {
 121:     print " (loaded by $already_loaded{$module})\n";
 122:   } else {
 123:     my $version = $module->VERSION();
 124:     print " (v$version)" if $version;
 125:     print "\n";
 126:     my $isa   = "${module}::ISA";
 127:     my $count = 1;
 128:     my $total = @$isa;
 129: 
 130:     foreach (@$isa) {
 131:       ScanModule($module, $_, $depth + 1, @total, $count, $total);
 132:       $count++;
 133:     }
 134:     $already_loaded{$module} = $parent;
 135:   } ## end else [ if ($loaded)
 136: } ## end sub ScanModule