develooper Front page | perl.perl6.language.objects | Postings from January 2001

Re: RFC335: Class Method Introspection

From:
Mark Summerfield
Date:
January 30, 2001 00:55
Subject:
Re: RFC335: Class Method Introspection
Message ID:
01013009384708.13761@sylkie
Hi,

I know the process ended some time ago, but I got an email from Peter
Schattner who was using the sample code that Piers and I wrote for the
RFC and had a suggested improvement. Piers rewrote the sample
implementation and I tweaked it a tiny bit and so I thought I ought to
submit it... The code below is runnable and contains the sample
implementation for UNIVERSAL::methods

Mark.


---------snip and save as test.pl-------------
#!/usr/bin/perl -w

use strict;

package BaseClass;
sub baseclass {}

package DerivedClass1;
use base 'BaseClass';
sub derived {}
sub one {}

package DerivedClass2;
use base 'BaseClass';
sub derived {}
sub two {}

package BabyClass;
use base qw(DerivedClass1 DerivedClass2);
sub three {}

package main;
print "BaseClass:           ",
    join(", ", sort BaseClass->methods()), "\n";
print "BaseClass (all):     ",
    join(", ", sort BaseClass->methods('all')), "\n";
print "DerivedClass1:       ",
    join(", ", sort DerivedClass1->methods()), "\n";
print "DerivedClass1 (all): ",
    join(", ", sort DerivedClass1->methods('all')), "\n";
print "DerivedClass2:       ",
    join(", ", sort DerivedClass2->methods()), "\n";
print "DerivedClass2 (all): ",
    join(", ", sort DerivedClass2->methods('all')), "\n";
print "BabyClass:           ",
    join(", ", sort BabyClass->methods()), "\n";
print "BabyClass (all):     ",
    join(", ", sort BabyClass->methods('all')), "\n";
print "BabyClass (most) full:\n";
my $methods = BabyClass->methods('all');
foreach my $method ( sort { $methods->{$a} cmp $methods->{$b} }
		     keys %{$methods} ) {
    my $class = $methods->{$method};
    print "\t$class\::$method\n" if index( $class, 'UNIVERSAL' ) == -1;
}


package UNIVERSAL;

use strict;

sub methods {
    my ( $class, $types, $seen, $methods, $recursing ) = @_;

    $class      = ref $class || $class;
    $types	||= '';
    $seen       ||= {};
    $methods	||= {};
    $recursing	||= 0;

    return if $seen->{$class}++;
    no strict 'refs';
    for my $method ( grep { not /^[(_]/ and
                            defined &{${"$class\::"}{$_}}}
                     keys %{"$class\::"} ) {
        $methods->{$method} ||= $class;
    }
    if ( $types eq 'all' ) {
	my @parents = @{"$class\::ISA"};
	push @parents, 'UNIVERSAL' unless $recursing;
	foreach my $parent ( @parents ) {
	    $parent->methods( $types, $seen, $methods, 1 );
	}
    }

    return wantarray ? keys %$methods : $methods;
}


1;




nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About