lib/Frey/PPI.pm

package Frey::PPI;
use Moose;

extends 'Frey::Class::Loader';

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

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 {
        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(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(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 ) = @_;

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

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

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

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