File Coverage

blib/lib/Tk/PerlInheritanceTree.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

#!/usr/bin/perl

=head1 NAME

Tk::PerlInheritanceTree - Display a graphical representation of the inheritance tree for a given class-name.

=head1 SYNOPSIS


  require Tk::PerlInheritanceTree;
  ...
  my $inheritance_tree = $main_window->PerlInheritanceTree()->pack;

  $inheritance_tree->classname('Tk::MainWindow');



=head1 DESCRIPTION

Tk::PerlInheritanceTree displays a graphical representation of the inheritance tree for a given class(package)-name. The nodes representing classnames have mouseclick bindings to open a Tk::PerlMethodList - widget. Tk::PerlInheritanceTree is a Tk::Frame-derived widget.

PerlInheritanceTree.pm can be run as stand-alone application (see Examples section)



=head1 SEE ALSO

Documentation of Tk::PerlMethodList.

=head1 METHODS

B supports the following methods:

=over 4

=item B'A::Classname'B<)>

Set the Classname-Entry to 'A::Classname' and show_classtree.

=item B

Display a tree for the given classname

=back


=head1 OPTIONS

B supports the following options:

=over 4

=item B<-classname>

configure(-classname=>'A::Classname')
same as method classname()

=item B<-gridsize>

configure(-gridsize=>$size)
Set the distance between nodes to $size pixels. Defaults to 120.

=item B<-multiple_methodlists>

configure(-multiple_methodlists=>bool)
Allows multiple instances of PerlMethodList to be opened if set to a true value. Defaults to 0.

=back


=head1 EXAMPLES

  Run PerlInheritanceTree from the console:

  perl -MTk::PerlInheritanceTree -e'Tk::PerlInheritanceTree::_test_'

  or:

  perl -MTk::PerlInheritanceTree -e'Tk::PerlInheritanceTree::_test_(shift)' Tk::Menu



=head1 AUTHOR

Christoph Lamprecht, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006-2008 by Christoph Lamprecht

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.



=cut
package Tk::PerlInheritanceTree;
our $VERSION = 0.05;
use warnings;
use strict;
require Class::Inspector;

require Tk;
require Tk::NumEntry;
require Tk::GraphItems::TextBox;
require Tk::GraphItems::Connector;
require Tk::PerlMethodList;
use base 'Tk::Frame';

use Data::Dumper;

Tk::Widget->Construct('PerlInheritanceTree');
unless (caller()){_test_()}

sub Populate{
  my ($self,$args)=@_;
  $self->SUPER::Populate($args);
  my $can = $self->Scrolled('Canvas',
                            -scrollregion=> [qw/0 0 200 200/]
                        )->pack(-expand =>1,
                                -fill   =>'both'
                            );
  my $c = $can->Subwidget('scrolled');
  $self->{canvas}=$c;

  $self -> _setup_bindings;
  my $bottom_f  = $self->Frame->pack(-fill   => 'x',
                                #     -expand => 1,
                                 );

  $self -> Label(-textvariable=>\$self->{status},
                 -relief      =>'sunken'
             )->pack(-fill   => 'x',
                      #   -expand => 1,
                         -padx   => 10
                     );
  my $bottom_left  = $bottom_f->Frame->pack(-side => 'left',
                                            -padx => 10,
                                        );
  my $bottom_right = $bottom_f->Frame->pack(-side => 'left',
                                            -padx => 10,
                                        );

  my $en = $bottom_left->Entry(-textvariable=>\$self->{class}
                           )->pack(-side =>'left',
                             );
  my $bt = $bottom_left->Button(-text    => 'Classtree',
                                -command => sub {$self->show_classtree()}
                       )->pack(-side =>'left',
                               -padx => 10,
                           );
  $bottom_right->Label(-text => 'Gridsize:',
                   )->pack(-side => 'left',
                           -padx => 5,
                       );
  $self->{gridsize} =$args->{'-gridsize'} ||= 120;
  my $ne;
  $ne = $bottom_right->NumEntry(-minvalue     => 80,
                                -maxvalue     => 200,
                                -increment    => 20,
                                -width        => 4,
                                -readonly     => 1,
                                -textvariable => \$self->{gridsize},
                                -browsecmd    => [$bt,'invoke'],
                                )->pack(-side => 'left',
                                    );

  $en->bind('',sub{$bt->Invoke});
  $self->ConfigSpecs(-background          => [$c],
                     -classname           => ['METHOD'],
                     -multiple_methodlists=> ['PASSIVE','','',0],
                     -gridsize            => ['METHOD','','',$self->{gridsize}],
                     DEFAULT              => [$c],
                 );

  $self;
}

sub _setup_bindings{
  my $self = shift;
  my $c =  $self->{canvas};

  ####create a Tk::GraphItems instance to set bindings###
  my $dummy = Tk::GraphItems::TextBox->new(text=>'',
                                           x   =>0,
                                           y   =>0,
                                           canvas=>$c);
  $dummy->bind_class('<3>',sub{$self->node_clicked($_[0])});
  $dummy->bind_class('',sub{$self->node_clicked($_[0])
                                                 unless $_[0]->was_dragged});
}

sub _build_classtree{
  my ($self,$row,$nr_nodes,$class,$succ,$succ_node) = @_;

  $succ ||= $self->{tree}||={};
  $succ->{$class}={};
  $self->{nodes}[$row]||=[];
  my $col = (scalar@{$self->{nodes}[$row]}) +1;
  my $node = Tk::GraphItems::TextBox->new(canvas =>  $self->{canvas},
                                          text   =>  $class,
                                          y      => 150,
                                          x      => 150,
                                      );

  push @{$self->{nodes}[$row]} , $node;
  if ($node && $succ_node){
    Tk::GraphItems::Connector->new(source => $node,
                                   target => $succ_node)
  }
  no strict 'refs';
  my @parents = @{$class."::ISA"};
  use strict;
  $row++;
  for my $parent(@parents){
    $self->_build_classtree($row,scalar@parents,$parent,$succ->{$class},$node);
  }
}
sub _place_nodes{
  my $self = shift;
  my $rows = @{$self->{nodes}};
  my $gridsz = $self->cget('-gridsize');
  my $bottom = ($rows-0.5)*$gridsz;
  my $max_cols= 1 ;
  for my $row(@{$self->{nodes}}){
    $max_cols = @$row if @$row>$max_cols;
  }
  my $center = ($max_cols+1) /2 *$gridsz;
  my $row = 0;
  for my $nodes ( @{$self->{nodes}}){
    my $cols = @$nodes;
    my $col = 0;
    for my $node(@$nodes){
      $node->set_coords($center +(($col-($cols-1)/2)* $gridsz),
                        $bottom - $row * $gridsz);
      $col++;
    }
    $row++;
  }
  $self->{canvas}->configure(-scrollregion=>[0,
                                             0,
                                             $center*2,
                                             $bottom+ .5*$gridsz]);
}
sub classname{
  my ($self,$class) = @_;
  $self->{class} = $class;
  $self->show_classtree;
}
sub gridsize{
    my $self = shift;
    $self->{gridsize} = $_[0] if ($_[0]);
    return $self->{gridsize};
}
sub show_classtree{
    my ($self) = @_;
    my $class = $self->{class};
    return unless ($class);
    eval "require $class";

        unless (Class::Inspector->loaded($class)){
        $self->{status} = "Error: Package '$class' not found !";
        return;
    }

    $self->{status} = "Showing inheritance tree for class '$class'";
    $self->{tree} = {};
    $self->{nodes}= [];
    $self->_build_classtree(0,1,$class);
    $self->_place_nodes;
    $self->_place_nodes;
}
sub node_clicked{
  my ($self,$node) = @_;
  my $text = $node->text;
  my $mml = $self->cget('-multiple_methodlists');
  my $ml = $self->{m_list};
  unless ($ml && $ml->Exists){
    $ml = $self->PerlMethodList;
  }

  $ml->configure(-classname=>$text,
                 -filter   =>'');
  $ml->show_methods;
  $ml->deiconify;
  $ml->focus;
  if (!$mml){
    $ml->protocol("WM_DELETE_WINDOW",sub{$ml->withdraw});
    $self->{m_list} = $ml;
  }else{
    $ml->protocol("WM_DELETE_WINDOW",'');
  }
}

sub _test_{

  my $mw = Tk::tkinit();
  my @cln;
  @cln = (-classname => $_[0]) if $_[0];
  my $cg =$mw->PerlInheritanceTree(@cln)
    ->pack(-fill   => 'both',
           -expand => 1);
  Tk::MainLoop();
}
1;
__END__