/[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 362 by dpavlin, Sun Nov 16 17:39:39 2008 UTC revision 487 by dpavlin, Mon Nov 24 17:09:00 2008 UTC
# Line 13  has 'class' => ( Line 13  has 'class' => (
13          documentation => 'Name of class to parse',          documentation => 'Name of class to parse',
14  );  );
15    
16  my $ppi_doc;  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 doc {  sub find {
32          my ( $self ) = @_;          my ( $self, $coderef ) = @_;
33    
34          if ( ! $ppi_doc ) {          my $doc = $self->doc;
35                  warn "# parse ", $self->class;          $doc->find(sub {
36                  my $doc = PPI::Document->new( $self->class_path( $self->class ) ) || die $!;                  my ( $doc,$el ) = @_;
37                  $doc->prune('PPI::Token::Whitespace');                  eval { $coderef->( $doc, $el ) };
38                  $ppi_doc = $doc;                  warn "ERROR: $@" if $@;
39          }          });
         return $ppi_doc;  
40  }  }
41    
42  sub attribute_order {  sub attribute_order {
43          my ( $self ) = @_;          my ( $self ) = @_;
44    
         my $doc = $self->doc;  
   
45          my @attribute_order;          my @attribute_order;
46            $self->find(sub {
         $doc->find(sub {  
47                  my ($doc,$el) = @_;                  my ($doc,$el) = @_;
48                  if ( $el->isa('PPI::Statement') && $el->{children}->[0]->{content} eq 'has' ) {                  return unless
49                          warn "## has ",$el->{children}->[1]->string if $self->debug;                          $el->isa('PPI::Statement') &&
50                          push @attribute_order, $el->{children}->[1]->string;                          $el->{children}->[0]->isa('PPI::Token::Word') &&
51                  }                          $el->{children}->[0]->literal eq 'has';
52                  return 1;  
53                    warn "## has ",$el->{children}->[1]->literal if $self->debug;
54                    push @attribute_order, $el->{children}->[1]->literal;
55          });          });
56    
57          warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;          warn "# ", $self->class, " attribute_order ", dump( @attribute_order ) if $self->debug;
58    
59          return @attribute_order;          return @attribute_order if wantarray;
60            return \@attribute_order;
61  }  }
62    
63  sub data {  sub includes {
64          my $self = shift;          my $self = shift;
65          my $doc = $self->doc;  
66          my $include;          my $include;
67          $doc->find( sub {          $self->find(sub {
68                  my ($doc,$el) = @_;                  my ($doc,$el) = @_;
69                  if ( $el->isa('PPI::Statement::Include') ) {                  return unless $el->isa('PPI::Statement::Include');
70                          warn dump( $el->module, $el->type, $el->pragma );  
71                          push @{ $include->{ $el->type } }, $el->module                  warn "## include ",dump( $el->module, $el->type, $el->pragma ) if $self->debug;
72                  }                  push @{ $include->{ $el->type } }, $el->module
                 return 1;  
73          });          });
74          warn "# ", $self->class, " ", dump( $include ) if $self->debug;          warn "# ", $self->class, " include ", dump( $include ) if $self->debug;
75            return $include;
76    }
77    
78    our $class_has_tests;
79    
80    sub parse_tests {
81            my ( $self ) = @_;
82    
83            map {
84                    warn "## ppi test $_" if $self->debug;
85    
86                    my $doc = Frey::PPI->new( class => $_ );
87                    my @tests;
88    
89    #               warn "## ",dump( $doc );
90    
91                    $doc->find(sub {
92                            my ($doc,$el) = @_;
93                            return unless
94                                    $el->isa('PPI::Statement') &&
95                                    $el->{children}->[0]->isa('PPI::Token::Word') &&
96                                    $el->{children}->[0]->literal eq 'use_ok';
97    
98    #                       warn "## ",dump( $el );
99                            my $class = $el->child(1)->child(0)->child(0)->literal;
100                            $class_has_tests->{$class}->{$_}++;
101                    });
102            } glob 't/*.t';
103            warn "# collected class tests ",dump( $class_has_tests ) if $self->debug;
104    
105            return $class_has_tests;
106    }
107    
108    =head2 has_tests
109    
110      my @tests = $self->has_tests;
111    
112    =cut
113    
114    sub has_tests {
115            my ($self) = shift;
116            
117            $self->parse_tests unless defined $class_has_tests;
118    
119            my $class = $self->class;
120    
121            if ( my $tests = $class_has_tests->{ $class } ) {
122    #               warn "# has_tests $class ",dump( keys %$tests );
123                    return [ keys %$tests ];
124            }
125            return [];
126    }
127    
128    =head2 as_data
129    
130    Debugging output
131    
132    =cut
133    
134    sub as_data {
135            my $self = shift;
136          return {          return {
137                  include => $include,                  includes => $self->includes,
138                  doc => $doc,                  attribute_order => [ $self->attribute_order ],
139                    doc => $self->doc,
140          };          };
141  }  }
142    
Legend:
Removed from v.362  
changed lines
  Added in v.487
  ViewVC Help
Powered by ViewVC 1.1.26