/[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 689 by dpavlin, Sun Sep 24 18:52:35 2006 UTC revision 692 by dpavlin, Sun Sep 24 21:13:40 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_lookups
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->debug("valid_inputs = ", dump( $self->{valid_inputs} ));          $log->logdie("no source found for database $database input $input path $path") unless ($source);
129    
130          my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});          $log->info("parsing lookups for $database/$input from $path");
131    
132            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');
136    
137          # Find all the named subroutines          # Find all the named subroutines
138    
139          my $eval_create;          $self->{_lookup_errors} = ();
140    
141            sub _lookup_error {
142                    my $self = shift;
143                    my $msg = shift;
144                    $self->_get_logger->logconfess("error without message?") unless ($msg);
145                    push @{ $self->{_lookup_errors} }, $msg;
146                    return '';
147            }
148    
149          $Document->find( sub {          $Document->find( sub {
150                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 154  sub parse { Line 206  sub parse {
206    
207                          $log->debug("create: $create");                          $log->debug("create: $create");
208    
209                          $log->logdie("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] );
210                          $log->logdie("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] );
211    
212                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $self->add_lookup_create( $e[3], $e[5], $create );
213    
214                          if ($#e < 10) {                          if ($#e < 10) {
215                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 173  sub parse { Line 225  sub parse {
225                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
226          });          });
227    
228          $log->info("create: ", dump($eval_create) );          my $source = $Document->serialize;
229          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
230            $log->debug("normalize: $source");
231    
232            $self->{_normalize_source}->{$database}->{$input} = $source;
233    
234          if ($self->{debug}) {          if ($self->{debug}) {
235                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
236                  $Dumper->print;                  $Dumper->print;
237          }          }
238    
239            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
240    
241          return 1;          return 1;
242  }  }
243    
244    =head2 add_lookup_create
245    
246      $parse->add_lookup_create($database,$input,$source);
247    
248    =cut
249    
250    sub add_lookup_create {
251            my $self = shift;
252            my ($database,$input,$source) = @_;
253            $self->{_lookup_create}->{$database}->{$input} .= $source;
254    }
255    
256    
257  =head2 valid_database  =head2 valid_database
258    
259    my $ok = $parse->valid_database('key');    my $ok = $parse->valid_database('key');
Legend:
Removed from v.689  
changed lines
  Added in v.692
  ViewVC Help
Powered by ViewVC 1.1.26