/[webpac2]/trunk/lib/WebPAC/Parser.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/WebPAC/Parser.pm

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

revision 690 by dpavlin, Sun Sep 24 19:00:56 2006 UTC revision 691 by dpavlin, Sun Sep 24 21:13:36 2006 UTC
# Line 3  package WebPAC::Parser; Line 3  package WebPAC::Parser;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
 use base qw/WebPAC::Common WebPAC::Normalize/;  
6    
7  use PPI;  use PPI;
8  use PPI::Dumper;  use PPI::Dumper;
9  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
10  use File::Slurp;  use File::Slurp;
11    
12    use base qw/WebPAC::Common WebPAC::Normalize/;
13    
14  =head1 NAME  =head1 NAME
15    
# Line 17  WebPAC::Parser - parse perl normalizatio Line 17  WebPAC::Parser - parse perl normalizatio
17    
18  =head1 VERSION  =head1 VERSION
19    
20  Version 0.02  Version 0.03
21    
22  =cut  =cut
23    
24  our $VERSION = '0.02';  our $VERSION = '0.03';
25    
26  =head1 SYNOPSIS  =head1 SYNOPSIS
27    
# Line 51  sub new { Line 51  sub new {
51    
52          $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));          $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
53    
54          my $source;          $self->read_sources;
55    
56            $self->{config}->iterate_inputs( sub {
57                    my ($input, $database) = @_;
58                    return unless $self->valid_database_input($database, $input->{name});
59                    $self->parse_lookups($database,$input->{name});
60            } );
61    
62            $self ? return $self : return undef;
63    }
64    
65    =head2 read_sources
66    
67      my $source_files = $parser->read_sources;
68    
69    Called by L</new>.
70    
71    =cut
72    
73    sub read_sources {
74            my $self = shift;
75    
76            my $log = $self->_get_logger();
77    
78            my $nr = 0;
79    
80          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
81                  my ($input, $database) = @_;                  my ($input, $database) = @_;
82    
83                  my $path = $input->{normalize}->{path} || return;                  my $path = $input->{normalize}->{path} || return;
84                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
85    
86                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);
87    
88                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
89    
90                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));
                 $log->debug("$database/$input_name: adding $path to parser [",length($s)," bytes]");  
                 $source .= $s;  
                 $self->{valid_inputs}->{$database}->{$input_name}++;  
         } );  
91    
92          $log->debug("collected ", length($source), " bytes of source");                  $log->debug("$database/$input_name: adding $path");
93    
94          $self->{source} = $source;                  $self->{valid_inputs}->{$database}->{$input_name} = {
95                            source => $s,
96                            path => $full,
97                            usage => 0,
98                    } unless defined($self->{valid_inputs}->{$database}->{$input_name});
99    
100          $self ? return $self : return undef;                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;
101    
102                    $nr++;
103            } );
104    
105            $log->debug("found $nr source files");
106    
107            return $nr;
108  }  }
109    
110  =head2 parse  =head2 parse_lookup
111    
112      $parser->parse_lookups($database,$input);
113    
114  =cut  =cut
115    
116  sub parse {  sub parse_lookups {
117          my $self = shift;          my $self = shift;
118            my ($database, $input) = @_;
119    
120          my $log = $self->_get_logger();          my $log = $self->_get_logger();
121    
122          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
123            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
124    
125            my $source = $self->{valid_inputs}->{$database}->{$input}->{source};
126            my $path = $self->{valid_inputs}->{$database}->{$input}->{path};
127    
128            $log->logdie("no source found for database $database input $input path $path") unless ($source);
129    
130          $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));          $log->info("parsing lookups for $database/$input in $path");
131    
132          my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});          my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
133    
134          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
135          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
# Line 93  sub parse { Line 137  sub parse {
137          # Find all the named subroutines          # Find all the named subroutines
138    
139          my $eval_create;          my $eval_create;
140          my @errors;          $self->{_lookup_errors} = ();
141    
142          sub error {          sub _lookup_error {
143                  my $msg = shift || $log->logconfess("error without message?");                  my $self = shift;
144                  push @errors, $msg;                  my $msg = shift;
145                    $self->_get_logger->logconfess("error without message?") unless ($msg);
146                    push @{ $self->{_lookup_errors} }, $msg;
147                  return '';                  return '';
148          }          }
149    
# Line 161  sub parse { Line 207  sub parse {
207    
208                          $log->debug("create: $create");                          $log->debug("create: $create");
209    
210                          return error("invalid database $e[3]" ) unless $self->valid_database( $e[3] );                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
211                          return error("invalid input $e[5] of database $e[3]", ) unless $self->valid_database_input( $e[3], $e[5] );                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
212    
213                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;
214    
# Line 188  sub parse { Line 234  sub parse {
234                  $Dumper->print;                  $Dumper->print;
235          }          }
236    
237          $log->error("Parser errors: ", join("\n",@errors) ) if (@errors);          $log->error("Parser errors: ", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
238    
239          return 1;          return 1;
240  }  }
Legend:
Removed from v.690  
changed lines
  Added in v.691
  ViewVC Help
Powered by ViewVC 1.1.26