/[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 691 by dpavlin, Sun Sep 24 21:13:36 2006 UTC revision 1259 by dpavlin, Tue Jul 28 13:55:44 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    my $source_files = $parser->read_sources;  =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    =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                    foreach my $normalize (@{ $input->{normalize} }) {
256    
257                            my $path = $normalize->{path};
258                            return unless($path);
259                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
260    
261                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                          $log->logdie("normalization input $full doesn't exist") unless (-e $full);
262    
263                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
264    
265                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                          my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
266    
267                  $log->debug("$database/$input_name: adding $path");                          $log->debug("$database/$input_name: adding $path");
268    
269                  $self->{valid_inputs}->{$database}->{$input_name} = {                          $self->{valid_inputs}->{$database}->{$input_name}++;
                         source => $s,  
                         path => $full,  
                         usage => 0,  
                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});  
270    
271                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          push @sources, sub {
272                                    #warn "### $database $input_name, $full ###\n";
273                                    $self->_parse_source( $database, $input_name, $full, $s );
274                            };
275    
276                  $nr++;                          $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_lookup  =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 in $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
320    
         my $eval_create;  
321          $self->{_lookup_errors} = ();          $self->{_lookup_errors} = ();
322    
323          sub _lookup_error {          sub _lookup_error {
# Line 151  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                            }
341    
342                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
343    
344                          $log->debug("expansion: ", $Element->snext_sibling);                          $log->debug("expansion: ", $Element->snext_sibling);
# Line 197  sub parse_lookups { Line 385  sub parse_lookups {
385    
386                          $log->debug("key = $key");                          $log->debug("key = $key");
387    
388                          my $create = '                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
389                                  $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] );
390                                  foreach my $v ($coderef->()) {  
391                                          next unless (defined($v) && $v ne \'\');                          my $create = qq{
392                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                                  save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
393                                  }                          };
                         ';  
394    
395                          $log->debug("create: $create");                          $log->debug("create: $create");
396    
397                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
398                          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;
399                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
400    
401    
402                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
403                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
404                            }
405    
406                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          # save this dependency
407                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
408    
409                          if ($#e < 10) {                          if ($#e < 10) {
410                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 219  sub parse_lookups { Line 413  sub parse_lookups {
413                          }                          }
414    
415                          $e[7]->remove;                          $e[7]->remove;
416                          $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );                          $e[8]->insert_before( PPI::Token::Quote::Single->new( "'$key'" ) );
417                          $e[8]->remove;                          $e[8]->remove;
418    
419    
420                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
421          });          });
422    
423          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
424          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
425            $log->debug("normalize: $normalize_source");
426    
427            $self->{_normalize_source}->{$database}->{$input} .= $normalize_source;
428    
429          if ($self->{debug}) {          if ($self->{debug}) {
430                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
431                  $Dumper->print;                  $Dumper->print;
432          }          }
433    
434          $log->error("Parser errors: ", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});          $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
435    
436            $Document->find( sub {
437                            my ($Document,$Element) = @_;
438    
439                            $Element->isa('PPI::Token::Word') or return '';
440                            if ($Element->content =~ m/^(marc|search)/) {
441                                    my $what = $1;
442                                    $log->debug("found $what rules in $database/$input");
443                                    $self->{_have_rules}->{ $database }->{ $input }->{ $what }->{ $Element->content }++;
444                            } else {
445                                    return '';
446                            }
447            });
448    
449          return 1;          return 1;
450  }  }
451    
 =head2 valid_database  
452    
453    my $ok = $parse->valid_database('key');  =head2 _q
454    
455  =cut  Strip single or double quotes around value
456    
457  sub valid_database {    _q(qq/'foo'/) -> foo
         my $self = shift;  
458    
459          my $database = shift || return;  =cut
         $database =~ s/['"]//g;  
460    
461          return defined($self->{valid_inputs}->{$database});  sub _q {
462            my $v = shift || return;
463            $v =~ s/^['"]*//g;
464            $v =~ s/['"]*$//g;
465            return $v;
466  }  }
467    
468  =head2 valid_database_input  =head2 _input_name
469    
470    my $ok = $parse->valid_database('database_key','input_name');  Return C<name> value if HASH or arg if scalar
471    
472  =cut    _input_name($input)
   
 sub valid_database_input {  
         my $self = shift;  
473    
474          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
475    
476          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
477            my $input = shift || return;
478            if (ref($input) eq 'HASH') {
479                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
480                    return $input->{name};
481            } else {
482                    return $input;
483            }
484  }  }
485    
486    
487  =head1 AUTHOR  =head1 AUTHOR
488    
489  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.691  
changed lines
  Added in v.1259
  ViewVC Help
Powered by ViewVC 1.1.26