/[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 686 by dpavlin, Sun Sep 24 17:25:04 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.01  Version 0.03
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  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 = shift;                  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: $!");
                 $log->debug("adding $path to parser [",length($s)," bytes]");  
                 $source .= $s;  
         } );  
89    
90          $log->debug("collected ", length($source), " bytes of source");                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));
91    
92          $self->{source} = $source;                  $log->debug("$database/$input_name: adding $path");
93    
94          $self ? return $self : return undef;                  $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->{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->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 89  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            $self->{_lookup_errors} = ();
141    
142            sub _lookup_error {
143                    my $self = shift;
144                    my $msg = shift;
145                    $self->_get_logger->logconfess("error without message?") unless ($msg);
146                    push @{ $self->{_lookup_errors} }, $msg;
147                    return '';
148            }
149    
150          $Document->find( sub {          $Document->find( sub {
151                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 96  sub parse { Line 153  sub parse {
153                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
154                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
155    
156                          print "#*** expansion: ", $Element->snext_sibling,$/;                          $log->debug("expansion: ", $Element->snext_sibling);
157    
158                          my $args = $Element->snext_sibling;                          my $args = $Element->snext_sibling;
159                                    
160                          my @e = $args->child(0)->elements;                          my @e = $args->child(0)->elements;
161                          print "hum, expect at least 8 elements, got ", scalar @e, " in $args\n" if ($#e < 8);                          $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
162    
163                            if ($log->is_debug) {
164                                    my $report = "found " . scalar @e . " elements:\n";
165    
166                          print "# found ", scalar @e, " elements:\n";                                  foreach my $i ( 0 .. $#e ) {
167                                            $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
168                                    }
169    
170                          foreach my $i ( 0 .. $#e ) {                                  $log->debug($report);
                                 printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );  
171                          }                          }
172    
173                          my $key_element = $e[8]->clone;                          my $key_element = $e[8]->clone;
174    
175                          die "key element must be PPI::Structure::Block" unless $key_element->isa('PPI::Structure::Block');                          $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
176    
177                          print "## key part: ", $key_element, $/;                          $log->debug("key part: ", $key_element);
178    
179                          my @key;                          my @key;
180    
# Line 124  sub parse { Line 185  sub parse {
185    
186                                  my $kf = $e->snext_sibling;                                  my $kf = $e->snext_sibling;
187    
188                                  print "## key fragment = $kf\n";                                  $log->debug("key fragment = $kf");
189    
190                                  push @key, eval $kf;                                  push @key, eval $kf;
191                                  print "ERROR: can't eval { $kf }: $@" if ($@);                                  $log->logdie("can't eval { $kf }: $@") if ($@);
192    
193                                  return 1;                                  return 1;
194                          });                          });
195    
196                          my $key = join('-', @key ) || print "ERROR: no key found!";                          my $key = join('-', @key ) || $log->logdie("no key found!");
197    
198                          print "key = $key\n";                          $log->debug("key = $key");
199    
200                          my $create = '                          my $create = '
201                                  $coderef = ' . $e[7] . $e[8] . ';                                  $coderef = ' . $e[7] . $e[8] . ';
# Line 144  sub parse { Line 205  sub parse {
205                                  }                                  }
206                          ';                          ';
207    
208                          print "create: $create\n";                          $log->debug("create: $create");
209    
210                            return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
211                            return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
212    
                         $create =~ s/\s+/ /gs;  
213                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;
214    
215                          if ($#e < 10) {                          if ($#e < 10) {
# Line 160  sub parse { Line 223  sub parse {
223                          $e[8]->remove;                          $e[8]->remove;
224    
225    
226                          print "# >>> ", $Element->snext_sibling, "\n";                          $log->debug(">>> ", $Element->snext_sibling);
227          });          });
228    
229          print "-----\ncreate: ", dump($eval_create), "\n";          $log->info("create: ", dump($eval_create) );
230          print "-----\nlookup: ", $Document->serialize, "\n";          $log->info("lookup: ", $Document->serialize );
231          print "-----\n";  
232            if ($self->{debug}) {
233                    my $Dumper = PPI::Dumper->new( $Document );
234                    $Dumper->print;
235            }
236    
237            $log->error("Parser errors: ", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
238    
239            return 1;
240    }
241    
242    =head2 valid_database
243    
244      my $ok = $parse->valid_database('key');
245    
246    =cut
247    
248    sub valid_database {
249            my $self = shift;
250    
251            my $database = shift || return;
252            $database =~ s/['"]//g;
253    
254            return defined($self->{valid_inputs}->{$database});
255    }
256    
257    =head2 valid_database_input
258    
259      my $ok = $parse->valid_database('database_key','input_name');
260    
261    =cut
262    
263    sub valid_database_input {
264            my $self = shift;
265    
266          my $Dumper = PPI::Dumper->new( $Document );          my ($database,$input) = @_;
267          $Dumper->print;          $database =~ s/['"]//g;
268            $input =~ s/['"]//g;
269    
270            return defined($self->{valid_inputs}->{$database}->{$input});
271  }  }
272    
273  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.686  
changed lines
  Added in v.691
  ViewVC Help
Powered by ViewVC 1.1.26