File Coverage

blib/lib/Tk/PerlMethodList.pm

Criterion	Covered	Total	%
statement	21	257	8.1
branch	0	54	0.0
condition	0	29	0.0
subroutine	7	37	18.9
pod			n/a
total	28	377	7.4

#! /usr/bin/perl

package Tk::PerlMethodList;
our $VERSION = 0.07;

use warnings;
use strict;
#use Data::Dumper;
use File::Slurp qw /read_file/;
require Tk;
require Tk::LabEntry;
require Tk::NumEntry;
require Tk::ROText;
require Class::Inspector;
require B ;
use MRO::Compat;
use Devel::Peek qw(CvGV);
our @ISA    = ('Tk::Toplevel');

=head1 NAME

Tk::PerlMethodList - query the Symbol-table for methods (subroutines) defined in a class (package) and its parents.

=head1 SYNOPSIS


require Tk::PerlMethodList;

my $instance = $main_window->PerlMethodList();

=head1 DESCRIPTION

Tk::PerlMethodList is a Tk::Toplevel-derived widget.

The window contains entry fields for a classname and a regex. The list below displays the subroutine-names in the package(s) of the given classname and its parent classes. The list displays the sub-names present in the the symbol-table. In case of imported subs, the last field of a row contains the name of the aliased sub as reported by DevelPeek::CvGV. Tk::PerlMethodList will not show subs which can be - but have not yet been autoloaded. It will show declared subs though. The 'Filter' entry takes a regex to filter the returned List of sub/methodnames.

If the file containing a subroutine definition can be found in %INC, a green mark will be displayed at the beginning of the line. The sourcecode will be displayed by clicking on the subs list-entry.


Method list and source window have Control-plus and Control-minus bindings to change fontsize.



=head1 METHODS

B supports the following methods:

=over 4

=item B'A::Class::Name'B<)>

Set the classname-entry to 'A::Class::Name'.

=item B'a_regex'B<)>

Set the filter-entry to 'a_regex'.

=item B

Build the list for classname and filter present in the entry-fields.

=back

=head1 OPTIONS

B supports the following options:

=over 4

=item B<-classname>

$instance->configure(-classname =>'A::Class::Name')
Same as classname('A::Class::Name').

=item B<-filter>

$instance->configure(-filter =>'a_regex')
Same as filter('a_regex').


=back

=head1 AUTHOR

Christoph Lamprecht, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006-2007 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


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

sub Populate{
    my ($self,@args) = @_;
    $self->SUPER::Populate(@args);
    my $frame    = $self -> Frame()->pack(-fill => 'x',
                                          -padx => 20,
                                          -pady => 4,
                                      );
    my $fr_left  = $frame-> Frame()->pack(-side => 'left',
                                          -fill => 'y');
    my $fr_mid = $frame-> Frame(-relief      => 'sunken',
                                  -borderwidth => 2,
                              )->pack(-side => 'left',
                                      -padx => 10);
    my $fr_right  = $frame-> Frame()->pack(-side => 'left',
                                           -fill => 'y',
                                           -padx => 20);

    my $fr_overr = $fr_left->Frame()->pack(-anchor => 'nw',
                                           -pady   => 1
                                       );
    my $fr_source= $fr_left->Frame()->pack(-anchor => 'nw',
                                           -pady   => 1,
                                       );
    $fr_overr->Label(-width => 1,
                     -bg    => 'orange')->pack(-side => 'left');
    $fr_overr->Label(-text  => 'overridden if called as a method',
                 )->pack(-side => 'left');
    $fr_source->Label(-width => 1,
                      -bg    => 'green')->pack(-side => 'left');
    $fr_source->Label(-text  => 'sourcecode can be displayed',
                 )->pack(-side => 'left');
    my @btn_data = (['Classname',\$self->{classname}],
                    ['Filter'   ,\($self->{filter}||='')]);

    @$self{qw/entry_cl entry_f/}=
        map {my $e = $fr_mid -> LabEntry(-label       => $_->[0],
                                         -textvariable=> $_->[1],
                                         -labelPack   => [-side=>'left'],
                                    ) ->pack(-anchor => 'e');
             $e->Subwidget('entry')->configure(-background => 'white');
             $e;
         } @btn_data;


    my $btn   = $fr_mid -> Button (-text   => 'show methods',
                                     -command=> sub{$self->show_methods}
                                 )->pack;
    my $text  = $self -> Scrolled('ROText',
                                  -wrap         => 'none',
                                  -insertontime => 0,
                              )->pack(-fill   => 'both',
                                      -expand => 1,
                                  );
    my $font  = $self -> fontCreate(-family => 'Courier',
                                    -size   => 12,
                                );
    $text->configure(-font=>$font);
    $text->tagConfigure('overridden',-background => 'orange');
    $text->tagConfigure('source_ok' ,-background => 'green');
    $text->tagConfigure('white'     ,-background => 'white');

    $text->menu(undef);         #disable

    $self -> Label(-textvariable=>\$self->{status})->pack;

    $fr_right->Label(-text => 'Fontsize:',
                 )->pack(-side => 'left',
                         -padx => 10,
                         );
    my $ne;
    $ne  = $fr_right->NumEntry(-minvalue => 8,
                               -maxvalue => 16,
                               -value    => 12,
                               -width    => 3,
                               -readonly => 1,
                               -browsecmd=> sub{
                                   $self->_change_fontsize($ne->cget('-value'))
                               },
                           )->pack(-side => 'left');

    $text->bind('',sub{$ne->incdec(1)});
    $text->bind('',sub{$ne->incdec(-1)});
    $text->bind('<1>',sub{$self->_text_click});
    $text->bind('',sub {$self->_adjust_selection});
    for my $w (@$self{qw/entry_cl entry_f/}) {
        $w->bind('',sub{$btn->Invoke});
    }
    $text->focus;

    @$self{qw/text font list/}= ($text,$font,[]);

    $self->ConfigSpecs(-background  => [$text,'','','white'],
                       -classname   => ['METHOD'],
                       -filter      => ['METHOD'],
                       DEFAULT      => ['SELF'],
                   );
    return $self;
}

sub _adjust_selection{
    my $self = shift;
    my $w = $self->{text};
    $w->unselectAll;
    $w->adjustSelect;
    $w->selectLine;
}

sub _change_fontsize{
    my $self = shift;
    my $size = $_[0];
    my ($text,$font) = @$self{qw/text font/};
    $text->fontConfigure($font,'-size',$size);
}


sub _text_click{
    my $self = shift;
    my $w    = $self->{text};
    my $position = $w->index('current');
    my $line;
    if ($position =~ m/^(\d+)\./) {
        $line = $1;
    } else {
        return
    }
    my $idx  = $line - 1; #line range starts at 1

    my $file = $self->{list}[$idx]{file};
    my $methodname = $self->{list}[$idx]{sourcesymbol};
    my $re = qq/sub\\s+$methodname(\\W.*)?\$/;
    $self->_start_code_view($file,$re);
}

sub _get_methods{
    my $self = shift;
    my $class_name = $self->{classname};
    my $filter = $self->{filter};
    my $regex = qr/$filter/i ;

    my @function_list;
    my $classes = mro::get_linear_isa($class_name);
    my %overridden;
    foreach my $class (@$classes) {
        no strict 'refs';
        my @list;
        my $s_t_r = \%{$class."::"};
        use strict ;
        foreach my $key ( keys %$s_t_r) {
            next unless ($key =~ $regex);
            my $var =  \ ( $s_t_r->{$key} );
            my $state;
            ref $var eq 'GLOB' && *{$var}{CODE}
                && ($state = 'declared')
                && defined &{*{$var}{CODE}} && ($state = 'defined');

            ref $var eq 'SCALAR' && $$var == -1 && ($state = 'declared');

            if ($state) {
                my $overridden = $overridden{$key} || 0;
                my $definition = '';
                my $file = '';
                if ($state eq 'defined'){
                    $definition .= CvGV(*{$var}{CODE});
                    my $o = B::svref_2object(*{$var}{CODE});
                    $file = $o->FILE;# to do: fix .al
                }
                $overridden{$key} = 1;
                push @list , {symbol       => $key,
                              state        => $state,
                              package      => $class,
                              overridden   => $overridden,
                              defined_as   => $definition,
                              file         => $file,
                          };
            }
        }
        @list = sort {lc $a->{symbol}cmp lc $b->{symbol}} @list;
        push @function_list,@list;
    }
    $self->{list} = \@function_list;
    return $self;
}

sub _grep_sources{
    my $self = shift;
    my $list = $self->{list};
    $self->_set_source_fields;
    my $last_filename = '';
    my $module_source = '';
    for my $element (@$list) {

        my $converted    = $self-> _convert_filename($element->{file});
        $element->{file} = $converted if  $converted;
        unless ($element->{file}){
            # fallback: check package file for autosplit defs
            $element->{file}
                = $self-> _convert_packagename($element->{package});
        }
        my $filename = $element->{file};
        next unless $filename;
        if ($filename && ($filename ne $last_filename)){
            $module_source = read_file($filename, err_mode=>'quiet') || '';
            $last_filename = $filename;
        }
        my $symbol = $element->{sourcesymbol};
        $element->{source_avail}
            = ($module_source =~/sub\s+$symbol(\W.*)?$/m)?
                1 : 0;

    }
    return $self;
}

sub _set_source_fields{
    my $self = shift;
    my $list = $self->{list};
    for my $element (@$list) {
        if ($element->{defined_as} =~ /\*(.*)::(.*)$/){
            $element->{sourcepackage} = $1;
            $element->{sourcesymbol}  = $2;
            $element->{defined_as} =~ s/^\*/alias to:  /;
        }
        my $is_alias = 0;
        for (qw/symbol package/){
            $element->{"source$_"}||= $element->{$_};
            unless($element->{$_} eq $element->{"source$_"}){
               # $defined_as = $element->{defined_as};
                $is_alias = 1;
                last;
            }
        }
        $element->{defined_as} = '' unless $is_alias;
    }
}


sub show_methods{
    my $self = shift;
    my ($text,$classname) = @$self{qw/text classname/};
    $text->delete('1.0','end');
    $self->{indexmap} = [];

    eval "require $classname";
    # now check if package $classname is loaded -
    # package $classname needn't be defined in the required file...


    unless (Class::Inspector->loaded($classname)) {
        $self->{list}= [];
        $self->{status}="Error: package '$classname' not loaded!";
        return;
    }

    $self->{status}="Showing methods for '$classname'";

    $self->{inc_files} = {map {$INC{$_}, 1} keys(%INC)};

    $self->_get_methods
         ->_grep_sources;
    my $list = $self->{list};
    my %max_width = ( symbol     => 0,
                      package    => 0,
                      defined_as => 0,
                      file       => 0,
                  );
    for my $element (@$list) {
        map {my $length = length($element->{$_})+2;
             $max_width{$_} =  $length if $length > $max_width{$_};
         } qw/symbol package defined_as file/;
    }
    for my $element (@$list) {
            my $line = sprintf( '%-'.$max_width{package}.'s'
                               .'%-'.$max_width{symbol}.'s'
                               .'%-'.$max_width{file}.'s'
                               .'%-12s'
                               .'%-'.$max_width{defined_as}.'s',

                               $element->{package},
                               $element->{symbol} ,
                               $element->{file},
                               $element->{state},
                               $element->{defined_as},
                           )."\n";
            $text->insert('end',# provide pairs of content, tag:
                          '  ',
                          $element->{overridden} ? 'overridden': 'white',# tag
                           '  ',
                          $element->{source_avail}? 'source_ok': 'white',# tag
                          $line, '');
    }
    return $self;
}

sub _convert_filename{
    my ($self,$filename) = @_;
    my $inc_files = $self->{inc_files};

    my $path_name =  exists ($inc_files->{$filename})? $filename : '';
    # If $filename is not in $inc_files, it might be a .al file:
    unless ($path_name){
        if ($filename =~ m|autosplit into .*lib.auto.(.*\.al)|){
            my $seg = $1;
            $seg =~ y|\\|/|;
            for (keys %$inc_files){
                if ($_ =~ /$seg/){
                    $path_name = $_;
                    last;
                }
            }
        }
    }
    return $path_name;
}
sub _convert_packagename{
    my ($self,$package) = @_;
    $package =~  s#::#/#g;
    $package.='.pm';
    return $INC{$package}||'';
}
sub classname{
    my ($self,$classname) = @_;
    $self->{classname} = $classname if $classname;
    $self->{classname};
}
sub filter{
    my ($self,$filter) = @_;
    $self->{filter} = $filter;
    $filter;
}

sub _start_code_view{
    my $self = shift;
    my ($filename,$regex)=@_;
    return unless $filename;
    my $c_v = $self->{c_v};
    $self->{c_v_entry_filter}= $regex;
    unless ($c_v && $c_v->Exists){
        $self->_code_view_init_top();
        $c_v = $self->{c_v};
    } else {
        $c_v->deiconify;
        $c_v->raise;
    }
    my $text = $self->{c_v_text};
    $text->delete('0.0','end');

    my $content = read_file($filename,
                          err_mode=> 'quiet',
                      );
    unless ($content){
        $self->messageBox(-message => "No file '$filename' found",
                         # -font    => 'Helvetica 14',
                          -title   => 'Error',
                      );
        $c_v->withdraw;
        return;
    }
    $c_v->configure(-title=>$filename);
    $text->insert('end',$content);
    $c_v->focus();
    $self->_c_v_filter_changed() if $regex;
}
sub _code_view_init_top{
    my $self = shift;
    my $c_v = $self->Toplevel();
    my $top_fr = $c_v->Frame()->pack;
    my $frame = $top_fr->Frame()->pack;
    my $text     = $c_v->Scrolled('ROText',
                                  -wrap => 'none',
                                  -bg   => 'white',
                              )->pack(-fill   => 'both',
                                      -expand => 1,
                                  );
    my $entry = $frame ->LabEntry(-label       => 'Filter',
                                  -labelPack   => [-side=>'left'],
                                  -textvariable=>\($self->{c_v_entry_filter}||=''),
                                  -bg          =>'white'
                              )->pack(-side => 'left',
                                      );
    my $font  = $self -> fontCreate(-family => 'Courier',
                                    -size   => 12,
                                );

    $text->configure(-font => $font);

    $entry->bind('',sub {$self->_c_v_filter_changed});

    $frame->Button(-text    =>'Find Next',
                   -command => sub{$self->_c_v_filter_changed},
               )->pack(-side => 'left',
                       -padx => 10);
    $frame->Label(-text => 'Fontsize:')->pack(-side => 'left',
                                             -padx => 10);
    my $ne;
    $ne  = $frame->NumEntry(-minvalue => 8,
                            -maxvalue => 16,
                            -value    => 12,
                            -width    => 3,
                            -readonly => 1,
                            -browsecmd=> sub{
                                   $self->_c_v_change_fontsize(
                                            $ne->cget('-value'))
                               },
                        )->pack(-side => 'left');

    $text->bind('',sub{$ne->incdec(1)});
    $text->bind('',sub{$ne->incdec(-1)});

    @$self{qw/c_v c_v_text c_v_font/} = ($c_v,$text,$font);
    #allow one code_view window only:
    $c_v->protocol("WM_DELETE_WINDOW",sub{$c_v->withdraw});
}
sub _c_v_filter_changed{
    my $self = shift;
    my $text = $self->{c_v_text};
    $text->focus;
    $text->FindNext(-forward=>'-regex','-case',$self->{c_v_entry_filter});
}

sub _c_v_change_fontsize{
    my $self = shift;
    my $size = $_[0];
    my ($text,$font) = @$self{qw/c_v_text c_v_font/};
    $text->fontConfigure($font,'-size',$size);
}

sub _test_{
    my $mw = Tk::tkinit();
    $mw->PerlMethodList(-classname=>'Tk::MainWindow')->show_methods;

    Tk::MainLoop();
}
1;