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