lib/Frey/PPI.pm

package Frey::PPI;
use Moose;

extends 'Frey::Class::Loader';

use PPI;
use Data::Dump qw/dump/;
use File::Find;

has 'class' => (
        is => 'rw',
        isa => 'Str',
        required => 1,
        documentation => 'Name of class to parse',
);

has 'doc' => (
        is => 'ro',
        isa => 'PPI::Document',
        lazy => 1,
        default => sub {
                my ( $self ) = @_;
                my $path = $self->class;
                $path = $self->class_path( $path ) unless $path =~ m{/};
                warn "# doc from ", $self->class, " at ", $path if $self->debug;
                my $doc = PPI::Document->new( $path );
                $doc->prune('PPI::Token::Whitespace');
                return $doc;
        },
);

sub find_doc_el {
        my ( $self, $coderef ) = @_;

        my $doc = $self->doc;
        $doc->find(sub {
                my ( $doc,$el ) = @_;
                eval { $coderef->( $doc, $el ) };
                warn "ERROR: $@" if $@;
        });
}

sub attribute_order {
        my ( $self ) = @_;

        my @attribute_order;
        $self->find_doc_el(sub {
                my ($doc,$el) = @_;
                return unless 
                        $el->isa('PPI::Statement') &&
                        $el->{children}->[0]->isa('PPI::Token::Word') &&
                        $el->{children}->[0]->literal eq 'has';

                warn "## has ",$el->{children}->[1]->literal if $self->debug;
                push @attribute_order, $el->{children}->[1]->literal;
        });

        warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;

        return @attribute_order if wantarray;
        return \@attribute_order;
}

sub includes {
        my $self = shift;

        my $include;
        $self->find_doc_el(sub {
                my ($doc,$el) = @_;
                return unless $el->isa('PPI::Statement::Include');

                warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
                push @{ $include->{ $el->type } }, $el->module
                        unless $el->module eq 'lib'; # skip use lib 'lib';
        });
        warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
        return $include;
}

our $class_has_tests;

sub parse_tests {
        my ( $self ) = @_;

        finddepth({ no_chdir => 1, wanted => sub {
                return unless m{\.t$};

                warn "## ppi test $_" if $self->debug;

                my $ppi = Frey::PPI->new( class => $_ );
                my @tests;

#               warn "## ",dump( $doc );

                $ppi->find_doc_el(sub {
                        my ($doc,$el) = @_;
                        return unless 
                                $el->isa('PPI::Statement') &&
                                $el->{children}->[0]->isa('PPI::Token::Word') &&
                                $el->{children}->[0]->literal eq 'use_ok';

#                       warn "## ",dump( $el );
                        my $class = $el->child(1)->child(0)->child(0)->literal;
                        $class_has_tests->{$class}->{$_}++;
                });
        } }, 't/');
        warn "# collected class tests ",dump( $class_has_tests ) if $self->debug;

        return $class_has_tests;
}

=head2 has_tests

  my @tests = $self->has_tests;

=cut

sub has_tests {
        my ($self) = shift;
        
        $self->parse_tests unless $class_has_tests;

        my $class = $self->class;

        if ( my $tests = $class_has_tests->{ $class } ) {
                my @tests = keys %$tests;
                warn "# has_tests $class ",dump( @tests );
                return @tests;
        }
}

=head2 as_data

Debugging output

=cut

sub as_data {
        my $self = shift;
        return {
                includes => $self->includes,
                attribute_order => [ $self->attribute_order ],
                doc => $self->doc,
        };
}

1;
1	package Frey::PPI;
2	use Moose;
3
4	extends 'Frey::Class::Loader';
5
6	use PPI;
7	use Data::Dump qw/dump/;
8	use File::Find;
9
10	has 'class' => (
11	is => 'rw',
12	isa => 'Str',
13	required => 1,
14	documentation => 'Name of class to parse',
15	);
16
17	has 'doc' => (
18	is => 'ro',
19	isa => 'PPI::Document',
20	lazy => 1,
21	default => sub {
22	my ( $self ) = @_;
23	my $path = $self->class;
24	$path = $self->class_path( $path ) unless $path =~ m{/};
25	warn "# doc from ", $self->class, " at ", $path if $self->debug;
26	my $doc = PPI::Document->new( $path );
27	$doc->prune('PPI::Token::Whitespace');
28	return $doc;
29	},
30	);
31
32	sub find_doc_el {
33	my ( $self, $coderef ) = @_;
34
35	my $doc = $self->doc;
36	$doc->find(sub {
37	my ( $doc,$el ) = @_;
38	eval { $coderef->( $doc, $el ) };
39	warn "ERROR: $@" if $@;
40	});
41	}
42
43	sub attribute_order {
44	my ( $self ) = @_;
45
46	my @attribute_order;
47	$self->find_doc_el(sub {
48	my ($doc,$el) = @_;
49	return unless
50	$el->isa('PPI::Statement') &&
51	$el->{children}->[0]->isa('PPI::Token::Word') &&
52	$el->{children}->[0]->literal eq 'has';
53
54	warn "## has ",$el->{children}->[1]->literal if $self->debug;
55	push @attribute_order, $el->{children}->[1]->literal;
56	});
57
58	warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;
59
60	return @attribute_order if wantarray;
61	return \@attribute_order;
62	}
63
64	sub includes {
65	my $self = shift;
66
67	my $include;
68	$self->find_doc_el(sub {
69	my ($doc,$el) = @_;
70	return unless $el->isa('PPI::Statement::Include');
71
72	warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
73	push @{ $include->{ $el->type } }, $el->module
74	unless $el->module eq 'lib'; # skip use lib 'lib';
75	});
76	warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
77	return $include;
78	}
79
80	our $class_has_tests;
81
82	sub parse_tests {
83	my ( $self ) = @_;
84
85	finddepth({ no_chdir => 1, wanted => sub {
86	return unless m{\.t$};
87
88	warn "## ppi test $_" if $self->debug;
89
90	my $ppi = Frey::PPI->new( class => $_ );
91	my @tests;
92
93	# warn "## ",dump( $doc );
94
95	$ppi->find_doc_el(sub {
96	my ($doc,$el) = @_;
97	return unless
98	$el->isa('PPI::Statement') &&
99	$el->{children}->[0]->isa('PPI::Token::Word') &&
100	$el->{children}->[0]->literal eq 'use_ok';
101
102	# warn "## ",dump( $el );
103	my $class = $el->child(1)->child(0)->child(0)->literal;
104	$class_has_tests->{$class}->{$_}++;
105	});
106	} }, 't/');
107	warn "# collected class tests ",dump( $class_has_tests ) if $self->debug;
108
109	return $class_has_tests;
110	}
111
112	=head2 has_tests
113
114	my @tests = $self->has_tests;
115
116	=cut
117
118	sub has_tests {
119	my ($self) = shift;
120
121	$self->parse_tests unless $class_has_tests;
122
123	my $class = $self->class;
124
125	if ( my $tests = $class_has_tests->{ $class } ) {
126	my @tests = keys %$tests;
127	warn "# has_tests $class ",dump( @tests );
128	return @tests;
129	}
130	}
131
132	=head2 as_data
133
134	Debugging output
135
136	=cut
137
138	sub as_data {
139	my $self = shift;
140	return {
141	includes => $self->includes,
142	attribute_order => [ $self->attribute_order ],
143	doc => $self->doc,
144	};
145	}
146
147	1;