/[Frey]/trunk/lib/Frey/PPI.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/Frey/PPI.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 331 by dpavlin, Sat Nov 8 16:12:39 2008 UTC revision 1105 by dpavlin, Mon Jun 29 14:09:34 2009 UTC
# Line 1  Line 1 
1  package Frey::PPI;  package Frey::PPI;
2  use Moose;  use Moose;
3    
4  extends 'Frey::ClassLoader';  extends 'Frey::Class::Loader';
5    
6  use PPI;  use PPI;
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8    use File::Find;
9    
10  has 'class' => (  has 'class' => (
11          is => 'rw',          is => 'rw',
# Line 13  has 'class' => ( Line 14  has 'class' => (
14          documentation => 'Name of class to parse',          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 {  sub attribute_order {
44          my ( $self ) = @_;          my ( $self ) = @_;
45    
46          my $doc = PPI::Document->new( $self->class_path( $self->class ) ) || die $!;          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          $doc->prune('PPI::Token::Whitespace');          warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;
59    
60          my @attribute_order;          return @attribute_order if wantarray;
61            return \@attribute_order;
62    }
63    
64          $doc->find(sub {  sub includes {
65            my $self = shift;
66    
67            my $include;
68            $self->find_doc_el(sub {
69                  my ($doc,$el) = @_;                  my ($doc,$el) = @_;
70                  if ( $el->isa('PPI::Statement') && $el->{children}->[0]->{content} eq 'has' ) {                  return unless $el->isa('PPI::Statement::Include');
71                          warn "## has ",$el->{children}->[1]->string if $self->debug;  
72                          push @attribute_order, $el->{children}->[1]->string;                  warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
73                  }                  push @{ $include->{ $el->type } }, $el->module
74                  return 1;                          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          warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;  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          return @attribute_order;          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  sub data {  =head2 as_data
133    
134    Debugging output
135    
136    =cut
137    
138    sub as_data {
139          my $self = shift;          my $self = shift;
140          [ $self->attribute_order ];          return {
141                    includes => $self->includes,
142                    attribute_order => [ $self->attribute_order ],
143                    doc => $self->doc,
144            };
145  }  }
146    
147  1;  1;
Legend:
Removed from v.331  
changed lines
  Added in v.1105
  ViewVC Help
Powered by ViewVC 1.1.26