/[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 705 by dpavlin, Mon Sep 25 13:46: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.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 lookup_create_rules
117    
118      my $source = $parser->lookup_create_rules($database, $input);
119    
120    =cut
121    
122    sub lookup_create_rules {
123            my $self = shift;
124            my ($database,$input) = @_;
125            $input = _input_name($input);
126            return unless (
127                    defined( $self->{_lookup_create}->{ _q($database) } ) &&
128                    defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
129            );
130            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
131    }
132    
133    =head1 PRIVATE
134    
135    =head2 _read_sources
136    
137      my $source_files = $parser->_read_sources;
138    
139    Called by L</new>.
140    
141    =cut
142    
143    sub _read_sources {
144            my $self = shift;
145    
146            my $log = $self->_get_logger();
147    
148            my $nr = 0;
149    
150            my @lookups;
151    
152          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
153                  my $input = shift;                  my ($input, $database) = @_;
154                  my $path = $input->{normalize}->{path} || return;  
155                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  $log->debug("database: $database input = ", dump($input));
156                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);  
157                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  foreach my $normalize (@{ $input->{normalize} }) {
158                  $log->debug("adding $path to parser [",length($s)," bytes]");  
159                  $source .= $s;                          my $path = $normalize->{path};
160                            return unless($path);
161                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
162    
163                            $log->logdie("normalization input $full doesn't exist") unless (-e $full);
164    
165                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
166    
167                            my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
168    
169                            $log->debug("$database/$input_name: adding $path");
170    
171                            $self->{valid_inputs}->{$database}->{$input_name}++;
172    
173                            push @lookups, sub {
174                                    $self->_parse_lookups( $database, $input_name, $full, $s );
175                            };
176    
177                            $nr++;
178                    }
179          } );          } );
180    
181          $log->debug("collected ", length($source), " bytes of source");          $log->debug("found $nr source files");
182    
183          $self->{source} = $source;          # parse all lookups
184            $_->() foreach (@lookups);
185    
186          $self ? return $self : return undef;          return $nr;
187  }  }
188    
189  =head2 parse  =head2 _parse_lookups
190    
191      $parser->_parse_lookups($database,$input,$path,$source);
192    
193    Called for each normalize source (rules) in each input by L</read_sources>
194    
195    It will report invalid databases and inputs in error log after parsing.
196    
197  =cut  =cut
198    
199  sub parse {  sub _parse_lookups {
200          my $self = shift;          my $self = shift;
201            my ($database, $input, $path, $source) = @_;
202    
203            $input = _input_name($input);
204    
205          my $log = $self->_get_logger();          my $log = $self->_get_logger();
206    
207          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
208            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
209    
210            $log->logdie("no source found for database $database input $input path $path") unless ($source);
211    
212            $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
213    
214          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});
215    
216          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
217          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
218    
219          # Find all the named subroutines          # Find all the named subroutines
220    
221          my $eval_create;          $self->{_lookup_errors} = ();
222    
223            sub _lookup_error {
224                    my $self = shift;
225                    my $msg = shift;
226                    $self->_get_logger->logconfess("error without message?") unless ($msg);
227                    push @{ $self->{_lookup_errors} }, $msg;
228                    return '';
229            }
230    
231          $Document->find( sub {          $Document->find( sub {
232                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 96  sub parse { Line 234  sub parse {
234                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
235                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
236    
237                          print "#*** expansion: ", $Element->snext_sibling,$/;                          $log->debug("expansion: ", $Element->snext_sibling);
238    
239                          my $args = $Element->snext_sibling;                          my $args = $Element->snext_sibling;
240                                    
241                          my @e = $args->child(0)->elements;                          my @e = $args->child(0)->elements;
242                          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);
243    
244                            if ($log->is_debug) {
245                                    my $report = "found " . scalar @e . " elements:\n";
246    
247                          print "# found ", scalar @e, " elements:\n";                                  foreach my $i ( 0 .. $#e ) {
248                                            $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
249                                    }
250    
251                          foreach my $i ( 0 .. $#e ) {                                  $log->debug($report);
                                 printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );  
252                          }                          }
253    
254                          my $key_element = $e[8]->clone;                          my $key_element = $e[8]->clone;
255    
256                          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');
257    
258                          print "## key part: ", $key_element, $/;                          $log->debug("key part: ", $key_element);
259    
260                          my @key;                          my @key;
261    
# Line 124  sub parse { Line 266  sub parse {
266    
267                                  my $kf = $e->snext_sibling;                                  my $kf = $e->snext_sibling;
268    
269                                  print "## key fragment = $kf\n";                                  $log->debug("key fragment = $kf");
270    
271                                  push @key, eval $kf;                                  push @key, eval $kf;
272                                  print "ERROR: can't eval { $kf }: $@" if ($@);                                  $log->logdie("can't eval { $kf }: $@") if ($@);
273    
274                                  return 1;                                  return 1;
275                          });                          });
276    
277                          my $key = join('-', @key ) || print "ERROR: no key found!";                          my $key = join('-', @key ) || $log->logdie("no key found!");
278    
279                          print "key = $key\n";                          $log->debug("key = $key");
280    
281                          my $create = '                          my $create = '
282                                  $coderef = ' . $e[7] . $e[8] . ';                                  $coderef = ' . $e[7] . $e[8] . ';
# Line 144  sub parse { Line 286  sub parse {
286                                  }                                  }
287                          ';                          ';
288    
289                          print "create: $create\n";                          $log->debug("create: $create");
290    
291                          $create =~ s/\s+/ /gs;                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
292                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
293    
294                            # save code to create this lookup
295                            $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= "# lookup for $e[3]/$e[5]/$key\n\n$create";
296    
297    
298                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
299                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
300                            }
301    
302                            # save this dependency
303                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
304    
305                          if ($#e < 10) {                          if ($#e < 10) {
306                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 160  sub parse { Line 313  sub parse {
313                          $e[8]->remove;                          $e[8]->remove;
314    
315    
316                          print "# >>> ", $Element->snext_sibling, "\n";                          $log->debug(">>> ", $Element->snext_sibling);
317          });          });
318    
319          print "-----\ncreate: ", dump($eval_create), "\n";          my $normalize_source = $Document->serialize;
320          print "-----\nlookup: ", $Document->serialize, "\n";          $log->debug("create: ", dump($self->{_lookup_create}) );
321          print "-----\n";          $log->debug("normalize: $normalize_source");
322    
323            $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
324    
325          my $Dumper = PPI::Dumper->new( $Document );          if ($self->{debug}) {
326          $Dumper->print;                  my $Dumper = PPI::Dumper->new( $Document );
327                    $Dumper->print;
328            }
329    
330            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
331    
332            return 1;
333  }  }
334    
335    
336    =head2 _q
337    
338    Strip single or double quotes around value
339    
340      _q(qq/'foo'/) -> foo
341    
342    =cut
343    
344    sub _q {
345            my $v = shift || return;
346            $v =~ s/^['"]*//g;
347            $v =~ s/['"]*$//g;
348            return $v;
349    }
350    
351    =head2 _input_name
352    
353    Return C<name> value if HASH or arg if scalar
354    
355      _input_name($input)
356    
357    =cut
358    
359    sub _input_name {
360            my $input = shift || return;
361            if (ref($input) eq 'HASH') {
362                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
363                    return $input->{name};
364            } else {
365                    return $input;
366            }
367    }
368    
369    
370  =head1 AUTHOR  =head1 AUTHOR
371    
372  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.686  
changed lines
  Added in v.705
  ViewVC Help
Powered by ViewVC 1.1.26