/[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 1265 by dpavlin, Sun Aug 9 20:10:21 2009 UTC
# Line 9  use PPI::Dumper; Line 9  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/;  use base qw/WebPAC::Common/;
13    
14  =head1 NAME  =head1 NAME
15    
16  WebPAC::Parser - parse perl normalization configuration files and mungle it  WebPAC::Parser - parse perl normalization configuration files (rules) and mungle it
17    
18  =head1 VERSION  =head1 VERSION
19    
20  Version 0.03  Version 0.08
21    
22  =cut  =cut
23    
24  our $VERSION = '0.03';  our $VERSION = '0.08';
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. It will also parse other parts of
30    source to produce some of DWIM (I<Do What I Mean>) magic
31    (like producing MARC oputput using L<WebPAC::Output::MARC> if there are C<marc_*>
32    rules in normalisation).
33    
34    It's written using L<PPI>, pure-perl parser for perl and heavily influenced by
35    reading about LISP. It might be a bit over-the board, but at least it removed
36    separate configuration files for lookups.
37    
38    This is experimental code, but it replaces all older formats which where,
39    at one point in time, available in WebPAC.
40    
41  FIXME  FIXME
42    
43  =head1 FUNCTIONS  =head1 FUNCTIONS
# Line 36  Create new parser object. Line 49  Create new parser object.
49    my $parser = new WebPAC::Parser(    my $parser = new WebPAC::Parser(
50          config => new WebPAC::Config(),          config => new WebPAC::Config(),
51          base_path => '/optional/path/to/conf',          base_path => '/optional/path/to/conf',
52            only_database => $only
53    );    );
54    
55  =cut  =cut
# Line 51  sub new { Line 65  sub new {
65    
66          $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'));
67    
68          $self->read_sources;          $self->_read_sources;
   
         $self->{config}->iterate_inputs( sub {  
                 my ($input, $database) = @_;  
                 return unless $self->valid_database_input($database, $input->{name});  
                 $self->parse_lookups($database,$input->{name});  
         } );  
69    
70          $self ? return $self : return undef;          $self ? return $self : return undef;
71  }  }
72    
73  =head2 read_sources  =head2 valid_database
74    
75      my $ok = $parse->valid_database('key');
76    
77    =cut
78    
79    sub valid_database {
80            my $self = shift;
81    
82            my $database = shift || return;
83    
84            return defined($self->{valid_inputs}->{ _q($database) });
85    }
86    
87    =head2 valid_database_input
88    
89      my $ok = $parse->valid_database('database_key','input_name');
90    
91    =cut
92    
93    sub valid_database_input {
94            my $self = shift;
95            my ($database,$input) = @_;
96            $input = _input_name($input);
97            return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
98    }
99    
100    =head2 depends
101    
102    Return all databases and inputs on which specified one depends
103    
104      $depends_on = $parser->depends('database','input');
105    
106    =cut
107    
108    sub depends {
109            my $self = shift;
110            my ($database,$input) = @_;
111            $input = _input_name($input);
112            $self->_get_logger->debug("depends($database,$input)");
113            return unless (
114                    defined( $self->{depends}->{ _q($database) } ) &&
115                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
116            );
117            return $self->{depends}->{ _q($database) }->{ _q($input) };
118    }
119    
120    =head2 have_lookup_create
121    
122      my @keys = $parser->have_lookup_create($database, $input);
123    
124    =cut
125    
126    sub have_lookup_create {
127            my $self = shift;
128            my ($database,$input) = @_;
129            $input = _input_name($input);
130            return unless (
131                    defined( $self->{_lookup_create_key}->{ _q($database) } ) &&
132                    defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } )
133            );
134            return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } };
135    }
136    
137    
138    =head2 lookup_create_rules
139    
140      my $source = $parser->lookup_create_rules($database, $input);
141    
142    =cut
143    
144    sub lookup_create_rules {
145            my $self = shift;
146            my ($database,$input) = @_;
147            $input = _input_name($input);
148            return unless (
149                    defined( $self->{_lookup_create}->{ _q($database) } ) &&
150                    defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
151            );
152            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
153    }
154    
155    =head2 normalize_rules
156    
157      my $source = $parser->normalize_rules($database, $input);
158    
159    =cut
160    
161    sub normalize_rules {
162            my $self = shift;
163            my ($database,$input) = @_;
164            $input = _input_name($input);
165            return unless (
166                    defined( $self->{_normalize_source}->{ _q($database) } ) &&
167                    defined( $self->{_normalize_source}->{ _q($database) }->{ _q($input) } )
168            );
169            return $self->{_normalize_source}->{ _q($database) }->{ _q($input) };
170    }
171    
172    
173    =head2 have_rules
174    
175      my $do_marc = $parser->have_rules('marc', $database, $input);
176      my $do_index = $parser->have_rules('search', $database);
177    
178    This function will return hash containing count of all found C<marc_*> or
179    C<search> directives. Input name is optional.
180    
181    =cut
182    
183    sub have_rules {
184            my $self = shift;
185    
186            my $log = $self->_get_logger();
187            my $type = shift @_ || $log->logconfess("need at least type");
188            my $database = shift @_ || $log->logconfess("database is required");
189            my $input = shift @_;
190    
191            $input = _input_name($input);
192    
193    
194            return unless defined( $self->{_have_rules}->{ _q($database) } );
195    
196            my $database_rules = $self->{_have_rules}->{ _q($database ) };
197    
198            if (defined($input)) {
199    
200                    return unless (
201                            defined( $database_rules->{ _q($input) } ) &&
202                            defined( $database_rules->{ _q($input) }->{ $type } )
203                    );
204    
205                    return $database_rules->{ _q($input) }->{ $type };
206            }
207    
208            my $usage;
209    
210            foreach my $i (keys %{ $database_rules }) {
211                    next unless defined( $database_rules->{$i}->{$type} );
212    
213                    foreach my $t (keys %{ $database_rules->{ $i }->{$type} }) {
214                            $usage->{ $t } += $database_rules->{ $i }->{ $t };
215                    }
216            }
217    
218            return $usage;
219    
220    }
221    
222    
223    =head1 PRIVATE
224    
225    my $source_files = $parser->read_sources;  =head2 _read_sources
226    
227      my $source_files = $parser->_read_sources;
228    
229  Called by L</new>.  Called by L</new>.
230    
231  =cut  =cut
232    
233  sub read_sources {  sub _read_sources {
234          my $self = shift;          my $self = shift;
235    
236          my $log = $self->_get_logger();          my $log = $self->_get_logger();
237    
238          my $nr = 0;          my $nr = 0;
239    
240            my @sources;
241    
242            my $lookup_src_cache;
243    
244            my $only_database = $self->{only_database};
245            my $only_input = $self->{only_input};
246    
247          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
248                  my ($input, $database) = @_;                  my ($input, $database) = @_;
249    
250                  my $path = $input->{normalize}->{path} || return;                  return if ( $only_database && $database !~ m/$only_database/i );
251                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  return if ( $only_input && $input->{name} !~ m/$only_input/i );
252    
253                    $log->debug("database: $database input = ", dump($input));
254    
255                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  foreach my $normalize (@{ $input->{normalize} }) {
256    
257                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          my $path = $normalize->{path};
258                            return unless($path);
259                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
260    
261                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                          $log->logdie("normalization input $full doesn't exist") unless (-e $full);
262    
263                  $log->debug("$database/$input_name: adding $path");                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
264    
265                  $self->{valid_inputs}->{$database}->{$input_name} = {                          my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
                         source => $s,  
                         path => $full,  
                         usage => 0,  
                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});  
266    
267                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          $log->debug("$database/$input_name: adding $path");
268    
269                  $nr++;                          $self->{valid_inputs}->{$database}->{$input_name}++;
270    
271                            push @sources, sub {
272                                    #warn "### $database $input_name, $full ###\n";
273                                    $self->_parse_source( $database, $input_name, $full, $s );
274                            };
275    
276                            $nr++;
277                    }
278          } );          } );
279    
280          $log->debug("found $nr source files");          $log->debug("found $nr source files");
281    
282            # parse all sources
283            $_->() foreach (@sources);
284    
285          return $nr;          return $nr;
286  }  }
287    
288  =head2 parse_lookups  =head2 _parse_source
289    
290      $parser->_parse_source($database,$input,$path,$source);
291    
292    $parser->parse_lookups($database,$input);  Called for each normalize source (rules) in each input by L</_read_sources>
293    
294    It will report invalid databases and inputs in error log after parsing.
295    
296  =cut  =cut
297    
298  sub parse_lookups {  sub _parse_source {
299          my $self = shift;          my $self = shift;
300          my ($database, $input) = @_;          my ($database, $input, $path, $source) = @_;
301    
302            $input = _input_name($input);
303    
304          my $log = $self->_get_logger();          my $log = $self->_get_logger();
305    
306          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
307          $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 );
308    
         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};  
         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};  
   
309          $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);
310    
311          $log->info("parsing lookups for $database/$input from $path");          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
312    
313          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});
314    
315          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
316            $Document->prune('PPI::Token::Comment');
317          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
318    
319          # Find all the named subroutines          # Find all the named subroutines
# Line 150  sub parse_lookups { Line 332  sub parse_lookups {
332                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
333    
334                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
335    
336                            if ( $Element->content eq 'sub' ) {
337                                    # repair demage done by prune of whitespace
338                                    $Element->insert_after( PPI::Token::Whitespace->new(' ') );
339                                    return '';
340                            } elsif ( $Element->content eq 'my' ) {
341                                    $Element->insert_before( PPI::Token::Whitespace->new(' ') );
342                            }
343    
344                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
345    
346                          $log->debug("expansion: ", $Element->snext_sibling);                          $log->debug("expansion: ", $Element->snext_sibling);
# Line 196  sub parse_lookups { Line 387  sub parse_lookups {
387    
388                          $log->debug("key = $key");                          $log->debug("key = $key");
389    
390                          my $create = '                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
391                                  $coderef = ' . $e[7] . $e[8] . ';                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
392                                  foreach my $v ($coderef->()) {  
393                                          next unless (defined($v) && $v ne \'\');                          my $create = qq{
394                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                                  save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
395                                  }                          };
                         ';  
396    
397                          $log->debug("create: $create");                          $log->debug("create: $create");
398    
399                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
400                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );                          $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create;
401                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
402    
403                          $self->add_lookup_create( $e[3], $e[5], $create );  
404                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
405                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
406                            }
407    
408                            # save this dependency
409                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
410    
411                          if ($#e < 10) {                          if ($#e < 10) {
412                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 218  sub parse_lookups { Line 415  sub parse_lookups {
415                          }                          }
416    
417                          $e[7]->remove;                          $e[7]->remove;
418                          $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );                          $e[8]->insert_before( PPI::Token::Quote::Single->new( "'$key'" ) );
419                          $e[8]->remove;                          $e[8]->remove;
420    
421    
422                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
423          });          });
424    
425          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
426          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
427          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
428    
429          $self->{_normalize_source}->{$database}->{$input} = $source;          $self->{_normalize_source}->{$database}->{$input} .= $normalize_source;
430    
431          if ($self->{debug}) {          if ($self->{debug}) {
432                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
# Line 238  sub parse_lookups { Line 435  sub parse_lookups {
435    
436          $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});          $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
437    
438          return 1;          $Document->find( sub {
439  }                          my ($Document,$Element) = @_;
   
 =head2 add_lookup_create  
   
   $parse->add_lookup_create($database,$input,$source);  
440    
441  =cut                          $Element->isa('PPI::Token::Word') or return '';
442                            if ($Element->content =~ m/^(marc|search)/) {
443                                    my $what = $1;
444                                    $log->debug("found $what rules in $database/$input");
445                                    $self->{_have_rules}->{ $database }->{ $input }->{ $what }->{ $Element->content }++;
446                            } else {
447                                    return '';
448                            }
449            });
450    
451  sub add_lookup_create {          return 1;
         my $self = shift;  
         my ($database,$input,$source) = @_;  
         $self->{_lookup_create}->{$database}->{$input} .= $source;  
452  }  }
453    
454    
455  =head2 valid_database  =head2 _q
456    
457    my $ok = $parse->valid_database('key');  Strip single or double quotes around value
458    
459  =cut    _q(qq/'foo'/) -> foo
460    
461  sub valid_database {  =cut
         my $self = shift;  
   
         my $database = shift || return;  
         $database =~ s/['"]//g;  
462    
463          return defined($self->{valid_inputs}->{$database});  sub _q {
464            my $v = shift || return;
465            $v =~ s/^['"]*//g;
466            $v =~ s/['"]*$//g;
467            return $v;
468  }  }
469    
470  =head2 valid_database_input  =head2 _input_name
   
   my $ok = $parse->valid_database('database_key','input_name');  
471    
472  =cut  Return C<name> value if HASH or arg if scalar
473    
474  sub valid_database_input {    _input_name($input)
         my $self = shift;  
475    
476          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
477    
478          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
479            my $input = shift || return;
480            if (ref($input) eq 'HASH') {
481                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
482                    return $input->{name};
483            } else {
484                    return $input;
485            }
486  }  }
487    
488    
489  =head1 AUTHOR  =head1 AUTHOR
490    
491  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.692  
changed lines
  Added in v.1265
  ViewVC Help
Powered by ViewVC 1.1.26