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;
