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