/[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 943 by dpavlin, Tue Jan 6 14:50:30 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/;
# Line 13  has 'class' => ( Line 13  has 'class' => (
13          documentation => 'Name of class to parse',          documentation => 'Name of class to parse',
14  );  );
15    
16    has 'doc' => (
17            is => 'ro',
18            isa => 'PPI::Document',
19            lazy => 1,
20            default => sub {
21                    my ( $self ) = @_;
22                    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                    $doc->prune('PPI::Token::Whitespace');
27                    return $doc;
28            },
29    );
30    
31    sub find {
32            my ( $self, $coderef ) = @_;
33    
34            my $doc = $self->doc;
35            $doc->find(sub {
36                    my ( $doc,$el ) = @_;
37                    eval { $coderef->( $doc, $el ) };
38                    warn "ERROR: $@" if $@;
39            });
40    }
41    
42  sub attribute_order {  sub attribute_order {
43          my ( $self ) = @_;          my ( $self ) = @_;
44    
45          my $doc = PPI::Document->new( $self->class_path( $self->class ) ) || die $!;          my @attribute_order;
46            $self->find(sub {
47                    my ($doc,$el) = @_;
48                    return unless
49                            $el->isa('PPI::Statement') &&
50                            $el->{children}->[0]->isa('PPI::Token::Word') &&
51                            $el->{children}->[0]->literal eq 'has';
52    
53                    warn "## has ",$el->{children}->[1]->literal if $self->debug;
54                    push @attribute_order, $el->{children}->[1]->literal;
55            });
56    
57          $doc->prune('PPI::Token::Whitespace');          warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;
58    
59          my @attribute_order;          return @attribute_order if wantarray;
60            return \@attribute_order;
61    }
62    
63          $doc->find(sub {  sub includes {
64            my $self = shift;
65    
66            my $include;
67            $self->find(sub {
68                  my ($doc,$el) = @_;                  my ($doc,$el) = @_;
69                  if ( $el->isa('PPI::Statement') && $el->{children}->[0]->{content} eq 'has' ) {                  return unless $el->isa('PPI::Statement::Include');
70                          warn "## has ",$el->{children}->[1]->string if $self->debug;  
71                          push @attribute_order, $el->{children}->[1]->string;                  warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
72                  }                  push @{ $include->{ $el->type } }, $el->module
73                  return 1;                          unless $el->module eq 'lib'; # skip use lib 'lib';
74          });          });
75            warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
76            return $include;
77    }
78    
79          warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;  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            $self->parse_tests unless $class_has_tests;
119    
120          return @attribute_order;          my $class = $self->class;
121    
122            if ( my $tests = $class_has_tests->{ $class } ) {
123                    my @tests = keys %$tests;
124                    warn "# has_tests $class ",dump( @tests );
125                    return @tests if wantarray;
126                    return \@tests;
127            }
128  }  }
129    
130  sub data {  =head2 as_data
131    
132    Debugging output
133    
134    =cut
135    
136    sub as_data {
137          my $self = shift;          my $self = shift;
138          [ $self->attribute_order ];          return {
139                    includes => $self->includes,
140                    attribute_order => [ $self->attribute_order ],
141                    doc => $self->doc,
142            };
143  }  }
144    
145  1;  1;
Legend:
Removed from v.331  
changed lines
  Added in v.943
  ViewVC Help
Powered by ViewVC 1.1.26