Re^4: Getting methods existing in a Perl Object!

[Ace128]

Ok, that helped. Now, if I add this object: Bah2.pm:

package Bah2;                             
                                          
use lib ".";                              
use Bah;                                  
                                          
use strict;                               
                                          
our @ISA = qw(Bah); # inherits from Bah
                                          
# Create Object class instance            
#my $Object = Object()->new();            
                                          
sub new {                                 
                                          
        my ($class) = @_;                 
        my $self = $class->SUPER::new(@_);
                                          
        $self->{'_bah2'} = 0;             
        return $self;                     
}                                         
                                          
sub printBah2 {                           
        my $self = shift;                 
        print "Bah2\n";                   
}                                         
                                                                      
+              
1

And I modify the test to use Bah2 I get:

Objects = $VAR1 = {                
          'Bah' => [               
                     'new',        
                     'printBah',   
                     'new',        
                     'toString'    
                   ],              
          'Bah2' => [              
                      'new',       
                      'printBah2'  
                    ]              
        };

So, the Object hash is missing! Well, Object's functions are now in Bah though... but would be nice to have the functions in their Object they came from.

Maybe the structure should be redone even more, so its an array with all the objects in the hiarchy. [0] is the current object, [1] one up etc. Or opposite ([0] is the top one, [1] subclass of [0] etc...) Functions may also need to be hashes, to remove duplicates...

What say you?

[liverpole]

Okay, I think I've got the problem fixed now.

Previously, I wasn't inspecting the keys in the hash returned from the recursive call to find_methods, which has been fixed.

I also created 3 new anonymous subroutines, $p_class_syms, $p_class_subs and $p_super_classes, as it didn't feel right to have so much code after the no strict; statement.  Creating those subroutines let me localize no strict; within each, and take it out of the main subroutine, which felt both safer and cleaned up the code, I think.

Update:  I've also changed the program to take advantage of the blessed method in Scalar::Util, as pointed out by chromatic further below.

Update 2:  Minor change suggested by ysth.

use strict;
use warnings;

use lib ".";
use Scalar::Util qw(blessed);
use Bah2;
use Data::Dumper;

my $bah = Bah2->new();

print $bah->toString() . "\n";
$bah->printBah();

# Create anonymous subroutine for generating all methods
my $p_get_methods = find_methods();
my $presults = $p_get_methods->($bah);
printf "Modules = %s\n\n", Dumper($presults);

#
#  find_methods()
#  061226 by liverpole
#  Based on 'methods_via()' from the Perl debugger 'perl5db.pl'.
#
#  Takes 1 argument, a classname (eg. "Bah") or a blessed object (eg. 
+$bah),
#  and returns a hash containing all methods for the given class and a
+ny
#  classes from which it is inherited.  For example:
#
#        {
#           'Bah' => [
#                      'new',
#                      'printBah'
#                    ],
#           'Object' => [
#                         'new',
#                         'test_method',
#                         'toString'
#                       ]
#        };
#
#
sub find_methods {
    my %seen;
    my %methods;

    my $p_class_syms = sub {
        my $class = shift;
        no strict;
        return sort keys %{"${class}::"};
    };

    my $p_class_subs = sub {
        my ($class, $psyms) = @_;
        no strict;
        return grep { defined &{ ${"${class}::"}{$_} } } @$psyms;
    };

    my $p_super_classes = sub {
        my $class = shift;
        no strict;
        return @{"${class}::ISA"};
    };

    my $psub = sub {
        my $class = shift;

        # Fix the class name (eg. "Bah=HASH(0x192a324)" => "Bah")
        # $class =~ s/=.*//;
        my $cname = blessed($class);
        $class = $cname if defined($cname);

        # If we've processed this class already, just quit.
        if ($seen{$class}++) {
            return \%methods;
        }

        # Extract from all the symbols in this class, and
        # get the entire list of class methods.
        my @syms = $p_class_syms->($class);
        my @subs = $p_class_subs->($class, \@syms);

        # Save each method name which hasn't yet been seen.
        for my $subname (@subs) {
            if (!$seen{$subname}++) {
                $methods{$class} ||= [ ];
                push @{$methods{$class}}, $subname;
            }
        }

        # Keep going up the tree, finding all super classes.
        # Dump each class' methods into the %methods hash.
        #
        my @super = $p_super_classes->($class);
        for my $name (@super) {
            my $pnewsub  = find_methods();
            my $pmethods = $pnewsub->($name);
            while (my ($key, $pvals) = each %$pmethods) {
                $methods{$key} ||= [ ];
                map { push @{$methods{$key}}, $_ } @$pvals;
            }
        }

        return \%methods;
    };

    return $psub;
}

So, give that a try, and let me know if it works for you!

[chromatic]

# Fix the class name (eg. "Bah=HASH(0x192a324)" => "Bah")

Are you aware of blessed() in Scalar::Util?

[liverpole]

Yes, I am now ;-)

So it looks like a better (more standard) way to "Fix the class name" would be:

use Scalar::Util qw(blessed);   # Near the top of the program

    # ...

        # Fix the class name (eg. "Bah=HASH(0x192a324)" => "Bah")
        # Brute force method:  $class =~ s/=.*//;
        my $cname = blessed($class);
        $class = $cname if defined($cname);  # was "if $cname;"

Thank you for the tip, ++chromatic!

Update:  ... and ysth, whose change I've also incorporated.

[Ace128]

Seems to be working nicely man!