|
423
|
1 package IMPL::Class::ClassInfo;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use Sub::Util qw(subname);
|
|
|
5 use mro;
|
|
|
6
|
|
|
7 my %props;
|
|
|
8
|
|
|
9 sub new {
|
|
|
10 my ( $self, $class ) = @_;
|
|
|
11
|
|
|
12 return bless \$class, $self;
|
|
|
13 }
|
|
|
14
|
|
|
15 sub className {
|
|
|
16 ${ $_[0] };
|
|
|
17 }
|
|
|
18
|
|
|
19 sub linearISA {
|
|
|
20 return mro::get_linear_isa( ${ $_[0] } );
|
|
|
21 }
|
|
|
22
|
|
|
23 sub members {
|
|
|
24
|
|
|
25 }
|
|
|
26
|
|
|
27 sub methods {
|
|
|
28 my ( $this, %opts ) = @_;
|
|
|
29
|
|
|
30 my %hide;
|
|
|
31
|
|
|
32 if ( !$opts{hidden} ) {
|
|
|
33 %hide =
|
|
|
34 map ( ( $_, 1 ), map @{$_}{qw(getter setter)},
|
|
|
35 $this->properties(%opts) );
|
|
|
36 }
|
|
|
37
|
|
|
38 if ( !$opts{inherited} ) {
|
|
|
39 no strict 'refs';
|
|
|
40 my $class = $this->className();
|
|
|
41
|
|
|
42 my @members;
|
|
|
43
|
|
|
44 while ( my ( $k, $v ) = each %{"${class}::"} ) {
|
|
|
45 my $fn = *{$v}{CODE};
|
|
|
46 next unless $fn;
|
|
|
47
|
|
|
48 my ( $fqname, $pkg, $name ) =
|
|
|
49 ( subname($fn) =~ m/^((.+)::(.+?))$/ );
|
|
|
50
|
|
|
51 push @members, $fqname if $pkg eq $class and not $hide{$name};
|
|
|
52 }
|
|
|
53
|
|
|
54 return @members;
|
|
|
55 }
|
|
|
56 else {
|
|
|
57
|
|
|
58 my @isa =
|
|
|
59 reverse( $opts{inherited} ? $this->linearISA() : $this->className() );
|
|
|
60
|
|
|
61 my %methods = map { $_->memberName(), $_ }
|
|
|
62 grep not( $hide{ $_->memberName() } ),
|
|
|
63 map { IMPL::Class::ClassInfo->new($_)->methods( inherited => 0 ) } @isa;
|
|
|
64
|
|
|
65 return values %methods;
|
|
|
66 }
|
|
|
67 }
|
|
|
68
|
|
|
69 sub properties {
|
|
|
70
|
|
|
71 }
|
|
|
72
|
|
|
73 1;
|
