/[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 708 by dpavlin, Mon Sep 25 16:07:08 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/;
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.05
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  our $VERSION = '0.05';
25    
26  =head1 SYNOPSIS  =head1 SYNOPSIS
27    
28    This module will parse L<WebPAC::Normalize/lookup> directives and generate source
29    to produce lookups and normalization.
30    
31    It's written using L<PPI>, pure-perl parser for perl and heavily influenced by
32    reading about LISP. It might be a bit over-the board, but at least it removed
33    separate configuration files for lookups.
34    
35    This is experimental code, but it replaces all older formats which where,
36    at one point in time, available in WebPAC.
37    
38  FIXME  FIXME
39    
40  =head1 FUNCTIONS  =head1 FUNCTIONS
# Line 51  sub new { Line 61  sub new {
61    
62          $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'));
63    
64          my $source;          $self->_read_sources;
65    
66            $self ? return $self : return undef;
67    }
68    
69    =head2 valid_database
70    
71      my $ok = $parse->valid_database('key');
72    
73    =cut
74    
75    sub valid_database {
76            my $self = shift;
77    
78            my $database = shift || return;
79    
80            return defined($self->{valid_inputs}->{ _q($database) });
81    }
82    
83    =head2 valid_database_input
84    
85      my $ok = $parse->valid_database('database_key','input_name');
86    
87    =cut
88    
89    sub valid_database_input {
90            my $self = shift;
91            my ($database,$input) = @_;
92            $input = _input_name($input);
93            return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
94    }
95    
96    =head2 depends
97    
98    Return all databases and inputs on which specified one depends
99    
100      $depends_on = $parser->depends('database','input');
101    
102    =cut
103    
104    sub depends {
105            my $self = shift;
106            my ($database,$input) = @_;
107            $input = _input_name($input);
108            $self->_get_logger->debug("depends($database,$input)");
109            return unless (
110                    defined( $self->{depends}->{ _q($database) } ) &&
111                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
112            );
113            return $self->{depends}->{ _q($database) }->{ _q($input) };
114    }
115    
116    =head2 have_lookup_create
117    
118      my @keys = $parser->have_lookup_create($database, $input);
119    
120    =cut
121    
122    sub have_lookup_create {
123            my $self = shift;
124            my ($database,$input) = @_;
125            $input = _input_name($input);
126            return unless (
127                    defined( $self->{_lookup_create_key}->{ _q($database) } ) &&
128                    defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } )
129            );
130            return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } };
131    }
132    
133    
134    =head2 lookup_create_rules
135    
136      my $source = $parser->lookup_create_rules($database, $input);
137    
138    =cut
139    
140    sub lookup_create_rules {
141            my $self = shift;
142            my ($database,$input) = @_;
143            $input = _input_name($input);
144            return unless (
145                    defined( $self->{_lookup_create}->{ _q($database) } ) &&
146                    defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
147            );
148            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
149    }
150    
151    =head1 PRIVATE
152    
153    =head2 _read_sources
154    
155      my $source_files = $parser->_read_sources;
156    
157    Called by L</new>.
158    
159    =cut
160    
161    sub _read_sources {
162            my $self = shift;
163    
164            my $log = $self->_get_logger();
165    
166            my $nr = 0;
167    
168            my @lookups;
169    
170          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
171                  my $input = shift;                  my ($input, $database) = @_;
172                  my $path = $input->{normalize}->{path} || return;  
173                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  $log->debug("database: $database input = ", dump($input));
174                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);  
175                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  foreach my $normalize (@{ $input->{normalize} }) {
176                  $log->debug("adding $path to parser [",length($s)," bytes]");  
177                  $source .= $s;                          my $path = $normalize->{path};
178                            return unless($path);
179                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
180    
181                            $log->logdie("normalization input $full doesn't exist") unless (-e $full);
182    
183                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
184    
185                            my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
186    
187                            $log->debug("$database/$input_name: adding $path");
188    
189                            $self->{valid_inputs}->{$database}->{$input_name}++;
190    
191                            push @lookups, sub {
192                                    $self->_parse_lookups( $database, $input_name, $full, $s );
193                            };
194    
195                            $nr++;
196                    }
197          } );          } );
198    
199          $log->debug("collected ", length($source), " bytes of source");          $log->debug("found $nr source files");
200    
201          $self->{source} = $source;          # parse all lookups
202            $_->() foreach (@lookups);
203    
204          $self ? return $self : return undef;          return $nr;
205  }  }
206    
207  =head2 parse  =head2 _parse_lookups
208    
209      $parser->_parse_lookups($database,$input,$path,$source);
210    
211    Called for each normalize source (rules) in each input by L</_read_sources>
212    
213    It will report invalid databases and inputs in error log after parsing.
214    
215  =cut  =cut
216    
217  sub parse {  sub _parse_lookups {
218          my $self = shift;          my $self = shift;
219            my ($database, $input, $path, $source) = @_;
220    
221            $input = _input_name($input);
222    
223          my $log = $self->_get_logger();          my $log = $self->_get_logger();
224    
225          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
226            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
227    
228            $log->logdie("no source found for database $database input $input path $path") unless ($source);
229    
230          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 (",length($source)," bytes)");
231    
232            my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
233    
234          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
235          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
236    
237          # Find all the named subroutines          # Find all the named subroutines
238    
239          my $eval_create;          $self->{_lookup_errors} = ();
240    
241            sub _lookup_error {
242                    my $self = shift;
243                    my $msg = shift;
244                    $self->_get_logger->logconfess("error without message?") unless ($msg);
245                    push @{ $self->{_lookup_errors} }, $msg;
246                    return '';
247            }
248    
249          $Document->find( sub {          $Document->find( sub {
250                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 96  sub parse { Line 252  sub parse {
252                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
253                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
254    
255                          print "#*** expansion: ", $Element->snext_sibling,$/;                          $log->debug("expansion: ", $Element->snext_sibling);
256    
257                          my $args = $Element->snext_sibling;                          my $args = $Element->snext_sibling;
258                                    
259                          my @e = $args->child(0)->elements;                          my @e = $args->child(0)->elements;
260                          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);
261    
262                            if ($log->is_debug) {
263                                    my $report = "found " . scalar @e . " elements:\n";
264    
265                          print "# found ", scalar @e, " elements:\n";                                  foreach my $i ( 0 .. $#e ) {
266                                            $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
267                                    }
268    
269                          foreach my $i ( 0 .. $#e ) {                                  $log->debug($report);
                                 printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );  
270                          }                          }
271    
272                          my $key_element = $e[8]->clone;                          my $key_element = $e[8]->clone;
273    
274                          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');
275    
276                          print "## key part: ", $key_element, $/;                          $log->debug("key part: ", $key_element);
277    
278                          my @key;                          my @key;
279    
# Line 124  sub parse { Line 284  sub parse {
284    
285                                  my $kf = $e->snext_sibling;                                  my $kf = $e->snext_sibling;
286    
287                                  print "## key fragment = $kf\n";                                  $log->debug("key fragment = $kf");
288    
289                                  push @key, eval $kf;                                  push @key, eval $kf;
290                                  print "ERROR: can't eval { $kf }: $@" if ($@);                                  $log->logdie("can't eval { $kf }: $@") if ($@);
291    
292                                  return 1;                                  return 1;
293                          });                          });
294    
295                          my $key = join('-', @key ) || print "ERROR: no key found!";                          my $key = join('-', @key ) || $log->logdie("no key found!");
296    
297                          print "key = $key\n";                          $log->debug("key = $key");
298    
299                          my $create = '                          my $create = "save_into_lookup('$key', $e[7] $e[8] );\n";
300                                  $coderef = ' . $e[7] . $e[8] . ';  
301                                  foreach my $v ($coderef->()) {                          $log->debug("create: $create");
302                                          next unless (defined($v) && $v ne \'\');  
303                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
304                                  }                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
                         ';  
305    
306                          print "create: $create\n";                          # save code to create this lookup
307                            $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create;
308                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
309    
310    
311                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
312                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
313                            }
314    
315                          $create =~ s/\s+/ /gs;                          # save this dependency
316                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
317    
318                          if ($#e < 10) {                          if ($#e < 10) {
319                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 160  sub parse { Line 326  sub parse {
326                          $e[8]->remove;                          $e[8]->remove;
327    
328    
329                          print "# >>> ", $Element->snext_sibling, "\n";                          $log->debug(">>> ", $Element->snext_sibling);
330          });          });
331    
332          print "-----\ncreate: ", dump($eval_create), "\n";          my $normalize_source = $Document->serialize;
333          print "-----\nlookup: ", $Document->serialize, "\n";          $log->debug("create: ", dump($self->{_lookup_create}) );
334          print "-----\n";          $log->debug("normalize: $normalize_source");
335    
336          my $Dumper = PPI::Dumper->new( $Document );          $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
         $Dumper->print;  
337    
338            if ($self->{debug}) {
339                    my $Dumper = PPI::Dumper->new( $Document );
340                    $Dumper->print;
341            }
342    
343            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
344    
345            return 1;
346  }  }
347    
348    
349    =head2 _q
350    
351    Strip single or double quotes around value
352    
353      _q(qq/'foo'/) -> foo
354    
355    =cut
356    
357    sub _q {
358            my $v = shift || return;
359            $v =~ s/^['"]*//g;
360            $v =~ s/['"]*$//g;
361            return $v;
362    }
363    
364    =head2 _input_name
365    
366    Return C<name> value if HASH or arg if scalar
367    
368      _input_name($input)
369    
370    =cut
371    
372    sub _input_name {
373            my $input = shift || return;
374            if (ref($input) eq 'HASH') {
375                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
376                    return $input->{name};
377            } else {
378                    return $input;
379            }
380    }
381    
382    
383  =head1 AUTHOR  =head1 AUTHOR
384    
385  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.686  
changed lines
  Added in v.708
  ViewVC Help
Powered by ViewVC 1.1.26