lib/Frey/PPI.pm

package Frey::PPI;
use Moose;

extends 'Frey::ClassLoader';

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 ) = @_;
                warn "doc from ", $self->class;
                my $doc = PPI::Document->new( $self->class_path( $self->class ) ) || die $!;
                $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 
        });
        warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
        return $include;
}

sub 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			extends 'Frey::ClassLoader';
5
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			warn "doc from ", $self->class;
23			my $doc = PPI::Document->new( $self->class_path( $self->class ) ) \|\| die $!;
24			$doc->prune('PPI::Token::Whitespace');
25			return $doc;
26			},
27			);
28	dpavlin	362
29	dpavlin	364	sub find {
30			my ( $self, $coderef ) = @_;
31	dpavlin	362
32	dpavlin	364	my $doc = $self->doc;
33			$doc->find(sub {
34			my ( $doc,$el ) = @_;
35			eval { $coderef->( $doc, $el ) };
36			warn "ERROR: $@" if $@;
37			});
38	dpavlin	362	}
39
40	dpavlin	331	sub attribute_order {
41			my ( $self ) = @_;
42
43	dpavlin	369	my @attribute_order;
44	dpavlin	364	$self->find(sub {
45			my ($doc,$el) = @_;
46			return unless ( $el->isa('PPI::Statement') && $el->{children}->[0]->isa('PPI::Token::Word') && $el->{children}->[0]->literal eq 'has' );
47	dpavlin	331
48	dpavlin	364	warn "## has ",$el->{children}->[1]->literal if $self->debug;
49	dpavlin	369	push @attribute_order, $el->{children}->[1]->literal;
50	dpavlin	331	});
51
52	dpavlin	369	warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;
53	dpavlin	331
54	dpavlin	369	return @attribute_order if wantarray;
55			return \@attribute_order;
56	dpavlin	331	}
57
58	dpavlin	364	sub includes {
59	dpavlin	331	my $self = shift;
60	dpavlin	364
61	dpavlin	362	my $include;
62	dpavlin	364	$self->find(sub {
63	dpavlin	362	my ($doc,$el) = @_;
64	dpavlin	364	return unless $el->isa('PPI::Statement::Include');
65
66			warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
67			push @{ $include->{ $el->type } }, $el->module
68	dpavlin	362	});
69	dpavlin	364	warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
70			return $include;
71			}
72	dpavlin	362
73	dpavlin	364	sub data {
74			my $self = shift;
75	dpavlin	362	return {
76	dpavlin	364	includes => $self->includes,
77			attribute_order => $self->attribute_order,
78			doc => $self->doc,
79	dpavlin	362	};
80	dpavlin	331	}
81
82			1;