/[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 687 by dpavlin, Sun Sep 24 17:49:05 2006 UTC revision 702 by dpavlin, Mon Sep 25 13:08:17 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.04
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  our $VERSION = '0.04';
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 read_sources
70    
71      my $source_files = $parser->read_sources;
72    
73    Called by L</new>.
74    
75    =cut
76    
77    sub read_sources {
78            my $self = shift;
79    
80            my $log = $self->_get_logger();
81    
82            my $nr = 0;
83    
84            my @lookups;
85    
86          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
87                  my $input = shift;                  my ($input, $database) = @_;
88                  my $path = $input->{normalize}->{path} || return;  
89                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  $log->debug("database: $database input = ", dump($input));
90                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);  
91                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  foreach my $normalize (@{ $input->{normalize} }) {
92                  $log->debug("adding $path to parser [",length($s)," bytes]");  
93                  $source .= $s;                          my $path = $normalize->{path};
94                            return unless($path);
95                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
96    
97                            $log->logdie("normalization input $full doesn't exist") unless (-e $full);
98    
99                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
100    
101                            my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
102    
103                            $log->debug("$database/$input_name: adding $path");
104    
105                            $self->{valid_inputs}->{$database}->{$input_name}++;
106    
107                            push @lookups, sub {
108                                    $self->parse_lookups( $database, $input_name, $full, $s );
109                            };
110    
111                            $nr++;
112                    }
113          } );          } );
114    
115          $log->debug("collected ", length($source), " bytes of source");          $log->debug("found $nr source files");
116    
117          $self->{source} = $source;          # parse all lookups
118            $_->() foreach (@lookups);
119    
120          $self ? return $self : return undef;          return $nr;
121  }  }
122    
123  =head2 parse  =head2 parse_lookups
124    
125      $parser->parse_lookups($database,$input,$path,$source);
126    
127    Called for each normalize source in each input by L</new>
128    
129    It will report invalid databases and inputs in error log after parsing.
130    
131  =cut  =cut
132    
133  sub parse {  sub parse_lookups {
134          my $self = shift;          my $self = shift;
135            my ($database, $input, $path, $source) = @_;
136    
137            $input = _input_name($input);
138    
139          my $log = $self->_get_logger();          my $log = $self->_get_logger();
140    
141          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
142            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
143    
144            $log->logdie("no source found for database $database input $input path $path") unless ($source);
145    
146            $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
147    
148          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});
149    
150          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
151          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
152    
153          # Find all the named subroutines          # Find all the named subroutines
154    
155          my $eval_create;          $self->{_lookup_errors} = ();
156    
157            sub _lookup_error {
158                    my $self = shift;
159                    my $msg = shift;
160                    $self->_get_logger->logconfess("error without message?") unless ($msg);
161                    push @{ $self->{_lookup_errors} }, $msg;
162                    return '';
163            }
164    
165          $Document->find( sub {          $Document->find( sub {
166                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 150  sub parse { Line 222  sub parse {
222    
223                          $log->debug("create: $create");                          $log->debug("create: $create");
224    
225                          $create =~ s/\s+/ /gs;                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
226                          $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] );
227    
228                            # save code to create this lookup
229                            $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;
230    
231    
232                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
233                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
234                            }
235    
236                            # save this dependency
237                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
238    
239                          if ($#e < 10) {                          if ($#e < 10) {
240                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 167  sub parse { Line 250  sub parse {
250                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
251          });          });
252    
253          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
254          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
255            $log->debug("normalize: $normalize_source");
256    
257            $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
258    
259          if ($self->{debug}) {          if ($self->{debug}) {
260                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
261                  $Dumper->print;                  $Dumper->print;
262          }          }
263    
264            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
265    
266          return 1;          return 1;
267  }  }
268    
269    
270    =head2 lookup_create_rules
271    
272      my $source = $parser->lookup_create_rules($database, $input);
273    
274    =cut
275    
276    sub lookup_create_rules {
277            my $self = shift;
278            my ($database,$input) = @_;
279            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
280    }
281    
282    =head2 valid_database
283    
284      my $ok = $parse->valid_database('key');
285    
286    =cut
287    
288    sub valid_database {
289            my $self = shift;
290    
291            my $database = shift || return;
292    
293            return defined($self->{valid_inputs}->{ _q($database) });
294    }
295    
296    =head2 valid_database_input
297    
298      my $ok = $parse->valid_database('database_key','input_name');
299    
300    =cut
301    
302    sub valid_database_input {
303            my $self = shift;
304    
305            my ($database,$input) = @_;
306            return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
307    }
308    
309    =head2 depends
310    
311    Return all databases and inputs on which specified one depends
312    
313      $depends_on = $parser->depends('database','input');
314    
315    =cut
316    
317    sub depends {
318            my $self = shift;
319            my ($database,$input) = @_;
320            $self->_get_logger->debug("depends($database,$input)");
321            return unless (
322                    defined( $self->{depends}->{ _q($database) } ) &&
323                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
324            );
325            return $self->{depends}->{ _q($database) }->{ _q($input) };
326    }
327    
328    =head1 PRIVATE
329    
330    =head2 _q
331    
332    Strip single or double quotes around value
333    
334      _q(qq/'foo'/) -> foo
335    
336    =cut
337    
338    sub _q {
339            my $v = shift || return;
340            $v =~ s/^['"]*//g;
341            $v =~ s/['"]*$//g;
342            return $v;
343    }
344    
345    =head2 _input_name
346    
347    Return C<name> value if HASH or arg if scalar
348    
349      _input_name($input)
350    
351    =cut
352    
353    sub _input_name {
354            my $input = shift || return;
355            if (ref($input) eq 'HASH') {
356                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
357                    return $input->{name};
358            } else {
359                    return $input;
360            }
361    }
362    
363    
364  =head1 AUTHOR  =head1 AUTHOR
365    
366  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.687  
changed lines
  Added in v.702
  ViewVC Help
Powered by ViewVC 1.1.26