/[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 701 by dpavlin, Mon Sep 25 12:51:47 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]) } )) {
233                                    my $dep_key = $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) };
234                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] allready recorded as $dep_key, now changed to $key") if ($dep_key ne $key);
235                            }
236    
237                            # save this dependency
238                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } .= $key;
239    
240                          if ($#e < 10) {                          if ($#e < 10) {
241                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 225  sub parse_lookups { Line 251  sub parse_lookups {
251                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
252          });          });
253    
254          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
255          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
256          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
257    
258          $self->{_normalize_source}->{$database}->{$input} = $source;          $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
259    
260          if ($self->{debug}) {          if ($self->{debug}) {
261                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
# Line 241  sub parse_lookups { Line 267  sub parse_lookups {
267          return 1;          return 1;
268  }  }
269    
 =head2 add_lookup_create  
270    
271    $parse->add_lookup_create($database,$input,$source);  =head2 lookup_create_rules
272    
273      my $source = $parser->lookup_create_rules($database, $input);
274    
275  =cut  =cut
276    
277  sub add_lookup_create {  sub lookup_create_rules {
278          my $self = shift;          my $self = shift;
279          my ($database,$input,$source) = @_;          my ($database,$input) = @_;
280          $self->{_lookup_create}->{$database}->{$input} .= $source;          return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
281  }  }
282    
   
283  =head2 valid_database  =head2 valid_database
284    
285    my $ok = $parse->valid_database('key');    my $ok = $parse->valid_database('key');
# Line 264  sub valid_database { Line 290  sub valid_database {
290          my $self = shift;          my $self = shift;
291    
292          my $database = shift || return;          my $database = shift || return;
         $database =~ s/['"]//g;  
293    
294          return defined($self->{valid_inputs}->{$database});          return defined($self->{valid_inputs}->{ _q($database) });
295  }  }
296    
297  =head2 valid_database_input  =head2 valid_database_input
# Line 279  sub valid_database_input { Line 304  sub valid_database_input {
304          my $self = shift;          my $self = shift;
305    
306          my ($database,$input) = @_;          my ($database,$input) = @_;
307          $database =~ s/['"]//g;          return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
308          $input =~ s/['"]//g;  }
309    
310    =head2 depends
311    
312          return defined($self->{valid_inputs}->{$database}->{$input});  Return all databases and inputs on which specified one depends
313    
314      $depends_on = $parser->depends('database','input');
315    
316    =cut
317    
318    sub depends {
319            my $self = shift;
320            my ($database,$input) = @_;
321            $self->_get_logger->debug("depends($database,$input)");
322            return unless (
323                    defined( $self->{depends}->{ _q($database) } ) &&
324                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
325            );
326            return $self->{depends}->{ _q($database) }->{ _q($input) };
327  }  }
328    
329    =head1 PRIVATE
330    
331    =head2 _q
332    
333    Strip single or double quotes around value
334    
335      _q(qq/'foo'/) -> foo
336    
337    =cut
338    
339    sub _q {
340            my $v = shift || return;
341            $v =~ s/^['"]*//g;
342            $v =~ s/['"]*$//g;
343            return $v;
344    }
345    
346    =head2 _input_name
347    
348    Return C<name> value if HASH or arg if scalar
349    
350      _input_name($input)
351    
352    =cut
353    
354    sub _input_name {
355            my $input = shift || return;
356            if (ref($input) eq 'HASH') {
357                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
358                    return $input->{name};
359            } else {
360                    return $input;
361            }
362    }
363    
364    
365  =head1 AUTHOR  =head1 AUTHOR
366    
367  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.692  
changed lines
  Added in v.701
  ViewVC Help
Powered by ViewVC 1.1.26