/[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 1277 by dpavlin, Wed Aug 19 16:24:43 2009 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/;
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.01  Version 0.08
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  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          my $source;          $self->_read_sources;
69    
70            $self ? return $self : return undef;
71    }
72    
73    =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    =head2 _read_sources
226    
227      my $source_files = $parser->_read_sources;
228    
229    Called by L</new>.
230    
231    =cut
232    
233    sub _read_sources {
234            my $self = shift;
235    
236            my $log = $self->_get_logger();
237    
238            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 = shift;                  my ($input, $database) = @_;
249                  my $path = $input->{normalize}->{path} || return;  
250                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  return if ( $only_database && $database !~ m/$only_database/i );
251                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  return if ( $only_input && $input->{name} !~ m/$only_input/i );
252                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");  
253                  $log->debug("adding $path to parser [",length($s)," bytes]");                  $log->debug("database: $database input = ", dump($input));
254                  $source .= $s;  
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);
262    
263                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
264    
265                            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");
268    
269                            $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("collected ", length($source), " bytes of source");          $log->debug("found $nr source files");
281    
282          $self->{source} = $source;          # parse all sources
283            $_->() foreach (@sources);
284    
285          $self ? return $self : return undef;          return $nr;
286  }  }
287    
288  =head2 parse  =head2 _parse_source
289    
290      $parser->_parse_source($database,$input,$path,$source);
291    
292    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 {  sub _parse_source {
299          my $self = shift;          my $self = shift;
300            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('no source found in object') unless ($self->{source});          $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 );
308    
309            $log->logdie("no source found for database $database input $input path $path") unless ($source);
310    
311          my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});          $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});
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    
321          my $eval_create;          $self->{_lookup_errors} = ();
322    
323            sub _lookup_error {
324                    my $self = shift;
325                    my $msg = shift;
326                    $self->_get_logger->logconfess("error without message?") unless ($msg);
327                    push @{ $self->{_lookup_errors} }, $msg;
328                    return '';
329            }
330    
331          $Document->find( sub {          $Document->find( sub {
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 =~ m{^(sub|if)$} ) {
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 140  sub parse { Line 387  sub parse {
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                          $create =~ s/\s+/ /gs;                          # save code to create this lookup
400                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $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    
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 160  sub parse { Line 415  sub parse {
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          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
426          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
427            $log->debug("normalize: $normalize_source");
428    
429            $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 );
433                  $Dumper->print;                  $Dumper->print;
434          }          }
435    
436            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
437    
438            $Document->find( sub {
439                            my ($Document,$Element) = @_;
440    
441                            $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          return 1;          return 1;
452  }  }
453    
454    
455    =head2 _q
456    
457    Strip single or double quotes around value
458    
459      _q(qq/'foo'/) -> foo
460    
461    =cut
462    
463    sub _q {
464            my $v = shift || return;
465            $v =~ s/^['"]*//g;
466            $v =~ s/['"]*$//g;
467            return $v;
468    }
469    
470    =head2 _input_name
471    
472    Return C<name> value if HASH or arg if scalar
473    
474      _input_name($input)
475    
476    =cut
477    
478    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.687  
changed lines
  Added in v.1277
  ViewVC Help
Powered by ViewVC 1.1.26