/[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 692 by dpavlin, Sun Sep 24 21:13:40 2006 UTC revision 702 by dpavlin, Mon Sep 25 13:08:17 2006 UTC
# Line 17  WebPAC::Parser - parse perl normalizatio Line 17  WebPAC::Parser - parse perl normalizatio
17    
18  =head1 VERSION  =head1 VERSION
19    
20  Version 0.03  Version 0.04
21    
22  =cut  =cut
23    
24  our $VERSION = '0.03';  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 53  sub new { Line 63  sub new {
63    
64          $self->read_sources;          $self->read_sources;
65    
         $self->{config}->iterate_inputs( sub {  
                 my ($input, $database) = @_;  
                 return unless $self->valid_database_input($database, $input->{name});  
                 $self->parse_lookups($database,$input->{name});  
         } );  
   
66          $self ? return $self : return undef;          $self ? return $self : return undef;
67  }  }
68    
# Line 77  sub read_sources { Line 81  sub read_sources {
81    
82          my $nr = 0;          my $nr = 0;
83    
84            my @lookups;
85    
86          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
87                  my ($input, $database) = @_;                  my ($input, $database) = @_;
88    
89                  my $path = $input->{normalize}->{path} || return;                  $log->debug("database: $database input = ", dump($input));
90                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
91                    foreach my $normalize (@{ $input->{normalize} }) {
92    
93                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                          my $path = $normalize->{path};
94                            return unless($path);
95                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
96    
97                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          $log->logdie("normalization input $full doesn't exist") unless (-e $full);
98    
99                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
100    
101                  $log->debug("$database/$input_name: adding $path");                          my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
102    
103                  $self->{valid_inputs}->{$database}->{$input_name} = {                          $log->debug("$database/$input_name: adding $path");
                         source => $s,  
                         path => $full,  
                         usage => 0,  
                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});  
104    
105                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          $self->{valid_inputs}->{$database}->{$input_name}++;
106    
107                  $nr++;                          push @lookups, sub {
108                                    $self->parse_lookups( $database, $input_name, $full, $s );
109                            };
110    
111                            $nr++;
112                    }
113          } );          } );
114    
115          $log->debug("found $nr source files");          $log->debug("found $nr source files");
116    
117            # parse all lookups
118            $_->() foreach (@lookups);
119    
120          return $nr;          return $nr;
121  }  }
122    
123  =head2 parse_lookups  =head2 parse_lookups
124    
125    $parser->parse_lookups($database,$input);    $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_lookups {  sub parse_lookups {
134          my $self = shift;          my $self = shift;
135          my ($database, $input) = @_;          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("invalid database $database" ) unless $self->valid_database( $database );          $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 );          $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
143    
         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};  
         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};  
   
144          $log->logdie("no source found for database $database input $input path $path") unless ($source);          $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");          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
147    
148          my $Document = PPI::Document->new( \$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    
# Line 209  sub parse_lookups { Line 225  sub parse_lookups {
225                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
226                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) 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] );
227    
228                          $self->add_lookup_create( $e[3], $e[5], $create );                          # 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 225  sub parse_lookups { Line 250  sub parse_lookups {
250                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
251          });          });
252    
253          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
254          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
255          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
256    
257          $self->{_normalize_source}->{$database}->{$input} = $source;          $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 );
# Line 241  sub parse_lookups { Line 266  sub parse_lookups {
266          return 1;          return 1;
267  }  }
268    
 =head2 add_lookup_create  
269    
270    $parse->add_lookup_create($database,$input,$source);  =head2 lookup_create_rules
271    
272      my $source = $parser->lookup_create_rules($database, $input);
273    
274  =cut  =cut
275    
276  sub add_lookup_create {  sub lookup_create_rules {
277          my $self = shift;          my $self = shift;
278          my ($database,$input,$source) = @_;          my ($database,$input) = @_;
279          $self->{_lookup_create}->{$database}->{$input} .= $source;          return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
280  }  }
281    
   
282  =head2 valid_database  =head2 valid_database
283    
284    my $ok = $parse->valid_database('key');    my $ok = $parse->valid_database('key');
# Line 264  sub valid_database { Line 289  sub valid_database {
289          my $self = shift;          my $self = shift;
290    
291          my $database = shift || return;          my $database = shift || return;
         $database =~ s/['"]//g;  
292    
293          return defined($self->{valid_inputs}->{$database});          return defined($self->{valid_inputs}->{ _q($database) });
294  }  }
295    
296  =head2 valid_database_input  =head2 valid_database_input
# Line 279  sub valid_database_input { Line 303  sub valid_database_input {
303          my $self = shift;          my $self = shift;
304    
305          my ($database,$input) = @_;          my ($database,$input) = @_;
306          $database =~ s/['"]//g;          return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
307          $input =~ s/['"]//g;  }
308    
309    =head2 depends
310    
311          return defined($self->{valid_inputs}->{$database}->{$input});  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.692  
changed lines
  Added in v.702
  ViewVC Help
Powered by ViewVC 1.1.26