/[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 455 by dpavlin, Wed Nov 19 15:28:23 2008 UTC revision 1133 by dpavlin, Tue Jun 30 15:10:55 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 19  has 'doc' => ( Line 20  has 'doc' => (
20          lazy => 1,          lazy => 1,
21          default => sub {          default => sub {
22                  my ( $self ) = @_;                  my ( $self ) = @_;
23                  warn "# doc from ", $self->class if $self->debug;                  my $path = $self->class;
24                  my $doc = PPI::Document->new( $self->class_path( $self->class ) );                  $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');                  $doc->prune('PPI::Token::Whitespace');
28                  return $doc;                  return $doc;
29          },          },
30  );  );
31    
32  sub find {  sub find_doc_el {
33          my ( $self, $coderef ) = @_;          my ( $self, $coderef ) = @_;
34    
35          my $doc = $self->doc;          my $doc = $self->doc;
# Line 41  sub attribute_order { Line 44  sub attribute_order {
44          my ( $self ) = @_;          my ( $self ) = @_;
45    
46          my @attribute_order;          my @attribute_order;
47          $self->find(sub {          $self->find_doc_el(sub {
48                  my ($doc,$el) = @_;                  my ($doc,$el) = @_;
49                  return unless ( $el->isa('PPI::Statement') && $el->{children}->[0]->isa('PPI::Token::Word') && $el->{children}->[0]->literal eq 'has' );                  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;                  warn "## has ",$el->{children}->[1]->literal if $self->debug;
55                  push @attribute_order, $el->{children}->[1]->literal;                  push @attribute_order, $el->{children}->[1]->literal;
# Line 59  sub includes { Line 65  sub includes {
65          my $self = shift;          my $self = shift;
66    
67          my $include;          my $include;
68          $self->find(sub {          $self->find_doc_el(sub {
69                  my ($doc,$el) = @_;                  my ($doc,$el) = @_;
70                  return unless $el->isa('PPI::Statement::Include');                  return unless $el->isa('PPI::Statement::Include');
71    
72                  warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;                  warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
73                  push @{ $include->{ $el->type } }, $el->module                  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;          warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
77          return $include;          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 {  sub as_data {
139          my $self = shift;          my $self = shift;
140          return {          return {
141                  includes => $self->includes,                  includes => $self->includes,
142                  attribute_order => $self->attribute_order,                  attribute_order => [ $self->attribute_order ],
143                  doc => $self->doc,                  doc => $self->doc,
144          };          };
145  }  }
146    
147    __PACKAGE__->meta->make_immutable;
148    no Moose;
149    
150  1;  1;
Legend:
Removed from v.455  
changed lines
  Added in v.1133
  ViewVC Help
Powered by ViewVC 1.1.26