Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

Prettified Perl Inheritance

by Kageneko (Scribe)
on Jul 29, 2003 at 17:40 UTC ( [id://278901]=perlcraft: print w/replies, xml ) Need Help??

   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

Replies are listed 'Best First'.
Re: Prettified Perl Inheritance
by bsb (Priest) on Aug 03, 2003 at 07:01 UTC
    See also GraphViz::ISA and pmload in pmtools (basic).

    Diamond inheritence will get tree-ified won't it?

    Also, use/require already remembers loaded modules in %INC:

    $ perl -MDBI -le '$,="\n"; print %INC' warnings/register.pm /usr/share/perl/5.8.0/warnings/register.pm Carp.pm /usr/share/perl/5.8.0/Carp.pm Exporter/Heavy.pm /usr/share/perl/5.8.0/Exporter/Heavy.pm strict.pm /usr/share/perl/5.8.0/strict.pm continues ...

      Hmm, I haven't done any testing with diamond inheritance. I know that I setup the code to not follow an inheritance tree more than once, so it wouldn't get into infinite loops.

      The reason I didn't use %INC for testing whether a module was loaded was because I wanted to record which module had loaded it first (well, in the tree-scheme of things :) and didn't really care where the file existed.

      Thanks for the tip (and thanks to PodMaster for his) regarding the graphing modules.
Re: Prettified Perl Inheritance
by metaperl (Curate) on Jul 07, 2011 at 22:16 UTC

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others browsing the Monastery: (3)
As of 2024-03-29 07:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found